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
96
escher.hs
96
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}
|
||||
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) $
|
||||
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 : syntResolvers 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,
|
||||
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)
|
||||
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,8 +430,8 @@ patterns2 = [Hole :&&: Hole,
|
|||
Hole ::: Hole]
|
||||
|
||||
patterns3 :: [Expr]
|
||||
patterns3 = [] -- [
|
||||
-- CreateNodeE {nodeLeft = Hole, nodeRoot = Hole, nodeRight = 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
|
||||
|
||||
if exFound
|
||||
then do -- redo prev exprs (including current)
|
||||
st <- get
|
||||
if exFound then stepOnAddedExprs $ map fst $ syntExprs st else do -- redo prev exprs (including current)
|
||||
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
|
||||
-- TODO
|
||||
-- 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) False . syntResolvers)-- resolve existing goals
|
||||
st <- get
|
||||
put $ foldl (splitGoalsFold expr exprOutputs) st $ Set.toList $ syntUnsolvedGoals st
|
||||
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
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue