cabal

only doing this because Data.Set is not in the stdlib

lib/Logic/Graph.hs

@@ -0,0 +1,68 @@
+module Logic.Graph where
+
+import Data.Set (Set, insert)
+
+type GetEdges vertex edge = vertex -> [(vertex, edge)]
+type GetEdgesCosts vertex edge cost = vertex -> [((vertex, edge), cost)]
+
+bfs
+  :: (Eq vertex, Ord vertex)
+  => GetEdges vertex edge
+  -> vertex
+  -> vertex
+  -> Maybe [edge]
+bfs getEdges goal start = reverse <$> aux [(start, [])] mempty
+  where
+    aux [] _ = Nothing
+    aux ((vertex, path):queue) visited
+      | vertex == goal = Just path
+      | otherwise =
+        let new = getUnvisitedAdjacent vertex visited
+        in
+          case filter (\(v, _) -> v == goal) new of
+            [] ->
+              let queue' = queue ++ map (\(next, edge) -> (next, edge:path)) new
+              in aux queue' $ insert vertex visited
+            ((_, edge):_) -> Just (edge:path)
+
+    getUnvisitedAdjacent vertex visited =
+      filter (\(next, edge) -> not $ next `elem` visited) $
+      getEdges vertex
+
+{-
+ghci> bfs 10 0 (\x -> [("pred", x-1), ("succ", x+1)])
+Just ["succ","succ","succ","succ","succ","succ","succ","succ","succ","succ"]
+ghci> bfs 13 0 (\x -> [("double", x+x), ("add", x+1)])
+Just ["add","double","add","double","double","add"]
+-}
+
+data VerifyPathError vertex edge
+  = NoSuchEdge vertex edge
+  | GoalNotReached [vertex]
+  deriving Show
+
+verifyPath
+  :: (Eq vertex, Ord vertex, Eq edge)
+  => GetEdges vertex edge
+  -> vertex
+  -> vertex
+  -> [edge]
+  -> Either (VerifyPathError vertex edge) [vertex]
+verifyPath getEdges goal start path =
+  case aux start path of
+    Right (vertices, True) -> Right vertices
+    Right (vertices, False) -> Left $ GoalNotReached vertices
+    Left x -> Left x
+  where
+    aux vertex path' = cons vertex <$>
+      case path' of
+        [] -> Right $
+          if vertex == goal
+          then ([], True)
+          else ([], False)
+        (thisEdge:nextEdges) ->
+          case map fst $ filter (\(next, realEdge) -> realEdge == thisEdge) $ getEdges vertex of
+            [] -> Left $ NoSuchEdge vertex thisEdge
+            (next:_) -> aux next nextEdges
+
+    cons vertex (vertices, bool) = (vertex:vertices, bool)

lib/Logic/Language.hs

@@ -0,0 +1,40 @@
+module Logic.Language where
+
+-- Convenience newtype so strings of symbols are less ugly
+newtype ConcatShowList symbol = ConcatShowList [symbol]
+instance Show symbol => Show (ConcatShowList symbol) where
+  show (ConcatShowList xs) = concat $ map show xs
+
+-- Formal language (/grammar/production system/whatever)
+-- https://en.wikipedia.org/wiki/Post_canonical_system
+class Show symbol => Language symbol where
+  isWellFormed :: [symbol] -> Bool
+
+  -- If Haskell had dependent types these could be generalized.
+
+  -- axiomN : N wffs -> theorem
+  axiom0 :: [TypeAxiom0 symbol]
+  axiom1 :: [TypeAxiom1 symbol]
+  axiom2 :: [TypeAxiom2 symbol]
+  axiom3 :: [TypeAxiom3 symbol]
+
+  axiom0 = []
+  axiom1 = []
+  axiom2 = []
+  axiom3 = []
+
+  -- inferN : N theorems -> theorem
+  -- (axiom0 and infer0 would mean the same thing.)
+  infer1 :: [TypeInfer1 symbol]
+  infer2 :: [TypeInfer2 symbol]
+
+  infer1 = []
+  infer2 = []
+
+type TypeAxiom0 s = [s]
+type TypeAxiom1 s = [s] -> [s]
+type TypeAxiom2 s = [s] -> [s] -> [s]
+type TypeAxiom3 s = [s] -> [s] -> [s] -> [s]
+
+type TypeInfer1 s = [s] -> [[s]]
+type TypeInfer2 s = [s] -> [s] -> [[s]]

lib/Logic/Language/Derivation.hs

@@ -0,0 +1,97 @@
+module Logic.Language.Derivation where
+
+import Logic.Language (Language(..))
+
+data Derivation symbol
+  = Hypothesis [symbol]
+  | Axiom0 Integer
+  | Axiom1 Integer [symbol]
+  | Axiom2 Integer [symbol] [symbol]
+  | Axiom3 Integer [symbol] [symbol] [symbol]
+  | Infer1 Integer Integer (Derivation symbol)
+  | Infer2 Integer Integer (Derivation symbol) (Derivation symbol)
+  deriving Show
+
+data DerivationError s
+  = SelectIndexError (DerivationSelectIndexError s)
+  | ResultIndexError (DerivationResultIndexError s)
+  | NotWellFormed [s]
+  deriving Show
+
+data DerivationSelectIndexError s = DerivationSelectIndexError
+  { dserrSelectPlace :: DerivationSelectIndexErrorPlace
+  , dserrSelectErrorIndex :: Integer
+  , dserrSize :: Int
+  , dserrWffs :: [[s]]
+  } deriving Show
+
+data DerivationSelectIndexErrorPlace
+  = AxiomSelect
+  | InferSelect
+  deriving Show
+
+data DerivationResultIndexError s = DerivationResultIndexError
+  { drerrPlace :: DerivationResultIndexErrorPlace
+  , drerrSelectIndex :: Integer
+  , drerrResultIndex :: Integer
+  , drerrResult :: [[s]]
+  , drerrTheorems :: [[s]]
+  } deriving Show
+
+data DerivationResultIndexErrorPlace
+  = InferResult
+  deriving Show
+
+resolveDerivation :: Language s => Derivation s -> Either (DerivationError s) [s]
+resolveDerivation derivation =
+  case derivation of
+    (Hypothesis wff)
+      | not $ isWellFormed wff -> Left $ NotWellFormed wff
+      | otherwise -> Right wff
+    (Axiom0 index) -> trySelect AxiomSelect axiom0 index []
+    (Axiom1 index wff1)
+      | not $ isWellFormed wff1 -> Left $ NotWellFormed wff1
+      | otherwise -> do
+        rule <- trySelect AxiomSelect axiom1 index [wff1]
+        return $ rule wff1
+    (Axiom2 index wff1 wff2)
+      | not $ isWellFormed wff1 -> Left $ NotWellFormed wff1
+      | not $ isWellFormed wff2 -> Left $ NotWellFormed wff2
+      | otherwise -> do
+        rule <- trySelect AxiomSelect axiom2 index [wff1, wff2]
+        return $ rule wff1 wff2
+    (Axiom3 index wff1 wff2 wff3)
+      | not $ isWellFormed wff1 -> Left $ NotWellFormed wff1
+      | not $ isWellFormed wff2 -> Left $ NotWellFormed wff2
+      | not $ isWellFormed wff3 -> Left $ NotWellFormed wff3
+      | otherwise -> do
+        rule <- trySelect AxiomSelect axiom3 index [wff1, wff2, wff3]
+        return $ rule wff1 wff2 wff3
+    (Infer1 selectIndex resultIndex deriv1) -> do
+      theorem1 <- resolveDerivation deriv1
+      rule <- trySelect InferSelect infer1 selectIndex [theorem1]
+      let result = rule theorem1
+      tryResult InferResult selectIndex resultIndex result [theorem1]
+    (Infer2 selectIndex resultIndex deriv1 deriv2) -> do
+      theorem1 <- resolveDerivation deriv1
+      theorem2 <- resolveDerivation deriv2
+      rule <- trySelect InferSelect infer2 selectIndex [theorem1, theorem2]
+      let result = rule theorem1 theorem2
+      tryResult InferResult selectIndex resultIndex result [theorem1, theorem2]
+  where
+    trySelect place list index wffs = maybe
+      (Left $ SelectIndexError $ DerivationSelectIndexError place index (length list) wffs)
+      Right $
+      get index list
+
+    tryResult place selectIndex resultIndex list theorems = maybe
+      (Left $ ResultIndexError $ DerivationResultIndexError place selectIndex resultIndex list theorems)
+      Right $
+      get resultIndex list
+
+    get :: Integer -> [a] -> Maybe a
+    get 0 (x:xs) = Just x
+    get index [] = Nothing
+    get index (x:xs)
+      | index >= 1 = get (index - 1) xs
+      | otherwise = Nothing

