579 lines
29 KiB
Haskell
579 lines
29 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeAbstractions #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
module LambdaCalculusV2 where
|
|
|
|
import Data.Dynamic
|
|
import Data.Kind
|
|
import qualified Data.Set as Set
|
|
import qualified Data.List.NonEmpty as NE
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Random
|
|
import Data.Typeable
|
|
import Debug.Trace as DB
|
|
import qualified Data.Text as T
|
|
import GA
|
|
import Protolude
|
|
import Protolude.Error
|
|
import Protolude.Partial
|
|
import qualified Type.Reflection as Ref
|
|
import Utils
|
|
|
|
data BoundSymbol where
|
|
BoundSymbol :: (Typeable a) => Ref.TypeRep a -> a -> Maybe Text -> BoundSymbol
|
|
|
|
type Bindings = Map.Map (Ref.SomeTypeRep) Int
|
|
|
|
data SomeSimplyTypedLambdaExpression where
|
|
SomeSimplyTypedLambdaExpression :: (Typeable a) => SimplyTypedLambdaExpression a -> SomeSimplyTypedLambdaExpression
|
|
|
|
-- We specify a and use GADTs to allow Haskell to guarantee full type safety over these expressions!
|
|
-- This gurantees us that a SimplyTypedLambdaExpression a describes a lambda expression of type a!
|
|
data SimplyTypedLambdaExpression t where
|
|
Application :: (Typeable a, Typeable b) => SimplyTypedLambdaExpression (a -> b) -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression b -- e = e1 e2
|
|
Abstraction :: (Typeable (a -> b), Typeable b) => Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> SimplyTypedLambdaExpression (a -> b) -- e = λx:a. e
|
|
VariableReference :: (Typeable a) => Ref.TypeRep a -> Int -> SimplyTypedLambdaExpression a -- e = x this Includes predefined function use!
|
|
Constant :: (Typeable a, Ord a, Hashable a, Show a) => a -> SimplyTypedLambdaExpression a -- e = c
|
|
|
|
instance Eq (SimplyTypedLambdaExpression t) where
|
|
e1 == e2 = compare e1 e2 == EQ
|
|
|
|
instance Ord (SimplyTypedLambdaExpression t) where
|
|
compare (Application (stleAtoB1 :: SimplyTypedLambdaExpression (a1 -> t)) (stleA1 :: SimplyTypedLambdaExpression a1)) (Application (stleAtoB2 :: SimplyTypedLambdaExpression (a2 -> t)) (stleA2 :: SimplyTypedLambdaExpression a2)) = case eqT @a1 @a2 of
|
|
Just Refl -> (compare stleAtoB1 stleAtoB2) `thenCmp` (compare stleA1 stleA2)
|
|
_ -> compare (Ref.SomeTypeRep (Ref.TypeRep @a1)) (Ref.SomeTypeRep (Ref.TypeRep @a2))
|
|
compare (Abstraction rep1 stle1) (Abstraction rep2 stle2) = (compare rep1 rep2) `thenCmp` (compare stle1 stle2)
|
|
compare (VariableReference repA inx1) (VariableReference repB inx2) = (compare repA repB) `thenCmp` (compare inx1 inx2)
|
|
compare (Constant res1) (Constant res2) = compare res1 res2
|
|
compare (Application _ _) _ = LT
|
|
compare _ (Application _ _) = GT
|
|
compare (Abstraction _ _) _ = LT
|
|
compare _ (Abstraction _ _) = GT
|
|
compare (VariableReference _ _) _ = LT
|
|
compare _ (VariableReference _ _) = GT
|
|
|
|
instance Hashable (SimplyTypedLambdaExpression t) where
|
|
hashWithSalt salt (Application stleAtoB stleA) = salt `hashWithSalt` (1 :: Int) `hashWithSalt` stleAtoB `hashWithSalt` stleA
|
|
hashWithSalt salt (Abstraction rep stle) = salt `hashWithSalt` (2 :: Int) `hashWithSalt` rep `hashWithSalt` stle
|
|
hashWithSalt salt (VariableReference rep inx) = salt `hashWithSalt` (3 :: Int) `hashWithSalt` rep `hashWithSalt` inx
|
|
hashWithSalt salt (Constant res) = salt `hashWithSalt` (4 :: Int) `hashWithSalt` res
|
|
|
|
thenCmp :: Ordering -> Ordering -> Ordering
|
|
thenCmp EQ o2 = o2
|
|
thenCmp o1 _ = o1
|
|
|
|
data ConstVal where
|
|
ConstVal :: (Typeable a, Ord a, Hashable a, Show a) => Ref.TypeRep a -> RVar a -> ConstVal
|
|
|
|
data ExpressionWeights = ExpressionWeights
|
|
{ application :: Int,
|
|
abstraction :: Int,
|
|
variableReference :: Int,
|
|
constant :: Int,
|
|
-- chance in percent an Application will (try to) work towards something from the boundVars becoming usable. I recommend values over 90.
|
|
functionBias :: Int
|
|
}
|
|
|
|
data LambdaEnviroment a = LambdaEnviroment
|
|
{ functions :: [BoundSymbol],
|
|
constants :: [ConstVal],
|
|
maxDepth :: Int,
|
|
weights :: ExpressionWeights,
|
|
-- likelyhood of an sub-expression to be mutated
|
|
mutationStrength :: Float,
|
|
-- likelyhood of an crossover attempt at a sub-expression
|
|
crossoverStrength :: Float
|
|
}
|
|
|
|
data FittnesRes = FittnesRes
|
|
{ total :: R,
|
|
fitnessTotal :: R,
|
|
fitnessGeoMean :: R,
|
|
fitnessMean :: R,
|
|
accuracy :: R,
|
|
biasSize :: R,
|
|
totalSize :: N
|
|
}
|
|
deriving (Show)
|
|
|
|
instance Fitness FittnesRes where
|
|
getR = total
|
|
|
|
data Dataset t where
|
|
Input :: (Typeable a, Typeable b) => [a] -> Dataset b -> Dataset (a -> b)
|
|
Result :: (Typeable a, Eq a, Enum a, Bounded a) => [a] -> Dataset a
|
|
|
|
data ExecutionEnviroment e = ExecutionEnviroment {
|
|
fun :: [BoundSymbol],
|
|
training :: Bool,
|
|
trainingData :: Dataset e,
|
|
testData :: Dataset e
|
|
}
|
|
|
|
data ResultList where
|
|
Res :: (Typeable a, Eq a, Enum a, Bounded a) => [(a,a)] -> ResultList
|
|
|
|
instance Typeable a => Evaluator (SimplyTypedLambdaExpression a) (ExecutionEnviroment a) FittnesRes where
|
|
fitness' ee@(ExecutionEnviroment {fun}) e = evalResult ee e (eval fun e)
|
|
|
|
evalResult :: ExecutionEnviroment a -> SimplyTypedLambdaExpression a -> a -> FittnesRes
|
|
evalResult (ExecutionEnviroment {training, trainingData, testData}) tr result = FittnesRes
|
|
{ total = (\(Res r) -> meanOfDistributionAccuracy r) res,
|
|
fitnessTotal = fitness',
|
|
fitnessMean = (\(Res r) -> meanOfAccuricyPerClass r) res ,
|
|
fitnessGeoMean = (\(Res r) -> meanOfDistributionAccuracy r) res,
|
|
accuracy = acc,
|
|
biasSize = biasSmall,
|
|
totalSize = expSize tr
|
|
}
|
|
where
|
|
dataS = (if training then trainingData else testData)
|
|
res = apply result dataS
|
|
acc = (\(Res r) -> (foldr (\(ts) s -> if ((fst ts) == (snd ts)) then s + 1 else s) 0 r) / fromIntegral (length r)) res
|
|
biasSmall = exp ((-(fromIntegral (expSize tr))) / 1000) -- 0 (schlecht) bis 1 (gut)
|
|
fitness' = (\(Res r) -> meanOfAccuricyPerClass r) res
|
|
score = fitness' + (biasSmall - 1)
|
|
|
|
apply :: a -> Dataset a -> ResultList
|
|
apply fun (Input b c) = applyL (map fun b) c
|
|
apply val (Result b) = Res (zip b (repeat val))
|
|
|
|
applyL :: [a] -> Dataset a -> ResultList
|
|
applyL fun (Input b c) = applyL (zipWith (\a b -> a b) fun b) c
|
|
applyL val (Result b) = Res (zip b val)
|
|
|
|
|
|
|
|
hasSymbolOfType :: forall (a :: Type). [BoundSymbol] -> Ref.TypeRep a -> Bool
|
|
hasSymbolOfType bound tr = length ((getSymbolsOfType bound tr) :: [a]) /= 0
|
|
|
|
getSymbolsOfType :: forall a. [BoundSymbol] -> Ref.TypeRep a -> [a]
|
|
getSymbolsOfType bound tr = mapMaybe (getIfType tr) bound
|
|
|
|
getBoundSymbolsOfType :: forall a. [BoundSymbol] -> Ref.TypeRep a -> [BoundSymbol]
|
|
getBoundSymbolsOfType bound tr = mapMaybe (getSymbolIfType tr) bound
|
|
|
|
getSymbolIfType :: forall a. Ref.TypeRep a -> BoundSymbol -> Maybe BoundSymbol
|
|
getSymbolIfType rep b@(BoundSymbol t _ _)
|
|
| Just Ref.HRefl <- t `Ref.eqTypeRep` rep = Just b
|
|
| otherwise = Nothing
|
|
|
|
getIfType :: forall a. Ref.TypeRep a -> BoundSymbol -> Maybe a
|
|
getIfType rep (BoundSymbol t val _)
|
|
| Just Ref.HRefl <- t `Ref.eqTypeRep` rep = Just val
|
|
| otherwise = Nothing
|
|
|
|
startingBindings :: [BoundSymbol] -> Bindings
|
|
startingBindings functions = (foldr (\(BoundSymbol tr _ _) map -> Map.insertWith (+) (Ref.SomeTypeRep tr) 1 map) Map.empty functions)
|
|
|
|
showSanifid :: (Show a) => a -> Text
|
|
showSanifid var = T.replace " -> " "To" (show var)
|
|
|
|
toDotE :: LambdaEnviroment a -> Text
|
|
toDotE (LambdaEnviroment {functions}) = foldr (<>) "" (map (\(BoundSymbol tr _ t, inx) -> "\"" <> (showSanifid tr) <> show inx <> "\" [style = invis label = " <> fromJust t <>"\"]\n") (concatMap (\(Ref.SomeTypeRep k,v) -> zip (getBoundSymbolsOfType functions k)[0 .. (v-1)]) (Map.toList (startingBindings functions))))
|
|
|
|
toDotI :: SimplyTypedLambdaExpression e -> Int -> Text
|
|
toDotI (Application e1 e2) inx = "\"app" <> show inx <> "\" -- " <> toDotI e1 (inx + 1) <> "\n" <> "\"app" <> show inx <> "\" -- " <> toDotI e2 (inx + 1 + expSize e1)
|
|
toDotI (Abstraction _ e) inx = "\"abs" <> show inx <> "\" -- " <> toDotI e (inx + 1)
|
|
toDotI (VariableReference tr i) _ = "\"" <> (showSanifid tr) <> show i <> "\""
|
|
toDotI (Constant c) _ = "\"" <> show c <> "\""
|
|
|
|
instance Eq SomeSimplyTypedLambdaExpression where
|
|
e1 == e2 = compare e1 e2 == EQ
|
|
|
|
instance Ord SomeSimplyTypedLambdaExpression where
|
|
compare (SomeSimplyTypedLambdaExpression (e1 :: SimplyTypedLambdaExpression a)) (SomeSimplyTypedLambdaExpression (e2 :: SimplyTypedLambdaExpression b))
|
|
| Just Refl <- eqT @a @b = compare e1 e2
|
|
| otherwise = compare (Ref.SomeTypeRep (Ref.TypeRep @a)) (Ref.SomeTypeRep (Ref.TypeRep @b))
|
|
|
|
instance Typeable a => Individual (SimplyTypedLambdaExpression a)
|
|
|
|
instance Typeable a => Environment (SimplyTypedLambdaExpression a) (LambdaEnviroment a) where
|
|
output env i = toDotE env <> toDotI i 0
|
|
|
|
nX _ = 3
|
|
|
|
new env = DB.trace "new !" ((generateFromEnv env) :: RVar (SimplyTypedLambdaExpression a))
|
|
|
|
mutate env le = (mutateUnwrapped env le)
|
|
|
|
crossover1 env le le2 = crossoverUnwrapper env le le2
|
|
|
|
crossoverUnwrapper :: (Typeable a) => LambdaEnviroment a -> SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression a -> RVar (Maybe (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression a))
|
|
crossoverUnwrapper env@(LambdaEnviroment {maxDepth, functions}) le1 le2 =
|
|
( do
|
|
(tree1, tree2) <- crossedover le1 le2 env maxDepth (startingBindings functions)
|
|
return $ if (tree2 == le2) then Nothing else Just (tree1, tree2)
|
|
)
|
|
|
|
crossedover :: forall a e. (Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> SimplyTypedLambdaExpression e -> LambdaEnviroment e -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e)
|
|
crossedover le1 le2 env@(LambdaEnviroment {crossoverStrength, maxDepth, functions}) sizeLeft bound = do
|
|
roll <- uniform 0 1
|
|
let crossoverChild =
|
|
( case le1 of
|
|
(Application e1 e2) ->
|
|
( do
|
|
(elm1, partner1) <- crossedover e1 le2 env ((sizeLeft - 1) - expSize e2) bound
|
|
(elm2, partner2) <- crossedover e2 le2 env ((sizeLeft - 1) - expSize e1) bound
|
|
leftMutated <- uniform False True
|
|
let mutateLeft = if partner1 == le2 then False else (if partner2 == le2 then False else leftMutated)
|
|
return $ if mutateLeft then (Application elm1 e2, partner1) else (Application e1 elm2, partner2)
|
|
)
|
|
(Abstraction tr e) ->
|
|
( do
|
|
(elm2, partner2) <- crossedover e le2 env (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep tr) 1 bound)
|
|
return $ (Abstraction tr elm2, partner2)
|
|
)
|
|
_ -> return (le1, le2)
|
|
)
|
|
if (roll < crossoverStrength)
|
|
then
|
|
( do
|
|
maybeSwapped <- trySwapSubtree le1 sizeLeft bound le2 maxDepth (startingBindings functions)
|
|
case maybeSwapped of
|
|
Just (ler1, ler2) -> return (ler1, ler2)
|
|
_ -> crossoverChild
|
|
)
|
|
else crossoverChild
|
|
|
|
trySwapSubtree :: forall a e.(Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> Int -> Bindings -> SimplyTypedLambdaExpression e -> Int -> Bindings -> RVar (Maybe (SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e))
|
|
trySwapSubtree le1 sizeLeft bound le2 sizeLeft2 bound2 = do
|
|
let possible = possibleSwapSubtrees le1 sizeLeft bound le2 sizeLeft2 bound2
|
|
case possible of
|
|
[] -> return Nothing
|
|
ne -> Just <$> randomElement ne
|
|
|
|
|
|
possibleSwapSubtrees :: forall a e.(Typeable a,Typeable e) => SimplyTypedLambdaExpression a -> Int -> Bindings -> SimplyTypedLambdaExpression e -> Int -> Bindings -> [(SimplyTypedLambdaExpression a, SimplyTypedLambdaExpression e)]
|
|
possibleSwapSubtrees le1 sizeLeft bound le2 sizeLeft2 bound2
|
|
| Just Refl <- eqT @a @e = if compatibleSubtree sizeLeft2 bound2 le1 && compatibleSubtree sizeLeft bound le2 then (adaptSubtree bound2 le1, adaptSubtree bound le2) : continue else continue
|
|
| otherwise = continue
|
|
where
|
|
continue = (case le2 of
|
|
Application e1 e2 -> (map (\(li1,li2) -> (li1, (Application e1 li2))) (possibleSwapSubtrees le1 sizeLeft bound e2 (sizeLeft2 - 1 - expSize e1) bound2) ) ++ (map (\(li1,li2) -> (li1, (Application li2 e2))) (possibleSwapSubtrees le1 sizeLeft bound e1 (sizeLeft2 - 1 - expSize e2) bound2) )
|
|
Abstraction t e -> (map (\(li1,li2) -> (li1, (Abstraction t li2))) (possibleSwapSubtrees le1 sizeLeft bound e (sizeLeft2 - 1) (addToBindings t bound2)))
|
|
_ -> [])
|
|
|
|
addToBindings ::Ref.TypeRep a -> Bindings -> Bindings
|
|
addToBindings t bound = (Map.insertWith (+) (Ref.SomeTypeRep t) 1 bound)
|
|
|
|
adaptSubtree :: Bindings -> SimplyTypedLambdaExpression e -> SimplyTypedLambdaExpression e
|
|
adaptSubtree bound (Application e1 e2) = (Application (adaptSubtree bound e1) (adaptSubtree bound e2))
|
|
adaptSubtree bound (Abstraction t e) = (Abstraction t (adaptSubtree (addToBindings t bound) e))
|
|
adaptSubtree bound (VariableReference tr idx) = (VariableReference tr (mod idx ( bound Map.! (Ref.SomeTypeRep tr))))
|
|
adaptSubtree _ e = e
|
|
|
|
compatibleSubtree :: Int -> Bindings -> SimplyTypedLambdaExpression e -> Bool
|
|
compatibleSubtree sizeLeft bound subtree = bound `bindingContains` (bindingReq subtree) && sizeLeft > (expSize subtree)
|
|
|
|
expSize :: SimplyTypedLambdaExpression e -> Int
|
|
expSize (Application e1 e2) = expSize e1 + expSize e2 + 1
|
|
expSize (Abstraction _ e) = expSize e + 1
|
|
expSize _ = 1
|
|
|
|
bindingReq :: SimplyTypedLambdaExpression e -> Bindings
|
|
bindingReq (Application e1 e2) = Map.unionWith (max) (bindingReq e1) (bindingReq e2)
|
|
bindingReq (Abstraction tr e) = rmFromBindings tr (bindingReq e)
|
|
bindingReq (VariableReference tr idx) = Map.singleton (Ref.SomeTypeRep tr) 1
|
|
bindingReq (Constant _) = Map.empty
|
|
|
|
rmFromBindings ::Ref.TypeRep a -> Bindings -> Bindings
|
|
rmFromBindings t bound = (Map.insertWith (\i1 i2 -> max 0 (i1 + i2)) (Ref.SomeTypeRep t) (- 1) bound)
|
|
|
|
bindingContains :: Bindings -> Bindings -> Bool
|
|
bindingContains superset subset = all (\(key,val) -> (fromMaybe 0 (Map.lookup key superset)) >= val ) (Map.toList subset)
|
|
|
|
mutateUnwrapped :: (Typeable r) => LambdaEnviroment r -> SimplyTypedLambdaExpression r -> RVar (SimplyTypedLambdaExpression r)
|
|
mutateUnwrapped env@(LambdaEnviroment {maxDepth, functions}) stle = mutated stle env maxDepth (startingBindings functions)
|
|
|
|
mutated :: forall r a. (Typeable r) => SimplyTypedLambdaExpression r -> LambdaEnviroment a -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
mutated (Application e1 e2) env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
|
|
roll <- uniform 0 1
|
|
if (roll < mutationStrength)
|
|
then generate env (Ref.TypeRep @r) constants sizeLeft bound
|
|
else do
|
|
sizeDistribution <- uniform 0 (sizeLeft - 1)
|
|
elm1 <- mutated e1 env sizeDistribution bound
|
|
elm2 <- mutated e2 env ((sizeLeft - 1) - sizeDistribution) bound
|
|
return $ Application elm1 elm2
|
|
mutated (Abstraction tr e) env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
|
|
roll <- uniform 0 1
|
|
if (roll < mutationStrength)
|
|
then generate env (Ref.TypeRep @r) constants sizeLeft bound
|
|
else do
|
|
elm2 <- mutated e env (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep tr) 1 bound)
|
|
return $ Abstraction tr elm2
|
|
mutated stle env@(LambdaEnviroment {constants, mutationStrength}) sizeLeft bound = do
|
|
roll <- uniform 0 1
|
|
if (roll < mutationStrength) then generate env (Ref.TypeRep @r) constants sizeLeft bound else return stle
|
|
|
|
|
|
test :: SimplyTypedLambdaExpression (Bool -> Int -> Int -> Int)
|
|
test = Abstraction (Ref.typeRep @(Bool)) (Abstraction (Ref.typeRep @(Int)) (Abstraction (Ref.typeRep @(Int)) (Constant 5)))
|
|
|
|
generateFromEnv :: forall r. (Typeable r) => LambdaEnviroment r -> RVar (SimplyTypedLambdaExpression r)
|
|
generateFromEnv env@(LambdaEnviroment {functions, constants, maxDepth}) = generate env (Ref.TypeRep @r) constants maxDepth (foldr (\(BoundSymbol tr _ _) map -> Map.insertWith (+) (Ref.SomeTypeRep tr) 1 map) Map.empty functions)
|
|
|
|
generate :: LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
generate env tr@(Ref.Fun (Ref.TypeRep @a) (Ref.TypeRep @b)) constantTypes sizeLeft bound
|
|
| (sizeLeft > 0) && (Map.member (Ref.SomeTypeRep tr) bound) = do
|
|
let weight = weights env
|
|
let options = [(application weight, genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
|
|
expres <- selectWeighted options
|
|
res <- expres
|
|
return res
|
|
| (sizeLeft > 0) = do
|
|
let weight = weights env
|
|
let options = [(application weight + round (1000 * closestFractionMatch tr bndK), genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound)]
|
|
expres <- selectWeighted options
|
|
res <- expres
|
|
return res
|
|
-- Application can crate a fitting type in a smaller expression. e.g. if':: Bool -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) and target type (Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool) can be finished in one Application (if' True::(Int-> Int -> Bool) -> (Int-> Int -> Bool) -> (Int-> Int -> Bool)) and one Var or constant, but resoving it purely with Abstractions would require 5 abstractions and one constant or var
|
|
-- | (any (< typeDepth tr) (mapMaybe (sizeMising tr) bndK)) = do
|
|
-- let weight = weights env
|
|
-- let options = [(application weight + (typeDepth tr - (minimum (mapMaybe (sizeMising tr) bndK))), genApplication env tr constantTypes sizeLeft bound), (abstraction weight, genAbstraction env tr constantTypes sizeLeft bound)]
|
|
-- expres <- selectWeighted options
|
|
-- res <- expres
|
|
-- return res
|
|
| (Map.member (Ref.SomeTypeRep tr) bound) = do
|
|
let weight = weights env
|
|
let options = [(abstraction weight, genAbstraction env tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
|
|
expres <- selectWeighted options
|
|
res <- expres
|
|
return res
|
|
| otherwise = do
|
|
res <- genAbstraction env tr constantTypes sizeLeft bound
|
|
return res
|
|
where
|
|
bndK = Map.keys bound
|
|
generate env tr constantTypes sizeLeft bound
|
|
| (sizeLeft > 0) && (Map.member (Ref.SomeTypeRep tr) bound) = do
|
|
let weight = weights env
|
|
let options = [(application weight, genApplication env tr constantTypes sizeLeft bound), (constant weight, genConstant tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
|
|
expres <- selectWeighted options
|
|
res <- expres
|
|
return res
|
|
| (sizeLeft > 0) = do
|
|
let weight = weights env
|
|
let options = [(application weight + round (1000 * closestFractionMatch tr bndK), genApplication env tr constantTypes sizeLeft bound), (constant weight, genConstant tr constantTypes sizeLeft bound)]
|
|
expres <- selectWeighted options
|
|
res <- expres
|
|
return res
|
|
| (Map.member (Ref.SomeTypeRep tr) bound) = do
|
|
let weight = weights env
|
|
let options = [(constant weight, genConstant tr constantTypes sizeLeft bound), (variableReference weight, genVariableReference env tr constantTypes sizeLeft bound)]
|
|
expres <- selectWeighted options
|
|
res <- expres
|
|
return res
|
|
| otherwise = do
|
|
res <- genConstant tr constantTypes sizeLeft bound
|
|
return res
|
|
where
|
|
bndK = Map.keys bound
|
|
|
|
genVariableReference :: LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genVariableReference _ tr@(Ref.TypeRep) _ _ bound = do
|
|
typeIndex <- uniform 0 (((Map.!) bound (Ref.SomeTypeRep tr)) - 1)
|
|
return $ (VariableReference tr typeIndex)
|
|
|
|
genConstant :: Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genConstant (Ref.TypeRep @a) constantTypes _ _ = do
|
|
val <- (constantGen constantTypes) :: RVar (SimplyTypedLambdaExpression a)
|
|
return $ val
|
|
|
|
constantGen :: forall a. (Typeable a) => [ConstVal] -> RVar (SimplyTypedLambdaExpression a)
|
|
constantGen ((ConstVal tr rVal) : rest)
|
|
| Just Ref.HRefl <- Ref.typeRep @a `Ref.eqTypeRep` tr = Constant <$> rVal
|
|
| otherwise = constantGen rest
|
|
constantGen [] = error $ "unknown constant " <> show (Ref.typeRep @a)
|
|
|
|
genAbstraction :: forall r a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genAbstraction env tr@(Ref.Fun trA@(Ref.TypeRep) trB@(Ref.TypeRep)) constantTypes sizeLeft bound
|
|
| Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind trA,
|
|
Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind trB = do
|
|
child <- generate env trB constantTypes (sizeLeft - 1) (Map.insertWith (+) (Ref.SomeTypeRep trA) 1 bound)
|
|
return $ Abstraction trA child
|
|
genAbstraction _ tr _ _ _ = error $ "cannot generate Abstraction for " <> show tr
|
|
|
|
-- generate: e:a = e1:b->a e2:b
|
|
-- the by far most complex functions in this module! why?
|
|
-- 1. we need to sensibly limit how insane we make b, favorably without excluding anything completely!
|
|
-- 2. we need this function to heavily lean towards generating an b->a available in Bindings, so we are likely to use any predefined functions... at all
|
|
genApplication :: forall r c a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genApplication env@(LambdaEnviroment {weights}) tr constantTypes sizeLeft bound
|
|
| (sizeLeft <= 0) = genApplicationClosestToCompletion env tr constantTypes bound
|
|
| otherwise = do
|
|
i <- uniform 0 100
|
|
( if i < (functionBias weights) && any (1 >) (mapMaybe (matchedFractionS tr) (Map.keys bound))
|
|
then (genApplicationTowardsBound (maximum (filter (1 >) (mapMaybe (matchedFractionS tr) (Map.keys bound)))) env tr constantTypes sizeLeft bound)
|
|
else (genRandomApplication env tr constantTypes sizeLeft bound)
|
|
)
|
|
|
|
closestFractionMatch :: Ref.TypeRep r -> [Ref.SomeTypeRep] -> Float
|
|
closestFractionMatch tr trs | any (1 >) (mapMaybe (matchedFractionS tr) (trs)) = (maximum (filter (1 >) (mapMaybe (matchedFractionS tr) (trs))))
|
|
| otherwise = 0
|
|
|
|
genRandomApplication :: forall a r c. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genRandomApplication env tr constantTypes sizeLeft bound = do
|
|
t1 <- randomType constantTypes
|
|
genApplicationWithTypeOfS t1 env tr constantTypes sizeLeft bound
|
|
|
|
randomType :: [ConstVal] -> RVar Ref.SomeTypeRep
|
|
randomType constantTypes = do
|
|
functon :: Int <- (uniform 0 100)
|
|
ret <-
|
|
if functon < 25
|
|
then
|
|
( do
|
|
tr1 <- randomType constantTypes
|
|
tr2 <- randomType constantTypes
|
|
return (mkFunTy tr1 tr2)
|
|
)
|
|
else
|
|
( do
|
|
(ConstVal _ (_ :: RVar t1)) <- randomElement constantTypes
|
|
return $ Ref.SomeTypeRep (Ref.TypeRep @t1)
|
|
)
|
|
return ret
|
|
|
|
genApplicationClosestToCompletion :: forall r a. LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genApplicationClosestToCompletion env tr constantTypes bound = do
|
|
(ref) <- nextTypeFromClosestBound tr bound
|
|
genApplicationWithTypeOfS ref env tr constantTypes 0 bound
|
|
|
|
nextTypeFromClosestBound :: Ref.TypeRep r -> Bindings -> RVar Ref.SomeTypeRep
|
|
nextTypeFromClosestBound trB bound = randomElement ((getMinimasByMaybe (sizeMising trB) (filter (matchingTypesS trB) (Map.keys bound))))
|
|
|
|
genApplicationTowardsBound :: forall r c a. Float -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genApplicationTowardsBound matchedFrac env tr constantTypes sizeLeft bound
|
|
| nextMatchedFrac > 0 = do
|
|
(f :: Float) <- uniform 0 1
|
|
bs <- randomElement (filter (\bs -> Just matchedFrac == matchedFractionS tr bs) (Map.keys bound))
|
|
if (f < matchedFrac + 1) then (genApplicationWithTypeOfS ((nextTypeS tr bs)) env tr constantTypes sizeLeft bound) else (genApplicationTowardsBound nextMatchedFrac env tr constantTypes sizeLeft bound)
|
|
| otherwise = do
|
|
bs <- randomElement (filter (\bs -> Just matchedFrac == matchedFractionS tr bs) (Map.keys bound))
|
|
genApplicationWithTypeOfS ((nextTypeS tr bs)) env tr constantTypes sizeLeft bound
|
|
where
|
|
nextMatchedFrac = (if (any (matchedFrac >) (mapMaybe (matchedFractionS tr) (Map.keys bound))) then (maximum (filter (matchedFrac >) (mapMaybe (matchedFractionS tr) (Map.keys bound)))) else 0) --todo nicer!
|
|
|
|
-- how many Base types will need to be generated for bound to fit onto tr. This equals the size of the subtree that needs to be generated.
|
|
sizeMising :: Ref.TypeRep r -> Ref.SomeTypeRep -> Maybe Int
|
|
sizeMising tr (Ref.SomeTypeRep trbs)
|
|
| matchingTypes tr trbs = Just $ (typeDepth tr) - (typeDepth trbs)
|
|
| otherwise = Nothing
|
|
|
|
matchedFractionS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Maybe Float
|
|
matchedFractionS tr (Ref.SomeTypeRep trbs) = matchedFraction tr trbs
|
|
|
|
matchedFraction :: Ref.TypeRep r -> Ref.TypeRep a -> Maybe Float
|
|
matchedFraction tr trbs
|
|
| matchingTypes tr trbs = Just $ fromIntegral (typeDepth trbs) / fromIntegral (typeDepth tr)
|
|
| otherwise = Nothing
|
|
|
|
nextTypeS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Ref.SomeTypeRep
|
|
nextTypeS tr (Ref.SomeTypeRep trbs) = nextType tr trbs
|
|
|
|
nextType :: Ref.TypeRep r -> Ref.TypeRep a -> Ref.SomeTypeRep
|
|
nextType trR@(Ref.Fun (from) (to)) avail
|
|
| Just Ref.HRefl <- (to `Ref.eqTypeRep` avail),
|
|
Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind from =
|
|
Ref.SomeTypeRep from
|
|
| otherwise = nextType to avail
|
|
nextType tra trbs = error ("can't extract nextType from " <> show tra <> " and " <> show trbs)
|
|
|
|
matchingTypesS :: Ref.TypeRep r -> Ref.SomeTypeRep -> Bool
|
|
matchingTypesS tr (Ref.SomeTypeRep trbs) = matchingTypes tr trbs
|
|
|
|
matchingTypes :: Ref.TypeRep a -> Ref.TypeRep b -> Bool
|
|
matchingTypes tra trb | Ref.SomeTypeRep tra == Ref.SomeTypeRep trb = True
|
|
matchingTypes (Ref.Fun _ (traRes :: Ref.TypeRep aRes)) trb = matchingTypes (traRes :: Ref.TypeRep aRes) trb
|
|
matchingTypes _ _ = False
|
|
|
|
typeSize :: Ref.TypeRep r -> Int
|
|
typeSize (Ref.Fun _ trb) = 1 + (typeSize trb)
|
|
typeSize _ = 1
|
|
|
|
typeDepth :: Ref.TypeRep r -> Int
|
|
typeDepth (Ref.Fun _ (trb :: Ref.TypeRep b)) = 1 + (typeDepth (trb :: Ref.TypeRep b))
|
|
typeDepth _ = 1
|
|
|
|
genApplicationWithTypeOfS :: forall r a. Ref.SomeTypeRep -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genApplicationWithTypeOfS (Ref.SomeTypeRep btr@(Ref.TypeRep))
|
|
| Just Ref.HRefl <- Ref.typeRep @Type `Ref.eqTypeRep` Ref.typeRepKind btr = genApplicationWithTypeOfB btr
|
|
genApplicationWithTypeOfS (Ref.SomeTypeRep btr) = error $ "typeRepKind not Type: " <> show (Ref.typeRepKind btr)
|
|
|
|
genApplicationWithTypeOfB :: forall r a (b :: Type). Ref.TypeRep b -> LambdaEnviroment a -> Ref.TypeRep r -> [ConstVal] -> Int -> Bindings -> RVar (SimplyTypedLambdaExpression r)
|
|
genApplicationWithTypeOfB trB@(Ref.TypeRep) env trR@(Ref.TypeRep) constantTypes sizeLeft bound = do
|
|
sizeDistribution <- uniform 0 (sizeLeft - 1)
|
|
right <- generate env trB constantTypes sizeDistribution bound
|
|
left <- generate env (Ref.Fun (Ref.TypeRep @b) trR) constantTypes ((sizeLeft - 1) - sizeDistribution) bound
|
|
return $ Application left right
|
|
|
|
selectWeighted :: [(Int, a)] -> RVar a
|
|
selectWeighted x = do
|
|
let total = Protolude.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)
|
|
|
|
eval :: [BoundSymbol] -> SimplyTypedLambdaExpression ex -> ex
|
|
eval bound (Abstraction rep stle) = lam bound rep stle
|
|
eval bound (Application stleAtoB stleA) = (eval bound stleAtoB) (eval bound stleA)
|
|
eval bound (VariableReference rep inx) = (getSymbolsOfType bound rep) !! inx
|
|
eval _ (Constant res) = res
|
|
|
|
lam :: [BoundSymbol] -> Ref.TypeRep a -> SimplyTypedLambdaExpression (b) -> (a -> b)
|
|
lam bound Ref.TypeRep stle = \(aVal :: a) -> eval (appendToBoundVar bound aVal) stle
|
|
|
|
appendToBoundVar :: (Typeable a) => [BoundSymbol] -> a -> [BoundSymbol]
|
|
appendToBoundVar bv val = bv ++ [BoundSymbol (Ref.typeOf val) val Nothing]
|
|
|
|
listAppend :: (Typeable a) => a -> Maybe [Dynamic] -> Maybe [Dynamic]
|
|
listAppend val (Just dyns) = Just (dyns ++ [toDyn val])
|
|
listAppend val (Nothing) = Just [toDyn val]
|
|
|
|
getMinimasBy :: (Ord b) => (a -> b) -> [a] -> [a]
|
|
getMinimasBy fun as = filter (\a -> fun a == minOverAs) as
|
|
where
|
|
minOverAs = minimum (map fun as)
|
|
|
|
getMinimasByMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> [a]
|
|
getMinimasByMaybe fun as = filter (\a -> fun a == Just minOverAs) as
|
|
where
|
|
minOverAs = minimum (mapMaybe fun as)
|
|
|
|
getMaximasBy :: (Ord b) => (a -> b) -> [a] -> [a]
|
|
getMaximasBy fun as = filter (\a -> fun a == maxOverAs) as
|
|
where
|
|
maxOverAs = maximum (map fun as)
|
|
|
|
getMaximasByMaybe :: (Ord b) => (a -> Maybe b) -> [a] -> [a]
|
|
getMaximasByMaybe fun as = filter (\a -> fun a == Just maxOverAs) as
|
|
where
|
|
maxOverAs = maximum (mapMaybe fun as)
|