parsedArgs;
diff -r 663aa9552bfc -r 9dcb2e83b24f QTfrontend/newnetclient.cpp
--- a/QTfrontend/newnetclient.cpp Wed Feb 02 09:23:42 2011 +0100
+++ b/QTfrontend/newnetclient.cpp Wed Feb 02 23:21:14 2011 +0100
@@ -276,7 +276,7 @@
return;
}
if (netClientState == 2)
- emit chatStringLobby(HWProto::formatChatMsg(lst[1], lst[2]));
+ emit chatStringLobby(lst[1], HWProto::formatChatMsgForFrontend(lst[2]));
else
emit chatStringFromNet(HWProto::formatChatMsg(lst[1], lst[2]));
return;
@@ -418,7 +418,7 @@
}
emit nickAddedLobby(lst[i], false);
- emit chatStringLobby(tr("%1 *** %2 has joined").arg('\x03').arg(lst[i]));
+ emit chatStringLobby(lst[i], tr("%1 *** %2 has joined").arg('\x03').arg("|nick|"));
}
return;
}
@@ -489,6 +489,26 @@
return;
}
+ if (lst[0] == "NOTICE") {
+ if(lst.size() < 2)
+ {
+ qWarning("Net: Bad NOTICE message");
+ return;
+ }
+
+ bool ok;
+ int n = lst[1].toInt(&ok);
+ if(!ok)
+ {
+ qWarning("Net: Bad NOTICE message");
+ return;
+ }
+
+ handleNotice(n);
+
+ return;
+ }
+
if (lst[0] == "TEAM_ACCEPTED") {
if (lst.size() != 2)
{
@@ -673,10 +693,10 @@
return isChief;
}
-void HWNewNet::gameFinished()
+void HWNewNet::gameFinished(bool correctly)
{
if (netClientState == 5) netClientState = 3;
- RawSendNet(QString("ROUNDFINISHED"));
+ RawSendNet(QString("ROUNDFINISHED%1%2").arg(delimeter).arg(correctly ? "1" : "0"));
}
void HWNewNet::banPlayer(const QString & nick)
@@ -752,3 +772,28 @@
{
RawSendNet(QString("GET_SERVER_VAR"));
}
+
+void HWNewNet::handleNotice(int n)
+{
+ switch(n)
+ {
+ case 0:
+ {
+ bool ok = false;
+ QString newNick = QInputDialog::getText(0, tr("Nickname"), tr("Some one already uses\n your nickname %1\non the server.\nPlease pick another nickname:").arg(mynick), QLineEdit::Normal, mynick, &ok);
+
+ if (!ok || newNick.isEmpty()) {
+ Disconnect();
+ emit Disconnected();
+ return;
+ }
+
+ config->setValue("net/nick", newNick);
+ mynick = newNick;
+
+ RawSendNet(QString("NICK%1%2").arg(delimeter).arg(newNick));
+
+ break;
+ }
+ }
+}
diff -r 663aa9552bfc -r 9dcb2e83b24f QTfrontend/newnetclient.h
--- a/QTfrontend/newnetclient.h Wed Feb 02 09:23:42 2011 +0100
+++ b/QTfrontend/newnetclient.h Wed Feb 02 23:21:14 2011 +0100
@@ -86,6 +86,7 @@
void RawSendNet(const QString & buf);
void RawSendNet(const QByteArray & buf);
void ParseCmd(const QStringList & lst);
+ void handleNotice(int n);
int loginStep;
int netClientState;
@@ -112,6 +113,7 @@
void hhnumChanged(const HWTeam&);
void teamColorChanged(const HWTeam&);
void chatStringLobby(const QString&);
+ void chatStringLobby(const QString&, const QString&);
void chatStringFromNet(const QString&);
void chatStringFromMe(const QString&);
void chatStringFromMeLobby(const QString&);
@@ -146,7 +148,7 @@
void JoinRoom(const QString & room);
void CreateRoom(const QString & room);
void askRoomsList();
- void gameFinished();
+ void gameFinished(bool correcly);
void banPlayer(const QString &);
void kickPlayer(const QString &);
void infoPlayer(const QString &);
@@ -161,7 +163,7 @@
void ClientRead();
void OnConnect();
void OnDisconnect();
- void displayError(QAbstractSocket::SocketError socketError);
+ void displayError(QAbstractSocket::SocketError socketError);
};
#endif // _NEW_NETCLIENT_INCLUDED
diff -r 663aa9552bfc -r 9dcb2e83b24f QTfrontend/pages.cpp
--- a/QTfrontend/pages.cpp Wed Feb 02 09:23:42 2011 +0100
+++ b/QTfrontend/pages.cpp Wed Feb 02 23:21:14 2011 +0100
@@ -122,7 +122,7 @@
Tips << tr("We're open to suggestions and constructive feedback. If you don't like something or got a great idea, let us know!", "Tips");
Tips << tr("Especially while playing online be polite and always remember there might be some minors playing with or against you as well!", "Tips");
Tips << tr("Special game modes such as 'Vampirism' or 'Karma' allow you to develop completely new tactics. Try them in a custom game!", "Tips");
- Tips << tr("The Windows version of Hedgewars supports Xfire. Make sure to add Hedgwars to its game list so your friends can see you playing.", "Tips");
+ Tips << tr("The Windows version of Hedgewars supports Xfire. Make sure to add Hedgewars to its game list so your friends can see you playing.", "Tips");
Tips << tr("You should never install Hedgewars on computers you don't own (school, university, work, etc.). Please ask the responsible person instead!", "Tips");
Tips << tr("Hedgewars can be perfect for short games during breaks. Just ensure you don't add too many hedgehogs or use an huge map. Reducing time and health might help as well.", "Tips");
Tips << tr("No hedgehogs were harmed in making this game.", "Tips");
@@ -132,13 +132,13 @@
Tips << tr("Most weapons won't work once they touch the water. The Homing Bee as well as the Cake are exceptions to this.", "Tips");
Tips << tr("The Old Limbuger only causes a small explosion. However the wind affected smelly cloud can poison lots of hogs at once.", "Tips");
Tips << tr("The Piano Strike is the most damaging air strike. You'll lose the hedgehog performing it, so there's a huge downside as well.", "Tips");
- Tips << tr("The Homing Bee can be tricky to use. It's turn radius depends on it's velocity, so try to not use full power.", "Tips");
+ Tips << tr("The Homing Bee can be tricky to use. Its turn radius depends on it's velocity, so try to not use full power.", "Tips");
Tips << tr("Sticky Mines are a perfect tool to create small chain reactions knocking enemy hedgehogs into dire situations ... or water.", "Tips");
Tips << tr("The Hammer is most effective when used on bridges or girders. Hit hogs will just break through the ground.", "Tips");
Tips << tr("If you're stuck behind an enemy hedgehog, use the Hammer to free yourself without getting damaged by an explosion.", "Tips");
Tips << tr("The Cake's maximum walking distance depends on the ground it has to pass. Use [attack] to detonate it early.", "Tips");
Tips << tr("The Flame Thrower is a weapon but it can be used for tunnel digging as well.", "Tips");
- Tips << tr("Use the Incinerating Grenade to temporary keep hedgehogs from passing terrain such as tunnels or platforms.", "Tips");
+ Tips << tr("Use the Molotov or Flame Thrower to temporary keep hedgehogs from passing terrain such as tunnels or platforms.", "Tips");
Tips << tr("Want to know who's behind the game? Click on the Hedgewars logo in the main menu to see the credits.", "Tips");
Tips << tr("Like Hedgewars? Become a fan on %1 or follow us on %2!", "Tips").arg("Facebook").arg("Twitter");
Tips << tr("Feel free to draw your own graves, hats, flags or even maps and themes! But note that you'll have to share them somewhere to use them online.", "Tips");
@@ -617,6 +617,7 @@
editNetNick = new QLineEdit(groupMisc);
editNetNick->setMaxLength(20);
editNetNick->setText(QLineEdit::tr("unnamed"));
+ connect(editNetNick, SIGNAL(editingFinished()), this, SLOT(trimNetNick()));
MiscLayout->addWidget(editNetNick, 0, 1);
QLabel *labelLanguage = new QLabel(groupMisc);
@@ -669,6 +670,7 @@
QVBoxLayout * GBAlayout = new QVBoxLayout(AGGroupBox);
QHBoxLayout * GBAreslayout = new QHBoxLayout(0);
+ QHBoxLayout * GBAstereolayout = new QHBoxLayout(0);
QHBoxLayout * GBAqualayout = new QHBoxLayout(0);
CBFrontendFullscreen = new QCheckBox(AGGroupBox);
@@ -704,6 +706,7 @@
CBFullscreen = new QCheckBox(AGGroupBox);
CBFullscreen->setText(QCheckBox::tr("Fullscreen"));
GBAlayout->addWidget(CBFullscreen);
+ connect(CBFullscreen, SIGNAL(stateChanged(int)), this, SLOT(setFullscreen(void)));
QLabel * quality = new QLabel(AGGroupBox);
quality->setText(QLabel::tr("Quality"));
@@ -717,6 +720,25 @@
SLQuality->setFixedWidth(150);
GBAqualayout->addWidget(SLQuality);
GBAlayout->addLayout(GBAqualayout);
+ QLabel * stereo = new QLabel(AGGroupBox);
+ stereo->setText(QLabel::tr("Stereo rendering"));
+ GBAstereolayout->addWidget(stereo);
+
+ CBStereoMode = new QComboBox(AGGroupBox);
+ CBStereoMode->addItem(QComboBox::tr("Disabled"));
+ CBStereoMode->addItem(QComboBox::tr("Red/Cyan"));
+ CBStereoMode->addItem(QComboBox::tr("Cyan/Red"));
+ CBStereoMode->addItem(QComboBox::tr("Red/Blue"));
+ CBStereoMode->addItem(QComboBox::tr("Blue/Red"));
+ CBStereoMode->addItem(QComboBox::tr("Red/Green"));
+ CBStereoMode->addItem(QComboBox::tr("Green/Red"));
+ CBStereoMode->addItem(QComboBox::tr("Side-by-side"));
+ CBStereoMode->addItem(QComboBox::tr("Top-Bottom"));
+ CBStereoMode->addItem(QComboBox::tr("Wiggle"));
+ connect(CBStereoMode, SIGNAL(currentIndexChanged(int)), this, SLOT(forceFullscreen(int)));
+
+ GBAstereolayout->addWidget(CBStereoMode);
+ GBAlayout->addLayout(GBAstereolayout);
hr = new QFrame(AGGroupBox);
hr->setFrameStyle(QFrame::HLine);
@@ -781,8 +803,39 @@
BtnBack->setFixedHeight(BtnSaveOptions->height());
BtnBack->setFixedWidth(BtnBack->width()+2);
BtnBack->setStyleSheet("QPushButton{margin: 22px 0 9px 2px;}");
+}
-// BtnAssociateFiles = addButton("");
+void PageOptions::forceFullscreen(int index)
+{
+ if (index != 0) {
+ previousFullscreenValue = this->CBFullscreen->isChecked();
+ this->CBFullscreen->setChecked(true);
+ this->CBFullscreen->setEnabled(false);
+ previousQuality = this->SLQuality->value();
+ this->SLQuality->setValue(this->SLQuality->maximum());
+ this->SLQuality->setEnabled(false);
+ } else {
+ this->CBFullscreen->setChecked(previousFullscreenValue);
+ this->CBFullscreen->setEnabled(true);
+ this->SLQuality->setValue(previousQuality);
+ this->SLQuality->setEnabled(true);
+ }
+}
+
+void PageOptions::setFullscreen(void)
+{
+ int tmp = this->CBResolution->currentIndex();
+ if (this->CBFullscreen->isChecked())
+ this->CBResolution->setCurrentIndex(0);
+ else
+ this->CBResolution->setCurrentIndex(previousResolutionIndex);
+ previousResolutionIndex = tmp;
+ this->CBResolution->setEnabled(!this->CBFullscreen->isChecked());
+}
+
+void PageOptions::trimNetNick()
+{
+ editNetNick->setText(editNetNick->text().trimmed());
}
PageNet::PageNet(QWidget* parent) : AbstractPage(parent)
@@ -931,6 +984,7 @@
// chatwidget
pChatWidget = new HWChatWidget(this, gameSettings, sdli, true);
pChatWidget->setShowReady(true); // show status bulbs by default
+ pChatWidget->setShowFollow(false); // don't show follow in nicks' context menus
pageLayout->addWidget(pChatWidget, 2, 0, 1, 2);
pageLayout->setRowStretch(1, 100);
@@ -1306,6 +1360,8 @@
compString = "Random Map";
} else if (a == 5 && compString == "+maze+") {
compString = "Random Maze";
+ } else if (a == 5 && compString == "+drawn+") {
+ compString = "Drawn Map";
}
if (compString.contains(searchText->text(), Qt::CaseInsensitive)) {
found = true;
@@ -1968,6 +2024,8 @@
pageLayout->addWidget(lblPreview, 4, 0);
tb = new QTextBrowser(this);
+ tb->setOpenExternalLinks(true);
+ tb->document()->setDefaultStyleSheet(HWChatWidget::STYLE);
pageLayout->addWidget(tb, 4, 1, 1, 2);
connect(leServerMessageNew, SIGNAL(textEdited(const QString &)), tb, SLOT(setHtml(const QString &)));
connect(leServerMessageOld, SIGNAL(textEdited(const QString &)), tb, SLOT(setHtml(const QString &)));
diff -r 663aa9552bfc -r 9dcb2e83b24f QTfrontend/pages.h
--- a/QTfrontend/pages.h Wed Feb 02 09:23:42 2011 +0100
+++ b/QTfrontend/pages.h Wed Feb 02 23:21:14 2011 +0100
@@ -234,6 +234,7 @@
QComboBox *CBTeamName;
IconedGroupBox *AGGroupBox;
QComboBox *CBResolution;
+ QComboBox *CBStereoMode;
QCheckBox *CBEnableSound;
QCheckBox *CBEnableFrontendSound;
QCheckBox *CBEnableMusic;
@@ -254,6 +255,16 @@
QLineEdit *editNetNick;
QSlider *SLQuality;
QCheckBox *CBFrontendEffects;
+
+private:
+ bool previousFullscreenValue;
+ int previousResolutionIndex;
+ int previousQuality;
+
+private slots:
+ void forceFullscreen(int index);
+ void setFullscreen(void);
+ void trimNetNick();
};
class PageNet : public AbstractPage
diff -r 663aa9552bfc -r 9dcb2e83b24f QTfrontend/proto.cpp
--- a/QTfrontend/proto.cpp Wed Feb 02 09:23:42 2011 +0100
+++ b/QTfrontend/proto.cpp Wed Feb 02 23:21:14 2011 +0100
@@ -45,6 +45,11 @@
return buf;
}
+QString HWProto::formatChatMsgForFrontend(const QString & msg)
+{
+ return formatChatMsg("|nick|", msg);
+}
+
QString HWProto::formatChatMsg(const QString & nick, const QString & msg)
{
if(msg.left(4) == "/me ")
diff -r 663aa9552bfc -r 9dcb2e83b24f QTfrontend/proto.h
--- a/QTfrontend/proto.h Wed Feb 02 09:23:42 2011 +0100
+++ b/QTfrontend/proto.h Wed Feb 02 23:21:14 2011 +0100
@@ -34,6 +34,7 @@
static QByteArray & addByteArrayToBuffer(QByteArray & buf, const QByteArray & msg);
static QByteArray & addStringListToBuffer(QByteArray & buf, const QStringList & strList);
static QString formatChatMsg(const QString & nick, const QString & msg);
+ static QString formatChatMsgForFrontend(const QString & msg);
};
#endif // _PROTO_H
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/Actions.hs
--- a/gameServer/Actions.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/Actions.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,449 +1,427 @@
-module Actions where
-
-import Control.Concurrent.STM
-import Control.Concurrent.Chan
-import Data.IntMap
-import qualified Data.IntSet as IntSet
-import qualified Data.Sequence as Seq
-import System.Log.Logger
-import Control.Monad
-import Data.Time
-import Data.Maybe
------------------------------
-import CoreTypes
-import Utils
-
-data Action =
- AnswerThisClient [String]
- | AnswerAll [String]
- | AnswerAllOthers [String]
- | AnswerThisRoom [String]
- | AnswerOthersInRoom [String]
- | AnswerSameClan [String]
- | AnswerLobby [String]
- | SendServerMessage
- | SendServerVars
- | RoomAddThisClient Int -- roomID
- | RoomRemoveThisClient String
- | RemoveTeam String
- | RemoveRoom
- | UnreadyRoomClients
- | MoveToLobby
- | ProtocolError String
- | Warning String
- | ByeClient String
- | KickClient Int -- clID
- | KickRoomClient Int -- clID
- | BanClient String -- nick
- | RemoveClientTeams Int -- clID
- | ModifyClient (ClientInfo -> ClientInfo)
- | ModifyClient2 Int (ClientInfo -> ClientInfo)
- | ModifyRoom (RoomInfo -> RoomInfo)
- | ModifyServerInfo (ServerInfo -> ServerInfo)
- | AddRoom String String
- | CheckRegistered
- | ClearAccountsCache
- | ProcessAccountInfo AccountInfo
- | Dump
- | AddClient ClientInfo
- | PingAll
- | StatsAction
-
-type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
-
-replaceID a (b, c, d, e) = (a, c, d, e)
-
-processAction :: (Int, ServerInfo, Clients, Rooms) -> Action -> IO (Int, ServerInfo, Clients, Rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerThisClient msg) = do
- writeChan (sendChan $ clients ! clID) msg
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerAll msg) = do
- mapM_ (\cl -> writeChan (sendChan cl) msg) (elems clients)
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerAllOthers msg) = do
- mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $
- Prelude.filter (\id' -> (id' /= clID) && logonPassed (clients ! id')) (keys clients)
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerThisRoom msg) = do
- mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
- return (clID, serverInfo, clients, rooms)
- where
- roomClients = IntSet.elems $ playersIDs room
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerOthersInRoom msg) = do
- mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) $ Prelude.filter (/= clID) roomClients
- return (clID, serverInfo, clients, rooms)
- where
- roomClients = IntSet.elems $ playersIDs room
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerLobby msg) = do
- mapM_ (\id' -> writeChan (sendChan $ clients ! id') msg) roomClients
- return (clID, serverInfo, clients, rooms)
- where
- roomClients = IntSet.elems $ playersIDs room
- room = rooms ! 0
-
-
-processAction (clID, serverInfo, clients, rooms) (AnswerSameClan msg) = do
- mapM_ (\cl -> writeChan (sendChan cl) msg) sameClanOrSpec
- return (clID, serverInfo, clients, rooms)
- where
- otherRoomClients = Prelude.map ((!) clients) $ IntSet.elems $ clID `IntSet.delete` (playersIDs room)
- sameClanOrSpec = if teamsInGame client > 0 then sameClanClients else spectators
- spectators = Prelude.filter (\cl -> teamsInGame cl == 0) otherRoomClients
- sameClanClients = Prelude.filter (\cl -> teamsInGame cl > 0 && clientClan cl == thisClan) otherRoomClients
- thisClan = clientClan client
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) SendServerMessage = do
- writeChan (sendChan $ clients ! clID) ["SERVER_MESSAGE", message serverInfo]
- return (clID, serverInfo, clients, rooms)
- where
- client = clients ! clID
- message si = if clientProto client < latestReleaseVersion si then
- serverMessageForOldVersions si
- else
- serverMessage si
-
-processAction (clID, serverInfo, clients, rooms) SendServerVars = do
- writeChan (sendChan $ clients ! clID) ("SERVER_VARS" : vars)
- return (clID, serverInfo, clients, rooms)
- where
- client = clients ! clID
- vars = [
- "MOTD_NEW", serverMessage serverInfo,
- "MOTD_OLD", serverMessageForOldVersions serverInfo,
- "LATEST_PROTO", show $ latestReleaseVersion serverInfo
- ]
-
-
-processAction (clID, serverInfo, clients, rooms) (ProtocolError msg) = do
- writeChan (sendChan $ clients ! clID) ["ERROR", msg]
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (Warning msg) = do
- writeChan (sendChan $ clients ! clID) ["WARNING", msg]
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ByeClient msg) = do
- infoM "Clients" (show (clientUID client) ++ " quits: " ++ msg)
- (_, _, newClients, newRooms) <-
- if roomID client /= 0 then
- processAction (clID, serverInfo, clients, rooms) $ RoomRemoveThisClient "quit"
- else
- return (clID, serverInfo, clients, rooms)
-
- mapM_ (processAction (clID, serverInfo, newClients, newRooms)) $ answerOthersQuit ++ answerInformRoom
- writeChan (sendChan $ clients ! clID) ["BYE", msg]
- return (
- 0,
- serverInfo,
- delete clID newClients,
- adjust (\r -> r{
- playersIDs = IntSet.delete clID (playersIDs r),
- playersIn = (playersIn r) - 1,
- readyPlayers = if isReady client then readyPlayers r - 1 else readyPlayers r
- }) (roomID $ newClients ! clID) newRooms
- )
- where
- client = clients ! clID
- clientNick = nick client
- answerInformRoom =
- if roomID client /= 0 then
- if not $ Prelude.null msg then
- [AnswerThisRoom ["LEFT", clientNick, msg]]
- else
- [AnswerThisRoom ["LEFT", clientNick]]
- else
- []
- answerOthersQuit =
- if logonPassed client then
- if not $ Prelude.null msg then
- [AnswerAll ["LOBBY:LEFT", clientNick, msg]]
- else
- [AnswerAll ["LOBBY:LEFT", clientNick]]
- else
- []
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyClient func) =
- return (clID, serverInfo, adjust func clID clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyClient2 cl2ID func) =
- return (clID, serverInfo, adjust func cl2ID clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyRoom func) =
- return (clID, serverInfo, clients, adjust func rID rooms)
- where
- rID = roomID $ clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (ModifyServerInfo func) =
- return (clID, func serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (RoomAddThisClient rID) =
- processAction (
- clID,
- serverInfo,
- adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
- adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
- adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
- ) joinMsg
- where
- client = clients ! clID
- joinMsg = if rID == 0 then
- AnswerAllOthers ["LOBBY:JOINED", nick client]
- else
- AnswerThisRoom ["JOINED", nick client]
-
-
-processAction (clID, serverInfo, clients, rooms) (RoomRemoveThisClient msg) = do
- (_, _, newClients, newRooms) <-
- if roomID client /= 0 then
- if isMaster client then
- if (gameinprogress room) && (playersIn room > 1) then
- (changeMaster >>= (\state -> foldM processAction state
- [AnswerOthersInRoom ["LEFT", nick client, msg],
- AnswerOthersInRoom ["WARNING", "Admin left the room"],
- RemoveClientTeams clID]))
- else -- not in game
- processAction (clID, serverInfo, clients, rooms) RemoveRoom
- else -- not master
- foldM
- processAction
- (clID, serverInfo, clients, rooms)
- [AnswerOthersInRoom ["LEFT", nick client, msg],
- RemoveClientTeams clID]
- else -- in lobby
- return (clID, serverInfo, clients, rooms)
-
- return (
- clID,
- serverInfo,
- adjust resetClientFlags clID newClients,
- adjust removeClientFromRoom rID $ adjust insertClientToRoom 0 newRooms
- )
- where
- rID = roomID client
- client = clients ! clID
- room = rooms ! rID
- resetClientFlags cl = cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined}
- removeClientFromRoom r = r{
- playersIDs = otherPlayersSet,
- playersIn = (playersIn r) - 1,
- readyPlayers = if isReady client then (readyPlayers r) - 1 else readyPlayers r
- }
- insertClientToRoom r = r{playersIDs = IntSet.insert clID (playersIDs r)}
- changeMaster = do
- processAction (newMasterId, serverInfo, clients, rooms) $ AnswerThisClient ["ROOM_CONTROL_ACCESS", "1"]
- return (
- clID,
- serverInfo,
- adjust (\cl -> cl{isMaster = True}) newMasterId clients,
- adjust (\r -> r{masterID = newMasterId, name = newRoomName}) rID rooms
- )
- newRoomName = nick newMasterClient
- otherPlayersSet = IntSet.delete clID (playersIDs room)
- newMasterId = IntSet.findMin otherPlayersSet
- newMasterClient = clients ! newMasterId
-
-
-processAction (clID, serverInfo, clients, rooms) (AddRoom roomName roomPassword) = do
- let newServerInfo = serverInfo {nextRoomID = newID}
- let room = newRoom{
- roomUID = newID,
- masterID = clID,
- name = roomName,
- password = roomPassword,
- roomProto = (clientProto client)
- }
-
- processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "ADD", roomName]
-
- processAction (
- clID,
- newServerInfo,
- adjust (\cl -> cl{isMaster = True}) clID clients,
- insert newID room rooms
- ) $ RoomAddThisClient newID
- where
- newID = (nextRoomID serverInfo) - 1
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (RemoveRoom) = do
- processAction (clID, serverInfo, clients, rooms) $ AnswerLobby ["ROOM", "DEL", name room]
- processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["ROOMABANDONED", name room]
- return (clID,
- serverInfo,
- Data.IntMap.map (\cl -> if roomID cl == rID then cl{roomID = 0, isMaster = False, isReady = False, teamsInGame = undefined} else cl) clients,
- delete rID $ adjust (\r -> r{playersIDs = IntSet.union (playersIDs room) (playersIDs r)}) 0 rooms
- )
- where
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (UnreadyRoomClients) = do
- processAction (clID, serverInfo, clients, rooms) $ AnswerThisRoom ("NOT_READY" : roomPlayers)
- return (clID,
- serverInfo,
- Data.IntMap.map (\cl -> if roomID cl == rID then cl{isReady = False} else cl) clients,
- adjust (\r -> r{readyPlayers = 0}) rID rooms)
- where
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
- roomPlayers = Prelude.map (nick . (clients !)) roomPlayersIDs
- roomPlayersIDs = IntSet.elems $ playersIDs room
-
-
-processAction (clID, serverInfo, clients, rooms) (RemoveTeam teamName) = do
- newRooms <- if not $ gameinprogress room then
- do
- processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["REMOVE_TEAM", teamName]
- return $
- adjust (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r}) rID rooms
- else
- do
- processAction (clID, serverInfo, clients, rooms) $ AnswerOthersInRoom ["EM", rmTeamMsg]
- return $
- adjust (\r -> r{
- teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
- leftTeams = teamName : leftTeams r,
- roundMsgs = roundMsgs r Seq.|> rmTeamMsg
- }) rID rooms
- return (clID, serverInfo, clients, newRooms)
- where
- room = rooms ! rID
- rID = roomID client
- client = clients ! clID
- rmTeamMsg = toEngineMsg $ 'F' : teamName
-
-
-processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do
- writeChan (dbQueries serverInfo) $ CheckAccount (clientUID client) (nick client) (host client)
- return (clID, serverInfo, clients, rooms)
- where
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (ClearAccountsCache) = do
- writeChan (dbQueries serverInfo) ClearCache
- return (clID, serverInfo, clients, rooms)
- where
- client = clients ! clID
-
-
-processAction (clID, serverInfo, clients, rooms) (Dump) = do
- writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) =
- case info of
- HasAccount passwd isAdmin -> do
- infoM "Clients" $ show clID ++ " has account"
- writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
- return (clID, serverInfo, adjust (\cl -> cl{webPassword = passwd, isAdministrator = isAdmin}) clID clients, rooms)
- Guest -> do
- infoM "Clients" $ show clID ++ " is guest"
- processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True}) clID clients, rooms) MoveToLobby
- Admin -> do
- infoM "Clients" $ show clID ++ " is admin"
- foldM processAction (clID, serverInfo, adjust (\cl -> cl{logonPassed = True, isAdministrator = True}) clID clients, rooms) [MoveToLobby, AnswerThisClient ["ADMIN_ACCESS"]]
-
-
-processAction (clID, serverInfo, clients, rooms) (MoveToLobby) =
- foldM processAction (clID, serverInfo, clients, rooms) $
- (RoomAddThisClient 0)
- : answerLobbyNicks
- ++ [SendServerMessage]
-
- -- ++ (answerServerMessage client clients)
- where
- lobbyNicks = Prelude.map nick $ Prelude.filter logonPassed $ elems clients
- answerLobbyNicks = [AnswerThisClient ("LOBBY:JOINED": lobbyNicks) | not $ Prelude.null lobbyNicks]
-
-
-processAction (clID, serverInfo, clients, rooms) (KickClient kickID) = do
- let client = clients ! kickID
- currentTime <- getCurrentTime
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo{lastLogins = (host client, (addUTCTime 60 $ currentTime, "60 seconds ban")) : lastLogins serverInfo}, clients, rooms) $ ByeClient "Kicked")
-
-
-processAction (clID, serverInfo, clients, rooms) (BanClient banNick) =
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (KickRoomClient kickID) = do
- writeChan (sendChan $ clients ! kickID) ["KICKED"]
- liftM2 replaceID (return clID) (processAction (kickID, serverInfo, clients, rooms) $ RoomRemoveThisClient "kicked")
-
-
-processAction (clID, serverInfo, clients, rooms) (RemoveClientTeams teamsClID) =
- liftM2 replaceID (return clID) $
- foldM processAction (teamsClID, serverInfo, clients, rooms) removeTeamsActions
- where
- client = clients ! teamsClID
- room = rooms ! (roomID client)
- teamsToRemove = Prelude.filter (\t -> teamowner t == nick client) $ teams room
- removeTeamsActions = Prelude.map (RemoveTeam . teamname) teamsToRemove
-
-
-processAction (clID, serverInfo, clients, rooms) (AddClient client) = do
- let updatedClients = insert (clientUID client) client clients
- infoM "Clients" (show (clientUID client) ++ ": New client. Time: " ++ show (connectTime client))
- writeChan (sendChan client) ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
-
- let newLogins = takeWhile (\(_ , (time, _)) -> (connectTime client) `diffUTCTime` time <= 0) $ lastLogins serverInfo
-
- let info = host client `Prelude.lookup` newLogins
- if isJust info then
- processAction (clID, serverInfo{lastLogins = newLogins}, updatedClients, rooms) $ ByeClient (snd . fromJust $ info)
- else
- return (clID, serverInfo{lastLogins = (host client, (addUTCTime 10 $ connectTime client, "Reconnected too fast")) : newLogins}, updatedClients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) PingAll = do
- (_, _, newClients, newRooms) <- foldM kickTimeouted (clID, serverInfo, clients, rooms) $ elems clients
- processAction (clID,
- serverInfo,
- Data.IntMap.map (\cl -> cl{pingsQueue = pingsQueue cl + 1}) newClients,
- newRooms) $ AnswerAll ["PING"]
- where
- kickTimeouted (clID, serverInfo, clients, rooms) client =
- if pingsQueue client > 0 then
- processAction (clientUID client, serverInfo, clients, rooms) $ ByeClient "Ping timeout"
- else
- return (clID, serverInfo, clients, rooms)
-
-
-processAction (clID, serverInfo, clients, rooms) (StatsAction) = do
- writeChan (dbQueries serverInfo) $ SendStats (size clients) (size rooms - 1)
- return (clID, serverInfo, clients, rooms)
+{-# LANGUAGE OverloadedStrings #-}
+module Actions where
+
+import Control.Concurrent
+import Control.Concurrent.Chan
+import qualified Data.IntSet as IntSet
+import qualified Data.Set as Set
+import qualified Data.Sequence as Seq
+import System.Log.Logger
+import Control.Monad
+import Data.Time
+import Data.Maybe
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import qualified Data.ByteString.Char8 as B
+import Control.DeepSeq
+import Data.Time
+import Text.Printf
+-----------------------------
+import CoreTypes
+import Utils
+import ClientIO
+import ServerState
+
+data Action =
+ AnswerClients ![ClientChan] ![B.ByteString]
+ | SendServerMessage
+ | SendServerVars
+ | MoveToRoom RoomIndex
+ | MoveToLobby B.ByteString
+ | RemoveTeam B.ByteString
+ | RemoveRoom
+ | UnreadyRoomClients
+ | JoinLobby
+ | ProtocolError B.ByteString
+ | Warning B.ByteString
+ | NoticeMessage Notice
+ | ByeClient B.ByteString
+ | KickClient ClientIndex
+ | KickRoomClient ClientIndex
+ | BanClient NominalDiffTime B.ByteString ClientIndex
+ | ChangeMaster
+ | RemoveClientTeams ClientIndex
+ | ModifyClient (ClientInfo -> ClientInfo)
+ | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
+ | ModifyRoom (RoomInfo -> RoomInfo)
+ | ModifyServerInfo (ServerInfo -> ServerInfo)
+ | AddRoom B.ByteString B.ByteString
+ | CheckRegistered
+ | ClearAccountsCache
+ | ProcessAccountInfo AccountInfo
+ | AddClient ClientInfo
+ | DeleteClient ClientIndex
+ | PingAll
+ | StatsAction
+
+type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+
+instance NFData Action where
+ rnf (AnswerClients chans msg) = chans `deepseq` msg `deepseq` ()
+ rnf a = a `seq` ()
+
+instance NFData B.ByteString
+instance NFData (Chan a)
+
+othersChans = do
+ cl <- client's id
+ ri <- clientRoomA
+ liftM (map sendChan . filter (/= cl)) $ roomClientsS ri
+
+processAction :: Action -> StateT ServerState IO ()
+
+
+processAction (AnswerClients chans msg) = do
+ io $ mapM_ (flip writeChan (msg `deepseq` msg)) (chans `deepseq` chans)
+
+
+processAction SendServerMessage = do
+ chan <- client's sendChan
+ protonum <- client's clientProto
+ si <- liftM serverInfo get
+ let message = if protonum < latestReleaseVersion si then
+ serverMessageForOldVersions si
+ else
+ serverMessage si
+ processAction $ AnswerClients [chan] ["SERVER_MESSAGE", message]
+
+
+processAction SendServerVars = do
+ chan <- client's sendChan
+ si <- gets serverInfo
+ io $ writeChan chan ("SERVER_VARS" : vars si)
+ where
+ vars si = [
+ "MOTD_NEW", serverMessage si,
+ "MOTD_OLD", serverMessageForOldVersions si,
+ "LATEST_PROTO", B.pack . show $ latestReleaseVersion si
+ ]
+
+
+processAction (ProtocolError msg) = do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["ERROR", msg]
+
+
+processAction (Warning msg) = do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["WARNING", msg]
+
+processAction (NoticeMessage n) = do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["NOTICE", B.pack . show . fromEnum $ n]
+
+processAction (ByeClient msg) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+
+ chan <- client's sendChan
+ clNick <- client's nick
+
+ when (ri /= lobbyId) $ do
+ processAction $ MoveToLobby ("quit: " `B.append` msg)
+ return ()
+
+ clientsChans <- liftM (Prelude.map sendChan . Prelude.filter logonPassed) $! allClientsS
+ io $ do
+ infoM "Clients" (show ci ++ " quits: " ++ (B.unpack msg))
+
+ processAction $ AnswerClients [chan] ["BYE", msg]
+ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
+
+ s <- get
+ put $! s{removedClients = ci `Set.insert` removedClients s}
+
+processAction (DeleteClient ci) = do
+ rnc <- gets roomsClients
+ io $ removeClient rnc ci
+
+ s <- get
+ put $! s{removedClients = ci `Set.delete` removedClients s}
+
+processAction (ModifyClient f) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ io $ modifyClient rnc f ci
+ return ()
+
+processAction (ModifyClient2 ci f) = do
+ rnc <- gets roomsClients
+ io $ modifyClient rnc f ci
+ return ()
+
+
+processAction (ModifyRoom f) = do
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+ io $ modifyRoom rnc f ri
+ return ()
+
+
+processAction (ModifyServerInfo f) =
+ modify (\s -> s{serverInfo = f $ serverInfo s})
+
+
+processAction (MoveToRoom ri) = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+
+ io $ do
+ modifyClient rnc (\cl -> cl{teamsInGame = 0, isReady = False, isMaster = False}) ci
+ modifyRoom rnc (\r -> r{playersIn = (playersIn r) + 1}) ri
+ moveClientToRoom rnc ri ci
+
+ chans <- liftM (map sendChan) $ roomClientsS ri
+ clNick <- client's nick
+
+ processAction $ AnswerClients chans ["JOINED", clNick]
+
+
+processAction (MoveToLobby msg) = do
+ (Just ci) <- gets clientIndex
+ ri <- clientRoomA
+ rnc <- gets roomsClients
+ (gameProgress, playersNum) <- io $ room'sM rnc (\r -> (gameinprogress r, playersIn r)) ri
+ ready <- client's isReady
+ master <- client's isMaster
+-- client <- client's id
+ clNick <- client's nick
+ chans <- othersChans
+
+ if master then
+ if gameProgress && playersNum > 1 then
+ mapM_ processAction [ChangeMaster, AnswerClients chans ["LEFT", clNick, msg], NoticeMessage AdminLeft, RemoveClientTeams ci]
+ else
+ processAction RemoveRoom
+ else
+ mapM_ processAction [AnswerClients chans ["LEFT", clNick, msg], RemoveClientTeams ci]
+
+ io $ do
+ modifyRoom rnc (\r -> r{
+ playersIn = (playersIn r) - 1,
+ readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
+ }) ri
+ moveClientToLobby rnc ci
+
+processAction ChangeMaster = do
+ ri <- clientRoomA
+ rnc <- gets roomsClients
+ newMasterId <- liftM head . io $ roomClientsIndicesM rnc ri
+ newMaster <- io $ client'sM rnc id newMasterId
+ let newRoomName = nick newMaster
+ mapM_ processAction [
+ ModifyRoom (\r -> r{masterID = newMasterId, name = newRoomName}),
+ ModifyClient2 newMasterId (\c -> c{isMaster = True}),
+ AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
+ ]
+
+processAction (AddRoom roomName roomPassword) = do
+ Just clId <- gets clientIndex
+ rnc <- gets roomsClients
+ proto <- io $ client'sM rnc clientProto clId
+
+ let room = newRoom{
+ masterID = clId,
+ name = roomName,
+ password = roomPassword,
+ roomProto = proto
+ }
+
+ rId <- io $ addRoom rnc room
+
+ processAction $ MoveToRoom rId
+
+ chans <- liftM (map sendChan) $! roomClientsS lobbyId
+
+ mapM_ processAction [
+ AnswerClients chans ["ROOM", "ADD", roomName]
+ , ModifyClient (\cl -> cl{isMaster = True})
+ ]
+
+
+processAction RemoveRoom = do
+ Just clId <- gets clientIndex
+ rnc <- gets roomsClients
+ ri <- io $ clientRoomM rnc clId
+ roomName <- io $ room'sM rnc name ri
+ others <- othersChans
+ lobbyChans <- liftM (map sendChan) $! roomClientsS lobbyId
+
+ mapM_ processAction [
+ AnswerClients lobbyChans ["ROOM", "DEL", roomName],
+ AnswerClients others ["ROOMABANDONED", roomName]
+ ]
+
+ io $ removeRoom rnc ri
+
+
+processAction (UnreadyRoomClients) = do
+ rnc <- gets roomsClients
+ ri <- clientRoomA
+ roomPlayers <- roomClientsS ri
+ roomClIDs <- io $ roomClientsIndicesM rnc ri
+ processAction $ AnswerClients (map sendChan roomPlayers) ("NOT_READY" : map nick roomPlayers)
+ io $ mapM_ (modifyClient rnc (\cl -> cl{isReady = False})) roomClIDs
+ processAction $ ModifyRoom (\r -> r{readyPlayers = 0})
+
+
+processAction (RemoveTeam teamName) = do
+ rnc <- gets roomsClients
+ cl <- client's id
+ ri <- clientRoomA
+ inGame <- io $ room'sM rnc gameinprogress ri
+ chans <- othersChans
+ if inGame then
+ mapM_ processAction [
+ AnswerClients chans ["REMOVE_TEAM", teamName],
+ ModifyRoom (\r -> r{teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r})
+ ]
+ else
+ mapM_ processAction [
+ AnswerClients chans ["EM", rmTeamMsg],
+ ModifyRoom (\r -> r{
+ teams = Prelude.filter (\t -> teamName /= teamname t) $ teams r,
+ leftTeams = teamName : leftTeams r,
+ roundMsgs = roundMsgs r Seq.|> rmTeamMsg
+ })
+ ]
+ where
+ rmTeamMsg = toEngineMsg $ (B.singleton 'F') `B.append` teamName
+
+
+processAction (RemoveClientTeams clId) = do
+ rnc <- gets roomsClients
+
+ removeTeamActions <- io $ do
+ clNick <- client'sM rnc nick clId
+ rId <- clientRoomM rnc clId
+ roomTeams <- room'sM rnc teams rId
+ return . Prelude.map (RemoveTeam . teamname) . Prelude.filter (\t -> teamowner t == clNick) $ roomTeams
+
+ mapM_ processAction removeTeamActions
+
+
+
+processAction CheckRegistered = do
+ (Just ci) <- gets clientIndex
+ n <- client's nick
+ h <- client's host
+ db <- gets (dbQueries . serverInfo)
+ io $ writeChan db $ CheckAccount ci n h
+ return ()
+
+
+processAction ClearAccountsCache = do
+ dbq <- gets (dbQueries . serverInfo)
+ io $ writeChan dbq ClearCache
+ return ()
+
+
+processAction (ProcessAccountInfo info) =
+ case info of
+ HasAccount passwd isAdmin -> do
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["ASKPASSWORD"]
+ Guest -> do
+ processAction JoinLobby
+ Admin -> do
+ mapM processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
+ chan <- client's sendChan
+ processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
+
+
+processAction JoinLobby = do
+ chan <- client's sendChan
+ clientNick <- client's nick
+ (lobbyNicks, clientsChans) <- liftM (unzip . Prelude.map (\c -> (nick c, sendChan c)) . Prelude.filter logonPassed) $! allClientsS
+ mapM_ processAction $
+ (AnswerClients clientsChans ["LOBBY:JOINED", clientNick])
+ : [AnswerClients [chan] ("LOBBY:JOINED" : clientNick : lobbyNicks)]
+ ++ [ModifyClient (\cl -> cl{logonPassed = True}), SendServerMessage]
+
+{-
+processAction (clID, serverInfo, rnc) (RoomAddThisClient rID) =
+ processAction (
+ clID,
+ serverInfo,
+ adjust (\cl -> cl{roomID = rID, teamsInGame = if rID == 0 then teamsInGame cl else 0}) clID clients,
+ adjust (\r -> r{playersIDs = IntSet.insert clID (playersIDs r), playersIn = (playersIn r) + 1}) rID $
+ adjust (\r -> r{playersIDs = IntSet.delete clID (playersIDs r)}) 0 rooms
+ ) joinMsg
+ where
+ client = clients ! clID
+ joinMsg = if rID == 0 then
+ AnswerAllOthers ["LOBBY:JOINED", nick client]
+ else
+ AnswerThisRoom ["JOINED", nick client]
+ -}
+processAction (KickClient kickId) = do
+ modify (\s -> s{clientIndex = Just kickId})
+ processAction $ ByeClient "Kicked"
+
+
+processAction (BanClient seconds reason banId) = do
+ modify (\s -> s{clientIndex = Just banId})
+ clHost <- client's host
+ currentTime <- io $ getCurrentTime
+ let msg = "Ban for " `B.append` (B.pack . show $ seconds) `B.append` "seconds (" `B.append` msg` B.append` ")"
+ mapM_ processAction [
+ ModifyServerInfo (\s -> s{lastLogins = (clHost, (addUTCTime seconds $ currentTime, msg)) : lastLogins s})
+ , KickClient banId
+ ]
+
+
+processAction (KickRoomClient kickId) = do
+ modify (\s -> s{clientIndex = Just kickId})
+ ch <- client's sendChan
+ mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
+
+
+processAction (AddClient cl) = do
+ rnc <- gets roomsClients
+ si <- gets serverInfo
+ newClId <- io $ do
+ ci <- addClient rnc cl
+ t <- forkIO $ clientRecvLoop (clientSocket cl) (coreChan si) ci
+ forkIO $ clientSendLoop (clientSocket cl) t (coreChan si) (sendChan cl) ci
+
+ infoM "Clients" (show ci ++ ": New client. Time: " ++ show (connectTime cl))
+
+ return ci
+
+ modify (\s -> s{clientIndex = Just newClId})
+ processAction $ AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
+
+ si <- gets serverInfo
+ let newLogins = takeWhile (\(_ , (time, _)) -> (connectTime cl) `diffUTCTime` time <= 0) $ lastLogins si
+ let info = host cl `Prelude.lookup` newLogins
+ if isJust info then
+ mapM_ processAction [ModifyServerInfo (\s -> s{lastLogins = newLogins}), ByeClient (snd . fromJust $ info)]
+ else
+ processAction $ ModifyServerInfo (\s -> s{lastLogins = (host cl, (addUTCTime 10 $ connectTime cl, "Reconnected too fast")) : newLogins})
+
+
+processAction PingAll = do
+ rnc <- gets roomsClients
+ io (allClientsM rnc) >>= mapM_ (kickTimeouted rnc)
+ cis <- io $ allClientsM rnc
+ chans <- io $ mapM (client'sM rnc sendChan) cis
+ io $ mapM_ (modifyClient rnc (\cl -> cl{pingsQueue = pingsQueue cl + 1})) cis
+ processAction $ AnswerClients chans ["PING"]
+ where
+ kickTimeouted rnc ci = do
+ pq <- io $ client'sM rnc pingsQueue ci
+ when (pq > 0) $
+ withStateT (\as -> as{clientIndex = Just ci}) $
+ processAction (ByeClient "Ping timeout")
+
+
+processAction (StatsAction) = do
+ rnc <- gets roomsClients
+ si <- gets serverInfo
+ (roomsNum, clientsNum) <- io $ withRoomsAndClients rnc stats
+ io $ writeChan (dbQueries si) $ SendStats clientsNum (roomsNum - 1)
+ where
+ stats irnc = (length $ allRooms irnc, length $ allClients irnc)
+
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/ClientIO.hs
--- a/gameServer/ClientIO.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/ClientIO.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
module ClientIO where
import qualified Control.Exception as Exception
@@ -6,45 +6,75 @@
import Control.Concurrent
import Control.Monad
import System.IO
-import qualified Data.ByteString.UTF8 as BUTF8
-import qualified Data.ByteString as B
+import Network
+import Network.Socket.ByteString
+import qualified Data.ByteString.Char8 as B
----------------
import CoreTypes
+import RoomsAndClients
+import Utils
-listenLoop :: Handle -> Int -> [String] -> Chan CoreMessage -> Int -> IO ()
-listenLoop handle linesNumber buf chan clientID = do
- str <- liftM BUTF8.toString $ B.hGetLine handle
- if (linesNumber > 50) || (length str > 20000) then
- writeChan chan $ ClientMessage (clientID, ["QUIT", "Protocol violation"])
- else
- if str == "" then do
- writeChan chan $ ClientMessage (clientID, buf)
- yield
- listenLoop handle 0 [] chan clientID
- else
- listenLoop handle (linesNumber + 1) (buf ++ [str]) chan clientID
+
+pDelim :: B.ByteString
+pDelim = B.pack "\n\n"
+
+bs2Packets :: B.ByteString -> ([[B.ByteString]], B.ByteString)
+bs2Packets buf = unfoldrE extractPackets buf
+ where
+ extractPackets :: B.ByteString -> Either B.ByteString ([B.ByteString], B.ByteString)
+ extractPackets buf =
+ let buf' = until (not . B.isPrefixOf pDelim) (B.drop 2) buf in
+ let (bsPacket, bufTail) = B.breakSubstring pDelim buf' in
+ if B.null bufTail then
+ Left bsPacket
+ else
+ if B.null bsPacket then
+ Left bufTail
+ else
+ Right (B.splitWith (== '\n') bsPacket, bufTail)
+
-clientRecvLoop :: Handle -> Chan CoreMessage -> Int -> IO ()
-clientRecvLoop handle chan clientID =
- listenLoop handle 0 [] chan clientID
- `catch` (\e -> clientOff (show e) >> return ())
- where clientOff msg = writeChan chan $ ClientMessage (clientID, ["QUIT", msg]) -- if the client disconnects, we perform as if it sent QUIT message
+listenLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
+listenLoop sock chan ci = recieveWithBufferLoop B.empty
+ where
+ recieveWithBufferLoop recvBuf = do
+ recvBS <- recv sock 4096
+-- putStrLn $ show sock ++ " got smth: " ++ (show $ B.length recvBS)
+ unless (B.null recvBS) $ do
+ let (packets, newrecvBuf) = bs2Packets $ B.append recvBuf recvBS
+ forM_ packets sendPacket
+ recieveWithBufferLoop newrecvBuf
+
+ sendPacket packet = writeChan chan $ ClientMessage (ci, packet)
-clientSendLoop :: Handle -> Chan CoreMessage -> Chan [String] -> Int -> IO()
-clientSendLoop handle coreChan chan clientID = do
+
+clientRecvLoop :: Socket -> Chan CoreMessage -> ClientIndex -> IO ()
+clientRecvLoop s chan ci = do
+ msg <- (listenLoop s chan ci >> return "Connection closed") `catch` (return . B.pack . show)
+ clientOff msg
+ where
+ clientOff msg = writeChan chan $ ClientMessage (ci, ["QUIT", msg])
+
+
+
+clientSendLoop :: Socket -> ThreadId -> Chan CoreMessage -> Chan [B.ByteString] -> ClientIndex -> IO ()
+clientSendLoop s tId coreChan chan ci = do
answer <- readChan chan
- doClose <- Exception.handle
- (\(e :: Exception.IOException) -> if isQuit answer then return True else sendQuit e >> return False) $ do
- B.hPutStrLn handle $ BUTF8.fromString $ unlines answer
- hFlush handle
- return $ isQuit answer
+ Exception.handle
+ (\(e :: Exception.IOException) -> when (not $ isQuit answer) $ sendQuit e) $ do
+ sendAll s $ (B.unlines answer) `B.append` (B.singleton '\n')
- if doClose then
- Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on hClose") $ hClose handle
+ if (isQuit answer) then
+ do
+ Exception.handle (\(_ :: Exception.IOException) -> putStrLn "error on sClose") $ sClose s
+ killThread tId
+ writeChan coreChan $ Remove ci
else
- clientSendLoop handle coreChan chan clientID
+ clientSendLoop s tId coreChan chan ci
where
- sendQuit e = writeChan coreChan $ ClientMessage (clientID, ["QUIT", show e])
+ sendQuit e = do
+ putStrLn $ show e
+ writeChan coreChan $ ClientMessage (ci, ["QUIT", B.pack $ show e])
isQuit ("BYE":xs) = True
isQuit _ = False
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/CoreTypes.hs
--- a/gameServer/CoreTypes.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/CoreTypes.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,106 +1,101 @@
+{-# LANGUAGE OverloadedStrings #-}
module CoreTypes where
import System.IO
+import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.STM
import Data.Word
import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.Sequence(Seq, empty)
import Data.Time
import Network
import Data.Function
+import Data.ByteString.Char8 as B
+import RoomsAndClients
+
+type ClientChan = Chan [B.ByteString]
data ClientInfo =
ClientInfo
{
- clientUID :: !Int,
- sendChan :: Chan [String],
- clientHandle :: Handle,
- host :: String,
+ sendChan :: ClientChan,
+ clientSocket :: Socket,
+ host :: B.ByteString,
connectTime :: UTCTime,
- nick :: String,
- webPassword :: String,
+ nick :: B.ByteString,
+ webPassword :: B.ByteString,
logonPassed :: Bool,
clientProto :: !Word16,
- roomID :: !Int,
+ roomID :: RoomIndex,
pingsQueue :: !Word,
isMaster :: Bool,
- isReady :: Bool,
+ isReady :: !Bool,
isAdministrator :: Bool,
- clientClan :: String,
+ clientClan :: B.ByteString,
teamsInGame :: Word
}
instance Show ClientInfo where
- show ci = show (clientUID ci)
- ++ " nick: " ++ (nick ci)
- ++ " host: " ++ (host ci)
+ show ci = " nick: " ++ (unpack $ nick ci) ++ " host: " ++ (unpack $ host ci)
instance Eq ClientInfo where
- (==) = (==) `on` clientHandle
+ (==) = (==) `on` clientSocket
data HedgehogInfo =
- HedgehogInfo String String
+ HedgehogInfo B.ByteString B.ByteString
data TeamInfo =
TeamInfo
{
- teamownerId :: !Int,
- teamowner :: String,
- teamname :: String,
- teamcolor :: String,
- teamgrave :: String,
- teamfort :: String,
- teamvoicepack :: String,
- teamflag :: String,
+ teamownerId :: ClientIndex,
+ teamowner :: B.ByteString,
+ teamname :: B.ByteString,
+ teamcolor :: B.ByteString,
+ teamgrave :: B.ByteString,
+ teamfort :: B.ByteString,
+ teamvoicepack :: B.ByteString,
+ teamflag :: B.ByteString,
difficulty :: Int,
hhnum :: Int,
hedgehogs :: [HedgehogInfo]
}
instance Show TeamInfo where
- show ti = "owner: " ++ (teamowner ti)
- ++ "name: " ++ (teamname ti)
- ++ "color: " ++ (teamcolor ti)
+ show ti = "owner: " ++ (unpack $ teamowner ti)
+ ++ "name: " ++ (unpack $ teamname ti)
+ ++ "color: " ++ (unpack $ teamcolor ti)
data RoomInfo =
RoomInfo
{
- roomUID :: !Int,
- masterID :: !Int,
- name :: String,
- password :: String,
+ masterID :: ClientIndex,
+ name :: B.ByteString,
+ password :: B.ByteString,
roomProto :: Word16,
teams :: [TeamInfo],
gameinprogress :: Bool,
playersIn :: !Int,
readyPlayers :: !Int,
- playersIDs :: IntSet.IntSet,
isRestrictedJoins :: Bool,
isRestrictedTeams :: Bool,
- roundMsgs :: Seq String,
- leftTeams :: [String],
+ roundMsgs :: Seq B.ByteString,
+ leftTeams :: [B.ByteString],
teamsAtStart :: [TeamInfo],
- params :: Map.Map String [String]
+ params :: Map.Map B.ByteString [B.ByteString]
}
instance Show RoomInfo where
- show ri = show (roomUID ri)
- ++ ", players ids: " ++ show (IntSet.size $ playersIDs ri)
- ++ ", players: " ++ show (playersIn ri)
+ show ri = ", players: " ++ show (playersIn ri)
++ ", ready: " ++ show (readyPlayers ri)
++ ", teams: " ++ show (teams ri)
-instance Eq RoomInfo where
- (==) = (==) `on` roomUID
-
+newRoom :: RoomInfo
newRoom = (
RoomInfo
- 0
- 0
+ undefined
""
""
0
@@ -108,7 +103,6 @@
False
0
0
- IntSet.empty
False
False
Data.Sequence.empty
@@ -128,15 +122,15 @@
ServerInfo
{
isDedicated :: Bool,
- serverMessage :: String,
- serverMessageForOldVersions :: String,
+ serverMessage :: B.ByteString,
+ serverMessageForOldVersions :: B.ByteString,
latestReleaseVersion :: Word16,
listenPort :: PortNumber,
nextRoomID :: Int,
- dbHost :: String,
- dbLogin :: String,
- dbPassword :: String,
- lastLogins :: [(String, (UTCTime, String))],
+ dbHost :: B.ByteString,
+ dbLogin :: B.ByteString,
+ dbPassword :: B.ByteString,
+ lastLogins :: [(B.ByteString, (UTCTime, B.ByteString))],
stats :: TMVar StatisticsInfo,
coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery
@@ -145,12 +139,13 @@
instance Show ServerInfo where
show _ = "Server Info"
+newServerInfo :: TMVar StatisticsInfo -> Chan CoreMessage -> Chan DBQuery -> ServerInfo
newServerInfo = (
ServerInfo
True
"http://www.hedgewars.org/
"
- "Hedgewars 0.9.15 is out! Please update.
Download page here
"
- 37
+ "Hedgewars 0.9.14.1 is out! Please update.
Download page here
"
+ 35
46631
0
""
@@ -160,29 +155,35 @@
)
data AccountInfo =
- HasAccount String Bool
+ HasAccount B.ByteString Bool
| Guest
| Admin
deriving (Show, Read)
data DBQuery =
- CheckAccount Int String String
+ CheckAccount ClientIndex B.ByteString B.ByteString
| ClearCache
| SendStats Int Int
deriving (Show, Read)
data CoreMessage =
Accept ClientInfo
- | ClientMessage (Int, [String])
- | ClientAccountInfo (Int, AccountInfo)
+ | ClientMessage (ClientIndex, [B.ByteString])
+ | ClientAccountInfo (ClientIndex, AccountInfo)
| TimerAction Int
-
-type Clients = IntMap.IntMap ClientInfo
-type Rooms = IntMap.IntMap RoomInfo
+ | Remove ClientIndex
---type ClientsTransform = [ClientInfo] -> [ClientInfo]
---type RoomsTransform = [RoomInfo] -> [RoomInfo]
---type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
---type Answer = ServerInfo -> (HandlesSelector, [String])
+instance Show CoreMessage where
+ show (Accept _) = "Accept"
+ show (ClientMessage _) = "ClientMessage"
+ show (ClientAccountInfo _) = "ClientAccountInfo"
+ show (TimerAction _) = "TimerAction"
+ show (Remove _) = "Remove"
-type ClientsSelector = Clients -> Rooms -> [Int]
+type MRnC = MRoomsAndClients RoomInfo ClientInfo
+type IRnC = IRoomsAndClients RoomInfo ClientInfo
+
+data Notice =
+ NickAlreadyInUse
+ | AdminLeft
+ deriving Enum
\ No newline at end of file
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/HWProtoCore.hs
--- a/gameServer/HWProtoCore.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/HWProtoCore.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,72 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
module HWProtoCore where
-import qualified Data.IntMap as IntMap
-import Data.Foldable
+import Control.Monad.Reader
import Data.Maybe
+import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import Actions
-import Utils
import HWProtoNEState
import HWProtoLobbyState
import HWProtoInRoomState
+import HandlerUtils
+import RoomsAndClients
+import Utils
handleCmd, handleCmd_loggedin :: CmdHandler
-handleCmd clID _ _ ["PING"] = [AnswerThisClient ["PONG"]]
+
+handleCmd ["PING"] = answerClient ["PONG"]
+
-handleCmd clID clients rooms ("QUIT" : xs) =
- [ByeClient msg]
+handleCmd ("QUIT" : xs) = return [ByeClient msg]
where
- msg = if not $ null xs then head xs else ""
+ msg = if not $ null xs then head xs else "bye"
-handleCmd clID clients _ ["PONG"] =
- if pingsQueue client == 0 then
- [ProtocolError "Protocol violation"]
- else
- [ModifyClient (\cl -> cl{pingsQueue = pingsQueue cl - 1})]
- where
- client = clients IntMap.! clID
+handleCmd ["PONG"] = do
+ cl <- thisClient
+ if pingsQueue cl == 0 then
+ return [ProtocolError "Protocol violation"]
+ else
+ return [ModifyClient (\c -> c{pingsQueue = pingsQueue c - 1})]
-
-handleCmd clID clients rooms cmd =
- if not $ logonPassed client then
- handleCmd_NotEntered clID clients rooms cmd
- else
- handleCmd_loggedin clID clients rooms cmd
- where
- client = clients IntMap.! clID
+handleCmd cmd = do
+ (ci, irnc) <- ask
+ if logonPassed (irnc `client` ci) then
+ handleCmd_loggedin cmd
+ else
+ handleCmd_NotEntered cmd
-handleCmd_loggedin clID clients rooms ["INFO", asknick] =
+handleCmd_loggedin ["INFO", asknick] = do
+ (_, rnc) <- ask
+ maybeClientId <- clientByNick asknick
+ let noSuchClient = isNothing maybeClientId
+ let clientId = fromJust maybeClientId
+ let cl = rnc `client` fromJust maybeClientId
+ let roomId = clientRoom rnc clientId
+ let clRoom = room rnc roomId
+ let roomMasterSign = if isMaster cl then "@" else ""
+ let adminSign = if isAdministrator cl then "@" else ""
+ let roomInfo = if roomId /= lobbyId then roomMasterSign `B.append` "room " `B.append` (name clRoom) else adminSign `B.append` "lobby"
+ let roomStatus = if gameinprogress clRoom then
+ if teamsInGame cl > 0 then "(playing)" else "(spectating)"
+ else
+ ""
if noSuchClient then
- []
- else
- [AnswerThisClient
- ["INFO",
- nick client,
- "[" ++ host client ++ "]",
- protoNumber2ver $ clientProto client,
- "[" ++ roomInfo ++ "]" ++ roomStatus]]
- where
- maybeClient = find (\cl -> asknick == nick cl) clients
- noSuchClient = isNothing maybeClient
- client = fromJust maybeClient
- room = rooms IntMap.! roomID client
- roomInfo = if roomID client /= 0 then roomMasterSign ++ "room " ++ (name room) else adminSign ++ "lobby"
- roomMasterSign = if isMaster client then "@" else ""
- adminSign = if isAdministrator client then "@" else ""
- roomStatus =
- if gameinprogress room
- then if teamsInGame client > 0 then "(playing)" else "(spectating)"
- else ""
+ return []
+ else
+ answerClient [
+ "INFO",
+ nick cl,
+ "[" `B.append` host cl `B.append` "]",
+ protoNumber2ver $ clientProto cl,
+ "[" `B.append` roomInfo `B.append` "]" `B.append` roomStatus
+ ]
-handleCmd_loggedin clID clients rooms cmd =
- if roomID client == 0 then
- handleCmd_lobby clID clients rooms cmd
- else
- handleCmd_inRoom clID clients rooms cmd
- where
- client = clients IntMap.! clID
+handleCmd_loggedin cmd = do
+ (ci, rnc) <- ask
+ if clientRoom rnc ci == lobbyId then
+ handleCmd_lobby cmd
+ else
+ handleCmd_inRoom cmd
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/HWProtoInRoomState.hs
--- a/gameServer/HWProtoInRoomState.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/HWProtoInRoomState.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,196 +1,254 @@
+{-# LANGUAGE OverloadedStrings #-}
module HWProtoInRoomState where
-import qualified Data.Foldable as Foldable
-import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
-import Data.Sequence(Seq, (|>), (><), fromList, empty)
+import Data.Sequence((|>), empty)
import Data.List
import Data.Maybe
+import qualified Data.ByteString.Char8 as B
+import Control.Monad
+import Control.Monad.Reader
--------------------------------------
import CoreTypes
import Actions
import Utils
-
+import HandlerUtils
+import RoomsAndClients
handleCmd_inRoom :: CmdHandler
-handleCmd_inRoom clID clients _ ["CHAT", msg] =
- [AnswerOthersInRoom ["CHAT", clientNick, msg]]
- where
- clientNick = nick $ clients IntMap.! clID
+handleCmd_inRoom ["CHAT", msg] = do
+ n <- clientNick
+ s <- roomOthersChans
+ return [AnswerClients s ["CHAT", n, msg]]
-handleCmd_inRoom clID clients rooms ["PART"] =
- [RoomRemoveThisClient "part"]
- where
- client = clients IntMap.! clID
+handleCmd_inRoom ["PART"] = return [MoveToLobby "part"]
+handleCmd_inRoom ["PART", msg] = return [MoveToLobby $ "part: " `B.append` msg]
-handleCmd_inRoom clID clients rooms ("CFG" : paramName : paramStrs)
- | null paramStrs = [ProtocolError "Empty config entry"]
- | isMaster client =
- [ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
- AnswerOthersInRoom ("CFG" : paramName : paramStrs)]
- | otherwise = [ProtocolError "Not room master"]
- where
- client = clients IntMap.! clID
+handleCmd_inRoom ("CFG" : paramName : paramStrs)
+ | null paramStrs = return [ProtocolError "Empty config entry"]
+ | otherwise = do
+ chans <- roomOthersChans
+ cl <- thisClient
+ if isMaster cl then
+ return [
+ ModifyRoom (\r -> r{params = Map.insert paramName paramStrs (params r)}),
+ AnswerClients chans ("CFG" : paramName : paramStrs)]
+ else
+ return [ProtocolError "Not room master"]
-handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
- | length hhsInfo == 15 && clientProto client < 30 = handleCmd_inRoom clID clients rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : " " : flag : difStr : hhsInfo)
- | length hhsInfo /= 16 = [ProtocolError "Corrupted hedgehogs info"]
- | length (teams room) == 8 = [Warning "too many teams"]
- | canAddNumber <= 0 = [Warning "too many hedgehogs"]
- | isJust findTeam = [Warning "There's already a team with same name in the list"]
- | gameinprogress room = [Warning "round in progress"]
- | isRestrictedTeams room = [Warning "restricted"]
- | otherwise =
- [ModifyRoom (\r -> r{teams = teams r ++ [newTeam]}),
- ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
- AnswerThisClient ["TEAM_ACCEPTED", name],
- AnswerOthersInRoom $ teamToNet (clientProto client) newTeam,
- AnswerOthersInRoom ["TEAM_COLOR", name, color]
- ]
+handleCmd_inRoom ("ADD_TEAM" : name : color : grave : fort : voicepack : flag : difStr : hhsInfo)
+ | length hhsInfo /= 16 = return [ProtocolError "Corrupted hedgehogs info"]
+ | otherwise = do
+ (ci, rnc) <- ask
+ r <- thisRoom
+ clNick <- clientNick
+ clChan <- thisClientChans
+ othersChans <- roomOthersChans
+ return $
+ if not . null . drop 5 $ teams r then
+ [Warning "too many teams"]
+ else if canAddNumber r <= 0 then
+ [Warning "too many hedgehogs"]
+ else if isJust $ findTeam r then
+ [Warning "There's already a team with same name in the list"]
+ else if gameinprogress r then
+ [Warning "round in progress"]
+ else if isRestrictedTeams r then
+ [Warning "restricted"]
+ else
+ [ModifyRoom (\r -> r{teams = teams r ++ [newTeam ci clNick r]}),
+ ModifyClient (\c -> c{teamsInGame = teamsInGame c + 1, clientClan = color}),
+ AnswerClients clChan ["TEAM_ACCEPTED", name],
+ AnswerClients othersChans $ teamToNet $ newTeam ci clNick r,
+ AnswerClients othersChans ["TEAM_COLOR", name, color]
+ ]
+ where
+ canAddNumber r = 48 - (sum . map hhnum $ teams r)
+ findTeam = find (\t -> name == teamname t) . teams
+ newTeam ci clNick r = (TeamInfo ci clNick name color grave fort voicepack flag difficulty (newTeamHHNum r) (hhsList hhsInfo))
+ difficulty = case B.readInt difStr of
+ Just (i, t) | B.null t -> fromIntegral i
+ otherwise -> 0
+ hhsList [] = []
+ hhsList [_] = error "Hedgehogs list with odd elements number"
+ hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
+ newTeamHHNum r = min 4 (canAddNumber r)
+
+handleCmd_inRoom ["REMOVE_TEAM", name] = do
+ (ci, rnc) <- ask
+ r <- thisRoom
+ clNick <- clientNick
+
+ let maybeTeam = findTeam r
+ let team = fromJust maybeTeam
+
+ return $
+ if isNothing $ findTeam r then
+ [Warning "REMOVE_TEAM: no such team"]
+ else if clNick /= teamowner team then
+ [ProtocolError "Not team owner!"]
+ else
+ [RemoveTeam name,
+ ModifyClient
+ (\c -> c{
+ teamsInGame = teamsInGame c - 1,
+ clientClan = if teamsInGame c == 1 then undefined else anotherTeamClan ci r
+ })
+ ]
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- canAddNumber = 48 - (sum . map hhnum $ teams room)
- findTeam = find (\t -> name == teamname t) $ teams room
- newTeam = (TeamInfo clID (nick client) name color grave fort voicepack flag difficulty newTeamHHNum (hhsList hhsInfo))
- difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
- hhsList [] = []
- hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
- newTeamHHNum = min 4 canAddNumber
-
-handleCmd_inRoom clID clients rooms ["REMOVE_TEAM", teamName]
- | noSuchTeam = [Warning "REMOVE_TEAM: no such team"]
- | nick client /= teamowner team = [ProtocolError "Not team owner!"]
- | otherwise =
- [RemoveTeam teamName,
- ModifyClient (\c -> c{teamsInGame = teamsInGame c - 1, clientClan = if teamsInGame client == 1 then undefined else anotherTeamClan})
- ]
- where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
- anotherTeamClan = teamcolor $ fromJust $ find (\t -> teamownerId t == clID) $ teams room
+ anotherTeamClan ci = teamcolor . fromJust . find (\t -> teamownerId t == ci) . teams
+ findTeam = find (\t -> name == teamname t) . teams
-handleCmd_inRoom clID clients rooms ["HH_NUM", teamName, numberStr]
- | not $ isMaster client = [ProtocolError "Not room master"]
- | hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) = []
- | otherwise =
- [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
- AnswerOthersInRoom ["HH_NUM", teamName, show hhNumber]]
+handleCmd_inRoom ["HH_NUM", teamName, numberStr] = do
+ cl <- thisClient
+ others <- roomOthersChans
+ r <- thisRoom
+
+ let maybeTeam = findTeam r
+ let team = fromJust maybeTeam
+
+ return $
+ if not $ isMaster cl then
+ [ProtocolError "Not room master"]
+ else if hhNumber < 1 || hhNumber > 8 || isNothing maybeTeam || hhNumber > (canAddNumber r) + (hhnum team) then
+ []
+ else
+ [ModifyRoom $ modifyTeam team{hhnum = hhNumber},
+ AnswerClients others ["HH_NUM", teamName, B.pack $ show hhNumber]]
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
- canAddNumber = 48 - (sum . map hhnum $ teams room)
+ hhNumber = case B.readInt numberStr of
+ Just (i, t) | B.null t -> fromIntegral i
+ otherwise -> 0
+ findTeam = find (\t -> teamName == teamname t) . teams
+ canAddNumber = (-) 48 . sum . map hhnum . teams
+
-handleCmd_inRoom clID clients rooms ["TEAM_COLOR", teamName, newColor]
- | not $ isMaster client = [ProtocolError "Not room master"]
- | noSuchTeam = []
- | otherwise = [ModifyRoom $ modifyTeam team{teamcolor = newColor},
- AnswerOthersInRoom ["TEAM_COLOR", teamName, newColor],
+handleCmd_inRoom ["TEAM_COLOR", teamName, newColor] = do
+ cl <- thisClient
+ others <- roomOthersChans
+ r <- thisRoom
+
+ let maybeTeam = findTeam r
+ let team = fromJust maybeTeam
+
+ return $
+ if not $ isMaster cl then
+ [ProtocolError "Not room master"]
+ else if isNothing maybeTeam then
+ []
+ else
+ [ModifyRoom $ modifyTeam team{teamcolor = newColor},
+ AnswerClients others ["TEAM_COLOR", teamName, newColor],
ModifyClient2 (teamownerId team) (\c -> c{clientClan = newColor})]
where
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams room
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
+ findTeam = find (\t -> teamName == teamname t) . teams
-handleCmd_inRoom clID clients rooms ["TOGGLE_READY"] =
- [ModifyClient (\c -> c{isReady = not $ isReady client}),
- ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady client then -1 else 1)}),
- AnswerThisRoom [if isReady client then "NOT_READY" else "READY", nick client]]
- where
- client = clients IntMap.! clID
+handleCmd_inRoom ["TOGGLE_READY"] = do
+ cl <- thisClient
+ chans <- roomClientsChans
+ return [
+ ModifyClient (\c -> c{isReady = not $ isReady cl}),
+ ModifyRoom (\r -> r{readyPlayers = readyPlayers r + (if isReady cl then -1 else 1)}),
+ AnswerClients chans [if isReady cl then "NOT_READY" else "READY", nick cl]
+ ]
+handleCmd_inRoom ["START_GAME"] = do
+ cl <- thisClient
+ r <- thisRoom
+ chans <- roomClientsChans
-handleCmd_inRoom clID clients rooms ["START_GAME"] =
- if isMaster client && (playersIn room == readyPlayers room) && (not . gameinprogress) room then
- if enoughClans then
- [ModifyRoom
+ if isMaster cl && (playersIn r == readyPlayers r) && (not $ gameinprogress r) then
+ if enoughClans r then
+ return [
+ ModifyRoom
(\r -> r{
gameinprogress = True,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = teams r}
),
- AnswerThisRoom ["RUN_GAME"]]
+ AnswerClients chans ["RUN_GAME"]
+ ]
+ else
+ return [Warning "Less than two clans!"]
else
- [Warning "Less than two clans!"]
- else
- []
+ return []
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams room
+ enoughClans = not . null . drop 1 . group . map teamcolor . teams
-handleCmd_inRoom clID clients rooms ["EM", msg] =
- if (teamsInGame client > 0) && isLegal then
- (AnswerOthersInRoom ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
- else
- []
+handleCmd_inRoom ["EM", msg] = do
+ cl <- thisClient
+ r <- thisRoom
+ chans <- roomOthersChans
+
+ if (teamsInGame cl > 0) && isLegal then
+ return $ (AnswerClients chans ["EM", msg]) : [ModifyRoom (\r -> r{roundMsgs = roundMsgs r |> msg}) | not isKeepAlive]
+ else
+ return []
where
- client = clients IntMap.! clID
(isLegal, isKeepAlive) = checkNetCmd msg
-handleCmd_inRoom clID clients rooms ["ROUNDFINISHED"] =
- if isMaster client then
- [ModifyRoom
+
+handleCmd_inRoom ["ROUNDFINISHED", _] = do
+ cl <- thisClient
+ r <- thisRoom
+ chans <- roomClientsChans
+
+ if isMaster cl && (gameinprogress r) then
+ return $ (ModifyRoom
(\r -> r{
gameinprogress = False,
readyPlayers = 0,
roundMsgs = empty,
leftTeams = [],
teamsAtStart = []}
- ),
- UnreadyRoomClients
- ] ++ answerRemovedTeams
- else
- []
+ ))
+ : UnreadyRoomClients
+ : answerRemovedTeams chans r
+ else
+ return []
where
- client = clients IntMap.! clID
- room = rooms IntMap.! (roomID client)
- answerRemovedTeams = map (\t -> AnswerThisRoom ["REMOVE_TEAM", t]) $ leftTeams room
-
+ answerRemovedTeams chans = map (\t -> AnswerClients chans ["REMOVE_TEAM", t]) . leftTeams
-handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_JOINS"]
- | isMaster client = [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
- | otherwise = [ProtocolError "Not room master"]
- where
- client = clients IntMap.! clID
+handleCmd_inRoom ["TOGGLE_RESTRICT_JOINS"] = do
+ cl <- thisClient
+ return $
+ if not $ isMaster cl then
+ [ProtocolError "Not room master"]
+ else
+ [ModifyRoom (\r -> r{isRestrictedJoins = not $ isRestrictedJoins r})]
-handleCmd_inRoom clID clients _ ["TOGGLE_RESTRICT_TEAMS"]
- | isMaster client = [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
- | otherwise = [ProtocolError "Not room master"]
- where
- client = clients IntMap.! clID
-
-handleCmd_inRoom clID clients rooms ["KICK", kickNick] =
- [KickRoomClient kickID | isMaster client && not noSuchClient && (kickID /= clID) && (roomID client == roomID kickClient)]
- where
- client = clients IntMap.! clID
- maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
- noSuchClient = isNothing maybeClient
- kickClient = fromJust maybeClient
- kickID = clientUID kickClient
+handleCmd_inRoom ["TOGGLE_RESTRICT_TEAMS"] = do
+ cl <- thisClient
+ return $
+ if not $ isMaster cl then
+ [ProtocolError "Not room master"]
+ else
+ [ModifyRoom (\r -> r{isRestrictedTeams = not $ isRestrictedTeams r})]
-handleCmd_inRoom clID clients _ ["TEAMCHAT", msg] =
- [AnswerSameClan ["EM", engineMsg]]
+handleCmd_inRoom ["KICK", kickNick] = do
+ (thisClientId, rnc) <- ask
+ maybeClientId <- clientByNick kickNick
+ master <- liftM isMaster thisClient
+ let kickId = fromJust maybeClientId
+ let sameRoom = (clientRoom rnc thisClientId) == (clientRoom rnc kickId)
+ return
+ [KickRoomClient kickId | master && isJust maybeClientId && (kickId /= thisClientId) && sameRoom]
+
+
+handleCmd_inRoom ["TEAMCHAT", msg] = do
+ cl <- thisClient
+ chans <- roomSameClanChans
+ return [AnswerClients chans ["EM", engineMsg cl]]
where
- client = clients IntMap.! clID
- engineMsg = toEngineMsg $ 'b' : ((nick client) ++ "(team): " ++ msg ++ "\x20\x20")
+ engineMsg cl = toEngineMsg $ "b" `B.append` (nick cl) `B.append` "(team): " `B.append` msg `B.append` "\x20\x20"
-handleCmd_inRoom clID _ _ _ = [ProtocolError "Incorrect command (state: in room)"]
+handleCmd_inRoom _ = return [ProtocolError "Incorrect command (state: in room)"]
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/HWProtoLobbyState.hs
--- a/gameServer/HWProtoLobbyState.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/HWProtoLobbyState.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,185 +1,175 @@
+{-# LANGUAGE OverloadedStrings #-}
module HWProtoLobbyState where
import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Foldable as Foldable
import Data.Maybe
import Data.List
import Data.Word
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
+import Control.DeepSeq
--------------------------------------
import CoreTypes
import Actions
import Utils
+import HandlerUtils
+import RoomsAndClients
-answerAllTeams protocol teams = concatMap toAnswer teams
+answerAllTeams cl = concatMap toAnswer
where
+ clChan = sendChan cl
toAnswer team =
- [AnswerThisClient $ teamToNet protocol team,
- AnswerThisClient ["TEAM_COLOR", teamname team, teamcolor team],
- AnswerThisClient ["HH_NUM", teamname team, show $ hhnum team]]
+ [AnswerClients [clChan] $ teamToNet team,
+ AnswerClients [clChan] ["TEAM_COLOR", teamname team, teamcolor team],
+ AnswerClients [clChan] ["HH_NUM", teamname team, B.pack . show $ hhnum team]]
handleCmd_lobby :: CmdHandler
-handleCmd_lobby clID clients rooms ["LIST"] =
- [AnswerThisClient ("ROOMS" : roomsInfoList)]
+
+handleCmd_lobby ["LIST"] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ rooms <- allRoomInfos
+ let roomsInfoList = concatMap (roomInfo irnc) . filter (\r -> (roomProto r == clientProto cl) && not (isRestrictedJoins r))
+ return [AnswerClients [sendChan cl] ("ROOMS" : roomsInfoList rooms)]
where
- roomsInfoList = concatMap roomInfo sameProtoRooms
- sameProtoRooms = filter (\r -> (roomProto r == protocol) && not (isRestrictedJoins r)) roomsList
- roomsList = IntMap.elems rooms
- protocol = clientProto client
- client = clients IntMap.! clID
- roomInfo room
- | clientProto client < 28 = [
+ roomInfo irnc room = [
+ showB $ gameinprogress room,
name room,
- show (playersIn room) ++ "(" ++ show (length $ teams room) ++ ")",
- show $ gameinprogress room
- ]
- | otherwise = [
- show $ gameinprogress room,
- name room,
- show $ playersIn room,
- show $ length $ teams room,
- nick $ clients IntMap.! (masterID room),
+ showB $ playersIn room,
+ showB $ length $ teams room,
+ nick $ irnc `client` masterID room,
head (Map.findWithDefault ["+gen+"] "MAP" (params room)),
head (Map.findWithDefault ["Default"] "SCHEME" (params room)),
head (Map.findWithDefault ["Default"] "AMMO" (params room))
]
-handleCmd_lobby clID clients _ ["CHAT", msg] =
- [AnswerOthersInRoom ["CHAT", clientNick, msg]]
- where
- clientNick = nick $ clients IntMap.! clID
+
+handleCmd_lobby ["CHAT", msg] = do
+ n <- clientNick
+ s <- roomOthersChans
+ return [AnswerClients s ["CHAT", n, msg]]
+
+handleCmd_lobby ["CREATE_ROOM", newRoom, roomPassword]
+ | illegalName newRoom = return [Warning "Illegal room name"]
+ | otherwise = do
+ rs <- allRoomInfos
+ cl <- thisClient
+ return $ if isJust $ find (\room -> newRoom == name room) rs then
+ [Warning "Room exists"]
+ else
+ [
+ AddRoom newRoom roomPassword,
+ AnswerClients [sendChan cl] ["NOT_READY", nick cl]
+ ]
-handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, roomPassword]
- | haveSameRoom = [Warning "Room exists"]
- | illegalName newRoom = [Warning "Illegal room name"]
- | otherwise =
- [RoomRemoveThisClient "", -- leave lobby
- AddRoom newRoom roomPassword,
- AnswerThisClient ["NOT_READY", clientNick]
- ]
- where
- clientNick = nick $ clients IntMap.! clID
- haveSameRoom = isJust $ find (\room -> newRoom == name room) $ IntMap.elems rooms
-
-
-handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom] =
- handleCmd_lobby clID clients rooms ["CREATE_ROOM", newRoom, ""]
+handleCmd_lobby ["CREATE_ROOM", newRoom] =
+ handleCmd_lobby ["CREATE_ROOM", newRoom, ""]
-handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, roomPassword]
- | noSuchRoom = [Warning "No such room"]
- | isRestrictedJoins jRoom = [Warning "Joining restricted"]
- | roomPassword /= password jRoom = [Warning "Wrong password"]
- | otherwise =
- [RoomRemoveThisClient "", -- leave lobby
- RoomAddThisClient rID] -- join room
- ++ answerNicks
- ++ answerReady
- ++ [AnswerThisRoom ["NOT_READY", nick client]]
- ++ answerFullConfig
- ++ answerTeams
- ++ watchRound
- where
- noSuchRoom = isNothing mbRoom
- mbRoom = find (\r -> roomName == name r && roomProto r == clientProto client) $ IntMap.elems rooms
- jRoom = fromJust mbRoom
- rID = roomUID jRoom
- client = clients IntMap.! clID
- roomClientsIDs = IntSet.elems $ playersIDs jRoom
- answerNicks =
- [AnswerThisClient $ "JOINED" :
- map (\clID -> nick $ clients IntMap.! clID) roomClientsIDs | playersIn jRoom /= 0]
- answerReady = map
- ((\ c ->
- AnswerThisClient
- [if isReady c then "READY" else "NOT_READY", nick c])
- . (\ clID -> clients IntMap.! clID))
- roomClientsIDs
+handleCmd_lobby ["JOIN_ROOM", roomName, roomPassword] = do
+ (ci, irnc) <- ask
+ let ris = allRooms irnc
+ cl <- thisClient
+ let maybeRI = find (\ri -> roomName == name (irnc `room` ri)) ris
+ let jRI = fromJust maybeRI
+ let jRoom = irnc `room` jRI
+ let jRoomClients = map (client irnc) $ roomClients irnc jRI
+ let nicks = map nick jRoomClients
+ let chans = map sendChan (cl : jRoomClients)
+ return $
+ if isNothing maybeRI then
+ [Warning "No such rooms"]
+ else if isRestrictedJoins jRoom then
+ [Warning "Joining restricted"]
+ else if roomPassword /= password jRoom then
+ [Warning "Wrong password"]
+ else
+ [
+ MoveToRoom jRI,
+ AnswerClients [sendChan cl] $ "JOINED" : nicks,
+ AnswerClients chans ["NOT_READY", nick cl]
+ ]
+ ++ (map (readynessMessage cl) jRoomClients)
+ ++ (answerFullConfig cl $ params jRoom)
+ ++ (answerTeams cl jRoom)
+ ++ (watchRound cl jRoom)
- toAnswer (paramName, paramStrs) = AnswerThisClient $ "CFG" : paramName : paramStrs
-
- answerFullConfig = map toAnswer ((Data.List.reverse . Data.List.sort $ leftConfigPart) ++ rightConfigPart)
- (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p == "MAP" || p == "MAPGEN" || p == "SCHEME") (Map.toList $ params jRoom)
+ where
+ readynessMessage cl c = AnswerClients [sendChan cl] [if isReady c then "READY" else "NOT_READY", nick c]
+
+ toAnswer cl (paramName, paramStrs) = AnswerClients [sendChan cl] $ "CFG" : paramName : paramStrs
- watchRound = if not $ gameinprogress jRoom then
+ answerFullConfig cl params = map (toAnswer cl) (leftConfigPart ++ rightConfigPart)
+ where
+ (leftConfigPart, rightConfigPart) = partition (\(p, _) -> p /= "MAP") $ Map.toList params
+
+ answerTeams cl jRoom = let f = if gameinprogress jRoom then teamsAtStart else teams in answerAllTeams cl $ f jRoom
+
+ watchRound cl jRoom = if not $ gameinprogress jRoom then
[]
else
- [AnswerThisClient ["RUN_GAME"],
- AnswerThisClient $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
+ [AnswerClients [sendChan cl] ["RUN_GAME"],
+ AnswerClients [sendChan cl] $ "EM" : toEngineMsg "e$spectate 1" : Foldable.toList (roundMsgs jRoom)]
- answerTeams = if gameinprogress jRoom then
- answerAllTeams (clientProto client) (teamsAtStart jRoom)
- else
- answerAllTeams (clientProto client) (teams jRoom)
+
+handleCmd_lobby ["JOIN_ROOM", roomName] =
+ handleCmd_lobby ["JOIN_ROOM", roomName, ""]
-handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName] =
- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName, ""]
-
-
-handleCmd_lobby clID clients rooms ["FOLLOW", asknick] =
- if noSuchClient || roomID followClient == 0 then
- []
- else
- handleCmd_lobby clID clients rooms ["JOIN_ROOM", roomName]
- where
- maybeClient = Foldable.find (\cl -> asknick == nick cl) clients
- noSuchClient = isNothing maybeClient
- followClient = fromJust maybeClient
- roomName = name $ rooms IntMap.! roomID followClient
-
+handleCmd_lobby ["FOLLOW", asknick] = do
+ (_, rnc) <- ask
+ ci <- clientByNick asknick
+ let ri = clientRoom rnc $ fromJust ci
+ let clRoom = room rnc ri
+ if isNothing ci || ri == lobbyId then
+ return []
+ else
+ handleCmd_lobby ["JOIN_ROOM", name clRoom]
---------------------------
-- Administrator's stuff --
-handleCmd_lobby clID clients rooms ["KICK", kickNick] =
- [KickClient kickID | isAdministrator client && (not noSuchClient) && kickID /= clID]
- where
- client = clients IntMap.! clID
- maybeClient = Foldable.find (\cl -> kickNick == nick cl) clients
- noSuchClient = isNothing maybeClient
- kickID = clientUID $ fromJust maybeClient
+handleCmd_lobby ["KICK", kickNick] = do
+ (ci, _) <- ask
+ cl <- thisClient
+ kickId <- clientByNick kickNick
+ return [KickClient $ fromJust kickId | isAdministrator cl && isJust kickId && fromJust kickId /= ci]
-handleCmd_lobby clID clients rooms ["BAN", banNick] =
- if not $ isAdministrator client then
- []
- else
- BanClient banNick : handleCmd_lobby clID clients rooms ["KICK", banNick]
- where
- client = clients IntMap.! clID
-
+handleCmd_lobby ["BAN", banNick, reason] = do
+ (ci, _) <- ask
+ cl <- thisClient
+ banId <- clientByNick banNick
+ return [BanClient 60 reason (fromJust banId) | isAdministrator cl && isJust banId && fromJust banId /= ci]
-handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_NEW", newMessage] =
- [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator client]
- where
- client = clients IntMap.! clID
+handleCmd_lobby ["SET_SERVER_VAR", "MOTD_NEW", newMessage] = do
+ cl <- thisClient
+ return [ModifyServerInfo (\si -> si{serverMessage = newMessage}) | isAdministrator cl]
-handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "MOTD_OLD", newMessage] =
- [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator client]
- where
- client = clients IntMap.! clID
+handleCmd_lobby ["SET_SERVER_VAR", "MOTD_OLD", newMessage] = do
+ cl <- thisClient
+ return [ModifyServerInfo (\si -> si{serverMessageForOldVersions = newMessage}) | isAdministrator cl]
-handleCmd_lobby clID clients rooms ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] =
- [ModifyServerInfo (\si -> si{latestReleaseVersion = fromJust readNum}) | isAdministrator client && isJust readNum]
+handleCmd_lobby ["SET_SERVER_VAR", "LATEST_PROTO", protoNum] = do
+ cl <- thisClient
+ return [ModifyServerInfo (\si -> si{latestReleaseVersion = readNum}) | isAdministrator cl && readNum > 0]
where
- client = clients IntMap.! clID
- readNum = maybeRead protoNum :: Maybe Word16
+ readNum = case B.readInt protoNum of
+ Just (i, t) | B.null t -> fromIntegral i
+ otherwise -> 0
-handleCmd_lobby clID clients rooms ["GET_SERVER_VAR"] =
- [SendServerVars | isAdministrator client]
- where
- client = clients IntMap.! clID
+handleCmd_lobby ["GET_SERVER_VAR"] = do
+ cl <- thisClient
+ return [SendServerVars | isAdministrator cl]
+
+handleCmd_lobby ["CLEAR_ACCOUNTS_CACHE"] = do
+ cl <- thisClient
+ return [ClearAccountsCache | isAdministrator cl]
-handleCmd_lobby clID clients rooms ["CLEAR_ACCOUNTS_CACHE"] =
- [ClearAccountsCache | isAdministrator client]
- where
- client = clients IntMap.! clID
-
-
-handleCmd_lobby clID _ _ _ = [ProtocolError "Incorrect command (state: in lobby)"]
+handleCmd_lobby _ = return [ProtocolError "Incorrect command (state: in lobby)"]
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/HWProtoNEState.hs
--- a/gameServer/HWProtoNEState.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/HWProtoNEState.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,54 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
module HWProtoNEState where
import qualified Data.IntMap as IntMap
import Data.Maybe
import Data.List
import Data.Word
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
--------------------------------------
import CoreTypes
import Actions
import Utils
+import RoomsAndClients
handleCmd_NotEntered :: CmdHandler
-handleCmd_NotEntered clID clients _ ["NICK", newNick]
- | not . null $ nick client = [ProtocolError "Nickname already chosen"]
- | haveSameNick = [AnswerThisClient ["WARNING", "Nickname already in use"], ByeClient ""]
- | illegalName newNick = [ByeClient "Illegal nickname"]
- | otherwise =
- ModifyClient (\c -> c{nick = newNick}) :
- AnswerThisClient ["NICK", newNick] :
- [CheckRegistered | clientProto client /= 0]
+handleCmd_NotEntered ["NICK", newNick] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ if not . B.null $ nick cl then return [ProtocolError "Nickname already chosen"]
+ else
+ if haveSameNick irnc then return [NoticeMessage NickAlreadyInUse]
+ else
+ if illegalName newNick then return [ByeClient "Illegal nickname"]
+ else
+ return $
+ ModifyClient (\c -> c{nick = newNick}) :
+ AnswerClients [sendChan cl] ["NICK", newNick] :
+ [CheckRegistered | clientProto cl /= 0]
where
- client = clients IntMap.! clID
- haveSameNick = isJust $ find (\cl -> newNick == nick cl) $ IntMap.elems clients
+ haveSameNick irnc = isJust . find (== newNick) . map (nick . client irnc) $ allClients irnc
+
+handleCmd_NotEntered ["PROTO", protoNum] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+ if clientProto cl > 0 then return [ProtocolError "Protocol already known"]
+ else
+ if parsedProto == 0 then return [ProtocolError "Bad number"]
+ else
+ return $
+ ModifyClient (\c -> c{clientProto = parsedProto}) :
+ AnswerClients [sendChan cl] ["PROTO", B.pack $ show parsedProto] :
+ [CheckRegistered | not . B.null $ nick cl]
+ where
+ parsedProto = case B.readInt protoNum of
+ Just (i, t) | B.null t -> fromIntegral i
+ otherwise -> 0
-handleCmd_NotEntered clID clients _ ["PROTO", protoNum]
- | clientProto client > 0 = [ProtocolError "Protocol already known"]
- | parsedProto == 0 = [ProtocolError "Bad number"]
- | otherwise =
- ModifyClient (\c -> c{clientProto = parsedProto}) :
- AnswerThisClient ["PROTO", show parsedProto] :
- [CheckRegistered | (not . null) (nick client)]
- where
- client = clients IntMap.! clID
- parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
+handleCmd_NotEntered ["PASSWORD", passwd] = do
+ (ci, irnc) <- ask
+ let cl = irnc `client` ci
+
+ if passwd == webPassword cl then
+ return $ JoinLobby : [AnswerClients [sendChan cl] ["ADMIN_ACCESS"] | isAdministrator cl]
+ else
+ return [ByeClient "Authentication failed"]
-handleCmd_NotEntered clID clients _ ["PASSWORD", passwd] =
- if passwd == webPassword client then
- [ModifyClient (\cl -> cl{logonPassed = True}),
- MoveToLobby] ++ adminNotice
- else
- [ByeClient "Authentication failed"]
- where
- client = clients IntMap.! clID
- adminNotice = [AnswerThisClient ["ADMIN_ACCESS"] | isAdministrator client]
-
-
-handleCmd_NotEntered clID clients _ ["DUMP"] =
- if isAdministrator (clients IntMap.! clID) then [Dump] else []
-
-
-handleCmd_NotEntered clID _ _ _ = [ProtocolError "Incorrect command (state: not entered)"]
+handleCmd_NotEntered _ = return [ProtocolError "Incorrect command (state: not entered)"]
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/HandlerUtils.hs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HandlerUtils.hs Wed Feb 02 23:21:14 2011 +0100
@@ -0,0 +1,65 @@
+module HandlerUtils where
+
+import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as B
+import Data.List
+
+import RoomsAndClients
+import CoreTypes
+import Actions
+
+thisClient :: Reader (ClientIndex, IRnC) ClientInfo
+thisClient = do
+ (ci, rnc) <- ask
+ return $ rnc `client` ci
+
+thisRoom :: Reader (ClientIndex, IRnC) RoomInfo
+thisRoom = do
+ (ci, rnc) <- ask
+ let ri = clientRoom rnc ci
+ return $ rnc `room` ri
+
+clientNick :: Reader (ClientIndex, IRnC) B.ByteString
+clientNick = liftM nick thisClient
+
+roomOthersChans :: Reader (ClientIndex, IRnC) [ClientChan]
+roomOthersChans = do
+ (ci, rnc) <- ask
+ let ri = clientRoom rnc ci
+ return $ map (sendChan . client rnc) $ filter (/= ci) (roomClients rnc ri)
+
+roomSameClanChans :: Reader (ClientIndex, IRnC) [ClientChan]
+roomSameClanChans = do
+ (ci, rnc) <- ask
+ let ri = clientRoom rnc ci
+ let otherRoomClients = map (client rnc) . filter (/= ci) $ roomClients rnc ri
+ let cl = rnc `client` ci
+ let thisClan = clientClan cl
+ let sameClanClients = Prelude.filter (\c -> teamsInGame cl > 0 && clientClan c == thisClan) otherRoomClients
+ let spectators = Prelude.filter (\c -> teamsInGame c == 0) otherRoomClients
+ let sameClanOrSpec = if teamsInGame cl > 0 then sameClanClients else spectators
+ return $ map sendChan sameClanOrSpec
+
+roomClientsChans :: Reader (ClientIndex, IRnC) [ClientChan]
+roomClientsChans = do
+ (ci, rnc) <- ask
+ let ri = clientRoom rnc ci
+ return $ map (sendChan . client rnc) (roomClients rnc ri)
+
+thisClientChans :: Reader (ClientIndex, IRnC) [ClientChan]
+thisClientChans = do
+ (ci, rnc) <- ask
+ return $ [sendChan (rnc `client` ci)]
+
+answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
+answerClient msg = thisClientChans >>= return . (: []) . flip AnswerClients msg
+
+allRoomInfos :: Reader (a, IRnC) [RoomInfo]
+allRoomInfos = liftM ((\irnc -> map (room irnc) $ allRooms irnc) . snd) ask
+
+clientByNick :: B.ByteString -> Reader (ClientIndex, IRnC) (Maybe ClientIndex)
+clientByNick n = do
+ (_, rnc) <- ask
+ let allClientIDs = allClients rnc
+ return $ find (\clId -> n == nick (client rnc clId)) allClientIDs
+
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/NetRoutines.hs
--- a/gameServer/NetRoutines.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/NetRoutines.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,46 +1,41 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
module NetRoutines where
-import Network
import Network.Socket
import System.IO
-import Control.Concurrent
import Control.Concurrent.Chan
-import Control.Concurrent.STM
import qualified Control.Exception as Exception
import Data.Time
+import Control.Monad
-----------------------------
import CoreTypes
-import ClientIO
import Utils
+import RoomsAndClients
-acceptLoop :: Socket -> Chan CoreMessage -> Int -> IO ()
-acceptLoop servSock coreChan clientCounter = do
+acceptLoop :: Socket -> Chan CoreMessage -> IO ()
+acceptLoop servSock chan = forever $ do
Exception.handle
(\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
do
- (socket, sockAddr) <- Network.Socket.accept servSock
+ (sock, sockAddr) <- Network.Socket.accept servSock
- cHandle <- socketToHandle socket ReadWriteMode
- hSetBuffering cHandle LineBuffering
clientHost <- sockAddr2String sockAddr
currentTime <- getCurrentTime
-
- sendChan <- newChan
+
+ sendChan' <- newChan
let newClient =
(ClientInfo
- nextID
- sendChan
- cHandle
+ sendChan'
+ sock
clientHost
currentTime
""
""
False
0
- 0
+ lobbyId
0
False
False
@@ -49,12 +44,5 @@
undefined
)
- writeChan coreChan $ Accept newClient
-
- forkIO $ clientRecvLoop cHandle coreChan nextID
- forkIO $ clientSendLoop cHandle coreChan sendChan nextID
+ writeChan chan $ Accept newClient
return ()
-
- acceptLoop servSock coreChan nextID
- where
- nextID = clientCounter + 1
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/OfficialServer/DBInteraction.hs
--- a/gameServer/OfficialServer/DBInteraction.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/OfficialServer/DBInteraction.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
module OfficialServer.DBInteraction
(
startDBConnection
@@ -20,7 +20,7 @@
localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"]
-fakeDbConnection serverInfo = do
+fakeDbConnection serverInfo = forever $ do
q <- readChan $ dbQueries serverInfo
case q of
CheckAccount clUid _ clHost -> do
@@ -29,8 +29,6 @@
ClearCache -> return ()
SendStats {} -> return ()
- fakeDbConnection serverInfo
-
#if defined(OFFICIAL_SERVER)
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache =
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/OfficialServer/extdbinterface.hs
--- a/gameServer/OfficialServer/extdbinterface.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/OfficialServer/extdbinterface.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
module Main where
@@ -26,7 +26,7 @@
case q of
CheckAccount clUid clNick _ -> do
statement <- prepare dbConn dbQueryAccount
- execute statement [SqlString $ clNick]
+ execute statement [SqlByteString $ clNick]
passAndRole <- fetchRow statement
finish statement
let response =
@@ -47,7 +47,7 @@
dbConnectionLoop mySQLConnectionInfo =
- Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $
+ Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $
bracket
(connectMySQL mySQLConnectionInfo)
(disconnect)
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/Opts.hs
--- a/gameServer/Opts.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/Opts.hs Wed Feb 02 23:21:14 2011 +0100
@@ -3,10 +3,12 @@
getOpts,
) where
-import System.Environment ( getArgs )
+import System.Environment
import System.Console.GetOpt
import Network
import Data.Maybe ( fromMaybe )
+import qualified Data.ByteString.Char8 as B
+
import CoreTypes
import Utils
@@ -30,9 +32,9 @@
where
readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
-readDbLogin str opts = opts{dbLogin = str}
-readDbPassword str opts = opts{dbPassword = str}
-readDbHost str opts = opts{dbHost = str}
+readDbLogin str opts = opts{dbLogin = B.pack str}
+readDbPassword str opts = opts{dbPassword = B.pack str}
+readDbHost str opts = opts{dbHost = B.pack str}
getOpts :: ServerInfo -> IO ServerInfo
getOpts opts = do
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/RoomsAndClients.hs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/RoomsAndClients.hs Wed Feb 02 23:21:14 2011 +0100
@@ -0,0 +1,196 @@
+module RoomsAndClients(
+ RoomIndex(),
+ ClientIndex(),
+ MRoomsAndClients(),
+ IRoomsAndClients(),
+ newRoomsAndClients,
+ addRoom,
+ addClient,
+ removeRoom,
+ removeClient,
+ modifyRoom,
+ modifyClient,
+ lobbyId,
+ moveClientToLobby,
+ moveClientToRoom,
+ clientRoomM,
+ clientExists,
+ client,
+ room,
+ client'sM,
+ room'sM,
+ allClientsM,
+ clientsM,
+ roomClientsM,
+ roomClientsIndicesM,
+ withRoomsAndClients,
+ allRooms,
+ allClients,
+ clientRoom,
+ showRooms,
+ roomClients
+ ) where
+
+
+import Store
+import Control.Monad
+
+
+data Room r = Room {
+ roomClients' :: [ClientIndex],
+ room' :: r
+ }
+
+
+data Client c = Client {
+ clientRoom' :: RoomIndex,
+ client' :: c
+ }
+
+
+newtype RoomIndex = RoomIndex ElemIndex
+ deriving (Eq)
+newtype ClientIndex = ClientIndex ElemIndex
+ deriving (Eq, Show, Read, Ord)
+
+instance Show RoomIndex where
+ show (RoomIndex i) = 'r' : show i
+
+unRoomIndex :: RoomIndex -> ElemIndex
+unRoomIndex (RoomIndex r) = r
+
+unClientIndex :: ClientIndex -> ElemIndex
+unClientIndex (ClientIndex c) = c
+
+
+newtype MRoomsAndClients r c = MRoomsAndClients (MStore (Room r), MStore (Client c))
+newtype IRoomsAndClients r c = IRoomsAndClients (IStore (Room r), IStore (Client c))
+
+
+lobbyId :: RoomIndex
+lobbyId = RoomIndex firstIndex
+
+
+newRoomsAndClients :: r -> IO (MRoomsAndClients r c)
+newRoomsAndClients r = do
+ rooms <- newStore
+ clients <- newStore
+ let rnc = MRoomsAndClients (rooms, clients)
+ ri <- addRoom rnc r
+ when (ri /= lobbyId) $ error "Empty struct inserts not at firstIndex index"
+ return rnc
+
+
+roomAddClient :: ClientIndex -> Room r -> Room r
+roomAddClient cl room = let cls = cl : roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr
+
+roomRemoveClient :: ClientIndex -> Room r -> Room r
+roomRemoveClient cl room = let cls = filter (/= cl) $ roomClients' room; nr = room{roomClients' = cls} in cls `seq` nr `seq` nr
+
+
+addRoom :: MRoomsAndClients r c -> r -> IO RoomIndex
+addRoom (MRoomsAndClients (rooms, _)) room = do
+ i <- addElem rooms (Room [] room)
+ return $ RoomIndex i
+
+
+addClient :: MRoomsAndClients r c -> c -> IO ClientIndex
+addClient (MRoomsAndClients (rooms, clients)) client = do
+ i <- addElem clients (Client lobbyId client)
+ modifyElem rooms (roomAddClient (ClientIndex i)) (unRoomIndex lobbyId)
+ return $ ClientIndex i
+
+removeRoom :: MRoomsAndClients r c -> RoomIndex -> IO ()
+removeRoom rnc@(MRoomsAndClients (rooms, _)) room@(RoomIndex ri)
+ | room == lobbyId = error "Cannot delete lobby"
+ | otherwise = do
+ clIds <- liftM roomClients' $ readElem rooms ri
+ forM_ clIds (moveClientToLobby rnc)
+ removeElem rooms ri
+
+
+removeClient :: MRoomsAndClients r c -> ClientIndex -> IO ()
+removeClient (MRoomsAndClients (rooms, clients)) cl@(ClientIndex ci) = do
+ RoomIndex ri <- liftM clientRoom' $ readElem clients ci
+ modifyElem rooms (roomRemoveClient cl) ri
+ removeElem clients ci
+
+
+modifyRoom :: MRoomsAndClients r c -> (r -> r) -> RoomIndex -> IO ()
+modifyRoom (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = modifyElem rooms (\r -> r{room' = f $ room' r}) ri
+
+modifyClient :: MRoomsAndClients r c -> (c -> c) -> ClientIndex -> IO ()
+modifyClient (MRoomsAndClients (_, clients)) f (ClientIndex ci) = modifyElem clients (\c -> c{client' = f $ client' c}) ci
+
+moveClientInRooms :: MRoomsAndClients r c -> RoomIndex -> RoomIndex -> ClientIndex -> IO ()
+moveClientInRooms (MRoomsAndClients (rooms, clients)) (RoomIndex riFrom) rt@(RoomIndex riTo) cl@(ClientIndex ci) = do
+ modifyElem rooms (roomRemoveClient cl) riFrom
+ modifyElem rooms (roomAddClient cl) riTo
+ modifyElem clients (\c -> c{clientRoom' = rt}) ci
+
+
+moveClientToLobby :: MRoomsAndClients r c -> ClientIndex -> IO ()
+moveClientToLobby rnc ci = do
+ room <- clientRoomM rnc ci
+ moveClientInRooms rnc room lobbyId ci
+
+
+moveClientToRoom :: MRoomsAndClients r c -> RoomIndex -> ClientIndex -> IO ()
+moveClientToRoom rnc ri ci = moveClientInRooms rnc lobbyId ri ci
+
+
+clientExists :: MRoomsAndClients r c -> ClientIndex -> IO Bool
+clientExists (MRoomsAndClients (_, clients)) (ClientIndex ci) = elemExists clients ci
+
+clientRoomM :: MRoomsAndClients r c -> ClientIndex -> IO RoomIndex
+clientRoomM (MRoomsAndClients (_, clients)) (ClientIndex ci) = liftM clientRoom' (clients `readElem` ci)
+
+client'sM :: MRoomsAndClients r c -> (c -> a) -> ClientIndex -> IO a
+client'sM (MRoomsAndClients (_, clients)) f (ClientIndex ci) = liftM (f . client') (clients `readElem` ci)
+
+room'sM :: MRoomsAndClients r c -> (r -> a) -> RoomIndex -> IO a
+room'sM (MRoomsAndClients (rooms, _)) f (RoomIndex ri) = liftM (f . room') (rooms `readElem` ri)
+
+allClientsM :: MRoomsAndClients r c -> IO [ClientIndex]
+allClientsM (MRoomsAndClients (_, clients)) = liftM (map ClientIndex) $ indicesM clients
+
+clientsM :: MRoomsAndClients r c -> IO [c]
+clientsM (MRoomsAndClients (_, clients)) = indicesM clients >>= mapM (\ci -> liftM client' $ readElem clients ci)
+
+roomClientsIndicesM :: MRoomsAndClients r c -> RoomIndex -> IO [ClientIndex]
+roomClientsIndicesM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri)
+
+roomClientsM :: MRoomsAndClients r c -> RoomIndex -> IO [c]
+roomClientsM (MRoomsAndClients (rooms, clients)) (RoomIndex ri) = liftM roomClients' (rooms `readElem` ri) >>= mapM (\(ClientIndex ci) -> liftM client' $ readElem clients ci)
+
+withRoomsAndClients :: MRoomsAndClients r c -> (IRoomsAndClients r c -> a) -> IO a
+withRoomsAndClients (MRoomsAndClients (rooms, clients)) f =
+ withIStore2 rooms clients (\r c -> f $ IRoomsAndClients (r, c))
+
+----------------------------------------
+----------- IRoomsAndClients -----------
+
+showRooms :: (Show r, Show c) => IRoomsAndClients r c -> String
+showRooms rnc@(IRoomsAndClients (rooms, clients)) = concatMap showRoom (allRooms rnc)
+ where
+ showRoom r = unlines $ ((show r) ++ ": " ++ (show $ room' $ rooms ! (unRoomIndex r))) : (map showClient (roomClients' $ rooms ! (unRoomIndex r)))
+ showClient c = " " ++ (show c) ++ ": " ++ (show $ client' $ clients ! (unClientIndex c))
+
+
+allRooms :: IRoomsAndClients r c -> [RoomIndex]
+allRooms (IRoomsAndClients (rooms, _)) = map RoomIndex $ indices rooms
+
+allClients :: IRoomsAndClients r c -> [ClientIndex]
+allClients (IRoomsAndClients (_, clients)) = map ClientIndex $ indices clients
+
+clientRoom :: IRoomsAndClients r c -> ClientIndex -> RoomIndex
+clientRoom (IRoomsAndClients (_, clients)) (ClientIndex ci) = clientRoom' (clients ! ci)
+
+client :: IRoomsAndClients r c -> ClientIndex -> c
+client (IRoomsAndClients (_, clients)) (ClientIndex ci) = client' (clients ! ci)
+
+room :: IRoomsAndClients r c -> RoomIndex -> r
+room (IRoomsAndClients (rooms, _)) (RoomIndex ri) = room' (rooms ! ri)
+
+roomClients :: IRoomsAndClients r c -> RoomIndex -> [ClientIndex]
+roomClients (IRoomsAndClients (rooms, _)) (RoomIndex ri) = roomClients' $ (rooms ! ri)
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/ServerCore.hs
--- a/gameServer/ServerCore.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/ServerCore.hs Wed Feb 02 23:21:14 2011 +0100
@@ -2,86 +2,92 @@
import Network
import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Concurrent.Chan
import Control.Monad
-import qualified Data.IntMap as IntMap
import System.Log.Logger
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import Data.Set as Set
+import qualified Data.ByteString.Char8 as B
+import Control.DeepSeq
--------------------------------------
import CoreTypes
import NetRoutines
-import Utils
import HWProtoCore
import Actions
import OfficialServer.DBInteraction
+import ServerState
+
+
+timerLoop :: Int -> Chan CoreMessage -> IO ()
+timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-timerLoop :: Int -> Chan CoreMessage -> IO()
-timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
-
-firstAway (_, a, b, c) = (a, b, c)
-
-reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
-reactCmd serverInfo clID cmd clients rooms =
- liftM firstAway $ foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
+reactCmd :: [B.ByteString] -> StateT ServerState IO ()
+reactCmd cmd = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
+ forM_ (actions `deepseq` actions) processAction
-mainLoop :: ServerInfo -> Clients -> Rooms -> IO ()
-mainLoop serverInfo clients rooms = do
- r <- readChan $ coreChan serverInfo
-
- (newServerInfo, mClients, mRooms) <-
- case r of
- Accept ci ->
- liftM firstAway $ processAction
- (clientUID ci, serverInfo, clients, rooms) (AddClient ci)
+mainLoop :: StateT ServerState IO ()
+mainLoop = forever $ do
+ get >>= \s -> put $! s
+
+ si <- gets serverInfo
+ r <- liftIO $ readChan $ coreChan si
+
+ case r of
+ Accept ci -> processAction (AddClient ci)
+
+ ClientMessage (ci, cmd) -> do
+ liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
- ClientMessage (clID, cmd) -> do
- debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
- if clID `IntMap.member` clients then
- reactCmd serverInfo clID cmd clients rooms
- else
- do
- debugM "Clients" "Message from dead client"
- return (serverInfo, clients, rooms)
+ removed <- gets removedClients
+ when (not $ ci `Set.member` removed) $ do
+ as <- get
+ put $! as{clientIndex = Just ci}
+ reactCmd cmd
+
+ Remove ci -> do
+ liftIO $ debugM "Clients" $ "DeleteClient: " ++ show ci
+ processAction (DeleteClient ci)
- ClientAccountInfo (clID, info) ->
- if clID `IntMap.member` clients then
- liftM firstAway $ processAction
- (clID, serverInfo, clients, rooms)
- (ProcessAccountInfo info)
- else
- do
- debugM "Clients" "Got info for dead client"
- return (serverInfo, clients, rooms)
+ --else
+ --do
+ --debugM "Clients" "Message from dead client"
+ --return (serverInfo, rnc)
- TimerAction tick ->
- liftM firstAway $
- foldM processAction (0, serverInfo, clients, rooms) $
- PingAll : [StatsAction | even tick]
+ ClientAccountInfo (ci, info) -> do
+ rnc <- gets roomsClients
+ exists <- liftIO $ clientExists rnc ci
+ when (exists) $ do
+ as <- get
+ put $! as{clientIndex = Just ci}
+ processAction (ProcessAccountInfo info)
+ return ()
+
+ TimerAction tick ->
+ mapM_ processAction $
+ PingAll : [StatsAction | even tick]
- {- let hadRooms = (not $ null rooms) && (null mrooms)
- in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
- mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
-
- mainLoop newServerInfo mClients mRooms
-
startServer :: ServerInfo -> Socket -> IO ()
-startServer serverInfo serverSocket = do
- putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
+startServer si serverSocket = do
+ putStrLn $ "Listening on port " ++ show (listenPort si)
forkIO $
acceptLoop
serverSocket
- (coreChan serverInfo)
- 0
+ (coreChan si)
return ()
-
- forkIO $ timerLoop 0 $ coreChan serverInfo
+
+ forkIO $ timerLoop 0 $ coreChan si
+
+ startDBConnection si
- startDBConnection serverInfo
+ rnc <- newRoomsAndClients newRoom
- forkIO $ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
+ forkIO $ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)
- forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"
\ No newline at end of file
+ forever $ threadDelay 3600000000 -- one hour
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/ServerState.hs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/ServerState.hs Wed Feb 02 23:21:14 2011 +0100
@@ -0,0 +1,47 @@
+module ServerState
+ (
+ module RoomsAndClients,
+ clientRoomA,
+ ServerState(..),
+ client's,
+ allClientsS,
+ roomClientsS,
+ io
+ ) where
+
+import Control.Monad.State.Strict
+import Data.Set as Set
+----------------------
+import RoomsAndClients
+import CoreTypes
+
+data ServerState = ServerState {
+ clientIndex :: !(Maybe ClientIndex),
+ serverInfo :: !ServerInfo,
+ removedClients :: !(Set.Set ClientIndex),
+ roomsClients :: !MRnC
+ }
+
+
+clientRoomA :: StateT ServerState IO RoomIndex
+clientRoomA = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ io $ clientRoomM rnc ci
+
+client's :: (ClientInfo -> a) -> StateT ServerState IO a
+client's f = do
+ (Just ci) <- gets clientIndex
+ rnc <- gets roomsClients
+ io $ client'sM rnc f ci
+
+allClientsS :: StateT ServerState IO [ClientInfo]
+allClientsS = gets roomsClients >>= liftIO . clientsM
+
+roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
+roomClientsS ri = do
+ rnc <- gets roomsClients
+ io $ roomClientsM rnc ri
+
+io :: IO a -> StateT ServerState IO a
+io = liftIO
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/Store.hs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/Store.hs Wed Feb 02 23:21:14 2011 +0100
@@ -0,0 +1,145 @@
+module Store(
+ ElemIndex(),
+ MStore(),
+ IStore(),
+ newStore,
+ addElem,
+ removeElem,
+ readElem,
+ writeElem,
+ modifyElem,
+ elemExists,
+ firstIndex,
+ indicesM,
+ withIStore,
+ withIStore2,
+ (!),
+ indices
+ ) where
+
+import qualified Data.Array.IArray as IA
+import qualified Data.Array.IO as IOA
+import qualified Data.IntSet as IntSet
+import Data.IORef
+import Control.Monad
+
+
+newtype ElemIndex = ElemIndex Int
+ deriving (Eq, Show, Read, Ord)
+newtype MStore e = MStore (IORef (IntSet.IntSet, IntSet.IntSet, IOA.IOArray Int e))
+newtype IStore e = IStore (IntSet.IntSet, IA.Array Int e)
+
+
+firstIndex :: ElemIndex
+firstIndex = ElemIndex 0
+
+-- MStore code
+initialSize :: Int
+initialSize = 10
+
+
+growFunc :: Int -> Int
+growFunc a = a * 3 `div` 2
+
+
+newStore :: IO (MStore e)
+newStore = do
+ newar <- IOA.newArray_ (0, initialSize - 1)
+ new <- newIORef (IntSet.empty, IntSet.fromAscList [0..initialSize - 1], newar)
+ return (MStore new)
+
+
+growStore :: MStore e -> IO ()
+growStore (MStore ref) = do
+ (busyElems, freeElems, arr) <- readIORef ref
+ (_, m') <- IOA.getBounds arr
+ let newM' = growFunc (m' + 1) - 1
+ newArr <- IOA.newArray_ (0, newM')
+ sequence_ [IOA.readArray arr i >>= IOA.writeArray newArr i | i <- [0..m']]
+ writeIORef ref (busyElems, freeElems `IntSet.union` (IntSet.fromAscList [m'+1..newM']), newArr)
+
+
+growIfNeeded :: MStore e -> IO ()
+growIfNeeded m@(MStore ref) = do
+ (_, freeElems, _) <- readIORef ref
+ when (IntSet.null freeElems) $ growStore m
+
+
+addElem :: MStore e -> e -> IO ElemIndex
+addElem m@(MStore ref) element = do
+ growIfNeeded m
+ (busyElems, freeElems, arr) <- readIORef ref
+ let (n, freeElems') = IntSet.deleteFindMin freeElems
+ IOA.writeArray arr n element
+ writeIORef ref (IntSet.insert n busyElems, freeElems', arr)
+ return $ ElemIndex n
+
+
+removeElem :: MStore e -> ElemIndex -> IO ()
+removeElem (MStore ref) (ElemIndex n) = do
+ (busyElems, freeElems, arr) <- readIORef ref
+ IOA.writeArray arr n (error $ "Store: no element " ++ show n)
+ writeIORef ref (IntSet.delete n busyElems, IntSet.insert n freeElems, arr)
+
+
+readElem :: MStore e -> ElemIndex -> IO e
+readElem (MStore ref) (ElemIndex n) = readIORef ref >>= \(_, _, arr) -> IOA.readArray arr n
+
+
+writeElem :: MStore e -> ElemIndex -> e -> IO ()
+writeElem (MStore ref) (ElemIndex n) el = readIORef ref >>= \(_, _, arr) -> IOA.writeArray arr n el
+
+
+modifyElem :: MStore e -> (e -> e) -> ElemIndex -> IO ()
+modifyElem (MStore ref) f (ElemIndex n) = do
+ (_, _, arr) <- readIORef ref
+ IOA.readArray arr n >>= IOA.writeArray arr n . f
+
+elemExists :: MStore e -> ElemIndex -> IO Bool
+elemExists (MStore ref) (ElemIndex n) = do
+ (_, free, _) <- readIORef ref
+ return $ n `IntSet.notMember` free
+
+indicesM :: MStore e -> IO [ElemIndex]
+indicesM (MStore ref) = do
+ (busy, _, _) <- readIORef ref
+ return $ map ElemIndex $ IntSet.toList busy
+
+
+-- A way to see MStore elements in pure code via IStore
+m2i :: MStore e -> IO (IStore e)
+m2i (MStore ref) = do
+ (a, _, c') <- readIORef ref
+ c <- IOA.unsafeFreeze c'
+ return $ IStore (a, c)
+
+i2m :: (MStore e) -> IStore e -> IO ()
+i2m (MStore ref) (IStore (_, arr)) = do
+ (b, e, _) <- readIORef ref
+ a <- IOA.unsafeThaw arr
+ writeIORef ref (b, e, a)
+
+withIStore :: MStore e -> (IStore e -> a) -> IO a
+withIStore m f = do
+ i <- m2i m
+ let res = f i
+ res `seq` i2m m i
+ return res
+
+
+withIStore2 :: MStore e1 -> MStore e2 -> (IStore e1 -> IStore e2 -> a) -> IO a
+withIStore2 m1 m2 f = do
+ i1 <- m2i m1
+ i2 <- m2i m2
+ let res = f i1 i2
+ res `seq` i2m m1 i1
+ i2m m2 i2
+ return res
+
+
+-- IStore code
+(!) :: IStore e -> ElemIndex -> e
+(!) (IStore (_, arr)) (ElemIndex i) = (IA.!) arr i
+
+indices :: IStore e -> [ElemIndex]
+indices (IStore (busy, _)) = map ElemIndex $ IntSet.toList busy
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/Utils.hs
--- a/gameServer/Utils.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/Utils.hs Wed Feb 02 23:21:14 2011 +0100
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
module Utils where
import Control.Concurrent
@@ -13,40 +14,38 @@
import System.IO
import qualified Data.List as List
import Control.Monad
+import Control.Monad.Trans
import Data.Maybe
-------------------------------------------------
import qualified Codec.Binary.Base64 as Base64
-import qualified Data.ByteString.UTF8 as BUTF8
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString as BW
import CoreTypes
-sockAddr2String :: SockAddr -> IO String
-sockAddr2String (SockAddrInet _ hostAddr) = inet_ntoa hostAddr
+sockAddr2String :: SockAddr -> IO B.ByteString
+sockAddr2String (SockAddrInet _ hostAddr) = liftM B.pack $ inet_ntoa hostAddr
sockAddr2String (SockAddrInet6 _ _ (a, b, c, d) _) =
- return $ (foldr1 (.)
+ return $ B.pack $ (foldr1 (.)
$ List.intersperse (\a -> ':':a)
$ concatMap (\n -> (\(a, b) -> [showHex a, showHex b]) $ divMod n 65536) [a, b, c, d]) []
-toEngineMsg :: String -> String
-toEngineMsg msg = Base64.encode (fromIntegral (B.length encodedMsg) : (B.unpack encodedMsg))
- where
- encodedMsg = BUTF8.fromString msg
+toEngineMsg :: B.ByteString -> B.ByteString
+toEngineMsg msg = B.pack $ Base64.encode (fromIntegral (BW.length msg) : (BW.unpack msg))
-fromEngineMsg :: String -> Maybe String
-fromEngineMsg msg = liftM (map w2c) (Base64.decode msg >>= removeLength)
+fromEngineMsg :: B.ByteString -> Maybe B.ByteString
+fromEngineMsg msg = Base64.decode (B.unpack msg) >>= removeLength >>= return . BW.pack
where
removeLength (x:xs) = if length xs == fromIntegral x then Just xs else Nothing
removeLength _ = Nothing
-checkNetCmd :: String -> (Bool, Bool)
-checkNetCmd msg = check decoded
+checkNetCmd :: B.ByteString -> (Bool, Bool)
+checkNetCmd = check . liftM B.unpack . fromEngineMsg
where
- decoded = fromEngineMsg msg
check Nothing = (False, False)
check (Just (m:ms)) = (m `Set.member` legalMessages, m == '+')
check _ = (False, False)
- legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghbc12345" ++ slotMessages
+ legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sFNpPwtghb12345" ++ slotMessages
slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
maybeRead :: Read a => String -> Maybe a
@@ -54,29 +53,17 @@
[(x, rest)] | all isSpace rest -> Just x
_ -> Nothing
-teamToNet :: Word16 -> TeamInfo -> [String]
-teamToNet protocol team
- | protocol < 30 = [
- "ADD_TEAM",
- teamname team,
- teamgrave team,
- teamfort team,
- teamvoicepack team,
- teamowner team,
- show $ difficulty team
- ]
- ++ hhsInfo
- | otherwise = [
- "ADD_TEAM",
- teamname team,
- teamgrave team,
- teamfort team,
- teamvoicepack team,
- teamflag team,
- teamowner team,
- show $ difficulty team
- ]
- ++ hhsInfo
+teamToNet :: TeamInfo -> [B.ByteString]
+teamToNet team =
+ "ADD_TEAM"
+ : teamname team
+ : teamgrave team
+ : teamfort team
+ : teamvoicepack team
+ : teamflag team
+ : teamowner team
+ : (B.pack $ show $ difficulty team)
+ : hhsInfo
where
hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
@@ -90,34 +77,48 @@
else
t : replaceTeam team teams
-illegalName :: String -> Bool
-illegalName s = null s || all isSpace s || isSpace (head s) || isSpace (last s)
+illegalName :: B.ByteString -> Bool
+illegalName b = null s || all isSpace s || isSpace (head s) || isSpace (last s)
+ where
+ s = B.unpack b
-protoNumber2ver :: Word16 -> String
-protoNumber2ver 17 = "0.9.7-dev"
-protoNumber2ver 19 = "0.9.7"
-protoNumber2ver 20 = "0.9.8-dev"
-protoNumber2ver 21 = "0.9.8"
-protoNumber2ver 22 = "0.9.9-dev"
-protoNumber2ver 23 = "0.9.9"
-protoNumber2ver 24 = "0.9.10-dev"
-protoNumber2ver 25 = "0.9.10"
-protoNumber2ver 26 = "0.9.11-dev"
-protoNumber2ver 27 = "0.9.11"
-protoNumber2ver 28 = "0.9.12-dev"
-protoNumber2ver 29 = "0.9.12"
-protoNumber2ver 30 = "0.9.13-dev"
-protoNumber2ver 31 = "0.9.13"
-protoNumber2ver 32 = "0.9.14-dev"
-protoNumber2ver 33 = "0.9.14"
-protoNumber2ver 34 = "0.9.15-dev"
-protoNumber2ver 35 = "0.9.14.1"
-protoNumber2ver 37 = "0.9.15"
-protoNumber2ver 38 = "0.9.16-dev"
-protoNumber2ver w = show w
+protoNumber2ver :: Word16 -> B.ByteString
+protoNumber2ver v = Map.findWithDefault "Unknown" v vermap
+ where
+ vermap = Map.fromList [
+ (17, "0.9.7-dev"),
+ (19, "0.9.7"),
+ (20, "0.9.8-dev"),
+ (21, "0.9.8"),
+ (22, "0.9.9-dev"),
+ (23, "0.9.9"),
+ (24, "0.9.10-dev"),
+ (25, "0.9.10"),
+ (26, "0.9.11-dev"),
+ (27, "0.9.11"),
+ (28, "0.9.12-dev"),
+ (29, "0.9.12"),
+ (30, "0.9.13-dev"),
+ (31, "0.9.13"),
+ (32, "0.9.14-dev"),
+ (33, "0.9.14"),
+ (34, "0.9.15-dev"),
+ (35, "0.9.14.1"),
+ (37, "0.9.15"),
+ (38, "0.9.16-dev")]
askFromConsole :: String -> IO String
askFromConsole msg = do
putStr msg
hFlush stdout
getLine
+
+
+unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b)
+unfoldrE f b =
+ case f b of
+ Right (a, new_b) -> let (a', b') = unfoldrE f new_b in (a : a', b')
+ Left new_b -> ([], new_b)
+
+showB :: Show a => a -> B.ByteString
+showB = B.pack .show
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/hedgewars-server.cabal
--- a/gameServer/hedgewars-server.cabal Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/hedgewars-server.cabal Wed Feb 02 23:21:14 2011 +0100
@@ -28,6 +28,6 @@
dataenc,
hslogger,
process,
- utf8-string
-
- ghc-options: -O2
\ No newline at end of file
+ deepseq
+
+ ghc-options: -O2
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/hedgewars-server.hs
--- a/gameServer/hedgewars-server.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/hedgewars-server.hs Wed Feb 02 23:21:14 2011 +0100
@@ -3,22 +3,15 @@
module Main where
import Network.Socket
-import qualified Network
import Network.BSD
import Control.Concurrent.STM
import Control.Concurrent.Chan
-#if defined(NEW_EXCEPTIONS)
-import qualified Control.OldException as Exception
-#else
import qualified Control.Exception as Exception
-#endif
import System.Log.Logger
-----------------------------------
import Opts
import CoreTypes
-import OfficialServer.DBInteraction
import ServerCore
-import Utils
#if !defined(mingw32_HOST_OS)
@@ -26,10 +19,12 @@
#endif
+setupLoggers :: IO ()
setupLoggers =
updateGlobalLogger "Clients"
(setLevel INFO)
+main :: IO ()
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
installHandler sigPIPE Ignore Nothing;
@@ -38,11 +33,11 @@
setupLoggers
- stats <- atomically $ newTMVar (StatisticsInfo 0 0)
+ stats' <- atomically $ newTMVar (StatisticsInfo 0 0)
dbQueriesChan <- newChan
- coreChan <- newChan
- serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan
-
+ coreChan' <- newChan
+ serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan
+
#if defined(OFFICIAL_SERVER)
dbHost' <- askFromConsole "DB host: "
dbLogin' <- askFromConsole "login: "
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/stresstest.hs
--- a/gameServer/stresstest.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/stresstest.hs Wed Feb 02 23:21:14 2011 +0100
@@ -6,7 +6,7 @@
import System.IO
import Control.Concurrent
import Network
-import Control.Exception
+import Control.OldException
import Control.Monad
import System.Random
@@ -14,24 +14,24 @@
import System.Posix
#endif
-session1 nick room = ["NICK", nick, "", "PROTO", "24", "", "CHAT", "lobby 1", "", "CREATE", room, "", "CHAT", "room 1", "", "QUIT", "bye-bye", ""]
-session2 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "bye-bye", ""]
-session3 nick room = ["NICK", nick, "", "PROTO", "24", "", "LIST", "", "JOIN", room, "", "CHAT", "room 2", "", "QUIT", "bye-bye", ""]
+session1 nick room = ["NICK", nick, "", "PROTO", "32", "", "PING", "", "CHAT", "lobby 1", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""]
+session2 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROOM", room, "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""]
+session3 nick room = ["NICK", nick, "", "PROTO", "32", "", "LIST", "", "JOIN_ROON", room, "", "CHAT", "room 2", "", "QUIT", "quit", ""]
emulateSession sock s = do
- mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (50000::Int, 90000) >>= threadDelay) s
+ mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (30000::Int, 59000) >>= threadDelay) s
hFlush sock
threadDelay 225000
-testing = Control.Exception.handle print $ do
+testing = Control.OldException.handle print $ do
putStrLn "Start"
sock <- connectTo "127.0.0.1" (PortNumber 46631)
num1 <- randomRIO (70000::Int, 70100)
num2 <- randomRIO (0::Int, 2)
num3 <- randomRIO (0::Int, 5)
- let nick1 = show num1
- let room1 = show num2
+ let nick1 = 'n' : show num1
+ let room1 = 'r' : show num2
case num2 of
0 -> emulateSession sock $ session1 nick1 room1
1 -> emulateSession sock $ session2 nick1 room1
@@ -40,7 +40,7 @@
putStrLn "Finish"
forks = forever $ do
- delay <- randomRIO (10000::Int, 19000)
+ delay <- randomRIO (30000::Int, 59000)
threadDelay delay
forkIO testing
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/stresstest2.hs
--- a/gameServer/stresstest2.hs Wed Feb 02 09:23:42 2011 +0100
+++ b/gameServer/stresstest2.hs Wed Feb 02 23:21:14 2011 +0100
@@ -6,7 +6,7 @@
import System.IO
import Control.Concurrent
import Network
-import Control.Exception
+import Control.OldException
import Control.Monad
import System.Random
@@ -14,22 +14,28 @@
import System.Posix
#endif
-testing = Control.Exception.handle print $ do
- delay <- randomRIO (100::Int, 300)
- threadDelay delay
+session1 nick room = ["NICK", nick, "", "PROTO", "32", ""]
+
+
+
+testing = Control.OldException.handle print $ do
+ putStrLn "Start"
sock <- connectTo "127.0.0.1" (PortNumber 46631)
- hClose sock
-forks i = do
- delay <- randomRIO (50::Int, 190)
- if i `mod` 10 == 0 then putStr (show i) else putStr "."
- hFlush stdout
- threadDelay delay
- forkIO testing
- forks (i + 1)
+ num1 <- randomRIO (70000::Int, 70100)
+ num2 <- randomRIO (0::Int, 2)
+ num3 <- randomRIO (0::Int, 5)
+ let nick1 = 'n' : show num1
+ let room1 = 'r' : show num2
+ mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (300::Int, 590) >>= threadDelay) $ session1 nick1 room1
+ mapM_ (\x -> hPutStrLn sock x >> hFlush sock) $ concatMap (\x -> ["CHAT_MSG", show x, ""]) [1..]
+ hClose sock
+ putStrLn "Finish"
+
+forks = testing
main = withSocketsDo $ do
#if !defined(mingw32_HOST_OS)
installHandler sigPIPE Ignore Nothing;
#endif
- forks 1
+ forks
diff -r 663aa9552bfc -r 9dcb2e83b24f gameServer/stresstest3.hs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/stresstest3.hs Wed Feb 02 23:21:14 2011 +0100
@@ -0,0 +1,75 @@
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+import IO
+import System.IO
+import Control.Concurrent
+import Network
+import Control.OldException
+import Control.Monad
+import System.Random
+import Control.Monad.State
+import Data.List
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix
+#endif
+
+type SState = Handle
+io = liftIO
+
+readPacket :: StateT SState IO [String]
+readPacket = do
+ h <- get
+ p <- io $ hGetPacket h []
+ return p
+ where
+ hGetPacket h buf = do
+ l <- hGetLine h
+ if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf
+
+waitPacket :: String -> StateT SState IO Bool
+waitPacket s = do
+ p <- readPacket
+ return $ head p == s
+
+sendPacket :: [String] -> StateT SState IO ()
+sendPacket s = do
+ h <- get
+ io $ do
+ mapM_ (hPutStrLn h) s
+ hPutStrLn h ""
+ hFlush h
+
+emulateSession :: StateT SState IO ()
+emulateSession = do
+ n <- io $ randomRIO (100000::Int, 100100)
+ waitPacket "CONNECTED"
+ sendPacket ["NICK", "test" ++ (show n)]
+ waitPacket "NICK"
+ sendPacket ["PROTO", "31"]
+ waitPacket "PROTO"
+ b <- waitPacket "LOBBY:JOINED"
+ --io $ print b
+ sendPacket ["QUIT", "BYE"]
+ return ()
+
+testing = Control.OldException.handle print $ do
+ putStr "+"
+ sock <- connectTo "127.0.0.1" (PortNumber 46631)
+ evalStateT emulateSession sock
+ --hClose sock
+ putStr "-"
+ hFlush stdout
+
+forks = forM_ [1..100] $ const $ do
+ delay <- randomRIO (10000::Int, 30000)
+ threadDelay delay
+ forkIO testing
+
+main = withSocketsDo $ do
+#if !defined(mingw32_HOST_OS)
+ installHandler sigPIPE Ignore Nothing;
+#endif
+ forks
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/ArgParsers.inc
--- a/hedgewars/ArgParsers.inc Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/ArgParsers.inc Wed Feb 02 23:21:14 2011 +0100
@@ -8,6 +8,7 @@
end;
procedure internalStartGameWithParameters();
+var tmp: LongInt;
begin
val(ParamStr(2), cScreenWidth);
val(ParamStr(3), cScreenHeight);
@@ -23,7 +24,9 @@
cAltDamage:= ParamStr(13) = '1';
UserNick:= DecodeBase64(ParamStr(14));
val(ParamStr(15), cReducedQuality);
- cLocaleFName:= ParamStr(16)
+ val(ParamStr(16), tmp);
+ cStereoMode:= TStereoMode(max(0, min(ord(high(TStereoMode)), tmp)));
+ cLocaleFName:= ParamStr(17);
end;
procedure setVideo(screenWidth: LongInt; screenHeight: LongInt; bitsStr: LongInt);
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/GSHandlers.inc
--- a/hedgewars/GSHandlers.inc Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/GSHandlers.inc Wed Feb 02 23:21:14 2011 +0100
@@ -176,7 +176,15 @@
procedure CheckCollision(Gear: PGear); inline;
begin
- if TestCollisionXwithGear(Gear, hwSign(Gear^.X)) or TestCollisionYwithGear(Gear, hwSign(Gear^.Y)
+ if TestCollisionXwithGear(Gear, hwSign(Gear^.dX)) or TestCollisionYwithGear(Gear, hwSign(Gear^.dY)
+ )
+ then Gear^.State := Gear^.State or gstCollision
+ else Gear^.State := Gear^.State and not gstCollision
+end;
+
+procedure CheckCollisionWithLand(Gear: PGear); inline;
+begin
+ if TestCollisionX(Gear, hwSign(Gear^.dX)) or TestCollisionY(Gear, hwSign(Gear^.dY)
)
then Gear^.State := Gear^.State or gstCollision
else Gear^.State := Gear^.State and not gstCollision
@@ -207,7 +215,7 @@
//else
// PlaySound(sndOw1, Gear^.Hedgehog^.Team^.voicepack);
- ApplyDamage(Gear, dmg, dsFall);
+ ApplyDamage(Gear, CurrentHedgehog, dmg, dsFall);
end
end;
@@ -233,10 +241,10 @@
AllInactive := false;
Gear^.Y := Gear^.Y + cDrownSpeed;
Gear^.X := Gear^.X + Gear^.dX * cDrownSpeed;
- if (cWaterOpacity > $FE) or (hwRound(Gear^.Y) > Gear^.Radius + cWaterLine + cVisibleWater) then
+ if (not SuddenDeathDmg and (cWaterOpacity > $FE)) or (SuddenDeathDmg and (cSDWaterOpacity > $FE)) or (hwRound(Gear^.Y) > Gear^.Radius + cWaterLine + cVisibleWater) then
DeleteGear(Gear);
// Create some bubbles (0.5% might be better but causes too few bubbles sometimes)
- if (cWaterOpacity < $FF) and ((GameTicks and $1F) = 0) then
+ if ((not SuddenDeathDmg and (cWaterOpacity < $FF)) or (SuddenDeathDmg and (cSDWaterOpacity < $FF))) and ((GameTicks and $1F) = 0) then
if (Gear^.Kind = gtHedgehog) and (Random(4) = 0) then
AddVisualGear(hwRound(Gear^.X) - Gear^.Radius, hwRound(Gear^.Y) - Gear^.Radius,
vgtBubble)
@@ -367,7 +375,7 @@
begin
CheckCollision(Gear);
if (Gear^.State and gstCollision) <> 0 then
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, EXPLDontDraw or EXPLNoGfx);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, Gear^.Hedgehog, EXPLDontDraw or EXPLNoGfx);
end;
if (Gear^.Kind = gtGasBomb) and ((GameTicks mod 200) = 0) then
@@ -380,13 +388,13 @@
if Gear^.Timer = 0 then
begin
case Gear^.Kind of
- gtBomb: doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
- gtBall: doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 40, EXPLAutoSound);
+ gtBomb: doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
+ gtBall: doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 40, Gear^.Hedgehog, EXPLAutoSound);
gtClusterBomb:
begin
x := hwRound(Gear^.X);
y := hwRound(Gear^.Y);
- doMakeExplosion(x, y, 20, EXPLAutoSound);
+ doMakeExplosion(x, y, 20, Gear^.Hedgehog, EXPLAutoSound);
for i:= 0 to 4 do
begin
dX := rndSign(GetRandom * _0_1) + Gear^.dX / 5;
@@ -398,7 +406,7 @@
begin
x := hwRound(Gear^.X);
y := hwRound(Gear^.Y);
- doMakeExplosion(x, y, 75, EXPLAutoSound);
+ doMakeExplosion(x, y, 75, Gear^.Hedgehog, EXPLAutoSound);
for i:= 0 to 5 do
begin
dX := rndSign(GetRandom * _0_1) + Gear^.dX / 5;
@@ -410,7 +418,7 @@
begin
x := hwRound(Gear^.X);
y := hwRound(Gear^.Y);
- doMakeExplosion(x, y, 90, EXPLAutoSound);
+ doMakeExplosion(x, y, 90, Gear^.Hedgehog, EXPLAutoSound);
for i:= 0 to 127 do
begin
@@ -424,7 +432,7 @@
end;
gtGasBomb:
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, Gear^.Hedgehog, EXPLAutoSound);
for i:= 0 to 2 do
begin
x:= GetRandom(60);
@@ -501,7 +509,7 @@
doStepFallingGear(Gear);
if (Gear^.State and gstCollision) <> 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), Gear^.Timer, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), Gear^.Timer, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
exit
end;
@@ -520,7 +528,7 @@
doStepFallingGear(Gear);
if (Gear^.State and gstCollision) <> 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
exit
end;
@@ -563,6 +571,7 @@
move, allpx: Boolean;
s: PSDL_Surface;
p: PLongwordArray;
+ oAlpha, nAlpha: byte;
begin
if GameTicks and $7 = 0 then
begin
@@ -590,49 +599,86 @@
move:= false;
// move back to cloud layer
if yy > cWaterLine then move:= true
- else if ((yy and LAND_HEIGHT_MASK) = 0) and ((xx and LAND_WIDTH_MASK) = 0) and (Land[yy, xx] > 255) then
+ else if ((yy and LAND_HEIGHT_MASK) <> 0) or ((xx and LAND_WIDTH_MASK) <> 0) then move:=true
+ // Solid pixel encountered
+ else if (Land[yy, xx] <> 0) then
begin
- // we've collided with land. draw some stuff and get back into the clouds
- move:= true;
- if (CurAmmoGear = nil) or (CurAmmoGear^.Kind <> gtRope) then
+ // If there's room below keep falling
+ if (((yy-1) and LAND_HEIGHT_MASK) = 0) and (Land[yy-1, xx] = 0) then
+ begin
+ X:= X - cWindSpeed * 1600 - dX;
+ end
+ // If there's room below, on the sides, fill the gaps
+ else if (((yy-1) and LAND_HEIGHT_MASK) = 0) and (((xx-(1*hwSign(cWindSpeed))) and LAND_WIDTH_MASK) = 0) and (Land[yy-1, (xx-(1*hwSign(cWindSpeed)))] = 0) then
+ begin
+ X:= X - _0_8 * hwSign(cWindSpeed);
+ Y:= Y - dY - cGravity * vobFallSpeed * 8;
+ end
+ else if (((yy-1) and LAND_HEIGHT_MASK) = 0) and (((xx-(2*hwSign(cWindSpeed))) and LAND_WIDTH_MASK) = 0) and (Land[yy-1, (xx-(2*hwSign(cWindSpeed)))] = 0) then
begin
-////////////////////////////////// TODO - ASK UNC0RR FOR A GOOD HOME FOR THIS ////////////////////////////////////
- if cWindSpeed * 1600 + dX < _0 then i:= -1
- else i:= 1;
- if (yy > 0) and ((Land[yy-1, xx] and $FF00) = 0) then dec(yy)
- else dec(xx, i);
- dec(yy,2);
- dec(xx,i);
- s:= SpritesData[sprSnow].Surface;
- p:= s^.pixels;
- allpx:= true;
- for py:= 0 to Pred(s^.h) do
+ X:= X - _0_8 * 2 * hwSign(cWindSpeed);
+ Y:= Y - dY - cGravity * vobFallSpeed * 8;
+ end
+ else if (((yy-1) and LAND_HEIGHT_MASK) = 0) and (((xx+(1*hwSign(cWindSpeed))) and LAND_WIDTH_MASK) = 0) and (Land[yy-1, (xx+(1*hwSign(cWindSpeed)))] = 0) then
+ begin
+ X:= X + _0_8 * hwSign(cWindSpeed);
+ Y:= Y - dY - cGravity * vobFallSpeed * 8;
+ end
+ else if (((yy-1) and LAND_HEIGHT_MASK) = 0) and (((xx+(2*hwSign(cWindSpeed))) and LAND_WIDTH_MASK) = 0) and (Land[yy-1, (xx+(2*hwSign(cWindSpeed)))] = 0) then
+ begin
+ X:= X + _0_8 * 2 * hwSign(cWindSpeed);
+ Y:= Y - dY - cGravity * vobFallSpeed * 8;
+ end
+ // if there's an hog/object below do nothing
+ else if ((((yy+1) and LAND_HEIGHT_MASK) = 0) and ((Land[yy+1, xx] and $FF) <> 0))
+ then move:=true
+ else
+ begin
+ // we've collided with land. draw some stuff and get back into the clouds
+ move:= true;
+ if (CurAmmoGear = nil) or (CurAmmoGear^.Kind <> gtRope) then
begin
- for px:= 0 to Pred(s^.w) do
- if (((yy + py) and LAND_HEIGHT_MASK) = 0) and (((xx + px) and LAND_WIDTH_MASK) = 0) and
- ((Land[yy + py, xx + px] and $FF00) = 0) then
- begin
- if (cReducedQuality and rqBlurryLand) = 0 then
- LandPixels[yy + py, xx + px]:= p^[px]
- else
- LandPixels[(yy + py) div 2, (xx + px) div 2]:= p^[px]
- end
- else allpx:= false;
- p:= @(p^[s^.pitch shr 2])
- end;
- if allpx then UpdateLandTexture(xx, 4, yy, 4)
- else if ((yy and LAND_HEIGHT_MASK) = 0) and ((xx and LAND_WIDTH_MASK) = 0) then UpdateLandTexture(xx, 1, yy, 1);
- inc(yy,2);
- inc(xx,i);
- if ((xx and LAND_WIDTH_MASK) = 0) and ((yy and LAND_HEIGHT_MASK) = 0) then Land[yy, xx]:= Land[yy, xx] or lfObject;
- if yy > 0 then
- begin
- Land[yy-1, xx]:= Land[yy-1, xx] or lfObject;
- if ((xx-i and LAND_WIDTH_MASK) = 0) then Land[yy-1, xx-i]:= Land[yy-1, xx-i] or lfObject;
- end;
- if ((xx-i and LAND_WIDTH_MASK) = 0) and ((yy and LAND_HEIGHT_MASK) = 0) then Land[yy, xx-i]:= Land[yy, xx-i] or lfObject
-////////////////////////////////// TODO - ASK UNC0RR FOR A GOOD HOME FOR THIS ////////////////////////////////////
- end
+ ////////////////////////////////// TODO - ASK UNC0RR FOR A GOOD HOME FOR THIS ////////////////////////////////////
+ dec(yy,3);
+ dec(xx,1);
+ s:= SpritesData[sprSnow].Surface;
+ p:= s^.pixels;
+ allpx:= true;
+ for py:= 0 to Pred(s^.h) do
+ begin
+ for px:= 0 to Pred(s^.w) do
+ if ((((yy + py) and LAND_HEIGHT_MASK) = 0) and (((xx + px) and LAND_WIDTH_MASK) = 0)) and ((Land[yy + py, xx + px] and $FF) = 0) then
+ begin
+ Land[yy + py, xx + px]:= Land[yy + py, xx + px] or lfObject;
+ if (cReducedQuality and rqBlurryLand) = 0 then
+ begin
+ LandPixels[yy + py, xx + px]:= addBgColor(LandPixels[yy + py, xx + px], p^[px]);
+ end
+ else
+ begin
+ LandPixels[(yy + py) div 2, (xx + px) div 2]:= addBgColor(LandPixels[(yy + py) div 2, (xx + px) div 2], p^[px]);
+ end;
+ end
+ else allpx:= false;
+ p:= @(p^[s^.pitch shr 2])
+ end;
+
+
+ Land[py, px+1]:= lfBasic;
+
+ if allpx then UpdateLandTexture(xx, Pred(s^.h), yy, Pred(s^.w))
+ else
+ begin
+ UpdateLandTexture(
+ max(0, min(LAND_WIDTH, xx)),
+ min(LAND_WIDTH - xx, Pred(s^.w)),
+ max(0, min(LAND_WIDTH, yy)),
+ min(LAND_HEIGHT - yy, Pred(s^.h))
+ );
+ end;
+ ////////////////////////////////// TODO - ASK UNC0RR FOR A GOOD HOME FOR THIS ////////////////////////////////////
+ end
+ end;
end;
if move then
begin
@@ -720,7 +766,7 @@
if ((Gear^.State and gstCollision) <> 0) or (Gear^.Timer = 0) then
begin
StopSound(Gear^.SoundChannel);
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
end;
end;
@@ -734,7 +780,7 @@
CheckCollision(Gear);
if (Gear^.State and gstCollision) <> 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
exit
end;
@@ -851,7 +897,7 @@
dec(Gear^.Health, Gear^.Damage);
Gear^.Damage := 0
end;
- if ((Gear^.State and gstDrowning) <> 0) and (Gear^.Damage < Gear^.Health) and (cWaterOpacity < $FF) then
+ if ((Gear^.State and gstDrowning) <> 0) and (Gear^.Damage < Gear^.Health) and ((not SuddenDeathDmg and (cWaterOpacity < $FF)) or (SuddenDeathDmg and (cSDWaterOpacity < $FF))) then
begin
for i:=(Gear^.Health - Gear^.Damage) * 4 downto 0 do
begin
@@ -1037,7 +1083,7 @@
if (Gear^.Timer mod 33) = 0 then
begin
HHGear^.State := HHGear^.State or gstNoDamage;
- doMakeExplosion(x, y + 7, 6, EXPLDontDraw);
+ doMakeExplosion(x, y + 7, 6, Gear^.Hedgehog, EXPLDontDraw);
HHGear^.State := HHGear^.State and not gstNoDamage
end;
@@ -1316,19 +1362,19 @@
if (GameFlags and gfMoreWind) <> 0 then HHGear^.dX := HHGear^.dX + cWindSpeed / HHGear^.Density;
end;
+ // vector between hedgehog and rope attaching point
ropeDx := HHGear^.X - Gear^.X;
- // vector between hedgehog and rope attaching point
ropeDy := HHGear^.Y - Gear^.Y;
mdX := ropeDx + HHGear^.dX;
mdY := ropeDy + HHGear^.dY;
len := _1 / Distance(mdX, mdY);
+ // rope vector plus hedgehog direction vector normalized
mdX := mdX * len;
- // rope vector plus hedgehog direction vector normalized
mdY := mdY * len;
+ // for visual purposes only
Gear^.dX := mdX;
- // for visual purposes only
Gear^.dY := mdY;
/////
@@ -1456,35 +1502,45 @@
HHGear^.dY := HHGear^.dY * len;
end;
- haveCollision:= false;
- if RopePoints.Count > 0 then
- begin
- ly:= hwRound(RopePoints.ar[0].Y);
- lx:= hwRound(RopePoints.ar[0].X)
- end
- else if Gear^.Elasticity.QWordValue > 0 then
- begin
- ly:= hwRound(Gear^.Y);
- lx:= hwRound(Gear^.X)
- end;
-(* // just in case it turns out we have rounding problems
- i:= -1;
- while not haveCollision and (i < 2) do
+ haveCollision:= ((hwRound(Gear^.Y) and LAND_HEIGHT_MASK) = 0) and ((hwRound(Gear^.X) and LAND_WIDTH_MASK) = 0) and ((Land[hwRound(Gear^.Y), hwRound(Gear^.X)] and $FF00) <> 0);
+
+ if not haveCollision then
begin
- j:= -1;
- while not haveCollision and (j < 2) do
+ // backup gear location
+ tx:= Gear^.X;
+ ty:= Gear^.Y;
+
+ if RopePoints.Count > 0 then
+ begin
+ // set gear location to the remote end of the rope, the attachment point
+ Gear^.X:= RopePoints.ar[0].X;
+ Gear^.Y:= RopePoints.ar[0].Y;
+ end;
+
+ CheckCollisionWithLand(Gear);
+ // if we haven't found any collision yet then check the otheer side too
+ if (Gear^.State and gstCollision) = 0 then
begin
- haveCollision:= ((((ly + i) and LAND_HEIGHT_MASK) = 0) and
- (((lx + j) and LAND_WIDTH_MASK) = 0) and
- ((Land[ly + i, lx + j] and $FF00) <> 0));
- inc(j)
+ Gear^.dX.isNegative:= not Gear^.dX.isNegative;
+ Gear^.dY.isNegative:= not Gear^.dY.isNegative;
+ CheckCollisionWithLand(Gear);
+ Gear^.dX.isNegative:= not Gear^.dX.isNegative;
+ Gear^.dY.isNegative:= not Gear^.dY.isNegative;
end;
- inc(i)
- end; *)
- if ((Gear^.Message and gmAttack) <> 0) or
- (((ly and LAND_HEIGHT_MASK) = 0) and
- ((lx and LAND_WIDTH_MASK) = 0) and
- ((Land[ly, lx] and $FF00) = 0)) then
+
+ haveCollision:= (Gear^.State and gstCollision) <> 0;
+
+ // restore gear location
+ Gear^.X:= tx;
+ Gear^.Y:= ty;
+ end;
+
+ // if the attack key is pressed, lose rope contact as well
+ if (Gear^.Message and gmAttack) <> 0 then
+ haveCollision:= false;
+
+ if not haveCollision then
+ begin
if (Gear^.State and gsttmpFlag) <> 0 then
with Gear^.Hedgehog^ do
begin
@@ -1494,10 +1550,11 @@
else
DeleteMe
end
- else
+ end
else
if (Gear^.State and gsttmpFlag) = 0 then
Gear^.State := Gear^.State or gsttmpFlag;
+
end;
procedure doStepRopeAttach(Gear: PGear);
@@ -1574,9 +1631,7 @@
end;
end;
- if ((hwRound(Gear^.Y) and LAND_HEIGHT_MASK) = 0) and ((hwRound(Gear^.X) and LAND_WIDTH_MASK) = 0) and ((Land[hwRound(Gear^.Y), hwRound(Gear^.X)] and $FF00) <> 0) then
- Gear^.State:= Gear^.State or gstCollision
- else Gear^.State:= Gear^.State and not gstCollision;
+ CheckCollisionWithLand(Gear);
if (Gear^.State and gstCollision) <> 0 then
if Gear^.Elasticity < _10 then
@@ -1655,7 +1710,7 @@
(cMineDudPercent = 0) or
(getRandom(100) > cMineDudPercent) then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear)
end
else
@@ -1676,41 +1731,45 @@
////////////////////////////////////////////////////////////////////////////////
procedure doStepSMine(Gear: PGear);
begin
- DeleteCI(Gear);
// TODO: do real calculation?
if TestCollisionXwithGear(Gear, 2) or TestCollisionYwithGear(Gear, -2) or TestCollisionXwithGear(Gear, -2) or TestCollisionYwithGear(Gear, 2) then
begin
if (hwAbs(Gear^.dX) > _0) or (hwAbs(Gear^.dY) > _0) then
+ begin
PlaySound(sndRopeAttach);
- Gear^.dX:= _0;
- Gear^.dY:= _0;
+ Gear^.dX:= _0;
+ Gear^.dY:= _0;
+ AddGearCI(Gear);
+ end;
end
else
begin
+ DeleteCI(Gear);
doStepFallingGear(Gear);
AllInactive := false;
CalcRotationDirAngle(Gear);
end;
- AddGearCI(Gear);
if ((Gear^.State and gsttmpFlag) <> 0) and (Gear^.Health <> 0) then
+ begin
if ((Gear^.State and gstAttacking) = 0) then
begin
if ((GameTicks and $1F) = 0) then
if CheckGearNear(Gear, gtHedgehog, 46, 32) <> nil then Gear^.State := Gear^.State or
gstAttacking
end
- else // gstAttacking <> 0
- begin
- AllInactive := false;
- if (Gear^.Timer and $FF) = 0 then PlaySound(sndMineTick);
- if Gear^.Timer = 0 then
+ else // gstAttacking <> 0
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound);
- DeleteGear(Gear);
- exit
- end;
- dec(Gear^.Timer);
+ AllInactive := false;
+ if (Gear^.Timer and $FF) = 0 then PlaySound(sndMineTick);
+ if Gear^.Timer = 0 then
+ begin
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound);
+ DeleteGear(Gear);
+ exit
+ end;
+ dec(Gear^.Timer);
+ end
end
else // gsttmpFlag = 0
if TurnTimeLeft = 0 then Gear^.State := Gear^.State or gsttmpFlag;
@@ -1726,7 +1785,7 @@
makeHogsWorry(Gear^.X, Gear^.Y, 75);
if Gear^.Timer = 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 75, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 75, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
exit
end;
@@ -1819,6 +1878,7 @@
k: TGearType;
exBoom: boolean;
dX, dY: HWFloat;
+ hog: PHedgehog;
begin
k := Gear^.Kind;
exBoom := false;
@@ -1855,18 +1915,20 @@
begin
x := hwRound(Gear^.X);
y := hwRound(Gear^.Y);
+ hog:= Gear^.Hedgehog;
+
DeleteGear(Gear);
// <-- delete gear!
if k = gtCase then
begin
- doMakeExplosion(x, y, 25, EXPLAutoSound);
+ doMakeExplosion(x, y, 25, hog, EXPLAutoSound);
for i:= 0 to 63 do
AddGear(x, y, gtFlame, 0, _0, _0, 0);
end
else if k = gtExplosives then
begin
- doMakeExplosion(x, y, 75, EXPLAutoSound);
+ doMakeExplosion(x, y, 75, hog, EXPLAutoSound);
for i:= 0 to 31 do
begin
dX := AngleCos(i * 64) * _0_5 * (getrandom + _1);
@@ -1917,28 +1979,12 @@
if (Gear^.Tag = 0) and (Gear^.Timer < 1000) then
inc(Gear^.Timer)
else if Gear^.Tag = 1 then
- begin
- Gear^.Tag := 2;
- if (TrainingFlags and tfTimeTrial) <> 0 then
- begin
- inc(TurnTimeLeft, TrainingTimeInc);
-
- if TrainingTimeInc > TrainingTimeInM then
- dec(TrainingTimeInc, TrainingTimeInD);
- if TurnTimeLeft > TrainingTimeMax then
- TurnTimeLeft := TrainingTimeMax;
- end;
- end
+ Gear^.Tag := 2
else if Gear^.Tag = 2 then
if Gear^.Timer > 0 then
dec(Gear^.Timer)
else
begin
- if (TrainingFlags and tfTargetRespawn) <> 0 then
- begin
- TrainingTargetGear := AddGear(0, 0, gtTarget, 0, _0, _0, 0);
- FindPlace(TrainingTargetGear, false, 0, LAND_WIDTH);
- end;
DeleteGear(Gear);
exit;
end;
@@ -2067,7 +2113,7 @@
AmmoShove(Gear, 4, 150);
Gear^.Radius := 1;
end
- else if ((GameTicks and $3) = 3) then doMakeExplosion(gX, gY, 6, 0);//, EXPLNoDamage);
+ else if ((GameTicks and $3) = 3) then doMakeExplosion(gX, gY, 6, Gear^.Hedgehog, 0);//, EXPLNoDamage);
//DrawExplosion(gX, gY, 4);
if ((GameTicks and $7) = 0) and (Random(2) = 0) then
for i:= 1 to Random(2)+1 do
@@ -2206,14 +2252,16 @@
exit
end;
- if not TestCollisionXwithGear(HHGear, hwSign(HHGear^.dX)) then
- HHGear^.X := HHGear^.X + cWindSpeed * 200;
+ HHGear^.X := HHGear^.X + cWindSpeed * 200;
if (Gear^.Message and gmLeft) <> 0 then HHGear^.X := HHGear^.X - cMaxWindSpeed * 80
else if (Gear^.Message and gmRight) <> 0 then HHGear^.X := HHGear^.X + cMaxWindSpeed * 80;
if (Gear^.Message and gmUp) <> 0 then HHGear^.Y := HHGear^.Y - cGravity * 40
else if (Gear^.Message and gmDown) <> 0 then HHGear^.Y := HHGear^.Y + cGravity * 40;
+ // don't drift into obstacles
+ if TestCollisionXwithGear(HHGear, hwSign(HHGear^.dX)) then
+ HHGear^.X := HHGear^.X - int2hwFloat(hwSign(HHGear^.dX));
HHGear^.Y := HHGear^.Y + cGravity * 100;
Gear^.X := HHGear^.X;
Gear^.Y := HHGear^.Y
@@ -2255,7 +2303,7 @@
2: FollowGear := AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtNapalmBomb, 0, cBombsSpeed *
Gear^.Tag, _0, 0);
3: FollowGear := AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtDrill, gsttmpFlag, cBombsSpeed *
- Gear^.Tag, _0, 0);
+ Gear^.Tag, _0, Gear^.Timer + 1);
//4: FollowGear := AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtWaterMelon, 0, cBombsSpeed *
// Gear^.Tag, _0, 5000);
end;
@@ -2286,9 +2334,13 @@
Gear^.Y := int2hwFloat(topY-300);
Gear^.dX := int2hwFloat(TargetPoint.X - 5 * Gear^.Tag * 15);
- if (int2hwFloat(TargetPoint.Y) - Gear^.Y > _0) then
- Gear^.dX := Gear^.dX - cBombsSpeed * hwSqrt((int2hwFloat(TargetPoint.Y) - Gear^.Y) * 2 /
- cGravity) * Gear^.Tag;
+ // calcs for Napalm Strike, so that it will hit the target (without wind at least :P)
+ if (Gear^.State = 2) then
+ Gear^.dX := Gear^.dX - cBombsSpeed * Gear^.Tag * 1000 // ^.Timer of gtNapalmBomb, make it a constant var if you prefer that :P
+ // calcs for regular falling gears
+ else if (int2hwFloat(TargetPoint.Y) - Gear^.Y > _0) then
+ Gear^.dX := Gear^.dX - cBombsSpeed * hwSqrt((int2hwFloat(TargetPoint.Y) - Gear^.Y) * 2 /
+ cGravity) * Gear^.Tag;
Gear^.Health := 6;
Gear^.doStep := @doStepAirAttackWork;
@@ -2302,7 +2354,7 @@
doStepFallingGear(Gear);
if (Gear^.State and gstCollision) <> 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
performRumble();
exit
@@ -2329,7 +2381,7 @@
if (Distance(tx - x, ty - y) > _256) or
not TryPlaceOnLand(TargetPoint.X - SpritesData[sprAmGirder].Width div 2,
TargetPoint.Y - SpritesData[sprAmGirder].Height div 2,
- sprAmGirder, Gear^.State, true) then
+ sprAmGirder, Gear^.State, true, false) then
begin
PlaySound(sndDenied);
HHGear^.Message := HHGear^.Message and not gmAttack;
@@ -2358,6 +2410,7 @@
Gear^.Hedgehog^.Unplaced := false;
HHGear := Gear^.Hedgehog^.Gear;
HHGear^.Y := HHGear^.Y + HHGear^.dY;
+ HHGear^.X := HHGear^.X + HHGear^.dX;
// hedgehog falling to collect cases
HHGear^.dY := HHGear^.dY + cGravity;
if TestCollisionYwithGear(HHGear, 1)
@@ -2389,7 +2442,7 @@
HHGear := Gear^.Hedgehog^.Gear;
if not TryPlaceOnLand(TargetPoint.X - SpritesData[sprHHTelepMask].Width div 2,
TargetPoint.Y - SpritesData[sprHHTelepMask].Height div 2,
- sprHHTelepMask, 0, false) then
+ sprHHTelepMask, 0, false, false) then
begin
HHGear^.Message := HHGear^.Message and not gmAttack;
HHGear^.State := HHGear^.State and not gstAttacking;
@@ -2501,7 +2554,7 @@
doStepFallingGear(Gear);
if (Gear^.State and gstCollision) <> 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, Gear^.Hedgehog, EXPLAutoSound);
Gear^.dX.isNegative := not dxn;
Gear^.dY.isNegative := not dyn;
@@ -2571,7 +2624,7 @@
if Gear^.Health < Gear^.Damage then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound);
AfterAttack;
DeleteGear(Gear);
DeleteGear(HHGear);
@@ -2631,7 +2684,7 @@
inc(Gear^.Tag);
if Gear^.Tag < 2250 then exit;
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), cakeDmg, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), cakeDmg, Gear^.Hedgehog, EXPLAutoSound);
AfterAttack;
DeleteGear(Gear)
end;
@@ -2885,6 +2938,9 @@
end;
////////////////////////////////////////////////////////////////////////////////
+procedure doStepDrill(Gear: PGear);
+forward;
+
procedure doStepDrillDrilling(Gear: PGear);
var
t: PGearArray;
@@ -2913,19 +2969,26 @@
if (Gear^.Timer = 0)
or (t^.Count <> 0)
or (not TestCollisionYWithGear(Gear, hwSign(Gear^.dY))
- and not TestCollisionXWithGear(Gear, hwSign(Gear^.dX)))
+ and not TestCollisionXWithGear(Gear, hwSign(Gear^.dX))
+ and ((Gear^.State and gsttmpFlag) = 0))
// CheckLandValue returns true if the type isn't matched
or not CheckLandValue(hwRound(Gear^.X), hwRound(Gear^.Y), lfIndestructible) then
- begin
+ begin
//out of time or exited ground
StopSound(Gear^.SoundChannel);
if (Gear^.State and gsttmpFlag) <> 0 then
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound)
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound)
else
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
exit
- end;
+ end
+ else if not TestCollisionYWithGear(Gear, hwSign(Gear^.dY)) and not TestCollisionXWithGear(Gear, hwSign(Gear^.dX)) then
+ begin
+ StopSound(Gear^.SoundChannel);
+ Gear^.Tag := 1;
+ Gear^.doStep := @doStepDrill
+ end;
dec(Gear^.Timer);
end;
@@ -2967,17 +3030,29 @@
begin
//explode right on contact with HH
if (Gear^.State and gsttmpFlag) <> 0 then
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound)
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound)
else
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50, Gear^.Hedgehog, EXPLAutoSound);
DeleteGear(Gear);
exit;
end;
Gear^.SoundChannel := LoopSound(sndDrillRocket);
Gear^.doStep := @doStepDrillDrilling;
+ if (Gear^.State and gsttmpFlag) <> 0 then
+ gear^.RenderTimer:= true;
dec(Gear^.Timer)
end
+ else if ((Gear^.State and gsttmpFlag) <> 0) and (Gear^.Tag <> 0) then
+ begin
+ if Gear^.Timer = 0 then
+ begin
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, Gear^.Hedgehog, EXPLAutoSound);
+ DeleteGear(Gear);
+ end
+ else
+ dec(Gear^.Timer);
+ end;
end;
////////////////////////////////////////////////////////////////////////////////
@@ -3037,14 +3112,11 @@
begin
AllInactive := false;
- if ((TrainingFlags and tfRCPlane) = 0) and (Gear^.Timer > 0) then dec(Gear^.Timer);
-
- if ((TrainingFlags and tfRCPlane) <> 0) and ((TrainingFlags and tfTimeTrial) <> 0 ) and (
- TimeTrialStartTime = 0) then TimeTrialStartTime := RealTicks;
-
HHGear := Gear^.Hedgehog^.Gear;
FollowGear := Gear;
+ if Gear^.Timer > 0 then dec(Gear^.Timer);
+
fChanged := false;
if ((HHGear^.State and gstHHDriven) = 0) or (Gear^.Timer = 0) then
begin
@@ -3084,73 +3156,44 @@
Gear^.X := Gear^.X + Gear^.dX;
Gear^.Y := Gear^.Y + Gear^.dY;
- if (TrainingFlags and tfRCPlane) = 0 then
+ if (GameTicks and $FF) = 0 then
+ if Gear^.Timer < 3500 then
+ AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtEvilTrace)
+ else
+ AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtSmokeTrace);
+
+ if ((HHGear^.Message and gmAttack) <> 0) and (Gear^.Health <> 0) then
begin
- if (GameTicks and $FF) = 0 then
- if Gear^.Timer < 3500 then
- AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtEvilTrace)
- else
- AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtSmokeTrace);
-
- if ((HHGear^.Message and gmAttack) <> 0) and (Gear^.Health <> 0) then
- begin
- HHGear^.Message := HHGear^.Message and not gmAttack;
- AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtAirBomb, 0, Gear^.dX * _0_5, Gear^.dY *
- _0_5, 0);
- dec(Gear^.Health)
- end;
-
- if ((HHGear^.Message and gmLJump) <> 0)
- and ((Gear^.State and gsttmpFlag) = 0) then
- begin
- Gear^.State := Gear^.State or gsttmpFlag;
- PauseMusic;
- playSound(sndRideOfTheValkyries);
- end;
-
- // pickup bonuses
- t := CheckGearNear(Gear, gtCase, 36, 36);
- if t <> nil then
- PickUp(HHGear, t);
- end
- else
+ HHGear^.Message := HHGear^.Message and not gmAttack;
+ AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtAirBomb, 0, Gear^.dX * _0_5, Gear^.dY *
+ _0_5, 0);
+ dec(Gear^.Health)
+ end;
+
+ if ((HHGear^.Message and gmLJump) <> 0)
+ and ((Gear^.State and gsttmpFlag) = 0) then
begin
- if (GameTicks and $FF) = 0 then
- AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtSmokeTrace);
-
- // pickup targets
- t := CheckGearNear(Gear, gtTarget, 36, 36);
- if t <> nil then
- begin
- if t^.Tag <> 0 then // collect it only once
- exit;
- PlaySound(sndShotgunReload);
- t^.Tag := 1;
- TrainingTargetGear := nil;
- // remove target cursor
- exit;
- end;
-
- if (TurnTimeLeft > 0) then
- dec(TurnTimeLeft)
+ Gear^.State := Gear^.State or gsttmpFlag;
+ PauseMusic;
+ playSound(sndRideOfTheValkyries);
end;
+ // pickup bonuses
+ t := CheckGearNear(Gear, gtCase, 36, 36);
+ if t <> nil then
+ PickUp(HHGear, t);
+
CheckCollision(Gear);
- if ((Gear^.State and gstCollision) <> 0) or (((TrainingFlags and tfRCPlane) <> 0) and (
- TurnTimeLeft = 0))
- or CheckGearDrowning(Gear) then
+ if ((Gear^.State and gstCollision) <> 0) or CheckGearDrowning(Gear) then
begin
- if ((TrainingFlags and tfRCPlane) <> 0) and ((TrainingFlags and tfTimeTrial) <> 0 ) and (
- TimeTrialStopTime = 0) then TimeTrialStopTime := RealTicks;
StopSound(Gear^.SoundChannel);
StopSound(sndRideOfTheValkyries);
ResumeMusic;
- if ((Gear^.State and gstCollision) <> 0) or (((TrainingFlags and tfRCPlane) <> 0) and (
- TurnTimeLeft = 0)) then
+ if ((Gear^.State and gstCollision) <> 0) then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 25, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 25, Gear^.Hedgehog, EXPLAutoSound);
for i:= 0 to 32 do
begin
dX := AngleCos(i * 64) * _0_5 * (GetRandom + _1);
@@ -3165,10 +3208,6 @@
CurAmmoGear := nil;
if (GameFlags and gfInfAttack) = 0 then TurnTimeLeft := 14 * 125;
- if (TrainingFlags and tfRCPlane) <> 0 then
- TurnTimeLeft := 0;
- // HACK: RCPlane training allows unlimited plane starts in last 2 seconds
-
HHGear^.Message := 0;
ParseCommand('/taunt '#1, true)
end
@@ -3529,7 +3568,7 @@
if (Gear^.State and gstCollision) <> 0 then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 10, EXPLPoisoned, $C0E0FFE0);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 10, Gear^.Hedgehog, EXPLPoisoned, $C0E0FFE0);
PlaySound(sndEggBreak);
AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtEgg);
vg := AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtEgg);
@@ -3549,8 +3588,7 @@
////////////////////////////////////////////////////////////////////////////////
procedure doPortalColorSwitch();
-var flags: LongWord;
- CurWeapon: PAmmo;
+var CurWeapon: PAmmo;
begin
if (CurrentHedgehog <> nil)
and (CurrentHedgehog^.Gear <> nil)
@@ -3561,11 +3599,10 @@
CurrentHedgehog^.Gear^.Message := CurrentHedgehog^.Gear^.Message and not gmSwitch;
CurWeapon:= GetAmmoEntry(CurrentHedgehog^);
- flags := CurWeapon^.Timer and not 2;
- if (flags and 1) = 0 then
- CurWeapon^.Timer := flags or 1
+ if CurWeapon^.Pos <> 0 then
+ CurWeapon^.Pos := 0
else
- CurWeapon^.Timer := flags and not 1;
+ CurWeapon^.Pos := 1;
end;
end;
@@ -3834,8 +3871,7 @@
s: hwFloat;
procedure loadNewPortalBall(oldPortal: PGear; destroyGear: Boolean);
-var
- flags: LongWord;
+var
CurWeapon: PAmmo;
begin
if CurrentHedgehog <> nil then
@@ -3844,18 +3880,19 @@
CurWeapon:= GetAmmoEntry(CurrentHedgehog^);
if (CurAmmoType = amPortalGun) then
begin
- flags := CurWeapon^.Timer;
-
- if destroyGear xor ((oldPortal^.Tag and 2) = 0) then
- flags := flags or 1
- else
- flags := flags and not 1;
-
- CurWeapon^.Timer := flags and not 2;
+ if not destroyGear then
+ begin
+ // switch color of ball to opposite of oldPortal
+ if (oldPortal^.Tag and 2) = 0 then
+ CurWeapon^.Pos:= 1
+ else
+ CurWeapon^.Pos:= 0;
+ end;
+
// make the ball visible
+ CurWeapon^.Timer := 0;
end
end;
-
if destroyGear then oldPortal^.Timer:= 0;
end;
@@ -3940,11 +3977,8 @@
newPortal^.Elasticity.isNegative := not newPortal^.Elasticity.isNegative;
// make portal gun look unloaded
- CurWeapon^.Timer := CurWeapon^.Timer or 2;
-
- // set portal to the currently chosen color
- if ((CurWeapon^.Timer and 1) <> 0) then
- newPortal^.Tag := newPortal^.Tag or 2;
+ if (CurWeapon <> nil) and (CurAmmoType = amPortalGun) then
+ CurWeapon^.Timer := CurWeapon^.Timer or 2;
iterator := GearsList;
while iterator <> nil do
@@ -4040,9 +4074,9 @@
begin
r0 := GetRandom(21);
r1 := GetRandom(21);
- doMakeExplosion(hwRound(Gear^.X) - 30 - r0, hwRound(Gear^.Y) + 40, 40 + r1, 0);
- doMakeExplosion(hwRound(Gear^.X) + 30 + r1, hwRound(Gear^.Y) + 40, 40 + r0, 0);
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 80 + r0, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X) - 30 - r0, hwRound(Gear^.Y) + 40, 40 + r1, Gear^.Hedgehog, 0);
+ doMakeExplosion(hwRound(Gear^.X) + 30 + r1, hwRound(Gear^.Y) + 40, 40 + r0, Gear^.Hedgehog, 0);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 80 + r0, Gear^.Hedgehog, EXPLAutoSound);
for r0:= 0 to 4 do
AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtNote);
Gear^.dY := odY * -1 + cGravity * 2;
@@ -4283,7 +4317,7 @@
Gear^.dX := Gear^.dX + cWindSpeed / 4;
Gear^.dY := Gear^.dY + cGravity / 100;
if (GameTicks mod 250) = 0 then
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, EXPLDontDraw or EXPLNoGfx or EXPLNoDamage or EXPLDoNotTouchAny or EXPLPoisoned);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 20, Gear^.Hedgehog, EXPLDontDraw or EXPLNoGfx or EXPLNoDamage or EXPLDoNotTouchAny or EXPLPoisoned);
AllInactive:= false;
end;
@@ -4311,7 +4345,7 @@
if (tmp^.Kind = gtHedgehog) then
begin
//tmp^.State:= tmp^.State or gstFlatened;
- ApplyDamage(tmp, tmp^.Health div 3, dsUnknown);
+ ApplyDamage(tmp, CurrentHedgehog, tmp^.Health div 3, dsUnknown);
//DrawTunnel(tmp^.X, tmp^.Y - _1, _0, _0_5, cHHRadius * 6, cHHRadius * 3);
tmp2:= AddGear(hwRound(tmp^.X), hwRound(tmp^.Y), gtHammerHit, 0, _0, _0, 0);
tmp2^.Hedgehog:= tmp^.Hedgehog;
@@ -4480,13 +4514,9 @@
RenderHealth(resgear^.Hedgehog^);
RecountTeamHealth(resgear^.Hedgehog^.Team);
resgear^.Hedgehog^.Effects[heResurrected]:= true;
+ // only make hat-less hedgehogs look like zombies, preserve existing hats
if resgear^.Hedgehog^.Hat = 'NoHat' then
- begin
- FreeTexture(resgear^.Hedgehog^.HatTex);
- resgear^.Hedgehog^.HatTex := Surface2Tex(
- LoadImage(Pathz[ptHats] + '/Reserved/Zombie', ifNone),
- True)
- end
+ LoadHedgehogHat(resgear, 'Reserved/Zombie');
end;
hh^.Gear^.dY := _0;
@@ -4534,7 +4564,7 @@
doStepFallingGear(Gear);
if (Gear^.Timer > 0) and ((Gear^.State and gstCollision) <> 0) then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 10, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 10, Gear^.Hedgehog, EXPLAutoSound);
gX := hwRound(Gear^.X);
gY := hwRound(Gear^.Y);
for i:= 0 to 10 do
@@ -4551,7 +4581,7 @@
end;
if (Gear^.Timer = 0) then
begin
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 10, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 10, Gear^.Hedgehog, EXPLAutoSound);
for i:= -19 to 19 do
FollowGear := AddGear(hwRound(Gear^.X) + i div 3, hwRound(Gear^.Y), gtFlame, 0, _0_001 * i, _0, 0);
DeleteGear(Gear);
@@ -4563,4 +4593,116 @@
end;
////////////////////////////////////////////////////////////////////////////////
-
+procedure doStepPlaceStructure(Gear: PGear);
+var
+ HHGear: PGear;
+ x, y, tx, ty: hwFloat;
+begin
+ AllInactive := false;
+
+ HHGear := Gear^.Hedgehog^.Gear;
+ tx := int2hwFloat(TargetPoint.X);
+ ty := int2hwFloat(TargetPoint.Y);
+ x := HHGear^.X;
+ y := HHGear^.Y;
+
+ if (Distance(tx - x, ty - y) > _256) or
+ not TryPlaceOnLand(TargetPoint.X - SpritesData[sprAmGirder].Width div 2,
+ TargetPoint.Y - SpritesData[sprAmGirder].Height div 2,
+ sprAmGirder, Gear^.State, true, false) then
+ begin
+ PlaySound(sndDenied);
+ HHGear^.Message := HHGear^.Message and not gmAttack;
+ HHGear^.State := HHGear^.State and not gstAttacking;
+ HHGear^.State := HHGear^.State or gstHHChooseTarget;
+ isCursorVisible := true;
+ DeleteGear(Gear)
+ end
+ else
+ begin
+ PlaySound(sndPlaced);
+ DeleteGear(Gear);
+ AfterAttack;
+ end;
+
+ HHGear^.State := HHGear^.State and not (gstAttacking or gstAttacked);
+ HHGear^.Message := HHGear^.Message and not gmAttack;
+ TargetPoint.X := NoPointX
+end;
+
+procedure doStepStructure(Gear: PGear);
+var
+ i, x, y: LongInt;
+ dX, dY: HWFloat;
+ hog: PHedgehog;
+begin
+ if Gear^.Hedgehog <> nil then
+ if Gear^.Tag = 0 then
+ begin
+ hog:= Gear^.Hedgehog;
+ hog^.GearHidden:= hog^.Gear;
+ RemoveGearFromList(hog^.Gear);
+ hog^.Gear:= nil;
+ Gear^.Tag:= TotalRounds + 3;
+ end
+ else if Gear^.Tag = TotalRounds then
+ begin
+ hog:= Gear^.Hedgehog;
+ hog^.Gear:= hog^.GearHidden;
+ hog^.Gear^.X:= Gear^.X;
+ hog^.Gear^.Y:= Gear^.Y - Int2hwFloat(Gear^.Radius);
+ hog^.Gear^.Active:= false;
+ hog^.Gear^.State:= hog^.Gear^.State And not gstHHdriven;
+ InsertGearToList(hog^.Gear);
+ hog^.GearHidden:= nil;
+ Gear^.Hedgehog:= nil;
+ end;
+
+ if (Gear^.dY.QWordValue <> 0) or (not TestCollisionYwithGear(Gear, 1)) then
+ begin
+ AllInactive := false;
+ Gear^.dY := Gear^.dY + cGravity;
+ Gear^.Y := Gear^.Y + Gear^.dY;
+ if (not Gear^.dY.isNegative) and (Gear^.dY > _0_001) then SetAllHHToActive;
+ if (Gear^.dY.isNegative) and TestCollisionYwithGear(Gear, -1) then Gear^.dY := _0;
+ if (not Gear^.dY.isNegative) and TestCollisionYwithGear(Gear, 1) then
+ begin
+ if Gear^.dY > _0_2 then
+ for i:= min(12, hwRound(Gear^.dY*_10)) downto 0 do
+ AddVisualGear(hwRound(Gear^.X) - 5 + Random(10), hwRound(Gear^.Y) + 12, vgtDust);
+ Gear^.dY := - Gear^.dY * Gear^.Elasticity;
+ if Gear^.dY > - _0_001 then Gear^.dY := _0
+ else if Gear^.dY < - _0_03 then
+ PlaySound(Gear^.ImpactSound);
+ end;
+ CheckGearDrowning(Gear);
+ end;
+
+ if (Gear^.dY.QWordValue = 0) then AddGearCI(Gear)
+ else if (Gear^.dY.QWordValue <> 0) then DeleteCI(Gear);
+
+ dec(Gear^.Health, Gear^.Damage);
+ Gear^.Damage := 0;
+
+ if Gear^.Health <= 0 then
+ begin
+ if Gear^.Hedgehog <> nil then
+ begin
+ hog:= Gear^.Hedgehog;
+ hog^.Gear:= hog^.GearHidden;
+ hog^.Gear^.X:= Gear^.X;
+ hog^.Gear^.Y:= Gear^.Y;
+ InsertGearToList(hog^.Gear);
+ hog^.GearHidden:= nil;
+ Gear^.Hedgehog:= nil;
+ end;
+
+ x := hwRound(Gear^.X);
+ y := hwRound(Gear^.Y);
+
+ DeleteGear(Gear);
+
+ doMakeExplosion(x, y, 50, CurrentHedgehog, EXPLAutoSound);
+ end;
+end;
+
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/HHHandlers.inc
--- a/hedgewars/HHHandlers.inc Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/HHHandlers.inc Wed Feb 02 23:21:14 2011 +0100
@@ -41,29 +41,29 @@
end;
// Shouldn't more of this ammo switching stuff be moved to uAmmos ?
-function ChangeAmmo(Gear: PGear): boolean;
+function ChangeAmmo(HHGear: PGear): boolean;
var slot, i: Longword;
ammoidx: LongInt;
begin
ChangeAmmo:= false;
-slot:= Gear^.MsgParam;
+slot:= HHGear^.MsgParam;
-with Gear^.Hedgehog^ do
+with HHGear^.Hedgehog^ do
begin
- Gear^.Message:= Gear^.Message and not gmSlot;
+ HHGear^.Message:= HHGear^.Message and not gmSlot;
ammoidx:= 0;
- if ((Gear^.State and (gstAttacking or gstAttacked)) <> 0) or
+ if ((HHGear^.State and (gstAttacking or gstAttacked)) <> 0) or
(TargetPoint.X <> NoPointX) or
((MultiShootAttacks > 0) and ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_NoRoundEnd) = 0)) or
- ((Gear^.State and gstHHDriven) = 0) then exit;
+ ((HHGear^.State and gstHHDriven) = 0) then exit;
ChangeAmmo:= true;
while (ammoidx < cMaxSlotAmmoIndex) and (Ammo^[slot, ammoidx].AmmoType <> CurAmmoType) do inc(ammoidx);
- if ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_NoRoundEnd) <> 0) and (MultiShootAttacks > 0) then OnUsedAmmo(Gear^.Hedgehog^);
+ if ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_NoRoundEnd) <> 0) and (MultiShootAttacks > 0) then OnUsedAmmo(HHGear^.Hedgehog^);
MultiShootAttacks:= 0;
- Gear^.Message:= Gear^.Message and not (gmLJump or gmHJump);
+ HHGear^.Message:= HHGear^.Message and not (gmLJump or gmHJump);
if Ammoz[CurAmmoType].Slot = slot then
begin
@@ -94,31 +94,33 @@
end
end;
-procedure HHSetWeapon(Gear: PGear);
+procedure HHSetWeapon(HHGear: PGear);
var t: LongInt;
weap: TAmmoType;
Hedgehog: PHedgehog;
s: boolean;
begin
-weap:= TAmmoType(Gear^.MsgParam);
-Hedgehog:= Gear^.Hedgehog;
+s:= false;
+
+weap:= TAmmoType(HHGear^.MsgParam);
+Hedgehog:= HHGear^.Hedgehog;
if Hedgehog^.Team^.Clan^.TurnNumber <= Ammoz[weap].SkipTurns then exit; // weapon is not activated yet
-Gear^.MsgParam:= Ammoz[weap].Slot;
+HHGear^.MsgParam:= Ammoz[weap].Slot;
t:= cMaxSlotAmmoIndex;
-Gear^.Message:= Gear^.Message and not gmWeapon;
+HHGear^.Message:= HHGear^.Message and not gmWeapon;
with Hedgehog^ do
while (CurAmmoType <> weap) and (t >= 0) do
begin
- s:= ChangeAmmo(Gear);
+ s:= ChangeAmmo(HHGear);
dec(t)
end;
-if s then ApplyAmmoChanges(Gear^.Hedgehog^)
+if s then ApplyAmmoChanges(HHGear^.Hedgehog^)
end;
procedure HHSetTimer(Gear: PGear);
@@ -223,7 +225,11 @@
amSMine: FollowGear:= AddGear(hwRound(lx), hwRound(ly), gtSMine, 0, xx*Power/cPowerDivisor, yy*Power/cPowerDivisor, 0);
amDEagle: CurAmmoGear:= AddGear(hwRound(lx + xx * cHHRadius), hwRound(ly + yy * cHHRadius), gtDEagleShot, 0, xx * _0_5, yy * _0_5, 0);
amSineGun: CurAmmoGear:= AddGear(hwRound(lx + xx * cHHRadius), hwRound(ly + yy * cHHRadius), gtSineGunShot, 0, xx * _0_5, yy * _0_5, 0);
- amPortalGun: AddGear(hwRound(lx + xx * cHHRadius), hwRound(ly + yy * cHHRadius), gtPortal, 0, xx * _0_6, yy * _0_6, 0);
+ amPortalGun: begin
+ AddGear(hwRound(lx + xx * cHHRadius), hwRound(ly + yy * cHHRadius), gtPortal, 0, xx * _0_6, yy * _0_6,
+ // set selected color
+ CurWeapon^.Pos);
+ end;
amSniperRifle: begin
PlaySound(sndSniperReload);
CurAmmoGear:= AddGear(hwRound(lx + xx * cHHRadius), hwRound(ly + yy * cHHRadius), gtSniperRifleShot, 0, xx * _0_5, yy * _0_5, 0);
@@ -307,8 +313,12 @@
gtResurrector, 0, _0, _0, 0);
CurAmmoGear^.SoundChannel := LoopSound(sndResurrector);
end;
- amDrillStrike: AddGear(CurWeapon^.Pos, 0, gtAirAttack, 3, _0, _0, 0);
+ amDrillStrike: AddGear(CurWeapon^.Pos, 0, gtAirAttack, 3, _0, _0, CurWeapon^.Timer);
//amMelonStrike: AddGear(CurWeapon^.Pos, 0, gtAirAttack, 4, _0, _0, 0);
+ amStructure: begin
+ FollowGear:= AddGear(hwRound(lx) + hwSign(dX) * 7, hwRound(ly), gtStructure, 0, SignAs(_0_03, dX), _0, 0);
+ FollowGear^.Hedgehog:= Gear^.Hedgehog;
+ end;
end;
uStats.AmmoUsed(CurAmmoType);
@@ -398,7 +408,7 @@
if Gear^.Timer = 1 then
begin
Gear^.State:= Gear^.State or gstNoDamage;
- doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, EXPLAutoSound);
+ doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 30, CurrentHedgehog, EXPLAutoSound);
AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtGrave, 0, _0, _0, 0)^.Hedgehog:= Gear^.Hedgehog;
DeleteGear(Gear);
SetAllToActive
@@ -629,17 +639,17 @@
end
end;
-procedure HedgehogChAngle(Gear: PGear);
+procedure HedgehogChAngle(HHGear: PGear);
var da: LongWord;
begin
-with Gear^.Hedgehog^ do
+with HHGear^.Hedgehog^ do
if (CurAmmoType = amRope)
- and ((Gear^.State and (gstMoving or gstHHJumping)) = gstMoving) then da:= 2 else da:= 1;
+ and ((HHGear^.State and (gstMoving or gstHHJumping)) = gstMoving) then da:= 2 else da:= 1;
-if (((Gear^.Message and gmPrecise) = 0) or ((GameTicks mod 5) = 1)) then
- if ((Gear^.Message and gmUp) <> 0) and (Gear^.Angle >= CurMinAngle + da) then dec(Gear^.Angle, da)
+if (((HHGear^.Message and gmPrecise) = 0) or ((GameTicks mod 5) = 1)) then
+ if ((HHGear^.Message and gmUp) <> 0) and (HHGear^.Angle >= CurMinAngle + da) then dec(HHGear^.Angle, da)
else
- if ((Gear^.Message and gmDown) <> 0) and (Gear^.Angle + da <= CurMaxAngle) then inc(Gear^.Angle, da)
+ if ((HHGear^.Message and gmDown) <> 0) and (HHGear^.Angle + da <= CurMaxAngle) then inc(HHGear^.Angle, da)
end;
procedure doStepHedgehog(Gear: PGear); forward;
@@ -770,118 +780,118 @@
end;
-procedure doStepHedgehogDriven(Gear: PGear);
+procedure doStepHedgehogDriven(HHGear: PGear);
var t: PGear;
wasJumping: boolean;
Hedgehog: PHedgehog;
begin
-Hedgehog:= Gear^.Hedgehog;
+Hedgehog:= HHGear^.Hedgehog;
if not isInMultiShoot then
AllInactive:= false
else
- Gear^.Message:= 0;
+ HHGear^.Message:= 0;
-if (TurnTimeLeft = 0) or (Gear^.Damage > 0) then
+if (TurnTimeLeft = 0) or (HHGear^.Damage > 0) then
begin
TurnTimeLeft:= 0;
isCursorVisible:= false;
- Gear^.State:= Gear^.State and not (gstHHDriven or gstAnimation or gstAttacking);
+ HHGear^.State:= HHGear^.State and not (gstHHDriven or gstAnimation or gstAttacking);
AttackBar:= 0;
- if Gear^.Damage > 0 then
- Gear^.State:= Gear^.State and not (gstHHJumping or gstHHHJump);
+ if HHGear^.Damage > 0 then
+ HHGear^.State:= HHGear^.State and not (gstHHJumping or gstHHHJump);
exit
end;
-if (Gear^.State and gstAnimation) <> 0 then
+if (HHGear^.State and gstAnimation) <> 0 then
begin
- Gear^.Message:= 0;
- if (Gear^.Pos = Wavez[TWave(Gear^.Tag)].VoiceDelay) and (Gear^.Timer = 0) then PlaySound(Wavez[TWave(Gear^.Tag)].Voice, Hedgehog^.Team^.voicepack);
- inc(Gear^.Timer);
- if Gear^.Timer = Wavez[TWave(Gear^.Tag)].Interval then
+ HHGear^.Message:= 0;
+ if (HHGear^.Pos = Wavez[TWave(HHGear^.Tag)].VoiceDelay) and (HHGear^.Timer = 0) then PlaySound(Wavez[TWave(HHGear^.Tag)].Voice, Hedgehog^.Team^.voicepack);
+ inc(HHGear^.Timer);
+ if HHGear^.Timer = Wavez[TWave(HHGear^.Tag)].Interval then
begin
- Gear^.Timer:= 0;
- inc(Gear^.Pos);
- if Gear^.Pos = Wavez[TWave(Gear^.Tag)].FramesCount then
- Gear^.State:= Gear^.State and not gstAnimation
+ HHGear^.Timer:= 0;
+ inc(HHGear^.Pos);
+ if HHGear^.Pos = Wavez[TWave(HHGear^.Tag)].FramesCount then
+ HHGear^.State:= HHGear^.State and not gstAnimation
end;
exit
end;
-if ((Gear^.State and gstMoving) <> 0)
+if ((HHGear^.State and gstMoving) <> 0)
or (StepTicks = cHHStepTicks)
or (CurAmmoGear <> nil) then // we are moving
begin
with Hedgehog^ do
if (CurAmmoGear = nil)
- and (Gear^.dY > _0_39)
- and (CurAmmoType = amParachute) then Gear^.Message:= Gear^.Message or gmAttack;
+ and (HHGear^.dY > _0_39)
+ and (CurAmmoType = amParachute) then HHGear^.Message:= HHGear^.Message or gmAttack;
// check for case with ammo
- t:= CheckGearNear(Gear, gtCase, 36, 36);
+ t:= CheckGearNear(HHGear, gtCase, 36, 36);
if t <> nil then
- PickUp(Gear, t)
+ PickUp(HHGear, t)
end;
if (CurAmmoGear = nil) then
- if (((Gear^.Message and gmAttack) <> 0)
- or ((Gear^.State and gstAttacking) <> 0)) then
- Attack(Gear) // should be before others to avoid desync with '/put' msg and changing weapon msgs
+ if (((HHGear^.Message and gmAttack) <> 0)
+ or ((HHGear^.State and gstAttacking) <> 0)) then
+ Attack(HHGear) // should be before others to avoid desync with '/put' msg and changing weapon msgs
else
else
with Hedgehog^ do
if ((Ammoz[CurAmmoGear^.AmmoType].Ammo.Propz and ammoprop_AltAttack) <> 0)
- and ((Gear^.Message and gmLJump) <> 0)
+ and ((HHGear^.Message and gmLJump) <> 0)
and ((Ammoz[CurAmmoType].Ammo.Propz and ammoprop_AltUse) <> 0) then
begin
- Attack(Gear);
- Gear^.Message:= Gear^.Message and not gmLJump
+ Attack(HHGear);
+ HHGear^.Message:= HHGear^.Message and not gmLJump
end;
if (CurAmmoGear = nil)
or ((Ammoz[CurAmmoGear^.AmmoType].Ammo.Propz and ammoprop_AltAttack) <> 0)
or ((Ammoz[CurAmmoGear^.AmmoType].Ammo.Propz and ammoprop_NoRoundEnd) <> 0) then
begin
- if ((Gear^.Message and gmSlot) <> 0) then
- if ChangeAmmo(Gear) then ApplyAmmoChanges(Hedgehog^);
+ if ((HHGear^.Message and gmSlot) <> 0) then
+ if ChangeAmmo(HHGear) then ApplyAmmoChanges(Hedgehog^);
- if ((Gear^.Message and gmWeapon) <> 0) then HHSetWeapon(Gear);
+ if ((HHGear^.Message and gmWeapon) <> 0) then HHSetWeapon(HHGear);
- if ((Gear^.Message and gmTimer) <> 0) then HHSetTimer(Gear);
+ if ((HHGear^.Message and gmTimer) <> 0) then HHSetTimer(HHGear);
end;
if CurAmmoGear <> nil then
begin
- CurAmmoGear^.Message:= Gear^.Message;
+ CurAmmoGear^.Message:= HHGear^.Message;
exit
end;
if not isInMultiShoot then
- HedgehogChAngle(Gear);
+ HedgehogChAngle(HHGear);
-if (Gear^.State and gstMoving) <> 0 then
+if (HHGear^.State and gstMoving) <> 0 then
begin
- wasJumping:= ((Gear^.State and gstHHJumping) <> 0);
+ wasJumping:= ((HHGear^.State and gstHHJumping) <> 0);
- if ((Gear^.Message and gmHJump) <> 0) and
+ if ((HHGear^.Message and gmHJump) <> 0) and
wasJumping and
- ((Gear^.State and gstHHHJump) = 0) then
- if (not (hwAbs(Gear^.dX) > cLittle)) and (Gear^.dY < -_0_02) then
+ ((HHGear^.State and gstHHHJump) = 0) then
+ if (not (hwAbs(HHGear^.dX) > cLittle)) and (HHGear^.dY < -_0_02) then
begin
- Gear^.State:= Gear^.State or gstHHHJump;
- Gear^.dY:= -_0_25;
- if not cArtillery then Gear^.dX:= -SignAs(_0_02, Gear^.dX);
+ HHGear^.State:= HHGear^.State or gstHHHJump;
+ HHGear^.dY:= -_0_25;
+ if not cArtillery then HHGear^.dX:= -SignAs(_0_02, HHGear^.dX);
PlaySound(sndJump2, Hedgehog^.Team^.voicepack)
end;
- Gear^.Message:= Gear^.Message and not (gmLJump or gmHJump);
+ HHGear^.Message:= HHGear^.Message and not (gmLJump or gmHJump);
if (not cArtillery) and wasJumping and
- TestCollisionXwithGear(Gear, hwSign(Gear^.dX)) then SetLittle(Gear^.dX);
+ TestCollisionXwithGear(HHGear, hwSign(HHGear^.dX)) then SetLittle(HHGear^.dX);
- doStepHedgehogMoving(Gear);
+ if Hedgehog^.Gear <> nil then doStepHedgehogMoving(HHGear);
- if ((Gear^.State and (gstMoving or gstDrowning)) = 0) then
+ if ((HHGear^.State and (gstMoving or gstDrowning)) = 0) then
begin
- AddGearCI(Gear);
+ AddGearCI(HHGear);
if wasJumping then
StepTicks:= 410
else
@@ -890,10 +900,10 @@
exit
end;
- if not isInMultiShoot then
+ if not isInMultiShoot and (Hedgehog^.Gear <> nil) then
begin
if StepTicks > 0 then dec(StepTicks);
- if (StepTicks = 0) then HedgehogStep(Gear)
+ if (StepTicks = 0) then HedgehogStep(HHGear)
end
end;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/PascalExports.pas
--- a/hedgewars/PascalExports.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/PascalExports.pas Wed Feb 02 23:21:14 2011 +0100
@@ -22,7 +22,7 @@
interface
uses uTypes, uConsts, uVariables, GLunit, uKeys, uChat, uSound, uAmmos, uUtils,
- uCommands;
+ uCommands, uMobile;
{$INCLUDE "config.inc"}
@@ -38,6 +38,7 @@
versionStr^:= cVersionString;
end;
+// emulate mouse/keyboard input
procedure HW_click; cdecl; export;
begin
leftClick:= true;
@@ -190,12 +191,15 @@
GameState:= previousGameState;
end;
+// equivalent to esc+y; when closeFrontend = true the game exits after memory cleanup
procedure HW_terminate(closeFrontend: boolean); cdecl; export;
begin
- isTerminated:= true;
- if closeFrontend then alsoShutdownFrontend:= true;
+ {$IFDEF IPHONEOS}setGameRunning(false);{$ENDIF}
+ alsoShutdownFrontend:= closeFrontend;
+ ParseCommand('forcequit', true);
end;
+// cursor handling
procedure HW_setCursor(x,y: LongInt); cdecl; export;
begin
CursorPoint.X:= x;
@@ -208,9 +212,10 @@
y^:= CursorPoint.Y;
end;
+// ammo menu related functions
function HW_isAmmoMenuOpen: boolean; cdecl; export;
begin
- exit(bShowAmmoMenu);
+ exit( bShowAmmoMenu );
end;
function HW_isAmmoMenuNotAllowed: boolean; cdecl; export;
@@ -219,11 +224,6 @@
((Ammoz[CurAmmoGear^.AmmoType].Ammo.Propz and ammoprop_AltAttack) = 0)) and hideAmmoMenu)) );
end;
-function HW_isWaiting: boolean; cdecl; export;
-begin
- exit( ReadyTimeLeft > 0 );
-end;
-
function HW_isWeaponRequiringClick: boolean; cdecl; export;
begin
if (CurrentHedgehog <> nil) and (CurrentHedgehog^.Gear <> nil) and (CurrentHedgehog^.BotLevel = 0) then
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/VGSHandlers.inc
--- a/hedgewars/VGSHandlers.inc Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/VGSHandlers.inc Wed Feb 02 23:21:14 2011 +0100
@@ -24,14 +24,23 @@
with Gear^ do
begin
inc(FrameTicks, Steps);
- if FrameTicks > vobFrameTicks then
+ if not SuddenDeathDmg and (FrameTicks > vobFrameTicks) then
begin
dec(FrameTicks, vobFrameTicks);
inc(Frame);
if Frame = vobFramesCount then Frame:= 0
+ end
+ else if SuddenDeathDmg and (FrameTicks > vobSDFrameTicks) then
+ begin
+ dec(FrameTicks, vobSDFrameTicks);
+ inc(Frame);
+ if Frame = vobSDFramesCount then Frame:= 0
end;
X:= X + (cWindSpeedf * 200 + dX + tdX) * Steps;
- Y:= Y + (dY + tdY + cGravityf * vobFallSpeed) * Steps;
+ if SuddenDeathDmg then
+ Y:= Y + (dY + tdY + cGravityf * vobSDFallSpeed) * Steps
+ else
+ Y:= Y + (dY + tdY + cGravityf * vobFallSpeed) * Steps;
Angle:= Angle + dAngle * Steps;
if Angle > 360 then
Angle:= Angle - 360
@@ -663,8 +672,8 @@
else dec(tmp);
if tmp < round(dX) then tdY:= 1;
if tmp > round(dY) then tdY:= -1;
- if tmp > 255 then tmp := 255;
- if tmp < 0 then tmp := 0;
+ if tmp > 255 then tmp := 255;
+ if tmp < 0 then tmp := 0;
Gear^.Tint:= (Gear^.Tint and $FFFFFF00) or tmp
end
end
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/hwLibrary.pas
--- a/hedgewars/hwLibrary.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/hwLibrary.pas Wed Feb 02 23:21:14 2011 +0100
@@ -12,9 +12,8 @@
// these procedures/functions to the PascalImports.h file (also in the "Pascal Sources" group)
// to make these functions available in the C/C++/Objective-C source files
// (add "#include PascalImports.h" near the top of these files if it's not there yet)
-uses cmem, uVariables, PascalExports, hwengine;
+uses PascalExports, hwengine;
begin
- // avoid compiler warnings about units not being used
- isTerminated:= isTerminated;
+
end.
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/hwengine.pas
--- a/hedgewars/hwengine.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/hwengine.pas Wed Feb 02 23:21:14 2011 +0100
@@ -60,6 +60,7 @@
gsStart: begin
if HasBorder then DisableSomeWeapons;
AddClouds;
+ AddFlakes;
AssignHHCoords;
AddMiscGears;
StoreLoad;
@@ -200,9 +201,7 @@
{$ENDIF}
var p: TPathType;
s: shortstring;
-{$IFDEF DEBUGFILE}
i: LongInt;
-{$ENDIF}
begin
{$IFDEF HWLIBRARY}
cBits:= 32;
@@ -225,16 +224,16 @@
cAltDamage:= gameArgs[8] = '1';
val(gameArgs[9], rotationQt);
recordFileName:= gameArgs[10];
+ cStereoMode:= smNone;
{$ENDIF}
cLogfileBase:= 'game';
initEverything(true);
+
WriteLnToConsole('Hedgewars ' + cVersionString + ' engine (network protocol: ' + inttostr(cNetProtoVersion) + ')');
-{$IFDEF DEBUGFILE}
AddFileLog('Prefix: "' + PathPrefix +'"');
for i:= 0 to ParamCount do
AddFileLog(inttostr(i) + ': ' + ParamStr(i));
-{$ENDIF}
for p:= Succ(Low(TPathType)) to High(TPathType) do
if p <> ptMapCurrent then Pathz[p]:= PathPrefix + '/' + Pathz[p];
@@ -380,7 +379,7 @@
//uGame does not need to be freed
//uFloat does not need to be freed
uCollisions.freeModule; //stub
- uChat.freeModule; //stub
+ uChat.freeModule;
uAmmos.freeModule;
uAIMisc.freeModule; //stub
//uAIAmmoTests does not need to be freed
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/options.inc
--- a/hedgewars/options.inc Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/options.inc Wed Feb 02 23:21:14 2011 +0100
@@ -25,13 +25,12 @@
{$MODE OBJFPC}
{$MACRO ON}
-{$DEFINE GLunit:=GL,GLext}
+{$DEFINE GLunit:=GL}
{$IFDEF IPHONEOS}
{$DEFINE SDL13}
- {$DEFINE SDL_MIXER_NEWER}
- {$DEFINE SDL_IMAGE_NEWER}
{$DEFINE HWLIBRARY}
+ {$DEFINE S3D_DISABLED}
{$DEFINE GLunit:=gles11}
{$ENDIF}
@@ -41,3 +40,5 @@
{ $DEFINE TRACEAIACTIONS}
{ $DEFINE COUNTTICKS}
{$ENDIF}
+
+//also available LUA_DISABLED
\ No newline at end of file
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uAI.pas
--- a/hedgewars/uAI.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uAI.pas Wed Feb 02 23:21:14 2011 +0100
@@ -41,10 +41,10 @@
procedure FreeActionsList;
begin
-{$IFDEF DEBUGFILE}AddFileLog('FreeActionsList called');{$ENDIF}
+AddFileLog('FreeActionsList called');
if hasThread <> 0 then
begin
- {$IFDEF DEBUGFILE}AddFileLog('Waiting AI thread to finish');{$ENDIF}
+ AddFileLog('Waiting AI thread to finish');
StopThinking:= true;
repeat
SDL_Delay(10)
@@ -323,7 +323,7 @@
FillBonuses((Me^.State and gstAttacked) <> 0);
for a:= Low(TAmmoType) to High(TAmmoType) do
CanUseAmmo[a]:= Assigned(AmmoTests[a].proc) and HHHasAmmo(Me^.Hedgehog^, a);
-{$IFDEF DEBUGFILE}AddFileLog('Enter Think Thread');{$ENDIF}
+AddFileLog('Enter Think Thread');
BeginThread(@Think, Me, ThinkThread)
end;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uAIAmmoTests.pas
--- a/hedgewars/uAIAmmoTests.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uAIAmmoTests.pas Wed Feb 02 23:21:14 2011 +0100
@@ -103,8 +103,10 @@
(proc: @TestGrenade; flags: 0), // amSMine
(proc: @TestFirePunch; flags: 0), // amHammer
(proc: nil; flags: 0), // amResurrector
- (proc: nil; flags: 0),// amDrillStrike
- (proc: @TestSnowball; flags: 0) // amSnowball
+ (proc: nil; flags: 0), // amDrillStrike
+ (proc: @TestSnowball; flags: 0), // amSnowball
+ (proc: nil; flags: 0), // amTardis
+ (proc: nil; flags: 0) // amStructure
);
const BadTurn = Low(LongInt) div 4;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uAmmos.pas
--- a/hedgewars/uAmmos.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uAmmos.pas Wed Feb 02 23:21:14 2011 +0100
@@ -94,7 +94,6 @@
Ammoz[a].Probability:= probability[byte(ammoProbability[ord(a)]) - byte('0')];
Ammoz[a].SkipTurns:= (byte(ammoDelay[ord(a)]) - byte('0'));
Ammoz[a].NumberInCase:= (byte(ammoReinforcement[ord(a)]) - byte('0'));
- if (TrainingFlags and tfIgnoreDelays) <> 0 then Ammoz[a].SkipTurns:= 0;
cnt:= byte(ammoLoadout[ord(a)]) - byte('0');
// avoid things we already have infinite number
if cnt = 9 then
@@ -320,15 +319,12 @@
with CurWeapon^ do
begin
- if AmmoType <> amNothing then
- begin
- s:= trammo[Ammoz[AmmoType].NameId];
- if (Count <> AMMO_INFINITE) and not (Hedgehog.Team^.ExtDriven or (Hedgehog.BotLevel > 0)) then
- s:= s + ' (' + IntToStr(Count) + ')';
- if (Propz and ammoprop_Timerable) <> 0 then
- s:= s + ', ' + IntToStr(Timer div 1000) + ' ' + trammo[sidSeconds];
- AddCaption(s, Team^.Clan^.Color, capgrpAmmoinfo);
- end;
+ s:= trammo[Ammoz[AmmoType].NameId];
+ if (Count <> AMMO_INFINITE) and not (Hedgehog.Team^.ExtDriven or (Hedgehog.BotLevel > 0)) then
+ s:= s + ' (' + IntToStr(Count) + ')';
+ if (Propz and ammoprop_Timerable) <> 0 then
+ s:= s + ', ' + IntToStr(Timer div 1000) + ' ' + trammo[sidSeconds];
+ AddCaption(s, Team^.Clan^.Color, capgrpAmmoinfo);
if (Propz and ammoprop_NeedTarget) <> 0
then begin
Gear^.State:= Gear^.State or gstHHChooseTarget;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uCaptions.pas
--- a/hedgewars/uCaptions.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uCaptions.pas Wed Feb 02 23:21:14 2011 +0100
@@ -10,7 +10,7 @@
procedure freeModule;
implementation
-uses uTextures, uRenderUtils, uVariables, uRender, uConsts;
+uses uTextures, uRenderUtils, uVariables, uRender;
type TCaptionStr = record
Tex: PTexture;
@@ -39,14 +39,11 @@
grp: TCapGroup;
offset: LongInt;
begin
- {$IFDEF IPHONEOS}
+{$IFDEF IPHONEOS}
offset:= 40;
- {$ELSE}
- if ((TrainingFlags and tfTimeTrial) <> 0) and (TimeTrialStartTime > 0) then
- offset:= 48
- else
- offset:= 8;
- {$ENDIF}
+{$ELSE}
+ offset:= 8;
+{$ENDIF}
for grp:= Low(TCapGroup) to High(TCapGroup) do
with Captions[grp] do
@@ -69,7 +66,13 @@
end;
procedure freeModule;
+var
+ group: TCapGroup;
begin
+ for group:= Low(TCapGroup) to High(TCapGroup) do
+ begin
+ FreeTexture(Captions[group].Tex);
+ end;
end;
end.
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uChat.pas
--- a/hedgewars/uChat.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uChat.pas Wed Feb 02 23:21:14 2011 +0100
@@ -29,10 +29,6 @@
procedure DrawChat;
procedure KeyPressChat(Key: Longword);
-var UserNick: shortstring = '';
- ChatReady: boolean;
- showAll: boolean;
-
implementation
uses SDLh, uKeys, uTypes, uVariables, uCommands, uUtils, uTextures, uRender, uIO;
@@ -52,6 +48,8 @@
visibleCount: LongWord;
InputStr: TChatLine;
InputStrL: array[0..260] of char; // for full str + 4-byte utf-8 char
+ ChatReady: boolean;
+ showAll: boolean;
const colors: array[#1..#5] of TSDL_Color = (
(r:$FF; g:$FF; b:$FF; unused:$FF), // chat message [White]
@@ -372,8 +370,13 @@
end;
procedure freeModule;
+var i: ShortInt;
begin
- UserNick:= '';
+ FreeTexture(InputStr.Tex);
+ for i:= 0 to MaxStrIndex do
+ begin
+ FreeTexture(Strs[i].Tex);
+ end;
end;
end.
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uCollisions.pas
--- a/hedgewars/uCollisions.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uCollisions.pas Wed Feb 02 23:21:14 2011 +0100
@@ -44,6 +44,7 @@
function TestCollisionXKick(Gear: PGear; Dir: LongInt): boolean;
function TestCollisionYKick(Gear: PGear; Dir: LongInt): boolean;
+function TestCollisionX(Gear: PGear; Dir: LongInt): boolean;
function TestCollisionY(Gear: PGear; Dir: LongInt): boolean;
function TestCollisionXwithXYShift(Gear: PGear; ShiftX: hwFloat; ShiftY: LongInt; Dir: LongInt): boolean;
@@ -289,6 +290,24 @@
Gear^.X:= Gear^.X - ShiftX;
Gear^.Y:= Gear^.Y - int2hwFloat(ShiftY)
end;
+function TestCollisionX(Gear: PGear; Dir: LongInt): boolean;
+var x, y, i: LongInt;
+begin
+x:= hwRound(Gear^.X);
+if Dir < 0 then x:= x - Gear^.Radius
+ else x:= x + Gear^.Radius;
+if (x and LAND_WIDTH_MASK) = 0 then
+ begin
+ y:= hwRound(Gear^.Y) - Gear^.Radius + 1;
+ i:= y + Gear^.Radius * 2 - 2;
+ repeat
+ if (y and LAND_HEIGHT_MASK) = 0 then
+ if Land[y, x] > 255 then exit(true);
+ inc(y)
+ until (y > i);
+ end;
+TestCollisionX:= false
+end;
function TestCollisionY(Gear: PGear; Dir: LongInt): boolean;
var x, y, i: LongInt;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uCommandHandlers.pas
--- a/hedgewars/uCommandHandlers.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uCommandHandlers.pas Wed Feb 02 23:21:14 2011 +0100
@@ -306,7 +306,7 @@
bShowFinger:= false;
with CurrentHedgehog^.Gear^ do
begin
- {$IFDEF DEBUGFILE}AddFileLog('/+attack: hedgehog''s Gear^.State = '+inttostr(State));{$ENDIF}
+ AddFileLog('/+attack: hedgehog''s Gear^.State = '+inttostr(State));
if ((State and gstHHDriven) <> 0) then
begin
FollowGear:= CurrentHedgehog^.Gear;
@@ -347,9 +347,7 @@
TryDo(AllInactive, '/nextturn called when not all gears are inactive', true);
if not CurrentTeam^.ExtDriven then SendIPC('N');
-{$IFDEF DEBUGFILE}
AddFileLog('Doing SwitchHedgehog: time '+inttostr(GameTicks));
-{$ENDIF}
end;
procedure chTimer(var s: shortstring);
@@ -589,7 +587,6 @@
RegisterVariable('minesnum', vtLongInt, @cLandMines , false);
RegisterVariable('explosives',vtLongInt,@cExplosives , false);
RegisterVariable('gmflags' , vtLongInt, @GameFlags , false);
- RegisterVariable('trflags' , vtLongInt, @TrainingFlags , false);
RegisterVariable('turntime', vtLongInt, @cHedgehogTurnTime, false);
RegisterVariable('minestime',vtLongInt, @cMinesTime , false);
RegisterVariable('fort' , vtCommand, @chFort , false);
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uCommands.pas
--- a/hedgewars/uCommands.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uCommands.pas Wed Feb 02 23:21:14 2011 +0100
@@ -60,7 +60,7 @@
if c in ['/', '$'] then Delete(CmdStr, 1, 1) else c:= '/';
s:= '';
SplitBySpace(CmdStr, s);
-{$IFDEF DEBUGFILE}AddFileLog('[Cmd] ' + c + CmdStr + ' (' + inttostr(length(s)) + ')');{$ENDIF}
+AddFileLog('[Cmd] ' + c + CmdStr + ' (' + inttostr(length(s)) + ')');
t:= Variables;
while t <> nil do
begin
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uConsole.pas
--- a/hedgewars/uConsole.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uConsole.pas Wed Feb 02 23:21:14 2011 +0100
@@ -52,7 +52,7 @@
done: boolean;
begin
{$IFNDEF NOCONSOLE}
-{$IFDEF DEBUGFILE}AddFileLog('[Con] ' + s);{$ENDIF}
+AddFileLog('[Con] ' + s);
Write(s);
done:= false;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uConsts.pas
--- a/hedgewars/uConsts.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uConsts.pas Wed Feb 02 23:21:14 2011 +0100
@@ -23,15 +23,11 @@
uses SDLh, uFloat, GLunit;
-
{$INCLUDE "config.inc"}
-// typed const is a variable despite const qualifier
-// in freepascal you may actually use var for the same purpose
-
const
sfMax = 1000;
- cDefaultParamNum = 16;
+ cDefaultParamNum = 17;
// message constants
errmsgCreateSurface = 'Error creating SDL surface';
@@ -69,7 +65,7 @@
rqNoBackground= $00000004; // don't draw background
rqSimpleRope = $00000008; // draw rope using lines only
rq2DWater = $00000010; // disable 3D water effect
- rqFancyBoom = $00000020; // no fancy explosion effects
+ rqAntiBoom = $00000020; // no fancy explosion effects
rqKillFlakes = $00000040; // no flakes
rqSlowMenu = $00000080; // ammomenu appears with no animation
rqPlainSplash = $00000100; // no droplets
@@ -116,6 +112,7 @@
cCursorEdgesDist : LongInt = 100;
cTeamHealthWidth : LongInt = 128;
cWaterOpacity : byte = $80;
+ cSDWaterOpacity : byte = $80;
cifRandomize = $00000001;
cifTheme = $00000002;
@@ -162,14 +159,6 @@
cSendEmptyPacketTime = 1000;
trigTurns = $80000001;
- // Training Flags
- tfNone = $00000000;
- tfTimeTrial = $00000001;
- tfRCPlane = $00000002;
- tfSpawnTargets = $00000004;
- tfIgnoreDelays = $00000008;
- tfTargetRespawn = $00000010;
-
gfAny = $FFFFFFFF;
gfOneClanMode = $00000001; // used in trainings
gfMultiWeapon = $00000002; // used in trainings
@@ -194,7 +183,7 @@
gfInfAttack = $00100000;
gfResetWeps = $00200000;
gfPerHogAmmo = $00400000;
- gfDisableWind = $00800000; // only lua for now
+ gfDisableWind = $00800000;
gfMoreWind = $01000000;
// NOTE: When adding new game flags, ask yourself
// if a "game start notice" would be useful. If so,
@@ -252,7 +241,7 @@
ammoprop_NotBorder = $00000800;
ammoprop_Utility = $00001000;
ammoprop_Effect = $00002000;
- ammoprop_NoRoundEnd=$10000000;
+ ammoprop_NoRoundEnd = $10000000;
AMMO_INFINITE = 100;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uDebug.pas
--- a/hedgewars/uDebug.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uDebug.pas Wed Feb 02 23:21:14 2011 +0100
@@ -32,4 +32,4 @@
if not Assert then OutError(SDL_GetError, isFatal)
end;
-end.
\ No newline at end of file
+end.
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uFloat.pas
--- a/hedgewars/uFloat.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uFloat.pas Wed Feb 02 23:21:14 2011 +0100
@@ -352,9 +352,7 @@
function AngleSin(const Angle: Longword): hwFloat;
begin
-{$IFDEF DEBUGFILE}
//TryDo((Angle >= 0) and (Angle <= 2048), 'Sin param exceeds limits', true);
-{$ENDIF}
AngleSin.isNegative:= false;
if Angle < 1024 then AngleSin.QWordValue:= SinTable[Angle]
else AngleSin.QWordValue:= SinTable[2048 - Angle]
@@ -362,9 +360,7 @@
function AngleCos(const Angle: Longword): hwFloat;
begin
-{$IFDEF DEBUGFILE}
//TryDo((Angle >= 0) and (Angle <= 2048), 'Cos param exceeds limits', true);
-{$ENDIF}
AngleCos.isNegative:= Angle > 1024;
if Angle < 1024 then AngleCos.QWordValue:= SinTable[1024 - Angle]
else AngleCos.QWordValue:= SinTable[Angle - 1024]
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uGears.pas
--- a/hedgewars/uGears.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uGears.pas Wed Feb 02 23:21:14 2011 +0100
@@ -29,7 +29,7 @@
procedure ResurrectHedgehog(gear: PGear);
procedure ProcessGears;
procedure EndTurnCleanup;
-procedure ApplyDamage(Gear: PGear; Damage: Longword; Source: TDamageSource);
+procedure ApplyDamage(Gear: PGear; AttackerHog: PHedgehog; Damage: Longword; Source: TDamageSource);
procedure SetAllToActive;
procedure SetAllHHToActive;
procedure DrawGears;
@@ -50,8 +50,7 @@
uCommands, uUtils, uTextures, uRenderUtils, uGearsRender, uCaptions, uDebug, uLandTexture;
-procedure doMakeExplosion(X, Y, Radius: LongInt; Mask: LongWord); forward;
-procedure doMakeExplosion(X, Y, Radius: LongInt; Mask, Tint: LongWord); forward;
+procedure doMakeExplosion(X, Y, Radius: LongInt; AttackingHog: PHedgehog; Mask: Longword; const Tint: LongWord = $FFFFFFFF); forward;
procedure AmmoShove(Ammo: PGear; Damage, Power: LongInt); forward;
//procedure AmmoFlameWork(Ammo: PGear); forward;
function GearsNear(X, Y: hwFloat; Kind: TGearType; r: LongInt): TPGearArray; forward;
@@ -60,10 +59,10 @@
procedure AfterAttack; forward;
procedure HedgehogStep(Gear: PGear); forward;
procedure doStepHedgehogMoving(Gear: PGear); forward;
-procedure HedgehogChAngle(Gear: PGear); forward;
+procedure HedgehogChAngle(HHGear: PGear); forward;
procedure ShotgunShot(Gear: PGear); forward;
procedure PickUp(HH, Gear: PGear); forward;
-procedure HHSetWeapon(Gear: PGear); forward;
+procedure HHSetWeapon(HHGear: PGear); forward;
procedure doStepCase(Gear: PGear); forward;
{$INCLUDE "GSHandlers.inc"}
@@ -129,7 +128,8 @@
@doStepResurrector,
@doStepNapalmBomb,
@doStepSnowball,
- @doStepSnowflake
+ @doStepSnowflake,
+ @doStepStructure
);
procedure InsertGearToList(Gear: PGear);
@@ -182,9 +182,7 @@
var gear: PGear;
begin
inc(Counter);
-{$IFDEF DEBUGFILE}
AddFileLog('AddGear: #' + inttostr(Counter) + ' (' + inttostr(x) + ',' + inttostr(y) + '), d(' + floattostr(dX) + ',' + floattostr(dY) + ') type = ' + EnumToStr(Kind));
-{$ENDIF}
New(gear);
FillChar(gear^, sizeof(TGear), 0);
@@ -205,7 +203,7 @@
gear^.ImpactSound:= sndNone;
gear^.nImpactSounds:= 0;
-if CurrentTeam <> nil then
+if CurrentHedgehog <> nil then
begin
gear^.Hedgehog:= CurrentHedgehog;
gear^.IntersectGear:= CurrentHedgehog^.Gear
@@ -428,7 +426,9 @@
gear^.Timer:= 5000
end;
gtDrill: begin
- gear^.Timer:= 5000;
+ if gear^.Timer = 0 then gear^.Timer:= 5000;
+ // Tag for drill strike. if 1 then first impact occured already
+ gear^.Tag := 0;
gear^.Radius:= 4;
gear^.Density:= _1;
end;
@@ -477,7 +477,8 @@
gear^.nImpactSounds:= 1;
gear^.AdvBounce:= 0;
gear^.Radius:= 16;
- gear^.Tag:= 0;
+ // set color
+ gear^.Tag:= 2 * gear^.Timer;
gear^.Timer:= 15000;
gear^.RenderTimer:= false;
gear^.Health:= 100;
@@ -512,6 +513,13 @@
gear^.Radius:= 5;
gear^.Density:= _1_5;
end;
+ gtStructure: begin
+ gear^.ImpactSound:= sndGrenadeImpact;
+ gear^.nImpactSounds:= 1;
+ gear^.Radius:= 13;
+ gear^.Elasticity:= _0_3;
+ gear^.Health:= 50;
+ end;
end;
InsertGearToList(gear);
@@ -556,9 +564,12 @@
begin
t:= max(Gear^.Damage, Gear^.Health);
Gear^.Damage:= t;
- if (cWaterOpacity < $FF) and (hwRound(Gear^.Y) < cWaterLine + 256) then
+ if ((not SuddenDeathDmg and (cWaterOpacity < $FF)) or (SuddenDeathDmg and (cWaterOpacity < $FF))) and (hwRound(Gear^.Y) < cWaterLine + 256) then
spawnHealthTagForHH(Gear, t);
- uStats.HedgehogDamaged(Gear)
+
+ // should be not CurrentHedgehog, but hedgehog of the last gear which caused damage to this hog
+ // same stand for CheckHHDamage
+ uStats.HedgehogDamaged(Gear, CurrentHedgehog)
end;
team:= Gear^.Hedgehog^.Team;
@@ -589,12 +600,12 @@
Team^.AIKillsTex := RenderStringTex(inttostr(Team^.stats.AIKills), Team^.Clan^.Color, fnt16);
end
end;
-{$IFDEF DEBUGFILE}
-with Gear^ do AddFileLog('Delete: #' + inttostr(uid) + ' (' + inttostr(hwRound(x)) + ',' + inttostr(hwRound(y)) + '), d(' + floattostr(dX) + ',' + floattostr(dY) + ') type = ' + EnumToStr(Kind));
-{$ENDIF}
+with Gear^ do
+ AddFileLog('Delete: #' + inttostr(uid) + ' (' + inttostr(hwRound(x)) + ',' + inttostr(hwRound(y)) + '), d(' + floattostr(dX) + ',' + floattostr(dY) + ') type = ' + EnumToStr(Kind));
if CurAmmoGear = Gear then CurAmmoGear:= nil;
if FollowGear = Gear then FollowGear:= nil;
+if lastGearByUID = Gear then lastGearByUID := nil;
RemoveGearFromList(Gear);
Dispose(Gear)
end;
@@ -614,7 +625,7 @@
(not Gear^.Invulnerable) then
begin
CheckNoDamage:= false;
- uStats.HedgehogDamaged(Gear);
+
dmg:= Gear^.Damage;
if Gear^.Health < dmg then
begin
@@ -791,11 +802,20 @@
stHealth: begin
if (cWaterRise <> 0) or (cHealthDecrease <> 0) then
begin
- if (TotalRounds = cSuddenDTurns) and not SuddenDeathDmg and not isInMultiShoot then
+ if (TotalRounds = cSuddenDTurns) and not SuddenDeath and not isInMultiShoot then
begin
- SuddenDeathDmg:= true;
+ SuddenDeath:= true;
+ if cHealthDecrease <> 0 then
+ begin
+ SuddenDeathDmg:= true;
+ ChangeToSDClouds;
+ ChangeToSDFlakes;
+ glClearColor(SDSkyColor.r / 255, SDSkyColor.g / 255, SDSkyColor.b / 255, 0.99);
+ end;
AddCaption(trmsg[sidSuddenDeath], cWhiteColor, capgrpGameState);
- playSound(sndSuddenDeath)
+ playSound(sndSuddenDeath);
+ MusicFN:= SDMusic;
+ ChangeMusic
end
else if (TotalRounds < cSuddenDTurns) and not isInMultiShoot then
begin
@@ -976,13 +996,16 @@
RecountTeamHealth(TeamsArray[i])
end;
-procedure ApplyDamage(Gear: PGear; Damage: Longword; Source: TDamageSource);
+procedure ApplyDamage(Gear: PGear; AttackerHog: PHedgehog; Damage: Longword; Source: TDamageSource);
var s: shortstring;
vampDmg, tmpDmg, i: Longword;
vg: PVisualGear;
begin
- if (Gear^.Kind = gtHedgehog) and (Damage>=1) then
+ if Damage = 0 then exit; // nothing to apply
+
+ if (Gear^.Kind = gtHedgehog) then
begin
+ uStats.HedgehogDamaged(Gear, AttackerHog);
HHHurt(Gear^.Hedgehog, Source);
AddDamageTag(hwRound(Gear^.X), hwRound(Gear^.Y), Damage, Gear^.Hedgehog^.Team^.Clan^.Color);
tmpDmg:= min(Damage, max(0,Gear^.Health-Gear^.Damage));
@@ -1018,7 +1041,11 @@
spawnHealthTagForHH(CurrentHedgehog^.Gear, tmpDmg);
end;
end;
- end;
+ end else if Gear^.Kind <> gtStructure then // not gtHedgehog nor gtStructure
+ begin
+ AddFileLog('Assigning hedgehog ' + inttostr(LongInt(AttackerHog)) + ' to gear ' + inttostr(Gear^.uid));
+ Gear^.Hedgehog:= AttackerHog;
+ end;
inc(Gear^.Damage, Damage);
ScriptCall('onGearDamage', Gear^.UID, Damage);
end;
@@ -1042,7 +1069,7 @@
t:= GearsList;
while t <> nil do
begin
- if t^.Kind = gtHedgehog then t^.Active:= true;
+ if (t^.Kind = gtHedgehog) or (t^.Kind = gtExplosives) then t^.Active:= true;
t:= t^.NextGear
end
end;
@@ -1081,21 +1108,22 @@
begin
AddGear(0, 0, gtATStartGame, 0, _0, _0, 2000);
-if (TrainingFlags and tfSpawnTargets) <> 0 then
- begin
- TrainingTargetGear:= AddGear(0, 0, gtTarget, 0, _0, _0, 0);
- FindPlace(TrainingTargetGear, false, 0, LAND_WIDTH);
- end;
-
-for i:= 0 to Pred(cLandMines) do
+i:= 0;
+Gear:= PGear(1);
+while (i < cLandMines) {and (Gear <> nil)} do // disable this check until better solution found
begin
Gear:= AddGear(0, 0, gtMine, 0, _0, _0, 0);
FindPlace(Gear, false, 0, LAND_WIDTH);
+ inc(i)
end;
-for i:= 0 to Pred(cExplosives) do
+
+i:= 0;
+Gear:= PGear(1);
+while (i < cExplosives){ and (Gear <> nil)} do
begin
Gear:= AddGear(0, 0, gtExplosives, 0, _0, _0, 0);
FindPlace(Gear, false, 0, LAND_WIDTH);
+ inc(i)
end;
if (GameFlags and gfLowGravity) <> 0 then
@@ -1121,20 +1149,15 @@
if (GameFlags and gfArtillery) <> 0 then
cArtillery:= true;
-if not hasBorder and ((Theme = 'Snow') or (Theme = 'Christmas')) then
+if not hasBorder and ((Theme = 'Snow') or (Theme = 'Christmas')) and ((cReducedQuality and rqLowRes) = 0) then
begin
for i:= 0 to Pred(vobCount*2) do
- AddGear(GetRandom(LAND_WIDTH+1024)-512, LAND_HEIGHT - GetRandom(1024), gtFlake, 0, _0, _0, 0);
+ AddGear(GetRandom(LAND_WIDTH+1024)-512, LAND_HEIGHT - GetRandom(LAND_HEIGHT div 2), gtFlake, 0, _0, _0, 0);
disableLandBack:= true
end
end;
-procedure doMakeExplosion(X, Y, Radius: LongInt; Mask: LongWord);
-begin
-doMakeExplosion(X, Y, Radius, Mask, $FFFFFFFF);
-end;
-
-procedure doMakeExplosion(X, Y, Radius: LongInt; Mask, Tint: LongWord);
+procedure doMakeExplosion(X, Y, Radius: LongInt; AttackingHog: PHedgehog; Mask: Longword; const Tint: LongWord);
var Gear: PGear;
dmg, dmgRadius, dmgBase: LongInt;
fX, fY: hwFloat;
@@ -1142,7 +1165,7 @@
i, cnt: LongInt;
begin
TargetPoint.X:= NoPointX;
-{$IFDEF DEBUGFILE}if Radius > 4 then AddFileLog('Explosion: at (' + inttostr(x) + ',' + inttostr(y) + ')');{$ENDIF}
+if Radius > 4 then AddFileLog('Explosion: at (' + inttostr(x) + ',' + inttostr(y) + ')');
if Radius > 25 then KickFlakes(Radius, X, Y);
if ((Mask and EXPLNoGfx) = 0) then
@@ -1177,18 +1200,19 @@
gtCase,
gtTarget,
gtFlame,
- gtExplosives: begin
+ gtExplosives,
+ gtStructure: begin
// Run the calcs only once we know we have a type that will need damage
if hwRound(hwAbs(Gear^.X-fX)+hwAbs(Gear^.Y-fY)) < dmgBase then
dmg:= dmgBase - hwRound(Distance(Gear^.X - fX, Gear^.Y - fY));
if dmg > 1 then
begin
dmg:= ModifyDamage(min(dmg div 2, Radius), Gear);
- //{$IFDEF DEBUGFILE}AddFileLog('Damage: ' + inttostr(dmg));{$ENDIF}
+ //AddFileLog('Damage: ' + inttostr(dmg));
if (Mask and EXPLNoDamage) = 0 then
begin
if not Gear^.Invulnerable then
- ApplyDamage(Gear, dmg, dsExplosion)
+ ApplyDamage(Gear, AttackingHog, dmg, dsExplosion)
else
Gear^.State:= Gear^.State or gstWinner;
end;
@@ -1252,9 +1276,10 @@
gtSMine,
gtCase,
gtTarget,
- gtExplosives: begin
+ gtExplosives,
+ gtStructure: begin
if (not t^.Invulnerable) then
- ApplyDamage(t, dmg, dsBullet)
+ ApplyDamage(t, Gear^.Hedgehog, dmg, dsBullet)
else
Gear^.State:= Gear^.State or gstWinner;
@@ -1301,13 +1326,13 @@
tmpDmg:= ModifyDamage(Damage, Gear);
if (Gear^.State and gstNoDamage) = 0 then
begin
-
+
if (Ammo^.Kind = gtDEagleShot) or (Ammo^.Kind = gtSniperRifleShot) then
begin
VGear := AddVisualGear(hwround(Ammo^.X), hwround(Ammo^.Y), vgtBulletHit);
if VGear <> nil then VGear^.Angle := DxDy2Angle(-Ammo^.dX, Ammo^.dY);
end;
-
+
if (Gear^.Kind = gtHedgehog) and (Ammo^.State and gsttmpFlag <> 0) and (Ammo^.Kind = gtShover) then Gear^.FlightTime:= 1;
case Gear^.Kind of
@@ -1316,13 +1341,14 @@
gtSMine,
gtTarget,
gtCase,
- gtExplosives: begin
+ gtExplosives,
+ gtStructure: begin
if (Ammo^.Kind = gtDrill) then begin Ammo^.Timer:= 0; exit; end;
if (not Gear^.Invulnerable) then
- ApplyDamage(Gear, tmpDmg, dsShove)
+ ApplyDamage(Gear, Ammo^.Hedgehog, tmpDmg, dsShove)
else
Gear^.State:= Gear^.State or gstWinner;
- if (Gear^.Kind = gtExplosives) and (Ammo^.Kind = gtBlowtorch) then ApplyDamage(Gear, tmpDmg * 100, dsUnknown); // crank up damage for explosives + blowtorch
+ if (Gear^.Kind = gtExplosives) and (Ammo^.Kind = gtBlowtorch) then ApplyDamage(Gear, Ammo^.Hedgehog, tmpDmg * 100, dsUnknown); // crank up damage for explosives + blowtorch
DeleteCI(Gear);
if (Gear^.Kind = gtHedgehog) and Gear^.Hedgehog^.King then
@@ -1424,12 +1450,13 @@
var
t: PGear;
begin
+ r:= r*r;
GearsNear := nil;
t := GearsList;
while t <> nil do begin
if (t^.Kind = Kind) then begin
if (X - t^.X)*(X - t^.X) + (Y - t^.Y)*(Y-t^.Y) <
- int2hwFloat(r)*int2hwFloat(r) then
+ int2hwFloat(r) then
begin
SetLength(GearsNear, Length(GearsNear)+1);
GearsNear[High(GearsNear)] := t;
@@ -1513,7 +1540,6 @@
gear^.dX := _0;
gear^.dY := _0;
gear^.State := gstWait;
- uStats.HedgehogDamaged(gear);
gear^.Damage := 0;
gear^.Health := gear^.Hedgehog^.InitialHealth;
gear^.Hedgehog^.Effects[hePoisoned] := false;
@@ -1744,9 +1770,7 @@
begin
Gear^.X:= int2hwFloat(x);
Gear^.Y:= int2hwFloat(y);
- {$IFDEF DEBUGFILE}
AddFileLog('Assigned Gear coordinates (' + inttostr(x) + ',' + inttostr(y) + ')');
- {$ENDIF}
end
else
begin
@@ -1776,13 +1800,20 @@
var gear: PGear;
begin
GearByUID:= nil;
+if uid = 0 then exit;
+if (lastGearByUID <> nil) and (lastGearByUID^.uid = uid) then
+ begin
+ GearByUID:= lastGearByUID;
+ exit
+ end;
gear:= GearsList;
while gear <> nil do
begin
if gear^.uid = uid then
begin
- GearByUID:= gear;
- exit
+ lastGearByUID:= gear;
+ GearByUID:= gear;
+ exit
end;
gear:= gear^.NextGear
end
@@ -1830,7 +1861,7 @@
if (x < 4) and (TeamsArray[t] <> nil) then
begin
// if team matches current hedgehog team, default to current hedgehog
- if (i = 0) and (CurrentHedgehog^.Team = TeamsArray[t]) then hh:= CurrentHedgehog
+ if (i = 0) and (CurrentHedgehog <> nil) and (CurrentHedgehog^.Team = TeamsArray[t]) then hh:= CurrentHedgehog
else
begin
// otherwise use the first living hog or the hog amongs the remaining ones indicated by i
@@ -1847,12 +1878,15 @@
inc(j)
end
end;
- if hh <> nil then Gear:= AddVisualGear(0, 0, vgtSpeechBubble);
- if Gear <> nil then
+ if hh <> nil then
begin
- Gear^.Hedgehog:= hh;
- Gear^.Text:= text;
- Gear^.FrameTicks:= x
+ Gear:= AddVisualGear(0, 0, vgtSpeechBubble);
+ if Gear <> nil then
+ begin
+ Gear^.Hedgehog:= hh;
+ Gear^.Text:= text;
+ Gear^.FrameTicks:= x
+ end
end
//else ParseCommand('say ' + text, true)
end
@@ -1871,9 +1905,9 @@
CurAmmoGear:= nil;
GearsList:= nil;
KilledHHs:= 0;
+ SuddenDeath:= false;
SuddenDeathDmg:= false;
SpeechType:= 1;
- TrainingTargetGear:= nil;
skipFlag:= false;
AllInactive:= false;
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uGearsRender.pas
--- a/hedgewars/uGearsRender.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uGearsRender.pas Wed Feb 02 23:21:14 2011 +0100
@@ -186,7 +186,7 @@
if (Gear^.State and gstHHDeath) <> 0 then
begin
DrawSprite(sprHHDeath, ox - 16, oy - 26, Gear^.Pos);
- Tint(HH^.Team^.Clan^.Color);
+ Tint(HH^.Team^.Clan^.Color shl 8 or $FF);
DrawSprite(sprHHDeath, ox - 16, oy - 26, Gear^.Pos + 8);
Tint($FF, $FF, $FF, $FF);
exit
@@ -353,7 +353,7 @@
i*DxDy2Angle(CurAmmoGear^.dY, CurAmmoGear^.dX) + hAngle);
if HatTex^.w > 64 then
begin
- Tint(HH^.Team^.Clan^.Color);
+ Tint(HH^.Team^.Clan^.Color shl 8 or $FF);
DrawRotatedTextureF(HatTex, 1.0, -1.0, -6.0, ox, oy, 32, i, 32, 32,
i*DxDy2Angle(CurAmmoGear^.dY, CurAmmoGear^.dX) + hAngle);
Tint($FF, $FF, $FF, $FF)
@@ -383,7 +383,7 @@
32);
if HatTex^.w > 64 then
begin
- Tint(HH^.Team^.Clan^.Color);
+ Tint(HH^.Team^.Clan^.Color shl 8 or $FF);
DrawTextureF(HatTex,
1,
sx,
@@ -555,7 +555,7 @@
amPortalGun: if (CurWeapon^.Timer and 2) <> 0 then // Add a new Hedgehog value instead of abusing timer?
DrawRotatedF(sprPortalGun, hx, hy, 0, sign, aangle)
else
- DrawRotatedF(sprPortalGun, hx, hy, 1+(CurWeapon^.Timer and 1), sign, aangle);
+ DrawRotatedF(sprPortalGun, hx, hy, 1+CurWeapon^.Pos, sign, aangle);
amSniperRifle: DrawRotatedF(sprSniperRifle, hx, hy, 0, sign, aangle);
amBlowTorch: DrawRotated(sprHandBlowTorch, hx, hy, sign, aangle);
amCake: DrawRotated(sprHandCake, hx, hy, sign, aangle);
@@ -705,7 +705,7 @@
32);
if HatTex^.w > 64 then
begin
- Tint(HH^.Team^.Clan^.Color);
+ Tint(HH^.Team^.Clan^.Color shl 8 or $FF);
DrawTextureF(HatTex,
HatVisibility,
sx,
@@ -729,7 +729,7 @@
32);
if HatTex^.w > 64 then
begin
- Tint(HH^.Team^.Clan^.Color);
+ Tint(HH^.Team^.Clan^.Color shl 8 or $FF);
DrawTextureF(HatTex,
HatVisibility,
sx,
@@ -855,8 +855,6 @@
DrawRotated(sprPlane, x, y, -1, DxDy2Angle(Gear^.dX, Gear^.dY) + 90)
else
DrawRotated(sprPlane, x, y,0,DxDy2Angle(Gear^.dY, Gear^.dX));
- if ((TrainingFlags and tfRCPlane) <> 0) and (TrainingTargetGear <> nil) and ((Gear^.State and gstDrowning) = 0) then
- DrawRotatedf(sprFinger, x, y, GameTicks div 32 mod 16, 0, DxDy2Angle(Gear^.X - TrainingTargetGear^.X, TrainingTargetGear^.Y - Gear^.Y));
end;
gtBall: DrawRotatedf(sprBalls, x, y, Gear^.Tag,0, Gear^.DirAngle);
@@ -1026,6 +1024,7 @@
//DrawRotatedF(sprFlake, x-SpritesData[sprFlake].Width div 2, y-SpritesData[sprFlake].Height div 2, Gear^.Timer, 1, Gear^.DirAngle);
DrawRotatedF(sprFlake, x, y, Gear^.Timer, 1, Gear^.DirAngle)
end;
+ gtStructure: DrawSprite(sprTarget, x - 16, y - 16, 0);
end;
if Gear^.RenderTimer and (Gear^.Tex <> nil) then DrawCentered(x + 8, y + 8, Gear^.Tex);
diff -r 663aa9552bfc -r 9dcb2e83b24f hedgewars/uIO.pas
--- a/hedgewars/uIO.pas Wed Feb 02 09:23:42 2011 +0100
+++ b/hedgewars/uIO.pas Wed Feb 02 23:21:14 2011 +0100
@@ -22,9 +22,6 @@
interface
uses SDLh, uTypes;
-var ipcPort: Word = 0;
- hiTicks: Word;
-
procedure initModule;
procedure freeModule;
@@ -99,18 +96,18 @@
procedure InitIPC;
var ipaddr: TIPAddress;
begin
-WriteToConsole('Init SDL_Net... ');
-SDLTry(SDLNet_Init = 0, true);
-fds:= SDLNet_AllocSocketSet(1);
-SDLTry(fds <> nil, true);
-WriteLnToConsole(msgOK);
-WriteToConsole('Establishing IPC connection... ');
-{$HINTS OFF}
-SDLTry(SDLNet_ResolveHost(ipaddr, '127.0.0.1', ipcPort) = 0, true);
-{$HINTS ON}
-IPCSock:= SDLNet_TCP_Open(ipaddr);
-SDLTry(IPCSock <> nil, true);
-WriteLnToConsole(msgOK)
+ WriteToConsole('Init SDL_Net... ');
+ SDLTry(SDLNet_Init = 0, true);
+ fds:= SDLNet_AllocSocketSet(1);
+ SDLTry(fds <> nil, true);
+ WriteLnToConsole(msgOK);
+ WriteToConsole('Establishing IPC connection to tcp 127.0.0.1:' + IntToStr(ipcPort) + ' ');
+ {$HINTS OFF}
+ SDLTry(SDLNet_ResolveHost(ipaddr, '127.0.0.1', ipcPort) = 0, true);
+ {$HINTS ON}
+ IPCSock:= SDLNet_TCP_Open(ipaddr);
+ SDLTry(IPCSock <> nil, true);
+ WriteLnToConsole(msgOK)
end;
procedure CloseIPC;
@@ -124,7 +121,7 @@
var loTicks: Word;
begin
case s[1] of
- '!': begin {$IFDEF DEBUGFILE}AddFileLog('Ping? Pong!');{$ENDIF}isPonged:= true; end;
+ '!': begin AddFileLog('Ping? Pong!'); isPonged:= true; end;
'?': SendIPC('!');
'e': ParseCommand(copy(s, 2, Length(s) - 1), true);
'E': OutError(copy(s, 2, Length(s) - 1), true);
@@ -139,7 +136,7 @@
else
loTicks:= SDLNet_Read16(@s[byte(s[0]) - 1]);
AddCmd(loTicks, s);
- {$IFDEF DEBUGFILE}AddFileLog('[IPC in] '+s[1]+' ticks '+IntToStr(lastcmd^.loTime));{$ENDIF}
+ AddFileLog('[IPC in] '+s[1]+' ticks '+IntToStr(lastcmd^.loTime));
end
end;
@@ -220,7 +217,7 @@
SendEmptyPacketTicks:= 0;
if s[0]>#251 then s[0]:= #251;
SDLNet_Write16(GameTicks, @s[Succ(byte(s[0]))]);
- {$IFDEF DEBUGFILE}AddFileLog('[IPC out] '+ s[1]);{$ENDIF}
+ AddFileLog('[IPC out] '+ s[1]);
inc(s[0], 2);
SDLNet_TCP_Send(IPCSock, @s, Succ(byte(s[0])))
end
@@ -247,7 +244,7 @@
procedure SendIPCTimeInc;
const timeinc: shortstring = '#';
begin
-{$IFDEF DEBUGFILE}AddFileLog('[IPC out]