{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} module LambdaCalculus where import Data.List (foldr1, last) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe import Data.Random import qualified Data.Text as T import Data.Tuple.Extra import Data.Typeable import GA import Pretty import Protolude import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck.Monadic (assert, monadicIO) import qualified Type.Reflection as Ref data ExpressionWeights = ExpressionWeights { lambdaSpucker :: Int, lambdaSchlucker :: Int, symbol :: Int, variable :: Int, constant :: Int } data LambdaEnviroment = LambdaEnviroment { functions :: (Map TypeRep [ConVal]), constants :: (Map TypeRep [RVar ConVal]), targetType :: TypeRep, maxDepth :: Int, weights :: ExpressionWeights } showSanifid :: (Show a) => a -> Text showSanifid var = T.replace " -> " "To" (show var) exampleLE :: LambdaEnviroment exampleLE = LambdaEnviroment { functions = Map.fromList [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), ["(+)", "(-)", "(*)", "mod"]), ((Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Bool))), ["(>)", "(==)", "(>=)"]), ((Ref.SomeTypeRep (Ref.TypeRep @(Bool -> Int -> Int -> Int))), ["if'"]) ], constants = Map.fromList [ ((Ref.SomeTypeRep (Ref.TypeRep @(Int))), [(fmap show (uniform 0 10000 :: RVar Int))]), ((Ref.SomeTypeRep (Ref.TypeRep @(Bool))), [(fmap show (uniform True False :: RVar Bool))]) ], targetType = (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int))), maxDepth = 10, weights = ExpressionWeights { lambdaSpucker = 1, lambdaSchlucker = 2, symbol = 2, variable = 10, constant = 2 } } type BoundVars = [TypeRep] -- we need a dynamic typ with a concept of equality here, should we want to interpret the result, instead of compiling it... type ConVal = Text -- LambdaSpucker - adds TypeRequester#1 as bound var and returns the result of TypeRequester#2 data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal deriving (Eq, Ord, Show) asList :: LambdaExpression -> [TypeRequester] asList (LambdaSpucker tr1 tr2 _) = [tr1, tr2] asList (LambdaSchlucker tr _) = [tr] asList (Symbol _ trs _) = trs asList (Var _ _ trs _) = trs asList (Constan _) = [] data TypeRequester = TR TypeRep (Maybe LambdaExpression) BoundVars deriving (Eq, Ord, Show) toLambdaExpressionS :: TypeRequester -> Text toLambdaExpressionS (TR typeRep (Just lambdaExpression) boundVars) = "((" <> eToLambdaExpressionS lambdaExpression <> ") :: (" <> show typeRep <> "))" toLambdaExpressionS (TR _ (Nothing) _) = "Invalid Lambda Epr" -- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int | Constan ConVal eToLambdaExpressionS :: LambdaExpression -> Text eToLambdaExpressionS (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester2 <> ") " <> toLambdaExpressionS typeRequester1 eToLambdaExpressionS (LambdaSchlucker typeRequester boundVars) = "\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionS typeRequester eToLambdaExpressionS (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionS typeRequesters)) eToLambdaExpressionS (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionS typeRequesters)) eToLambdaExpressionS (Constan (valS)) = valS instance Pretty TypeRequester where pretty = toLambdaExpressionShort instance Individual TypeRequester instance Pretty LambdaEnviroment where pretty (LambdaEnviroment functions constants target _ _) = "Functions: " <> show functions <> " Constants: " <> show (Map.keys constants) <> " Target is a function: " <> show target genTypeRequester :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar TypeRequester genTypeRequester env depthLeft target boundVars = do le <- genLambdaExpression env (depthLeft - 1) target boundVars return (TR target (Just le) boundVars) genLambdaExpression :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaExpression env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do let weightMap = ( if not (canGenSchlucker target) then [(constant weights, genLambdaConst env depthLeft target boundVar)] else [] ) <> ( if depthLeft > 0 then [(lambdaSpucker weights, genLambdaSpucker env depthLeft target boundVar)] else [] ) <> ( if canGenSchlucker target then [(lambdaSchlucker weights, genLambdaSchlucker env depthLeft target boundVar)] else [] ) <> ( if depthLeft > 0 && doAnyMatchThatType target (Map.keys functions) then [(symbol weights, genLambdaSymbol env depthLeft target boundVar)] else [] ) <> ( if depthLeft > 0 && doAnyMatchThatType target boundVar then [(variable weights, genLambdaVar env depthLeft target boundVar)] else [] ) expres <- selectWeighted weightMap res <- expres return res selectWeighted :: [(Int, a)] -> RVar a selectWeighted x = do let total = sum (map fst x) selection <- uniform 1 total return $ selectAtWeight selection (NE.fromList x) selectAtWeight :: Int -> NonEmpty (Int, a) -> a selectAtWeight _ (x :| []) = snd x selectAtWeight w (x :| xs) | fst x >= w = snd x | otherwise = selectAtWeight (w - fst x) (NE.fromList xs) canGenSchlucker :: TypeRep -> Bool canGenSchlucker t = (typeRepTyCon t) == (typeRepTyCon (Ref.SomeTypeRep (Ref.TypeRep @(->)))) doAnyMatchThatType :: TypeRep -> [TypeRep] -> Bool doAnyMatchThatType toGen available = any (doTypesMatch toGen) available doTypesMatch :: TypeRep -> TypeRep -> Bool doTypesMatch toGen available = elem toGen (available : (repeatedly (lastMay . typeRepArgs) available)) genLambdaSpucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaSpucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do lamdaTypeLength <- uniform 1 4 lambaTypes <- replicateM lamdaTypeLength (randomElement (Map.keys constants)) let lambaType = foldr1 mkFunTy lambaTypes lamdaVarTypeRequester <- genTypeRequester env depthLeft lambaType boundVar typeRequester <- genTypeRequester env depthLeft target (boundVar ++ [lambaType]) return (LambdaSpucker lamdaVarTypeRequester typeRequester (boundVar ++ [lambaType])) genLambdaSchlucker :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaSchlucker env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do let args = typeRepArgs target let lambaType = fromJust (head args) let toFind = last args typeRequester <- genTypeRequester env depthLeft toFind (boundVar ++ [lambaType]) return (LambdaSchlucker typeRequester (boundVar ++ [lambaType])) genLambdaConst :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaConst env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do elm <- randomElement $ fromJust (Map.lookup target constants) res <- elm return $ Constan res genLambdaSymbol :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaSymbol env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do let availFunTypes = filter (doTypesMatch target) (Map.keys functions) (tr, fun) <- randomElement $ concatMap (\l -> zip (repeat l) (fromMaybe [] (Map.lookup l functions))) availFunTypes ret <- genLambdaSymbol' tr fun [] env depthLeft target boundVar return ret genLambdaSymbol' :: TypeRep -> ConVal -> [TypeRequester] -> LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaSymbol' tr v trs env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar | tr == target = do return $ Symbol v trs boundVar | otherwise = do let args = typeRepArgs tr let param = fromJust (head args) let rest = last args newTypeRequ <- genTypeRequester env depthLeft param boundVar ret <- genLambdaSymbol' rest v (trs ++ [newTypeRequ]) env depthLeft target boundVar return ret genLambdaVar :: LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaVar env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar = do let availTypes = filter (doTypesMatch target) boundVar choosenType <- randomElement $ availTypes let tCount = count boundVar choosenType indexV <- uniform 0 (tCount - 1) ret <- genLambdaVar' choosenType choosenType indexV [] env depthLeft target boundVar return ret genLambdaVar' :: TypeRep -> TypeRep -> Int -> [TypeRequester] -> LambdaEnviroment -> Int -> TypeRep -> BoundVars -> RVar LambdaExpression genLambdaVar' tr varType varNumber trs env@(LambdaEnviroment functions constants _ _ weights) depthLeft target boundVar | tr == target = do return $ Var varType varNumber trs boundVar | otherwise = do let args = typeRepArgs tr let param = fromJust (head args) let rest = last args newTypeRequ <- genTypeRequester env depthLeft param boundVar ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar return ret instance Environment TypeRequester LambdaEnviroment where new env@(LambdaEnviroment _ _ target maxDepth _) = do tr <- genTypeRequester env maxDepth target [] return tr mutate env@(LambdaEnviroment _ _ _ maxDepth _) tr = do let trCount = countTrsR (tr) selectedTR <- uniform 1 trCount let (depthAt, (TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth res <- genTypeRequester env depthAt trep bound return $ replaceAtR selectedTR tr res nX _ = 3 -- todo! crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do return Nothing -- TODO: crossover! -- let trCount = countTrsR tr1 -- selectedIndex1 <- uniform 1 trCount -- let (depthAt, selectedTr1@(TR trep _ bound)) = depthLeftAndTypeAtR tr selectedTR maxDepth -- let indexes = findIndicesWhere tr2 ( == trep) -- if length indexes == 0 then return Nothing else (do -- (selectedTr2,selectedIndex2) <- randomElement indexes) -- helper -- findIndicesWhere:: TypeRequester -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] -- findIndicesWhere tr@(TR t lE _) filte indx = case lE of -- Just le -> (tr, indx+1):(findIndicesWhere' (asList le) filte (indx+1)) -- Nothing -> undefined -- findIndicesWhere':: [TypeRequester] -> (TypeRep -> Bool) -> Int -> [(TypeRequester, Int)] -- findIndicesWhere' (tr:trs) f indx = (findIndicesWhere tr f indx) ++ (findIndicesWhere' trs f (indx + countTrsR tr)) replaceAtR :: Int -> TypeRequester -> TypeRequester -> TypeRequester replaceAtR 1 _ with = with replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i - 1) le with)) bV replaceAtR _ (TR _ Nothing _) _ = undefined replaceAt :: Int -> LambdaExpression -> TypeRequester -> LambdaExpression replaceAt i le@(LambdaSpucker _ _ bv) with = LambdaSpucker (fromJust (head trs)) (last trs) bv where trs = replaceInSubtreeWithIndex i (asList le) with replaceAt i (LambdaSchlucker tr bv) with = LambdaSchlucker (replaceAtR i tr with) bv replaceAt i le@(Symbol cv _ bv) with = Symbol cv trs bv where trs = replaceInSubtreeWithIndex i (asList le) with replaceAt i le@(Var tr ix _ bv) with = Var tr ix trs bv where trs = replaceInSubtreeWithIndex i (asList le) with replaceAt _ (Constan _) _ = undefined replaceInSubtreeWithIndex :: Int -> [TypeRequester] -> TypeRequester -> [TypeRequester] replaceInSubtreeWithIndex indexLeft (tr : trs) with = if countTrsR tr >= indexLeft then (replaceAtR indexLeft tr with) : trs else tr : (replaceInSubtreeWithIndex (indexLeft - countTrsR tr) trs with) replaceInSubtreeWithIndex _ [] _ = undefined depthLeftAndTypeAtR :: TypeRequester -> Int -> Int -> (Int, TypeRequester) depthLeftAndTypeAtR t 1 depthLeft = ((depthLeft - 1), t) depthLeftAndTypeAtR (TR _ (Just le) _) indexLeft depthLeft = depthLeftAndTypeAt le (indexLeft - 1) (depthLeft - 1) depthLeftAndTypeAtR (TR _ Nothing _) indexLeft depthLeft = undefined depthLeftAndTypeAt :: LambdaExpression -> Int -> Int -> (Int, TypeRequester) depthLeftAndTypeAt le indexLeft depthLeft = depthLeftAndTypeInSubtreeWithIndex (asList le) indexLeft depthLeft depthLeftAndTypeInSubtreeWithIndex :: [TypeRequester] -> Int -> Int -> (Int, TypeRequester) depthLeftAndTypeInSubtreeWithIndex (tr : trs) indexLeft depthLeft = if countTrsR tr >= indexLeft then depthLeftAndTypeAtR tr indexLeft depthLeft else depthLeftAndTypeInSubtreeWithIndex trs (indexLeft - countTrsR tr) depthLeft depthLeftAndTypeInSubtreeWithIndex [] indexLeft depthLeft = undefined countTrsR :: TypeRequester -> Int countTrsR tr@(TR t lE _) = case lE of Just le -> countTrs le + 1 Nothing -> 1 countTrs :: LambdaExpression -> Int countTrs le = sum (map countTrsR (asList le)) repeatedly :: (a -> Maybe a) -> a -> [a] repeatedly f x = case f x of Nothing -> [] Just y -> y : repeatedly f y count :: (Eq a) => [a] -> a -> Int count [] find = 0 count ys find = length xs where xs = [xs | xs <- ys, xs == find] -- Test Stuff testConstInt :: TypeRequester testConstInt = TR (Ref.SomeTypeRep (Ref.TypeRep @Int)) (Just (Symbol ("5") [] [])) [] testIntToClassCons :: TypeRequester testIntToClassCons = TR (Ref.SomeTypeRep (Ref.TypeRep @(Int -> ResClass))) (Just (Symbol ("Class1") [] [])) [] testIntToClassCorrect :: TypeRequester testIntToClassCorrect = TR (Ref.SomeTypeRep (Ref.TypeRep @(Int -> ResClass))) ( Just ( LambdaSchlucker ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) ( Just ( Symbol ("iteClass") [ ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Bool))) ( Just ( Symbol ("eqInt") [ ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Int))) (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] [])) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Int))) (Just (Constan ("1"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ] [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) (Just (Constan ("Class1"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) ( Just ( Symbol ("iteClass") [ ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Bool))) ( Just ( Symbol ("eqInt") [ ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Int))) (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] [])) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Int))) (Just (Constan ("2"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ] [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) (Just (Constan ("Class2"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) ( Just ( Symbol ("iteClass") [ ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Bool))) ( Just ( Symbol ("eqInt") [ ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Int))) (Just (Var (Ref.SomeTypeRep (Ref.TypeRep @(Int))) 0 [] [])) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(Int))) (Just (Constan ("3"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ] [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) (Just (Constan ("Class3"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ), ( TR (Ref.SomeTypeRep (Ref.TypeRep @(ResClass))) (Just (Constan ("Class3"))) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ] [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ] [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ] [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) [(Ref.SomeTypeRep (Ref.TypeRep @(Int)))] ) ) [] data ResClass = Class1 | Class2 | Class3 deriving (Enum, Show) eqInt :: Int -> Int -> Bool eqInt a b = a == b iteClass :: Bool -> ResClass -> ResClass -> ResClass iteClass True c _ = c iteClass False _ c = c toLambdaExpressionShort :: TypeRequester -> Text toLambdaExpressionShort (TR _ (Just lambdaExpression) _) = "(" <> eToLambdaExpressionShort lambdaExpression <> ")" toLambdaExpressionShort (TR _ (Nothing) _) = "Invalid Lambda Epr" -- data LambdaExpression = LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int | Constan ConVal eToLambdaExpressionShort :: LambdaExpression -> Text eToLambdaExpressionShort (LambdaSpucker typeRequester1 typeRequester2 boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester2 <> ") " <> toLambdaExpressionShort typeRequester1 eToLambdaExpressionShort (LambdaSchlucker typeRequester boundVars) = "(\\l" <> showSanifid (last boundVars) <> show (count boundVars (last boundVars) - 1) <> " -> " <> toLambdaExpressionShort typeRequester <> ")" eToLambdaExpressionShort (Symbol (valS) typeRequesters _) = valS <> " " <> (unwords (map toLambdaExpressionShort typeRequesters)) eToLambdaExpressionShort (Var typeRep int typeRequesters _) = "l" <> showSanifid typeRep <> show int <> " " <> (unwords (map toLambdaExpressionShort typeRequesters)) eToLambdaExpressionShort (Constan (valS)) = valS res :: Int -> ResClass res = ((\lInt0 -> ((iteClass ((eqInt ((lInt0) :: (Int)) ((1) :: (Int))) :: (Bool)) ((Class1) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((2) :: (Int))) :: (Bool)) ((Class2) :: (ResClass)) ((iteClass ((eqInt ((lInt0) :: (Int)) ((3) :: (Int))) :: (Bool)) ((Class3) :: (ResClass)) ((Class3) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (ResClass))) :: (Int -> ResClass))