-- Parallel critical pairs (Toyama 1981).

module PCP where

import Data.List
import Term
import Rule
import TRS

type CP = (Term, Rule, Position, Term, Rule, Term)

-- PCP
type CritPairInfo = (Term, [Position], Term, Term, Maybe (Int, Int), [Term])

show_parallel_peak :: CritPairInfo -> String
show_parallel_peak (t, _, s, u, _, _) =
  "  " ++ show t ++ " <-||- " ++ show s ++ " -> " ++ show u

show_PCPs :: [CritPairInfo] -> String
show_PCPs [] = 
  unlines ["  (no peaks/pairs)"]
show_PCPs diagrams =
  unlines [ show_parallel_peak diagram | diagram <- diagrams ]

-- critical peaks
critical_peaks :: TRS -> [CP]
critical_peaks trs =
  [ (replace l2sigma (Term.substitute r1 sigma) p,
     (l1, r1),
     p,
     l2sigma,
     (l2, r2),
     Term.substitute r2 sigma)
  | (l2, r2) <- TRS.rename "y" 1 trs,
    p <- function_positions l2,
    let l2p = subterm_at l2 p,
    (l1, r1) <- TRS.rename "x" 1 trs,
    p /= [] || not (Rule.variant (l1, r1) (l2, r2)),
    Just sigma <- [mgu l1 l2p],
    let l2sigma = Term.substitute l2 sigma ]

data LabeledTerm =
    LV String
  | LF String [(Rule, Rule, Subst)] [LabeledTerm]
  deriving Show

-- R<-||- ->_{l -> r}
type PCP = (Term, TRS, [Position], [String], Term, Rule, Term)

label' :: Int -> TRS -> Term -> Maybe Term -> (Int, LabeledTerm)
label' k _ (V x) _ = (k, LV x)
label' k trs s@(F f ss) mt =
  (k1, LF f [ ((l, r), Rule.substitute (l, r) sigma, sigma)
            | rule <- trs,
              case mt of
                Nothing -> True
                Just t -> not (Rule.variant (s, t) rule),
              let (l, r) = Rule.rename ("x" ++ show k ++ "_") 1 rule,
              Just sigma <- [mgu l s] ]
            lts)
  where (k1, lts) = labelTerms (k+1) trs ss

labelTerms :: Int -> TRS -> [Term] -> (Int, [LabeledTerm])
labelTerms k _   []       = (k, [])
labelTerms k trs (s : ss) = (k2, lt : lts)
  where
    (k1, lt)  = label' k trs s Nothing
    (k2, lts) = labelTerms k1 trs ss

label :: TRS -> Term -> Term -> LabeledTerm
label trs l r = lt
  where (_, lt) = label' 0 trs l (Just r)

pcp1 :: LabeledTerm -> [(Term, TRS, [Position], [String], Subst, Bool)]
pcp1 (LV x) = [(V x, [], [], [], [], False)]
pcp1 (LF f redexes lts) =
    [ (t, [lr], [[]], Term.variables s, sigma, True)
    | (lr, (s, t), sigma) <- redexes ] ++
    [ (F f ts,
       nub (concat rs), 
       [ i : p | (i, ps) <- zip [0..] pss, p <- ps ],
       nub (concat xss),  
       concat sigmas, 
       or bs)
    | tuples <- sequence [ pcp1 lti | lti <- lts ],
      let (ts, rs, pss, xss, sigmas, bs) = unzip6 tuples
    ]

-- This definition includes parallel critical pairs 
-- of form t <-||-_P . -> u with P empty.
pcp :: TRS -> [(Term, (TRS, Rule), [String], Term)]
pcp trs =
  nub [ (t, (rs, rule), xs, Term.substitute r sigma)
      | rule <- trs,
        let (l, r) = Rule.rename "y" 1 rule,
        (t, rs, _, xs, sigma, True) <- pcp1 (label trs l r) ]

pcpeak :: TRS -> [PCP]
pcpeak trs =
  nub [ (t, rs, ps, xs, Term.substitute l sigma, rule, Term.substitute r sigma)
      | rule <- trs,
        let (l, r) = Rule.rename "y" 1 rule,
        (t, rs, ps, xs, sigma, True) <- pcp1 (label trs l r) ]

