module Rewriting where

import Data.List
import Term
import Rule
import TRS

contract :: TRS -> Term -> Maybe (Term, Subst)
contract [] _ = Nothing
contract ((l, r) : rules) t
  | Just sigma <- match l t = Just (r, sigma)
  | otherwise               = contract rules t

normalize :: TRS -> Term -> Subst -> Term
normalize _   s@(V _)  sigma  = Term.substitute s sigma
normalize trs (F f ss) sigma =
  case contract trs t of
    Nothing       -> t
    Just (r, tau) -> normalize trs r tau 
  where
    t = F f [ normalize trs si sigma | si <- ss ]

nf :: TRS -> Term -> Term
nf trs t = normalize trs t []

normal_form :: TRS -> Term -> Bool
normal_form trs t = reducts trs t == []

-- { t | s ->_R^i t for some i <= k }
at_most_k_steps :: Int -> TRS -> Term -> [Term]
at_most_k_steps 0 _ s = [ s ]
at_most_k_steps k trs s =
  nub (s : [ u | t <- reducts trs s, u <- at_most_k_steps (k-1) trs t ])

k_step_reducts' :: TRS -> [Term] ->  [(Int, Term)] -> [Term]
k_step_reducts' _   _  [] = []
k_step_reducts' trs ss ((k, t) : pairs)
  | elem t ss = k_step_reducts' trs ss pairs
  | k == 0    = t : k_step_reducts' trs (t : ss) pairs
  | otherwise =
      case reducts trs t of
        [] -> t : k_step_reducts' trs (t : ss) pairs
        us -> k_step_reducts' trs ss (pairs ++ [ (k-1,u) | u <- us ])

k_step_reducts :: Int -> TRS -> Term -> [Term]
k_step_reducts k trs t = k_step_reducts' trs [] [(k, t)]

at_most_k_walks :: Int -> TRS -> Term -> [(Term, [(Term, Term)])]
at_most_k_walks 0 _ s = [ (s, []) ]
at_most_k_walks k trs s =
  nub (ts ++ [ (u, nub (lr:rs)) | lr <- trs, (t,rs) <- ts, u <- reducts [lr] t ])
    where
      ts = at_most_k_walks (k-1) trs s

partially_normalize :: Int -> TRS -> Term -> Term
partially_normalize _ _   s@(V _) = s
partially_normalize k trs s@(F f ss)
  | Just u <- find (\v -> normal_form trs v) (at_most_k_steps k trs s) = u
  | otherwise = F f [ partially_normalize k trs si | si <- ss ]


-- { t | s ->_R^epsilon t }
rootStep :: TRS -> Term -> [Term]
rootStep trs s =
  [ Term.substitute r sigma | (l, r) <- trs, Just sigma <- [match l s] ]

-- { t | s -||->_R t }
parallelStep :: TRS -> Term -> [Term]
parallelStep _ s@(V _) = [s]
parallelStep trs s@(F f ss) =
  nub (s : rootStep trs s ++
       [ F f ts | ts <- sequence [ parallelStep trs si | si <- ss ] ])

-- { (rule, t) | s ->_rule^epsilon t }
rootStepWithRule :: TRS -> Term -> [(Rule, Term)]
rootStepWithRule trs s =
  [ ((l, r), Term.substitute r sigma) 
  | (l, r) <- trs, 
    Just sigma <- [match l s] ]

stepWithRule :: TRS -> Term -> [(Rule, Term)]
stepWithRule trs s =
  [ ((l, r), Term.replace s t p)
  | p <- Term.positions s,
    ((l, r), t) <- rootStepWithRule trs (subterm_at s p)]

parallelStepWithRule :: TRS -> Term -> [(TRS, Term)]
parallelStepWithRule _ s@(V _)    = [([], s)]
parallelStepWithRule trs s@(F f ss) =
  nub ([ ([rule], t) 
       | (rule, t) <- rootStepWithRule trs s ] ++
       [ (nub (concat ruless), F f ts) 
       | pairs <- sequence [ parallelStepWithRule trs si | si <- ss ],
         let (ruless, ts) = unzip pairs ])

-- variable-restricted parallel step
-- { (S, t) | S subseteq R, s -||->_S^P t and Var(t, P) subseteq X }
restrictedParallelStep :: TRS -> [String] -> Term -> [(TRS, Term)]
restrictedParallelStep _ _ s@(V _)    = [([], s)]
restrictedParallelStep trs xs s@(F f ss) =
  nub ([ ([rule], t) 
       | (rule, t) <- rootStepWithRule trs s, 
         subset (Term.variables t) xs ] ++
       [ (nub (concat ruless), F f ts) 
       | pairs <- sequence [ restrictedParallelStep trs xs si | si <- ss ],
         let (ruless, ts) = unzip pairs ])
