From b73e98202ead097348472a3ad2bed4923b5f8f67 Mon Sep 17 00:00:00 2001 From: Andreas Grois Date: Thu, 5 Jan 2023 13:09:56 +0100 Subject: Day11, MonkeyBrain unfinished --- Day11/CHANGELOG.md | 5 ++ Day11/Day11.cabal | 34 +++++++++++ Day11/app/Main.hs | 7 +++ Day11/app/MonkeyBrain.hs | 147 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 193 insertions(+) create mode 100644 Day11/CHANGELOG.md create mode 100644 Day11/Day11.cabal create mode 100644 Day11/app/Main.hs create mode 100644 Day11/app/MonkeyBrain.hs diff --git a/Day11/CHANGELOG.md b/Day11/CHANGELOG.md new file mode 100644 index 0000000..ae90a51 --- /dev/null +++ b/Day11/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for Day11 + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Day11/Day11.cabal b/Day11/Day11.cabal new file mode 100644 index 0000000..da1d855 --- /dev/null +++ b/Day11/Day11.cabal @@ -0,0 +1,34 @@ +cabal-version: 2.4 +name: Day11 +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Andreas Grois +maintainer: andi@grois.info + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable Day11 + main-is: Main.hs + + -- Modules included in this executable, other than Main. + other-modules: MonkeyBrain + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.16.3.0 + hs-source-dirs: app + default-language: Haskell2010 diff --git a/Day11/app/Main.hs b/Day11/app/Main.hs new file mode 100644 index 0000000..c7f9fa1 --- /dev/null +++ b/Day11/app/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import MonkeyBrain (evaluateIntExpression, tryParseExpression, Expression, VariableNameValidator (..), VariableValues (..), Variable (..)) +import Data.Maybe (fromJust) + +main :: IO () +main = putStrLn "Hello, Haskell!" \ No newline at end of file diff --git a/Day11/app/MonkeyBrain.hs b/Day11/app/MonkeyBrain.hs new file mode 100644 index 0000000..1eefda1 --- /dev/null +++ b/Day11/app/MonkeyBrain.hs @@ -0,0 +1,147 @@ +module MonkeyBrain (evaluateIntExpression, evaluateFracExpression, tryParseExpression, Expression, VariableNameValidator (..), VariableValues (..), Variable (..), ExpressionParseError(..)) where + +import Control.Exception (assert) +import Data.Either (isRight) +import Control.Applicative ((<|>)) +import Control.Monad ((<=<)) +import Text.Read (readMaybe) + +newtype VariableNameValidator = VariableNameValidator (String -> Bool) + +data Expression a = Add (Expression a) (Expression a) + | Sub (Expression a) (Expression a) + | Mul (Expression a) (Expression a) + | Div (Expression a) (Expression a) + | Neg (Expression a) + | Value a + | Var Variable + deriving (Show) + +newtype Variable = Variable String deriving (Eq, Show) + +newtype VariableValues = VariableValues [(Variable, Int)] -- List, because, let's be honest: AOC Day11 just has one variable. + +-- Evaluates the given expression with the supplied set of variables. Returns Nothing if not all required variables have a value. +evaluateIntExpression :: (Integral a) => Expression a -> VariableValues -> Maybe Int +evaluateIntExpression = undefined + +evaluateFracExpression :: (Fractional a) => Expression a -> VariableValues -> Maybe Int +evaluateFracExpression = undefined + +data ExpressionParseError = MismatchedBrackets + | VariableFailedValidation String + deriving (Show) + +-- Tries to parse the input string as a maths expression. Returns Left in case of parse errors. +tryParseExpression :: (Read a) => VariableNameValidator -> String -> Either ExpressionParseError (Expression a) +tryParseExpression (VariableNameValidator v) = tryParse (VariableNameValidator (\vs -> v vs && internalValidator vs)) <=< (validateBracketPairing . removeAllWhitespace) + where removeAllWhitespace = filter (' ' /=) + + +------------------------------------------------------------------------------------------------------ +-- Private stuff below + +newtype StringWithMatchingBrackets = StringWithMatchingBrackets {getStringWithMatchingBrackets :: String} + +-- To be run exactly once on the input +validateBracketPairing :: String -> Either ExpressionParseError StringWithMatchingBrackets +validateBracketPairing s = if allBracketsMatch 0 s then Right (StringWithMatchingBrackets s) else Left MismatchedBrackets + where allBracketsMatch :: Word -> String -> Bool + allBracketsMatch i [] = i == 0 + allBracketsMatch 0 (')':_) = False + allBracketsMatch i (')':ss) = allBracketsMatch (i-1) ss + allBracketsMatch i ('(':ss) = allBracketsMatch (i+1) ss + allBracketsMatch i (_:ss) = allBracketsMatch i ss + + +removeEnclosingBrackets :: StringWithMatchingBrackets -> StringWithMatchingBrackets +removeEnclosingBrackets (StringWithMatchingBrackets ('(':cs)) | isWholeStringInBrackets 1 cs = removeEnclosingBrackets $ StringWithMatchingBrackets $ init cs + where isWholeStringInBrackets :: Word -> String -> Bool -- Since this is a local function, I think working on String directly is ok... + isWholeStringInBrackets 0 (_:_) = False -- Reached top level of brackets, but string is not at end + isWholeStringInBrackets 0 [] = True + isWholeStringInBrackets i ('(':ss) = isWholeStringInBrackets (i+1) ss + isWholeStringInBrackets i (')':ss) = isWholeStringInBrackets (i-1) ss + isWholeStringInBrackets i (_:ss) = isWholeStringInBrackets i ss +removeEnclosingBrackets s = s + +internalValidator :: String -> Bool +internalValidator st = not (null st) && all (\s -> not (s == '(' || s== ')' || s == '+' || s=='-' || s=='*' || s=='/')) st + +tryParse :: (Read a) => VariableNameValidator -> StringWithMatchingBrackets -> Either ExpressionParseError (Expression a) +tryParse v (StringWithMatchingBrackets s) | assert (isRight $ validateBracketPairing s) False = undefined -- for debugging. Checks invariant of StringWithMatchingBrackets +tryParse v sr = tryMakeBinaryExpression v s + >>= (\x -> fmap (x <|>) (tryMakeUnaryExpression v s) ) + + + + + + `fmap` (<|> tryReadValue s) -- todo: this is wrong!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Should try make Unary first! + + + + + + + + + >>= maybe (tryReadVariable v s) Right + where s = removeEnclosingBrackets sr + +zipEithers :: Either a b -> Either a b -> Either a (b,b) +zipEithers (Left l) _ = Left l +zipEithers _ (Left l) = Left l +zipEithers (Right r1) (Right r2) = Right (r1,r2) + +--tries to parse a +-*/ expression. +tryMakeBinaryExpression :: (Read a) => VariableNameValidator -> StringWithMatchingBrackets -> Either ExpressionParseError (Maybe (Expression a)) +tryMakeBinaryExpression v (StringWithMatchingBrackets s) = mapM (makeBinaryExpression s) $ findLowestPriorityRightMostBinaryOperator s + where makeBinaryExpression :: (Read a1) => String -> Int -> Either ExpressionParseError (Expression a1) + makeBinaryExpression s i = makeOperator operator <$> zipEithers (recurse firstSubExpression) (recurse secondSubExpression) + where (firstSubExpression, operator:secondSubExpression) = splitAt i s + recurse :: (Read a2) => String -> Either ExpressionParseError (Expression a2) + recurse = tryParse v . StringWithMatchingBrackets + makeOperator :: Char -> (Expression a, Expression a) -> Expression a + makeOperator '+' (a,b) = Add a b + makeOperator '-' (a,b) = Sub a b + makeOperator '*' (a,b) = Mul a b + makeOperator '/' (a,b) = Div a b + findLowestPriorityRightMostBinaryOperator :: String -> Maybe Int + findLowestPriorityRightMostBinaryOperator = fLpRmBoWorker Nothing . filterBrackets 0 . zip [0..] + where filterBrackets :: Int -> [(Int, Char)] -> [(Int, Char)] + filterBrackets i ((_,'('):ss) = filterBrackets (i+1) ss + filterBrackets i ((_,')'):ss) = filterBrackets (i-1) ss + filterBrackets 0 (s:ss) = s:filterBrackets 0 ss + filterBrackets 0 [] = [] + filterBrackets i (s:ss) = filterBrackets i ss + + fLpRmBoWorker :: Maybe (Int, Char) -> [(Int, Char)] -> Maybe Int + fLpRmBoWorker f ((0,_):ss) = fLpRmBoWorker f ss -- first character cannot be a binary operator. + fLpRmBoWorker f [] = fst <$> f + fLpRmBoWorker f ((i,c):(j,_):ss) | isOperator c && hasSameOrLowerPrecedence (snd <$> f) c && j==i+1 = fLpRmBoWorker (Just (i,c)) ss -- skip the first character right after operator. If it's another operator, it's unary. + fLpRmBoWorker f ((i,c):ss) | isOperator c && hasSameOrLowerPrecedence (snd <$> f) c = fLpRmBoWorker (Just (i,c)) ss + fLpRmBoWorker f (s:ss) = fLpRmBoWorker f ss -- no operator means just go to next char. + + isOperator :: Char -> Bool + isOperator c = ('+' == c) || ('-' == c) || ('*' == c) || ('/' == c) + + hasSameOrLowerPrecedence :: Maybe Char -> Char -> Bool -- this is not typesafe, but well, it's a local helper, so it's probably fine... + hasSameOrLowerPrecedence Nothing _ = True + hasSameOrLowerPrecedence (Just '/') _ = True + hasSameOrLowerPrecedence (Just '*') c = c == '*' || c == '-' || c == '+' + hasSameOrLowerPrecedence (Just '-') c = c == '-' || c == '+' + hasSameOrLowerPrecedence (Just '+') c = c == '+' + + +--tries to make neg expression +tryMakeUnaryExpression :: (Read a) => VariableNameValidator -> StringWithMatchingBrackets -> Either ExpressionParseError (Maybe (Expression a)) +tryMakeUnaryExpression v (StringWithMatchingBrackets ('-':ss)) = Just . Neg <$> tryParse v (StringWithMatchingBrackets ss) +tryMakeUnaryExpression _ _ = Right Nothing + +--tries to readMaybe. +tryReadValue :: (Read a) => StringWithMatchingBrackets -> Maybe (Expression a) +tryReadValue = fmap Value . readMaybe . getStringWithMatchingBrackets + +tryReadVariable :: VariableNameValidator -> StringWithMatchingBrackets -> Either ExpressionParseError (Expression a) +tryReadVariable (VariableNameValidator v) (StringWithMatchingBrackets s) | v s = Right $ Var (Variable s) +tryReadVariable _ (StringWithMatchingBrackets s) = Left $ VariableFailedValidation s \ No newline at end of file -- cgit v1.2.3