mirror of
https://codeberg.org/ProgramSnail/prog_synthesis.git
synced 2025-12-06 05:28:42 +00:00
297 lines
15 KiB
Haskell
297 lines
15 KiB
Haskell
import Expr
|
|
import Eval
|
|
import Syntesis
|
|
|
|
import Control.Monad (guard, liftM, when, unless, foldM, foldM_)
|
|
import Control.Applicative
|
|
import Control.Monad.State as State
|
|
import Data.Map (Map)
|
|
import Data.Set (Set)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Data.List (inits)
|
|
import Data.Maybe (fromMaybe, isJust, maybeToList)
|
|
|
|
import Debug.Trace (trace)
|
|
import TypeCheck
|
|
|
|
|
|
eval'' :: Conf -> Expr -> SyntState (Result Value)
|
|
eval'' conf expr = do cache <- gets syntCache
|
|
let (result, cache') = eval' cache conf expr
|
|
modify $ \st -> st {syntCache = cache'}
|
|
return result
|
|
|
|
|
|
------------
|
|
|
|
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
|
|
matchValue output' output -- TODO
|
|
matchValue (Result x) (Just y) = x == y
|
|
matchValue _ Nothing = True
|
|
matchValue _ _ = False
|
|
|
|
------ syntesis steps
|
|
|
|
calcExprOutputs :: Expr -> SyntState [Result Value]
|
|
calcExprOutputs expr = gets (\st -> map (\input -> eval (confBySynt input expr st) expr) $ syntExamples st)
|
|
|
|
matchAnyOutputs :: [Result Value] -> SyntState Bool
|
|
matchAnyOutputs outputs = do exprs <- gets syntExprs
|
|
foldM step False $ map fst exprs
|
|
where step :: Bool -> Expr -> SyntState Bool
|
|
step True _ = return True
|
|
step False expr = do exprOutputs <- calcExprOutputs expr
|
|
return $ outputs == exprOutputs -- and $ zipWith sameResults outputs exprOutputs
|
|
sameResults (Result left) (Result right) = left == right
|
|
sameResults (RecError {}) (RecError {}) = True
|
|
sameResults _ _ = False
|
|
|
|
-- generate next step of exprs, remove copies
|
|
forwardStep :: Expr -> [Expr] -> SyntState (Maybe Expr)
|
|
forwardStep comp args = do let expr = fillHoles comp args
|
|
outputs <- calcExprOutputs expr
|
|
matchedExisting <- gets $ evalState (matchAnyOutputs outputs)
|
|
-- TODO: all RecErrors example could be useful on future cases ?
|
|
if any isFatalError outputs || all isRecError outputs || matchedExisting then return Nothing else do
|
|
modify $ \st -> st { syntExprs = (expr, []) : syntExprs st}
|
|
return $ Just expr
|
|
|
|
splitGoal :: Goal -> [Bool] -> Resolver
|
|
splitGoal resolverGoal@(Goal outputs) selector | length outputs == length selector =
|
|
let resolverCond = Goal $ map (Just . BoolV) selector in
|
|
let resolverThen = Goal $ zipWith (\v b -> if b then v else Nothing) outputs selector in
|
|
let resolverElse = Goal $ zipWith (\v b -> if b then Nothing else v) outputs selector in
|
|
Resolver { resolverGoal, resolverCond, resolverThen, resolverElse }
|
|
|
|
-- 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 let r = splitGoal goal selector
|
|
resolvers <- gets syntResolvers
|
|
unless (r `elem` resolvers) $ -- do not add existing resolvers
|
|
modify $ \st -> st { syntUnsolvedGoals = Set.insert (resolverCond r) $
|
|
Set.insert (resolverThen r) $
|
|
Set.insert (resolverElse r) $
|
|
syntUnsolvedGoals st,
|
|
syntResolvers = r : syntResolvers st } -- Set.insert
|
|
return r
|
|
|
|
-- TODO: use expr evaluated outputs ?
|
|
trySolveGoal :: Expr -> Goal -> SyntState Bool
|
|
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
|
|
-- trace ("goal solved: " ++ show goal) -- Tmp: trace
|
|
else return False
|
|
|
|
isGoalSolved :: Goal -> SyntState Bool
|
|
isGoalSolved goal = gets (Map.member goal . syntSolvedGoals)
|
|
|
|
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 Expr
|
|
-- resolveStep r _ | trace ("resolution: " ++ show r) False = undefined -- TMP: trace
|
|
resolveStep (ifCond, ifDoThen, ifDoElse) r = do let expr = IfE { ifCond, ifDoThen, ifDoElse }
|
|
let goal = resolverGoal r
|
|
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 (Maybe Expr)
|
|
-- tryResolve r | trace ("try resolution: " ++ show r) False = undefined -- TMP: trace
|
|
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
|
|
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
|
|
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 ?)
|
|
-- returns new example
|
|
saturateStep :: Expr -> SyntState [[Value]]
|
|
saturateStep expr = do (newInputs, newOutputs) <- gets $ \st -> unzip $ foldl (searchEx st) [] (syntExamples st)
|
|
let exFound = not . null $ newInputs
|
|
when exFound $ remakeSynt newInputs newOutputs
|
|
return newInputs
|
|
where searchEx st [] input = case eval (confBySynt input expr st) expr of
|
|
NewExamples exs -> exs
|
|
_ -> []
|
|
searchEx _ exs _ = exs
|
|
|
|
-- try to find terminating expr
|
|
terminateStep :: Expr -> SyntState (Maybe Expr)
|
|
terminateStep expr = do doesMatch <- gets $ \st -> matchGoal (syntRoot st) expr st
|
|
return $ if doesMatch then Just expr else Nothing
|
|
|
|
stepOnAddedExpr :: Expr -> SyntState (Maybe Expr)
|
|
stepOnAddedExpr expr = do newEx <- saturateStep expr
|
|
if not . null $ newEx then do -- redo prev exprs (including current)
|
|
st <- get
|
|
-- trace ("exFound: " ++ show newEx) $ -- TMP: trace
|
|
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 }
|
|
unsolvedGoals <- gets syntUnsolvedGoals
|
|
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 [syntRoot st] -- TODO: use Set.toList $ syntUnsolvedGoals st ?
|
|
gets $ \st -> syntRoot st `Map.lookup` syntSolvedGoals st
|
|
where splitGoalsFold expr outputs st goal@(Goal expected) = let matches = zipWith matchResult outputs expected in
|
|
if not $ any (fromMaybe False) matches then st else
|
|
let matchesBool = map (fromMaybe True) matches in
|
|
execState (do r <- splitGoalStep goal matchesBool
|
|
exprs <- gets 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
|
|
trySolveGoal expr (resolverThen r)) st
|
|
matchResult :: Result Value -> Maybe Value -> Maybe Bool -- Nothing for unimportant matches marked as Nothing
|
|
matchResult (NewExamples {}) _ = Just False
|
|
matchResult _ Nothing = Nothing
|
|
matchResult (RecError {}) _ = Just False
|
|
matchResult (Result x) (Just y) = Just $ x == y
|
|
-- compareExprOutputs outputs False _ = False
|
|
-- compareExprOutputs outputs True e = do eOutputs <- calcExprOutputs e
|
|
-- outputs == eOutputs
|
|
|
|
stepOnAddedExprs :: [Expr] -> SyntState (Maybe Expr)
|
|
stepOnAddedExprs = foldM step Nothing
|
|
where step :: Maybe Expr -> Expr -> SyntState (Maybe Expr)
|
|
step res@(Just {}) _ = return res
|
|
step Nothing expr = stepOnAddedExpr expr
|
|
|
|
-- returns result and valid expr
|
|
stepOnNewExpr :: Expr -> [Expr] -> SyntState (Maybe Expr, Maybe Expr)
|
|
stepOnNewExpr comp args = do expr <- forwardStep comp args
|
|
case expr of
|
|
Just expr' -> do res <- stepOnAddedExpr expr'
|
|
return (res, expr)
|
|
Nothing -> return (Nothing, Nothing)
|
|
|
|
-- stages:
|
|
-- init state
|
|
-- 1. gen new step exprs
|
|
-- 2. process exprs by one
|
|
-- 3. try terminate / saturate
|
|
-- 4. try to solve existing goals
|
|
-- 5. make resolutions if goals solved
|
|
-- 6. split goals, where expr partially matched
|
|
syntesisStep :: Int -> [[Expr]] -> SyntState (Maybe Expr)
|
|
syntesisStep 0 _ = return Nothing
|
|
syntesisStep steps prevExprs = -- oracle should be defined on the provided emample inputs
|
|
do let genExprs = genStep prevExprs
|
|
(result, validExprs) <- foldM step (Nothing, []) genExprs
|
|
if isJust result
|
|
then return result
|
|
else trace ("steps left: " ++ show (steps - 1)) $ syntesisStep (steps - 1) (validExprs : prevExprs)
|
|
where step res@(Just {}, _) _ = return res
|
|
step (Nothing, exprs) expr = do (res, val) <- uncurry stepOnNewExpr expr
|
|
return (res, maybeToList val ++ exprs)
|
|
|
|
syntesis' :: [[Expr]] -> Int -> Oracle -> [[Value]] -> (Maybe Expr, Synt)
|
|
syntesis' exprs steps oracle inputs = -- oracle should be defined on the providid examples
|
|
let outputs = map (fromMaybe undefined . oracle) inputs in
|
|
runState (syntesisStep steps exprs) (createSynt oracle $ zip inputs outputs)
|
|
|
|
syntesis :: Int -> Oracle -> [[Value]] -> (Maybe Expr, Synt)
|
|
syntesis = syntesis' []
|
|
|
|
------ examples
|
|
|
|
mainExamples :: [[Value]]
|
|
mainExamples = [[ListV [IntV 1, IntV 2, IntV 3]]]
|
|
|
|
allExamples :: [[Value]]
|
|
-- 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
|
|
|
|
reverseOracle :: Oracle
|
|
-- reverseOracle [ListV xs] = Just $ ListV $ reverse xs
|
|
reverseOracle [ListV xs] | all isInt xs = Just $ ListV $ reverse xs
|
|
reverseOracle _ = Nothing
|
|
|
|
reverseExpr :: Expr
|
|
reverseExpr = IfE { ifCond = IsEmptyE (InputE 0),
|
|
ifDoThen = EmptyListE,
|
|
ifDoElse = SelfE [TailE (InputE 0)] :++: (HeadE (InputE 0) ::: EmptyListE) }
|
|
|
|
reverseConf :: Conf
|
|
reverseConf = Conf { confInput = head allExamples,
|
|
confOracle = reverseOracle,
|
|
confExamples = allExamples }
|
|
|
|
--- stutter
|
|
|
|
stutterOracle :: Oracle
|
|
stutterOracle [ListV (x : xs)] | isInt x = do ListV xs' <- stutterOracle [ListV xs]
|
|
return $ ListV $ x : x : xs'
|
|
stutterOracle [ListV []] = Just $ ListV []
|
|
stutterOracle _ = Nothing
|
|
|
|
stutterExpr :: Expr
|
|
stutterExpr = IfE { ifCond = IsEmptyE (InputE 0),
|
|
ifDoThen = EmptyListE,
|
|
ifDoElse = HeadE (InputE 0) ::: (HeadE (InputE 0) ::: SelfE [TailE (InputE 0)]) }
|
|
|
|
stutterConf :: Conf
|
|
stutterConf = Conf { confInput = head allExamples,
|
|
confOracle = stutterOracle,
|
|
confExamples = allExamples }
|
|
|
|
--- length
|
|
|
|
lengthOracle :: Oracle
|
|
lengthOracle [ListV xs] = Just $ IntV $ length xs
|
|
lengthOracle _ = Nothing
|
|
|
|
lengthExpr :: Expr
|
|
lengthExpr = IfE { ifCond = IsEmptyE (InputE 0),
|
|
ifDoThen = ZeroE,
|
|
ifDoElse = IncE $ SelfE [TailE (InputE 0)] }
|
|
|
|
lengthConf :: Conf
|
|
lengthConf = Conf { confInput = head allExamples,
|
|
confOracle = lengthOracle,
|
|
confExamples = allExamples }
|
|
|
|
---
|
|
|
|
idOracle :: Oracle
|
|
idOracle [x] = Just x
|
|
idOracle _ = Nothing
|
|
|
|
main = do steps <- readLn :: IO Int
|
|
print $ fst $ syntesis steps reverseOracle allExamples
|
|
|
|
-- main = print $ (SelfE (TailE (InputE ZeroE) ::: EmptyListE) :++: (HeadE (InputE ZeroE) ::: EmptyListE)) `elem` (map fst $ syntExprs $ snd $ syntesis 10 reverseOracle allExamples)
|
|
-- Just (IfE {ifCond = IsEmptyE (InputE ZeroE), ifDoThen = InputE ZeroE :++: TailE (InputE ZeroE :++: (InputE ZeroE :++: (ZeroE ::: EmptyListE))), ifDoElse = SelfE (TailE (InputE ZeroE) ::: EmptyListE) :++: (HeadE (InputE ZeroE) ::: EmptyListE)})
|