Initial commit
This commit is contained in:
4
.gitignore
vendored
Normal file
4
.gitignore
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
/save.yml
|
||||
/conf.yml
|
||||
/dist-newstyle/
|
||||
/haddocks/
|
||||
42
ninapcar.cabal
Normal file
42
ninapcar.cabal
Normal file
@ -0,0 +1,42 @@
|
||||
cabal-version: 2.2
|
||||
|
||||
name: ninapcar
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
homepage: https://git.annwan.me/software/ninapcar
|
||||
license: BSD-3-Clause
|
||||
author: Annwan
|
||||
maintainer: annwan@annwan.me
|
||||
copyright: 2026 Annwan
|
||||
category: Web
|
||||
build-type: Simple
|
||||
|
||||
executable ninapcar
|
||||
hs-source-dirs: src
|
||||
main-is: Main.hs
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.7 && < 5
|
||||
, text >= 2.1 && < 3
|
||||
, yaml >= 0.11.11.2
|
||||
, data-default == 0.8.0.2
|
||||
, unliftio == 0.2.25.1
|
||||
, discord-haskell == 1.18.0
|
||||
, random == 1.3.1
|
||||
, regex == 1.1.0.2
|
||||
, regex-pcre == 0.95.0.1
|
||||
, attoparsec == 0.14.4
|
||||
ghc-options: -Wall
|
||||
-Wcompat
|
||||
-Widentities
|
||||
-Wincomplete-record-updates
|
||||
-Wincomplete-uni-patterns
|
||||
-Wmissing-export-lists
|
||||
-Wmissing-home-modules
|
||||
-Wpartial-fields
|
||||
-Wredundant-constraints
|
||||
other-modules: Dice
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://git.annwan.me/software/ninapcar
|
||||
176
src/Dice.hs
Normal file
176
src/Dice.hs
Normal file
@ -0,0 +1,176 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-|
|
||||
Module : Dice
|
||||
Description : Dice Rolling
|
||||
Maintainer : Annwan <annwan@annwan.me>
|
||||
|
||||
Internals of the dice roller module for the bot
|
||||
-}
|
||||
module Dice (DiceResult(..), DiceExpr(..), parseDiceExpr, compute) where
|
||||
|
||||
import System.Random
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.List (sort)
|
||||
import qualified Data.Attoparsec.Text as P
|
||||
import Data.Text (Text, pack)
|
||||
|
||||
-- | The result of a dice expression
|
||||
data DiceResult = DiceResult [(Bool, Integer)] Integer
|
||||
|
||||
-- | A dice expression
|
||||
--
|
||||
-- Examples:
|
||||
--
|
||||
-- * @4@: @Constant 4@
|
||||
-- * @(3 + 3d6kh3)@: @'Sum' ('Constant' 3) ('DiceKeepHigh' 3 6 3)@
|
||||
-- * @(4d6 /^ 2)@: @'DivCeil' ('Dice' 4 6) ('Constant' 2)@
|
||||
-- * @(10d8kl8 /v (4d6 - 1))@: @'DivFloor' ('DiceKeepLow' 10 8 8) ('Sub' ('Dice' 4 6) ('Constant' 1)))@
|
||||
data DiceExpr = -- | An integer constant
|
||||
Constant Integer
|
||||
| -- | The sum of 2 expressions
|
||||
Sum DiceExpr DiceExpr
|
||||
| -- | The Product of 2 expressions
|
||||
Product DiceExpr DiceExpr
|
||||
| -- | Divide and round down
|
||||
DivFloor DiceExpr DiceExpr
|
||||
| -- | Divide and round up
|
||||
DivCeil DiceExpr DiceExpr
|
||||
| -- | Divide and round to nearest
|
||||
DivRound DiceExpr DiceExpr
|
||||
| -- | The difference of 2 expressions
|
||||
Sub DiceExpr DiceExpr
|
||||
| -- | A plain set of dice
|
||||
Dice Integer Integer
|
||||
| -- | A set of dice where you keep the /n/ lowest
|
||||
DiceKeepLow Integer Integer Integer
|
||||
| -- | A set of dice where you keep the /n/ highest
|
||||
DiceKeepHigh Integer Integer Integer
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
-- | Compute the result of a dice expression
|
||||
--
|
||||
-- This function runs in IO due to random number generation.
|
||||
compute :: DiceExpr -> IO DiceResult
|
||||
compute (Constant v) = pure $ DiceResult [] v
|
||||
compute (Sum lhs rhs) = do
|
||||
DiceResult ll lv <- compute lhs
|
||||
DiceResult rl rv <- compute rhs
|
||||
pure $ DiceResult (ll ++ rl) (lv + rv)
|
||||
compute (Product lhs rhs) = do
|
||||
DiceResult ll lv <- compute lhs
|
||||
DiceResult rl rv <- compute rhs
|
||||
pure $ DiceResult (ll ++ rl) (lv * rv)
|
||||
compute (Sub lhs rhs) = do
|
||||
DiceResult ll lv <- compute lhs
|
||||
DiceResult rl rv <- compute rhs
|
||||
pure $ DiceResult (ll ++ rl) (lv - rv)
|
||||
compute (DivFloor lhs rhs) = do
|
||||
DiceResult ll lv <- compute lhs
|
||||
DiceResult rl rv <- compute rhs
|
||||
let (q, _) = quotRem lv rv
|
||||
pure $ DiceResult (ll ++ rl) (q)
|
||||
compute (DivCeil lhs rhs) = do
|
||||
DiceResult ll lv <- compute lhs
|
||||
DiceResult rl rv <- compute rhs
|
||||
let (q, r) = quotRem lv rv
|
||||
pure $ DiceResult (ll ++ rl) (q + if r > 0 then 1 else 0)
|
||||
compute (DivRound lhs rhs) = do
|
||||
DiceResult ll lv <- compute lhs
|
||||
DiceResult rl rv <- compute rhs
|
||||
let (q, r) = quotRem lv rv
|
||||
(n, _) = quotRem rv 2
|
||||
pure $ DiceResult (ll ++ rl) (q + if r > n then 1 else 0)
|
||||
compute (Dice count sides) = do
|
||||
rRaw <- replicateM (fromInteger count) $ randomRIO (1, sides)
|
||||
let r = map (True,) rRaw
|
||||
pure $ DiceResult r $ sum rRaw
|
||||
compute (DiceKeepLow count sides keep) = do
|
||||
rRaw <- replicateM (fromInteger count) $ randomRIO (1, sides)
|
||||
let rSorted = sort rRaw
|
||||
rKept = take (fromInteger keep) rSorted
|
||||
rLeft = drop (fromInteger keep) rSorted
|
||||
res = sum rKept
|
||||
rolls = map (True,) rKept ++ map (False,) rLeft
|
||||
pure $ DiceResult rolls res
|
||||
compute (DiceKeepHigh count sides keep) = do
|
||||
rRaw <- replicateM (fromInteger count) $ randomRIO (1, sides)
|
||||
let rSorted = map negate . sort . map negate $ rRaw
|
||||
rKept = take (fromInteger keep) rSorted
|
||||
rLeft = drop (fromInteger keep) rSorted
|
||||
res = sum rKept
|
||||
rolls = map (True,) rKept ++ map (False,) rLeft
|
||||
pure $ DiceResult rolls res
|
||||
|
||||
-- | Parser for a constant litteral
|
||||
parserConstant :: P.Parser DiceExpr
|
||||
parserConstant = Constant <$> P.decimal
|
||||
|
||||
-- | Parser for a dice litteral
|
||||
parserDice :: P.Parser DiceExpr
|
||||
parserDice = Dice <$> P.decimal
|
||||
<*> ("d" *> P.decimal)
|
||||
|
||||
-- | Parser for a keep-high dice literal
|
||||
parserDiceKeepHigh :: P.Parser DiceExpr
|
||||
parserDiceKeepHigh = DiceKeepHigh <$> P.decimal
|
||||
<*> ("d" *> P.decimal)
|
||||
<*> ("kh" *> P.decimal)
|
||||
|
||||
-- | Parser for a keep-low dice literal
|
||||
parserDiceKeepLow :: P.Parser DiceExpr
|
||||
parserDiceKeepLow = DiceKeepLow <$> P.decimal
|
||||
<*> ("d" *> P.decimal)
|
||||
<*> ("kl" *> P.decimal)
|
||||
|
||||
-- | Parser for a sum
|
||||
parserSum :: P.Parser DiceExpr
|
||||
parserSum = Sum <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "+" *> P.skipSpace *> parserDiceExpr) <* ")"
|
||||
|
||||
-- | Parser for a product
|
||||
parserProduct :: P.Parser DiceExpr
|
||||
parserProduct = Product <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "*" *> parserDiceExpr) <* ")"
|
||||
|
||||
-- | Parser for a subtraction
|
||||
parserSub :: P.Parser DiceExpr
|
||||
parserSub = Sub <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "*" *> P.skipSpace *> parserDiceExpr) <* ")"
|
||||
|
||||
-- | Parser for a rounded division
|
||||
parserDivRound :: P.Parser DiceExpr
|
||||
parserDivRound = DivRound <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "/" *> P.skipSpace *> parserDiceExpr) <* ")"
|
||||
|
||||
|
||||
-- | Parser for a high-rounding division
|
||||
parserDivCeil :: P.Parser DiceExpr
|
||||
parserDivCeil = DivCeil <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "/^" *> P.skipSpace *> parserDiceExpr) <* ")"
|
||||
|
||||
-- | Parser for a low-rounding division
|
||||
parserDivFloor :: P.Parser DiceExpr
|
||||
parserDivFloor = DivFloor <$> ("(" *> parserDiceExpr) <*> (P.skipSpace *> "/v" *> P.skipSpace *> parserDiceExpr) <* ")"
|
||||
|
||||
-- | Parser for a dice expression
|
||||
parserDiceExpr :: P.Parser DiceExpr
|
||||
parserDiceExpr = allP
|
||||
where allP = parserSum
|
||||
<|> parserSub
|
||||
<|> parserProduct
|
||||
<|> parserDivRound
|
||||
<|> parserDivFloor
|
||||
<|> parserDivCeil
|
||||
<|> parserDiceKeepHigh
|
||||
<|> parserDiceKeepLow
|
||||
<|> parserDice
|
||||
<|> parserConstant
|
||||
|
||||
-- | Parse a dice expression
|
||||
parseDiceExpr :: Text -> Either Text DiceExpr
|
||||
parseDiceExpr spec =
|
||||
let res = P.parse parserDiceExpr spec
|
||||
in case res of
|
||||
P.Fail _ _ msg -> Left $ pack msg
|
||||
P.Partial f -> case f "" of
|
||||
P.Fail _ _ msg -> Left $ pack msg
|
||||
P.Partial _ -> error "unreachable"
|
||||
P.Done _ r -> Right r
|
||||
P.Done _ r -> Right r
|
||||
246
src/Main.hs
Normal file
246
src/Main.hs
Normal file
@ -0,0 +1,246 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (forM_, void)
|
||||
import Data.Default
|
||||
import Data.List (find)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Yaml
|
||||
import Discord
|
||||
import Discord.Interactions
|
||||
import qualified Discord.Requests as R
|
||||
import Discord.Types
|
||||
import UnliftIO
|
||||
import Dice
|
||||
|
||||
data Config = Config {token :: Text, server :: GuildId} deriving (Show, Eq)
|
||||
|
||||
instance FromJSON Config where
|
||||
parseJSON = withObject "Config" $ \v ->
|
||||
Config
|
||||
<$> v .: "token"
|
||||
<*> v .: "server"
|
||||
|
||||
data Project = Project
|
||||
{ rolls :: [Integer],
|
||||
target :: Integer
|
||||
}
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
instance FromJSON Project where
|
||||
parseJSON = withObject "Project" $
|
||||
\v ->
|
||||
Project
|
||||
<$> v .: "rolls"
|
||||
<*> v .: "target"
|
||||
|
||||
instance ToJSON Project where
|
||||
toJSON (Project r t) = object ["rolls" .= r, "target" .= t]
|
||||
|
||||
newtype State = State {projects :: [Project]} deriving (Show, Read, Eq)
|
||||
|
||||
instance FromJSON State where
|
||||
parseJSON = withObject "State" $ \v -> State <$> v .: "projects"
|
||||
|
||||
instance ToJSON State where
|
||||
toJSON (State p) = object ["projects" .= p]
|
||||
|
||||
instance Default State where def = State []
|
||||
|
||||
readSave :: IO State
|
||||
readSave = do
|
||||
loaded :: Either ParseException State <- decodeFileEither "save.yml"
|
||||
case loaded of
|
||||
Left _ -> do
|
||||
putStrLn "Couldn't parse save, using empty state"
|
||||
pure def
|
||||
Right s -> do
|
||||
putStrLn "Save Loaded"
|
||||
pure s
|
||||
|
||||
readConfig :: IO Config
|
||||
readConfig = do
|
||||
loaded :: Either ParseException Config <- decodeFileEither "conf.yml"
|
||||
case loaded of
|
||||
Left _ -> error "Couldn't read config"
|
||||
Right c -> do
|
||||
putStrLn "Loaded config"
|
||||
pure c
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
config <- readConfig
|
||||
stateContent <- readSave
|
||||
state :: MVar State <- newMVar stateContent
|
||||
t <-
|
||||
runDiscord $
|
||||
def
|
||||
{ discordToken = token config,
|
||||
discordOnStart = liftIO $ putStrLn "ninapcar init done",
|
||||
discordOnEvent = eventHandler config state,
|
||||
discordOnEnd = do
|
||||
s <- readMVar state
|
||||
encodeFile "save.yml" s
|
||||
putStrLn "done",
|
||||
discordGatewayIntent = def {gatewayIntentMessageContent = False}
|
||||
}
|
||||
putStrLn (T.unpack t)
|
||||
|
||||
eventHandler :: Config -> MVar State -> Event -> DiscordHandler ()
|
||||
eventHandler config state = \case
|
||||
Ready _ _ _ _ _ _ (PartialApplication appId _) -> onReady config appId
|
||||
InteractionCreate intr -> onInteractionCreate state intr
|
||||
_ -> pure ()
|
||||
|
||||
data SlashCommand = SlashCommand
|
||||
{ name :: Text,
|
||||
registration :: Maybe CreateApplicationCommand,
|
||||
handler :: MVar State -> Interaction -> Maybe OptionsData -> DiscordHandler ()
|
||||
}
|
||||
|
||||
ping :: SlashCommand
|
||||
ping =
|
||||
SlashCommand
|
||||
{ name = "ping",
|
||||
registration =
|
||||
let create = createChatInput "ping" "check bot status"
|
||||
in create,
|
||||
handler = \_state intr _opts ->
|
||||
void . restCall $
|
||||
R.CreateInteractionResponse
|
||||
(interactionId intr)
|
||||
(interactionToken intr)
|
||||
(interactionResponseBasic "pong")
|
||||
}
|
||||
|
||||
rollDice :: Text -> IO (Either Text DiceResult)
|
||||
rollDice s =
|
||||
case parseDiceExpr s of
|
||||
Left err -> pure $ Left err
|
||||
Right expr -> Right <$> compute expr
|
||||
|
||||
data RollOpts = RollOpts { spec :: Maybe Text, comment :: Maybe Text }
|
||||
|
||||
roll :: SlashCommand
|
||||
roll =
|
||||
SlashCommand
|
||||
{ name = "roll",
|
||||
registration = reg,
|
||||
handler = han
|
||||
}
|
||||
where
|
||||
reg =
|
||||
let create = createChatInput "roll" "roll a dice"
|
||||
in case create of
|
||||
Nothing -> Nothing
|
||||
Just c@CreateApplicationCommandChatInput {} ->
|
||||
Just $
|
||||
c
|
||||
{ createOptions =
|
||||
Just $
|
||||
OptionsValues
|
||||
[ OptionValueString
|
||||
{ optionValueName = "dice"
|
||||
, optionValueLocalizedName = Nothing
|
||||
, optionValueDescription = "dice spec to roll"
|
||||
, optionValueLocalizedDescription = Nothing
|
||||
, optionValueRequired = True
|
||||
, optionValueStringChoices = Left False
|
||||
, optionValueStringMinLen = Nothing
|
||||
, optionValueStringMaxLen = Nothing
|
||||
}
|
||||
, OptionValueString
|
||||
{ optionValueName = "comment"
|
||||
, optionValueLocalizedName = Nothing
|
||||
, optionValueDescription = "comment for the dice roll"
|
||||
, optionValueLocalizedDescription = Nothing
|
||||
, optionValueRequired = False
|
||||
, optionValueStringChoices = Left False
|
||||
, optionValueStringMinLen = Nothing
|
||||
, optionValueStringMaxLen = Nothing
|
||||
}
|
||||
]
|
||||
}
|
||||
_ -> Nothing
|
||||
han _state intr = \case
|
||||
Just (OptionsDataValues raw_opts) -> do
|
||||
let opts = parse_opts (RollOpts Nothing Nothing) raw_opts
|
||||
commentTxt :: Text
|
||||
commentTxt = case comment opts of
|
||||
Nothing -> ""
|
||||
Just c -> c <> ": "
|
||||
case spec opts of
|
||||
Nothing -> interactionReplyError intr "something went wrong"
|
||||
Just s -> do
|
||||
res <- liftIO $ rollDice s
|
||||
case res of
|
||||
Left err -> interactionReplyError intr $ "Error: " <> err
|
||||
Right r -> void . restCall
|
||||
$ R.CreateInteractionResponse (interactionId intr) (interactionToken intr) (interactionResponseBasic $ commentTxt <> "(`" <> s <> "`) " <> showResult r)
|
||||
where
|
||||
parse_opts :: RollOpts -> [OptionDataValue] -> RollOpts
|
||||
parse_opts old [] = old
|
||||
parse_opts old ((OptionDataValueString {optionDataValueString= Right val, optionDataValueName= "dice"}):rest) =
|
||||
parse_opts (old { spec = Just val }) rest
|
||||
parse_opts old ((OptionDataValueString {optionDataValueString = Right val, optionDataValueName = "comment" }):rest) =
|
||||
parse_opts (old { comment = Just val }) rest
|
||||
parse_opts old (_:rest) = parse_opts old rest
|
||||
showResult :: DiceResult -> Text
|
||||
showResult (DiceResult rs final) =
|
||||
"[ " <> (foldr (<>) "" . map showRoll $ rs) <> "] -> " <> T.show final
|
||||
showRoll :: (Bool, Integer) -> Text
|
||||
showRoll (True, i) = T.show i <> " "
|
||||
showRoll (False, i) = "~~" <> T.show i <> "~~ "
|
||||
_ -> interactionReplyError intr "Something went wrong"
|
||||
slashCommands :: [SlashCommand]
|
||||
slashCommands = [ping, roll]
|
||||
|
||||
onReady :: Config -> ApplicationId -> DiscordHandler ()
|
||||
onReady config appId = do
|
||||
liftIO $ putStrLn "Bot Ready!"
|
||||
appCmdRegistrations <- mapM tryRegistering slashCommands
|
||||
|
||||
case sequence appCmdRegistrations of
|
||||
Left err ->
|
||||
liftIO $ putStrLn $ "[!] Failed to register some commands" ++ show err
|
||||
Right cmds -> do
|
||||
liftIO $ putStrLn $ "Registered " ++ show (length cmds) ++ " command(s)"
|
||||
|
||||
unregisterOutdatedCmds cmds
|
||||
where
|
||||
tryRegistering cmd = case registration cmd of
|
||||
Just reg ->
|
||||
restCall $
|
||||
R.CreateGuildApplicationCommand appId (server config) reg
|
||||
Nothing -> pure . Left $ RestCallErrorCode 0 "" ""
|
||||
|
||||
unregisterOutdatedCmds validCmds = do
|
||||
registered <- restCall $ R.GetGuildApplicationCommands appId (server config)
|
||||
case registered of
|
||||
Left err -> liftIO $ putStrLn $ "Failed to get registerd commands" ++ show err
|
||||
Right cmds ->
|
||||
let validIds = map applicationCommandId validCmds
|
||||
outdatedIds =
|
||||
filter (`notElem` validIds)
|
||||
. map applicationCommandId
|
||||
$ cmds
|
||||
in forM_ outdatedIds $
|
||||
restCall . R.DeleteGuildApplicationCommand appId (server config)
|
||||
|
||||
onInteractionCreate :: MVar State -> Interaction -> DiscordHandler ()
|
||||
onInteractionCreate state = \case
|
||||
cmd@InteractionApplicationCommand
|
||||
{ applicationCommandData = input@ApplicationCommandDataChatInput {}
|
||||
} ->
|
||||
case find (\c -> applicationCommandDataName input == name c) slashCommands of
|
||||
Just found -> handler found state cmd (optionsData input)
|
||||
Nothing -> liftIO $ putStrLn $ "Unknown slash command: `" ++ show (applicationCommandDataName input) ++ "`"
|
||||
_ -> pure ()
|
||||
|
||||
interactionReplyError :: Interaction -> Text -> DiscordHandler ()
|
||||
interactionReplyError intr err = void. restCall $ R.CreateInteractionResponse (interactionId intr) (interactionToken intr) (interactionResponseBasic $ "[ERROR] " <> err)
|
||||
Reference in New Issue
Block a user