module O24 where

import Data.List
import TRS
import Proof
import PCP
import Rule
import Term
import SMT
import SN

at_most_k_steps :: Bool -> Int -> TRS -> Term -> [([Term], [Rule])]
at_most_k_steps _ 0 _   s = [ ([s], []) ]
at_most_k_steps allsequences k trs s
  | allsequences = trss ++ [ (u : ts, nub (rule : rules)) | (ts@(t : _), rules) <- trss, (u, rule) <- reductsRules trs t ]
  |otherwise  = nubBy eq (trss ++ [ (u : ts, nub (rule : rules)) | (ts@(t : _), rules) <- trss, (u, rule) <- reductsRules trs t ])
  where 
    eq ((v : _), _) ((w : _), _) = v == w
    eq _       _       = error "at_most_k_steps"
    trss = at_most_k_steps allsequences (k-1) trs s

rule_index' :: Int -> TRS -> Rule -> Maybe Int
rule_index' _ [] _ = Nothing
rule_index' i (rule' : rules) rule
  | Rule.variant rule rule' = Just i
  | otherwise               = rule_index' (i + 1) rules rule

rule_index :: TRS -> Rule -> Maybe Int
rule_index table rule = rule_index' 0 table rule

in_S :: TRS -> Rule -> Formula
in_S table rule
  | Just i <- rule_index table rule = FVar ("in_S_" ++ show i)
  | otherwise                       = error "in_S"

in_FunS :: String -> Formula
in_FunS f = FVar ("inFunS_" ++ f)

rules_of_join_sequence :: Bool -> Int -> TRS -> Term -> Term -> [TRS]
rules_of_join_sequence allsequences k trs t u
  | t == u    = [[]]
  | otherwise = [ nub (rules ++ rules') | (v : _, rules) <- trss, (v' : _, rules') <- urss, v == v']
  where trss = at_most_k_steps allsequences k trs t
        urss = at_most_k_steps allsequences k trs u

rules_of_to_sequence :: Int -> TRS -> Term -> Term -> [TRS]
rules_of_to_sequence k trs t u
  | t == u = [[]]
  | otherwise = [rules | (v : _, rules) <- at_most_k_steps True k trs t, v == u]

subset_of_S :: TRS -> TRS -> Formula
subset_of_S table trs = conj [ in_S table rule | rule <- trs ]

subset_of_FunS :: [String] -> Formula
subset_of_FunS fs = conj [ in_FunS f | f <- fs ]

-- persistency
in_G :: String -> Formula
in_G f = FVar ("in_G_" ++ f)

sort_of_variable :: String -> Exp
sort_of_variable x = Var ("sort_var_" ++ x)

sort_of_function :: String -> Int -> Exp
sort_of_function f i = Var ("sort_func_" ++ f ++ show i)

tau_hat :: Term -> Exp
tau_hat (V x) = sort_of_variable x
tau_hat (F f _) = sort_of_function f 0

sort_star :: Exp
sort_star = Val 0

well_sorted :: Term -> Formula
well_sorted (V _) = top
well_sorted (F f ts) =
    conj
        [conj [well_sorted' (sort_of_function f i) t, well_sorted t]
        | (i, t) <- zip [1..] ts]

well_sorted' :: Exp -> Term -> Formula
well_sorted' x (V y) = Eq x (sort_of_variable y)
well_sorted' x (F f _) = Eq x (sort_of_function f 0)

encode_rule_removal :: RuleRemoval -> Int -> TRS -> Formula
encode_rule_removal Modularity k trs =
  conj
    (neg (subset_of_S table trs) : 
     [ implies (in_S table rule) (subset_of_FunS (Rule.functions rule)) 
     | rule <- trs ] ++
     [ implies (subset_of_FunS (Term.functions l))
               (disj [ subset_of_S table ss
                     | ss <- rules_of_to_sequence k trs l r])
     | (l, r) <- trs ])
  where table = trs
encode_rule_removal Persistency k trs =
  conj
    (neg (subset_of_S table trs) :
    [conj
      [conj
        [implies (in_S table rule)
                 (conj
                    [well_sorted l,
                     well_sorted r,
                     Eq (tau_hat l) (tau_hat r),
                     neg (Eq (tau_hat l) sort_star)]),
         implies (conj
                    [well_sorted l,
                     neg (Eq (tau_hat l) sort_star)])
                 (disj
                    [subset_of_S table ss
                    | ss <- rules_of_to_sequence k trs' l r])]
    | rule@(l, r) <- trs'],
    conj
      [conj
        [implies (in_G f)
                 (conj [neg (Eq (sort_of_function f i) sort_star) | i <- [0..n]]),
        implies  (neg (in_G f))
                 (conj [Eq (sort_of_function f i) sort_star | i <- [0..n]])]
        | (f, n) <- TRS.signature_of trs']])
  where trs' = [Rule.rename ("x_" ++ show i ++ "_") 0 rule | (rule, i) <- zip trs [0::Int ..]]
        table = trs'

encode_peaks :: Bool -> Int -> TRS -> [PCP] -> Formula
encode_peaks allsequences k trs peaks =
  conj [ disj [subset_of_S table (rule : rules),
               disj [ subset_of_S table ss
                    | ss <- rules_of_join_sequence allsequences k trs t u ]] 
       | (t, rules, _, _, _, rule, u) <- peaks ]
  where
    table = trs

encode :: Bool -> Int -> RuleRemoval -> TRS -> [PCP] -> Formula
encode allsequences k rr trs peaks = 
  conj [encode_peaks allsequences k trs peaks,
        encode_rule_removal rr k trs]

decode_S :: TRS -> Model -> TRS
decode_S table model = 
  [ rule | rule <- table, eval_formula model (in_S table rule)]

value_of :: Model -> Exp -> String
value_of model (Var x)
  | Just 0 <- v = "*"
  | Just i <- v = show i
  | otherwise = "-"
  where v = lookup x model
value_of _ _ = ""

decode_sorts :: TRS -> Model -> SortAttachment
decode_sorts trs model =
  [(f, [value_of model (sort_of_function f i) | i <- [0..n]])
  | (f, n) <- TRS.signature_of trs]

reduce :: String -> Bool -> Int -> RuleRemoval -> TRS -> IO (Maybe Proof)
reduce smt allsequences k rr trs
  | TRS.left_linear trs = do
      m <- sat smt (O24.encode allsequences k rr trs peaks)
      case m of
        Nothing    -> return Nothing
        Just model -> return (Just ([proof_step], Subgoal subsystem))
          where
            subsystem = decode_S trs model
            proof_step =
              CPS {
                _trsR = trs,
                _trsS = subsystem,
                _trsP = [],
                _joinSequencesForS = [],
                _joinSequencesForR = [],
                _relativeTerminationProof = RIsEmpty,
                _sortAttachment = decode_sorts trs model
              }
  | otherwise = return Nothing
  where 
    peaks = pcpeak trs
