[Introduced accumulators
tobias@goedderz.info**20150312163840
 Ignore-this: 8fb4545670b3af3bdbd52c36f2382cdf
 
 When some variable-free term occurs in all IO examples of a given rule, it may
 be replaced by an accumulator variable. By setting the +accum parameter, this
 additional step is added to the derivation steps for new hypotheses.
] hunk ./src/Igor2/RuleDevelopment.hs 12
+import Igor2.RuleDevelopment.Accumulator (accumIntro)
hunk ./src/Igor2/RuleDevelopment.hs 27
-  (fs,ns,ms,ps,cs) <- compSucs h r
+  (fs,ns,ms,ps,cs,as) <- compSucs h r
hunk ./src/Igor2/RuleDevelopment.hs 34
-  let all = concat $ map rights  [fhs, nhs, mhs, phs, chs]
+  ahs <- developAll r h as
+  let all = concat $ map rights  [fhs, nhs, mhs, phs, chs, ahs]
hunk ./src/Igor2/RuleDevelopment.hs 50
-                  text "Hypotheses  :" <$> pretty chs
+                  text "Hypotheses  :" <$> pretty chs <$>
+                  text "OP5: ACCUM" <^> text "Advancements:" <$> pretty as <^>
+                  text "Hypotheses  :" <$> pretty ahs
hunk ./src/Igor2/RuleDevelopment.hs 60
-        if not $ null fs then return (fs,[],[],[],[])
-          else liftM4 ((,,,,)[])
+        if not $ null fs then return (fs,[],[],[],[],[])
+          else liftM5 ((,,,,,)[])
hunk ./src/Igor2/RuleDevelopment.hs 66
+                      (ifIsSet introduceAccums (accumIntro r) [])
+
addfile ./src/Igor2/RuleDevelopment/Accumulator.hs
hunk ./src/Igor2/RuleDevelopment/Accumulator.hs 1
+{-# LANGUAGE ScopedTypeVariables #-}
+module Igor2.RuleDevelopment.Accumulator where
+
+import Control.Monad.State (State, runState, state)
+import Control.Monad (liftM, forM)
+import Data.List (foldl1', isPrefixOf)
+import Data.Set (Set())
+import qualified Data.Set as Set
+
+import Syntax.Class.Term (root, subterms, subtermAt, toVar, isVar,
+    Position(Root), (°), applyAtPos, getVarNames)
+import Syntax.Expressions (TExp(TConE, TVarE), foldTAppE)
+import Syntax.Type (arrowT, isFunT, typeOf)
+import Syntax (mkName, Name)
+import Igor2.Data.CallDependencies (Call)
+import Igor2.Data.IOData (CovrRule, CovrRules, covrRules, crul, modifycrul, name)
+import Igor2.Data.IgorMonad (IM, breakupM, addIO, coverAll)
+import Igor2.Data.Rules (lhs, rhs, rule, rules, Rule(), Rules(), RulePos(Body), mkCallAt)
+import Igor2.Logging (logIN, logDE, waypointS)
+import Igor2.Ppr ((<+>), (<$>), pretty, text, cat, punctuate, squotes)
+
+import Debug.Trace (trace)
+
+mapFst :: (a -> a') -> (a, b) -> (a', b)
+mapFst f (x, y) = (f x, y)
+
+mapSnd :: (b -> b') -> (a, b) -> (a, b')
+mapSnd f (x, y) = (x, f y)
+
+mapFsts :: (a -> a') -> [(a, b)] -> [(a', b)]
+mapFsts = map . mapFst
+
+mapSnds :: (b -> b') -> [(a, b)] -> [(a, b')]
+mapSnds = map . mapSnd
+
+-- TODO: Rename variable-free terms to ground terms.
+accumIntro :: CovrRule -> IM [(CovrRules, [Call])]
+accumIntro rf = do
+    waypointS $ text "Introducing accumulator for" <+> (squotes $ pretty $ rf)
+    cruls :: [Rule] <- liftM (map crul) $ breakupM rf
+    let -- Contains a list of positions of variable free terms for each rule.
+        variableFreeTerms :: [[(Position, TExp)]]
+        variableFreeTerms = map (snd . getVariableFreeTerms . rhs) cruls
+
+        getVariableFreeTerms :: TExp -> (Bool, [(Position, TExp)])
+        getVariableFreeTerms t =
+            let hasVariables :: [Bool]
+                vfreeSubterms' :: [[(Position, TExp)]]
+                (hasVariables, vfreeSubterms') = unzip
+                    $ map getVariableFreeTerms (subterms t)
+                -- Complement the positions, concatenate the results.
+                vfreeSubterms :: [(Position, TExp)]
+                vfreeSubterms = concatMap (\(i, st) -> mapFsts (i°) st)
+                                $ zip [0..] vfreeSubterms'
+            in if not (isVar t) && and hasVariables
+               then (True, (Root, t) : vfreeSubterms)
+               else (False, vfreeSubterms)
+
+        -- These are just for readability.
+        vftPos :: (Position, TExp) -> Position
+        vftPos = fst
+
+        vftTerm :: (Position, TExp) -> TExp
+        vftTerm = snd
+
+    logIN (text "Found the following variable-free subterms:" <$> pretty variableFreeTerms)
+    -- A set of all variable-free subterms that occur in all IO examples.
+    let candidateTerms :: Set TExp
+        candidateTerms = foldl1' Set.intersection
+                            $ map (Set.fromList . map vftTerm)
+                            $ variableFreeTerms
+    -- Grep all entries denoting a given term t, and project only the positions
+    -- to the result.
+    let filterPosByTerm :: TExp -> [[(Position, TExp)]] -> [[Position]]
+        filterPosByTerm t = map (map vftPos . filter ((== t) . vftTerm))
+    -- A partition of the inner lists of variableFreeTerms by candidate terms.
+    let positionsByCandidate :: [(TExp, [[Position]])]
+        positionsByCandidate = map (\ct -> (ct, filterPosByTerm ct variableFreeTerms)) (Set.toList candidateTerms)
+        numPositions = map (map length . snd) positionsByCandidate :: [[Int]]
+    logIN (text "Choosing combinations from:" <$> pretty positionsByCandidate)
+    logIN (text "Expected total number of combinations:"
+            <$> cat (punctuate (text " + ")
+                        $ map (cat . punctuate (text "*") . map pretty)
+                              numPositions
+                    )
+            <+> text "=" <+> pretty (sum $ map product numPositions)
+        )
+    -- Replace each [[Position]] by the cartesian product of its inner lists.
+    -- Where before there was one [Position] for each IO example (in
+    -- positionsByCandidate), now each (in positionCombinationsByCandidate)
+    -- [Position] has one entry for each IO example.
+    let positionCombinationsByCandidate :: [(TExp, [[Position]])]
+        positionCombinationsByCandidate = mapSnds sequence positionsByCandidate
+    logIN (text "Number of combinations per candidate term:" <$> pretty (mapSnds length positionCombinationsByCandidate))
+
+    -- Search for a free name for the new accumulator variable
+    let accVarNamePrefix = "aCC"
+        occuringAccVarNames = filter (isPrefixOf accVarNamePrefix) $ map show $ concatMap getVarNames $ concatMap lhs cruls
+        accVarNames = [ accVarNamePrefix ++ show i | i <- [1..] ]
+        freeVarNames = [ name | name <- accVarNames, not (name `elem` occuringAccVarNames) ]
+        newAccVarName = mkName (head freeVarNames)
+
+    let addAccVar initExpr poss =
+           rules [ let accVar = toVar initExpr newAccVarName
+                   in rule (lhs r ++ [accVar])
+                           (applyAtPos (const accVar) p (rhs r))
+                 | (p, r) <- zip poss cruls ]
+
+    let crulss :: [(TExp, Rules)]
+        crulss = concatMap (\(initExpr, combs) ->
+                     map (\poss -> (initExpr, addAccVar initExpr poss)) combs
+                 ) positionCombinationsByCandidate
+
+    fnnames <- mapM (addIO . snd) crulss :: IM [Name]
+
+    rfaccs <- mapM coverAll fnnames :: IM [CovrRule]
+
+    let callfn :: Name -> TExp -> Rule -> Rule
+        callfn accfn initExpr r = mkCallAt (Body Root) accfn (lhs r ++ [initExpr]) r
+    let rfnews :: [CovrRule]
+        rfnews = [ modifycrul rf (callfn accfn initExpr) | ((initExpr, _), accfn) <- zip crulss fnnames ]
+    let result :: [(CovrRules, [Call])]
+        result = [ (covrRules [rfnew, rfacc], [(name rf, accfnname, GT)]) | (accfnname, rfacc, rfnew) <- zip3 fnnames rfaccs rfnews ]
+    logIN (text "Resulting accumulator functions and calls:" <$> pretty result)
+    return result