diff --git a/escher.hs b/escher.hs index 275934e..617fb7e 100644 --- a/escher.hs +++ b/escher.hs @@ -2,7 +2,7 @@ import Control.Monad (guard, liftM, when, foldM, foldM_) import Control.Applicative import Control.Monad.State as State import Data.Map (Map) -import Data.Set (Set, insert, delete) +import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set import Data.List (inits) @@ -238,11 +238,12 @@ data Resolver = Resolver { resolverGoal :: Goal, resolverCond :: Goal, resolverThen :: Goal, resolverElse :: Goal } -- ids ?? + deriving (Read, Show, Eq, Ord) data Synt = Synt { syntExprs :: [(Expr, [Maybe Value])], syntSolvedGoals :: Map Goal Expr, syntUnsolvedGoals :: Set Goal, - syntResolvers :: [Resolver], + syntResolvers :: Set Resolver, syntExamples :: [[Value]], syntOracle :: Oracle, syntRoot :: Goal} @@ -289,8 +290,8 @@ confBySynt input expr st = Conf {confInput = input, confProg = expr, confExamples = syntExamples st} -matchGoal :: Goal -> Synt -> Expr -> Bool -matchGoal (Goal goal) st expr = let examples = syntExamples st in +matchGoal :: Goal -> Expr -> Synt -> Bool +matchGoal (Goal goal) expr st = let examples = syntExamples st in foldl checkOnInput True $ zip examples goal where checkOnInput False _ = False checkOnInput acc (input, output) = let output' = eval (confBySynt input expr st) expr in @@ -310,16 +311,19 @@ matchAnyOutputs outputs = do exprs <- gets syntExprs where step :: Bool -> Expr -> SyntState Bool step True _ = return True step False expr = do exprOutputs <- calcExprOutputs expr - return $ outputs == exprOutputs + return $ outputs == exprOutputs -- and $ zipWith sameResults outputs exprOutputs + -- sameResults (Result left) (Result right) = left == right + -- sameResults (RecError {}) _ = False + -- sameResults _ (RecError {}) = False -- generate next step of exprs, remove copies forwardStep :: Expr -> [Expr] -> SyntState (Maybe Expr) -forwardStep comp args = do st <- get - let expr = fillHoles comp args +forwardStep comp args = do let expr = fillHoles comp args outputs <- calcExprOutputs expr - -- TODO: FIXME separate recoverable & non-recoverable errors -- any isError outputs || - if any isFatalError outputs || evalState (matchAnyOutputs outputs) st then return Nothing else do - put st { syntExprs = (expr, []) : syntExprs st} + -- TODO: FIXME separate recoverable & non-recoverable errors -- any isError outputs || + matchedExisting <- gets $ evalState (matchAnyOutputs outputs) + if any isFatalError outputs || matchedExisting then return Nothing else do + modify $ \st -> st { syntExprs = (expr, []) : syntExprs st} return $ Just expr splitGoal :: Goal -> [Bool] -> Resolver @@ -331,20 +335,19 @@ splitGoal resolverGoal@(Goal outputs) selector | length outputs == length select -- split goal by its index and by expr (if any answers matched), check if there is same goals to generated splitGoalStep :: Goal -> [Bool] -> SyntState Resolver -splitGoalStep goal selector = do st <- get - let r = splitGoal goal selector - put st { syntUnsolvedGoals = Set.insert (resolverCond r) $ - Set.insert (resolverThen r) $ - Set.insert (resolverElse r) $ - syntUnsolvedGoals st, - syntResolvers = r : syntResolvers st } +splitGoalStep goal selector = do let r = splitGoal goal selector + modify $ \st -> st { syntUnsolvedGoals = Set.insert (resolverCond r) $ + Set.insert (resolverThen r) $ + Set.insert (resolverElse r) $ + syntUnsolvedGoals st, + syntResolvers = r `Set.insert` syntResolvers st } return r -- TODO: use expr evaluated outputs ? trySolveGoal :: Expr -> Goal -> SyntState Bool -trySolveGoal expr goal = do st <- get - if matchGoal goal st expr then do - put st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st, +trySolveGoal expr goal = do doesMatch <- gets $ matchGoal goal expr + if doesMatch then do + modify $ \st -> st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st, syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st } return True else return False @@ -356,37 +359,37 @@ goalSolution :: Goal -> SyntState (Maybe Expr) goalSolution goal = gets (Map.lookup goal . syntSolvedGoals) -- find all goals solved by new expr, by expr id it's values on examples, remove solved goals +-- returns found expr -- NOTE: goals expected to be resolved -resolveStep :: (Expr, Expr, Expr) -> Resolver -> SyntState () -resolveStep (ifCond, ifDoThen, ifDoElse) r = do st <- get - let expr = IfE { ifCond, ifDoThen, ifDoElse } +resolveStep :: (Expr, Expr, Expr) -> Resolver -> SyntState Expr +resolveStep (ifCond, ifDoThen, ifDoElse) r = do let expr = IfE { ifCond, ifDoThen, ifDoElse } let goal = resolverGoal r - put st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st, - syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st, - syntExprs = (expr, []) : syntExprs st } + modify $ \st -> st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st, + syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st, + syntExprs = (expr, []) : syntExprs st } + return expr -tryResolve :: Resolver -> SyntState Bool +tryResolve :: Resolver -> SyntState (Maybe Expr) tryResolve r = do condSol <- goalSolution $ resolverCond r thenSol <- goalSolution $ resolverThen r elseSol <- goalSolution $ resolverElse r case (condSol, thenSol, elseSol) of (Just condExpr, Just thenExpr, Just elseExpr) -> do - resolveStep (condExpr, thenExpr, elseExpr) r - return True - _ -> return False + expr <- resolveStep (condExpr, thenExpr, elseExpr) r + return $ Just expr + _ -> return Nothing remakeSynt :: [[Value]] -> [Value] -> SyntState () remakeSynt newInputs newOutputs = do st <- get let Goal oldOutputs = syntRoot st - let goals = zip (newInputs ++ syntExamples st) - (newOutputs ++ map (fromMaybe undefined) oldOutputs) + goals <- gets $ \st -> zip (newInputs ++ syntExamples st) + (newOutputs ++ map (fromMaybe undefined) oldOutputs) initSynt (syntOracle st) goals modify (\st' -> st' { syntExprs = syntExprs st }) -- clear goal tree up to root, add example, calculate exprs on input (could be recursive ?) saturateStep :: Expr -> SyntState Bool -saturateStep expr = do st <- get - let (newInputs, newOutputs) = unzip $ foldl (searchEx st) [] (syntExamples st) +saturateStep expr = do (newInputs, newOutputs) <- gets $ \st -> unzip $ foldl (searchEx st) [] (syntExamples st) let isExFound = not $ null newInputs when isExFound $ remakeSynt newInputs newOutputs return isExFound @@ -397,9 +400,8 @@ saturateStep expr = do st <- get -- try to find terminating expr terminateStep :: Expr -> SyntState (Maybe Expr) -terminateStep expr = do st <- get - return $ if matchGoal (syntRoot st) st expr - then Just expr else Nothing +terminateStep expr = do doesMatch <- gets $ \st -> matchGoal (syntRoot st) expr st + return $ if doesMatch then Just expr else Nothing ------ patterns @@ -413,7 +415,8 @@ patterns1 = [NotE Hole, Leq0 Hole, TailE Hole, HeadE Hole, -- IsLeafE Hole, TreeValE Hole, -- TreeLeftE Hole, TreeRightE Hole, --- CreateLeafE Hole, SelfE Hole, +-- CreateLeafE Hole, + SelfE Hole, InputE Hole ] @@ -427,9 +430,9 @@ patterns2 = [Hole :&&: Hole, Hole ::: Hole] patterns3 :: [Expr] -patterns3 = [] -- [ --- CreateNodeE {nodeLeft = Hole, nodeRoot = Hole, nodeRight = Hole}, - -- IfE {ifCond = Hole, ifDoThen = Hole, ifDoElse = Hole}] +patterns3 = [] +-- [CreateNodeE {nodeLeft = Hole, nodeRoot = Hole, nodeRight = Hole}, +-- IfE {ifCond = Hole, ifDoThen = Hole, ifDoElse = Hole}] ------ generation @@ -472,7 +475,7 @@ createSynt oracle goals = let root = Goal $ map (Just . snd) goals in Synt { syntExprs = [], syntSolvedGoals = Map.empty, syntUnsolvedGoals = Set.singleton root, - syntResolvers = [], + syntResolvers = Set.empty, syntExamples = map fst goals, syntOracle = oracle, syntRoot = root} @@ -482,23 +485,28 @@ initSynt oracle goals = put $ createSynt oracle goals stepOnAddedExpr :: Expr -> SyntState (Maybe Expr) stepOnAddedExpr expr = do exFound <- saturateStep expr - st <- get - if exFound then stepOnAddedExprs $ map fst $ syntExprs st else do -- redo prev exprs (including current) - maybeResult <- terminateStep expr - if isJust maybeResult then return maybeResult else do - exprOutputs <- calcExprOutputs expr - -- TODO - -- when (foldl (compareExprOutputs exprOutputs) True $ map fst $ syntExprs st) $ modify $ \st -> st { syntExprs = tail $ syntExprs st } - gets (foldM_ (const $ trySolveGoal expr) False . syntUnsolvedGoals) -- solve existing goals - gets (foldM_ (const tryResolve) False . syntResolvers)-- resolve existing goals - st <- get - put $ foldl (splitGoalsFold expr exprOutputs) st $ Set.toList $ syntUnsolvedGoals st - return Nothing + + if exFound + then do -- redo prev exprs (including current) + st <- get + stepOnAddedExprs $ map fst $ syntExprs st + else do -- try resolve goals & resolvers, generate new resolvers + maybeResult <- terminateStep expr + if isJust maybeResult then return maybeResult else do + exprOutputs <- calcExprOutputs expr + -- NOTE: now done in fowardStep + -- when (foldl (compareExprOutputs exprOutputs) True $ map fst $ syntExprs st) $ modify $ \st -> st { syntExprs = tail $ syntExprs st } + gets (foldM_ (const $ trySolveGoal expr) False . syntUnsolvedGoals) -- solve existing goals + gets (foldM_ (const tryResolve) Nothing . syntResolvers) -- resolve existing goals + modify $ \st -> foldl (splitGoalsFold expr exprOutputs) st $ Set.toList $ syntUnsolvedGoals st + return Nothing where splitGoalsFold expr outputs st goal@(Goal expected) = let matches = zipWith matchResult outputs expected in - if any (fromMaybe False) matches then st else + if not $ any (fromMaybe False) matches then st else let matchesBool = map (fromMaybe True) matches in execState (do r <- splitGoalStep goal matchesBool - -- TODO: always solve goal + gets (foldM_ (const $ flip trySolveGoal $ resolverCond r) False . map fst . syntExprs) + gets (foldM_ (const $ flip trySolveGoal $ resolverElse r) False . map fst . syntExprs) + -- TODO: replace with always solve goal trySolveGoal expr (resolverThen r)) st matchResult :: Result Value -> Maybe Value -> Maybe Bool -- Nothing for unimportant matches marked as Nothing matchResult (NewExamples {}) _ = Just False @@ -519,8 +527,7 @@ stepOnAddedExprs = foldM step Nothing -- TODO: throw away exprs with Errors (?) -- returns result and valid expr stepOnNewExpr :: Expr -> [Expr] -> SyntState (Maybe Expr, Maybe Expr) -stepOnNewExpr comp args = do st <- get - expr <- forwardStep comp args +stepOnNewExpr comp args = do expr <- forwardStep comp args case expr of Just expr' -> do res <- stepOnAddedExpr expr' return (res, expr) @@ -560,7 +567,8 @@ mainExamples :: [[Value]] mainExamples = [[ListV [IntV 1, IntV 2, IntV 3]]] allExamples :: [[Value]] -allExamples = [[ListV [IntV 1, IntV 2, IntV 3]], [ListV [IntV 2, IntV 3]], [ListV [IntV 3]], [ListV []]] +allExamples = [[ListV [IntV 2, IntV 3]], [ListV [IntV 3]], [ListV []]] +-- allExamples = [[ListV [IntV 1, IntV 2, IntV 3]], [ListV [IntV 2, IntV 3]], [ListV [IntV 3]], [ListV []]] --- reverse