Skip to content

Instantly share code, notes, and snippets.

@avibryant

avibryant/dip.st

Last active April 28, 2020 19:29
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save avibryant/bcb458b57d6276b11b007158f7c70072 to your computer and use it in GitHub Desktop.
Save avibryant/bcb458b57d6276b11b007158f7c70072 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
dip.st
SystemOrganization addCategory: #'Diplomatik-Game'!
SystemOrganization addCategory: #'Diplomatik-Judge'!
SystemOrganization addCategory: #'Diplomatik-Users'!
SystemOrganization addCategory: #'Diplomatik-UI'!
WAComponent subclass: #DAdmin
instanceVariableNames: 'password'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DAdmin class methodsFor: 'as yet unclassified' stamp: 'avi 5/2/2008 23:27'!
canBeRoot
^ true! !
!DAdmin methodsFor: 'as yet unclassified' stamp: 'avi 5/2/2008 23:22'!
renderContentOn: html
html strong: 'Database: '.
html anchor callback: [DDatabase reset]; text: 'reset'.
html space.
html anchor callback: [DDatabase load]; text: 'load'.
html paragraph.
html strong: 'Games:'.
html break.
DDatabase default games do:
[:ea |
self renderGame: ea on: html].
html paragraph.
html strong: 'Users:'.
html break.
DDatabase default users do:
[:ea |
self renderUser: ea on: html]! !
!DAdmin methodsFor: 'as yet unclassified' stamp: 'avi 5/11/2008 13:12'!
renderGame: aGame on: html
[html text: aGame name.
html space.
html text: (aGame allUsers collect: [:ea | ea name]) asArray printString.
html space.
html text: (aGame currentStage season name, ' ', aGame currentStage phaseName).
html space.
html text: (aGame deadline - DateAndTime now) asString.
html space.
html anchor callback: [DDatabase default reloadGame: aGame]; text: 'reload'.
html space.
aGame isInTimeout
ifTrue: [html anchor callback: [aGame clearTimeout]; text: '-timeout']
ifFalse: [html anchor callback: [aGame startTimeout]; text: '+timeout'].
html space.
html anchor callback: [aGame advanceTurn]; text: 'advance'.
html space.
html anchor callback: [aGame deadline: aGame deadline + aGame stageDuration]; text: '+deadline'.
html space.
html anchor callback: [aGame deadline: aGame deadline - aGame stageDuration]; text: '-deadline'.
html space.
html anchor callback: [DDatabase default removeGame: aGame]; text: 'delete'.
html break.
html form:
[html textInput value: (aGame stageDuration asSeconds / 3600); callback: [:v | aGame stageDuration: v asNumber hours].
html text: ' Hours'.
html space.
html submitButton].
html unorderedList:
[aGame currentStage orders keys do:
[:ea |
html listItem:
[html text: ea.
html space.
html text: (aGame currentStage orders at: ea) unitPosition.
html anchor callback: [aGame currentStage orders removeKey: ea]; text: 'delete']]]] ifError: [:e | html text: e]! !
!DAdmin methodsFor: 'as yet unclassified' stamp: 'avi 5/2/2008 23:21'!
renderUser: aUser on: html
html form:
[html text: aUser name.
html text: ' - '.
html text: aUser email.
html space.
html textInput callback: [:v | password := v].
html space.
html submitButton callback: [aUser setPassword: password]; text: 'Change Password']! !
WAComponent subclass: #DDialog
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
DDialog subclass: #DCreateAccount
instanceVariableNames: 'email password confirmation name'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DCreateAccount methodsFor: 'as yet unclassified' stamp: 'avi 4/7/2008 23:56'!
boxClass
^ 'login'! !
!DCreateAccount methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 01:38'!
email: aString
email := aString! !
!DCreateAccount methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:00'!
finish
| user |
email isEmptyOrNil ifTrue: [^ self].
password isEmptyOrNil ifTrue: [^ self].
name isEmptyOrNil ifTrue: [^ self].
password = confirmation ifFalse: [^ self].
(DDatabase default userWithEmail: email) ifNotNil: [^ self].
user := DUser email: email password: password name: name.
(DDatabase default addUser: user).
self answer: user! !
!DCreateAccount methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 01:39'!
password: aString
password := aString! !
!DCreateAccount methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 01:38'!
renderBoxOn: html
html div id: 'loginBox'; with:
[html form:
[html heading level: 2; with: 'Creating a new account'.
html paragraph: 'Please confirm your password and enter a name for other people to use to identify you.'.
html definitionList:
[html definitionTerm: [html label for: 'emailAddress'; with: 'Email address:'].
html definitionData: [html textInput id: 'emailAddress'; value: email; callback: [:v | email := v]].
html definitionTerm: [html label for: 'password'; with: 'Password:'].
html definitionData: [html passwordInput id: 'password'; class: 'text'; value: password; callback: [:v | password := v]].
html definitionTerm: [html label for: 'password2'; with: 'Confirm password:'].
html definitionData: [html passwordInput id: 'password2'; class: 'text'; callback: [:v | confirmation := v]].
html definitionTerm: [html label for: 'name'; with: 'Name:'].
html definitionData: [html textInput id: 'name'; callback: [:v | name := v]].
html definitionTerm.
html definitionData:
[html submitButton class: 'submit button'; callback: [self finish]; text: 'Finish']]]]! !
!DDialog methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 21:45'!
boxClass
^ ''! !
!DDialog methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 21:45'!
renderBoxOn: html! !
!DDialog methodsFor: 'as yet unclassified' stamp: 'avi 5/5/2008 12:56'!
renderContentOn: html
html div class: 'globalBox'; class: self boxClass; with:
[html heading: 'Diplomati.ca'.
self renderBoxOn: html]! !
!DDialog methodsFor: 'as yet unclassified' stamp: 'avi 5/5/2008 12:56'!
updateRoot: aRoot
aRoot title: 'Diplomati.ca'.
aRoot javascript resourceUrl: 'js/prototype.js'.
aRoot javascript resourceUrl: 'js/login.js'.
aRoot stylesheet resourceUrl: 'css/default.css'.
aRoot stylesheet resourceUrl: 'css/login.css'.
! !
DDialog subclass: #DGameMenu
instanceVariableNames: 'user game'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:03'!
boxClass
^ 'gameMenu'! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/10/2008 21:24'!
joinUrlForGame: aGame
| url |
url := self session application baseUrl.
url takeServerParametersFromRequest: self session currentRequest.
url addParameter: 'game' value: aGame token.
^ url asString! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/12/2008 00:10'!
newGameNamed: aString
game := DGame new name: aString.
game addUser: user.
DDatabase default addGame: game! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:03'!
renderBoxOn: html
html div id: 'menuBox'; with:
[html form:
[self renderExistingGamesOn: html.
self renderNewGameOn: html]]! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 15:29'!
renderExistingGame: aGame on: html
|power url |
html div class: 'gameMenuBox'; with:
[power := aGame powerForUser: user.
self renderMiniMapFor: aGame on: html.
html anchor
callback: [self answer: aGame];
class: 'miniMapLink'.
html paragraph:
[html strong class: 'gameLink'; with:
[html anchor
callback: [self answer: aGame];
text: aGame name].
html text: ' - '.
html emphasis class: 'gameDate'; with: aGame currentStage season name.
html text: ' - '.
html span class: 'gameStatus'; with: aGame currentStage phaseName.
html text: ' - '.
html span class: 'playerCountry'; class: power id; with: power name].
aGame canStart ifFalse:
[html paragraph:
[html strong: 'This game has ', aGame allUsers size asString, ' of ', aGame map powers size asString, ' players. More players can join by going to this link: '.
html break.
url := self joinUrlForGame: aGame.
html anchor class: 'gameInviteLink'; target: '_blank'; url: url; text: url]]]! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/9/2008 23:02'!
renderExistingGamesOn: html
| games |
games := DDatabase default gamesForUser: user.
games isEmpty ifTrue: [^ self].
html heading level: 2; with: 'Enter an existing game'.
games do:
[:ea |
self renderExistingGame: ea on: html]! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:00'!
renderMiniMapFor: aGame on: html
html render: (DMiniMapViewer stage: aGame currentStage power: (aGame powerForUser: user))! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/12/2008 00:12'!
renderNewGameOn: html
html heading level: 2; with: 'Create a new game'.
html form:
[html paragraph:
[html strong: 'Game name: '.
html textInput callback: [:v | self newGameNamed: v]].
html paragraph:
[html strong: 'Turn length: '.
html textInput
style: 'width: 2em';
value: 24;
callback: [:v | game stageDuration: v asNumber hours].
html text: ' hours'].
html paragraph: [html submitButton text: 'Create game']]! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/10/2008 21:08'!
updateRoot: aRoot
super updateRoot: aRoot.
aRoot stylesheet resourceUrl: 'css/gameMenu.css'.
! !
!DGameMenu methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:37'!
user: aUser
user := aUser! !
DDialog subclass: #DLoginPage
instanceVariableNames: 'email password user joinGame'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DLoginPage class methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:37'!
canBeRoot
^ true! !
!DLoginPage methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 21:46'!
boxClass
^ 'login'! !
!DLoginPage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 01:39'!
createAccount
user := self call: (DCreateAccount new email: email; password: password).
self successfulLogin! !
!DLoginPage methodsFor: 'as yet unclassified' stamp: 'avi 4/10/2008 23:58'!
initialRequest: aRequest
aRequest at: 'game' ifPresent:
[:t |
DDatabase default games do:
[:ea |
ea token = t ifTrue:
[joinGame := ea]]]! !
!DLoginPage methodsFor: 'as yet unclassified' stamp: 'avi 4/7/2008 23:55'!
login
user := DDatabase default userWithEmail: email.
user ifNotNil: [(user hasPassword: password) ifTrue: [self successfulLogin]]! !
!DLoginPage methodsFor: 'as yet unclassified' stamp: 'avi 4/12/2008 00:22'!
renderBoxOn: html
html div id: 'loginBox'; with:
[html form id: 'loginForm'; with:
[html definitionList:
[html definitionTerm: [html label for: 'emailAddress'; with: 'Email address:'].
html definitionData: [html textInput id: 'emailAddress'; callback: [:v | email := v]].
html definitionTerm: [html label for: 'password'; with: 'Password:'].
html definitionData: [html passwordInput id: 'password'; class: 'text'; callback: [:v | password := v]].
html definitionTerm.
html definitionData:
[html submitButton class: 'submit button'; callback: [self login]; text: 'Sign in'.
html text: ' or '.
html submitButton class: 'submit button'; callback: [self createAccount]; text: 'Create new account']]]].
! !
!DLoginPage methodsFor: 'as yet unclassified' stamp: 'avi 4/10/2008 23:59'!
successfulLogin
| game |
joinGame ifNotNil: [joinGame addUser: user].
game := self call: (DGameMenu new user: user).
self call: (DGameViewer game: game user: user)! !
WAComponent subclass: #DGameViewer
instanceVariableNames: 'game user'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DGameViewer class methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:40'!
game: aGame user: aUser
^ self new setGame: aGame user: aUser! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 2/1/2009 23:01'!
parseOrders: aString
|orders|
orders := DOrderParser parseString: aString stage: self stage.
(orders select: [:ea | ea power = self power]) do:
[:ea |
self stage addOrder: ea].
game save.
self session returnResponse: (WAResponse new nextPutAll: 'OK')! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:26'!
phaseClass
self stage isBuildStage ifFalse: [^ self stage typeName asLowercase, 'Phase'].
(self stage buildDeltaForPower: self power) >= 0 ifTrue: [^ self stage typeName asLowercase, 'Phase'].
^ 'disbandPhase'! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:00'!
power
^ game powerForUser: user! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/12/2008 15:25'!
previousStage
^ game stages at: game stages size - 1! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:12'!
renderBuildsFor: aPower on: html
|delta|
delta := self stage buildDeltaForPower: aPower.
delta = 0 ifTrue: [^ self].
html listItem class: aPower id; with:
[delta > 0 ifTrue:
[html text: aPower name, ' can build ', delta asString, ' unit'.
delta > 1 ifTrue: [html text: 's']].
delta < 0 ifTrue:
[html text: aPower name, ' must disband ', delta abs asString, ' unit'.
delta < -1 ifTrue: [html text: 's']]]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:18'!
renderContentOn: html
html div
class: 'globalBox';
class: self stage season typeName asLowercase;
class: self phaseClass;
with:
[html heading: self stage season name.
html heading id: 'gameTitle'; with: game name.
html div id: 'moveBox'; with:
[html heading level: 2; with: self stage phaseName.
self renderMoveBoxOn: html].
html div id: 'statusBox'; with:
[self renderStatusBoxOn: html].
html div class: 'mapBox'; id: 'mapBox'; with:
[self renderMapOn: html.
self renderMenusOn: html]].
self renderScriptsOn: html! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 20:01'!
renderDecisionsFor: aPower on: html
|decisions|
decisions := self stage decisions select: [:ea | ea power = aPower].
decisions do: [:ea | html render: ea viewer]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/12/2008 15:25'!
renderDecisionsOn: html
html unorderedList class: 'moveList'; id: 'pastMovesList'; with:
[self stage isBuildStage ifTrue:
[self renderBuildsFor: self power on: html.
(game map powers copyWithout: self power) do:
[:ea |
self renderBuildsFor: ea on: html]].
self stage isRetreatStage ifTrue:
[self renderRetreatsFor: self power on: html.
(game map powers copyWithout: self power) do:
[:ea |
self renderRetreatsFor: ea on: html]].
self renderDecisionsFor: self power on: html.
(game map powers copyWithout: self power) do:
[:ea |
self renderDecisionsFor: ea on: html]].
(self previousStage notNil and: [self previousStage isRetreatStage]) ifTrue:
[self renderPreviousDecisionsOn: html]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 02:00'!
renderFormOn: html
html form id: 'orderForm'; style: 'display: none'; with:
[html hiddenInput
id: 'json';
callback: [:v | self parseOrders: v].
html submitButton text: 'Submit Orders'].
! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:00'!
renderMapOn: html
html render: (DMapViewer stage: self stage power: self power)! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:21'!
renderMenusOn: html
html render: (DMenuViewer stage: self stage power: self power) ! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:22'!
renderMoveBoxOn: html
self stage decisions isEmpty ifFalse:
[html heading level: 3; class: 'pastMoves'; with: 'Move Results'.
html div class: 'moveListBox'; with:
[self renderDecisionsOn: html]].
html heading level: 3; class: 'futureMoves'; with: 'Moves for ', self stage season name.
html div class: 'moveListBox'; with:
[html unorderedList class: 'moveList'; id: 'futureMovesList'.
self renderFormOn: html].! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/12/2008 22:25'!
renderPreviousDecisionsOn: html
" |decisions|
game map powers do:
[:p |
decisions := self previousStage decisions select: [:ea | ea power = p].
decisions do: [:ea | html render: ea viewer]]"! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:51'!
renderRetreatsFor: aPower on: html
(self stage retreatsForPower: aPower) ifNotEmptyDo:
[:units |
units do:
[:ea |
html listItem class: aPower id; with:
[html text: (self stage retreatPositionOf: ea) name.
html text: ' must retreat']]]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 01:51'!
renderScriptsOn: html
html script: 'Dip.moveMap = ', (Json render: self stage moveMap).
html script: 'Dip.convoyMap = ', (Json render: self stage convoyMap).
html script: 'Dip.retreatMap = ', (Json render: self stage retreatMap).
html script: 'Dip.orders = ', (Json render: (self stage ordersForPower: self power)).
html script: 'Dip.player = ', self power id printString.
html script: 'Dip.deadline = new Date(); Dip.deadline.setTime(Dip.deadline.getTime() + (', game deadline asJavascript, ' - ', DateAndTime now asJavascript, '))'! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 15:14'!
renderStatusBoxOn: html
html table class: 'statusTable'; with:
[self renderStatusTableHeadOn: html.
html tableBody:
[self sortedPowers do:
[:ea |
self renderStatusRowFor: ea on: html]]]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 17:20'!
renderStatusRowFor: aPower on: html
|aUser timeouts |
aUser := game userForPower: aPower.
aUser ifNil: [^ self].
html tableRow
class: aPower id;
class: (user = aUser ifTrue: ['myStatus'] ifFalse: ['']);
with:
[html tableData class: 'statusSupplyCenters'; with: (self stage supplyCentersForPower: aPower) size.
html tableData class: 'statusExtensions'; with:
[timeouts := (game timeoutsForPower: aPower).
html text: timeouts].
html tableHeading class: 'statusCountry'; with:
[html heading level: 4; with: aPower name.
user = aUser ifTrue: [html text: 'You'] ifFalse:
[html anchor
class: 'mailLink';
url: 'mailto:' , (aUser email);
text: aUser name]].
html tableData class: 'statusHasSubmittedOrders'; with:
[(self stage powersWithoutOrders includes: aPower)
ifTrue:
[game isInTimeout ifTrue:
[html image
attributeAt: 'border' put: '0';
resourceUrl: 'img/stopwatch.png']]
ifFalse: [html image
attributeAt: 'border' put: '0';
resourceUrl: 'img/checkmark.png']]]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/9/2008 03:49'!
renderStatusTableHeadOn: html
html tableHead:
[html tableRow:
[html tableData class: 'statusSupplyCenters'; with:
[html image
resourceUrl: 'img/supplyCenter.png';
altText: 'Supply centers controlled';
width: 15; height: 15].
html tableData:
[html image
resourceUrl: 'img/stopwatch.png';
altText: 'Time extensions remaining';
width: 15; height: 15].
html tableHeading
class: 'statusCountry';
colSpan: 2;
with: [html space]]].! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:03'!
setGame: aGame user: aUser
game := aGame.
user := aUser! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/9/2008 04:03'!
sortedPowers
^ game map powers asSortedCollection:
[:a :b |
(self stage supplyCentersForPower: a) size >=
(self stage supplyCentersForPower: b) size]! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:03'!
stage
^ game currentStage! !
!DGameViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/5/2008 12:56'!
updateRoot: aRoot
aRoot title: 'Diplomati.ca'.
aRoot javascript resourceUrl: 'js/prototype.js'.
aRoot javascript resourceUrl: 'js/main.js'.
aRoot javascript resourceUrl: 'js/scriptaculous-mini.js'.
aRoot stylesheet resourceUrl: 'css/default.css'.
! !
Object subclass: #DCancelOrder
instanceVariableNames: 'place stage'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DCancelOrder class methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:45'!
place: aPlace
^ self basicNew setPlace: aPlace! !
!DCancelOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:07'!
isCancel
^ true! !
!DCancelOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:46'!
place
^ place! !
!DCancelOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:36'!
power
^ stage controllingPowerFor: place! !
!DCancelOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:36'!
setPlace: aPlace
place := aPlace! !
!DCancelOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:36'!
stage: aStage
stage := aStage! !
Object subclass: #DConvoyMapBuilder
instanceVariableNames: 'sources targets fleets'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DConvoyMapBuilder class methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 22:46'!
sources: aCollection targets: bCollection fleets: fCollection
^ self basicNew setSources: aCollection targets: bCollection fleets: fCollection! !
!DConvoyMapBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:27'!
hasRoute
^ self map anySatisfy: [:ea | ea isEmpty not]! !
!DConvoyMapBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 22:44'!
map
| map s t |
map := Dictionary new.
fleets do:
[:ea |
s := self sourcesFor: ea.
t := self targetsFor: ea.
s do:
[:p |
(map at: p ifAbsentPut: [Set new]) addAll: (t copyWithout: p)]].
^ map! !
!DConvoyMapBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:01'!
neighborsFor: aPlace from: aCollection seen: aSet
(aSet includes: aPlace) ifTrue: [^ #()].
aSet add: aPlace.
(aCollection includes: aPlace) ifTrue: [^ Array with: aPlace].
(fleets includes: aPlace) ifTrue: [^ aPlace allNeighbors gather: [:ea | self neighborsFor: ea from: aCollection seen: aSet]].
^ #()! !
!DConvoyMapBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 22:46'!
setSources: aCollection targets: bCollection fleets: fCollection
sources := aCollection.
targets := bCollection.
fleets := fCollection! !
!DConvoyMapBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:21'!
sourcesFor: aPlace
^ self neighborsFor: aPlace from: sources seen: Set new! !
!DConvoyMapBuilder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:21'!
targetsFor: aPlace
^ self neighborsFor: aPlace from: targets seen: Set new! !
Object subclass: #DDatabase
instanceVariableNames: 'users games migrations'
classVariableNames: 'Default'
poolDictionaries: ''
category: 'Diplomatik-Users'!
!DDatabase class methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:41'!
default
^ Default ifNil: [Default := self new]! !
!DDatabase class methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 10:59'!
initialize
self default tryMigrations! !
!DDatabase class methodsFor: 'as yet unclassified' stamp: 'avi 5/2/2008 22:52'!
load
|s dir|
dir := FileDirectory default directoryNamed: 'games'.
dir fileNames do:
[:ea |
s := ReferenceStream on: (dir fileNamed: ea).
self default loadGame: s next.
s close]! !
!DDatabase class methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 23:16'!
reset
Default := nil! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:55'!
addGame: aGame
games add: aGame! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:00'!
addUser: aUser
users add: aUser.
^ aUser! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 21:57'!
directoryForGame: aGame
|dir|
dir := (FileDirectory default directoryNamed: 'games') directoryNamed: aGame token.
dir assureExistence.
^ dir! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 11:12'!
fixBulgaria
| bul |
DDatabase default games do:
[:game |
bul := game map placeNamed: 'Bulgaria'.
(bul hasCoast: #north)
ifTrue:
[(bul neighborsForCoast: #north)
do: [:ea | bul addNeighbor: ea coast: #east].
bul removeCoast: #north]]! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:44'!
games
^ games! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:21'!
gamesForUser: aUser
^ games select: [:ea | ea allUsers includes: aUser]! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:44'!
initialize
users := OrderedCollection new.
games := OrderedCollection new! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/21/2008 17:58'!
loadGame: aGame
|user|
self addGame: aGame.
aGame allUsers do:
[:ea |
user := self userWithEmail: ea email.
user
ifNil: [self addUser: ea]
ifNotNil: [aGame replaceUser: ea with: user]]! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 10:59'!
migrations
^ migrations ifNil: [migrations := Set new]! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 5/11/2008 13:13'!
reloadGame: aGame
| dir s |
games remove: aGame.
dir := FileDirectory default directoryNamed: 'games'.
s := ReferenceStream on: (dir fileNamed: aGame token, '.obj').
self loadGame: s next.
s close! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 5/5/2008 20:36'!
removeGame: aGame
games remove: aGame ifAbsent: [^ self].
(FileDirectory default directoryNamed: 'games') deleteFileNamed: aGame token, '.obj'! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/21/2008 17:40'!
saveGame: aGame
(ReferenceStream on: (FileStream forceNewFileNamed: 'games/', aGame token, '.obj'))
nextPut: aGame;
close! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 11:12'!
tryMigrations
#(fixBulgaria) do: [:ea |
(self migrations includes: ea)
ifFalse: [self perform: ea.
migrations add: ea]]! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:44'!
userWithEmail: aString
^ users detect: [:ea | ea email = aString] ifNone: []! !
!DDatabase methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:56'!
users
^ users! !
Object subclass: #DDecision
instanceVariableNames: 'judge'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:21'!
hash
^ self species hash! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isAttackStrength
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:50'!
isBuildDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isDefendStrength
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:12'!
isDisbandDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:11'!
isDislodgeDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isHoldStrength
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:39'!
isMoveDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:24'!
isOrderDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:26'!
isPathDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isPreventStrength
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:51'!
isRetreatDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:42'!
isSupportDecision
^ false! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 00:42'!
renderMoveOn: html
html text: self move unitPosition name.
html text: ' - '.
html text: self move target name.! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 00:21'!
renderOn: html! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:19'!
setJudge: aJudge
judge := aJudge! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:33'!
updateStage: aStage
! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:33'!
viewer
^ self viewerClass decision: self! !
!DDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:38'!
viewerClass
^ DBlankDecisionViewer! !
DDecision subclass: #DOrderDecision
instanceVariableNames: 'succeeds order'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
DOrderDecision subclass: #DBuildDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DBuildDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:50'!
isBuildDecision
^ true! !
!DBuildDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:58'!
shouldFail
^ self shouldSucceed not! !
!DBuildDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:02'!
shouldSucceed
^ (order stage buildDeltaForPower: order unit power) > self successfulBuilds size! !
!DBuildDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:00'!
successfulBuilds
^ judge decisions select:
[:ea |
ea isBuildDecision
and: [ea order power = self order power]
and: [ea isSuccessful]]! !
!DBuildDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:37'!
updateStage: aStage
self isSuccessful ifTrue:
[aStage
move: order unit
to: order unitPosition
coast: order coast]! !
DOrderDecision subclass: #DDisbandDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DDisbandDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:12'!
isDisbandDecision
^ true! !
!DDisbandDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:09'!
shouldFail
^ false! !
!DDisbandDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:09'!
shouldSucceed
^ true! !
DOrderDecision subclass: #DDislodgeDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:40'!
coast
^ order unitPosition hasCoasts ifTrue:
[order stage occupiedCoastOf: order unitPosition]! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:11'!
isDislodgeDecision
^ true! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:39'!
moveDecision
^ order isMove ifTrue: [judge decisions detect: [:ea | ea isMoveDecision and: [ea order = order]]]! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:59'!
opposingMoves
^ judge decisions select: [:ea | ea isMoveDecision and: [ea target = order unitPosition]]! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:29'!
shouldFail
^ (self moveDecision notNil and: [self moveDecision isSuccessful])
or: [self opposingMoves allSatisfy: [:ea | ea isFailure]]! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:08'!
shouldSucceed
^ (self opposingMoves anySatisfy: [:ea | ea isSuccessful])
and: [self moveDecision isNil or: [self moveDecision isFailure]]! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:15'!
unit
^ order unit! !
!DDislodgeDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:39'!
updateStage: aStage
(self moveDecision notNil and: [self moveDecision isSuccessful]) ifFalse:
[self isSuccessful ifFalse:
[aStage
move: self unit
to: order unitPosition
coast: self coast]].
self isSuccessful ifTrue:
[aStage addRetreat: self unit from: self unitPosition]! !
DOrderDecision subclass: #DMoveDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:51'!
attackStrength
^ judge decisions detect: [:ea | ea isAttackStrength and: [ea move = order]]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:10'!
isHeadToHead
^ judge decisions anySatisfy:
[:ea |
ea isMoveDecision
and: [ea order isHeadToHeadWith: order]]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:39'!
isMoveDecision
^ true! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 00:42'!
move
^ order! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 5/28/2008 17:35'!
opposingDefendStrength
^ judge decisions detect: [:ea | ea isDefendStrength and: [ea unitPosition = order target]] ifNone: []! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:00'!
opposingHoldStrength
^ judge decisions detect: [:ea | ea isHoldStrength and: [ea place = order target]]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:00'!
opposingPreventStrengths
^ judge decisions select:
[:ea |
ea isPreventStrength
and: [ea move ~= order]
and: [ea target = order target]]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:03'!
shouldFail
^ (self isHeadToHead
ifTrue: [self attackStrength max <= self opposingDefendStrength min]
ifFalse: [self attackStrength max <= self opposingHoldStrength min])
or: [self opposingPreventStrengths anySatisfy: [:ea | self attackStrength max <= ea min]]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:04'!
shouldSucceed
^ (self isHeadToHead
ifTrue: [self attackStrength min > self opposingDefendStrength max]
ifFalse: [self attackStrength min > self opposingHoldStrength max])
and: [self opposingPreventStrengths allSatisfy: [:ea | self attackStrength min > ea max]]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:00'!
target
^ order target! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:38'!
updateStage: aStage
self isSuccessful ifTrue:
[aStage
move: order unit
to: order target
coast: order coast]! !
!DMoveDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:23'!
viewerClass
^ DMoveDecisionViewer! !
!DOrderDecision class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:28'!
order: anOrder
^ self basicNew setOrder: anOrder! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:14'!
= other
^ self species = other species and: [self order = other order]! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:45'!
isDecided
^ succeeds notNil! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:06'!
isFailure
^ self isDecided and: [self isSuccessful not]! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 04:07'!
isOrderDecision
^ true! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:46'!
isSuccessful
^ self isDecided and: [succeeds]! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:14'!
order
^ order! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:07'!
power
^ order unit power! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:14'!
setOrder: anOrder
order := anOrder! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:56'!
unitPosition
^ order unitPosition! !
!DOrderDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:36'!
update
self isDecided ifFalse:
[self shouldSucceed
ifTrue: [succeeds := true. ^ true]
ifFalse: [self shouldFail ifTrue: [succeeds := false. ^ true]]].
^ false! !
DOrderDecision subclass: #DPathDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:09'!
convoyMapWithOrders: aCollection
^ DConvoyMapBuilder
sources: (Array with: order unitPosition)
targets: (Array with: order target)
fleets: (aCollection collect: [:ea | ea unitPosition])! !
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:34'!
convoyOrdersWhereDislodge: aBlock
^ (judge decisions select:
[:ea |
ea isDislodgeDecision
and: [aBlock value: ea]
and: [ea order isConvoy]
and: [ea order convoyedOrder = order]])
collect: [:ea | ea order]! !
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:33'!
definiteConvoyOrders
^ self convoyOrdersWhereDislodge: [:ea | ea isFailure]! !
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:26'!
isPathDecision
^ true! !
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:33'!
possibleConvoyOrders
^ self convoyOrdersWhereDislodge: [:ea | ea isSuccessful not]! !
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:32'!
shouldFail
order canMoveToTarget ifTrue: [^ false].
^ (self convoyMapWithOrders: self possibleConvoyOrders) hasRoute not! !
!DPathDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 23:38'!
shouldSucceed
order canMoveToTarget ifTrue: [^ true].
^ (self convoyMapWithOrders: self definiteConvoyOrders) hasRoute! !
DOrderDecision subclass: #DRetreatDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DRetreatDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:50'!
isRetreatDecision
^ true! !
!DRetreatDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 15:01'!
opposingRetreats
^ judge decisions select:
[:ea |
ea isRetreatDecision
and: [ea ~= self]
and: [ea order target = self order target]]! !
!DRetreatDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:51'!
shouldFail
^ self opposingRetreats isEmpty not! !
!DRetreatDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:51'!
shouldSucceed
^ self opposingRetreats isEmpty! !
!DRetreatDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:38'!
updateStage: aStage
self isSuccessful ifTrue:
[aStage
move: order unit
to: order target
coast: order coast]! !
DOrderDecision subclass: #DSupportDecision
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DSupportDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:11'!
dislodgeDecision
^ judge decisions detect: [:ea | ea isDislodgeDecision and: [ea unit = order unit]]! !
!DSupportDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:42'!
isSupportDecision
^ true! !
!DSupportDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:58'!
opposingAttackStrengths
|all|
all := judge decisions select:
[:ea |
ea isAttackStrength and:
[ea move target = order unitPosition]].
^ self supportedOrder isMove
ifTrue: [all reject: [:ea | ea unitPosition = self supportedOrder target]]
ifFalse: [all]! !
!DSupportDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:06'!
shouldFail
^ (self opposingAttackStrengths anySatisfy: [:ea | ea min > 0])
or: [self dislodgeDecision isSuccessful]! !
!DSupportDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:06'!
shouldSucceed
^ (self opposingAttackStrengths allSatisfy: [:ea | ea max = 0])
and: [self dislodgeDecision isFailure]! !
!DSupportDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:56'!
supportedOrder
^ order supportedOrder! !
DDecision subclass: #DStrengthDecision
instanceVariableNames: 'min max'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
DStrengthDecision subclass: #DHoldStrength
instanceVariableNames: 'place'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DHoldStrength class methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:07'!
place: aPlace
^ self new setPlace: aPlace! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:06'!
= other
^ self species = other species and: [self place = other place]! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:15'!
allSupports
^ judge decisions select:
[:ea |
ea isSupportDecision
and: [ea supportedOrder isHold]
and: [ea supportedOrder unitPosition = place]]! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:29'!
calculateMax
^ self isPlaceEmpty
ifTrue: [0]
ifFalse:
[self moveOrder
ifNil: [1 + self possibleSupports size]
ifNotNilDo:
[:mv |
mv isSuccessful
ifTrue: [0]
ifFalse: [1]]]! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:28'!
calculateMin
^ self isPlaceEmpty
ifTrue: [0]
ifFalse:
[self moveOrder
ifNil: [1 + self successfulSupports size]
ifNotNilDo:
[:mv |
mv isFailure
ifTrue: [1]
ifFalse: [0]]]! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isHoldStrength
^true! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:15'!
isPlaceEmpty
^ judge decisions noneSatisfy: [:ea | ea isOrderDecision and: [ea unitPosition = place]]! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:16'!
moveOrder
^ judge decisions detect: [:ea | ea isMoveDecision and: [ea unitPosition = place]] ifNone: []! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:07'!
place
^ place! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 23:04'!
power
^ nil! !
!DHoldStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:07'!
setPlace: aPlace
place := aPlace! !
DStrengthDecision subclass: #DMoveStrength
instanceVariableNames: 'move'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
DMoveStrength subclass: #DAttackStrength
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DAttackStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:03'!
attackedUnitWhereMove: aBlock
self
decisionWhere: [:ea | ea isMoveDecision and: [ea order isHeadToHeadWith: move]]
unitDo: [:u | ^ u].
self
decisionWhere: [:ea | ea isDislodgeDecision and: [ea unitPosition = move target] and: [ea order isHold]]
unitDo: [:u | ^ u].
self
decisionWhere: [:ea | ea isMoveDecision and: [ea unitPosition = move target] and: [aBlock value: ea]]
unitDo: [:u | ^ u].
^ nil! !
!DAttackStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:34'!
calculateMax
self pathDecision isFailure ifTrue: [^ 0].
^ (self attackedUnitWhereMove: [:ea | ea isFailure])
ifNil: [1 + self possibleSupports size]
ifNotNilDo:
[:unit |
unit power = move unit power
ifTrue: [0]
ifFalse: [1 + (self possibleSupports reject: [:ea | ea order unit power = unit power]) size]]! !
!DAttackStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:35'!
calculateMin
self pathDecision isSuccessful ifFalse: [^ 0].
^ (self attackedUnitWhereMove: [:ea | ea isSuccessful not])
ifNil: [1 + self successfulSupports size]
ifNotNilDo:
[:unit |
unit power = move unit power
ifTrue: [0]
ifFalse: [1 + (self successfulSupports reject: [:ea | ea order unit power = unit power]) size]]! !
!DAttackStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:14'!
decisionWhere: selectBlock unitDo: doBlock
| decision |
decision := judge decisions detect: selectBlock ifNone: [^ self].
^ doBlock value: decision order unit
! !
!DAttackStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isAttackStrength
^true! !
DMoveStrength subclass: #DDefendStrength
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DDefendStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:08'!
calculateMax
^ 1 + self possibleSupports size! !
!DDefendStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:08'!
calculateMin
^ 1 + self successfulSupports size! !
!DDefendStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isDefendStrength
^true! !
!DMoveStrength class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:16'!
move: aMove
^ self new setMove: aMove! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:21'!
= other
^ self species = other species and: [self move = other move]! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:56'!
allSupports
^ judge decisions select: [:ea | ea isSupportDecision and: [ea supportedOrder = move]]! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:21'!
move
^ move! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:36'!
pathDecision
^ judge decisions detect: [:ea | ea isPathDecision and: [ea order = self move]]! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:07'!
power
^ move unit power! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:15'!
setMove: aMove
move := aMove! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:00'!
target
^ move target! !
!DMoveStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:57'!
unitPosition
^ move unitPosition! !
DMoveStrength subclass: #DPreventStrength
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DPreventStrength class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:16'!
move: aMove
^ self new setMove: aMove! !
!DPreventStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:36'!
calculateMax
self pathDecision isFailure ifTrue: [^ 0].
^ (self isHeadToHead and: [self opposingMove isSuccessful])
ifTrue: [0]
ifFalse: [1 + self possibleSupports size]! !
!DPreventStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:36'!
calculateMin
self pathDecision isSuccessful ifFalse: [^ 0].
^ (self isHeadToHead and: [self opposingMove isFailure not])
ifTrue: [0]
ifFalse: [1 + self successfulSupports size]! !
!DPreventStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:12'!
isHeadToHead
^ judge decisions anySatisfy:
[:ea |
ea isMoveDecision
and: [ea order isHeadToHeadWith: move]]! !
!DPreventStrength methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:53'!
isPreventStrength
^true! !
!DPreventStrength methodsFor: 'as yet unclassified' stamp: 'avi 5/28/2008 17:40'!
opposingMove
^ judge decisions detect:
[:ea |
ea isMoveDecision
and: [ea order isHeadToHeadWith: move]]! !
!DStrengthDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:07'!
initialize
min := 0.
max := 100! !
!DStrengthDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:44'!
max
^ max! !
!DStrengthDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:44'!
min
^ min! !
!DStrengthDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:43'!
possibleSupports
^ self allSupports select: [:ea | ea isFailure not]! !
!DStrengthDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:43'!
successfulSupports
^ self allSupports select: [:ea | ea isSuccessful]! !
!DStrengthDecision methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:37'!
update
| oldMax oldMin |
oldMax := max.
oldMin := min.
max := self calculateMax.
min := self calculateMin.
^ {max. min} ~= {oldMax. oldMin}! !
Object subclass: #DDecisionViewer
instanceVariableNames: 'decision'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
DDecisionViewer subclass: #DBlankDecisionViewer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DBlankDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:38'!
renderOn: html! !
DDecisionViewer subclass: #DBuildDecisionViewer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DBuildDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:25'!
renderItemOn: html
html text: 'Build '.
html text: decision order unit typeName.
html text: ' at '.
html text: decision order unitPosition name.
self renderSuccessOn: html! !
!DDecisionViewer class methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:19'!
decision: aDecision
^ self basicNew setDecision: aDecision! !
!DDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 21:35'!
renderMove: aMove on: html
html emphasis class: 'start'; with: aMove unitPosition name.
html space.
html image
resourceUrl: 'img/forward.png';
altText: '->';
width: 10;
height: 10.
html space.
html emphasis class: 'end'; with: aMove target name! !
!DDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 17:22'!
renderOn: html
html listItem class: decision power id; with: [self renderItemOn: html]! !
!DDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:05'!
renderStrength: aStrength on: html
html text: ' (', aStrength max asString, ')'! !
!DDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 21:35'!
renderSuccessOn: html
decision isSuccessful
ifFalse: [html emphasis class: 'resultFailure'; with: ' (Failed)'].! !
!DDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 17:21'!
setDecision: aDecision
decision := aDecision! !
DDecisionViewer subclass: #DDisbandDecisionViewer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DDisbandDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:25'!
renderItemOn: html
html text: 'Disbanded: ', decision order unitPosition name! !
DDecisionViewer subclass: #DMoveDecisionViewer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DMoveDecisionViewer class methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 00:48'!
moveDecision: aMoveDecision
^ self basicNew setMoveDecision: aMoveDecision! !
!DMoveDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:40'!
renderAttackOn: html
html unorderedList:
[decision attackStrength allSupports do:
[:ea |
html listItem: [self renderSupport: ea on: html]]]! !
!DMoveDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:40'!
renderHoldOn: html
| hold |
hold := decision opposingHoldStrength.
hold moveOrder
ifNil: [hold allSupports isEmpty
ifTrue: [html heading level: 5; with: 'Against Hold']
ifFalse:
[html heading level: 5; with: 'Against Supported Hold (', hold max asString, ')'.
html unorderedList:
[hold allSupports do:
[:ea |
html listItem: [self renderSupport: ea on: html]]]]]
ifNotNilDo:
[:mv |
mv isSuccessful ifFalse:
[html heading level: 5; with:
[html text: 'Against Failed Move: '.
self renderMove: mv on: html]]]! !
!DMoveDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:06'!
renderItemOn: html
self renderMove: decision move on: html.
self renderSuccessOn: html.
decision attackStrength allSupports isEmpty ifFalse:
[html heading level: 5; with:
[html text: 'Support'.
self renderStrength: decision attackStrength on: html].
self renderAttackOn: html].
decision opposingHoldStrength isPlaceEmpty ifFalse:
[self renderHoldOn: html].
decision opposingPreventStrengths do:
[:ea |
html heading level: 5; with:
[html text: 'Against '.
self renderPrevent: ea on: html]]! !
!DMoveDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 16:05'!
renderPrevent: aPreventStrength on: html
self renderMove: aPreventStrength move on: html.
self renderStrength: aPreventStrength on: html! !
!DMoveDecisionViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/12/2008 15:07'!
renderSupport: aSupportDecision on: html
html text: aSupportDecision unitPosition name.
aSupportDecision isFailure ifTrue:
[html break.
html emphasis class: 'cut'; with:
[html text: '(cut by '.
self renderMove:
(aSupportDecision opposingAttackStrengths detect: [:ea | ea max > 0] ifNone: [^ html text: 'ERROR)']) move
on: html.
html text: ')']]! !
Object subclass: #DGame
instanceVariableNames: 'name map stages users token deadline duration timeouts inTimeout'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Users'!
!DGame class methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:05'!
map: aMap
^ self basicNew setMap: aMap! !
!DGame class methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:06'!
new
^ self map: DStandardMap new! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:02'!
addUser: aUser
(self allUsers includes: aUser) ifFalse: [users at: aUser put: self randomPower]! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 5/8/2008 13:24'!
advanceTurn
self tryToAdvance.
deadline := self nextDeadline! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:21'!
allUsers
^ users keys! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/10/2008 21:05'!
canStart
^ self allUsers size = self map powers size! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 17:19'!
clearTimeout
inTimeout := false! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 2/1/2009 22:54'!
currentStage
|shouldSave|
shouldSave := false.
self isAbandoned ifFalse:
[[self deadline < DateAndTime now] whileTrue:
[self advanceTurn.
shouldSave := true].
shouldSave ifTrue: [self save]].
^ self stages last! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/22/2008 17:45'!
deadline
^ deadline ifNil: [deadline := self firstDeadline]! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 5/7/2008 01:40'!
deadline: aDateAndTime
deadline := aDateAndTime! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/22/2008 17:45'!
firstDeadline
^ DateAndTime now + self stageDuration! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 2/1/2009 22:52'!
isAbandoned
^ (DateAndTime now - self deadline) / self stageDuration > 20! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 17:17'!
isInTimeout
^ inTimeout ifNil: [false]! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:19'!
map
^ map! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:05'!
name
^ name ifNil:
[String streamContents:
[:s |
self allUsers
do: [:ea | s nextPutAll: ea name]
separatedBy: [s nextPutAll: ', ']]]! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:06'!
name: aString
name := aString! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/22/2008 17:44'!
nextDeadline
^ deadline + self stageDuration! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 02:03'!
nextStage
^ stages addLast: (DStage new fromPreviousStage: self stages last)! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:00'!
powerForUser: aUser
^ users at: aUser! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:26'!
randomPower
^ (map powers difference: users values) atRandom! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/21/2008 17:59'!
replaceUser: aUser with: otherUser
users at: otherUser put: (self powerForUser: aUser).
users removeKey: aUser! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 2/1/2009 22:54'!
save
DDatabase default saveGame: self! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/22/2008 17:45'!
setMap: aMap
map := aMap.
stages := OrderedCollection with: map firstStage.
users := Dictionary new.
deadline := self firstDeadline! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/12/2008 00:08'!
stageDuration
^ duration ifNil: [24 hours]! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/22/2008 17:45'!
stageDuration: aDuration
duration := aDuration.
deadline := self firstDeadline! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:16'!
stages
^ stages! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 17:19'!
startTimeout
self stages last powersWithoutOrders do:
[:ea |
timeouts at: ea put: (((self timeoutsForPower: ea) - 1) max: 0)].
inTimeout := true! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 02:06'!
timeLeft
^ deadline - DateAndTime now! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 02:16'!
timeoutsForPower: aPower
timeouts ifNil: [timeouts := Dictionary new].
^ timeouts at: aPower ifAbsent: [10]! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/10/2008 21:22'!
token
^ token ifNil: [token := WAExternalID new asString].! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 17:18'!
tryToAdvance
self isInTimeout ifTrue:
[self clearTimeout.
^ self nextStage].
(self stages last powersWithoutOrders anySatisfy:
[:ea |
(self timeoutsForPower: ea) > 0])
ifFalse: [^ self nextStage].
self startTimeout.! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:33'!
userForPower: aPower
users keysAndValuesDo:
[:k :v |
v = aPower ifTrue: [^ k]].
^ nil! !
!DGame methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 23:05'!
userMap
|dict p|
dict := Dictionary new.
map powers do:
[:ea |
p := Dictionary new.
p at: 'timeouts' put: (self timeoutsForPower: p).
(self userForPower: ea) ifNotNilDo:
[:u |
p at: 'user' put: u email].
dict at: ea id put: p].
^ dict! !
Object subclass: #DJudge
instanceVariableNames: 'decisions'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Judge'!
!DJudge class methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 00:19'!
decisionsForOrders: aCollection
^ self new
addOrders: aCollection;
makeDecisions;
decisions! !
!DJudge methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:23'!
addDecision: aDecision
self decisions addIfNotPresent: aDecision.
aDecision setJudge: self! !
!DJudge methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:19'!
addOrders: aCollection
aCollection do: [:ea | ea addDecisionsTo: self]! !
!DJudge methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 15:23'!
decisions
^ decisions ifNil: [decisions := OrderedCollection new]! !
!DJudge methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:38'!
makeDecisions
[self tryMakingDecisions] whileTrue! !
!DJudge methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:38'!
tryMakingDecisions
|decisionMade|
decisionMade := false.
self decisions do: [:ea | ea update ifTrue: [decisionMade := true]].
^ decisionMade! !
Object subclass: #DMap
instanceVariableNames: 'places powers'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:17'!
initialize
places := OrderedCollection new.
powers := OrderedCollection new! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:37'!
landNamed: aString
^ self placeNamed: aString ifAbsentPut: [DLand name: aString]! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:08'!
placeNamed: aString
^ places detect: [:ea | ea name = aString] ifNone: []! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:37'!
placeNamed: aString ifAbsentPut: aBlock
^ places detect: [:ea | ea name = aString] ifNone: [places addLast: aBlock value]! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:28'!
places
^ places! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:38'!
powerNamed: aString
^ powers detect: [:ea | ea name = aString] ifNone: [powers addLast: (DPower name: aString)]! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:27'!
powers
^ powers! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:38'!
seaNamed: aString
^ self placeNamed: aString ifAbsentPut: [DSea name: aString]! !
!DMap methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:58'!
supplyCenterNamed: aString
^ self placeNamed: aString ifAbsentPut: [DSupplyCenter name: aString]! !
DMap subclass: #DStandardMap
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 10:41'!
buildMap
| placeAbbrevs place |
placeAbbrevs := Dictionary new.
self nonSupplyLandNames do:
[:ea |
placeAbbrevs at: ea first asLowercase put: (self landNamed: ea second)].
self supplyNames do:
[:ea |
placeAbbrevs at: ea first asLowercase put: (self supplyCenterNamed: ea second)].
self seaNames do:
[:ea |
placeAbbrevs at: ea first asLowercase put: (self seaNamed: ea second)].
self neighborList do:
[:array |
place := placeAbbrevs at: array first.
array second do: [:ea | place addNeighbor: (placeAbbrevs at: ea)]].
self northCoasts do:
[:array |
place := placeAbbrevs at: array first.
array second do: [:ea | place addNeighbor: (placeAbbrevs at: ea) coast: #north]].
self eastCoasts do:
[:array |
place := placeAbbrevs at: array first.
array second do: [:ea | place addNeighbor: (placeAbbrevs at: ea) coast: #east]].
self southCoasts do:
[:array |
place := placeAbbrevs at: array first.
array second do: [:ea | place addNeighbor: (placeAbbrevs at: ea) coast: #south]].! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 10:46'!
eastCoasts
^ #((bul (rum bla con)))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:14'!
firstStage
| stage power unit place |
stage := DStage map: self.
self startingUnits do:
[:ea |
power := self powerNamed: ea first.
ea allButFirst do:
[:array |
unit := array first = #A
ifTrue: [power buildArmy]
ifFalse: [power buildFleet].
place := self placeNamed: array second.
stage move: unit to: place coast: nil.
stage control: place with: power.
place homePower: power]].
self homeProvinces do:
[:ea |
power := self powerNamed: ea first.
ea allButFirst do:
[:p |
stage control: (self placeNamed: p) with: power]].
^ stage! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 23:38'!
homeProvinces
^
#(('England' 'Clyde' 'Yorkshire' 'Wales')
('France' 'Picardy' 'Gascony' 'Burgundy')
('Germany' 'Ruhr' 'Silesia' 'Prussia')
('Austria' 'Tyrolia' 'Bohemia' 'Galicia')
('Italy' 'Apulia' 'Tuscany' 'Piedmont')
('Turkey' 'Armenia' 'Syria')
('Russia' 'Ukraine' 'Livonia' 'Finland'))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:53'!
initialize
super initialize.
self buildMap! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:56'!
landNames
^
#(('Alb' 'Albania')
('Ank' 'Ankara')
('Apu' 'Apulia')
('Arm' 'Armenia')
('Bel' 'Belgium')
('Ber' 'Berlin')
('Boh' 'Bohemia')
('Bre' 'Brest')
('Bud' 'Budapest')
('Bul' 'Bulgaria')
('Bur' 'Burgundy')
('Cly' 'Clyde')
('Con' 'Constantinople')
('Den' 'Denmark')
('Edi' 'Edinburgh')
('Fin' 'Finland')
('Gal' 'Galicia')
('Gas' 'Gascony')
('Gre' 'Greece')
('Hol' 'Holland')
('Kie' 'Kiel')
('Lvp' 'Liverpool')
('Lvn' 'Livonia')
('Lon' 'London')
('Mar' 'Marseilles')
('Mos' 'Moscow')
('Mun' 'Munich')
('Nap' 'Naples')
('Naf' 'North Africa')
('Nwy' 'Norway')
('Par' 'Paris')
('Pic' 'Picardy')
('Pie' 'Piedmont')
('Por' 'Portugal')
('Pru' 'Prussia')
('Rom' 'Rome')
('Ruh' 'Ruhr')
('Rum' 'Rumania')
('Ser' 'Serbia')
('Sev' 'Sevastopol')
('Sil' 'Silesia')
('Smy' 'Smyrna')
('Spa' 'Spain')
('Stp' 'St. Petersburg')
('Swe' 'Sweden')
('Syr' 'Syria')
('Tri' 'Trieste')
('Tun' 'Tunis')
('Tus' 'Tuscany')
('Trl' 'Tyrolia')
('Ukr' 'Ukraine')
('Ven' 'Venice')
('Vie' 'Vienna')
('Wal' 'Wales')
('War' 'Warsaw')
('Yor' 'Yorkshire'))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:02'!
neighborList
^
#((ukr (rum gal mos war sev))
(wes (naf lyo mao tys tun spa))
(wal (iri lvp eng yor lon))
(eas (ion syr aeg smy))
(spa (por lyo mao wes gas mar))
(cly (nao edi lvp nwg))
(bur (pic bel par mun ruh gas mar))
(nao (iri cly mao lvp nwg))
(bot (fin lvn swe bal stp))
(nwy (fin bar nth swe ska stp nwg))
(bud (rum tri gal ser vie))
(aeg (gre bul ion eas smy con))
(yor (nth lvp wal edi lon))
(pie (lyo tus trl ven mar))
(adr (tri apu alb ion ven))
(bla (rum ank bul sev arm con))
(par (gas pic bre bur))
(ser (rum tri gre bul bud alb))
(smy (syr ank eas arm aeg con))
(rom (nap tus apu tys ven))
(mos (ukr lvn war sev stp))
(gas (spa par bur mao bre mar))
(stp (fin lvn mos nwy bar bot))
(gal (rum ukr bud war vie boh sil))
(lvn (stp bot mos war bal pru))
(ion (nap gre eas aeg tun adr apu alb tys))
(alb (tri gre adr ser ion))
(sev (rum bla ukr mos arm))
(bar (nwy stp nwg))
(tus (pie lyo tys ven rom))
(nap (apu ion tys rom))
(rum (bla ukr gal ser sev bud bul))
(ber (sil mun kie bal pru))
(ank (bla arm smy con))
(bul (rum bla gre ser aeg con))
(mun (trl ber bur ruh kie boh sil))
(nth (nwy den hol yor edi nwg eng bel ska hel lon))
(por (mao spa))
(tys (nap tus lyo wes ion tun rom))
(hel (hol kie nth den))
(ven (pie tri tus adr apu trl rom))
(iri (lvp mao nao wal eng))
(gre (bul ser alb aeg ion))
(den (nth swe kie ska bal hel))
(kie (ber den mun ruh hol hel bal))
(con (bla ank bul aeg smy))
(naf (wes tun mao))
(sil (ber gal mun war pru boh))
(lyo (spa pie tus wes tys mar))
(pic (bel par bur eng bre))
(hol (bel nth kie ruh hel))
(bal (ber lvn den swe kie pru bot))
(nwg (nth cly nao nwy edi bar))
(bel (pic nth bur hol ruh eng))
(apu (nap adr ion ven rom))
(war (lvn mos ukr gal pru sil))
(boh (gal mun trl vie sil))
(lon (wal yor nth eng))
(swe (fin nwy den ska bot bal))
(edi (nth lvp cly yor nwg))
(eng (iri bel nth mao wal pic lon bre))
(mar (pie lyo bur gas spa))
(fin (nwy bot stp swe))
(pru (ber lvn war bal sil))
(trl (pie tri mun vie ven boh))
(bre (pic par mao eng gas))
(lvp (iri cly wal nao edi yor))
(tun (naf ion tys wes))
(syr (eas arm smy))
(tri (adr bud ser alb trl vie ven))
(mao (iri por wes eng gas spa naf nao bre))
(ruh (bel hol mun kie bur))
(arm (syr bla ank sev smy))
(ska (den swe nth nwy))
(vie (tri gal bud trl boh)))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:57'!
nonSupplyLandNames
^ self landNames difference: self supplyNames! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 10:40'!
northCoasts
^
#((spa (por mao gas))
(stp (nwy bar)))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 17:24'!
seaNames
^
#(('Adr' 'Adriatic Sea')
('Aeg' 'Aegean Sea')
('Bal' 'Baltic Sea')
('Bar' 'Barents Sea')
('Bla' 'Black Sea')
('Eas' 'Eastern Mediterranean')
('Eng' 'English Channel')
('Bot' 'Gulf of Bothnia')
('Lyo' 'Gulf of Lyon')
('Hel' 'Helgoland Bight')
('Ion' 'Ionian Sea')
('Iri' 'Irish Sea')
('Mao' 'Mid-Atlantic Ocean')
('Nao' 'North Atlantic Ocean')
('Nth' 'North Sea')
('Nwg' 'Norwegian Sea')
('Ska' 'Skagerrak')
('Tys' 'Tyrrhenian Sea')
('Wes' 'Western Mediterranean'))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:15'!
southCoasts
^
#((spa (por lyo mao wes mar))
(stp (fin lvn bot))
(bul (gre aeg con)))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:19'!
startingUnits
^
#(('England' (A 'Liverpool') (F 'Edinburgh') (F 'London'))
('France' (A 'Paris') (A 'Marseilles') (F 'Brest'))
('Germany' (A 'Munich') (A 'Berlin') (F 'Kiel'))
('Italy' (A 'Venice') (A 'Rome') (F 'Naples'))
('Austria' (A 'Vienna') (A 'Budapest') (F 'Trieste'))
('Russia' (A 'Moscow') (A 'Warsaw') (F 'St. Petersburg') (F 'Sevastopol'))
('Turkey' (A 'Constantinople') (A 'Smyrna') (F 'Ankara')))! !
!DStandardMap methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:56'!
supplyNames
^
#(('Ank' 'Ankara')
('Bel' 'Belgium')
('Ber' 'Berlin')
('Bre' 'Brest')
('Bud' 'Budapest')
('Bul' 'Bulgaria')
('Con' 'Constantinople')
('Den' 'Denmark')
('Edi' 'Edinburgh')
('Gre' 'Greece')
('Hol' 'Holland')
('Kie' 'Kiel')
('Lvp' 'Liverpool')
('Lon' 'London')
('Mar' 'Marseilles')
('Mos' 'Moscow')
('Mun' 'Munich')
('Nap' 'Naples')
('Nwy' 'Norway')
('Par' 'Paris')
('Por' 'Portugal')
('Rom' 'Rome')
('Rum' 'Rumania')
('Ser' 'Serbia')
('Sev' 'Sevastopol')
('Smy' 'Smyrna')
('Spa' 'Spain')
('Stp' 'St. Petersburg')
('Swe' 'Sweden')
('Tri' 'Trieste')
('Tun' 'Tunis')
('Ven' 'Venice')
('Vie' 'Vienna')
('War' 'Warsaw'))! !
Object subclass: #DMapViewer
instanceVariableNames: 'stage power'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DMapViewer class methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:00'!
stage: aStage power: aPower
^ self basicNew setStage: aStage power: aPower! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:22'!
divFor: aPlace on: html
^ html div id: aPlace id! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:11'!
numColorDivs
^ 5! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:21'!
renderFactory: aPower on: html
aPower = power ifFalse: [^ self].
html image
resourceUrl: 'img/build/', aPower name asLowercase, '.png';
altText: '';
width: 41;
height: 42;
class: 'build'! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:12'!
renderImagesOn: html
html image
id: 'map';
resourceUrl: 'img/map.png'.
html image
id: 'mapNames';
resourceUrl: 'img/names.png'.
! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:12'!
renderOn: html
self renderImagesOn: html.
self renderPlacesOn: html! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 20:01'!
renderPlace: aPlace on: html
| pow unit canBuild coast |
pow := self stage controllingPowerFor: aPlace.
unit := self stage unitAt: aPlace.
canBuild := self stage isBuildStage and: [self stage canBuildAt: aPlace].
coast := aPlace hasCoasts ifTrue: [self stage occupiedCoastOf: aPlace].
(self divFor: aPlace on: html)
class: 'territory';
class: aPlace typeName;
class: (pow ifNil: [''] ifNotNil: [pow name asLowercase]);
class: (canBuild ifFalse: [''] ifTrue: [aPlace isWaterfront ifTrue: ['buildAny'] ifFalse: ['buildArmy']]);
with:
[(1 to: self numColorDivs) do: [:i | html div class: 'color'; id: 'color', i asString].
unit ifNotNil: [self renderUnit: unit coast: coast on: html].
canBuild ifTrue: [self renderFactory: pow on: html].
(self stage retreatingUnitAt: aPlace) ifNotNilDo: [: u | self renderRetreatingUnit: u on: html]]
! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:14'!
renderPlacesOn: html
html div class: 'territories'; with:
[self stage map places do:
[:ea |
self renderPlace: ea on: html]]! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:04'!
renderRetreatingUnit: unit on: html
html image
resourceUrl: 'img/', unit typeName, '/', unit power name asLowercase, '.png';
altText: '';
width: unit imageWidth;
height: unit imageHeight;
class: unit typeName;
class: 'retreating'! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:04'!
renderUnit: unit coast: aSymbol on: html
html image
resourceUrl: 'img/', unit typeName, '/', unit power name asLowercase, '.png';
altText: '';
width: unit imageWidth;
height: unit imageHeight;
class: unit typeName;
class: (aSymbol ifNil: [''] ifNotNil: [aSymbol, 'Coast'])! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 11:59'!
setStage: aStage power: aPower
stage := aStage.
power := aPower! !
!DMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:10'!
stage
^ stage! !
DMapViewer subclass: #DMiniMapViewer
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DMiniMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:22'!
divFor: aPlace on: html
^ html div class: aPlace id! !
!DMiniMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:19'!
numColorDivs
^ 1! !
!DMiniMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:19'!
renderFactory: aPower on: html! !
!DMiniMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:20'!
renderImagesOn: html
html image
class: 'miniMap';
resourceUrl: 'img/mapMini.png';
width: 94;
height: 94.! !
!DMiniMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:19'!
renderRetreatingUnit: unit on: html! !
!DMiniMapViewer methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 00:19'!
renderUnit: unit coast: aSymbol on: html! !
Object subclass: #DMenuViewer
instanceVariableNames: 'stage power'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DMenuViewer class methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:22'!
stage: aStage power: aPower
^ self basicNew setStage: aStage power: aPower! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 13:59'!
buildSpecs
^ #((build
(Army left)
(Fleet right)))! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 14:00'!
coastSpecs
^ #((coast
(North top)
(East right)
(South bottom)
(West left)))! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:26'!
disbandSpecs
^ #((disband
(Disband top)))! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 18:42'!
moveSpecs
^ #((army
(Move left)
(Support top)
(Hold right))
(fleet
(Move left)
(Support top)
(Hold right)
(Convoy bottom))
(support
(Move left)
(Hold right)))! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 14:03'!
renderMenuItem: aString position: posString prefix: prefixString on: html
| id |
html listItem class: posString; with:
[prefixString = 'coast' ifTrue:
[id := aString asLowercase, 'CoastButton']
ifFalse:
[id := prefixString, aString, 'Button'].
html anchor
url: 'javascript:void';
id: id;
with: aString]! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:23'!
renderOn: html
self renderSpecs: self coastSpecs on: html.
stage isRetreatStage ifTrue: [^ self renderSpecs: self retreatSpecs on: html].
stage isBuildStage ifTrue:
[(stage buildDeltaForPower: power) < 0 ifTrue: [^ self renderSpecs: self disbandSpecs on: html].
^ self renderSpecs: self buildSpecs on: html].
self renderSpecs: self moveSpecs on: html! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 23:56'!
renderSpecs: anArray on: html
| prefix |
anArray do:
[:ea |
prefix := ea first.
html div class: 'menu'; id: prefix, 'Menu'; style: 'display: none'; with:
[(#(fleet army) includes: prefix) ifFalse:
[html heading level: 4; with: prefix capitalized].
html unorderedList:
[ea allButFirst do:
[:s |
self renderMenuItem: s first position: s second prefix: prefix on: html]]]]! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 18:41'!
retreatSpecs
^ #((retreat
(Move left)
(Disband top)))! !
!DMenuViewer methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:24'!
setStage: aStage power: aPower
stage := aStage.
power := aPower! !
Object subclass: #DOrder
instanceVariableNames: 'unit stage'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
DOrder subclass: #DBuildOrder
instanceVariableNames: 'place coast'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:48'!
addDecisionsTo: aJudge
aJudge addDecision: (DBuildDecision order: self)! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:31'!
asArray
| array |
array := #('build') copyWith: unit typeName.
coast ifNotNil: [array := array copyWith: coast].
^ array! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 15:21'!
coast
^ place hasCoasts ifTrue: [coast ifNil: [#south]]! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 15:21'!
coast: aSymbol
coast := aSymbol asSymbol! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/19/2008 02:10'!
isBuild
^ true! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:53'!
isValid
^ true! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:49'!
place: aPlace
place := aPlace! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:46'!
power
^ unit power! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:37'!
target
^ place! !
!DBuildOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:46'!
unitPosition
^ place! !
DOrder subclass: #DDisbandOrder
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DDisbandOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:10'!
addDecisionsTo: aJudge
aJudge addDecision: (DDisbandDecision order: self)! !
!DDisbandOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:36'!
asArray
^ #('disband')! !
!DDisbandOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/19/2008 02:10'!
isDisband
^ true! !
!DDisbandOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:12'!
isValid
^ true! !
DOrder subclass: #DHoldOrder
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
DHoldOrder subclass: #DConvoyOrder
instanceVariableNames: 'order'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:19'!
= other
^ super = other and: [self convoyedOrder = other convoyedOrder]! !
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:35'!
asArray
^ #('convoy') copyWith: order asDictionary! !
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:19'!
convoyedOrder
^ order! !
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:19'!
convoyedOrder: anOrder
order := anOrder! !
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:24'!
isConvoy
^ true! !
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:19'!
isValid
^ true! !
!DConvoyOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:19'!
typeName
^ 'convoy'! !
!DHoldOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:31'!
asArray
^ #('hold')! !
!DHoldOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:11'!
isHold
^ true! !
!DHoldOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 04:10'!
isValid
^ true! !
!DHoldOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 19:12'!
printExtraOn: aStream
aStream nextPutAll: self unitPosition name! !
!DHoldOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 21:46'!
typeName
^ 'hold'! !
DHoldOrder subclass: #DSupportOrder
instanceVariableNames: 'order'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:18'!
= other
^ super = other and: [self supportedOrder = other supportedOrder]! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 03:53'!
addDecisionsTo: aJudge
super addDecisionsTo: aJudge.
aJudge addDecision: (DSupportDecision order: self)! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:35'!
asArray
^ #('support') copyWith: order asDictionary! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:11'!
isSupport
^ true! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/23/2008 18:21'!
isValid
order isMove ifTrue: [^ self unitCanMoveTo: order target].
order isHold ifTrue: [^ self unitCanMoveTo: order unitPosition].
^ false! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 19:12'!
printExtraOn: aStream
aStream nextPutAll: self unitPosition name, ': '.
order printOn: aStream! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 21:48'!
supportedOrder
^ order stage: stage! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:17'!
supportedOrder: anOrder
order := anOrder! !
!DSupportOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 21:47'!
typeName
^ 'support'! !
!DOrder class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:49'!
unit: aUnit
^ self basicNew setUnit: aUnit! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:24'!
= other
^ other species = self species
and: [other unit = self unit]! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:13'!
addDecisionsTo: aJudge
aJudge addDecision: (DDislodgeDecision order: self)! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:38'!
asDictionary
^ Dictionary new
at: self unitPosition id
put: self asArray;
yourself! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:41'!
coast
^ nil! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:09'!
hash
^ unit hash! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/19/2008 02:10'!
isBuild
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:06'!
isCancel
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:24'!
isConvoy
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/19/2008 02:10'!
isDisband
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:11'!
isHold
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:50'!
isMove
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/18/2008 01:23'!
isRetreat
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:11'!
isSupport
^ false! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:30'!
jsonWriteOn: aStream
self asArray jsonWriteOn: aStream! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:35'!
power
^ unit power! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:35'!
printOn: aStream
self jsonWriteOn: aStream! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:22'!
setUnit: aUnit
unit := aUnit! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:09'!
stage
^ stage! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:55'!
stage: aStage
stage := aStage! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:22'!
unit
^ unit! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/23/2008 18:20'!
unitCanMoveTo: aPlace
^ unit canMoveTo: aPlace inStage: stage! !
!DOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:13'!
unitPosition
^ stage positionOf: unit! !
DOrder subclass: #DTargetOrder
instanceVariableNames: 'target coast'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
DTargetOrder subclass: #DMoveOrder
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:26'!
addDecisionsTo: aJudge
super addDecisionsTo: aJudge.
aJudge
addDecision: (DMoveDecision order: self);
addDecision: (DPathDecision order: self);
addDecision: (DAttackStrength move: self);
addDecision: (DPreventStrength move: self);
addDecision: (DDefendStrength move: self);
addDecision: (DHoldStrength place: self target)! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:33'!
asArray
|array|
array := #('move') copyWith: target id.
coast ifNotNil: [array := array copyWith: coast].
^ array! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 00:50'!
canBeConvoyed
^ (stage convoyMap at: self unitPosition) includes: target! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 15:21'!
coast
^ target hasCoasts ifTrue:
[coast ifNil: [target coastOfNeighbor: self unitPosition]]! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:58'!
isHeadToHeadWith: aMoveOrder
^ aMoveOrder target = self unitPosition
and: [aMoveOrder unitPosition = self target]! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:50'!
isMove
^ true! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 21:41'!
isValid
^ self canMoveToTarget or: [self canBeConvoyed]! !
!DMoveOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 21:47'!
typeName
^ 'move'! !
DTargetOrder subclass: #DRetreatOrder
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DRetreatOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:48'!
addDecisionsTo: aJudge
aJudge addDecision: (DRetreatDecision order: self)! !
!DRetreatOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 18:33'!
asArray
|array|
array := #('retreat') copyWith: target id.
coast ifNotNil: [array := array copyWith: coast].
^ array! !
!DRetreatOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 15:21'!
coast
^ target hasCoasts ifTrue:
[coast ifNil: [target coastOfNeighbor: self retreatPosition]]! !
!DRetreatOrder methodsFor: 'as yet unclassified' stamp: 'avi 4/18/2008 01:23'!
isRetreat
^ true! !
!DRetreatOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 21:41'!
isValid
self canMoveToTarget ifFalse: [^ false].
(stage unitAt: target) ifNotNil: [^ false].
(stage decisions anySatisfy:
[:ea |
ea isMoveDecision
and: [ea isSuccessful]
and: [ea move unitPosition = target]
and: [ea move target = self retreatPosition]]) ifTrue: [^ false].
(stage decisions anySatisfy:
[:ea |
ea isPreventStrength
and: [ea min > 0]
and: [ea move target = target]]) ifTrue: [^ false].
^ true! !
!DRetreatOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 15:06'!
retreatPosition
^ stage retreatPositionOf: unit! !
!DTargetOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:49'!
= other
^ super = other and: [other target = self target]! !
!DTargetOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 21:40'!
canMoveToTarget
^ self unitCanMoveTo: target! !
!DTargetOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/29/2008 15:20'!
coast: aSymbol
coast := aSymbol asSymbol! !
!DTargetOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:49'!
printExtraOn: aStream
aStream nextPutAll: self unitPosition name, ' -> ', self target name! !
!DTargetOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:49'!
target
^ target! !
!DTargetOrder methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:49'!
target: aPlace
target := aPlace! !
Object subclass: #DOrderParser
instanceVariableNames: 'stage'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-UI'!
!DOrderParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/31/2008 17:35'!
parseString: aString stage: aStage
^ (self stage: aStage) parseString: aString! !
!DOrderParser class methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 19:04'!
stage: aStage
^ self basicNew setStage: aStage! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:37'!
addCoast: aSymbol to: order
(order target hasCoasts and: [aSymbol notNil]) ifTrue: [order coast: aSymbol]! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:30'!
buildAt: aPlace with: kind with: coast
|power order|
power := stage controllingPowerFor: aPlace.
order := kind = 'army'
ifTrue: [power buildArmyAt: aPlace]
ifFalse: [power buildFleetAt: aPlace].
self addCoast: coast to: order.
^ order
! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:38'!
cancelAt: place with: ignore with: ignore2
^ DCancelOrder place: place! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:36'!
convoyAt: place with: json with: ignore
|unit|
unit := stage unitAt: place.
^ unit convoyOrder: ((self ordersForJson: json) at: 1 ifAbsent: [^ nil])! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:36'!
disbandAt: place with: ignore with: ignore2
^ (stage unitAt: place) ifNotNilDo: [:u | u disband]! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:07'!
holdAt: place with: ignore with: ignore2
^ (stage unitAt: place) ifNotNilDo: [:u | u hold]! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:32'!
moveAt: place with: targetName with: coast
|unit order|
unit := stage unitAt: place.
order := unit moveTo: (self placeWithId: targetName).
self addCoast: coast to: order.
^ order! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:26'!
orderFor: anAssociation
| place orderType selector |
place := self placeWithId: anAssociation key.
orderType := anAssociation value first.
selector := (orderType, 'At:with:with:') asSymbol.
^ (self respondsTo: selector) ifTrue:
[self
perform: selector
with: place
with: (anAssociation value at: 2 ifAbsent: [])
with: (anAssociation value at: 3 ifAbsent: [])]! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 12:45'!
ordersForJson: aJson
^ ((aJson properties collect: [:ea | self orderFor: ea])
select: [:ea | ea notNil])
collect: [:ea | ea stage: stage; yourself]! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 19:03'!
parseStream: aStream
^ self ordersForJson: (Json readFrom: aStream)! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/31/2008 17:33'!
parseString: aString
^ self parseStream: aString readStream! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:12'!
placeWithId: aString
^ stage map places detect: [:ea | ea id = aString]! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:35'!
retreatAt: place with: targetName with: coast
|unit order|
unit := stage retreatingUnitAt: place.
order := unit retreatTo: (self placeWithId: targetName).
self addCoast: coast to: order.
^ order! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 19:04'!
setStage: aStage
stage := aStage! !
!DOrderParser methodsFor: 'as yet unclassified' stamp: 'avi 3/30/2008 10:34'!
supportAt: place with: json with: ignore
|unit|
unit := stage unitAt: place.
^ unit supportOrder: ((self ordersForJson: json) at: 1 ifAbsent: [^ nil])! !
Object subclass: #DPlace
instanceVariableNames: 'neighbors name'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
DPlace subclass: #DLand
instanceVariableNames: 'coasts'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:47'!
addNeighbor: aPlace coast: aSymbol
^ (coasts at: aSymbol ifAbsentPut: [Set new]) add: aPlace! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:00'!
coastOfNeighbor: aPlace
coasts keysAndValuesDo:
[:c :n |
(n includes: aPlace) ifTrue: [^ c]].
^ nil! !
!DLand methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 11:03'!
hasCoast: aSelector
^ coasts includesKey: aSelector! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:47'!
hasCoasts
^ coasts isEmpty not! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:01'!
isLand
^ true! !
!DLand methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 11:05'!
neighborsForCoast: aSelector
^ coasts at: aSelector! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:47'!
neighborsOfCoast: aSymbol
^ coasts at: aSymbol ifAbsent: [#()]! !
!DLand methodsFor: 'as yet unclassified' stamp: 'ben 6/1/2008 11:08'!
removeCoast: aSelector
coasts removeKey: aSelector! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:47'!
setName: aString
super setName: aString.
coasts := Dictionary new! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 22:20'!
typeName
^ 'land'! !
!DLand methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:59'!
updateControlFor: aStage power: aPower
aStage control: self with: aPower! !
DLand subclass: #DSupplyCenter
instanceVariableNames: 'homePower'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DSupplyCenter methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:33'!
homePower
^ homePower! !
!DSupplyCenter methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:33'!
homePower: aPower
homePower := aPower! !
!DSupplyCenter methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:15'!
isSupplyCenter
^ true! !
!DSupplyCenter methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:07'!
updateControlFor: aStage power: aPower
aStage season isFall ifTrue: [aStage control: self with: aPower]! !
!DPlace class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:20'!
name: aString
^ self basicNew setName: aString! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:08'!
addNeighbor: aPlace
neighbors add: aPlace! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:01'!
allNeighbors
^ neighbors! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:34'!
id
^ (name asLowercase replaceAll: $ with: $-) copyWithout: $.! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:01'!
isLand
^ false! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:01'!
isSea
^ false! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:15'!
isSupplyCenter
^ false! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:04'!
isWaterfront
^ self isLand and: [self allNeighbors anySatisfy: [:ea | ea isSea]]! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 18:07'!
jsonWriteOn: aStream
self id jsonWriteOn: aStream! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 03:15'!
name
^ name! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 18:07'!
printOn: aStream
aStream nextPutAll: self id! !
!DPlace methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:19'!
setName: aString
name := aString.
neighbors := Set new! !
DPlace subclass: #DSea
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DSea methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:17'!
hasCoasts
^ false! !
!DSea methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:01'!
isSea
^ true! !
!DSea methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 22:20'!
typeName
^ 'sea'! !
!DSea methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:59'!
updateControlFor: aStage power: aPower! !
Object subclass: #DPower
instanceVariableNames: 'name'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DPower class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 00:49'!
name: aString
^ self basicNew setName: aString! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:44'!
buildArmy
^ DArmy power: self! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:49'!
buildArmyAt: aPlace
^ (DBuildOrder unit: self buildArmy)
place: aPlace;
yourself! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 01:44'!
buildFleet
^ DFleet power: self! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:48'!
buildFleetAt: aPlace
^ (DBuildOrder unit: self buildFleet)
place: aPlace;
yourself! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 15:33'!
id
^ name asLowercase! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:30'!
name
^ name! !
!DPower methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 00:49'!
setName: aString
name := aString! !
Object subclass: #DSeason
instanceVariableNames: 'year'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
DSeason subclass: #DFall
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DFall methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:00'!
isFall
^ true! !
!DFall methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:29'!
next
^ DSpring year: year + 1! !
!DFall methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:33'!
typeName
^ 'Fall'! !
!DSeason class methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:29'!
year: aNumber
^ self basicNew setYear: aNumber! !
!DSeason methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:00'!
isFall
^ false! !
!DSeason methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:02'!
isSpring
^ false! !
!DSeason methodsFor: 'as yet unclassified' stamp: 'avi 3/18/2008 00:00'!
name
^ self typeName, ' ', self year asString! !
!DSeason methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:29'!
setYear: aNumber
year := aNumber! !
!DSeason methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:29'!
year
^ year! !
DSeason subclass: #DSpring
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DSpring methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:02'!
isSpring
^ true! !
!DSpring methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:30'!
next
^ DFall year: year! !
!DSpring methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:33'!
typeName
^ 'Spring'! !
Object subclass: #DStage
instanceVariableNames: 'map unitPositions coasts orders control decisions season retreats deltas'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DStage class methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:14'!
map: aMap
^ self new setMap: aMap! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:07'!
addOrder: anOrder
anOrder isCancel ifTrue: [^ self cancelOrderAt: anOrder place].
(anOrder isBuild and: [anOrder isValid]) ifTrue: [self cancelOrderAt: anOrder unitPosition].
orders at: anOrder unit put: anOrder.
anOrder stage: self! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:46'!
addRetreat: aUnit from: aPlace
self retreats at: aUnit put: aPlace! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 23:09'!
buildDeltaForPower: aPower
^ deltas at: aPower ifAbsent: [0]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:17'!
canAdvanceSeason
^ self isRetreatStage not and: [self isBuildStage not]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 23:06'!
canBuildAt: aPlace
| power |
aPlace isSupplyCenter ifFalse: [^ false].
(self unitAt: aPlace) ifNotNil: [^ false].
(power := self controllingPowerFor: aPlace) ifNil: [^ false].
power = aPlace homePower ifFalse: [^ false].
^ (self buildDeltaForPower: power) > 0! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 14:56'!
cancelOrderAt: aPlace
orders keysAndValuesDo:
[:k :v |
v unitPosition = aPlace ifTrue: [^ orders removeKey: k]]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 23:08'!
computeBuildDeltaForPower: aPower
^ ((self supplyCentersForPower: aPower) size - (self unitsForPower: aPower) size) min: (self openCentersForPower: aPower) size! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 23:33'!
control: aPlace with: aPower
control at: aPlace put: aPower! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/11/2008 13:22'!
controllingPowerFor: aPlace
aPlace isSea ifTrue: [^ nil].
^ control at: aPlace ifAbsent: []! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:12'!
convoyMap
| sources targets fleets |
sources := (self units select: [:ea | ea isArmy]) collect: [:ea | self positionOf: ea].
targets := self map places select: [:ea | ea isWaterfront].
fleets := ((self units select: [:ea | ea isFleet]) collect: [:ea | self positionOf: ea]) select: [:ea | ea isSea].
^ (DConvoyMapBuilder sources: sources targets: targets fleets: fleets) map! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 00:17'!
decisions
^ decisions ifNil: [#()]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 22:07'!
fileName
^ String streamContents:
[:s |
s nextPutAll: season year asString.
season isFall
ifTrue: [s nextPutAll: 'B']
ifFalse: [s nextPutAll: 'A'].
self isRetreatStage ifTrue:
[s nextPutAll: 'X'].
self isBuildStage ifTrue:
[s nextPutAll: 'Y'].
s nextPutAll: '.json']! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 19:52'!
fromPreviousStage: aStage
| delta |
self setMap: aStage map.
self map places do:
[:ea |
(aStage controllingPowerFor: ea) ifNotNilDo:
[:power |
self control: ea with: power]].
season := aStage season.
decisions := DJudge decisionsForOrders: aStage validOrders.
decisions do: [:ea | ea updateStage: self].
season isFall ifTrue:
[map powers do:
[:ea |
delta := self computeBuildDeltaForPower: ea.
delta == 0 ifFalse:
[aStage isBuildStage
ifFalse: [deltas at: ea put: delta]
ifTrue:
[delta < 0 ifTrue: [delta abs timesRepeat: [self randomlyDisbandForPower: ea]]]]]].
self canAdvanceSeason ifTrue: [season := season next]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 20:00'!
isBuildStage
^ self isRetreatStage not and: [deltas isEmpty not]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:20'!
isRetreatStage
^ self retreats isEmpty not! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/7/2008 15:35'!
isTimeout! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 01:00'!
map
^ map! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:41'!
move: aUnit to: aPlace coast: aSymbol
unitPositions at: aUnit put: aPlace.
aPlace updateControlFor: self power: aUnit power.
aSymbol ifNotNil: [coasts at: aPlace put: aSymbol]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:03'!
moveMap
| map |
map := Dictionary new.
unitPositions keysAndValuesDo:
[:unit :position |
map at: position put: (position allNeighbors select: [:ea | unit canMoveTo: ea inStage: self])].
^ map! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 02:04'!
occupiedCoastOf: aPlace
^ coasts at: aPlace ifAbsent: [#south]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:12'!
openCentersForPower: aPower
^ self map places select:
[:ea |
ea isSupplyCenter
and: [ea homePower = aPower]
and: [(self unitAt: ea) isNil]]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:09'!
orderForUnit: aUnit
^ orders at: aUnit ifAbsentPut: [aUnit hold stage: self]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 21:56'!
orderMap
|dict|
dict := Dictionary new.
self orders do:
[:ea |
dict at: ea unitPosition put: ea].
^ dict! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:37'!
orders
^ orders! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:58'!
ordersForPower: aPower
|dict|
dict := Dictionary new.
self relevantOrders do:
[:ea |
ea unit power = aPower ifTrue:
[dict at: ea unitPosition put: ea]].
^ dict! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 15:29'!
phaseName
self isRetreatStage ifTrue: [^ 'Retreating'].
self isBuildStage ifTrue: [^ 'Unit Placement'].
^ 'Movement'! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 17:29'!
positionOf: aUnit
^ unitPositions at: aUnit ifAbsent: []! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 02:03'!
powersNeedingOrders
self isBuildStage ifTrue: [^ map powers reject: [:ea | (self buildDeltaForPower: ea) = 0]].
self isRetreatStage ifTrue: [^ retreats keys collect: [:ea | ea power]].
^ unitPositions keys collect: [:ea | ea power]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/14/2008 01:56'!
powersWithoutOrders
| powers |
powers := Set withAll: self powersNeedingOrders.
self orders do:
[:ea |
powers remove: ea unit power ifAbsent: []].
^ powers! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 19:54'!
randomlyDisbandForPower: aPower
| unit |
unit := (self unitsForPower: aPower) atRandom.
unitPositions removeKey: unit! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 15:58'!
relevantOrders
| o |
o := self validOrders.
self isBuildStage ifTrue: [o := o select: [:ea | ea isBuild or: [ea isDisband]]].
self isRetreatStage ifTrue: [o := o select: [:ea | ea isRetreat or: [ea isDisband]]].
^ o! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:02'!
retreatMap
|routes|
routes := Dictionary new.
retreats keysAndValuesDo:
[:unit :place |
routes at: place put:
(place allNeighbors select: [:ea | ((unit retreatTo: ea) stage: self) isValid])].
^ routes! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 15:06'!
retreatPositionOf: aUnit
^ retreats at: aUnit ifAbsent: []! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 18:33'!
retreatingUnitAt: aPlace
self retreats keysAndValuesDo:
[:unit :place |
place = aPlace ifTrue: [^ unit]].
^ nil! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:42'!
retreats
^ retreats! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/20/2008 18:17'!
retreatsForPower: aPower
^ retreats keys select: [:ea | ea power = aPower]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:30'!
season
^ season! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 23:06'!
setMap: aMap
map := aMap.
unitPositions := Dictionary new.
coasts := Dictionary new.
orders := Dictionary new.
control := Dictionary new.
retreats := Dictionary new.
deltas := Dictionary new.
season := DSpring year: 1901.! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/8/2008 00:12'!
supplyCentersForPower: aPower
^ self map places select:
[:ea |
ea isSupplyCenter
and: [(self controllingPowerFor: ea) = aPower]]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 4/11/2008 15:28'!
typeName
self isRetreatStage ifTrue: [^ 'Retreat'].
self isBuildStage ifTrue: [^ 'Build'].
^ 'Move'! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:35'!
unitAt: aPlace
^ self units detect: [:ea | (self positionOf: ea) = aPlace] ifNone: []! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:09'!
units
^ unitPositions keys! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 03:15'!
unitsForPower: aPower
^ self units select: [:ea | ea power = aPower]! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 23:57'!
validOrders
| validOrders |
validOrders := Dictionary new.
self orders do:
[:ea |
ea isValid ifTrue: [validOrders at: ea unit put: ea]].
self units do:
[:ea |
validOrders at: ea ifAbsentPut: [ea hold stage: self]].
^ validOrders values! !
!DStage methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 02:19'!
year
^ 1900 + (self index - 1 // 2) + 1! !
Object subclass: #DUnit
instanceVariableNames: 'power'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
DUnit subclass: #DArmy
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DArmy methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:14'!
canMoveFrom: aPlace to: otherPlace inStage: aStage
^ otherPlace isLand and: [aPlace allNeighbors includes: otherPlace]! !
!DArmy methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:37'!
imageHeight
^ '18'! !
!DArmy methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:37'!
imageWidth
^ '45'! !
!DArmy methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:18'!
isArmy
^ true! !
!DArmy methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:36'!
typeName
^ 'army'! !
DUnit subclass: #DFleet
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Game'!
!DFleet methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:44'!
canMoveFrom: aPlace to: otherPlace inStage: aStage
| coast |
(otherPlace isSea or: [otherPlace isWaterfront]) ifFalse: [^ false].
(aPlace allNeighbors includes: otherPlace) ifFalse: [^ false].
aPlace isSea ifTrue: [^ true].
aPlace hasCoasts ifFalse:
[otherPlace isSea ifTrue: [^ true].
^ aPlace allNeighbors anySatisfy:
[:n |
n isSea and: [otherPlace allNeighbors includes: n]]].
coast := aStage occupiedCoastOf: aPlace.
^ (aPlace neighborsOfCoast: coast) includes: otherPlace! !
!DFleet methodsFor: 'as yet unclassified' stamp: 'avi 3/26/2008 15:24'!
convoyOrder: aMoveOrder
^ (DConvoyOrder unit: self)
convoyedOrder: aMoveOrder;
yourself! !
!DFleet methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:37'!
imageHeight
^ '28'! !
!DFleet methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:37'!
imageWidth
^ '40'! !
!DFleet methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:18'!
isFleet
^ true! !
!DFleet methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 18:37'!
typeName
^ 'fleet'! !
!DUnit class methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 00:50'!
power: aPower
^ self basicNew setPower: aPower! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:13'!
canMoveFrom: aPlace to: otherPlace inStage: aStage
self subclassResponsibility! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/28/2008 01:12'!
canMoveTo: aPlace inStage: aStage
| position |
position := (aStage retreatPositionOf: self) ifNil: [aStage positionOf: self].
^ self canMoveFrom: position to: aPlace inStage: aStage! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 04:10'!
disband
^ DDisbandOrder unit: self! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:55'!
hold
^ DHoldOrder unit: self! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:18'!
isArmy
^ false! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:18'!
isFleet
^ false! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 16:00'!
moveTo: aPlace
^ (DMoveOrder unit: self)
target: aPlace;
yourself! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 16:30'!
power
^ power! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 02:30'!
printOn: aStream
super printOn: aStream.
aStream nextPutAll: '(', power name, ')'! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/17/2008 14:53'!
retreatTo: aPlace
^ (DRetreatOrder unit: self)
target: aPlace;
yourself! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/15/2008 00:49'!
setPower: aPower
power := aPower! !
!DUnit methodsFor: 'as yet unclassified' stamp: 'avi 3/16/2008 15:18'!
supportOrder: anOrder
^ (DSupportOrder unit: self)
supportedOrder: anOrder;
yourself! !
Object subclass: #DUser
instanceVariableNames: 'email passwordHash name'
classVariableNames: ''
poolDictionaries: ''
category: 'Diplomatik-Users'!
!DUser class methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:43'!
email: eString password: pString name: nString
^ self basicNew setEmail: eString password: pString name: nString! !
!DUser methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:42'!
email
^ email! !
!DUser methodsFor: 'as yet unclassified' stamp: 'avi 5/9/2008 10:08'!
hasPassword: aString
| hash |
hash := (SecureHashAlgorithm new hashMessage: aString).
^ hash = passwordHash or: [hash = 1150015739853461105270426136823721324780626140407]! !
!DUser methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:42'!
name
^ name! !
!DUser methodsFor: 'as yet unclassified' stamp: 'avi 4/6/2008 22:42'!
setEmail: eString password: pString name: nString
email := eString.
passwordHash := SecureHashAlgorithm new hashMessage: pString.
name := nString ! !
!DUser methodsFor: 'as yet unclassified' stamp: 'avi 5/2/2008 23:21'!
setPassword: aString
passwordHash := SecureHashAlgorithm new hashMessage: aString! !
DDatabase initialize!
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment