diff --git a/app/Main.hs b/app/Main.hs index 4c6b30f..c80864c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,5 +2,50 @@ module Main (main) where import Lib +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Either (rights, lefts) +import Data.List (intercalate) + +parseInputLine :: Int -> String -> Either ParseError Expression +parseInputLine n s = parseFullString ("stdin:" ++ show n) s + +title :: [String] -> String +title ns = " " ++ intercalate " | " ns + +header :: [Int] -> String +header ws = intercalate "|" . map (flip replicate '-' . (+2) ) $ ws + +row :: [Int] -> [Bool] -> String +row ws rs = intercalate "|" $ (zipWith row' ws rs) + where + row' :: Int -> Bool -> String + row' w b = replicate (left+1) ' ' ++ (if b then "1" else "0") ++ replicate (right+1) ' ' + where + left = (w-1) `div` 2 + right = (w-1) - left + main :: IO () -main = someFunc +main = do + equation_strings <- fmap lines getContents + let equation_expressions = zipWith parseInputLine [0..] equation_strings + +-- TODO: Show proper error messages + _ <- mapM putStrLn . map show . lefts $ equation_expressions + + let variable_names = Set.toAscList . Set.unions . map collectVariableNames . rights $ equation_expressions + let value_combinations = mapM (const [True, False]) [1..length variable_names] + let value_maps = map Map.fromList $ zipWith (zipWith (,)) (cycle [variable_names]) value_combinations + + let expression_strings = variable_names ++ equation_strings + let column_widths = map length expression_strings + + putStrLn . title $ expression_strings + putStrLn . header $ column_widths + + let expressions = rights $ map (parseFullString "") variable_names ++ equation_expressions + + let results = map (\m -> map (evaluate m) expressions) value_maps + + mapM_ putStrLn . map (row column_widths) $ results + diff --git a/package.yaml b/package.yaml index c740158..b40c66a 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,8 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- parsec +- containers ghc-options: - -Wall diff --git a/src/Lib.hs b/src/Lib.hs index d36ff27..e036200 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,6 +1,79 @@ module Lib - ( someFunc + ( parseFullString, evaluate, collectVariableNames, Expression, ParseError ) where -someFunc :: IO () -someFunc = putStrLn "someFunc" +import Text.Parsec +import Text.Parsec.Expr +import Text.Parsec.Token +import Text.Parsec.Language + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.Functor.Identity + +data Expression = Constant Bool | Binary BinaryOperator Expression Expression | Unary UnaryOperator Expression | Variable String + deriving Show +data BinaryOperator = LogicalAnd | LogicalOr + deriving Show +data UnaryOperator = LogicalNot + deriving Show + +def :: GenLanguageDef String u Identity +def = emptyDef{ commentStart = "" + , commentEnd = "" + , identStart = letter <|> char '_' + , identLetter = alphaNum <|> char '_' + , opStart = oneOf "&|~" + , opLetter = oneOf "&|~" + , reservedOpNames = ["&", "|", "~"] + , reservedNames = ["true", "false"] + } + +TokenParser{ parens = m_parens + , identifier = m_identifier + , reservedOp = m_reservedOp + , reserved = m_reserved + , whiteSpace = m_whiteSpace } = makeTokenParser def + +exprparser :: ParsecT String () Identity Expression +exprparser = buildExpressionParser table term "expression" + +table :: [[Operator String u Identity Expression]] +table = [ + [ + Prefix (m_reservedOp "~" >> return (Unary LogicalNot)) + ], + [ + Infix (m_reservedOp "&" >> return (Binary LogicalAnd)) AssocLeft + ], + [ + Infix (m_reservedOp "|" >> return (Binary LogicalOr)) AssocLeft + ] + ] + +term :: ParsecT String () Data.Functor.Identity.Identity Expression +term = m_parens exprparser + <|> fmap Variable (m_identifier) + <|> (m_reserved "true" >> return (Constant True)) + <|> (m_reserved "false" >> return (Constant False)) + "logical expression" + +parseFullString :: SourceName -> String -> Either ParseError Expression +parseFullString = parse (m_whiteSpace *> exprparser <* eof) + +collectVariableNames :: Expression -> Set String +collectVariableNames (Constant _) = Set.empty +collectVariableNames (Binary _ left right) = Set.union (collectVariableNames left) (collectVariableNames right) +collectVariableNames (Unary _ right) = collectVariableNames right +collectVariableNames (Variable name) = Set.singleton name + +evaluate :: Map String Bool -> Expression -> Bool +evaluate _ (Constant b) = b +evaluate vs (Unary LogicalNot e) = not (evaluate vs e) +evaluate vs (Binary LogicalAnd l r) = evaluate vs l && evaluate vs r +evaluate vs (Binary LogicalOr l r) = evaluate vs l || evaluate vs r +evaluate vs (Variable name) = maybe False id (Map.lookup name vs) diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..e60110a --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,13 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + sha256: edbd50d7e7c85c13ad5f5835ae2db92fab1e9cf05ecf85340e2622ec0a303df1 + size: 720020 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/34.yaml diff --git a/wwffwfwf.cabal b/wwffwfwf.cabal index a19ada8..b55eb8e 100644 --- a/wwffwfwf.cabal +++ b/wwffwfwf.cabal @@ -6,6 +6,7 @@ cabal-version: 2.2 name: wwffwfwf version: 0.1.0.0 +synopsis: it's true because it works description: Please see the README on GitHub at homepage: https://github.com/githubuser/wwffwfwf#readme bug-reports: https://github.com/githubuser/wwffwfwf/issues @@ -35,6 +36,8 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , containers + , parsec default-language: Haskell2010 executable wwffwfwf-exe @@ -48,6 +51,8 @@ executable wwffwfwf-exe ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , containers + , parsec , wwffwfwf default-language: Haskell2010 @@ -63,5 +68,7 @@ test-suite wwffwfwf-test ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 + , containers + , parsec , wwffwfwf default-language: Haskell2010