lib/Logic/Language/Impl/L.hs

@@ -0,0 +1,163 @@
+module Logic.Language.Impl.L where
+
+import Logic.Language (Language(..))
+import Logic.Language.Derivation (Derivation(..))
+import Logic.Statement (Statement(..))
+import Logic.Parse
+  ( Parser(..)
+  , ParseError
+  , Input(..)
+  , eof
+  , expected
+  , mkInput
+  , parseToken
+  )
+
+import Control.Applicative (Alternative((<|>)))
+import Data.Either (isRight)
+import Data.Maybe (fromJust, maybeToList)
+import Text.Read (readMaybe)
+
+-- The language L
+data AlphaL
+  = Arrow
+  | Tilde
+  | Open
+  | Close
+  | Variable Integer
+  deriving (Eq, Show)
+
+type StringL = [AlphaL]
+
+instance Language AlphaL where
+  isWellFormed string = isRight $ eof parseL $ mkInput string
+
+  axiom2 = [lAxiom1, lAxiom3]
+  axiom3 = [lAxiom2]
+  infer2 = [lRule1]
+
+-- (A → (B → A))
+lAxiom1 :: StringL -> StringL -> StringL
+lAxiom1 wff1 wff2 =
+  [Open] ++
+    wff1 ++
+  [Arrow] ++
+    [Open] ++ wff2 ++ [Arrow] ++ wff1 ++ [Close] ++
+  [Close]
+
+-- ((A → (B → C)) → ((A → B) → (A → C)))
+lAxiom2 :: StringL -> StringL -> StringL -> StringL
+lAxiom2 wff1 wff2 wff3 =
+  [Open] ++
+    [Open] ++
+      wff1 ++
+    [Arrow] ++
+      [Open] ++ wff2 ++ [Arrow] ++ wff3 ++ [Close] ++
+    [Close] ++
+  [Arrow] ++
+    [Open] ++
+      [Open] ++ wff1 ++ [Arrow] ++ wff2 ++ [Close] ++
+    [Arrow] ++
+      [Open] ++ wff1 ++ [Arrow] ++ wff3 ++ [Close] ++
+    [Close] ++
+  [Close]
+
+-- ((¬A → ¬B) → ((¬A → B) → A))
+lAxiom3 :: StringL -> StringL -> StringL
+lAxiom3 wff1 wff2 =
+  [Open] ++
+    [Open, Tilde] ++ wff1 ++ [Arrow, Tilde] ++ wff2 ++ [Close] ++
+  [Arrow] ++
+    [Open] ++
+      [Open, Tilde] ++ wff1 ++ [Arrow] ++ wff2 ++ [Close] ++
+    [Arrow] ++
+      wff1 ++
+    [Close] ++
+  [Close]
+
+{-
+ghci> import Logic.Statement.Eval (bucket)
+ghci> import Data.Either (fromRight)
+ghci> bucket $ fromRight undefined $ eof parseL $ mkInput $ lAxiom1 [Variable 0] [Variable 1]
+Tautology
+ghci> bucket $ fromRight undefined $ eof parseL $ mkInput $ lAxiom2 [Variable 0] [Variable 1] [Variable 2]
+Tautology
+ghci> bucket $ fromRight undefined $ eof parseL $ mkInput $ lAxiom3 [Variable 0] [Variable 1]
+Tautology
+-}
+
+-- Modus ponens: from (A → B) and A, conclude B.
+lRule1 :: StringL -> StringL -> [StringL]
+lRule1 theorem1 theorem2 = maybeToList $ do
+  s1 <- fromEither $ eof parseL $ mkInput theorem1
+  s2 <- fromEither $ eof parseL $ mkInput theorem2
+  case s1 of
+    Implies s1a s1b
+      | s1a == s2 -> Just $ fromJust $ serializeL s1b
+      | otherwise -> Nothing
+    _ -> Nothing
+  where
+    fromEither = either (const Nothing) Just
+
+{-
+ghci> f x = fromJust $ serializeL $ fromRight undefined $ eof stmt $ mkInput x
+ghci> lRule1 (f "(0->1)") (f "0")
+[[Variable 1]]
+ghci> lRule1 (f "((!0->2)->(!!!!!!!1->1))") (f "(!0->2)")
+[[Open,Tilde,Tilde,Tilde,Tilde,Tilde,Tilde,Tilde,Variable 1,Arrow,Variable 1,Close]]
+ghci> lRule1 (f "((!0->2)->(!!!!!!!1->1))") (f "(!0->3)")
+[]
+-}
+
+parseL :: Parser AlphaL Statement
+parseL = Parser variable <|> Parser tilde <|> arrow <|> fail
+  where
+    variable :: Input AlphaL -> Either ParseError (Statement, Input AlphaL)
+    variable input@(Input pos ((Variable n):xs)) =
+      Right (Atom $ show n, Input (pos + 1) xs)
+    variable input = Left $ expected "statement variable" input
+
+    tilde :: Input AlphaL -> Either ParseError (Statement, Input AlphaL)
+    tilde input@(Input pos (Tilde:xs)) =
+      (\(statement, rest) -> (Not statement, rest)) <$>
+      runParser parseL (Input (pos + 1) xs)
+    tilde input = Left $ expected "negation" input
+
+    arrow :: Parser AlphaL Statement
+    arrow = do
+      _  <- parseToken [Open]
+      s1 <- parseL
+      _  <- parseToken [Arrow]
+      s2 <- parseL
+      _  <- parseToken [Close]
+      return $ Implies s1 s2
+
+    fail :: Parser AlphaL Statement
+    fail = Parser $ \input -> Left $ expected "well-formed formula" input
+
+serializeL :: Statement -> Maybe [AlphaL]
+serializeL (Atom label) = (\x -> [x]) <$> Variable <$> readMaybe label
+serializeL (Not s) = (Tilde:) <$> serializeL s
+serializeL (Implies s1 s2) = do
+  l1 <- serializeL s1
+  l2 <- serializeL s2
+  return $ [Open] ++ l1 ++ [Arrow] ++ l2 ++ [Close]
+serializeL _ = Nothing
+
+deriveLExample1 :: Derivation AlphaL
+deriveLExample1 = step5
+  where
+    step1 = Hypothesis [Open, Variable 1, Arrow, Variable 2, Close]
+    step2 = Axiom2 0 [Open, Variable 1, Arrow, Variable 2, Close] [Variable 0]
+    step3 = Infer2 0 0 step2 step1
+    step4 = Axiom3 0 [Variable 0] [Variable 1] [Variable 2]
+    step5 = Infer2 0 0 step4 step3
+
+deriveLExample2 :: Derivation AlphaL
+deriveLExample2 = step5
+  where
+    step1 = Axiom2 0 [Variable 0] [Open, Variable 0, Arrow, Variable 0, Close]
+    step2 = Axiom3 0 [Variable 0] [Open, Variable 0, Arrow, Variable 0, Close] [Variable 0]
+    step3 = Infer2 0 0 step2 step1
+    step4 = Axiom2 0 [Variable 0] [Variable 0]
+    step5 = Infer2 0 0 step3 step4

