diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/Checking.hs | 39 | ||||
| -rw-r--r-- | source/Meaning.hs | 12 | ||||
| -rw-r--r-- | source/Syntax/Abstract.hs | 2 | ||||
| -rw-r--r-- | source/Syntax/Adapt.hs | 2 | ||||
| -rw-r--r-- | source/Syntax/Concrete.hs | 2 | ||||
| -rw-r--r-- | source/Syntax/Internal.hs | 2 |
6 files changed, 47 insertions, 12 deletions
diff --git a/source/Checking.hs b/source/Checking.hs index dc90264..817c477 100644 --- a/source/Checking.hs +++ b/source/Checking.hs @@ -28,6 +28,7 @@ import Data.HashSet qualified as HS import Data.InsOrdMap (InsOrdMap) import Data.InsOrdMap qualified as InsOrdMap import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.IO qualified as Text @@ -149,7 +150,7 @@ assume asms = traverse_ go asms go :: Asm -> Checking go = \case Asm phi -> do - phi' <- (canonicalize phi) + phi' <- canonicalize phi modify \st -> st{ checkingAssumptions = phi' : checkingAssumptions st , fixedVars = freeVars phi' <> fixedVars st @@ -542,6 +543,42 @@ checkProof = \case checkCalc calc assume [Asm (calcResult calc)] checkProof continue + DefineFunctionMathy funVar domVar ranVar argVar definitions continue -> do + -- We have f: X \to Y and x \mapsto ... + -- definition is a nonempty list of (expresssion e, formula phi) + -- such that f(x) = e if phi(x) + -- since we do a case deduction in the definition there has to be a check that, + -- our domains in the case are a disjunct union of dom(f) + assume + [Asm (TermOp DomSymbol [TermVar funVar] `Equals` TermVar domVar) + ,Asm (rightUniqueAdj (TermVar funVar)) + ,Asm (relationNoun (TermVar funVar))] + + goals <- gets checkingGoals + setGoals [makeForall [argVar] ((TermVar argVar `IsElementOf` TermVar domVar) `Iff` subdomainConjuctionLocalFunction argVar definitions )] -- check the disjunct union + tellTasks + + assume [Asm (makeForall [argVar] ((TermVar argVar `IsElementOf` TermVar domVar) `Implies` (TermOp ApplySymbol [TermVar funVar, TermVar argVar] `IsElementOf` TermVar ranVar)))] -- function f from \dom(f) \to \ran(f) + assume (functionSubdomianExpression funVar argVar definitions) --behavior on the subdomians + setGoals goals + checkProof continue + + +-- | Makes a conjunction of all the subdomain statments +subdomainConjuctionLocalFunction :: VarSymbol -> NonEmpty (Term, Formula) -> Formula +subdomainConjuctionLocalFunction argVar defintions = + let stmts = [snd x | x <- NonEmpty.toList defintions] + in TermVar argVar `IsElementOf` makeConjunction stmts + + +functionSubdomianExpression :: VarSymbol -> VarSymbol -> NonEmpty (Term, Formula) -> [Asm] +functionSubdomianExpression f a nxs = case nxs of + x:|xs -> singleFunctionSubdomianExpression f a x : functionSubdomianExpression f a (NonEmpty.fromList xs) + + +singleFunctionSubdomianExpression :: VarSymbol -> VarSymbol -> (Term, Formula) -> Asm +singleFunctionSubdomianExpression funVar argVar x = Asm (makeForall [argVar] ((TermVar argVar `IsElementOf` snd x) `Implies` (TermOp ApplySymbol [TermVar funVar, TermVar argVar] `Equals` fst x))) + checkCalc :: Calc -> Checking checkCalc calc = locally do diff --git a/source/Meaning.hs b/source/Meaning.hs index 30e13f8..ab98c9a 100644 --- a/source/Meaning.hs +++ b/source/Meaning.hs @@ -607,17 +607,15 @@ glossProof = \case else error "mismatched variables in function definition." Raw.DefineFunctionMathy funVar domVar ranVar funVar2 argVar definitions proof -> do - if funVar /= funVar2 - then error "missmatched function names" - else Sem.DefineFunctionMathy funVar domVar ranVar argVar <*> glossLocalFunctionExprEach definitions <*> glossProof proof + if funVar == funVar2 + then Sem.DefineFunctionMathy funVar domVar ranVar argVar <$> (glossLocalFunctionExprDef `each` definitions) <*> glossProof proof + else error "missmatched function names" Raw.Calc calc proof -> Sem.Calc <$> glossCalc calc <*> glossProof proof -glossLocalFunctionExprEach :: NonEmpty [(Raw.Expr, Raw.Formula)]-> Gloss [(Sem.Term, Sem.Formula)] -glossLocalFunctionExprEach def = pure ( glossLocalFunctionExpr `each` def ) -glossLocalFunctionExpr :: (Raw.Expr, Raw.Formula) -> Gloss (Sem.Term, Sem.Formula) -glossLocalFunctionExpr (definingExpression, localDomain) = do +glossLocalFunctionExprDef :: (Raw.Expr, Raw.Formula) -> Gloss (Sem.Term, Sem.Formula) +glossLocalFunctionExprDef (definingExpression, localDomain) = do e <- glossExpr definingExpression d <- glossFormula localDomain pure (e,d) diff --git a/source/Syntax/Abstract.hs b/source/Syntax/Abstract.hs index 6457d42..6372c87 100644 --- a/source/Syntax/Abstract.hs +++ b/source/Syntax/Abstract.hs @@ -373,7 +373,7 @@ data Proof - | DefineFunctionMathy VarSymbol VarSymbol VarSymbol VarSymbol VarSymbol (NonEmpty [(Expr, Formula)]) Proof + | DefineFunctionMathy VarSymbol VarSymbol VarSymbol VarSymbol VarSymbol (NonEmpty (Expr, Formula)) Proof -- ^ Local function definition, but in this case we give the domain and target an the rules for $xs$ in some sub domains. -- deriving (Show, Eq, Ord) diff --git a/source/Syntax/Adapt.hs b/source/Syntax/Adapt.hs index 96fd76d..3cff497 100644 --- a/source/Syntax/Adapt.hs +++ b/source/Syntax/Adapt.hs @@ -35,7 +35,7 @@ scanChunk ltoks = Located{startPos = pos, unLocated = (BeginEnv "inductive")} :_ -> matchOrErr inductive "inductive definition" pos Located{startPos = pos, unLocated = (BeginEnv "signature")} :_ -> - matchOrErr signature "signature" pos + matchOrErr signatureIntro "signature" pos _ -> [] adaptChunks :: [[Located Token]] -> Lexicon -> Lexicon diff --git a/source/Syntax/Concrete.hs b/source/Syntax/Concrete.hs index f414ea6..69280c1 100644 --- a/source/Syntax/Concrete.hs +++ b/source/Syntax/Concrete.hs @@ -373,7 +373,7 @@ grammar lexicon@Lexicon{..} = mdo -- 3 & \text{else} -- \end{cases} - functionDefineCase <- rule $ (:[]) <$> ((,) <$> expr <*> (_ampersand *> formula)) + functionDefineCase <- rule $ (,) <$> expr <*> (_ampersand *> formula) defineFunctionMathy <- rule $ DefineFunctionMathy <$> (_define *> beginMath *> varSymbol) -- Define $ f <*> (_colon *> varSymbol) -- : 'var' \to 'var' diff --git a/source/Syntax/Internal.hs b/source/Syntax/Internal.hs index 872ae06..0e3361d 100644 --- a/source/Syntax/Internal.hs +++ b/source/Syntax/Internal.hs @@ -436,7 +436,7 @@ data Proof | Define VarSymbol Term Proof | DefineFunction VarSymbol VarSymbol Term Term Proof - | DefineFunctionMathy VarSymbol VarSymbol VarSymbol VarSymbol [(Term, Formula)] Proof + | DefineFunctionMathy VarSymbol VarSymbol VarSymbol VarSymbol (NonEmpty (Term, Formula)) Proof deriving instance Show Proof deriving instance Eq Proof |