module Tupling (doTupling, getInverse) where

import ParseTree
import Data.List ( (\\), union, elemIndex )
import Data.Maybe (fromJust)


tpcons = Constructor "#" undefined -- TODO: undefined??

getInverse :: ParseTree a -> ParseTree a
getInverse tdecls =
    map getInv tdecls
    where
      getInv (Decl (l,r,w) n) = let (l',r') = getInvPair (l,r) 
                                in Decl (l',r',map getInvPair w) n
      getInvPair (l,r) = 
          case l of 
            SNode (Function f a) pt ->
                case r of 
                  SNode (Constructor c a) es | (Constructor c a) ==  tpcons ->
                       ( SNode (Function (convName f) a) es, mkTp pt  )
                  _ ->
                      ( SNode (Function (convName f) a) [r], mkTp pt  )
            SNode (Constructor c a) vs | (Constructor c a) == tpcons ->
                case r of
                  SNode (Function f a) es ->
                      ( mkTp es, SNode (Function (convName f) a) vs )
            SNode (Variable v a) _ ->
                case r of
                  SNode (Function f a) es ->
                      ( mkTp es, SNode (Function (convName f) a) [l] )
      mkTp [l] = l 
      mkTp ls  = SNode tpcons ls
      convName (f) = f ++ "#Inv"
                       
                        
                      

doTupling :: ParseTree a -> ParseTree a -> ParseTree a 
doTupling decls decls' = 
    let (tdecls, injsymbs) = 
            foldr (\(decl, decl') (tdecls,injsymbs) ->
                       let (tdecl, isymbs) = tupling_decl decl decl' 
                       in  ( tdecl:tdecls, isymbs `union` injsymbs) ) ([],[]) $ zip decls decls'
    in  tdecls ++ getDecl injsymbs decls 
    where
      getDecl symbs decls = 
          case decls of 
            (d@(Decl (SNode f ps,r,w) n)):restdecls ->
                if elem f symbs then
                    convW d:getDecl symbs restdecls
                else
                    getDecl symbs restdecls
            [] -> []
      convW (d@(Decl (l,r,_) n)) = Decl (l,tr,w) n
          where 
            funcs    = calledFuncs d 
            tr       = replaceFc basename funcs r
            basename = "*c" 
            w        = map (\i -> (mkL i, mkR i)) $ [0..length funcs -1]
                where mkL i = SNode (Variable (basename++show i) undefined) []
                      mkR i = funcs !! i
      mkNewFSymb (Function f a) = Function ('#':f) a
      mkNewFSymb symb           = symb 
      mkNewFSymbS (SNode s ss)  = SNode (mkNewFSymb s) ss
      tupling_decl decl decl' =
          ( Decl (mkNewFSymbS (lhs decl), SNode tpcons [tr,tr'], w) nn, sfuncs \\ sfuncs' )
          where 
            nn       = let Decl _ n = decl in n
            funcs    = calledFuncs decl  -- We assume that funcs' is subsequnce of func  
            sfuncs   = calledSymbols decl
            sfuncs'  = map rmPrefix $ calledSymbols decl'
            tr       = replaceFc basename  funcs (rhs decl)
            tr'      = replaceFc basename' (map addPrefixT funcs) (rhs decl')
            basename  = "*a"
            basename' = "*b"
            w        = map (\i -> (mkL i, mkR i)) $ [0..length funcs-1]
                where isFoundBoth i = 
                          let sf = sfuncs !! i 
                          in elem sf sfuncs'
                      mkL i = if isFoundBoth i then 
                                  SNode tpcons [SNode (Variable (basename++show i) undefined) []
                                               ,SNode (Variable (basename'++show i) undefined) []]
                              else 
                                  SNode (Variable (basename++show i) undefined) []
                      mkR i = if isFoundBoth i then
                                  mkNewFSymbS $ funcs !! i
                              else 
                                  funcs !! i
            rmPrefix (Function ('_':f) a) = Function f a 
            rmPrefix symb                 = symb
            addPrefixT (SNode (Function f a) es) = SNode (Function ('_':f) a) es 
            addPrefixT t                         = t
      replaceFc bn fs exp = 
          case exp of 
            SNode (Constructor c a) es ->
                SNode (Constructor c a) (map (replaceFc bn fs) es)
            SNode (Function f a) es ->
                SNode (Variable (bn++show (fromJust $ elemIndex exp fs)) a) []
            SNode (Variable v a) es ->
                SNode (Variable v a) es
