mirror of
https://codeberg.org/ProgramSnail/prog_synthesis.git
synced 2025-12-06 05:28:42 +00:00
192 lines
10 KiB
Haskell
192 lines
10 KiB
Haskell
import Data.List (elemIndex, sort, find)
|
|
import Data.Maybe (isJust)
|
|
|
|
infixl 4 :+:
|
|
|
|
data Expr = Zero
|
|
| Succ Expr
|
|
| Len Expr
|
|
| FirstZero Expr
|
|
| Sort Expr
|
|
| SubList Expr Expr Expr
|
|
| Expr :+: Expr
|
|
| Recursive Expr
|
|
| ZeroList
|
|
| InList
|
|
deriving (Read, Show, Eq)
|
|
|
|
data Type = IntT | ListT
|
|
deriving (Read, Show, Eq)
|
|
data Value = IntV Int | ListV [Int]
|
|
deriving (Read, Show, Eq)
|
|
|
|
typeOf :: Expr -> Type
|
|
typeOf Zero = IntT
|
|
typeOf (Succ {}) = IntT
|
|
typeOf (Len {}) = IntT
|
|
typeOf (FirstZero {}) = IntT
|
|
typeOf _ = ListT
|
|
|
|
data Env = Env {input :: [Int], prog :: Expr, steps :: Int}
|
|
|
|
stepInEnv :: Env -> Env
|
|
stepInEnv env@(Env {input, prog, steps}) = env { steps = steps - 1 }
|
|
|
|
execInt :: Env -> Expr -> Maybe Int
|
|
execInt (Env {input, prog, steps=0}) _ = Nothing
|
|
execInt _ Zero = Just 0
|
|
execInt env (Succ expr) = (+) 1 <$> execInt (stepInEnv env) expr
|
|
execInt env (Len listExpr) = length <$> execList (stepInEnv env) listExpr
|
|
execInt env (FirstZero listExpr) = do value <- execList (stepInEnv env) listExpr
|
|
0 `elemIndex` value
|
|
execInt _ _ = Nothing
|
|
|
|
execList :: Env -> Expr -> Maybe [Int]
|
|
execList (Env {input, prog, steps=0}) _ = Nothing
|
|
execList env (Sort listExpr) = sort <$> execList (stepInEnv env) listExpr
|
|
execList env (SubList listExpr exprFrom exprTo) = do valFrom <- execInt (stepInEnv env) exprFrom
|
|
valTo <- execInt (stepInEnv env) exprTo
|
|
listValue <- execList (stepInEnv env) listExpr
|
|
return $ drop valFrom $ take (valTo + 1) listValue
|
|
execList env (exprLeft :+: exprRight) = do valLeft <- execList (stepInEnv env) exprLeft
|
|
valRight <- execList (stepInEnv env) exprRight
|
|
return $ valLeft ++ valRight
|
|
execList env (Recursive listExpr) = do listValue <- execList (stepInEnv env) listExpr
|
|
if null listValue then Just [] else execList (stepInEnv $ env {input = listValue}) (prog env)
|
|
execList _ ZeroList = Just [0]
|
|
execList (Env {input, prog, steps}) InList = Just input
|
|
execList _ _ = Nothing
|
|
|
|
-- TODO: union
|
|
execProg :: [Int] -> Expr -> Maybe [Int]
|
|
execProg input expr = execList (Env {input, prog=expr, steps=20}) expr
|
|
|
|
terminals :: [Expr]
|
|
terminals = [Zero, ZeroList, InList] -- ,
|
|
-- Succ Zero, Len InList]
|
|
|
|
concatShuffle :: [[Expr]] -> [Expr]
|
|
concatShuffle xxs = let xxs' = filter (not . null) xxs in
|
|
if null xxs' then [] else
|
|
map head xxs' ++ concatShuffle (map tail xxs')
|
|
|
|
nextSimpleExprsLists :: [Expr] -> [[Expr]]
|
|
nextSimpleExprsLists exprs = let listExprs = [ e | e <- exprs, typeOf e == ListT] in
|
|
[[Succ e | e <- exprs, typeOf e == IntT],
|
|
map Sort listExprs,
|
|
map Recursive listExprs,
|
|
map FirstZero listExprs,
|
|
map Len listExprs]
|
|
|
|
nextExprsLists :: [Expr] -> [[Expr]]
|
|
nextExprsLists exprs = let listExprs = [ e | e <- exprs, typeOf e == ListT] in
|
|
let intExprs = [ e | e <- exprs, typeOf e == IntT] in
|
|
nextSimpleExprsLists exprs ++
|
|
[[e :+: e' | e <- listExprs,
|
|
e' <- listExprs],
|
|
[SubList e from to | e <- listExprs, from <- intExprs, to <- intExprs]]
|
|
|
|
nextSimpleExprs :: [Expr] -> [Expr]
|
|
nextSimpleExprs exprs = (++) exprs $ concatShuffle $ nextSimpleExprsLists exprs
|
|
|
|
nextExprs :: [Expr] -> [Expr]
|
|
nextExprs exprs = (++) exprs $ concatShuffle $ nextExprsLists exprs
|
|
|
|
nextSimpleExprs' :: [Expr] -> [Expr]
|
|
nextSimpleExprs' = concatShuffle . nextSimpleExprsLists
|
|
|
|
nextExprsLists' :: [Expr] -> [Expr] -> [[Expr]]
|
|
nextExprsLists' newExprs oldExprs = let listNewExprs = [ e | e <- newExprs, typeOf e == ListT] in
|
|
let intNewExprs = [ e | e <- newExprs, typeOf e == IntT] in
|
|
let listOldExprs = [ e | e <- oldExprs, typeOf e == ListT] in
|
|
let intOldExprs = [ e | e <- oldExprs, typeOf e == IntT] in
|
|
nextSimpleExprsLists newExprs ++
|
|
[concat [[e :+: e' | e <- listNewExprs, e' <- listNewExprs],
|
|
[e :+: e' | e <- listNewExprs, e' <- listOldExprs],
|
|
[e :+: e' | e <- listOldExprs, e' <- listNewExprs]],
|
|
concat [[SubList e from to | e <- listNewExprs, from <- intNewExprs, to <- intNewExprs],
|
|
[SubList e from to | e <- listOldExprs, from <- intNewExprs, to <- intNewExprs],
|
|
[SubList e from to | e <- listNewExprs, from <- intOldExprs, to <- intNewExprs],
|
|
[SubList e from to | e <- listNewExprs, from <- intNewExprs, to <- intOldExprs],
|
|
[SubList e from to | e <- listOldExprs, from <- intOldExprs, to <- intNewExprs],
|
|
[SubList e from to | e <- listOldExprs, from <- intNewExprs, to <- intOldExprs],
|
|
[SubList e from to | e <- listNewExprs, from <- intOldExprs, to <- intOldExprs]]]
|
|
|
|
nextExprs' :: [Expr] -> [Expr] -> [Expr]
|
|
nextExprs' newExprs oldExprs = concatShuffle $ nextExprsLists' newExprs oldExprs
|
|
|
|
data Example = Example {exampleInput :: [Int], exampleOutput :: [Int]}
|
|
|
|
-- check expr on all examples
|
|
isCorrect :: [Example] -> Expr -> Bool
|
|
isCorrect examples expr = all (\Example {exampleInput, exampleOutput} -> execProg exampleInput expr == Just exampleOutput) examples
|
|
|
|
isValid :: [Example] -> Expr -> Bool
|
|
isValid examples expr | typeOf expr == IntT = True
|
|
| otherwise = all (\Example {exampleInput, exampleOutput} -> isJust $ execProg exampleInput expr) examples
|
|
|
|
-- check are exprs produce same results on all the examples
|
|
areSame :: [Example] -> Expr -> Expr -> Bool
|
|
areSame examples exprLeft exprRight | typeOf exprLeft == IntT = False
|
|
| typeOf exprRight == IntT = False
|
|
| otherwise = all (\Example {exampleInput, exampleOutput} -> let Just resLeft = execProg exampleInput exprLeft in
|
|
let Just resRight = execProg exampleInput exprRight in
|
|
resLeft /= [] -- NOTE: not in the base algorithm, way to remove rec deletion (?)
|
|
&& resLeft == resRight) examples
|
|
|
|
-----
|
|
|
|
upSyntesisStep :: [Example] -> [Expr] -> Either [Expr] Expr
|
|
upSyntesisStep examples exprs = case find (isCorrect examples) exprs of
|
|
Just answer -> Right answer
|
|
Nothing -> let exprs' = filter (isValid examples) exprs in -- exclude invalid fragments
|
|
let exprs'' = foldl (\acc expr -> if any (areSame examples expr) acc then acc else expr : acc) [] exprs' in -- merge same values
|
|
Left $
|
|
nextSimpleExprs $
|
|
nextExprs exprs''
|
|
|
|
upSyntesisRec :: [Example] -> Int -> [Expr] -> Maybe Expr
|
|
upSyntesisRec _ 0 _ = Nothing
|
|
upSyntesisRec examples steps exprs = case upSyntesisStep examples exprs of
|
|
Right answer -> Just answer
|
|
Left exprs' -> upSyntesisRec examples (steps - 1) exprs'
|
|
|
|
|
|
upSyntesis :: [Example] -> Int -> Maybe Expr
|
|
upSyntesis examples steps = upSyntesisRec examples steps $ nextSimpleExprs terminals
|
|
|
|
-----
|
|
|
|
data ExprsPair = ExprsPair [Expr] [Expr]
|
|
|
|
upSyntesisStep' :: [Example] -> [Expr] -> [Expr] -> Either ExprsPair Expr
|
|
upSyntesisStep' examples newExprs oldExprs =
|
|
case find (isCorrect examples) newExprs of
|
|
Just answer -> Right answer
|
|
Nothing -> let newExprs' = filter (isValid examples) newExprs in -- exclude invalid fragments
|
|
-- NOTE: new exprs are not checked against old exprs for now
|
|
let newExprs'' = foldl (\acc expr -> if any (areSame examples expr) acc then acc else expr : acc) [] newExprs' in -- merge same values
|
|
Left $
|
|
-- nextSimpleExprs $
|
|
ExprsPair (nextExprs' newExprs'' oldExprs) newExprs''
|
|
|
|
upSyntesisRec' :: [Example] -> Int -> [Expr] -> [Expr] -> Maybe Expr
|
|
upSyntesisRec' _ 0 _ _ = Nothing
|
|
upSyntesisRec' examples steps newExprs oldExprs = case upSyntesisStep' examples newExprs oldExprs of
|
|
Right answer -> Just answer
|
|
Left (ExprsPair newExprs' oldExprs') -> upSyntesisRec' examples (steps - 1) newExprs' (oldExprs' ++ oldExprs)
|
|
|
|
upSyntesis' :: [Example] -> Int -> Maybe Expr
|
|
upSyntesis' examples steps = upSyntesisRec' examples steps (nextSimpleExprs terminals) []
|
|
|
|
-----
|
|
|
|
exampleOf :: [Int] -> [Int] -> Example
|
|
exampleOf input output = Example {exampleInput = input, exampleOutput = output}
|
|
|
|
sameExamplesExpected = InList
|
|
sameExamples = [exampleOf [1] [1], exampleOf [1,2] [1,2], exampleOf [1,2,3] [1,2,3], exampleOf [1,2,3,4] [1,2,3,4]]
|
|
revExamplesExpected = Recursive (SubList InList (Succ Zero) (Len InList)) :+: SubList InList Zero Zero
|
|
revExamples = [exampleOf [1] [1], exampleOf [1,2] [2,1], exampleOf [1,2,3] [3,2,1], exampleOf [1,2,3,4] [4,3,2,1]]
|
|
|
|
main = print $ upSyntesis' revExamples 4
|