diff --git a/lib/haskell/natural4/app/Main.hs b/lib/haskell/natural4/app/Main.hs index fe374913a..07fbea11c 100644 --- a/lib/haskell/natural4/app/Main.hs +++ b/lib/haskell/natural4/app/Main.hs @@ -28,6 +28,7 @@ import LS.Interpreter l4interpret, onlyTheItems, ) +import LS.DataFlow import LS.NLP.NLG ( allLangs, expandRulesForNLG, @@ -57,7 +58,7 @@ import LS.XPile.Maude qualified as Maude import LS.XPile.NaturalLanguage (toNatLang) import LS.XPile.Org (toOrg) import LS.XPile.Petri (toPetri) -import LS.XPile.Prolog (sfl4ToProlog) +import LS.XPile.Prolog (rulesToProlog, rulesToSCasp) import LS.XPile.Purescript (translate2PS) import LS.XPile.SVG qualified as AAS import LS.XPile.Typescript (asTypescript) @@ -95,7 +96,7 @@ main = do workuuid = SFL4.workdir opts <> "/" <> SFL4.uuiddir opts -- Bits that have to do with natural language processing and generation - nlgLangs <- unsafeInterleaveIO allLangs + nlgLangs <- unsafeInterleaveIO allLangs -- [TODO] Edsko is not a fan and has a whole talk about why we should not use this. strLangs <- unsafeInterleaveIO $ printLangs allLangs (engE,engErr) <- xpLog <$> langEng -- [NOTE] the Production Haskell book gives better ways to integrate Logging with IO @@ -172,7 +173,8 @@ main = do -- end of the section that deals with NLG - let (toprologFN, asProlog) = (workuuid <> "/" <> "prolog", show (sfl4ToProlog rules)) + let (toprologFN, asProlog) = (workuuid <> "/" <> "prolog", rulesToProlog rules) + (toscaspFN, asSCasp) = (workuuid <> "/" <> "scasp", rulesToSCasp rules) (topetriFN, (asPetri, asPetriErr)) = (workuuid <> "/" <> "petri", xpLog $ toPetri rules) (toaasvgFN, asaasvg) = (workuuid <> "/" <> "aasvg", AAS.asAAsvg defaultAAVConfig l4i rules) (tocorel4FN, (asCoreL4, asCoreL4Err)) = (workuuid <> "/" <> "corel4", xpLog (sfl4ToCorel4 rules)) @@ -193,6 +195,7 @@ main = do (totsFN, (asTSpretty, asTSerr)) = (workuuid <> "/" <> "ts", xpLog $ asTypescript l4i) (togroundsFN, asGrounds) = (workuuid <> "/" <> "grounds", show $ groundrules rc rules) (toOrgFN, asOrg) = (workuuid <> "/" <> "org", toOrg l4i rules) + (toDFGFN, (asDFG, asDFGerr)) = (workuuid <> "/" <> "dataflow", xpLog $ dataFlowAsDot l4i) (toNL_FN, asNatLang) = (workuuid <> "/" <> "natlang", toNatLang l4i) (toMaudeFN, asMaude) = (workuuid <> "/" <> "maude", Maude.rules2maudeStr rules) (tonativeFN, asNative) = (workuuid <> "/" <> "native", unlines @@ -232,6 +235,7 @@ main = do -- however, we can flag specific exclusions by adding the --tomd option which, counterintuitively, disables tomd when (toworkdir && not (null $ SFL4.uuiddir opts) && (null $ SFL4.only opts)) $ do + when (SFL4.tonative opts) $ mywritefile2 True toDFGFN iso8601 "dot" asDFG asDFGerr when (SFL4.tonative opts) $ mywritefile True toOrgFN iso8601 "org" asOrg when (SFL4.tonative opts) $ mywritefile True tonativeFN iso8601 "hs" asNative when ( SFL4.tocorel4 opts) $ mywritefile2 True tocorel4FN iso8601 "l4" (commentIfError "--" asCoreL4) asCoreL4Err @@ -288,6 +292,7 @@ main = do (concatMap snd toWriteVue) when (SFL4.toprolog opts) $ mywritefile True toprologFN iso8601 "pl" asProlog + when (SFL4.toscasp opts) $ mywritefile True toscaspFN iso8601 "pl" asSCasp when (SFL4.topetri opts) $ mywritefile2 True topetriFN iso8601 "dot" (commentIfError "//" asPetri) asPetriErr when (SFL4.tots opts) $ mywritefile2 True totsFN iso8601 "ts" (show asTSpretty) asTSerr when (SFL4.tonl opts) $ mywritefile True toNL_FN iso8601 "txt" asNatLang @@ -336,6 +341,9 @@ main = do pPrint $ groundrules rc rules when (SFL4.toProlog rc) $ pPrint asProlog + when (SFL4.toSCasp rc) $ pPrint asSCasp + + when (SFL4.toTS rc) $ print $ asTypescript rules when (SFL4.only opts == "" && SFL4.workdir opts == "") $ pPrint rules when (SFL4.only opts == "native") $ pPrint rules diff --git a/lib/haskell/natural4/doc/Interpreter.dot b/lib/haskell/natural4/doc/Interpreter.dot index 3dcf55fc1..ad259e6d5 100644 --- a/lib/haskell/natural4/doc/Interpreter.dot +++ b/lib/haskell/natural4/doc/Interpreter.dot @@ -1,89 +1,87 @@ strict digraph deps { node [colorscheme=set312, style=filled]; - subgraph cluster_2 { - label = "src/LS/Interpreter.hs"; - "unleaf" [label= "unleaf", color=2]; - "topsortedClasses" [label= "topsortedClasses", color=2]; - "symbolTable" [label= "symbolTable", color=2]; - "stitchRules" [label= "stitchRules", color=2]; - "ruleNameStr" [label= "ruleNameStr", color=2]; - "ruleDecisionGraph" [label= "ruleDecisionGraph", color=2]; - "relPredRefsAll" [label= "relPredRefsAll", color=2]; - "relPredRefs" [label= "relPredRefs", color=2]; - "onlyTheItems" [label= "onlyTheItems", color=2]; - "onlyItemNamed" [label= "onlyItemNamed", color=2]; - "musings" [label= "musings", color=2]; - "l4interpret" [label= "l4interpret", color=2]; - "itemsByRule" [label= "itemsByRule", color=2]; - "isRuleAlias" [label= "isRuleAlias", color=2]; - "groupedByAOTree" [label= "groupedByAOTree", color=2]; - "getRuleByName" [label= "getRuleByName", color=2]; - "getRuleByLabelName" [label= "getRuleByLabelName", color=2]; - "getRuleByLabel" [label= "getRuleByLabel", color=2]; - "getInheritances" [label= "getInheritances", color=2]; - "getCTkeys" [label= "getCTkeys", color=2]; - "getAttrTypesIn" [label= "getAttrTypesIn", color=2]; - "getAndOrTree" [label= "getAndOrTree", color=2]; - "extractRPMT2Text" [label= "extractRPMT2Text", color=2]; - "exposedRoots" [label= "exposedRoots", color=2]; - "expandTraceDebugging" [label= "expandTraceDebugging", color=2]; - "expandTrace" [label= "expandTrace", color=2]; - "expandRulesByLabel" [label= "expandRulesByLabel", color=2]; - "expandRule" [label= "expandRule", color=2]; - "expandRP" [label= "expandRP", color=2]; - "expandMT" [label= "expandMT", color=2]; - "expandClauses\'" [label= "expandClauses\'", color=2]; - "expandClauses" [label= "expandClauses", color=2]; - "expandClause" [label= "expandClause", color=2]; - "expandBody" [label= "expandBody", color=2]; - "expandBSR\'" [label= "expandBSR\'", color=2]; - "expandBSR" [label= "expandBSR", color=2]; - "decisionRoots" [label= "decisionRoots", color=2]; - "classHierarchy" [label= "classHierarchy", color=2]; - "classGraph" [label= "classGraph", color=2]; - "bsr2bsmt" [label= "bsr2bsmt", color=2]; - "bsmtOfClauses" [label= "bsmtOfClauses", color=2]; - "biggestItem" [label= "biggestItem", color=2]; - "attrType" [label= "attrType", color=2]; - "allCTkeys" [label= "allCTkeys", color=2]; - } - subgraph cluster_1 { - label = "src/LS/XPile/SVG.hs"; - "asAAsvg" [label= "asAAsvg", color=1]; + label = "src/LS/Interpreter.hs"; + "unleaf" [label= "unleaf", color=1]; + "topsortedClasses" [label= "topsortedClasses", color=1]; + "symbolTable" [label= "symbolTable", color=1]; + "ruleNameStr" [label= "ruleNameStr", color=1]; + "ruleLocalsOut" [label= "ruleLocalsOut", color=1]; + "ruleLocalsIn" [label= "ruleLocalsIn", color=1]; + "ruleLocals" [label= "ruleLocals", color=1]; + "ruleDecisionGraph" [label= "ruleDecisionGraph", color=1]; + "relPredRefsAll" [label= "relPredRefsAll", color=1]; + "relPredRefs" [label= "relPredRefs", color=1]; + "qaHornsT" [label= "qaHornsT", color=1]; + "qaHornsR" [label= "qaHornsR", color=1]; + "onlyTheItems" [label= "onlyTheItems", color=1]; + "onlyItemNamed" [label= "onlyItemNamed", color=1]; + "l4interpret" [label= "l4interpret", color=1]; + "itemsByRule" [label= "itemsByRule", color=1]; + "isRuleAlias" [label= "isRuleAlias", color=1]; + "groupedByAOTree" [label= "groupedByAOTree", color=1]; + "globalFacts" [label= "globalFacts", color=1]; + "getRuleByName" [label= "getRuleByName", color=1]; + "getRuleByLabelName" [label= "getRuleByLabelName", color=1]; + "getRuleByLabel" [label= "getRuleByLabel", color=1]; + "getMarkings" [label= "getMarkings", color=1]; + "getInheritances" [label= "getInheritances", color=1]; + "getCTkeys" [label= "getCTkeys", color=1]; + "getAttrTypesIn" [label= "getAttrTypesIn", color=1]; + "getAndOrTree" [label= "getAndOrTree", color=1]; + "extractRPMT2Text" [label= "extractRPMT2Text", color=1]; + "extractEnums" [label= "extractEnums", color=1]; + "exposedRoots" [label= "exposedRoots", color=1]; + "expandTraceDebugging" [label= "expandTraceDebugging", color=1]; + "expandTrace" [label= "expandTrace", color=1]; + "expandRulesByLabel" [label= "expandRulesByLabel", color=1]; + "expandRule" [label= "expandRule", color=1]; + "expandRP" [label= "expandRP", color=1]; + "expandMT" [label= "expandMT", color=1]; + "expandClauses\'" [label= "expandClauses\'", color=1]; + "expandClauses" [label= "expandClauses", color=1]; + "expandClause" [label= "expandClause", color=1]; + "expandBody" [label= "expandBody", color=1]; + "expandBSR\'" [label= "expandBSR\'", color=1]; + "expandBSRM" [label= "expandBSRM", color=1]; + "expandBSR" [label= "expandBSR", color=1]; + "entryPoints" [label= "entryPoints", color=1]; + "defaultToSuperType" [label= "defaultToSuperType", color=1]; + "defaultToSuperClass" [label= "defaultToSuperClass", color=1]; + "decisionRoots" [label= "decisionRoots", color=1]; + "classHierarchy" [label= "classHierarchy", color=1]; + "classGraph" [label= "classGraph", color=1]; + "bsr2bsmt" [label= "bsr2bsmt", color=1]; + "bsmtOfClauses" [label= "bsmtOfClauses", color=1]; + "attrsAsMethods" [label= "attrsAsMethods", color=1]; + "attrType" [label= "attrType", color=1]; + "allCTkeys" [label= "allCTkeys", color=1]; } "allCTkeys" -> "allCTkeys"; "allCTkeys" -> "getCTkeys"; -"asAAsvg" -> "expandBSR"; -"asAAsvg" -> "exposedRoots"; -"asAAsvg" -> "groupedByAOTree"; -"asAAsvg" -> "isRuleAlias"; -"biggestItem" -> "itemsByRule"; "bsmtOfClauses" -> "bsr2bsmt"; "bsmtOfClauses" -> "expandClauses"; "bsmtOfClauses" -> "expandTrace"; "bsr2bsmt" -> "bsr2bsmt"; -"classGraph" -> "classGraph"; "classHierarchy" -> "classHierarchy"; +"classHierarchy" -> "defaultToSuperType"; +"defaultToSuperType" -> "defaultToSuperClass"; "expandBSR" -> "expandBSR\'"; "expandBSR" -> "expandTrace"; +"expandBSRM" -> "expandBSR"; "expandBSR\'" -> "expandBSR\'"; "expandBSR\'" -> "expandRP"; -"expandBSR\'" -> "expandTrace"; "expandClause" -> "expandBSR\'"; -"expandClause" -> "expandTrace"; "expandClauses" -> "expandClauses\'"; "expandClauses" -> "expandTrace"; "expandClauses\'" -> "expandRP"; "expandClauses\'" -> "expandTrace"; "expandClauses\'" -> "unleaf"; "expandMT" -> "expandClause"; -"expandMT" -> "expandTrace"; "expandRP" -> "expandBSR\'"; "expandRP" -> "expandMT"; -"expandRP" -> "expandTrace"; "expandRule" -> "expandRulesByLabel"; "expandRulesByLabel" -> "expandRule"; "expandTrace" -> "expandTraceDebugging"; @@ -98,25 +96,23 @@ strict digraph deps { "getAndOrTree" -> "getRuleByName"; "getAttrTypesIn" -> "getAttrTypesIn"; "getAttrTypesIn" -> "getCTkeys"; +"getInheritances" -> "defaultToSuperClass"; "getInheritances" -> "getCTkeys"; -"groupedByAOTree" -> "decisionRoots"; "groupedByAOTree" -> "getAndOrTree"; -"groupedByAOTree" -> "ruleDecisionGraph"; "itemsByRule" -> "getAndOrTree"; +"l4interpret" -> "attrsAsMethods"; "l4interpret" -> "classHierarchy"; "l4interpret" -> "symbolTable"; -"musings" -> "classGraph"; -"musings" -> "expandBSR"; -"musings" -> "expandRule"; -"musings" -> "exposedRoots"; -"musings" -> "getAndOrTree"; -"musings" -> "groupedByAOTree"; -"musings" -> "isRuleAlias"; -"musings" -> "ruleDecisionGraph"; "onlyItemNamed" -> "itemsByRule"; "onlyTheItems" -> "getAndOrTree"; +"qaHornsR" -> "expandBSR"; +"qaHornsR" -> "exposedRoots"; +"qaHornsR" -> "groupedByAOTree"; +"qaHornsT" -> "qaHornsR"; "relPredRefsAll" -> "relPredRefs"; "ruleDecisionGraph" -> "relPredRefsAll"; +"ruleLocals" -> "ruleLocalsIn"; +"ruleLocals" -> "ruleLocalsOut"; "topsortedClasses" -> "getAttrTypesIn"; "topsortedClasses" -> "getCTkeys"; "topsortedClasses" -> "getInheritances"; diff --git a/lib/haskell/natural4/doc/Interpreter.svg b/lib/haskell/natural4/doc/Interpreter.svg index d9bce4e61..03d6e3402 100644 --- a/lib/haskell/natural4/doc/Interpreter.svg +++ b/lib/haskell/natural4/doc/Interpreter.svg @@ -4,692 +4,687 @@ - - + + deps - + -cluster_2 - -src/LS/Interpreter.hs - - cluster_1 - -src/LS/XPile/SVG.hs + +src/LS/Interpreter.hs unleaf - -unleaf + +unleaf - + unleaf->unleaf - - + + topsortedClasses - -topsortedClasses + +topsortedClasses - + getInheritances - -getInheritances + +getInheritances - + topsortedClasses->getInheritances - - + + - + getCTkeys - -getCTkeys + +getCTkeys - + topsortedClasses->getCTkeys - - + + - + getAttrTypesIn - -getAttrTypesIn + +getAttrTypesIn - + topsortedClasses->getAttrTypesIn - - + + symbolTable - -symbolTable + +symbolTable - + -stitchRules - -stitchRules +ruleNameStr + +ruleNameStr - + -ruleNameStr - -ruleNameStr +ruleLocalsOut + +ruleLocalsOut - + +ruleLocalsIn + +ruleLocalsIn + + + +ruleLocals + +ruleLocals + + + +ruleLocals->ruleLocalsOut + + + + + +ruleLocals->ruleLocalsIn + + + + + ruleDecisionGraph - -ruleDecisionGraph + +ruleDecisionGraph - + relPredRefsAll - -relPredRefsAll + +relPredRefsAll - + ruleDecisionGraph->relPredRefsAll - - + + - + relPredRefs - -relPredRefs + +relPredRefs - + relPredRefsAll->relPredRefs - - - - - -onlyTheItems - -onlyTheItems + + - - -getAndOrTree - -getAndOrTree - - - -onlyTheItems->getAndOrTree - - - - - -onlyItemNamed - -onlyItemNamed - - - -itemsByRule - -itemsByRule - - - -onlyItemNamed->itemsByRule - - - - + -musings - -musings +qaHornsT + +qaHornsT - - -musings->ruleDecisionGraph - - - - - -isRuleAlias - -isRuleAlias + + +qaHornsR + +qaHornsR - - -musings->isRuleAlias - - + + +qaHornsT->qaHornsR + + - + groupedByAOTree - -groupedByAOTree + +groupedByAOTree - - -musings->groupedByAOTree - - - - - -musings->getAndOrTree - - + + +qaHornsR->groupedByAOTree + + - + exposedRoots - -exposedRoots - - - -musings->exposedRoots - - + +exposedRoots - - -expandRule - -expandRule - - - -musings->expandRule - - + + +qaHornsR->exposedRoots + + - + expandBSR - -expandBSR + +expandBSR - - -musings->expandBSR - - + + +qaHornsR->expandBSR + + - - -classGraph - -classGraph + + +onlyTheItems + +onlyTheItems - - -musings->classGraph - - + + +getAndOrTree + +getAndOrTree + + + +onlyTheItems->getAndOrTree + + + + + +onlyItemNamed + +onlyItemNamed + + + +itemsByRule + +itemsByRule + + + +onlyItemNamed->itemsByRule + + - + l4interpret - -l4interpret + +l4interpret - + l4interpret->symbolTable - - + + - + classHierarchy - -classHierarchy + +classHierarchy - + l4interpret->classHierarchy - - + + + + + +attrsAsMethods + +attrsAsMethods + + + +l4interpret->attrsAsMethods + + - + itemsByRule->getAndOrTree - - + + - - -groupedByAOTree->ruleDecisionGraph - - + + +isRuleAlias + +isRuleAlias - + groupedByAOTree->getAndOrTree - - - - - -decisionRoots - -decisionRoots + + - - -groupedByAOTree->decisionRoots - - + + +globalFacts + +globalFacts - + getRuleByName - -getRuleByName + +getRuleByName - + getRuleByLabelName - -getRuleByLabelName + +getRuleByLabelName - + getRuleByLabel - -getRuleByLabel + +getRuleByLabel + + + +getMarkings + +getMarkings - + getInheritances->getCTkeys - - + + + + + +defaultToSuperClass + +defaultToSuperClass + + + +getInheritances->defaultToSuperClass + + - + getAttrTypesIn->getCTkeys - - + + - + getAttrTypesIn->getAttrTypesIn - - + + - + getAndOrTree->getRuleByName - - + + - + getAndOrTree->getAndOrTree - - + + - + extractRPMT2Text - -extractRPMT2Text + +extractRPMT2Text - + getAndOrTree->extractRPMT2Text - - + + - + expandTrace - -expandTrace + +expandTrace - + getAndOrTree->expandTrace - - + + - + expandClauses - -expandClauses + +expandClauses - + getAndOrTree->expandClauses - - + + - + bsmtOfClauses - -bsmtOfClauses + +bsmtOfClauses - + getAndOrTree->bsmtOfClauses - - + + + + + +extractEnums + +extractEnums - + exposedRoots->ruleDecisionGraph - - + + - + exposedRoots->isRuleAlias - - + + + + + +decisionRoots + +decisionRoots - + exposedRoots->decisionRoots - - + + - + expandTraceDebugging - -expandTraceDebugging + +expandTraceDebugging - + expandTrace->expandTraceDebugging - - + + - + expandRulesByLabel - -expandRulesByLabel + +expandRulesByLabel + + + +expandRule + +expandRule - + expandRulesByLabel->expandRule - - + + - + expandRule->expandRulesByLabel - - + + - + expandRP - -expandRP - - - -expandRP->expandTrace - - + +expandRP - + expandMT - -expandMT + +expandMT - + expandRP->expandMT - - + + - + expandBSR\' - -expandBSR' + +expandBSR' - + expandRP->expandBSR\' - - - - - -expandMT->expandTrace - - + + - + expandClause - -expandClause + +expandClause - + expandMT->expandClause - - + + - + expandClauses\' - -expandClauses' + +expandClauses' - + expandClauses\'->unleaf - - + + - + expandClauses\'->expandTrace - - + + - + expandClauses\'->expandRP - - + + - + expandClauses->expandTrace - - + + - + expandClauses->expandClauses\' - - - - - -expandClause->expandTrace - - + + - + expandClause->expandBSR\' - - + + - + expandBody - -expandBody - - - -expandBSR\'->expandTrace - - + +expandBody - + expandBSR\'->expandRP - - + + - + expandBSR\'->expandBSR\' - - + + + + + +expandBSRM + +expandBSRM + + + +expandBSRM->expandBSR + + - + expandBSR->expandTrace - - + + - + expandBSR->expandBSR\' - - + + + + + +entryPoints + +entryPoints + + + +defaultToSuperType + +defaultToSuperType + + + +defaultToSuperType->defaultToSuperClass + + + + + +classHierarchy->defaultToSuperType + + - + classHierarchy->classHierarchy - - + + - - -classGraph->classGraph - - + + +classGraph + +classGraph - + bsr2bsmt - -bsr2bsmt + +bsr2bsmt - + bsr2bsmt->bsr2bsmt - - + + - + bsmtOfClauses->expandTrace - - + + - + bsmtOfClauses->expandClauses - - + + - + bsmtOfClauses->bsr2bsmt - - - - - -biggestItem - -biggestItem - - - -biggestItem->itemsByRule - - + + - + attrType - -attrType + +attrType - + allCTkeys - -allCTkeys + +allCTkeys allCTkeys->getCTkeys - - + + allCTkeys->allCTkeys - - - - - -asAAsvg - -asAAsvg - - - -asAAsvg->isRuleAlias - - - - - -asAAsvg->groupedByAOTree - - - - - -asAAsvg->exposedRoots - - - - - -asAAsvg->expandBSR - - + + diff --git a/lib/haskell/natural4/grammars/CustomSyntax.gf b/lib/haskell/natural4/grammars/CustomSyntax.gf index 4cafe558a..fc3928d5e 100644 --- a/lib/haskell/natural4/grammars/CustomSyntax.gf +++ b/lib/haskell/natural4/grammars/CustomSyntax.gf @@ -1,30 +1,34 @@ abstract CustomSyntax = Numeral , Grammar [ - N, N2, CN, UseN, NP, Det, DetCN, MassNP - , V, VV, V2, VS, VP - , A, A2, AP, AdjCN, PositA + N, N2, CN, PN, NP, UseN, ComplN2, UsePN, Num, NumSg, NumPl, Det, DetCN, MassNP + , V, VV, V2, VS, VP, UseV + , A, A2, AP, AdjCN, PositA, ComplA2 , Comp, Adv, VP, UseComp, CompNP, CompAP, CompAdv -- is a public agency , Prep, PrepNP, AdvVP - , AdA, AdAdv + , AdA, AdAdv, Card, CAdv, AdN, AdNum, AdnCAdv + , Dig, Digits, NumDigits, IDig, IIDig, D_0, D_1, D_2, D_3, D_4, D_5, D_6, D_7, D_8, D_9 , ListAdv, BaseAdv, ConsAdv, ConjAdv , ListAP, BaseAP, ConsAP, ConjAP , ListNP, BaseNP, ConsNP, ConjNP , ListS, BaseS, ConsS, ConjS - , S, QS, Conj + , S, QS, Conj, Subj, SubjS + , RS, RP, IdRP, RelCN ] , Structural [ Prep, to_Prep, for_Prep, from_Prep, on_Prep, before_Prep, after_Prep, possess_Prep , VV, must_VV + , AdN, CAdv, less_CAdv, more_CAdv, at_least_AdN, at_most_AdN + , Subj, because_Subj ] , Extend [ VPS, MkVPS, ListVPS, BaseVPS, ConsVPS, ConjVPS , VPI, MkVPI --, [VPI], BaseVPI, ConsVPI, ConjVPI , VP, Tense, Ant, Temp, Pol, Conj -- for VPS -- , GenRP -- nice to have in the future? - , ByVP - , S, PredVPS - , NP, GerundNP + , ByVP, N, CompoundN + , S, PredVPS, RelVPS + , NP, GerundNP, Num, GenModNP ] ** { ----------------------------------------------------------------------------- @@ -55,7 +59,9 @@ abstract CustomSyntax = MayHave : VP -> VPS ; -- getting "may have occurred" with pure RGL is a pain ReferenceNP : NP -> S ; -- it is NP — reference to a previous NP + WhileDoing : VP -> Adv ; -- while travelling in a public transport -- ExpletiveVP : VP -> S ; -- it is raining — dummy subject it (TODO: restrict usage of this and above from HS) + CNwhereS : CN -> NP -> VPS -> CN ; -- premise where school activities take place presAnt, -- has occurred presSimul, -- occurs @@ -68,6 +74,7 @@ abstract CustomSyntax = theSg : Det ; thePl : Det ; aSg : Det ; + aPl : Det ; your : Det ; about_Prep : Prep ; diff --git a/lib/haskell/natural4/grammars/CustomSyntaxChi.gf b/lib/haskell/natural4/grammars/CustomSyntaxChi.gf index 3d438b113..c6ae01f99 100644 --- a/lib/haskell/natural4/grammars/CustomSyntaxChi.gf +++ b/lib/haskell/natural4/grammars/CustomSyntaxChi.gf @@ -1,27 +1,31 @@ concrete CustomSyntaxChi of CustomSyntax = NumeralChi , GrammarChi [ - N, N2, CN, UseN, NP, Det, DetCN, MassNP - , V, VV, V2, VS, VP, AdvVP + N, N2, CN, PN, NP, UseN, ComplN2, UsePN, Num, NumSg, NumPl, Det, DetCN, MassNP + , V, VV, V2, VS, VP, UseV, AdvVP , A, A2, AP, PositA , Comp, Adv, VP, UseComp, CompAP, CompAdv -- is a public agency - , AdA, AdAdv -- only (within the organisation) + , AdA, AdAdv, Card, CAdv, AdN, AdNum, AdnCAdv + , Dig, Digits, NumDigits, IDig, IIDig, D_0, D_1, D_2, D_3, D_4, D_5, D_6, D_7, D_8, D_9 -- only (within the organisation) , ListAdv, BaseAdv, ConsAdv, ConjAdv , ListAP, BaseAP, ConsAP, ConjAP , ListNP, BaseNP, ConsNP, ConjNP , ListS, BaseS, ConsS, ConjS - , S, QS, Conj + , S, QS, Conj, Subj, SubjS + , RS, RP, IdRP, RelCN ] , StructuralChi [ VV, must_VV + , AdN, CAdv, less_CAdv, more_CAdv, at_least_AdN, at_most_AdN + , Subj, because_Subj ] , ExtendChi [ VPS, MkVPS, mkVPS, ListVPS, BaseVPS, ConsVPS, ConjVPS, baseVPS , VPI, MkVPI, mkVPI --, [VPI], BaseVPI, ConsVPI, ConjVPI , VP, Tense, Ant, Temp, Pol, Conj -- for VPS - , ByVP - , S, PredVPS - , NP, GerundNP -- by performing NDB qualification + , ByVP, N, CompoundN + , S, PredVPS, RelVPS + , NP, GerundNP, Num, GenModNP -- by performing NDB qualification ] ** open SyntaxChi diff --git a/lib/haskell/natural4/grammars/CustomSyntaxEng.gf b/lib/haskell/natural4/grammars/CustomSyntaxEng.gf index fa67649f8..82d970d27 100644 --- a/lib/haskell/natural4/grammars/CustomSyntaxEng.gf +++ b/lib/haskell/natural4/grammars/CustomSyntaxEng.gf @@ -1,29 +1,33 @@ concrete CustomSyntaxEng of CustomSyntax = NumeralEng , GrammarEng [ - N, N2, CN, UseN, NP, Det, DetCN, MassNP - , V, VV, V2, VS, VP - , A, A2, AP, AdjCN, PositA + N, N2, CN, PN, NP, UseN, ComplN2, UsePN, Num, NumSg, NumPl, Det, DetCN, MassNP + , V, VV, V2, VS, VP, UseV + , A, A2, AP, AdjCN, PositA, ComplA2 , Comp, Adv, VP, UseComp, CompAP, CompNP, CompAdv -- is a public agency , Prep, PrepNP, AdvVP - , AdA, AdAdv -- only (within the organisation) + , AdA, AdAdv, Card, CAdv, AdN, AdNum, AdnCAdv + , Dig, Digits, NumDigits, IDig, IIDig, D_0, D_1, D_2, D_3, D_4, D_5, D_6, D_7, D_8, D_9 -- only (within the organisation) , ListAdv, BaseAdv, ConsAdv, ConjAdv , ListAP, BaseAP, ConsAP, ConjAP , ListNP, BaseNP, ConsNP, ConjNP , ListS, BaseS, ConsS, ConjS - , S, QS, Conj + , S, QS, Conj, Subj, SubjS + , RS, RP, IdRP, RelCN ] , StructuralEng [ Prep, to_Prep, for_Prep, from_Prep, on_Prep, before_Prep, after_Prep, possess_Prep , VV, must_VV + , AdN, CAdv, less_CAdv, more_CAdv, at_least_AdN, at_most_AdN + , Subj, because_Subj ] , ExtendEng [ VPS, MkVPS, mkVPS, ListVPS, BaseVPS, ConsVPS, ConjVPS, baseVPS , VPI, MkVPI, mkVPI --, [VPI], BaseVPI, ConsVPI, ConjVPI , VP, Tense, Ant, Temp, Pol, Conj -- for VPS - , ByVP - , S, PredVPS - , NP, GerundNP -- by performing NDB qualification + , ByVP, N, CompoundN + , S, PredVPS, RelVPS + , NP, GerundNP, Num, GenModNP -- by performing NDB qualification ] ** open SyntaxEng @@ -94,6 +98,8 @@ concrete CustomSyntaxEng of CustomSyntax = in vps ** {s = \\_,_ => may_have_occurred} ; -- : NP -> S ; -- it is NP — reference to a previous NP ReferenceNP np = mkS (mkCl it_NP ) ; + WhileDoing vp = cc2 (ss "while") (GerundAdv vp) ; + CNwhereS cn np vps = SentCN cn (cc2 (ss "where") (PredVPS np vps)) ; presSimul = mkTemp presentTense simultaneousAnt ; presAnt = mkTemp presentTense anteriorAnt ; @@ -104,6 +110,7 @@ concrete CustomSyntaxEng of CustomSyntax = theSg = theSg_Det ; thePl = thePl_Det ; aSg = aSg_Det ; + aPl = aPl_Det ; your = mkDet youSg_Pron ; about_Prep = ParadigmsEng.mkPrep "about" ; diff --git a/lib/haskell/natural4/grammars/CustomSyntaxMay.gf b/lib/haskell/natural4/grammars/CustomSyntaxMay.gf index 2b4b6f25b..6798b3e58 100644 --- a/lib/haskell/natural4/grammars/CustomSyntaxMay.gf +++ b/lib/haskell/natural4/grammars/CustomSyntaxMay.gf @@ -1,30 +1,34 @@ concrete CustomSyntaxMay of CustomSyntax = NumeralMay , GrammarMay [ - N, N2, CN, UseN, NP, Det, DetCN, MassNP - , V, VV, V2, VS, VP - , A, A2, AP, AdjCN, PositA + N, N2, CN, PN, NP, UseN, ComplN2, UsePN, Num, NumSg, NumPl, Det, DetCN, MassNP + , V, VV, V2, VS, VP, UseV + , A, A2, AP, AdjCN, PositA, ComplA2 -- , ProgrVP -- becoming aware , Comp, Adv, VP, UseComp, CompAP, CompNP, CompAdv -- is a public agency , Prep, PrepNP, AdvVP - , AdA, AdAdv -- only (within the organisation) + , AdA, AdAdv, Card, CAdv, AdN, AdNum, AdnCAdv + , Dig, Digits, NumDigits, IDig, IIDig, D_0, D_1, D_2, D_3, D_4, D_5, D_6, D_7, D_8, D_9 -- only (within the organisation) , ListAdv, BaseAdv, ConsAdv, ConjAdv , ListAP, BaseAP, ConsAP, ConjAP , ListNP, BaseNP, ConsNP, ConjNP , ListS, BaseS, ConsS, ConjS - , S, QS, Conj + , S, QS, Conj, Subj, SubjS + , RS, RP, IdRP, RelCN ] , StructuralMay [ Prep, for_Prep, from_Prep, on_Prep, after_Prep, possess_Prep , VV, must_VV + , AdN, CAdv, less_CAdv, more_CAdv, at_least_AdN, at_most_AdN + , Subj, because_Subj ] , ExtendMay [ VPS, MkVPS, mkVPS, ListVPS, BaseVPS, ConsVPS, ConjVPS, baseVPS , VPI, MkVPI, mkVPI --, [VPI], BaseVPI, ConsVPI, ConjVPI , VP, Tense, Ant, Temp, Pol, Conj -- for VPS - , ByVP - , S, PredVPS - , NP, GerundNP -- by performing NDB qualification + , ByVP, N, CompoundN + , S, PredVPS, RelVPS + , NP, GerundNP, Num, GenModNP -- by performing NDB qualification ] ** open SyntaxMay diff --git a/lib/haskell/natural4/grammars/InsLex.gf b/lib/haskell/natural4/grammars/InsLex.gf new file mode 100644 index 000000000..8ea4a2908 --- /dev/null +++ b/lib/haskell/natural4/grammars/InsLex.gf @@ -0,0 +1,750 @@ +abstract InsLex = NL4Base ** { + fun + _ignore_consider_V2 : V2 ; + _Number_PN : PN ; + _note_V2 : V2 ; + _thing_N : N ; + _convert_to_V2 : V2 ; + _A_PN : PN ; + _detail_N : N ; + _earn_V2 : V2 ; + _appearance_N : N ; + _concrete_A : A ; + _Pru_PN : PN ; + _administrative_A : A ; + _natural4_N : N ; + _claim_from_V2 : V2 ; + _damage_N : N ; + _base_on_V2 : V2 ; + _overall_A : A ; + _encoding_N : N ; + _OverallPolicySum_PN : PN ; + _database_N : N ; + _Amount_N : N ; + _reinstatement_N : N ; + _A_N : N ; + _life_assured_N : N ; + _like_Prep : Prep ; + _PruAssure_PN : PN ; + _convert_V2 : V2 ; + _long_Adv : Adv ; + _remark_N : N ; + _involve_VS : VS ; + _represent_V2 : V2 ; + _Damage_N : N ; + _relate_to_V2 : V2 ; + _Pru_N : N ; + _cause_V : V ; + _subsection_N : N ; + _text_N : N ; + _cell_N : N ; + _Damage_PN : PN ; + _PruAssure_N : N ; + _end_V : V ; + _end_accord_V2 : V2 ; + _argument_N : N ; + _use_VV : VV ; + _describe_in_V2 : V2 ; + _about_Prep : Prep ; + _arise_V2 : V2 ; + _qualify_for_V2 : V2 ; + _directly_Adv : Adv ; + _OverallPolicySum_N : N ; + _Number_N : N ; + _update_N : N ; + _indirectly_Adv : Adv ; + _ph_PN : PN ; + _natural_A : A ; + _separate_A : A ; + _subsequent_A : A ; + _structure_N : N ; + _accord_to_V2 : V2 ; + _atomicity_N : N ; + _Amount_PN : PN ; + _income_N : N ; + _reward_N : N ; + _more_Adv : Adv ; + _datatype_N : N ; + _Hsi_N : N ; + _consider_V2 : V2 ; + _reach_V2 : V2 ; + _insurer_N : N ; + _whether_Subj : Subj ; + _handle_V2 : V2 ; + _renew_V2 : V2 ; + _ph_N : N ; + _no_Adv : Adv ; + _live_A : A ; + _capacity_N : N ; + _cover_N : N ; + _start_V2 : V2 ; + _so_Adv : Adv ; + _define_based_on_V2 : V2 ; + _exclude_from_V2 : V2 ; + _similar_A : A ; + _here_Adv : Adv ; + _demarcate_V2 : V2 ; + _underlie_V : V ; + _complex_A : A ; + _clause_N : N ; + _leg_N : N ; + _line_N : N ; + _SA_PN : PN ; + _contract_N : N ; + _b_N : N ; + _then_Adv : Adv ; + _Life_PN : PN ; + _subject_A : A ; + _state_N : N ; + _result_from_V2 : V2 ; + _up_Prep : Prep ; + _authority_N : N ; + _first_Adv : Adv ; + _plan1_N : N ; + _play_V2 : V2 ; + _organise_V : V ; + _hockey_N : N ; + _than_Prep : Prep ; + _date_N : N ; + _Republic_PN : PN ; + _between_Prep : Prep ; + _tsapp_N : N ; + _work_N : N ; + _planF_PN : PN ; + _while_Subj : Subj ; + _after_Prep : Prep ; + _mean_as_V2 : V2 ; + _Schedule_PN : PN ; + _mental_A : A ; + _total_A : A ; + _register_V : V ; + _1014_PN : PN ; + _surgical_A : A ; + _set_in_V2 : V2 ; + _canoe_V : V ; + _govern_V : V ; + _benefit_V : V ; + _tcm_N : N ; + _occur_before_V2 : V2 ; + _convenience_N : N ; + _exception_V : V ; + _benTCM_PN : PN ; + _address_N : N ; + _hearing_N : N ; + _sport_N : N ; + _verifier_N : N ; + _expense_N : N ; + _UPON_PN : PN ; + _first_A : A ; + _pedestrian_N : N ; + _license_V : V ; + _supervise_V : V ; + _airline_N : N ; + _assure_for_V2 : V2 ; + _from_Prep : Prep ; + _planB_PN : PN ; + _transport_N : N ; + _Influenza_PN : PN ; + _can_claim_add_N : N ; + _benfcpa_N : N ; + _military_N : N ; + _majority_N : N ; + _sssure_for_V2 : V2 ; + _lead_to_V2 : V2 ; + _minimum_N : N ; + _benefpaidout_N : N ; + _reasoner_N : N ; + _suffer_V : V ; + _planf_N : N ; + _time_N : N ; + _employee_N : N ; + _other_A : A ; + _benADD_PN : PN ; + _Leg_PN : PN ; + _try_VV : VV ; + _federation_N : N ; + _suffer_V2 : V2 ; + _policysubscription_N : N ; + _vehicle_N : N ; + _add_A : A ; + _revolution_N : N ; + _step_V2 : V2 ; + _firstclaimyear_N : N ; + _schedule_N : N ; + _limb_N : N ; + _treatment_N : N ; + _name_N : N ; + _within_Prep : Prep ; + _fractured_A : A ; + _assure_in_V2 : V2 ; + _pothole_V : V ; + _physical_A : A ; + _passenger_N : N ; + _met_common_requirement_for_add_V2 : V2 ; + _H7N_PN : PN ; + _step_N : N ; + _incurable_A : A ; + _transform_into_V2 : V2 ; + _Nipah_PN : PN ; + _maximum_A : A ; + _number_N : N ; + _birthdate_N : N ; + _happen_after_V2 : V2 ; + _H7N9_PN : PN ; + _y_PN : PN ; + _hrr_N : N ; + _plan_N : N ; + _Type_PN : PN ; + _successful_A : A ; + _skydive_V : V ; + _auditorium_N : N ; + _sail_V : V ; + _tcmpb_N : N ; + _into_Prep : Prep ; + _as_Adv : Adv ; + _mean_VS : VS ; + _define_V2 : V2 ; + _death_N : N ; + _life_assured_die_N : N ; + _occur_during_V2 : V2 ; + _commercial_A : A ; + _dc_N : N ; + _injury_N : N ; + _self_injury_N : N ; + _active_A : A ; + _money_N : N ; + _bicycle_N : N ; + _Accident_PN : PN ; + _eligibility_N : N ; + _patella_N : N ; + _Reductions_PN : PN ; + _Accidental_PN : PN ; + _year_N : N ; + _only_Adv : Adv ; + _mountaineer_V : V ; + _relevant_A : A ; + _least_Adv : Adv ; + _assure_V : V ; + _due_A : A ; + _behaviour_N : N ; + _holder_PN : PN ; + _to_Prep : Prep ; + _planaf_N : N ; + _equal_A : A ; + _plan3_PN : PN ; + _disease_N : N ; + _Expense_PN : PN ; + _hotel_N : N ; + _occur_at_V2 : V2 ; + _have_V2 : V2 ; + _kind_N : N ; + _CN_of_any_kind_CN : CN -> CN ; + _benefit_N : N ; + _task_N : N ; + _Disease_PN : PN ; + _part_N : N ; + _bus_N : N ; + _rule_N : N ; + _pregnancy_N : N ; + _cost_N : N ; + _sumassure_V : V ; + _alcohol_N : N ; + _n_N : N ; + _assure_per_V2 : V2 ; + _parachute_V : V ; + _confinement_N : N ; + _mall_N : N ; + _fully_Adv : Adv ; + _act_N : N ; + _geographical_A : A ; + _less_A : A ; + _attempt_N : N ; + _benADDs_PN : PN ; + _take_in_V2 : V2 ; + _weapon_N : N ; + _dangerous_weapon_N : N ; + _payable_A : A ; + _exception_N : N ; + _N_PN : PN ; + _past_A : A ; + _p_PN : PN ; + _diving_PN : PN ; + _TABLE_PN : PN ; + _registered_A : A ; + _H7N7_V : V ; + _lens_N : N ; + _establish_V : V ; + _box_in_V2 : V2 ; + _1012_PN : PN ; + _hernia_N : N ; + _for_Prep : Prep ; + _adjust_for_V2 : V2 ; + _risk_N : N ; + _save_V2 : V2 ; + _burn_N : N ; + _possible_A : A ; + _basic_A : A ; + _pland_Adv : Adv ; + _register_with_V2 : V2 ; + _suicide_N : N ; + _stepupsumassure_V : V ; + _declare_VS : VS ; + _diagnosis_N : N ; + _month_N : N ; + _Details_PN : PN ; + _radiation_N : N ; + _motocross_PN : PN ; + _Ministry_PN : PN ; + _cover_in_V2 : V2 ; + _degree_N : N ; + _third_A : A ; + _nuclear_A : A ; + _sustain_V2 : V2 ; + _phalanx_N : N ; + _use_N : N ; + _sum_N : N ; + _make_within_V2 : V2 ; + _circumstance_N : N ; + _customer_N : N ; + _met_common_requirement_for_add_V : V ; + _Accidents_PN : PN ; + _life_assured_suffers_injury_does_not_die_within_30_day_N : N ; + _infectious_A : A ; + _pay_for_V2 : V2 ; + _per_Prep : Prep ; + _fire_N : N ; + _form_N : N ; + _claim_for_V2 : V2 ; + _get_from_V2 : V2 ; + _suffer_in_V2 : V2 ; + _toe_N : N ; + _fare_N : N ; + _exercise_N : N ; + _totally_Adv : Adv ; + _fever_N : N ; + _up_Adv : Adv ; + _ear_N : N ; + _insanity_N : N ; + _tail_N : N ; + _normal_A : A ; + _Plan14_PN : PN ; + _Claim_PN : PN ; + _across_Prep : Prep ; + _defect_N : N ; + _cover_V2 : V2 ; + _Yellow_PN : PN ; + _predicate_N : N ; + _private_A : A ; + _question_N : N ; + _Health_PN : PN ; + _shortening_N : N ; + _lose_V2 : V2 ; + _riot_N : N ; + _nature_N : N ; + _outcome_N : N ; + _way_N : N ; + _on_its_way_Adv : Adv ; + _Injury_PN : PN ; + _hand_N : N ; + _CoV_PN : PN ; + _previous_A : A ; + _low_A : A ; + _damagetype_N : N ; + _activity_N : N ; + _planC_PN : PN ; + _foot_N : N ; + _radioactivity_N : N ; + _Triple_PN : PN ; + _benmr_N : N ; + _333A_PN : PN ; + _eye_N : N ; + _home_N : N ; + _asssure_V : V ; + _virus_N : N ; + _drug_N : N ; + _polilcy_N : N ; + _car_N : N ; + _M_PN : PN ; + _mind_N : N ; + _m_N : N ; + _stepuppercentage_N : N ; + _include_V2 : V2 ; + _Event_PN : PN ; + _start_N : N ; + _policy_N : N ; + _1013_PN : PN ; + _Medicine_PN : PN ; + _accident_N : N ; + _possibility_N : N ; + _human_A : A ; + _payout_N : N ; + _school_N : N ; + _during_Prep : Prep ; + _addpercentageforinjury_N : N ; + _Cap_PN : PN ; + _sum_list_PN : PN ; + _viral_A : A ; + _place_N : N ; + _mean_V2 : V2 ; + _vcjd_N : N ; + _hence_Adv : Adv ; + _with_Prep : Prep ; + _that_Subj : Subj ; + _cave_V : V ; + _policyholder_N : N ; + _middle_A : A ; + _Subscribed_PN : PN ; + _string_N : N ; + _pland_N : N ; + _high_A : A ; + _pay_V2 : V2 ; + _Insurer_PN : PN ; + _adjustment_N : N ; + _give_V2 : V2 ; + _logical_A : A ; + _triple_A : A ; + _timeyear_N : N ; + _Adjustment_PN : PN ; + _dTime_PN : PN ; + _e_N : N ; + _lose_through_V2 : V2 ; + _cm_N : N ; + _biological_A : A ; + _recognise_V : V ; + _HAS_PN : PN ; + _scuba_diving_N : N ; + _before_Subj : Subj ; + _adjusted_A : A ; + _MIN_PN : PN ; + _Types_PN : PN ; + _day_N : N ; + _MR_PN : PN ; + _apply_V : V ; + _Date_PN : PN ; + _benRA_PN : PN ; + _life_N : N ; + _dangerous_A : A ; + _x_PN : PN ; + _japanese_A : A ; + _union_N : N ; + _policyHolder_PN : PN ; + _claim_N : N ; + _association_N : N ; + _case_N : N ; + _head_N : N ; + _upscaled_A : A ; + _martial_A : A ; + _if_Subj : Subj ; + _valid_A : A ; + _soon_Adv : Adv ; + _strain_N : N ; + _PolicyHolder_PN : PN ; + _speech_N : N ; + _y_N : N ; + _event_N : N ; + _at_Adv : Adv ; + _c_N : N ; + _Dismemberment_PN : PN ; + _1013_N : N ; + _both_Subj : Subj ; + _v_N : N ; + _include_V : V ; + _unsound_A : A ; + _thumb_N : N ; + _Removal_PN : PN ; + _amount_N : N ; + _addsa_N : N ; + _permanently_Adv : Adv ; + _chemical_A : A ; + _Melioidosis_PN : PN ; + _circ_PN : PN ; + _Benefit_PN : PN ; + _particular_A : A ; + _participate_in_V2 : V2 ; + _planAF_PN : PN ; + _at_Prep : Prep ; + _accepted_A : A ; + _war_N : N ; + _adjust_V : V ; + _or_Subj : Subj ; + _duty_N : N ; + _finger_N : N ; + _deduce_VS : VS ; +-- _occur_V : V ; + _accidental_A : A ; + _medical_A : A ; + _cover_V : V ; + _ponder_V2 : V2 ; + _mean_V : V ; + _climbing_N : N ; + _theatre_N : N ; + _Wife_PN : PN ; + _Service_PN : PN ; + _illness_N : N ; + _hospital_N : N ; + _more_A : A ; + _claimant_N : N ; + _unnecessary_A : A ; + _H5N1_PN : PN ; + _premise_N : N ; + _premise_where_N2 : N2 ; + _operation_N : N ; + _give_V : V ; + _ps_N : N ; + _LE_PN : PN ; + _RETURN_PN : PN ; + _under_Prep : Prep ; + _BSA_PN : PN ; + _unsuccessful_A : A ; + _Head_PN : PN ; + _die_from_V2 : V2 ; + _hand_V : V ; + _Legionnaires_PN : PN ; + _contamination_N : N ; + _when_Subj : Subj ; + _section_N : N ; + _Section_PN : PN ; + _removal_N : N ; + _traditional_A : A ; + _claim_V : V ; + _disabled_A : A ; + _non_N : N ; + _condition_N : N ; + _disability_N : N ; + _SG_PN : PN ; + _polo_N : N ; + _military_A : A ; + _Ontology_PN : PN ; + _hang_VV : VV ; + _through_Prep : Prep ; + _PlanAF_PN : PN ; + _refund_V2 : V2 ; + _hfmd_A : A ; + _PS_PN : PN ; + _terrorism_N : N ; + _have_give_V2 : V2 ; + _unlawful_A : A ; + _H9N2_PN : PN ; + _AIDS_PN : PN ; + _involve_V2 : V2 ; + _involving_Prep : Prep ; + _person_N : N ; + _double_A : A ; + _physician_N : N ; + _add_N : N ; + _police_N : N ; + _LA_PN : PN ; + _competitive_A : A ; + _jaw_N : N ; + _H7N7_N : N ; + _Death_PN : PN ; + _policyholder_V : V ; + _Teeth_PN : PN ; + _bool_N : N ; + _benefit_V2 : V2 ; + _race_V : V ; + _regulation_N : N ; + _of_Prep : Prep ; + _husband_N : N ; + _competition_N : N ; + _planE_PN : PN ; + _by_Prep : Prep ; + _declaration_N : N ; + _incident_N : N ; + _dead_A : A ; + _type_N : N ; + _aircraft_N : N ; + _Limit_PN : PN ; + _little_A : A ; + _waterborne_A : A ; + _p_N : N ; + _damageevent_N : N ; + _and_Subj : Subj ; + _Policy_PN : PN ; + _national_A : A ; + _cover_as_V2 : V2 ; + _assure_of_V2 : V2 ; + _acc_injury_or_death_happens_within_12_mos_of_accident_N : N ; + _infection_N : N ; + _claim_V2 : V2 ; + _Flu_PN : PN ; + _pay_as_V2 : V2 ; + _travel_as_V2 : V2 ; + _h7n9_N : N ; + _age_N : N ; + _hear_in_V2 : V2 ; + _MAP_PN : PN ; + _professional_A : A ; + _assure_across_V2 : V2 ; + _diagnose_with_V2 : V2 ; + _assure_V2 : V2 ; + _multiple_A : A ; + _glide_V : V ; + _current_A : A ; + _plan4_PN : PN ; + _vessel_N : N ; + _racing_N : N ; + _fit_N : N ; + _located_in_A2 : A2 ; + _percentage_N : N ; + _service_N : N ; + _Singapore_PN : PN ; + _in_Prep : Prep ; + _Step_PN : PN ; + _body_N : N ; + _out_Prep : Prep ; + _plana_N : N ; + _subscribe_V : V ; + _Mumps_PN : PN ; + _over_Prep : Prep ; + _sight_N : N ; + _description_N : N ; + _travel_in_V2 : V2 ; + _great_A : A ; + _practitioner_N : N ; + _loss_N : N ; + _training_N : N ; + _as_Prep : Prep ; + _take_V2 : V2 ; + _public_A : A ; + _train_V : V ; + _result_N : N ; + _limit_N : N ; + _windsurf_V : V ; + _area_N : N ; + _reckless_A : A ; + _list_N : N ; + _on_Prep : Prep ; + _as_Subj : Subj ; + _holder_N : N ; + _alive_A : A ; + _juvenile_A : A ; + _intentional_A : A ; + _permanent_A : A ; + _d_N : N ; + _riding_N : N ; + _Conditions_PN : PN ; + _reduction_N : N ; + _claimable_A : A ; + _addSA_PN : PN ; + _pay_V : V ; + _wrestle_in_V2 : V2 ; + _start_VS : VS ; + _tooth_N : N ; + _declare_V2 : V2 ; + _initial_A : A ; + _hunt_V : V ; + _but_Subj : Subj ; + _Assured_PN : PN ; + _ADD_PN : PN ; + _f_N : N ; + _travel_by_N2 : N2 ; + _qualifies_for_add_PN : PN ; + _member_N : N ; + _happen_within_V2 : V2 ; + _Address_PN : PN ; + _circumstancedescription_N : N ; + _dType_PN : PN ; + _schema_PN : PN ; +-- some PNs as Ns + _1012_N : N ; + _1014_N : N ; + _333A_N : N ; + _ADD_N : N ; + _AIDS_N : N ; + _Accident_N : N ; + _Accidental_N : N ; + _Accidents_N : N ; + _Address_N : N ; + _Adjustment_N : N ; + _Assured_N : N ; + _BSA_N : N ; + _Benefit_N : N ; + _Cap_N : N ; + _Claim_N : N ; + _CoV_N : N ; + _Conditions_N : N ; + _Date_N : N ; + _Death_N : N ; + _Details_N : N ; + _Disease_N : N ; + _Dismemberment_N : N ; + _Event_N : N ; + _Expense_N : N ; + _Flu_N : N ; + _H5N1_N : N ; + _H7N9_N : N ; + _H7N_N : N ; + _H9N2_N : N ; + _HAS_N : N ; + _Head_N : N ; + _Health_N : N ; + _Influenza_N : N ; + _Injury_N : N ; + _Insurer_N : N ; + _LA_N : N ; + _LE_N : N ; + _Leg_N : N ; + _Legionnaires_N : N ; + _Life_N : N ; + _Limit_N : N ; + _MAP_N : N ; + _MIN_N : N ; + _MR_N : N ; + _M_N : N ; + _Medicine_N : N ; + _Melioidosis_N : N ; + _Ministry_N : N ; + _Mumps_N : N ; + _N_N : N ; + _Nipah_N : N ; + _Ontology_N : N ; + _PS_N : N ; + _Plan14_N : N ; + _PlanAF_N : N ; + _PolicyHolder_N : N ; + _Policy_N : N ; + _RETURN_N : N ; + _Reductions_N : N ; + _Removal_N : N ; + _Republic_N : N ; + _SA_N : N ; + _SG_N : N ; + _Schedule_N : N ; + _Section_N : N ; + _Service_N : N ; + _Singapore_N : N ; + _Step_N : N ; + _Subscribed_N : N ; + _TABLE_N : N ; + _Teeth_N : N ; + _Triple_N : N ; + _Type_N : N ; + _Types_N : N ; + _UPON_N : N ; + _Wife_N : N ; + _Yellow_N : N ; + _addSA_N : N ; + _benADD_N : N ; + _benADDs_N : N ; + _benRA_N : N ; + _benTCM_N : N ; + _circ_N : N ; + _dTime_N : N ; + _dType_N : N ; + _diving_N : N ; + _motocross_N : N ; + _plan3_N : N ; + _plan4_N : N ; + _planAF_N : N ; + _planB_N : N ; + _planC_N : N ; + _planE_N : N ; + _planF_N : N ; + _policyHolder_N : N ; + _qualifies_for_add_N : N ; + _schema_N : N ; + _sum_list_N : N ; + _x_N : N ; + +} \ No newline at end of file diff --git a/lib/haskell/natural4/grammars/InsLexEng.gf b/lib/haskell/natural4/grammars/InsLexEng.gf new file mode 100644 index 000000000..e7b28510e --- /dev/null +++ b/lib/haskell/natural4/grammars/InsLexEng.gf @@ -0,0 +1,749 @@ +concrete InsLexEng of InsLex = NL4BaseEng ** + open ParadigmsEng, Prelude, GrammarEng in { + oper mkSubj : Str -> Subj = \s -> lin Subj (ss s) ; + lin _ignore_consider_V2 = mkV2 (mkV "ignore") (mkPrep "consider") ; + lin _Number_PN = mkPN "Number" ; + lin _note_V2 = mkV2 (mkV "note") ; + lin _thing_N = mkN "thing" ; + lin _convert_to_V2 = mkV2 (mkV "convert") (mkPrep "to") ; + lin _A_PN = mkPN "A" ; + lin _detail_N = mkN "detail" ; + lin _earn_V2 = mkV2 (mkV "earn") ; + lin _appearance_N = mkN "appearance" ; + lin _concrete_A = mkA "concrete" ; + lin _Pru_PN = mkPN "Pru" ; + lin _administrative_A = mkA "administrative" ; + lin _natural4_N = mkN "natural4" ; + lin _claim_from_V2 = mkV2 (mkV "claim") (mkPrep "from") ; + lin _damage_N = mkN "damage" ; + lin _base_on_V2 = mkV2 (mkV "base") (mkPrep "on") ; + lin _overall_A = mkA "overall" ; + lin _encoding_N = mkN "encoding" ; + lin _OverallPolicySum_PN = mkPN "OverallPolicySum" ; + lin _database_N = mkN "database" ; + lin _Amount_N = mkN "Amount" ; + lin _reinstatement_N = mkN "reinstatement" ; + lin _A_N = mkN "A" ; + lin _like_Prep = mkPrep "like" ; + lin _PruAssure_PN = mkPN "PruAssure" ; + lin _convert_V2 = mkV2 (mkV "convert") ; + lin _long_Adv = mkAdv "long" ; + lin _remark_N = mkN "remark" ; + lin _involve_VS = mkVS (mkV "involve") ; + lin _represent_V2 = mkV2 (mkV "represent") ; + lin _Damage_N = mkN "Damage" ; + lin _relate_to_V2 = mkV2 (mkV "relate") (mkPrep "to") ; + lin _Pru_N = mkN "Pru" ; + lin _cause_V = mkV "cause" ; + lin _subsection_N = mkN "subsection" ; + lin _text_N = mkN "text" ; + lin _cell_N = mkN "cell" ; + lin _Damage_PN = mkPN "Damage" ; + lin _PruAssure_N = mkN "PruAssure" ; + lin _end_V = mkV "end" ; + lin _end_accord_V2 = mkV2 (mkV "end") (mkPrep "accord") ; + lin _argument_N = mkN "argument" ; + lin _use_VV = mkVV (mkV "use") ; + lin _describe_in_V2 = mkV2 (mkV "describe") (mkPrep "in") ; + lin _about_Prep = mkPrep "about" ; + lin _arise_V2 = mkV2 (mkV "arise") ; + lin _qualify_for_V2 = mkV2 (mkV "qualify") (mkPrep "for") ; + lin _directly_Adv = mkAdv "directly" ; + lin _OverallPolicySum_N = mkN "OverallPolicySum" ; + lin _Number_N = mkN "Number" ; + lin _update_N = mkN "update" ; + lin _indirectly_Adv = mkAdv "indirectly" ; + lin _ph_PN = mkPN "ph" ; + lin _natural_A = mkA "natural" ; + lin _separate_A = mkA "separate" ; + lin _subsequent_A = mkA "subsequent" ; + lin _structure_N = mkN "structure" ; + lin _accord_to_V2 = mkV2 (mkV "accord") (mkPrep "to") ; + lin _atomicity_N = mkN "atomicity" ; + lin _Amount_PN = mkPN "Amount" ; + lin _income_N = mkN "income" ; + lin _reward_N = mkN "reward" ; + lin _more_Adv = mkAdv "more" ; + lin _datatype_N = mkN "datatype" ; + lin _consider_V2 = mkV2 (mkV "consider") ; + lin _reach_V2 = mkV2 (mkV "reach") ; + lin _insurer_N = mkN "insurer" ; + lin _whether_Subj = mkSubj "whether" ; + lin _handle_V2 = mkV2 (mkV "handle") ; + lin _renew_V2 = mkV2 (mkV "renew") ; + lin _ph_N = mkN "ph" ; + lin _no_Adv = mkAdv "no" ; + lin _live_A = mkA "//,,,live" ; + lin _capacity_N = mkN "capacity" ; + lin _cover_N = mkN "cover" ; + lin _start_V2 = mkV2 (mkV "start") ; + lin _so_Adv = mkAdv "so" ; + lin _define_based_on_V2 = mkV2 (mkV "define") (mkPrep "based on") ; + lin _exclude_from_V2 = mkV2 (mkV "exclude") (mkPrep "from") ; + lin _similar_A = mkA "similar" ; + lin _here_Adv = mkAdv "here" ; + lin _demarcate_V2 = mkV2 (mkV "demarcate") ; + lin _underlie_V = mkV "underlie" ; + lin _complex_A = mkA "complex" ; + lin _clause_N = mkN "clause" ; + lin _practitioner_N = mkN "practitioner" ; + lin _insanity_N = mkN "insanity" ; + lin _plan_N = mkN "plan" ; + lin _amount_N = mkN "amount" ; + lin _SA_PN = mkPN "SA" ; + lin _cover_as_V2 = mkV2 (us_britishV "cover") (mkPrep "as") ; + lin _govern_V = us_britishV "govern" ; + lin _auditorium_N = mkN "auditorium" ; + lin _Health_PN = mkPN "Health" ; + lin _nuclear_A = mkA "nuclear" ; + lin _question_N = mkN "question" ; + lin _permanently_Adv = mkAdv "permanently" ; + lin _Nipah_PN = mkPN "Nipah" ; + lin _hospital_N = mkN "hospital" ; + lin _take_in_V2 = mkV2 (us_britishV "take") (mkPrep "in") ; + lin _asssure_V = us_britishV "asssure" ; + lin _Schedule_PN = mkPN "Schedule" ; + lin _disability_N = mkN "disability" ; + lin _addSA_PN = mkPN "addSA" ; + lin _cover_in_V2 = mkV2 (us_britishV "cover") (mkPrep "in") ; + lin _juvenile_A = mkA "juvenile" ; + lin _state_N = mkN "state" ; + lin _tail_N = mkN "tail" ; + lin _home_N = mkN "home" ; + lin _speech_N = mkN "speech" ; + lin _Disease_PN = mkPN "Disease" ; + lin _event_N = mkN "event" ; + lin _box_in_V2 = mkV2 (us_britishV "box") (mkPrep "in") ; + lin _or_Subj = mkSubj "or" ; + lin _martial_A = mkA "martial" ; + lin _b_N = mkN "b" ; + lin _LE_PN = mkPN "LE" ; + lin _Type_PN = mkPN "Type" ; + lin _medical_A = mkA "medical" ; + lin _suffer_V = us_britishV "suffer" ; + lin _benefit_V = us_britishV "benefit" ; + lin _thumb_N = mkN "thumb" ; + lin _that_Subj = mkSubj "that" ; + lin _pay_as_V2 = mkV2 (us_britishV "pay") (mkPrep "as") ; + lin _active_A = mkA "active" ; + lin _into_Prep = mkPrep "into" ; + lin _Injury_PN = mkPN "Injury" ; + lin _behaviour_N = mkN "behaviour" ; + lin _planAF_PN = mkPN "planAF" ; + lin _illness_N = mkN "illness" ; + lin _at_Prep = mkPrep "at" ; + lin _unsound_A = mkA "unsound" ; + lin _can_claim_add_N = mkN "can_claim_add" ; + lin _stepupsumassure_V = us_britishV "stepupsumassure" ; + lin _possible_A = mkA "possible" ; + lin _training_N = mkN "training" ; + lin _step_N = mkN "step" ; + lin _benRA_PN = mkPN "benRA" ; + lin _body_N = mkN "body" ; + lin _tooth_N = mkN "tooth" ; + lin _up_Adv = mkAdv "up" ; + lin _strain_N = mkN "strain" ; + lin _war_N = mkN "war" ; + lin _public_A = mkA "public" ; + lin _totally_Adv = mkAdv "totally" ; + lin _reckless_A = mkA "reckless" ; + lin _reduction_N = mkN "reduction" ; + lin _removal_N = mkN "removal" ; + lin _sport_N = mkN "sport" ; + lin _weapon_N = mkN "weapon" ; + lin _dangerous_weapon_N = mkN "nuclear, biological or chemical weapon" ; + lin _middle_A = mkA "middle" ; + lin _MAP_PN = mkPN "MAP" ; + lin _UPON_PN = mkPN "UPON" ; + lin _act_N = mkN "act" ; + lin _outcome_N = mkN "outcome" ; + lin _pregnancy_N = mkN "pregnancy" ; + lin _hand_V = us_britishV "hand" ; + lin _across_Prep = mkPrep "across" ; + lin _subscribe_V = us_britishV "subscribe" ; + lin _acc_injury_or_death_happens_within_12_mos_of_accident_N = mkN "acc_injury_or_death_happens_within_12_mos_of_accident" ; + lin _great_A = mkA "great" ; + lin _date_N = mkN "date" ; + lin _climbing_N = mkN "climbing" ; + lin _jaw_N = mkN "jaw" ; + lin _bus_N = mkN "bus" ; + lin _add_A = mkA "add" ; + lin _PolicyHolder_PN = mkPN "PolicyHolder" ; + lin _Teeth_PN = mkPN "Teeth" ; + lin _permanent_A = mkA "permanent" ; + lin _degree_N = mkN "degree" ; + lin _benmr_N = mkN "benmr" ; + lin _finger_N = mkN "finger" ; + lin _HAS_PN = mkPN "HAS" ; + lin _more_A = mkA "more" ; + lin _n_N = mkN "n" ; + lin _biological_A = mkA "biological" ; + lin _travel_as_V2 = mkV2 (us_britishV "travel") (mkPrep "as") ; + lin _happen_within_V2 = mkV2 (us_britishV "happen") (mkPrep "within") ; + lin _sumassure_V = us_britishV "sumassure" ; + lin _race_V = us_britishV "race" ; + lin _if_Subj = mkSubj "if" ; + lin _radioactivity_N = mkN "radioactivity" ; + lin _at_Adv = mkAdv "at" ; + lin _first_Adv = mkAdv "first" ; + lin _assure_V = us_britishV "assure" ; + lin _unnecessary_A = mkA "unnecessary" ; + lin _plan1_N = mkN "plan1" ; + lin _minimum_N = mkN "minimum" ; + lin _planC_PN = mkPN "planC" ; + lin _bicycle_N = mkN "bicycle" ; + lin _day_N = mkN "day" ; + lin _drug_N = mkN "drug" ; + lin _Removal_PN = mkPN "Removal" ; + lin _majority_N = mkN "majority" ; + lin _geographical_A = mkA "geographical" ; + lin _confinement_N = mkN "confinement" ; + lin _take_V2 = mkV2 (us_britishV "take") ; + lin _PS_PN = mkPN "PS" ; + lin _Accidents_PN = mkPN "Accidents" ; + lin _and_Subj = mkSubj "and" ; + lin _suffer_V2 = mkV2 (us_britishV "suffer") ; + lin _sum_N = mkN "sum" ; + lin _claim_V = us_britishV "claim" ; + lin _have_give_V2 = mkV2 (us_britishV "have") (mkPrep "give") ; + lin _customer_N = mkN "customer" ; + lin _1013_N = mkN "10.1.3" ; + lin _v_N = mkN "v" ; + lin _valid_A = mkA "valid" ; + lin _maximum_A = mkA "maximum" ; + lin _unlawful_A = mkA "unlawful" ; + lin _sail_V = us_britishV "sail" ; + lin _pay_V = us_britishV "pay" ; + lin _assure_across_V2 = mkV2 (us_britishV "assure") (mkPrep "across") ; + lin _sustain_V2 = mkV2 (us_britishV "sustain") ; + lin _while_Subj = mkSubj "while" ; + lin _register_with_V2 = mkV2 (us_britishV "register") (mkPrep "with") ; + lin _cave_V = us_britishV "cave" ; + lin _rule_N = mkN "rule" ; + lin _regulation_N = mkN "regulation" ; + lin _damagetype_N = mkN "damagetype" ; + lin _part_N = mkN "part" ; + lin _Legionnaires_PN = mkPN "Legionnaires" ; + lin _claim_N = mkN "claim" ; + lin _money_N = mkN "money" ; + lin _dTime_PN = mkPN "dTime" ; + lin _birthdate_N = mkN "birthdate" ; + lin _1013_PN = mkPN "10.1.3" ; + lin _benfcpa_N = mkN "benfcpa" ; + lin _than_Prep = mkPrep "than" ; + lin _add_N = mkN "add" ; + lin _little_A = mkA "little" ; + lin _as_Subj = mkSubj "as" ; + lin _mind_N = mkN "mind" ; + lin _claim_for_V2 = mkV2 (us_britishV "claim") (mkPrep "for") ; + lin _planaf_N = mkN "planaf" ; + lin _initial_A = mkA "initial" ; + lin _triple_A = mkA "triple" ; + lin _mean_V2 = mkV2 (us_britishV "mean") ; + lin _convenience_N = mkN "convenience" ; + lin _circumstancedescription_N = mkN "circumstancedescription" ; + lin _diving_PN = mkPN "diving" ; + lin _Benefit_PN = mkPN "Benefit" ; + lin _lose_through_V2 = mkV2 (us_britishV "lose") (mkPrep "through") ; + lin _up_Prep = mkPrep "up" ; + lin _japanese_A = mkA "japanese" ; + lin _car_N = mkN "car" ; + lin _upscaled_A = mkA "upscaled" ; + lin _RETURN_PN = mkPN "RETURN" ; + lin _H7N9_PN = mkPN "H7N9" ; + lin _claim_V2 = mkV2 (us_britishV "claim") ; + lin _hand_N = mkN "hand" ; + lin _adjust_for_V2 = mkV2 (us_britishV "adjust") (mkPrep "for") ; + lin _involve_V2 = mkV2 (us_britishV "involve") ; + lin _involving_Prep = mkPrep "involving" ; + lin _place_N = mkN "place" ; + lin _injury_N = mkN "injury" ; + lin _self_injury_N = mkN "self-injury" ; + lin _treatment_N = mkN "treatment" ; + lin _BSA_PN = mkPN "BSA" ; + lin _hrr_N = mkN "hrr" ; + lin _motocross_PN = mkPN "motocross" ; + lin _schema_PN = mkPN "schema" ; + lin _but_Subj = mkSubj "but" ; + lin _case_N = mkN "case" ; + lin _planf_N = mkN "planf" ; + lin _h7n9_N = mkN "h7n9" ; + lin _on_its_way_Adv = ParadigmsEng.mkAdv "on its way" ; + lin _way_N = mkN "way" ; + lin _Medicine_PN = mkPN "Medicine" ; + lin _result_N = mkN "result" ; + lin _less_A = mkA "less" ; + lin _percentage_N = mkN "percentage" ; + lin _scuba_diving_N = mkN "scuba diving" ; + lin _Types_PN = mkPN "Types" ; + lin _revolution_N = mkN "revolution" ; + lin _physician_N = mkN "physician" ; + lin _use_N = mkN "use" ; + lin _third_A = mkA "third" ; + lin _first_A = mkA "first" ; + lin _circ_PN = mkPN "circ" ; + lin _travel_by_N2 = mkN2 (mkN "travel") (mkPrep "by") ; + lin _burn_N = mkN "burn" ; + lin _shortening_N = mkN "shortening" ; + lin _wrestle_in_V2 = mkV2 (us_britishV "wrestle") (mkPrep "in") ; + lin _set_in_V2 = mkV2 (us_britishV "set") (mkPrep "in") ; + lin _Date_PN = mkPN "Date" ; + lin _windsurf_V = us_britishV "windsurf" ; + lin _travel_in_V2 = mkV2 (us_britishV "travel") (mkPrep "in") ; + lin _Adjustment_PN = mkPN "Adjustment" ; + lin _benADDs_PN = mkPN "benADDs" ; + lin _aircraft_N = mkN "aircraft" ; + lin _current_A = mkA "current" ; + lin _husband_N = mkN "husband" ; + lin _Dismemberment_PN = mkPN "Dismemberment" ; + lin _successful_A = mkA "successful" ; + lin _viral_A = mkA "viral" ; + lin _equal_A = mkA "equal" ; + lin _qualifies_for_add_PN = mkPN "qualifies_for_add" ; + lin _contamination_N = mkN "contamination" ; + lin _bool_N = mkN "bool" ; + lin _as_Prep = mkPrep "as" ; + lin _virus_N = mkN "virus" ; + lin _parachute_V = us_britishV "parachute" ; + lin _low_A = mkA "low" ; + lin _competitive_A = mkA "competitive" ; + lin _hotel_N = mkN "hotel" ; + lin _Limit_PN = mkPN "Limit" ; + lin _register_V = us_britishV "register" ; + lin _alive_A = mkA "alive" ; + lin _fever_N = mkN "fever" ; + lin _theatre_N = mkN "theatre" ; + lin _claimable_A = mkA "claimable" ; + lin _after_Prep = mkPrep "after" ; + lin _normal_A = mkA "normal" ; + lin _declare_VS = mkVS (us_britishV "declare") ; + lin _with_Prep = mkPrep "with" ; + lin _Assured_PN = mkPN "Assured" ; + lin _deduce_VS = mkVS (us_britishV "deduce") ; + lin _relevant_A = mkA "relevant" ; + lin _lead_to_V2 = mkV2 (us_britishV "lead") (mkPrep "to") ; + lin _exercise_N = mkN "exercise" ; + lin _head_N = mkN "head" ; + lin _mental_A = mkA "mental" ; + lin _police_N = mkN "police" ; + lin _Leg_PN = mkPN "Leg" ; + lin _section_N = mkN "section" ; + lin _license_V = us_britishV "license" ; + lin _dead_A = mkA "dead" ; + lin _CoV_PN = mkPN "CoV" ; + lin _physical_A = mkA "physical" ; + lin _assure_for_V2 = mkV2 (us_britishV "assure") (mkPrep "for") ; + lin _apply_V = us_britishV "apply" ; + lin _basic_A = mkA "basic" ; + lin _policyholder_V = us_britishV "policyholder" ; + lin _traditional_A = mkA "traditional" ; + lin _Step_PN = mkPN "Step" ; + lin _holder_PN = mkPN "holder" ; + lin _lens_N = mkN "lens" ; + lin _die_from_V2 = mkV2 (us_britishV "die") (mkPrep "from") ; + lin _H5N1_PN = mkPN "H5N1" ; + lin _surgical_A = mkA "surgical" ; + lin _nature_N = mkN "nature" ; + lin _transform_into_V2 = mkV2 (us_britishV "transform") (mkPrep "into") ; + lin _only_Adv = mkAdv "only" ; + lin _benefit_V2 = mkV2 (us_britishV "benefit") ; + lin _fully_Adv = mkAdv "fully" ; + lin _MIN_PN = mkPN "MIN" ; + lin _step_V2 = mkV2 (us_britishV "step") ; + lin _terrorism_N = mkN "terrorism" ; + lin _commercial_A = mkA "commercial" ; + lin _include_V = us_britishV "include" ; + lin _name_N = mkN "name" ; + lin _hunt_V = us_britishV "hunt" ; + lin _PlanAF_PN = mkPN "PlanAF" ; + lin _operation_N = mkN "operation" ; + lin _333A_PN = mkPN "333A" ; + lin _previous_A = mkA "previous" ; + lin _give_V = us_britishV "give" ; + lin _other_A = mkA "other" ; + lin _addpercentageforinjury_N = mkN "addpercentageforinjury" ; + lin _line_N = mkN "line" ; + lin _activity_N = mkN "activity" ; + lin _adjust_V = us_britishV "adjust" ; + lin _eye_N = mkN "eye" ; + lin _Subscribed_PN = mkPN "Subscribed" ; + lin _x_PN = mkPN "x" ; + lin _hence_Adv = mkAdv "hence" ; + lin _occur_V = us_britishV "occur" ; + lin _Ontology_PN = mkPN "Ontology" ; + lin _start_N = mkN "start" ; + lin _Mumps_PN = mkPN "Mumps" ; + lin _string_N = mkN "string" ; + lin _plan4_PN = mkPN "plan4" ; + lin _alcohol_N = mkN "alcohol" ; + lin _H9N2_PN = mkPN "H9N2" ; + lin _organise_V = us_britishV "organise" ; + lin _benefit_N = mkN "benefit" ; + lin _type_N = mkN "type" ; + lin _waterborne_A = mkA "waterborne" ; + lin _when_Subj = mkSubj "when" ; + lin _non_N = mkN "non" ; + lin _high_A = mkA "high" ; + lin _Event_PN = mkPN "Event" ; + lin _occur_at_V2 = mkV2 (us_britishV "occur") (mkPrep "at") ; + lin _fit_N = mkN "fit" ; + lin _least_Adv = mkAdv "least" ; + lin _policysubscription_N = mkN "policysubscription" ; + lin _union_N = mkN "union" ; + lin _diagnose_with_V2 = mkV2 (us_britishV "diagnose") (mkPrep "with") ; + lin _risk_N = mkN "risk" ; + lin _define_V2 = mkV2 (us_britishV "define") ; + lin _met_common_requirement_for_add_V2 = mkV2 (us_britishV "met_common_requirement_for_add") ; + lin _defect_N = mkN "defect" ; + lin _polo_N = mkN "polo" ; + lin _policyHolder_PN = mkPN "policyHolder" ; + lin _Cap_PN = mkPN "Cap" ; + lin _tcmpb_N = mkN "tcmpb" ; + lin _pedestrian_N = mkN "pedestrian" ; + lin _fire_N = mkN "fire" ; + lin _Accidental_PN = mkPN "Accidental" ; + lin _Life_PN = mkPN "Life" ; + lin _assure_in_V2 = mkV2 (us_britishV "assure") (mkPrep "in") ; + lin _kind_N = mkN "kind" ; + lin _CN_of_any_kind_CN illness = AdvCN illness (ParadigmsEng.mkAdv "of any kind") ; + lin _double_A = mkA "double" ; + lin _claimant_N = mkN "claimant" ; + lin _suicide_N = mkN "suicide" ; + lin _Reductions_PN = mkPN "Reductions" ; + lin _occur_before_V2 = mkV2 (us_britishV "occur") (mkPrep "before") ; + lin _on_Prep = mkPrep "on" ; + lin _area_N = mkN "area" ; + lin _Head_PN = mkPN "Head" ; + lin _y_PN = mkPN "y" ; + lin _MR_PN = mkPN "MR" ; + lin _by_Prep = mkPrep "by" ; + lin _fractured_A = mkA "fractured" ; + lin _benefpaidout_N = mkN "benefpaidout" ; + lin _Conditions_PN = mkPN "Conditions" ; + lin _attempt_N = mkN "attempt" ; + lin _ADD_PN = mkPN "ADD" ; + lin _hearing_N = mkN "hearing" ; + lin _polilcy_N = mkN "polilcy" ; + lin _Claim_PN = mkPN "Claim" ; + lin _for_Prep = mkPrep "for" ; + lin _assure_per_V2 = mkV2 (us_britishV "assure") (mkPrep "per") ; + lin _radiation_N = mkN "radiation" ; + lin _declaration_N = mkN "declaration" ; + lin _occur_during_V2 = mkV2 (us_britishV "occur") _during_Prep ; + lin _work_N = mkN "work" ; + lin _accidental_A = mkA "accidental" ; + lin _as_Adv = mkAdv "as" ; + lin _accident_N = mkN "accident" ; + lin _give_V2 = mkV2 (us_britishV "give") ; + lin _Republic_PN = mkPN "Republic" ; + lin _hear_in_V2 = mkV2 (us_britishV "hear") (mkPrep "in") ; + lin _get_from_V2 = mkV2 (us_britishV "get") (mkPrep "from") ; + lin _Plan14_PN = mkPN "Plan14" ; + lin _reasoner_N = mkN "reasoner" ; + lin _limit_N = mkN "limit" ; + lin _H7N7_V = us_britishV "H7N7" ; + lin _timeyear_N = mkN "timeyear" ; + lin _life_N = mkN "life" ; + lin _establish_V = us_britishV "establish" ; + lin _pland_Adv = mkAdv "pland" ; + lin _supervise_V = us_britishV "supervise" ; + lin _out_Prep = mkPrep "out" ; + lin _start_VS = mkVS (us_britishV "start") ; + lin _riot_N = mkN "riot" ; + lin _transport_N = mkN "transport" ; + lin _H7N7_N = mkN "H7N7" ; + lin _both_Subj = mkSubj "both" ; + lin _leg_N = mkN "leg" ; + lin _firstclaimyear_N = mkN "firstclaimyear" ; + lin _Section_PN = mkPN "Section" ; + lin _list_N = mkN "list" ; + lin _recognise_V = us_britishV "recognise" ; + lin _planF_PN = mkPN "planF" ; + lin _benADD_PN = mkPN "benADD" ; + lin _SG_PN = mkPN "SG" ; + lin _AIDS_PN = mkPN "AIDS" ; + lin _human_A = mkA "human" ; + lin _cover_V = us_britishV "cover" ; + lin _address_N = mkN "address" ; + lin _Address_PN = mkPN "Address" ; + lin _duty_N = mkN "duty" ; + lin _patella_N = mkN "patella" ; + lin _schedule_N = mkN "schedule" ; + lin _particular_A = mkA "particular" ; + lin _participate_in_V2 = mkV2 (mkV "participate") in_Prep ; + lin _passenger_N = mkN "passenger" ; + lin _where_Subj = mkSubj "where" ; + lin _total_A = mkA "total" ; + lin _addsa_N = mkN "addsa" ; + lin _of_Prep = mkPrep "of" ; + lin _phalanx_N = mkN "phalanx" ; + lin _eligibility_N = mkN "eligibility" ; + lin _past_A = mkA "past" ; + lin _assure_V2 = mkV2 (us_britishV "assure") ; + lin _racing_N = mkN "racing" ; + lin _f_N = mkN "f" ; + lin _ponder_V2 = mkV2 (us_britishV "ponder") ; + lin _incident_N = mkN "incident" ; + lin _life_assured_die_N = mkN "life_assured_die" ; + lin _ps_N = mkN "ps" ; + lin _in_Prep = mkPrep "in" ; + lin _Expense_PN = mkPN "Expense" ; + lin _before_Subj = mkSubj "before" ; + lin _p_N = mkN "p" ; + lin _1014_PN = mkPN "10.1.4" ; + lin _canoe_V = us_britishV "canoe" ; + lin _pothole_V = us_britishV "pothole" ; + lin _exception_N = mkN "exception" ; + lin _limb_N = mkN "limb" ; + lin _between_Prep = mkPrep "between" ; + lin _school_N = mkN "school" ; + lin _logical_A = mkA "logical" ; + lin _sight_N = mkN "sight" ; + lin _policyholder_N = mkN ("policyHolder"|"policyholder") ; + lin _refund_V2 = mkV2 (us_britishV "refund") ; + lin _cost_N = mkN "cost" ; + lin _located_in_A2 = mkA2 (mkA "located") (mkPrep "in") ; + lin _unsuccessful_A = mkA "unsuccessful" ; + lin _during_Prep = mkPrep ("during"|"DURING") ; + lin _happen_after_V2 = mkV2 (us_britishV "happen") (mkPrep "after") ; + lin _hfmd_A = mkA "hfmd" ; + lin _tsapp_N = mkN "tsapp" ; + lin _possibility_N = mkN "possibility" ; + lin _ear_N = mkN "ear" ; + lin _TABLE_PN = mkPN "TABLE" ; + lin _authority_N = mkN "authority" ; + lin _federation_N = mkN "federation" ; + lin _Insurer_PN = mkPN "Insurer" ; + lin _Policy_PN = mkPN "Policy" ; + lin _Flu_PN = mkPN "Flu" ; + lin _condition_N = mkN "condition" ; + lin _LA_PN = mkPN "LA" ; + lin _hang_VV = mkVV (us_britishV "hang") ; + lin _over_Prep = mkPrep "over" ; + lin _benTCM_PN = mkPN "benTCM" ; + lin _pay_for_V2 = mkV2 (us_britishV "pay") (mkPrep "for") ; + lin _payable_A = mkA "payable" ; + lin _military_N = mkN "military" ; + lin _plana_N = mkN "plana" ; + lin _p_PN = mkPN "p" ; + lin _H7N_PN = mkPN "H7N" ; + lin _vessel_N = mkN "vessel" ; + lin _foot_N = mkN "foot" ; + lin _incurable_A = mkA "incurable" ; + lin _employee_N = mkN "employee" ; + lin _fare_N = mkN "fare" ; + lin _military_A = mkA "military" ; + lin _exception_V = us_britishV "exception" ; + lin _policy_N = mkN "policy" ; + lin _person_N = mkN "person" ; + lin _mean_VS = mkVS (us_britishV "mean") ; + lin _1012_PN = mkPN "10.1.2" ; + lin _include_V2 = mkV2 (us_britishV "include") ; + lin _within_Prep = mkPrep "within" ; + lin _pay_V2 = mkV2 (us_britishV "pay") ; + lin _Melioidosis_PN = mkPN "Melioidosis" ; + lin _chemical_A = mkA "chemical" ; + lin _N_PN = mkPN "N" ; + lin _pland_N = mkN "pland" ; + lin _cm_N = mkN "cm" ; + lin _intentional_A = mkA "intentional" ; + lin _predicate_N = mkN "predicate" ; + lin _dType_PN = mkPN "dType" ; + lin _try_VV = mkVV (us_britishV "try") ; + lin _result_from_V2 = mkV2 (us_britishV "result") (mkPrep "from") ; + lin _through_Prep = mkPrep "through" ; + lin _registered_A = mkA "registered" ; + lin _expense_N = mkN "expense" ; + lin _premise_N = mkN "premise" ; + lin _premise_where_N2 = mkN2 _premise_N (mkPrep "where") ; + lin _year_N = mkN "year" ; + lin _circumstance_N = mkN "circumstance" ; + lin _life_assured_suffers_injury_does_not_die_within_30_day_N = mkN "life_assured_suffers_injury_does_not_die_within_30_day" ; + lin _make_within_V2 = mkV2 (us_britishV "make") (mkPrep "within") ; + lin _description_N = mkN "description" ; + lin _diagnosis_N = mkN "diagnosis" ; + lin _train_V = us_britishV "train" ; + lin _Singapore_PN = mkPN "Singapore" ; + lin _glide_V = us_britishV "glide" ; + lin _sssure_for_V2 = mkV2 (us_britishV "sssure") (mkPrep "for") ; + lin _damageevent_N = mkN "damageevent" ; + lin _infection_N = mkN "infection" ; + lin _mean_V = us_britishV "mean" ; + lin _lose_V2 = mkV2 (us_britishV "lose") ; + lin _payout_N = mkN "payout" ; + lin _y_N = mkN "y" ; + lin _riding_N = mkN "riding" ; + lin _service_N = mkN "service" ; + lin _mean_as_V2 = mkV2 (us_britishV "mean") (mkPrep "as") ; + lin _association_N = mkN "association" ; + lin _hernia_N = mkN "hernia" ; + lin _month_N = mkN "month" ; + lin _competition_N = mkN "competition" ; + lin _Influenza_PN = mkPN "Influenza" ; + lin _c_N = mkN "c" ; + lin _skydive_V = us_britishV "skydive" ; + lin _m_N = mkN "m" ; + lin _private_A = mkA "private" ; + lin _accepted_A = mkA "accepted" ; + lin _age_N = mkN "age" ; + lin _Details_PN = mkPN "Details" ; + lin _contract_N = mkN "contract" ; + lin _member_N = mkN "member" ; + lin _e_N = mkN "e" ; + lin _number_N = mkN "number" ; + lin _Ministry_PN = mkPN "Ministry" ; + lin _mall_N = mkN "mall" ; + lin _Yellow_PN = mkPN "Yellow" ; + lin _verifier_N = mkN "verifier" ; + lin _under_Prep = mkPrep "under" ; + lin _due_A = mkA "due" ; + lin _multiple_A = mkA "multiple" ; + lin _vehicle_N = mkN "vehicle" ; + lin _d_N = mkN "d" ; + lin _cover_V2 = mkV2 (us_britishV "cover") ; + lin _hockey_N = mkN "hockey" ; + lin _declare_V2 = mkV2 (us_britishV "declare") ; + lin _play_V2 = mkV2 (us_britishV "play") ; + lin _planE_PN = mkPN "planE" ; + lin _national_A = mkA "national" ; + lin _per_Prep = mkPrep "per" ; + lin _planB_PN = mkPN "planB" ; + lin _stepuppercentage_N = mkN "stepuppercentage" ; + lin _adjusted_A = mkA "adjusted" ; + lin _disease_N = mkN "disease" ; + lin _Triple_PN = mkPN "Triple" ; + lin _disabled_A = mkA "disabled" ; + lin _subject_A = mkA "subject" ; + lin _holder_N = mkN "holder" ; + lin _then_Adv = mkAdv "then" ; + lin _task_N = mkN "task" ; + lin _save_V2 = mkV2 (us_britishV "save") ; + lin _adjustment_N = mkN "adjustment" ; + lin _airline_N = mkN "airline" ; + lin _to_Prep = mkPrep "to" ; + lin _infectious_A = mkA "infectious" ; + lin _death_N = mkN "death" ; + lin _time_N = mkN "time" ; + lin _professional_A = mkA "professional" ; + lin _life_assured_N = mkN "life assured" ; + lin _form_N = mkN "form" ; + lin _dc_N = mkN "dc" ; + lin _sum_list_PN = mkPN "sum_list" ; + lin _have_V2 = mkV2 (us_britishV "have") ; + lin _toe_N = mkN "toe" ; + lin _soon_Adv = mkAdv "soon" ; + lin _plan3_PN = mkPN "plan3" ; + lin _Wife_PN = mkPN "Wife" ; + lin _tcm_N = mkN "tcm" ; + lin _Service_PN = mkPN "Service" ; + lin _loss_N = mkN "loss" ; + lin _Accident_PN = mkPN "Accident" ; + lin _Death_PN = mkPN "Death" ; + lin _suffer_in_V2 = mkV2 (us_britishV "suffer") (mkPrep "in") ; + lin _from_Prep = mkPrep "from" ; + lin _dangerous_A = mkA "dangerous" ; + lin _M_PN = mkPN "M" ; + lin _mountaineer_V = us_britishV "mountaineer" ; + lin _assure_of_V2 = mkV2 (us_britishV "assure") (mkPrep "of") ; + lin _met_common_requirement_for_add_V = us_britishV "met_common_requirement_for_add" ; + lin _vcjd_N = mkN "vcjd" ; +-- some PNs as Ns + lin _1012_N = mkN "10.1.2" ; + lin _1014_N = mkN "10.1.4" ; + lin _333A_N = mkN "333A" ; + lin _ADD_N = mkN "ADD" ; + lin _AIDS_N = mkN "AIDS" ; + lin _Accident_N = mkN "Accident" ; + lin _Accidental_N = mkN "Accidental" ; + lin _Accidents_N = mkN "Accidents" ; + lin _Address_N = mkN "Address" ; + lin _Adjustment_N = mkN "Adjustment" ; + lin _Assured_N = mkN "Assured" ; + lin _BSA_N = mkN "BSA" ; + lin _Benefit_N = mkN "Benefit" ; + lin _Cap_N = mkN "Cap" ; + lin _Claim_N = mkN "Claim" ; + lin _CoV_N = mkN "CoV" ; + lin _Conditions_N = mkN "Conditions" ; + lin _Date_N = mkN "Date" ; + lin _Death_N = mkN "Death" ; + lin _Details_N = mkN "Details" ; + lin _Disease_N = mkN "Disease" ; + lin _Dismemberment_N = mkN "Dismemberment" ; + lin _Event_N = mkN "Event" ; + lin _Expense_N = mkN "Expense" ; + lin _Flu_N = mkN "Flu" ; + lin _H7N9_N = mkN "H7N9" ; + lin _H7N_N = mkN "H7N" ; + lin _H9N2_N = mkN "H9N2" ; + lin _HAS_N = mkN "HAS" ; + lin _Head_N = mkN "Head" ; + lin _Health_N = mkN "Health" ; + lin _Influenza_N = mkN "Influenza" ; + lin _Injury_N = mkN "Injury" ; + lin _Insurer_N = mkN "Insurer" ; + lin _LA_N = mkN "LA" ; + lin _LE_N = mkN "LE" ; + lin _Leg_N = mkN "Leg" ; + lin _Legionnaires_N = mkN "Legionnaires" ; + lin _Life_N = mkN "Life" ; + lin _Limit_N = mkN "Limit" ; + lin _MAP_N = mkN "MAP" ; + lin _MIN_N = mkN "MIN" ; + lin _MR_N = mkN "MR" ; + lin _M_N = mkN "M" ; + lin _Medicine_N = mkN "Medicine" ; + lin _Melioidosis_N = mkN "Melioidosis" ; + lin _Ministry_N = mkN "Ministry" ; + lin _Mumps_N = mkN "Mumps" ; + lin _N_N = mkN "N" ; + lin _Nipah_N = mkN "Nipah" ; + lin _Ontology_N = mkN "Ontology" ; + lin _PS_N = mkN "PS" ; + lin _Plan14_N = mkN "Plan14" ; + lin _PlanAF_N = mkN "PlanAF" ; + lin _PolicyHolder_N = mkN "PolicyHolder" ; + lin _Policy_N = mkN "Policy" ; + lin _RETURN_N = mkN "RETURN" ; + lin _Reductions_N = mkN "Reductions" ; + lin _Removal_N = mkN "Removal" ; + lin _Republic_N = mkN "Republic" ; + lin _SA_N = mkN "SA" ; + lin _SG_N = mkN "SG" ; + lin _Schedule_N = mkN "Schedule" ; + lin _Section_N = mkN "Section" ; + lin _Service_N = mkN "Service" ; + lin _Singapore_N = mkN "Singapore" ; + lin _Step_N = mkN "Step" ; + lin _Subscribed_N = mkN "Subscribed" ; + lin _TABLE_N = mkN "TABLE" ; + lin _Teeth_N = mkN "Teeth" ; + lin _Triple_N = mkN "Triple" ; + lin _Type_N = mkN "Type" ; + lin _Types_N = mkN "Types" ; + lin _UPON_N = mkN "UPON" ; + lin _Wife_N = mkN "Wife" ; + lin _Yellow_N = mkN "Yellow" ; + lin _addSA_N = mkN "addSA" ; + lin _benADD_N = mkN "benADD" ; + lin _benADDs_N = mkN "benADDs" ; + lin _benRA_N = mkN "benRA" ; + lin _benTCM_N = mkN "benTCM" ; + lin _circ_N = mkN "circ" ; + lin _dTime_N = mkN "dTime" ; + lin _dType_N = mkN "dType" ; + lin _diving_N = mkN "diving" ; + lin _motocross_N = mkN "motocross" ; + lin _plan3_N = mkN "plan3" ; + lin _plan4_N = mkN "plan4" ; + lin _planAF_N = mkN "planAF" ; + lin _planB_N = mkN "planB" ; + lin _planC_N = mkN "planC" ; + lin _planE_N = mkN "planE" ; + lin _planF_N = mkN "planF" ; + lin _policyHolder_N = mkN "policyHolder" ; + lin _qualifies_for_add_N = mkN "qualifies_for_add" ; + lin _schema_N = mkN "schema" ; + lin _sum_list_N = mkN "sum_list" ; + lin _x_N = mkN "x" ; +} \ No newline at end of file diff --git a/lib/haskell/natural4/grammars/NL4.gf b/lib/haskell/natural4/grammars/NL4.gf index 6f0921a7b..80188bffe 100644 --- a/lib/haskell/natural4/grammars/NL4.gf +++ b/lib/haskell/natural4/grammars/NL4.gf @@ -1,4 +1,5 @@ abstract NL4 = StandardLexicon -- Manually curated set of common legal domain words (TODO: split into smaller domains? when does size of lexicon become an issue?) , DomainLexicon -- Automatically generated on the fly from whatever document we are processing + , InsLex ; \ No newline at end of file diff --git a/lib/haskell/natural4/grammars/NL4.pgf b/lib/haskell/natural4/grammars/NL4.pgf index 6d2877de0..208e8e108 100644 Binary files a/lib/haskell/natural4/grammars/NL4.pgf and b/lib/haskell/natural4/grammars/NL4.pgf differ diff --git a/lib/haskell/natural4/grammars/NL4Base.gf b/lib/haskell/natural4/grammars/NL4Base.gf index 9ec8e0c8c..0f78a49c5 100644 --- a/lib/haskell/natural4/grammars/NL4Base.gf +++ b/lib/haskell/natural4/grammars/NL4Base.gf @@ -12,41 +12,41 @@ abstract NL4Base = CustomSyntax ** { Action ; Who ; [Who]{2} ; - Subj ; Deontic ; Upon ; fun -- for fancy NLG - Regulative : Subj -> Deontic -> Action -> Text ; + Regulative : NP -> Deontic -> Action -> Text ; advUPON : Upon -> Text ; -- actually include the word Upon -- for web forms qWHO, - sWHO : Subj -> Who -> Text ; + sWHO : NP -> Who -> Text ; qUPON, -- TODO rethink types when adding more langs -- TODO2 do we allow upon to take full sentence or just VP*? - sUPON : Subj -> Upon -> Text ; + sUPON : NP -> Upon -> Text ; qCOND, sCOND : Cond -> Text ; -- general Regulative stuff - EVERY, - PARTY, - AN, THE : CN -> Subj ; -- EVERY Person + EVERY : CN -> NP ; -- EVERY Person + -- PARTY, + -- AN, THE WHO : Temp -> Pol -> VP -> Who ; -- WHO walks ACTION : VP -> Action ; MUST, MAY, SHANT : Deontic ; AND, OR : Conj ; - SubjWho : Subj -> Who -> Subj ; + SubjWho : NP -> Who -> NP ; ConjWho : Conj -> [Who] -> Who ; ConjPreWho : PrePost -> Conj -> [Who] -> Who ; -- TODO need to find examples in the wild ConjPrePostWho : (_,_ : PrePost) -> Conj -> [Who] -> Who ; - You : Subj ; + You : NP ; UPON : VP -> Upon ; -- upon becoming + UPONnp : NP -> VP -> Upon ; -- upon Accident happening -- not used for parsing WHEN : NP -> Temp -> Pol -> VP -> Cond ; ConjCond : Conj -> [Cond] -> Cond ; @@ -63,9 +63,11 @@ abstract NL4Base = CustomSyntax ** { fun RPleafS : NP -> VPS -> Constraint ; - RPleafNP : NP -> Constraint ; -- to pair with PrePost to get a full sentence ??? RPleafVP : VPS -> Constraint ; + -- to pair with PrePost, which we assume to contain the actual predicate + RPleafNP : NP -> Constraint ; RPleafAP : AP -> Constraint ; + RPleafAdv : Adv -> Constraint ; ConjConstraint : Conj -> [Constraint] -> Constraint ; ConjPreConstraint : PrePost -> Conj -> [Constraint] -> Constraint ; ConjPrePostConstraint : PrePost -> PrePost -> Conj -> [Constraint] -> Constraint ; @@ -120,12 +122,21 @@ abstract NL4Base = CustomSyntax ** { MkYear : (x1,_,_,x4: YearComponent) -> Year ; Y0, Y1, Y2, Y3, Y4, Y5, Y6, Y7, Y8, Y9 : YearComponent ; + -- Ages and comparisons + Comparison_Card_Years : Card -> VPS ; + + -- Generic comparisons + LessThan, + GreaterThan : NP -> VPS ; + ----------------------------------------------------------------------------- -- Very specific things, yet uncategorised - V2_PrePost : V2 -> PrePost ; -- consumes + V2_PrePost : Temp -> Pol -> V2 -> PrePost ; -- consumes NP_PrePost : NP -> PrePost ; -- beverage AP_PrePost : AP -> PrePost ; -- any unauthorised Adv_PrePost : Adv -> PrePost ; -- of personal data + SSlash_PrePost : NP -> Temp -> Pol -> V2 -> PrePost ; -- accident resulted from + S_PrePost : NP -> VPS -> PrePost ; -- the vehicle is on its way APWho : AP -> Who ; -- alcoholic AdvWho : Adv -> Who ; -- in whole @@ -138,11 +149,12 @@ abstract NL4Base = CustomSyntax ** { recoverUnparsedWho : String -> Who ; recoverUnparsedCond : String -> Cond ; recoverUnparsedUpon : String -> Upon ; - recoverUnparsedSubj : String -> Subj ; + recoverUnparsedNP : String -> NP ; recoverUnparsedAction : String -> Action ; recoverUnparsedTimeUnit : String -> TimeUnit ; recoverRPis : String -> String -> Constraint ; + recoverRPmath : String -> String -> String -> Constraint ; recoverUnparsedAdv : String -> Adv ; diff --git a/lib/haskell/natural4/grammars/NL4BaseChi.gf b/lib/haskell/natural4/grammars/NL4BaseChi.gf index 5731a37c2..fb83da77f 100644 --- a/lib/haskell/natural4/grammars/NL4BaseChi.gf +++ b/lib/haskell/natural4/grammars/NL4BaseChi.gf @@ -13,6 +13,7 @@ concrete NL4BaseChi of NL4Base = , (Extend=ExtendChi) , (Symbolic=SymbolicChi) , (Lexicon=LexiconChi) + , (Construction=ConstructionChi) , (CustomSyntax=CustomSyntaxChi) ** open Coordination, Prelude, ParadigmsChi, (R=ResChi) in { @@ -126,7 +127,7 @@ lin recoverUnparsedUpon string = mkVP (invarV string.s) ; - recoverUnparsedSubj string = symb string ; + recoverUnparsedNP string = symb string ; recoverUnparsedAction string = MkVPI (mkVP (invarV string.s)) ; diff --git a/lib/haskell/natural4/grammars/NL4BaseEng.gf b/lib/haskell/natural4/grammars/NL4BaseEng.gf index 584391ec4..c893fcb90 100644 --- a/lib/haskell/natural4/grammars/NL4BaseEng.gf +++ b/lib/haskell/natural4/grammars/NL4BaseEng.gf @@ -6,6 +6,7 @@ concrete NL4BaseEng of NL4Base = , (Extend=ExtendEng) , (Symbolic=SymbolicEng) , (Lexicon=LexiconEng) + , (Construction=ConstructionEng) , (CustomSyntax=CustomSyntaxEng) ** open Coordination, Prelude, ParadigmsEng, (R=ResEng) in { @@ -52,22 +53,29 @@ concrete NL4BaseEng of NL4Base = s = "·" ++ damage.s ++ "is" ++ toContents.s ; -- if constraint isn't parsed, use the original string qs = "Is" ++ damage.s ++ toContents.s ++ bindQM } ; - lin recoverUnparsedConstraint string = recoverUnparsedPrePost string ; + lin recoverRPmath gt age fifty = { + s = "·" ++ age.s ++ gt.s ++ fifty.s ; -- if constraint isn't parsed, use the original string + qs = "Is" ++ age.s ++ gt.s ++ fifty.s ++ bindQM + } ; + lin recoverUnparsedConstraint string = { + s = "·" ++ string.s ; + qs = string.s ++ bindQM + } ; - lin recoverUnparsedWho string = MkVPS presSimul POS (mkVP (invarV string.s)) ; + lin recoverUnparsedWho string = MkVPS presSimul POS (mkVP (invarUnparsedV string)) ; lin recoverUnparsedCond string = { s = lin S string ; qs = lin QS {s = \\_ => string.s} } ; - lin recoverUnparsedUpon string = mkVP (invarV string.s) ; + lin recoverUnparsedUpon string = mkVP (invarUnparsedV string) ; - lin recoverUnparsedSubj string = symb string ; - - lin recoverUnparsedAction string = MkVPI (mkVP (invarV string.s)) ; + lin recoverUnparsedAction string = MkVPI (mkVP (invarUnparsedV string)) ; lin recoverUnparsedTimeUnit string = mkCN "·" ++ string.s} : N> ; + oper invarUnparsedV : SS -> V = \ss -> invarV ("·" ++ ss.s) ; + } diff --git a/lib/haskell/natural4/grammars/NL4BaseFunctor.gf b/lib/haskell/natural4/grammars/NL4BaseFunctor.gf index 574667f11..1a0bac0e5 100644 --- a/lib/haskell/natural4/grammars/NL4BaseFunctor.gf +++ b/lib/haskell/natural4/grammars/NL4BaseFunctor.gf @@ -5,6 +5,7 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open , Lexicon , CustomSyntax , Coordination + , Construction , Prelude in { @@ -17,7 +18,6 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open Action = Extend.VPI ; Who = Extend.VPS ; [Who] = Extend.ListVPS ; - Subj = Syntax.NP ; Deontic = Syntax.VV ; Upon = Syntax.VP ; @@ -75,7 +75,7 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open -- : (_,_ : PrePost) -> Conj -> [Who] -> Who ; ConjPrePostWho = CustomSyntax.ConjPrePostVPS ; -- fun/lin in CustomSyntax - -- : Subj -> Who -> Subj ; + -- : NP -> Who -> NP ; SubjWho subj who = mkNP subj (Extend.RelVPS CustomSyntax.whoRP who) ; -- who_RP is oper in CustomSyntax You = you_NP ; @@ -139,6 +139,11 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open -- qs = qsStr (Extend.SQuestVPS it_NP (MkVPS presSimul POS (mkVP ap))) ++ bindQM qs = (mkUtt ap).s ++ bindQM } ; + RPleafAdv adv = { + s = (mkUtt adv).s ; + qs = (mkUtt adv).s ++ bindQM + } ; + BaseConstraint c d = { s = Coordination.twoStr c.s d.s ; qs = Coordination.twoStr c.qs d.qs @@ -196,9 +201,9 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open ConsTComparison = CustomSyntax.ConsPrep ; ConjTComparison = CustomSyntax.ConjPrep ; -- Chi has changed lincat and defs of Prep, so all must be from CustomSyntax - BEFORE = CustomSyntax.withinPrep -- internal oper defined in CustomSyntax{Eng,Chi,May} - | CustomSyntax.before_Prep ; -- comes from RGL, re-exported by CustomSyntax{Eng,Chi,May}. + BEFORE = CustomSyntax.before_Prep -- comes from RGL, re-exported by CustomSyntax{Eng,Chi,May}. -- In addition, its lincat and lin has been changed in CustomSyntaxChi. + | CustomSyntax.withinPrep ; -- internal oper defined in CustomSyntax{Eng,Chi,May} AFTER = CustomSyntax.after_Prep ; BY = CustomSyntax.by8timePrep ; ON = CustomSyntax.on_Prep ; @@ -226,16 +231,24 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open MkYear = cc4 ; + -- Ages + -- : Card -> VPS ; + Comparison_Card_Years card = MkVPS presSimul POS (Construction.has_age_VP card) ; + + -- Generic comparisons + -- LessThan, + -- GreaterThan : NP -> VPS ; + ----------------------------------------------------------------------------- -- Very specific things, yet uncategorised -- : AP -> Who ; -- hack APWho alcoholic = Extend.MkVPS presSimul POS (mkVP alcoholic) ; AdvWho in_part = Extend.MkVPS presSimul POS (mkVP in_part) ; - -- : V2 -> PrePost ; -- consumes - V2_PrePost consume = - let consumes : SS = mkUtt (mkS (mkCl emptyNP (mkVP consume emptyNP))) ; - consume : SS = mkUtt (mkS (mkCl emptyPlNP (mkVP consume emptyNP))) ; + -- : Temp -> Pol -> V2 -> PrePost ; -- consumes + V2_PrePost t p consume = + let consumes : SS = mkUtt (mkS t p (mkCl emptyNP (mkVP consume emptyNP))) ; + consume : SS = mkUtt (mkS t p (mkCl emptyPlNP (mkVP consume emptyNP))) ; in {s = consumes.s ; qs = consume.s} ; -- : NP -> PrePost ; -- beverage @@ -253,6 +266,20 @@ incomplete concrete NL4BaseFunctor of NL4Base = CustomSyntax ** open -- : Adv -> PrePost ; -- of personal data Adv_PrePost adv = {s,qs = (mkUtt adv).s} ; + -- : S -> PrePost ; -- the vehicle is on its way + S_PrePost np vps = { + s = (mkUtt (PredVPS np vps)).s ; + qs = (mkUtt (SQuestVPS np vps)).s + } ; + + -- : NP -> Temp -> Pol -> V2 -> PrePost ; -- accident resulted from + SSlash_PrePost accident t p result_from = + let result_from_S : SS = mkUtt (mkS t p (mkCl accident (mkVP result_from emptyNP))) ; + result_from_QS : SS = mkUtt (mkQS t p (mkQCl (mkCl accident (mkVP result_from emptyNP)))) ; + in {s = result_from_S.s ; qs = result_from_QS.s} ; + + recoverUnparsedNP string = symb (cc2 (ss "·") string) ; + recoverUnparsedAdv string = lin Adv (cc2 {s="·"} string) ; -- override for Chi } diff --git a/lib/haskell/natural4/grammars/NL4BaseMay.gf b/lib/haskell/natural4/grammars/NL4BaseMay.gf index 25afae682..e39f05701 100644 --- a/lib/haskell/natural4/grammars/NL4BaseMay.gf +++ b/lib/haskell/natural4/grammars/NL4BaseMay.gf @@ -6,6 +6,7 @@ concrete NL4BaseMay of NL4Base = , (Extend=ExtendMay) , (Symbolic=SymbolicMay) , (Lexicon=LexiconMay) + , (Construction=ConstructionMay) , (CustomSyntax=CustomSyntaxMay) ** open Coordination, Prelude, ParadigmsMay, (R=ResMay) in { @@ -49,7 +50,7 @@ lin recoverUnparsedUpon string = mkVP (invarV string.s) ; - recoverUnparsedSubj string = symb string ; + recoverUnparsedNP string = symb string ; recoverUnparsedAction string = MkVPI (mkVP (invarV string.s)) ; diff --git a/lib/haskell/natural4/grammars/NL4Eng.gf b/lib/haskell/natural4/grammars/NL4Eng.gf index ba7ff05d7..d08106155 100644 --- a/lib/haskell/natural4/grammars/NL4Eng.gf +++ b/lib/haskell/natural4/grammars/NL4Eng.gf @@ -1,4 +1,5 @@ concrete NL4Eng of NL4 = StandardLexiconEng , DomainLexiconEng + , InsLexEng ; \ No newline at end of file diff --git a/lib/haskell/natural4/grammars/StandardLexicon.gf b/lib/haskell/natural4/grammars/StandardLexicon.gf index 6c20063bf..03dd6f641 100644 --- a/lib/haskell/natural4/grammars/StandardLexicon.gf +++ b/lib/haskell/natural4/grammars/StandardLexicon.gf @@ -8,6 +8,7 @@ abstract StandardLexicon = NL4Base ** { fun within_Prep : Prep ; only_AdA : AdA ; -- within -> only within + due_to_A2 : A2 ; -- Open classes, like nouns, verbs etc. fun diff --git a/lib/haskell/natural4/grammars/StandardLexiconChi.gf b/lib/haskell/natural4/grammars/StandardLexiconChi.gf index 474984e8f..0b4543836 100644 --- a/lib/haskell/natural4/grammars/StandardLexiconChi.gf +++ b/lib/haskell/natural4/grammars/StandardLexiconChi.gf @@ -42,7 +42,7 @@ concrete StandardLexiconChi of StandardLexicon = NL4BaseChi ** NP_caused_NP_to_VP_Prep_PrePost np water escape from = let cl : Cl = mkCl (mkVP cause_V2V ) ; - cls : ClSlash = mkClSlash cl ; + cls : ClSlash = mkClSlash cl ; qcl : QCl = hackQCl cls ; ss : SSlash = mkSSlash (mkTemp pastTense simultaneousAnt) positivePol cls ; qs : QS = mkQS pastTense qcl ; diff --git a/lib/haskell/natural4/grammars/StandardLexiconEng.gf b/lib/haskell/natural4/grammars/StandardLexiconEng.gf index e11dc65ef..e1efcef04 100644 --- a/lib/haskell/natural4/grammars/StandardLexiconEng.gf +++ b/lib/haskell/natural4/grammars/StandardLexiconEng.gf @@ -14,6 +14,7 @@ concrete StandardLexiconEng of StandardLexicon = NL4BaseEng ** lin within_Prep = mkPrep "within" ; only_AdA = mkAdA "only" ; + due_to_A2 = mkA2 (mkA "due") to_Prep ; -- Open classes, like nouns, verbs etc. lin diff --git a/lib/haskell/natural4/grammars/updateHS.sh b/lib/haskell/natural4/grammars/updateHS.sh index 45b11bb19..3dee6b629 100755 --- a/lib/haskell/natural4/grammars/updateHS.sh +++ b/lib/haskell/natural4/grammars/updateHS.sh @@ -2,7 +2,7 @@ set -euo pipefail -gf -make -f haskell --haskell=gadt --haskell=lexical --lexical=N,CN,AP,VP,V2,VS,VV,Dig,Day,Month,YearComponent NL4Eng.gf NL4May.gf NL4Chi.gf +gf -make -f haskell --haskell=gadt --haskell=lexical --lexical=A,V,N,CN,PN,Prep,Conj,Subj,AP,VP,V2,VS,VV,V2V,Dig,Day,Month,YearComponent NL4Eng.gf NL4May.gf NL4Chi.gf cat NL4.hs | sed 's/module NL4 where/module LS.NLP.NL4 where/' | \ sed 's/instance Show .*//' | \ diff --git a/lib/haskell/natural4/package.yaml b/lib/haskell/natural4/package.yaml index ce1ca62d6..4d4bf1adb 100644 --- a/lib/haskell/natural4/package.yaml +++ b/lib/haskell/natural4/package.yaml @@ -71,7 +71,6 @@ dependencies: - string-interpolate - prettyprinter-interp - json - - jsonlogic language: GHC2021 @@ -79,6 +78,11 @@ ghc-options: -Wdefault -Wno-missed-extra-shared-lib -fconstraint-solver-iteratio library: source-dirs: src + dependencies: + - filepath + - filemanip +# the file stuff is for the interactive repl utils +# it's a bit misleading to list them as dependencies of the lib, but there doesn't seem to be any real alternative if we're using stack, at least according to discord executables: natural4-exe: diff --git a/lib/haskell/natural4/src/LS/BasicTypes.hs b/lib/haskell/natural4/src/LS/BasicTypes.hs index a07b8554c..b9c86a150 100644 --- a/lib/haskell/natural4/src/LS/BasicTypes.hs +++ b/lib/haskell/natural4/src/LS/BasicTypes.hs @@ -80,7 +80,7 @@ data MyToken = Every | Party | TokAll | Empty | EOL | RuleMarker Int Text.Text | Expect | ScenarioTok - | TokLT | TokLTE | TokGT | TokGTE | TokIn | TokNotIn | TokEQ | TokAnd | TokOr | TokSum | TokProduct + | TokLT | TokLTE | TokGT | TokGTE | TokIn | TokNotIn | TokEQ | TokAnd | TokOr | TokSum | TokProduct | TokMin | TokMax | Notwithstanding | Despite | SubjectTo | Otherwise | SOF | EOF @@ -243,11 +243,11 @@ toToken "§§§§§§" = pure $ RuleMarker 6 "§" toToken "SCENARIO" = pure ScenarioTok toToken "EXPECT" = pure Expect toToken "<" = pure TokLT -toToken "MIN" = pure TokLT; toToken "MIN OF" = pure TokLT +toToken "MIN" = pure TokMin; toToken "MIN OF" = pure TokMin toToken "=<" = pure TokLTE toToken "<=" = pure TokLTE toToken ">" = pure TokGT -toToken "MAX" = pure TokGT; toToken "MAX OF" = pure TokGT +toToken "MAX" = pure TokMax; toToken "MAX OF" = pure TokMax toToken ">=" = pure TokGTE toToken "=" = pure TokEQ toToken "&&" = pure TokAnd @@ -416,6 +416,8 @@ renderToken (RuleMarker n txt) = concat $ replicate n (Text.unpack txt) renderToken Semicolon = ";;" renderToken SubjectTo = "SUBJECT TO" +renderToken TokMin = "MIN" +renderToken TokMax = "MAX" renderToken TokSum = "SUM" renderToken TokProduct = "PRODUCT" renderToken FMap = "MAP" diff --git a/lib/haskell/natural4/src/LS/DataFlow.hs b/lib/haskell/natural4/src/LS/DataFlow.hs new file mode 100644 index 000000000..a38968d9f --- /dev/null +++ b/lib/haskell/natural4/src/LS/DataFlow.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| transpiler to show dataflow for both arithmetic and boolean logic -} + +module LS.DataFlow where + +import LS.XPile.Logging +import LS +import LS.Interpreter +import LS.Rule +import Data.Text qualified as Text +import Flow ((.>), (|>)) + +import qualified Data.Map as Map -- if you want to upgrade this to Hashmap, go ahead + +-- fgl +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.PatriciaTree (Gr) + +-- graphviz +import Data.GraphViz + ( shape, + graphToDot, + Shape(Circle), + GraphID(Str), + NodeCluster(N, C), + GlobalAttributes(NodeAttrs, GraphAttrs), + GraphvizParams(..), + PrintDot (unqtDot), + DotGraph, + toLabel, + ) +import Data.Text.Lazy qualified as LT +import Data.GraphViz.Printing (renderDot) +import Data.GraphViz.Attributes.Complete + +-- * Conceptually, a FlowNode is either a rule or a leaf/ground term referenced by a rule. +-- +-- Suppose the top-level rule is: +-- +-- @DECIDE happy IF warm AND sunny@ +-- +-- The top-level node corresponds to "happy". And there are two dependencies: @warm@ and @sunny@. +-- +-- Let's say @warm@ is a ground term: we have no further information +-- about @warm@. We need a human to provide a valuation of that fact. +-- In our graph it is a leaf node. +-- +-- Let's say @sunny@ is itself a rule: @sunny IF daytime AND NOT cloudy@. +-- +-- And it bottoms out there: both @daytime@ and @cloudy@ are ground terms. +-- +-- So our dataflow graph has: +-- +-- @ +-- warm -> happy +-- sunny -> happy +-- daytime -> sunny +-- cloudy -> sunny +-- @ +-- +-- Note that we are throwing away the logic -- we have lost the "NOT" on the "cloudy". +-- +-- The same idea applies to arithmetic rules: we might have @DECIDE happiness IS baselineHappiness + situationalHappiness@, where the terms are numeric-typed; the same shape of graph obtains. +-- +-- Our task is to return that graph. +-- +-- We get most of it out of the Interpreter, with the original Rules preserved, so we work with that. + +-- | This is the top-level entry point for this file; we produce a dotfile and rely on other elements of the L4 runtime to produce SVG from the Dot. +dataFlowAsDot :: Interpreted -> XPileLog String +dataFlowAsDot l4i = do + -- https://hackage.haskell.org/package/fgl-5.8.1.1/docs/Data-Graph-Inductive-Graph.html#v:mkGraph + let dfg :: RuleGraph + dfg = ruleGraph l4i + + let dot :: DotGraph Node + dot = graphToDot flowParams dfg + + -- if you look at Petri.hs you will see its graph construction delves deep into the logical relationship between rules. + -- That code was written before we had the Intepreter available to analyze rules for us. + -- So, we grab one tree of rules at a time from the RuleGraph provided by the interpreter, and dump those; + -- then we dump the ground term leaves in those rules. + + let rG = ruleGraph l4i + mutterd 2 "dataFlowasDot: retrieving ruleGraph" + mutterdhsf 3 "dataFlowasDot: first, let's dump the rulegraph" pShowNoColorS rG + + mutterd 3 "dataFlowasDot: heeere's ruleGraphErr" + mutters (ruleGraphErr l4i) + + let toreturn = ( dfg + |> graphToDot flowParams + |> unqtDot + |> renderDot + |> LT.toStrict + |> Text.unpack + ) + + mutterdhsf 3 "and now we should get some dot goodness" pShowNoColorS toreturn + return toreturn + + + where + ruleNodes = Map.fromList ( zip [1..] [ [MTT "pretend rule R1" ] -- 1 + , [MTT "pretend rule R2" ] -- 2 + ] ) + leafNodes = Map.fromList ( zip [1..] [ [MTT "pretend leaf L1" ] -- 1 + , [MTT "pretend leaf L2" ] -- 2 + , [MTT "pretend leaf L3" ] -- 3 + , [MTT "pretend leaf L4" ] -- 4 + ] ) + ruleEdges = [ (1, 1, ()), + (1, 2, ()), + (2, 3, ()), + (2, 4, ()) ] + + -- see Petri.hs for a more complex example of styling the graphviz output + flowParams :: GraphvizParams Int Rule () Int Rule + flowParams = Params + { isDirected = True + , globalAttributes = [GraphAttrs [Compound True]] + , clusterBy = C 1 . N -- in future we may want to partition all leaf nodes into a separate cluster to better identify them + , isDotCluster = const False + , clusterID = const (Str "clusterId") + , fmtCluster = const [NodeAttrs [ shape Circle ] ] + , fmtNode = fmtRuleNode + , fmtEdge = const [] + } + +fmtRuleNode :: (Node, Rule) -> [Attribute] +fmtRuleNode (_n, r) = pure $ toLabel $ mt2text $ name r + + + diff --git a/lib/haskell/natural4/src/LS/Interpreter.hs b/lib/haskell/natural4/src/LS/Interpreter.hs index 8d8db7853..6f9d8a907 100644 --- a/lib/haskell/natural4/src/LS/Interpreter.hs +++ b/lib/haskell/natural4/src/LS/Interpreter.hs @@ -32,7 +32,7 @@ import Data.Either (partitionEithers, fromRight) import Data.Graph.Inductive import Data.HashMap.Strict ((!)) import Data.HashMap.Strict qualified as Map -import Data.List (find) +import Data.List (find, (\\)) import Data.List qualified as DL import Data.List.NonEmpty as NE import Data.Maybe @@ -63,11 +63,14 @@ l4interpret iopts rs = let ct = classHierarchy rs st = symbolTable iopts rs (vp, vpErr) = xpLog $ attrsAsMethods rs + (rDGout, rDGerr) = xpLog $ ruleDecisionGraph rs in L4I { classtable = ct , scopetable = st , origrules = rs , valuePreds = fromRight [] vp + , ruleGraph = rDGout + , ruleGraphErr = rDGerr } -- | Provide the fully expanded, exposed, decision roots of all rules in the ruleset, @@ -94,7 +97,8 @@ qaHornsR l4i = [ ( ruleLabelName <$> uniqrs , expanded) | (grpval, uniqrs) <- groupedByAOTree l4i $ -- NUBBED - exposedRoots l4i -- EXPOSED + let (eRout, eRerr) = xpLog $ exposedRoots l4i -- EXPOSED + in eRout , not $ null grpval , expanded <- expandBSR l4i 1 <$> maybeToList (getBSR (DL.head uniqrs)) ] @@ -281,12 +285,11 @@ groupedByAOTree l4i rs = -- The SVG outputter likes to exclude things that have only a single element and are therefore visually uninteresting. -- We want the SVG Xpiler to reuse this code as authoritative. -exposedRoots :: Interpreted -> [Rule] -exposedRoots l4i = - let rs = origrules l4i - decisionGraph = ruleDecisionGraph l4i rs - decisionroots = decisionRoots decisionGraph - in [ r | r <- decisionroots, not $ isRuleAlias l4i (ruleLabelName r) ] +exposedRoots :: Interpreted -> XPileLog [Rule] +exposedRoots l4i = do + let decisionGraph = ruleGraph l4i + decisionroots <- decisionRoots decisionGraph + return [ r | r <- decisionroots, not $ isRuleAlias l4i (ruleLabelName r) ] -- | the (inner) type of a particular class's attribute attrType :: ClsTab -> EntityType -> Maybe TypeSig @@ -325,6 +328,7 @@ getAttrTypesIn ct classname = -- | structure the rules as a graph. -- in the simple case, the graph is one or more trees, each rooted at a "top-level" rule which is not "used" by any another rule. + -- if we walk the roots, we will sooner or later encounter all the decision elements relevant to each root. -- in a less simple case, the graph is cyclic! everything depends on everything else! but we can recognize that as an error condition. -- @@ -338,42 +342,131 @@ type RuleGraph = Gr Rule RuleGraphEdgeLabel type RuleIDMap = Map.HashMap Rule Int -- | which decision rules depend on which other decision rules? -ruleDecisionGraph :: Interpreted -> [Rule] -> RuleGraph -ruleDecisionGraph l4i rs = - let ruleIDmap = Map.fromList (Prelude.zip decisionRules [1..]) - in mkGraph - (swap <$> Map.toList ruleIDmap) -- the nodes - (relPredRefsAll l4i rs ruleIDmap) +-- And which ground terms don't expand any further? +-- +-- We answer these questions in two passes. +-- +-- First, we construct a rulegraph of only rules and their relations. In a conventional programming language we might call this the interprocedural graph. +-- In the first version of this codebase we stopped here and just returned the graph of rules, which is why the type is called `RuleGraph`. +-- +-- But that's not enough! We want to know about the leaf nodes, the ground terms, as well. +-- So, in a second pass, we traverse the rulegraph from the first pass, and return all the leaf nodes found in the RelationalPredicates; +-- then we eliminate all the tokens which appear in the graph from the first pass. That should leave us with only leaf nodes. +-- +-- With that clarity, we elevate the leaf nodes into stub rules and return a rule graph of the combined rules + ground terms. +-- +-- If, downstream, you want to distinguish between rule and ground term, just look for those nodes in the graph which are leaves! +-- +ruleDecisionGraph :: RuleSet -> XPileLog RuleGraph +ruleDecisionGraph rs = do + + "(1.1) for first pass, we begin with decisionrules" ***-> decisionRules + + let ruleOnlyMap = Map.fromList (Prelude.zip decisionRules [1..]) + "(1.2) ruleOnlyMap" ***-> ruleOnlyMap + + mutterd 3 "ruleDecisionGraph: (1.3) ruleOnlyGraph construction log using relPredRefsAll" + + ruleOnlyGraph :: RuleGraph <- mkGraph + (swap <$> Map.toList ruleOnlyMap) -- the nodes + <$> relPredRefsAll rs ruleOnlyMap -- The <$> lifts into the XPileLog monad + + "(1.4) ruleOnlyGraph result" ***-> ruleOnlyGraph + + mutterd 3 "as a flex, just to show what's going on, we extract all the leaf terms, if we can, by starting with all the terms entirely. Well, MultiTerms." + + let allTerms = DL.nub $ concat (concatMap rp2bodytexts . concatMap AA.extractLeaves . getBSR <$> rs) + "(2.1) allTerms" ***-> allTerms + + mutterd 3 "(2.2) we filter for the leaf terms by excluding all the ruleNames that we know from the original ruleset. This may not be a perfect match with the MultiTerms used in the rule graph. [TODO]" + + let (ruleNames, ruleLabelNames) = (ruleName <$> rs, ruleLabelName <$> rs) + "(2.3) ruleNames to omit" ***-> ruleNames + "(2.3 alt) what if we used ~ruleLabelName~ instead of ~ruleName~?)" ***-> ruleLabelNames + + let difference = (allTerms \\ ruleNames) \\ [[ MTT "OTHERWISE" ]] -- special case: Otherwise drops out + "(2.4) that leaves" ***-> difference + + mutterd 3 "(2.5) let's elevate all the leaf terms to stubby little rules in their own right" + let stubRules = [ defaultHorn { name = rulename, keyword = Define, srcref = Nothing + , clauses = stubClause rulename } + | rulename <- difference ] + + mutterd 3 "(2.6) then we rebuild the graph with those rules included" + let expandedRuleMap = Map.fromList (Prelude.zip (decisionRules ++ stubRules) [1..]) + expandedRuleGraph :: RuleGraph <- mkGraph + (swap <$> Map.toList expandedRuleMap) + <$> relPredRefsAll (rs ++ stubRules) expandedRuleMap + + "(2.7) expandedRuleGraph" ***-> expandedRuleGraph + + mutterd 3 "(3.1) finally we strip the reflexive BSR from the stub rules while leaving the nodes themselves in place." + + let prunedRuleGraph = dereflexed $ nmap (\r -> if hasClauses r && clauses r == stubClause (name r) then r { clauses = [] } else r ) expandedRuleGraph + "(3.2.7) prunedRuleGraph" ***-> prunedRuleGraph + + return prunedRuleGraph + where + -- [NOTE] for the purposes of generating the graph in the 2nd pass, + -- leaf nodes are reflexive. Let's just say we meant for it to be that way, cuz they "bottom out", lol. + -- This gets removed in the third pass. + stubClause rulename = + [ HC { hHead = RPMT rulename + , hBody = Just $ AA.mkLeaf (RPMT rulename) } + ] + + -- filter for just those rules which involve decisions decisionRules = [ r | r <- rs, not . null . getBSR $ r ] + -- we want to represent the leaf nodes in the rule decision graph, so we elevate those to the status of rules by including them in the map + groundTerms :: Map.HashMap Rule Int -> [RuleName] + groundTerms knownRules = [] + -- find all the body elements which + + (***->) str hs = mutterdhsf 3 ("ruleDecisionGraph: " <> str) pShowNoColorS hs + -- | walk all relationalpredicates in a set of rules, and return the list of edges showing how one rule relies on another. -relPredRefsAll :: Interpreted -> [Rule] -> RuleIDMap -> [LEdge RuleGraphEdgeLabel] -relPredRefsAll l4i rs ridmap = - concatMap (relPredRefs l4i rs ridmap) rs +relPredRefsAll :: RuleSet -> RuleIDMap -> XPileLog [LEdge RuleGraphEdgeLabel] +relPredRefsAll rs ridmap = + concat <$> mapM (relPredRefs rs ridmap) rs -- | in a particular rule, walk all the relational predicates available, and show outdegree links --- that correspond to known BSR heads from the entire ruleset. +-- that correspond to known rule heads from the entire ruleset. -- -- in other words, if a rule R1 says something like (a WHEN b OR c), it defines a, and relies on b and c; -- if we find a rule R2 which defines (c MEANS c1 AND c2), then it defines c, and relies on c1 and c2. -- so we show that rule R1 relies on, or refers to, rule R2: R1 -> R2. -- there is some overlap here with the idea of scopetabs in the symbol table, but let's just do it -- the brute way first and then refactor later once we have a better idea if this approach even works. -relPredRefs :: Interpreted -> [Rule] -> RuleIDMap -> Rule -> [LEdge RuleGraphEdgeLabel] -relPredRefs _l4i rs ridmap r = +relPredRefs :: RuleSet -> RuleIDMap -> Rule -> XPileLog [LEdge RuleGraphEdgeLabel] +relPredRefs rs ridmap r = do let headElements :: Map.HashMap MultiTerm Rule -- does this get recomputed each time or cached? -- given a term, see which rule defines it headElements = Map.fromList $ [ (headName,r') | r' <- rs - , headName <- getDecisionHeads r' + , headName <- getDecisionHeads r' -- [TODO] this is quadratic ] -- given a rule, see which terms it relies on - bodyElements = concatMap rp2bodytexts (concatMap AA.extractLeaves (getBSR r)) + myGetBSR = getBSR r + myLeaves = concatMap AA.extractLeaves myGetBSR + bodyElements = concatMap rp2bodytexts myLeaves + + mutterd 4 (T.unpack $ mt2text $ ruleLabelName r) + mutterdhsf 5 "relPredRefs: headElements" pShowNoColorS headElements + + mutterdhsf 5 "relPredRefs: original rule" pShowNoColorS r + mutterdhsf 5 "relPredRefs: getBSR" pShowNoColorS myGetBSR + mutterdhsf 5 "relPredRefs: extractLeaves" pShowNoColorS myLeaves + mutterdhsf 5 "relPredRefs: bodyElements" pShowNoColorS bodyElements + + -- [BUG] at some point we lose the moon + mutterd 5 "relPredReffs: will exclude various things not found in headElements" -- given a rule R, for each term relied on by rule R, identify all the subsidiary rules which define those terms. - in [ (rid, targetRuleId', ()) - | bElem <- bodyElements + toreturn <- sequence + [ (rid, targetRuleId', ()) <$ mutterd 6 ("relPredRefs list comp: returning " <> show rid <> ", " <> show targetRuleId') + | bElem <- bodyElements , let targetRule = Map.lookup bElem headElements , isJust targetRule , let targetRule' = fromJust targetRule -- safe due to above isJust test @@ -383,6 +476,8 @@ relPredRefs _l4i rs ridmap r = rid = ridmap ! r ] + mutterdhsf 5 "relPredRefs: returning" pShowNoColorS toreturn + return toreturn -- | Which rules are "top-level", "entry-point" rules? -- @@ -392,24 +487,29 @@ relPredRefs _l4i rs ridmap r = -- -- Examine the rulegraph for rules which have no indegrees, as far as decisioning goes. -decisionRoots :: RuleGraph -> [Rule] -decisionRoots rg = - let rg' = dereflexed - in - catMaybes [ lab rg' r - | r <- nodes rg' - , indeg rg' r == 0 --- , outdeg rg' r > 0 - ] - where - -- remove reflexive edges that go from node n to node n - dereflexed :: RuleGraph - dereflexed = - let toreturn = foldr (\n g -> delEdge (n,n) g) rg (nodes rg) - in --- trace ("dereflexed before: " ++ prettify rg) $ --- trace ("dereflexed after: " ++ prettify toreturn) $ - toreturn +decisionRoots :: RuleGraph -> XPileLog [Rule] +decisionRoots rg = do + let rg' = dereflexed rg + return $ + catMaybes [ lab rg' r + | r <- nodes rg' + , indeg rg' r == 0 + -- , outdeg rg' r > 0 + ] + +-- remove reflexive edges that go from node n to node n +dereflexed :: RuleGraph -> RuleGraph +dereflexed rg = + foldr (\n g -> delEdge (n,n) g) rg (nodes rg) + + +-- | extract a data flow graph +-- suitable for drawing as SVG +-- from the rulegraph. +-- +-- we're interested in a data flow graph whose leaves are the leaf elements in the rulegraph; +-- the intermediate nodes can be the rules; and +-- the graph roots out at the decisionRoots. -- | return the internal conditions of the rule, if any, as an and-or tree. @@ -887,4 +987,22 @@ attrsAsMethods rs = do xpReturn (DL.filter (not . T.null) $ T.strip <$> T.splitOn "'s" (T.replace "'s" "'s" $ mt2text $ DL.init mt) , mt2text [DL.last mt]) - + + +-- * Data Flow Analysis +-- +-- the previous generation of Nubbed Decision Roots worked for +-- boolean propositions. Now we want to analyze the roots that involve +-- more complicated RelationalPredicates, involving not only booleans +-- but also numbers. + +-- | entryPoints returns those data elements that are not used by any other. +-- +entryPoints :: Interpreted -> XPileLog [RelationalPredicate] +entryPoints l4i = do + mutter "entryPoints running." + + + + return [] + diff --git a/lib/haskell/natural4/src/LS/Lib.hs b/lib/haskell/natural4/src/LS/Lib.hs index e29fc5de0..002d6585f 100644 --- a/lib/haskell/natural4/src/LS/Lib.hs +++ b/lib/haskell/natural4/src/LS/Lib.hs @@ -87,6 +87,7 @@ data Opts w = Opts { demo :: w ::: Bool "False" , workdir :: w ::: String "" "workdir to save all the output files to" , uuiddir :: w ::: String "no-uuid" "uuid prefix to follow the workdir" , toprolog :: w ::: Bool "True" "prolog-like syntax representing the predicate logic" + , toscasp :: w ::: Bool "True" "sCasp-like syntax representing the predicate logic" , tonative :: w ::: Bool "True" "native Haskell data structure of the AST" , topetri :: w ::: Bool "True" "a petri-net Dot file of the state graph" , toaasvg :: w ::: Bool "True" "an anyall SVG of the decision trees" @@ -157,6 +158,7 @@ getConfig o = do , toBabyL4 = only o == "babyl4" || only o == "corel4" , toASP = only o == "asp" , toProlog = only o == "prolog" + , toSCasp = only o == "scasp" , toUppaal = only o == "uppaal" , toGrounds = only o == "grounds" , toChecklist = only o == "checklist" @@ -170,8 +172,16 @@ getConfig o = do } -parseRules :: Opts Unwrapped -> IO [Either (ParseErrorBundle MyStream Void) [Rule]] -parseRules o = do +-- | Each stanza gets parsed separately, which is why we have a top-level IO [Rule]. +-- +-- At some point we added functionality that allowed sub-rules to be defined inline within a top-level rule, which is why we now have IO [... [Rule]]. +-- +-- Note that sub-rules are themselves rules, which is why we only have one Rule type here. +-- +-- Shouldn't the idea of sub-rules and top-level rules be reflected in a type hierarchy? +-- +parseRules :: Opts Unwrapped -> IO [Either (ParseErrorBundle MyStream Void) [Rule]] -- [TODO] why inner [Rule] and not just a plain Rule? Give explanation in comment. +parseRules o = do runConfig <- getConfig o let files = getNoLabel $ file o if null files @@ -392,7 +402,7 @@ stanzaAsStream rs = -- tokenLength = fromIntegral $ Text.length rawToken + 1 & \r -> Debug.trace (show r) r -- tokenLength = fromIntegral $ Text.length rawToken + 1 & Debug.trace <$> show <*> id -- same as above line, but with reader applicative -- tokenLength = fromIntegral $ Text.length rawToken + 1 -- without debugging - , tokenVal <- toToken rawToken + , tokenVal <- toToken (Text.strip rawToken) -- strip leading and trailing whitespace from tokens. If you want a bare "IS" your best bet is to say "is". , tokenVal `notElem` [ Empty, TokTrue, TokFalse ] -- ignore TRUE and FALSE values ... so long as our policy is to ignore checkboxes, that is. ] where diff --git a/lib/haskell/natural4/src/LS/NLP/NL4.hs b/lib/haskell/natural4/src/LS/NLP/NL4.hs index 88cda3a6e..5ee9790d1 100644 --- a/lib/haskell/natural4/src/LS/NLP/NL4.hs +++ b/lib/haskell/natural4/src/LS/NLP/NL4.hs @@ -1,28 +1,9 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE UndecidableInstances #-} - +{-# LANGUAGE GADTs, UndecidableInstances #-} module LS.NLP.NL4 where -import Control.Monad.Identity - ( Identity (Identity, runIdentity), - MonadPlus (..), - ap, - ) +import Control.Monad.Identity (Identity ( Identity, runIdentity), MonadPlus (..), ap ) import Data.Monoid () -import PGF - ( Expr, - mkApp, - mkCId, - mkFloat, - mkInt, - mkStr, - showCId, - showExpr, - unApp, - unFloat, - unInt, - unStr, - ) +import PGF (Expr, mkApp, mkCId, mkFloat, mkInt, mkStr, showCId, showExpr, unApp, unFloat, unInt, unStr ) ---------------------------------------------------- -- automatic translation from GF to Haskell @@ -59,16 +40,26 @@ instance (Gf (Tree a)) => Show (Tree a) where show = showExpr [] . gf ---------------------------------------------------- +type GA = Tree GA_ +data GA_ +type GA2 = Tree GA2_ +data GA2_ type GAP = Tree GAP_ data GAP_ type GAction = Tree GAction_ data GAction_ type GAdA = Tree GAdA_ data GAdA_ +type GAdN = Tree GAdN_ +data GAdN_ type GAdv = Tree GAdv_ data GAdv_ +type GCAdv = Tree GCAdv_ +data GCAdv_ type GCN = Tree GCN_ data GCN_ +type GCard = Tree GCard_ +data GCard_ type GComp = Tree GComp_ data GComp_ type GCond = Tree GCond_ @@ -115,10 +106,18 @@ type GListWho = Tree GListWho_ data GListWho_ type GMonth = Tree GMonth_ data GMonth_ +type GN = Tree GN_ +data GN_ +type GN2 = Tree GN2_ +data GN2_ type GNP = Tree GNP_ data GNP_ +type GNum = Tree GNum_ +data GNum_ type GNumeral = Tree GNumeral_ data GNumeral_ +type GPN = Tree GPN_ +data GPN_ type GPol = Tree GPol_ data GPol_ type GPrePost = Tree GPrePost_ @@ -127,6 +126,10 @@ type GPrep = Tree GPrep_ data GPrep_ type GQS = Tree GQS_ data GQS_ +type GRP = Tree GRP_ +data GRP_ +type GRS = Tree GRS_ +data GRS_ type GS = Tree GS_ data GS_ type GSub10 = Tree GSub10_ @@ -155,6 +158,8 @@ type GTimeUnit = Tree GTimeUnit_ data GTimeUnit_ type GUpon = Tree GUpon_ data GUpon_ +type GV = Tree GV_ +data GV_ type GV2 = Tree GV2_ data GV2_ type GVP = Tree GVP_ @@ -173,20 +178,10 @@ type GYear = Tree GYear_ data GYear_ type GYearComponent = Tree GYearComponent_ data GYearComponent_ -type GA = Tree GA_ -data GA_ -type GA2 = Tree GA2_ -data GA2_ type GAnt = Tree GAnt_ data GAnt_ -type GN = Tree GN_ -data GN_ -type GN2 = Tree GN2_ -data GN2_ type GTense = Tree GTense_ data GTense_ -type GV = Tree GV_ -data GV_ type GString = Tree GString_ data GString_ type GInt = Tree GInt_ @@ -195,6 +190,10 @@ type GFloat = Tree GFloat_ data GFloat_ data Tree :: * -> * where + LexA :: String -> Tree GA_ + G_located_in_A2 :: Tree GA2_ + Gdue_to_A2 :: Tree GA2_ + GComplA2 :: GA2 -> GNP -> Tree GAP_ GConjAP :: GConj -> GListAP -> Tree GAP_ GInt_or_older :: GInt -> Tree GAP_ GPositA :: GA -> Tree GAP_ @@ -204,16 +203,50 @@ data Tree :: * -> * where GACTION :: GVP -> Tree GAction_ GrecoverUnparsedAction :: GString -> Tree GAction_ Gonly_AdA :: Tree GAdA_ + GAdnCAdv :: GCAdv -> Tree GAdN_ + Gat_least_AdN :: Tree GAdN_ + Gat_most_AdN :: Tree GAdN_ GAdAdv :: GAdA -> GAdv -> Tree GAdv_ GByVP :: GVP -> Tree GAdv_ GConjAdv :: GConj -> GListAdv -> Tree GAdv_ GPrepNP :: GPrep -> GNP -> Tree GAdv_ + GSubjS :: GSubj -> GS -> Tree GAdv_ + GWhileDoing :: GVP -> Tree GAdv_ + G_as_Adv :: Tree GAdv_ + G_at_Adv :: Tree GAdv_ + G_directly_Adv :: Tree GAdv_ + G_first_Adv :: Tree GAdv_ + G_fully_Adv :: Tree GAdv_ + G_hence_Adv :: Tree GAdv_ + G_here_Adv :: Tree GAdv_ + G_indirectly_Adv :: Tree GAdv_ + G_least_Adv :: Tree GAdv_ + G_long_Adv :: Tree GAdv_ + G_more_Adv :: Tree GAdv_ + G_no_Adv :: Tree GAdv_ + G_on_its_way_Adv :: Tree GAdv_ + G_only_Adv :: Tree GAdv_ + G_permanently_Adv :: Tree GAdv_ + G_pland_Adv :: Tree GAdv_ + G_so_Adv :: Tree GAdv_ + G_soon_Adv :: Tree GAdv_ + G_then_Adv :: Tree GAdv_ + G_totally_Adv :: Tree GAdv_ + G_up_Adv :: Tree GAdv_ Gin_part :: Tree GAdv_ Gin_whole :: Tree GAdv_ GrecoverUnparsedAdv :: GString -> Tree GAdv_ + Gless_CAdv :: Tree GCAdv_ + Gmore_CAdv :: Tree GCAdv_ GAdjCN :: GAP -> GCN -> Tree GCN_ + GCNwhereS :: GCN -> GNP -> GVPS -> Tree GCN_ + GComplN2 :: GN2 -> GNP -> Tree GCN_ + GRelCN :: GCN -> GRS -> Tree GCN_ GUseN :: GN -> Tree GCN_ + G_CN_of_any_kind_CN :: GCN -> Tree GCN_ LexCN :: String -> Tree GCN_ + GAdNum :: GAdN -> GCard -> Tree GCard_ + GNumDigits :: GDigits -> Tree GCard_ GCompAP :: GAP -> Tree GComp_ GCompAdv :: GAdv -> Tree GComp_ GCompNP :: GNP -> Tree GComp_ @@ -223,22 +256,24 @@ data Tree :: * -> * where GRPConstraint :: GCond -> GTComparison -> GDate -> Tree GCond_ GWHEN :: GNP -> GTemp -> GPol -> GVP -> Tree GCond_ GrecoverUnparsedCond :: GString -> Tree GCond_ - GAND :: Tree GConj_ - GOR :: Tree GConj_ + LexConj :: String -> Tree GConj_ GConjConstraint :: GConj -> GListConstraint -> Tree GConstraint_ GConjPreConstraint :: GPrePost -> GConj -> GListConstraint -> Tree GConstraint_ GConjPrePostConstraint :: GPrePost -> GPrePost -> GConj -> GListConstraint -> Tree GConstraint_ GRPleafAP :: GAP -> Tree GConstraint_ + GRPleafAdv :: GAdv -> Tree GConstraint_ GRPleafNP :: GNP -> Tree GConstraint_ GRPleafS :: GNP -> GVPS -> Tree GConstraint_ GRPleafVP :: GVPS -> Tree GConstraint_ GrecoverRPis :: GString -> GString -> Tree GConstraint_ + GrecoverRPmath :: GString -> GString -> GString -> Tree GConstraint_ GrecoverUnparsedConstraint :: GString -> Tree GConstraint_ GMkDate :: GDay -> GMonth -> GYear -> Tree GDate_ LexDay :: String -> Tree GDay_ GMAY :: Tree GDeontic_ GMUST :: Tree GDeontic_ GSHANT :: Tree GDeontic_ + GaPl :: Tree GDet_ GaSg :: Tree GDet_ GthePl :: Tree GDet_ GtheSg :: Tree GDet_ @@ -266,13 +301,22 @@ data Tree :: * -> * where GListVPS :: [GVPS] -> Tree GListVPS_ GListWho :: [GWho] -> Tree GListWho_ LexMonth :: String -> Tree GMonth_ + GCompoundN :: GN -> GN -> Tree GN_ + LexN :: String -> Tree GN_ + G_premise_where_N2 :: Tree GN2_ + G_travel_by_N2 :: Tree GN2_ GConjNP :: GConj -> GListNP -> Tree GNP_ GContents :: Tree GNP_ GDetCN :: GDet -> GCN -> Tree GNP_ + GEVERY :: GCN -> Tree GNP_ + GGenModNP :: GNum -> GNP -> GCN -> Tree GNP_ GGerundNP :: GVP -> Tree GNP_ GLoss_or_Damage :: Tree GNP_ GMassNP :: GCN -> Tree GNP_ GNDB_Qualification :: Tree GNP_ + GSubjWho :: GNP -> GWho -> Tree GNP_ + GUsePN :: GPN -> Tree GNP_ + GYou :: Tree GNP_ Ganimal :: Tree GNP_ Gany_other_exclusion :: Tree GNP_ Gbirds :: Tree GNP_ @@ -283,6 +327,7 @@ data Tree :: * -> * where Ginsects :: Tree GNP_ Gplumbing_heating_or_AC :: Tree GNP_ Gpremium :: Tree GNP_ + GrecoverUnparsedNP :: GString -> Tree GNP_ Gresult_from :: GNP -> Tree GNP_ Grodents :: Tree GNP_ Gsigned :: Tree GNP_ @@ -291,7 +336,10 @@ data Tree :: * -> * where Gswimming_pool :: Tree GNP_ Gvermin :: Tree GNP_ Gwater :: Tree GNP_ + GNumPl :: Tree GNum_ + GNumSg :: Tree GNum_ Gnum :: GSub1000000 -> Tree GNumeral_ + LexPN :: String -> Tree GPN_ GNEG :: Tree GPol_ GPOS :: Tree GPol_ GAP_PrePost :: GAP -> Tree GPrePost_ @@ -299,20 +347,16 @@ data Tree :: * -> * where GNP_PrePost :: GNP -> Tree GPrePost_ GNP_caused_NP_to_VP_Prep_PrePost :: GNP -> GNP -> GVP -> GPrep -> Tree GPrePost_ GNP_caused_by_PrePost :: GNP -> Tree GPrePost_ - GV2_PrePost :: GV2 -> Tree GPrePost_ + GSSlash_PrePost :: GNP -> GTemp -> GPol -> GV2 -> Tree GPrePost_ + GS_PrePost :: GNP -> GVPS -> Tree GPrePost_ + GV2_PrePost :: GTemp -> GPol -> GV2 -> Tree GPrePost_ GrecoverUnparsedPrePost :: GString -> Tree GPrePost_ GConjPrep :: GConj -> GListPrep -> Tree GPrep_ - Gabout_Prep :: Tree GPrep_ - Gafter_Prep :: Tree GPrep_ - Gbefore_Prep :: Tree GPrep_ - Gfor_Prep :: Tree GPrep_ - Gfrom_Prep :: Tree GPrep_ - Gon_Prep :: Tree GPrep_ - Gpossess_Prep :: Tree GPrep_ - Gto_Prep :: Tree GPrep_ - Gwithin_Prep :: Tree GPrep_ + LexPrep :: String -> Tree GPrep_ GConjPrePostQS :: GString -> GString -> GConj -> GListQS -> Tree GQS_ GConjQS :: GConj -> GListQS -> Tree GQS_ + GIdRP :: Tree GRP_ + GRelVPS :: GRP -> GVPS -> Tree GRS_ GConjPrePostS :: GString -> GString -> GConj -> GListS -> Tree GS_ GConjS :: GConj -> GListS -> Tree GS_ GPredVPS :: GNP -> GVPS -> Tree GS_ @@ -344,13 +388,7 @@ data Tree :: * -> * where Gpot51 :: Tree GSub1000000000000_ Gpot5float :: GFloat -> Tree GSub1000000000000_ Gpot5plus :: GSub1000 -> GSub1000000000 -> Tree GSub1000000000000_ - GAN :: GCN -> Tree GSubj_ - GEVERY :: GCN -> Tree GSubj_ - GPARTY :: GCN -> Tree GSubj_ - GSubjWho :: GSubj -> GWho -> Tree GSubj_ - GTHE :: GCN -> Tree GSubj_ - GYou :: Tree GSubj_ - GrecoverUnparsedSubj :: GString -> Tree GSubj_ + LexSubj :: String -> Tree GSubj_ GAFTER :: Tree GTComparison_ GBEFORE :: Tree GTComparison_ GBY :: Tree GTComparison_ @@ -362,22 +400,24 @@ data Tree :: * -> * where GpresSimul :: Tree GTemp_ GTemporalConstraint :: GTComparison -> GDigits -> GTimeUnit -> Tree GTemporal_ GTemporalConstraintNoDigits :: GTComparison -> GTimeUnit -> Tree GTemporal_ - GRegulative :: GSubj -> GDeontic -> GAction -> Tree GText_ + GRegulative :: GNP -> GDeontic -> GAction -> Tree GText_ GadvUPON :: GUpon -> Tree GText_ GqCOND :: GCond -> Tree GText_ GqCONSTR :: GConstraint -> Tree GText_ GqPREPOST :: GPrePost -> Tree GText_ - GqUPON :: GSubj -> GUpon -> Tree GText_ - GqWHO :: GSubj -> GWho -> Tree GText_ + GqUPON :: GNP -> GUpon -> Tree GText_ + GqWHO :: GNP -> GWho -> Tree GText_ GsCOND :: GCond -> Tree GText_ - GsUPON :: GSubj -> GUpon -> Tree GText_ - GsWHO :: GSubj -> GWho -> Tree GText_ + GsUPON :: GNP -> GUpon -> Tree GText_ + GsWHO :: GNP -> GWho -> Tree GText_ GDay_Unit :: Tree GTimeUnit_ GMonth_Unit :: Tree GTimeUnit_ GYear_Unit :: Tree GTimeUnit_ GrecoverUnparsedTimeUnit :: GString -> Tree GTimeUnit_ GUPON :: GVP -> Tree GUpon_ + GUPONnp :: GNP -> GVP -> Tree GUpon_ GrecoverUnparsedUpon :: GString -> Tree GUpon_ + LexV :: String -> Tree GV_ LexV2 :: String -> Tree GV2_ GAdvVP :: GVP -> GAdv -> Tree GVP_ GComplV2 :: GV2 -> GNP -> Tree GVP_ @@ -386,10 +426,14 @@ data Tree :: * -> * where GComplVSif :: GVS -> GS -> Tree GVP_ GComplVSthat :: GVS -> GS -> Tree GVP_ GUseComp :: GComp -> Tree GVP_ + GUseV :: GV -> Tree GVP_ LexVP :: String -> Tree GVP_ GMkVPI :: GVP -> Tree GVPI_ + GComparison_Card_Years :: GCard -> Tree GVPS_ GConjPrePostVPS :: GString -> GString -> GConj -> GListVPS -> Tree GVPS_ GConjVPS :: GConj -> GListVPS -> Tree GVPS_ + GGreaterThan :: GNP -> Tree GVPS_ + GLessThan :: GNP -> Tree GVPS_ GMayHave :: GVP -> Tree GVPS_ GMkVPS :: GTemp -> GPol -> GVP -> Tree GVPS_ LexVS :: String -> Tree GVS_ @@ -403,13 +447,16 @@ data Tree :: * -> * where GrecoverUnparsedWho :: GString -> Tree GWho_ GMkYear :: GYearComponent -> GYearComponent -> GYearComponent -> GYearComponent -> Tree GYear_ LexYearComponent :: String -> Tree GYearComponent_ - LexN :: String -> Tree GN_ GString :: String -> Tree GString_ GInt :: Int -> Tree GInt_ GFloat :: Double -> Tree GFloat_ instance Eq (Tree a) where i == j = case (i,j) of + (LexA x,LexA y) -> x == y + (G_located_in_A2,G_located_in_A2) -> and [ ] + (Gdue_to_A2,Gdue_to_A2) -> and [ ] + (GComplA2 x1 x2,GComplA2 y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GConjAP x1 x2,GConjAP y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GInt_or_older x1,GInt_or_older y1) -> and [ x1 == y1 ] (GPositA x1,GPositA y1) -> and [ x1 == y1 ] @@ -419,16 +466,50 @@ instance Eq (Tree a) where (GACTION x1,GACTION y1) -> and [ x1 == y1 ] (GrecoverUnparsedAction x1,GrecoverUnparsedAction y1) -> and [ x1 == y1 ] (Gonly_AdA,Gonly_AdA) -> and [ ] + (GAdnCAdv x1,GAdnCAdv y1) -> and [ x1 == y1 ] + (Gat_least_AdN,Gat_least_AdN) -> and [ ] + (Gat_most_AdN,Gat_most_AdN) -> and [ ] (GAdAdv x1 x2,GAdAdv y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GByVP x1,GByVP y1) -> and [ x1 == y1 ] (GConjAdv x1 x2,GConjAdv y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GPrepNP x1 x2,GPrepNP y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GSubjS x1 x2,GSubjS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GWhileDoing x1,GWhileDoing y1) -> and [ x1 == y1 ] + (G_as_Adv,G_as_Adv) -> and [ ] + (G_at_Adv,G_at_Adv) -> and [ ] + (G_directly_Adv,G_directly_Adv) -> and [ ] + (G_first_Adv,G_first_Adv) -> and [ ] + (G_fully_Adv,G_fully_Adv) -> and [ ] + (G_hence_Adv,G_hence_Adv) -> and [ ] + (G_here_Adv,G_here_Adv) -> and [ ] + (G_indirectly_Adv,G_indirectly_Adv) -> and [ ] + (G_least_Adv,G_least_Adv) -> and [ ] + (G_long_Adv,G_long_Adv) -> and [ ] + (G_more_Adv,G_more_Adv) -> and [ ] + (G_no_Adv,G_no_Adv) -> and [ ] + (G_on_its_way_Adv,G_on_its_way_Adv) -> and [ ] + (G_only_Adv,G_only_Adv) -> and [ ] + (G_permanently_Adv,G_permanently_Adv) -> and [ ] + (G_pland_Adv,G_pland_Adv) -> and [ ] + (G_so_Adv,G_so_Adv) -> and [ ] + (G_soon_Adv,G_soon_Adv) -> and [ ] + (G_then_Adv,G_then_Adv) -> and [ ] + (G_totally_Adv,G_totally_Adv) -> and [ ] + (G_up_Adv,G_up_Adv) -> and [ ] (Gin_part,Gin_part) -> and [ ] (Gin_whole,Gin_whole) -> and [ ] (GrecoverUnparsedAdv x1,GrecoverUnparsedAdv y1) -> and [ x1 == y1 ] + (Gless_CAdv,Gless_CAdv) -> and [ ] + (Gmore_CAdv,Gmore_CAdv) -> and [ ] (GAdjCN x1 x2,GAdjCN y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GCNwhereS x1 x2 x3,GCNwhereS y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] + (GComplN2 x1 x2,GComplN2 y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GRelCN x1 x2,GRelCN y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GUseN x1,GUseN y1) -> and [ x1 == y1 ] + (G_CN_of_any_kind_CN x1,G_CN_of_any_kind_CN y1) -> and [ x1 == y1 ] (LexCN x,LexCN y) -> x == y + (GAdNum x1 x2,GAdNum y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GNumDigits x1,GNumDigits y1) -> and [ x1 == y1 ] (GCompAP x1,GCompAP y1) -> and [ x1 == y1 ] (GCompAdv x1,GCompAdv y1) -> and [ x1 == y1 ] (GCompNP x1,GCompNP y1) -> and [ x1 == y1 ] @@ -438,22 +519,24 @@ instance Eq (Tree a) where (GRPConstraint x1 x2 x3,GRPConstraint y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GWHEN x1 x2 x3 x4,GWHEN y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GrecoverUnparsedCond x1,GrecoverUnparsedCond y1) -> and [ x1 == y1 ] - (GAND,GAND) -> and [ ] - (GOR,GOR) -> and [ ] + (LexConj x,LexConj y) -> x == y (GConjConstraint x1 x2,GConjConstraint y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GConjPreConstraint x1 x2 x3,GConjPreConstraint y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GConjPrePostConstraint x1 x2 x3 x4,GConjPrePostConstraint y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GRPleafAP x1,GRPleafAP y1) -> and [ x1 == y1 ] + (GRPleafAdv x1,GRPleafAdv y1) -> and [ x1 == y1 ] (GRPleafNP x1,GRPleafNP y1) -> and [ x1 == y1 ] (GRPleafS x1 x2,GRPleafS y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GRPleafVP x1,GRPleafVP y1) -> and [ x1 == y1 ] (GrecoverRPis x1 x2,GrecoverRPis y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GrecoverRPmath x1 x2 x3,GrecoverRPmath y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GrecoverUnparsedConstraint x1,GrecoverUnparsedConstraint y1) -> and [ x1 == y1 ] (GMkDate x1 x2 x3,GMkDate y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (LexDay x,LexDay y) -> x == y (GMAY,GMAY) -> and [ ] (GMUST,GMUST) -> and [ ] (GSHANT,GSHANT) -> and [ ] + (GaPl,GaPl) -> and [ ] (GaSg,GaSg) -> and [ ] (GthePl,GthePl) -> and [ ] (GtheSg,GtheSg) -> and [ ] @@ -481,13 +564,22 @@ instance Eq (Tree a) where (GListVPS x1,GListVPS y1) -> and [x == y | (x,y) <- zip x1 y1] (GListWho x1,GListWho y1) -> and [x == y | (x,y) <- zip x1 y1] (LexMonth x,LexMonth y) -> x == y + (GCompoundN x1 x2,GCompoundN y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (LexN x,LexN y) -> x == y + (G_premise_where_N2,G_premise_where_N2) -> and [ ] + (G_travel_by_N2,G_travel_by_N2) -> and [ ] (GConjNP x1 x2,GConjNP y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GContents,GContents) -> and [ ] (GDetCN x1 x2,GDetCN y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GEVERY x1,GEVERY y1) -> and [ x1 == y1 ] + (GGenModNP x1 x2 x3,GGenModNP y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GGerundNP x1,GGerundNP y1) -> and [ x1 == y1 ] (GLoss_or_Damage,GLoss_or_Damage) -> and [ ] (GMassNP x1,GMassNP y1) -> and [ x1 == y1 ] (GNDB_Qualification,GNDB_Qualification) -> and [ ] + (GSubjWho x1 x2,GSubjWho y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GUsePN x1,GUsePN y1) -> and [ x1 == y1 ] + (GYou,GYou) -> and [ ] (Ganimal,Ganimal) -> and [ ] (Gany_other_exclusion,Gany_other_exclusion) -> and [ ] (Gbirds,Gbirds) -> and [ ] @@ -498,6 +590,7 @@ instance Eq (Tree a) where (Ginsects,Ginsects) -> and [ ] (Gplumbing_heating_or_AC,Gplumbing_heating_or_AC) -> and [ ] (Gpremium,Gpremium) -> and [ ] + (GrecoverUnparsedNP x1,GrecoverUnparsedNP y1) -> and [ x1 == y1 ] (Gresult_from x1,Gresult_from y1) -> and [ x1 == y1 ] (Grodents,Grodents) -> and [ ] (Gsigned,Gsigned) -> and [ ] @@ -506,7 +599,10 @@ instance Eq (Tree a) where (Gswimming_pool,Gswimming_pool) -> and [ ] (Gvermin,Gvermin) -> and [ ] (Gwater,Gwater) -> and [ ] + (GNumPl,GNumPl) -> and [ ] + (GNumSg,GNumSg) -> and [ ] (Gnum x1,Gnum y1) -> and [ x1 == y1 ] + (LexPN x,LexPN y) -> x == y (GNEG,GNEG) -> and [ ] (GPOS,GPOS) -> and [ ] (GAP_PrePost x1,GAP_PrePost y1) -> and [ x1 == y1 ] @@ -514,20 +610,16 @@ instance Eq (Tree a) where (GNP_PrePost x1,GNP_PrePost y1) -> and [ x1 == y1 ] (GNP_caused_NP_to_VP_Prep_PrePost x1 x2 x3 x4,GNP_caused_NP_to_VP_Prep_PrePost y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GNP_caused_by_PrePost x1,GNP_caused_by_PrePost y1) -> and [ x1 == y1 ] - (GV2_PrePost x1,GV2_PrePost y1) -> and [ x1 == y1 ] + (GSSlash_PrePost x1 x2 x3 x4,GSSlash_PrePost y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] + (GS_PrePost x1 x2,GS_PrePost y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GV2_PrePost x1 x2 x3,GV2_PrePost y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (GrecoverUnparsedPrePost x1,GrecoverUnparsedPrePost y1) -> and [ x1 == y1 ] (GConjPrep x1 x2,GConjPrep y1 y2) -> and [ x1 == y1 , x2 == y2 ] - (Gabout_Prep,Gabout_Prep) -> and [ ] - (Gafter_Prep,Gafter_Prep) -> and [ ] - (Gbefore_Prep,Gbefore_Prep) -> and [ ] - (Gfor_Prep,Gfor_Prep) -> and [ ] - (Gfrom_Prep,Gfrom_Prep) -> and [ ] - (Gon_Prep,Gon_Prep) -> and [ ] - (Gpossess_Prep,Gpossess_Prep) -> and [ ] - (Gto_Prep,Gto_Prep) -> and [ ] - (Gwithin_Prep,Gwithin_Prep) -> and [ ] + (LexPrep x,LexPrep y) -> x == y (GConjPrePostQS x1 x2 x3 x4,GConjPrePostQS y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GConjQS x1 x2,GConjQS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GIdRP,GIdRP) -> and [ ] + (GRelVPS x1 x2,GRelVPS y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GConjPrePostS x1 x2 x3 x4,GConjPrePostS y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GConjS x1 x2,GConjS y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GPredVPS x1 x2,GPredVPS y1 y2) -> and [ x1 == y1 , x2 == y2 ] @@ -559,13 +651,7 @@ instance Eq (Tree a) where (Gpot51,Gpot51) -> and [ ] (Gpot5float x1,Gpot5float y1) -> and [ x1 == y1 ] (Gpot5plus x1 x2,Gpot5plus y1 y2) -> and [ x1 == y1 , x2 == y2 ] - (GAN x1,GAN y1) -> and [ x1 == y1 ] - (GEVERY x1,GEVERY y1) -> and [ x1 == y1 ] - (GPARTY x1,GPARTY y1) -> and [ x1 == y1 ] - (GSubjWho x1 x2,GSubjWho y1 y2) -> and [ x1 == y1 , x2 == y2 ] - (GTHE x1,GTHE y1) -> and [ x1 == y1 ] - (GYou,GYou) -> and [ ] - (GrecoverUnparsedSubj x1,GrecoverUnparsedSubj y1) -> and [ x1 == y1 ] + (LexSubj x,LexSubj y) -> x == y (GAFTER,GAFTER) -> and [ ] (GBEFORE,GBEFORE) -> and [ ] (GBY,GBY) -> and [ ] @@ -592,7 +678,9 @@ instance Eq (Tree a) where (GYear_Unit,GYear_Unit) -> and [ ] (GrecoverUnparsedTimeUnit x1,GrecoverUnparsedTimeUnit y1) -> and [ x1 == y1 ] (GUPON x1,GUPON y1) -> and [ x1 == y1 ] + (GUPONnp x1 x2,GUPONnp y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GrecoverUnparsedUpon x1,GrecoverUnparsedUpon y1) -> and [ x1 == y1 ] + (LexV x,LexV y) -> x == y (LexV2 x,LexV2 y) -> x == y (GAdvVP x1 x2,GAdvVP y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GComplV2 x1 x2,GComplV2 y1 y2) -> and [ x1 == y1 , x2 == y2 ] @@ -601,10 +689,14 @@ instance Eq (Tree a) where (GComplVSif x1 x2,GComplVSif y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GComplVSthat x1 x2,GComplVSthat y1 y2) -> and [ x1 == y1 , x2 == y2 ] (GUseComp x1,GUseComp y1) -> and [ x1 == y1 ] + (GUseV x1,GUseV y1) -> and [ x1 == y1 ] (LexVP x,LexVP y) -> x == y (GMkVPI x1,GMkVPI y1) -> and [ x1 == y1 ] + (GComparison_Card_Years x1,GComparison_Card_Years y1) -> and [ x1 == y1 ] (GConjPrePostVPS x1 x2 x3 x4,GConjPrePostVPS y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (GConjVPS x1 x2,GConjVPS y1 y2) -> and [ x1 == y1 , x2 == y2 ] + (GGreaterThan x1,GGreaterThan y1) -> and [ x1 == y1 ] + (GLessThan x1,GLessThan y1) -> and [ x1 == y1 ] (GMayHave x1,GMayHave y1) -> and [ x1 == y1 ] (GMkVPS x1 x2 x3,GMkVPS y1 y2 y3) -> and [ x1 == y1 , x2 == y2 , x3 == y3 ] (LexVS x,LexVS y) -> x == y @@ -618,13 +710,34 @@ instance Eq (Tree a) where (GrecoverUnparsedWho x1,GrecoverUnparsedWho y1) -> and [ x1 == y1 ] (GMkYear x1 x2 x3 x4,GMkYear y1 y2 y3 y4) -> and [ x1 == y1 , x2 == y2 , x3 == y3 , x4 == y4 ] (LexYearComponent x,LexYearComponent y) -> x == y - (LexN x,LexN y) -> x == y (GString x, GString y) -> x == y (GInt x, GInt y) -> x == y (GFloat x, GFloat y) -> x == y _ -> False +instance Gf GA where + gf (LexA x) = mkApp (mkCId x) [] + + fg t = + case unApp t of + + Just (i,[]) -> LexA (showCId i) + _ -> error ("no A " ++ show t) + +instance Gf GA2 where + gf G_located_in_A2 = mkApp (mkCId "_located_in_A2") [] + gf Gdue_to_A2 = mkApp (mkCId "due_to_A2") [] + + fg t = + case unApp t of + Just (i,[]) | i == mkCId "_located_in_A2" -> G_located_in_A2 + Just (i,[]) | i == mkCId "due_to_A2" -> Gdue_to_A2 + + + _ -> error ("no A2 " ++ show t) + instance Gf GAP where + gf (GComplA2 x1 x2) = mkApp (mkCId "ComplA2") [gf x1, gf x2] gf (GConjAP x1 x2) = mkApp (mkCId "ConjAP") [gf x1, gf x2] gf (GInt_or_older x1) = mkApp (mkCId "Int_or_older") [gf x1] gf (GPositA x1) = mkApp (mkCId "PositA") [gf x1] @@ -634,6 +747,7 @@ instance Gf GAP where fg t = case unApp t of + Just (i,[x1,x2]) | i == mkCId "ComplA2" -> GComplA2 (fg x1) (fg x2) Just (i,[x1,x2]) | i == mkCId "ConjAP" -> GConjAP (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "Int_or_older" -> GInt_or_older (fg x1) Just (i,[x1]) | i == mkCId "PositA" -> GPositA (fg x1) @@ -660,16 +774,53 @@ instance Gf GAdA where fg t = case unApp t of - Just (i,[]) | i == mkCId "only_AdA" -> Gonly_AdA + Just (i,[]) | i == mkCId "only_AdA" -> Gonly_AdA _ -> error ("no AdA " ++ show t) +instance Gf GAdN where + gf (GAdnCAdv x1) = mkApp (mkCId "AdnCAdv") [gf x1] + gf Gat_least_AdN = mkApp (mkCId "at_least_AdN") [] + gf Gat_most_AdN = mkApp (mkCId "at_most_AdN") [] + + fg t = + case unApp t of + Just (i,[x1]) | i == mkCId "AdnCAdv" -> GAdnCAdv (fg x1) + Just (i,[]) | i == mkCId "at_least_AdN" -> Gat_least_AdN + Just (i,[]) | i == mkCId "at_most_AdN" -> Gat_most_AdN + + + _ -> error ("no AdN " ++ show t) + instance Gf GAdv where gf (GAdAdv x1 x2) = mkApp (mkCId "AdAdv") [gf x1, gf x2] gf (GByVP x1) = mkApp (mkCId "ByVP") [gf x1] gf (GConjAdv x1 x2) = mkApp (mkCId "ConjAdv") [gf x1, gf x2] gf (GPrepNP x1 x2) = mkApp (mkCId "PrepNP") [gf x1, gf x2] + gf (GSubjS x1 x2) = mkApp (mkCId "SubjS") [gf x1, gf x2] + gf (GWhileDoing x1) = mkApp (mkCId "WhileDoing") [gf x1] + gf G_as_Adv = mkApp (mkCId "_as_Adv") [] + gf G_at_Adv = mkApp (mkCId "_at_Adv") [] + gf G_directly_Adv = mkApp (mkCId "_directly_Adv") [] + gf G_first_Adv = mkApp (mkCId "_first_Adv") [] + gf G_fully_Adv = mkApp (mkCId "_fully_Adv") [] + gf G_hence_Adv = mkApp (mkCId "_hence_Adv") [] + gf G_here_Adv = mkApp (mkCId "_here_Adv") [] + gf G_indirectly_Adv = mkApp (mkCId "_indirectly_Adv") [] + gf G_least_Adv = mkApp (mkCId "_least_Adv") [] + gf G_long_Adv = mkApp (mkCId "_long_Adv") [] + gf G_more_Adv = mkApp (mkCId "_more_Adv") [] + gf G_no_Adv = mkApp (mkCId "_no_Adv") [] + gf G_on_its_way_Adv = mkApp (mkCId "_on_its_way_Adv") [] + gf G_only_Adv = mkApp (mkCId "_only_Adv") [] + gf G_permanently_Adv = mkApp (mkCId "_permanently_Adv") [] + gf G_pland_Adv = mkApp (mkCId "_pland_Adv") [] + gf G_so_Adv = mkApp (mkCId "_so_Adv") [] + gf G_soon_Adv = mkApp (mkCId "_soon_Adv") [] + gf G_then_Adv = mkApp (mkCId "_then_Adv") [] + gf G_totally_Adv = mkApp (mkCId "_totally_Adv") [] + gf G_up_Adv = mkApp (mkCId "_up_Adv") [] gf Gin_part = mkApp (mkCId "in_part") [] gf Gin_whole = mkApp (mkCId "in_whole") [] gf (GrecoverUnparsedAdv x1) = mkApp (mkCId "recoverUnparsedAdv") [gf x1] @@ -680,26 +831,81 @@ instance Gf GAdv where Just (i,[x1]) | i == mkCId "ByVP" -> GByVP (fg x1) Just (i,[x1,x2]) | i == mkCId "ConjAdv" -> GConjAdv (fg x1) (fg x2) Just (i,[x1,x2]) | i == mkCId "PrepNP" -> GPrepNP (fg x1) (fg x2) - Just (i,[]) | i == mkCId "in_part" -> Gin_part - Just (i,[]) | i == mkCId "in_whole" -> Gin_whole + Just (i,[x1,x2]) | i == mkCId "SubjS" -> GSubjS (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "WhileDoing" -> GWhileDoing (fg x1) + Just (i,[]) | i == mkCId "_as_Adv" -> G_as_Adv + Just (i,[]) | i == mkCId "_at_Adv" -> G_at_Adv + Just (i,[]) | i == mkCId "_directly_Adv" -> G_directly_Adv + Just (i,[]) | i == mkCId "_first_Adv" -> G_first_Adv + Just (i,[]) | i == mkCId "_fully_Adv" -> G_fully_Adv + Just (i,[]) | i == mkCId "_hence_Adv" -> G_hence_Adv + Just (i,[]) | i == mkCId "_here_Adv" -> G_here_Adv + Just (i,[]) | i == mkCId "_indirectly_Adv" -> G_indirectly_Adv + Just (i,[]) | i == mkCId "_least_Adv" -> G_least_Adv + Just (i,[]) | i == mkCId "_long_Adv" -> G_long_Adv + Just (i,[]) | i == mkCId "_more_Adv" -> G_more_Adv + Just (i,[]) | i == mkCId "_no_Adv" -> G_no_Adv + Just (i,[]) | i == mkCId "_on_its_way_Adv" -> G_on_its_way_Adv + Just (i,[]) | i == mkCId "_only_Adv" -> G_only_Adv + Just (i,[]) | i == mkCId "_permanently_Adv" -> G_permanently_Adv + Just (i,[]) | i == mkCId "_pland_Adv" -> G_pland_Adv + Just (i,[]) | i == mkCId "_so_Adv" -> G_so_Adv + Just (i,[]) | i == mkCId "_soon_Adv" -> G_soon_Adv + Just (i,[]) | i == mkCId "_then_Adv" -> G_then_Adv + Just (i,[]) | i == mkCId "_totally_Adv" -> G_totally_Adv + Just (i,[]) | i == mkCId "_up_Adv" -> G_up_Adv + Just (i,[]) | i == mkCId "in_part" -> Gin_part + Just (i,[]) | i == mkCId "in_whole" -> Gin_whole Just (i,[x1]) | i == mkCId "recoverUnparsedAdv" -> GrecoverUnparsedAdv (fg x1) _ -> error ("no Adv " ++ show t) +instance Gf GCAdv where + gf Gless_CAdv = mkApp (mkCId "less_CAdv") [] + gf Gmore_CAdv = mkApp (mkCId "more_CAdv") [] + + fg t = + case unApp t of + Just (i,[]) | i == mkCId "less_CAdv" -> Gless_CAdv + Just (i,[]) | i == mkCId "more_CAdv" -> Gmore_CAdv + + + _ -> error ("no CAdv " ++ show t) + instance Gf GCN where gf (GAdjCN x1 x2) = mkApp (mkCId "AdjCN") [gf x1, gf x2] + gf (GCNwhereS x1 x2 x3) = mkApp (mkCId "CNwhereS") [gf x1, gf x2, gf x3] + gf (GComplN2 x1 x2) = mkApp (mkCId "ComplN2") [gf x1, gf x2] + gf (GRelCN x1 x2) = mkApp (mkCId "RelCN") [gf x1, gf x2] gf (GUseN x1) = mkApp (mkCId "UseN") [gf x1] + gf (G_CN_of_any_kind_CN x1) = mkApp (mkCId "_CN_of_any_kind_CN") [gf x1] gf (LexCN x) = mkApp (mkCId x) [] fg t = case unApp t of Just (i,[x1,x2]) | i == mkCId "AdjCN" -> GAdjCN (fg x1) (fg x2) + Just (i,[x1,x2,x3]) | i == mkCId "CNwhereS" -> GCNwhereS (fg x1) (fg x2) (fg x3) + Just (i,[x1,x2]) | i == mkCId "ComplN2" -> GComplN2 (fg x1) (fg x2) + Just (i,[x1,x2]) | i == mkCId "RelCN" -> GRelCN (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "UseN" -> GUseN (fg x1) + Just (i,[x1]) | i == mkCId "_CN_of_any_kind_CN" -> G_CN_of_any_kind_CN (fg x1) Just (i,[]) -> LexCN (showCId i) _ -> error ("no CN " ++ show t) +instance Gf GCard where + gf (GAdNum x1 x2) = mkApp (mkCId "AdNum") [gf x1, gf x2] + gf (GNumDigits x1) = mkApp (mkCId "NumDigits") [gf x1] + + fg t = + case unApp t of + Just (i,[x1,x2]) | i == mkCId "AdNum" -> GAdNum (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "NumDigits" -> GNumDigits (fg x1) + + + _ -> error ("no Card " ++ show t) + instance Gf GComp where gf (GCompAP x1) = mkApp (mkCId "CompAP") [gf x1] gf (GCompAdv x1) = mkApp (mkCId "CompAdv") [gf x1] @@ -735,15 +941,12 @@ instance Gf GCond where _ -> error ("no Cond " ++ show t) instance Gf GConj where - gf GAND = mkApp (mkCId "AND") [] - gf GOR = mkApp (mkCId "OR") [] + gf (LexConj x) = mkApp (mkCId x) [] fg t = case unApp t of - Just (i,[]) | i == mkCId "AND" -> GAND - Just (i,[]) | i == mkCId "OR" -> GOR - + Just (i,[]) -> LexConj (showCId i) _ -> error ("no Conj " ++ show t) instance Gf GConstraint where @@ -751,10 +954,12 @@ instance Gf GConstraint where gf (GConjPreConstraint x1 x2 x3) = mkApp (mkCId "ConjPreConstraint") [gf x1, gf x2, gf x3] gf (GConjPrePostConstraint x1 x2 x3 x4) = mkApp (mkCId "ConjPrePostConstraint") [gf x1, gf x2, gf x3, gf x4] gf (GRPleafAP x1) = mkApp (mkCId "RPleafAP") [gf x1] + gf (GRPleafAdv x1) = mkApp (mkCId "RPleafAdv") [gf x1] gf (GRPleafNP x1) = mkApp (mkCId "RPleafNP") [gf x1] gf (GRPleafS x1 x2) = mkApp (mkCId "RPleafS") [gf x1, gf x2] gf (GRPleafVP x1) = mkApp (mkCId "RPleafVP") [gf x1] gf (GrecoverRPis x1 x2) = mkApp (mkCId "recoverRPis") [gf x1, gf x2] + gf (GrecoverRPmath x1 x2 x3) = mkApp (mkCId "recoverRPmath") [gf x1, gf x2, gf x3] gf (GrecoverUnparsedConstraint x1) = mkApp (mkCId "recoverUnparsedConstraint") [gf x1] fg t = @@ -763,10 +968,12 @@ instance Gf GConstraint where Just (i,[x1,x2,x3]) | i == mkCId "ConjPreConstraint" -> GConjPreConstraint (fg x1) (fg x2) (fg x3) Just (i,[x1,x2,x3,x4]) | i == mkCId "ConjPrePostConstraint" -> GConjPrePostConstraint (fg x1) (fg x2) (fg x3) (fg x4) Just (i,[x1]) | i == mkCId "RPleafAP" -> GRPleafAP (fg x1) + Just (i,[x1]) | i == mkCId "RPleafAdv" -> GRPleafAdv (fg x1) Just (i,[x1]) | i == mkCId "RPleafNP" -> GRPleafNP (fg x1) Just (i,[x1,x2]) | i == mkCId "RPleafS" -> GRPleafS (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "RPleafVP" -> GRPleafVP (fg x1) Just (i,[x1,x2]) | i == mkCId "recoverRPis" -> GrecoverRPis (fg x1) (fg x2) + Just (i,[x1,x2,x3]) | i == mkCId "recoverRPmath" -> GrecoverRPmath (fg x1) (fg x2) (fg x3) Just (i,[x1]) | i == mkCId "recoverUnparsedConstraint" -> GrecoverUnparsedConstraint (fg x1) @@ -798,14 +1005,15 @@ instance Gf GDeontic where fg t = case unApp t of - Just (i,[]) | i == mkCId "MAY" -> GMAY - Just (i,[]) | i == mkCId "MUST" -> GMUST - Just (i,[]) | i == mkCId "SHANT" -> GSHANT + Just (i,[]) | i == mkCId "MAY" -> GMAY + Just (i,[]) | i == mkCId "MUST" -> GMUST + Just (i,[]) | i == mkCId "SHANT" -> GSHANT _ -> error ("no Deontic " ++ show t) instance Gf GDet where + gf GaPl = mkApp (mkCId "aPl") [] gf GaSg = mkApp (mkCId "aSg") [] gf GthePl = mkApp (mkCId "thePl") [] gf GtheSg = mkApp (mkCId "theSg") [] @@ -813,10 +1021,11 @@ instance Gf GDet where fg t = case unApp t of - Just (i,[]) | i == mkCId "aSg" -> GaSg - Just (i,[]) | i == mkCId "thePl" -> GthePl - Just (i,[]) | i == mkCId "theSg" -> GtheSg - Just (i,[]) | i == mkCId "your" -> Gyour + Just (i,[]) | i == mkCId "aPl" -> GaPl + Just (i,[]) | i == mkCId "aSg" -> GaSg + Just (i,[]) | i == mkCId "thePl" -> GthePl + Just (i,[]) | i == mkCId "theSg" -> GtheSg + Just (i,[]) | i == mkCId "your" -> Gyour _ -> error ("no Det " ++ show t) @@ -842,14 +1051,14 @@ instance Gf GDigit where fg t = case unApp t of - Just (i,[]) | i == mkCId "n2" -> Gn2 - Just (i,[]) | i == mkCId "n3" -> Gn3 - Just (i,[]) | i == mkCId "n4" -> Gn4 - Just (i,[]) | i == mkCId "n5" -> Gn5 - Just (i,[]) | i == mkCId "n6" -> Gn6 - Just (i,[]) | i == mkCId "n7" -> Gn7 - Just (i,[]) | i == mkCId "n8" -> Gn8 - Just (i,[]) | i == mkCId "n9" -> Gn9 + Just (i,[]) | i == mkCId "n2" -> Gn2 + Just (i,[]) | i == mkCId "n3" -> Gn3 + Just (i,[]) | i == mkCId "n4" -> Gn4 + Just (i,[]) | i == mkCId "n5" -> Gn5 + Just (i,[]) | i == mkCId "n6" -> Gn6 + Just (i,[]) | i == mkCId "n7" -> Gn7 + Just (i,[]) | i == mkCId "n8" -> Gn8 + Just (i,[]) | i == mkCId "n9" -> Gn9 _ -> error ("no Digit " ++ show t) @@ -1007,14 +1216,42 @@ instance Gf GMonth where Just (i,[]) -> LexMonth (showCId i) _ -> error ("no Month " ++ show t) +instance Gf GN where + gf (GCompoundN x1 x2) = mkApp (mkCId "CompoundN") [gf x1, gf x2] + gf (LexN x) = mkApp (mkCId x) [] + + fg t = + case unApp t of + Just (i,[x1,x2]) | i == mkCId "CompoundN" -> GCompoundN (fg x1) (fg x2) + + Just (i,[]) -> LexN (showCId i) + _ -> error ("no N " ++ show t) + +instance Gf GN2 where + gf G_premise_where_N2 = mkApp (mkCId "_premise_where_N2") [] + gf G_travel_by_N2 = mkApp (mkCId "_travel_by_N2") [] + + fg t = + case unApp t of + Just (i,[]) | i == mkCId "_premise_where_N2" -> G_premise_where_N2 + Just (i,[]) | i == mkCId "_travel_by_N2" -> G_travel_by_N2 + + + _ -> error ("no N2 " ++ show t) + instance Gf GNP where gf (GConjNP x1 x2) = mkApp (mkCId "ConjNP") [gf x1, gf x2] gf GContents = mkApp (mkCId "Contents") [] gf (GDetCN x1 x2) = mkApp (mkCId "DetCN") [gf x1, gf x2] + gf (GEVERY x1) = mkApp (mkCId "EVERY") [gf x1] + gf (GGenModNP x1 x2 x3) = mkApp (mkCId "GenModNP") [gf x1, gf x2, gf x3] gf (GGerundNP x1) = mkApp (mkCId "GerundNP") [gf x1] gf GLoss_or_Damage = mkApp (mkCId "Loss_or_Damage") [] gf (GMassNP x1) = mkApp (mkCId "MassNP") [gf x1] gf GNDB_Qualification = mkApp (mkCId "NDB_Qualification") [] + gf (GSubjWho x1 x2) = mkApp (mkCId "SubjWho") [gf x1, gf x2] + gf (GUsePN x1) = mkApp (mkCId "UsePN") [gf x1] + gf GYou = mkApp (mkCId "You") [] gf Ganimal = mkApp (mkCId "animal") [] gf Gany_other_exclusion = mkApp (mkCId "any_other_exclusion") [] gf Gbirds = mkApp (mkCId "birds") [] @@ -1025,6 +1262,7 @@ instance Gf GNP where gf Ginsects = mkApp (mkCId "insects") [] gf Gplumbing_heating_or_AC = mkApp (mkCId "plumbing_heating_or_AC") [] gf Gpremium = mkApp (mkCId "premium") [] + gf (GrecoverUnparsedNP x1) = mkApp (mkCId "recoverUnparsedNP") [gf x1] gf (Gresult_from x1) = mkApp (mkCId "result_from") [gf x1] gf Grodents = mkApp (mkCId "rodents") [] gf Gsigned = mkApp (mkCId "signed") [] @@ -1037,34 +1275,52 @@ instance Gf GNP where fg t = case unApp t of Just (i,[x1,x2]) | i == mkCId "ConjNP" -> GConjNP (fg x1) (fg x2) - Just (i,[]) | i == mkCId "Contents" -> GContents + Just (i,[]) | i == mkCId "Contents" -> GContents Just (i,[x1,x2]) | i == mkCId "DetCN" -> GDetCN (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "EVERY" -> GEVERY (fg x1) + Just (i,[x1,x2,x3]) | i == mkCId "GenModNP" -> GGenModNP (fg x1) (fg x2) (fg x3) Just (i,[x1]) | i == mkCId "GerundNP" -> GGerundNP (fg x1) - Just (i,[]) | i == mkCId "Loss_or_Damage" -> GLoss_or_Damage + Just (i,[]) | i == mkCId "Loss_or_Damage" -> GLoss_or_Damage Just (i,[x1]) | i == mkCId "MassNP" -> GMassNP (fg x1) - Just (i,[]) | i == mkCId "NDB_Qualification" -> GNDB_Qualification - Just (i,[]) | i == mkCId "animal" -> Ganimal - Just (i,[]) | i == mkCId "any_other_exclusion" -> Gany_other_exclusion - Just (i,[]) | i == mkCId "birds" -> Gbirds - Just (i,[]) | i == mkCId "cancelled" -> Gcancelled - Just (i,[]) | i == mkCId "claim" -> Gclaim - Just (i,[]) | i == mkCId "condition" -> Gcondition - Just (i,[]) | i == mkCId "household_appliance" -> Ghousehold_appliance - Just (i,[]) | i == mkCId "insects" -> Ginsects - Just (i,[]) | i == mkCId "plumbing_heating_or_AC" -> Gplumbing_heating_or_AC - Just (i,[]) | i == mkCId "premium" -> Gpremium + Just (i,[]) | i == mkCId "NDB_Qualification" -> GNDB_Qualification + Just (i,[x1,x2]) | i == mkCId "SubjWho" -> GSubjWho (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "UsePN" -> GUsePN (fg x1) + Just (i,[]) | i == mkCId "You" -> GYou + Just (i,[]) | i == mkCId "animal" -> Ganimal + Just (i,[]) | i == mkCId "any_other_exclusion" -> Gany_other_exclusion + Just (i,[]) | i == mkCId "birds" -> Gbirds + Just (i,[]) | i == mkCId "cancelled" -> Gcancelled + Just (i,[]) | i == mkCId "claim" -> Gclaim + Just (i,[]) | i == mkCId "condition" -> Gcondition + Just (i,[]) | i == mkCId "household_appliance" -> Ghousehold_appliance + Just (i,[]) | i == mkCId "insects" -> Ginsects + Just (i,[]) | i == mkCId "plumbing_heating_or_AC" -> Gplumbing_heating_or_AC + Just (i,[]) | i == mkCId "premium" -> Gpremium + Just (i,[x1]) | i == mkCId "recoverUnparsedNP" -> GrecoverUnparsedNP (fg x1) Just (i,[x1]) | i == mkCId "result_from" -> Gresult_from (fg x1) - Just (i,[]) | i == mkCId "rodents" -> Grodents - Just (i,[]) | i == mkCId "signed" -> Gsigned - Just (i,[]) | i == mkCId "stay_during_policy_period" -> Gstay_during_policy_period - Just (i,[]) | i == mkCId "stay_overnight" -> Gstay_overnight - Just (i,[]) | i == mkCId "swimming_pool" -> Gswimming_pool - Just (i,[]) | i == mkCId "vermin" -> Gvermin - Just (i,[]) | i == mkCId "water" -> Gwater + Just (i,[]) | i == mkCId "rodents" -> Grodents + Just (i,[]) | i == mkCId "signed" -> Gsigned + Just (i,[]) | i == mkCId "stay_during_policy_period" -> Gstay_during_policy_period + Just (i,[]) | i == mkCId "stay_overnight" -> Gstay_overnight + Just (i,[]) | i == mkCId "swimming_pool" -> Gswimming_pool + Just (i,[]) | i == mkCId "vermin" -> Gvermin + Just (i,[]) | i == mkCId "water" -> Gwater _ -> error ("no NP " ++ show t) +instance Gf GNum where + gf GNumPl = mkApp (mkCId "NumPl") [] + gf GNumSg = mkApp (mkCId "NumSg") [] + + fg t = + case unApp t of + Just (i,[]) | i == mkCId "NumPl" -> GNumPl + Just (i,[]) | i == mkCId "NumSg" -> GNumSg + + + _ -> error ("no Num " ++ show t) + instance Gf GNumeral where gf (Gnum x1) = mkApp (mkCId "num") [gf x1] @@ -1075,14 +1331,23 @@ instance Gf GNumeral where _ -> error ("no Numeral " ++ show t) +instance Gf GPN where + gf (LexPN x) = mkApp (mkCId x) [] + + fg t = + case unApp t of + + Just (i,[]) -> LexPN (showCId i) + _ -> error ("no PN " ++ show t) + instance Gf GPol where gf GNEG = mkApp (mkCId "NEG") [] gf GPOS = mkApp (mkCId "POS") [] fg t = case unApp t of - Just (i,[]) | i == mkCId "NEG" -> GNEG - Just (i,[]) | i == mkCId "POS" -> GPOS + Just (i,[]) | i == mkCId "NEG" -> GNEG + Just (i,[]) | i == mkCId "POS" -> GPOS _ -> error ("no Pol " ++ show t) @@ -1093,7 +1358,9 @@ instance Gf GPrePost where gf (GNP_PrePost x1) = mkApp (mkCId "NP_PrePost") [gf x1] gf (GNP_caused_NP_to_VP_Prep_PrePost x1 x2 x3 x4) = mkApp (mkCId "NP_caused_NP_to_VP_Prep_PrePost") [gf x1, gf x2, gf x3, gf x4] gf (GNP_caused_by_PrePost x1) = mkApp (mkCId "NP_caused_by_PrePost") [gf x1] - gf (GV2_PrePost x1) = mkApp (mkCId "V2_PrePost") [gf x1] + gf (GSSlash_PrePost x1 x2 x3 x4) = mkApp (mkCId "SSlash_PrePost") [gf x1, gf x2, gf x3, gf x4] + gf (GS_PrePost x1 x2) = mkApp (mkCId "S_PrePost") [gf x1, gf x2] + gf (GV2_PrePost x1 x2 x3) = mkApp (mkCId "V2_PrePost") [gf x1, gf x2, gf x3] gf (GrecoverUnparsedPrePost x1) = mkApp (mkCId "recoverUnparsedPrePost") [gf x1] fg t = @@ -1103,7 +1370,9 @@ instance Gf GPrePost where Just (i,[x1]) | i == mkCId "NP_PrePost" -> GNP_PrePost (fg x1) Just (i,[x1,x2,x3,x4]) | i == mkCId "NP_caused_NP_to_VP_Prep_PrePost" -> GNP_caused_NP_to_VP_Prep_PrePost (fg x1) (fg x2) (fg x3) (fg x4) Just (i,[x1]) | i == mkCId "NP_caused_by_PrePost" -> GNP_caused_by_PrePost (fg x1) - Just (i,[x1]) | i == mkCId "V2_PrePost" -> GV2_PrePost (fg x1) + Just (i,[x1,x2,x3,x4]) | i == mkCId "SSlash_PrePost" -> GSSlash_PrePost (fg x1) (fg x2) (fg x3) (fg x4) + Just (i,[x1,x2]) | i == mkCId "S_PrePost" -> GS_PrePost (fg x1) (fg x2) + Just (i,[x1,x2,x3]) | i == mkCId "V2_PrePost" -> GV2_PrePost (fg x1) (fg x2) (fg x3) Just (i,[x1]) | i == mkCId "recoverUnparsedPrePost" -> GrecoverUnparsedPrePost (fg x1) @@ -1111,30 +1380,13 @@ instance Gf GPrePost where instance Gf GPrep where gf (GConjPrep x1 x2) = mkApp (mkCId "ConjPrep") [gf x1, gf x2] - gf Gabout_Prep = mkApp (mkCId "about_Prep") [] - gf Gafter_Prep = mkApp (mkCId "after_Prep") [] - gf Gbefore_Prep = mkApp (mkCId "before_Prep") [] - gf Gfor_Prep = mkApp (mkCId "for_Prep") [] - gf Gfrom_Prep = mkApp (mkCId "from_Prep") [] - gf Gon_Prep = mkApp (mkCId "on_Prep") [] - gf Gpossess_Prep = mkApp (mkCId "possess_Prep") [] - gf Gto_Prep = mkApp (mkCId "to_Prep") [] - gf Gwithin_Prep = mkApp (mkCId "within_Prep") [] + gf (LexPrep x) = mkApp (mkCId x) [] fg t = case unApp t of Just (i,[x1,x2]) | i == mkCId "ConjPrep" -> GConjPrep (fg x1) (fg x2) - Just (i,[]) | i == mkCId "about_Prep" -> Gabout_Prep - Just (i,[]) | i == mkCId "after_Prep" -> Gafter_Prep - Just (i,[]) | i == mkCId "before_Prep" -> Gbefore_Prep - Just (i,[]) | i == mkCId "for_Prep" -> Gfor_Prep - Just (i,[]) | i == mkCId "from_Prep" -> Gfrom_Prep - Just (i,[]) | i == mkCId "on_Prep" -> Gon_Prep - Just (i,[]) | i == mkCId "possess_Prep" -> Gpossess_Prep - Just (i,[]) | i == mkCId "to_Prep" -> Gto_Prep - Just (i,[]) | i == mkCId "within_Prep" -> Gwithin_Prep - + Just (i,[]) -> LexPrep (showCId i) _ -> error ("no Prep " ++ show t) instance Gf GQS where @@ -1149,6 +1401,26 @@ instance Gf GQS where _ -> error ("no QS " ++ show t) +instance Gf GRP where + gf GIdRP = mkApp (mkCId "IdRP") [] + + fg t = + case unApp t of + Just (i,[]) | i == mkCId "IdRP" -> GIdRP + + + _ -> error ("no RP " ++ show t) + +instance Gf GRS where + gf (GRelVPS x1 x2) = mkApp (mkCId "RelVPS") [gf x1, gf x2] + + fg t = + case unApp t of + Just (i,[x1,x2]) | i == mkCId "RelVPS" -> GRelVPS (fg x1) (fg x2) + + + _ -> error ("no RS " ++ show t) + instance Gf GS where gf (GConjPrePostS x1 x2 x3 x4) = mkApp (mkCId "ConjPrePostS") [gf x1, gf x2, gf x3, gf x4] gf (GConjS x1 x2) = mkApp (mkCId "ConjS") [gf x1, gf x2] @@ -1172,7 +1444,7 @@ instance Gf GSub10 where fg t = case unApp t of Just (i,[x1]) | i == mkCId "pot0" -> Gpot0 (fg x1) - Just (i,[]) | i == mkCId "pot01" -> Gpot01 + Just (i,[]) | i == mkCId "pot01" -> Gpot01 _ -> error ("no Sub10 " ++ show t) @@ -1189,8 +1461,8 @@ instance Gf GSub100 where case unApp t of Just (i,[x1]) | i == mkCId "pot0as1" -> Gpot0as1 (fg x1) Just (i,[x1]) | i == mkCId "pot1" -> Gpot1 (fg x1) - Just (i,[]) | i == mkCId "pot110" -> Gpot110 - Just (i,[]) | i == mkCId "pot111" -> Gpot111 + Just (i,[]) | i == mkCId "pot110" -> Gpot110 + Just (i,[]) | i == mkCId "pot111" -> Gpot111 Just (i,[x1,x2]) | i == mkCId "pot1plus" -> Gpot1plus (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "pot1to19" -> Gpot1to19 (fg x1) @@ -1207,7 +1479,7 @@ instance Gf GSub1000 where case unApp t of Just (i,[x1]) | i == mkCId "pot1as2" -> Gpot1as2 (fg x1) Just (i,[x1]) | i == mkCId "pot2" -> Gpot2 (fg x1) - Just (i,[]) | i == mkCId "pot21" -> Gpot21 + Just (i,[]) | i == mkCId "pot21" -> Gpot21 Just (i,[x1,x2]) | i == mkCId "pot2plus" -> Gpot2plus (fg x1) (fg x2) @@ -1224,7 +1496,7 @@ instance Gf GSub1000000 where case unApp t of Just (i,[x1]) | i == mkCId "pot2as3" -> Gpot2as3 (fg x1) Just (i,[x1]) | i == mkCId "pot3" -> Gpot3 (fg x1) - Just (i,[]) | i == mkCId "pot31" -> Gpot31 + Just (i,[]) | i == mkCId "pot31" -> Gpot31 Just (i,[x1]) | i == mkCId "pot3float" -> Gpot3float (fg x1) Just (i,[x1,x2]) | i == mkCId "pot3plus" -> Gpot3plus (fg x1) (fg x2) @@ -1242,7 +1514,7 @@ instance Gf GSub1000000000 where case unApp t of Just (i,[x1]) | i == mkCId "pot3as4" -> Gpot3as4 (fg x1) Just (i,[x1]) | i == mkCId "pot4" -> Gpot4 (fg x1) - Just (i,[]) | i == mkCId "pot41" -> Gpot41 + Just (i,[]) | i == mkCId "pot41" -> Gpot41 Just (i,[x1]) | i == mkCId "pot4float" -> Gpot4float (fg x1) Just (i,[x1,x2]) | i == mkCId "pot4plus" -> Gpot4plus (fg x1) (fg x2) @@ -1260,7 +1532,7 @@ instance Gf GSub1000000000000 where case unApp t of Just (i,[x1]) | i == mkCId "pot4as5" -> Gpot4as5 (fg x1) Just (i,[x1]) | i == mkCId "pot5" -> Gpot5 (fg x1) - Just (i,[]) | i == mkCId "pot51" -> Gpot51 + Just (i,[]) | i == mkCId "pot51" -> Gpot51 Just (i,[x1]) | i == mkCId "pot5float" -> Gpot5float (fg x1) Just (i,[x1,x2]) | i == mkCId "pot5plus" -> Gpot5plus (fg x1) (fg x2) @@ -1268,25 +1540,12 @@ instance Gf GSub1000000000000 where _ -> error ("no Sub1000000000000 " ++ show t) instance Gf GSubj where - gf (GAN x1) = mkApp (mkCId "AN") [gf x1] - gf (GEVERY x1) = mkApp (mkCId "EVERY") [gf x1] - gf (GPARTY x1) = mkApp (mkCId "PARTY") [gf x1] - gf (GSubjWho x1 x2) = mkApp (mkCId "SubjWho") [gf x1, gf x2] - gf (GTHE x1) = mkApp (mkCId "THE") [gf x1] - gf GYou = mkApp (mkCId "You") [] - gf (GrecoverUnparsedSubj x1) = mkApp (mkCId "recoverUnparsedSubj") [gf x1] + gf (LexSubj x) = mkApp (mkCId x) [] fg t = case unApp t of - Just (i,[x1]) | i == mkCId "AN" -> GAN (fg x1) - Just (i,[x1]) | i == mkCId "EVERY" -> GEVERY (fg x1) - Just (i,[x1]) | i == mkCId "PARTY" -> GPARTY (fg x1) - Just (i,[x1,x2]) | i == mkCId "SubjWho" -> GSubjWho (fg x1) (fg x2) - Just (i,[x1]) | i == mkCId "THE" -> GTHE (fg x1) - Just (i,[]) | i == mkCId "You" -> GYou - Just (i,[x1]) | i == mkCId "recoverUnparsedSubj" -> GrecoverUnparsedSubj (fg x1) - + Just (i,[]) -> LexSubj (showCId i) _ -> error ("no Subj " ++ show t) instance Gf GTComparison where @@ -1299,12 +1558,12 @@ instance Gf GTComparison where fg t = case unApp t of - Just (i,[]) | i == mkCId "AFTER" -> GAFTER - Just (i,[]) | i == mkCId "BEFORE" -> GBEFORE - Just (i,[]) | i == mkCId "BY" -> GBY + Just (i,[]) | i == mkCId "AFTER" -> GAFTER + Just (i,[]) | i == mkCId "BEFORE" -> GBEFORE + Just (i,[]) | i == mkCId "BY" -> GBY Just (i,[x1,x2]) | i == mkCId "ConjTComparison" -> GConjTComparison (fg x1) (fg x2) - Just (i,[]) | i == mkCId "ON" -> GON - Just (i,[]) | i == mkCId "VAGUE" -> GVAGUE + Just (i,[]) | i == mkCId "ON" -> GON + Just (i,[]) | i == mkCId "VAGUE" -> GVAGUE _ -> error ("no TComparison " ++ show t) @@ -1316,9 +1575,9 @@ instance Gf GTemp where fg t = case unApp t of - Just (i,[]) | i == mkCId "pastSimul" -> GpastSimul - Just (i,[]) | i == mkCId "presAnt" -> GpresAnt - Just (i,[]) | i == mkCId "presSimul" -> GpresSimul + Just (i,[]) | i == mkCId "pastSimul" -> GpastSimul + Just (i,[]) | i == mkCId "presAnt" -> GpresAnt + Just (i,[]) | i == mkCId "presSimul" -> GpresSimul _ -> error ("no Temp " ++ show t) @@ -1371,9 +1630,9 @@ instance Gf GTimeUnit where fg t = case unApp t of - Just (i,[]) | i == mkCId "Day_Unit" -> GDay_Unit - Just (i,[]) | i == mkCId "Month_Unit" -> GMonth_Unit - Just (i,[]) | i == mkCId "Year_Unit" -> GYear_Unit + Just (i,[]) | i == mkCId "Day_Unit" -> GDay_Unit + Just (i,[]) | i == mkCId "Month_Unit" -> GMonth_Unit + Just (i,[]) | i == mkCId "Year_Unit" -> GYear_Unit Just (i,[x1]) | i == mkCId "recoverUnparsedTimeUnit" -> GrecoverUnparsedTimeUnit (fg x1) @@ -1381,16 +1640,27 @@ instance Gf GTimeUnit where instance Gf GUpon where gf (GUPON x1) = mkApp (mkCId "UPON") [gf x1] + gf (GUPONnp x1 x2) = mkApp (mkCId "UPONnp") [gf x1, gf x2] gf (GrecoverUnparsedUpon x1) = mkApp (mkCId "recoverUnparsedUpon") [gf x1] fg t = case unApp t of Just (i,[x1]) | i == mkCId "UPON" -> GUPON (fg x1) + Just (i,[x1,x2]) | i == mkCId "UPONnp" -> GUPONnp (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "recoverUnparsedUpon" -> GrecoverUnparsedUpon (fg x1) _ -> error ("no Upon " ++ show t) +instance Gf GV where + gf (LexV x) = mkApp (mkCId x) [] + + fg t = + case unApp t of + + Just (i,[]) -> LexV (showCId i) + _ -> error ("no V " ++ show t) + instance Gf GV2 where gf (LexV2 x) = mkApp (mkCId x) [] @@ -1408,6 +1678,7 @@ instance Gf GVP where gf (GComplVSif x1 x2) = mkApp (mkCId "ComplVSif") [gf x1, gf x2] gf (GComplVSthat x1 x2) = mkApp (mkCId "ComplVSthat") [gf x1, gf x2] gf (GUseComp x1) = mkApp (mkCId "UseComp") [gf x1] + gf (GUseV x1) = mkApp (mkCId "UseV") [gf x1] gf (LexVP x) = mkApp (mkCId x) [] fg t = @@ -1419,6 +1690,7 @@ instance Gf GVP where Just (i,[x1,x2]) | i == mkCId "ComplVSif" -> GComplVSif (fg x1) (fg x2) Just (i,[x1,x2]) | i == mkCId "ComplVSthat" -> GComplVSthat (fg x1) (fg x2) Just (i,[x1]) | i == mkCId "UseComp" -> GUseComp (fg x1) + Just (i,[x1]) | i == mkCId "UseV" -> GUseV (fg x1) Just (i,[]) -> LexVP (showCId i) _ -> error ("no VP " ++ show t) @@ -1434,15 +1706,21 @@ instance Gf GVPI where _ -> error ("no VPI " ++ show t) instance Gf GVPS where + gf (GComparison_Card_Years x1) = mkApp (mkCId "Comparison_Card_Years") [gf x1] gf (GConjPrePostVPS x1 x2 x3 x4) = mkApp (mkCId "ConjPrePostVPS") [gf x1, gf x2, gf x3, gf x4] gf (GConjVPS x1 x2) = mkApp (mkCId "ConjVPS") [gf x1, gf x2] + gf (GGreaterThan x1) = mkApp (mkCId "GreaterThan") [gf x1] + gf (GLessThan x1) = mkApp (mkCId "LessThan") [gf x1] gf (GMayHave x1) = mkApp (mkCId "MayHave") [gf x1] gf (GMkVPS x1 x2 x3) = mkApp (mkCId "MkVPS") [gf x1, gf x2, gf x3] fg t = case unApp t of + Just (i,[x1]) | i == mkCId "Comparison_Card_Years" -> GComparison_Card_Years (fg x1) Just (i,[x1,x2,x3,x4]) | i == mkCId "ConjPrePostVPS" -> GConjPrePostVPS (fg x1) (fg x2) (fg x3) (fg x4) Just (i,[x1,x2]) | i == mkCId "ConjVPS" -> GConjVPS (fg x1) (fg x2) + Just (i,[x1]) | i == mkCId "GreaterThan" -> GGreaterThan (fg x1) + Just (i,[x1]) | i == mkCId "LessThan" -> GLessThan (fg x1) Just (i,[x1]) | i == mkCId "MayHave" -> GMayHave (fg x1) Just (i,[x1,x2,x3]) | i == mkCId "MkVPS" -> GMkVPS (fg x1) (fg x2) (fg x3) @@ -1510,22 +1788,6 @@ instance Gf GYearComponent where -instance Gf GA where - gf _ = undefined - fg _ = undefined - - - - - -instance Gf GA2 where - gf _ = undefined - fg _ = undefined - - - - - instance Gf GAnt where gf _ = undefined fg _ = undefined @@ -1534,22 +1796,6 @@ instance Gf GAnt where -instance Gf GN where - gf _ = undefined - fg _ = undefined - - - - - -instance Gf GN2 where - gf _ = undefined - fg _ = undefined - - - - - instance Gf GTense where gf _ = undefined fg _ = undefined @@ -1557,16 +1803,9 @@ instance Gf GTense where - -instance Gf GV where - gf _ = undefined - fg _ = undefined - - - - instance Compos Tree where compos r a f t = case t of + GComplA2 x1 x2 -> r GComplA2 `a` f x1 `a` f x2 GConjAP x1 x2 -> r GConjAP `a` f x1 `a` f x2 GInt_or_older x1 -> r GInt_or_older `a` f x1 GPositA x1 -> r GPositA `a` f x1 @@ -1574,13 +1813,22 @@ instance Compos Tree where Gensuing x1 -> r Gensuing `a` f x1 GACTION x1 -> r GACTION `a` f x1 GrecoverUnparsedAction x1 -> r GrecoverUnparsedAction `a` f x1 + GAdnCAdv x1 -> r GAdnCAdv `a` f x1 GAdAdv x1 x2 -> r GAdAdv `a` f x1 `a` f x2 GByVP x1 -> r GByVP `a` f x1 GConjAdv x1 x2 -> r GConjAdv `a` f x1 `a` f x2 GPrepNP x1 x2 -> r GPrepNP `a` f x1 `a` f x2 + GSubjS x1 x2 -> r GSubjS `a` f x1 `a` f x2 + GWhileDoing x1 -> r GWhileDoing `a` f x1 GrecoverUnparsedAdv x1 -> r GrecoverUnparsedAdv `a` f x1 GAdjCN x1 x2 -> r GAdjCN `a` f x1 `a` f x2 + GCNwhereS x1 x2 x3 -> r GCNwhereS `a` f x1 `a` f x2 `a` f x3 + GComplN2 x1 x2 -> r GComplN2 `a` f x1 `a` f x2 + GRelCN x1 x2 -> r GRelCN `a` f x1 `a` f x2 GUseN x1 -> r GUseN `a` f x1 + G_CN_of_any_kind_CN x1 -> r G_CN_of_any_kind_CN `a` f x1 + GAdNum x1 x2 -> r GAdNum `a` f x1 `a` f x2 + GNumDigits x1 -> r GNumDigits `a` f x1 GCompAP x1 -> r GCompAP `a` f x1 GCompAdv x1 -> r GCompAdv `a` f x1 GCompNP x1 -> r GCompNP `a` f x1 @@ -1594,18 +1842,26 @@ instance Compos Tree where GConjPreConstraint x1 x2 x3 -> r GConjPreConstraint `a` f x1 `a` f x2 `a` f x3 GConjPrePostConstraint x1 x2 x3 x4 -> r GConjPrePostConstraint `a` f x1 `a` f x2 `a` f x3 `a` f x4 GRPleafAP x1 -> r GRPleafAP `a` f x1 + GRPleafAdv x1 -> r GRPleafAdv `a` f x1 GRPleafNP x1 -> r GRPleafNP `a` f x1 GRPleafS x1 x2 -> r GRPleafS `a` f x1 `a` f x2 GRPleafVP x1 -> r GRPleafVP `a` f x1 GrecoverRPis x1 x2 -> r GrecoverRPis `a` f x1 `a` f x2 + GrecoverRPmath x1 x2 x3 -> r GrecoverRPmath `a` f x1 `a` f x2 `a` f x3 GrecoverUnparsedConstraint x1 -> r GrecoverUnparsedConstraint `a` f x1 GMkDate x1 x2 x3 -> r GMkDate `a` f x1 `a` f x2 `a` f x3 GIDig x1 -> r GIDig `a` f x1 GIIDig x1 x2 -> r GIIDig `a` f x1 `a` f x2 + GCompoundN x1 x2 -> r GCompoundN `a` f x1 `a` f x2 GConjNP x1 x2 -> r GConjNP `a` f x1 `a` f x2 GDetCN x1 x2 -> r GDetCN `a` f x1 `a` f x2 + GEVERY x1 -> r GEVERY `a` f x1 + GGenModNP x1 x2 x3 -> r GGenModNP `a` f x1 `a` f x2 `a` f x3 GGerundNP x1 -> r GGerundNP `a` f x1 GMassNP x1 -> r GMassNP `a` f x1 + GSubjWho x1 x2 -> r GSubjWho `a` f x1 `a` f x2 + GUsePN x1 -> r GUsePN `a` f x1 + GrecoverUnparsedNP x1 -> r GrecoverUnparsedNP `a` f x1 Gresult_from x1 -> r Gresult_from `a` f x1 Gnum x1 -> r Gnum `a` f x1 GAP_PrePost x1 -> r GAP_PrePost `a` f x1 @@ -1613,11 +1869,14 @@ instance Compos Tree where GNP_PrePost x1 -> r GNP_PrePost `a` f x1 GNP_caused_NP_to_VP_Prep_PrePost x1 x2 x3 x4 -> r GNP_caused_NP_to_VP_Prep_PrePost `a` f x1 `a` f x2 `a` f x3 `a` f x4 GNP_caused_by_PrePost x1 -> r GNP_caused_by_PrePost `a` f x1 - GV2_PrePost x1 -> r GV2_PrePost `a` f x1 + GSSlash_PrePost x1 x2 x3 x4 -> r GSSlash_PrePost `a` f x1 `a` f x2 `a` f x3 `a` f x4 + GS_PrePost x1 x2 -> r GS_PrePost `a` f x1 `a` f x2 + GV2_PrePost x1 x2 x3 -> r GV2_PrePost `a` f x1 `a` f x2 `a` f x3 GrecoverUnparsedPrePost x1 -> r GrecoverUnparsedPrePost `a` f x1 GConjPrep x1 x2 -> r GConjPrep `a` f x1 `a` f x2 GConjPrePostQS x1 x2 x3 x4 -> r GConjPrePostQS `a` f x1 `a` f x2 `a` f x3 `a` f x4 GConjQS x1 x2 -> r GConjQS `a` f x1 `a` f x2 + GRelVPS x1 x2 -> r GRelVPS `a` f x1 `a` f x2 GConjPrePostS x1 x2 x3 x4 -> r GConjPrePostS `a` f x1 `a` f x2 `a` f x3 `a` f x4 GConjS x1 x2 -> r GConjS `a` f x1 `a` f x2 GPredVPS x1 x2 -> r GPredVPS `a` f x1 `a` f x2 @@ -1642,12 +1901,6 @@ instance Compos Tree where Gpot5 x1 -> r Gpot5 `a` f x1 Gpot5float x1 -> r Gpot5float `a` f x1 Gpot5plus x1 x2 -> r Gpot5plus `a` f x1 `a` f x2 - GAN x1 -> r GAN `a` f x1 - GEVERY x1 -> r GEVERY `a` f x1 - GPARTY x1 -> r GPARTY `a` f x1 - GSubjWho x1 x2 -> r GSubjWho `a` f x1 `a` f x2 - GTHE x1 -> r GTHE `a` f x1 - GrecoverUnparsedSubj x1 -> r GrecoverUnparsedSubj `a` f x1 GConjTComparison x1 x2 -> r GConjTComparison `a` f x1 `a` f x2 GTemporalConstraint x1 x2 x3 -> r GTemporalConstraint `a` f x1 `a` f x2 `a` f x3 GTemporalConstraintNoDigits x1 x2 -> r GTemporalConstraintNoDigits `a` f x1 `a` f x2 @@ -1663,6 +1916,7 @@ instance Compos Tree where GsWHO x1 x2 -> r GsWHO `a` f x1 `a` f x2 GrecoverUnparsedTimeUnit x1 -> r GrecoverUnparsedTimeUnit `a` f x1 GUPON x1 -> r GUPON `a` f x1 + GUPONnp x1 x2 -> r GUPONnp `a` f x1 `a` f x2 GrecoverUnparsedUpon x1 -> r GrecoverUnparsedUpon `a` f x1 GAdvVP x1 x2 -> r GAdvVP `a` f x1 `a` f x2 GComplV2 x1 x2 -> r GComplV2 `a` f x1 `a` f x2 @@ -1671,9 +1925,13 @@ instance Compos Tree where GComplVSif x1 x2 -> r GComplVSif `a` f x1 `a` f x2 GComplVSthat x1 x2 -> r GComplVSthat `a` f x1 `a` f x2 GUseComp x1 -> r GUseComp `a` f x1 + GUseV x1 -> r GUseV `a` f x1 GMkVPI x1 -> r GMkVPI `a` f x1 + GComparison_Card_Years x1 -> r GComparison_Card_Years `a` f x1 GConjPrePostVPS x1 x2 x3 x4 -> r GConjPrePostVPS `a` f x1 `a` f x2 `a` f x3 `a` f x4 GConjVPS x1 x2 -> r GConjVPS `a` f x1 `a` f x2 + GGreaterThan x1 -> r GGreaterThan `a` f x1 + GLessThan x1 -> r GLessThan `a` f x1 GMayHave x1 -> r GMayHave `a` f x1 GMkVPS x1 x2 x3 -> r GMkVPS `a` f x1 `a` f x2 `a` f x3 GAPWho x1 -> r GAPWho `a` f x1 diff --git a/lib/haskell/natural4/src/LS/NLP/NL4Transformations.hs b/lib/haskell/natural4/src/LS/NLP/NL4Transformations.hs index 651559e34..5ccb20031 100644 --- a/lib/haskell/natural4/src/LS/NLP/NL4Transformations.hs +++ b/lib/haskell/natural4/src/LS/NLP/NL4Transformations.hs @@ -28,17 +28,17 @@ pushPrePostIntoMain bsgt = case bsgt of hackStrVP :: GString -> GVP -> GVP hackStrVP in_part vp = GAdvVP vp (GrecoverUnparsedAdv in_part) - transformWho :: GV2 -> GNP -> GText -> GText - transformWho consume beverage (GqWHO person (GAPWho alcoholic)) = - GqWHO (referSubj person) (GWHO GpresSimul GPOS (GComplV2 consume (introduceNP (insertAP alcoholic beverage)))) - transformWho consume beverage (GqWHO person (GAdvWho in_part)) = - GqWHO (referSubj person) (GWHO GpresSimul GPOS (GAdvVP (GComplV2 consume (referNP beverage)) in_part)) + transformWho :: GTemp -> GPol -> GV2 -> GNP -> GText -> GText + transformWho t p consume beverage (GqWHO person (GAPWho alcoholic)) = + GqWHO (referNP person) (GWHO t p (GComplV2 consume (introduceNP (insertAP alcoholic beverage)))) + transformWho t p consume beverage (GqWHO person (GAdvWho in_part)) = + GqWHO (referNP person) (GWHO t p (GAdvVP (GComplV2 consume (referNP beverage)) in_part)) tryTransformWhole :: BoolStructGText -> BoolStructGText tryTransformWhole bs = case bs of All pp ( Any - ( Just ( PrePost (GqPREPOST ( GV2_PrePost consume ) ) + ( Just ( PrePost (GqPREPOST ( GV2_PrePost t p consume ) ) (GqPREPOST ( GNP_PrePost beverage)))) alcoholic_nonalcoholic : Any @@ -48,15 +48,15 @@ pushPrePostIntoMain bsgt = case bsgt of All pp ( Any Nothing ( - (transformWho consume beverage `mapBS`) <$> alcoholic_nonalcoholic) + (transformWho t p consume beverage `mapBS`) <$> alcoholic_nonalcoholic) : Any Nothing ( - (transformWho consume beverage `mapBS`) <$> inpart_inwhole) + (transformWho t p consume beverage `mapBS`) <$> inpart_inwhole) : restOfInnerRules ) Any pp ( All - ( Just ( PrePost (GqPREPOST ( GV2_PrePost consume ) ) + ( Just ( PrePost (GqPREPOST ( GV2_PrePost t p consume ) ) (GqPREPOST ( GNP_PrePost beverage)))) alcoholic_nonalcoholic : All @@ -66,10 +66,10 @@ pushPrePostIntoMain bsgt = case bsgt of Any pp ( All Nothing ( - (transformWho consume beverage `mapBS`) <$> alcoholic_nonalcoholic) + (transformWho t p consume beverage `mapBS`) <$> alcoholic_nonalcoholic) : All Nothing ( - (transformWho consume beverage `mapBS`) <$> inpart_inwhole) + (transformWho t p consume beverage `mapBS`) <$> inpart_inwhole) : restOfInnerRules ) _ -> bs @@ -96,7 +96,7 @@ bsNeg2textNeg bs = case bs of -- textNeg2bsNeg :: BoolStructWho -> BoolStructWho ----------------------------------------------------------------------------- --- This is rather hard to read, but the alternative is to duplicate bs2gf for every single GF category +-- This is rather hard to read, but the alternative is to duplicate bs2gf for every single GF cate(LexConj "OR")y type ConjFun list single = GConj -> Tree list -> Tree single type ConjPreFun list single = GPrePost -> GConj -> Tree list -> Tree single @@ -106,12 +106,12 @@ type ListFun single list = [Tree single] -> Tree list bs2gf :: (Gf (Tree s)) => ConjFun l s -> ConjPreFun l s -> ConjPrePostFun l s -> ListFun s l -> BoolStructGF s -> Tree s bs2gf conj conjPre conjPrePost mkList bs = case bs' of AA.Leaf x -> x - AA.Any Nothing xs -> mergeConj $ conj GOR $ mkList $ f <$> xs - AA.All Nothing xs -> mergeConj $ conj GAND $ mkList $ f <$> xs - AA.Any (Just (AA.Pre pre)) xs -> conjPre pre GOR $ mkList $ f <$> xs - AA.All (Just (AA.Pre pre)) xs -> conjPre pre GAND $ mkList $ f <$> xs - AA.Any (Just (AA.PrePost pre post)) xs -> conjPrePost pre post GOR $ mkList $ f <$> xs - AA.All (Just (AA.PrePost pre post)) xs -> conjPrePost pre post GAND $ mkList $ f <$> xs + AA.Any Nothing xs -> mergeConj $ conj (LexConj "OR") $ mkList $ f <$> xs + AA.All Nothing xs -> mergeConj $ conj (LexConj "AND") $ mkList $ f <$> xs + AA.Any (Just (AA.Pre pre)) xs -> conjPre pre (LexConj "OR") $ mkList $ f <$> xs + AA.All (Just (AA.Pre pre)) xs -> conjPre pre (LexConj "AND") $ mkList $ f <$> xs + AA.Any (Just (AA.PrePost pre post)) xs -> conjPrePost pre post (LexConj "OR") $ mkList $ f <$> xs + AA.All (Just (AA.PrePost pre post)) xs -> conjPrePost pre post (LexConj "AND") $ mkList $ f <$> xs AA.Not unexpectedBS -> trace unexpectedNegationMsg $ bs2gf conj conjPre conjPrePost mkList unexpectedBS -- AA.Not _ -> error unexpectedNegationMsg where @@ -149,27 +149,16 @@ mapBS f bs = case bs of AA.Not x -> AA.Not $ mapBS f x ----------------------------------------------------------------------------- -- Generic useful transformations - --- for Subj -introduceSubj :: forall a . Tree a -> Tree a -introduceSubj (GEVERY x) = GAN x -introduceSubj (GPARTY x) = GAN x -introduceSubj x = composOp introduceSubj x - -referSubj :: forall a . Tree a -> Tree a -referSubj (GEVERY x) = GTHE x -referSubj (GPARTY x) = GTHE x -referSubj (GAN x) = GTHE x -referSubj x = composOp referSubj x - -- for NP introduceNP :: forall a . Tree a -> Tree a +introduceNP (GEVERY x) = GDetCN GaSg x introduceNP (GMassNP x) = GDetCN GaSg x introduceNP (GDetCN _ x) = GDetCN GaSg x introduceNP x = composOp introduceNP x referNP :: forall a . Tree a -> Tree a +referNP (GEVERY x) = GDetCN GtheSg x referNP (GMassNP x) = GDetCN GtheSg x referNP (GDetCN GaSg x) = GDetCN GtheSg x --referNP (GDetCN GaPl x) = GDetCN GthePl x @@ -238,6 +227,6 @@ aggregateBoolStruct l bs = then bs else (case bs of - AA.Any _ xs -> maybe bs AA.Leaf $ squeezeTrees GOR $ concatMap toList xs - AA.All _ xs -> maybe bs AA.Leaf $ squeezeTrees GAND $ concatMap toList xs + AA.Any _ xs -> maybe bs AA.Leaf $ squeezeTrees (LexConj "OR") $ concatMap toList xs + AA.All _ xs -> maybe bs AA.Leaf $ squeezeTrees (LexConj "AND") $ concatMap toList xs _ -> bs) diff --git a/lib/haskell/natural4/src/LS/NLP/NLG.hs b/lib/haskell/natural4/src/LS/NLP/NLG.hs index 2fc0b8105..e3f5f1524 100644 --- a/lib/haskell/natural4/src/LS/NLP/NLG.hs +++ b/lib/haskell/natural4/src/LS/NLP/NLG.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, GADTs #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module LS.NLP.NLG where import AnyAll qualified as AA import Control.Monad (when) -import Data.Char qualified as Char (toLower) +import Data.Char qualified as Char (toLower, isDigit) import Data.Foldable qualified as F import Data.HashMap.Strict (elems, keys, lookup, toList) import Data.HashMap.Strict qualified as Map @@ -32,13 +32,13 @@ import LS.NLP.NL4Transformations bsConstraint2gfConstraint, bsWho2gfWho, flipPolarity, - introduceSubj, + introduceNP, isChinese, isMalay, mapBSLabel, pastTense, pushPrePostIntoMain, - referSubj, + referNP, ) import LS.Rule (Interpreted (..), Rule (..), ruleLabelName, ruleName, ruleConstructor) import LS.Types @@ -51,7 +51,7 @@ import LS.Types MTExpr (MTT), MultiTerm, ParamText, - RPRel (RPTC, RPis), + RPRel (..), RelationalPredicate ( RPBoolStructR, RPConstraint, @@ -104,6 +104,7 @@ import PGF ) import Paths_natural4 (getDataFileName) import System.Environment (lookupEnv) +import Prettyprinter.Interpolate (__di) data NLGEnv = NLGEnv { gfGrammar :: PGF @@ -159,7 +160,7 @@ myNLGEnv l4i lang = do Left engL -> return $ mutter "** myNLGEnv" >> mutters engErr >> xpError engL Right engR -> do let myParse typ txt = parse gr engR typ (Text.unpack txt) - myLin = rmBIND . Text.pack . linearize gr lang + myLin = uncapKeywords . rmBIND . Text.pack . linearize gr lang return $ do mutter "** myNLGEnv" xpReturn $ NLGEnv gr lang myParse myLin verbose l4i @@ -167,6 +168,15 @@ myNLGEnv l4i lang = do rmBIND :: Text.Text -> Text.Text rmBIND = Text.replace " &+ " "" +uncapKeywords :: Text.Text -> Text.Text +uncapKeywords = Text.unwords . map (lowerWhole ["BEFORE","AFTER","IS"]) . Text.words + where + lowerWhole keywords word = + if word `elem` keywords + then Text.toLower word + else word + + gfPath :: String -> String gfPath x = "grammars/" ++ x @@ -214,7 +224,7 @@ nlg = nlg' TopLevel nlg' :: RecursionLevel -> NLGEnv -> Rule -> IO Text.Text nlg' thl env rule = case rule of Regulative {subj,upon,temporal,cond,who,deontic,action,lest,hence} -> do - let subjExpr = introduceSubj $ parseSubj env subj + let subjExpr = introduceNP $ parseSubj env subj deonticExpr = parseDeontic deontic actionExpr = parseAction env action whoSubjExpr = case who of @@ -322,6 +332,7 @@ ruleQuestions env alias rule = do text DefNameAlias {} -> pure [] -- no questions needed to produce from DefNameAlias DefTypically {} -> pure [] -- no questions needed to produce from DefTypically + RuleGroup {} -> pure [] _ -> pure [AA.Leaf $ Text.pack ("ruleQuestions: doesn't work yet for " <> ruleConstructor rule)] -- [TODO] for our Logging exercise, see how to convert the _ case above to an xpError @@ -359,10 +370,10 @@ ruleQnTrees env alias rule = do case rule of Regulative {subj,who,cond,upon} -> do let subjExpr = parseSubj env subj - aliasExpr = if subjExpr==orgExpr then youExpr else referSubj subjExpr + aliasExpr = if subjExpr==orgExpr then youExpr else referNP subjExpr qWhoTrees = mkWhoText env GqPREPOST (GqWHO aliasExpr) <$> who qCondTrees = mkCondText env GqPREPOST GqCOND <$> cond - qUponTrees = mkUponText env (GqUPON aliasExpr) <$> upon + qUponTrees = mkUponText env aliasExpr GqUPON <$> upon mutterdhsf 4 "Regulative/subjExpr" show subjExpr mutterdhsf 4 "Regulative/aliasExpr" show aliasExpr mutterdhsf 4 "Regulative/qWhoTrees" show qWhoTrees @@ -387,10 +398,10 @@ ruleQnTrees env alias rule = do ---------------------------------------------------------------------- -textViaQaHorns :: NLGEnv -> Alias -> Maybe GSubj -> [([RuleName], BoolStructT)] -textViaQaHorns env alias subj = [ (rn, linBStext env $ mkGFtext env alias (referSubj <$> subj) bsr) | (rn, bsr) <- qaHornsR (interpreted env)] +textViaQaHorns :: NLGEnv -> Alias -> Maybe GNP -> [([RuleName], BoolStructT)] +textViaQaHorns env alias subj = [ (rn, linBStext env $ mkGFtext env alias (referNP <$> subj) bsr) | (rn, bsr) <- qaHornsR (interpreted env)] -mkGFtext :: NLGEnv -> Alias -> Maybe GSubj -> BoolStructR -> BoolStructGText +mkGFtext :: NLGEnv -> Alias -> Maybe GNP -> BoolStructR -> BoolStructGText mkGFtext env alias subj bsr = case (whoParses, condParses) of ([], []) -> mkConstraintText env GqPREPOST GqCONSTR bsr ([], _:_) -> mkCondText env GqPREPOST GqCOND bsr @@ -427,11 +438,13 @@ mkCondText env f g bsr = mapBSLabel f g $ aggregateBoolStruct (gfLang env) $ par mkConstraintText :: NLGEnv -> (GPrePost -> GText) -> (GConstraint -> GText) -> BoolStructR -> BoolStructGText mkConstraintText env f g bsr = mapBSLabel f g $ aggregateBoolStruct (gfLang env) $ parseConstraintBS env bsr -mkUponText :: NLGEnv -> (GUpon -> GText) -> ParamText -> BoolStructGText -mkUponText env f pt = AA.Leaf (f $ parseUpon env pt) - --- mkUponText :: NLGEnv -> (GUpon -> GText) -> ParamText -> BoolStructT --- mkUponText env f = AA.Leaf . gfLin env . gf . f . parseUpon env +mkUponText :: NLGEnv -> GNP -> (GNP -> GUpon -> GText) -> ParamText -> BoolStructGText +mkUponText env alias f pt = AA.Leaf (f subj upon) + where + upon0 = parseUpon env pt + (subj,upon) = case upon0 of + GUPONnp np vp -> (np, GUPON vp) + _ -> (alias, upon0) nlgQuestion :: NLGEnv -> Rule -> XPileLog [Text.Text] nlgQuestion env rl = do @@ -497,11 +510,11 @@ parseAction env bsp = fg tree txt = bsp2text bsp tree :| _ = parseAny "Action" env txt -parseSubj :: NLGEnv -> BoolStructP -> GSubj +parseSubj :: NLGEnv -> BoolStructP -> GNP parseSubj env bsp = fg tree where txt = bsp2text bsp - tree :| _ = parseAny "Subj" env txt + tree :| _ = parseAny "NP" env txt parseWho :: NLGEnv -> RelationalPredicate -> GWho parseWho env rp = fg tree @@ -515,15 +528,32 @@ parseCond env (RPConstraint c (RPTC t) d) = GRPConstraint cond tc date cond = parseCond env (RPMT c) tc = parseTComparison t date = parseDate d +parseCond env (RPConstraint a RPis b) = case (nps,vps) of + (np:_, (GMkVPS t p vp):_) -> GWHEN np t p vp + _ -> parseCond env (RPMT [MTT $ Text.unwords [aTxt, "is", bTxt]]) + where + aTxt = Text.strip $ mt2text a + bTxt = Text.strip $ mt2text b + nps :: [GNP] + nps = fg <$> parseAnyNoRecover "NP" env aTxt + vps :: [GVPS] + vps = fg <$> parseAnyNoRecover "VPS" env (Text.unwords ["is", bTxt]) + parseCond env rp = fg tree where txt = rp2text rp tree :| _ = parseAny "Cond" env txt parseUpon :: NLGEnv -> ParamText -> GUpon -parseUpon env pt = fg tree +parseUpon env pt = case upons of + upon:_ -> upon + [] -> case nps of + np:_ -> GUPONnp np (LexVP "occur") + [] -> fg tree where txt = pt2text pt + upons = fg <$> parseAnyNoRecover "Upon" env txt + nps = fg <$> parseAnyNoRecover "NP" env txt tree :| _ = parseAny "Upon" env txt parseTemporal :: NLGEnv -> TemporalConstraint Text.Text -> GTemporal @@ -556,7 +586,7 @@ parseConstraint env (RPBoolStructR a RPis (AA.Not b)) = case (nps,vps) of (np:_, vp:_) -> GRPleafS (fg np) (flipPolarity $ fg vp) _ -> GrecoverRPis (tString aTxt) (tString $ Text.unwords ["not", bTxt]) where - aTxt = mt2text a + aTxt = Text.strip $ mt2text a bTxt = bsr2text b nps = parseAnyNoRecover "NP" env aTxt vps = parseAnyNoRecover "VPS" env $ Text.unwords ["is", bTxt] @@ -565,13 +595,94 @@ parseConstraint env (RPConstraint a RPis b) = case (nps,vps) of (np:_, vp:_) -> GRPleafS (fg np) (fg vp) _ -> GrecoverRPis (tString aTxt) (tString bTxt) where - aTxt = mt2text a - bTxt = mt2text b + aTxt = Text.strip $ mt2text a + bTxt = Text.strip $ mt2text b nps = parseAnyNoRecover "NP" env aTxt vps = parseAnyNoRecover "VPS" env $ Text.unwords ["is", bTxt] - tString :: Text.Text -> GString - tString = GString . Text.unpack +parseConstraint env (RPConstraint a (RPTC t) b) = case (sents,advs) of + (s:_, adv:_) -> case s of + GPredVPS np (GMkVPS t p vp) -> GRPleafS np (GMkVPS t p (GAdvVP vp adv)) + _ -> trace ("parseConstraint: unable to parse " <> showExpr [] (gf s)) fallback + x -> trace ("parseConstraint: unable to parse " <> show x <> Text.unpack tTxt) fallback + where + aTxt = Text.strip $ mt2text a + tTxt = gfLin env $ gf $ parseTComparison t + bTxt = Text.strip $ mt2text b + sents :: [GS] + sents = fg <$> parseAnyNoRecover "S" env aTxt + advs :: [GAdv] + advs = fg <$> parseAnyNoRecover "Adv" env (Text.unwords [tTxt, bTxt]) + fallback = GrecoverUnparsedConstraint (tString $ Text.unwords [aTxt, tTxt, bTxt]) + + +parseConstraint env (RPConstraint a RPgt b) = case (nps,vps) of + (np:_, vp:_) -> GRPleafS (fg np) (fg vp) + _ -> GrecoverRPmath (tString ">") (tString aTxt) (tString bTxt) + where + aTxt0 = Text.strip $ mt2text a + aTxt = case dp 6 aTxt0 of + "'s age" -> tk 6 aTxt0 -- policy holder's age -> policy holder + _ -> aTxt0 + + bTxt0 = Text.strip $ mt2text b + bTxt = case (dp 6 aTxt0, dp 5 bTxt0) of + ("'s age", "years") -> Text.unwords ["is more than", splitDigits bTxt0, "old"] + _ -> Text.unwords ["is greater than", bTxt0] + + nps = parseAnyNoRecover "NP" env aTxt + vps = parseAnyNoRecover "VPS" env bTxt + +parseConstraint env (RPConstraint a RPlt b) = case (nps,vps) of + (np:_, vp:_) -> GRPleafS (fg np) (fg vp) + _ -> GrecoverRPmath (tString "<") (tString aTxt) (tString bTxt) + where + aTxt0 = Text.strip $ mt2text a + aTxt = case dp 6 aTxt0 of + "'s age" -> tk 6 aTxt0 -- policy holder's age -> policy holder + _ -> aTxt0 + + bTxt0 = Text.strip $ mt2text b + bTxt = case (dp 6 aTxt0, dp 5 bTxt0) of + ("'s age", "years") -> Text.unwords ["is less than", splitDigits bTxt0, "old"] + _ -> Text.unwords ["is less than", bTxt0] + + nps = parseAnyNoRecover "NP" env aTxt + vps = parseAnyNoRecover "VPS" env bTxt + +parseConstraint env (RPConstraint a RPlte b) = case (nps,vps) of + (np:_, vp:_) -> GRPleafS (fg np) (fg vp) + _ -> GrecoverRPmath (tString "<") (tString aTxt) (tString bTxt) + where + aTxt0 = Text.strip $ mt2text a + aTxt = case dp 6 aTxt0 of + "'s age" -> tk 6 aTxt0 -- policy holder's age -> policy holder + _ -> aTxt0 + + bTxt0 = Text.strip $ mt2text b + bTxt = case (dp 6 aTxt0, dp 5 bTxt0) of + ("'s age", "years") -> Text.unwords ["is at most", splitDigits bTxt0, "old"] + _ -> Text.unwords ["is at most", bTxt0] + + nps = parseAnyNoRecover "NP" env aTxt + vps = parseAnyNoRecover "VPS" env bTxt + +parseConstraint env (RPConstraint a RPgte b) = case (nps,vps) of + (np:_, vp:_) -> GRPleafS (fg np) (fg vp) + _ -> GrecoverRPmath (tString "<") (tString aTxt) (tString bTxt) + where + aTxt0 = Text.strip $ mt2text a + aTxt = case dp 6 aTxt0 of + "'s age" -> tk 6 aTxt0 -- policy holder's age -> policy holder + _ -> aTxt0 + + bTxt0 = Text.strip $ mt2text b + bTxt = case (dp 6 aTxt0, dp 5 bTxt0) of + ("'s age", "years") -> Text.unwords ["is at least", splitDigits bTxt0, "old"] + _ -> Text.unwords ["is at least", bTxt0] + + nps = parseAnyNoRecover "NP" env aTxt + vps = parseAnyNoRecover "VPS" env bTxt parseConstraint env rp = fg tree where @@ -614,6 +725,24 @@ typeError cat actualCats = error $ unwords ["category", cat, "not a valid GF cat tString :: Text.Text -> GString tString = GString . Text.unpack + +splitDigits :: Text.Text -> Text.Text +splitDigits txt = Text.unwords (splitDigit <$> Text.words txt) + where + splitDigit d = if Text.all Char.isDigit d + then Text.intercalate " &+ " (Text.groupBy (\x y -> False) d) + else d + +tk, dp :: Int -> Text.Text -> Text.Text +tk i = Text.pack . tk' i . Text.unpack +dp i = Text.pack . dp' i . Text.unpack + + +tk', dp' :: Int -> String -> String +tk' i = reverse . drop i . reverse -- tk 2 "hello" == "hel" +dp' i = reverse . take i . reverse -- dp 2 "hello" == "lo" + + ----------------------------------------------------------------------------- -- Expand a set of rules diff --git a/lib/haskell/natural4/src/LS/RelationalPredicates.hs b/lib/haskell/natural4/src/LS/RelationalPredicates.hs index 356c2ec57..1ee4bb320 100644 --- a/lib/haskell/natural4/src/LS/RelationalPredicates.hs +++ b/lib/haskell/natural4/src/LS/RelationalPredicates.hs @@ -238,6 +238,8 @@ tok2rel = choice , RPor <$ pToken TokOr , RPsum <$ pToken TokSum , RPproduct <$ pToken TokProduct + , RPmin <$ pToken TokMin + , RPmax <$ pToken TokMax , RPlt <$ pToken TokLT -- serves double duty as MinOflist when in RPnary position , RPlte <$ pToken TokLTE , RPgt <$ pToken TokGT -- serves double duty as MaxOflist when in RPnary position @@ -978,8 +980,18 @@ pBSR = debugName "pBSR" $ getBSR :: Rule -> Maybe BoolStructR getBSR Hornlike{..} = Just $ AA.simplifyBoolStruct $ AA.mkAll Nothing $ catMaybes [ hbody | HC _hhead hbody <- clauses ] - [ bsr | HC (RPBoolStructR _rp1 _rprel bsr) _hbody <- clauses ] + concat [ go headRP + | HC headRP _body <- clauses ] + where + go :: RelationalPredicate -> [BoolStructR] + go c = case c of + RPBoolStructR _rp1 _rprel bsr -> [bsr] + RPnary RPis (r:rps) -> concatMap go rps -- we assume r is the subject of the rule and doesn't bear further scrutiny + RPnary rprel rps -> concatMap go rps + RPMT mt -> pure $ AA.mkLeaf (RPMT mt) + _ -> [] + -- | monochrom on IRC commented that I'm basically doing Prolog's `cut`, here. -- I would have used (<||>) but that's already in use by the permutation parser () :: Foldable t => t a -> t a -> t a diff --git a/lib/haskell/natural4/src/LS/Rule.hs b/lib/haskell/natural4/src/LS/Rule.hs index aae6d23ed..82492c4d8 100644 --- a/lib/haskell/natural4/src/LS/Rule.hs +++ b/lib/haskell/natural4/src/LS/Rule.hs @@ -12,6 +12,7 @@ import Control.Monad.Writer.Lazy (WriterT (runWriterT)) import Data.Aeson (ToJSON) import Data.Bifunctor (second) import Data.Hashable (Hashable) +import qualified Data.HashMap.Strict as Map import Data.List.NonEmpty (NonEmpty) import Data.Set qualified as Set import Data.Text qualified as Text @@ -21,7 +22,7 @@ import GHC.Generics (Generic) import LS.Types ( BoolStructP, BoolStructR, - ClsTab, + ClsTab(..), DList, Deontic (DMust), Depth, @@ -63,7 +64,11 @@ import Text.Megaparsec (), (<|>), ) +import Data.Graph.Inductive (Gr, empty) +import LS.XPile.Logging (XPileLogW) +-- | [TODO] refactoring: these should be broken out into their own (new)types and have Rule include them all. +-- We should take advantage of NoFieldSelectors to reduce the hazards here data Rule = Regulative { subj :: BoolStructP -- man AND woman AND child , rkeyword :: RegKeywords -- Every | Party | TokAll @@ -384,8 +389,36 @@ data Interpreted = L4I { -- | valuepredicates contain the bulk of the top-level decision logic, and can be easily expressed as instance or class methosd. , valuePreds :: [ValuePredicate] + + -- | rule decision graph gets used by multiple transpilers, so it lives here + , ruleGraph :: RuleGraph + , ruleGraphErr :: XPileLogW + } + deriving (Eq, Show) + +-- | default L4I +defaultL4I :: Interpreted +defaultL4I = L4I + { classtable = CT Map.empty + , scopetable = Map.empty + , origrules = mempty + , valuePreds = mempty + , ruleGraph = empty + , ruleGraphErr = mempty } - deriving (Eq, Ord, Show) + +-- | structure the rules as a graph. +-- in the simple case, the graph is one or more trees, each rooted at a "top-level" rule which is not "used" by any another rule. +-- if we walk the roots, we will sooner or later encounter all the decision elements relevant to each root. +-- in a less simple case, the graph is cyclic! everything depends on everything else! but we can recognize that as an error condition. +-- +-- note that a regulative rule R1 HENCE R2 is recorded as a single rule, even if we think of the R2 as a separate rule +-- perhaps we should have a notion of anonymous rules, that are internally labelled and structured, so R2 is equal to R1 in the graph. + +type RuleGraphEdgeLabel = () +type RuleGraph = Gr Rule RuleGraphEdgeLabel + + multiterm2bsr :: Rule -> BoolStructR multiterm2bsr = AA.mkLeaf . RPParamText . multiterm2pt . name diff --git a/lib/haskell/natural4/src/LS/Types.hs b/lib/haskell/natural4/src/LS/Types.hs index 90f1402e1..995ee0eeb 100644 --- a/lib/haskell/natural4/src/LS/Types.hs +++ b/lib/haskell/natural4/src/LS/Types.hs @@ -51,6 +51,7 @@ type BoolStructR = AA.OptionallyLabeledBoolStruct RelationalPredicate -- | the relations in a RelationalPredicate data RPRel = RPis | RPhas | RPeq | RPlt | RPlte | RPgt | RPgte | RPelem | RPnotElem | RPnot | RPand | RPor | RPsum | RPproduct | RPsubjectTo + | RPmin | RPmax | RPmap | RPTC TComparison -- ^ temporal constraint as part of a relational predicate; note there is a separate `TemporalConstraint` type. deriving (Eq, Ord, Show, Generic, ToJSON) @@ -276,6 +277,7 @@ mkRpmt a = RPMT (MTT <$> a) mkRpmtLeaf :: [Text.Text] -> BoolStructR mkRpmtLeaf a = mkLeaf (mkRpmt a) +-- | [TODO] figure out why there are two very similar functions, this and `rel2op` rel2txt :: RPRel -> Text.Text rel2txt RPis = "IS" rel2txt RPhas = "HAS" -- "relHas" @@ -290,6 +292,8 @@ rel2txt RPnot = "NOT" -- "relNot" rel2txt RPand = "&&" -- "relAnd" rel2txt RPor = "||" -- "relOr" rel2txt RPmap = "MAP" +rel2txt RPmin = "MIN" +rel2txt RPmax = "MAX" rel2txt RPsum = "SUM" rel2txt RPproduct = "PRODUCT" rel2txt (RPTC TBefore) = "BEFORE" @@ -298,6 +302,7 @@ rel2txt (RPTC TBy ) = "BY" rel2txt (RPTC TOn) = "ON" rel2txt (RPTC TVague) = "ABOUT" +-- | [TODO] figure out why there are two very similar functions, this and `rel2txt` rel2op :: RPRel -> Text.Text rel2op RPis = "IS" rel2op RPhas = ".?" @@ -311,14 +316,7 @@ rel2op RPnotElem = "NOT IN" rel2op RPnot = "NOT" rel2op RPand = "&&" rel2op RPor = "||" -rel2op RPmap = "MAP" -rel2op RPsum = "SUM" -rel2op RPproduct = "PRODUCT" -rel2op (RPTC TBefore) = "BEFORE" -rel2op (RPTC TAfter ) = "AFTER" -rel2op (RPTC TBy ) = "BY" -rel2op (RPTC TOn) = "ON" -rel2op (RPTC TVague) = "ABOUT" +rel2op x = rel2txt x rp2mt :: RelationalPredicate -> MultiTerm rp2mt (RPParamText pt) = pt2multiterm pt @@ -331,7 +329,7 @@ rp2mt (RPnary rel rps) = MTT (rel2txt rel) : concatMap rp2mt rps rp2bodytexts :: RelationalPredicate -> [MultiTerm] rp2bodytexts (RPParamText pt) = [pt2multiterm pt] rp2bodytexts (RPMT mt) = [mt] -rp2bodytexts (RPConstraint mt1 rel mt2) = [mt1, [MTT $ rel2op rel], mt2] +rp2bodytexts (RPConstraint mt1 rel mt2) = [mt1 ++ [MTT $ rel2op rel] ++ mt2] rp2bodytexts (RPBoolStructR mt1 rel bsr) = [mt1 ++ MTT (rel2op rel) : bod | bod <- concatMap rp2bodytexts (AA.extractLeaves bsr) ] rp2bodytexts (RPnary rel rps) = [MTT (rel2op rel), MTT "("] : concatMap rp2bodytexts rps ++ [[MTT ")"]] @@ -401,6 +399,7 @@ data InterpreterOptions = IOpts } deriving (Eq, Ord, Show) +-- [TODO] consider using typeclass Default https://hackage.haskell.org/package/data-default defaultInterpreterOptions :: InterpreterOptions defaultInterpreterOptions = IOpts { enums2decls = False @@ -606,6 +605,7 @@ data RunConfig = RC { debug :: Bool , toBabyL4 :: Bool , toASP :: Bool , toProlog :: Bool + , toSCasp :: Bool , toUppaal :: Bool , toHTML :: Bool , saveAKA :: Bool @@ -631,6 +631,7 @@ defaultRC = RC , toBabyL4 = False , toASP = False , toProlog = False + , toSCasp = False , toUppaal = False , saveAKA = False , wantNotRules = False diff --git a/lib/haskell/natural4/src/LS/UtilsREPLDev.hs b/lib/haskell/natural4/src/LS/UtilsREPLDev.hs new file mode 100644 index 000000000..0f3d7815b --- /dev/null +++ b/lib/haskell/natural4/src/LS/UtilsREPLDev.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +{-| +Simple utils / convenience functions for prototyping / dev-ing at the REPL. +-} + + +module LS.UtilsREPLDev + ( filesInDirWithExtn, + findFileByNameInDir, + csvsInDir, + l4csv2rules, + leTestcasesDir, + leTestCSVs + ) +where + +import Flow ((|>)) +import Data.Maybe (fromMaybe, listToMaybe) + +import System.FilePath (()) +import System.FilePath.Find + ( always, + fileName, + find, + (==?), + extension + ) +import Text.Pretty.Simple ( pShowNoColor, pPrint ) + +import LS qualified +import LS.Lib (NoLabel (..), Opts (..)) +import LS.Utils ((|$>)) + + +-- Getting file paths + +type FileExtn = String +type BaseFileName = String +type StartDir = String + +filesInDirWithExtn :: FileExtn -> StartDir -> IO [FilePath] +filesInDirWithExtn fextn = find always (extension ==? fextn) + +csvsInDir :: StartDir -> IO [FilePath] +csvsInDir = filesInDirWithExtn ".csv" + +{-| +==== __Examples__ +>>> findFileByNameInDir leTestcasesDir "indentation-databreach.csv" +Just "test/Testcases/LogicalEnglish/indentation-propn-databreach/indentation-databreach.csv" +-} +findFileByNameInDir :: StartDir -> BaseFileName -> IO (Maybe FilePath) +findFileByNameInDir startdir basefnm = + startdir + |> find always (fileName ==? basefnm) + |$> listToMaybe + + +-- Getting rules from L4 CSVs +--- TODO: Would be convenient to also have a function that allows you to match just on a part of the base filename + +{-| +Util function for getting raw rules from a L4 CSV filepath +Not meant for production apps! +Adapted from Joe's code for testing LP Programs +==== __Examples__ +>>> l4csv2rules "test/Testcases/LogicalEnglish/" "indentation-databreach.csv" +-} +l4csv2rules :: StartDir -> BaseFileName -> IO [LS.Rule] +l4csv2rules startdir csvFpath = + findFileByNameInDir startdir csvFpath >>= + \case + Nothing -> error "Can't find file" + -- remember, this is meant to be for internal use by a developer in the REPL + Just file -> LS.dumpRules + Opts + { file = NoLabel [file], + dbug = False, + dstream = False + } + +{-| +Util function for __pretty printing (in color)__ raw rules from a L4 CSV filepath +==== __Examples__ +>>> pRules "test/Testcases/LogicalEnglish/" "indentation-databreach.csv" +-} +pRules :: StartDir -> BaseFileName -> IO () +pRules startdir csvFpath = l4csv2rules startdir csvFpath >>= pPrint + + +------- TODO: LE-specific things; to be moved into a better place when I have more time +-- | Convenient, tho not the best practice to put this in this module +leTestcasesDir :: FilePath +leTestcasesDir = "test" "Testcases" "LogicalEnglish" + +-- | Returns a list of csvs in the LE subdir of test/Testcases +leTestCSVs :: IO [FilePath] +leTestCSVs = csvsInDir leTestcasesDir \ No newline at end of file diff --git a/lib/haskell/natural4/src/LS/XPile/CoreL4.hs b/lib/haskell/natural4/src/LS/XPile/CoreL4.hs index 8173a85ea..7b38a5675 100644 --- a/lib/haskell/natural4/src/LS/XPile/CoreL4.hs +++ b/lib/haskell/natural4/src/LS/XPile/CoreL4.hs @@ -420,7 +420,7 @@ rpRelToBComparOp RPelem = refute "rpRelToBComparOp: erroring on RPelem" rpRelToBComparOp RPnotElem = refute "rpRelToBComparOp: erroring on RPnotElem" rpRelToBComparOp RPnot = refute "rpRelToBComparOp: erroring on RPnot" rpRelToBComparOp RPTC {} = refute "rpRelToBComparOp: erroring on RPTC" - +rpRelToBComparOp x = refute ("rpRelToBComparOp: erroring on " <> pretty (show x)) -- END helper functions boolStructRToExpr :: [String] -> BoolStructR -> ExprM ann () diff --git a/lib/haskell/natural4/src/LS/XPile/Logging.hs b/lib/haskell/natural4/src/LS/XPile/Logging.hs index b46a5336c..5a490be57 100644 --- a/lib/haskell/natural4/src/LS/XPile/Logging.hs +++ b/lib/haskell/natural4/src/LS/XPile/Logging.hs @@ -140,11 +140,20 @@ type XPileLogTE m a = XPileLogT m (Either XPileLogW a) -- in case you need that. You can also define your own type along -- these lines. type XPileLog = XPileLogT Identity + +-- | placeholder for arbitrary environment. This should be replaced by +-- what your actual environment is. Currently there are modules that +-- make up variants of an XPileLog monad; this is an example of how to +-- do that. But we should generalize all that and have an XPileLogR a. type XPileLogR = HashMap String String + +-- | mutterings are basically lists of strings. Any structure in here should be up to the conventions of your logging style; in this project we frequently use org-mode conventions living inside these strings. type XPileLogW = [XPileLogW']; type XPileLogW' = String type XPileLogS = HashMap String String --- | XPileLog as a monad transformer, allowing specialization of the base monad to something besides Identity +-- | XPileLog as a monad transformer, allowing specialization of the base monad to something besides Identity. +-- +-- [TODO] newtypes are preferred! type XPileLogT m = RWST XPileLogR XPileLogW XPileLogS m diff --git a/lib/haskell/natural4/src/LS/XPile/Org.hs b/lib/haskell/natural4/src/LS/XPile/Org.hs index bdd0807ef..917478ca4 100644 --- a/lib/haskell/natural4/src/LS/XPile/Org.hs +++ b/lib/haskell/natural4/src/LS/XPile/Org.hs @@ -22,11 +22,14 @@ import LS.Interpreter extractEnums, defaultToSuperClass, defaultToSuperType, attrsAsMethods, + entryPoints, ) +import LS.DataFlow + import LS.RelationalPredicates ( partitionExistentials, getBSR ) import LS.Rule - ( Interpreted(classtable, scopetable), + ( Interpreted(..), Rule(..), hasGiven, hasClauses, @@ -68,7 +71,8 @@ musings :: Interpreted -> [Rule] -> Doc ann musings l4i rs = let cg = classGraph (classtable l4i) [] expandedRules = nub $ concatMap (expandRule rs) rs - decisionGraph = ruleDecisionGraph l4i rs + decisionGraph = ruleGraph l4i + (eRout, eRerr) = xpLog (exposedRoots l4i) in vvsep [ "* musings" , "** Global Facts" srchs (globalFacts l4i) @@ -117,13 +121,16 @@ musings l4i rs = , "we dump expressions of the form DECIDE class's record's attribute IS someValue WHEN someCondition" , let aam = xpLog $ attrsAsMethods rs -- [TODO] this duplicates work done in the Interpreter -- find a way to coherently log common errors from the Interpreter itself, clean up l4i's valuePreds in srchs (fst aam) vsep (pretty <$> snd aam) + , "** Dataflow modelling" + , "*** entryPoints" let (ePout, ePerr) = xpLog (entryPoints l4i) in srchs ePout vsep (pretty <$> ePerr) , "** the Rule Decision Graph" , orgexample (pretty (prettify (first ruleLabelName decisionGraph))) + , "*** logging output" vsep (pretty <$> ruleGraphErr l4i) , "** Decision Roots" , "rules which are not just RuleAlises, and which are not relied on by any other rule" - , srchs (ruleLabelName <$> exposedRoots l4i) - + , srchs (ruleLabelName <$> eRout) + , "*** logging output from exposedRoots" vsep (pretty <$> eRerr) , "*** Nubbed, Exposed, Decision Roots" , "Each ruleset can be organized into multiple trees. Each tree contains rules." , "The leaves of the trees contain datapoints we need to collect from the user, typically by asking the user for that data in some interactive Q&A form style." @@ -162,8 +169,8 @@ musings l4i rs = , hasClauses r , hasGiven r ] - | ((grpval, uniqrs),n :: Int) <- Prelude.zip (groupedByAOTree l4i $ -- NUBBED - exposedRoots l4i -- EXPOSED + | ((grpval, uniqrs),n :: Int) <- Prelude.zip (groupedByAOTree l4i -- NUBBED + eRout -- EXPOSED ) [1..] , not $ null uniqrs ] diff --git a/lib/haskell/natural4/src/LS/XPile/Prolog.hs b/lib/haskell/natural4/src/LS/XPile/Prolog.hs index 958b46da9..97fc2aec4 100644 --- a/lib/haskell/natural4/src/LS/XPile/Prolog.hs +++ b/lib/haskell/natural4/src/LS/XPile/Prolog.hs @@ -8,12 +8,35 @@ to Prolog. For more information see also `RelationalPredicates`. -} +{-| +TODO: Move the following into a README once the transpiler toolchain +is operational. + +The transpiler comes in two versions: for Prolog and for sCasp. +For a generation of valid sCasp to work, some very strong assumptions +about Spreadsheet / csv files have been made, and if these +are not respected, the compiler produces garbage without mercy and warnings: +* Each argument of a predicate has to be written in a separate CSV cell, + and so has the predicate itself +* However, arguments can be composite, e.g. function and arguments. +* Also comparison operators have to be written in a separate cell. +For available comparison operators, see function showLPspecialSCasp +* Assignment of a numerical value to a variable has to be written with IS: + var IS val which is rendered as var #= val in sCasp +* Equating two terms (triggerin unification in sCasp / Prolog) has to be written = . + Attention, in a spreadsheet, the symbol = has to be preceeded by a simple quote to be accepted. + term1 = term2 is rendered as term1 = term2 in sCasp + The tokens == and === are synonymes of = and are also rendered as term1 = term2 in sCasp +-} + module LS.XPile.Prolog where -import AnyAll (BoolStruct (All, Any, Leaf, Not)) +import AnyAll (BoolStruct (All, Any, Leaf, Not), Dot (xPos)) import Data.List.NonEmpty as NE (NonEmpty (..), toList) import Data.Map qualified as Map import Data.Text qualified as Text +import Prettyprinter +import Prettyprinter.Render.Text (putDoc) import LS.Rule as SFL4 ( Rule (Hornlike, TypeDecl, clauses, enums, has, name, super), ) @@ -26,7 +49,7 @@ import LS.Types as SFL4 MTExpr (..), ParamText, ParamType (TList0, TList1, TOne, TOptional), - RPRel, + RPRel (RPeq), RelationalPredicate (..), TypeSig (..), mt2text, @@ -35,7 +58,65 @@ import LS.Types as SFL4 rel2txt, untypePT, ) -import Language.Prolog (Clause (Clause), Term (Struct), var) +import Language.Prolog (Clause (Clause), Term (Struct, Var, Wildcard, Cut), Atom, var) +import Data.Functor.Classes (showsBinary1) +import qualified Data.Bits as sCasp + + + +-- Document generation for Logic Programs +-- Currently supported: Prolog and SCasp + +data TranslationMode = Prolog | SCasp +class ShowLP x where + showLP :: TranslationMode -> x -> Doc ann + +instance ShowLP Clause where + -- showLP t c = pretty (show c) + showLP t (Clause lhs []) = + showLP t lhs <> pretty ("." :: Text.Text) + showLP t (Clause lhs rhs) = + showLP t lhs <> + pretty (":-" :: Text.Text) <> + nest 4 + (vsep (punctuate comma (map (showLP t) rhs)) <> + pretty ("." :: Text.Text)) + showLP t c = pretty (show c) + +instance ShowLP Term where + showLP SCasp trm@(Struct atom terms) = + if showLPIsSpecial atom + then showLPspecialSCasp atom terms + else pretty (show trm) + showLP t trm = pretty (show trm) + +showLPIsSpecial :: Atom -> Bool +showLPIsSpecial "IS" = True +showLPIsSpecial "<" = True +showLPIsSpecial "=<" = True +showLPIsSpecial "<=" = True +showLPIsSpecial ">" = True +showLPIsSpecial ">=" = True +showLPIsSpecial "=" = True +showLPIsSpecial "==" = True +showLPIsSpecial _ = False + + +showLPspecialSCasp :: Atom -> [Term] -> Doc ann +showLPspecialSCasp "IS" = showBinaryInfixSCasp "#=" +showLPspecialSCasp "<" = showBinaryInfixSCasp "#<" +showLPspecialSCasp "=<" = showBinaryInfixSCasp "#=<" +showLPspecialSCasp "<=" = showBinaryInfixSCasp "#=<" +showLPspecialSCasp ">" = showBinaryInfixSCasp "#>" +showLPspecialSCasp ">=" = showBinaryInfixSCasp "#>=" +showLPspecialSCasp "=" = showBinaryInfixSCasp "=" -- non arithmetic equality +showLPspecialSCasp "==" = showBinaryInfixSCasp "#=" + +showBinaryInfixSCasp :: Text.Text -> [Term] -> Doc ann +showBinaryInfixSCasp sym (trm1:trm2:trms) = + pretty (show trm1) <> + pretty (sym :: Text.Text) <> + pretty (show trm2) prologExamples :: [Clause] prologExamples = @@ -44,13 +125,23 @@ prologExamples = type Analysis = Map.Map Text.Text Text.Text -sfl4ToProlog :: [SFL4.Rule] -> [Clause] -sfl4ToProlog rs = +rulesToProlog :: [SFL4.Rule] -> String +rulesToProlog rs = show (vsep (map (showLP Prolog) (sfl4ToLogProg rs))) + +rulesToSCasp :: [SFL4.Rule] -> String +rulesToSCasp rs = show (vsep (map (showLP SCasp) (sfl4ToLogProg rs))) + +-- Translation of rules to generic logic programming clauses +sfl4ToLogProg :: [SFL4.Rule] -> [Clause] +sfl4ToLogProg rs = let analysis = analyze rs :: Analysis in concatMap (rule2clause analysis) rs +-- TODO: not clear what the "Analysis" is good for. +-- The corresponding parameter seems to be ignored in all called functions. +-- Also see the comment in the "analyze" function further below. rule2clause :: Analysis -> SFL4.Rule -> [Clause] rule2clause st cr@Hornlike {} = hornlike2clauses st (mt2text $ name cr) (clauses cr) rule2clause st td@TypeDecl { enums = Just ens } = clpEnums st (mt2text $ name td) ens @@ -99,7 +190,7 @@ showtype (SimpleType TList1 tt) = "nonEmptyList(" <> tt <> ")" showtype (InlineEnum pt tt) = showtype (SimpleType pt (inEnums (fmap mtexpr2text <$> untypePT tt))) inEnums :: NonEmpty (NonEmpty Text.Text) -> Text.Text -inEnums pt = "enums(" <> Text.unwords [ h | (h :| _) <- NE.toList pt ] <> ")" +inEnums pt = "enums(" <> Text.unwords [ h | (h :| _) <- NE.toList pt ] <> ")" -- we gonna need the same writer magic to append top-level output. -- in future, run clpEnums -- for now, just blurt it out @@ -167,8 +258,13 @@ rp2goal (RPBoolStructR lhs_ _rel bsr) = Struct (Text.unpack $ mt2text lhs_) <$> rp2goal (RPConstraint mt1 rel mt2) = pure $ Struct (rel2f rel) $ (varmt <$> mt1) ++ (varmt <$> mt2) rp2goal (RPnary rprel rps) = pure $ Struct (rel2f rprel) (concatMap rp2goal rps) +-- The equality token RPeq has three external appearances: =, ==, === +-- whose difference is not clear. +-- Here, they are mapped to =, so that the symbol can be used as +-- Prolog's "unifiable". TODO: a bad hack. rel2f :: RPRel -> String -rel2f = Text.unpack . rel2txt +rel2f RPeq = "=" +rel2f r = Text.unpack (rel2txt r) analyze :: [SFL4.Rule] -> Analysis analyze _rs = Map.fromList [("enumPrimaryKey", "1")] -- sorry, gonna have to read and show this all the time, slightly lame diff --git a/lib/haskell/natural4/src/LS/XPile/Purescript.hs b/lib/haskell/natural4/src/LS/XPile/Purescript.hs index 2889c18a2..d34ef4b00 100644 --- a/lib/haskell/natural4/src/LS/XPile/Purescript.hs +++ b/lib/haskell/natural4/src/LS/XPile/Purescript.hs @@ -11,7 +11,12 @@ Largely a wrapper. Most of the functionality is in the anyall lib. -} -module LS.XPile.Purescript where +-- [TODO] export list +module LS.XPile.Purescript + -- * These are the top-level entry points for the Purescript transpiler + ( asPurescript + , translate2PS) +where import AnyAll qualified as AA import AnyAll.BoolStruct (alwaysLabeled) @@ -203,7 +208,16 @@ biggestS env rl = do then [] else pure $ onlys ! fst (DL.head sorted) -asPurescript :: NLGEnv -> [Rule] -> XPileLogE String +-- | top level entry point for purescript generation +-- +-- [TODO] how do we modularize and abstract from the NLG and the GF interaction here? +-- 1. because other modules might want to take advantage of NLG too. +-- 2. because maybe we want to decouple and decline NLG here for simplicity. + +asPurescript + :: NLGEnv -- ^ Used to produce more human readable versions of the questions + -> [Rule] + -> XPileLogE String asPurescript env rl = do let nlgEnvStr = env |> gfLang |> showLanguage l4i = env |> interpreted diff --git a/lib/haskell/natural4/src/LS/XPile/Typescript.hs b/lib/haskell/natural4/src/LS/XPile/Typescript.hs index 3cd0f1410..a47c420da 100644 --- a/lib/haskell/natural4/src/LS/XPile/Typescript.hs +++ b/lib/haskell/natural4/src/LS/XPile/Typescript.hs @@ -349,7 +349,7 @@ hc2ts l4i _hc2@HC { hHead = RPParamText pt } = pretty (PT4 pt l4 hc2ts l4i hc2@HC { hHead = RPnary _rprel [] } = error "TypeScript: headless RPnary encountered" hc2ts l4i hc2@HC { hHead = RPnary _rprel rps } = hc2ts l4i hc2 {hHead = head rps} <+> "// hc2ts RPnary" - +-- | for debugging at the moment only. toPlainTS :: Interpreted -> XPileLog (Doc ann) toPlainTS l4i = do return $ vvsep [ "//" <+> viaShow valpred diff --git a/lib/haskell/natural4/stack.yaml b/lib/haskell/natural4/stack.yaml index 36e527480..47ab6ca13 100644 --- a/lib/haskell/natural4/stack.yaml +++ b/lib/haskell/natural4/stack.yaml @@ -51,7 +51,6 @@ extra-deps: - cgi-3001.5.0.1 - multipart-0.2.1@sha256:c96322a5bb34c29738ba82345d071a8e07d752648de3522f1c04d96df955ea0d,1150 -- jsonlogic-0.1.0.0 allow-newer: true diff --git a/lib/haskell/natural4/stack.yaml.lock b/lib/haskell/natural4/stack.yaml.lock index e67af1a42..2ec76be11 100644 --- a/lib/haskell/natural4/stack.yaml.lock +++ b/lib/haskell/natural4/stack.yaml.lock @@ -87,13 +87,6 @@ packages: size: 383 original: hackage: multipart-0.2.1@sha256:c96322a5bb34c29738ba82345d071a8e07d752648de3522f1c04d96df955ea0d,1150 -- completed: - hackage: jsonlogic-0.1.0.0@sha256:79b5f48ef3f52d0b8c84cf6b7383a7bb5ffd97a15c2683b947335b370c4183aa,2932 - pantry-tree: - sha256: 3c13d5a13a02f581652e1223767ca1d9b0de30fecef5272af6d2a00806e55f77 - size: 3341 - original: - hackage: jsonlogic-0.1.0.0 snapshots: - completed: sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 diff --git a/lib/haskell/natural4/test/LS/NLGSpec.hs b/lib/haskell/natural4/test/LS/NLGSpec.hs index 035d62072..0da6b41d2 100644 --- a/lib/haskell/natural4/test/LS/NLGSpec.hs +++ b/lib/haskell/natural4/test/LS/NLGSpec.hs @@ -22,6 +22,7 @@ import LS.NLP.NLG ) import LS.Rule ( Interpreted (..), + defaultL4I, Rule ( DefNameAlias, DefTypically, @@ -83,6 +84,7 @@ import Test.Hspec shouldBe, ) import qualified Data.Text as Text +import qualified Data.Graph.Inductive as Graph (empty) spec :: Spec spec = do @@ -136,13 +138,19 @@ spec = do -- in MustSing5, the gold just happens to be the same as returned by ruleQuestions, so why not - let mustsing5ViaQaHorns = textViaQaHorns envMustSing5 Nothing (Just $ parseSubj env $ subj $ head mustsing5Rules) - let (mustsing5ViaRuleQuestions,_) = xpLog $ ruleQuestions envMustSing5 Nothing (head $ expandRulesForNLG envMustSing5 mustsing5Rules) - testViaQaHorns "mustsing5" (map snd mustsing5ViaQaHorns) (mustsing5ViaRuleQuestions <> [Leaf "Does the following hold: Person Qualifies"]) + let mustsing5ViaQaHorns = + textViaQaHorns envMustSing5 + Nothing + (Just $ parseSubj env $ subj $ head mustsing5Rules) + let (mustsing5ViaRuleQuestions,_) = xpLog $ + ruleQuestions envMustSing5 + Nothing + (head $ expandRulesForNLG envMustSing5 mustsing5Rules) + testViaQaHorns "mustsing5" (map snd mustsing5ViaQaHorns) (mustsing5ViaRuleQuestions <> [Leaf "Person Qualifies?"]) let mustsing6ViaQaHorns = textViaQaHorns envMustSing6 Nothing (Just $ parseSubj env $ subj $ head mustsing6Rules) let (mustsing6ViaRuleQuestions,_) = xpLog $ ruleQuestions envMustSing6 Nothing (head $ expandRulesForNLG envMustSing6 mustsing6Rules) - testViaQaHorns "mustsing6" (map snd mustsing6ViaQaHorns) ([Leaf "Does the following hold: Person Qualifies"] <> mustsing6ViaRuleQuestions) + testViaQaHorns "mustsing6" (map snd mustsing6ViaQaHorns) ([Leaf "Person Qualifies?"] <> mustsing6ViaRuleQuestions) -- for Rodents, apparently ruleQuestions is genuinely buggy so compare it against a manually copied gold let rodentsViaQaHorns = textViaQaHorns env Nothing (Just $ parseSubj env $ subj $ head rodentsRules) @@ -900,7 +908,7 @@ becomingAwareBSR = Leaf ) pdpa1withUnexpandedUponInterp :: Interpreted -pdpa1withUnexpandedUponInterp = L4I +pdpa1withUnexpandedUponInterp = defaultL4I { classtable = CT Map.empty , scopetable = fromList [ ([ MTT "becoming aware" ] @@ -922,8 +930,10 @@ mustsing5Interp :: Interpreted mustsing5Interp = mustsingInterp qualifiesBSRdrinks mustsing5Rules mustsing6Interp = mustsingInterp qualifiesBSRnotdrink mustsing6Rules +-- [TODO] some tests are broken because the L4I shouldn't be hardcoded -- it should result from running the interpreter on some input ruleset; hence populating the ruleGraph field correctly. + mustsingInterp :: BoolStructR -> [Rule] -> Interpreted -mustsingInterp variableBSR variableOrigRules = L4I +mustsingInterp variableBSR variableOrigRules = defaultL4I { classtable = CT Map.empty , scopetable = fromList [ ([ MTT "Qualifies" ] @@ -962,7 +972,7 @@ mustsingInterp variableBSR variableOrigRules = L4I ] , origrules = variableOrigRules } rodentsInterp :: Interpreted -rodentsInterp = L4I +rodentsInterp = defaultL4I { classtable = CT Map.empty , scopetable = fromList [ @@ -997,7 +1007,7 @@ rodentsInterp = L4I ], origrules = rodentsRules } pdpafullInterp :: Interpreted -pdpafullInterp = L4I {classtable = CT (fromList []), scopetable = fromList [([MTT "NDB Qualification"],fromList [([MTT "it is a Notifiable Data Breach"],((Nothing,[]),[HC {hHead = RPMT [MTT "it is a Notifiable Data Breach"], hBody = Just (All Nothing [Leaf (RPMT [MTT "a data breach",MTT "occurred"]),Not (Leaf (RPMT [MTT "the data breach occurred only within an organisation"])),Any Nothing [Leaf (RPMT [MTT "it results in, or is likely to result in, significant harm to an affected individual"]),Leaf (RPMT [MTT "it is, or is likely to be, of a significant scale"])]])}]))]),([MTT "Notification"],fromList [([MTT "Notification"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "Notification"] RPis (All Nothing [Leaf (RPMT [MTT "Notify PDPC"]),Leaf (RPMT [MTT "Notify Individuals"])]), hBody = Nothing}]))]),([MTT "a data breach",MTT "occurred"],fromList [([MTT "a data breach",MTT "occurred"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "a data breach",MTT "occurred"] RPis (Any Nothing [Any (Just (PrePost "any unauthorised" "of personal data")) [Leaf (RPMT [MTT "access"]),Leaf (RPMT [MTT "use"]),Leaf (RPMT [MTT "disclosure"]),Leaf (RPMT [MTT "copying"]),Leaf (RPMT [MTT "modification"]),Leaf (RPMT [MTT "disposal"])],Any (Just (PrePost "loss of storage medium on which personal data is stored in circumstances where the unauthorised" "of the personal data is likely to occur")) [Leaf (RPMT [MTT "access"]),Leaf (RPMT [MTT "use"]),Leaf (RPMT [MTT "disclosure"]),Leaf (RPMT [MTT "copying"]),Leaf (RPMT [MTT "modification"]),Leaf (RPMT [MTT "disposal"])]]), hBody = Nothing}]))]),([MTT "it is, or is likely to be, of a significant scale"],fromList [([MTT "it is, or is likely to be, of a significant scale"],((Nothing,[]),[HC {hHead = RPMT [MTT "it is, or is likely to be, of a significant scale"], hBody = Just (Leaf (RPConstraint [MTT "the number of affected individuals"] RPgt [MTT "the prescribed threshold of affected individuals"]))}]))]),([MTT "it results in, or is likely to result in, significant harm to an affected individual"],fromList [([MTT "it results in, or is likely to result in, significant harm to an affected individual"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "it results in, or is likely to result in, significant harm to an affected individual"] RPis (All Nothing [Leaf (RPMT [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"]),Not (Any Nothing [Leaf (RPMT [MTT "the organisation has taken any action ",MTT "to render it unlikely that the notifiable data breach will result in significant harm to the individual"]),Leaf (RPMT [MTT "the organisation already implemented any technological measure",MTT "to render it unlikely that the notifiable data breach will result in significant harm to the individual"])])]), hBody = Nothing}]))]),([MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"],fromList [([MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"] RPis (All Nothing [Any (Just (Pre "the data breach relates to the individual's")) [Leaf (RPMT [MTT "full name"]),Leaf (RPMT [MTT "alias"]),Leaf (RPMT [MTT "identification number"])],Leaf (RPMT [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"])]), hBody = Nothing}]))]),([MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"],fromList [([MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"],((Nothing,[]),[HC {hHead = RPMT [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"], hBody = Just (Any Nothing [Leaf (RPMT [MTI 1,MTT "The amount of any wages, salary, fee, commission, bonus, gratuity, allowance or other remuneration paid or payable to the individual by any person, whether under a contract of service or a contract for services."]),Leaf (RPMT [MTI 2,MTT "The income of the individual from the sale of any goods or property."]),Leaf (RPMT [MTI 3,MTT "The number of any credit card, charge card or debit card issued to or in the name of the individual."]),Leaf (RPMT [MTI 4,MTT "The number assigned to any account the individual has with any organisation that is a bank or finance company."]),Any (Just (Pre "5 Any information that identifies, or is likely to lead to the identification of, the individual as a child or young person who \8212")) [Leaf (RPMT [MTT "5.a",MTT "is or had been the subject of any investigation under the CYPA;"]),Leaf (RPMT [MTT "5.b",MTT "is or had been arrested, on or after 1 July 2020, for an offence committed under any written law;"]),Leaf (RPMT [MTT "5.c",MTT "is or had been taken into care or custody by the Director-General of Social Welfare, a protector, any officer generally or specially authorised in that behalf in writing by the Director-General or protector or a police officer under the CYPA;"]),Leaf (RPMT [MTT "5.d",MTT "is attending or had attended a family programme in relation to an application to be made under section 50 of the CYPA;"]),Leaf (RPMT [MTT "5.e",MTT "is or was the subject of an order made by a court under the CYPA; or"]),Leaf (RPMT [MTT "5.f",MTT "is or had been concerned in any proceedings in any court or on appeal from any court, whether the individual is the person against or in respect of whom the proceedings are taken or a witness in those proceedings."])],Any (Just (Pre "6 Any information that identifies, or is likely to lead to the identification of \8212 b")) [Leaf (RPMT [MTT "6.a",MTT "the individual who has been or is the subject of any investigation, examination, assessment or treatment under the VAA relating to whether the individual is a vulnerable adult experiencing or at risk of abuse, neglect or self-neglect;"]),Leaf (RPMT [MTT "6.b",MTT "the individual as a vulnerable adult who has been committed to a place of temporary care and protection or place of safety or to the care of a fit person under the VAA;"]),Leaf (RPMT [MTT "6.c",MTT "the individual as a vulnerable adult who is the subject of an order made by a court under the VAA;"]),Leaf (RPMT [MTT "6.d",MTT "a place of temporary care and protection or place of safety in which an individual or a vulnerable adult mentioned in sub-paragraph (a), (b) or (c) is committed, or the location of such a place of temporary care and protection or place of safety; or"]),Leaf (RPMT [MTT "6.e",MTT "a fit person under whose care an individual or a vulnerable adult mentioned in sub-paragraph (a), (b) or (c) is placed, or the location of the premises of such a fit person."])],Any (Just (Pre "7 Any private key of or relating to the individual that is used or may be used \8212")) [Leaf (RPMT [MTT "7.a",MTT "to create a secure electronic record or secure electronic signature;"]),Leaf (RPMT [MTT "7.b",MTT "to verify the integrity of a secure electronic record; or"]),Leaf (RPMT [MTT "7.c",MTT "to verify the authenticity or integrity of a secure electronic signature."])],Leaf (RPMT [MTI 8,MTT "The net worth of the individual."]),Leaf (RPMT [MTI 9,MTT "The deposit of moneys by the individual with any organisation."]),Leaf (RPMT [MTI 10,MTT "The withdrawal by the individual of moneys deposited with any organisation."]),Leaf (RPMT [MTI 11,MTT "The granting by an organisation of advances, loans and other facilities by which the individual, being a customer of the organisation, has access to funds or financial guarantees."]),Leaf (RPMT [MTI 12,MTT "The incurring by the organisation of any liabilities other than those mentioned in paragraph 11 on behalf of the individual."]),Leaf (RPMT [MTI 13,MTT "The payment of any moneys, or transfer of any property, by any person to the individual, including the amount of the moneys paid or the value of the property transferred, as the case may be."]),Leaf (RPMT [MTI 14,MTT "The creditworthiness of the individual."]),Leaf (RPMT [MTI 15,MTT "The individual\8217s investment in any capital markets products."]),Any (Just (Pre "16 The existence, and amount due or outstanding, of any debt \8212")) [Leaf (RPMT [MTT "16.a",MTT "owed by the individual to an organisation; or"]),Leaf (RPMT [MTT "16.b",MTT "owed by an organisation to the individual."])],Any (Just (Pre "17 Any of the following:")) [Leaf (RPMT [MTT "17.a",MTT "the terms and conditions of any accident and health policy or life policy (called in this item the applicable policy) of which the individual is the policy owner or under which the individual is a beneficiary;"]),Leaf (RPMT [MTT "17.b",MTT "the premium payable by the policy owner under the applicable policy;"]),Leaf (RPMT [MTT "17.c",MTT "the benefits payable to any beneficiary under the applicable policy;"]),Leaf (RPMT [MTT "17.d",MTT "any information relating to any claim on, or payment under, the applicable policy, including the condition of the health of the individual and the diagnosis, treatment, prevention or alleviation of any ailment, condition, disability, disease, disorder or injury that the individual has suffered or is suffering from;"]),Leaf (RPMT [MTT "17.e",MTT "any other information that the individual is the policy owner of, or a beneficiary under, an applicable policy."])],Any (Just (Pre "18 The assessment, diagnosis, treatment, prevention or alleviation by a health professional of any of the following affecting the individual:")) [Leaf (RPMT [MTT "18.a",MTT "any sexually-transmitted disease such as Chlamydial Genital Infection, Gonorrhoea and Syphilis;"]),Leaf (RPMT [MTT "18.b",MTT "Human Immunodeficiency Virus Infection;"]),Leaf (RPMT [MTT "mental illness;"]),Leaf (RPMT [MTT "18.c",MTT "schizophrenia or delusional disorder;"]),Leaf (RPMT [MTT "18.d",MTT "substance abuse and addiction, including drug addiction and alcoholism"])],Any (Just (Pre "19 The provision of treatment to the individual for or in respect of \8212")) [Leaf (RPMT [MTT "19.a",MTT "the donation or receipt of a human egg or human sperm; or"]),Leaf (RPMT [MTT "19.b",MTT "any contraceptive operation or procedure or abortion."])],Any (Just (Pre "20 Any of the following:")) [Leaf (RPMT [MTT "20.a",MTT "subject to section 4(4)(b) of the Act, the donation and removal of any organ from the body of the deceased individual for the purpose of its transplantation into the body of another individual;"]),Leaf (RPMT [MTT "20.b",MTT "the donation and removal of any specified organ from the individual, being a living organ donor, for the purpose of its transplantation into the body of another individual;"]),Leaf (RPMT [MTT "20.c",MTT "the transplantation of any organ mentioned in sub-paragraph (a) or (b) into the body of the individual."])],Leaf (RPMT [MTI 21,MTT "Subject to section 4(4)(b) of the Act, the suicide or attempted suicide of the individual."]),Leaf (RPMT [MTI 22,MTT "Domestic abuse, child abuse or sexual abuse involving or alleged to involve the individual."]),Any (Just (Pre "23 Any of the following:")) [Leaf (RPMT [MTT "23.a",MTT "information that the individual is or had been adopted pursuant to an adoption order made under the Adoption of Children Act (Cap. 4), or is or had been the subject of an application for an adoption order;"]),Leaf (RPMT [MTT "23.b",MTT "the identity of the natural father or mother of the individual;"]),Leaf (RPMT [MTT "23.c",MTT "the identity of the adoptive father or mother of the individual;"]),Leaf (RPMT [MTT "23.d",MTT "the identity of any applicant for an adoption order;"]),Leaf (RPMT [MTT "23.e",MTT "the identity of any person whose consent is necessary under that Act for an adoption order to be made, whether or not the court has dispensed with the consent of that person in accordance with that Act;"]),Leaf (RPMT [MTT "23.f",MTT "any other information that the individual is or had been an adopted child or relating to the adoption of the individual."])]])}]))]),([MTT "the prescribed threshold of affected individuals"],fromList [([MTT "the prescribed threshold of affected individuals"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "the prescribed threshold of affected individuals"] RPis (Leaf (RPMT [MTI 500])), hBody = Nothing}]))])], origrules = pdpafullRules} +pdpafullInterp = defaultL4I {classtable = CT (fromList []), scopetable = fromList [([MTT "NDB Qualification"],fromList [([MTT "it is a Notifiable Data Breach"],((Nothing,[]),[HC {hHead = RPMT [MTT "it is a Notifiable Data Breach"], hBody = Just (All Nothing [Leaf (RPMT [MTT "a data breach",MTT "occurred"]),Not (Leaf (RPMT [MTT "the data breach occurred only within an organisation"])),Any Nothing [Leaf (RPMT [MTT "it results in, or is likely to result in, significant harm to an affected individual"]),Leaf (RPMT [MTT "it is, or is likely to be, of a significant scale"])]])}]))]),([MTT "Notification"],fromList [([MTT "Notification"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "Notification"] RPis (All Nothing [Leaf (RPMT [MTT "Notify PDPC"]),Leaf (RPMT [MTT "Notify Individuals"])]), hBody = Nothing}]))]),([MTT "a data breach",MTT "occurred"],fromList [([MTT "a data breach",MTT "occurred"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "a data breach",MTT "occurred"] RPis (Any Nothing [Any (Just (PrePost "any unauthorised" "of personal data")) [Leaf (RPMT [MTT "access"]),Leaf (RPMT [MTT "use"]),Leaf (RPMT [MTT "disclosure"]),Leaf (RPMT [MTT "copying"]),Leaf (RPMT [MTT "modification"]),Leaf (RPMT [MTT "disposal"])],Any (Just (PrePost "loss of storage medium on which personal data is stored in circumstances where the unauthorised" "of the personal data is likely to occur")) [Leaf (RPMT [MTT "access"]),Leaf (RPMT [MTT "use"]),Leaf (RPMT [MTT "disclosure"]),Leaf (RPMT [MTT "copying"]),Leaf (RPMT [MTT "modification"]),Leaf (RPMT [MTT "disposal"])]]), hBody = Nothing}]))]),([MTT "it is, or is likely to be, of a significant scale"],fromList [([MTT "it is, or is likely to be, of a significant scale"],((Nothing,[]),[HC {hHead = RPMT [MTT "it is, or is likely to be, of a significant scale"], hBody = Just (Leaf (RPConstraint [MTT "the number of affected individuals"] RPgt [MTT "the prescribed threshold of affected individuals"]))}]))]),([MTT "it results in, or is likely to result in, significant harm to an affected individual"],fromList [([MTT "it results in, or is likely to result in, significant harm to an affected individual"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "it results in, or is likely to result in, significant harm to an affected individual"] RPis (All Nothing [Leaf (RPMT [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"]),Not (Any Nothing [Leaf (RPMT [MTT "the organisation has taken any action ",MTT "to render it unlikely that the notifiable data breach will result in significant harm to the individual"]),Leaf (RPMT [MTT "the organisation already implemented any technological measure",MTT "to render it unlikely that the notifiable data breach will result in significant harm to the individual"])])]), hBody = Nothing}]))]),([MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"],fromList [([MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"] RPis (All Nothing [Any (Just (Pre "the data breach relates to the individual's")) [Leaf (RPMT [MTT "full name"]),Leaf (RPMT [MTT "alias"]),Leaf (RPMT [MTT "identification number"])],Leaf (RPMT [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"])]), hBody = Nothing}]))]),([MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"],fromList [([MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"],((Nothing,[]),[HC {hHead = RPMT [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"], hBody = Just (Any Nothing [Leaf (RPMT [MTI 1,MTT "The amount of any wages, salary, fee, commission, bonus, gratuity, allowance or other remuneration paid or payable to the individual by any person, whether under a contract of service or a contract for services."]),Leaf (RPMT [MTI 2,MTT "The income of the individual from the sale of any goods or property."]),Leaf (RPMT [MTI 3,MTT "The number of any credit card, charge card or debit card issued to or in the name of the individual."]),Leaf (RPMT [MTI 4,MTT "The number assigned to any account the individual has with any organisation that is a bank or finance company."]),Any (Just (Pre "5 Any information that identifies, or is likely to lead to the identification of, the individual as a child or young person who \8212")) [Leaf (RPMT [MTT "5.a",MTT "is or had been the subject of any investigation under the CYPA;"]),Leaf (RPMT [MTT "5.b",MTT "is or had been arrested, on or after 1 July 2020, for an offence committed under any written law;"]),Leaf (RPMT [MTT "5.c",MTT "is or had been taken into care or custody by the Director-General of Social Welfare, a protector, any officer generally or specially authorised in that behalf in writing by the Director-General or protector or a police officer under the CYPA;"]),Leaf (RPMT [MTT "5.d",MTT "is attending or had attended a family programme in relation to an application to be made under section 50 of the CYPA;"]),Leaf (RPMT [MTT "5.e",MTT "is or was the subject of an order made by a court under the CYPA; or"]),Leaf (RPMT [MTT "5.f",MTT "is or had been concerned in any proceedings in any court or on appeal from any court, whether the individual is the person against or in respect of whom the proceedings are taken or a witness in those proceedings."])],Any (Just (Pre "6 Any information that identifies, or is likely to lead to the identification of \8212 b")) [Leaf (RPMT [MTT "6.a",MTT "the individual who has been or is the subject of any investigation, examination, assessment or treatment under the VAA relating to whether the individual is a vulnerable adult experiencing or at risk of abuse, neglect or self-neglect;"]),Leaf (RPMT [MTT "6.b",MTT "the individual as a vulnerable adult who has been committed to a place of temporary care and protection or place of safety or to the care of a fit person under the VAA;"]),Leaf (RPMT [MTT "6.c",MTT "the individual as a vulnerable adult who is the subject of an order made by a court under the VAA;"]),Leaf (RPMT [MTT "6.d",MTT "a place of temporary care and protection or place of safety in which an individual or a vulnerable adult mentioned in sub-paragraph (a), (b) or (c) is committed, or the location of such a place of temporary care and protection or place of safety; or"]),Leaf (RPMT [MTT "6.e",MTT "a fit person under whose care an individual or a vulnerable adult mentioned in sub-paragraph (a), (b) or (c) is placed, or the location of the premises of such a fit person."])],Any (Just (Pre "7 Any private key of or relating to the individual that is used or may be used \8212")) [Leaf (RPMT [MTT "7.a",MTT "to create a secure electronic record or secure electronic signature;"]),Leaf (RPMT [MTT "7.b",MTT "to verify the integrity of a secure electronic record; or"]),Leaf (RPMT [MTT "7.c",MTT "to verify the authenticity or integrity of a secure electronic signature."])],Leaf (RPMT [MTI 8,MTT "The net worth of the individual."]),Leaf (RPMT [MTI 9,MTT "The deposit of moneys by the individual with any organisation."]),Leaf (RPMT [MTI 10,MTT "The withdrawal by the individual of moneys deposited with any organisation."]),Leaf (RPMT [MTI 11,MTT "The granting by an organisation of advances, loans and other facilities by which the individual, being a customer of the organisation, has access to funds or financial guarantees."]),Leaf (RPMT [MTI 12,MTT "The incurring by the organisation of any liabilities other than those mentioned in paragraph 11 on behalf of the individual."]),Leaf (RPMT [MTI 13,MTT "The payment of any moneys, or transfer of any property, by any person to the individual, including the amount of the moneys paid or the value of the property transferred, as the case may be."]),Leaf (RPMT [MTI 14,MTT "The creditworthiness of the individual."]),Leaf (RPMT [MTI 15,MTT "The individual\8217s investment in any capital markets products."]),Any (Just (Pre "16 The existence, and amount due or outstanding, of any debt \8212")) [Leaf (RPMT [MTT "16.a",MTT "owed by the individual to an organisation; or"]),Leaf (RPMT [MTT "16.b",MTT "owed by an organisation to the individual."])],Any (Just (Pre "17 Any of the following:")) [Leaf (RPMT [MTT "17.a",MTT "the terms and conditions of any accident and health policy or life policy (called in this item the applicable policy) of which the individual is the policy owner or under which the individual is a beneficiary;"]),Leaf (RPMT [MTT "17.b",MTT "the premium payable by the policy owner under the applicable policy;"]),Leaf (RPMT [MTT "17.c",MTT "the benefits payable to any beneficiary under the applicable policy;"]),Leaf (RPMT [MTT "17.d",MTT "any information relating to any claim on, or payment under, the applicable policy, including the condition of the health of the individual and the diagnosis, treatment, prevention or alleviation of any ailment, condition, disability, disease, disorder or injury that the individual has suffered or is suffering from;"]),Leaf (RPMT [MTT "17.e",MTT "any other information that the individual is the policy owner of, or a beneficiary under, an applicable policy."])],Any (Just (Pre "18 The assessment, diagnosis, treatment, prevention or alleviation by a health professional of any of the following affecting the individual:")) [Leaf (RPMT [MTT "18.a",MTT "any sexually-transmitted disease such as Chlamydial Genital Infection, Gonorrhoea and Syphilis;"]),Leaf (RPMT [MTT "18.b",MTT "Human Immunodeficiency Virus Infection;"]),Leaf (RPMT [MTT "mental illness;"]),Leaf (RPMT [MTT "18.c",MTT "schizophrenia or delusional disorder;"]),Leaf (RPMT [MTT "18.d",MTT "substance abuse and addiction, including drug addiction and alcoholism"])],Any (Just (Pre "19 The provision of treatment to the individual for or in respect of \8212")) [Leaf (RPMT [MTT "19.a",MTT "the donation or receipt of a human egg or human sperm; or"]),Leaf (RPMT [MTT "19.b",MTT "any contraceptive operation or procedure or abortion."])],Any (Just (Pre "20 Any of the following:")) [Leaf (RPMT [MTT "20.a",MTT "subject to section 4(4)(b) of the Act, the donation and removal of any organ from the body of the deceased individual for the purpose of its transplantation into the body of another individual;"]),Leaf (RPMT [MTT "20.b",MTT "the donation and removal of any specified organ from the individual, being a living organ donor, for the purpose of its transplantation into the body of another individual;"]),Leaf (RPMT [MTT "20.c",MTT "the transplantation of any organ mentioned in sub-paragraph (a) or (b) into the body of the individual."])],Leaf (RPMT [MTI 21,MTT "Subject to section 4(4)(b) of the Act, the suicide or attempted suicide of the individual."]),Leaf (RPMT [MTI 22,MTT "Domestic abuse, child abuse or sexual abuse involving or alleged to involve the individual."]),Any (Just (Pre "23 Any of the following:")) [Leaf (RPMT [MTT "23.a",MTT "information that the individual is or had been adopted pursuant to an adoption order made under the Adoption of Children Act (Cap. 4), or is or had been the subject of an application for an adoption order;"]),Leaf (RPMT [MTT "23.b",MTT "the identity of the natural father or mother of the individual;"]),Leaf (RPMT [MTT "23.c",MTT "the identity of the adoptive father or mother of the individual;"]),Leaf (RPMT [MTT "23.d",MTT "the identity of any applicant for an adoption order;"]),Leaf (RPMT [MTT "23.e",MTT "the identity of any person whose consent is necessary under that Act for an adoption order to be made, whether or not the court has dispensed with the consent of that person in accordance with that Act;"]),Leaf (RPMT [MTT "23.f",MTT "any other information that the individual is or had been an adopted child or relating to the adoption of the individual."])]])}]))]),([MTT "the prescribed threshold of affected individuals"],fromList [([MTT "the prescribed threshold of affected individuals"],((Nothing,[]),[HC {hHead = RPBoolStructR [MTT "the prescribed threshold of affected individuals"] RPis (Leaf (RPMT [MTI 500])), hBody = Nothing}]))])], origrules = pdpafullRules} pdpafullRules :: [Rule] pdpafullRules = [Regulative {subj = Leaf ((MTT "Organisation" :| [],Nothing) :| []), rkeyword = REvery, who = Just (Not (Leaf (RPMT [MTT "is",MTT "a Public Agency"]))), cond = Just (Any Nothing [Leaf (RPConstraint [MTT "the data breach occurred"] (RPTC TOn) [MTT "1 Feb 2022"]),Leaf (RPConstraint [MTT "the data breach occurred"] (RPTC TAfter) [MTT "1 Feb 2022"])]), deontic = DMust, action = Leaf ((MTT "assess" :| [MTT "if it is a Notifiable Data Breach"],Nothing) :| [(MTT "by" :| [MTT "evaluating",MTT "NDB Qualification"],Nothing)]), temporal = Just (TemporalConstraint TBefore (Just 30) "days"), hence = Just (RuleAlias [MTT "Notification"]), lest = Just (RuleAlias [MTT "PDPC query with demand"]), rlabel = Just ("\167",1,"Assessment"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 8, srccol = 24, version = Nothing}), upon = Just ((MTT "becoming aware a data breach may have occurred" :| [],Nothing) :| []), given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "the PDPC" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Nothing, deontic = DMay, action = Leaf ((MTT "query" :| [MTT "You"],Nothing) :| [(MTT "with" :| [MTT "a demand"],Nothing),(MTT "for" :| [MTT "an explanation of your inaction"],Nothing)]), temporal = Nothing, hence = Just (RuleAlias [MTT "Respond to PDPC"]), lest = Nothing, rlabel = Just ("\167",1,"PDPC query with demand"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 7, srccol = 37, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "You" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Nothing, deontic = DMust, action = Leaf ((MTT "respond to" :| [MTT "the PDPC"],Nothing) :| [(MTT "with" :| [MTT "an explanation of your inaction"],Nothing)]), temporal = Nothing, hence = Nothing, lest = Nothing, rlabel = Just ("\167",1,"Respond to PDPC"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 7, srccol = 45, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},defaultHorn {name = [MTT "it is a Notifiable Data Breach"], super = Nothing, keyword = Decide, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPMT [MTT "it is a Notifiable Data Breach"], hBody = Just (All Nothing [Leaf (RPMT [MTT "a data breach",MTT "occurred"]),Not (Leaf (RPMT [MTT "the data breach occurred only within an organisation"])),Any Nothing [Leaf (RPMT [MTT "it results in, or is likely to result in, significant harm to an affected individual"]),Leaf (RPMT [MTT "it is, or is likely to be, of a significant scale"])]])}], rlabel = Just ("\167",1,"NDB Qualification"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 8, srccol = 72, version = Nothing}), defaults = [], symtab = []},defaultHorn {name = [MTT "it is, or is likely to be, of a significant scale"], super = Nothing, keyword = Decide, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPMT [MTT "it is, or is likely to be, of a significant scale"], hBody = Just (Leaf (RPConstraint [MTT "the number of affected individuals"] RPgt [MTT "the prescribed threshold of affected individuals"]))}], rlabel = Nothing, lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 8, srccol = 123, version = Nothing}), defaults = [], symtab = []},defaultHorn {name = [MTT "the prescribed threshold of affected individuals"], super = Nothing, keyword = Means, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPBoolStructR [MTT "the prescribed threshold of affected individuals"] RPis (Leaf (RPMT [MTI 500])), hBody = Nothing}], rlabel = Nothing, lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 17, srccol = 126, version = Nothing}), defaults = [], symtab = []},defaultHorn {name = [MTT "Notification"], super = Nothing, keyword = Means, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPBoolStructR [MTT "Notification"] RPis (All Nothing [Leaf (RPMT [MTT "Notify PDPC"]),Leaf (RPMT [MTT "Notify Individuals"])]), hBody = Nothing}], rlabel = Just ("\167",1,"Notification"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 134, version = Nothing}), defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "You" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Just (All Nothing [Leaf (RPMT [MTT "it is a Notifiable Data Breach"]),Not (Leaf (RPMT [MTT "you are a Public Agency"]))]), deontic = DMust, action = Leaf ((MTT "NOTIFY" :| [MTT "the PDPC"],Nothing) :| [(MTT "in" :| [MTT "the form and manner specified at www.pdpc.gov.sg"],Nothing),(MTT "with" :| [MTT "a Notification Message"],Nothing),(MTT "containing" :| [MTT "a list of individuals for whom notification waiver is sought"],Nothing),(MTT "and" :| [MTT "justification for why"],Nothing)]), temporal = Just (TemporalConstraint TBefore (Just 3) "DAYS"), hence = Just (RuleAlias [MTT "PDPC prohibit notify individuals"]), lest = Nothing, rlabel = Just ("\167",2,"Notify PDPC"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 139, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "the PDPC" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Nothing, deontic = DMay, action = Leaf ((MTT "NOTIFY" :| [MTT "you"],Nothing) :| [(MTT "with" :| [MTT "a list of individuals to exclude from notification"],Nothing)]), temporal = Nothing, hence = Just (RuleAlias [MTT "Cannot notify individuals"]), lest = Nothing, rlabel = Just ("\167",2,"PDPC prohibit notify individuals"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 155, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "YOU" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Nothing, deontic = DShant, action = Leaf ((MTT "NOTIFY" :| [MTT "each of the Notifiable Individuals"],Nothing) :| [(MTT "who" :| [MTT "are on the affected list"],Nothing)]), temporal = Nothing, hence = Nothing, lest = Nothing, rlabel = Just ("\167",2,"Cannot notify individuals"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 163, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "You" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Just (All Nothing [Leaf (RPMT [MTT "it is a Notifiable Data Breach"]),Not (Leaf (RPMT [MTT "you are a Public Agency"]))]), deontic = DMust, action = Leaf ((MTT "NOTIFY" :| [MTT "each of the Notifiable Individuals"],Nothing) :| [(MTT "in" :| [MTT "any manner that is reasonable in the circumstances"],Nothing),(MTT "with" :| [MTT "a message obeying a certain format"],Nothing)]), temporal = Just (TemporalConstraint TBefore (Just 3) "days"), hence = Nothing, lest = Just (RuleAlias [MTT "Notify and explain"]), rlabel = Just ("\167",2,"Notify Individuals"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 175, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},Regulative {subj = Leaf ((MTT "You" :| [],Nothing) :| []), rkeyword = RParty, who = Nothing, cond = Nothing, deontic = DMust, action = Leaf ((MTT "notify" :| [MTT "each of the Notifiable Individuals"],Nothing) :| []), temporal = Nothing, hence = Nothing, lest = Nothing, rlabel = Just ("\167",2,"Notify and explain"), lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 191, version = Nothing}), upon = Nothing, given = Nothing, having = Nothing, wwhere = [], defaults = [], symtab = []},defaultHorn {name = [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"], super = Nothing, keyword = Decide, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPMT [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"], hBody = Just (Any Nothing [Leaf (RPMT [MTI 1,MTT "The amount of any wages, salary, fee, commission, bonus, gratuity, allowance or other remuneration paid or payable to the individual by any person, whether under a contract of service or a contract for services."]),Leaf (RPMT [MTI 2,MTT "The income of the individual from the sale of any goods or property."]),Leaf (RPMT [MTI 3,MTT "The number of any credit card, charge card or debit card issued to or in the name of the individual."]),Leaf (RPMT [MTI 4,MTT "The number assigned to any account the individual has with any organisation that is a bank or finance company."]),Any (Just (Pre "5 Any information that identifies, or is likely to lead to the identification of, the individual as a child or young person who \8212")) [Leaf (RPMT [MTT "5.a",MTT "is or had been the subject of any investigation under the CYPA;"]),Leaf (RPMT [MTT "5.b",MTT "is or had been arrested, on or after 1 July 2020, for an offence committed under any written law;"]),Leaf (RPMT [MTT "5.c",MTT "is or had been taken into care or custody by the Director-General of Social Welfare, a protector, any officer generally or specially authorised in that behalf in writing by the Director-General or protector or a police officer under the CYPA;"]),Leaf (RPMT [MTT "5.d",MTT "is attending or had attended a family programme in relation to an application to be made under section 50 of the CYPA;"]),Leaf (RPMT [MTT "5.e",MTT "is or was the subject of an order made by a court under the CYPA; or"]),Leaf (RPMT [MTT "5.f",MTT "is or had been concerned in any proceedings in any court or on appeal from any court, whether the individual is the person against or in respect of whom the proceedings are taken or a witness in those proceedings."])],Any (Just (Pre "6 Any information that identifies, or is likely to lead to the identification of \8212 b")) [Leaf (RPMT [MTT "6.a",MTT "the individual who has been or is the subject of any investigation, examination, assessment or treatment under the VAA relating to whether the individual is a vulnerable adult experiencing or at risk of abuse, neglect or self-neglect;"]),Leaf (RPMT [MTT "6.b",MTT "the individual as a vulnerable adult who has been committed to a place of temporary care and protection or place of safety or to the care of a fit person under the VAA;"]),Leaf (RPMT [MTT "6.c",MTT "the individual as a vulnerable adult who is the subject of an order made by a court under the VAA;"]),Leaf (RPMT [MTT "6.d",MTT "a place of temporary care and protection or place of safety in which an individual or a vulnerable adult mentioned in sub-paragraph (a), (b) or (c) is committed, or the location of such a place of temporary care and protection or place of safety; or"]),Leaf (RPMT [MTT "6.e",MTT "a fit person under whose care an individual or a vulnerable adult mentioned in sub-paragraph (a), (b) or (c) is placed, or the location of the premises of such a fit person."])],Any (Just (Pre "7 Any private key of or relating to the individual that is used or may be used \8212")) [Leaf (RPMT [MTT "7.a",MTT "to create a secure electronic record or secure electronic signature;"]),Leaf (RPMT [MTT "7.b",MTT "to verify the integrity of a secure electronic record; or"]),Leaf (RPMT [MTT "7.c",MTT "to verify the authenticity or integrity of a secure electronic signature."])],Leaf (RPMT [MTI 8,MTT "The net worth of the individual."]),Leaf (RPMT [MTI 9,MTT "The deposit of moneys by the individual with any organisation."]),Leaf (RPMT [MTI 10,MTT "The withdrawal by the individual of moneys deposited with any organisation."]),Leaf (RPMT [MTI 11,MTT "The granting by an organisation of advances, loans and other facilities by which the individual, being a customer of the organisation, has access to funds or financial guarantees."]),Leaf (RPMT [MTI 12,MTT "The incurring by the organisation of any liabilities other than those mentioned in paragraph 11 on behalf of the individual."]),Leaf (RPMT [MTI 13,MTT "The payment of any moneys, or transfer of any property, by any person to the individual, including the amount of the moneys paid or the value of the property transferred, as the case may be."]),Leaf (RPMT [MTI 14,MTT "The creditworthiness of the individual."]),Leaf (RPMT [MTI 15,MTT "The individual\8217s investment in any capital markets products."]),Any (Just (Pre "16 The existence, and amount due or outstanding, of any debt \8212")) [Leaf (RPMT [MTT "16.a",MTT "owed by the individual to an organisation; or"]),Leaf (RPMT [MTT "16.b",MTT "owed by an organisation to the individual."])],Any (Just (Pre "17 Any of the following:")) [Leaf (RPMT [MTT "17.a",MTT "the terms and conditions of any accident and health policy or life policy (called in this item the applicable policy) of which the individual is the policy owner or under which the individual is a beneficiary;"]),Leaf (RPMT [MTT "17.b",MTT "the premium payable by the policy owner under the applicable policy;"]),Leaf (RPMT [MTT "17.c",MTT "the benefits payable to any beneficiary under the applicable policy;"]),Leaf (RPMT [MTT "17.d",MTT "any information relating to any claim on, or payment under, the applicable policy, including the condition of the health of the individual and the diagnosis, treatment, prevention or alleviation of any ailment, condition, disability, disease, disorder or injury that the individual has suffered or is suffering from;"]),Leaf (RPMT [MTT "17.e",MTT "any other information that the individual is the policy owner of, or a beneficiary under, an applicable policy."])],Any (Just (Pre "18 The assessment, diagnosis, treatment, prevention or alleviation by a health professional of any of the following affecting the individual:")) [Leaf (RPMT [MTT "18.a",MTT "any sexually-transmitted disease such as Chlamydial Genital Infection, Gonorrhoea and Syphilis;"]),Leaf (RPMT [MTT "18.b",MTT "Human Immunodeficiency Virus Infection;"]),Leaf (RPMT [MTT "mental illness;"]),Leaf (RPMT [MTT "18.c",MTT "schizophrenia or delusional disorder;"]),Leaf (RPMT [MTT "18.d",MTT "substance abuse and addiction, including drug addiction and alcoholism"])],Any (Just (Pre "19 The provision of treatment to the individual for or in respect of \8212")) [Leaf (RPMT [MTT "19.a",MTT "the donation or receipt of a human egg or human sperm; or"]),Leaf (RPMT [MTT "19.b",MTT "any contraceptive operation or procedure or abortion."])],Any (Just (Pre "20 Any of the following:")) [Leaf (RPMT [MTT "20.a",MTT "subject to section 4(4)(b) of the Act, the donation and removal of any organ from the body of the deceased individual for the purpose of its transplantation into the body of another individual;"]),Leaf (RPMT [MTT "20.b",MTT "the donation and removal of any specified organ from the individual, being a living organ donor, for the purpose of its transplantation into the body of another individual;"]),Leaf (RPMT [MTT "20.c",MTT "the transplantation of any organ mentioned in sub-paragraph (a) or (b) into the body of the individual."])],Leaf (RPMT [MTI 21,MTT "Subject to section 4(4)(b) of the Act, the suicide or attempted suicide of the individual."]),Leaf (RPMT [MTI 22,MTT "Domestic abuse, child abuse or sexual abuse involving or alleged to involve the individual."]),Any (Just (Pre "23 Any of the following:")) [Leaf (RPMT [MTT "23.a",MTT "information that the individual is or had been adopted pursuant to an adoption order made under the Adoption of Children Act (Cap. 4), or is or had been the subject of an application for an adoption order;"]),Leaf (RPMT [MTT "23.b",MTT "the identity of the natural father or mother of the individual;"]),Leaf (RPMT [MTT "23.c",MTT "the identity of the adoptive father or mother of the individual;"]),Leaf (RPMT [MTT "23.d",MTT "the identity of any applicant for an adoption order;"]),Leaf (RPMT [MTT "23.e",MTT "the identity of any person whose consent is necessary under that Act for an adoption order to be made, whether or not the court has dispensed with the consent of that person in accordance with that Act;"]),Leaf (RPMT [MTT "23.f",MTT "any other information that the individual is or had been an adopted child or relating to the adoption of the individual."])]])}], rlabel = Nothing, lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 8, srccol = 233, version = Nothing}), defaults = [], symtab = []},DefNameAlias {name = [MTT "You"], detail = [MTT "Organisation"], nlhint = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 26, version = Nothing})},DefTypically {name = [MTT "is",MTT "a Public Agency"], defaults = [RPConstraint [MTT "is",MTT "a Public Agency"] RPis [MTT "not"]], srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 27, version = Nothing})},DefNameAlias {name = [MTT "NDB"], detail = [MTT "it is a Notifiable Data Breach"], nlhint = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 9, srccol = 74, version = Nothing})},defaultHorn {name = [MTT "a data breach",MTT "occurred"], super = Nothing, keyword = Means, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPBoolStructR [MTT "a data breach",MTT "occurred"] RPis (Any Nothing [Any (Just (PrePost "any unauthorised" "of personal data")) [Leaf (RPMT [MTT "access"]),Leaf (RPMT [MTT "use"]),Leaf (RPMT [MTT "disclosure"]),Leaf (RPMT [MTT "copying"]),Leaf (RPMT [MTT "modification"]),Leaf (RPMT [MTT "disposal"])],Any (Just (PrePost "loss of storage medium on which personal data is stored in circumstances where the unauthorised" "of the personal data is likely to occur")) [Leaf (RPMT [MTT "access"]),Leaf (RPMT [MTT "use"]),Leaf (RPMT [MTT "disclosure"]),Leaf (RPMT [MTT "copying"]),Leaf (RPMT [MTT "modification"]),Leaf (RPMT [MTT "disposal"])]]), hBody = Nothing}], rlabel = Nothing, lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 10, srccol = 74, version = Nothing}), defaults = [], symtab = []},defaultHorn {name = [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"], super = Nothing, keyword = Means, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPBoolStructR [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"] RPis (All Nothing [Any (Just (Pre "the data breach relates to the individual's")) [Leaf (RPMT [MTT "full name"]),Leaf (RPMT [MTT "alias"]),Leaf (RPMT [MTT "identification number"])],Leaf (RPMT [MTT "the data breach relates to",MTT "any of the prescribed personal data or classes of personal data relating to the individual"])]), hBody = Nothing}], rlabel = Nothing, lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 12, srccol = 91, version = Nothing}), defaults = [], symtab = []},defaultHorn {name = [MTT "it results in, or is likely to result in, significant harm to an affected individual"], super = Nothing, keyword = Means, given = Nothing, giveth = Nothing, upon = Nothing, clauses = [HC {hHead = RPBoolStructR [MTT "it results in, or is likely to result in, significant harm to an affected individual"] RPis (All Nothing [Leaf (RPMT [MTT "the data breach is in relation to any prescribed personal data or class of personal data relating to the individual"]),Not (Any Nothing [Leaf (RPMT [MTT "the organisation has taken any action ",MTT "to render it unlikely that the notifiable data breach will result in significant harm to the individual"]),Leaf (RPMT [MTT "the organisation already implemented any technological measure",MTT "to render it unlikely that the notifiable data breach will result in significant harm to the individual"])])]), hBody = Nothing}], rlabel = Nothing, lsource = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 10, srccol = 90, version = Nothing}), defaults = [], symtab = []},DefNameAlias {name = [MTT "the PDPC Exclusion List"], detail = [MTT "with",MTT "a list of individuals to exclude from notification"], nlhint = Nothing, srcref = Just (SrcRef {url = "test/pdpa-full.csv", short = "test/pdpa-full.csv", srcrow = 11, srccol = 160, version = Nothing})}] diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/and-not/and-not.csv b/lib/haskell/natural4/test/Testcases/LogicalEnglish/and-not/and-not.csv new file mode 100644 index 000000000..275a1c75b --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/and-not/and-not.csv @@ -0,0 +1,5 @@ +GIVEN,x,IS A,Animal +,aquatic animal,IS A,Aquatic animal +DECIDE,x,is an,aquatic animal +IF,,x,lives in water +AND,NOT,x,lives on land diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/indentation-databreach.csv b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/indentation-databreach.csv new file mode 100644 index 000000000..3b241264b --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/indentation-databreach.csv @@ -0,0 +1,8 @@ +GIVEN,data breach,,IS A,Data Breach,,,, +,organization,,IS A,Organization,,,, +,individual,,IS A,Person,,,, +DECIDE,data breach,with,organization,results in harm to,individual,,, +IF,data breach,with,organization,exposed data from,individual,,, +AND,data breach,with,organization,related to the name of,individual,,, +,OR,data breach,with,organization,relates to an account,individual,had with,organization +,,AND,data breach,with,organization,relates to data required for access to the account of,individual, \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/nonlib-rules.txt b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/nonlib-rules.txt new file mode 100644 index 000000000..51ddb89af --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/nonlib-rules.txt @@ -0,0 +1,5 @@ +a data breach with a organization results in harm to a individual +if data breach with organization exposed data from individual +and data breach with organization relates to the name of individual + or data breach with organization relates to an account individual had with organization + and data breach with organization relates to data required for access to the account of individual. \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/nonlib-templates.txt b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/nonlib-templates.txt new file mode 100644 index 000000000..a00dcfa8c --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/nonlib-templates.txt @@ -0,0 +1,5 @@ +*a data breach* with *a organization* results in harm to *a individual* +*a data breach* with *a organization* exposed data from *an individual* +*a data breach* with *a organization* relates to the name of *a individual* +*a data breach* with *a organization* relates to an account *a individual* had with *a organization* +*a data breach* with *a organization* relates to data required for access to the account of *a individual* \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/notes/indentation-databreach-with-queries.le b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/notes/indentation-databreach-with-queries.le new file mode 100644 index 000000000..c2bcfa840 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/indentation-propn-databreach/notes/indentation-databreach-with-queries.le @@ -0,0 +1,31 @@ +the target language is: prolog. + +the templates are: + *a data breach* with *a organization* results in harm to *a individual*, + *a data breach* with *a organization* exposed data from *an individual*, + *a data breach* with *a organization* relates to the name of *a individual*, + *a data breach* with *a organization* relates to an account *a individual* had with *a organization*, + *a data breach* with *a organization* relates to data required for access to the account of *a individual*. + +the knowledge base includes: + a data breach with a organization results in harm to a individual + if data breach with organization exposed data from individual + and data breach with organization relates to the name of individual + or data breach with organization relates to an account individual had with organization + and data breach with organization relates to data required for access to the account of individual. + +scenario alicesimple is: + the incident last night with acmecorp exposed data from alice. + the incident last night with acmecorp relates to the name of alice. + + +scenario aliceharder is: + the incident last night with acmecorp exposed data from alice. + the incident last night with acmecorp relates to an account alice had with acmecorp. + the incident last night with acmecorp relates to data required for access to the account of alice. + +query q is: + 0 < 1. + +query qa is: + which breach with which org results in harm to alice. \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/nonlib-rules.txt b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/nonlib-rules.txt new file mode 100644 index 000000000..a49f860b7 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/nonlib-rules.txt @@ -0,0 +1,3 @@ +a x is twice of a y +if y is between 0 & 100 +and x is the product of [y, 2]. diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/nonlib-templates.txt b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/nonlib-templates.txt new file mode 100644 index 000000000..7e2a06db5 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/nonlib-templates.txt @@ -0,0 +1 @@ +*a x* is twice of *a y* diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/notes/product.pl b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/notes/product.pl new file mode 100644 index 000000000..9eee1f35f --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/notes/product.pl @@ -0,0 +1,11 @@ +:-module('product-prolog', []). +source_lang(en). +local_dict([is_twice_of, A, B], [x-x, y-y], [A, is, twice, of, B]). +local_meta_dict([],[],[]). +prolog_le(verified). +is_twice_of(A, B) :- + between(0, 100, B), + product_list([B, 2], A). +example(null, []). +query(null, true). +query(q, is_twice_of(_, _)). diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/product.csv b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/product.csv new file mode 100644 index 000000000..125b588d3 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/product.csv @@ -0,0 +1,7 @@ +GIVEN,x,IS A,Number, +,y,IS A,Number, +DECIDE,x,is twice of,y, +IF,y,>=,0, +AND,y,<=,100, +AND,x,IS,PRODUCT,y +,,,,2 diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/product.le b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/product.le new file mode 100644 index 000000000..e96d8a880 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/product-twiceof/product.le @@ -0,0 +1,12 @@ +the target language is: prolog. + +the templates are: + *a x* is twice of *a y*. + +the knowledge base encoding includes: + a x is twice of a y + if y is between 0 & 100 + and x is the product of [y, 2]. + +query q is: + which number is twice of which other number. diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/rpnary-and/rpnary-and.csv b/lib/haskell/natural4/test/Testcases/LogicalEnglish/rpnary-and/rpnary-and.csv new file mode 100644 index 000000000..b58ca5fde --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/rpnary-and/rpnary-and.csv @@ -0,0 +1,4 @@ +GIVEN,x,IS A,Fluorescent Lamp, +DECIDE,x,IS,&&,low-pressure +,,,,mercury-vapor +,,,,gas-discharge diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/nonlib-rules.txt b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/nonlib-rules.txt new file mode 100644 index 000000000..3413979b2 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/nonlib-rules.txt @@ -0,0 +1,2 @@ +a x is the parent of a y +if y is the child of x. \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/nonlib-templates.txt b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/nonlib-templates.txt new file mode 100644 index 000000000..cf099796a --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/nonlib-templates.txt @@ -0,0 +1,2 @@ +*a x* is the parent of *a y* +*a y* is the child of *a x* \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/notes/parentchild.pl b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/notes/parentchild.pl new file mode 100644 index 000000000..7f25bc90e --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/notes/parentchild.pl @@ -0,0 +1,12 @@ +:-module('parent_eg_no_libs-prolog', []). +source_lang(en). +local_dict([is_the_parent_of, A, B], [x-x, y-y], [A, is, the, parent, of, B]). +local_dict([is_the_child_of, A, B], [y-y, x-x], [A, is, the, child, of, B]). +local_meta_dict([],[],[]). +prolog_le(verified). +is_the_parent_of(A, B) :- + is_the_child_of(B, A). +example(null, []). +example(alice, [scenario([(is_the_child_of('Alice6', 'Bob'):-true)], true)]). +query(null, true). +query(q_ap, is_the_parent_of(_, 'Alice6')). diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild-with-period.csv b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild-with-period.csv new file mode 100644 index 000000000..9347322c8 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild-with-period.csv @@ -0,0 +1,4 @@ +GIVEN,x,,IS A,Person +,y,,IS A,Person +DECIDE,x,is the parent of,y, +IF,y,is the child of,x., \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild-without-period.csv b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild-without-period.csv new file mode 100644 index 000000000..fe4721208 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild-without-period.csv @@ -0,0 +1,4 @@ +GIVEN,x,,IS A,Person +,y,,IS A,Person +DECIDE,x,is the parent of,y, +IF,y,is the child of,x, \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild.le b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild.le new file mode 100644 index 000000000..2fa660393 --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-parentchild/parentchild.le @@ -0,0 +1,9 @@ +the target language is: prolog. + +the templates are: + *a x* is the parent of *a y*, + *a y* is the child of *a x*. + +the knowledge base encoding includes: + a x is the parent of a y + if y is the child of x. \ No newline at end of file diff --git a/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-sum/notes/simple-sum.le b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-sum/notes/simple-sum.le new file mode 100644 index 000000000..59f1c976c --- /dev/null +++ b/lib/haskell/natural4/test/Testcases/LogicalEnglish/simple-sum/notes/simple-sum.le @@ -0,0 +1,31 @@ +the target language is: prolog. + +the templates are: + *a number* is the sum of *a list*, + the additional savings is *a number*, + the total savings is *a z*, + the initial savings is *a x*, + the additional savings is *a y*. + + +the knowledge base includes: + + % Arithmetic predicates required for sum example + a number is the sum of a list + if number is the sum of each X such that + X is in list. + + the total savings is a z + if the initial savings is a x + and the additional savings is a y + and z is the sum of [x, y]. + +scenario simple is: + the initial savings is 1000. + the additional savings is 337. + +%query q is: +% 0 < 1. + +query totalsavings is: + the total savings is which value. \ No newline at end of file