From 0a32f28db59474efbf587a4b3af16ae7d3315b4b Mon Sep 17 00:00:00 2001 From: Annwan Date: Thu, 11 Jun 2026 18:33:19 +0200 Subject: [PATCH] Initial commit --- .gitignore | 4 + README.md | 1 + ninapcar.cabal | 42 +++++++++ src/Dice.hs | 176 +++++++++++++++++++++++++++++++++++ src/Main.hs | 246 +++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 469 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 ninapcar.cabal create mode 100644 src/Dice.hs create mode 100644 src/Main.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a1cc8fa --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +/save.yml +/conf.yml +/dist-newstyle/ +/haddocks/ diff --git a/README.md b/README.md new file mode 100644 index 0000000..a1f3c9e --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# ninapcar diff --git a/ninapcar.cabal b/ninapcar.cabal new file mode 100644 index 0000000..6afce9d --- /dev/null +++ b/ninapcar.cabal @@ -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 diff --git a/src/Dice.hs b/src/Dice.hs new file mode 100644 index 0000000..6d3315e --- /dev/null +++ b/src/Dice.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Dice +Description : Dice Rolling +Maintainer : Annwan + +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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..cef4a7d --- /dev/null +++ b/src/Main.hs @@ -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)