diff options
Diffstat (limited to 'source')
31 files changed, 7245 insertions, 0 deletions
diff --git a/source/Api.hs b/source/Api.hs new file mode 100644 index 0000000..ac277f5 --- /dev/null +++ b/source/Api.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} + +module Api + ( constructTheoryGraph, TheoryGraph + , tokenize, TokStream + , scan + , parse + , simpleStream + , builtins + , ParseException(..) + , gloss, GlossError(..), GlossException(..) + , generateTasks + , encodeTasks + , dumpTask + , verify, ProverAnswer(..), VerificationResult(..) + , exportMegalodon + , WithCache(..) + , WithFilter(..) + , WithOmissions(..) + , WithProver(..) + , WithVersion(..) + , WithLogging(..) + , WithDump(..) + , WithMegalodon(..) + , pattern WithoutDump + , WithParseOnly(..) + , Options(..) + , WithDumpPremselTraining(..) + ) where + + +import Base +import Checking +import Checking.Cache +import Encoding +import Meaning (meaning, GlossError(..)) +import Provers +import Syntax.Abstract qualified as Raw +import Syntax.Adapt (adaptChunks, scanChunk, ScannedLexicalItem) +import Syntax.Concrete +import Syntax.Import +import Syntax.Chunk +import Syntax.Internal qualified as Internal +import Syntax.Lexicon (Lexicon, builtins) +import Syntax.Token +import TheoryGraph (TheoryGraph, Precedes(..)) +import TheoryGraph qualified +import Tptp.UnsortedFirstOrder qualified as Tptp +import Filter(filterTask) +import Megalodon qualified + +import Control.Monad.Logger +import Data.List (intercalate) +import Control.Monad.Reader +import Data.Set qualified as Set +import Data.List qualified as List +import Data.Text.IO qualified as Text +import qualified Data.Text as Text +import System.FilePath.Posix +import Text.Earley (parser, fullParses, Report(..)) +import Text.Megaparsec hiding (parse, Token) +import UnliftIO +import UnliftIO.Directory +import UnliftIO.Environment + +-- | Follow all @\\import@ statements recursively and build a theory graph from them. +-- The @\\import@ statements should be on their own separate line and precede all +-- top-level environments. This process is entirely decoupled from tokenizing and +-- parsing processes. +constructTheoryGraph :: forall io. MonadIO io => FilePath -> io TheoryGraph +constructTheoryGraph root = fmap snd (go mempty (TheoryGraph.singleton root) root) + where + go :: Set FilePath -> TheoryGraph -> FilePath -> io (Set FilePath, TheoryGraph) + go visited graph file = + if file `Set.member` visited then pure (visited, graph) + else do + raw <- findAndReadFile file + let files = gatherImports raw + let visited' = Set.insert file visited + let precedes = [ancestor `Precedes` file | ancestor <- files] + let graph' = TheoryGraph.fromList precedes <> graph + results <- go visited' graph' `traverse` files + let (visited'', graph'') = unzip results + pure (visited' <> Set.unions visited'', graph' <> TheoryGraph.unions graph'') + + +-- | Given a filename for a theory, look for it in a set of predetermined places: +-- the current directory, the library directory, and the Naproche root directory. +findAndReadFile :: MonadIO io => FilePath -> io Text +findAndReadFile path = do + homeDir <- getHomeDirectory + currentDir <- getCurrentDirectory + userLib <- (?? (homeDir </> "formalizations")) <$> lookupEnv "NAPROCHE_LIB" + srcLib <- (?? (homeDir </> "code/zf/library")) <$> lookupEnv "NAPROCHE_SCR_LIB" + + existsCurrent <- doesFileExist (currentDir </> path) + existsUserLib <- doesFileExist (userLib </> path) + existsScrLib <- doesFileExist (srcLib </> path) + liftIO if + | existsCurrent -> Text.readFile (currentDir </> path) + | existsUserLib -> Text.readFile (userLib </> path) + | existsScrLib -> Text.readFile (srcLib </> path) + | otherwise -> error ("Could not find file: " <> path) + + +-- | Throws a 'ParseException' when tokenizing fails. +tokenize :: MonadIO io => FilePath -> io TokStream +tokenize file = do + raw <- findAndReadFile file + case runLexer file raw of + Left tokenError -> throwIO (TokenError (errorBundlePretty tokenError)) + Right tokenStream -> pure (TokStream raw tokenStream) + +-- | Scan the given file for lexical items. The actual parsing process +-- uses 'adaptChunks' instead. +scan :: MonadIO io => FilePath -> io [ScannedLexicalItem] +scan input = do + tokenStream <- tokenize input + let chunks = chunkify (unTokStream tokenStream) + pure (concatMap scanChunk chunks) + + +-- | Parse a file. Throws a 'ParseException' when tokenizing, scanning, or +-- parsing fails. +parse :: MonadIO io => FilePath -> io ([Raw.Block], Lexicon) +parse file = do + -- We need to consider the entire theory graph here already + -- since we can use vocabulary of imported theories. + theoryGraph <- constructTheoryGraph file + case TheoryGraph.topSortSeq theoryGraph of + -- LATER replace with a more helpful error message, like actually showing the cycle properly + Left cyc -> error ("could not linearize theory graph (likely due to circular dependencies):\n" <> show cyc) + Right theoryChain -> do + tokenStreams <- traverse tokenize theoryChain + let tokenStream = mconcat (toList tokenStreams) + let chunks = chunkify (unTokStream tokenStream) + let lexicon = adaptChunks chunks builtins + (, lexicon) <$> combineParseResults [fullParses (parser (grammar lexicon)) toks | toks <- chunks] + +combineParseResults :: MonadIO io => [([Raw.Block], Report Text [Located Token])] -> io [Raw.Block] +combineParseResults [] = pure [] +combineParseResults (result : results) = case result of + (_, Report _ es (tok:toks)) -> throwIO (UnconsumedTokens es (tok :| toks)) + ([], _) -> throwIO EmptyParse + (ambi@(_:_:_), _) -> case nubOrd ambi of + [block] -> do + blocks <- combineParseResults results + pure (trace ("technically ambiguous parse:\n" <> show block) (block : blocks)) + ambi' -> throwIO (AmbigousParse ambi') + ([block], _) -> do + blocks <- combineParseResults results + pure (block : blocks) + + +simpleStream :: TokStream -> [Token] +simpleStream stream = fmap unLocated (unTokStream stream) + + +data ParseException + = UnconsumedTokens [Text] (NonEmpty (Located Token)) -- ^ Expectations and unconsumed tokens. + | AmbigousParse [Raw.Block] + | EmptyParse + | TokenError String + +instance Show ParseException where + show = \case + UnconsumedTokens es (ltok :| ltoks) -> + let tok = unLocated ltok + toks = unLocated <$> ltoks + in + "unconsumed " <> describeToken tok <> " at " <> sourcePosPretty (startPos ltok) <> "\n" <> + " " <> unwords (tokToString <$> (tok : take 4 toks)) <> "\n" <> + " " <> replicate (length (tokToString tok)) '^' <> "\n" <> + case es of + [] -> "while expecting nothing" + _ -> "while expecting one of the following:\n" <> intercalate ", " (Text.unpack <$> nubOrd es) + AmbigousParse blocks -> + "ambiguous parse: " <> show blocks + EmptyParse -> + "empty parse" + TokenError err -> + err -- Re-use pretty printing from Megaparsec. + +instance Exception ParseException where + + +describeToken :: Token -> String +describeToken = \case + Word _ -> "word" + Variable _ -> "variable" + Symbol _ -> "symbol" + Integer _ -> "integer" + Command _ -> "command" + BeginEnv _ -> "begin of environment" + EndEnv _ -> "end of environment" + _ -> "delimiter" + + +gloss :: MonadIO io => FilePath -> io ([Internal.Block], Lexicon) +gloss file = do + (blocks, lexicon) <- parse file + case meaning blocks of + Left err -> throwIO (GlossException err) + Right blocks' -> pure (blocks', lexicon) + + +newtype GlossException + = GlossException GlossError + deriving (Show, Eq) + +instance Exception GlossException + + + +generateTasks :: (MonadIO io, MonadReader Options io) => FilePath -> io ([Internal.Task], Lexicon) +generateTasks file = do + dumpPremselTraining <- asks withDumpPremselTraining + (blocks, lexicon) <- gloss file + tasks <- liftIO (check dumpPremselTraining lexicon blocks) + pure (Internal.contractionTask <$> tasks, lexicon) + + +encodeTasks :: (MonadIO io, MonadReader Options io) => FilePath -> io [Tptp.Task] +encodeTasks file = do + (tasks, lexicon) <- generateTasks file + pure (encodeTask lexicon <$> tasks) + +data VerificationResult + = VerificationSuccess + | VerificationFailure [(Internal.Formula, ProverAnswer)] + deriving (Show) + +resultFromAnswers :: [(Internal.Formula, ProverAnswer)] -> VerificationResult +resultFromAnswers answers = + case List.filter isFailure answers of + [] -> VerificationSuccess + failures -> VerificationFailure failures + +isFailure :: (a, ProverAnswer) -> Bool +isFailure (_phi, Yes) = False +isFailure (_phi, _ans) = True + +verify :: (MonadUnliftIO io, MonadLogger io, MonadReader Options io) => ProverInstance -> FilePath -> io VerificationResult +verify prover file = do + (tasks, lexicon) <- generateTasks file + filterOption <- asks withFilter + let filteredTasks = case filterOption of + WithFilter -> filterTask <$> tasks + WithoutFilter -> tasks + cacheOption <- asks withCache + answers <- case cacheOption of + WithoutCache -> + pooledForConcurrently filteredTasks (runProver prover lexicon) + WithCache -> do + xdgCache <- getXdgDirectory XdgCache "zf" + let cacheDir = xdgCache </> takeDirectory file + let cache = xdgCache </> file + createDirectoryIfMissing True cacheDir + -- Initialize with an empty cache when no cache exists. + -- If we do not do this opening the cache file will fail. + unlessM (doesFileExist cache) + (putTaskCache cache []) + + filteredTasks' <- filterM (notInCache cache) filteredTasks + answers' <- pooledForConcurrently filteredTasks' (runProver prover lexicon) + + -- MAYBE: use Seq.breakl + let firstFailure = find (\(_, answer) -> isFailure answer) (List.zip filteredTasks' answers') + let successfulPrefix = List.takeWhile (\task -> Just task /= (fst <$> firstFailure)) filteredTasks + putTaskCache cache successfulPrefix + pure answers' + pure (resultFromAnswers answers) + +dumpTask :: MonadIO io => FilePath -> Tptp.Task -> io () +dumpTask file tptp = liftIO (Text.writeFile file (Tptp.toText tptp)) + +exportMegalodon :: (MonadUnliftIO io) => FilePath -> io Text +exportMegalodon file = do + (blocks, lexicon) <- gloss file + pure (Megalodon.encodeBlocks lexicon blocks) + + +-- | Should we use caching? +data WithCache = WithoutCache | WithCache deriving (Show, Eq) + +data WithFilter = WithoutFilter | WithFilter deriving (Show, Eq) + +-- | Are proof omissions allowed? +data WithOmissions = WithoutOmissions | WithOmissions deriving (Show, Eq) + +-- | Which external prover should be used? +data WithProver = WithDefaultProver | WithEprover | WithVampire | WithIprover deriving (Show, Eq) + +-- | Should we show the version of the software? +data WithVersion = WithoutVersion | WithVersion deriving (Show, Eq) + +data WithLogging = WithoutLogging | WithLogging deriving (Show, Eq) + +-- | Should we dump all proof tasks? Where? +newtype WithDump = WithDump FilePath deriving (Show, Eq) + +-- | Should we export to Megalodon? +data WithMegalodon = WithMegalodon | WithoutMegalodon deriving (Show, Eq) + +pattern WithoutDump :: WithDump +pattern WithoutDump = WithDump "" + +data WithParseOnly = WithoutParseOnly | WithParseOnly deriving (Show, Eq) + + +data Options = Options + { inputPath :: FilePath + , withCache :: WithCache + , withDump :: WithDump + , withFilter :: WithFilter + , withLogging :: WithLogging + , withMemoryLimit :: Provers.MemoryLimit + , withOmissions :: WithOmissions + , withParseOnly :: WithParseOnly + , withProver :: WithProver + , withTimeLimit :: Provers.TimeLimit + , withVersion :: WithVersion + , withMegalodon :: WithMegalodon + , withDumpPremselTraining :: WithDumpPremselTraining + } diff --git a/source/Base.hs b/source/Base.hs new file mode 100644 index 0000000..1068684 --- /dev/null +++ b/source/Base.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | A basic prelude intended to reduce the amount of repetitive imports. +-- Mainly consists of re-exports from @base@ modules. +-- Intended to be imported explicitly (but with @NoImplicitPrelude@ enabled) +-- so that it is obvious that this module is used. Commonly used data types +-- or helper functions from outside of @base@ are also included. +-- +module Base (module Base, module Export) where + +-- Some definitions from @base@ need to be hidden to avoid clashes. +-- +import Prelude as Export hiding + ( Word + , head, last, init, tail, lines, lookup + , filter -- Replaced by generalized form from "Data.Filtrable". + , words, pi, all + ) + +import Control.Applicative as Export hiding (some) +import Control.Applicative qualified as Applicative +import Control.Monad.IO.Class as Export +import Control.Monad.State +import Data.Containers.ListUtils as Export (nubOrd) -- Faster than `nub`. +import Data.DList as Export (DList) +import Data.Foldable as Export +import Data.Function as Export (on) +import Data.Functor as Export (void) +import Data.Hashable as Export (Hashable(..)) +import Data.IntMap.Strict as Export (IntMap) +import Data.List.NonEmpty as Export (NonEmpty(..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map as Export (Map) +import Data.Maybe as Export hiding (mapMaybe, catMaybes) -- Replaced by generalized form from "Data.Filtrable". +import Data.Sequence as Export (Seq(..), replicateA) +import Data.Set as Export (Set) +import Data.HashSet as Export (HashSet) +import Data.HashMap.Strict as Export (HashMap) +import Data.String as Export (IsString(..)) +import Data.Text as Export (Text) +import Data.Traversable as Export +import Data.Void as Export +import Data.Word as Export (Word64) +import Debug.Trace as Export +import GHC.Generics as Export (Generic(..), Generic1(..)) +import Prettyprinter as Export (pretty) +import UnliftIO as Export (throwIO) +import Data.Monoid (First(..)) + +-- | Signal to the developer that a branch is unreachable or represent +-- an impossible state. Using @impossible@ instead of @error@ allows +-- for easily finding leftover @error@s while ignoring impossible branches. +impossible :: String -> a +impossible msg = error ("IMPOSSIBLE: " <> msg) + +-- | Signal to the developer that some part of the program is unfinished. +_TODO :: String -> a +_TODO msg = error ("TODO: " <> msg) + +-- | Eliminate a @Maybe a@ value with default value as fallback. +(??) :: Maybe a -> a -> a +ma ?? a = fromMaybe a ma + +-- | Convert a ternary uncurried function to a curried function. +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +curry3 f a b c = f (a,b,c) + +-- | Convert a ternary curried function to an uncurried function. +uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) +uncurry3 f ~(a, b, c) = f a b c + +-- | Convert a ternary curried function to an uncurried function. +uncurry4 :: (a -> b -> c -> d -> e) -> ((a, b, c, d) -> e) +uncurry4 f ~(a, b, c, d) = f a b c d + +-- | Fold of composition of endomorphisms: +-- like @sum@ but for @(.)@ instead of @(+)@. +compose :: Foldable t => t (a -> a) -> (a -> a) +compose = foldl' (.) id + +-- | Safe list lookup. Replaces @(!!)@. +nth :: Int -> [a] -> Maybe a +nth _ [] = Nothing +nth 0 (a : _) = Just a +nth n (_ : as) = nth (n - 1) as + +-- Same as 'find', but with a 'Maybe'-valued predicate that also transforms the resulting value. +firstJust :: Foldable t => (a -> Maybe b) -> t a -> Maybe b +firstJust p = getFirst . foldMap (\ x -> First (p x)) + +-- | Do nothing and return @()@. +skip :: Applicative f => f () +skip = pure () + +-- | One or more. Equivalent to @some@ from @Control.Applicative@, but +-- keeps the information that the result is @NonEmpty@. +many1 :: Alternative f => f a -> f (NonEmpty a) +many1 a = NonEmpty.fromList <$> Applicative.some a + +-- | Same as 'many1', but discards the type information that the result is @NonEmpty@. +many1_ :: Alternative f => f a -> f [a] +many1_ = Applicative.some + +count :: Applicative f => Int -> f a -> f [a] +count n fa + | n <= 0 = pure [] + | otherwise = replicateM n fa + +-- | Same as 'count', but requires at least one occurrence. +count1 :: Applicative f => Int -> f a -> f (NonEmpty a) +count1 n fa + | n <= 1 = (:| []) <$> fa + | otherwise = NonEmpty.fromList <$> replicateM n fa + +-- | Apply a functor of functions to a plain value. +flap :: Functor f => f (a -> b) -> a -> f b +flap ff x = (\f -> f x) <$> ff +{-# INLINE flap #-} + +-- | Like 'when' but for functions that carry a witness with them: +-- execute a monadic action depending on a 'Left' value. +-- Does nothing on 'Right' values. +-- +-- > whenLeft eitherErrorOrResult throwError +-- +whenLeft :: Applicative f => Either a b -> (a -> f ()) -> f () +whenLeft mab action = case mab of + Left err -> action err + Right _ -> skip + +-- | Like 'when', but the guard is monadic. +whenM :: Monad m => m Bool -> m () -> m () +whenM mb ma = ifM mb ma skip + +-- | Like 'unless', but the guard is monadic. +unlessM :: Monad m => m Bool -> m () -> m () +unlessM mb ma = ifM mb skip ma + +-- | Like 'guard', but the guard is monadic. +guardM :: MonadPlus m => m Bool -> m () +guardM f = guard =<< f + +-- | @if [...] then [...] else [...]@ lifted to a monad. +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM mb ma1 ma2 = do + b <- mb + if b then ma1 else ma2 + +-- | Similar to @Reader@'s @local@, but for @MonadState@. Resets the state after a computation. +locally :: MonadState s m => m a -> m a +locally ma = do + s <- get + a <- ma + put s + return a diff --git a/source/Checking.hs b/source/Checking.hs new file mode 100644 index 0000000..dc90264 --- /dev/null +++ b/source/Checking.hs @@ -0,0 +1,935 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + + +module Checking where + + +import Base +import StructGraph +import Syntax.Internal +import Syntax.Lexicon +import Encoding +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Bound.Scope +import Bound.Var (Var(..), unvar) +import Control.Exception (Exception) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer.Strict +import Data.DList qualified as DList +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.InsOrdMap (InsOrdMap) +import Data.InsOrdMap qualified as InsOrdMap +import Data.List qualified as List +import Data.Set qualified as Set +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import System.FilePath.Posix +import Text.Megaparsec (SourcePos) +import UnliftIO.Directory + +type Checking = CheckingM () +type CheckingM = StateT CheckingState (WriterT (DList Task) IO) + +check :: WithDumpPremselTraining -> Lexicon -> [Block] -> IO [Task] +check dumpPremselTraining lexicon blocks = do + tasks <- execWriterT (runStateT (checkBlocks blocks) initialCheckingState) + pure (DList.toList tasks) + where + initialCheckingState = CheckingState + { checkingAssumptions = [] + , checkingDumpPremselTraining = dumpPremselTraining + , checkingGoals = [] + , checkingFacts = mempty + , checkingDirectness = Direct + , checkingAbbreviations = initAbbreviations + , checkingPredicateDefinitions = mempty + , checkingStructs = initCheckingStructs + , instantiatedStructs = Set.empty + , instantiatedStructOps = HM.empty + , definedMarkers = HS.empty + , checkingLexicon = lexicon + , blockLabel = Marker "" + , fixedVars = mempty + } + +data WithDumpPremselTraining = WithoutDumpPremselTraining | WithDumpPremselTraining + +-- | The checking state accumulates the proof tasks and +-- helps to keep track of the surrounding context. +-- INVARIANT: All formulas in the checking state that eventually +-- get exported should have all their abbreviations resolved. +data CheckingState = CheckingState + { checkingLexicon :: Lexicon -- For debugging and dumping training data. + + , checkingDumpPremselTraining :: WithDumpPremselTraining + + , checkingAssumptions :: [Formula] + -- ^ Local assumption. + -- + , checkingGoals :: [Formula] + -- ^ The current goals. + -- + , checkingFacts :: InsOrdMap Marker Formula + -- ^ Axioms and proven results. + -- + -- + , checkingDirectness :: Directness + -- ^ E can detect contradictory axioms and warns about them. + -- In an indirect proof (e.g. a proof by contradiction) we want + -- to ignore that warning. + -- + , checkingAbbreviations :: HashMap Symbol (Scope Int ExprOf Void) + -- ^ Abbreviations are definitions that automatically get expanded. + -- They are given by a closed rhs (hence the 'Void' indicating no free variables). + -- INVARIANT: The bound 'Int' values must be lower than the arity of the symbol. + -- + , checkingPredicateDefinitions :: HashMap Predicate [Scope Int ExprOf Void] + -- ^ Definitions of predicate that we can match against in assumptions. + -- Axioms and theorems that have the shape of a definition can be added as alternate definitions. + -- + , checkingStructs :: StructGraph + -- ^ Graph of structs defined so far. + -- + , instantiatedStructs :: Set VarSymbol + -- ^ For checking which structure names are in scope to cast them to their carrier. + -- + , instantiatedStructOps :: HashMap StructSymbol VarSymbol + -- ^ For annotation of structure operations. + -- + , fixedVars :: Set VarSymbol + -- ^ Keeps track of the variables that are locally constant (either introduced implicitly in the assumption or explicitly through the proof steps "take" or "fix"). + -- + , definedMarkers :: HashSet Marker + -- ^ Markers for toplevel sections need to be unique. This keeps track of the + -- markers used thus far. + -- + , blockLabel :: Marker + -- ^ Label/marker of the current block + } + +initCheckingStructs :: StructGraph +initCheckingStructs = StructGraph.insert + _Onesorted + mempty -- no parents + (Set.singleton CarrierSymbol) -- used for casting X -> \carrier[X] + mempty -- empty graph + +initAbbreviations :: HashMap Symbol (Scope Int ExprOf Void) +initAbbreviations = HM.fromList + [ (SymbolPredicate (PredicateRelation (Command "notin")), toScope (TermVar (B 0) `IsNotElementOf` TermVar (B 1))) + , (SymbolPredicate (PredicateVerb (unsafeReadPhraseSgPl "equal[s/] ?")), toScope (TermVar (B 0) `Equals` TermVar (B 1))) + , (SymbolPredicate (PredicateNoun (unsafeReadPhraseSgPl "element[/s] of ?")), toScope (TermVar (B 0) `IsElementOf` TermVar (B 1))) + ] + +data CheckingError + = DuplicateMarker Marker SourcePos + | ByContradictionOnMultipleGoals + | BySetInductionSyntacticMismatch + | ProofWithoutPrecedingTheorem + | CouldNotEliminateHigherOrder FunctionSymbol Term + | AmbiguousInductionVar + | MismatchedSetExt [Formula] + | MismatchedAssume Formula Formula + deriving (Show, Eq) + +instance Exception CheckingError + + +assume :: [Asm] -> Checking +assume asms = traverse_ go asms + where + go :: Asm -> Checking + go = \case + Asm phi -> do + phi' <- (canonicalize phi) + modify \st -> + st{ checkingAssumptions = phi' : checkingAssumptions st + , fixedVars = freeVars phi' <> fixedVars st + } + AsmStruct x sp -> + instantiateStruct x sp + + +instantiateStruct :: VarSymbol -> StructPhrase -> Checking +instantiateStruct x sp = do + st <- get + let structGraph = checkingStructs st + let struct = lookupStruct structGraph sp + let fixes = StructGraph.structSymbols struct structGraph + let phi = (TermSymbol (SymbolPredicate (PredicateNounStruct sp)) [TermVar x]) + -- + -- NOTE: this will always cause shadowing of operations, ideally this should be type-directed instead. + let ops = HM.fromList [(op, x) | op <- Set.toList fixes] + put st + { instantiatedStructs = Set.insert x (instantiatedStructs st) + , instantiatedStructOps = ops <> instantiatedStructOps st -- left-biased union + , checkingAssumptions = phi : checkingAssumptions st + } + + +lookupStruct :: StructGraph -> StructPhrase -> Struct +lookupStruct structGraph struct = case StructGraph.lookup struct structGraph of + Just result -> result + Nothing -> error $ "lookup of undefined structure: " <> show struct + + +-- | Replace all current goals with a new goal. Use with care! +setGoals :: [Formula] -> Checking +setGoals goals = do + goals <- traverse canonicalize goals + modify $ \st -> st{checkingGoals = goals} + + +-- | Create (and add) tasks based on facts, local assumptions, and goals. +tellTasks :: Checking +tellTasks = do + goals <- gets checkingGoals + m <- gets blockLabel + facts <- liftA2 (<>) (gets checkingFacts) (withMarker m <$> gets checkingAssumptions) + directness <- gets checkingDirectness + let tasks = DList.fromList (Task directness (InsOrdMap.toList facts) m <$> goals) + tell tasks + +withMarker :: Marker -> [v] -> InsOrdMap Marker v +withMarker (Marker m) phis = InsOrdMap.fromList $ zipWith (\phi k -> (Marker (m <> Text.pack (show k)), phi)) phis ([1..] :: [Int]) + +-- | Make a fact available to all future paragraphs. +addFact :: Formula -> Checking +addFact phi = do + phi' <- canonicalize phi + m <- gets blockLabel + modify $ \st -> st{checkingFacts = InsOrdMap.insert m phi' (checkingFacts st)} + + +-- | Make a fact available to all future paragraphs. +addFacts :: InsOrdMap Marker Formula -> Checking +addFacts phis = do + phis' <- forM phis canonicalize + modify $ \st -> st{checkingFacts = phis' <> (checkingFacts st)} + + + + + +addFactWithAsms :: [Asm] -> Formula -> Checking +addFactWithAsms asms stmt = do + (asms', structs, structOps) <- mergeAssumptions asms + asms'' <- traverse (canonicalizeWith structs structOps) asms' + stmt' <- canonicalizeWith structs structOps stmt + m <- gets blockLabel + modify $ \st -> + let phi = case asms'' of + [] -> forallClosure mempty stmt' + _ -> forallClosure mempty (makeConjunction asms'' `Implies` stmt') + in st{checkingFacts = InsOrdMap.insert m phi (checkingFacts st)} + + +-- | Mark a proof as indirect. Intended to be used in a @locally do@ block. +byContradiction :: Checking +byContradiction = do + st <- get + case checkingGoals st of + [goal] -> put st{checkingGoals = [Bottom], checkingDirectness = Indirect goal} + goals -> error ("multiple or no goal in proof by contradiction" <> show goals) + + +unabbreviateWith :: (forall a. HashMap Symbol (Scope Int ExprOf a)) -> (forall b. ExprOf b -> ExprOf b) +unabbreviateWith abbrs = unabbr + where + unabbr :: ExprOf b -> ExprOf b + unabbr = \case + TermSymbol sym es -> + let es' = unabbr <$> es + in case HM.lookup sym abbrs of + Nothing -> TermSymbol sym es' + Just scope -> unabbr (instantiate (\k -> nth k es ?? error "unabbreviateWith: incorrect index") scope) + Not e -> + Not (unabbr e) + Apply e es -> + Apply (unabbr e) (unabbr <$> es) + TermSep vs e scope -> + TermSep vs (unabbr e) (hoistScope unabbr scope) + Iota x scope -> + Iota x (hoistScope unabbr scope) + ReplacePred y x xB scope -> + ReplacePred y x xB (hoistScope unabbr scope) + ReplaceFun bounds scope cond -> + ReplaceFun ((\(x, e) -> (x, unabbr e)) <$> bounds) (hoistScope unabbr scope) (hoistScope unabbr cond) + Connected con e1 e2 -> + Connected con (unabbr e1) (unabbr e2) + Lambda scope -> + Lambda (hoistScope unabbr scope) + Quantified quant scope -> + Quantified quant (hoistScope unabbr scope) + e@PropositionalConstant{} -> + e + e@TermVar{} -> + e + TermSymbolStruct symb e -> + TermSymbolStruct symb (unabbr <$> e) + +-- | Unroll comprehensions in equations. +-- E.g. /@B = \\{f(a) | a\\in A \\}@/ turns into +-- /@\\forall b. b\\in B \\iff \\exists a\\in A. b = f(a)@/. +desugarComprehensions :: forall a. ExprOf a -> ExprOf a +desugarComprehensions = \case + -- We only desugar comprehensions under equations. We do not allow nesting. + e@TermSep{} -> e + e@ReplacePred{} -> e + e@ReplaceFun{} -> e + e@TermVar{} -> e + e@PropositionalConstant{} -> e + e@TermSymbolStruct{}-> e + -- + e `Equals` TermSep x bound scope -> desugarSeparation e x bound scope + TermSep x bound scope `Equals` e -> desugarSeparation e x bound scope + -- + e `Equals` ReplaceFun bounds scope cond -> makeReplacementIff (F <$> e) bounds scope cond + ReplaceFun bounds scope cond `Equals` e -> makeReplacementIff (F <$> e) bounds scope cond + -- + Apply e es -> Apply (desugarComprehensions e) (desugarComprehensions <$> es) + Not e -> Not (desugarComprehensions e) + TermSymbol sym es -> TermSymbol sym (desugarComprehensions <$> es) + Iota x scope -> Iota x (hoistScope desugarComprehensions scope) + Connected conn e1 e2 -> Connected conn (desugarComprehensions e1) (desugarComprehensions e2) + Lambda scope -> Lambda (hoistScope desugarComprehensions scope) + Quantified quant scope -> Quantified quant (hoistScope desugarComprehensions scope) + where + desugarSeparation :: ExprOf a -> VarSymbol -> (ExprOf a) -> (Scope () ExprOf a) -> ExprOf a + desugarSeparation e x bound scope = + let phi = (TermVar (B x) `IsElementOf` (F <$> e)) :: ExprOf (Var VarSymbol a) + psi = (TermVar (B x) `IsElementOf` (F <$> bound)) :: ExprOf (Var VarSymbol a) + rho = fromScope (mapBound (const x) scope) + in Quantified Universally (toScope (phi `Iff` (psi `And` rho))) + + +desugarComprehensionsA :: Applicative f => ExprOf a -> f (ExprOf a) +desugarComprehensionsA e = pure (desugarComprehensions e) + + + + +checkBlocks :: [Block] -> Checking +checkBlocks = \case + BlockAxiom pos marker axiom : blocks -> do + withLabel pos marker (checkAxiom axiom) + checkBlocks blocks + BlockDefn pos marker defn : blocks -> do + withLabel pos marker (checkDefn defn) + checkBlocks blocks + BlockAbbr pos marker abbr : blocks -> do + withLabel pos marker (checkAbbr abbr) + checkBlocks blocks + BlockLemma pos marker lemma : BlockProof _pos2 proof : blocks -> do + withLabel pos marker (checkLemmaWithProof lemma proof) + checkBlocks blocks + BlockLemma pos marker lemma : blocks -> do + withLabel pos marker (checkLemma lemma) + checkBlocks blocks + BlockProof _pos _proof : _ -> + throwIO ProofWithoutPrecedingTheorem + BlockSig _pos asms sig : blocks -> do + checkSig asms sig + checkBlocks blocks + BlockInductive pos marker inductiveDefn : blocks -> do + withLabel pos marker (checkInductive inductiveDefn) + checkBlocks blocks + BlockStruct pos marker structDefn : blocks -> do + withLabel pos marker (checkStructDefn structDefn) + checkBlocks blocks + [] -> skip + +-- | Add the given label to the set of in-scope markers and set it as the current label for error reporting. +withLabel :: SourcePos -> Marker -> CheckingM a -> CheckingM a +withLabel pos marker ma = do + -- Add a new marker to the set. It is a checking error if the marker has already been used. + st <- get + let markers = definedMarkers st + if HS.member marker markers + then throwIO (DuplicateMarker marker pos) + else put st{definedMarkers = HS.insert marker markers} + -- Set the marker as the label of the current block. + modify \st -> st{blockLabel = marker} + ma + +-- | Verification of a lemma with a proof. +-- We skip omitted proofs and treat them as proper gaps of the formalization. +-- This is useful when developing a formalization, as it makes it easy to +-- leave difficult proofs for later. +checkLemmaWithProof :: Lemma -> Proof -> Checking +checkLemmaWithProof (Lemma asms goal) proof = do + locally do + assume asms + setGoals [goal] + checkProof proof + addFactWithAsms asms goal + + +-- | Verification of a lemma without a proof. +checkLemma :: Lemma -> Checking +checkLemma (Lemma asms goal) = do + locally do + assume asms + setGoals [goal] + tellTasks + -- Make fact from asms and stmt (take universal closure). + addFactWithAsms asms goal + + +checkAxiom :: Axiom -> Checking +checkAxiom (Axiom asms axiom) = addFactWithAsms asms axiom + +checkProof :: Proof -> Checking +checkProof = \case + Qed JustificationEmpty-> + tellTasks + Qed JustificationSetExt -> do + goals <- gets checkingGoals + case goals of + [goal] -> do + goals' <- splitGoalWithSetExt goal + setGoals goals' + tellTasks + [] -> pure () + _ -> throwIO (MismatchedSetExt goals) + Qed (JustificationRef ms) -> + byRef ms + Qed JustificationLocal -> + byAssumption + ByContradiction proof -> do + goals <- gets checkingGoals + case goals of + [goal] -> do + assume [Asm (Not goal)] + byContradiction + checkProof proof + _ -> throwIO ByContradictionOnMultipleGoals + ByCase splits -> do + for_ splits checkCase + setGoals [makeDisjunction (caseOf <$> splits)] + tellTasks + BySetInduction mx continue -> do + goals <- gets checkingGoals + case goals of + Forall scope : goals' -> do + let zs = nubOrd (bindings scope) + z <- case mx of + Nothing -> case zs of + [z'] -> pure z' + _ -> throwIO AmbiguousInductionVar + Just (TermVar z') -> pure z' + _ -> throwIO AmbiguousInductionVar + let y = NamedVar "IndAntecedent" + let ys = List.delete z zs + let anteInst bv = if bv == z then TermVar y else TermVar bv + let antecedent = makeForall (y : ys) ((TermVar y `IsElementOf` TermVar z) `Implies` instantiate anteInst scope) + assume [Asm antecedent] + let consequent = instantiate TermVar scope + setGoals (consequent : goals') + checkProof continue + _ -> throwIO BySetInductionSyntacticMismatch + ByOrdInduction continue -> do + goals <- gets checkingGoals + case goals of + Forall scope : goals' -> case fromScope scope of + Implies (IsOrd (TermVar (B bz))) rhs -> do + let zs = nubOrd (bindings scope) + z <- case zs of + [z'] | z' == bz -> pure z' + [_] -> error "induction variable does not match the variable with ordinal guard" + _ -> throwIO AmbiguousInductionVar + -- LATER: this is kinda sketchy: + -- we now use the induction variable in two ways: + -- we assume the induction hypothesis, where we recycle the induction variable both as a bound variable and a free variable + -- we then need to show that under that hypothesis the claim holds for the free variable... + let hypo = Forall (toScope (Implies ((TermVar (B z)) `IsElementOf` (TermVar (F z))) rhs)) + assume [Asm (IsOrd (TermVar z)), Asm hypo] + let goal' = unvar id id <$> rhs -- we "instantiate" the single bound variable on the rhs + setGoals (goal' : goals') + checkProof continue + _ -> error ("could not match transfinite induction with syntactic structure of the first goal: " <> show goals) + _ -> error ("the first goal must be universally quantifier to apply transfinite induction: " <> show goals) + Assume phi continue -> do + goals' <- matchAssumptionWithGoal phi + assume [Asm phi] + setGoals goals' + checkProof continue + Fix xs suchThat continue -> do + fixing xs + checkProof case suchThat of + Top -> continue + _ -> Assume suchThat continue + Subclaim subclaim subproof continue -> do + locally (checkLemmaWithProof (Lemma [] subclaim) subproof) + assume [Asm subclaim] + checkProof continue + Omitted -> do + setGoals [] + Suffices reduction by proof -> do + goals <- gets checkingGoals + setGoals [reduction `Implies` makeConjunction goals] + justify by + setGoals [reduction] + checkProof proof + Take _witnesses _suchThat JustificationSetExt _continue -> + error "cannot justify existential statement with setext" + Take witnesses suchThat by continue -> locally do + goals <- gets checkingGoals + setGoals [makeExists witnesses suchThat] + justify by + assume [Asm suchThat] + setGoals goals + checkProof continue + Have claim (JustificationRef ms) continue -> locally do + goals <- gets checkingGoals + setGoals [claim] + byRef ms -- locally prove things with just refs and local assumptions + assume [Asm claim] + setGoals goals + checkProof continue + Have claim JustificationLocal continue -> locally do + goals <- gets checkingGoals + setGoals [claim] + byAssumption -- locally prove things with just local assumptions + assume [Asm claim] + setGoals goals + checkProof continue + Have claim by continue -> do + locally do + goals <- gets checkingGoals + claims <- case by of + JustificationEmpty -> + pure [claim] + JustificationSetExt -> + splitGoalWithSetExt claim + -- NOTE: we already handled @JustificationRef ms@ and GHC recognizes this + setGoals claims + tellTasks + assume [Asm claim] + setGoals goals + checkProof continue + Define x t continue -> locally do + assume [Asm case t of + TermSep y yBound phi -> + makeForall [y] $ + Iff (TermVar y `IsElementOf` TermVar x) + ((TermVar y `IsElementOf` yBound) `And` instantiate1 (TermVar y) phi) + ReplaceFun bounds lhs cond -> + makeReplacementIff (TermVar (F x)) bounds lhs cond + Iota _ _ -> + _TODO "local definitions with iota" + _ -> Equals (TermVar x) t + ] + checkProof continue + DefineFunction funVar argVar valueExpr domExpr continue -> do + -- we're given f, x, e, d + assume + [ Asm (TermOp DomSymbol [TermVar funVar] `Equals` domExpr) -- dom(f) = d + , Asm (makeForall [argVar] ((TermVar argVar `IsElementOf` domExpr) `Implies` (TermOp ApplySymbol [TermVar funVar, TermVar argVar] `Equals` valueExpr))) -- f(x) = e for all x\in d + , Asm (rightUniqueAdj (TermVar funVar)) + , Asm (relationNoun (TermVar funVar)) + ] + checkProof continue + Calc calc continue -> do + checkCalc calc + assume [Asm (calcResult calc)] + checkProof continue + +checkCalc :: Calc -> Checking +checkCalc calc = locally do + let tasks = calculation calc + forM_ tasks tell + where + tell = \case + (goal, by) -> setGoals [goal] *> justify by + + +makeReplacementIff + :: forall a. (ExprOf (Var VarSymbol a) -- ^ Newly defined local constant. + -> NonEmpty (VarSymbol, ExprOf a) -- ^ Bounds of the replacement. + -> Scope VarSymbol ExprOf a -- ^ Left hand side (function application). + -> Scope VarSymbol ExprOf a -- ^ Optional constraints on bounds (can just be 'Top'). + -> ExprOf a) +makeReplacementIff e bounds lhs cond = + Forall (toScope (Iff (TermVar (B "frv") `IsElementOf` e) existsPreimage)) + where + existsPreimage :: ExprOf (Var VarSymbol a) + existsPreimage = Exists (toScope replaceBound) + + replaceBound :: ExprOf (Var VarSymbol (Var VarSymbol a)) + replaceBound = makeConjunction [TermVar (B x) `IsElementOf` (F . F <$> xB) | (x, xB) <- toList bounds] `And` replaceCond + + replaceEq :: ExprOf (Var VarSymbol (Var VarSymbol a)) + replaceEq = (nestF <$> fromScope lhs) `Equals` TermVar (F (B "frv")) + + replaceCond :: ExprOf (Var VarSymbol (Var VarSymbol a)) + replaceCond = case fromScope cond of + Top -> replaceEq + cond' -> replaceEq `And` (F <$> cond') + + nestF :: Var b a1 -> Var b (Var b1 a1) + nestF (B a) = B a + nestF (F a) = F (F a) + + +splitGoalWithSetExt :: Formula -> CheckingM [Formula] +splitGoalWithSetExt = \case + NotEquals x y -> do + let z = FreshVar 0 + elemNotElem x' y' = makeExists [FreshVar 0] (And (TermVar z `IsElementOf` x') ((TermVar z `IsNotElementOf` y'))) + pure [elemNotElem x y `Or` elemNotElem y x] + Equals x y -> do + let z = FreshVar 0 + subset x' y' = makeForall [FreshVar 0] (Implies (TermVar z `IsElementOf` x') ((TermVar z `IsElementOf` y'))) + pure [subset x y, subset y x] + goal -> throwIO (MismatchedSetExt [goal]) + +justify :: Justification -> Checking +justify = \case + JustificationEmpty -> tellTasks + JustificationLocal -> byAssumption + JustificationRef ms -> byRef ms + JustificationSetExt -> do + goals <- gets checkingGoals + case goals of + [goal] -> do + goals' <- splitGoalWithSetExt goal + setGoals goals' + tellTasks + _ -> throwIO (MismatchedSetExt goals) + +byRef :: NonEmpty Marker -> Checking +byRef ms = locally do + facts <- gets checkingFacts + dumpPremselTraining <- gets checkingDumpPremselTraining + case dumpPremselTraining of + WithDumpPremselTraining -> dumpTrainingData facts ms + WithoutDumpPremselTraining -> skip + case InsOrdMap.lookupsMap ms facts of + Left (Marker str) -> error ("unknown marker: " <> Text.unpack str) + Right facts' -> modify (\st -> st{checkingFacts = facts'}) *> tellTasks + +byAssumption :: Checking +byAssumption = locally do + modify (\st -> st{checkingFacts = mempty}) *> tellTasks + +dumpTrainingData :: InsOrdMap Marker Formula -> NonEmpty Marker -> Checking +dumpTrainingData facts ms = do + let (picked, unpicked) = InsOrdMap.pickOutMap ms facts + lexicon <- gets checkingLexicon + goals <- gets checkingGoals + m@(Marker m_) <- gets blockLabel + _localFacts <- withMarker m <$> gets checkingAssumptions + let dir = "premseldump" + let makePath k = dir </> (Text.unpack m_ <> show (k :: Int)) <.> "txt" + let dumpTrainingExample goal = + let conj = encodeConjecture lexicon m goal + usefuls = encodeWithRole Tptp.AxiomUseful lexicon (InsOrdMap.toList picked) + redundants = encodeWithRole Tptp.AxiomRedundant lexicon (InsOrdMap.toList unpicked) + k = hash goal + example = Tptp.toTextNewline (Tptp.Task (conj : (usefuls <> redundants))) + in do + liftIO (Text.writeFile (makePath k) example) + liftIO (createDirectoryIfMissing True dir) + forM_ goals dumpTrainingExample + +-- | Since the case tactic replaces /all/ current goals with the disjunction +-- of the different case hypotheses, each case proof must cover all goals. +checkCase :: Case -> Checking +checkCase (Case split proof) = locally do + assume [Asm split] + checkProof proof + + +checkDefn :: Defn -> Checking +checkDefn = \case + DefnPredicate asms symb vs f -> do + -- We first need to take the universal closure of the defining formula + -- while ignoring the variables that occur on the lhs, then take the + -- universal formula of the equivalence, quantifying the remaining + -- variables (from the lhs). + let vs' = TermVar <$> toList vs + let f' = forallClosure (Set.fromList (toList vs)) f + addFactWithAsms asms (Atomic symb vs' `Iff` f') + DefnFun asms fun vs rhs -> do + let lhs = TermSymbol (SymbolFun fun) (TermVar <$> vs) + addFactWithAsms asms (lhs `Equals` rhs) + -- TODO Check that the function symbol on the lhs does not appear on the rhs. + DefnOp op vs (TermSep x bound phi) -> + addFact $ makeForall (x : vs) $ + Iff (TermVar x `IsElementOf` TermOp op (TermVar <$> vs)) + ((TermVar x `IsElementOf` bound) `And` instantiate1 (TermVar x) phi) + DefnOp op vs (TermSymbol symbol [x, y]) | symbol == SymbolMixfix ConsSymbol -> do + -- TODO generalize this to support arbitrarily many applications of _Cons + -- and also handle the case of emptyset or singleton as final argument separately + -- so that finite set terms get recognized in full. + let phi = TermVar "any" `IsElementOf` TermOp op (TermVar <$> vs) + let psi = (TermVar "any" `IsElementOf` y) `Or` (TermVar "any" `Equals` x) + addFact (makeForall ("any" : vs) (phi `Iff` psi)) + DefnOp op vs (ReplacePred _y _x xBound scope) -> do + let x = (FreshVar 0) + let y = (FreshVar 1) + let y' = (FreshVar 2) + let fromReplacementVar = \case + ReplacementDomVar -> TermVar x + ReplacementRangeVar -> TermVar y + let fromReplacementVar' = \case + ReplacementDomVar -> TermVar x + ReplacementRangeVar -> TermVar y' + let phi = instantiate fromReplacementVar scope + let psi = instantiate fromReplacementVar' scope + let singleValued = makeForall [x] ((TermVar x `IsElementOf` xBound) `Implies` makeForall [y, y'] ((phi `And` psi) `Implies` (TermVar y `Equals` TermVar y'))) + setGoals [singleValued] + tellTasks + addFact (makeForall (y : vs) ((TermVar y `IsElementOf` TermOp op (TermVar <$> vs)) `Iff` makeExists [x] ((TermVar x `IsElementOf` xBound) `And` phi))) + + DefnOp op vs (ReplaceFun bounds lhs cond) -> + addFact (forallClosure mempty (makeReplacementIff (TermOp op (TermVar . F <$> vs)) bounds lhs cond)) + DefnOp op vs rhs -> + if containsHigherOrderConstructs rhs + then throwIO (CouldNotEliminateHigherOrder op rhs) + else do + let lhs = TermSymbol (SymbolMixfix op) (TermVar <$> vs) + addFactWithAsms [] (lhs `Equals` rhs) + + +checkSig :: [Asm] -> Signature -> Checking +checkSig asms sig = case sig of + SignatureFormula f -> + addFactWithAsms asms f + SignaturePredicate _predi _vs -> do + skip -- TODO + +-- | Annotate plain structure operations in a formula with the label of a suitable in-scope struct. +annotateStructOps :: Formula -> CheckingM Formula +annotateStructOps phi = do + ops <- gets instantiatedStructOps + labels <- gets instantiatedStructs + pure (annotateWith labels ops phi) + + +mergeAssumptions :: [Asm] -> CheckingM ([Formula], Set VarSymbol, HashMap StructSymbol VarSymbol) +mergeAssumptions [] = pure ([], mempty, mempty) +mergeAssumptions (asm : asms) = case asm of + Asm phi -> + (\(phis, xs, ops) -> (phi : phis, xs, ops)) <$> mergeAssumptions asms + AsmStruct x phrase -> do + st <- get + let structGraph = checkingStructs st + let struct = lookupStruct structGraph phrase + let fixes = StructGraph.structSymbols struct structGraph + let ops' = HM.fromList [(op, x) | op <- Set.toList fixes] + (\(phis, xs, ops) -> (TermSymbol (SymbolPredicate (PredicateNounStruct phrase)) [TermVar x] : phis, Set.insert x xs, ops' <> ops)) <$> mergeAssumptions asms + +canonicalize :: Formula -> CheckingM Formula +canonicalize = unabbreviate >=> annotateStructOps >=> desugarComprehensionsA + +canonicalizeWith :: Set VarSymbol -> HashMap StructSymbol VarSymbol -> Formula -> CheckingM Formula +canonicalizeWith labels ops = unabbreviate >=> annotateWithA labels ops >=> desugarComprehensionsA + +annotateWithA :: Applicative f => Set VarSymbol -> HashMap StructSymbol VarSymbol -> Formula -> f Formula +annotateWithA labels ops phi = pure (annotateWith labels ops phi) + +unabbreviate :: ExprOf a -> CheckingM (ExprOf a) +unabbreviate phi = do + abbrs <- gets checkingAbbreviations + pure (unabbreviateWith ((absurd <$>) <$> abbrs) phi) + + + +checkInductive :: Inductive -> Checking +checkInductive Inductive{..} = do + forM inductiveIntros (checkIntroRule inductiveSymbol inductiveParams inductiveDomain) + addFact (forallClosure mempty (TermOp inductiveSymbol (TermVar <$> inductiveParams) `IsSubsetOf` inductiveDomain)) + forM_ inductiveIntros addIntroRule + +addIntroRule :: IntroRule -> Checking +addIntroRule (IntroRule conditions result) = addFact (forallClosure mempty (makeConjunction conditions `Implies` result)) + +checkIntroRule :: FunctionSymbol -> [VarSymbol] -> Expr -> IntroRule -> Checking +checkIntroRule f args dom rule = do + case isValidIntroRule f args rule of + Left err -> error err + Right goals -> case List.filter (/= Top) goals of + [] -> skip + goals' -> setGoals goals' *> tellTasks + setGoals [typecheckRule f args dom rule] *> tellTasks + +-- isValidCondition e phi returns 'Right' the needed monotonicity proof tasks if the condition is a valid for an inductive definition of e, and returns 'Left' if the condition is invalid. +isValidCondition :: FunctionSymbol -> [VarSymbol] -> Formula -> Either String Formula +isValidCondition f args phi = if isSideCondition phi + then Right Top -- Side conditions do not require any monotonicty proofs. + else monotonicty phi + where + -- Side conditions are formulas in which f does not appear. + isSideCondition :: ExprOf a -> Bool + isSideCondition = \case + Not a -> isSideCondition a + Connected _ a b -> isSideCondition a && isSideCondition b + TermVar _ -> True + TermSymbol f' args -> f' /= SymbolMixfix f && all isSideCondition args + TermSymbolStruct _ Nothing -> True + TermSymbolStruct _ (Just e) -> isSideCondition e + Apply a b -> isSideCondition a && all isSideCondition b + TermSep _ xB cond -> isSideCondition xB && isSideCondition (fromScope cond) + Iota _ body -> isSideCondition (fromScope body) + ReplacePred _ _ e scope -> isSideCondition e && isSideCondition (fromScope scope) + ReplaceFun bounds lhs rhs -> + all (\(_, e) -> isSideCondition e) bounds && isSideCondition (fromScope lhs) && isSideCondition (fromScope rhs) + Lambda body -> isSideCondition (fromScope body) + Quantified _ body -> isSideCondition (fromScope body) + PropositionalConstant _ -> True + -- Potential monotonicity task for conditions in which f appears + monotonicty = \case + -- Conditions that are not side conditions must be atomic statements about membership + _ `IsElementOf` TermOp f' args' | f' == f && args' == (TermVar <$> args) -> + Right Top -- No monotonicity to prove if the symbols occurs plainly. + _ `IsElementOf` e -> + Right (monotone (extractMonotonicFunction e)) + _ -> Left "Intro rule not of the form \"_ \\in h(_) \"" + -- IMPORTANT: we assume that extractMonotonicFunction is applied to a first-order term + extractMonotonicFunction :: Expr -> (Expr -> Expr) + extractMonotonicFunction e = \x -> go x e + where + go x = \case + TermSymbol f' args' -> if + | f' == SymbolMixfix f && args' == (TermVar <$> args) -> x + | f' == SymbolMixfix f -> error ("symbol " <> show f <> " occurred with the wrong arguments " <> show args') + | otherwise -> TermSymbol f' (go x <$> args') + TermVar x -> TermVar x + e@(TermSymbolStruct _ Nothing) -> e + TermSymbolStruct s (Just e') -> TermSymbolStruct s (Just (go x e')) + _ -> error "could not extract monotonic function" + +isValidResult :: FunctionSymbol -> [VarSymbol] -> Formula -> Bool +isValidResult f args phi = case phi of + _ `IsElementOf` e | e == TermOp f (TermVar <$> args) -> True + _ -> False + +isValidIntroRule :: FunctionSymbol -> [VarSymbol] -> IntroRule -> Either String [Formula] +isValidIntroRule f args rule = if isValidResult f args (introResult rule) + then mapM (isValidCondition f args) (introConditions rule) + else Left "invalid result in rule" + +monotone :: (Expr -> Expr) -> Formula +monotone h = makeForall ("xa" : ["xb"]) + ((TermVar "xa" `IsSubsetOf` TermVar "xb") `Implies` (h (TermVar "xa") `IsSubsetOf` h (TermVar "xb"))) + +typecheckRule :: FunctionSymbol -> [VarSymbol] -> Expr -> IntroRule -> Formula +typecheckRule f args dom (IntroRule conds result) = makeConjunction (go <$> conds) `Implies` go result + where + -- replace symbol by dom for TC rule + go :: Expr -> Expr + go = \case + TermSymbol f' args' -> if + | f' == SymbolMixfix f && args' == (TermVar <$> args) -> dom + | f' == SymbolMixfix f -> error ("typecheckRule: symbol " <> show f <> " occurred with the wrong arguments " <> show args') + | otherwise -> TermSymbol f' (go <$> args') + TermVar x -> TermVar x + e@(TermSymbolStruct _ Nothing) -> e + TermSymbolStruct s (Just e') -> TermSymbolStruct s (Just (go e')) + Not a -> Not (go a) + Connected conn a b -> Connected conn (go a) (go b) + Apply a b -> Apply (go a) (go <$> b) + e@PropositionalConstant{} -> e + --TermSep x xB cond -> TermSep x (go xB) (hoistScope go cond) + --Iota x body -> Iota x (hoistScope go body) + --ReplacePred x y e scope -> ReplacePred x y (go e) (hoistScope go scope) + --ReplaceFun bounds lhs rhs -> + -- ReplaceFun ((\(x, e) -> (x, go e)) <$> bounds) (hoistScope go lhs) (hoistScope go rhs) + --Lambda body -> Lambda (hoistScope go body) + --Quantified quant body -> Quantified quant (hoistScope go body) + _ -> error "typecheckRule does not handle binders" + +checkStructDefn :: StructDefn -> Checking +checkStructDefn StructDefn{..} = do + st <- get + let structGraph = checkingStructs st + let m@(Marker m_) = blockLabel st + let structAncestors = Set.unions (Set.map (`StructGraph.lookupAncestors` structGraph) structParents) + let structAncestors' = structParents <> structAncestors + let isStruct p = TermSymbol (SymbolPredicate (PredicateNounStruct p)) [TermVar structDefnLabel] + let intro = forallClosure mempty if structParents == Set.singleton _Onesorted + then makeConjunction (snd <$> structDefnAssumes) `Implies` isStruct structPhrase + else makeConjunction ([isStruct parent | parent <- toList structParents] <> (snd <$> structDefnAssumes)) `Implies` isStruct structPhrase + let intro' = (m, intro) + let inherit' = (Marker (m_ <> "inherit"), forallClosure mempty (isStruct structPhrase `Implies` makeConjunction [isStruct parent | parent <- toList structParents])) + let elims' = [(marker, forallClosure mempty (isStruct structPhrase `Implies` phi)) | (marker, phi) <- structDefnAssumes] + rules' <- forM (InsOrdMap.fromList (intro' : inherit' : elims')) canonicalize + put st + { checkingStructs = StructGraph.insert structPhrase structAncestors' structDefnFixes (checkingStructs st) + , checkingFacts = rules' <> checkingFacts st + } + +fixing :: NonEmpty VarSymbol -> Checking +fixing xs = do + goals <- gets checkingGoals + let (goal, goals') = case goals of + goal : goals' -> (goal, goals') + _ -> error "no open goals, cannot use \"fix\" step" + let goal' = case goal of + Forall body | [_bv] <- nubOrd (bindings body) -> + -- If there's only one quantified variable we can freely choose a new name. + -- This is useful for nameless quantified phrases such as @every _ is an element of _@. + case xs of + x :| [] -> + instantiate (\_bv -> TermVar x) body + _ -> + error "couldn't use fix: only one bound variable but multiple variables to be fixed" + Forall body | toList xs `List.intersect` nubOrd (bindings body) == toList xs -> + Forall (instantiateSome xs body) + Forall body -> + error ("You can only use \"fix\" if all specified variables occur in the outermost quantifier. Variables to be fixed were: " + <> show xs <> " but only the following are bound: " <> show (nubOrd (bindings body))) + _ -> + error "you can only use \"fix\" if the goal is universal." + setGoals (goal' : goals') + +-- | An assumption step in a proof is supposed to match the goal. +matchAssumptionWithGoal :: Formula -> CheckingM [Formula] +matchAssumptionWithGoal asm = do + goals <- gets checkingGoals + let (goal, goals') = case goals of + goal : goals' -> (goal, goals') + _ -> error "no open goals, cannot use assumption step" + defns <- gets checkingPredicateDefinitions + case syntacticMatch goal of + Just phi -> pure (phi : goals') + -- + -- Unfolding definitions against atomic goals + Nothing -> case goal of + phi@(Atomic p args) -> + let rhos = (HM.lookup p defns ?? []) + rhos' = [instantiate (\k -> nth k args ?? error "defns: incorrect index") (absurd <$> rho) | rho <- rhos] + in case firstJust syntacticMatch rhos' of + Nothing -> throwIO (MismatchedAssume asm phi) + Just match -> pure (match : goals') + phi -> + throwIO (MismatchedAssume asm phi) + + where + syntacticMatch :: Formula -> Maybe Formula + syntacticMatch = \case + (phi1 `And` phi2) `Implies` psi | phi1 == asm -> + Just (phi2 `Implies` psi) + (phi1 `And` phi2) `Implies` psi | phi2 == asm -> + Just (phi1 `Implies` psi) + phi `Implies` psi | phi == asm -> + Just psi + phi `Or` psi | phi == asm -> + Just (dual psi) + _ -> Nothing + + +checkAbbr :: Abbreviation -> Checking +checkAbbr (Abbreviation symbol scope) = do + scope' <- transverseScope unabbreviate scope + modify (\st -> st{checkingAbbreviations = HM.insert symbol scope' (checkingAbbreviations st)}) diff --git a/source/Checking/Cache.hs b/source/Checking/Cache.hs new file mode 100644 index 0000000..74185aa --- /dev/null +++ b/source/Checking/Cache.hs @@ -0,0 +1,30 @@ +module Checking.Cache where + +import Base +import Syntax.Internal(Task) + +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.Binary + +-- The following would not work: +-- Checking that the new task is a superset of an old task: +-- additional assumptions may slow down the checking and +-- lead to a failure with default timeouts. Then when you +-- recheck the file from scratch it won't work. + + +hashTasks :: [Task] -> IntSet +hashTasks tasks = IntSet.fromList (hash <$> tasks) + + +putTaskCache :: MonadIO io => FilePath -> [Task] -> io () +putTaskCache path tasks = liftIO $ encodeFile path $ hashTasks tasks + + +notInCache :: MonadIO io => FilePath -> Task -> io Bool +notInCache path task = do + eitherHashedTasks <- liftIO $ decodeFileOrFail path + pure case eitherHashedTasks of + Left _ -> True + Right hashedTasks -> hash task `IntSet.notMember` hashedTasks diff --git a/source/CommandLine.hs b/source/CommandLine.hs new file mode 100644 index 0000000..a9fb00d --- /dev/null +++ b/source/CommandLine.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} + +module CommandLine where + +import Api +import Base +import Provers qualified +import Version qualified + +import Control.Monad.Logger +import Control.Monad.Reader +import Data.Text.IO qualified as Text +import Data.Text.Lazy.IO qualified as LazyText +import Options.Applicative +import Text.Pretty.Simple (pShowNoColor) +import UnliftIO +import UnliftIO.Directory +import UnliftIO.Environment (lookupEnv) +import System.FilePath.Posix + + +runCommandLine :: IO () +runCommandLine = do + options@Options{withLogging = logging} <- execParser (withInfo parseOptions) + case logging of + WithoutLogging -> runNoLoggingT (runReaderT run options) + WithLogging -> runStdoutLoggingT (runReaderT run options) + where + withInfo :: Parser a -> ParserInfo a + withInfo p = info (helper <*> p) (fullDesc <> header "Naproche/ZF") + + +run :: (MonadUnliftIO io, MonadLogger io, MonadReader Options io) => io () +run = do + opts <- ask + case withVersion opts of + WithVersion -> liftIO (Text.putStrLn Version.info) + WithoutVersion -> skip + case withOmissions opts of + WithoutOmissions -> liftIO (Text.putStrLn "--safe is not implemented yet.") + WithOmissions -> skip + case withDump opts of + WithoutDump -> skip + WithDump dir -> do + let serials = [dir </> show n <.> "p" | n :: Int <- [1..]] + tasks <- zip serials <$> encodeTasks (inputPath opts) + createDirectoryIfMissing True dir + forM_ tasks (uncurry dumpTask) + case (withParseOnly opts, withMegalodon opts) of + (WithParseOnly, _) -> do + ast <- parse (inputPath opts) + liftIO (LazyText.putStrLn (pShowNoColor ast)) + (_, WithMegalodon) -> do + megalodon <- exportMegalodon (inputPath opts) + let outputFile = "megalodon" </> replaceExtension (inputPath opts) "mg" + createDirectoryIfMissing True (takeDirectory outputFile) + liftIO (Text.writeFile outputFile megalodon) + (WithoutParseOnly, WithoutMegalodon) -> do + -- A custom E executable can be configured using environment variables. + -- If the environment variable is undefined we fall back to the + -- a globally installed E executable. + vampirePathPath <- (?? "vampire") <$> lookupEnv "NAPROCHE_VAMPIRE" + eproverPath <- (?? "eprover") <$> lookupEnv "NAPROCHE_EPROVER" + let prover = case withProver opts of + WithVampire -> Provers.vampire vampirePathPath + WithEprover -> Provers.eprover eproverPath + WithIprover -> Provers.iprover + WithDefaultProver -> Provers.vampire vampirePathPath + let proverInstance = prover Provers.Silent (withTimeLimit opts) (withMemoryLimit opts) + result <- verify proverInstance (inputPath opts) + liftIO case result of + VerificationSuccess -> (Text.putStrLn "Verification successful.") + VerificationFailure [] -> error "Empty verification fail" + VerificationFailure ((_, proverAnswer) : _) -> case proverAnswer of + Yes -> + skip + No tptp -> do + putStrLn "Verification failed: prover found countermodel" + Text.hPutStrLn stderr tptp + ContradictoryAxioms tptp -> do + putStrLn "Verification failed: contradictory axioms" + Text.hPutStrLn stderr tptp + Uncertain tptp -> do + putStrLn "Verification failed: out of resources" + Text.hPutStrLn stderr tptp + Error err -> + Text.hPutStrLn stderr err + + + +parseOptions :: Parser Options +parseOptions = do + inputPath <- strArgument (help "Source file" <> metavar "FILE") + withCache <- withCacheParser + withDump <- withDumpParser + withFilter <- withFilterParser + withLogging <- withLoggingParser + withMemoryLimit <- withMemoryLimitParser + withOmissions <- withOmissionsParser + withParseOnly <- withParseOnlyParser + withProver <- withProverParser + withTimeLimit <- withTimeLimitParser + withVersion <- withVersionParser + withMegalodon <- withMegalodonParser + withDumpPremselTraining <- withDumpPremselTrainingParser + pure Options{..} + +withTimeLimitParser :: Parser Provers.TimeLimit +withTimeLimitParser = Provers.Seconds <$> option auto (long "timelimit" <> short 't' <> value dflt <> help "Time limit for each proof task in seconds.") + where + Provers.Seconds dflt = Provers.defaultTimeLimit + +withMemoryLimitParser :: Parser Provers.MemoryLimit +withMemoryLimitParser = Provers.Megabytes <$> option auto (long "memlimit" <> short 'm' <> value dflt <> help "Memory limit for each proof task in MB.") + where + Provers.Megabytes dflt = Provers.defaultMemoryLimit + +withProverParser :: Parser WithProver +withProverParser = flag' WithEprover (long "eprover" <> help "Use E as external prover.") + <|> flag' WithVampire (long "vampire" <> help "Use Vampire as external prover.") + <|> flag' WithIprover (long "iprover" <> help "Use iProver as external prover.") + <|> pure WithDefaultProver + +withFilterParser :: Parser WithFilter +withFilterParser = flag' WithoutFilter (long "nofilter" <> help "Do not perform relevance filtering.") + <|> flag' WithFilter (long "filter" <> help "Perform relevance filtering.") + <|> pure WithoutFilter + +withOmissionsParser :: Parser WithOmissions +withOmissionsParser = flag' WithOmissions (long "unsafe" <> help "Allow proof omissions (default).") + <|> flag' WithoutOmissions (long "safe" <> help "Disallow proof omissions.") + <|> pure WithOmissions -- Default to allowing omissions. + +withParseOnlyParser :: Parser WithParseOnly +withParseOnlyParser = flag' WithParseOnly (long "parseonly" <> help "Only parse and show the resulting AST.") + <|> pure WithoutParseOnly -- Default to allowing omissions. + +withVersionParser :: Parser WithVersion +withVersionParser = flag' WithVersion (long "version" <> help "Show the current version.") + <|> pure WithoutVersion -- Default to not showing the version. + +withLoggingParser :: Parser WithLogging +withLoggingParser = flag' WithLogging (long "log" <> help "Enable logging.") + <|> pure WithoutLogging -- Default to not showing the version. + +withCacheParser :: Parser WithCache +withCacheParser = flag' WithoutCache (long "uncached" <> help "Do not use caching.") + <|> flag' WithCache (long "cached" <> help "Use caching (default).") + <|> pure WithCache -- Default to using the cache. + +withDumpParser :: Parser WithDump +withDumpParser = WithDump <$> strOption (long "dump" <> metavar "DUMPDIR" <> help "Dump all proof tasks in a separate directory.") + <|> pure WithoutDump -- Default to using the cache. + +withDumpPremselTrainingParser :: Parser WithDumpPremselTraining +withDumpPremselTrainingParser = flag' WithDumpPremselTraining (long "premseldump" <> help "Dump training data for premise selection.") + <|> pure WithoutDumpPremselTraining -- Default to using the cache. + +withMegalodonParser :: Parser WithMegalodon +withMegalodonParser = flag' WithMegalodon (long "megalodon" <> help "Export to Megalodon.") + <|> pure WithoutMegalodon -- Default to using the cache. diff --git a/source/Data/InsOrdMap.hs b/source/Data/InsOrdMap.hs new file mode 100644 index 0000000..ae75d31 --- /dev/null +++ b/source/Data/InsOrdMap.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TupleSections #-} + +{- + Simple "mostly-insert-only" insert-ordered maps. + + There's also OMap from ordered-containers which uses two regular Maps, + but this isn't really more efficient for our use case. + + There's also InsOrdHashMap from insert-ordered-containers which tries + its best to preserve the insertion order. Alas, this isn't quite enough to have + stable ATP proofs. At scale and with some other features helping with proof stability, + (i.e. prover guidance, premise selection, etc), it may be worth revisiting InsOrdHashMap. +-} + +module Data.InsOrdMap where + +import Data.Either +import Data.Functor +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Int +import Data.List qualified as List +import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (Maybe, maybe) +import Data.Maybe qualified as Maybe +import Data.Monoid +import Data.Semigroup +import Prelude (error) +import Data.Traversable +import Data.Foldable hiding (toList) + +data InsOrdMap k v = InsOrdMap {toList :: [(k, v)], toHashMap :: (HashMap k v)} + +instance Hashable k => Semigroup (InsOrdMap k a) where + InsOrdMap a b <> InsOrdMap c d = InsOrdMap (a <> c) (b <> d) + +instance Hashable k => Monoid (InsOrdMap k a) where + mempty = InsOrdMap mempty mempty + +instance Functor (InsOrdMap k) where + fmap f (InsOrdMap asList asHashMap) = InsOrdMap (fmap (\(k,v) -> (k, f v)) asList) (fmap f asHashMap) + +instance Foldable (InsOrdMap k) where + foldr f b (InsOrdMap _asList asHashMap) = foldr f b asHashMap + +instance Traversable (InsOrdMap k) where + traverse f (InsOrdMap _asList asHashMap) = fromHashMap <$> (traverse f asHashMap) + +size :: InsOrdMap k v -> Int +size omap = HM.size (toHashMap omap) + +fromList :: Hashable k => [(k, v)] -> InsOrdMap k v +fromList kvs = InsOrdMap kvs (HM.fromList kvs) + +fromHashMap :: HashMap k v -> InsOrdMap k v +fromHashMap kvs = InsOrdMap (HM.toList kvs) kvs + +insert :: Hashable k => k -> v -> InsOrdMap k v -> InsOrdMap k v +insert k v (InsOrdMap kvs kvs') = InsOrdMap ((k, v) : kvs) (HM.insert k v kvs') + +mapMaybe :: (v1 -> Maybe v) -> InsOrdMap k v1 -> InsOrdMap k v +mapMaybe f (InsOrdMap kvs kvs') = InsOrdMap (Maybe.mapMaybe (\(k, v) -> (k,) <$> f v) kvs) (HM.mapMaybe f kvs') + +lookup :: Hashable k => k -> InsOrdMap k a -> Maybe a +lookup a (InsOrdMap _ kvs) = HM.lookup a kvs + +lookups :: Hashable k => NonEmpty k -> InsOrdMap k v -> Either k (NonEmpty v) +lookups ks kvs = + let lookups' = (\a kvs' -> maybe (Left a) Right (lookup a kvs')) <$> ks + flap ff x = (\f -> f x) <$> ff + in case partitionEithers (NonEmpty.toList (flap lookups' kvs)) of + (missingKey : _, _) -> Left missingKey + ([], v : vs) -> Right (v :| vs) + ([], []) -> error "IMPOSSIBLE (Data.InsOrdMap.lookups): one of the two result lists must be nonempty as they partition a nonempty list" + +-- | Only intended for very small nonempty lists of keys! +lookupsMap :: Hashable k => NonEmpty k -> InsOrdMap k v -> Either k (InsOrdMap k v) +lookupsMap ks kvs = + let lookups' = (\a kvs' -> maybe (Left a) Right (lookup a kvs')) <$> ks + flap ff x = (\f -> f x) <$> ff + in case partitionEithers (NonEmpty.toList (flap lookups' kvs)) of + (missingKey : _, _) -> Left missingKey + ([], vs) -> Right (fromList (List.zip (NonEmpty.toList ks) vs)) + +-- | Split an InsOrdMap into an InsOrdMap specified by given "relevant" keys and non-given "irrelevant" keys. +pickOutMap :: Hashable k => NonEmpty k -> InsOrdMap k v -> (InsOrdMap k v, InsOrdMap k v) +pickOutMap ks kvs = + let (relevants, irrelevants) = List.partition (\(k,_) -> k `List.elem` NonEmpty.toList ks) (toList kvs) + in (fromList relevants, fromList irrelevants) diff --git a/source/Encoding.hs b/source/Encoding.hs new file mode 100644 index 0000000..e3a65f2 --- /dev/null +++ b/source/Encoding.hs @@ -0,0 +1,159 @@ +module Encoding where + + +import Base +import Syntax.Internal +import Syntax.Lexicon +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Data.Text qualified as Text +import Bound +import Bound.Scope + + +encodeTask :: Lexicon -> Task -> Tptp.Task +encodeTask l (Task _isByContradiction hypos m conjecture) = Tptp.Task (conjecture' : hypos') + where + conjecture' = encodeConjecture l m conjecture + hypos' = encodeHypos l hypos + + +encodeConjecture :: Lexicon -> Marker -> Formula -> Tptp.AnnotatedFormula +encodeConjecture l (Marker str) f = Tptp.AnnotatedFormula (Tptp.NameAtomicWord (Tptp.AtomicWord str)) Tptp.Conjecture (encodeExpr l f) + +-- NOTE: E's SInE will only filter out axioms and leave hypotheses fixed. +encodeHypos :: Lexicon -> [(Marker, Formula)] -> [Tptp.AnnotatedFormula] +encodeHypos l phis = [makeHypo m (encodeExpr l phi) | (m, phi) <- phis] + where + makeHypo :: Marker -> Tptp.Expr -> Tptp.AnnotatedFormula + makeHypo (Marker str) f' = Tptp.AnnotatedFormula (Tptp.NameAtomicWord (Tptp.AtomicWord str)) Tptp.Axiom f' + +encodeWithRole :: Tptp.Role -> Lexicon -> [(Marker, Formula)] -> [Tptp.AnnotatedFormula] +encodeWithRole role l phis = [makeHypo m (encodeExpr l phi) | (m, phi) <- phis] + where + makeHypo :: Marker -> Tptp.Expr -> Tptp.AnnotatedFormula + makeHypo (Marker str) f' = Tptp.AnnotatedFormula (Tptp.NameAtomicWord (Tptp.AtomicWord str)) role f' + + +encodeExpr :: Lexicon -> Expr -> Tptp.Expr +encodeExpr l = go . (fmap encodeFreeVar) + where + go :: ExprOf Tptp.Expr -> Tptp.Expr + go = \case + e1 `Equals` e2 -> + Tptp.Eq (go e1) (go e2) + e1 `NotEquals` e2 -> + Tptp.NotEq (go e1) (go e2) + Atomic p es -> + let p' = encodePredicate l p + es' = go <$> toList es + in Tptp.Apply p' es' + PropositionalConstant IsBottom -> + Tptp.Bottom + PropositionalConstant IsTop -> + Tptp.Top + Not f -> + Tptp.Not (go f) + Connected Conjunction f1 f2 -> + Tptp.Conn Tptp.And (go f1) (go f2) + Connected Disjunction f1 f2 -> + Tptp.Conn Tptp.Or (go f1) (go f2) + Connected Implication f1 f2 -> + Tptp.Conn Tptp.Imply (go f1) (go f2) + Connected Equivalence f1 f2 -> + Tptp.Conn Tptp.Iff (go f1) (go f2) + Connected NegatedDisjunction f1 f2 -> + Tptp.Not (Tptp.Conn Tptp.Or (go f1) (go f2)) + Connected ExclusiveOr f1 f2 -> + Tptp.Not (Tptp.Conn Tptp.Iff (go f1) (go f2)) + Quantified quant scope -> + let phi = instantiate instantiator scope + xs = [encodeBoundVar x | x <- nubOrd (bindings scope)] + phi' = go phi + quant' = encodeQuant quant + in case xs of + [] -> phi' + y:ys -> Tptp.Quantified quant' (y:|ys) phi' + TermVar v -> + v + Apply e es -> case e of + TermVar (Tptp.Const x) -> Tptp.Apply x (go <$> toList es) + _ -> error ("encodeExpr: complex term as head of applicaition: " <> show e) + TermSymbol symb es -> + Tptp.Apply (encodeSymbol l symb) (go <$> es) + e@ReplaceFun{} -> + error ("Precondition failed in encodeTerm, cannot encode terms with comprehensions directly: " <> show e) + e@ReplacePred{} -> + error ("Precondition failed in encodeTerm, cannot encode terms with comprehensions directly: " <> show e) + e@TermSep{} -> + error ("Precondition failed in encodeTerm, cannot encode terms with comprehensions directly: " <> show e) + e@Iota{} -> + error ("Precondition failed in encodeTerm, cannot encode terms with descriptors directly: " <> show e) + TermSymbolStruct symb e -> case e of + Just e' -> + Tptp.Apply (Tptp.AtomicWord ("s__" <> (unStructSymbol symb))) [go e'] + Nothing -> + error ("encodeExpr.go (precondition failed): unannotated struct symbol" <> show symb) + _ -> error "encodeExpr.go: missing case" + + +instantiator :: VarSymbol -> ExprOf Tptp.Expr +instantiator bv = TermVar (Tptp.Var (encodeBoundVar bv)) + + + +encodeQuant :: Quantifier -> Tptp.Quantifier +encodeQuant Universally = Tptp.Forall +encodeQuant Existentially = Tptp.Exists + + + + +encodeSymbol :: Lexicon -> Symbol -> Tptp.AtomicWord +encodeSymbol l symb = atomicWordFromRightMarker case symb of + SymbolMixfix op -> + lookupOp op (lexiconMixfix l) + SymbolFun fun -> + lookupLexicalItem fun (lexiconFuns l) + SymbolInteger n -> + Right (Marker (Text.pack (show n))) + SymbolPredicate _ -> + error "IMPOSSIBLE: predicates should already be translated" + + +encodePredicate :: Lexicon -> Predicate -> Tptp.AtomicWord +encodePredicate l p = atomicWordFromRightMarker case p of + PredicateAdj adj -> + lookupLexicalItem adj (lexiconAdjs l) + PredicateVerb verb -> + lookupLexicalItem verb (lexiconVerbs l) + PredicateNoun noun -> + lookupLexicalItem noun (lexiconNouns l) + PredicateRelation rel -> + lookupLexicalItem rel (lexiconRelationSymbols l) + PredicateNounStruct noun -> + lookupLexicalItem noun (lexiconStructNouns l) + PredicateSymbol symb -> + Right (Marker symb) + + +atomicWordFromRightMarker :: Either String Marker -> Tptp.AtomicWord +atomicWordFromRightMarker = \case + Right (Marker m) -> Tptp.AtomicWord m + Left a -> error ("symbol not in lexicon" <> a) + +encodeFreeVar :: VarSymbol -> Tptp.Expr +encodeFreeVar fv = Tptp.Const fv' + where + fv' = Tptp.AtomicWord case fv of + NamedVar x -> Text.cons 'f' x + FreshVar n -> Text.cons 'y' (Text.pack (show n)) + + +-- | Tptp variables must be "upper words", starting with an uppercase letter +-- and continuing with alphanumeric characters. We prefix all variables +-- with "X" to make them easy to decode. +encodeBoundVar :: VarSymbol -> Tptp.Variable +encodeBoundVar bv = Tptp.Variable $ Text.cons 'X' case bv of + NamedVar x -> x + FreshVar n -> Text.pack (show n) diff --git a/source/Filter.hs b/source/Filter.hs new file mode 100644 index 0000000..747a712 --- /dev/null +++ b/source/Filter.hs @@ -0,0 +1,121 @@ +module Filter where + + +import Base +import Syntax.Internal + +import Data.Set qualified as Set +import Data.Map qualified as Map +import GHC.Float (int2Float) +import Bound.Scope + + +convergence :: Float +convergence = 2.8 + + +passmark :: Float +passmark = 0.4 + + +filterTask :: Task -> Task +filterTask Task{taskDirectness = directness, taskConjectureLabel = label, taskConjecture = conjecture, taskHypotheses = hypotheses} = + let + motive = case directness of + Indirect formerConjecture -> formerConjecture + Direct -> conjecture + filteredHypos = if length hypotheses < 20 + then hypotheses + else Map.keys (relevantFacts passmark motive (Set.fromList hypotheses)) + in Task + { taskDirectness = directness + , taskConjecture = conjecture + , taskHypotheses = filteredHypos + , taskConjectureLabel = label + } + + +relevantFacts :: Float -> ExprOf a -> Set (Marker, Expr) -> Map (Marker, Expr) Float +relevantFacts p conjecture cs = relevantClausesNaive p (symbols conjecture) cs Map.empty + + +relevantClausesNaive + :: Float -- ^ Pass mark + -> Set Symbol -- ^ Relevant symbols + -> Set (Marker, Expr) -- ^ working irrelevant facts + -> Map (Marker, Expr) Float -- ^ Accumulator of relevant facts + -> Map (Marker, Expr) Float -- ^ Final relevant facts +relevantClausesNaive p rs cs a = + let ms = Map.fromSet (clauseMarkNaive rs) cs + rels = Map.filter (p <=) ms + cs' = Map.keysSet (Map.difference ms rels) + p' = p + (1 - p) / convergence + a' = a `Map.union` rels + rs' = Set.unions (Set.map (symbols . snd) (Map.keysSet rels)) `Set.union` rs + in + if Map.null rels + then a + else relevantClausesNaive p' rs' cs' a' + + +clauseMarkNaive + :: Set Symbol + -> (Marker, Expr) + -> Float +clauseMarkNaive rs c = + let cs = symbols (snd c) + r = cs `Set.intersection` rs + ir = cs `Set.difference` r + in int2Float (Set.size r) / int2Float (Set.size r + Set.size ir) + + +clauseMark :: Set Symbol -> ExprOf a -> Map Symbol Int -> Float +clauseMark rs c ftab = + let cs = symbols c + r = cs `Set.intersection` rs + ir = cs `Set.difference` r + m = sum (Set.map (ftab `funWeight`) r) + in m / (m + int2Float (Set.size ir)) + + +funWeight :: Map Symbol Int -> Symbol -> Float +funWeight ftab f = weightFromFrequency (Map.lookup f ftab ?? 0) + + +weightFromFrequency :: Int -> Float +weightFromFrequency n = 1 + 2 / log (int2Float n + 1) + + +symbols :: ExprOf a -> Set Symbol +symbols = \case + TermVar{} -> Set.empty + TermSymbol sym es -> Set.insert sym (Set.unions (fmap symbols es)) + TermSep _ e scope -> symbols e `Set.union` symbols (fromScope scope) + Iota _ scope -> symbols (fromScope scope) + ReplacePred _ _ e scope -> symbols e `Set.union` symbols (fromScope scope) + ReplaceFun es scope cond -> (Set.unions (fmap (symbols . snd) es)) `Set.union` symbols (fromScope scope) `Set.union` symbols (fromScope cond) + Connected _ e1 e2 -> symbols e1 `Set.union` symbols e2 + Lambda scope -> symbols (fromScope scope) + Quantified _ scope -> symbols (fromScope scope) + PropositionalConstant{} -> Set.empty + Not e -> symbols e + _ -> error "Filter.symbols" + +symbolTable :: ExprOf a -> Map Symbol Int +symbolTable = \case + TermVar{} -> Map.empty + TermSymbol sym es -> insert sym 1 (unions (fmap symbolTable es)) + TermSep _ e scope -> symbolTable e `union` symbolTable (fromScope scope) + Iota _ scope -> symbolTable (fromScope scope) + ReplacePred _ _ e scope -> symbolTable e `union` symbolTable (fromScope scope) + ReplaceFun es scope cond -> (unions (fmap (symbolTable . snd) (toList es))) `union` symbolTable (fromScope scope) `union` symbolTable (fromScope cond) + Connected _ e1 e2 -> symbolTable e1 `union` symbolTable e2 + Lambda scope -> symbolTable (fromScope scope) + Quantified _ scope -> symbolTable (fromScope scope) + PropositionalConstant{} -> Map.empty + Not e -> symbolTable e + _ -> error "Filter.symbolTable" + where + union = Map.unionWith (+) + unions = Map.unionsWith (+) + insert = Map.insertWith (+) diff --git a/source/Meaning.hs b/source/Meaning.hs new file mode 100644 index 0000000..d32e8ac --- /dev/null +++ b/source/Meaning.hs @@ -0,0 +1,740 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} + + +module Meaning where + + +import Base +import Serial +import Syntax.Abstract (Sign(..)) +import Syntax.Abstract qualified as Raw +import Syntax.Internal (VarSymbol(..)) +import Syntax.Internal qualified as Sem +import Syntax.LexicalPhrase (unsafeReadPhrase) +import Syntax.Lexicon + + +import Bound +import Bound.Scope (abstractEither) +import Control.Monad.Except +import Control.Monad.State +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map qualified as Map +import Data.Set qualified as Set + + +-- | The 'Gloss' monad. Basic elaboration, desugaring, and validation +-- computations take place in this monad, using 'ExceptT' to log +-- validation errors and 'State' to keep track of the surrounding context. +type Gloss = ExceptT GlossError (State GlossState) +-- This monad previously used 'ValidationT' for validation so that multiple +-- validation errors could be reported. Using only 'ExceptT' we fail immediately +-- on the first error. If we ever swich back to 'ValidateT' for error reporting, +-- then we should re-enable {-# OPTIONS_GHC -foptimal-applicative-do #-}, +-- as 'ValidateT' can report more errors when used with applicative combinators. + +-- | Errors that can be detected during glossing. +data GlossError + = GlossDefnError DefnError String + | GlossInductionError + deriving (Show, Eq, Ord) + + +-- | Specialization of 'traverse' to 'Gloss'. +each :: (Traversable t) => (a -> Gloss b) -> t a -> Gloss (t b) +explain `each` as = traverse explain as +infix 7 `each` -- In particular, 'each' has precedence over '(<$>)'. + +-- | Wellformedness check for definitions. +-- The following conditions need to be met. +-- +-- * Variables occurring in the lexical phrases on the left side must be linear, +-- i.e. each variable can only occur once. +-- * The arguments of the lexical phrases must be variables, not complex terms. +-- This is statically guaranteed by the grammar. +-- * The optional typing noun may not have any free variables. +-- * The rhs side may not have any free variables not occurring on the lhs. +-- * If a variable on the lhs does not occur on the rhs, a warning should we issued. +-- +isWellformedDefn :: Sem.Defn -> Either DefnError Sem.Defn +isWellformedDefn defn = lhsLinear defn + + +lhsVars :: Sem.Defn -> [VarSymbol] +lhsVars = \case + Sem.DefnPredicate _ _ vs _ -> toList vs + Sem.DefnFun _ _ vs _ -> vs + Sem.DefnOp _ vs _ -> vs + +lhsLinear :: Sem.Defn -> Either DefnError Sem.Defn +lhsLinear defn' = let vs = lhsVars defn' in + if nubOrd vs /= vs + then Left DefnErrorLhsNotLinear + else Right defn' + + +-- | Validation errors for top-level definitions. +data DefnError + = DefnWarnLhsFree + | DefnErrorLhsNotLinear + | DefnErrorLhsTypeFree + | DefnErrorRhsFree + deriving (Show, Eq, Ord) + + +-- | Context for 'Gloss' computations. +data GlossState = GlossState + { varCount :: Int + -- ^ Counter for generating variables names for the output. + , lemmaCount :: Serial + -- ^ Counter for generating names for unlabelled lemmas. + , lexicon :: Lexicon + , pretypings :: Map VarSymbol Sem.Formula + -- ^ Keeps track of variable constraints. We lookup and insert constraints + -- when quantifying. Each variable maps to a predicate that the variables + -- must (implicitly) satisfy. Multiple constraints are represented as + -- a conjunction. + -- CONDITION: For convenience the keys are 'VarSymbol's, but variable constraints + -- should not be used for 'FreshVar's. + } deriving (Show, Eq) + + +freshLemmaId :: Gloss Serial +freshLemmaId = do + i <- gets lemmaCount + modify $ \s -> s {lemmaCount = Serial.next (lemmaCount s)} + pure i + +freshVar :: Gloss VarSymbol +freshVar = do + i <- gets varCount + modify $ \s -> s {varCount = varCount s + 1} + pure $ FreshVar i + + +meaning :: [Raw.Block] -> Either GlossError [Sem.Block] +meaning a = evalState (runExceptT (glossBlocks a)) initialGlossState + where + initialGlossState = GlossState + { varCount = 0 + , lemmaCount = Serial.start + , lexicon = builtins + , pretypings = mempty + } + +glossExpr :: Raw.Expr -> Gloss (Sem.ExprOf VarSymbol) +glossExpr = \case + Raw.ExprVar v -> + pure $ Sem.TermVar v + Raw.ExprInteger n -> + pure $ Sem.TermSymbol (Sem.SymbolInteger n) [] + Raw.ExprOp f es -> + Sem.TermSymbol <$> pure (Sem.SymbolMixfix f) <*> (glossExpr `each` es) + Raw.ExprStructOp tok maybeLabel -> do + maybeLabel' <- traverse glossExpr maybeLabel + pure $ Sem.TermSymbolStruct tok maybeLabel' + Raw.ExprSep x t phi -> do + t' <- glossExpr t + phi' <- glossStmt phi + pure (Sem.TermSep x t' (abstract1 x phi')) + Raw.ExprReplacePred y x xBound stmt -> do + xBound' <- glossExpr xBound + stmt' <- glossStmt stmt + let toReplacementVar z = if + | z == x -> Just Sem.ReplacementDomVar + | z == y -> Just Sem.ReplacementRangeVar + | otherwise -> Nothing + let scope = abstract toReplacementVar stmt' + pure (Sem.ReplacePred y x xBound' scope) + Raw.ExprReplace e bounds phi -> do + e' <- glossExpr e + bounds' <- glossReplaceBound `each` bounds + let xs = fst <$> bounds' + phi'' <- case phi of + Just phi' -> glossStmt phi' + Nothing -> pure Sem.Top + let abstractBoundVars = abstract (\x -> List.find (== x) (toList xs)) + pure $ Sem.ReplaceFun bounds' (abstractBoundVars e') (abstractBoundVars phi'') + where + glossReplaceBound :: (VarSymbol, Raw.Expr) -> Gloss (VarSymbol, Sem.Term) + glossReplaceBound (x, b) = (x,) <$> glossExpr b + Raw.ExprFiniteSet es -> + Sem.finiteSet <$> glossExpr `each` es + + +glossFormula :: Raw.Formula -> Gloss (Sem.ExprOf VarSymbol) +glossFormula = \case + Raw.FormulaChain ch -> + glossChain ch + Raw.Connected conn phi psi -> + glossConnective conn <*> glossFormula phi <*> glossFormula psi + Raw.FormulaNeg f -> + Sem.Not <$> glossFormula f + Raw.FormulaPredicate predi es -> + Sem.Atomic <$> glossPrefixPredicate predi <*> glossExpr `each` toList es + Raw.PropositionalConstant c -> + pure $ Sem.PropositionalConstant c + Raw.FormulaQuantified quantifier xs bound phi -> do + bound' <- glossBound bound + phi' <- glossFormula phi + quantify <- glossQuantifier quantifier + pure (quantify xs (bound' (toList xs)) phi') + +glossChain :: Sem.Chain -> Gloss (Sem.ExprOf VarSymbol) +glossChain ch = Sem.makeConjunction <$> makeRels (conjuncts (splat ch)) + where + -- | Separate each link of the chain into separate triples. + splat :: Raw.Chain -> [(NonEmpty Raw.Expr, Sign, Raw.Relation, NonEmpty Raw.Expr)] + splat = \case + Raw.ChainBase es sign rel es' + -> [(es, sign, rel, es')] + Raw.ChainCons es sign rel ch'@(Raw.ChainBase es' _ _ _) + -> (es, sign, rel, es') : splat ch' + Raw.ChainCons es sign rel ch'@(Raw.ChainCons es' _ _ _) + -> (es, sign, rel, es') : splat ch' + + -- | Take each triple and combine the lhs/rhs to make all the conjuncts. + conjuncts :: [(NonEmpty Raw.Expr, Sign, Raw.Relation, NonEmpty Raw.Expr)] -> [(Sign, Raw.Relation, Raw.Expr, Raw.Expr)] + conjuncts triples = do + (e1s, sign, rel, e2s) <- triples + e1 <- toList e1s + e2 <- toList e2s + pure (sign, rel, e1, e2) + + makeRels :: [(Sign, Raw.Relation, Raw.Expr, Raw.Expr)] -> Gloss [Sem.Formula] + makeRels triples = for triples makeRel + + makeRel :: (Sign, Raw.Relation, Raw.Expr, Raw.Expr) -> Gloss Sem.Formula + makeRel (sign, rel, e1, e2) = do + e1' <- glossExpr e1 + e2' <- glossExpr e2 + case rel of + Raw.RelationSymbol tok -> + pure $ sign' $ Sem.Relation tok (e1' : [e2']) + Raw.RelationExpr e -> do + e' <- glossExpr e + pure $ sign' $ Sem.TermPair e1' e2' `Sem.IsElementOf` e' + where + sign' = case sign of + Positive -> id + Negative -> Sem.Not + + +glossPrefixPredicate :: Raw.PrefixPredicate -> Gloss Sem.Predicate +glossPrefixPredicate (Raw.PrefixPredicate symb _ar) = pure (Sem.PredicateSymbol symb) + + +glossNPNonEmpty :: Raw.NounPhrase NonEmpty -> Gloss (NonEmpty VarSymbol, Sem.Formula) +glossNPNonEmpty (Raw.NounPhrase leftAdjs noun vars rightAdjs maySuchThat) = do + -- We interpret the noun as a predicate. + noun' <- glossNoun noun + -- Now we turn the noun and all its modifiers into statements. + let typings = (\v' -> noun' (Sem.TermVar v')) <$> vars + leftAdjs' <- forEach (toList vars) <$> glossAdjL `each` leftAdjs + rightAdjs' <- forEach (toList vars) <$> glossAdjR `each` rightAdjs + suchThat <- maybeToList <$> glossStmt `each` maySuchThat + let constraints = toList typings <> leftAdjs' <> rightAdjs' <> suchThat + pure (vars, Sem.makeConjunction constraints) + + +-- | If needed, we introduce a fresh variable to reduce this to the case @NounPhrase NonEmpty@. +glossNPList :: Raw.NounPhrase [] -> Gloss (NonEmpty VarSymbol, Sem.Formula) +glossNPList (Raw.NounPhrase leftAdjs noun vars rightAdjs maySuchThat) = do + vars' <- case vars of + [] -> (:| []) <$> freshVar + v:vs -> pure (v :| vs) + glossNPNonEmpty $ Raw.NounPhrase leftAdjs noun vars' rightAdjs maySuchThat + +-- Returns a predicate for a term (the constraints) and the optional such-that clause. +-- We treat suchThat separately since multiple terms can share the same such-that clause. +glossNPMaybe :: Raw.NounPhrase Maybe -> Gloss (Sem.Term -> Sem.Formula, Maybe Sem.Formula) +glossNPMaybe (Raw.NounPhrase leftAdjs noun mayVar rightAdjs maySuchThat) = do + case mayVar of + Nothing -> do + glossNP leftAdjs noun rightAdjs maySuchThat + Just v' -> do + -- Next we desugar all the modifiers into statements. + leftAdjs' <- apply v' <$> glossAdjL `each` leftAdjs + rightAdjs' <- apply v' <$> glossAdjR `each` rightAdjs + maySuchThat' <- glossStmt `each` maySuchThat + let constraints = leftAdjs' <> rightAdjs' + -- Finally we translate the noun itself. + noun' <- glossNoun noun + pure case constraints of + [] -> (\t -> noun' t, maySuchThat') + _ -> (\t -> noun' t `Sem.And` Sem.makeConjunction (eq t v' : constraints), maySuchThat') + where + eq t v = t `Sem.Equals` Sem.TermVar v + apply :: VarSymbol -> [Sem.Term -> Sem.Formula] -> [Sem.Formula] + apply v stmts = [stmt (Sem.TermVar v) | stmt <- stmts] + +-- | Gloss a noun without a variable name. +-- Returns a predicate for a term (the constraints) and the optional such-that clause. +-- We treat suchThat separately since multiple terms can share the same such-that clause. +glossNP :: [Raw.AdjL] -> Raw.Noun -> [Raw.AdjR] -> Maybe Raw.Stmt -> Gloss (Sem.Term -> Sem.ExprOf VarSymbol, Maybe Sem.Formula) +glossNP leftAdjs noun rightAdjs maySuchThat = do + noun' <- glossNoun noun + leftAdjs' <- glossAdjL `each` leftAdjs + rightAdjs' <- glossAdjR `each` rightAdjs + maySuchThat' <- glossStmt `each` maySuchThat + let constraints = [noun'] <> leftAdjs' <> rightAdjs' + pure (\t -> Sem.makeConjunction (flap constraints t), maySuchThat') + + +-- | If we have a plural noun with multiple variables, then we need to desugar +-- adjectives to apply to each individual variable. +forEach :: Applicative t => t VarSymbol -> t (Sem.Term -> a) -> t a +forEach vs'' stmts = do + v <- vs'' + stmt <- stmts + pure $ stmt (Sem.TermVar v) + + +glossAdjL :: Raw.AdjL -> Gloss (Sem.Term -> Sem.Formula) +glossAdjL (Raw.AdjL pat es) = do + (es', quantifies) <- unzip <$> glossTerm `each` es + let quantify = compose $ reverse quantifies + pure $ \t -> quantify $ Sem.FormulaAdj t pat es' + + +-- | Since we need to be able to remove negation in verb phrases, +-- we need to have 'Sem.Stmt' as the target. We do not yet have +-- the term representing the subject, hence the parameter 'Sem.Expr'. +glossAdjR :: Raw.AdjR -> Gloss (Sem.Term -> Sem.Formula) +glossAdjR = \case + Raw.AdjR pat [e] | pat == unsafeReadPhrase "equal to ?" -> do + (e', quantify) <- glossTerm e + pure $ \t -> quantify $ Sem.Equals t e' + Raw.AdjR pat es -> do + (es', quantifies) <- unzip <$> glossTerm `each` es + let quantify = compose $ reverse quantifies + pure $ \t -> quantify $ Sem.FormulaAdj t pat es' + Raw.AttrRThat vp -> glossVP vp + + +glossAdj :: Raw.AdjOf Raw.Term -> Gloss (Sem.ExprOf VarSymbol -> Sem.Formula) +glossAdj adj = case adj of + Raw.Adj pat [e] | pat == unsafeReadPhrase "equal to ?" -> do + (e', quantify) <- glossTerm e + pure $ \t -> quantify $ Sem.Equals t e' + Raw.Adj pat es -> do + (es', quantifies) <- unzip <$> glossTerm `each` es + let quantify = compose $ reverse quantifies + pure $ \t -> quantify $ Sem.FormulaAdj t pat es' + +glossVP :: Raw.VerbPhrase -> Gloss (Sem.Term -> Sem.Formula) +glossVP = \case + Raw.VPVerb verb -> glossVerb verb + Raw.VPAdj adjs -> do + mkAdjs <- glossAdj `each` toList adjs + pure (\x -> Sem.makeConjunction [mkAdj x | mkAdj <- mkAdjs]) + Raw.VPVerbNot verb -> (Sem.Not .) <$> glossVerb verb + Raw.VPAdjNot adjs -> (Sem.Not .) <$> glossVP (Raw.VPAdj adjs) + + +glossVerb :: Raw.Verb -> Gloss (Sem.Term -> Sem.Formula) +glossVerb (Raw.Verb pat es) = do + (es', quantifies) <- unzip <$> glossTerm `each` es + let quantify = compose $ reverse quantifies + pure $ \ t -> quantify $ Sem.FormulaVerb t pat es' + + +glossNoun :: Raw.Noun -> Gloss (Sem.Term -> Sem.Formula) +glossNoun (Raw.Noun pat es) = do + (es', quantifies) <- unzip <$> glossTerm `each` es + let quantify = compose $ reverse quantifies + pure case Sem.sg pat of + -- Everything is a set + [Just (Sem.Word "set")] -> const Sem.Top + _ -> \e' -> quantify (Sem.FormulaNoun e' pat es') + + +glossFun :: Raw.Fun -> Gloss (Sem.Term, Sem.Formula -> Sem.Formula) +glossFun (Raw.Fun phrase es) = do + (es', quantifies) <- unzip <$> glossTerm `each` es + let quantify = compose $ reverse quantifies + pure (Sem.TermSymbol (Sem.SymbolFun phrase) es', quantify) + + +glossTerm :: Raw.Term -> Gloss (Sem.Term, Sem.Formula -> Sem.Formula) +glossTerm = \case + Raw.TermExpr e -> + (, id) <$> glossExpr e + Raw.TermFun f -> + glossFun f + Raw.TermIota x stmt -> do + stmt' <- glossStmt stmt + pure (Sem.Iota x (abstract1 x stmt'), id) + Raw.TermQuantified quantifier np -> do + quantify <- glossQuantifier quantifier + (mkConstraint, maySuchThat) <- glossNPMaybe np + v <- freshVar + let e = Sem.TermVar v + let constraints = [mkConstraint e] + pure (e, quantify (v:|[]) (maybeToList maySuchThat <> constraints)) + + + +glossStmt :: Raw.Stmt -> Gloss Sem.Formula +glossStmt = \case + Raw.StmtFormula f -> glossFormula f + Raw.StmtNeg s -> Sem.Not <$> glossStmt s + Raw.StmtVerbPhrase ts vp -> do + (ts', quantifies) <- NonEmpty.unzip <$> glossTerm `each` ts + vp' <- glossVP vp + let phi = Sem.makeConjunction (vp' <$> toList ts') + pure (compose quantifies phi) + Raw.StmtNoun t np -> do + (t', quantify) <- glossTerm t + (np', maySuchThat) <- glossNPMaybe np + let andSuchThat phi = case maySuchThat of + Just suchThat -> phi `Sem.And` suchThat + Nothing -> phi + pure (quantify (andSuchThat (np' t'))) + Raw.StmtStruct t sp -> do + (t', quantify) <- glossTerm t + pure (quantify (Sem.TermSymbol (Sem.SymbolPredicate (Sem.PredicateNounStruct sp)) [t'])) + Raw.StmtConnected conn s1 s2 -> glossConnective conn <*> glossStmt s1 <*> glossStmt s2 + Raw.StmtQuantPhrase (Raw.QuantPhrase quantifier np) f -> do + (vars, constraints) <- glossNPList np + f' <- glossStmt f + quantify <- glossQuantifier quantifier + pure (quantify vars [constraints] f') + Raw.StmtExists np -> do + (vars, constraints) <- glossNPList np + pure (Sem.makeExists vars constraints) + Raw.SymbolicQuantified quant vs bound suchThat have -> do + quantify <- glossQuantifier quant + bound' <- glossBound bound + suchThatConstraints <- maybeToList <$> glossStmt `each` suchThat + let boundConstraints = bound' (toList vs) + have' <- glossStmt have + pure (quantify vs (boundConstraints <> suchThatConstraints) have') + +-- | A bound applies to all listed variables. Note the use of '<**>'. +-- +-- >>> ([1, 2, 3] <**> [(+ 10)]) == [11, 12, 13] +-- +glossBound :: Raw.Bound -> Gloss ([VarSymbol] -> [Sem.Formula]) +glossBound = \case + Raw.Unbounded -> pure (const []) + Raw.Bounded sign rel term -> do + term' <- glossExpr term + let sign' = case sign of + Positive -> id + Negative -> Sem.Not + bound <- case rel of + Raw.RelationSymbol rel' -> + pure $ \v -> sign' $ + Sem.Relation rel' (Sem.TermVar v : [term']) + Raw.RelationExpr e -> do + e' <- glossExpr e + pure $ \v -> sign' $ + Sem.TermPair (Sem.TermVar v) term' `Sem.IsElementOf` e' + pure \vs -> vs <**> [bound] + + +gatherGuards :: Traversable t => t VarSymbol -> Gloss (Maybe (t Sem.Formula)) +gatherGuards vs = do + info <- gets pretypings + pure $ for vs $ \v -> Map.lookup v info + + +glossConnective :: Raw.Connective -> Gloss (Sem.Formula -> Sem.Formula -> Sem.Formula) +glossConnective conn = pure (Sem.Connected conn) + + +glossAsm :: Raw.Asm -> Gloss [Sem.Asm] +glossAsm = \case + Raw.AsmSuppose s -> do + s' <- glossStmt s + pure [Sem.Asm s'] + Raw.AsmLetNoun vs np -> do + (np', maySuchThat) <- glossNPMaybe np + let f v = Sem.Asm (np' (Sem.TermVar v) ) + let suchThat = Sem.Asm <$> maybeToList maySuchThat + pure (suchThat <> fmap f (toList vs)) + Raw.AsmLetIn vs e -> do + e' <- glossExpr e + let f v = Sem.Asm (Sem.TermVar v `Sem.IsElementOf` e') + pure $ fmap f (toList vs) + Raw.AsmLetStruct structLabel structPhrase -> + pure [Sem.AsmStruct structLabel structPhrase] + Raw.AsmLetThe _ _ -> + _TODO "glossAsm AsmLetThe" + Raw.AsmLetEq _ _ -> + _TODO "glossAsm AsmLetEq" + + +-- | A quantifier is interpreted as a quantification function that takes a nonempty list of variables, +-- a list of formulas expressing the constraints, and the formula to be quantified as arguments. +-- It then returns the quantification with the correct connective for the constraints. +glossQuantifier + :: (Foldable t, Applicative f) + => Raw.Quantifier + -> f (t VarSymbol + -> [Sem.ExprOf VarSymbol] + -> Sem.Formula + -> Sem.Formula) +glossQuantifier quantifier = pure quantify + where + quantify vs constraints f = case (quantifier, constraints) of + (Raw.Universally, []) -> + Sem.makeForall vs f + (Raw.Existentially, []) -> + Sem.makeExists vs f + (Raw.Nonexistentially, []) -> + Sem.Not (Sem.makeExists vs f) + (Raw.Universally, _) -> + Sem.makeForall vs (Sem.makeConjunction constraints `Sem.Implies` f) + (Raw.Existentially, _) -> + Sem.makeExists vs (Sem.makeConjunction constraints `Sem.And` f) + (Raw.Nonexistentially, _) -> + Sem.Not (Sem.makeExists vs (Sem.makeConjunction constraints `Sem.And` f)) + + +glossAsms :: [Raw.Asm] -> Gloss [Sem.Asm] +glossAsms asms = do + asms' <- glossAsm `each` asms + pure $ concat asms' + + +glossAxiom :: Raw.Axiom -> Gloss Sem.Axiom +glossAxiom (Raw.Axiom asms f) = Sem.Axiom <$> glossAsms asms <*> glossStmt f + + +glossLemma :: Raw.Lemma -> Gloss Sem.Lemma +glossLemma (Raw.Lemma asms f) = Sem.Lemma <$> glossAsms asms <*> glossStmt f + + +glossDefn :: Raw.Defn -> Gloss Sem.Defn +glossDefn = \case + Raw.Defn asms h f -> glossDefnHead h <*> glossAsms asms <*> glossStmt f + Raw.DefnFun asms (Raw.Fun fun vs) _ e -> do + asms' <- glossAsms asms + e' <- case e of + -- TODO improve error handling or make grammar stricter + Raw.TermQuantified _ _ -> error $ "Quantified term in definition: " <> show e + _ -> fst <$> glossTerm e + pure $ Sem.DefnFun asms' fun vs e' + Raw.DefnOp (Raw.SymbolPattern op vs) e -> + Sem.DefnOp op vs <$> glossExpr e + + +-- | A definition head is interpreted as a builder of a definition, +-- depending on a previous assumptions and on a rhs. +glossDefnHead :: Raw.DefnHead -> Gloss ([Sem.Asm] -> Sem.Formula -> Sem.Defn) +glossDefnHead = \case + -- TODO add info from NP. + Raw.DefnAdj _mnp v (Raw.Adj adj vs) -> do + pure $ \asms f -> Sem.DefnPredicate asms (Sem.PredicateAdj adj) (v :| vs) f + --mnp' <- glossNPMaybe `each` mnp + --pure $ case mnp' of + -- Nothing -> \asms f -> Sem.DefnPredicate asms (Sem.PredicateAdj adj') (v :| vs) f + -- Just np' -> \asms f -> Sem.DefnPredicate asms (Sem.PredicateAdj adj') (v :| vs) (Sem.FormulaAnd (np' v) f) + Raw.DefnVerb _mnp v (Raw.Verb verb vs) -> + pure $ \asms f -> Sem.DefnPredicate asms (Sem.PredicateVerb verb) (v :| vs) f + Raw.DefnNoun v (Raw.Noun noun vs) -> + pure $ \asms f -> Sem.DefnPredicate asms (Sem.PredicateNoun noun) (v :| vs) f + Raw.DefnRel v1 rel v2 -> + pure $ \asms f -> Sem.DefnPredicate asms (Sem.PredicateRelation rel) (v1 :| [v2]) f + Raw.DefnSymbolicPredicate (Raw.PrefixPredicate symb _ar) vs -> + pure $ \asms f -> Sem.DefnPredicate asms (Sem.PredicateSymbol symb) vs f + + +glossProof :: Raw.Proof -> Gloss Sem.Proof +glossProof = \case + Raw.Omitted -> + pure Sem.Omitted + Raw.Qed by -> + pure (Sem.Qed by) + Raw.ByContradiction proof -> + Sem.ByContradiction <$> glossProof proof + Raw.BySetInduction mt proof -> + Sem.BySetInduction <$> mmt' <*> glossProof proof + where + mmt' = case mt of + Nothing -> pure Nothing + Just (Raw.TermExpr (Raw.ExprVar x)) -> pure (Just (Sem.TermVar x)) + Just _t -> throwError GlossInductionError + Raw.ByOrdInduction proof -> + Sem.ByOrdInduction <$> glossProof proof + Raw.ByCase cases -> Sem.ByCase <$> glossCase `each` cases + Raw.Have _ms s by proof -> case s of + -- Pragmatics: an existential @Have@ implicitly + -- introduces the witness and is interpreted as a @Take@ construct. + Raw.SymbolicExists vs bound suchThat -> do + bound' <- glossBound bound + suchThat' <- glossStmt suchThat + proof' <- glossProof proof + pure (Sem.Take vs (Sem.makeConjunction (suchThat' : bound' (toList vs))) by proof') + _otherwise -> + Sem.Have <$> glossStmt s <*> pure by <*> glossProof proof + Raw.Assume stmt proof -> + Sem.Assume <$> glossStmt stmt <*> glossProof proof + Raw.FixSymbolic xs bound proof -> do + bound' <- glossBound bound + proof' <- glossProof proof + pure (Sem.Fix xs (Sem.makeConjunction (bound' (toList xs))) proof') + Raw.FixSuchThat xs stmt proof -> do + stmt' <- glossStmt stmt + proof' <- glossProof proof + pure (Sem.Fix xs stmt' proof') + Raw.TakeVar vs bound suchThat by proof -> do + bound' <- glossBound bound + suchThat' <- glossStmt suchThat + proof' <- glossProof proof + pure (Sem.Take vs (Sem.makeConjunction (suchThat' : bound' (toList vs))) by proof') + Raw.TakeNoun np by proof -> do + (vs, constraints) <- glossNPList np + proof' <- glossProof proof + pure $ Sem.Take vs constraints by proof' + Raw.Subclaim subclaim subproof proof -> + Sem.Subclaim <$> glossStmt subclaim <*> glossProof subproof <*> glossProof proof + Raw.Suffices reduction by proof -> + Sem.Suffices <$> glossStmt reduction <*> pure by <*> glossProof proof + Raw.Define var term proof -> + Sem.Define var <$> glossExpr term <*> glossProof proof + Raw.DefineFunction funVar argVar valueExpr domVar domExpr proof -> + if domVar == argVar + then Sem.DefineFunction funVar argVar <$> glossExpr valueExpr <*> glossExpr domExpr <*> glossProof proof + else error "mismatched variables in function definition." + Raw.Calc calc proof -> + Sem.Calc <$> glossCalc calc <*> glossProof proof + +glossCase :: Raw.Case -> Gloss Sem.Case +glossCase (Raw.Case caseOf proof) = Sem.Case <$> glossStmt caseOf <*> glossProof proof + +glossCalc :: Raw.Calc -> Gloss Sem.Calc +glossCalc = \case + Raw.Equation e eqns -> do + e' <- glossExpr e + eqns' <- (\(ei, ji) -> (,ji) <$> glossExpr ei) `each` eqns + pure (Sem.Equation e' eqns') + Raw.Biconditionals p ps -> do + p' <- glossFormula p + ps' <- (\(pi, ji) -> (,ji) <$> glossFormula pi) `each` ps + pure (Sem.Biconditionals p' ps') + +glossSignature :: Raw.Signature -> Gloss Sem.Signature +glossSignature sig = case sig of + Raw.SignatureAdj v (Raw.Adj adj vs) -> + pure $ Sem.SignaturePredicate (Sem.PredicateAdj adj) (v :| vs) + Raw.SignatureVerb v (Raw.Verb verb vs) -> + pure $ Sem.SignaturePredicate (Sem.PredicateVerb verb) (v :| vs) + Raw.SignatureNoun v (Raw.Noun noun vs) -> + pure $ Sem.SignaturePredicate (Sem.PredicateNoun noun) (v :| vs) + Raw.SignatureSymbolic (Raw.SymbolPattern op vs) np -> do + (np', maySuchThat) <- glossNPMaybe np + let andSuchThat phi = case maySuchThat of + Just suchThat -> phi `Sem.And` suchThat + Nothing -> phi + let op' = Sem.TermOp op (Sem.TermVar <$> vs) + v <- freshVar + let v' = Sem.TermVar v + pure $ Sem.SignatureFormula $ Sem.makeForall [v] ((v' `Sem.Equals` op') `Sem.Implies` andSuchThat (np' v')) + + +glossStructDefn :: Raw.StructDefn -> Gloss Sem.StructDefn +glossStructDefn (Raw.StructDefn phrase base carrier fixes assumes) = do + assumes' <- (\(m, stmt) -> (m,) <$> glossStmt stmt) `each` assumes + -- We substitute occurrences of the bare label with the builtin symbol @\carrier@. + -- let assumes'' = fmap (annotateCarrierFormula carrier) assumes' + let assumes'' = [(m, annotateCarrierFormula carrier phi) |(m, phi) <- assumes'] + let base' = Set.fromList base + let fixes' = Set.fromList fixes + pure $ Sem.StructDefn phrase base' carrier fixes' assumes'' + +-- | Replace free variables corresponding to the label of a structure +-- with the abstract carrier symbol. +annotateCarrierFormula :: Sem.VarSymbol -> Sem.Term -> Sem.Term +annotateCarrierFormula lbl = \case + a `Sem.IsElementOf` Sem.TermVar x | x == lbl -> a `Sem.IsElementOf` Sem.TermSymbolStruct CarrierSymbol (Just (Sem.TermVar lbl)) + x -> x + + +glossAbbreviation :: Raw.Abbreviation -> Gloss Sem.Abbreviation +glossAbbreviation = \case + Raw.AbbreviationAdj x (Raw.Adj adj xs) stmt -> + makeAbbrStmt (Sem.SymbolPredicate (Sem.PredicateAdj adj)) (x : xs) stmt + Raw.AbbreviationVerb x (Raw.Verb verb xs) stmt -> + makeAbbrStmt (Sem.SymbolPredicate (Sem.PredicateVerb verb)) (x : xs) stmt + Raw.AbbreviationNoun x (Raw.Noun noun xs) stmt -> + makeAbbrStmt (Sem.SymbolPredicate (Sem.PredicateNoun noun)) (x : xs) stmt + Raw.AbbreviationRel x rel y stmt -> + makeAbbrStmt (Sem.SymbolPredicate (Sem.PredicateRelation rel)) [x, y] stmt + Raw.AbbreviationFun (Raw.Fun fun xs) t -> + makeAbbrTerm (Sem.SymbolFun fun) xs t + Raw.AbbreviationEq (Raw.SymbolPattern op xs) e -> + makeAbbrExpr (Sem.SymbolMixfix op) xs e + + +makeAbbrStmt :: Sem.Symbol -> [VarSymbol] -> Raw.Stmt -> Gloss (Sem.Abbreviation) +makeAbbrStmt symbol zs stmt = do + stmt' <- glossStmt stmt + let aux y = case y `List.elemIndex` zs of + Nothing -> error ("free variable " <> show y <> " in abbreviation " <> show symbol) + Just k -> Left k + let scope = abstractEither aux stmt' :: Scope Int Sem.ExprOf Void + pure (Sem.Abbreviation symbol scope) + +makeAbbrTerm :: Sem.Symbol -> [VarSymbol] -> Raw.Term -> Gloss (Sem.Abbreviation) +makeAbbrTerm symbol zs t = do + (t', _quantify) <- glossTerm t + -- TODO replace "glossTerm t" with a more specific interpretation function + -- that checks if no indefinite terms are part of the term (erroring out if the term is indefinite). + let aux y = case y `List.elemIndex` zs of + Nothing -> error ("free variable " <> show y <> " in abbreviation " <> show symbol) + Just k -> Left k + let scope = abstractEither aux t' :: Scope Int Sem.ExprOf Void + pure (Sem.Abbreviation symbol scope) + +makeAbbrExpr :: Sem.Symbol -> [VarSymbol] -> Raw.Expr -> Gloss (Sem.Abbreviation) +makeAbbrExpr symbol zs e = do + e' <- glossExpr e + -- TODO replace "glossTerm t" with a more specific interpretation function + -- that checks if no indefinite terms are part of the term (erroring out if the term is indefinite). + let aux y = case y `List.elemIndex` zs of + Nothing -> error ("free variable " <> show y <> " in abbreviation " <> show symbol) + Just k -> Left k + let scope = abstractEither aux e' :: Scope Int Sem.ExprOf Void + pure (Sem.Abbreviation symbol scope) + + +glossInductive :: Raw.Inductive -> Gloss Sem.Inductive +glossInductive (Raw.Inductive (Raw.SymbolPattern symbol args) domain rules) = + Sem.Inductive symbol args <$> glossExpr domain <*> (glossRule `each` rules) + where + glossRule (Raw.IntroRule phis psi) = Sem.IntroRule <$> (glossFormula `each` phis) <*> glossFormula psi + +glossBlock :: Raw.Block -> Gloss Sem.Block +glossBlock = \case + Raw.BlockAxiom pos marker axiom -> + Sem.BlockAxiom pos marker <$> glossAxiom axiom + Raw.BlockLemma pos marker lemma -> + Sem.BlockLemma pos marker <$> glossLemma lemma + Raw.BlockProof pos proof -> + Sem.BlockProof pos <$> glossProof proof + Raw.BlockDefn pos marker defn -> do + defn' <- glossDefn defn + whenLeft (isWellformedDefn defn') (\err -> throwError (GlossDefnError err (show defn'))) + pure $ Sem.BlockDefn pos marker defn' + Raw.BlockAbbr pos marker abbr -> + Sem.BlockAbbr pos marker <$> glossAbbreviation abbr + Raw.BlockSig pos asms sig -> + Sem.BlockSig pos <$> glossAsms asms <*> glossSignature sig + Raw.BlockStruct pos m structDefn -> + Sem.BlockStruct pos m <$> glossStructDefn structDefn + Raw.BlockData _pos _ -> + _TODO "glossBlock datatype definitions" + Raw.BlockInductive pos marker ind -> + Sem.BlockInductive pos marker <$> glossInductive ind + + +glossBlocks :: [Raw.Block] -> Gloss [Sem.Block] +glossBlocks blocks = glossBlock `each` blocks diff --git a/source/Megalodon.hs b/source/Megalodon.hs new file mode 100644 index 0000000..37479b2 --- /dev/null +++ b/source/Megalodon.hs @@ -0,0 +1,209 @@ +module Megalodon where + +import Base hiding (null) +import Syntax.Internal +import Syntax.Lexicon +import Checking (makeReplacementIff) + +import Bound.Scope +import Bound.Var +import Data.HashMap.Strict qualified as HM +import Data.List.NonEmpty qualified as NonEmpty +import Text.Builder +import Data.List qualified as List +import Data.Text qualified as Text + + +encodeBlocks :: Lexicon -> [Block] -> Text +encodeBlocks lexi blocks = run (preamble <> buildBlocks lexi blocks) + +closure :: [ExprOf VarSymbol] -> ExprOf VarSymbol -> Formula +closure asms stmt = contraction (forallClosure mempty (makeConjunction asms `Implies` stmt)) + +unAsm :: Asm -> Formula +unAsm (Asm phi )= phi +unAsm (AsmStruct x sp) = TermSymbol (SymbolPredicate (PredicateNounStruct sp)) [TermVar x] + +buildBlocks :: Lexicon -> [Block] -> Builder +buildBlocks lexi = \case + BlockAxiom _pos lbl (Axiom asms stmt) : blocks -> + let phi = closure (unAsm <$> asms) stmt + in text "Fact " <> buildMarker lbl <> text " : " <> buildFormula lexi phi <> text ".\nAdmitted.\n" <> buildBlocks lexi blocks + BlockLemma _pos lbl (Lemma asms stmt) : BlockProof _ _ : blocks -> + let phi = closure (unAsm <$> asms) stmt + in text "Theorem " <> buildMarker lbl <> text " : " <> buildFormula lexi phi <> text ".\nAdmitted.\n" <> buildBlocks lexi blocks + BlockLemma _pos lbl (Lemma asms stmt) : blocks -> + let phi = closure (unAsm <$> asms) stmt + in text "Theorem " <> buildMarker lbl <> text " : " <> buildFormula lexi phi <> text ".\nAdmitted.\n" <> buildBlocks lexi blocks + BlockDefn _pos _lbl defn : blocks-> + buildDefn lexi defn <> buildBlocks lexi blocks + BlockAbbr _pos _lbl abbr : blocks-> + buildAbbr lexi abbr <> buildBlocks lexi blocks + [] -> + mempty + block : _ -> + _TODO ("builBlocks" <> show block) + +buildDefn :: Lexicon -> Defn -> Builder +buildDefn lexi = \case + DefnPredicate [] predi xs phi -> + "Definition " <> buildSymbol lexi (SymbolPredicate predi) <> " := " <> + "fun " <> buildVarSymbols xs <> ": set => " <> buildFormula lexi phi <> ".\n" + DefnFun [] f xs phi -> + "Definition " <> buildSymbol lexi (SymbolFun f) <> " := " <> + buildSetFunIfNonEmpty (buildVarSymbols xs) (buildFormula lexi phi) <> ".\n" + DefnOp f xs phi -> + "Definition " <> buildSymbol lexi (SymbolMixfix f) <> " := " <> + buildSetFunIfNonEmpty (buildVarSymbols xs) (buildFormula lexi phi) <> ".\n" + _ -> + error "assumptions in definition, deprecated" + +buildAbbr :: Lexicon -> Abbreviation -> Builder +buildAbbr lexi (Abbreviation f body) = + "Definition " <> buildSymbol lexi f <> " := " <> + buildSetFunIfNonEmpty buildBindings' (buildFormula lexi ((instantiate (TermVar . FreshVar) (fmap absurd body)))) <> ".\n" + where + buildBindings' :: Builder + buildBindings' = intercalate (char ' ') (buildVarSymbol . FreshVar <$> List.sort (List.nub (bindings body))) + +buildSetFunIfNonEmpty :: Builder -> Builder -> Builder +buildSetFunIfNonEmpty xs b = if null xs then b else "fun " <> xs <> " : set => " <> b + +buildFormula :: Lexicon -> Formula -> Builder +buildFormula lexi = \case + TermVar x -> buildVarSymbol x + -- We handle eq in a special manner to avoid having to specify the type of the equality. + TermSymbol f [x,y] | isEqSymbol f -> + char '(' <> buildFormula lexi x <> text " = " <> buildFormula lexi y <> char ')' + TermSymbol f [x,y] | isDiseqSymbol f -> + char '(' <> buildFormula lexi x <> text " <> " <> buildFormula lexi y <> char ')' + TermSymbol f es -> + let es' = buildSymbol lexi f : (buildFormula lexi <$> es) + in char '(' <> intercalate (char ' ') es' <> char ')' + Apply e es -> + let es' = NonEmpty.cons (buildFormula lexi e) (buildFormula lexi <$> es) + in char '(' <> intercalate (char ' ') es' <> char ')' + Not e -> text "~(" <> buildFormula lexi e <> char ')' + Connected conn e1 e2 -> + char '(' <> buildConn conn (buildFormula lexi e1) (buildFormula lexi e2) <> char ')' + Quantified quant body -> + char '(' <> buildQuant quant <> char ' ' <> buildBindings body <> text ",(" <> buildFormula lexi (instantiate TermVar body) <> text "))" + TermSep x bound phi -> + char '{' <> buildVarSymbol x <> " :e (" <> buildFormula lexi bound <> text ")|" <> buildFormula lexi (instantiate1 (TermVar x) phi) <> char '}' + Iota _ _ -> error "TODO buildFormula Iota" + ReplacePred y x xB body -> + let x' = buildVarSymbol x + y' = buildVarSymbol y + fromReplacementVar = \case + ReplacementDomVar -> TermVar x + ReplacementRangeVar -> TermVar y + body' = buildFormula lexi (instantiate fromReplacementVar body) + in "let MkReplFun := fun " <> x' <> " : set => (Eps_i (fun " <> y' <> "=>" <> body' <> ")) in {MkReplFun " <> x' <> "|" <> x' <> " :e (" <> buildFormula lexi xB <> ")}" + ReplaceFun ((x, xB) :| []) lhs cond -> + let x' = buildVarSymbol x + xB' = "(" <> buildFormula lexi xB <> ")" -- parens probably not needed + lhs' = "(fun " <> x' <> " => " <> buildFormula lexi (instantiate TermVar lhs) <> ")" + cond' = "(fun " <> x' <> " => " <> buildFormula lexi (instantiate TermVar cond) <> ")" + -- Using "ReplSep : set->(set->prop)->(set->set)->set" + in "ReplSep " <> xB' <> cond' <> lhs' + ReplaceFun ((x, xB) :| (y, yB) : []) lhs cond -> + let x' = buildVarSymbol x + xB' = "(" <> buildFormula lexi xB <> ")" + y' = buildVarSymbol y + yB' = "(fun dummyVar => " <> buildFormula lexi yB <> ")" + lhs' = "(fun " <> x' <> " " <> y' <> " => " <> buildFormula lexi (instantiate TermVar lhs) <> ")" + cond' = "(fun " <> x' <> " " <> y' <> " => " <> buildFormula lexi (instantiate TermVar cond) <> ")" + -- Using "ReplSep2 : set -> (set -> set) -> (set -> set -> prop) -> (set -> set -> set) -> set" + in "ReplSep2 " <> xB' <> yB' <> cond' <> lhs' + ReplaceFun bounds lhs cond -> + -- Silly placeholder translation for now + let iff = makeReplacementIff (TermVar (F "frs")) bounds lhs cond + in "Eps_i (fun frs : set => " <> buildFormula lexi iff <> ")" + Lambda _ -> text "TODO_buildFormula_Lambda" + PropositionalConstant IsTop -> "True" + PropositionalConstant IsBottom -> "False" + TermSymbolStruct f me -> + let f' = buildMarker ((?? error "unrecognized symbol") (HM.lookup f (lexiconStructFun lexi))) + e = me ?? error "unannotated struct op" + in char '(' <> f' <> buildFormula lexi e <> char ')' + +buildMarker :: Marker -> Builder +buildMarker (Marker m)= text m + +buildQuant :: Quantifier -> Builder +buildQuant = \case + Universally -> "forall" + Existentially -> "exists" + +buildBindings :: Scope VarSymbol ExprOf a -> Builder +buildBindings body = intercalate (char ' ') (buildVarSymbol <$> List.nub (bindings body)) + +buildBounds :: Lexicon -> NonEmpty (VarSymbol, ExprOf VarSymbol) -> Builder +buildBounds l (bound :| bounds) = foldr (\b bs -> buildBound b <> "/\\ " <> bs) (buildBound bound) bounds + where + buildBound (y, yB) = buildVarSymbol y <> " :e (" <> buildFormula l yB <> ")" + +buildConn :: Connective -> (Builder -> Builder -> Builder) +buildConn conn = \p q -> case conn of + Conjunction -> p <> text "/\\" <> q + Disjunction -> p <> text "\\/" <> q + Implication -> p <> text "->" <> q + Equivalence -> p <> text "<->" <> q + ExclusiveOr -> text "xor" <> p <> char ' ' <> q + NegatedDisjunction -> text "nor" <> p <> char ' ' <> q + +buildVarSymbol :: VarSymbol -> Builder +buildVarSymbol = \case + NamedVar x -> text x + FreshVar i -> char 'x' <> decimal i + +buildVarSymbols :: (Functor t, Foldable t) => t VarSymbol -> Builder +buildVarSymbols xs = intercalate (char ' ') (fmap buildVarSymbol xs) + +buildSymbol :: Lexicon -> Symbol -> Builder +buildSymbol _ (SymbolInteger i) = decimal i +buildSymbol lexi symb = fromRightMarker case symb of + SymbolMixfix f -> + lookupOp f (lexiconMixfix lexi) + SymbolFun f -> lookupLexicalItem f (lexiconFuns lexi) + SymbolPredicate (PredicateAdj f) -> lookupLexicalItem f (lexiconAdjs lexi) + SymbolPredicate (PredicateVerb f) -> lookupLexicalItem f (lexiconVerbs lexi) + SymbolPredicate (PredicateNoun f) -> lookupLexicalItem f (lexiconNouns lexi) + SymbolPredicate (PredicateRelation f) ->lookupLexicalItem f (lexiconRelationSymbols lexi) + SymbolPredicate (PredicateNounStruct f) -> lookupLexicalItem f (lexiconStructNouns lexi) + SymbolPredicate (PredicateSymbol f) -> Right (Marker f) -- HM.lookup f (lexiconPrefixPredicates lexi) + + +fromRightMarker :: Either String Marker -> Builder +fromRightMarker = \case + Right (Marker m) -> text m + Left a -> error ("symbol not in lexicon" <> a) + +isEqSymbol :: Symbol -> Bool +isEqSymbol = \case + SymbolPredicate (PredicateRelation (Symbol "=")) -> True + SymbolPredicate (PredicateVerb f) | f == (unsafeReadPhraseSgPl "equal[s/] ?") -> True + SymbolPredicate (PredicateAdj f) | f == (unsafeReadPhrase "equal to ?") -> True + _ -> False + +isDiseqSymbol :: Symbol -> Bool +isDiseqSymbol = \case + SymbolPredicate (PredicateRelation (Command "neq")) -> True + SymbolPredicate (PredicateAdj f) | f == (unsafeReadPhrase "distinct from ?") -> True + _ -> False + +preamble :: Builder +preamble = text $ Text.unlines + [ "Let emptyset : set := Empty." + , "Let elem : set->set->prop := In." + , "Let notelem : set->set->prop := fun a A => ~(In a A)." + , "Let pow : set->set := Power." + , "Let unions : set->set := Union." + , "Let union : set->set->set := binunion." + , "Let cons : set -> set -> set := fun x X => binunion {x} X." + , "Let xor : prop -> prop -> prop := fun p q => (p \\/ q) /\\ ~(p /\\ q)." + , "Let pair : set -> set -> set := fun a b => {{a}, {a, b}}." + , "Let fst : set -> set := fun p => Eps_i (fun a => exists b, p = pair a b)." + , "Let snd : set -> set := fun p => Eps_i (fun b => exists a, p = pair a b)." + , "Let nor : prop -> prop -> prop := fun p q => ~(p \\/ q) ." + ] diff --git a/source/Provers.hs b/source/Provers.hs new file mode 100644 index 0000000..203ee82 --- /dev/null +++ b/source/Provers.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Provers where + +import Base +import Encoding +import Syntax.Lexicon (Lexicon) +import Syntax.Internal (Formula, Task(..), isIndirect) +import Tptp.UnsortedFirstOrder qualified as Tptp + +import Control.Monad.Logger +import Data.Text qualified as Text +import Data.Time +import System.Process.Text (readProcessWithExitCode) +import Text.Builder + +type Prover = Verbosity -> TimeLimit -> MemoryLimit -> ProverInstance + +-- | Prover responses are stored as a list of prefixes. +data ProverInstance = Prover + { proverName :: String + , proverPath :: FilePath + , proverArgs :: [String] + , proverSaysYes :: [Text] + , proverSaysNo :: [Text] + , proverDoesNotKnow :: [Text] + , proverWarnsContradiction :: [Text] + } deriving (Show, Eq) + + +data Verbosity = Silent | Verbose deriving (Show, Eq) +newtype TimeLimit = Seconds Word64 deriving (Show, Eq, Num) +newtype MemoryLimit = Megabytes Word64 deriving (Show, Eq) + +toSeconds :: TimeLimit -> String +toSeconds (Seconds secs) = show secs + +toMegabytes :: MemoryLimit -> String +toMegabytes (Megabytes mbs) = show mbs + +defaultTimeLimit :: TimeLimit +defaultTimeLimit = Seconds 10 + +defaultMemoryLimit :: MemoryLimit +defaultMemoryLimit = Megabytes 5000 + + +eproverDev :: ProverInstance +eproverDev = eprover "eprover" Silent defaultTimeLimit defaultMemoryLimit + +eprover :: FilePath -> Prover +eprover path verbosity timeLimit memoryLimit = Prover + { proverName = "eprover" + , proverPath = path + , proverArgs = + [ "--tptp3-format" + , "--auto" + , case verbosity of + Silent -> "--silent" + Verbose -> "--verbose" + , "--soft-cpu-limit=" <> toSeconds timeLimit + , "--cpu-limit=" <> toSeconds (timeLimit + 5) + , "--memory-limit=" <> toMegabytes memoryLimit + ] + , proverSaysYes = ["# SZS status Theorem"] + , proverSaysNo = ["# SZS status CounterSatisfiable"] + , proverDoesNotKnow = ["# SZS status ResourceOut", "# SZS status GaveUp"] + , proverWarnsContradiction = ["# SZS status ContradictoryAxioms"] + } + + +vampire :: FilePath -> Prover +vampire path _verbosity timeLimit memoryLimit = Prover + { proverName = "vampire" + , proverPath = path + , proverArgs = + [ "--mode", "casc" + , "--time_limit", toSeconds timeLimit + , "--memory_limit", toMegabytes memoryLimit + ] + , proverSaysYes = ["% SZS output end Proof for"] + , proverSaysNo = ["% SZS status CounterSatisfiable for"] + , proverDoesNotKnow = ["% SZS status Timeout for"] + , proverWarnsContradiction = ["% SZS status ContradictoryAxioms for"] + } + +-- WIP: setting up a clausifier +iprover :: Prover +iprover _verbosity timeLimit _memoryLimit = Prover + { proverName = "iProver" + , proverPath = "iproveropt" + , proverArgs = + [ "--time_out_real " <> toSeconds timeLimit + ] + , proverSaysYes = ["% SZS status Theorem for"] + , proverSaysNo = ["% SZS status CounterSatisfiable for"] + , proverDoesNotKnow = ["% SZS status Unknown"] + , proverWarnsContradiction = [] + } + +-- | 'No', 'Uncertain', and 'ContradictoryAxioms' carry the 'Text'-encoded +-- TPTP problem that failed with them for debugging purposes. 'Error' simply +-- contains the error message of the prover verbatim. +data ProverAnswer + = Yes + | No Text + | ContradictoryAxioms Text + | Uncertain Text + | Error Text + deriving (Show, Eq) + +nominalDiffTimeToText :: NominalDiffTime -> Text +nominalDiffTimeToText delta = run (nominalDiffTimeToBuilder delta) + +nominalDiffTimeToBuilder :: NominalDiffTime -> Builder +nominalDiffTimeToBuilder delta = case hours of + 0 -> padded minutes <> ":" <> padded restSeconds <> "." <> padded restCentis + _ -> padded hours <> ":" <> padded restMinutes <> ":" <> padded restSeconds + where + padded n = if n < 10 then char '0' <> decimal n else decimal n + centiseconds = truncate (100 * nominalDiffTimeToSeconds delta) :: Int + (seconds, restCentis) = divMod centiseconds 100 + (minutes, restSeconds) = divMod seconds 60 + (hours, restMinutes) = divMod minutes 60 + +timeDifferenceToText :: UTCTime -> UTCTime -> Text +timeDifferenceToText startTime endTime = nominalDiffTimeToText (diffUTCTime endTime startTime) + + +runProver :: (MonadIO io, MonadLogger io) => ProverInstance -> Lexicon -> Task -> io (Formula, ProverAnswer) +runProver prover@Prover{..} lexicon task = do + startTime <- liftIO getCurrentTime + let tptp = encodeTask lexicon task + let tptp' = Tptp.toText tptp + (_exitCode, answer, answerErr) <- liftIO (readProcessWithExitCode proverPath proverArgs tptp') + endTime <- liftIO getCurrentTime + let duration = timeDifferenceToText startTime endTime + + logInfoN + let hypo = case tptp of + Tptp.Task (head : _) -> Tptp.Task [head] + _ -> Tptp.Task [] + in duration <> " " <> Tptp.toText hypo + + pure (taskConjecture task, recognizeAnswer prover task tptp' answer answerErr) + + +-- | Parse the answer of a prover based on the configured prefixes of responses. +recognizeAnswer :: ProverInstance -> Task -> Text -> Text -> Text -> ProverAnswer +recognizeAnswer Prover{..} task tptp answer answerErr = + let + matches prefixes = any (\l -> any (`Text.isPrefixOf` l) prefixes) (Text.lines answer) + saidYes = matches proverSaysYes + saidNo = matches proverSaysNo + doesNotKnow = matches proverDoesNotKnow + warned = matches proverWarnsContradiction + in if + | saidYes || (warned && isIndirect task) -> Yes + | saidNo -> No tptp + | doesNotKnow -> Uncertain tptp + | warned -> ContradictoryAxioms tptp + | otherwise -> Error (answer <> answerErr) diff --git a/source/Report/Region.hs b/source/Report/Region.hs new file mode 100644 index 0000000..04b2186 --- /dev/null +++ b/source/Report/Region.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Report.Region where + + +import Base + + +-- | 'Loc' wraps a value with location information specified by a 'Region'. +-- If the 'Region' of @la :: Loc a@ is 'Nowhere', we call @la@ pure, since +-- @la = pure a@ for some @a :: a@. +data Loc a = At {unLoc :: a, locRegion :: Region} deriving (Show) + +-- | Equality tests ignore the location information, so that we can match +-- located values from the token stream against pure values with functions +-- such as 'Text.Earley.Derived.token'. +instance Eq a => Eq (Loc a) where + (==) = (==) `on` unLoc + +-- | As with 'Eq', comparison ignores the location information. +instance Ord a => Ord (Loc a) where + compare = compare `on` unLoc + +instance Functor Loc where + fmap :: (a -> b) -> Loc a -> Loc b + fmap f (a `At` loc) = f a `At` loc + +instance Applicative Loc where + pure :: a -> Loc a + pure a = a `At` mempty + + (<*>) :: Loc (a -> b) -> Loc a -> Loc b + f `At` r1 <*> a `At` r2 = f a `At` (r1 <> r2) + + +data Position = Position + { positionLine :: Int -- ^ Line of the position, starting at 1. + , positionColumn :: Int -- ^ Column of the position, starting at 1. + , positionOffset :: Int -- ^ Index of the position, starting at 0. + } deriving (Show, Eq, Ord) + +compareLine :: Position -> Position -> Ordering +compareLine = compare `on` positionLine + + +data Region +-- +-- Start End Hint for pretty-printing the region +-- vvvvvvvv vvvvvvvv vvvvvvvvvvvv + = Region Position Position PrintingHint -- ^ +-- +-- Source regions are indicated by start and end position. +-- The start is inclusive, the end is exclusive. Thus below +-- +-- > 1 5 10 15 20 25 30 35 +-- > | | | | | | | | +-- > ┌─────────────────────────────────────── +-- > 1 ─ │ ##### +-- > 2 ─ │ %%%%%%%%%%%%%%%%%%% +-- > 3 ─ │ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-- > 4 ─ │ %%%% +-- +-- the hash signs (@#@) fill the region @1:5-1:10@ (a 'SingleLine') and the +-- percent signs (@%@) fill the region @2:19-4:5@ (a 'MultiLine'). Note that +-- that the length of the region is equal to the difference of the columns +-- if the region is a single line. The start position must be strictly +-- less than the end position of the region. +-- + | Nowhere -- ^ +-- +-- Intended for errors without source regions or +-- for lifting pure values into a located value. +-- + deriving (Show, Eq, Ord) + +regionOffset :: Region -> Maybe Int +regionOffset (Region s _e _i) = Just (positionOffset s) +regionOffset Nowhere = Nothing + +-- | 'Region's form a commutative monoid under taking the convex hull of +-- their unions. The empty region 'Nowhere' is the neutral element. +convexUnion :: Region -> Region -> Region +convexUnion r1 r2 = case (r1, r2) of + (Region s1 e1 i1, Region s2 e2 i2) -> Region s e i + where + s = min s1 s2 + e = max e1 e2 + i = case (i1, i2) of + (_, MultiLine) -> MultiLine + (MultiLine, _) -> MultiLine + _ | positionLine s1 == positionLine e2 -> SingleLine (positionColumn e - positionColumn s) + _ -> MultiLine + (_, Nowhere) -> r1 + (Nowhere, _) -> r2 + +instance Semigroup Region where + (<>) :: Region -> Region -> Region + (<>) = convexUnion + +instance Monoid Region where + mempty :: Region + mempty = Nowhere + + + +data PrintingHint + = MultiLine + | SingleLine Int -- ^ Describes the length of the single-line region. + deriving (Show, Eq, Ord) diff --git a/source/Serial.hs b/source/Serial.hs new file mode 100644 index 0000000..5836afd --- /dev/null +++ b/source/Serial.hs @@ -0,0 +1,18 @@ +module Serial (Serial, start, next) where + +import Data.Eq +import Data.Hashable +import Data.Ord +import GHC.Generics as Export (Generic(..)) +import Numeric.Natural +import Prelude (Num(..)) +import Text.Show + + +newtype Serial = Serial Natural deriving (Show, Eq, Ord, Generic, Hashable) + +start :: Serial +start = Serial 0 + +next :: Serial -> Serial +next (Serial k) = Serial (k + 1) diff --git a/source/StructGraph.hs b/source/StructGraph.hs new file mode 100644 index 0000000..35de34f --- /dev/null +++ b/source/StructGraph.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module StructGraph where + + +import Base +import Syntax.Internal + +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + + +data Struct = Struct + { structNoun :: StructPhrase + , structAncestors :: Set StructPhrase -- ^ All ancestors, including transitive ancestors. + , structInternalSymbols :: Set StructSymbol -- ^ Signature. + } deriving (Show, Eq, Ord) + +newtype StructGraph + = StructGraph {unStructGraph :: Map StructPhrase Struct} + deriving (Show, Eq, Semigroup, Monoid) + + +-- | Lookup a struct by its name. +lookup :: StructPhrase -> StructGraph -> Maybe Struct +lookup str graph = Map.lookup str (unStructGraph graph) + +-- | Unsafe variant of 'lookup'. +unsafeLookup :: StructPhrase -> StructGraph -> Struct +unsafeLookup str graph = lookup str graph ?? error ("not in scope: " <> show str) + +-- | Returns the ancestors of the given StructPhrase in the graph. +-- This function fails quietly by returning the empty set if the struct is not present in the graph. +lookupAncestors :: StructPhrase -> StructGraph -> Set StructPhrase +lookupAncestors str graph = case lookup str graph of + Just struct -> structAncestors struct + Nothing -> mempty + +-- | Unsafe lookup of internal symbols by struct name. +lookupInternalSymbols :: StructPhrase -> StructGraph -> Set StructSymbol +lookupInternalSymbols phrase graph = case lookup phrase graph of + Nothing -> error ("structure not in scope: " <> show phrase) + Just struct -> structInternalSymbols struct + +-- | Unsafe lookup of symbols of a structure, including those inherited from ancestors. +lookupSymbols :: StructPhrase -> StructGraph -> Set StructSymbol +lookupSymbols phrase graph = case lookup phrase graph of + Nothing -> error ("structure not in scope: " <> show phrase) + Just struct -> + let ancestors = Set.map (`unsafeLookup` graph) (structAncestors struct) + ancestorSymbols = Set.unions (Set.map structInternalSymbols ancestors) + in ancestorSymbols <> structInternalSymbols struct + +structSymbols :: Struct -> StructGraph -> Set StructSymbol +structSymbols struct graph = + let ancestors = Set.map (`unsafeLookup` graph) (structAncestors struct) + ancestorSymbols = Set.unions (Set.map structInternalSymbols ancestors) + in structInternalSymbols struct <> ancestorSymbols + +isInternalSymbolIn :: StructSymbol -> Struct -> Bool +isInternalSymbolIn tok struct = Set.member tok (structInternalSymbols struct) + +isSymbolIn :: StructSymbol -> Struct -> StructGraph -> Bool +isSymbolIn tok struct graph = Set.member tok (structSymbols struct graph) + +-- | Insert a new struct into the graph. +insert + :: StructPhrase + -> Set StructPhrase + -> Set StructSymbol + -> StructGraph + -> StructGraph +insert structNoun ancestors structInternalSymbols graph = + let + transitiveAncestors anc = lookupAncestors anc graph + structAncestors = ancestors `Set.union` Set.unions (Set.map transitiveAncestors ancestors) + in StructGraph (Map.insert structNoun Struct{..} (unStructGraph graph)) diff --git a/source/Syntax/Abstract.hs b/source/Syntax/Abstract.hs new file mode 100644 index 0000000..6f30612 --- /dev/null +++ b/source/Syntax/Abstract.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} + + +-- | Data types for the abstract syntax tree and helper functions +-- for constructing the lexicon. +-- +module Syntax.Abstract + ( module Syntax.Abstract + , module Syntax.LexicalPhrase + , module Syntax.Token + ) where + + +import Base +import Syntax.LexicalPhrase (LexicalPhrase, SgPl(..), unsafeReadPhraseSgPl, unsafeReadPhrase) +import Syntax.Token (Token(..)) + +import Text.Earley.Mixfix (Holey) +import Data.Text qualified as Text +import Text.Megaparsec.Pos (SourcePos) + +-- | Local "variable-like" symbols that can be captured by binders. +data VarSymbol + = NamedVar Text -- ^ A named variable. + | FreshVar Int -- ^ A nameless (implicit) variable. Should only come from desugaring. + deriving (Show, Eq, Ord, Generic, Hashable) + +instance IsString VarSymbol where + fromString v = NamedVar $ Text.pack v + + +data Expr + = ExprVar VarSymbol + | ExprInteger Int + | ExprOp FunctionSymbol [Expr] + | ExprStructOp StructSymbol (Maybe Expr) + | ExprFiniteSet (NonEmpty Expr) + | ExprSep VarSymbol Expr Stmt + -- ^ Of the form /@{x ∈ X | P(x)}@/. + | ExprReplace Expr (NonEmpty (VarSymbol,Expr)) (Maybe Stmt) + -- ^ E.g.: /@{ f(x, y) | x ∈ X, y ∈ Y | P(x, y) }@/. + | ExprReplacePred VarSymbol VarSymbol Expr Stmt + -- ^ E.g.: /@{ y | \\exists x\\in X. P(x, y) }@/. + deriving (Show, Eq, Ord) + + +type FunctionSymbol = Holey Token + +type RelationSymbol = Token + +newtype StructSymbol = StructSymbol { unStructSymbol :: Text } deriving newtype (Show, Eq, Ord, Hashable) + +-- | The predefined @cons@ function symbol used for desugaring finite set expressions. +pattern ConsSymbol :: FunctionSymbol +pattern ConsSymbol = [Just (Command "cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] + +-- | The predefined @pair@ function symbol used for desugaring tuple notation.. +pattern PairSymbol :: FunctionSymbol +pattern PairSymbol = [Just (Command "pair"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] + +-- | Function application /@f(x)@/ desugars to /@\apply{f}{x}@/. +pattern ApplySymbol :: FunctionSymbol +pattern ApplySymbol = [Just (Command "apply"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR] + +pattern DomSymbol :: FunctionSymbol +pattern DomSymbol = [Just (Command "dom"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR] + +pattern CarrierSymbol :: StructSymbol +pattern CarrierSymbol = StructSymbol "carrier" + +pattern ExprConst :: Token -> Expr +pattern ExprConst c = ExprOp [Just c] [] + +pattern ExprApp :: Expr -> Expr -> Expr +pattern ExprApp e1 e2 = ExprOp ApplySymbol [e1, e2] + +pattern ExprPair :: Expr -> Expr -> Expr +pattern ExprPair e1 e2 = ExprOp PairSymbol [e1, e2] + +-- | Tuples are interpreted as nested pairs: +-- the triple /@(a, b, c)@/ is interpreted as +-- /@(a, (b, c))@/. +-- This means that the product operation should also +-- be right associative, so that /@(a, b, c)@/ can +-- form elements of /@A\times B\times C@/. +makeTuple :: NonEmpty Expr -> Expr +makeTuple = foldr1 ExprPair + + +data Chain + = ChainBase (NonEmpty Expr) Sign Relation (NonEmpty Expr) + | ChainCons (NonEmpty Expr) Sign Relation Chain + deriving (Show, Eq, Ord) + +data Relation + = RelationSymbol RelationSymbol -- ^ E.g.: /@x \in X@/ + | RelationExpr Expr -- ^ E.g.: /@x \mathrel{R} y@/ + deriving (Show, Eq, Ord) + +data Sign = Positive | Negative deriving (Show, Eq, Ord) + +data Formula + = FormulaChain Chain + | FormulaPredicate PrefixPredicate (NonEmpty Expr) + | Connected Connective Formula Formula + | FormulaNeg Formula + | FormulaQuantified Quantifier (NonEmpty VarSymbol) Bound Formula + | PropositionalConstant PropositionalConstant + deriving (Show, Eq, Ord) + +data PropositionalConstant = IsBottom | IsTop + deriving (Show, Eq, Ord, Generic, Hashable) + +data PrefixPredicate + = PrefixPredicate Text Int + deriving (Show, Eq, Ord, Generic, Hashable) + + +data Connective + = Conjunction + | Disjunction + | Implication + | Equivalence + | ExclusiveOr + | NegatedDisjunction + deriving (Show, Eq, Ord, Generic, Hashable) + + + +makeConnective :: Holey Token -> [Formula] -> Formula +makeConnective [Nothing, Just (Command "implies"), Nothing] [f1, f2] = Connected Implication f1 f2 +makeConnective [Nothing, Just (Command "land"), Nothing] [f1, f2] = Connected Conjunction f1 f2 +makeConnective [Nothing, Just (Command "lor"), Nothing] [f1, f2] = Connected Disjunction f1 f2 +makeConnective [Nothing, Just (Command "iff"), Nothing] [f1, f2] = Connected Equivalence f1 f2 +makeConnective [Just(Command "lnot"), Nothing] [f1] = FormulaNeg f1 +makeConnective pat _ = error ("makeConnective does not handle the following connective correctly: " <> show pat) + + + +type StructPhrase = SgPl LexicalPhrase + +-- | For example 'an integer' would be +-- > Noun (unsafeReadPhrase "integer[/s]") [] +type Noun = NounOf Term +data NounOf a + = Noun (SgPl LexicalPhrase) [a] + deriving (Show, Eq, Ord) + + + + +type NounPhrase t = NounPhraseOf t Term +-- NOTE: 'NounPhraseOf' is only used with arguments of type 'Term', +-- but keeping the argument parameter @a@ allows the 'Show' and 'Eq' +-- instances to remain decidable. +data NounPhraseOf t a + = NounPhrase [AdjLOf a] (NounOf a) (t VarSymbol) [AdjROf a] (Maybe Stmt) + +instance (Show a, Show (t VarSymbol)) => Show (NounPhraseOf t a) where + show (NounPhrase ls n vs rs ms) = + "NounPhrase (" + <> show ls <> ") (" + <> show n <> ") (" + <> show vs <> ") (" + <> show rs <> ") (" + <> show ms <> ")" + +instance (Eq a, Eq (t VarSymbol)) => Eq (NounPhraseOf t a) where + NounPhrase ls n vs rs ms == NounPhrase ls' n' vs' rs' ms' = + ls == ls' && n == n' && vs == vs' && rs == rs' && ms == ms' + +-- This is arbitrary and ugly, but it's useful to have a somewhat +-- usable Ord instance for all raw syntax (e.g. for 'nubOrd'). +instance (Ord a, Ord (t VarSymbol)) => Ord (NounPhraseOf t a) where + NounPhrase ls n vs rs ms `compare` NounPhrase ls' n' vs' rs' ms' = + case compare n n' of + GT -> case compare ls ls' of + GT -> case compare rs rs' of + GT -> case compare ms ms' of + GT -> compare vs vs' + ordering -> ordering + ordering -> ordering + ordering -> ordering + ordering -> ordering + +-- | @Nameless a@ is quivalent to @Const () a@ (from "Data.Functor.Const"). +-- It describes a container that is unwilling to actually contain something. +-- @Nameless@ lets us treat nouns with no names, one name, or many names uniformly. +-- Thus @NounPhraseOf Nameless a@ is a noun phrase without a name and with arguments +-- of type @a@. +data Nameless a = Nameless deriving (Show, Eq, Ord) + + +-- | Left adjectives modify nouns from the left side, +-- e.g. /@even@/, /@continuous@/, and /@σ-finite@/. +type AdjL = AdjLOf Term +data AdjLOf a + = AdjL LexicalPhrase [a] + deriving (Show, Eq, Ord) + + +-- | Right attributes consist of basic right adjectives, e.g. +-- /@divisible by ?@/, or /@of finite type@/ and verb phrases +-- marked with /@that@/, such as /@integer that divides n@/. +-- In some cases these right attributes may be followed +-- by an additional such-that phrase. +type AdjR = AdjROf Term +data AdjROf a + = AdjR LexicalPhrase [a] + | AttrRThat VerbPhrase + deriving (Show, Eq, Ord) + + +-- | Adjectives for parts of the AST where adjectives are not used +-- to modify nouns and the L/R distinction does not matter, such as +-- when then are used together with a copula (like /@n is even@/). +type Adj = AdjOf Term +data AdjOf a + = Adj LexicalPhrase [a] + deriving (Show, Eq, Ord) + + +type Verb = VerbOf Term +data VerbOf a + = Verb (SgPl LexicalPhrase) [a] + deriving (Show, Eq, Ord) + + +type Fun = FunOf Term +data FunOf a + = Fun (SgPl LexicalPhrase) [a] + deriving (Show, Eq, Ord) + + +type VerbPhrase = VerbPhraseOf Term +data VerbPhraseOf a + = VPVerb (VerbOf a) + | VPAdj (NonEmpty (AdjOf a)) -- ^ @x is foo@ / @x is foo and bar@ + | VPVerbNot (VerbOf a) + | VPAdjNot (NonEmpty (AdjOf a)) -- ^ @x is not foo@ / @x is neither foo nor bar@ + deriving (Show, Eq, Ord) + + +data Quantifier + = Universally + | Existentially + | Nonexistentially + deriving (Show, Eq, Ord) + +data QuantPhrase = QuantPhrase Quantifier (NounPhrase []) deriving (Show, Eq, Ord) + + +data Term + = TermExpr Expr + -- ^ A symbolic expression. + | TermFun Fun + -- ^ Definite noun phrase, e.g. /@the derivative of $f$@/. + | TermIota VarSymbol Stmt + -- ^ Definite descriptor, e.g. /@an $x$ such that ...@// + | TermQuantified Quantifier (NounPhrase Maybe) + -- ^ Indefinite quantified notion, e.g. /@every even integer that divides $k$ ...@/. + deriving (Show, Eq, Ord) + + +data Stmt + = StmtFormula Formula -- ^ E.g.: /@We have \<Formula\>@/. + | StmtVerbPhrase (NonEmpty Term) VerbPhrase -- ^ E.g.: /@\<Term\> and \<Term\> \<verb\>@/. + | StmtNoun Term (NounPhrase Maybe) -- ^ E.g.: /@\<Term\> is a(n) \<NP\>@/. + | StmtStruct Term StructPhrase + | StmtNeg Stmt -- ^ E.g.: /@It is not the case that \<Stmt\>@/. + | StmtExists (NounPhrase []) -- ^ E.g.: /@There exists a(n) \<NP\>@/. + | StmtConnected Connective Stmt Stmt + | StmtQuantPhrase QuantPhrase Stmt + | SymbolicQuantified Quantifier (NonEmpty VarSymbol) Bound (Maybe Stmt) Stmt + deriving (Show, Eq, Ord) + +data Bound = Unbounded | Bounded Sign Relation Expr deriving (Show, Eq, Ord) + +pattern SymbolicForall :: NonEmpty VarSymbol -> Bound -> Maybe Stmt -> Stmt -> Stmt +pattern SymbolicForall vs bound suchThat have = SymbolicQuantified Universally vs bound suchThat have + +pattern SymbolicExists :: NonEmpty VarSymbol -> Bound -> Stmt -> Stmt +pattern SymbolicExists vs bound suchThat = SymbolicQuantified Existentially vs bound Nothing suchThat + +pattern SymbolicNotExists :: NonEmpty VarSymbol -> Bound -> Stmt -> Stmt +pattern SymbolicNotExists vs bound suchThat = StmtNeg (SymbolicExists vs bound suchThat) + +data Asm + = AsmSuppose Stmt + | AsmLetNoun (NonEmpty VarSymbol) (NounPhrase Maybe) -- ^ E.g.: /@let k be an integer@/ + | AsmLetIn (NonEmpty VarSymbol) Expr -- ^ E.g.: /@let $k\in\integers$@/ + | AsmLetThe VarSymbol Fun -- ^ E.g.: /@let $g$ be the derivative of $f$@/ + | AsmLetEq VarSymbol Expr -- ^ E.g.: /@let $m = n + k$@/ + | AsmLetStruct VarSymbol StructPhrase -- ^ E.g.: /@let $A$ be a monoid@/ + deriving (Show, Eq, Ord) + +data Axiom = Axiom [Asm] Stmt + deriving (Show, Eq, Ord) + +data Lemma = Lemma [Asm] Stmt + deriving (Show, Eq, Ord) + +-- | The head of the definition describes the part before the /@iff@/, +-- i.e. the definiendum. An optional noun-phrase corresponds to an optional +-- type annotation for the 'Term' of the head. The last part of the head +-- is the lexical phrase that is defined. +-- +-- > "A natural number $n$ divides $m$ iff ..." +-- > ^^^^^^^^^^^^^^^^ ^^^ ^^^^^^^^^^^ ^^^ +-- > type annotation variable verb definiens +-- > (a noun phrase) (all args are vars) (a statement) +-- +data DefnHead + = DefnAdj (Maybe (NounPhrase Maybe)) VarSymbol (AdjOf VarSymbol) + | DefnVerb (Maybe (NounPhrase Maybe)) VarSymbol (VerbOf VarSymbol) + | DefnNoun VarSymbol (NounOf VarSymbol) + | DefnSymbolicPredicate PrefixPredicate (NonEmpty VarSymbol) + | DefnRel VarSymbol RelationSymbol VarSymbol + -- ^ E.g.: /@$x \subseteq y$ iff [...@/ + deriving (Show, Eq, Ord) + +data Defn + = Defn [Asm] DefnHead Stmt + | DefnFun [Asm] (FunOf VarSymbol) (Maybe Term) Term + -- ^ A 'DefnFun' consists of the functional noun (which must start with /@the@/) + -- and an optional specification of a symbolic equivalent. The symbolic equivalent + -- does not need to have the same variables as the full functional noun pattern. + -- + -- > "The tensor product of $U$ and $V$ over $K$, $U\tensor V$, is ..." + -- > ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^ ^^^ + -- > definiendum symbolic eqv. definiens + -- > (a functional noun) (an exression) (a term) + -- + | DefnOp SymbolPattern Expr + deriving (Show, Eq, Ord) + +data Proof + = Omitted + | Qed Justification + -- ^ Ends of a proof, leaving automation to discharge the current goal using the given justification. + | ByCase [Case] + | ByContradiction Proof + | BySetInduction (Maybe Term) Proof + -- ^ ∈-induction. + | ByOrdInduction Proof + -- ^ Transfinite induction for ordinals. + | Assume Stmt Proof + | FixSymbolic (NonEmpty VarSymbol) Bound Proof + | FixSuchThat (NonEmpty VarSymbol) Stmt Proof + | Calc Calc Proof + -- ^ Simplify goals that are implications or disjunctions. + | TakeVar (NonEmpty VarSymbol) Bound Stmt Justification Proof + | TakeNoun (NounPhrase []) Justification Proof + | Have (Maybe Stmt) Stmt Justification Proof + -- ^ /@Since \<stmt\>, we have \<stmt\> by \<ref\>.@/ + | Suffices Stmt Justification Proof + -- ^ /@It suffices to show that [...]. [...]@/ + | Subclaim Stmt Proof Proof + -- ^ A claim is a sublemma with its own proof: + -- /@Show \<goal stmt\>. \<steps\>. \<continue other proof\>.@/ + | Define VarSymbol Expr Proof + -- ^ Local definition. + -- + | DefineFunction VarSymbol VarSymbol Expr VarSymbol Expr Proof + -- ^ Local function definition, e.g. /@Let $f(x) = e$ for $x\\in d$@/. + -- The first 'VarSymbol' is the newly defined symbol, the second one is the argument. + -- The first 'Expr' is the value, the final variable and expr specify a bound (the domain of the function). + deriving (Show, Eq, Ord) + +-- | An inline justification. +data Justification + = JustificationRef (NonEmpty Marker) + | JustificationSetExt + | JustificationEmpty + | JustificationLocal -- ^ Use only local assumptions + deriving (Show, Eq, Ord) + + +-- | A case of a case split. +data Case = Case + { caseOf :: Stmt + , caseProof :: Proof + } deriving (Show, Eq, Ord) + +data Calc + = Equation Expr (NonEmpty (Expr, Justification)) + -- ^ A chain of equalities. Each claimed equality has a (potentially empty) justification. + -- For example: @a &= b \\explanation{by \\cref{a_eq_b}} &= c@ + -- would be (modulo expr constructors) + -- @Equation "a" [("b", JustificationRef "a_eq_b"), ("c", JustificationEmpty)]@. + | Biconditionals Formula (NonEmpty (Formula, Justification)) + deriving (Show, Eq, Ord) + + +data Abbreviation + = AbbreviationAdj VarSymbol (AdjOf VarSymbol) Stmt + | AbbreviationVerb VarSymbol (VerbOf VarSymbol) Stmt + | AbbreviationNoun VarSymbol (NounOf VarSymbol) Stmt + | AbbreviationRel VarSymbol RelationSymbol VarSymbol Stmt + | AbbreviationFun (FunOf VarSymbol) Term + | AbbreviationEq SymbolPattern Expr + deriving (Show, Eq, Ord) + +data Datatype + = DatatypeFin (NounOf Term) (NonEmpty Text) + deriving (Show, Eq, Ord) + +data Inductive = Inductive + { inductiveSymbolPattern :: SymbolPattern + , inductiveDomain :: Expr + , inductiveIntros :: NonEmpty IntroRule + } + deriving (Show, Eq, Ord) + +data IntroRule = IntroRule + { introConditions :: [Formula] -- The inductively defined set may only appear as an argument of monotone operations on the rhs. + , introResult :: Formula -- TODO Refine. + } + deriving (Show, Eq, Ord) + + +data SymbolPattern = SymbolPattern FunctionSymbol [VarSymbol] + deriving (Show, Eq, Ord) + +data Signature + = SignatureAdj VarSymbol (AdjOf VarSymbol) + | SignatureVerb VarSymbol (VerbOf VarSymbol) + | SignatureNoun VarSymbol (NounOf VarSymbol) + | SignatureSymbolic SymbolPattern (NounPhrase Maybe) + -- ^ /@$\<symbol\>(\<vars\>)$ is a \<noun\>@/ + deriving (Show, Eq, Ord) + + +data StructDefn = StructDefn + { structPhrase :: StructPhrase + -- ^ E.g.: @partial order@ or @abelian group@.\ + , structParents :: [StructPhrase] + -- ^ Structural parents + , structLabel :: VarSymbol + , structFixes :: [StructSymbol] + -- ^ List of text for commands representing constants not inherited from its parents, + -- e.g.: @\sqsubseteq@ or @\inv@. + , structAssumes :: [(Marker, Stmt)] + } + deriving (Show, Eq, Ord) + +newtype Marker = Marker Text deriving (Show, Eq, Ord, Generic) + +deriving newtype instance Hashable Marker + +instance IsString Marker where + fromString str = Marker (Text.pack str) + +data Block + = BlockAxiom SourcePos Marker Axiom + | BlockLemma SourcePos Marker Lemma + | BlockProof SourcePos Proof + | BlockDefn SourcePos Marker Defn + | BlockAbbr SourcePos Marker Abbreviation + | BlockData SourcePos Datatype + | BlockInductive SourcePos Marker Inductive + | BlockSig SourcePos [Asm] Signature + | BlockStruct SourcePos Marker StructDefn + deriving (Show, Eq, Ord) diff --git a/source/Syntax/Adapt.hs b/source/Syntax/Adapt.hs new file mode 100644 index 0000000..0896c08 --- /dev/null +++ b/source/Syntax/Adapt.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module Syntax.Adapt where + +import Base +import Syntax.Abstract +import Syntax.Lexicon +import Syntax.Token + +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Set qualified as Set +import Data.Sequence qualified as Seq +import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as Text +import Text.Earley.Mixfix (Associativity(..)) +import Text.Regex.Applicative +import Text.Megaparsec.Pos + + +scanChunk :: [Located Token] -> [ScannedLexicalItem] +scanChunk ltoks = + let toks = unLocated <$> ltoks + matchOrErr re env pos = match re toks ?? error ("could not find lexical pattern in " <> env <> " at " <> sourcePosPretty pos) + in case ltoks of + Located pos (BeginEnv "definition") : _ -> matchOrErr definition "definition" pos + Located pos (BeginEnv "abbreviation") : _ -> matchOrErr abbreviation "abbreviation" pos + Located pos (BeginEnv "struct") :_ -> matchOrErr struct "struct definition" pos + Located pos (BeginEnv "inductive") :_ -> matchOrErr inductive "inductive definition" pos + _ -> [] + +adaptChunks :: [[Located Token]] -> Lexicon -> Lexicon +adaptChunks = extendLexicon . concatMap scanChunk + +data ScannedLexicalItem + = ScanAdj LexicalPhrase Marker + | ScanFun LexicalPhrase Marker + | ScanNoun LexicalPhrase Marker + | ScanStructNoun LexicalPhrase Marker + | ScanVerb LexicalPhrase Marker + | ScanRelationSymbol RelationSymbol Marker + | ScanFunctionSymbol FunctionSymbol Marker + | ScanPrefixPredicate PrefixPredicate Marker + | ScanStructOp Text -- we an use the command text as export name. + deriving (Show, Eq) + +skipUntilNextLexicalEnv :: RE Token [Token] +skipUntilNextLexicalEnv = many (psym otherToken) + where + otherToken tok = tok /= BeginEnv "definition" && tok /= BeginEnv "struct" && tok /= BeginEnv "abbreviation" + +notEndOfLexicalEnvToken :: RE Token Token +notEndOfLexicalEnvToken = psym innerToken + where + innerToken tok = tok /= EndEnv "definition" && tok /= EndEnv "struct" && tok /= EndEnv "abbreviation" + +definition :: RE Token [ScannedLexicalItem] +definition = do + sym (BeginEnv "definition") + few notEndOfLexicalEnvToken + m <- label + few anySym + lexicalItem <- head + few anySym + sym (EndEnv "definition") + skipUntilNextLexicalEnv + pure [lexicalItem m] + +abbreviation :: RE Token [ScannedLexicalItem] +abbreviation = do + sym (BeginEnv "abbreviation") + few anySym + m <- label + few anySym + lexicalItem <- head + few anySym + sym (EndEnv "abbreviation") + skipUntilNextLexicalEnv + pure [lexicalItem m] + +label :: RE Token Marker +label = msym \case + Label m -> Just (Marker m) + _ -> Nothing + +-- | 'RE' that matches the head of a definition. +head :: RE Token (Marker -> ScannedLexicalItem) +-- Note that @<|>@ is left biased for 'RE', so we can just +-- place 'adj' before 'verb' and do not have to worry about +-- overlapping patterns. +head = ScanNoun <$> noun + <|> ScanAdj <$> adj + <|> ScanVerb <$> verb + <|> ScanFun <$> fun + <|> ScanRelationSymbol <$> relationSymbol + <|> ScanFunctionSymbol <$> functionSymbol + <|> ScanPrefixPredicate <$> prefixPredicate + +inductive :: RE Token [ScannedLexicalItem] +inductive = do + sym (BeginEnv "inductive") + few notEndOfLexicalEnvToken + m <- label + few anySym + lexicalItem <- functionSymbolInductive + few anySym + sym (EndEnv "inductive") + skipUntilNextLexicalEnv + pure [ScanFunctionSymbol lexicalItem m] + +struct :: RE Token [ScannedLexicalItem] +struct = do + sym (BeginEnv "struct") + few anySym + m <- label + few anySym + lexicalItem <- ScanStructNoun . toLexicalPhrase <$> (an *> structPat <* var) + few anySym + lexicalItems <- structOps <|> pure [] + sym (EndEnv "struct") + skipUntilNextLexicalEnv + pure (lexicalItem m : lexicalItems) + +structOps :: RE Token [ScannedLexicalItem] +structOps = do + sym (BeginEnv "enumerate") + lexicalItems <- many structOp + sym (EndEnv "enumerate") + few anySym + pure lexicalItems + +structOp :: RE Token ScannedLexicalItem +structOp = do + sym (Command "item") + op <- math command + pure (ScanStructOp op) + +noun :: RE Token LexicalPhrase +noun = toLexicalPhrase <$> (var *> is *> an *> pat <* iff) + +adj :: RE Token LexicalPhrase +adj = toLexicalPhrase <$> (var *> is *> pat <* iff) + +verb :: RE Token LexicalPhrase +verb = toLexicalPhrase <$> (var *> pat <* iff) + +fun :: RE Token LexicalPhrase +fun = toLexicalPhrase <$> (the *> pat <* (is <|> comma)) + +relationSymbol :: RE Token RelationSymbol +relationSymbol = math relator' <* iff + where + relator' = do + varSymbol + rel <- symbol + varSymbol + pure rel + +functionSymbol :: RE Token FunctionSymbol +functionSymbol = do + sym (BeginEnv "math") + toks <- few nonDefinitionKeyword + sym (Symbol "=") + pure (fromToken <$> toks) + where + fromToken = \case + Variable _ -> Nothing -- Variables become slots. + tok -> Just tok -- Everything else is part of the pattern. + +functionSymbolInductive :: RE Token FunctionSymbol +functionSymbolInductive = do + sym (BeginEnv "math") + toks <- few nonDefinitionKeyword + sym (Command "subseteq") + pure (fromToken <$> toks) + where + fromToken = \case + Variable _ -> Nothing -- Variables become slots. + tok -> Just tok -- Everything else is part of the pattern. + +prefixPredicate :: RE Token PrefixPredicate +prefixPredicate = math prfx <* iff + where + prfx = do + r <- command + args <- many (sym InvisibleBraceL *> varSymbol <* sym InvisibleBraceR) + pure (PrefixPredicate r (length args)) + + +command :: RE Token Text +command = msym \case + Command cmd -> Just cmd + _ -> Nothing + +var :: RE Token Token +var = math varSymbol + +varSymbol :: RE Token Token +varSymbol = psym isVar + + +nonDefinitionKeyword :: RE Token Token +nonDefinitionKeyword = psym (`notElem` keywords) + where + keywords = + [ Word "if" + , Word "iff" + , Symbol "=" + , Command "iff" + ] + + +pat :: RE Token [Token] +pat = many (psym isLexicalPhraseToken <|> var) + +structPat :: RE Token [Token] +structPat = many (psym isLexicalPhraseToken) + +math :: RE Token a -> RE Token a +math re = sym (BeginEnv "math") *> re <* sym (EndEnv "math") + +-- | We allow /conditional perfection/: the first /@if@/ in a definition is interpreted as /@iff@/. +iff :: RE Token () +iff = void (sym (Word "if")) -- Using @void@ is faster (only requires recognition). + <|> void (sym (Word "iff")) + <|> void (string [Word "if", Word "and", Word "only", Word "if"]) + <|> void (sym (Word "denote")) + <|> void (sym (Word "stand") *> sym (Word "for")) +{-# INLINE iff #-} + +an :: RE Token () +an = void (sym (Word "a")) + <|> void (sym (Word "an")) +{-# INLINE an #-} + +is :: RE Token () +is = void (sym (Word "is") <|> sym (Word "denotes")) +{-# INLINE is #-} + +the :: RE Token () +the = void (sym (Word "the")) +{-# INLINE the #-} + +comma :: RE Token () +comma = void (sym (Symbol ",")) +{-# INLINE comma #-} + + +isVar :: Token -> Bool +isVar = \case + Variable _ -> True + _token -> False + +isCommand :: Token -> Bool +isCommand = \case + Command _ -> True + _token -> False + +isNotDefnToken :: Token -> Bool +isNotDefnToken = \case + BeginEnv "definition" -> False + EndEnv "definition" -> False + _token -> True + +isLexicalPhraseToken :: Token -> Bool +isLexicalPhraseToken = \case + Word w -> w `Set.notMember` keywords + -- + -- Simple commands (outside of math-mode) are allowed. This is useful + -- for defining lexical phrases containing symbolic expressions such as + -- `X is \Ttwo{}`, where `\Ttwo` is a macro that expands to `T_2`. + -- We also allow these macros to take arguments, hence the need to + -- allow grouping delimiters. They can also be used to escape the end + -- of the command for correct spacing, as in the above example. + -- + Command _cmd -> True + InvisibleBraceL -> True + InvisibleBraceR -> True + -- + -- No other tokens may occur in lexical phrases. In particular, no `_dot` + -- token may occur, limiting the lexical phrase to a single sentence. + -- Commas occurring in variable lists should be placed + -- within the math environment. Thus `$a,b$ are coprime iff`, + -- not `$a$,`$b$` are coprime iff`. + -- + _token -> False + where + keywords = Set.fromList ["a", "an", "is", "are", "if", "iff", "denote", "stand", "let"] + + +toLexicalPhrase :: [Token] -> LexicalPhrase +toLexicalPhrase toks = component <$> toks + where + component = \case + Variable _ -> Nothing + tok -> Just tok + + +symbol :: RE Token Token +symbol = msym $ \tok -> case tok of + Command _ -> Just tok + Symbol _ -> Just tok + _tok -> Nothing + + +-- | Basic paradigms for pluralizations of nominals. +guessNounPlural :: LexicalPhrase -> SgPl LexicalPhrase +guessNounPlural item = SgPl item (pluralize item) + where + pluralize :: LexicalPhrase -> LexicalPhrase + pluralize = \case + Just (Word w) : pat'@(Just w' : _) | isPreposition w' -> Just (Word (Text.snoc w 's')) : pat' + [Just (Word w)] -> [Just (Word (Text.snoc w 's'))] + [tok, Just (Word w)] -> [tok, Just (Word (Text.snoc w 's'))] + [tok, tok', Just (Word w)] -> [tok, tok', Just (Word (Text.snoc w 's'))] + pat' -> pat' + +guessVerbPlural :: LexicalPhrase -> SgPl LexicalPhrase +guessVerbPlural item = SgPl item itemPl + where + itemPl = case item of + Just (Word v) : rest -> case Text.unsnoc v of + Just (v', 's') -> Just (Word v') : rest + _ -> item + _ -> item + +isAdjR :: LexicalPhrase -> Bool +isAdjR item = containsPreposition item || containsSlot item + where + containsPreposition, containsSlot :: LexicalPhrase -> Bool + containsPreposition = any isPreposition . catMaybes + containsSlot = (Nothing `elem`) + +isPreposition :: Token -> Bool +isPreposition w = HS.member w (HS.map Word prepositions) + +-- | Right-biased set insertion, keeping the original set +-- when inserting already present elements. @insertR@ is unfortunately +-- a hidden function, even in @Data.Set.Internal@, so we approximate it +-- here. In theory one could avoid the indirection of first forming the singleton +-- set on the rhs. +insertR' :: Hashable a => a -> HashSet a -> HashSet a +insertR' x xs = xs `HS.union` HS.singleton x -- @union@ is left-biased. + +insertMapR :: Ord k => k -> a -> Map k a -> Map k a +insertMapR k x xs = xs `Map.union` Map.singleton k x -- @union@ is left-biased. + + +insertR :: Hashable k => k -> a -> HashMap k a -> HashMap k a +insertR k x xs = xs `HM.union` HM.singleton k x -- @union@ is left-biased. + +-- | Takes the scanned lexical phrases and inserts them in the correct +-- places in a lexicon. +extendLexicon :: [ScannedLexicalItem] -> Lexicon -> Lexicon +extendLexicon [] lexicon = lexicon +-- Note that we only consider 'sg' in the 'Ord' instance of SgPl, so that +-- known irregular plurals are preserved. +extendLexicon (scan : scans) lexicon@Lexicon{..} = case scan of + ScanAdj item m -> if isAdjR item + then extendLexicon scans lexicon{lexiconAdjRs = insertR item m lexiconAdjRs} + else extendLexicon scans lexicon{lexiconAdjLs = insertR item m lexiconAdjLs} + ScanFun item m -> + extendLexicon scans lexicon{lexiconFuns = insertR (guessNounPlural item) m lexiconFuns} + ScanVerb item m -> + extendLexicon scans lexicon{lexiconVerbs = insertR (guessVerbPlural item) m lexiconVerbs} + ScanNoun item m -> + extendLexicon scans lexicon{lexiconNouns = insertR (guessNounPlural item) m lexiconNouns} + ScanStructNoun item m -> + extendLexicon scans lexicon{lexiconStructNouns = insertR (guessNounPlural item) m lexiconStructNouns} + ScanRelationSymbol item m -> + extendLexicon scans lexicon{lexiconRelationSymbols = insertR item m lexiconRelationSymbols} + ScanFunctionSymbol item m -> + if any (item `HM.member`) lexiconMixfix + then extendLexicon scans lexicon + else extendLexicon scans lexicon{lexiconMixfix = Seq.adjust (HM.insert item (NonAssoc, m)) 9 lexiconMixfix} + ScanStructOp op -> + extendLexicon scans lexicon{lexiconStructFun = insertR (StructSymbol op) (Marker op) lexiconStructFun} + ScanPrefixPredicate tok m -> + extendLexicon scans lexicon{lexiconPrefixPredicates = insertR tok m lexiconPrefixPredicates} diff --git a/source/Syntax/Chunk.hs b/source/Syntax/Chunk.hs new file mode 100644 index 0000000..604ccf6 --- /dev/null +++ b/source/Syntax/Chunk.hs @@ -0,0 +1,46 @@ +module Syntax.Chunk where + +import Base +import Syntax.Token + +import Data.List qualified as List + + +-- LATER This is just a naïve implementation of token chunks. +-- It and the current tokenizer should probably be replaced by +-- a more efficient implementation that does chunking +-- directly while tokenizing. + +chunkify :: [Located Token] -> [[Located Token]] +chunkify [] = [] +chunkify (tok : toks) = case unLocated tok of + BeginEnv env | isTopLevelEnv env -> + let (axiomToks, otherToks) = envBlock env toks + in (tok : axiomToks) : chunkify otherToks + -- + -- Skip all tokens outside of toplevel environments. + _ -> chunkify toks + +isTopLevelEnv :: Text -> Bool +isTopLevelEnv env = env `elem` + [ "abbreviation" + , "axiom" + , "claim" + , "corollary" + , "datatype" + , "definition" + , "inductive" + , "lemma" + , "proof" + , "proposition" + , "signature" + , "struct" + , "theorem" + ] + +envBlock :: Text -> [Located Token] -> ([Located Token], [Located Token]) +envBlock env toks = + let (pre, post) = List.span (\tok -> unLocated tok /= EndEnv env) toks + in case post of + [] -> (pre, post) + endEnv : post' -> (pre ++ [endEnv], post') diff --git a/source/Syntax/Concrete.hs b/source/Syntax/Concrete.hs new file mode 100644 index 0000000..8c6962d --- /dev/null +++ b/source/Syntax/Concrete.hs @@ -0,0 +1,657 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} + +-- | Concrete syntax of the surface language. +module Syntax.Concrete where + +import Base +import Syntax.Abstract +import Syntax.Concrete.Keywords +import Syntax.Lexicon (Lexicon(..), lexiconAdjs, splitOnVariableSlot) +import Syntax.Token + +import Data.HashSet qualified as HS +import Data.List.NonEmpty qualified as NonEmpty +import Data.HashMap.Strict qualified as HM +import Text.Earley (Grammar, Prod, (<?>), rule, satisfy, terminal) +import Text.Earley.Mixfix +import Text.Megaparsec.Pos (SourcePos) + + +grammar :: Lexicon -> Grammar r (Prod r Text (Located Token) Block) +grammar lexicon@Lexicon{..} = mdo + let makeOp :: ([Maybe Token], Associativity) -> ([Maybe (Prod r Text (Located Token) Token)], Associativity) + makeOp (pat, assoc) = (map (fmap token) pat, assoc) + ops = map (map makeOp) (toList (HM.toList . HM.map fst <$> lexiconMixfix)) + conns = map (map makeOp) lexiconConnectives + + integer <- rule (terminal maybeIntToken <?> "integer") + relator <- rule $ unLocated <$> (satisfy (\ltok -> unLocated ltok `HM.member` lexiconRelationSymbols) <?> "relator") + varSymbol <- rule (terminal maybeVarToken <?> "variable") + varSymbols <- rule (commaList varSymbol) + cmd <- rule (terminal maybeCmdToken <?> "TEX command") +-- +-- Formulas have three levels: +-- +-- + Expressions: atoms or operators applied to atoms. +-- + Chains: comma-lists of expressions, separated by relators. +-- + Formulas: chains or connectives applied to chains. +-- +-- For example, the formula @x, y < z \implies x, y < z + 1@ consist of the +-- connective @\implies@ applied to two chains @x, y < z@ and @x, y < z + 1@. +-- In turn, the chain @x, y < z + 1@ consist of three expressions, +-- @x@, @y@, and @z + 1@. Finally, @z + 1@ consist the operator @+@ +-- applied to two atoms, the variable @z@ and the number literal @1@. +-- +-- This split is due to the different behaviour of relators compared to +-- operators and connectives. Relators can chain (@x < y < z@) and allow +-- lists as arguments, as in the above example. Operators and connectives +-- instead have precedence and fixity. The only syntactic difference between +-- an operator and a connective is the relative precedence compared to relators. +-- + replaceBound <- rule $ (,) <$> varSymbol <* _in <*> expr + replaceBounds <- rule $ commaList replaceBound + replaceFun <- rule $ ExprReplace <$> expr <* _pipe <*> replaceBounds <*> optional (_pipe *> comprStmt) + comprStmt <- rule $ (StmtFormula <$> formula) <|> text stmt + + replacePredSymbolic <- rule $ ExprReplacePred <$> varSymbol <* _pipe <*> (command "exists" *> varSymbol) <* _in <*> expr <* _dot <*> (StmtFormula <$> formula) + replacePredText <- rule $ ExprReplacePred <$> varSymbol <* _pipe <*> (begin "text" *> _exists *> beginMath *> varSymbol <* _in) <*> expr <* endMath <* _suchThat <*> stmt <* end "text" + replacePred <- rule $ replacePredSymbolic <|> replacePredText + + let exprStructOpOf ann = HS.foldr alg empty (HM.keysSet lexiconStructFun) + where + alg s prod = prod <|> (ExprStructOp <$> structSymbol s <*> ann) + + exprStructOp <- rule (exprStructOpOf (optional (bracket expr))) + + let bracedArgs1 ar arg = count1 ar $ group arg + let prefixPredicateOf f arg symb@(PrefixPredicate c ar) = f <$> pure symb <* command c <*> bracedArgs1 ar arg + + + exprParen <- rule $ paren expr + exprInteger <- rule $ ExprInteger <$> integer + exprVar <- rule $ ExprVar <$> varSymbol + exprTuple <- rule $ makeTuple <$> paren (commaList2 expr) + exprSep <- rule $ brace $ ExprSep <$> varSymbol <* _in <*> expr <* _pipe <*> comprStmt + exprReplace <- rule $ brace $ (replaceFun <|> replacePred) + exprFinSet <- rule $ brace $ ExprFiniteSet <$> exprs + exprBase <- rule $ asum [exprVar, exprInteger, exprStructOp, exprParen, exprTuple, exprSep, exprReplace, exprFinSet] + exprApp <- rule $ ExprApp <$> exprBase <*> (paren expr <|> exprTuple) + expr <- mixfixExpression ops (exprBase <|> exprApp) ExprOp + exprs <- rule $ commaList expr + + relationSign <- rule $ pure Positive <|> (Negative <$ command "not") + relationExpr <- rule $ RelationExpr <$> (command "mathrel" *> group expr) + relation <- rule $ (RelationSymbol <$> relator) <|> relationExpr + chainBase <- rule $ ChainBase <$> exprs <*> relationSign <*> relation <*> exprs + chainCons <- rule $ ChainCons <$> exprs <*> relationSign <*> relation <*> chain + chain <- rule $ chainCons <|> chainBase + + formulaPredicate <- rule $ asum $ prefixPredicateOf FormulaPredicate expr <$> HM.keys lexiconPrefixPredicates + formulaChain <- rule $ FormulaChain <$> chain + formulaBottom <- rule $ PropositionalConstant IsBottom <$ command "bot" <?> "\"\\bot\"" + formulaTop <- rule $ PropositionalConstant IsTop <$ command "top" <?> "\"\\top\"" + formulaExists <- rule $ FormulaQuantified Existentially <$> (command "exists" *> varSymbols) <*> maybeBounded <* _dot <*> formula + formulaAll <- rule $ FormulaQuantified Universally <$> (command "forall" *> varSymbols) <*> maybeBounded <* _dot <*> formula + formulaQuantified <- rule $ formulaExists <|> formulaAll + formulaBase <- rule $ asum [formulaChain, formulaPredicate, formulaBottom, formulaTop, paren formula] + formulaConn <- mixfixExpression conns formulaBase makeConnective + formula <- rule $ formulaQuantified <|> formulaConn + +-- These are asymmetric formulas (only variables are allowed on one side). +-- They express judgements. +-- + assignment <- rule $ (,) <$> varSymbol <* (_eq <|> _defeq) <*> expr + typing <- rule $ (,) <$> varSymbols <* (_in <|> _colon) <*> expr + + adjL <- rule $ adjLOf lexicon term + adjR <- rule $ adjROf lexicon term + adj <- rule $ adjOf lexicon term + adjVar <- rule $ adjOf lexicon var + + var <- rule $ math varSymbol + vars <- rule $ math varSymbols + + verb <- rule $ verbOf lexicon sg term + verbPl <- rule $ verbOf lexicon pl term + verbVar <- rule $ verbOf lexicon sg var + + noun <- rule $ nounOf lexicon sg term nounName -- Noun with optional variable name. + nounList <- rule $ nounOf lexicon sg term nounNames -- Noun with a list of names. + nounVar <- rule $ fst <$> nounOf lexicon sg var (pure Nameless) -- No names in defined nouns. + nounPl <- rule $ nounOf lexicon pl term nounNames + nounPlMay <- rule $ nounOf lexicon pl term nounName + + structNoun <- rule $ structNounOf lexicon sg var var + structNounNameless <- rule $ fst <$> structNounOf lexicon sg var (pure Nameless) + + + fun <- rule $ funOf lexicon sg term + funVar <- rule $ funOf lexicon sg var + + attrRThat <- rule $ AttrRThat <$> thatVerbPhrase + attrRThats <- rule $ ((:[]) <$> attrRThat) <|> ((\a a' -> [a,a']) <$> attrRThat <* _and <*> attrRThat) <|> pure [] + attrRs <- rule $ ((:[]) <$> adjR) <|> ((\a a' -> [a,a']) <$> adjR <* _and <*> adjR) <|> pure [] + attrRight <- rule $ (<>) <$> attrRs <*> attrRThats + + verbPhraseVerbSg <- rule $ VPVerb <$> verb + verbPhraseVerbNotSg <- rule $ VPVerbNot <$> (_does *> _not *> verbPl) + verbPhraseAdjSg <- rule $ VPAdj . (:|[]) <$> (_is *> adj) + verbPhraseAdjAnd <- rule do {_is; a1 <- adj; _and; a2 <- adj; pure (VPAdj (a1 :| [a2]))} + verbPhraseAdjNotSg <- rule $ VPAdjNot . (:|[]) <$> (_is *> _not *> adj) + verbPhraseNotSg <- rule $ verbPhraseVerbNotSg <|> verbPhraseAdjNotSg + verbPhraseSg <- rule $ verbPhraseVerbSg <|> verbPhraseAdjSg <|> verbPhraseAdjAnd <|> verbPhraseNotSg + + -- LATER can cause technical ambiguities? verbPhraseVerbPl <- rule $ VPVerb <$> verbPl + verbPhraseVerbNotPl <- rule $ VPVerbNot <$> (_do *> _not *> verbPl) + verbPhraseAdjPl <- rule $ VPAdj . (:|[]) <$> (_are *> adj) + verbPhraseAdjNotPl <- rule $ VPAdjNot . (:|[]) <$> (_are *> _not *> adj) + verbPhraseNotPl <- rule $ verbPhraseVerbNotPl <|> verbPhraseAdjNotPl + verbPhrasePl <- rule $ verbPhraseAdjPl <|> verbPhraseNotPl -- LATER <|> verbPhraseVerbPl + + + + thatVerbPhrase <- rule $ _that *> verbPhraseSg + + nounName <- rule $ optional (math varSymbol) + nounNames <- rule $ math (commaList_ varSymbol) <|> pure [] + nounPhrase <- rule $ makeNounPhrase <$> many adjL <*> noun <*> attrRight <*> optional suchStmt + nounPhrase' <- rule $ makeNounPhrase <$> many adjL <*> nounList <*> attrRight <*> optional suchStmt + nounPhrasePl <- rule $ makeNounPhrase <$> many adjL <*> nounPl <*> attrRight <*> optional suchStmt + nounPhrasePlMay <- rule $ makeNounPhrase <$> many adjL <*> nounPlMay <*> attrRight <*> optional suchStmt + nounPhraseMay <- rule $ makeNounPhrase <$> many adjL <*> noun <*> attrRight <*> optional suchStmt + + -- Quantification phrases for quantification and indfinite terms. + quantAll <- rule $ QuantPhrase Universally <$> (_forEvery *> nounPhrase' <|> _forAll *> nounPhrasePl) + quantSome <- rule $ QuantPhrase Existentially <$> (_some *> (nounPhrase' <|> nounPhrasePl)) + quantNone <- rule $ QuantPhrase Nonexistentially <$> (_no *> (nounPhrase' <|> nounPhrasePl)) + quant <- rule $ quantAll <|> quantSome <|> quantNone -- <|> quantUniq + + + termExpr <- rule $ TermExpr <$> math expr + termFun <- rule $ TermFun <$> (optional _the *> fun) + termIota <- rule $ TermIota <$> (_the *> var) <* _suchThat <*> stmt + termAll <- rule $ TermQuantified Universally <$> (_every *> nounPhraseMay) + termSome <- rule $ TermQuantified Existentially <$> (_some *> nounPhraseMay) + termNo <- rule $ TermQuantified Nonexistentially <$> (_no *> nounPhraseMay) + termQuantified <- rule $ termAll <|> termSome <|> termNo + term <- rule $ termExpr <|> termFun <|> termQuantified <|> termIota + +-- Basic statements @stmt'@ are statements without any conjunctions or quantifiers. +-- + stmtVerbSg <- rule $ StmtVerbPhrase <$> ((:| []) <$> term) <*> verbPhraseSg + stmtVerbPl <-rule $ StmtVerbPhrase <$> andList1 term <*> verbPhrasePl + stmtVerb <- rule $ stmtVerbSg <|> stmtVerbPl + stmtNounIs <- rule $ StmtNoun <$> term <* _is <* _an <*> nounPhrase + stmtNounIsNot <- rule $ StmtNeg <$> (StmtNoun <$> term <* _is <* _not <* _an <*> nounPhrase) + stmtNoun <- rule $ stmtNounIs <|> stmtNounIsNot + stmtStruct <- rule $ StmtStruct <$> (term <* _is <* _an) <*> structNounNameless + stmtExists <- rule $ StmtExists <$> (_exists *> _an *> nounPhrase') + stmtExist <- rule $ StmtExists <$> (_exist *> nounPhrasePl) + stmtExistsNot <- rule $ StmtNeg . StmtExists <$> (_exists *> _no *> nounPhrase') + stmtFormula <- rule $ StmtFormula <$> math formula + stmtBot <- rule $ StmtFormula (PropositionalConstant IsBottom) <$ _contradiction + stmt' <- rule $ stmtVerb <|> stmtNoun <|> stmtStruct <|> stmtFormula <|> stmtBot + stmtOr <- rule $ stmt' <|> (StmtConnected Disjunction <$> stmt' <* _or <*> stmt) + stmtAnd <- rule $ stmtOr <|> (StmtConnected Conjunction <$> stmtOr <* _and <*> stmt) + stmtIff <- rule $ stmtAnd <|> (StmtConnected Equivalence <$> stmtAnd <* _iff <*> stmt) + stmtIf <- rule $ StmtConnected Implication <$> (_if *> stmt) <* optional _comma <* _then <*> stmt + stmtXor <- rule $ StmtConnected ExclusiveOr <$> (_either *> stmt) <* _or <*> stmt + stmtNor <- rule $ StmtConnected NegatedDisjunction <$> (_neither *> stmt) <* _nor <*> stmt + stmtNeg <- rule $ StmtNeg <$> (_itIsWrong *> stmt) + + stmtQuantPhrase <- rule $ StmtQuantPhrase <$> (_for *> quant) <* optional _comma <* optional _have <*> stmt + + suchStmt <- rule $ _suchThat *> stmt <* optional _comma + + + -- Symbolic quantifications with or without generalized bounds. + symbolicForall <- rule $ SymbolicForall + <$> ((_forAll <|> _forEvery) *> beginMath *> varSymbols) + <*> maybeBounded <* endMath + <*> optional suchStmt + <* optional _have <*> stmt + symbolicExists <- rule $ SymbolicExists + <$> ((_exists <|> _exist) *> beginMath *> varSymbols) + <*> maybeBounded <* endMath + <*> ((_suchThat *> stmt) <|> pure (StmtFormula (PropositionalConstant IsTop))) + symbolicNotExists <- rule $ SymbolicNotExists + <$> (_exists *> _no *> beginMath *> varSymbols) + <*> maybeBounded <* endMath + <* _suchThat <*> stmt + symbolicBound <- rule $ Bounded <$> relationSign <*> relation <*> expr + maybeBounded <- rule (pure Unbounded <|> symbolicBound) + + symbolicQuantified <- rule $ symbolicForall <|> symbolicExists <|> symbolicNotExists + + stmt <- rule $ asum [stmtNeg, stmtIf, stmtXor, stmtNor, stmtExists, stmtExist, stmtExistsNot, stmtQuantPhrase, stmtIff, symbolicQuantified] <?> "a statement" + + asmLetIn <- rule $ uncurry AsmLetIn <$> (_let *> math typing) + asmLetNoun <- rule $ AsmLetNoun <$> (_let *> fmap pure var <* (_be <|> _denote) <* _an) <*> nounPhrase + asmLetNouns <- rule $ AsmLetNoun <$> (_let *> vars <* (_be <|> _denote)) <*> nounPhrasePlMay + asmLetEq <- rule $ uncurry AsmLetEq <$> (_let *> math assignment) + asmLetThe <- rule $ AsmLetThe <$> (_let *> var <* _be <* _the) <*> fun + asmLetStruct <- rule $ AsmLetStruct <$> (_let *> var <* _be <* _an) <*> structNounNameless + asmLet <- rule $ asmLetNoun <|> asmLetNouns <|> asmLetIn <|> asmLetEq <|> asmLetThe <|> asmLetStruct + asmSuppose <- rule $ AsmSuppose <$> (_suppose *> stmt) + asm <- rule $ assumptionList (asmLet <|> asmSuppose) <* _dot + asms <- rule $ concat <$> many asm + + axiom <- rule $ Axiom <$> asms <* optional _then <*> stmt <* _dot + + lemma <- rule $ Lemma <$> asms <* optional _then <*> stmt <* _dot + + defnAdj <- rule $ DefnAdj <$> optional (_an *> nounPhrase) <*> var <* _is <*> adjVar + defnVerb <- rule $ DefnVerb <$> optional (_an *> nounPhrase) <*> var <*> verbVar + defnNoun <- rule $ DefnNoun <$> var <* _is <* _an <*> nounVar + defnRel <- rule $ DefnRel <$> (beginMath *> varSymbol) <*> relator <*> varSymbol <* endMath + defnSymbolicPredicate <- rule $ math $ asum $ prefixPredicateOf DefnSymbolicPredicate varSymbol <$> HM.keys lexiconPrefixPredicates + defnHead <- rule $ optional _write *> asum [defnAdj, defnVerb, defnNoun, defnRel, defnSymbolicPredicate] + + defnIf <- rule $ Defn <$> asms <*> defnHead <* (_iff <|> _if) <*> stmt <* _dot + defnFunSymb <- rule $ _comma *> termExpr <* _comma -- ^ Optional symbolic equivalent. + defnFun <- rule $ DefnFun <$> asms <*> (optional _the *> funVar) <*> optional defnFunSymb <* _is <*> term <* _dot + + symbolicPatternEqTerm <- rule do + pat <- beginMath *> symbolicPattern <* _eq + e <- expr <* endMath <* _dot + pure (pat, e) + defnOp <- rule $ uncurry DefnOp <$> symbolicPatternEqTerm + + defn <- rule $ defnIf <|> defnFun <|> defnOp + + abbreviationVerb <- rule $ AbbreviationVerb <$> var <*> verbVar <* (_iff <|> _if) <*> stmt <* _dot + abbreviationAdj <- rule $ AbbreviationAdj <$> var <* _is <*> adjVar <* (_iff <|> _if) <*> stmt <* _dot + abbreviationNoun <- rule $ AbbreviationNoun <$> var <* _is <* _an <*> nounVar <* (_iff <|> _if) <*> stmt <* _dot + abbreviationRel <- rule $ AbbreviationRel <$> (beginMath *> varSymbol) <*> relator <*> varSymbol <* endMath <* (_iff <|> _if) <*> stmt <* _dot + abbreviationFun <- rule $ AbbreviationFun <$> (_the *> funVar) <* (_is <|> _denotes) <*> term <* _dot + abbreviationEq <- rule $ uncurry AbbreviationEq <$> symbolicPatternEqTerm + abbreviation <- rule $ (abbreviationVerb <|> abbreviationAdj <|> abbreviationNoun <|> abbreviationRel <|> abbreviationFun <|> abbreviationEq) + + datatypeFin <- rule $ DatatypeFin <$> fmap fst (_an *> noun) <*> (_is *> _oneOf *> orList2 (math cmd) <* _dot) + datatype <- rule datatypeFin + + unconditionalIntro <- rule $ IntroRule [] <$> math formula + conditionalIntro <- rule $ IntroRule <$> (_if *> andList1_ (math formula)) <* _comma <* _then <*> math formula + inductiveIntro <- rule $ (unconditionalIntro <|> conditionalIntro) <* _dot + inductiveDomain <- rule $ math $ (,) <$> symbolicPattern <* _subseteq <*> expr + inductiveHead <- rule $ _define *> inductiveDomain <* optional _inductively <* optional _asFollows <* _dot + inductive <- rule $ uncurry Inductive <$> inductiveHead <*> enumerated1 inductiveIntro + + signatureAdj <- rule $ SignatureAdj <$> var <* _can <* _be <*> adjOf lexicon var + symbolicPattern <- symbolicPatternOf ops varSymbol + signatureSymbolic <- rule $ SignatureSymbolic <$> math symbolicPattern <* _is <* _an <*> nounPhrase + signature <- rule $ (,) <$> asms <* optional _then <*> (signatureAdj <|> signatureSymbolic) <* _dot + + structFix <- rule do + beginMath + rawCmd <- cmd + endMath + pure (StructSymbol rawCmd) + structDefn <- rule $ do + _an + ~(structPhrase, structLabel) <- structNoun + _extends + structParents <- andList1_ (_an *> structNounNameless) + maybeFixes <- optional (_equipped *> enumerated structFix) + structAssumes <- (_suchThat *> enumeratedMarked (stmt <* _dot)) <|> ([] <$ _dot) + pure StructDefn + { structPhrase = structPhrase + , structLabel = structLabel + , structParents = structParents + , structFixes = maybeFixes ?? [] + , structAssumes = structAssumes + } + + justificationSet <- rule $ JustificationSetExt <$ _bySetExt + justificationRef <- rule $ JustificationRef <$> (_by *> ref) + justificationLocal <- rule $ JustificationLocal <$ (_by *> (_assumption <|> _definition)) + justification <- rule (justificationSet <|> justificationRef <|> justificationLocal <|> pure JustificationEmpty) + + trivial <- rule $ Qed JustificationEmpty <$ _trivial <* _dot + omitted <- rule $ Omitted <$ _omitted <* _dot + qedJustified <- rule $ Qed <$> (_follows *> justification <* _dot) + qed <- rule $ qedJustified <|> trivial <|> omitted <|> pure (Qed JustificationEmpty) + + let alignedEq = symbol "&=" <?> "\"&=\"" + explanation <- rule $ (text justification) <|> pure JustificationEmpty + equationItem <- rule $ (,) <$> (alignedEq *> expr) <*> explanation + equations <- rule $ Equation <$> expr <*> (many1 equationItem) + + let alignedIff = symbol "&" *> command "iff" <?> "\"&\\iff\"" + biconditionalItem <- rule $ (,) <$> (alignedIff *> formula) <*> explanation + biconditionals <- rule $ Biconditionals <$> formula <*> (many1 biconditionalItem) + + calc <- rule $ Calc <$> align (equations <|> biconditionals) <*> proof + + caseOf <- rule $ command "caseOf" *> token InvisibleBraceL *> stmt <* _dot <* token InvisibleBraceR + byCases <- rule $ ByCase <$> env_ "byCase" (many1_ (Case <$> caseOf <*> proof)) + byContradiction <- rule $ ByContradiction <$ _suppose <* _not <* _dot <*> proof + bySetInduction <- rule $ BySetInduction <$> proofBy (_in *> word "-induction" *> optional (word "on" *> term)) <*> proof + byOrdInduction <- rule $ ByOrdInduction <$> proofBy (word "transfinite" *> word "induction" *> proof) + assume <- rule $ Assume <$> (_suppose *> stmt <* _dot) <*> proof + + fixSymbolic <- rule $ FixSymbolic <$> (_fix *> beginMath *> varSymbols) <*> maybeBounded <* endMath <* _dot <*> proof + fixSuchThat <- rule $ FixSuchThat <$> (_fix *> math varSymbols) <* _suchThat <*> stmt <* _dot <*> proof + fix <- rule $ fixSymbolic <|> fixSuchThat + + takeVar <- rule $ TakeVar <$> (_take *> beginMath *> varSymbols) <*> maybeBounded <* endMath <* _suchThat <*> stmt <*> justification <* _dot <*> proof + takeNoun <- rule $ TakeNoun <$> (_take *> _an *> (nounPhrase' <|> nounPhrasePl)) <*> justification <* _dot <*> proof + take <- rule $ takeVar <|> takeNoun + suffices <- rule $ Suffices <$> (_sufficesThat *> stmt) <*> (justification <* _dot) <*> proof + subclaim <- rule $ Subclaim <$> (_show *> stmt <* _dot) <*> env_ "subproof" proof <*> proof + have <- rule $ Have <$> optional (_since *> stmt <* _comma <* _have) <* optional _haveIntro <*> stmt <*> justification <* _dot <*> proof + + define <- rule $ Define <$> (_let *> beginMath *> varSymbol <* _eq) <*> expr <* endMath <* _dot <*> proof + defineFunction <- rule $ DefineFunction <$> (_let *> beginMath *> varSymbol) <*> paren varSymbol <* _eq <*> expr <* endMath <* _for <* beginMath <*> varSymbol <* _in <*> expr <* endMath <* _dot <*> proof + + proof <- rule $ asum [byContradiction, byCases, bySetInduction, byOrdInduction, calc, subclaim, assume, fix, take, have, suffices, define, defineFunction, qed] + + + blockAxiom <- rule $ uncurry3 BlockAxiom <$> envPos "axiom" axiom + blockLemma <- rule $ uncurry3 BlockLemma <$> lemmaEnv lemma + blockProof <- rule $ uncurry BlockProof <$> envPos_ "proof" proof + blockDefn <- rule $ uncurry3 BlockDefn <$> envPos "definition" defn + blockAbbr <- rule $ uncurry3 BlockAbbr <$> envPos "abbreviation" abbreviation + blockData <- rule $ uncurry BlockData <$> envPos_ "datatype" datatype + blockInd <- rule $ uncurry3 BlockInductive <$> envPos "inductive" inductive + blockSig <- rule $ (\(p, (a, s)) -> BlockSig p a s) <$> envPos_ "signature" signature + blockStruct <- rule $ uncurry3 BlockStruct <$> envPos "struct" structDefn + block <- rule $ asum [blockAxiom, blockLemma, blockDefn, blockAbbr, blockData, blockInd, blockSig, blockStruct, blockProof] + + -- Starting category. + pure block + + +proofBy :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +proofBy method = bracket $ word "proof" *> word "by" *> method + + +lemmaEnv :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (SourcePos, Marker, a) +lemmaEnv content = asum + [ envPos "theorem" content + , envPos "lemma" content + , envPos "corollary" content + , envPos "claim" content + , envPos "proposition" content + ] + + +-- | A disjunctive list with at least two items: +-- * 'a or b' +-- * 'a, b, or c' +-- * 'a, b, c, or d' +-- +orList2 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +orList2 item = ((:|) <$> item <*> many (_commaOr *> item)) + <|> ((\i j -> i:|[j]) <$> item <* _or <*> item) + + +-- | Nonempty textual lists of the form "a, b, c, and d". +-- The final comma is mandatory, 'and' is not. +-- Also allows "a and b". Should therefore be avoided in contexts where +-- a logical conjunction would also be possible. +-- Currently also allows additional 'and's after each comma... +-- +andList1 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +andList1 item = ((:|) <$> item <*> many (_commaAnd *> item)) + <|> ((\i j -> i:|[j]) <$> item <* _and <*> item) + +-- | Like 'andList1', but drops the information about nonemptiness. +andList1_ :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +andList1_ item = toList <$> andList1 item + + +commaList :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +commaList item = (:|) <$> item <*> many (_comma *> item) + +-- | Like 'commaList', but drops the information about nonemptiness. +commaList_ :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +commaList_ item = NonEmpty.toList <$> commaList item + +-- | Like 'commaList', but requires at least two items (and hence at least one comma). +commaList2 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +commaList2 item = (:|) <$> item <* _comma <*> commaList_ item + + +assumptionList :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +assumptionList item = NonEmpty.toList <$> andList1 item + +enumerated :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [a] +enumerated p = NonEmpty.toList <$> enumerated1 p + +enumerated1 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty a) +enumerated1 p = begin "enumerate" *> many1 (command "item" *> p) <* end "enumerate" <?> "\"\\begin{enumerate} ...\"" + + +enumeratedMarked :: Prod r Text (Located Token) a -> Prod r Text (Located Token) [(Marker, a)] +enumeratedMarked p = NonEmpty.toList <$> enumeratedMarked1 p + +enumeratedMarked1 :: Prod r Text (Located Token) a -> Prod r Text (Located Token) (NonEmpty (Marker, a)) +enumeratedMarked1 p = begin "enumerate" *> many1 ((,) <$> (command "item" *> label) <*> p) <* end "enumerate" <?> "\"\\begin{enumerate}\\item\\label{...}...\"" + + + + +-- This function could be rewritten, so that it can be used directly in the grammar, +-- instead of with specialized variants. +-- +phraseOf + :: (pat -> [a] -> b) + -> Lexicon + -> (Lexicon -> HashSet pat) + -> (pat -> LexicalPhrase) + -> Prod r Text (Located Token) a + -> Prod r Text (Located Token) b +phraseOf constr lexicon selector proj arg = + uncurry constr <$> asum (fmap make pats) + where + pats = HS.toList (selector lexicon) + make pat = (\args -> (pat, args)) <$> go (proj pat) + go = \case + Just w : ws -> token w *> go ws + Nothing : ws -> (:) <$> arg <*> go ws + [] -> pure [] + +adjLOf :: Lexicon -> Prod r Text (Located Token) arg -> Prod r Text (Located Token) (AdjLOf arg) +adjLOf lexicon arg = phraseOf AdjL lexicon (HM.keysSet . lexiconAdjLs) id arg <?> "a left adjective" + +adjROf :: Lexicon -> Prod r Text (Located Token) arg -> Prod r Text (Located Token) (AdjROf arg) +adjROf lexicon arg = phraseOf AdjR lexicon (HM.keysSet . lexiconAdjRs) id arg <?> "a right adjective" + +adjOf :: Lexicon -> Prod r Text (Located Token) arg -> Prod r Text (Located Token) (AdjOf arg) +adjOf lexicon arg = phraseOf Adj lexicon (HM.keysSet . lexiconAdjs) id arg <?> "an adjective" + +verbOf + :: Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) a + -> Prod r Text (Located Token) (VerbOf a) +verbOf lexicon proj arg = phraseOf Verb lexicon (HM.keysSet . lexiconVerbs) proj arg + +funOf + :: Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) a + -> Prod r Text (Located Token) (FunOf a) +funOf lexicon proj arg = phraseOf Fun lexicon (HM.keysSet . lexiconFuns) proj arg <?> "functional phrase" + + +-- | A noun with a @t VarSymbol@ as name(s). +nounOf + :: Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) arg + -> Prod r Text (Located Token) (t VarSymbol) + -> Prod r Text (Located Token) (NounOf arg, t VarSymbol) +nounOf lexicon proj arg vars = + (\(args1, xs, args2, pat) -> (Noun pat (args1 <> args2), xs)) <$> asum (fmap make pats) <?> "a noun" + where + pats = HM.keys (lexiconNouns lexicon) + make pat = + let (pat1, pat2) = splitOnVariableSlot (proj pat) + in (\args1 xs args2 -> (args1, xs, args2, pat)) <$> go pat1 <*> vars <*> go pat2 + go = \case + Just w : ws -> token w *> go ws + Nothing : ws -> (:) <$> arg <*> go ws + [] -> pure [] + +structNounOf + :: Lexicon + -> (SgPl LexicalPhrase -> LexicalPhrase) + -> Prod r Text (Located Token) arg + -> Prod r Text (Located Token) name + -> Prod r Text (Located Token) (StructPhrase, name) +structNounOf lexicon proj arg name = + (\(_args1, xs, _args2, pat) -> (pat, xs)) <$> asum (fmap make pats) <?> "a structure noun" + where + pats = HM.keys (lexiconStructNouns lexicon) + make pat = + let (pat1, pat2) = splitOnVariableSlot (proj pat) + in (\args1 xs args2 -> (args1, xs, args2, pat)) <$> go pat1 <*> name <*> go pat2 + go = \case + Just w : ws -> token w *> go ws + Nothing : ws -> (:) <$> arg <*> go ws + [] -> pure [] + + +symbolicPatternOf + :: forall r. [[(Holey (Prod r Text (Located Token) Token), Associativity)]] + -> Prod r Text (Located Token) VarSymbol + -> Grammar r (Prod r Text (Located Token) SymbolPattern) +symbolicPatternOf ops varSymbol = rule $ asum + [ go op + | ops' <- ops + , (op, _assoc) <- ops' + ] <?> "a symbolic pattern" + where + go :: Holey (Prod r Text (Located Token) Token) -> Prod r Text (Located Token) SymbolPattern + go [] = pure $ SymbolPattern [] [] + go (head : tail) = case head of + Just symb -> (\s (SymbolPattern op vs) -> SymbolPattern (Just s : op) vs) <$> symb <*> go tail + Nothing -> (\v (SymbolPattern op vs) -> SymbolPattern (Nothing : op) (v : vs)) <$> varSymbol <*> go tail + + +makeNounPhrase + :: [AdjL] + -> (Noun, t VarSymbol) + -> [AdjR] + -> Maybe Stmt + -> NounPhrase t +makeNounPhrase ls (n, vs) rs ms = NounPhrase ls n vs rs ms + + + + +begin, end :: Text -> Prod r Text (Located Token) SourcePos +begin kind = tokenPos (BeginEnv kind) <?> ("\"\\begin{" <> kind <> "}\"") +end kind = tokenPos (EndEnv kind) <?> ("\"\\end{" <> kind <> "}\"") + +-- | Surround a production rule @body@ with an environment of a certain @kind@ requiring a marker specified in a @\\label@. +-- Ignores the optional title after the beginning of the environment. +envPos :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) (SourcePos, Marker, a) +envPos kind body = do + p <- begin kind <?> ("start of a \"" <> kind <> "\" environment") + optional title + m <- label + a <- body <* end kind + pure (p, m, a) + where + title :: Prod r Text (Located Token) [Token] + title = bracket (many (unLocated <$> satisfy (\ltok -> unLocated ltok /= BracketR))) + +-- 'env_' is like 'env', but without allowing titles. +-- +envPos_ :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) (SourcePos, a) +envPos_ kind body = (,) <$> begin kind <*> (optional label *> body) <* end kind + +env_ :: Text -> Prod r Text (Located Token) a -> Prod r Text (Located Token) a +env_ kind body = begin kind *> optional label *> body <* end kind + +-- | A label specifying a marker for referencing via /@\\label{...}@/. Returns the marker text. +label :: Prod r Text (Located Token) Marker +label = label_ <?> "\"\\label{...}\"" + where + label_ = terminal \ltok -> case unLocated ltok of + Label m -> Just (Marker m) + _tok -> Nothing + +-- | A reference via /@\\ref{...}@/. Returns the markers as text. +ref :: Prod r Text (Located Token) (NonEmpty Marker) +ref = terminal \ltok -> case unLocated ltok of + Ref ms -> Just (Marker <$> ms) + _tok -> Nothing + +math :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +math body = beginMath *> body <* endMath + +text :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +text body = begin "text" *> body <* end "text" <?> "\"\\text{...}\"" + +beginMath, endMath :: Prod r Text (Located Token) SourcePos +beginMath = begin "math" <?> "start of a formula, e.g. \"$\"" +endMath = end "math" <?> "end of a formula, e.g. \"$\"" + +paren :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +paren body = token ParenL *> body <* token ParenR <?> "\"(...)\"" + +bracket :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +bracket body = token BracketL *> body <* token BracketR <?> "\"[...]\"" + +brace :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +brace body = token VisibleBraceL *> body <* token VisibleBraceR <?> "\"\\{...\\}\"" + +group :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +group body = token InvisibleBraceL *> body <* token InvisibleBraceR <?> "\"{...}\"" + +align :: Prod r Text (Located Token) a -> Prod r Text (Located Token) a +align body = begin "align*" *> body <* end "align*" + + +maybeVarToken :: Located Token -> Maybe VarSymbol +maybeVarToken ltok = case unLocated ltok of + Variable x -> Just (NamedVar x) + _tok -> Nothing + +maybeWordToken :: Located Token -> Maybe Text +maybeWordToken ltok = case unLocated ltok of + Word n -> Just n + _tok -> Nothing + +maybeIntToken :: Located Token -> Maybe Int +maybeIntToken ltok = case unLocated ltok of + Integer n -> Just n + _tok -> Nothing + +maybeCmdToken :: Located Token -> Maybe Text +maybeCmdToken ltok = case unLocated ltok of + Command n -> Just n + _tok -> Nothing + +structSymbol :: StructSymbol -> Prod r Text (Located Token) StructSymbol +structSymbol s@(StructSymbol c) = terminal \ltok -> case unLocated ltok of + Command c' | c == c' -> Just s + _ -> Nothing + +-- | Tokens that are allowed to appear in labels of environments. +maybeTagToken :: Located Token -> Maybe Text +maybeTagToken ltok = case unLocated ltok of + Symbol "'" ->Just "'" + Symbol "-" -> Just "" + _ -> maybeWordToken ltok + + +token :: Token -> Prod r Text (Located Token) Token +token tok = terminal maybeToken <?> tokToText tok + where + maybeToken ltok = case unLocated ltok of + tok' | tok == tok' -> Just tok + _ -> Nothing + +tokenPos :: Token -> Prod r Text (Located Token) SourcePos +tokenPos tok = terminal maybeToken <?> tokToText tok + where + maybeToken ltok = case unLocated ltok of + tok' | tok == tok' -> Just (startPos ltok) + _ -> Nothing diff --git a/source/Syntax/Concrete/Keywords.hs b/source/Syntax/Concrete/Keywords.hs new file mode 100644 index 0000000..e0f577e --- /dev/null +++ b/source/Syntax/Concrete/Keywords.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-| +This module defines lots of keywords and various filler +phrases. The prefix underscore indicates that we do not +care about the parse result (analogous to discarding +like @...; _ <- action; ...@ in do-notation). Moreover, +this convention allows the use of short names that would +otherwise be Haskell keywords or clash with other definitions. +Care should be taken with introducing too many variants of +a keyword, lest the grammar becomes needlessly ambiguous! + +The names are chosen using the following criteria: + + * As short as possible (e.g.: @_since@ over @_because@). + + * Sound like a keyword (e.g.: @_show@). + +This module also defines symbols that have special uses +(such as @_colon@ for its use in type signatures). +-} +module Syntax.Concrete.Keywords where + + +import Base +import Syntax.Token + +import Text.Earley (Prod, (<?>), terminal) +import Text.Megaparsec (SourcePos) + +infixr 0 ? +-- | Variant of '<?>' for annotating literal tokens. +(?) :: Prod r Text t a -> Text -> Prod r Text t a +p ? e = p <?> ("\"" <> e <> "\"") + +word :: Text -> Prod r Text (Located Token) SourcePos +word w = terminal maybeToken + where + maybeToken ltok = case unLocated ltok of + Word w' | w == w' -> Just (startPos ltok) + _ -> Nothing + +symbol :: Text -> Prod r Text (Located Token) SourcePos +symbol s = terminal maybeToken + where + maybeToken ltok = case unLocated ltok of + Symbol s' | s == s' -> Just (startPos ltok) + _ -> Nothing + +command :: Text -> Prod r Text (Located Token) SourcePos +command cmd = terminal maybeToken + where + maybeToken ltok = case unLocated ltok of + Command cmd' | cmd == cmd' -> Just (startPos ltok) + _ -> Nothing + +_arity :: Prod r Text (Located Token) Int +_arity = asum + [ 1 <$ word "unary" + , 2 <$ word "binary" + , 3 <$ word "ternary" + , 4 <$ word "quaternary" + , 5 <$ word "quinary" + , 6 <$ word "senary" + , 7 <$ word "septenary" + , 8 <$ word "octonary" + , 9 <$ word "nonary" + , 10 <$ word "denary" + ] <?> "\"unary\", \"binary\', ..." + +-- * Keywords + +_an :: Prod r Text (Located Token) SourcePos +_an = word "a" <|> word "an" <?> "indefinite article" +_and :: Prod r Text (Located Token) SourcePos +_and = word "and" ? "and" +_are :: Prod r Text (Located Token) SourcePos +_are = word "are" ? "are" +_asFollows :: Prod r Text (Located Token) SourcePos +_asFollows = word "as" <* word "follows" ? "as follows" +_assumption :: Prod r Text (Located Token) SourcePos +_assumption = word "assumption" ? "assumption" +_be :: Prod r Text (Located Token) SourcePos +_be = word "be" ? "be" +_by :: Prod r Text (Located Token) SourcePos +_by = word "by" ? "by" +_bySetExt :: Prod r Text (Located Token) SourcePos +_bySetExt = word "by" <* ((word "set" ? "set") <* word "extensionality") ? "by set extensionality" +_can :: Prod r Text (Located Token) SourcePos +_can = word "can" ? "can" +_consistsOf :: Prod r Text (Located Token) SourcePos +_consistsOf = word "consists" <* word "of" ? "consists of" +_contradiction :: Prod r Text (Located Token) SourcePos +_contradiction = optional (word "a") *> word "contradiction" ? "a contradiction" +_define :: Prod r Text (Located Token) SourcePos +_define = word "define" ? "define" +_definition :: Prod r Text (Located Token) SourcePos +_definition = word "definition" ? "definition" +_denote :: Prod r Text (Located Token) SourcePos +_denote = word "denote" <|> (word "stand" <* word "for") ? "denote" +_denotes :: Prod r Text (Located Token) SourcePos +_denotes = word "denotes" ? "denotes" +_do :: Prod r Text (Located Token) SourcePos +_do = word "do" ? "do" +_does :: Prod r Text (Located Token) SourcePos +_does = word "does" ? "does" +_either :: Prod r Text (Located Token) SourcePos +_either = word "either" ? "either" +_equipped :: Prod r Text (Located Token) SourcePos +_equipped = (word "equipped" <|> word "together") <* word "with" ? "equipped with" +_every :: Prod r Text (Located Token) SourcePos +_every = (word "every") ? "every" +_exist :: Prod r Text (Located Token) SourcePos +_exist = word "there" <* word "exist" ? "there exist" +_exists :: Prod r Text (Located Token) SourcePos +_exists = word "there" <* word "exists" ? "there exists" +_extends :: Prod r Text (Located Token) SourcePos +_extends = (_is) <|> (word "consists" <* word "of") ? "consists of" +_fix :: Prod r Text (Located Token) SourcePos +_fix = word "fix" ? "fix" +_follows :: Prod r Text (Located Token) SourcePos +_follows = word "follows" ? "follows" +_for :: Prod r Text (Located Token) SourcePos +_for = word "for" ? "for" +_forAll :: Prod r Text (Located Token) SourcePos +_forAll = (word "for" <* word "all") <|> word "all" ? "all" +_forEvery :: Prod r Text (Located Token) SourcePos +_forEvery = (word "for" <* word "every") <|> (word "every") ? "for every" +_have :: Prod r Text (Located Token) SourcePos +_have = word "we" <* word "have" <* optional (word "that") ? "we have" +_if :: Prod r Text (Located Token) SourcePos +_if = word "if" ? "if" +_iff :: Prod r Text (Located Token) SourcePos +_iff = word "iff" <|> (word "if" <* word "and" <* word "only" <* word "if") ? "iff" +_inductively :: Prod r Text (Located Token) SourcePos +_inductively = word "inductively" ? "inductively" +_is :: Prod r Text (Located Token) SourcePos +_is = word "is" ? "is" +_itIsWrong :: Prod r Text (Located Token) SourcePos +_itIsWrong = word "it" <* word "is" <* (word "not" <* word "the" <* word "case" <|> word "wrong") <* word "that" ? "it is wrong that" +_let :: Prod r Text (Located Token) SourcePos +_let = word "let" ? "let" +_neither :: Prod r Text (Located Token) SourcePos +_neither = word "neither" ? "neither" +_no :: Prod r Text (Located Token) SourcePos +_no = word "no" ? "no" +_nor :: Prod r Text (Located Token) SourcePos +_nor = word "nor" ? "nor" +_not :: Prod r Text (Located Token) SourcePos +_not = word "not" ? "not" +_omitted :: Prod r Text (Located Token) SourcePos +_omitted = word "omitted" ? "omitted" +_on :: Prod r Text (Located Token) SourcePos +_on = word "on" ? "on" +_oneOf :: Prod r Text (Located Token) SourcePos +_oneOf = word "one" <* word "of" ? "one of" +_or :: Prod r Text (Located Token) SourcePos +_or = word "or" ? "or" +_particularly :: Prod r Text (Located Token) SourcePos +_particularly = (word "particularly" <|> (word "in" *> word "particular")) <* _comma ? "particularly" +_relation :: Prod r Text (Located Token) SourcePos +_relation = word "relation" ? "relation" +_satisfying :: Prod r Text (Located Token) SourcePos +_satisfying = _suchThat <|> word "satisfying" ? "satisfying" +_setOf :: Prod r Text (Located Token) SourcePos +_setOf = word "set" <* word "of" ? "set of" +_show :: Prod r Text (Located Token) SourcePos +_show = optional (word "first" <|> word "finally" <|> word "next" <|> word "now") *> optional (word "we") *> word "show" <* optional (word "that") +_since :: Prod r Text (Located Token) SourcePos +_since = word "since" <|> word "because" ? "since" +_some :: Prod r Text (Located Token) SourcePos +_some = word "some" ? "some" +_suchThat :: Prod r Text (Located Token) SourcePos +_suchThat = ((word "such" <* word "that") <|> (word "s" <* _dot <* word "t" <* _dot)) ? "such that" +_sufficesThat :: Prod r Text (Located Token) SourcePos +_sufficesThat = word "it" <* word "suffices" <* word "to" <* word "show" <* word "that" ? "it suffices to show" +_suppose :: Prod r Text (Located Token) SourcePos +_suppose = (word "suppose" <|> word "assume") <* optional (word "that") ? "assume" +_take :: Prod r Text (Located Token) SourcePos +_take = word "take" <|> word "consider" ? "take" +_that :: Prod r Text (Located Token) SourcePos +_that = word "that" ? "that" +_the :: Prod r Text (Located Token) SourcePos +_the = word "the" ? "the" +_then :: Prod r Text (Located Token) SourcePos +_then = word "then" ? "then" +_throughout :: Prod r Text (Located Token) SourcePos +_throughout = word "throughout" <* optional (word "this" <* word "section") <* optional _comma <|> (word "in" <* word "the" <* word "sequel") ? "throughout" +_thus :: Prod r Text (Located Token) SourcePos +_thus = word "thus" <|> word "then" <|> word "hence" <|> word "now" <|> word "finally" <|> word "therefore" ? "thus" +_trivial :: Prod r Text (Located Token) SourcePos +_trivial = word "straightforward" <|> word "trivial" ? "trivial" +_unique :: Prod r Text (Located Token) SourcePos +_unique = word "unique" ? "unique" +_write :: Prod r Text (Located Token) SourcePos +_write = (optional (word "we") *> word "say" <* optional (word "that")) <|> (optional (word "we") *> word "write") ? "write" + +-- | Introducing plain claims in proofs. +_haveIntro :: Prod r Text (Located Token) SourcePos +_haveIntro = _thus <|> _particularly <|> _have + +-- * Symbols + +_colon :: Prod r Text (Located Token) SourcePos +_colon = symbol ":" ? ":" +_pipe :: Prod r Text (Located Token) SourcePos +_pipe = symbol "|" <|> command "mid" ? "\\mid" +_comma :: Prod r Text (Located Token) SourcePos +_comma = symbol "," ? "," +_commaAnd :: Prod r Text (Located Token) SourcePos +_commaAnd = symbol "," <* optional (word "and") ? ", and" +_commaOr :: Prod r Text (Located Token) SourcePos +_commaOr = symbol "," <* optional (word "or") ? ", or" +_defeq :: Prod r Text (Located Token) SourcePos +_defeq = symbol ":=" ? ":=" -- Should use `\coloneq` from unicode-math as display. +_dot :: Prod r Text (Located Token) SourcePos +_dot = symbol "." ? "." +_eq :: Prod r Text (Located Token) SourcePos +_eq = symbol "=" ? "=" +_in :: Prod r Text (Located Token) SourcePos +_in = symbol "∈" <|> command "in" ? "\\in" +_subseteq :: Prod r Text (Located Token) SourcePos +_subseteq = command "subseteq" ? ":" diff --git a/source/Syntax/Import.hs b/source/Syntax/Import.hs new file mode 100644 index 0000000..33082f1 --- /dev/null +++ b/source/Syntax/Import.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ApplicativeDo #-} + + +module Syntax.Import where + + +import Base + +import Text.Regex.Applicative.Text +import Data.CharSet qualified as CharSet +import Data.Char (isAlphaNum) + +gatherImports :: Text -> [FilePath] +gatherImports s = case findFirstPrefix imps s of + Nothing -> [] + Just (paths, _) -> paths + + +imps :: RE Char [FilePath] +imps = do + mpath <- optional imp + paths <- many (few anySym *> string "\n" *> imp) + few anySym + begin + pure case mpath of + Nothing -> paths + Just path -> path : paths + + +imp :: RE Char FilePath +imp = do + -- Requiring a newline makes it possible to comment imports out. + string "\\import{" + path <- few (psym isTheoryNameChar) + sym '}' + pure path + +isTheoryNameChar :: Char -> Bool +isTheoryNameChar c = isAlphaNum c || c `CharSet.member` CharSet.fromList ".-_/" + +begin :: RE Char Text +begin = string "\\begin{" diff --git a/source/Syntax/Internal.hs b/source/Syntax/Internal.hs new file mode 100644 index 0000000..44603ad --- /dev/null +++ b/source/Syntax/Internal.hs @@ -0,0 +1,612 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Data types for the internal (semantic) syntax tree. +module Syntax.Internal + ( module Syntax.Internal + , module Syntax.Abstract + , module Syntax.LexicalPhrase + , module Syntax.Token + ) where + + +import Base +import Syntax.Lexicon (pattern PairSymbol, pattern ConsSymbol) +import Syntax.LexicalPhrase (LexicalPhrase, SgPl(..), unsafeReadPhrase, unsafeReadPhraseSgPl) +import Syntax.Token (Token(..)) + +import Syntax.Abstract + ( Chain(..) + , Connective(..) + , VarSymbol(..) + , FunctionSymbol + , RelationSymbol + , StructSymbol (..) + , Relation + , VarSymbol(..) + , PropositionalConstant(..) + , StructPhrase + , Justification(..) + , Marker(..) + , pattern CarrierSymbol, pattern ConsSymbol + ) + +import Bound +import Bound.Scope +import Data.Deriving (deriveShow1, deriveEq1, deriveOrd1) +import Data.Hashable.Lifted +import Data.HashMap.Strict qualified as HM +import Data.Maybe +import Data.Set qualified as Set +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Text.Megaparsec.Pos (SourcePos) + +-- | 'Symbol's can be used as function and relation symbols. +data Symbol + = SymbolMixfix FunctionSymbol + | SymbolFun (SgPl LexicalPhrase) + | SymbolInteger Int + | SymbolPredicate Predicate + deriving (Show, Eq, Ord, Generic, Hashable) + + +data Predicate + = PredicateAdj LexicalPhrase + | PredicateVerb (SgPl LexicalPhrase) + | PredicateNoun (SgPl LexicalPhrase) -- ^ /@\<...\> is a \<...\>@/. + | PredicateRelation RelationSymbol + | PredicateSymbol Text + | PredicateNounStruct (SgPl LexicalPhrase) -- ^ /@\<...\> is a \<...\>@/. + deriving (Show, Eq, Ord, Generic, Hashable) + + +data Quantifier + = Universally + | Existentially + deriving (Show, Eq, Ord, Generic, Hashable) + +type Formula = Term +type Term = Expr +type Expr = ExprOf VarSymbol + + +-- | Internal higher-order expressions. +data ExprOf a + = TermVar a + -- ^ Fresh constants disjoint from all user-named identifiers. + -- These can be used to eliminate higher-order constructs. + -- + | TermSymbol Symbol [ExprOf a] + -- ^ Application of a symbol (including function and predicate symbols). + | TermSymbolStruct StructSymbol (Maybe (ExprOf a)) + -- + | Apply (ExprOf a) (NonEmpty (ExprOf a)) + -- ^ Higher-order application. + -- + | TermSep VarSymbol (ExprOf a) (Scope () ExprOf a) + -- ^ Set comprehension using seperation, e.g.: /@{ x ∈ X | P(x) }@/. + -- + | Iota VarSymbol (Scope () ExprOf a) + -- ^ Definite descriptor. + -- + | ReplacePred VarSymbol VarSymbol (ExprOf a) (Scope ReplacementVar ExprOf a) + -- ^ Replacement for single-valued predicates. The concrete syntax for these + -- syntactically requires a bounded existential quantifier in the condition: + -- + -- /@$\\{ y | \\exists x\\in A. P(x,y) \\}$@/ + -- + -- In definitions the single-valuedness of @P@ becomes a proof obligation. + -- In other cases we could instead add it as constraint + -- + -- /@$b\\in \\{ y | \\exists x\\in A. P(x,y) \\}$@/ + -- /@iff@/ + -- /@$\\exists x\\in A. P(x,y)$ and $P$ is single valued@/ + -- + -- + | ReplaceFun (NonEmpty (VarSymbol, ExprOf a)) (Scope VarSymbol ExprOf a) (Scope VarSymbol ExprOf a) + -- ^ Set comprehension using functional replacement, + -- e.g.: /@{ f(x, y) | x ∈ X; y ∈ Y; P(x, y) }@/. + -- The list of pairs gives the domains, the integers in the scope point to list indices. + -- The first scope is the lhs, the optional scope can be used for additional constraints + -- on the variables (i.e. implicit separation over the product of the domains). + -- An out-of-bound index is an error, since otherwise replacement becomes unsound. + -- + | Connected Connective (ExprOf a) (ExprOf a) + | Lambda (Scope VarSymbol ExprOf a) + | Quantified Quantifier (Scope VarSymbol ExprOf a) + | PropositionalConstant PropositionalConstant + | Not (ExprOf a) + deriving (Functor, Foldable, Traversable) + +data ReplacementVar = ReplacementDomVar | ReplacementRangeVar deriving (Show, Eq, Ord, Generic, Hashable) + +makeBound ''ExprOf + +deriveShow1 ''ExprOf +deriveEq1 ''ExprOf +deriveOrd1 ''ExprOf + +deriving instance Show a => Show (ExprOf a) +deriving instance Eq a => Eq (ExprOf a) +deriving instance Ord a => Ord (ExprOf a) + +deriving instance Generic (ExprOf a) +deriving instance Generic1 ExprOf + +deriving instance Hashable1 ExprOf + +deriving instance Hashable a => Hashable (ExprOf a) + + +abstractVarSymbol :: VarSymbol -> ExprOf VarSymbol -> Scope VarSymbol ExprOf VarSymbol +abstractVarSymbol x = abstract (\y -> if x == y then Just x else Nothing) + +abstractVarSymbols :: Foldable t => t VarSymbol -> ExprOf VarSymbol -> Scope VarSymbol ExprOf VarSymbol +abstractVarSymbols xs = abstract (\y -> if y `elem` xs then Just y else Nothing) + +-- | Use the given set of in scope structures to cast them to their carriers +-- when occurring on the rhs of the element relation. +-- Use the given 'Map' to annotate (unannotated) structure operations +-- with the most recent inscope appropriate label. +annotateWith :: Set VarSymbol -> HashMap StructSymbol VarSymbol -> Formula -> Formula +annotateWith = go + where + go :: (Ord a) => Set a -> HashMap StructSymbol a -> ExprOf a -> ExprOf a + go labels ops = \case + TermSymbolStruct symb Nothing -> + TermSymbolStruct symb (TermVar <$> HM.lookup symb ops) + e@TermSymbolStruct{} -> + e + a `IsElementOf` TermVar x | x `Set.member` labels -> + go labels ops a `IsElementOf` TermSymbolStruct CarrierSymbol (Just (TermVar x)) + Not a -> + Not (go labels ops a) + Connected conn a b -> + Connected conn (go labels ops a) (go labels ops b) + Quantified quant body -> + Quantified quant (toScope (go (Set.map F labels) (F <$> ops) (fromScope body))) + e@TermVar{} -> e + TermSymbol symb args -> + TermSymbol symb (go labels ops <$> args) + Apply e1 args -> + Apply (go labels ops e1) (go labels ops <$> args) + TermSep vs e scope -> + TermSep vs (go labels ops e) (toScope (go (Set.map F labels) (F <$> ops) (fromScope scope))) + Iota x body -> + Iota x (toScope (go (Set.map F labels) (F <$> ops) (fromScope body))) + ReplacePred y x xB scope -> + ReplacePred y x (go labels ops xB) (toScope (go (Set.map F labels) (F <$> ops) (fromScope scope))) + ReplaceFun bounds ap cond -> + ReplaceFun + (fmap (\(x, e) -> (x, go labels ops e)) bounds) + (toScope (go (Set.map F labels) (F <$> ops) (fromScope ap))) + (toScope (go (Set.map F labels) (F <$> ops) (fromScope cond))) + Lambda body -> + Lambda (toScope (go (Set.map F labels) (F <$> ops) (fromScope body))) + e@PropositionalConstant{} -> e + +containsHigherOrderConstructs :: ExprOf a -> Bool +containsHigherOrderConstructs = \case + TermSep {} -> True + Iota{} -> True + ReplacePred{}-> True + ReplaceFun{}-> True + Lambda{} -> True + Apply{} -> False -- FIXME: this is a lie in general; we need to add sortchecking to determine this. + TermVar{} -> False + PropositionalConstant{} -> False + TermSymbol _ es -> any containsHigherOrderConstructs es + Not e -> containsHigherOrderConstructs e + Connected _ e1 e2 -> containsHigherOrderConstructs e1 || containsHigherOrderConstructs e2 + Quantified _ scope -> containsHigherOrderConstructs (fromScope scope) + TermSymbolStruct _ _ -> False + +pattern TermOp :: FunctionSymbol -> [ExprOf a] -> ExprOf a +pattern TermOp op es = TermSymbol (SymbolMixfix op) es + +pattern TermConst :: Token -> ExprOf a +pattern TermConst c = TermOp [Just c] [] + +pattern TermPair :: ExprOf a -> ExprOf a -> ExprOf a +pattern TermPair e1 e2 = TermOp PairSymbol [e1, e2] + +pattern Atomic :: Predicate -> [ExprOf a] -> ExprOf a +pattern Atomic symbol args = TermSymbol (SymbolPredicate symbol) args + + +pattern FormulaAdj :: ExprOf a -> LexicalPhrase -> [ExprOf a] -> ExprOf a +pattern FormulaAdj e adj es = Atomic (PredicateAdj adj) (e:es) + +pattern FormulaVerb :: ExprOf a -> SgPl LexicalPhrase -> [ExprOf a] -> ExprOf a +pattern FormulaVerb e verb es = Atomic (PredicateVerb verb) (e:es) + +pattern FormulaNoun :: ExprOf a -> SgPl LexicalPhrase -> [ExprOf a] -> ExprOf a +pattern FormulaNoun e noun es = Atomic (PredicateNoun noun) (e:es) + +relationNoun :: Expr -> Formula +relationNoun arg = FormulaNoun arg (unsafeReadPhraseSgPl "relation[/s]") [] + +rightUniqueAdj :: Expr -> Formula +rightUniqueAdj arg = FormulaAdj arg (unsafeReadPhrase "right-unique") [] + +-- | Untyped quantification. +pattern Forall, Exists :: Scope VarSymbol ExprOf a -> ExprOf a +pattern Forall scope = Quantified Universally scope +pattern Exists scope = Quantified Existentially scope + +makeForall, makeExists :: Foldable t => t VarSymbol -> Formula -> Formula +makeForall xs e = Quantified Universally (abstractVarSymbols xs e) +makeExists xs e = Quantified Existentially (abstractVarSymbols xs e) + +instantiateSome :: NonEmpty VarSymbol -> Scope VarSymbol ExprOf VarSymbol -> Scope VarSymbol ExprOf VarSymbol +instantiateSome xs scope = toScope (instantiateEither inst scope) + where + inst (Left x) | x `elem` xs = TermVar (F x) + inst (Left b) = TermVar (B b) + inst (Right fv) = TermVar (F fv) + +-- | Bind all free variables not occuring in the given set universally +forallClosure :: Set VarSymbol -> Formula -> Formula +forallClosure xs phi = if isClosed phi + then phi + else Quantified Universally (abstract isNamedVar phi) + where + isNamedVar :: VarSymbol -> Maybe VarSymbol + isNamedVar x = if x `Set.member` xs then Nothing else Just x + +freeVars :: ExprOf VarSymbol -> Set VarSymbol +freeVars = Set.fromList . toList + +pattern And :: ExprOf a -> ExprOf a -> ExprOf a +pattern And e1 e2 = Connected Conjunction e1 e2 + +pattern Or :: ExprOf a -> ExprOf a -> ExprOf a +pattern Or e1 e2 = Connected Disjunction e1 e2 + +pattern Implies :: ExprOf a -> ExprOf a -> ExprOf a +pattern Implies e1 e2 = Connected Implication e1 e2 + +pattern Iff :: ExprOf a -> ExprOf a -> ExprOf a +pattern Iff e1 e2 = Connected Equivalence e1 e2 + +pattern Xor :: ExprOf a -> ExprOf a -> ExprOf a +pattern Xor e1 e2 = Connected ExclusiveOr e1 e2 + + +pattern Bottom :: ExprOf a +pattern Bottom = PropositionalConstant IsBottom + +pattern Top :: ExprOf a +pattern Top = PropositionalConstant IsTop + + +pattern Relation :: RelationSymbol -> [ExprOf a] -> ExprOf a +pattern Relation rel es = Atomic (PredicateRelation rel) es + +-- | Membership. +pattern IsElementOf :: ExprOf a -> ExprOf a -> ExprOf a +pattern IsElementOf e1 e2 = Atomic (PredicateRelation (Command "in")) (e1 : [e2]) + +-- | Membership. +pattern IsNotElementOf :: ExprOf a -> ExprOf a -> ExprOf a +pattern IsNotElementOf e1 e2 = Not (IsElementOf e1 e2) + +-- | Subset relation (non-strict). +pattern IsSubsetOf :: ExprOf a -> ExprOf a -> ExprOf a +pattern IsSubsetOf e1 e2 = Atomic (PredicateRelation (Command "subseteq")) (e1 : [e2]) + +-- | Ordinal predicate. +pattern IsOrd :: ExprOf a -> ExprOf a +pattern IsOrd e1 = Atomic (PredicateNoun (SgPl [Just "ordinal"] [Just "ordinals"])) [e1] + +-- | Equality. +pattern Equals :: ExprOf a -> ExprOf a -> ExprOf a +pattern Equals e1 e2 = Atomic (PredicateRelation (Symbol "=")) (e1 : [e2]) + +-- | Disequality. +pattern NotEquals :: ExprOf a -> ExprOf a -> ExprOf a +pattern NotEquals e1 e2 = Atomic (PredicateRelation (Command "neq")) (e1 : [e2]) + +pattern EmptySet :: ExprOf a +pattern EmptySet = TermSymbol (SymbolMixfix [Just (Command "emptyset")]) [] + +makeConjunction :: [ExprOf a] -> ExprOf a +makeConjunction = \case + [] -> Top + es -> List.foldl1' And es + +makeDisjunction :: [ExprOf a] -> ExprOf a +makeDisjunction = \case + [] -> Bottom + es -> List.foldl1' Or es + +finiteSet :: NonEmpty (ExprOf a) -> ExprOf a +finiteSet = foldr cons EmptySet + where + cons x y = TermSymbol (SymbolMixfix ConsSymbol) [x, y] + +isPositive :: ExprOf a -> Bool +isPositive = \case + Not _ -> False + _ -> True + +dual :: ExprOf a -> ExprOf a +dual = \case + Not f -> f + f -> Not f + + + +-- | Local assumptions. +data Asm + = Asm Formula + | AsmStruct VarSymbol StructPhrase + + +deriving instance Show Asm +deriving instance Eq Asm +deriving instance Ord Asm + +data StructAsm + = StructAsm VarSymbol StructPhrase + + + +data Axiom = Axiom [Asm] Formula + +deriving instance Show Axiom +deriving instance Eq Axiom +deriving instance Ord Axiom + + +data Lemma = Lemma [Asm] Formula + +deriving instance Show Lemma +deriving instance Eq Lemma +deriving instance Ord Lemma + + +data Defn + = DefnPredicate [Asm] Predicate (NonEmpty VarSymbol) Formula + | DefnFun [Asm] (SgPl LexicalPhrase) [VarSymbol] Term + | DefnOp FunctionSymbol [VarSymbol] Term + +deriving instance Show Defn +deriving instance Eq Defn +deriving instance Ord Defn + +data Inductive = Inductive + { inductiveSymbol :: FunctionSymbol + , inductiveParams :: [VarSymbol] + , inductiveDomain :: Expr + , inductiveIntros :: NonEmpty IntroRule + } + deriving (Show, Eq, Ord) + +data IntroRule = IntroRule + { introConditions :: [Formula] -- The inductively defined set may only appear as an argument of monotone operations on the rhs. + , introResult :: Formula -- TODO Refine. + } + deriving (Show, Eq, Ord) + + +data Proof + = Omitted + -- ^ Ends a proof without further verification. + -- This results in a “gap” in the formalization. + | Qed Justification + -- ^ Ends of a proof, leaving automation to discharge the current goal using the given justification. + | ByContradiction Proof + -- ^ Take the dual of the current goal as an assumption and + -- set the goal to absurdity. + | BySetInduction (Maybe Term) Proof + -- ^ ∈-induction. + | ByOrdInduction Proof + -- ^ Transfinite induction for ordinals. + | Assume Formula Proof + -- ^ Simplify goals that are implications or disjunctions. + | Fix (NonEmpty VarSymbol) Formula Proof + -- ^ Simplify universal goals (with an optional bound or such that statement) + | Take (NonEmpty VarSymbol) Formula Justification Proof + -- ^ Use existential assumptions. + | Suffices Formula Justification Proof + | ByCase [Case] + -- ^ Proof by case. Disjunction of the case hypotheses 'Case' + -- must hold for this step to succeed. Each case starts a subproof, + -- keeping the same goal but adding the case hypothesis as an assumption. + -- Often this will be a classical split between /@P@/ and /@not P@/, in + -- which case the proof that /@P or not P@/ holds is easy. + -- + | Have Formula Justification Proof + -- ^ An affirmation, e.g.: /@We have \<stmt\> by \<ref\>@/. + -- + | Calc Calc Proof + | Subclaim Formula Proof Proof + -- ^ A claim is a sublemma with its own proof: + -- + -- /@Show \<goal stmt\>. \<steps\>. \<continue other proof\>.@/ + -- + -- A successful first proof adds the claimed formula as an assumption + -- for the remaining proof. + -- + | Define VarSymbol Term Proof + | DefineFunction VarSymbol VarSymbol Term Term Proof + +deriving instance Show Proof +deriving instance Eq Proof +deriving instance Ord Proof + + + +-- | A case of a case split. +data Case = Case + { caseOf :: Formula + , caseProof :: Proof + } + +deriving instance Show Case +deriving instance Eq Case +deriving instance Ord Case + +-- | See 'Syntax.Abstract.Calc'. +data Calc + = Equation Term (NonEmpty (Term, Justification)) + | Biconditionals Term (NonEmpty (Term, Justification)) + +deriving instance Show Calc +deriving instance Eq Calc +deriving instance Ord Calc + +calcResult :: Calc -> ExprOf VarSymbol +calcResult = \case + Equation e eqns -> e `Equals` fst (NonEmpty.last eqns) + Biconditionals phi phis -> phi `Iff` fst (NonEmpty.last phis) + +calculation :: Calc -> [(ExprOf VarSymbol, Justification)] +calculation = \case + Equation e1 eqns@((e2, jst) :| _) -> (e1 `Equals` e2, jst) : collectEquations (toList eqns) + Biconditionals p1 ps@((p2, jst) :| _) -> (p1 `Iff` p2, jst) : collectBiconditionals (toList ps) + + +collectEquations :: [(ExprOf a, b)] -> [(ExprOf a, b)] +collectEquations = \case + (e1, _) : eqns'@((e2, jst) : _) -> (e1 `Equals` e2, jst) : collectEquations eqns' + _ -> [] + +collectBiconditionals :: [(ExprOf a, b)] -> [(ExprOf a, b)] +collectBiconditionals = \case + (p1, _) : ps@((p2, jst) : _) -> (p1 `Iff` p2, jst) : collectEquations ps + _ -> [] + + +newtype Datatype + = DatatypeFin (NonEmpty Text) + deriving (Show, Eq, Ord) + + +data Signature + = SignaturePredicate Predicate (NonEmpty VarSymbol) + | SignatureFormula Formula -- TODO: Reconsider, this is pretty lossy. + +deriving instance Show Signature +deriving instance Eq Signature +deriving instance Ord Signature + +data StructDefn = StructDefn + { structPhrase :: StructPhrase + -- ^ The noun phrase naming the structure, e.g.: @partial order@ or @abelian group@. + , structParents :: Set StructPhrase + , structDefnLabel :: VarSymbol + , structDefnFixes :: Set StructSymbol + -- ^ List of commands representing operations, + -- e.g.: @\\contained@ or @\\inv@. These are used as default operation names + -- in instantiations such as @Let $G$ be a group@. + -- The commands should be set up to handle an optional struct label + -- which would typically be rendered as a sub- or superscript, e.g.: + -- @\\contained[A]@ could render as ”⊑ᴬ“. + -- -- + , structDefnAssumes :: [(Marker, Formula)] + -- ^ The assumption or axioms of the structure. + -- To be instantiate with the @structFixes@ of a given structure. + } + +deriving instance Show StructDefn +deriving instance Eq StructDefn +deriving instance Ord StructDefn + + +data Abbreviation + = Abbreviation Symbol (Scope Int ExprOf Void) + deriving (Show, Eq, Ord) + +data Block + = BlockAxiom SourcePos Marker Axiom + | BlockLemma SourcePos Marker Lemma + | BlockProof SourcePos Proof + | BlockDefn SourcePos Marker Defn + | BlockAbbr SourcePos Marker Abbreviation + | BlockStruct SourcePos Marker StructDefn + | BlockInductive SourcePos Marker Inductive + | BlockSig SourcePos [Asm] Signature + deriving (Show, Eq, Ord) + + +data Task = Task + { taskDirectness :: Directness + , taskHypotheses :: [(Marker, Formula)] -- ^ No guarantees on order. + , taskConjectureLabel :: Marker + , taskConjecture :: Formula + } deriving (Show, Eq, Generic, Hashable) + + +-- | Indicates whether a given proof is direct or indirect. +-- An indirect proof (i.e. a proof by contradiction) may +-- cause an ATP to emit a warning about contradictory axioms. +-- When we know that the proof is indirect, we want to ignore +-- this warning. For relevance filtering we also want to know +-- what our actual goal is, so we keep the original conjecture. +data Directness + = Indirect Formula -- ^ The former conjecture. + | Direct + deriving (Show, Eq, Generic, Hashable) + +isIndirect :: Task -> Bool +isIndirect task = case taskDirectness task of + Indirect _ -> True + Direct -> False + + +-- | Boolean contraction of a task. +contractionTask :: Task -> Task +contractionTask task = task + { taskHypotheses = mapMaybe contract (taskHypotheses task) + , taskConjecture = contraction (taskConjecture task) + } + +contract :: (Marker, Formula) -> Maybe (Marker, Formula) +contract (m, phi) = case contraction phi of + Top -> Nothing + phi' -> Just (m, phi') + + + +-- | Full boolean contraction. +contraction :: ExprOf a -> ExprOf a +contraction = \case + Connected conn f1 f2 -> atomicContraction (Connected conn (contraction f1) (contraction f2)) + Quantified quant scope -> atomicContraction (Quantified quant (hoistScope contraction scope)) + Not f -> Not (contraction f) + f -> f + + +-- | Atomic boolean contraction. +atomicContraction :: ExprOf a -> ExprOf a +atomicContraction = \case + Top `Iff` f -> f + Bottom `Iff` f -> Not f + f `Iff` Top -> f + f `Iff` Bottom -> Not f + + Top `Implies` f -> f + Bottom `Implies` _ -> Top + _ `Implies` Top -> Top + f `Implies` Bottom -> Not f + + Top `And` f -> f + Bottom `And` _ -> Bottom + f `And` Top -> f + _ `And` Bottom -> Bottom + + phi@(Quantified _quant scope) -> case unscope scope of + Top -> Top + Bottom -> Bottom + _ -> phi + + Not Top -> Bottom + Not Bottom -> Top + + f -> f diff --git a/source/Syntax/LexicalPhrase.hs b/source/Syntax/LexicalPhrase.hs new file mode 100644 index 0000000..1743255 --- /dev/null +++ b/source/Syntax/LexicalPhrase.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Syntax.LexicalPhrase where + + +import Base +import Syntax.Token (Token(..)) + +import Data.Char (isAlpha) +import Data.Text qualified as Text +import Text.Earley.Mixfix (Holey) +import Text.Earley (Grammar, Prod, (<?>), fullParses, parser, rule, token, satisfy) + + + +-- | 'LexicalPhrase's should be nonempty lists with at least one proper word token. +-- Hyphens and quotes in words are treated as letters. +-- Thus /@manifold-with-boundary@/ is a singleton lexical phrase (one word). +-- +type LexicalPhrase = Holey Token + +-- MAYBE Add this instance by making LexicalPhrase a proper Type? +-- Until then we can use the default instance for lists of prettyprintable things. +-- +-- instance Pretty LexicalPhrase where +-- pretty components = hsep (prettyComponent <$> components) +-- where +-- prettyComponent = \case +-- Nothing -> "_" +-- Just tok -> pretty tok + + + +-- | Split data by grammatical number (singular/plural). +-- The 'Eq' and 'Ord' instances only consider the singular +-- form so that we can prefer known irregular plurals over +-- guessed irregular plurals when inserting items into +-- the 'Lexicon'. +data SgPl a + = SgPl {sg :: a, pl :: a} + deriving (Show, Functor, Generic, Hashable) + +instance Eq a => Eq (SgPl a) where (==) = (==) `on` sg +instance Ord a => Ord (SgPl a) where compare = compare `on` sg + + +unsafeReadPhrase :: String -> LexicalPhrase +unsafeReadPhrase spec = case fst (fullParses (parser lexicalPhraseSpec) spec) of + pat : _ -> pat + _ -> error "unsafeReadPhrase failed" + +unsafeReadPhraseSgPl :: String -> SgPl LexicalPhrase +unsafeReadPhraseSgPl spec = case fst (fullParses (parser lexicalPhraseSpecSgPl) spec) of + pat : _ -> pat + _ -> error "unsafeReadPhraseSgPl failed" + + +lexicalPhraseSpec :: Grammar r (Prod r String Char LexicalPhrase) +lexicalPhraseSpec = do + hole <- rule $ Nothing <$ token '?' <?> "hole" + word <- rule $ Just <$> many (satisfy (\c -> isAlpha c || c == '-')) + space <- rule $ Just . (:[]) <$> token ' ' + segment <- rule $ hole <|> word + rule $ (\s ss -> makePhrase (s:ss)) <$> segment <*> many (space *> segment) + where + makePhrase :: [Maybe String] -> LexicalPhrase + makePhrase pat = fmap makeWord pat + + +lexicalPhraseSpecSgPl :: Grammar r (Prod r String Char (SgPl LexicalPhrase)) +lexicalPhraseSpecSgPl = do + space <- rule $ Just . (:[]) <$> token ' ' + hole <- rule $ (Nothing, Nothing) <$ token '?'<?> "hole" + + word <- rule (many (satisfy isAlpha) <?> "word") + wordSgPl <- rule $ (,) <$> (token '[' *> word) <* token '/' <*> word <* token ']' + complexWord <- rule $ (\(a,b) -> (Just a, Just b)) . fuse <$> + many ((<>) <$> (dup <$> word) <*> wordSgPl) <?> "word" + segment <- rule (hole <|> (dup . Just <$> word) <|> complexWord ) + rule $ (\s ss -> makePhrase (s:ss)) <$> segment <*> many (space *> segment) + where + dup x = (x,x) + fuse = \case + (a, b) : (c, d) : rest -> fuse ((a <> c, b <> d) : rest) + [(a, b)] -> (a, b) + _ -> error "Syntax.Abstract.fuse" + + makePhrase :: [(Maybe String, Maybe String)] -> SgPl LexicalPhrase + makePhrase = (\(patSg, patPl) -> SgPl (fmap makeWord patSg) (fmap makeWord patPl)) . unzip + +makeWord :: Maybe String -> Maybe Token +makeWord = fmap (Word . Text.pack) diff --git a/source/Syntax/Lexicon.hs b/source/Syntax/Lexicon.hs new file mode 100644 index 0000000..805b875 --- /dev/null +++ b/source/Syntax/Lexicon.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | The 'Lexicon' describes the part of the grammar that extensible/dynamic. +-- +-- The items of the 'Lexicon' are organized by their meaning and their +-- syntactic behaviour. They are typically represented as some kind of +-- pattern data which is then used to generate various production rules +-- for the concrete grammar. This representation makes inspection and +-- extension easier. +-- + +module Syntax.Lexicon + ( module Syntax.Lexicon + , pattern ConsSymbol + , pattern PairSymbol + , pattern CarrierSymbol + , pattern ApplySymbol + , pattern DomSymbol + ) where + + +import Base +import Syntax.Abstract + +import Data.List qualified as List +import Data.Sequence qualified as Seq +import Data.HashSet qualified as Set +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as Text +import Text.Earley.Mixfix (Holey, Associativity(..)) + + +data Lexicon = Lexicon + { lexiconMixfix :: Seq (HashMap (Holey Token) (Associativity, Marker)) + , lexiconConnectives :: [[(Holey Token, Associativity)]] + , lexiconPrefixPredicates :: LexicalItems PrefixPredicate + , lexiconStructFun :: LexicalItems StructSymbol + , lexiconRelationSymbols :: LexicalItems RelationSymbol + , lexiconVerbs :: LexicalItems (SgPl LexicalPhrase) + , lexiconAdjLs :: LexicalItems LexicalPhrase + , lexiconAdjRs :: LexicalItems LexicalPhrase + , lexiconNouns :: LexicalItems (SgPl LexicalPhrase) + , lexiconStructNouns :: LexicalItems (SgPl LexicalPhrase) + , lexiconFuns :: LexicalItems (SgPl LexicalPhrase) + } deriving (Show, Eq) + +-- Projection returning the union of both left and right attributes. +-- +lexiconAdjs :: Lexicon -> HashMap LexicalPhrase Marker +lexiconAdjs lexicon = lexiconAdjLs lexicon <> lexiconAdjRs lexicon + +lookupOp :: FunctionSymbol -> Seq (HashMap FunctionSymbol (assoc, Marker)) -> Either String Marker +lookupOp f ops = case snd <$> firstJust (HM.lookup f) ops of + Just m -> Right m + Nothing -> Left (show f) + +lookupLexicalItem :: (Hashable a, Show a) => a -> LexicalItems a -> Either String Marker +lookupLexicalItem a items = case HM.lookup a items of + Just m -> Right m + Nothing -> Left (show a) + +type LexicalItems a = HashMap a Marker + +builtins :: Lexicon +builtins = Lexicon + { lexiconMixfix = builtinMixfix + , lexiconPrefixPredicates = builtinPrefixPredicates + , lexiconStructFun = builtinStructOps + , lexiconConnectives = builtinConnectives + , lexiconRelationSymbols = builtinRelationSymbols + , lexiconAdjLs = mempty + , lexiconAdjRs = builtinAdjRs + , lexiconVerbs = builtinVerbs + , lexiconNouns = builtinNouns + , lexiconStructNouns = builtinStructNouns + , lexiconFuns = mempty + } + +-- INVARIANT: 10 precedence levels for now. +builtinMixfix :: Seq (HashMap FunctionSymbol (Associativity, Marker)) +builtinMixfix = Seq.fromList $ (HM.fromList <$>) + [ [] + , [binOp (Symbol "+") LeftAssoc "add", binOp (Command "union") LeftAssoc "union", binOp (Command "monus") LeftAssoc "monus"] + , [binOp (Command "relcomp") LeftAssoc "relcomp"] + , [binOp (Command "circ") LeftAssoc "circ"] + , [binOp (Command "mul") LeftAssoc "mul", binOp (Command "inter") LeftAssoc "inter"] + , [binOp (Command "setminus") LeftAssoc "setminus"] + , [binOp (Command "times") RightAssoc "times"] + , [] + , prefixOps + , builtinIdentifiers + ] + where + builtinIdentifiers :: [(FunctionSymbol, (Associativity, Marker))] + builtinIdentifiers = identifier <$> + [ "emptyset" + , "naturals" + , "rationals" + , "reals" + , "unit" + , "zero" + ] + +prefixOps :: [(FunctionSymbol, (Associativity, Marker))] +prefixOps = + [ ([Just (Command "unions"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "unions")) + , ([Just (Command "cumul"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "cumul")) + , ([Just (Command "fst"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "fst")) + , ([Just (Command "snd"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "snd")) + , ([Just (Command "pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "pow")) + , (ConsSymbol, (NonAssoc, "cons")) + , (PairSymbol, (NonAssoc, "pair")) + -- NOTE Is now defined and hence no longer necessary , (ApplySymbol, (NonAssoc, "apply")) + ] + + +builtinStructOps :: LexicalItems StructSymbol +builtinStructOps = HM.fromList + [ (CarrierSymbol, "carrier") + ] + +identifier :: Text -> (Holey Token, (Associativity, Marker)) +identifier cmd = ([Just (Command cmd)], (NonAssoc, Marker cmd)) + + +builtinRelationSymbols :: LexicalItems RelationSymbol +builtinRelationSymbols = HM.fromList + [ (Symbol "=", "eq") + , (Command "neq", "neq") + , (Command "in", "elem") + , (Command "notin", "notelem") -- Alternative to @\not\in@. + ] + +builtinPrefixPredicates :: LexicalItems PrefixPredicate +builtinPrefixPredicates = HM.fromList + [ (PrefixPredicate "Cong" 4, "cong") + , (PrefixPredicate "Betw" 3, "betw") + ] + + +builtinConnectives :: [[(Holey Token, Associativity)]] +builtinConnectives = + [ [binOp' (Command "iff") NonAssoc] + , [binOp' (Command "implies") RightAssoc] + , [binOp' (Command "lor") LeftAssoc] + , [binOp' (Command "land") LeftAssoc] + , [([Just (Command "lnot"), Nothing], NonAssoc)] + ] + + +binOp :: Token -> Associativity -> Marker -> (Holey Token, (Associativity, Marker)) +binOp tok assoc m = ([Nothing, Just tok, Nothing], (assoc, m)) + +binOp' :: Token -> Associativity -> (Holey Token, Associativity) +binOp' tok assoc = ([Nothing, Just tok, Nothing], assoc) + +builtinAdjRs :: LexicalItems LexicalPhrase +builtinAdjRs = HM.fromList + [ (unsafeReadPhrase "equal to ?", "eq") + ] + +builtinVerbs :: LexicalItems (SgPl LexicalPhrase) +builtinVerbs = HM.fromList + [ (unsafeReadPhraseSgPl "equal[s/] ?", "eq") + ] + + +-- Some of these do/should correspond to mathlib structures, +-- e.g.: lattice, complete lattice, ring, etc. +-- +builtinNouns :: LexicalItems (SgPl LexicalPhrase) +builtinNouns = HM.mapKeys unsafeReadPhraseSgPl (HM.fromList + -- Nullary + [ ("set[/s]", "set") + , ("point[/s]", "point") + , ("element[/s] of ?", "elem") + ]) + +_Onesorted :: SgPl LexicalPhrase +_Onesorted = unsafeReadPhraseSgPl "onesorted structure[/s]" + +builtinStructNouns :: LexicalItems (SgPl LexicalPhrase) +builtinStructNouns = HM.singleton _Onesorted "onesorted_structure" + + +-- | Naïve splitting of lexical phrases to insert a variable slot for names in noun phrases, +-- as in /@there exists a linear form $h$ on $E$@/, where the underlying pattern is +-- /@linear form on ?@/. In this case we would get: +-- +-- > splitOnVariableSlot (sg (unsafeReadPhraseSgPl "linear form[/s] on ?")) +-- > == +-- > (unsafeReadPhrase "linear form", unsafeReadPhrase "on ?") +-- +splitOnVariableSlot :: LexicalPhrase -> (LexicalPhrase, LexicalPhrase) +splitOnVariableSlot phrase = case prepositionIndices <> nonhyphenatedSlotIndices of + [] -> (phrase, []) -- Place variable slot at the end. + is -> List.splitAt (minimum is) phrase + where + prepositionIndices, slotIndices, nonhyphenatedSlotIndices :: [Int] -- Ascending. + prepositionIndices = List.findIndices isPreposition phrase + slotIndices = List.findIndices isNothing phrase + nonhyphenatedSlotIndices = [i | i <- slotIndices, noHyphen (nth (i + 1) phrase)] + + isPreposition :: Maybe Token -> Bool + isPreposition = \case + Just (Word w) -> w `Set.member` prepositions + _ -> False + + noHyphen :: Maybe (Maybe Token) -> Bool + noHyphen = \case + Just (Just (Word w)) -> Text.head w /= '-' + -- If we arrive here, either the pattern is over (`Nothing`) or the next + -- part of the pattern is not a word that starts with a hyphen. + _ -> True + + +-- Preposition are a closed class, but this list is not yet exhaustive. +-- It can and should be extended when needed. The following list is a +-- selection of the prepositions found at +-- https://en.wikipedia.org/wiki/List_of_English_prepositions. +-- +prepositions :: HashSet Text +prepositions = Set.fromList + [ "about" + , "above" + , "across" + , "after" + , "against" + , "along", "alongside" + , "amid", "amidst" + , "among" + , "around" + , "as" + , "at" + , "atop" + , "before" + , "behind" + , "below" + , "beneath" + , "beside", "besides" + , "between" + , "beyond" + , "but" + , "by" + , "except" + , "for" + , "from" + , "in", "inside", "into" + , "like" + , "modulo", "mod" + , "near" + , "next" + , "of" + , "off" + , "on" + , "onto" + , "opposite" + , "out" + , "over" + , "past" + , "per" + , "sans" + , "till" + , "to" + , "under" + , "underneath" + , "unlike" + , "unto" + , "up", "upon" + , "versus" + , "via" + , "with" + , "within" + , "without" + ] diff --git a/source/Syntax/Token.hs b/source/Syntax/Token.hs new file mode 100644 index 0000000..7c8606c --- /dev/null +++ b/source/Syntax/Token.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +-- This module defines the lexer and its associated data types. +-- The lexer takes `Text` as input and produces a stream of tokens +-- annotated with positional information. This information is bundled +-- together with the original raw input for producing error messages. +-- +-- The lexer perfoms some normalizations to make describing the grammar easier. +-- Words outside of math environments are case-folded. Some commands are analysed +-- as variable tokens and are equivalent to their respective unicode variants +-- (α, β, γ, ..., 𝔸, 𝔹, ℂ, ...). Similarly, @\\begin{...}@ and @\\end{...}@ commands +-- are each parsed as single tokens. +-- +module Syntax.Token + ( Token(..) + , tokToString + , tokToText + , TokStream(..) + , Located(..) + , runLexer + ) where + + +import Base hiding (many) + +import Control.Monad.Combinators +import Control.Monad.State.Strict +import Data.Char (isAsciiLower) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Text qualified as Text +import Prettyprinter (Pretty(..)) +import Text.Megaparsec hiding (Token, Label, label) +import Text.Megaparsec.Char qualified as Char +import Text.Megaparsec.Char.Lexer qualified as Lexer + + +runLexer :: String -> Text -> Either (ParseErrorBundle Text Void) [Located Token] +runLexer file raw = runParser (evalStateT toks initLexerState) file raw + + +type Lexer = StateT LexerState (Parsec Void Text) + + +data LexerState = LexerState + { textNesting :: !Int + -- ^ Represents nesting of braces inside of the @\text{...}@ + -- command. When we encounter @\text@ the token mode switches + -- to text tokens. In order to switch back to math mode correctly + -- we need to count the braces. + , mode :: !Mode + } deriving (Show, Eq) + +initLexerState :: LexerState +initLexerState = LexerState 0 TextMode + +incrNesting, decrNesting :: LexerState -> LexerState +incrNesting (LexerState n m) = LexerState (succ n) m +decrNesting (LexerState n m) = LexerState (pred n) m + +data Mode = TextMode | MathMode deriving (Show, Eq) + +isTextMode, isMathMode :: Lexer Bool +isTextMode = do + m <- gets mode + pure (m == TextMode) +isMathMode = do + m <- gets mode + pure (m == MathMode) + +setTextMode, setMathMode :: Lexer () +setTextMode = do + st <- get + put st{mode = TextMode} +setMathMode = do + st <- get + put st{mode = MathMode} + +-- | +-- A token stream as input stream for a parser. Contains the raw input +-- before tokenization as 'Text' for showing error messages. +-- +data TokStream = TokStream + { rawInput :: !Text + , unTokStream :: ![Located Token] + } deriving (Show, Eq) + +instance Semigroup TokStream where + TokStream raw1 toks1 <> TokStream raw2 toks2 = TokStream (raw1 <> raw2) (toks1 <> toks2) + +instance Monoid TokStream where + mempty = TokStream mempty mempty + +-- | A LaTeX token. +-- Invisible delimiters 'InvisibleBraceL' and 'InvisibleBraceR' are +-- unescaped braces used for grouping in TEX (@{@), +-- visibles braces are escaped braces (@\\{@). +data Token + = Word !Text + | Variable !Text + | Symbol !Text + | Integer !Int + | Command !Text + | Label Text -- ^ A /@\\label{...}@/ command (case-sensitive). + | Ref (NonEmpty Text) -- ^ A /@\\ref{...}@/ command (case-sensitive). + | BeginEnv !Text + | EndEnv !Text + | ParenL | ParenR + | BracketL | BracketR + | VisibleBraceL | VisibleBraceR + | InvisibleBraceL | InvisibleBraceR + deriving (Show, Eq, Ord, Generic, Hashable) + +instance IsString Token where + fromString w = Word (Text.pack w) + +tokToText :: Token -> Text +tokToText = \case + Word w -> w + Variable v -> v + Symbol s -> s + Integer n -> Text.pack (show n) + Command cmd -> Text.cons '\\' cmd + Label m -> "\\label{" <> m <> "}" + Ref ms -> "\\ref{" <> Text.intercalate ", " (toList ms) <> "}" + BeginEnv "math" -> "$" + EndEnv "math" -> "$" + BeginEnv env -> "\\begin{" <> env <> "}" + EndEnv env -> "\\end{" <> env <> "}" + ParenL -> "(" + ParenR -> ")" + BracketL -> "[" + BracketR -> "]" + VisibleBraceL -> "\\{" + VisibleBraceR -> "\\}" + InvisibleBraceL -> "{" + InvisibleBraceR -> "}" + +tokToString :: Token -> String +tokToString = Text.unpack . tokToText + +instance Pretty Token where + pretty = \case + Word w -> pretty w + Variable v -> pretty v + Symbol s -> pretty s + Integer n -> pretty n + Command cmd -> "\\" <> pretty cmd + Label m -> "\\label{" <> pretty m <> "}" + Ref m -> "\\ref{" <> pretty m <> "}" + BeginEnv env -> "\\begin{" <> pretty env <> "}" + EndEnv env -> "\\end{" <> pretty env <> "}" + ParenL -> "(" + ParenR -> ")" + BracketL -> "[" + BracketR -> "]" + VisibleBraceL -> "\\{" + VisibleBraceR -> "\\}" + InvisibleBraceL -> "{" + InvisibleBraceR -> "}" + + +data Located a = Located + { startPos :: !SourcePos + , unLocated :: !a + } deriving (Show) + +instance Eq a => Eq (Located a) where (==) = (==) `on` unLocated +instance Ord a => Ord (Located a) where compare = compare `on` unLocated + + +-- | Parses tokens, switching tokenizing mode when encountering math environments. +toks :: Lexer [Located Token] +toks = whitespace *> goNormal id <* eof + where + goNormal f = do + r <- optional tok + case r of + Nothing -> pure (f []) + Just t@(Located _ (BeginEnv "math")) -> goMath (f . (t:)) + Just t@(Located _ (BeginEnv "align*")) -> goMath (f . (t:)) + Just t -> goNormal (f . (t:)) + goText f = do + r <- optional textToken + case r of + Nothing -> pure (f []) + Just t@(Located _ (BeginEnv "math")) -> goMathInText (f . (t:)) + Just t@(Located _ (EndEnv "text")) -> goMath (f . (t:)) + Just t@(Located _ (EndEnv "explanation")) -> goMath (f . (t:)) + Just t -> goText (f . (t:)) + goMath f = do + r <- optional mathToken + case r of + Nothing -> pure (f []) + Just t@(Located _ (EndEnv "math")) -> goNormal (f . (t:)) + Just t@(Located _ (EndEnv "align*")) -> goNormal (f . (t:)) + Just t@(Located _ (BeginEnv "text")) -> goText (f . (t:)) + Just t@(Located _ (BeginEnv "explanation")) -> goText (f . (t:)) + Just t -> goMath (f . (t:)) + goMathInText f = do + r <- optional mathToken + case r of + Nothing -> pure (f []) + Just t@(Located _ (EndEnv "math")) -> goText (f . (t:)) + Just t@(Located _ (BeginEnv "text")) -> goText (f . (t:)) + Just t -> goMathInText (f . (t:)) +{-# INLINE toks #-} + +-- | Parses a single normal mode token. +tok :: Lexer (Located Token) +tok = + word <|> var <|> symbol <|> mathBegin <|> alignBegin <|> begin <|> end <|> opening <|> closing <|> label <|> ref <|> command + +-- | Parses a single math mode token. +mathToken :: Lexer (Located Token) +mathToken = + var <|> symbol <|> number <|> begin <|> alignEnd <|> end <|> opening <|> closing <|> beginText <|> beginExplanation <|> mathEnd <|> command + +beginText :: Lexer (Located Token) +beginText = lexeme do + Char.string "\\text{" + setTextMode + pure (BeginEnv "text") + +-- | Same as text modulo spacing, so we treat it synonymously +beginExplanation :: Lexer (Located Token) +beginExplanation = lexeme do + Char.string "\\explanation{" + setTextMode + pure (BeginEnv "text") + +-- | Normal mode embedded into math mode via @\text{...}@. +textToken :: Lexer (Located Token) +textToken = word <|> symbol <|> begin <|> end <|> textEnd <|> mathBegin <|> alignBegin <|> opening' <|> closing' <|> ref <|> command + where + textEnd = lexeme do + 0 <- gets textNesting -- Otherwise fail. + Char.char '}' + setMathMode + pure (EndEnv "text") + + opening' = lexeme (brace <|> group <|> paren <|> bracket) + where + brace = VisibleBraceL <$ lexeme (Char.string "\\{") + group = InvisibleBraceL <$ lexeme (Char.char '{') <* modify' incrNesting + paren = ParenL <$ lexeme (Char.char '(') + bracket = BracketL <$ lexeme (Char.char '[') + + closing' = lexeme (brace <|> group <|> paren <|> bracket) + where + brace = VisibleBraceR <$ lexeme (Char.string "\\}") + group = InvisibleBraceR <$ lexeme (Char.char '}') <* modify' decrNesting + paren = ParenR <$ lexeme (Char.char ')') + bracket = BracketR <$ lexeme (Char.char ']') + + +-- | Parses a single begin math token. +mathBegin :: Lexer (Located Token) +mathBegin = guardM isTextMode *> lexeme do + Char.string "\\(" <|> Char.string "\\[" <|> Char.string "$" + setMathMode + pure (BeginEnv "math") + +alignBegin :: Lexer (Located Token) +alignBegin = guardM isTextMode *> lexeme do + Char.string "\\begin{align*}" + setMathMode + pure (BeginEnv "align*") + + +-- | Parses a single end math token. +mathEnd :: Lexer (Located Token) +mathEnd = guardM isMathMode *> lexeme do + Char.string "\\)" <|> Char.string "\\]" <|> Char.string "$" + setTextMode + pure (EndEnv "math") + +alignEnd :: Lexer (Located Token) +alignEnd = guardM isMathMode *> lexeme do + Char.string "\\end{align*}" + setTextMode + pure (EndEnv "align*") + + +-- | Parses a word. Words are returned casefolded, since we want to ignore their case later on. +word :: Lexer (Located Token) +word = guardM isTextMode *> lexeme do + w <- some (Char.letterChar <|> Char.char '\'' <|> Char.char '-') + let t = Word (Text.toCaseFold (Text.pack w)) + pure t + +number :: Lexer (Located Token) +number = lexeme $ Integer <$> Lexer.decimal + + +var :: Lexer (Located Token) +var = guardM isMathMode *> lexeme (fmap Variable var') + where + var' = do + alphabeticPart <- letter <|> bb <|> greek + variationPart <- subscriptNumber <|> ticked <|> pure "" + pure (alphabeticPart <> variationPart) + + subscriptNumber :: Lexer Text + subscriptNumber = do + Char.char '_' + n <- some Char.digitChar + pure (Text.pack n) + + -- Temporary hack to fit the TPTP format. + ticked :: Lexer Text + ticked = do + ticks <- some $ Char.char '\'' + let ticks' = "prime" <$ ticks :: [Text] + pure (Text.concat ticks') + + letter :: Lexer Text + letter = fmap Text.singleton Char.letterChar + + greek :: Lexer Text + greek = try do + Char.char '\\' + l <- symbolParser greeks + notFollowedBy Char.letterChar + pure l + + greeks :: [Text] + greeks = + [ "alpha", "beta", "gamma", "delta", "epsilon", "zeta", "eta", "theta" + , "iota", "kappa", "lambda", "mu", "nu", "xi", "pi", "rho", "sigma" + , "tau", "upsilon", "phi", "chi", "psi", "omega" + , "Gamma", "Delta", "Theta", "Lambda", "Xi", "Pi", "Sigma", "Upsilon" + , "Phi", "Psi", "Omega" + ] + + bb :: Lexer Text + bb = do + Char.string "\\mathbb{" + l <- symbolParser bbs + Char.char '}' + pure $ "bb" <> l + + bbs :: [Text] + bbs = Text.singleton <$> ['A'..'Z'] + + + symbolParser :: [Text] -> Lexer Text + symbolParser symbols = asum (fmap Char.string symbols) + + +symbol :: Lexer (Located Token) +symbol = lexeme do + symb <- some (satisfy (`elem` symbols)) + pure (Symbol (Text.pack symb)) + where + symbols :: [Char] + symbols = ".,:;!?@=≠+-/|^><≤≥*&≈⊂⊃⊆⊇∈“”‘’" + +-- | Parses a TEX-style command. +command :: Lexer (Located Token) +command = lexeme do + Char.char '\\' + cmd <- some Char.letterChar + pure (Command (Text.pack cmd)) + +-- | Parses the beginning of an environment. +-- Commits only after having seen "\begin{". +begin :: Lexer (Located Token) +begin = lexeme do + Char.string "\\begin{" + env <- some (Char.letterChar <|> Char.char '*') + Char.char '}' + pure (BeginEnv (Text.pack env)) + +-- | Parses a label command and extracts its marker. +label :: Lexer (Located Token) +label = lexeme do + Char.string "\\label{" + m <- marker + Char.char '}' + pure (Label m) + +-- | Parses a label command and extracts its marker. +ref :: Lexer (Located Token) +ref = lexeme do + -- @\\cref@ is from @cleveref@ and @\\hyperref@ is from @hyperref@ + cmd <- Char.string "\\ref{" <|> Char.string "\\cref{" <|> Char.string "\\hyperref[" + ms <- NonEmpty.fromList <$> marker `sepBy1` Char.char ',' + case cmd of + "\\hyperref[" -> Char.string "]{" *> some (satisfy (/= '}')) *> Char.char '}' *> pure (Ref ms) + _ -> Char.char '}' *> pure (Ref ms) + +marker :: Lexer Text +marker = takeWhile1P Nothing (\x -> isAsciiLower x || x == '_') + +-- | Parses the end of an environment. +-- Commits only after having seen "\end{". +end :: Lexer (Located Token) +end = lexeme do + Char.string "\\end{" + env <- some (Char.letterChar <|> Char.char '*') + Char.char '}' + pure (EndEnv (Text.pack env)) + +-- | Parses an opening delimiter. +opening :: Lexer (Located Token) +opening = lexeme (paren <|> brace <|> group <|> bracket) + where + brace = VisibleBraceL <$ lexeme (Char.string "\\{") + group = InvisibleBraceL <$ lexeme (Char.char '{') + paren = ParenL <$ lexeme (Char.char '(') + bracket = BracketL <$ lexeme (Char.char '[') + +-- | Parses a closing delimiter. +closing :: Lexer (Located Token) +closing = lexeme (paren <|> brace <|> group <|> bracket) + where + brace = VisibleBraceR <$ lexeme (Char.string "\\}") + group = InvisibleBraceR <$ lexeme (Char.char '}') + paren = ParenR <$ lexeme (Char.char ')') + bracket = BracketR <$ lexeme (Char.char ']') + +-- | Turns a Lexer into one that tracks the source position of the token +-- and consumes trailing whitespace. +lexeme :: Lexer a -> Lexer (Located a) +lexeme p = do + start <- getSourcePos + t <- p + whitespace + pure (Located start t) + +space :: Lexer () +space = void (Char.char ' ' <|> Char.char '\n') + <|> void (Char.string "\\ " <|> Char.string "\\\\" <|> Char.string "\\!" <|> Char.string "\\," <|> Char.string "\\:" <|> Char.string "\\;" <|> Char.string "\\;") + +whitespace :: Lexer () +whitespace = Lexer.space (void (some space)) (Lexer.skipLineComment "%") empty diff --git a/source/Test/All.hs b/source/Test/All.hs new file mode 100644 index 0000000..7fb5bd3 --- /dev/null +++ b/source/Test/All.hs @@ -0,0 +1,14 @@ +module Test.All where + + +import Base +import Test.Golden +import Test.Unit +import Test.Tasty + + +runTests :: IO () +runTests = defaultMain =<< tests + +tests :: IO TestTree +tests = testGroup "all tests" <$> sequence [goldenTests, return unitTests] diff --git a/source/Test/Golden.hs b/source/Test/Golden.hs new file mode 100644 index 0000000..705aaa5 --- /dev/null +++ b/source/Test/Golden.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} + +module Test.Golden where + + +import Api qualified +import Provers qualified +import Tptp.UnsortedFirstOrder (toText) +import Base +import Provers (defaultTimeLimit) + +import Control.Monad.Logger +import Control.Monad.Reader +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.Text.Lazy.IO qualified as LazyTextIO +import System.Directory +import System.FilePath +import Test.Tasty +import Test.Tasty.Golden (goldenVsFile, findByExtension) +import Text.Pretty.Simple (pShowNoColor) +import UnliftIO +import UnliftIO.Environment +import Api (Options(withDumpPremselTraining)) + +testOptions :: Api.Options +testOptions = Api.Options + { Api.withDumpPremselTraining = Api.WithoutDumpPremselTraining + , Api.withCache = Api.WithoutCache + , Api.withFilter = Api.WithoutFilter + , inputPath = error "testOptions: no inputPath" + , withDump = Api.WithoutDump + , withLogging = Api.WithoutLogging + , withMemoryLimit = Provers.defaultMemoryLimit + , withOmissions = Api.WithOmissions + , withParseOnly = Api.WithoutParseOnly + , withProver = Api.WithDefaultProver + , withTimeLimit = Provers.defaultTimeLimit + , withVersion = Api.WithoutVersion + , withMegalodon = Api.WithoutMegalodon + } + +goldenTests :: IO TestTree +goldenTests = runReaderT goldenTestGroup testOptions + +goldenTestGroup :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +goldenTestGroup = testGroup "golden tests" <$> sequence + [ tokenizing + , scanning + , parsing + , glossing + , generatingTasks + , encodingTasks + , verification + ] + + +-- | A testing triple consists of a an 'input' file, which is proccesed, resulting +-- in 'output' file, which is then compared to a 'golden' file. +data Triple = Triple + { input :: FilePath + , output :: FilePath + , golden :: FilePath + } + deriving (Show, Eq) + + +-- | Gathers all the files for the test. We test all examples and everything in @test/pass/@. +-- The golden files for all tests are stored in @test/pass/@, so we need to adjust the filepath +-- of the files from @examples/@. +gatherTriples :: MonadIO io => String -> io [Triple] +gatherTriples stage = do + inputs <- liftIO (findByExtension [".tex"] "test/examples") + pure $ + [ Triple{..} + | input <- inputs + , let input' = "test" </> "golden" </> takeBaseName input </> stage + , let golden = input' <.> "golden" + , let output = input' <.> "out" + ] + +createTripleDirectoriesIfMissing :: MonadIO io => Triple -> io () +createTripleDirectoriesIfMissing Triple{..} = liftIO $ + createDirectoryIfMissing True (takeDirectory output) + +makeGoldenTest :: (MonadUnliftIO io, MonadReader Api.Options io) => String -> (Triple -> io ()) -> io TestTree +makeGoldenTest stage action = do + triples <- gatherTriples stage + for triples createTripleDirectoriesIfMissing + runInIO <- askRunInIO + pure $ testGroup stage + [ goldenVsFile + (takeBaseName input) -- test name + golden + output + (runInIO (action triple)) + | triple@Triple{..} <- triples + ] + +tokenizing :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +tokenizing = makeGoldenTest "tokenizing" $ \Triple{..} -> do + tokenStream <- Api.tokenize input + liftIO (LazyTextIO.writeFile output (pShowNoColor (Api.simpleStream tokenStream))) + + +scanning :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +scanning = makeGoldenTest "scanning" $ \Triple{..} -> do + lexicalItems <- Api.scan input + liftIO (LazyTextIO.writeFile output (pShowNoColor lexicalItems)) + +parsing :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +parsing = makeGoldenTest "parsing" $ \Triple{..} -> do + (parseResult, _) <- Api.parse input + liftIO (LazyTextIO.writeFile output (pShowNoColor parseResult)) + + +glossing :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +glossing = makeGoldenTest "glossing" $ \Triple{..} -> do + (interpretationResult, _) <- Api.gloss input + liftIO (LazyTextIO.writeFile output (pShowNoColor interpretationResult)) + + +generatingTasks :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +generatingTasks = makeGoldenTest "generating tasks" $ \Triple{..} -> do + (tasks, _) <- Api.generateTasks input + liftIO $ LazyTextIO.writeFile output (pShowNoColor tasks) + + +encodingTasks :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +encodingTasks = makeGoldenTest "encoding tasks" $ \Triple{..} -> do + tasks <- Api.encodeTasks input + liftIO (TextIO.writeFile output (Text.intercalate "\n------------------\n" (toText <$> tasks))) + + +verification :: (MonadUnliftIO io, MonadReader Api.Options io) => io TestTree +verification = makeGoldenTest "verification" $ \Triple{..} -> do + vampirePathPath <- (?? "vampire") <$> lookupEnv "NAPROCHE_VAMPIRE" + let defaultProverInstance = Provers.vampire vampirePathPath Provers.Silent Provers.defaultTimeLimit Provers.defaultMemoryLimit + answers <- runNoLoggingT (Api.verify defaultProverInstance input) + liftIO (LazyTextIO.writeFile output (pShowNoColor answers)) diff --git a/source/Test/Unit.hs b/source/Test/Unit.hs new file mode 100644 index 0000000..e98c33c --- /dev/null +++ b/source/Test/Unit.hs @@ -0,0 +1,15 @@ +module Test.Unit where + + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Unit.Symdiff qualified as Symdiff + + +unitTests :: TestTree +unitTests = testGroup "unit tests" [testCase "filter" filtersWell] + + +filtersWell :: Assertion +filtersWell = do + assertBool "Filter works on symdiff problem" Symdiff.filtersWell diff --git a/source/Test/Unit/Symdiff.hs b/source/Test/Unit/Symdiff.hs new file mode 100644 index 0000000..583004f --- /dev/null +++ b/source/Test/Unit/Symdiff.hs @@ -0,0 +1,96 @@ +module Test.Unit.Symdiff where + +import Base +import Bound.Scope +import Bound.Var +import Syntax.Internal +import Filter + +import Data.Text qualified as Text + +filtersWell :: Bool +filtersWell = badFact `notElem` (snd <$> taskHypotheses (filterTask symdiff)) + + +badFact :: ExprOf a +badFact = Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "FreshReplacementVar")), TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Quantified Existentially (Scope (Connected Conjunction (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (B (NamedVar "A"))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "b")), TermVar (F (TermVar (B (NamedVar "B"))))])) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (F (TermVar (B (NamedVar "FreshReplacementVar")))), TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))]])))))) + + +symdiff :: Task +symdiff = + Task + { taskDirectness = + Direct + , taskConjectureLabel = Marker "symdiff_test" + , taskHypotheses = zipWith (,) (Marker . Text.pack . show <$> ([1..] :: [Int])) + [ Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "A"))], TermVar (B (NamedVar "A"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []], TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "C"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "C"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "x"))], TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []], TermVar (B (NamedVar "x"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "symdiff"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "x"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermVar (B (NamedVar "Z"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))], TermVar (B (NamedVar "Z"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "A"))], TermVar (B (NamedVar "A"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []], TermVar (B (NamedVar "A"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "z"))]], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "z"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "C"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "C"))]]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Just (Command "inters"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermSymbol (SymbolMixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "A"))]], TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Just (Command "unions"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermSymbol (SymbolMixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "A"))]], TermVar (B (NamedVar "A"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Just (Command "fst"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))]], TermVar (B (NamedVar "a"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Just (Command "snd"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))]], TermVar (B (NamedVar "b"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "A")), TermSymbol (SymbolMixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "A"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Just (Command "Cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermSymbol (SymbolMixfix [Just (Command "emptyset")]) [], TermSymbol (SymbolMixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "A"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "neq"))) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))], TermVar (B (NamedVar "a"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "neq"))) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))], TermVar (B (NamedVar "b"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "A"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "A"))])) + , Quantified Universally (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermSymbol (SymbolMixfix [Just (Command "emptyset")]) [], TermVar (B (NamedVar "a"))])) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "disjoint"), Just (Word "from"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "disjoint"), Just (Word "from"), Nothing])) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "B"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Not (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))])))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]]) (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "Y"))])))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "neq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Existentially (Scope (Connected ExclusiveOr (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "A"))))]) (Not (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "B"))))]))) (Connected Conjunction (Not (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "A"))))])) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "c")), TermVar (F (TermVar (B (NamedVar "B"))))]))))))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "B"))]))) + , Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Z"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "Y")), TermVar (B (NamedVar "Z"))]]))) + , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (Not (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))]))) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]))) + , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "Y"))])) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))], TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]]))) + , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))])) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]))) + , Quantified Universally (Scope (Connected Implication (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "C"))])) (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "C"))]))) + , Quantified Universally (Scope (Connected Implication (Connected Conjunction (PropositionalConstant IsTop) (PropositionalConstant IsTop)) (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Connected Disjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))]))))) + , Quantified Universally (Scope (Connected Implication (Connected Conjunction (Not (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "x"))])) (Not (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "y"))]))) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]))) + , Quantified Universally (Scope (Connected Implication (Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (B (NamedVar "A"))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (B (NamedVar "B"))))])))) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "disjoint"), Just (Word "from"), Nothing])) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Universally (Scope (Not (Quantified Existentially (Scope (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "A"))))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "B"))))))]))))))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "A"))]) (Quantified Universally (Scope (Quantified Existentially (Scope (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "A"))))))]))))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "A"))]) (Not (Not (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "A"))]))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "b"))], TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "aprime")), TermVar (B (NamedVar "bprime"))]]) (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "aprime"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "b")), TermVar (B (NamedVar "bprime"))])))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "b")), TermVar (B (NamedVar "c"))]], TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "aprime")), TermSymbol (SymbolMixfix [Just (Word "pair")]) [TermVar (B (NamedVar "bprime")), TermVar (B (NamedVar "cprime"))]]]) (Connected Conjunction (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "aprime"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "b")), TermVar (B (NamedVar "bprime"))])) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "c")), TermVar (B (NamedVar "cprime"))])))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "B")), TermSymbol (SymbolMixfix [Just (Command "Pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "A"))]]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "B")), TermVar (B (NamedVar "A"))]))) + , badFact + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))])))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]]) (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "A"))]) (Not (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (B (NamedVar "B"))]))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "x")), TermSymbol (SymbolMixfix [Just (Command "Cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "y")), TermVar (B (NamedVar "X"))]]) (Connected Disjunction (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "y"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))])))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "z")), TermSymbol (SymbolMixfix [Just (Command "inters"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "X"))]]) (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "X"))]) (Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "Y")), TermVar (F (TermVar (B (NamedVar "X"))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (F (TermVar (B (NamedVar "z")))), TermVar (B (NamedVar "Y"))]))))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "z")), TermSymbol (SymbolMixfix [Just (Command "unions"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "X"))]]) (Quantified Existentially (Scope (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "Y")), TermVar (F (TermVar (B (NamedVar "X"))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (F (TermVar (B (NamedVar "z")))), TermVar (B (NamedVar "Y"))])))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "subset"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Universally (Scope (Connected Conjunction (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (F (TermVar (B (NamedVar "A")))), TermVar (F (TermVar (B (NamedVar "B"))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "neq"))) [TermVar (F (TermVar (B (NamedVar "A")))), TermVar (F (TermVar (B (NamedVar "B"))))])))))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Symbol "="))) [TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))], TermVar (B (NamedVar "A"))]))) + , Quantified Universally (Scope (Connected Equivalence (TermSymbol (SymbolPredicate (PredicateRelation (Command "subseteq"))) [TermVar (B (NamedVar "A")), TermVar (B (NamedVar "B"))]) (Quantified Universally (Scope (Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "A"))))))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermVar (F (TermVar (F (TermVar (B (NamedVar "B"))))))])))))))) + , Quantified Universally (Scope (Connected Equivalence (Not (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermSymbol (SymbolMixfix [Nothing, Just (Command "times"), Nothing]) [TermVar (B (NamedVar "X")), TermVar (B (NamedVar "Y"))]])) (Connected Disjunction (Not (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "X"))])) (Not (TermSymbol (SymbolPredicate (PredicateAdj [Just (Word "inhabited")])) [TermVar (B (NamedVar "Y"))]))))) + , Quantified Universally (Scope (Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (F (TermVar (B (NamedVar "y")))), TermVar (B (NamedVar "X"))]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (F (TermVar (B (NamedVar "y")))), TermSymbol (SymbolMixfix [Just (Command "Cons"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR, Just InvisibleBraceL, Nothing, Just InvisibleBraceR]) [TermVar (B (NamedVar "x")), TermVar (B (NamedVar "X"))]]))))) + , Quantified Universally (Scope (Not (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (NamedVar "a")), TermSymbol (SymbolMixfix [Just (Command "emptyset")]) []]))) + ] + , taskConjecture = + Quantified Universally (Scope (Connected Implication (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (FreshVar 0)), TermSymbol (SymbolMixfix [Nothing, Just (Command "setminus"), Nothing]) [TermSymbol (SymbolMixfix [Nothing, Just (Command "union"), Nothing]) [TermVar (F (TermVar (NamedVar "x"))), TermVar (F (TermVar (NamedVar "y")))], TermSymbol (SymbolMixfix [Nothing, Just (Command "inter"), Nothing]) [TermVar (F (TermVar (NamedVar "y"))), TermVar (F (TermVar (NamedVar "x")))]]]) (TermSymbol (SymbolPredicate (PredicateRelation (Command "in"))) [TermVar (B (FreshVar 0)), TermSymbol (SymbolMixfix [Nothing, Just (Command "symdiff"), Nothing]) [TermVar (F (TermVar (NamedVar "x"))), TermVar (F (TermVar (NamedVar "y")))]]))) + } diff --git a/source/TheoryGraph.hs b/source/TheoryGraph.hs new file mode 100644 index 0000000..c4887ea --- /dev/null +++ b/source/TheoryGraph.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + + +module TheoryGraph where + + +import Base + + +import Data.List qualified as List +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set + + +-- | A directed simple graph labelled by the 'FilePath' of each theory. +newtype TheoryGraph + = TheoryGraph {unTheoryGraph :: Digraph_ FilePath} + deriving (Show, Eq) + + +-- | Raw 'TheoryGraph': a map from each theory @t@ to theories that import @t@. +type Digraph_ a = Map a (Set a) + + +instance Semigroup TheoryGraph where + (<>) = union + + +instance Monoid TheoryGraph where + mempty = TheoryGraph Map.empty + + +data Precedes a = !a `Precedes` !a deriving (Show, Eq, Ord, Generic) + + +union :: TheoryGraph -> TheoryGraph -> TheoryGraph +union (TheoryGraph g) (TheoryGraph g') = TheoryGraph (Map.unionWith Set.union g g') + + +unions :: [TheoryGraph] -> TheoryGraph +unions graphs = TheoryGraph (Map.unionsWith Set.union (fmap unTheoryGraph graphs)) + + +-- | The set of filepaths of the theory graph. +filepaths :: TheoryGraph -> Set FilePath +filepaths (TheoryGraph g) = Map.keysSet g + + +-- | Return the 'Context' of a node if it is in the graph, +-- or 'Nothing' if it is not. +importers :: FilePath -> TheoryGraph -> Maybe (Set FilePath) +importers n (TheoryGraph g) = Map.lookup n g +{-# INLINE importers #-} + + +-- | Return a list of the immediate successors of the given node. +succs :: FilePath -> TheoryGraph -> Maybe [FilePath] +succs n g = fmap (Set.foldl' (\ts t -> t : ts) []) (importers n g) + + +-- | Return 'True' if the given node is in the TheoryGraph, and 'False' otherwise. +member :: FilePath -> TheoryGraph -> Bool +member n (TheoryGraph g) = Map.member n g + + +-- | Add a node to the TheoryGraph. This is a noop if the node is already present in the graph. +addNode :: FilePath -> TheoryGraph -> TheoryGraph +addNode a (TheoryGraph g) = TheoryGraph (Map.insertWith Set.union a Set.empty g) + + +-- | Add an edge to the TheoryGraph. This is a noop if the edge is already present in the graph. +addPrecedes :: Precedes FilePath -> TheoryGraph -> TheoryGraph +addPrecedes e@(Precedes _ a') (TheoryGraph g) = addNode a' (TheoryGraph (insertTail e g)) + where + insertTail :: forall a. Ord a => Precedes a -> Digraph_ a -> Digraph_ a + insertTail (Precedes p s) = Map.adjust (Set.insert s) p + {-# INLINABLE insertTail #-} + + +-- | Construct a graph with a single node. +singleton :: FilePath -> TheoryGraph +singleton a = TheoryGraph (Map.singleton a Set.empty) + + +makeTheoryGraph :: [Precedes FilePath] -> [FilePath] -> TheoryGraph +makeTheoryGraph es as = List.foldl' (flip addPrecedes) (TheoryGraph trivial) es + where + trivial :: forall empty. Map FilePath (Set empty) + trivial = Map.fromList (fmap (, Set.empty) as) +{-# INLINE makeTheoryGraph #-} + + +fromList :: [Precedes FilePath] -> TheoryGraph +fromList es = TheoryGraph (Map.fromListWith Set.union es') + where + es' :: [(FilePath, Set FilePath)] + es' = fmap tailPart es <> fmap headPart es + + tailPart, headPart :: Precedes FilePath -> (FilePath, Set FilePath) + tailPart (Precedes a a') = (a, Set.singleton a') + headPart (Precedes _ a') = (a', mempty) + + +-- | Return a topological sort, if it exists. +topSort :: TheoryGraph -> Maybe [FilePath] +topSort g = go (filepaths g) + where + -- While there are unmarked nodes, visit them + go :: Set FilePath -> Maybe [FilePath] + go o = snd $ Set.foldl' (\(unmarked, list) n -> visit n unmarked Set.empty list) (o, Just []) o + + -- Check for marks, then visit children, mark n, and add to list + visit :: FilePath -> Set FilePath -> Set FilePath -> Maybe [FilePath] -> (Set FilePath, Maybe [FilePath]) + visit _ opens _ Nothing = (opens, Nothing) + visit n o t l + | not (Set.member n o) = (o, l) + | Set.member n t = (o, Nothing) + | otherwise = (Set.delete n newO, fmap (n :) newL) + where + -- visit all children + (newO, newL) = foldl' (\(o',l') node -> visit node o' (Set.insert n t) l') (o,l) (fromJust $ succs n g) + + +-- | Return a 'Right' topological sort, if it exists, or a 'Left' cycle otherwise. +topSortSeq :: TheoryGraph -> Either (Seq FilePath) (Seq FilePath) +topSortSeq g = go (filepaths g) + where + -- While there are unmarked nodes, visit them + go :: Set FilePath -> Either (Seq FilePath) (Seq FilePath) + go o = snd $ Set.foldl' (\(unmarked, list) n -> visit n unmarked Set.empty list) (o, Right mempty) o + + -- Check for marks, then visit children, mark n, and add to list + visit :: FilePath -> Set FilePath -> Set FilePath -> Either (Seq FilePath) (Seq FilePath) -> (Set FilePath, Either (Seq FilePath) (Seq FilePath)) + visit _ opens _ (Left cyc) = (opens, Left cyc) + visit n o t l@(Right r) + | not (Set.member n o) = (o, l) + | Set.member n t = (o, Left r) + | otherwise = (Set.delete n newO, fmap (n :<|) newL) + where + -- visit all children + (newO, newL) = foldl' (\(o',l') node -> visit node o' (Set.insert n t) l') (o,l) (fromJust $ succs n g) diff --git a/source/Tptp/UnsortedFirstOrder.hs b/source/Tptp/UnsortedFirstOrder.hs new file mode 100644 index 0000000..277ffc9 --- /dev/null +++ b/source/Tptp/UnsortedFirstOrder.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | A lenient representation of first-order TPTP syntax that does not guarantee that +-- the expression is actually first-order. +module Tptp.UnsortedFirstOrder where + +import Data.Char +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty +import Data.String (IsString) +import Data.Text (Text) +import Data.Text qualified as Text +import Prelude hiding (head, tail) +import Prettyprinter +import Prettyprinter.Render.Text +import Text.Builder + + +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = isAsciiLower c || isAsciiUpper c || isDigit c || c == '_' + +-- | A TPTP atomic word, starting with a lowercase letter or enclosed in single quotes. +newtype AtomicWord = AtomicWord Text deriving (Show, Eq, Ord, IsString) + +isProperAtomicWord :: Text -> Bool +isProperAtomicWord w = case Text.uncons w of + Nothing -> False + Just (head, tail) -> isAsciiLower head && Text.all isAsciiAlphaNum tail + +-- | A TPTP variable, written as a word starting with an uppercase letter. +newtype Variable = Variable Text deriving (Show, Eq, Ord, IsString) + +isVariable :: Text -> Bool +isVariable var = case Text.uncons var of + Nothing -> False -- Variables must be nonempty. + Just (head, tail) -> isAsciiUpper head && Text.all isAsciiAlphaNum tail + + +data Expr + = Apply AtomicWord [Expr] + | Var Variable + | Top + | Bottom + | Eq Expr Expr + | NotEq Expr Expr + | Conn Connective Expr Expr + | Not Expr + | Quantified Quantifier (NonEmpty Variable) Expr + deriving (Show, Eq, Ord) + +pattern Const :: AtomicWord -> Expr +pattern Const x = Apply x [] + +data Quantifier = Forall | Exists deriving (Show, Eq, Ord) + +data Connective = And | Or | Imply | Iff deriving (Show, Eq, Ord) + +data Role + = Axiom + | AxiomUseful -- ^ Annotated axiom for trainig premise selection. + | AxiomRedundant -- ^ Annotated axiom for trainig premise selection. + | Hypothesis + | Conjecture + | NegatedConjecture + deriving (Show, Eq, Ord) + +data Name = NameAtomicWord AtomicWord | NameInt Int + deriving (Show, Eq, Ord) + + +data AnnotatedFormula + = AnnotatedFormula Name Role Expr + deriving (Show, Eq, Ord) + + +newtype Task + = Task [AnnotatedFormula] + deriving (Show, Eq, Ord, Semigroup, Monoid) + +toTextNewline :: Task -> Text +toTextNewline task = run (buildTask task <> char '\n') + +toText :: Task -> Text +toText task = run (buildTask task) + +singleQuoted :: Text -> Text +singleQuoted str = Text.snoc (Text.cons '\'' (escape str)) '\'' + where + -- First escape backslashes, then single quotes. + escape :: Text -> Text + escape = Text.replace "'" "\\'" . Text.replace "\\" "\\\\" + +buildTuple :: [Builder] -> Builder +buildTuple bs = char '(' <> intercalate (char ',') bs <> char ')' + +buildList :: [Builder] -> Builder +buildList bs = char '[' <> intercalate (char ',') bs <> char ']' + +renderTask :: Task -> Text +renderTask task = renderStrict (layoutPretty defaultLayoutOptions (prettyTask task)) + +buildAtomicWord :: AtomicWord -> Builder +buildAtomicWord (AtomicWord w) = text if isProperAtomicWord w then w else singleQuoted w + +buildVariable :: Variable -> Builder +buildVariable (Variable v) = text (Text.replace "'" "_" v) + + +buildApply :: AtomicWord -> [Expr] -> Builder +buildApply f args = buildAtomicWord f <> buildTuple (map buildExpr args) + +buildExpr :: Expr -> Builder +buildExpr = \case + Apply f [] -> buildAtomicWord f + Apply f args -> buildApply f args + Var var -> buildVariable var + Top -> text "$true" + Bottom -> text "$false" + Eq t1 t2 -> buildExpr t1 <> char '=' <> buildExpr t2 + NotEq t1 t2 -> buildExpr t1 <> text "!=" <> buildExpr t2 + Not f -> + char '~' <> buildUnitary f + Conn And f1 f2 -> + buildAnd f1 <> char '&' <> buildAnd f2 + Conn Or f1 f2 -> + buildOr f1 <> char '|' <> buildOr f2 + Conn Imply f1 f2 -> + buildUnitary f1 <> "=>" <> buildUnitary f2 + Conn Iff f1 f2 -> + buildUnitary f1 <> "<=>" <> buildUnitary f2 + Quantified quant vars f -> + buildQuantifier quant <> buildList (map buildVariable (NonEmpty.toList vars)) <> char ':' <> buildUnitary f + +isAtom :: Expr -> Bool +isAtom = \case + Var{} -> True + Apply{} -> True + Top -> True + Bottom -> True + Eq{} -> True + NotEq{} -> True + _ -> False + +buildQuantifier :: Quantifier -> Builder +buildQuantifier = \case + Forall -> text "!" + Exists -> text "?" + +buildUnitary :: Expr -> Builder +buildUnitary = \case + atom | isAtom atom -> buildExpr atom + Quantified quant vars f -> + buildQuantifier quant <> buildList (map buildVariable (NonEmpty.toList vars)) <> char ':' <> buildUnitary f + Not phi -> char '~' <> buildUnitary phi + phi -> char '(' <> buildExpr phi <> char ')' + +buildAnd :: Expr -> Builder +buildAnd = \case + Conn And f1 f2 -> buildAnd f1 <> char '&' <> buildAnd f2 + f -> buildUnitary f + +buildOr :: Expr -> Builder +buildOr = \case + Conn Or f1 f2 -> buildOr f1 <> char '|' <> buildUnitary f2 + f -> buildUnitary f + +buildName :: Name -> Builder +buildName = \case + NameAtomicWord w -> buildAtomicWord w + NameInt n -> decimal n + +buildRole :: Role -> Builder +buildRole = \case + Axiom -> "axiom" + AxiomUseful -> "axiom_useful" + AxiomRedundant -> "axiom_redundant" + Hypothesis -> "hypothesis" + Conjecture -> "conjecture" + NegatedConjecture -> "negated_conjecture" + +buildAnnotatedFormula :: AnnotatedFormula -> Builder +buildAnnotatedFormula (AnnotatedFormula name role phi) = + "fof" <> buildTuple [buildName name, buildRole role, buildExpr phi] <> "." + +buildTask :: Task -> Builder +buildTask (Task fofs) = intercalate (char '\n') (map buildAnnotatedFormula fofs) + + + +prettyAtomicWord :: AtomicWord -> Doc ann +prettyAtomicWord (AtomicWord w) = + if isProperAtomicWord w + then pretty w + else pretty (singleQuoted w) + +prettyVariable :: Variable -> Doc ann +prettyVariable (Variable v) = pretty v + + +prettyApply :: AtomicWord -> [Expr] -> Doc ann +prettyApply f args = prettyAtomicWord f <> tupled (map prettyExpr args) + +-- | @&@ and @|@ are associative, all other connectives are nonassociative. +-- The prettyprinting of these associative connectives does not preserve +-- the precise parenthesization but instead minimizes parentheses in the output. +prettyExpr :: Expr -> Doc ann +prettyExpr = \case + Apply f [] -> prettyAtomicWord f + Apply f args -> prettyApply f args + Var var -> prettyVariable var + Top -> "$true" + Bottom -> "$false" + Eq t1 t2 -> prettyExpr t1 <+> "=" <+> prettyExpr t2 + NotEq t1 t2 -> prettyExpr t1 <+> "!=" <+> prettyExpr t2 + atom | isAtom atom -> + prettyExpr atom + Not f -> + "~" <+> prettyUnitary f + Conn And f1 f2 -> + prettyAnd f1 <+> "&" <+> prettyAnd f2 + Conn Or f1 f2 -> + prettyOr f1 <+> "|" <+> prettyOr f2 + Conn Imply f1 f2 -> + prettyUnitary f1 <+> "=>" <+> prettyUnitary f2 + Conn Iff f1 f2 -> + prettyUnitary f1 <+> "<=>" <+> prettyUnitary f2 + Quantified quant vars f -> + prettyQuantifier quant <+> list (map prettyVariable (NonEmpty.toList vars)) <> ":" <+> prettyUnitary f + +prettyQuantifier :: Quantifier -> Doc ann +prettyQuantifier = \case + Forall -> "!" + Exists -> "?" + +prettyUnitary :: Expr -> Doc ann +prettyUnitary = \case + atom | isAtom atom -> prettyExpr atom + Quantified quant vars f -> + prettyQuantifier quant <+> list (map prettyVariable (NonEmpty.toList vars)) <> ":" <+> prettyUnitary f + Not phi -> "~" <+> prettyUnitary phi + phi -> parens (prettyExpr phi) + +prettyAnd :: Expr -> Doc ann +prettyAnd = \case + Conn And f1 f2 -> prettyAnd f1 <+> "&" <+> prettyAnd f2 + f -> prettyUnitary f + +prettyOr :: Expr -> Doc ann +prettyOr = \case + Conn Or f1 f2 -> prettyOr f1 <+> "|" <+> prettyUnitary f2 + f -> prettyUnitary f + +prettyName :: Name -> Doc ann +prettyName = \case + NameAtomicWord w -> prettyAtomicWord w + NameInt n -> pretty n + +prettyRole :: Role -> Doc ann +prettyRole = \case + Axiom -> "axiom" + AxiomUseful -> "axiom_useful" + AxiomRedundant -> "axiom_redundant" + Hypothesis -> "hypothesis" + Conjecture -> "conjecture" + NegatedConjecture -> "negated_conjecture" + +prettyAnnotatedFormula :: AnnotatedFormula -> Doc ann +prettyAnnotatedFormula (AnnotatedFormula name role phi) = + "fof" <> tupled [prettyName name, prettyRole role, prettyExpr phi] <> "." + +prettyTask :: Task -> Doc ann +prettyTask (Task fofs) = vsep (map prettyAnnotatedFormula fofs) diff --git a/source/Version.hs b/source/Version.hs new file mode 100644 index 0000000..2293e3c --- /dev/null +++ b/source/Version.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude #-} + + +module Version (info, infoBuilder) where + +import Data.Functor +import Data.Semigroup +import Data.Text (Text) +import Data.Version +import Paths_zf qualified as ZF +import Text.Builder + + +-- | Informational text about the version number (extracted from the cabal file). +info :: Text +info = run infoBuilder + +infoBuilder :: Builder +infoBuilder = text "Version " <> versionToBuilder ZF.version + +versionToBuilder :: Version -> Builder +versionToBuilder ver = intercalate (char '.') (decimal <$> versionBranch ver) |