Merge pull request #454 from smucclaw/oct6-le-fixes

Oct6 le fixes / changes to spec: apos vars; decimals; IS

lib/haskell/natural4/src/LS/Utils.hs

@@ -9,7 +9,9 @@ module LS.Utils
     runMonoidValidate,
     swallowErrs,
     MonoidValidate,
-    (<||>)
+    compose,
+    (<||>),
+    (<&&>)
   )
 where
 
@@ -21,8 +23,8 @@ import Control.Monad.Validate
   )
 import Data.Coerce (coerce)
 import Data.Either (rights, partitionEithers)
-import Data.Monoid (Ap (Ap))
-import Flow ((|>))
+import Data.Monoid (Ap (Ap), Endo (Endo))
+import Flow ((|>), (.>))
 
 infixl 0 |$>
 
@@ -76,7 +78,15 @@ swallowErrs = mapThenSwallowErrs id
 runMonoidValidate :: MonoidValidate e a -> Either e a
 runMonoidValidate x = x |> coerce |> runValidate 
 
+-- | Function composition via the endomorphism monoid.
+compose :: forall a. [a -> a] -> a -> a
+compose = (coerce :: [a -> a] -> [Endo a]) .> mconcat .> coerce
+
 -- | A simple lifted ('||'), copied from Control.Bool
 (<||>) :: Applicative f => f Bool -> f Bool -> f Bool
 (<||>) = liftA2 (||)
