mirror of
https://codeberg.org/ProgramSnail/prog_synthesis.git
synced 2025-12-06 05:28:42 +00:00
replace direct get of state in most places, fixes
This commit is contained in:
ProgramSnail
parent
0270c44bf6
commit
b04a28fd51
1 changed files with 67 additions and 59 deletions
126
escher.hs
126
escher.hs
|
|
@ -2,7 +2,7 @@ import Control.Monad (guard, liftM, when, foldM, foldM_)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad.State as State
|
import Control.Monad.State as State
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import Data.Set (Set, insert, delete)
|
import Data.Set (Set)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Data.List (inits)
|
import Data.List (inits)
|
||||||
|
|
@ -238,11 +238,12 @@ data Resolver = Resolver { resolverGoal :: Goal,
|
||||||
resolverCond :: Goal,
|
resolverCond :: Goal,
|
||||||
resolverThen :: Goal,
|
resolverThen :: Goal,
|
||||||
resolverElse :: Goal } -- ids ??
|
resolverElse :: Goal } -- ids ??
|
||||||
|
deriving (Read, Show, Eq, Ord)
|
||||||
|
|
||||||
data Synt = Synt { syntExprs :: [(Expr, [Maybe Value])],
|
data Synt = Synt { syntExprs :: [(Expr, [Maybe Value])],
|
||||||
syntSolvedGoals :: Map Goal Expr,
|
syntSolvedGoals :: Map Goal Expr,
|
||||||
syntUnsolvedGoals :: Set Goal,
|
syntUnsolvedGoals :: Set Goal,
|
||||||
syntResolvers :: [Resolver],
|
syntResolvers :: Set Resolver,
|
||||||
syntExamples :: [[Value]],
|
syntExamples :: [[Value]],
|
||||||
syntOracle :: Oracle,
|
syntOracle :: Oracle,
|
||||||
syntRoot :: Goal}
|
syntRoot :: Goal}
|
||||||
|
|
@ -289,8 +290,8 @@ confBySynt input expr st = Conf {confInput = input,
|
||||||
confProg = expr,
|
confProg = expr,
|
||||||
confExamples = syntExamples st}
|
confExamples = syntExamples st}
|
||||||
|
|
||||||
matchGoal :: Goal -> Synt -> Expr -> Bool
|
matchGoal :: Goal -> Expr -> Synt -> Bool
|
||||||
matchGoal (Goal goal) st expr = let examples = syntExamples st in
|
matchGoal (Goal goal) expr st = let examples = syntExamples st in
|
||||||
foldl checkOnInput True $ zip examples goal
|
foldl checkOnInput True $ zip examples goal
|
||||||
where checkOnInput False _ = False
|
where checkOnInput False _ = False
|
||||||
checkOnInput acc (input, output) = let output' = eval (confBySynt input expr st) expr in
|
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
|
where step :: Bool -> Expr -> SyntState Bool
|
||||||
step True _ = return True
|
step True _ = return True
|
||||||
step False expr = do exprOutputs <- calcExprOutputs expr
|
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
|
-- generate next step of exprs, remove copies
|
||||||
forwardStep :: Expr -> [Expr] -> SyntState (Maybe Expr)
|
forwardStep :: Expr -> [Expr] -> SyntState (Maybe Expr)
|
||||||
forwardStep comp args = do st <- get
|
forwardStep comp args = do let expr = fillHoles comp args
|
||||||
let expr = fillHoles comp args
|
|
||||||
outputs <- calcExprOutputs expr
|
outputs <- calcExprOutputs expr
|
||||||
-- TODO: FIXME separate recoverable & non-recoverable errors -- any isError outputs ||
|
-- TODO: FIXME separate recoverable & non-recoverable errors -- any isError outputs ||
|
||||||
if any isFatalError outputs || evalState (matchAnyOutputs outputs) st then return Nothing else do
|
matchedExisting <- gets $ evalState (matchAnyOutputs outputs)
|
||||||
put st { syntExprs = (expr, []) : syntExprs st}
|
if any isFatalError outputs || matchedExisting then return Nothing else do
|
||||||
|
modify $ \st -> st { syntExprs = (expr, []) : syntExprs st}
|
||||||
return $ Just expr
|
return $ Just expr
|
||||||
|
|
||||||
splitGoal :: Goal -> [Bool] -> Resolver
|
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
|
-- 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 -> [Bool] -> SyntState Resolver
|
||||||
splitGoalStep goal selector = do st <- get
|
splitGoalStep goal selector = do let r = splitGoal goal selector
|
||||||
let r = splitGoal goal selector
|
modify $ \st -> st { syntUnsolvedGoals = Set.insert (resolverCond r) $
|
||||||
put st { syntUnsolvedGoals = Set.insert (resolverCond r) $
|
Set.insert (resolverThen r) $
|
||||||
Set.insert (resolverThen r) $
|
Set.insert (resolverElse r) $
|
||||||
Set.insert (resolverElse r) $
|
syntUnsolvedGoals st,
|
||||||
syntUnsolvedGoals st,
|
syntResolvers = r `Set.insert` syntResolvers st }
|
||||||
syntResolvers = r : syntResolvers st }
|
|
||||||
return r
|
return r
|
||||||
|
|
||||||
-- TODO: use expr evaluated outputs ?
|
-- TODO: use expr evaluated outputs ?
|
||||||
trySolveGoal :: Expr -> Goal -> SyntState Bool
|
trySolveGoal :: Expr -> Goal -> SyntState Bool
|
||||||
trySolveGoal expr goal = do st <- get
|
trySolveGoal expr goal = do doesMatch <- gets $ matchGoal goal expr
|
||||||
if matchGoal goal st expr then do
|
if doesMatch then do
|
||||||
put st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st,
|
modify $ \st -> st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st,
|
||||||
syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st }
|
syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st }
|
||||||
return True
|
return True
|
||||||
else return False
|
else return False
|
||||||
|
|
@ -356,37 +359,37 @@ goalSolution :: Goal -> SyntState (Maybe Expr)
|
||||||
goalSolution goal = gets (Map.lookup goal . syntSolvedGoals)
|
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
|
-- 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
|
-- NOTE: goals expected to be resolved
|
||||||
resolveStep :: (Expr, Expr, Expr) -> Resolver -> SyntState ()
|
resolveStep :: (Expr, Expr, Expr) -> Resolver -> SyntState Expr
|
||||||
resolveStep (ifCond, ifDoThen, ifDoElse) r = do st <- get
|
resolveStep (ifCond, ifDoThen, ifDoElse) r = do let expr = IfE { ifCond, ifDoThen, ifDoElse }
|
||||||
let expr = IfE { ifCond, ifDoThen, ifDoElse }
|
|
||||||
let goal = resolverGoal r
|
let goal = resolverGoal r
|
||||||
put st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st,
|
modify $ \st -> st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st,
|
||||||
syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st,
|
syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st,
|
||||||
syntExprs = (expr, []) : syntExprs st }
|
syntExprs = (expr, []) : syntExprs st }
|
||||||
|
return expr
|
||||||
|
|
||||||
tryResolve :: Resolver -> SyntState Bool
|
tryResolve :: Resolver -> SyntState (Maybe Expr)
|
||||||
tryResolve r = do condSol <- goalSolution $ resolverCond r
|
tryResolve r = do condSol <- goalSolution $ resolverCond r
|
||||||
thenSol <- goalSolution $ resolverThen r
|
thenSol <- goalSolution $ resolverThen r
|
||||||
elseSol <- goalSolution $ resolverElse r
|
elseSol <- goalSolution $ resolverElse r
|
||||||
case (condSol, thenSol, elseSol) of
|
case (condSol, thenSol, elseSol) of
|
||||||
(Just condExpr, Just thenExpr, Just elseExpr) -> do
|
(Just condExpr, Just thenExpr, Just elseExpr) -> do
|
||||||
resolveStep (condExpr, thenExpr, elseExpr) r
|
expr <- resolveStep (condExpr, thenExpr, elseExpr) r
|
||||||
return True
|
return $ Just expr
|
||||||
_ -> return False
|
_ -> return Nothing
|
||||||
|
|
||||||
remakeSynt :: [[Value]] -> [Value] -> SyntState ()
|
remakeSynt :: [[Value]] -> [Value] -> SyntState ()
|
||||||
remakeSynt newInputs newOutputs = do st <- get
|
remakeSynt newInputs newOutputs = do st <- get
|
||||||
let Goal oldOutputs = syntRoot st
|
let Goal oldOutputs = syntRoot st
|
||||||
let goals = zip (newInputs ++ syntExamples st)
|
goals <- gets $ \st -> zip (newInputs ++ syntExamples st)
|
||||||
(newOutputs ++ map (fromMaybe undefined) oldOutputs)
|
(newOutputs ++ map (fromMaybe undefined) oldOutputs)
|
||||||
initSynt (syntOracle st) goals
|
initSynt (syntOracle st) goals
|
||||||
modify (\st' -> st' { syntExprs = syntExprs st })
|
modify (\st' -> st' { syntExprs = syntExprs st })
|
||||||
|
|
||||||
-- clear goal tree up to root, add example, calculate exprs on input (could be recursive ?)
|
-- clear goal tree up to root, add example, calculate exprs on input (could be recursive ?)
|
||||||
saturateStep :: Expr -> SyntState Bool
|
saturateStep :: Expr -> SyntState Bool
|
||||||
saturateStep expr = do st <- get
|
saturateStep expr = do (newInputs, newOutputs) <- gets $ \st -> unzip $ foldl (searchEx st) [] (syntExamples st)
|
||||||
let (newInputs, newOutputs) = unzip $ foldl (searchEx st) [] (syntExamples st)
|
|
||||||
let isExFound = not $ null newInputs
|
let isExFound = not $ null newInputs
|
||||||
when isExFound $ remakeSynt newInputs newOutputs
|
when isExFound $ remakeSynt newInputs newOutputs
|
||||||
return isExFound
|
return isExFound
|
||||||
|
|
@ -397,9 +400,8 @@ saturateStep expr = do st <- get
|
||||||
|
|
||||||
-- try to find terminating expr
|
-- try to find terminating expr
|
||||||
terminateStep :: Expr -> SyntState (Maybe Expr)
|
terminateStep :: Expr -> SyntState (Maybe Expr)
|
||||||
terminateStep expr = do st <- get
|
terminateStep expr = do doesMatch <- gets $ \st -> matchGoal (syntRoot st) expr st
|
||||||
return $ if matchGoal (syntRoot st) st expr
|
return $ if doesMatch then Just expr else Nothing
|
||||||
then Just expr else Nothing
|
|
||||||
|
|
||||||
------ patterns
|
------ patterns
|
||||||
|
|
||||||
|
|
@ -413,7 +415,8 @@ patterns1 = [NotE Hole, Leq0 Hole,
|
||||||
TailE Hole, HeadE Hole,
|
TailE Hole, HeadE Hole,
|
||||||
-- IsLeafE Hole, TreeValE Hole,
|
-- IsLeafE Hole, TreeValE Hole,
|
||||||
-- TreeLeftE Hole, TreeRightE Hole,
|
-- TreeLeftE Hole, TreeRightE Hole,
|
||||||
-- CreateLeafE Hole, SelfE Hole,
|
-- CreateLeafE Hole,
|
||||||
|
SelfE Hole,
|
||||||
InputE Hole
|
InputE Hole
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
@ -427,9 +430,9 @@ patterns2 = [Hole :&&: Hole,
|
||||||
Hole ::: Hole]
|
Hole ::: Hole]
|
||||||
|
|
||||||
patterns3 :: [Expr]
|
patterns3 :: [Expr]
|
||||||
patterns3 = [] -- [
|
patterns3 = []
|
||||||
-- CreateNodeE {nodeLeft = Hole, nodeRoot = Hole, nodeRight = Hole},
|
-- [CreateNodeE {nodeLeft = Hole, nodeRoot = Hole, nodeRight = Hole},
|
||||||
-- IfE {ifCond = Hole, ifDoThen = Hole, ifDoElse = Hole}]
|
-- IfE {ifCond = Hole, ifDoThen = Hole, ifDoElse = Hole}]
|
||||||
|
|
||||||
------ generation
|
------ generation
|
||||||
|
|
||||||
|
|
@ -472,7 +475,7 @@ createSynt oracle goals = let root = Goal $ map (Just . snd) goals in
|
||||||
Synt { syntExprs = [],
|
Synt { syntExprs = [],
|
||||||
syntSolvedGoals = Map.empty,
|
syntSolvedGoals = Map.empty,
|
||||||
syntUnsolvedGoals = Set.singleton root,
|
syntUnsolvedGoals = Set.singleton root,
|
||||||
syntResolvers = [],
|
syntResolvers = Set.empty,
|
||||||
syntExamples = map fst goals,
|
syntExamples = map fst goals,
|
||||||
syntOracle = oracle,
|
syntOracle = oracle,
|
||||||
syntRoot = root}
|
syntRoot = root}
|
||||||
|
|
@ -482,23 +485,28 @@ initSynt oracle goals = put $ createSynt oracle goals
|
||||||
|
|
||||||
stepOnAddedExpr :: Expr -> SyntState (Maybe Expr)
|
stepOnAddedExpr :: Expr -> SyntState (Maybe Expr)
|
||||||
stepOnAddedExpr expr = do exFound <- saturateStep expr
|
stepOnAddedExpr expr = do exFound <- saturateStep expr
|
||||||
st <- get
|
|
||||||
if exFound then stepOnAddedExprs $ map fst $ syntExprs st else do -- redo prev exprs (including current)
|
if exFound
|
||||||
maybeResult <- terminateStep expr
|
then do -- redo prev exprs (including current)
|
||||||
if isJust maybeResult then return maybeResult else do
|
st <- get
|
||||||
exprOutputs <- calcExprOutputs expr
|
stepOnAddedExprs $ map fst $ syntExprs st
|
||||||
-- TODO
|
else do -- try resolve goals & resolvers, generate new resolvers
|
||||||
-- when (foldl (compareExprOutputs exprOutputs) True $ map fst $ syntExprs st) $ modify $ \st -> st { syntExprs = tail $ syntExprs st }
|
maybeResult <- terminateStep expr
|
||||||
gets (foldM_ (const $ trySolveGoal expr) False . syntUnsolvedGoals) -- solve existing goals
|
if isJust maybeResult then return maybeResult else do
|
||||||
gets (foldM_ (const tryResolve) False . syntResolvers)-- resolve existing goals
|
exprOutputs <- calcExprOutputs expr
|
||||||
st <- get
|
-- NOTE: now done in fowardStep
|
||||||
put $ foldl (splitGoalsFold expr exprOutputs) st $ Set.toList $ syntUnsolvedGoals st
|
-- when (foldl (compareExprOutputs exprOutputs) True $ map fst $ syntExprs st) $ modify $ \st -> st { syntExprs = tail $ syntExprs st }
|
||||||
return Nothing
|
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
|
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
|
let matchesBool = map (fromMaybe True) matches in
|
||||||
execState (do r <- splitGoalStep goal matchesBool
|
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
|
trySolveGoal expr (resolverThen r)) st
|
||||||
matchResult :: Result Value -> Maybe Value -> Maybe Bool -- Nothing for unimportant matches marked as Nothing
|
matchResult :: Result Value -> Maybe Value -> Maybe Bool -- Nothing for unimportant matches marked as Nothing
|
||||||
matchResult (NewExamples {}) _ = Just False
|
matchResult (NewExamples {}) _ = Just False
|
||||||
|
|
@ -519,8 +527,7 @@ stepOnAddedExprs = foldM step Nothing
|
||||||
-- TODO: throw away exprs with Errors (?)
|
-- TODO: throw away exprs with Errors (?)
|
||||||
-- returns result and valid expr
|
-- returns result and valid expr
|
||||||
stepOnNewExpr :: Expr -> [Expr] -> SyntState (Maybe Expr, Maybe Expr)
|
stepOnNewExpr :: Expr -> [Expr] -> SyntState (Maybe Expr, Maybe Expr)
|
||||||
stepOnNewExpr comp args = do st <- get
|
stepOnNewExpr comp args = do expr <- forwardStep comp args
|
||||||
expr <- forwardStep comp args
|
|
||||||
case expr of
|
case expr of
|
||||||
Just expr' -> do res <- stepOnAddedExpr expr'
|
Just expr' -> do res <- stepOnAddedExpr expr'
|
||||||
return (res, expr)
|
return (res, expr)
|
||||||
|
|
@ -560,7 +567,8 @@ mainExamples :: [[Value]]
|
||||||
mainExamples = [[ListV [IntV 1, IntV 2, IntV 3]]]
|
mainExamples = [[ListV [IntV 1, IntV 2, IntV 3]]]
|
||||||
|
|
||||||
allExamples :: [[Value]]
|
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
|
--- reverse
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue