{- $Id: Gener.hs,v 1.12.2.3 2009/02/20 18:00:02 orlov Exp $ -}
{- vim: set syntax=haskell expandtab tabstop=4: -}
module Gener {-(
genStates
)-} where
import Prelude hiding (Num (negate))
import List (maximumBy, nubBy)
import XSG hiding (State)
import PPT
------------------------------------------------------------------
type GTab = [((Exp, Exp), Var)]
type GenData = (GTab, (Exps, Terms, Terms), (Exps, Terms, Terms))
type FuncIO = (Vars, Exps)
type State = (Terms, Exps)
type XState = (Vars, State)
------------------------------------------------------------------
instance Show XState where
showsPrec 0 (vs, st) = shows vs . (" ==> " ++) . shows st
instance Show (XState, XState, XState) where
showsPrec 0 (xst1, xst2, xst3) = shows xst1 . ("\n" ++) .
shows xst2 . ("\n" ++).
shows xst3
------------------------------- GEN ------------------------------
class GEN a where
mkT :: a -> a -> Index -> GTab
gen :: a -> a -> GTab -> a
instance GEN Var where
mkT vF@(L _) vG@(L _) idx = [((v2e vF, v2e vG), L idx)]
gen vF@(L _) vG@(L _) tab = head [v | (es, v) <- tab,
es==(v2e vF, v2e vG)]
instance GEN Exp where
mkT eF eG idx = mkT' [] eF eG idx
where mkT' ps (C cNF esF) (C cNG esG) idx | (fst cNF)==(fst cNG) =
if ((snd cNF)==(snd cNG) ||
(cNF, cNG) `elem` ps ||
(cNG, cNF) `elem` ps)
then []
else concat $ zipWith3 (mkT' ((cNF,cNG):ps)) esF esG (newIdxs idx)
mkT' ps eF eG idx = [((eF, eG), X idx)]
gen (C cNF esF)
(C cNG esG) tab | (fst cNF)==(fst cNG) = C cNF (gen esF esG tab)
gen eF eG tab = head [v2e v | (es, v) <- tab, es==(eF,eG)]
instance GEN Term where
mkT (vsF := (fNF, esF))
(vsG := (fNG, esG)) idx | fNF==fNG = mkT esF esG idx
gen (vsF := (fNF, esF))
(vsG := (fNG, esG)) tab | fNF==fNG = ((gen vsF vsG tab) := (fNF, gen esF esG tab))
instance GEN Branch where
mkT (tsF, [], esF) (tsG, [], esG) idx = mkT (tsF, esF) (tsG, esG) idx
gen (tsF, [], esF) (tsG, [], esG) tab = (gen tsF tsG tab, [], gen esF esG tab)
instance GEN a => GEN [a] where
mkT xsF xsG idx = concat $ zipWith3 mkT xsF xsG (newIdxs idx)
gen xsF xsG tab = zipWith3 gen xsF xsG (repeat tab)
instance (GEN a, GEN b) => GEN (a, b) where
mkT (xsF, ysF) (xsG, ysG) idx = (mkT xsF xsG idx1)++(mkT ysF ysG idx2) where idx1:idx2:_ = newIdxs idx
---------------------------- GENSTATES ---------------------------
instance Eq Term where
t1 == t2 = (getTid t1)==(getTid t2)
instance Eq Exp where
(VAR v1 ) == (VAR v2 ) = v1==v2
(C cN1 _) == (C cN2 _) = cN1==cN2
_ == _ = False
simplifyGTab :: GTab -> GTab
simplifyGTab = nubBy (\x1 x2 -> (fst x1)==(fst x2))
findPretend :: GTab -> Terms -> Terms -> Maybe (Term, Term)
findPretend tab tsF tsG =
findNext [(weight (zip vsF vsG), (tF, tG)) |
tF@(vsF:=(fNF, _)) <- tsF,
tG@(vsG:=(fNG, _)) <- tsG, fNF==fNG]
where pairs = [(vF, vG) | ((VAR vF, VAR vG), _) <- tab]
weight xs = length (filter (`elem` xs) pairs)
comp x1 x2 = compare (fst x1) (fst x2)
findNext [] = Nothing
findNext xs = Just (snd (maximumBy comp xs))
genLoop :: GenData -> Index -> GenData
genLoop gData@(tab, (esF, gtsF, tsF), (esG, gtsG, tsG)) idx =
case findPretend tab tsF tsG of
Nothing -> gData
Just (tF, tG) -> genLoop gData' idx1
where ptsF = (esF, gtsF+.[tF], tsF-.[tF])
ptsG = (esG, gtsG+.[tG], tsG-.[tG])
gData' = (tab++(mkT tF tG idx2), ptsF, ptsG)
idx1:idx2:_ = newIdxs idx
ioFGH :: GTab -> Terms -> Terms -> (FuncIO, FuncIO, FuncIO)
ioFGH tab tsF tsG = ((vLsF, esF), (vLsG, esG), (vXsH, eLsH))
where (esF , esG , vXsH) =
unzip3 [(eF, eG, vH) | ((eF, eG), vH@(X _)) <- tab]
(vLsF, vLsG, eLsH) =
unzip3 [(vF, vG, eH) | ((eF, eG), vH@(L _)) <- tab,
let vF = e2v eF
vG = e2v eG
eH = v2e vH
vsF = (getLVars esF)+.(rhsLVars tsF)
vsG = (getLVars esG)+.(rhsLVars tsG),
vF `elem` vsF || vG `elem` vsG]
mkXStateFG :: Vars -> Terms -> FuncIO -> Index -> XState
mkXStateFG vXs ts (vLs, es) idx = (vXs++vLs, (ts, es))/.s
where s = zipWith (:->) vLs (map (v2e.X) $ newIdxs idx)
mkXStateH :: Terms -> Exps -> FuncIO -> XState
mkXStateH tsH esH (vXsH, eLsH) =(vXsH, (tsH, esH++eLsH))
lhsVars :: Terms -> Vars
lhsVars = getVars . map (\(vs:=_) -> vs)
rhsLVars :: Terms -> Vars
rhsLVars = getLVars . map (\(_:=(_,es)) -> es)
genStates :: Branch -> Branch -> Index -> (XState, XState, XState)
genStates stF@(tsF, _, esF0) stG@(tsG, _, esG0) idx = (xstH, xstF, xstG)
where (tsF0, tsG0) = unzip [(tF, tG) | tF <- tsF, tG <- tsG, (getTid tF)==(getTid tG)]
tab0 = mkT (tsF0, esF0) (tsG0, esG0) idx1
gData0 = (tab0, (esF0, tsF0, tsF-.tsF0), (esG0, tsG0, tsG-.tsG0))
gData1 = genLoop gData0 idx2
(tab1, (esF1, gtsF1, tsF1), (esG1, gtsG1, tsG1)) = gData1
tab2 = mkT (lhsVars gtsF1) (lhsVars gtsG1) idx3
tab3 = simplifyGTab (tab2++tab1)
(ioF, ioG, ioH) = ioFGH tab3 tsF1 tsG1
xstF = mkXStateFG (getXVars stF) tsF1 ioF idx4
xstG = mkXStateFG (getXVars stG) tsG1 ioG idx5
xstH = mkXStateH (gen gtsF1 gtsG1 tab3) (gen esF1 esG1 tab3) ioH
idx1:idx2:idx3:idx4:idx5:_ = newIdxs idx
------------------------------------------------------------------
state1 = (
[
[L [1]] := ("F", [VAR (L [4])]),
[L [2]] := ("G", [VAR (L [3])]),
[L [3], L [4]] := ("H", [VAR (X [11])])
]
,[],
[VAR (L [1]), VAR (L [2])]
)
state2 = (
[
[L [10]] := ("F", [C ("123",[]) [VAR (L [40])]]),
[L [20]] := ("G", [VAR (L [30])]),
[L [30], L [40]] := ("H", [VAR (X [110])])
]
,[],
[VAR (L [10]), VAR (L [20])]
)
t = genStates state1 state2 [570]
{-
e1 = C "CONS" [C "C1" [], C "C1" []]
e2 = C "CONS" [C "C2" [], C "C2" []]
test = gen [e1, e1] [e2, e1] (mkT [e1, e1] [e2, e1] [57])
stateA = [
RES [VAR (L [1]), VAR (L [2])],
[L [1]] := (CALL "F" [VAR (X [4])]),
[L [2]] := (CALL "F" [VAR (X [3])])
]
stateB = [
RES [VAR (L [10]), VAR (L [20])],
[L [10]] := (CALL "F" [VAR (X [30])]),
[L [20]] := (CALL "F" [VAR (X [30])])
]
tt = genStates stateA stateB [570]
-}