End Monad.
Section Completness.
Infix ">>=" := Mbind (at level 15, left associativity) : monad_scope. (* level at random… *)
Open Scope monad_scope.
Infix ">>" := Mdo (at level 15, left associativity) : monad_scope.
Notation "ma >>+ mb" := (Mmap2 pair ma mb) (at level 15, left associativity):monad_scope.
Notation "mab >>++ mc" := (Mmap2 triple mab mc) (at level 15, left associativity):monad_scope.
Notation "mx >>:: mxs" :=  (Mmap2 cons mx mxs) (at level 15, left associativity):monad_scope.
Infix ">>==" := Mbind2 (at level 15, left associativity) : monad_scope.
Hint Immediate Nat.eqb_eq. (* used *a lot* for subproofs of assoc *)
Definition variable := nat.
Definition function := nat.
Inductive constructor := Zero | Succ0 | Succ1.
Scheme Equality for constructor.
Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).
Notation term_from_value := (Syntax.term_from_value variable function (constructor:=constructor)).
Notation term_from_pattern := (Syntax.term_from_pattern (variable:=variable) function (constructor:=constructor)).
Notation rule_vars_defined := (Syntax.rule_vars_defined (variable:=variable) (function:=function) (constructor:=constructor)).
Notation functions_of_term := (Syntax.functions_of_term (variable:=variable) (function:=function) (constructor:=constructor)).
(* QIs all have the shape q_f(normal vars) + max(safe vars).  However! This is a problem for terms like comp n s zero [] [] (with n>0 and s>0) where the safe variable are present in the max but the normal ones disappear from the q_f. Thus, the resulting QI does not have the subterm property for the normal variables.  Thus we choose QIs with the shape q_f(norm) + max(norm, safe). this should not be a problem in the proofs…  We only keep the q_f because it needs to be extracted to build larger QIs. Hence, we need to : - also keep memory of the number of normal vars; - remember to add back the max when actually computing things. *)
Definition assig := list nat → nat.
Definition Err_assig: assig :=  λ _, 0.
Record fun_info := info {rank: nat; asg: assig; norm :nat}.
Definition Err_info := {| rank := 0; asg := Err_assig; norm := 0 |}.
Record trs_prog:= trs {
main: function; (* main function symbol. *)
first: nat; (* 1st number of function used (the one used to generate it). *)
last: nat;  (* last number of function used (the one passed out of the monad). *)
maxar: nat; (* max_arity *)
maxrank: nat; (* max_rank *)
infos: list (function * fun_info);
rules: list rule;
}.
(*****************************************************************************)
(*                                                                           *)
(* Macros and intermediate functions needed to write the translation itself. *)
(*                                                                           *)
(*****************************************************************************)
(* Sanity stuff. Could be notations? *)
Definition px:pattern := p_var 0.
Definition tx:term := var 0.
Definition pnul:pattern := p_var 1.  (* case 0 of Cond *)
Definition tnul:term := var 1.
Definition pfalse:pattern := p_var 2. (* case S0 of Cond *)
Definition tfalse:term := var 2.
Definition ptrue:pattern := p_var 3. (* case S1 of Cond *)
Definition ttrue:term := var 3.
Definition pz:pattern := p_capply Zero [].
Definition tz:term := capply Zero [].
Definition ps0 (p:pattern):pattern := p_capply Succ0 [p].
Definition ts0 (t:term):term := capply Succ0 [t].
Definition ps1 (p:pattern):pattern := p_capply Succ1 [p].
Definition ts1 (t:term):term := capply Succ1 [t].
(* Building lists of variables as terms or patterns *)
Definition mk_pv (i:nat):pattern := p_var i.
Definition mk_tv (i:nat):term := var i.
Definition mk_pvl (n m:nat):list pattern := map mk_pv (ints n m).
Definition mk_tvl (n m:nat):list term := map mk_tv (ints n m).
(* Building simple programs *)
Definition simple_rule nf args rhs := (rule_intro nf args rhs):rule.
Definition sr_uncurry nf ru := simple_rule nf (fst ru) (snd ru).
Definition simple_prog rules infos ma mr nf :=
{| main:=nf ; first := nf ; last := nf ; maxar:=ma ; maxrank:=mr ;
infos:=infos; rules:=rules|}.
Definition one_rule_prog args rhs info ma mr nf :=
simple_prog [(simple_rule nf args rhs)] [(nf,info)] ma mr nf.
Definition Morp args rhs info ma mr nf := Mreturn (one_rule_prog args rhs info ma mr nf).
Definition multi_rules_prog argsl rhsl info ma mr nf:=
simple_prog (List.map (sr_uncurry nf) (List.combine argsl rhsl)) [(nf,info)] ma mr nf.
Definition Mmrp argsl rhsl info ma mr nf := Mreturn (multi_rules_prog argsl rhsl info ma mr nf).
(*****************************************************************************)
(*                                                                           *)
(*                     Fetching rules, infos and ranks                       *)
(*                                                                           *)
(*****************************************************************************)
Definition get_rules trsl := concat (map rules trsl).
Definition get_info trs f :=
match assoc Nat.eqb f trs.(infos) with
| Some inf => inf
| None => Err_info
end.
Definition get_infos trsl := concat (List.map infos trsl).
Definition get_info_l trsl f :=
match assoc Nat.eqb f (get_infos trsl) with
| Some inf => inf
| None => Err_info
end.
Definition asg_main trs := (get_info trs trs.(main)).(asg). (* q_f *)
Definition get_rank trs f := (get_info trs f).(rank).
(* rank 0 is used as an error value ! *)
Definition rank_main trs := get_rank trs trs.(main).
(* Stuff needed for QIs. *)
Definition mcs:=1. (* Max Constructor Size *)
Definition cs:= λ c:constructor, 1. (* Constructor Size *)
Definition qic c l:= suml l + cs c. (* QI of Constructor *)
Definition qif trs f l:= (* QI of Function. *)
let inf := get_info trs f in
let q := inf.(asg) in let norm := inf.(norm) in
let l1 := firstn norm l in let l2 := skipn norm l in
(q l1) + (maxl l2).
(*****************************************************************************)
(*                                                                           *)
(*                           Building calls                                  *)
(*                                                                           *)
(*****************************************************************************)
Definition mk_call args nf := fapply nf (mk_tvl 0 args).
Definition mk_call_trs args trs := mk_call args trs.(main).
Definition mk_args_h n s cf := (mk_tvl 0 n)++(cf::(mk_tvl n (n+s))).
(*****************************************************************************)
(*                                                                           *)
(*                          Macros for Rec                                   *)
(*                                                                           *)
(*****************************************************************************)
Definition max_rank3 p1 p2 p3 := max (rank_main p1) (max (rank_main p2) (rank_main p3)).
Definition make_rec n s trs_g trs_h0 trs_h1 nf :=
let pvl := mk_pvl 1 (n+s) in
let args_h := mk_args_h n s (mk_call (n+s) nf) in
let rk := (max_rank3 trs_g trs_h0 trs_h1)+1 in
let mr := max (max rk trs_g.(maxrank)) (max trs_h0.(maxrank) trs_h1.(maxrank)) in
let asg := λ l, (hd 0 l) * ((asg_main trs_h0 l) + (asg_main trs_h1 l)) + (asg_main trs_g (tl l)) in
let trs_f :=
multi_rules_prog [ pz::pvl ; (ps0 px)::pvl ; (ps1 px)::pvl ]
[ fapply trs_g.(main) (mk_tvl 1 (n+s)) ;
fapply trs_h0.(main) args_h ;
fapply trs_h1.(main) args_h ]
{| rank := rk ; asg:= asg;norm:=n|} (max (max (n+s+1) trs_g.(maxar)) (max trs_h0.(maxar) trs_h1.(maxar))) rk nf
in
{| main:=nf ; first:= trs_g.(first) ; last := nf ; maxar := trs_f.(maxar) ;
maxrank := mr ; infos := trs_f.(infos)++trs_g.(infos)++trs_h0.(infos)++trs_h1.(infos) ;
rules := trs_f.(rules)++trs_g.(rules)++trs_h0.(rules)++trs_h1.(rules) |}.
Definition Mmr n s trss nf :=
Mreturn (make_rec n s (fst (fst trss)) (snd (fst trss)) (snd trss) nf).
(*****************************************************************************)
(*                                                                           *)
(*                          Macros for Comp                                  *)
(*                                                                           *)
(*****************************************************************************)
Definition max_rankl trsl := maxl (map rank_main trsl).
Definition max_arl trsl := maxl (map maxar trsl).
Definition make_comp n s trs_h trs_gN trs_gS nf :=
let call_gN := map (mk_call_trs n) trs_gN in
let call_gS := map (mk_call_trs (n+s)) trs_gS in
let args_h := call_gN++call_gS in
let rules_gN := get_rules trs_gN in
let rules_gS := get_rules trs_gS in
let infos_gN := get_infos trs_gN in
let infos_gS := get_infos trs_gS in
let rk := (max (rank_main trs_h) (max (max_rankl trs_gN) (max_rankl trs_gS)))+1 in
let mr := max (max rk trs_h.(maxrank)) (max (maxl (map maxrank trs_gN)) (maxl (map maxrank trs_gS))) in
(*  let asg := λ l, (asg_main trs_h (map (λ trs, asg_main trs l) trs_gN)) + (maxl (map (λ trs, asg_main trs l) trs_gS)) in *)
let asg := λ l, (asg_main trs_h (map (λ trs, asg_main trs l) trs_gN)) + (suml (map (λ trs, asg_main trs l) trs_gS)) +
maxl l in
let trs_f :=
one_rule_prog (mk_pvl 0 (n+s)) (fapply trs_h.(main) args_h) {| rank:= rk; asg:=asg;norm:=n|}
(max (max (n+s) (length trs_gN + length trs_gS)) (max (max (max_arl trs_gN) (max_arl trs_gS)) trs_h.(maxar)))
rk nf
in
{| main := nf ; first := trs_h.(first) ; last := nf ; maxar := trs_f.(maxar) ; maxrank := mr ;
infos := trs_f.(infos)++trs_h.(infos)++infos_gN++infos_gS ;
rules := trs_f.(rules)++trs_h.(rules)++rules_gN++rules_gS |}.
Definition Mmc n s trss nf :=
Mreturn (make_comp n s (fst (fst trss)) (snd (fst trss)) (snd trss) nf).
(*****************************************************************************)
(*                                                                           *)
(*                        Errors values and base case                        *)
(*                                                                           *)
(*****************************************************************************)
(* rank of 0 is used as error value ! Thus base cases have rank 1 !*)
(* maxrank > 0 is needed for the bounds *)
Definition rule_error nf := (rule_intro nf [p_var 0] (var 0)):rule.
Definition trs_error nf := Mreturn {| main:=nf ; first:= nf ; last:=nf ; maxar:=0 ; maxrank:=1;
infos:=[(nf,{|rank:=0;asg:=Err_assig;norm:=0|})]; rules:=[rule_error nf]|}.
Definition base_info n := {| rank:=1 ; asg:=λ l, 1 + (suml l); norm:=n|}.
(*****************************************************************************)
(*                                                                           *)
(*                          Translation BC to TRS                            *)
(*                                                                           *)
(*****************************************************************************)
Fixpoint BC_to_TRS (bc:BC) :=
match bc with
| zero => Mnew_fun >>= (Morp [] tz (base_info 0) 0 1)
| proj n s i => Mnew_fun >>= (Morp (mk_pvl 0 (n+s)) (var i) (base_info n) (n+s) 1)
| succ true => Mnew_fun >>= (Morp [px] (ts1 tx) (base_info 0) 1 1)
| succ false => Mnew_fun >>= (Morp [px] (ts0 tx) (base_info 0) 1 1)
| pred => Mnew_fun >>= (Mmrp [ [pz] ; [ps0 px] ; [ps1 px] ] [tz ; tx ; tx] (base_info 0) 1 1)
| cond => Mnew_fun >>= (Mmrp [ [pz; pnul; pfalse ; ptrue] ; [ps0 px ; pnul ; pfalse ; ptrue ] ; [ps1 px ; pnul ; pfalse ; ptrue ] ]
[ tnul ; tfalse ; ttrue ] (base_info 0) 4 1)
| rec g h0 h1 =>
match (arities bc) with
| ok_arities n s => let mg:=BC_to_TRS g in let mh0:=BC_to_TRS h0 in let mh1:=BC_to_TRS h1 in
(mg >>+ mh0 >>++ mh1) >>+ Mnew_fun >>== (Mmr n s)
| _ =>  Mnew_fun >>= trs_error
end
| comp n s h gN gS =>
let mh := BC_to_TRS h in
let mgN := lm_to_ml (List.map BC_to_TRS gN) in
let mgS := lm_to_ml (List.map BC_to_TRS gS) in
(mh >>+ mgN >>++ mgS) >>+ Mnew_fun >>== (Mmc n s)
end.
(* Eval compute in (BC_to_TRS zero 0). Eval compute in (BC_to_TRS (succ false) 0). Eval compute in (arities  (rec zero (succ false) (succ true))). Eval compute in (BC_to_TRS (proj 1 1 1) 0). Eval compute in (BC_to_TRS (comp 0 2 (succ true) [] [proj 1 1 1]) 0).  Definition toto := comp 1 1 (succ false) [] [proj 1 1 1]. Eval compute in (arities toto). Definition titi:= comp 1 1 (succ true) [] [proj 1 1 1]. Eval compute in (arities titi). Definition id:= rec zero toto titi. Eval compute in (arities id). Eval compute in (BC_to_TRS id 0). Eval compute in (arities (rec (proj 0 1 0) (comp 1 2 (succ false) [] [proj 1 2 1]) (comp 1 2 (succ true) [] [proj 1 2 1])) ). Eval compute in (BC_to_TRS (rec (proj 0 1 0) (comp 1 2 (succ false) [] [proj 1 2 1]) (comp 1 2 (succ true) [] [proj 1 2 1])) 0). *)
(*****************************************************************************)
(*                                                                           *)
(*           Tactics for cleaning after the  translation                     *)
(*                                                                           *)
(*****************************************************************************)
Ltac case_rec bc1 bc2 bc3 := (* Use when no ok_arities hypothesis is made *)
destruct (match arities bc1 with
| error_rec a a0 a1 => error_rec (error_rec a a0 a1) (arities bc2) (arities bc3)
| error_comp a l l0 => error_rec (error_comp a l l0) (arities bc2) (arities bc3)
| error_proj n n0 n1 => error_rec (error_proj n n0 n1) (arities bc2) (arities bc3)
| ok_arities gn gs =>
match arities bc2 with
| error_rec a a0 a1 => error_rec (ok_arities gn gs) (error_rec a a0 a1) (arities bc3)
| error_comp a l l0 => error_rec (ok_arities gn gs) (error_comp a l l0) (arities bc3)
| error_proj n n0 n1 => error_rec (ok_arities gn gs) (error_proj n n0 n1) (arities bc3)
| ok_arities h0n h0s =>
match arities bc3 with
| error_rec a a0 a1 => error_rec (ok_arities gn gs) (ok_arities h0n h0s) (error_rec a a0 a1)
| error_comp a l l0 => error_rec (ok_arities gn gs) (ok_arities h0n h0s) (error_comp a l l0)
| error_proj n n0 n1 => error_rec (ok_arities gn gs) (ok_arities h0n h0s) (error_proj n n0 n1)
| ok_arities h1n h1s =>
if
match h0n with
| 0 => false
| S m' => gn =? m'
end && (h0n =? h1n) && match h0s with
| 0 => false
| S m' => gs =? m'
end && (h0s =? h1s)
then ok_arities h0n gs
else error_rec (ok_arities gn gs) (ok_arities h0n h0s) (ok_arities h1n h1s)
end
end
end).
Ltac open_rec Hg Hh0 Hh1 := rewrite Hg, Hh0, Hh1; repeat (rewrite Nat.eqb_refl); simpl.
(* Use with ok_arities hypothesis *)
Ltac finish_comp Hfinal :=
intros m Hm_in; rewrite in_map_iff in Hm_in; destruct Hm_in as [X Hm_in]; destruct Hm_in;
subst m; intros; apply Hfinal; auto.
Ltac open_monads_rec bc1 bc2 bc3 st:=
unfold Mbind2, Mmap2, Mnew_fun, Mupdate, Mread, Mmr, Mreturn, Mdo, Mbind, Meval, triple;
rewrite (surjective_pairing (BC_to_TRS bc1 st));
rewrite (surjective_pairing (BC_to_TRS bc2 (fst (BC_to_TRS bc1 st))));
rewrite (surjective_pairing (BC_to_TRS bc3 (fst (BC_to_TRS bc2 (fst (BC_to_TRS bc1 st))))));
simpl.
Ltac open_monads_comp h gN gS st:=
unfold Mbind2, Mmap2, Mnew_fun, Mupdate, Mread, Mmc, Mreturn, Mdo, Mbind, Meval, triple;
rewrite (surjective_pairing (BC_to_TRS h st));
rewrite (surjective_pairing (lm_to_ml (map BC_to_TRS gN) (fst (BC_to_TRS h st))));
rewrite (surjective_pairing (lm_to_ml (map BC_to_TRS gS)
(fst (lm_to_ml (map BC_to_TRS gN) (fst (BC_to_TRS h st))))));
simpl.

(*****************************************************************************)
(*                                                                           *)
(*                        BC_to_TRS is Mmono                                 *)
(*                                                                           *)
(*****************************************************************************)
Lemma Mnf_Morp_mono pl t i ma mr:
Mmono (Mnew_fun >>= (Morp pl t i ma mr)).