forked from GitHub/gf-core
change the PGF.Data.Exp type
This commit is contained in:
krasimir
@@ -41,19 +41,16 @@ data Type =
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Exp =
|
||||
DTr [CId] Atom [Exp]
|
||||
EAbs [CId] Exp
|
||||
| EApp CId [Exp]
|
||||
| EStr String
|
||||
| EInt Integer
|
||||
| EFloat Double
|
||||
| EMeta Integer
|
||||
| EVar CId
|
||||
| EEq [Equation]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Atom =
|
||||
AC CId
|
||||
| AS String
|
||||
| AI Integer
|
||||
| AF Double
|
||||
| AM Integer
|
||||
| AV CId
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Term =
|
||||
R [Term]
|
||||
| P Term Term
|
||||
|
||||
@@ -11,13 +11,13 @@ import System.Random
|
||||
generate :: GFCC -> CId -> Maybe Int -> [Exp]
|
||||
generate gfcc cat dp = concatMap (\i -> gener i cat) depths
|
||||
where
|
||||
gener 0 c = [tree (AC f) [] | (f, ([],_)) <- fns c]
|
||||
gener 0 c = [EApp f [] | (f, ([],_)) <- fns c]
|
||||
gener i c = [
|
||||
tr |
|
||||
(f, (cs,_)) <- fns c,
|
||||
let alts = map (gener (i-1)) cs,
|
||||
ts <- combinations alts,
|
||||
let tr = tree (AC f) ts,
|
||||
let tr = EApp f ts,
|
||||
depth tr >= i
|
||||
]
|
||||
fns c = [(f,catSkeleton ty) | (f,ty) <- functionsToCat gfcc c]
|
||||
@@ -36,16 +36,16 @@ genRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0 :: Double) gen) cat where
|
||||
(genTrees ds2 cat) -- else (drop k ds)
|
||||
|
||||
genTree rs = gett rs where
|
||||
gett ds cid | cid == mkCId "String" = (tree (AS "foo") [], 1)
|
||||
gett ds cid | cid == mkCId "Int" = (tree (AI 12345) [], 1)
|
||||
gett [] _ = (tree (AS "TIMEOUT") [], 1) ----
|
||||
gett ds cid | cid == mkCId "String" = (EStr "foo", 1)
|
||||
gett ds cid | cid == mkCId "Int" = (EInt 12345, 1)
|
||||
gett [] _ = (EStr "TIMEOUT", 1) ----
|
||||
gett ds cat = case fns cat of
|
||||
[] -> (tree (AM 0) [],1)
|
||||
[] -> (EMeta 0,1)
|
||||
fs -> let
|
||||
d:ds2 = ds
|
||||
(f,args) = getf d fs
|
||||
(ts,k) = getts ds2 args
|
||||
in (tree (AC f) ts, k+1)
|
||||
in (EApp f ts, k+1)
|
||||
getf d fs = let lg = (length fs) in
|
||||
fs !! (floor (d * fromIntegral lg))
|
||||
getts ds cats = case cats of
|
||||
|
||||
@@ -26,25 +26,21 @@ realize trm = case trm of
|
||||
_ -> "ERROR " ++ show trm ---- debug
|
||||
|
||||
linExp :: GFCC -> CId -> Exp -> Term
|
||||
linExp mcfg lang tree@(DTr xs at trees) =
|
||||
addB $ case at of
|
||||
AC fun -> comp (map lin trees) $ look fun
|
||||
AS s -> R [kks (show s)] -- quoted
|
||||
AI i -> R [kks (show i)]
|
||||
--- [C lst, kks (show i), C size] where
|
||||
--- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1
|
||||
AF d -> R [kks (show d)]
|
||||
AV x -> TM (prCId x)
|
||||
AM i -> TM (show i)
|
||||
where
|
||||
lin = linExp mcfg lang
|
||||
comp = compute mcfg lang
|
||||
look = lookLin mcfg lang
|
||||
addB t
|
||||
| Data.List.null xs = t
|
||||
| otherwise = case t of
|
||||
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
|
||||
TM s -> R $ t : (Data.List.map (kks . prCId) xs)
|
||||
linExp gfcc lang = lin
|
||||
where
|
||||
lin (EAbs xs e ) = case lin e of
|
||||
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
|
||||
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs)
|
||||
lin (EApp fun es) = comp (map lin es) $ look fun
|
||||
lin (EStr s ) = R [kks (show s)] -- quoted
|
||||
lin (EInt i ) = R [kks (show i)]
|
||||
lin (EFloat d ) = R [kks (show d)]
|
||||
lin (EVar x ) = TM (prCId x)
|
||||
lin (EMeta i ) = TM (show i)
|
||||
|
||||
comp = compute gfcc lang
|
||||
look = lookLin gfcc lang
|
||||
|
||||
|
||||
compute :: GFCC -> CId -> [Term] -> Term -> Term
|
||||
compute mcfg lang args = comp where
|
||||
|
||||
@@ -62,12 +62,9 @@ functionsToCat gfcc cat =
|
||||
fs = lookMap [] cat $ catfuns $ abstract gfcc
|
||||
|
||||
depth :: Exp -> Int
|
||||
depth tr = case tr of
|
||||
DTr _ _ [] -> 1
|
||||
DTr _ _ ts -> maximum (map depth ts) + 1
|
||||
|
||||
tree :: Atom -> [Exp] -> Exp
|
||||
tree = DTr []
|
||||
depth (EAbs _ t) = depth t
|
||||
depth (EApp _ ts) = maximum (0:map depth ts) + 1
|
||||
depth _ = 1
|
||||
|
||||
cftype :: [CId] -> CId -> Type
|
||||
cftype args val = DTyp [Hyp wildCId (cftype [] arg) | arg <- args] val []
|
||||
@@ -88,9 +85,6 @@ contextLength :: Type -> Int
|
||||
contextLength ty = case ty of
|
||||
DTyp hyps _ _ -> length hyps
|
||||
|
||||
exp0 :: Exp
|
||||
exp0 = tree (AM 0) []
|
||||
|
||||
primNotion :: Exp
|
||||
primNotion = EEq []
|
||||
|
||||
|
||||
@@ -180,8 +180,8 @@ applyProfileToForest (FMeta) = [FMeta]
|
||||
|
||||
|
||||
forest2exps :: SyntaxForest CId -> [Exp]
|
||||
forest2exps (FNode n forests) = map (DTr [] (AC n)) $ forests >>= mapM forest2exps
|
||||
forest2exps (FString s) = [DTr [] (AS s) []]
|
||||
forest2exps (FInt n) = [DTr [] (AI n) []]
|
||||
forest2exps (FFloat f) = [DTr [] (AF f) []]
|
||||
forest2exps (FMeta) = [DTr [] (AM 0) []]
|
||||
forest2exps (FNode n forests) = map (EApp n) $ forests >>= mapM forest2exps
|
||||
forest2exps (FString s) = [EStr s]
|
||||
forest2exps (FInt n) = [EInt n]
|
||||
forest2exps (FFloat f) = [EFloat f]
|
||||
forest2exps (FMeta) = [EMeta 0]
|
||||
|
||||
@@ -107,15 +107,14 @@ toHypo e = case e of
|
||||
|
||||
toExp :: RExp -> Exp
|
||||
toExp e = case e of
|
||||
App "App" [App fun [], App "B" xs, App "X" exps] ->
|
||||
DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (map toExp exps)
|
||||
App "Eq" eqs ->
|
||||
EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
|
||||
App "Var" [App i []] -> DTr [] (AV (mkCId i)) []
|
||||
AMet -> DTr [] (AM 0) []
|
||||
AInt i -> DTr [] (AI i) []
|
||||
AFlt i -> DTr [] (AF i) []
|
||||
AStr i -> DTr [] (AS i) []
|
||||
App "Abs" [App "B" xs, exp] -> EAbs [mkCId x | App x [] <- xs] (toExp exp)
|
||||
App "App" (App fun [] : exps) -> EApp (mkCId fun) (map toExp exps)
|
||||
App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
|
||||
App "Var" [App i []] -> EVar (mkCId i)
|
||||
AMet -> EMeta 0
|
||||
AInt i -> EInt i
|
||||
AFlt i -> EFloat i
|
||||
AStr i -> EStr i
|
||||
_ -> error $ "exp " ++ show e
|
||||
|
||||
toTerm :: RExp -> Term
|
||||
@@ -173,14 +172,14 @@ fromHypo e = case e of
|
||||
|
||||
fromExp :: Exp -> RExp
|
||||
fromExp e = case e of
|
||||
DTr xs (AC fun) exps ->
|
||||
App "App" [App (prCId fun) [], App "B" (map (flip App [] . prCId) xs), App "X" (map fromExp exps)]
|
||||
DTr [] (AV x) [] -> App "Var" [App (prCId x) []]
|
||||
DTr [] (AS s) [] -> AStr s
|
||||
DTr [] (AF d) [] -> AFlt d
|
||||
DTr [] (AI i) [] -> AInt (toInteger i)
|
||||
DTr [] (AM _) [] -> AMet ----
|
||||
EEq eqs ->
|
||||
EAbs xs exp -> App "Abs" [App "B" (map (flip App [] . prCId) xs), fromExp exp]
|
||||
EApp fun exps -> App "App" (App (prCId fun) [] : map fromExp exps)
|
||||
EVar x -> App "Var" [App (prCId x) []]
|
||||
EStr s -> AStr s
|
||||
EFloat d -> AFlt d
|
||||
EInt i -> AInt (toInteger i)
|
||||
EMeta _ -> AMet ----
|
||||
EEq eqs ->
|
||||
App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]
|
||||
_ -> error $ "exp " ++ show e
|
||||
|
||||
|
||||
@@ -77,7 +77,7 @@ recordLinearize gfcc lang = prRecord . recLinearize gfcc lang
|
||||
recLinearize :: GFCC -> CId -> Exp -> Record
|
||||
recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where
|
||||
typ = case exp of
|
||||
DTr _ (AC f) _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f
|
||||
EApp f _ -> lookParamLincat gfcc lang $ valCat $ lookType gfcc f
|
||||
|
||||
-- show GFCC term
|
||||
termLinearize :: GFCC -> CId -> Exp -> String
|
||||
|
||||
Reference in New Issue
Block a user