DCIprogram: #Greed
" Exported from Squeak 7179-basic.226 last modified on 3 November 2014 by: Trygve"
projection: Context
Class: PlayGameCtx
Context subclass: #PlayGameCtx
instanceVariableNames: 'data'
category: 'Greed-Context'
" Controls the playing process.
Otherwise see comment in Controller >> Greed. "
instanceMethods: operations
startPlayGreedOnData: dta
data := dta.
self triggerInteractionFrom: #GAMEMASTER with: #startPlay.
instanceMethods: role binding
CUP
^data controller cup
CURRENTPLAYER
^data players first
DICE
^OrderedCollection newFrom: data controller cup dice
GAMEMASTER
^data controller
PLAYERS
^OrderedCollection newFrom: data players
Interaction: PlayGameCtx
roleMethods: CURRENTPLAYER
instanceMethods: role methods
newGame
self color: Color lightGreen.
self totalScore: 0.
yourTurn
| oldColor rollScore |
oldColor := self color.
self color: Color lightOrange.
self thisRoundScore: 0.
CUP unlockDice.
rollScore := CUP roll.
(self totalScore = 0 and: [rollScore < 300])
ifTrue:
[" Not entered game. "
rollScore := 0]
ifFalse:
[ [ self thisRoundScore: self thisRoundScore + rollScore.
rollScore > 0 and: [self wantsAnotherRoll: CUP]]
whileTrue:
[ rollScore := CUP roll].
rollScore = 0 ifTrue: [self thisRoundScore: 0. " Bust! "].
].
self totalScore: self totalScore + self thisRoundScore.
(Delay forMilliseconds: 1000) wait.
self color: oldColor.
roleMethods: GAMEMASTER
instanceMethods: role methods
startPlay
self newGame.
" Initialize all players. "
PLAYERS resetPlayers.
" Play rounds until game finished. "
[ " Play one round. "
PLAYERS playOneRound.
self leader: PLAYERS identifyLeader.
(self leader notNil and: [self leader totalScore < 3000 and: [self isTerminating not]])
] whileTrue.
roleMethods: CUP
instanceMethods: role methods
roll
DICE roll.
^CUP score
score
| score faces noOfFaces theseDies triplets |
noOfFaces := 0.
self dice do: [:die | noOfFaces := noOfFaces max: die noOfFaces].
faces := Array new: noOfFaces.
" Faces is array, one entry for each die value (1..6) "
" A value is an OrderedCollection of die with given value. "
" Index is a face value. "
1 to: noOfFaces do: [:indx | faces at: indx put: OrderedCollection new].
" Value is OrderedCollection of dice with this value. "
self dice do: [:die | die isLocked ifFalse: [(faces at: die value) addLast: die]].
" Compute score. "
score := 0.
1 to: noOfFaces do:
[:faceValue |
theseDies := faces at: faceValue.
triplets := theseDies size // 3.
faceValue = 1
ifTrue:
[score := (triplets * 1000) +((theseDies size - (triplets * 3)) * 100) + score.
theseDies do: [:die | die isLocked: true]]
ifFalse:
[faceValue = 5
ifTrue:
[score := (triplets * faceValue * 100) + ((theseDies size - (triplets * 3)) * 50) + score.
theseDies do: [:die | die isLocked: true]]
ifFalse:
[score := (triplets * faceValue * 100) + score.
1 to: 3*triplets do: [:j | (theseDies at: j) isLocked: true]]]].
^score
roleMethods: PLAYERS
instanceMethods: role methods
resetPlayers
self with: #CURRENTPLAYER do: [CURRENTPLAYER newGame].
playOneRound
self with: #CURRENTPLAYER do: [CURRENTPLAYER yourTurn].
identifyLeader
| lead |
lead := nil.
self with: #CURRENTPLAYER
do: [(lead isNil or: [CURRENTPLAYER totalScore > lead totalScore])
ifTrue: [lead := CURRENTPLAYER]
].
^lead
roleMethods: DICE
instanceMethods: role methods
roll
20 timesRepeat:
[DICE do:
[:die |
die roll].
World ifNotNil: [World doOneCycle].
(Delay forMilliseconds: 100) wait].
projection: Controller
Class: Greed
SystemWindow subclass: #Greed
instanceVariableNames: 'data greedMorph cup windowStrips greedTextMorph cupStrip text leader playButton isTerminating'
category: 'Greed-Controller'
" Greed is a simple (and boring) game.
An unhappy DCI experiment.
Obscure DCI code?
Even more obscure Morphic code.
Human layer writes Player class to automate playing strategy. "
instanceMethods: initialize-release
initialize
super initialize.
self extent: 600@550.
self borderWidth: 3.
self color: Color lightBlue.
self borderColor: Color black.
text := 'Welcome to the game of Greed.\Play it.' withCRs asText allBold.
leader := nil.
data := (database new initialize) controller: self; yourself.
isTerminating := false.
open
" Greed open. "
| relY cupBottom aSeatMorph left right deltaY |
self setLabel: 'BabyGreed'.
windowStrips := OrderedCollection new.
left := 0.01.
right := 0.99.
"------"
cupStrip := self buildCupStrip.
cupBottom := cupStrip bottom.
self
addMorph: cupStrip
fullFrame: (LayoutFrame fractions: (left@0 corner: right@0) offsets: (0@0 corner: 0@cupBottom)).
"------"
relY := 0.
deltaY := 1/(data seats size+1).
1 to: 3 do:
[:indx |
aSeatMorph := Seat new.
data seats at: indx put: aSeatMorph.
self
addMorph: aSeatMorph
fullFrame:
(LayoutFrame
fractions: (left@relY corner: right@(relY := relY+deltaY))
offsets: (0@cupBottom corner: 0@cupBottom)).
aSeatMorph addPlayerClassName: (#(PlayerCareful PlayerOptimist PlayerSmart) at: indx).
].
self openInWorld.
delete
self terminate.
super delete.
instanceMethods: attributes-read
cup
^cup
leader
^leader
instanceMethods: attributes-write
leader: lead
| strm |
leader := lead.
strm := TextStream on: Text new.
strm
nextPutAll: 'Baby Greed. \ Game in progress' withCRs asText allBold;
nextPutAll: ('\The leader is: ' , leader getName) withCRs asText allItalics;
nextPutAll: ('\with score: ' , leader totalScore asString) withCRs asText.
greedMorph contents: strm contents..
instanceMethods: operations
startPlayGreed
| strm |
PlayGameCtx new startPlayGreedOnData: data.
strm := TextStream on: Text new.
strm
nextPutAll: 'Baby Greed finished' asText allBold;
cr; nextPutAll: 'The winner is: ' asText , leader getName asText allItalics;
cr; nextPutAll: (' with score: ' , leader totalScore asString) asText allItalics.
greedMorph contents: strm contents.
newGame
self color: Color lightBlue.
self borderColor: Color black.
leader := nil.
greedMorph contents: 'Baby Greed. \ Game starting' withCRs asText allBold.
terminate
isTerminating := true.
isTerminating
^isTerminating
instanceMethods: private
buildCupStrip
| strip |
strip := AlignmentMorph newRow
layoutPolicy: TableLayout new;
listDirection: #leftToRight;
hResizing: #spaceFill;
vResizing: #spaceFill;
cellInset: 1;
borderWidth: 0.
(playButton := (StringButtonMorph
contents: 'Play'
font: ( ((TextStyle named: 'BitstreamVeraSans') fontAt: 5))))
color: Color black;
borderWidth: 5;
borderColor: Color red;
target: self;
arguments: Array new;
actionSelector: #startPlayGreed;
actWhen: #buttonDown.
(greedMorph := TextMorph new)
layoutPolicy: TableLayout new;
hResizing: #spaceFill;
vResizing: #spaceFill;
textColor: Color blue;
backgroundColor: Color lightBlue;
borderColor: Color gray;
borderWidth: 1;
beAllFont: ((TextStyle named: 'BitstreamVeraSans') fontAt: 2);
contents: text;
autoFit: false.
cup := Cup new initialize.
strip
addMorph: cup;
addMorph: playButton;
addMorph: greedMorph;
bounds: strip fullBounds;
color: Color transparent.
^strip
instanceMethods: overrides
activate
"Bring me to the front and make me able to respond to mouse and keyboard"
| oldTop outerMorph sketchEditor pal |
outerMorph _ self topRendererOrSelf.
outerMorph owner ifNil: [^ self "avoid spurious activate when drop in trash"].
oldTop _ TopWindow.
TopWindow _ self.
oldTop ifNotNil: [oldTop passivate].
outerMorph owner firstSubmorph == outerMorph
ifFalse: ["Bring me (with any flex) to the top if not already"
outerMorph owner addMorphFront: outerMorph].
self submorphsDo: [:m | m unlock].
labelArea ifNotNil:
[labelArea submorphsDo: [:m | m unlock].
self setStripeColorsFrom: self color. "self paneColorToUse"].
self isCollapsed ifFalse:
[model modelWakeUpIn: self.
self positionSubmorphs.
labelArea ifNil: [self adjustBorderUponActivationWhenLabeless]].
(sketchEditor _ self extantSketchEditor) ifNotNil:
[sketchEditor comeToFront.
(pal _ self world findA: PaintBoxMorph) ifNotNil:
[pal comeToFront]].
addMorph: aMorph fullFrame: aLayoutFrame
| left right bottom top windowBorderWidth |
windowBorderWidth _ self class borderWidth.
left _ aLayoutFrame leftOffset ifNil: [0].
right _ aLayoutFrame rightOffset ifNil: [0].
bottom _ aLayoutFrame bottomOffset ifNil: [0].
top _ aLayoutFrame topOffset ifNil: [0].
aLayoutFrame rightFraction = 1 ifTrue: [aLayoutFrame rightOffset: right - windowBorderWidth].
aLayoutFrame leftFraction = 0
ifTrue: [aLayoutFrame leftOffset: left + windowBorderWidth]
ifFalse: [aLayoutFrame leftOffset: left + ProportionalSplitterMorph splitterWidth].
aLayoutFrame bottomFraction = 1 ifTrue: [aLayoutFrame bottomOffset: bottom - windowBorderWidth].
aLayoutFrame topFraction = 0
ifTrue: [aLayoutFrame topOffset: top]
ifFalse: [aLayoutFrame topOffset: top + ProportionalSplitterMorph splitterWidth].
(aMorph class name = #BrowserCommentTextMorph) ifTrue:
[aLayoutFrame rightOffset: windowBorderWidth negated.
aLayoutFrame leftOffset: windowBorderWidth.
aLayoutFrame bottomOffset: windowBorderWidth negated.
aLayoutFrame topOffset: (windowBorderWidth negated) + 4].
" super addMorph: aMorph fullFrame: aLayoutFrame."
aMorph layoutFrame: aLayoutFrame.
aMorph hResizing: #spaceFill; vResizing: #spaceFill.
self addMorph: aMorph.
paneMorphs _ paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
" aMorph adoptPaneColor: self paneColor."
" aMorph borderWidth: 1; borderColor: Color lightGray; color: Color white."
Preferences scrollBarsOnRight "reorder panes so flop-out right-side scrollbar is visible"
ifTrue: [self addMorphBack: aMorph].
" self addPaneSplitters"
color: aColor
" self traceRM: aColor levels: 2."
^super color: aColor
fillStyle: aFillStyle
"self traceRM: aFillStyle asColor levels: 4."
^super fillStyle: aFillStyle
openInWorld: aWorld
self bounds: (Rectangle originFromUser: self extent).
^self openAsIsIn: aWorld
passivate
"Make me unable to respond to mouse and keyboard"
self setStripeColorsFrom: self color. "self paneColorToUse."
model modelSleep.
"Control boxes remain active, except in novice mode"
self submorphsDo: [:m |
m == labelArea ifFalse:
[m lock]].
labelArea ifNotNil:
[labelArea submorphsDo: [:m |
(m == closeBox or: [m == collapseBox])
ifTrue:
[Preferences noviceMode ifTrue: [m lock]]
ifFalse:
[m lock]]]
ifNil: "i.e. label area is nil, so we're titleless"
[self adjustBorderUponDeactivationWhenLabeless].
self world ifNotNil: "clean damage now, so dont merge this rect with new top window"
[self world == World ifTrue: [self world displayWorld]].
classMethods: instance creation
open
" Greed open. "
^(self basicNew initialize) open
projection: Data
Class: Cup
Morph subclass: #Cup
instanceVariableNames: 'isRolling dice rollingSemaphore'
category: 'Greed-Data'
" Cup rolling dice in a separate process.
See comment in Controller>>Greed "
instanceMethods: initialize-release
initialize
| die |
super initialize.
dice := OrderedCollection new.
" rollingSemaphore := Semaphore forMutualExclusion."
self
layoutPolicy: TableLayout new;
listDirection: #leftToRight;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: 10;
cellInset: 5;
borderWidth: 15;
borderColor: Color blue;
color: Color lightGreen.
5 timesRepeat:
[dice addFirst: (die := Die new initialize).
self addMorph: die.
die stopStepping].
self bounds: self fullBounds.
instanceMethods: attributes-read
dice
^dice
instanceMethods: operations
rollHidden
dice do:
[:die |
die rollHidden].
^self scoreHidden
scoreHidden
| score faces noOfFaces theseDies triplets |
noOfFaces := 0.
dice do: [:die | noOfFaces := noOfFaces max: die noOfFaces].
faces := Array new: noOfFaces.
1 to: noOfFaces do: [:indx | faces at: indx put: OrderedCollection new].
dice do: [:die | die isLocked ifFalse: [(faces at: die value) addLast: die]].
score := 0.
1 to: noOfFaces do:
[:faceValue |
theseDies := faces at: faceValue.
triplets := theseDies size // 3.
faceValue = 1
ifTrue:
[score := (triplets * 1000) +((theseDies size - (triplets * 3)) * 100) + score.
"theseDies do: [:die | die isLocked: true]"]
ifFalse:
[faceValue = 5
ifTrue:
[score := (triplets * faceValue * 100) + ((theseDies size - (triplets * 3)) * 50) + score.
"theseDies do: [:die | die isLocked: true]"]
ifFalse:
[score := (triplets * faceValue * 100) + score.
"1 to: 3*triplets do: [:j | (theseDies at: j) isLocked: true]" ]]].
^score
unlockDice
dice do: [:die | die isLocked: false].
Class: Die
RectangleMorph subclass: #Die
instanceVariableNames: 'stringMorph noOfFaces value isLocked'
category: 'Greed-Data'
" See comment in Controller>>Greed "
instanceMethods: initialize-release
initialize
super initialize.
noOfFaces := 6.
isLocked := false.
self
layoutPolicy: TableLayout new;
listDirection: #leftToRight;
listCentering: #center;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 5;
borderColor: Color black;
color: Color yellow.
(stringMorph := StringMorph new)
font: ((TextStyle named: 'BitstreamVeraSans') fontAt: 5).
self addMorph: stringMorph.
self roll.
self bounds: self fullBounds.
instanceMethods: attributes-read
isLocked
^isLocked
noOfFaces
^noOfFaces
value
^value
instanceMethods: attributes-write
isLocked: bool
(isLocked := bool)
ifTrue: [self color: Color red]
ifFalse: [self color: Color yellow].
value: int
value := int.
stringMorph contents: value printString.
instanceMethods: operations
roll
self isLocked
ifFalse:
[self value: (Collection randomForPicking next * noOfFaces + 0.49999) rounded].
rollHidden
self isLocked
ifFalse:
[value := (Collection randomForPicking next * noOfFaces + 0.49999) rounded].
classMethods: testing
test1
" Die test1 "
| dice results val |
dice := Die new initialize.
results := (Array new: 6) atAllPut: 0.
1000 timesRepeat:
[dice step.
val := dice value.
results at: val put: (results at: val) + 1].
results inspect
Class: Player
TextMorph subclass: #Player
instanceVariableNames: 'name totalScore thisRoundScore'
category: 'Greed-Data'
" See comment in Controller>>Greed.
All players are instances of one of my subclasses. They differ as to playing strategy. "
instanceMethods: initialize-release
initialize
super initialize.
totalScore := 0.
self
textColor: Color green muchDarker;
backgroundColor: Color lightGreen;
borderColor: Color green;
borderWidth: 5;
layoutPolicy: (TableLayout new);
hResizing: #spaceFill;
vResizing: #spaceFill;
beAllFont: ((TextStyle named: 'BitstreamVeraSans') fontAt: 2);
autoFit: false.
self setName: nil.
instanceMethods: attributes-read
thisRoundScore
^thisRoundScore
totalScore
^totalScore
getName
^name
color
^self backgroundColor
isEmptySeat
^name isNil
isLocked
^true
instanceMethods: attributes-write
thisRoundScore: anInt
thisRoundScore := anInt.
self setContents.
totalScore: anInt
totalScore := anInt.
self setContents.
setName: aStringOrNil
name := aStringOrNil.
self setContents.
color: aColor
| w |
self backgroundColor: aColor.
(w := self world) ifNotNil: [w doOneCycle].
setContents
| strm |
strm := TextStream on: (Text new: 50).
self isEmptySeat
ifFalse:
[strm
nextPutAll: name asText allBold;
cr; nextPutAll: 'Total score = ' asText allItalics;
nextPutAll: totalScore printString asText;
cr; nextPutAll: 'Score last round = ' asText allItalics;
nextPutAll: thisRoundScore printString asText].
self
newContents: strm contents;
updateFromParagraph.
World ifNotNil: [World doOneCycle].
update: aParam
self updateFromParagraph.
instanceMethods: operations
wantsAnotherRoll: cup
^false
printOn: aStream
super printOn: aStream.
aStream nextPutAll: '(' , name printString , ')'.
Class: PlayerCareful
Player subclass: #PlayerCareful
instanceVariableNames: ''
category: 'Greed-Data'
" Rolls if there are three or more die to roll. "
instanceMethods: operations
wantsAnotherRoll: cup
^(cup dice select: [:die | die isLocked not]) size >= 5
Class: PlayerOptimist
Player subclass: #PlayerOptimist
instanceVariableNames: ''
category: 'Greed-Data'
" Rolls as long as there is a die to roll. "
instanceMethods: operations
wantsAnotherRoll: cup
^(cup dice select: [:die | die isLocked not]) size >= 2
Class: PlayerSmart
Player subclass: #PlayerSmart
instanceVariableNames: ''
category: 'Greed-Data'
" Rolls experimentally a hundred times, makes an actual roll if the majority were beneficial. "
instanceMethods: operations
wantsAnotherRoll: cup
| good burst score thisScore |
good := 0.
burst := 0.
score := 0.
100 timesRepeat: [(thisScore := cup rollHidden) > 0
ifTrue: [good := good + 1. score := score + thisScore]
ifFalse: [burst := burst + 1]].
^totalScore >= 300
ifTrue:
[(score / 100) > (totalScore * 0.3)] " Has entered game. "
ifFalse:
[false] " Entering game now. Take no chances. "
"good > burst"
Class: Seat
Morph subclass: #Seat
instanceVariableNames: 'player'
category: 'Greed-Data'
" Room for a player.
See Greed comment. "
instanceMethods: initialize-release
initialize
super initialize.
self
color: Color yellow;
borderColor: Color black;
borderWidth: 1;
layoutPolicy: (TableLayout new);
hResizing: #spaceFill;
vResizing: #spaceFill.
player := Player subclasses first new initialize.
player setName: player class name asString.
self removeAllMorphs.
self addMorph: player.
instanceMethods: attributes-read
player
^player
instanceMethods: attributes-write
player: aPlayer
player := aPlayer.
self update.
instanceMethods: operations
addPlayerClassName: clName
| playerClass |
playerClass := Smalltalk at: clName.
player ifNotNil: [player delete].
player := playerClass new initialize.
player setName: playerClass name asString.
self removeAllMorphs.
self addMorph: player.
choosePlayer
| playerClasses clIndx playerClass |
playerClasses := Player subclasses.
clIndx := PopUpMenu
withCaption: 'Please select player class'
chooseFrom: (playerClasses collect: [:cl | cl name]).
clIndx = 0 ifTrue: [^ self].
playerClass := playerClasses at: clIndx.
player ifNotNil: [player delete].
player := playerClass new initialize.
player setName: playerClass name asString.
self removeAllMorphs.
self addMorph: player.
delete
" NOTE: Cannot use 'delete' method in Morph because it handles 'player' specially. STUPID! "
| aWorld |
self removeHalo.
aWorld := self world ifNil: [World].
aWorld ifNotNil:
[self disableSubmorphFocusForHand: self activeHand.
self activeHand releaseKeyboardFocus: self;
releaseMouseFocus: self.].
owner ifNotNil:
[ self privateDelete.
player ifNotNil: [ player delete]].
instanceMethods: I/O
handlesMouseDown: evt
^self innerBounds containsPoint: evt cursorPoint
mouseDown: evt
evt yellowButtonPressed
ifTrue: ["First check for option (menu) click"
^ self yellowButtonActivity: evt shiftPressed].
"self eventHandler
ifNotNil: [self eventHandler mouseDown: evt fromMorph: self]"
yellowButtonActivity: shiftState
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu
add: 'choose player' action: #choosePlayer.
aMenu popUpInWorld.
Class: database
Object subclass: #database
instanceVariableNames: 'controller seats players cup'
category: 'Greed-Data'
" See Greed comment. "
instanceMethods: initialize-release
initialize
seats := Array new: 3.
instanceMethods: attributes-read
controller
^controller
players
| res |
res := OrderedCollection new.
seats do: [:s | s player ifNotNil: [res add: s player]].
^res
seats
^seats
instanceMethods: attributes-write
controller: ctr
controller := ctr.