(* used *a lot* for subproofs of assoc *)

Definition variable := nat.Definition function := nat.Inductive constructor := Zero | Succ0 | Succ1.Inductive constructor := Zero | Succ0 | Succ1.Inductive constructor := Zero | Succ0 | Succ1.Inductive constructor := Zero | Succ0 | Succ1.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}.Record fun_info := info {rank: nat; asg: assig; norm :nat}.Record fun_info := info {rank: nat; asg: assig; norm :nat}.Record fun_info := info {rank: nat; asg: assig; norm :nat}.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;
}.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;
}.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;
}.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;
}.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;
}.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;
}.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;
}.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;
}.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.(* 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 Morp args rhs info ma mr nf := Mreturn (one_rule_prog args rhs 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 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).Definition base_info n := {| rank:=1 ; asg:=λ l, 1 + (suml l); norm:=n|}.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.

(* Specifications: *)
Lemma Mnf_Morp_lt pl t i ma mr: Mlt (Mnew_fun >>= (Morp pl t i ma mr)).
Lemma Mnf_Mmrp_lt pll tl i ma mr: Mlt (Mnew_fun >>= (Mmrp pll tl i ma mr)).
Lemma Mnf_Merr_lt: Mlt (Mnew_fun >>= trs_error).
Lemma BC_to_TRS_Mlt bc: Mlt (BC_to_TRS bc).