Skip to content

Commit 0ad8fb4

Browse files
bbangertbbangert
committed
Moar cleanup.
1 parent 9ba49c3 commit 0ad8fb4

File tree

3 files changed

+67
-85
lines changed

3 files changed

+67
-85
lines changed

Diff for: ‎Main.hs

+8-31
Original file line numberDiff line numberDiff line change
@@ -2,54 +2,31 @@
22
module Main where
33

44
import Control.Applicative ((<$>))
5-
import Control.Monad.State (runState)
6-
import Data.List (foldl')
75
import qualified Data.Text as T
86
import qualified Data.Text.IO as T
9-
import System.Console.GetOpt (ArgDescr (..), ArgOrder (..),
10-
OptDescr (..), getOpt)
117
import System.Environment (getArgs)
128
import System.Exit (exitFailure)
13-
import System.Random (StdGen, getStdGen, mkStdGen)
149

1510
import Megahaskhal (Brain, getWords, loadBrainFromFilename)
16-
import Megahaskhal.Reply (generateReplies, sReply, sScore)
11+
import Megahaskhal.Reply (generateReply)
1712

1813
die :: T.Text -> IO ()
1914
die s = T.putStrLn s >> exitFailure
2015

21-
data Flags = Flags { fGetStdGen :: IO StdGen }
22-
23-
defaultFlags :: Flags
24-
defaultFlags = Flags { fGetStdGen = getStdGen }
25-
26-
options :: [OptDescr (Flags -> Flags)]
27-
options = [ Option "s" ["seed"] (ReqArg updateSeed "SEED") "set prng SEED"
28-
]
29-
where
30-
updateSeed d flags = case reads d of
31-
[(n, "")] -> flags { fGetStdGen = return (mkStdGen n) }
32-
-- ignore invalid seeds, might make sense to change this around to
33-
-- show errors
34-
_ -> flags
35-
3616
main :: IO ()
3717
main = do
38-
(makeFlags, args, errs) <- getOpt Permute options <$> getArgs
39-
let flags = foldl' (flip ($)) defaultFlags makeFlags
40-
gen <- fGetStdGen flags
41-
case (args, errs) of
42-
([filename], []) ->
18+
args <- getArgs
19+
case args of
20+
[filename] -> do
4321
loadBrainFromFilename filename >>=
4422
maybe (die "Unable to load from file.") runHal
45-
_ -> do
46-
mapM_ putStrLn errs
47-
die "Pass in a file name for the brain."
23+
_ -> die "Pass in a file name for the brain."
4824

4925
runHal :: Brain -> IO ()
5026
runHal brain = do
5127
T.putStrLn "Enter text: "
5228
phrase <- getWords <$> T.getLine
53-
reply <- generateReplies brain phrase
54-
T.putStrLn reply
29+
print phrase
30+
reply <- generateReply brain phrase
31+
print reply
5532
runHal brain

Diff for: ‎bot/Main.hs

+4-5
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@ module Main where
33

44
import Control.Monad (when)
55
import Control.Monad.Error (join, liftIO, runErrorT)
6-
import Control.Monad.State (runState)
76
import qualified Data.ByteString.Char8 as B
87
import Data.ConfigFile (CPError, emptyCP, get, readfile)
98
import Data.List.Split (splitOneOf)
@@ -13,10 +12,10 @@ import qualified Data.Text.IO as T
1312
import qualified Network.SimpleIRC as SI
1413
import System.Environment (getArgs)
1514
import System.Exit (exitFailure)
16-
import System.Random (StdGen, getStdGen, setStdGen)
15+
import System.Random (StdGen)
1716

1817
import Megahaskhal (Brain, getWords, loadBrainFromFilename)
19-
import Megahaskhal.Reply (generateReplies, sReply, sScore)
18+
import Megahaskhal.Reply (generateReply)
2019

2120
die :: T.Text -> IO ()
2221
die s = T.putStrLn s >> exitFailure
@@ -96,7 +95,7 @@ loadConfig brainFile configFile = loadBrainFromFilename brainFile >>= loadResult
9695
where
9796
loadResult Nothing = return $ Left "Unable to load brain file"
9897
loadResult (Just brain) = parseConfigFile configFile >>= parseResult brain
99-
parseResult brain (Left (_, errs)) = return $ Left $ "Unable to parse config: " ++ errs
98+
parseResult _ (Left (_, errs)) = return $ Left $ "Unable to parse config: " ++ errs
10099
parseResult brain (Right settings) = return $ Right (brain, settings)
101100

102101
startBot :: Brain -> Settings -> IO ()
@@ -112,7 +111,7 @@ startBot brain settings = do
112111
return ()
113112

114113
runHal :: Brain -> T.Text -> IO T.Text
115-
runHal brain phrase = generateReplies brain (getWords phrase)
114+
runHal brain phrase = generateReply brain (getWords phrase)
116115

117116
parseConfigFile :: String
118117
-> IO (Either CPError Settings)

Diff for: ‎src/Megahaskhal/Reply.hs

+55-49
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,19 @@
1-
{-| Core reply generation facilities
1+
{- |Core reply generation facilities
22
3-
These functions provide various ways to generate, filter, and
4-
restrict the final set of replies created in response to a phrase
5-
for a supplied 'Megahaskhal.Internal.Brain'.
3+
These functions provide various ways to generate, filter, and restrict
4+
the final set of replies created in response to a phrase for a supplied
5+
'Megahaskhal.Internal.Brain'.
6+
7+
Example usage to generate a response provided a brain:
8+
9+
> import qualified Data.Text as T
10+
> import Megahaskhal (Brain)
11+
> import Megahaskhal.Reply (generateReply, getWords)
12+
>
13+
> printReply :: Brain -> IO T.Text
14+
> printReply brain = do
15+
> phrase <- getLine
16+
> generateReply brain (getWords phrase)
617
718
-}
819

@@ -16,9 +27,8 @@ module Megahaskhal.Reply (
1627
-- * Pipe Components
1728
-- $pipes
1829
replyProducer
19-
, dropShortReply
20-
, dropLongReply
21-
, generateReplies
30+
, collectTopReplies
31+
, generateReply
2232

2333
-- * Replies
2434
-- $replies
@@ -91,44 +101,34 @@ replyProducer brain phrase = do
91101
lift $ setStdGen newGen
92102
replyProducer brain phrase
93103

94-
-- | Drop replies that are shorter than the length specified
95-
dropShortReply :: Int -> Pipe ScoredReply ScoredReply IO ()
96-
dropShortReply n = do
97-
repl <- await
98-
let repLen = T.length $ sReply repl
99-
if repLen > n
100-
then yield repl >> dropShortReply n
101-
else dropShortReply n
102-
103-
-- | Drop replies that are longer than the length specified
104-
dropLongReply :: Int -> Pipe ScoredReply ScoredReply IO ()
105-
dropLongReply n = do
104+
dropOutsideBounds :: Int -> Int -> Pipe ScoredReply ScoredReply IO ()
105+
dropOutsideBounds l u = do
106106
repl <- await
107107
let repLen = T.length $ sReply repl
108-
if repLen < n
109-
then yield repl >> dropLongReply n
110-
else dropLongReply n
108+
if l <= repLen && repLen <= u
109+
then yield repl >> dropOutsideBounds l u
110+
else dropOutsideBounds l u
111111

112112
-- | Collect top replies
113113
collectTopReplies :: TopReplies -> Parser ScoredReply IO TopReplies
114114
collectTopReplies tr = do
115-
reply <- draw
116-
case reply of
115+
repl <- draw
116+
case repl of
117117
Nothing -> return tr
118118
Just r -> collectTopReplies (addReply r tr)
119119

120120
-- | Generate a suitable amount of replies and return the highest scored
121-
generateReplies :: Brain -> [Text] -> IO Text
122-
generateReplies brain phrase = do
123-
times <- getStdRandom (randomR (500,1500))
121+
generateReply :: Brain -> [Text] -> IO Text
122+
generateReply brain phrase = do
123+
times <- getStdRandom (randomR (800,1500))
124124
replies <- evalStateT parser $
125-
producer >-> dropShortReply 25
126-
>-> dropLongReply 5000
125+
producer >-> dropOutsideBounds 25 5000
127126
>-> PL.take times
128127
let cc = length $ allReplies replies
129128
index <- getStdRandom (randomR (0, max 0 (cc-1)))
130129
let repl = allReplies replies !! index
131130
return $ capitalizeSentence . sReply $ repl
131+
-- return $ repl { sReply=(capitalizeSentence . sReply) repl }
132132
where producer = replyProducer brain phrase
133133
parser = collectTopReplies $ empty 20
134134

@@ -251,16 +251,18 @@ processWords ctx dict order keywords replies usedKey symbol = do
251251
replyWords = symbol:replies
252252
newCtx = updateContext ctx order symbol
253253

254-
-- Evaluate the 'surprise' factor of a given choice of reply words
255-
-- The surprise factor is based entirely around whether the chosen reply
256-
-- includes words used in the keywords that were supplied.
257-
-- For every word in the reply, the context is built up and iterated over
258-
-- regardless of if the word is a keyword. When a keyword is hit, a subloop
259-
-- runs for that portion over the entire context at that state determining if
260-
-- any of the tree's contain the symbol and updating the probability, at the
261-
-- end of which the entropy is updated.
254+
{-| Evaluate the 'surprise' factor of a given choice of reply words
255+
256+
The surprise factor is based entirely around whether the chosen reply
257+
includes words used in the keywords that were supplied. For every word
258+
in the reply, the context is built up and iterated over regardless of
259+
if the word is a keyword. When a keyword is hit, a subloop runs for
260+
that portion over the entire context at that state determining if any
261+
of the tree's contain the symbol and updating the probability, at the
262+
end of which the entropy is updated.
263+
264+
-}
262265
evaluateReply :: Brain -> Keywords -> Replies -> Float
263-
evaluateReply _ [] _ = 0
264266
evaluateReply (Brain fTree bTree _ order _) keys repl
265267
| num < 8 = entropy
266268
| num < 16 = entropy / sqrt (num-1)
@@ -274,16 +276,16 @@ evaluateReply (Brain fTree bTree _ order _) keys repl
274276
num = eNum bctx
275277
entropy = eEntropy bctx
276278

277-
-- entropy and num accumulator that retains updated context as each tree
278-
-- in the context is stepped through
279+
{- entropy and num accumulator that retains updated context as each tree
280+
in the context is stepped through -}
279281
evalulateSymbols :: Order
280282
-> Keywords
281283
-> EContext -- ^ Accumulator
282284
-> Int -- ^ Current symbol
283285
-> EContext -- ^ Accumulated value
284286
evalulateSymbols order keys acc@(EContext accNum accEntropy ctx) symbol
285-
| symbol `elem` keys ||
286-
null keys = EContext (accNum + 1) newEntropy newctx
287+
| symbol `elem` keys
288+
|| null keys = EContext (accNum + 1) newEntropy newctx
287289
| otherwise = acc { eContext = newctx }
288290
where
289291
-- we always update the context with the symbol on each step, even
@@ -314,13 +316,17 @@ evaluateContext symbol (!count, !prob) tree =
314316
{-| Transform a single @Text@ phrase into its component parts suitable to
315317
be fed into a reply generating function.
316318
317-
Rules for tokenization:
318-
Four character classes: alpha, digit, apostrophe, and other
319-
If the character class changed from the previous to current character, then
320-
it is a boundary. The only special case is alpha -> apostrophe -> alpha,
321-
which is not considered to be a boundary (it's considered to be alpha).
322-
If the last word is alphanumeric then add a last word of ".", otherwise
323-
replace the last word with "." unless it already ends with one of "!.?".
319+
Rules for tokenization:
320+
Four character classes: alpha, digit, apostrophe, and other
321+
322+
If the character class changed from the previous to current character,
323+
then it is a boundary. The only special case is alpha -> apostrophe ->
324+
alpha, which is not considered to be a boundary (it's considered to be
325+
alpha).
326+
327+
If the last word is alphanumeric then add a last word of ".", otherwise
328+
replace the last word with "." unless it already ends with one of
329+
"!.?".
324330
325331
-}
326332
getWords :: Text -> [Text]

0 commit comments

Comments
 (0)