483 lines
24 KiB
Haskell
483 lines
24 KiB
Haskell
|
{-# LANGUAGE GADTs #-}
|
||
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||
|
|
{-# LANGUAGE Trustworthy #-}
|
||
|
|
{-# LANGUAGE TypeApplications #-}
|
||
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||
|
|
|
||
|
|
module LambdaCalculus where
|
||
|
|
|
||
|
|
import Data.Dynamic
|
||
|
|
import Data.List (foldr1, last, lookup, zipWith3, (!!), (\\))
|
||
|
|
import Data.List.Extra (delete, nubOrd, nubOrdOn)
|
||
|
|
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.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 = 1,
|
||
|
|
symbol = 1,
|
||
|
|
variable = 1,
|
||
|
|
constant = 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
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)
|
||
|
|
|
||
|
|
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)
|
||
|
|
|
||
|
|
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 3
|
||
|
|
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
|
||
|
|
|
||
|
|
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
|
||
|
|
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))
|
||
|
|
|
||
|
|
|
||
|
|
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
|
||
|
|
|
||
|
|
replaceAtR:: Int -> TypeRequester -> TypeRequester -> TypeRequester
|
||
|
|
replaceAtR 0 _ with = with
|
||
|
|
replaceAtR i (TR tm (Just le) bV) with = TR tm (Just (replaceAt (i-1) le with)) bV
|
||
|
|
replaceAtR _ (TR _ Nothing _) _ = undefined
|
||
|
|
|
||
|
|
-- LambdaSpucker TypeRequester TypeRequester BoundVars | LambdaSchlucker TypeRequester BoundVars | Symbol ConVal [TypeRequester] BoundVars | Var TypeRep Int [TypeRequester] BoundVars | Constan ConVal
|
||
|
|
|
||
|
|
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 0 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))
|