1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-}
-- | This module is an IRC plugin that generates and kills ducks
module Hsbot.Plugin.Duck
( DuckArgs (..)
, duck
, theDuck
) where
import Control.Concurrent
import Control.Monad.Reader
import Control.Monad.State
import Data.Acid
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.Ord ()
import Data.SafeCopy
import Data.Typeable
import qualified Network.IRC as IRC
import System.Environment.XDG.BaseDir
import System.Random
import Hsbot.Message
import Hsbot.Types
import Hsbot.Utils
-- The statistics database
data StatDB = StatDB
{ nickStats :: M.Map String Int
} deriving (Show, Typeable)
-- | Statistics database initial state
emptyStatDB :: StatDB
emptyStatDB = StatDB { nickStats = M.empty }
$(deriveSafeCopy 0 'base ''StatDB)
-- | Statistics database transactions
updateScore :: String -> Int -> Update StatDB ()
updateScore sender score = do
statDB <- get
let stats = nickStats statDB
stat = fromMaybe 0 $ M.lookup sender stats
put statDB { nickStats = M.insert sender (stat + score) stats }
getDuckStats :: Query StatDB StatDB
getDuckStats = ask
$(makeAcidic ''StatDB ['getDuckStats, 'updateScore])
-- | The duck plugin identity
duck :: PluginId
duck = PluginId
{ pluginName = "duck"
, pluginEp = theDuck DuckArgs { duckChannel = "", duckFreq = 10 } }
data DuckArgs = DuckArgs
{ duckChannel :: String
, duckFreq :: Int }
-- | An IRC plugin that generates and kills ducks
theDuck :: DuckArgs -> Plugin (Env IO) ()
theDuck (DuckArgs channel seconds) = do
baseDir <- liftIO $ System.Environment.XDG.BaseDir.getUserDataDir "hsbot"
statDB <- liftIO $ openAcidStateFrom (baseDir ++ "/duckDB/") emptyStatDB
ducksMVar <- liftIO newEmptyMVar
timeMVar <- liftIO $ newMVar seconds
duckSpawner channel seconds ducksMVar
forever $ readMsg >>= eval statDB ducksMVar timeMVar
where
eval :: AcidState StatDB -> MVar Int -> MVar Int -> Message -> Plugin (Env IO) ()
eval statDB ducksMVar timeMVar (IncomingMsg msg)
| IRC.msg_command msg == "PRIVMSG" = do
-- First we kill the ducks that we find in the message
let kills = howManyDucksInThere . concat $ IRC.msg_params msg
when (kills /= "") $ answerMsg msg kills
when (getDestination msg == channel) $ do
-- Then we check if someone shot some duck
let shots = howManyBulletFiredInThere . concat $ IRC.msg_params msg
when (shots > 0) $ do
empty <- liftIO $ isEmptyMVar ducksMVar
ducksWaitingForDeath <- if empty then return 0
else liftIO $ modifyMVar ducksMVar (\x -> return (x - shots, x))
_ <- update' statDB . UpdateScore (getSender msg) $ computeScore ducksWaitingForDeath shots
when (and [ ducksWaitingForDeath > 0, shots >= ducksWaitingForDeath ]) $ do
_ <- liftIO $ takeMVar ducksMVar
time <- liftIO $ readMVar timeMVar
duckSpawner channel time ducksMVar
return ()
-- Finally we check if we received some command
cmdArgs <- lift $ getCommand msg
case cmdArgs of
"duck":"freq":time:_ -> case reads time :: [(Int, String)] of
(secs,_):_ -> liftIO $ modifyMVar_ timeMVar (\_ -> return secs)
_ -> answerMsg msg "Invalid time value."
"duck":"freq":_ -> answerMsg msg $ "You must provide an amount of seconds the bot should wait before spawning "
++ "new ducks after the end of a round."
"duck":"stat":_ -> query' statDB GetDuckStats >>= printDuckStats channel
"duck":_ -> answerMsg msg "Invalid duck command."
_ -> return ()
| otherwise = return ()
eval _ _ _ _ = return ()
computeScore :: Int -> Int -> Int
computeScore ducksWaitingForDeath shots
| shots < ducksWaitingForDeath = shots - 1
| shots == ducksWaitingForDeath = shots + 1
| otherwise = negate shots
-- | Spawns ducks on a channel, just waiting to be shot
duckSpawner :: String -> Int -> MVar Int -> Plugin (Env IO) ()
duckSpawner channel secs ducksMVar = do
pEnv <- ask
lift ask >>= liftIO . forkIO . runReaderT (runReaderT trueSpawner pEnv) >>= lift . addThreadIdToQuitMVar
where
trueSpawner :: Plugin (Env IO) ()
trueSpawner = do
rsecs <- liftIO . getStdRandom $ randomR (1,secs)
liftIO $ threadDelay (1000000 * rsecs)
nbDucks <- liftIO . getStdRandom $ randomR (1,4)
thoseDucks <- liftIO $ replicateM nbDucks someRandomDuck
liftIO $ putMVar ducksMVar nbDucks
writeMsg . OutgoingMsg $ IRC.Message Nothing "PRIVMSG" [channel, concat thoseDucks]
liftIO myThreadId >>= lift . delThreadIdFromQuitMVar
-- | Tels how many shots we can hear from this string
howManyBulletFiredInThere :: String -> Int
howManyBulletFiredInThere = sum . concatMap (\y -> map (\x -> if x `L.isInfixOf` y then 1 else 0) bangs) . words
-- | Shoot as many times there are ducks in the provided string
howManyDucksInThere :: String -> String
howManyDucksInThere = concat . concatMap (\y -> map (\x -> if x `L.isInfixOf` y then "PAN! " else "") ducks) . words
-- | Output a string made of the specified number of random ducks
someRandomDuck :: IO String
someRandomDuck = do
whatDuck <- getStdRandom $ randomR (0,length ducks - 1)
return $ ducks !! whatDuck ++ " "
-- | There are many ways to hide as a duck, this function tries to cover most of them
ducks :: [String]
ducks = [ x : y : z | x <- ">=", y <- face, z <- ["__/", "_/"] ]
++ [ L.reverse $ x : y : z | x <- "<=", y <- face, z <- ["__\\", "_\\"] ]
where
face :: String
face = "oO°@©®ð*òôóø⊕ΩꙫꙩꙨ◔ȯõ⁰"
-- | Weapons can have different noises
bangs :: [String]
bangs = [ "PAN", "PAN!" ]
-- | Nicely prints duck statistics
printDuckStats :: String -> StatDB -> Plugin (Env IO) ()
printDuckStats channel statDB = do
sendLine "Duck slaughter simulator - Hall of Fame"
mapM_ (sendLine . buildLine) . reverse . L.sortBy scoreSort $ M.toList (nickStats statDB)
where
scoreSort :: (String, Int) -> (String, Int) -> Ordering
scoreSort (_, s1) (_,s2)
| s1 < s2 = LT
| s1 > s2 = GT
| otherwise = EQ
buildLine :: (String, Int) -> String
buildLine (nick, score) = concat [ nick, ": ", show score ]
sendLine :: String -> Plugin (Env IO) ()
sendLine msg = writeMsg . OutgoingMsg $ IRC.Message Nothing "PRIVMSG" [channel, msg]
|
