kww@cs.glasgow.ac.uk (Dr Kevin Waite) (11/29/90)
My original posting of an implementation of the Montana game seems to have got lost. Since I think it is a reasonable example of simple MVC use (and a reasonable game to boot) I think some people might find it useful. If it doesn't get out this time then too bad. I hope you enjoy it. (If Ralph Johnson sees this could he please acknowledge - thanks for your earlier ACK). PS This version includes some heuristics for automatic playing of the game. The best one finishes about 1 in 10 games. ----------------- C U T H E R E ----------------- Object subclass: #PlayingCard instanceVariableNames: 'value ' classVariableNames: '' poolDictionaries: '' category: 'Montana'! PlayingCard comment: 'I am an abstract superclass for playing cards. My subclasses implement the four suits (Hearts, Spades, Clubs and Diamonds). Their instances have a value fixed at creation time. They can be displayed graphically.'! !PlayingCard methodsFor: 'accessing'! value ^value! value: anInteger value := anInteger.! ! !PlayingCard methodsFor: 'converting'! ancestor "Return my ancestor card. This is defined to be the card of the same suit but with a face value one lower than the receiver." | newValue ancestor | self value = 1 ifTrue: [self error: 'Aces do not have ancestors.']. newValue := self value - 1. ancestor := self class value: newValue. ^ancestor! descendent "Return my descendent card. This is defined to be the card of the same suit but with a face value one higher than the receiver." | newValue ancestor | self value = 13 ifTrue: [^nil "Kings do not have descendents"]. newValue := self value + 1. ancestor := self class value: newValue. ^ancestor! ! !PlayingCard methodsFor: 'displaying'! displayAt: origin self displayOn: Display at: origin! displayOn: aForm at: origin self displayOn: aForm at: origin clippingBox: (0 @ 0 extent: Display extent)! displayOn: aForm at: origin clippingBox: box | image number aRect x y | image := self class image. number := self formattedNumber asDisplayText. aRect := origin extent: self class extent. aForm white: aRect. aForm border: aRect width: 2. x := 3 + ((16 - number width) // 2). y := 2 + (aRect height - number height) // 2. number displayOn: aForm at: (x@y) + origin clippingBox: box. x := aRect width - image width - 4. y := 1 + (aRect height - image height) // 2. image displayOn: aForm at: (x@y) + origin clippingBox: box.! ! !PlayingCard methodsFor: 'printing'! formattedNumber self value = 1 ifTrue: [^'A']. self value <= 10 ifTrue: [^self value printString]. self value = 11 ifTrue: [^'J']. self value = 12 ifTrue: [^'Q']. self value = 13 ifTrue: [^'K']. ^'Unknown'! printOn: aStream aStream nextPutAll: self formattedNumber. aStream nextPutAll: ' of '. self printSuitOn: aStream.! printSuitOn: aStream aStream nextPutAll: 'Unknown'.! ! !PlayingCard methodsFor: 'testing'! = otherCard "Are the receiver and otherCard the same?" self class == otherCard class ifFalse: [^false]. ^self value = otherCard value! isAce "Is the receiver an ace?" ^self value = 1! isKing "Is the receiver a King?" ^self value = 13! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PlayingCard class instanceVariableNames: ''! !PlayingCard class methodsFor: 'constants'! extent "Return the maximum extent of a card's image." ^44@28! ! !PlayingCard class methodsFor: 'instance creation'! ace "Return the ace of the receiver class." ^self value: 1! new self error: 'Must use the value: instance creation method.'.! value: aNumber ^super new value: ((aNumber max: 1) min: 13)! ! PlayingCard subclass: #Heart instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Montana'! Heart comment: 'My instances are those playing cards whose suit is Hearts.'! !Heart methodsFor: 'printing'! printSuitOn: aStream aStream nextPutAll: 'Hearts'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Heart class instanceVariableNames: ''! !Heart class methodsFor: 'constants'! image ^Form extent: 20 @ 18 fromArray: #(514 0 1285 0 2698 32768 5461 16384 10922 40960 21845 20480 43690 40960 21845 20480 43690 40960 21845 16384 10922 32768 5461 0 2730 0 1364 0 680 0 336 0 160 0 64 0 ) offset: 0 @ 0! ! PlayingCard subclass: #Spade instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Montana'! Spade comment: 'My instances are those playing cards whose suit is Spades.'! !Spade methodsFor: 'printing'! printSuitOn: aStream aStream nextPutAll: 'Spades'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Spade class instanceVariableNames: ''! !Spade class methodsFor: 'constants'! image ^Form extent: 14 @ 20 fromArray: #(768 1920 4032 8160 16368 32760 65532 65532 65532 65532 65532 65532 31992 15600 1920 768 4032 4032 768 768 ) offset: 0 @ 0! ! PlayingCard subclass: #Diamond instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Montana'! Diamond comment: 'My instances are those playing cards whose suit is Diamonds.'! !Diamond methodsFor: 'printing'! printSuitOn: aStream aStream nextPutAll: 'Diamonds'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Diamond class instanceVariableNames: ''! !Diamond class methodsFor: 'constants'! image ^Form extent: 18@18 fromArray: #( 128 0 320 0 672 0 1360 0 2728 0 5460 0 10922 0 21845 0 43690 32768 21845 16384 10922 32768 5461 0 2730 0 1364 0 680 0 336 0 160 0 64 0) offset: 0@0! ! PlayingCard subclass: #Club instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Montana'! Club comment: 'My instances are those playing cards whose suit is Clubs.'! !Club methodsFor: 'printing'! printSuitOn: aStream aStream nextPutAll: 'Clubs'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Club class instanceVariableNames: ''! !Club class methodsFor: 'constants'! image ^Form extent: 14 @ 18 fromArray: #(768 1920 4032 4032 4032 1920 13104 31608 65532 65532 65532 65532 31992 14448 768 768 4032 4032 ) offset: 0 @ 0! ! FormView subclass: #MontanaView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Montana'! MontanaView comment: 'My instances provide a graphical representation of the state of the board in a game of Montana. My model is the instance of Montana. My instances listen for two update messages broadcast by my model. The first, #game, causes the entire board image to be refreshed. This is typically sent when a board is being reshuffled and at the start of a game. The second message, #move, takes an argument describing the last move made by the player. This is used to animate the movement of the card over the board.'! !MontanaView methodsFor: 'controller access'! defaultControllerClass ^MontanaController! ! !MontanaView methodsFor: 'displaying'! animateCardFrom: start to: finish "A card has been moved from start position to finish position. Show this move by animating the movement of the displayed card between these two positions. This is done by having the card follow a linear trajectory between these two points with ten equal steps." | startBox finishBox steps delta locus pause trajectory image count | startBox := self boundingBoxForPosition: start. finishBox := self boundingBoxForPosition: finish. steps := 10. delta := (finishBox origin - startBox origin) // steps. locus := startBox origin. pause := Delay forMilliseconds: 50. trajectory := [pause wait. locus := locus + delta]. image := Form fromDisplay: startBox. count := steps. Display gray: startBox. Cursor execute showWhile: [image follow: trajectory while: [count := count - 1. count > 0] within: self insetDisplayBox]. image displayAt: finishBox origin.! boundingBoxForPosition: position "Return the rectangle (expressed in Display coordinates) giving the bounding box of the Montana board at the given position." | count cardSize offset x y aRect displacement | cardSize := PlayingCard extent. offset := 5. count := position y. x := (count * offset) + ((count-1) * cardSize x). count := position x. y := (count * offset) + ((count-1) * cardSize y). displacement := self insetDisplayBox origin. aRect := (x@y extent: cardSize) translateBy: displacement. ^aRect! displayView "Completely regenerate the display of my model's board state." | origin cardSize y offset clipBox | Display fill: self insetDisplayBox mask: Form gray. origin := self insetDisplayBox origin. cardSize := PlayingCard extent. offset := 5. y := origin y + offset. clipBox := self insetDisplayBox. self model board do: [:row | | x | x := origin x + offset. row do: [:card | card isNil ifFalse: [ card displayOn: Display at: x@y clippingBox: clipBox]. x := x + cardSize x + offset. ]. y := y + cardSize y + offset. ].! highlightPosition: position "Highlight the board at the given position by turning the image at that location using reverse video." | aRect | aRect := self boundingBoxForPosition: position. Display reverse: aRect.! showAncestorOfCardAt: position "This method highlights the ancestor to the card at the given position. (See the comment of class PlayingCard for a definition of ancestor). If there is no such ancestor then flash the display." | thisCard ancestor locus | thisCard := self model cardAt: position. (thisCard isNil or: [thisCard value = 2]) ifTrue: [^self flash]. ancestor := thisCard ancestor. ancestor isNil ifTrue: [^self flash]. locus := self model positionOfCard: ancestor. self highlightPosition: locus. Sensor waitNoButton. self highlightPosition: locus.! showDescendentOfCardAt: position "This method highlights the descendent to the card at the given position. (See the comment of class PlayingCard for a definition of descendent). If there is no such descendent then flash the display." | thisCard desc locus | thisCard := self model cardToLeftOf: position. thisCard isNil ifTrue: [^self flash]. desc := thisCard descendent. desc isNil ifTrue: [^self flash]. locus := self model positionOfCard: desc. self highlightPosition: locus. Sensor waitNoButton. self highlightPosition: locus.! update: aspect with: aMove "A change has occurred in the state of my model. Depending upon the aspect, update the display accordingly." (aspect == #move and: [aMove notNil]) ifTrue: [self animateCardFrom: aMove first to: aMove last]. aspect == #game ifTrue: [self display].! ! !MontanaView methodsFor: 'window access'! defaultWindow "Return the window for a graphical display of a Montana board." | cardSize offset width height | cardSize := PlayingCard extent. offset := 5. width := self model class cardsPerSuit * (cardSize x + offset) + offset. height := self model class numberOfSuits * (cardSize y + offset) + offset. ^(Rectangle origin: 0 @ 0 extent: width@height) expandBy: self borderWidth! ! Model subclass: #Montana instanceVariableNames: 'board shufflesLeft lastMove moveCounter ' classVariableNames: 'RND ' poolDictionaries: '' category: 'Montana'! Montana comment: 'My instances hold the state of play in the Montana game. For details on how to play the game execute the following expression: (Montana instructions). This version is based on the Macintosh version implemented by Eric Snider. It has been elaborated slightly so as to illustrate some aspects of the Smalltalk Model-View-Controller framework. This version started out in life as a sample solution to an under-graduate Smalltalk introductory exercise. The game could usefully be extended by a facility for the program to play the game to completion. Instance variables: ''rows'' a 4-by-13 array of Cards or nil. Holds the state of the board. Board positions are accessed using a Point where the x value is the row number; the y value is the column number. ''shufflesLeft'' an integer saying how many shuffles the player has left. ''lastMove'' a two-element array describing the last move made by the player. At the start of a game and immediately after a shuffle, this value is undefined. The first element of the array is the position of the card before the move; the second element is the position after the move. (c) Dr. Kevin Waite, 1990. Computing Science Department University of Glasgow United Kingdom Email: kww@cs.glasgow.ac.uk'! !Montana methodsFor: 'accessing'! cardAt: aPoint "Return the given card at the specified location on the Montana board or nil if there is no card." ^(self board at: aPoint x) at: aPoint y! cardAt: aPoint put: aCard "Place the given card at the specified location on the Montana board. A value of nil for aCard means that this location no longer has a card." (self board at: aPoint x) at: aPoint y put: aCard.! lastMove "Return the last move made by the player as a two-element array whose first element is the starting position and the second is the finishing position for the card." ^lastMove! lastMove: anArrayOfTwoPoints "Set the last move made by the player as a two-element array whose first element is the starting position and the second is the finishing position for the card." lastMove := anArrayOfTwoPoints.! moveCounter ^moveCounter! random "Return the next random number; a value in the range 0..1." ^RND next! shufflesLeft "How many shuffles does the player have left?" ^shufflesLeft! shufflesLeft: anInteger shufflesLeft := anInteger.! ! !Montana methodsFor: 'automatic play'! automaticPlay "This method is a stub that calls the actual method that does the playing. This allows alternative methods to be tried quite easily." "self randomlyMoveCards." "self repeatedPriorityMove." self repeatedRunAndJuggle.! createAGapAt: position "Open up a gap at the given position. This may involve moving an arbitrary number of cards. Return a boolean saying whether the gap was actually created." | run | run := self getRunStartingAt: position. run isNil ifTrue: [^false]. run do: [:each | self moveCardAtPosition: each]. ^true! getRunStartingAt: position "A run is defined as an OrderedCollection of card positions that moved in order will leave a gap at the specified position. If there is no such run from this position then return nil. If there is already a gap then the run will be empty (but non-nil). A constraint on a run is that a card can only appear once (to avoid cycles)." ^self getRunStartingAt: position building: OrderedCollection new fixing: Set new! getRunStartingAt: position building: aRun fixing: fixedPositions "See the method getRunStartingAt: for details of what is a run. This method is trying to find a run building onto the one passed as parameter. Those cards mentioned in fixedPositions cannot be moved since other cards are depending on them being in their current position." | aCard parent holder target | (aRun includes: position) ifTrue: [^nil "Cycle."]. (fixedPositions includes: position) ifTrue: [^nil "Need this card here"]. (self numberOfPositionedCardsInRow: position x) >= position y ifTrue: [ "Prohibit the movement of a card that is in sequence." ^nil. ]. aCard := self cardAt: position. aCard isNil ifTrue: [^aRun "We found it."]. parent := aCard ancestor. parent isAce ifTrue: [ "This run is only possible if there is a vacant slot in the leftmost column to take aCard (known here to be a '2' or if we can create a slot." 1 to: self class numberOfSuits do: [:r | (self isCardAt: r @ 1) ifFalse: [ aRun addFirst: position. ^aRun ]. ]. aRun addFirst: position. 1 to: self class numberOfSuits do: [:r | | trial result | trial := aRun deepCopy. result := self getRunStartingAt: (r@1) building: trial fixing: fixedPositions. result isNil ifFalse: [^result] ]. ^nil "No luck in moving this '2'." ]. holder := self positionOfCard: parent. fixedPositions add: holder. holder y = self class cardsPerSuit ifTrue: [ "Up against the edge of the board. Since nothing will fit in behind it we cannot have a run." ^nil ]. target := holder + (0@1). "Look at slot one to the right." aRun addFirst: position. ^self getRunStartingAt: target building: aRun fixing: fixedPositions! placeOrderedCardAt: position "This method tries to replace the card this position with the one that should be here given its neighbour. This first involves opening up a gap here and then moving in the appropriate card. If we cannot open a gap then return false otherwise true." | success locus | success := self createAGapAt: position. success ifFalse: [^false]. position y = 1 ifTrue: [ | aTwo | "In the left most column. Move in an unplace '2'." aTwo := self findAnUnplacedTwoForRow: position x. aTwo isNil ifTrue: [^false]. locus := self positionOfCard: aTwo. ] ifFalse: [ | neighbour | neighbour := self cardToLeftOf: position. neighbour isNil ifTrue: [^false]. locus := self positionOfCard: neighbour descendent. ]. self moveCardAt: locus to: position. ^true! priorityBlock "Return a two-variable block that sorts cards into decreasing order of preferrance for a move." ^[:aCard :bCard | (self priorityOfCard: aCard) > (self priorityOfCard: bCard)]! priorityMove | movers priorityMovers start | movers := self allCardsThatCanMove. movers isEmpty ifTrue: [^false]. priorityMovers := movers asSortedCollection: self priorityBlock. start := self positionOfCard: priorityMovers first. self moveCardAtPosition: start. ^true! priorityOfCard: aCard "Return an integer giving the priority that should be assigned to the moving of this card. The high value means that this card should always be moved earlier, a low value means move this later." | position neighbour dest destNeighbour ordered | position := self positionOfCard: aCard. neighbour := self cardToLeftOf: position. dest := self destinationForCardAt: position. destNeighbour := self cardToLeftOf: dest. "Case: Moving a card to its final position." destNeighbour == aCard ancestor ifTrue: [^20]. "Case: Moving a card that will leave a gap that when filled will extend a sequence." ordered := self numberOfPositionedCardsInRow: position x. position y = (ordered + 1) ifTrue: [^30]. "Case: Moving a card that is to the right of a gap." neighbour isNil ifTrue: [^10]. "Case: Moving a card that is to the right of a King." neighbour isKing ifTrue: [^0]. "Otherwise case: Moving a card nearer its final position." ^(aCard value - position y) abs + 5! randomlyMoveCards "This method tries to play the game by randomly moving cards until it cannot move anymore. It then reshuffles and continues until it runs out of moves and shuffles." | moves | [ [moves := self randomlyMoveCardsIntoGaps. moves > 0] whileTrue. (self numberOfCardsInOrder < self class placeableCards) and: [self shufflesLeft > 0] ] whileTrue: [self shuffle].! randomlyMoveCardsIntoGaps "This method tries to play the game by randomly moving cards in the hope that this will eventually converge on the solution." | gaps moves | gaps := self positionsOfTheGaps. moves := 0. 1 to: gaps size do: [:k | | gap parent position aCard | gap := gaps at: k. parent := self cardToLeftOf: gap. aCard := parent isNil ifFalse: [parent descendent] ifTrue: ["Move a '2' into this gap." gap y = 1 ifTrue: [self findAnUnplacedTwoForRow: gap x] ifFalse: [nil]]. aCard isNil ifFalse: [ position := self positionOfCard: aCard. self moveCardAt: position to: gap. gaps at: k put: position. moves := moves + 1. ]. ]. ^moves! repeatedPriorityMove [ [self priorityMove] whileTrue. (self numberOfCardsInOrder < self class placeableCards) and: [self shufflesLeft > 0] ] whileTrue: [self shuffle].! repeatedRunAndJuggle [ [self runAndJuggle] whileTrue. (self numberOfCardsInOrder < self class placeableCards) and: [self shufflesLeft > 0] ] whileTrue: [self shuffle].! runAndJuggle "This method tries to fill the rows with the proper cards by moving in the proper cards. It tries this for each row in turn. If it cannot do a move in any row it performs a priority-based move in an attempt to free up some space that can be used as part of a run-based move. This continues until no more cards can be moved." | ordered moved | ordered := Array new: self class numberOfSuits. 1 to: self class numberOfSuits do: [:r | ordered at: r put: (self numberOfPositionedCardsInRow: r)]. moved := false. 1 to: self class numberOfSuits do: [:r | | attempt | attempt := (ordered at: r) + 1. [attempt < self class cardsPerSuit and: [ self placeOrderedCardAt: r @ attempt]] whileTrue: [ attempt := attempt + 1. moved := true ]. ordered at: r put: (attempt-1). ]. ^moved or: [self priorityMove]! ! !Montana methodsFor: 'initialize-release'! initialize "Prepare the receiver for the start of play." board := Array new: self class numberOfSuits. 1 to: board size do: [:k | | row | row := Array new: self class cardsPerSuit. board at: k put: row. ].! newGame "Initialize this instance of the game with a random distribution of cards." | cards | cards := OrderedCollection new: self class numberOfCards. 1 to: self class numberOfCards do: [:k | cards add: (self convertToCard: k)]. self shuffleCards: cards ordered: #(0 0 0 0). self resetShuffleCount. self resetMoveCounter. self changed: #game.! ! !Montana methodsFor: 'moving functions'! allCardsThatCanMove "Return a collection of the cards that could move given the current state of the board." | movers gaps | movers := Set new. gaps := self positionsOfTheGaps. gaps do: [:gap | | parent aCard | parent := self cardToLeftOf: gap. aCard := parent isNil ifFalse: [parent descendent] ifTrue: ["Move a '2' into this gap." gap y = 1 ifTrue: [self findAnUnplacedTwoForRow: gap x] ifFalse: [nil]]. aCard isNil ifFalse: [movers add: aCard]. ]. ^movers! cardToLeftOf: position "Return the card that appears in the same row as the given position but one column to the left. If there is no card at the new location, return nil." | row col newCol thisCard | row := position x. col := position y. newCol := col - 1. newCol = 0 ifTrue: [^nil]. thisCard := self cardAt: row @ newCol. ^thisCard! destinationForCardAt: index "The card at the given index is about to be moved. Return the index of the position where it should go to. If there is already a card there then return nil otherwise return the position. Note that '2' cards must go the first column: if there is no free slot then return nil. If the index argument corresponds to the first column then return the next free position in that column that is free or nil if none." | thisCard | thisCard := self cardAt: index. thisCard value = 2 ifTrue: [ | r c | r := index x. c := index y. c = 1 ifTrue: [ "Move to next free slot in first column." [r := r = 4 ifTrue: [1] ifFalse: [r+1]. r = index x ifTrue: [^nil]. self isCardAt: r@c] whileTrue. ^r @ c ] ifFalse: [ 1 to: 4 do: [:s | (self isCardAt: s@1) ifFalse: [^s @ 1]]. ^nil ]. ] ifFalse: ["Not a '2': find its ancestor." | locus destLocus | locus := self positionOfCard: thisCard ancestor. "Are we at the end of the row?" locus y = self class cardsPerSuit ifTrue: [^nil]. destLocus := locus x @ (locus y + 1). ^(self isCardAt: destLocus) ifTrue: [nil] ifFalse: [destLocus] ]. ^nil! moveCardAt: start to: finish "Move the card currently at location 'start' to its new location 'finish'. This leaves a gap at start. It is assumed that initially there is a gap at finish. Once the board has been updated, announce the change giving details of the move so that any graphical display of the board can be updated appropriately." | thisMove | self simplyMoveCardAt: start to: finish. thisMove := Array with: start with: finish. self lastMove: thisMove. self oneMoreMove. self changed: #move with: thisMove. self changed: #status.! moveCardAtPosition: position | destination | (self isCardAt: position) ifFalse: [^self error: 'There is no card here.']. destination := self destinationForCardAt: position. destination isNil ifTrue: [^self error: 'This is an illegal move.']. self moveCardAt: position to: destination! numberOfCardsInOrder "Return the number of cards that are in the proper order. This is used to compute the current score in the game." ^(1 to: self class numberOfSuits) inject: 0 into: [:total :r | total + (self numberOfPositionedCardsInRow: r)]! numberOfPositionedCardsInRow: r "How cards are in their correct position in the given row? A card N is in its proper position if it is a member of the sequence 2, 3,...,N with the sequence starting in the leftmost column of the row." | suit | suit := nil. 1 to: self class cardsPerSuit do: [:c | | v thisCard | v := c + 1. thisCard := self cardAt: r @ c. suit isNil ifTrue: [suit := thisCard class] ifFalse: [suit == thisCard class ifFalse: [^c-1]]. (thisCard isNil or: [ thisCard value ~= v]) ifTrue: [^c-1] ]. ^self class cardsPerSuit! positionOfCard: aCard "Return the position of the given card as an instance of Point with the x value denoting the row and the y value denoting the column occupied by aCard." 1 to: self class numberOfSuits do: [:r | 1 to: self class cardsPerSuit do: [:c | (self cardAt: r @ c) = aCard ifTrue: [^r @ c]]]. self error: 'Could not find the given card.'.! simplyMoveCardAt: start to: finish "Move the card currently at location 'start' to its new location 'finish'. This leaves a gap at start. It is assumed that initially there is a gap at finish." | thisCard | (self isCardAt: finish) ifTrue: [self error]. thisCard := self cardAt: start. self cardAt: start put: nil. self cardAt: finish put: thisCard.! ! !Montana methodsFor: 'private'! board "Returns the current state of the board." ^board! board: anArrayOfRows "Assigns the argument to be the new state of the board." board := anArrayOfRows! convertToCard: index "The argument 'index' is an integer in the range [1,52]. Convert this number into a unique card instance." | suit number cardClass aCard ind | ind := index - 1. suit := ind // self class cardsPerSuit. number := (ind - (suit * self class cardsPerSuit)) + 1. cardClass := suit = 0 ifTrue: [Club] ifFalse: [ suit = 1 ifTrue: [Heart] ifFalse: [ suit = 2 ifTrue: [Spade] ifFalse: [ suit = 3 ifTrue: [Diamond]]]]. aCard := cardClass value: number. ^aCard! findAnUnplacedTwoForRow: row "Return a '2' card that would best fit into the given row. There are various situations were one '2' is better than another." | twos preferred neighbour ordered first | "Is there already a '2' as the first card in this row but not in the left-most column? If so then move it so that it is in that column." first := self firstCardInRow: row. first value = 2 ifTrue: [^first]. "See if there is already a sequence 3,4,... in place that needs a start." twos := OrderedCollection new. 1 to: self class numberOfSuits do: [:r | ordered := self numberOfPositionedCardsInRow: r. "Don't consider solitary '2's as being immovable." (ordered max: 1) to: self class cardsPerSuit do: [:c | | aCard | aCard := self cardAt: r @ c. (aCard notNil and: [aCard value = 2]) ifTrue: [twos add: aCard] ]. ]. neighbour := self cardAt: row @ 2. preferred := twos detect: [:card | neighbour = card descendent] ifNone: [nil]. "If there was no preferred two then return one that is not already in the leftmost column." ^preferred isNil ifFalse: [preferred] ifTrue: [twos detect: [:card | (self positionOfCard: card) y > 2] ifNone: [twos first]]! firstCardInRow: r "Return the left-most card in the given row." 1 to: self class cardsPerSuit do: [:c | | aCard | aCard := self cardAt: r @ c. aCard isNil ifFalse: [^aCard]. ]. ^nil! oneLessShuffleLeft "The player has used up one more shuffle of the unordered cards." shufflesLeft := shufflesLeft - 1. self changed: #status.! oneMoreMove moveCounter := moveCounter + 1.! positionsOfTheGaps "Return an array giving the positions of the gaps in the board." | gaps | gaps := OrderedCollection new. 1 to: self class numberOfSuits do: [:r | 1 to: self class cardsPerSuit do: [:c | (self isCardAt: r @ c) ifFalse: [gaps add: r @ c] ]. ]. ^gaps! removeAces "Remove the aces from the board in order to create the gaps necessary for moving the other cards." 1 to: self class numberOfSuits do: [:r | 1 to: self class cardsPerSuit do: [:c | | aCard | aCard := self cardAt: r @ c. (aCard notNil and: [aCard isAce]) ifTrue: [self cardAt: r @ c put: nil]. ]. ].! resetMoveCounter moveCounter := 0.! resetShuffleCount "Reset the number of available shuffles to the starting value." shufflesLeft := 2. self changed: #status.! shuffleCards: cards ordered: orderedColumns "This method randomly fills the non-ordered columns of the board with cards picked from 'cards'. This set is destroyed by this method. The orderedColumns argument states how many columns are ordered for each row." 1 to: self class numberOfSuits do: [:r | | start | start := (orderedColumns at: r) + 1. start to: self class cardsPerSuit do: [:c | | index thisCard | "Get an integral random number in the range [1, cards size]." index := (self random * (cards size-1)) rounded + 1. thisCard := cards removeAtIndex: index. self cardAt: r @ c put: thisCard. ]. ]. self removeAces.! undefinedLastMove "Prevent the player from performing an undo last move command. This is necessary at the start of a game and immediately after a shuffle command." self lastMove: nil.! ! !Montana methodsFor: 'statistics'! collectStatistics: count | results log tock tick ticker moves max | results := Array new: self class numberOfCards. moves := Dictionary new. results atAllPut: 0. tock := (count // 100) rounded. tick := tock. ticker := 0. count timesRepeat: [ | placed remaining used | self automaticPlay. placed := self numberOfCardsInOrder. remaining := self class placeableCards - placed + 1. results at: remaining put: (results at: remaining) + 1. used := moves at: self moveCounter ifAbsent: [0]. moves at: self moveCounter put: used+1. self newGame. tick := tick - 1. tick = 0 ifTrue: [ ticker := ticker + 1. Transcript show: ticker printString, '% at ', Time now printString; cr. tick := tock. ]. ]. log := 'Remaining.results' asFilename writeStream. log nextPutAll: 'Remaining'; tab. log nextPutAll: 'Count'; cr. 1 to: results size do: [:k | log nextPutAll: (k-1) printString. log tab. log nextPutAll: (results at: k) printString. log cr. ]. log close. log := 'Moves.results' asFilename writeStream. log nextPutAll: 'Moves'; tab. log nextPutAll: 'Count'; cr. max := moves keys inject: 0 into: [:big :k | big max: k]. 1 to: max do: [:k | log nextPutAll: k printString. log tab. log nextPutAll: (moves at: k ifAbsent: [0]) printString. log cr. ]. log close.! ! !Montana methodsFor: 'testing'! hasLastMove "Do we have a valid last move that can be undone?" ^self lastMove notNil! isCardAt: index "Is there a card at the given location?" ^(self cardAt: index) notNil! ! !Montana methodsFor: 'view adaptor'! instructions | title info | title := Text string: 'Montana Instructions' emphasis: 5. info := Text string: ' Montana is a solitaire card game where the player tries to order cards by suit from 2 to king. A new game starts with all the cards dealt at random in four rows of thirteen columns. Then all the aces are removed to leave four gaps. Cards can only be moved into the gaps. A card can only be moved to the right of the card of the same suit but with face value one lower. For example, if there is a gap to the right of the 3 of spades then the only card that can be moved there is the 4 of spades. Any gap to the right of a king is dead since no card has higher value and so nothing can be moved there. If there is a gap in the leftmost column then any 2 may be moved there. To move a card, simply click on it using the left mouse button. If that card cannot move then the card it should go behind is highlighted. Clicking on a gap highlights the card that can be moved to that gap. An illegal action causes the board to flash. Once there are no more mores available, you can shuffle all the cards that are no in the correct order. You are allowed two shuffles per game. Commands to shuffle the cards, start a new game, and undo the last move are selected from a pop-up menu on the middle mouse button. The status window below the board tells you how many cards are in order and the the number of shuffles remaining. (c) Kevin Waite, 1990.' emphasis: 1. ^title, info! scoreText "Returns a text string that is used in displaying the score." | comment remaining percentage placed | placed := self numberOfCardsInOrder. remaining := self class placeableCards - placed. comment := 'Cards still to position = ', remaining printString. percentage := ((placed / self class placeableCards) * 100) rounded. comment := comment, ' Score = ', percentage printString, '%. '. comment := comment, ' Number of moves = ', self moveCounter printString, ' '. ^Text string: comment withCRs emphasis: 2! shuffleText "Return a text string saying how many shuffles are left in the game." | comment | comment := 'Remaining shuffles = ', self shufflesLeft printString. ^Text string: comment emphasis: 2! status "The complete status message for the game is a concatenation of the score and the remaining shuffles." ^self scoreText, self shuffleText! ! !Montana methodsFor: 'menu functions'! openInstructions | topView infoView | topView := StandardSystemView new model: self. topView borderWidth: 2. topView label: 'Montana Instructions'. infoView := TextView on: self aspect: #instructions change: nil menu: nil. infoView borderWidth: 1. topView addSubView: infoView. topView minimumSize: 500@500. topView controller open.! shuffle "Randomly re-arrange those cards that are not in correct order." | ordered cards aces | self shufflesLeft = 0 ifTrue: [^self "Cannot shuffle any more."]. aces := ReadStream on: self class aces. cards := OrderedCollection new: self class numberOfCards. "Find where the ordered part of each row ends and collect together all those cards that appear in the unordered part." ordered := Array new: self class numberOfSuits. 1 to: self class numberOfSuits do: [:r | | count | count := self numberOfPositionedCardsInRow: r. ordered at: r put: count. (count+1) to: self class cardsPerSuit do: [:c | | thisCard | thisCard := (self isCardAt: r @ c) ifTrue: [self cardAt: r @ c] ifFalse: [aces next]. cards add: thisCard. ]. ]. self shuffleCards: cards ordered: ordered. self changed: #game. self oneLessShuffleLeft. self undefinedLastMove.! undoLastMove "The last move made by the player is reversed with the property that two consecutive undo operations leave the board untouched. The move information is held as an array of two points. Note that undoing the last move DOES increment the move counter." | start finish | start := self lastMove first. finish := self lastMove last. self moveCardAt: finish to: start.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Montana class instanceVariableNames: ''! !Montana class methodsFor: 'constants'! aces ^Array with: Club ace with: Diamond ace with: Spade ace with: Heart ace! cardsPerSuit "Return the number of cards in each suit." ^13! numberOfCards "Return the total number of cards in the pack." ^52! numberOfSuits "Return the number of suits." ^4! placeableCards "How many cards does the user have to arrange to complete the game?" ^self numberOfCards - 4 "Number of aces"! statusHeight "What is the height of the status panel of the game?" ^40! ! !Montana class methodsFor: 'initialize-release'! initialize "Reset the random number generator." RND := Random new.! ! !Montana class methodsFor: 'instance creation'! instructions "Provide some help information on how to play the game." self new openInstructions! new self initialize. ^super new initialize! open "Create a new instance of the game and open a graphical display of the board and a textual summary of the game status." "Montana open" | montana topView montanaView boardSize statusView size | montana := self new newGame. topView := StandardSystemView new model: montana. topView borderWidth: 2. topView label: 'Montana'. montanaView := MontanaView new model: montana. topView addSubView: montanaView. statusView := TextView on: montana aspect: #status change: nil menu: nil. topView addSubView: montanaView in: (0@0 extent: 1@0.8) borderWidth: 2. topView addSubView: statusView in: (0@0.8 extent: 1@0.2) borderWidth: 2. boardSize := montanaView defaultWindow extent. size := boardSize + (0 @ self statusHeight). topView minimumSize: size. topView maximumSize: size. topView controller open.! ! Montana initialize! MouseMenuController subclass: #MontanaController instanceVariableNames: '' classVariableNames: 'Game GameAndUndo GameMenu Shuffle ShuffleAndMove ShuffleAndUndo ShuffleMenu ' poolDictionaries: '' category: 'Montana'! MontanaController comment: 'My instances control the user interaction in a game of Montana. The red mouse button is used to control the movement of the cards. To move a card, simply click on it using the left mouse button. If that card cannot move then the card it should go behind is highlighted. Clicking on a gap highlights the card that can be moved to that gap. An illegal action causes the board to flash. Commands to shuffle the cards, start a new game, and undo the last move are selected from a pop-up menu on the middle mouse button.'! !MontanaController methodsFor: 'control activity'! isControlActive ^super isControlActive & sensor blueButtonPressed not! ! !MontanaController methodsFor: 'menus'! gameMenu ^self model hasLastMove ifTrue: [GameAndUndo] ifFalse: [Game]! menu "Return an ActionMenu offering the commands that are applicable to this state of the game." ^self model shufflesLeft > 0 ifTrue: [self shuffleMenu] ifFalse: [self gameMenu]! shuffleMenu ^self model hasLastMove ifTrue: [ShuffleAndUndo] ifFalse: [Shuffle]! ! !MontanaController methodsFor: 'menu functions'! moveCardAtPosition: position "Move the card at the specified position. See my class comment for details of what happens when an attempt is made to move a card." | destination doAFullRun | doAFullRun := Sensor leftShiftDown. doAFullRun ifTrue: [ |success | success := self model placeOrderedCardAt: position. success ifFalse: [self view flash]. ^self ]. (self model isCardAt: position) ifFalse: [^self view showDescendentOfCardAt: position]. destination := self model destinationForCardAt: position. destination isNil ifTrue: [^self view showAncestorOfCardAt: position]. self model moveCardAtPosition: position.! ! !MontanaController methodsFor: 'mouse activity'! mousePositionAsBoardLocation "Convert the current mouse position into a Point that describes the position of the mouse on the Montana board. The x position refers to the row number; the y value gives the column number." | origin locus cardSize offset increment count row col | origin := self view insetDisplayBox origin. locus := sensor mousePoint - origin. cardSize := PlayingCard extent. offset := 5. increment := cardSize y + offset. count := (locus y \\ increment) - offset. row := count >= 0 ifTrue: [(locus y // increment) + 1] ifFalse: [^nil]. increment := cardSize x + offset. count := (locus x \\ increment) - offset. col := count >= 0 ifTrue: [(locus x // increment) + 1] ifFalse: [^nil]. ^row @ col! redButtonActivity | locus | locus := self mousePositionAsBoardLocation. locus isNil ifFalse: [self moveCardAtPosition: locus].! yellowButtonActivity | aMenu index selector saved | sensor leftShiftDown ifTrue: [ self model priorityMove. sensor waitNoButton. ^self ]. aMenu := self menu. aMenu isNil ifFalse: [ self controlTerminate. index := aMenu startUp. index ~= 0 ifTrue: [ selector := aMenu selectorAt: index. saved := Cursor currentCursor. Cursor currentCursor: Cursor execute. self model perform: selector. Cursor currentCursor: saved. ]. self controlInitialize. ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MontanaController class instanceVariableNames: ''! !MontanaController class methodsFor: 'initialize-release'! initialize "MontanaController initialize." Game := ActionMenu labels: 'Start New Game\Instructions' withCRs lines: #(1) selectors: #(newGame openInstructions). GameAndUndo := ActionMenu labels: 'Start New Game\Undo Last Move\Heuristic Play\Instructions' withCRs lines: #(1) selectors: #(newGame undoLastMove automaticPlay openInstructions). Shuffle := ActionMenu labels: 'Start New Game\Shuffle Unordered Cards\Heuristic Play\Instructions' withCRs lines: #() selectors: #(newGame shuffle automaticPlay openInstructions). ShuffleAndUndo := ActionMenu labels: 'Start New Game\Shuffle Unordered Cards\Undo Last Move\Heuristic Play\Instructions' withCRs lines: #() selectors: #(newGame shuffle undoLastMove automaticPlay openInstructions).! ! MontanaController initialize! ------------------- C U T H E R E --------------------- -- Email: kww@uk.ac.glasgow.cs (JANET) kww%cs.glasgow.ac.uk@nsfnet-relay.ac.uk (INTERNET) Address: Dept. of Computing Science, University of Glasgow, 17 Lilybank Gardens, Glasgow, United Kingdom. G12 8QQ