st/prog_synthesis
1
0
Fork 0
mirror of https://codeberg.org/ProgramSnail/prog_synthesis.git synced 2025-12-06 05:28:42 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

fix wrong gets usage, caching will require more changes

Browse source
This commit is contained in:
ProgramSnail 2025-10-26 23:29:03 +03:00
parent b04a28fd51
commit e8524a170f
1 changed files with 27 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

43
escher.hs
View file

@ -8,6 +8,8 @@ import qualified Data.Set as Set
import Data.List (inits) import Data.List (inits)
import Data.Maybe (fromMaybe, isJust, maybeToList) import Data.Maybe (fromMaybe, isJust, maybeToList)
import Debug.Trace (trace)
data Value = BoolV Bool data Value = BoolV Bool
| IntV Int | IntV Int
| ListV [Value] | ListV [Value]
@ -347,9 +349,12 @@ splitGoalStep goal selector = do let r = splitGoal goal selector
trySolveGoal :: Expr -> Goal -> SyntState Bool trySolveGoal :: Expr -> Goal -> SyntState Bool
trySolveGoal expr goal = do doesMatch <- gets $ matchGoal goal expr trySolveGoal expr goal = do doesMatch <- gets $ matchGoal goal expr
if doesMatch then do if doesMatch then do
modify $ \st -> 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
-- trace ("goal solved: " ++ show goal) -- TODO: trace
-- return True
else return False else return False
isGoalSolved :: Goal -> SyntState Bool isGoalSolved :: Goal -> SyntState Bool
@ -362,14 +367,16 @@ goalSolution goal = gets (Map.lookup goal . syntSolvedGoals)
-- returns found expr -- returns found expr
-- NOTE: goals expected to be resolved -- NOTE: goals expected to be resolved
resolveStep :: (Expr, Expr, Expr) -> Resolver -> SyntState Expr resolveStep :: (Expr, Expr, Expr) -> Resolver -> SyntState Expr
-- resolveStep r _ | trace ("resolution: " ++ show r) False = undefined -- TODO: trace
resolveStep (ifCond, ifDoThen, ifDoElse) r = do let expr = IfE { ifCond, ifDoThen, ifDoElse } resolveStep (ifCond, ifDoThen, ifDoElse) r = do let expr = IfE { ifCond, ifDoThen, ifDoElse }
let goal = resolverGoal r let goal = resolverGoal r
modify $ \st -> 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 return expr
tryResolve :: Resolver -> SyntState (Maybe Expr) tryResolve :: Resolver -> SyntState (Maybe Expr)
-- tryResolve r | trace ("try resolution: " ++ show r) False = undefined -- TODO
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
@ -388,11 +395,12 @@ remakeSynt newInputs newOutputs = do st <- get
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 -- returns new example
saturateStep :: Expr -> SyntState [[Value]]
saturateStep expr = do (newInputs, newOutputs) <- gets $ \st -> unzip $ foldl (searchEx st) [] (syntExamples st) saturateStep expr = do (newInputs, newOutputs) <- gets $ \st -> unzip $ foldl (searchEx st) [] (syntExamples st)
let isExFound = not $ null newInputs let exFound = not . null $ newInputs
when isExFound $ remakeSynt newInputs newOutputs when exFound $ remakeSynt newInputs newOutputs
return isExFound return newInputs
where searchEx st [] input = case eval (confBySynt input expr st) expr of where searchEx st [] input = case eval (confBySynt input expr st) expr of
NewExamples exs -> exs NewExamples exs -> exs
_ -> [] _ -> []
@ -484,11 +492,10 @@ initSynt :: Oracle -> [([Value], Value)] -> SyntState ()
initSynt oracle goals = put $ createSynt oracle goals 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 newEx <- saturateStep expr
if not . null $ newEx then do -- redo prev exprs (including current)
if exFound
then do -- redo prev exprs (including current)
st <- get st <- get
-- trace ("exFound: " ++ show newEx) $ -- TODO: trace
stepOnAddedExprs $ map fst $ syntExprs st stepOnAddedExprs $ map fst $ syntExprs st
else do -- try resolve goals & resolvers, generate new resolvers else do -- try resolve goals & resolvers, generate new resolvers
maybeResult <- terminateStep expr maybeResult <- terminateStep expr
@ -496,16 +503,20 @@ stepOnAddedExpr expr = do exFound <- saturateStep expr
exprOutputs <- calcExprOutputs expr exprOutputs <- calcExprOutputs expr
-- NOTE: now done in fowardStep -- NOTE: now done in fowardStep
-- when (foldl (compareExprOutputs exprOutputs) True $ map fst $ syntExprs st) $ modify $ \st -> st { syntExprs = tail $ syntExprs st } -- 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 unsolvedGoals <- gets syntUnsolvedGoals
gets (foldM_ (const tryResolve) Nothing . syntResolvers) -- resolve existing goals foldM_ (const $ trySolveGoal expr) False unsolvedGoals -- solve existing goals
resolvers <- gets syntResolvers
foldM_ (const tryResolve) Nothing resolvers -- resolve existing goals
modify $ \st -> foldl (splitGoalsFold expr exprOutputs) st $ Set.toList $ syntUnsolvedGoals st modify $ \st -> foldl (splitGoalsFold expr exprOutputs) st $ Set.toList $ syntUnsolvedGoals st
return Nothing gets $ \st -> syntRoot st `Map.lookup` syntSolvedGoals st
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 not $ 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
gets (foldM_ (const $ flip trySolveGoal $ resolverCond r) False . map fst . syntExprs) exprs <- gets syntExprs
gets (foldM_ (const $ flip trySolveGoal $ resolverElse r) False . map fst . syntExprs) foldM_ (const $ flip trySolveGoal $ resolverCond r) False $ map fst exprs
exprs <- gets syntExprs
foldM_ (const $ flip trySolveGoal $ resolverElse r) False $ map fst exprs
-- TODO: replace with always solve goal -- 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