-{-# INLINE (<||>) #-}
+{-# INLINE (<||>) #-}
+
+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
+(<&&>) = liftA2 (&&)
+{-# INLINE (<&&>) #-}

lib/haskell/natural4/src/LS/XPile/CoreL4.hs

@@ -211,6 +211,7 @@ import Prettyprinter.Interpolate (__di, di)
 import Text.Regex.TDFA (AllTextMatches (getAllTextMatches), (=~))
 import Text.XML.HXT.Core qualified as HXT
 import ToDMN.FromL4 (genXMLTreeNoType)
+import LS.Utils (compose)
 
 -- type ExprM a = Either String (Expr a)
 type ExprM ann a = MonoidValidate (Doc ann) (Expr a)
@@ -716,7 +717,7 @@ prettyDefnCs rname cs = do
       replacements =
         [ T.replace (T.pack t) $ T.pack $ show n
         | (t, n) <- zip (nub myterms) x123 ]
-      outstr = chain replacements $ mt2text rhs
+      outstr = compose replacements $ mt2text rhs
       returntype = "Integer"
 
   pure $ if null myterms
@@ -743,9 +744,6 @@ prettyDefnCs rname cs = do
       <> Prettyprinter.line <> commentShow "#" cl
     -- defn aPlusB : Integer -> Integer -> Integer = \x : Integer -> \y : Integer -> x + y
   where
-    -- Function composition via the endomorphism monoid
-    chain :: [a -> a] -> a -> a
-    chain = (coerce :: [a -> a] -> [Endo a]) .> mconcat .> coerce
 
     x123 = [[di|x#{n}|] | (n :: Int) <- [1..]]
 

lib/haskell/natural4/src/LS/XPile/LogicalEnglish/GenLEHCs.hs

@@ -13,12 +13,36 @@ module LS.XPile.LogicalEnglish.GenLEHCs (leHCFromVarsHC) where
 import Data.Text qualified as T
 import Data.HashSet qualified as HS
 -- import Data.Foldable (toList)
--- import Debug.Trace (trace)
 import Data.Coerce (coerce)
 -- import Data.String.Interpolate ( i )
 import Data.Traversable
 
 import LS.XPile.LogicalEnglish.Types
+  ( -- L4-related types
+      AtomicBPropn(..)
+
+    -- Intermediate representation types, prisms, and consts
+    , TemplateVar(..)
+    , aposSuffix
+    , VarsHC(VhcF, VhcR)
+    , VarsFact(..)
+    , BaseRule(..)
+    , VarsRule
+    , AtomicPWithVars
+    , VCell(..)
+
+    -- LE-related types
+    , LEhcCell(..)
+    , LEVar(..)
+    , NormdVars
+    , NormalizedVar(..)
+    , LEhcAtomicP
+    , LETemplateTxt(..)
+    , UnivStatus(..)
+    , RuleWithUnivsMarked
+    , LERuleForPrint
+    , LEhcPrint(..) 
+  )
 
 
 leHCFromVarsHC :: VarsHC -> LEhcPrint
@@ -94,31 +118,38 @@ markUnivVarsInRule larule =
   let lerule :: BaseRule LEhcAtomicP = simplifyVAtomicP <$> larule
   in snd (mapAccumL markUnivVarsInAtomicPacc HS.empty lerule)
 
-
--- TODO: Look into how to do this without this much plumbing
+{- TODO: I've thought of a way to do this with less plumbing using optics, 
+just not sure if streamlining the plumbing is worth the potential increased complexity for others -}
 markUnivVarsInAtomicPacc :: NormdVars -> LEhcAtomicP -> (NormdVars, AtomicBPropn UnivStatus)
 markUnivVarsInAtomicPacc nvars = \case
   ABPatomic lecells ->
     let (nvars', univStatuses) = markUnivVarsInLeCells nvars lecells
     in (nvars', ABPatomic univStatuses)
+
+  ABPBaseIs lefts rights -> 
+    let (nvars', leftsWithUnivStats) = markUnivVarsInLeCells nvars lefts
+        (nvars'', rightsWithUnivStats) = markUnivVarsInLeCells nvars' rights
+    in (nvars'', ABPBaseIs leftsWithUnivStats rightsWithUnivStats)
+
   ABPIsIn t1 t2     -> isSmtg ABPIsIn t1 t2
   ABPIsDiffFr t1 t2 -> isSmtg ABPIsDiffFr t1 t2
+
   ABPIsOpOf term opof termlst ->
     let (nvars', term') = identifyUnivVar nvars term
         (nvars'', univStatuses) = markUnivVarsInLeCells nvars' termlst
     in (nvars'', ABPIsOpOf term' opof univStatuses)
+
   ABPIsOpSuchTt term ostt lecells ->
     let (nvars', term') = identifyUnivVar nvars term
         (nvars'', univStatuses) = markUnivVarsInLeCells nvars' lecells
     in (nvars'', ABPIsOpSuchTt term' ostt univStatuses)
+
   where
     isSmtg op t1 t2 = 
       let (nvars', t1') = identifyUnivVar nvars t1
           (nvars'', t2') = identifyUnivVar nvars' t2
       in (nvars'', op t1' t2')
 
-
-
 --- start by doing it the EASIEST possible way 
 markUnivVarsInLeCells :: NormdVars -> [LEhcCell] -> (NormdVars, [UnivStatus])
 markUnivVarsInLeCells init lecells =
@@ -152,8 +183,9 @@ simplifyVAtomicP = fmap simplifyVCells
 
 simplifyVCells :: VCell -> LEhcCell
 simplifyVCells = \case
-  Pred txt   -> NotVar txt
-  TempVar tv -> tvar2lecell tv
+  NonVarOrNonAposAtom txt -> NotVar txt
+  AposAtom prefix         -> NotVar $ prefix <> aposSuffix
+  TempVar tv              -> tvar2lecell tv
 
 tvar2lecell :: TemplateVar -> LEhcCell
 tvar2lecell = \case

lib/haskell/natural4/src/LS/XPile/LogicalEnglish/GenNLAs.hs

@@ -39,21 +39,24 @@ import Data.Maybe (catMaybes)
 -- import Debug.Trace (trace)
 import Data.Coerce (coerce)
 
+import LS.Utils ((<&&>))
 import LS.XPile.LogicalEnglish.Types
   ( -- Common types 
       BoolPropn(..)
     -- L4-related types
     , AtomicBPropn(..)
     -- Intermediate representation types
     , TemplateVar(..)
-    
+
     , VarsHC(VhcF, VhcR)
     , VarsFact(..)
     , BaseRule(..)
     , VarsRule
     , AtomicPWithVars
     , VCell(..)
-    , _TempVar
+    , _TempVar, _AposAtom
+    , _EndsInApos
+    , aposSuffix
   )
 import LS.XPile.LogicalEnglish.Utils (setInsert)
 import Data.String (IsString)
@@ -72,7 +75,6 @@ import Optics
 import Data.HashSet.Optics (setOf)
 import Data.Sequence.Optics (seqOf)
 import Data.Containers.NonEmpty (NE, HasNonEmpty, nonEmpty, fromNonEmpty)
--- onNonEmpty, fromNonEmpty, 
 import Data.Sequence (Seq)
 import Data.Sequences (SemiSequence, intersperse) --groupAllOn
 import Data.List qualified as L
@@ -149,12 +151,12 @@ regexifyVCells :: NE (Seq VCell) -> Either String Regex
 regexifyVCells = makeRegex . textify strdelimitr regexf . fromNonEmpty
   where
     strdelimitr :: String = " "
+    escapeTxt = PCRE.escape . T.unpack
     regexf = \case
         TempVar tvar   -> tvar2WordsOrVIregex tvar
-        Pred nonvartxt -> (PCRE.escape . T.unpack $ nonvartxt)
-          --TODO: Add tests to check if have to escape metachars in Pred
-            -- T.unpack nonvartxt
-            -- PCRE.escape . T.unpack $ nonvartxt
+        AposAtom prefix -> escapeTxt $ prefix <> aposSuffix
+        NonVarOrNonAposAtom txt -> escapeTxt txt
+
 
 textify :: (Foldable t, Monoid c, SemiSequence (t c), Functor t) => Element (t c) -> (a -> c) -> t a -> c
 textify spaceDelimtr mappingfn = fold . intersperse spaceDelimtr . fmap mappingfn
@@ -333,7 +335,7 @@ rawregexifyNLAStr (T.unpack -> nlastr) =
                    >>> splitOn "*" "a class's *a list*"
                    ["a class's ","a list",""]
                -}
-    coreRegex = 
+    coreRegex =
       splitted
         & itraversed %& indices isVarIdx         .~ wordsOrVI
         & itraversed %& indices (not . isVarIdx) %~ PCRE.escape
@@ -367,20 +369,32 @@ nlasFromBody varsABP =
   let lstNLAs = fmap nlaLoneFromVAtomicP varsABP
   in HS.fromList . catMaybes . toList $ lstNLAs
 
+-- | Keeps only those VCells that we do want to generate an NLA from
+keepVCells :: (Foldable f) => f VCell -> Maybe (f VCell)
+keepVCells vcells = if allOf folded notEndInApos vcells then Just vcells else Nothing
+  where
+    notEndInApos = isn't (_TempVar % _EndsInApos) <&&> 
+                   isn't _AposAtom
+
 nlaLoneFromVAtomicP :: AtomicPWithVars -> Maybe NLA
 nlaLoneFromVAtomicP =  \case
-  ABPatomic vcells         -> mkNLA vcells
-  ABPIsOpSuchTt _ _ vcells -> mkNLA vcells
+  ABPatomic φvcs         -> selectivelyMkNLA φvcs
+  ABPIsOpSuchTt _ _ φvcs -> selectivelyMkNLA φvcs
 
   -- the other cases are accounted for by lib NLAs/templates, or are just built into LE
-  ABPIsIn{}     -> Nothing -- TODO: Check if `is in` is really built into LE! Seems tt way but haven't run LE query yet
+  ABPBaseIs{}   -> Nothing
+  ABPIsIn{}     -> Nothing
   ABPIsDiffFr{} -> Nothing
   ABPIsOpOf{}   -> Nothing
+
+  where 
+    selectivelyMkNLA φvcells = keepVCells φvcells >>= mkNLA
 
 vcell2NLAtxt :: VCell -> NLATxt
 vcell2NLAtxt = \case
-  TempVar tvar    -> tvar2NLAtxt tvar
-  Pred nonvartxt  -> coerce nonvartxt
+  TempVar tvar           -> tvar2NLAtxt tvar
+  AposAtom prefix        -> coerce $ prefix <> aposSuffix
+  NonVarOrNonAposAtom txt  -> coerce txt
 
 tvar2NLAtxt :: TemplateVar -> NLATxt
 tvar2NLAtxt = \case