structural rec comparasion, syntesis step parts, no deduplication & tests

This commit is contained in:
ProgramSnail 2025-10-21 16:45:45 +03:00
parent 372d38d813
commit d06c1a93f9

View file

@ -1,4 +1,4 @@
import Control.Monad (guard, liftM, when, foldM) 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)
@ -105,6 +105,14 @@ isInt = (== IntT) . typeOf
isList = (== ListT) . typeOf isList = (== ListT) . typeOf
isTree = (== TreeT) . typeOf isTree = (== TreeT) . typeOf
-- TODO: check
structuralLess :: Value -> Value -> Bool
structuralLess (BoolV left) (BoolV right) = left < right
structuralLess (IntV left) (IntV right) = left < right && left > 0 -- ??
structuralLess (ListV left) (ListV right) = left < right
structuralLess (TreeV left) (TreeV right) = left < right
structuralLess _ _ = False
eval :: Conf -> Expr -> Result Value eval :: Conf -> Expr -> Result Value
eval conf (left :&&: right) = do BoolV leftB <- eval conf left eval conf (left :&&: right) = do BoolV leftB <- eval conf left
BoolV rightB <- eval conf right BoolV rightB <- eval conf right
@ -159,7 +167,7 @@ eval conf (CreateLeafE e) = do v <- eval conf e
eval conf (IfE {ifCond, ifDoThen, ifDoElse}) = do BoolV condB <- eval conf ifCond eval conf (IfE {ifCond, ifDoThen, ifDoElse}) = do BoolV condB <- eval conf ifCond
if condB then eval conf ifDoThen else eval conf ifDoElse if condB then eval conf ifDoThen else eval conf ifDoElse
eval conf (SelfE e) = do ListV newInput <- eval conf e eval conf (SelfE e) = do ListV newInput <- eval conf e
guard $ length newInput < length (confInput conf) guard $ and $ zipWith structuralLess newInput (confInput conf) -- ??
if newInput `notElem` confExamples conf then if newInput `notElem` confExamples conf then
(case confOracle conf newInput of (case confOracle conf newInput of
Just expectedV -> NewExamples [(newInput, expectedV)] Just expectedV -> NewExamples [(newInput, expectedV)]
@ -268,8 +276,8 @@ splitGoalStep goal selector = do st <- get
syntResolvers = r : syntResolvers st } syntResolvers = r : syntResolvers st }
-- TODO: use expr evaluated outputs ? -- TODO: use expr evaluated outputs ?
trySolveGoal :: Goal -> Expr -> SyntState Bool trySolveGoal :: Expr -> Goal -> SyntState Bool
trySolveGoal goal expr = do st <- get trySolveGoal expr goal = do st <- get
if matchGoal goal st expr then do if matchGoal goal st expr then do
put st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st, put st { syntSolvedGoals = Map.insert goal expr $ syntSolvedGoals st,
syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st } syntUnsolvedGoals = Set.delete goal $ syntUnsolvedGoals st }
@ -403,6 +411,9 @@ createSynt oracle goals = let root = Goal $ map (Just . snd) goals in
initSynt :: Oracle -> [([Value], Value)] -> SyntState () initSynt :: Oracle -> [([Value], Value)] -> SyntState ()
initSynt oracle goals = put $ createSynt oracle goals initSynt oracle goals = put $ createSynt oracle goals
calcExprOutputs :: Expr -> SyntState [Result Value]
calcExprOutputs expr = gets (\st -> map (\input -> eval (confBySynt input expr st) expr) $ syntExamples st)
stepOnAddedExpr :: Expr -> SyntState (Maybe Expr) stepOnAddedExpr :: Expr -> SyntState (Maybe Expr)
stepOnAddedExpr expr = do exFound <- saturateStep expr stepOnAddedExpr expr = do exFound <- saturateStep expr
st <- get st <- get
@ -410,8 +421,9 @@ stepOnAddedExpr expr = do exFound <- saturateStep expr
maybeResult <- terminateStep expr maybeResult <- terminateStep expr
if isJust maybeResult then return maybeResult else do if isJust maybeResult then return maybeResult else do
let exprOutputs = map (\input -> eval (confBySynt input expr st) expr) $ syntExamples st let exprOutputs = map (\input -> eval (confBySynt input expr st) expr) $ syntExamples st
-- TODO: solve existing goals -- TODO: remove copies
-- TODO: resolve existing goals gets (foldM_ (const $ trySolveGoal expr) False . syntUnsolvedGoals) -- solve existing goals
gets (foldM_ (const tryResolve) False . syntResolvers)-- resolve existing goals
put $ foldl (splitGoalsFold exprOutputs) st $ Set.toList $ syntUnsolvedGoals st put $ foldl (splitGoalsFold exprOutputs) st $ Set.toList $ syntUnsolvedGoals st
return Nothing return Nothing
where splitGoalsFold outputs st goal@(Goal expected) = let matches = zipWith matchResult outputs expected in where splitGoalsFold outputs st goal@(Goal expected) = let matches = zipWith matchResult outputs expected in