lib/Logic/Language/Impl/MIU.hs

@@ -0,0 +1,86 @@
+module Logic.Language.Impl.MIU where
+
+import Logic.Language (Language(..))
+import Logic.Language.Derivation (Derivation(..))
+
+-- The MIU system
+-- (from "Gödel, Escher, Bach: An Eternal Golden Braid" by Douglas Hofstadter)
+data AlphaMIU
+  = M
+  | I
+  | U
+  deriving Show
+
+type StringMIU = [AlphaMIU]
+
+instance Language AlphaMIU where
+  isWellFormed (M:_) = True
+  isWellFormed _ = False
+
+  axiom0 = [[M, I]]
+  infer1 =
+    [ miuRule1
+    , miuRule2
+    , miuRule3
+    , miuRule4
+    ]
+
+-- RULE I: If you possess a string whose last letter is I, you can add on a U at the end.
+miuRule1 :: StringMIU -> [StringMIU]
+miuRule1 [I] = [[I, U]]
+miuRule1 (x:xs) = (x:) <$> miuRule1 xs
+miuRule1 _ = []
+
+-- RULE II: Suppose you have Mx. Then you may add Mxx to your collection.
+miuRule2 :: StringMIU -> [StringMIU]
+miuRule2 string@(M:xs) = [string ++ xs]
+miuRule2 _ = []
+
+-- RULE III: If III occurs in one of the strings in your collection, you may
+-- make a new string with U in place of III.
+miuRule3 :: StringMIU -> [StringMIU]
+miuRule3 string@(M:xs) = (M:) <$> aux xs
+  where
+    aux (x@I:xs@(I:I:xs')) = (U:xs'):((x:) <$> aux xs)
+    aux (x:xs) = (x:) <$> aux xs
+    aux _  = []
+miuRule3 _ = []
+
+-- RULE IV: If UU occurs inside one of your strings, you can drop it.
+miuRule4 :: StringMIU -> [StringMIU]
+miuRule4 string@(M:xs) = (M:) <$> aux xs
+  where
+    aux (x@U:xs@(U:xs')) = xs':((x:) <$> aux xs)
+    aux (x:xs) = (x:) <$> aux xs
+    aux _ = []
+miuRule4 _ = []
+
+{-
+ghci> import Logic.Language (ConcatShowList(..))
+ghci> map ConcatShowList infer0 :: [ConcatShowList AlphaMIU]
+[MI]
+ghci> map ConcatShowList $ concat $ map ($ [M, I, I, I, I, U, U, I]) infer1
+[MIIIIUUIU,MIIIIUUIIIIIUUI,MUIUUI,MIUUUI,MIIIII]
+-}
+
+deriveMIIUII :: Derivation AlphaMIU
+deriveMIIUII =
+  Infer1 3 0 $
+  Infer1 2 2 $
+  Infer1 0 0 $
+  Infer1 3 0 $
+  Infer1 3 0 $
+  Infer1 2 2 $
+  Infer1 1 0 $
+  Infer1 2 5 $
+  Infer1 0 0 $
+  Infer1 1 0 $
+  Infer1 1 0 $
+  Infer1 1 0 $
+  Axiom0 0
+
+{-
+ghci> import Logic.Language.Derivation (resolveDerivation)
+ghci> ConcatShowList <$> resolveDerivation deriveMIIUII
+Right MIIUII
+-}

lib/Logic/Parse.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE TupleSections #-}
+
+module Logic.Parse where
+
+import Control.Applicative (Alternative(..))
+
+newtype Parser symbol output = Parser
+  { runParser :: Input symbol -> Either ParseError (output, Input symbol)
+  }
+
+data Input symbol = Input
+  { inputPos :: Int
+  , inputSeq :: [symbol]
+  } deriving Show
+
+mkInput :: [symbol] -> Input symbol
+mkInput = Input 0
+
+data ParseError =
+  ParseError Int String
+  deriving Show
+
+expected :: Show s => String -> Input s -> ParseError
+expected thing input = ParseError (inputPos input) $
+  "expected " <> thing <> ", found " <> show (take 20 $ inputSeq input)
+
+eof :: Show symbol => Parser symbol a -> Input symbol -> Either ParseError a
+eof p input = do
+  (result, rest) <- runParser p input
+  case inputSeq rest of
+    [] -> Right result
+    _ -> Left $ expected "end of input" rest
+
+instance Functor (Parser s) where
+  fmap :: (a -> b) -> Parser symbol a -> Parser symbol b
+  fmap f (Parser p) = Parser $ \input -> do
+    (result, rest) <- p input
+    return (f result, rest)
+
+instance Applicative (Parser s) where
+  pure :: a -> Parser s a
+  pure result = Parser $ \input -> Right (result, input)
+
+  (<*>) :: Parser s (a -> b) -> Parser s a -> Parser s b
+  (Parser p1) <*> (Parser p2) =
+    Parser $ \input -> do
+      (f, rest) <- p1 input
+      (result, rest') <- p2 rest
+      return (f result, rest')
+
+instance Alternative (Parser s) where
+  empty :: Parser s a
+  empty = Parser $ const empty
+
+  (<|>) :: Parser s a -> Parser s a -> Parser s a
+  (Parser p1) <|> (Parser p2) =
+    Parser $ \input -> p1 input <|> p2 input
+
+instance Alternative (Either ParseError) where
+  empty :: Either ParseError a
+  empty = Left $ ParseError 0 "this parser always fails"
+
+  (<|>) :: Either ParseError a -> Either ParseError a -> Either ParseError a
+  (Right x) <|> _ = Right x
+  (Left _) <|> e = e
+
+instance Monad (Parser s) where
+  (>>=) :: Parser s a -> (a -> Parser s b) -> Parser s b
+  p1 >>= next = Parser $ \input ->
+    case runParser p1 input of
+      Right (result, rest) -> runParser (next result) rest
+      Left err -> Left err
+
+parseToken :: (Eq s, Show s) => [s] -> Parser s [s]
+parseToken token = Parser parse
+  where
+    n = length token
+    parse input@(Input pos xs)
+      | token == take n xs = Right $ (token,) $ Input (pos + n) (drop n xs)
+      | otherwise = Left $ expected (show token) input
+
+parseIf :: Show s => String -> (s -> Bool) -> Parser s s
+parseIf description check = Parser $ \input@(Input pos xs) ->
+  case xs of
+    [] -> Left $ ParseError pos "unexpected end of input"
+    (char:chars)
+      | check char -> Right $ (char,) $ Input (pos + 1) chars
+      | otherwise -> Left $ expected description input

lib/Logic/Statement.hs

@@ -0,0 +1,30 @@
+module Logic.Statement where
+
+import Data.Set (singleton, union, toAscList)
+
+data Statement
+  = Atom String
+  | Not Statement
+  | And Statement Statement
+  | Or Statement Statement
+  | Implies Statement Statement
+  | Iff Statement Statement
+  deriving (Eq, Ord, Show)
+
+atoms :: Statement -> [String]
+atoms = toAscList . mkSet
+  where
+    mkSet (Atom key)      = singleton key
+    mkSet (Not s)         = mkSet s
+    mkSet (And s1 s2)     = union (mkSet s1) (mkSet s2)
+    mkSet (Or s1 s2)      = union (mkSet s1) (mkSet s2)
+    mkSet (Implies s1 s2) = union (mkSet s1) (mkSet s2)
+    mkSet (Iff s1 s2)     = union (mkSet s1) (mkSet s2)
+
+substatements :: Statement -> [Statement]
+substatements s@(Atom _) = [s]
+substatements s@(Not s1) = s:(substatements s1)
+substatements s@(And s1 s2)     = (s:) $ substatements s1 ++ substatements s2
+substatements s@(Or s1 s2)      = (s:) $ substatements s1 ++ substatements s2
+substatements s@(Implies s1 s2) = (s:) $ substatements s1 ++ substatements s2
+substatements s@(Iff s1 s2)     = (s:) $ substatements s1 ++ substatements s2

lib/Logic/Statement/Eval.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE TupleSections #-}
+
+module Logic.Statement.Eval where
+
+import Logic.Statement (Statement(..), atoms)
+
+import Data.Either (fromRight)
+
+data Bucket
+  = Tautology
+  | Contradiction
+  | Contingent
+  deriving (Eq, Show)
+
+bucket :: Statement -> Bucket
+bucket s
+  | and values = Tautology
+  | all not values = Contradiction
+  | otherwise = Contingent
+  where
+    values = [fromRight undefined $ eval assignments s | assignments <- enumerate $ atoms s]
+
+eval :: [(String, Bool)] -> Statement -> Either String Bool
+eval assignments = aux
+  where
+    aux (Atom key)      = maybe (Left key) Right $ lookup key assignments
+    aux (Not s)         = not <$> aux s
+    aux (And s1 s2)     = (&&) <$> aux s1 <*> aux s2
+    aux (Or s1 s2)      = (||) <$> aux s1 <*> aux s2
+    aux (Implies s1 s2) = not <$> ((&&) <$> aux s1 <*> (not <$> aux s2))
+    aux (Iff s1 s2)     = (==) <$> aux s1 <*> aux s2
+
+enumerate :: [a] -> [[(a, Bool)]]
+enumerate keys = map reverse $ aux start
+  where
+    aux assignments = (assignments:) $
+      case next assignments of
+        Nothing -> []
+        Just (assignments') -> aux assignments'
+
+    start = map (, False) keys
+
+    next [] = Nothing
+    next ((key, False):rest) = Just $ (key, True):rest
+    next ((key, True):rest) = ((key, False):) <$> (next rest)
+
+implies :: Bool -> Bool -> Bool
+implies b1 b2 = not b1 || b2

lib/Logic/Statement/Laws.hs

@@ -0,0 +1,355 @@
+module Logic.Statement.Laws where
+
+import Logic.Parse (eof, mkInput)
+import Logic.Statement (Statement(..))
+import Logic.Statement.Parse (stmt)
+import Logic.Statement.Serialize (serialize, SerializeFormat(Plain))
+import Logic.Graph (bfs, verifyPath, VerifyPathError)
+
+import Data.Either (fromRight, rights)
+import Data.Maybe (fromJust, listToMaybe)
+
+data Law = Law
+  { lawName :: String
+  , lawLhs :: Statement
+  , lawRhs :: Statement
+  }
+
+instance Eq Law where
+  law1 == law2 =
+    lawLhs law1 == lawLhs law2
+    && lawRhs law1 == lawRhs law2
+
+instance Show Law where
+  show law =
+    "Law{"
+    <> lawName law
+    <> ": "
+    <> serialize Plain (lawLhs law)
+    <> " <=> "
+    <> serialize Plain (lawRhs law)
+    <> "}"
+
+mkLaw :: String -> String -> String -> Law
+mkLaw name lhs rhs = Law name (fromString lhs) (fromString rhs)
+  where
+    fromString :: String -> Statement
+    fromString string = fromRight undefined $ eof stmt $ mkInput string
+
+laws :: [Law]
+laws =
+  [ mkLaw "dbl_neg"         "A"         "!!A"
+  , mkLaw "and_comm"        "(A&B)"     "(B&A)"
+  , mkLaw "or_comm"         "(A|B)"     "(B|A)"
+  , mkLaw "and_assoc"       "(A&(B&C))" "((A&B)&C)"
+  , mkLaw "or_assoc"        "(A|(B|C))" "((A|B)|C)"
+  , mkLaw "and_or_distrib"  "(A&(B|C))" "((A&B)|(A&C))"
+  , mkLaw "or_and_distrib"  "(A|(B&C))" "((A|B)&(A|C))"
+  , mkLaw "and_symm_eq"     "A"         "(A&A)"
+  , mkLaw "or_symm_eq"      "A"         "(A|A)"
+  , mkLaw "not_and_distrib" "!(A&B)"    "(!A|!B)"
+  , mkLaw "not_or_distrib"  "!(A|B)"    "(!A&!B)"
+  , mkLaw "implies_or"      "(A->B)"    "(!A|B)"
+  , mkLaw "implies_and"     "(A->B)"    "!(A&!B)"
+  , mkLaw "or_contr_eq"     "A"         "(A|(B&!B))"
+  , mkLaw "and_or_cancel"   "A"         "(A&(A|B))"
+  , mkLaw "or_and_cancel"   "A"         "(A|(A&B))"
+  , mkLaw "iff_and"         "(A<->B)"   "((A->B)&(B->A))"
+  , mkLaw "iff_or"          "(A<->B)"   "((A&B)|(!A&!B))"
+  ]
+
+{-
+ghci> import Logic.Statement.Eval (bucket, Bucket(Tautology))
+ghci> all (== Tautology) $ map (\law -> bucket $ Iff (lawLhs law) (lawRhs law)) laws
+True
+-}
+
+lookupLaw :: String -> Maybe Law
+lookupLaw name = listToMaybe $ filter (\law -> lawName law == name) laws
+
+match
+  :: Statement
+  -- ^ pattern
+  -> Statement
+  -- ^ statement to search within
+  -> Maybe [(String, Statement)]
+  -- ^ mapping from pattern-statement atoms to search-statement parts
+match = aux []
+  where
+    aux
+      :: [(String, Statement)]
+      -> Statement
+      -> Statement
+      -> Maybe [(String, Statement)]
+    aux mapping (Atom key) s = add mapping (key, s)
+    aux mapping (Not p) (Not s) = aux mapping p s
+    aux mapping (And     p1 p2) (And     s1 s2) = binary mapping (p1, s1) (p2, s2)
+    aux mapping (Or      p1 p2) (Or      s1 s2) = binary mapping (p1, s1) (p2, s2)
+    aux mapping (Implies p1 p2) (Implies s1 s2) = binary mapping (p1, s1) (p2, s2)
+    aux mapping (Iff     p1 p2) (Iff     s1 s2) = binary mapping (p1, s1) (p2, s2)
+    aux mapping pattern s = Nothing
+
+    add
+      :: [(String, Statement)]
+      -> (String, Statement)
+      -> Maybe [(String, Statement)]
+    add mapping entry@(key, s') =
+      case lookup key mapping of
+        Nothing -> Just (entry:mapping)
+        Just existing
+          | existing == s' -> Just mapping
+          | otherwise -> Nothing
+
+    binary
+      :: [(String, Statement)]
+      -> (Statement, Statement)
+      -> (Statement, Statement)
+      -> Maybe [(String, Statement)]
+    binary mapping (p1, s1) (p2, s2) = do
+      mapping' <- aux mapping p1 s1
+      aux mapping' p2 s2
+
+{-
+ghci> f x = fromRight undefined $ eof stmt $ mkInput x
+ghci> match (f "(A&B)") (f "(p&(q|r))")
+Just [("B",Or (Atom "q") (Atom "r")),("A",Atom "p")]
+ghci> match (f "((A&B)|A)") (f "(p&(q|r))")
+Nothing
+ghci> match (f "((A&B)|A)") (f "((p&(q|r))|p)")
+Just [("B",Or (Atom "q") (Atom "r")),("A",Atom "p")]
+ghci> match (f "((A&B)|A)") (f "((p&(q|r))|q)")
+Nothing
+ghci> l = fromJust $ lookupLaw "and_or_distrib"
+ghci> l
+Law {lawName = "and_or_distrib", lawLhs = And (Atom "A") (Or (Atom "B") (Atom "C")), lawRhs = Or (And (Atom "A") (Atom "B")) (And (Atom "A") (Atom "C"))}
+ghci> match (lawLhs l) (f "(p&(q|r))")
+Just [("C",Atom "r"),("B",Atom "q"),("A",Atom "p")]
+-}
+
+data SwapError
+  = IndeterminateSwap
+  -- ^ An atom in p2 doesn't exist in p1.
+  -- Strictly: an atom in p2 doesn't exist in the result from `match`
+  -- (matters only if `match` is implemented incorrectly).
+  -- Theoretically if for atoms we used terms of a type instead of strings, we
+  -- could avoid needing this error, but I think we still wouldn't be able
+  -- to return a mapping from atom-type-1 to atom-type-2 in a type safe way.
+  | NonMatchingPattern
+  deriving Show
+
+swap :: Statement -> Statement -> Statement -> Either SwapError Statement
+swap p1 p2 s = do
+  mapping <- maybe (Left NonMatchingPattern) Right $ match p1 s
+  maybe (Left IndeterminateSwap) Right $ aux mapping p2
+  where
+    aux :: [(String, Statement)] -> Statement -> Maybe Statement
+    aux mapping (Atom key) = lookup key mapping
+    aux mapping (Not p) = Not <$> aux mapping p
+    aux mapping (And     p1 p2) = And     <$> aux mapping p1 <*> aux mapping p2
+    aux mapping (Or      p1 p2) = Or      <$> aux mapping p1 <*> aux mapping p2
+    aux mapping (Implies p1 p2) = Implies <$> aux mapping p1 <*> aux mapping p2
+    aux mapping (Iff     p1 p2) = Iff     <$> aux mapping p1 <*> aux mapping p2
+
+{-
+ghci> f x = fromRight undefined $ eof stmt $ mkInput x
+ghci> l = fromJust $ lookupLaw "and_or_distrib"
+ghci> l
+Law {lawName = "and_or_distrib", lawLhs = And (Atom "A") (Or (Atom "B") (Atom "C")), lawRhs = Or (And (Atom "A") (Atom "B")) (And (Atom "A") (Atom "C"))}
+ghci> 
+ghci> match (f "(A&B)") (f "(p&(q|r))")
+Just [("B",Or (Atom "q") (Atom "r")),("A",Atom "p")]
+ghci> swap (f "(A&B)") (f "A") (f "(p&(q|r))")
+Right (Atom "p")
+ghci> swap (f "(A&B)") (f "B") (f "(p&(q|r))")
+Right (Or (Atom "q") (Atom "r"))
+ghci> swap (f "(A&B)") (f "C") (f "(p&(q|r))")
+Left Indeterminate
+ghci> swap (f "((A&B)->C)") (f "A") (f "(p&(q|r))")
+Left NonMatchingPattern
+ghci> 
+ghci> x = f "(p&(q|r))"
+ghci> x
+And (Atom "p") (Or (Atom "q") (Atom "r"))
+ghci> serialize Plain x
+"(p&(q|r))"
+ghci> serialize Plain $ fromRight undefined $ swap (lawLhs l) (lawLhs l) x
+"(p&(q|r))"
+ghci> serialize Plain $ fromRight undefined $ swap (lawLhs l) (lawRhs l) x
+"((p&q)|(p&r))"
+ghci> 
+ghci> x = f "(p&(!q|r))"
+ghci> serialize Plain x
+"(p&(!q|r))"
+ghci> serialize Plain $ fromRight undefined $ swap (lawLhs l) (lawLhs l) x
+"(p&(!q|r))"
+ghci> serialize Plain $ fromRight undefined $ swap (lawLhs l) (lawRhs l) x
+"((p&!q)|(p&r))"
+-}
+
+data ReplaceError
+  = IndeterminateReplace
+  deriving Show
+
+replace :: Statement -> Statement -> Statement -> Either ReplaceError [Statement]
+replace p1 p2 = firstLeft . aux
+  where
+    aux :: Statement -> [Either ReplaceError Statement]
+    aux s =
+      case swap p1 p2 s of
+        Left IndeterminateSwap -> [Left IndeterminateReplace]
+        -- ^ terminate here because in `replace` we stop at the first Left
+        Left NonMatchingPattern -> deeper s
+        Right s' -> (Right s'):(deeper s)
+
+    deeper :: Statement -> [Either ReplaceError Statement]
+    deeper (Atom key) = []
+    deeper (Not s) = do
+      e <- aux s
+      return $ Not <$> e
+    deeper (And     s1 s2) = binary And     s1 s2
+    deeper (Or      s1 s2) = binary Or      s1 s2
+    deeper (Implies s1 s2) = binary Implies s1 s2
+    deeper (Iff     s1 s2) = binary Iff     s1 s2
+
+    binary constructor s1 s2 =
+      [constructor <$> e1 <*> (Right s2) | e1 <- aux s1] ++
+      [constructor <$> (Right s1) <*> e2 | e2 <- aux s2]
+
+firstLeft :: [Either a b] -> Either a [b]
+firstLeft [] = Right []
+firstLeft ((Left a):_) = Left a
+firstLeft ((Right b):xs) = (b:) <$> firstLeft xs
+
+data Direction
+  = Forward
+  | Reverse
+  deriving (Eq, Show)
+
+data LawsGraphEdge = LawsGraphEdge
+  { lgeDirection :: Direction
+  , lgeIndex :: Integer
+  , lgeLaw :: Law
+  } deriving Eq
+
+instance Show LawsGraphEdge where
+  show edge =
+    "LawsGraphEdge{"
+    <> (
+      case lgeDirection edge of
+        Forward -> "> "
+        Reverse -> "< "
+    )
+    <> lawName (lgeLaw edge)
+    <> " "
+    <> show (lgeIndex edge)
+    <> "}"
+
+bfsLaws :: Statement -> Statement -> Maybe [LawsGraphEdge]
+bfsLaws = bfs getLawsGraphEdges
+
+getLawsGraphEdges :: Statement -> [(Statement, LawsGraphEdge)]
+getLawsGraphEdges s = concat $ rights $ map aux laws
+  -- ^ `rights` here because we can't apply
+  -- e.g. or_contr_eq forwards without inventing B
+  -- and the `Left` case is `Left IndeterminateReplace`
+  where
+    aux :: Law -> Either ReplaceError [(Statement, LawsGraphEdge)]
+    aux law = do
+      forward <- edges Forward law
+      reverse <- edges Reverse law
+      return $ forward ++ reverse
+
+    replaceds :: Direction -> Law -> Either ReplaceError [Statement]
+    replaceds direction law =
+      let
+        (pattern1, pattern2) =
+          case direction of
+            Forward -> (lawLhs law, lawRhs law)
+            Reverse -> (lawRhs law, lawLhs law)
+      in replace pattern1 pattern2 s
+
+    mkEdges :: Direction -> Law -> [Statement] -> [(Statement, LawsGraphEdge)]
+    mkEdges direction law statements = do
+      (index, s') <- zip [0..] statements
+      return (s', LawsGraphEdge direction index law)
+
+    edges :: Direction -> Law -> Either ReplaceError [(Statement, LawsGraphEdge)]
+    edges direction law = mkEdges direction law <$> replaceds direction law
+
+{-
+ghci> fromString x = fromRight undefined $ eof stmt $ mkInput x
+ghci> niceEdges = map (\edge -> (if lgeReverse edge then "< " else "> ") <> lawName (lgeLaw edge) <> " " <> show (lgeIndex edge))
+ghci> 
+ghci> niceEdges <$> bfsLaws (fromString "(p|!q)") (fromString "(p|!q)")
+Just []
+ghci> niceEdges <$> bfsLaws (fromString "!!(p|!q)") (fromString "(p|!q)")
+Just ["> dbl_neg 0"]
+ghci> niceEdges <$> bfsLaws (fromString "(!!p|!q)") (fromString "(p|!q)")
+Just ["> dbl_neg 1"]
+ghci> niceEdges <$> bfsLaws (fromString "(p|!!!q)") (fromString "(p|!q)")
+Just ["> dbl_neg 2"]
+ghci> niceEdges <$> bfsLaws (fromString "(p|p)") (fromString "p")
+Just ["> or_symm_eq 0"]
+ghci> niceEdges <$> bfsLaws (fromString "p") (fromString "(p|p)")
+Just ["< or_symm_eq 0"]
+ghci> 
+ghci> niceEdges <$> bfsLaws (fromString "!(!p&(q|q))") (fromString "(p|!q)")
+Just ["> dbl_neg 1","> or_symm_eq 5","< not_and_distrib 0"]
+ghci> niceEdges <$> bfsLaws (fromString "!(!(p&p)&(q|q))") (fromString "(p|!q)")
+Just ["> dbl_neg 1","> and_symm_eq 3","> or_symm_eq 7","< not_and_distrib 0"]
+ghci> 
+ghci> import Data.Time.POSIX (getPOSIXTime)
+ghci> time f = getPOSIXTime >>= \t0 -> f >> getPOSIXTime >>= \t1 -> return $ t1 - t0
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "p") (fromString "p")
+Just []
+0.000087114s
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "!!p") (fromString "p")
+Just ["> dbl_neg 0"]
+0.000201159s
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "!!!!p") (fromString "p")
+Just ["> dbl_neg 0","> dbl_neg 0"]
+0.000444047s
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "!!!!!!p") (fromString "p")
+Just ["> dbl_neg 0","> dbl_neg 0","> dbl_neg 0"]
+0.001260947s
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "!!!!!!!!p") (fromString "p")
+Just ["> dbl_neg 0","> dbl_neg 0","> dbl_neg 0","> dbl_neg 0"]
+0.021864298s
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "!!!!!!!!!!p") (fromString "p")
+Just ["> dbl_neg 0","> dbl_neg 0","> dbl_neg 0","> dbl_neg 0","> dbl_neg 0"]
+3.244101767s
+ghci> time $ putStrLn $ show $ niceEdges <$> bfsLaws (fromString "!!!!!!!!!!!!p") (fromString "p")
+Just ["> dbl_neg 0","> dbl_neg 0","> dbl_neg 0","> dbl_neg 0","> dbl_neg 0","> dbl_neg 0"]
+3066.211460539s
+-}
+
+data LawsGraphPath = LawsGraphPath
+  { lgpStart :: Statement
+  , lgpGoal :: Statement
+  , lgpEdges :: [LawsGraphEdge]
+  } deriving Show
+
+verifyLawsPath
+  :: LawsGraphPath
+  -> Either (VerifyPathError Statement LawsGraphEdge) [Statement]
+verifyLawsPath path =
+  verifyPath getLawsGraphEdges (lgpGoal path) (lgpStart path) (lgpEdges path)
+
+lawsPathExample1 :: LawsGraphPath
+lawsPathExample1 = LawsGraphPath start goal edges
+  where
+    start = Implies (Atom "p") (Atom "q")
+    goal = Implies (Not (Atom "q")) (Not (Atom "p"))
+    edges =
+      [ LawsGraphEdge Forward 1 $ law "dbl_neg"
+      , LawsGraphEdge Forward 0 $ law "implies_and"
+      , LawsGraphEdge Forward 0 $ law "and_comm"
+      , LawsGraphEdge Reverse 0 $ law "implies_and"
+      ]
+    law = fromJust . lookupLaw
+
+{-
+ghci> import Logic.Statement.Serialize (serialize, SerializeFormat(..))
+ghci> map (serialize Plain) <$> verifyLawsPath lawsPathExample1
+Right ["(p->q)","(!!p->q)","!(!!p&!q)","!(!q&!!p)","(!q->!p)"]
+-}

lib/Logic/Statement/Parse.hs

@@ -0,0 +1,52 @@
+module Logic.Statement.Parse where
+
+import Logic.Parse
+  ( Parser(..)
+  , Input(..)
+  , expected
+  , parseToken
+  , parseIf
+  )
+import Logic.Statement (Statement(..))
+
+import Control.Applicative (Alternative((<|>), some))
+import Data.Char (isAlphaNum)
+
+stmtAtom :: Parser Char Statement
+stmtAtom = Atom <$> parse
+  where
+    parse = some $ parseIf "variable name" $ \char -> isAlphaNum char || char == '_'
+
+stmtNot :: Parser Char Statement
+stmtNot = Not <$> (parseToken "!" *> stmt)
+
+stmtBinary :: Parser Char Statement
+stmtBinary = do
+  _  <- parseToken "("
+  s1 <- stmt
+  constructor <- parseConnective
+  s2 <- stmt
+  _  <- parseToken ")"
+  return $ constructor s1 s2
+  where
+    parseConnective =
+      fmap (const And) (parseToken "&")
+      <|> fmap (const Or) (parseToken "|")
+      <|> fmap (const Implies) (parseToken "->")
+      <|> fmap (const Iff) (parseToken "<->")
+      <|> fail
+
+    fail = Parser $ \input -> Left $ expected "connective" input
+
+stmt :: Parser Char Statement
+stmt = Parser $ \input ->
+  let
+    parser =
+      case inputSeq input of
+        [] -> fail
+        ('!':_) -> stmtNot
+        ('(':_) -> stmtBinary
+        _ -> stmtAtom <|> fail
+  in runParser parser input
+  where
+    fail = Parser $ \input -> Left $ expected "statement" input

lib/Logic/Statement/Serialize.hs

@@ -0,0 +1,173 @@
+module Logic.Statement.Serialize where
+
+import Logic.Statement (Statement(..), atoms)
+import Logic.Statement.Eval (enumerate, eval, implies)
+
+import Data.List (intercalate)
+import Data.Either (fromRight)
+
+data TokenString = TokenString
+  { tsCanEval :: CanEval
+  , tsLevel :: Int
+  , tsString :: String
+  } deriving Show
+
+data CanEval
+  = Filler
+  | CanEval
+  deriving Show
+
+data TokenValue = TokenValue
+  { tvLevel :: Int
+  , tvValue :: Value
+  } deriving Show
+
+data Value
+  = NoValue
+  | Value Bool
+  deriving Show
+
+data SerializeFormat
+  = Plain
+  | Latex
+--  | PrefixPlain
+  deriving Show
+
+serialize :: SerializeFormat -> Statement -> String
+serialize fmt s = concat $ map tsString $ serializeStrings fmt s
+
+serializeStrings :: SerializeFormat -> Statement -> [TokenString]
+serializeStrings fmt = aux 0
+  where
+    aux :: Int -> Statement -> [TokenString]
+    aux =
+      case fmt of
+        Plain -> serializeStringsPlain
+        Latex -> serializeStringsLatex
+
+-- Internal function
+serializeStringsPlain :: Int -> Statement -> [TokenString]
+serializeStringsPlain level = aux
+  where
+    f = serializeStringsPlain
+    level' = level + 1
+
+    aux (Atom key)      = [TokenString CanEval level key]
+    aux (Not s)         = [TokenString CanEval level "!"] ++ f level' s
+    aux (And s1 s2)     = connective level "&"   (f level' s1) (f level' s2)
+    aux (Or s1 s2)      = connective level "|"   (f level' s1) (f level' s2)
+    aux (Implies s1 s2) = connective level "->"  (f level' s1) (f level' s2)
+    aux (Iff s1 s2)     = connective level "<->" (f level' s1) (f level' s2)
+
+-- Internal function
+serializeStringsLatex :: Int -> Statement -> [TokenString]
+serializeStringsLatex level = aux
+  where
+    f = serializeStringsLatex
+    level' = level + 1
+
+    aux (Atom key)      = [TokenString CanEval level key]
+    aux (Not s)         = [TokenString CanEval level "\\neg "] ++ f level' s
+    aux (And s1 s2)     = connective level "\\land "           (f level' s1) (f level' s2)
+    aux (Or s1 s2)      = connective level "\\lor "            (f level' s1) (f level' s2)
+    aux (Implies s1 s2) = connective level "\\to "             (f level' s1) (f level' s2)
+    aux (Iff s1 s2)     = connective level "\\leftrightarrow " (f level' s1) (f level' s2)
+
+-- Internal function
+connective :: Int -> String -> [TokenString] -> [TokenString] -> [TokenString]
+connective level middle tokens1 tokens2 =
+  [TokenString Filler level "("]
+  ++ tokens1
+  ++ [TokenString CanEval level middle]
+  ++ tokens2
+  ++ [TokenString Filler level ")"]
+
+-- Using infix convention with brackets
+serializeValues :: [(String, Bool)] -> Statement -> Either String [TokenValue]
+serializeValues ass = fmap snd . aux 0
+  where
+    aux :: Int -> Statement -> Either String (Bool, [TokenValue])
+    aux level s@(Atom key) = do
+      bool <- eval ass s
+      return (bool, [TokenValue level $ Value bool])
+    aux level (Not s) = do
+      (bool, tokens) <- aux (level + 1) s
+      return (not bool, [TokenValue level $ Value $ not bool] ++ tokens)
+    aux level (And s1 s2)     = connective level (&&) s1 s2
+    aux level (Or s1 s2)      = connective level (||) s1 s2
+    aux level (Implies s1 s2) = connective level implies s1 s2
+    aux level (Iff s1 s2)     = connective level (==) s1 s2
+
+    connective
+      :: Int
+      -> (Bool -> Bool -> Bool)
+      -> Statement
+      -> Statement
+      -> Either String (Bool, [TokenValue])
+    connective level f s1 s2 = do
+      (bool1, tokens1) <- aux (level + 1) s1
+      (bool2, tokens2) <- aux (level + 1) s2
+      let bracket = [TokenValue level NoValue]
+      let bool = f bool1 bool2
+      return (bool, bracket ++ tokens1 ++ [TokenValue level $ Value bool] ++ tokens2 ++ bracket)
+
+serializeLatexTruthTable :: Statement -> String
+serializeLatexTruthTable s = open <> header <> "\\hline\n" <> body <> close
+  where
+    open :: String
+    open = "\\begin{tabular}{" <> replicate (length $ atoms s) 'c' <> "||" <> spec <> "}\n"
+
+    close :: String
+    close = "\\end{tabular}\n"
+
+    spec :: String
+    spec
+      | length serial == 0 = undefined
+      | length serial == 1 = "c"
+      | isMain (head serial) = "c|" <> replicate (length serial - 1) 'c'
+      | isMain (serial !! (length serial - 1)) = replicate (length serial - 1) 'c' <> "|c"
+      | otherwise = concat $ map (\token -> if isMain token then "|c|" else "c") serial
+
+    isMain :: TokenString -> Bool
+    isMain (TokenString CanEval level string) = level == 0
+    isMain _ = False
+
+    serial :: [TokenString]
+    serial = serializeStrings Latex s
+
+    header :: String
+    header =
+      intercalate " & " (map dollars $ atoms s) <>
+      " & " <>
+      intercalate " & " (map dollars $ map tsString serial) <>
+      " \\\\\n"
+
+    dollars :: String -> String
+    dollars string = "$" <> string <> "$"
+
+    body :: String
+    body = concat $ map line $ enumerate $ atoms s
+
+    line :: [(String, Bool)] -> String
+    line ass =
+      intercalate " & " (bools ass) <>
+      " & " <>
+      intercalate " & " (cells ass) <>
+      "\\\\\n"
+
+    bools :: [(String, Bool)] -> [String]
+    bools ass = [if bool then "1" else "0" | (key, bool) <- ass]
+
+    cells :: [(String, Bool)] -> [String]
+    cells ass = map cell $ fromRight undefined $ serializeValues ass s
+
+    cell :: TokenValue -> String
+    cell (TokenValue level value) =
+      case value of
+        NoValue -> ""
+        Value bool -> mkBold level $ if bool then "1" else "0"
+
+    mkBold :: Int -> String -> String
+    mkBold level string
+      | level == 0 = "\\textbf " <> string
+      | otherwise = string

lib/Logic/readme.md

@@ -0,0 +1,58 @@
+things that are in here:
+
+## general things
+
+### [Logic.Parse](Parse.hs)
+
+- generic sequence parser
+
+### [Logic.Graph](Graph.hs)
+
+- generic breadth-first search
+- verify graph paths reach the goal and have all extant edges
+
+## statement things
+
+### [Logic.Statement.Parse](Statement/Serialize.hs)
+
+- parse string -> statement
+- serialize a statement -> plaintext, LaTeX
+
+### [Logic.Language.Impl.L](Language/Impl/L.hs)
+
+- serialize a statement -> L (the formal language)
+- parse L (the formal language) string -> statement
+
+## semantic statement things
+
+### [Logic.Statement.Eval](Statement/Eval.hs)
+
+- assign truth values and evaluate statements
+- determine tautology, contradiction, or contingent
+
+### [Logic.Statement.Serialize](Statement/Serialize.hs)
+
+- generate a LaTeX truth table from a statement
+
+## syntactic things
+
+### [Logic.Statements.Laws](Statements/Laws.hs)
+
+- match/replace patterns in statements (e.g. logical laws)
+- verify logical-law equivalence of statements
+- find logical-law equivalence of statements with breadth-first search (slow)
+
+### [Logic.Language](Language.hs)
+
+- implement formal languages (symbols, axioms schemas, and inference rules)
+  with a clunky api, see also
+  <https://en.wikipedia.org/wiki/Post_canonical_system>
+
+### [Logic.Language.Derivation](Language/Derivation.hs)
+
+- verify derivations in formal languages
+
+### formal languages
+
+- [the MIU system](Language/Impl/MIU.hs) (from "Gödel, Escher, Bach")
+- [L](Language/Impl/L.hs)