diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/Meaning.hs | 50 | ||||
| -rw-r--r-- | source/Syntax/Abstract.hs | 8 | ||||
| -rw-r--r-- | source/Syntax/Adapt.hs | 15 | ||||
| -rw-r--r-- | source/Syntax/Concrete.hs | 8 | ||||
| -rw-r--r-- | source/Syntax/Lexicon.hs | 2 |
5 files changed, 48 insertions, 35 deletions
diff --git a/source/Meaning.hs b/source/Meaning.hs index 3822221..61f1d7b 100644 --- a/source/Meaning.hs +++ b/source/Meaning.hs @@ -42,6 +42,7 @@ type Gloss = ExceptT GlossError (State GlossState) data GlossError = GlossDefnError DefnError String | GlossInductionError + | GlossRelationExprWithParams deriving (Show, Eq, Ord) @@ -189,36 +190,39 @@ 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 :: Raw.Chain -> [(NonEmpty Raw.Expr, Sign, Raw.Relation, [Raw.Expr], 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' + Raw.ChainBase es sign rel params es' + -> [(es, sign, rel, params, es')] + Raw.ChainCons es sign rel params ch'@(Raw.ChainBase es' _ _ _ _) + -> (es, sign, rel, params, es') : splat ch' + Raw.ChainCons es sign rel params ch'@(Raw.ChainCons es' _ _ _ _) + -> (es, sign, rel, params, 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 :: [(NonEmpty Raw.Expr, Sign, Raw.Relation, [Raw.Expr], NonEmpty Raw.Expr)] -> [(Sign, Raw.Relation, [Raw.Expr], Raw.Expr, Raw.Expr)] conjuncts triples = do - (e1s, sign, rel, e2s) <- triples + (e1s, sign, rel, params, e2s) <- triples e1 <- toList e1s e2 <- toList e2s - pure (sign, rel, e1, e2) + pure (sign, rel, params, e1, e2) - makeRels :: [(Sign, Raw.Relation, Raw.Expr, Raw.Expr)] -> Gloss [Sem.Formula] + makeRels :: [(Sign, Raw.Relation, [Raw.Expr], 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 + makeRel :: (Sign, Raw.Relation, [Raw.Expr], Raw.Expr, Raw.Expr) -> Gloss Sem.Formula + makeRel (sign, rel, params, e1, e2) = do e1' <- glossExpr e1 e2' <- glossExpr e2 + params' <- glossExpr `each` params 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' + pure $ sign' $ Sem.Relation tok (params' <> [e1',e2']) + Raw.RelationExpr e -> case params of + [] -> do + e' <- glossExpr e + pure (sign' (Sem.TermPair e1' e2' `Sem.IsElementOf` e')) + _ -> throwError GlossRelationExprWithParams where sign' = case sign of Positive -> id @@ -542,8 +546,12 @@ glossDefnHead = \case 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.DefnRel v1 rel params v2 -> + pure \asms f -> + let args = case params of + p : ps -> p :| (ps <> [v1, v2]) + [] -> v1 :| [v2] + in Sem.DefnPredicate asms (Sem.PredicateRelation rel) args f Raw.DefnSymbolicPredicate (Raw.PrefixPredicate symb _ar) vs -> pure $ \asms f -> Sem.DefnPredicate asms (Sem.PredicateSymbol symb) vs f @@ -688,8 +696,8 @@ glossAbbreviation = \case 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.AbbreviationRel x rel params y stmt -> + makeAbbrStmt (Sem.SymbolPredicate (Sem.PredicateRelation rel)) (params <> [x, y]) stmt Raw.AbbreviationFun (Raw.Fun fun xs) t -> makeAbbrTerm (Sem.SymbolFun fun) xs t Raw.AbbreviationEq (Raw.SymbolPattern op xs) e -> diff --git a/source/Syntax/Abstract.hs b/source/Syntax/Abstract.hs index 23da652..31a1029 100644 --- a/source/Syntax/Abstract.hs +++ b/source/Syntax/Abstract.hs @@ -92,8 +92,8 @@ makeTuple = foldr1 ExprPair data Chain - = ChainBase (NonEmpty Expr) Sign Relation (NonEmpty Expr) - | ChainCons (NonEmpty Expr) Sign Relation Chain + = ChainBase (NonEmpty Expr) Sign Relation [Expr] (NonEmpty Expr) -- left arguments, possibly empty list of parameters, right arguments + | ChainCons (NonEmpty Expr) Sign Relation [Expr] Chain deriving (Show, Eq, Ord) data Relation @@ -319,7 +319,7 @@ data DefnHead | DefnVerb (Maybe (NounPhrase Maybe)) VarSymbol (VerbOf VarSymbol) | DefnNoun VarSymbol (NounOf VarSymbol) | DefnSymbolicPredicate PrefixPredicate (NonEmpty VarSymbol) - | DefnRel VarSymbol RelationSymbol VarSymbol + | DefnRel VarSymbol RelationSymbol [VarSymbol] VarSymbol -- ^ E.g.: /@$x \subseteq y$ iff [...@/ deriving (Show, Eq, Ord) @@ -411,7 +411,7 @@ data Abbreviation = AbbreviationAdj VarSymbol (AdjOf VarSymbol) Stmt | AbbreviationVerb VarSymbol (VerbOf VarSymbol) Stmt | AbbreviationNoun VarSymbol (NounOf VarSymbol) Stmt - | AbbreviationRel VarSymbol RelationSymbol VarSymbol Stmt + | AbbreviationRel VarSymbol RelationSymbol [VarSymbol] VarSymbol Stmt | AbbreviationFun (FunOf VarSymbol) Term | AbbreviationEq SymbolPattern Expr deriving (Show, Eq, Ord) diff --git a/source/Syntax/Adapt.hs b/source/Syntax/Adapt.hs index b338d47..1b5a237 100644 --- a/source/Syntax/Adapt.hs +++ b/source/Syntax/Adapt.hs @@ -124,7 +124,7 @@ head = ScanNoun <$> noun <|> ScanAdj <$> adj <|> ScanVerb <$> verb <|> ScanFun <$> fun - <|> ScanRelationSymbol <$> relationSymbol + <|> ScanRelationSymbol . fst <$> relationSymbol <|> ScanFunctionSymbol <$> functionSymbol <|> ScanPrefixPredicate <$> prefixPredicate @@ -184,14 +184,19 @@ verb = toLexicalPhrase <$> (var *> pat <* iff) fun :: RE Token LexicalPhrase fun = toLexicalPhrase <$> (the *> pat <* (is <|> comma)) -relationSymbol :: RE Token RelationSymbol -relationSymbol = math relator' <* iff +relationSymbol :: RE Token (RelationSymbol, Int) +relationSymbol = definiendum <* iff where - relator' = do + definiendum = math do varSymbol rel <- symbol + k <- params varSymbol - pure rel + pure (rel, k) + params :: RE Token Int + params = do + vars <- many (sym InvisibleBraceL *> var <* sym InvisibleBraceR) + pure (length vars) functionSymbol :: RE Token FunctionSymbol functionSymbol = do diff --git a/source/Syntax/Concrete.hs b/source/Syntax/Concrete.hs index 383f348..3c6700b 100644 --- a/source/Syntax/Concrete.hs +++ b/source/Syntax/Concrete.hs @@ -84,8 +84,8 @@ grammar lexicon@Lexicon{..} = mdo 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 + chainBase <- rule $ ChainBase <$> exprs <*> relationSign <*> relation <*> many (brace expr) <*> exprs + chainCons <- rule $ ChainCons <$> exprs <*> relationSign <*> relation <*> many (brace expr) <*> chain chain <- rule $ chainCons <|> chainBase formulaPredicate <- rule $ asum $ prefixPredicateOf FormulaPredicate expr <$> HM.keys lexiconPrefixPredicates @@ -250,7 +250,7 @@ grammar lexicon@Lexicon{..} = mdo 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 + defnRel <- rule $ DefnRel <$> (beginMath *> varSymbol) <*> relator <*> many (group varSymbol) <*> varSymbol <* endMath defnSymbolicPredicate <- rule $ math $ asum $ prefixPredicateOf DefnSymbolicPredicate varSymbol <$> HM.keys lexiconPrefixPredicates defnHead <- rule $ optional _write *> asum [defnAdj, defnVerb, defnNoun, defnRel, defnSymbolicPredicate] @@ -269,7 +269,7 @@ grammar lexicon@Lexicon{..} = mdo 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 + abbreviationRel <- rule $ AbbreviationRel <$> (beginMath *> varSymbol) <*> relator <*> many (brace varSymbol) <*> 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) diff --git a/source/Syntax/Lexicon.hs b/source/Syntax/Lexicon.hs index 4fe8730..7f79294 100644 --- a/source/Syntax/Lexicon.hs +++ b/source/Syntax/Lexicon.hs @@ -112,7 +112,7 @@ prefixOps = , ([Just (Command "pow"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "pow")) , ([Just (Command "neg"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "neg")) , ([Just (Command "inv"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "inv")) - , ([Just (Command "abs"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "abs")) + , ([Just (Command "abs"), Just InvisibleBraceL, Nothing, Just InvisibleBraceR], (NonAssoc, "abs")) , (ConsSymbol, (NonAssoc, "cons")) , (PairSymbol, (NonAssoc, "pair")) -- NOTE Is now defined and hence no longer necessary , (ApplySymbol, (NonAssoc, "apply")) |