(* Consigne générale : remplacer les
              Admitted.
   par votre preuve ou votre définition et mettre Qed.
   Ne changer pas le nom des fonctions ou théorèmes demandés.

  Pré et post-condition : ce fichier compile sans erreur

   Il y a 3 types de questions :
   - des questions [**] que vous devriez être capable de réussir si vous avez fait
     et compris le projet
   - des questions [***] plus difficiles et apportant plus de points
   - des questions [*] que vous n'avez pas besoin de traiter si vous avec réussi
     des questions mieux étoilées

   Une question peut rapporter des points si la solution proposée débute
   correctement.

   Il n'est pas nécessaire de traiter toutes les questions pour obtenir la note maximale.
   *)

Require Import String.

Definition prenom : string := "Eve".
Definition nom : string := "Poitevin".

(* ------------------------------------------------------------ *)
Require Import List.
Require Import Arith.
Import List.ListNotations.

(* ================================================================================= *)
(* Questions inspirées du projet

   On considère le langage LOOP, pour lequel on peut
   - manipuler 1 ou 2 variables (désignées ici par les numéros 0 et 1)
   - exécuter des instructions en séquence (";")
   - incrémenter une des variables
   - remettre la valeur d'une variable à 0
   - boucler un nombre de fois désigné par une constante entière

   *)

Definition var := nat.

Inductive linstr:=
| Skip : linstr
| Incr : var -> linstr
| Reset : var -> linstr
| Seq : linstr -> linstr -> linstr
| Loop : nat -> linstr -> linstr.

Definition state := list nat.

Definition init : state := [0; 0].

Definition incr_var (v:var) (s:state) : state :=
  match v, s with
  | 0, v0 :: l => S v0 :: l
  | 1, v0 :: v1 :: l => v0 :: S v1 :: l
  | _, _ => init
  end.

Definition reset_var (v:var) (s:state) : state :=
  match v, s with
  | 0, v0 :: l => 0 :: l
  | 1, v0 :: v1 :: l => v0 :: 0 :: l
  | _, _ => init
  end.

(* Sémantique naturelle (à grands pas) *)
Inductive SNL: linstr -> state -> state -> Prop :=
| SN_Skip : forall s,
    SNL Skip s s
| SN_Incr : forall s v,
    SNL (Incr v) s (incr_var v s)
| SN_Reset : forall s v,
    SNL (Reset v) s (reset_var v s)
| SN_Seq: forall s0 s1 s2 i1 i2,
    SNL i1 s0 s1 -> SNL i2 s1 s2 -> SNL (Seq i1 i2) s0 s2
| SN_Loop_0 : forall s i,
    SNL (Loop 0 i) s s
| SN_Loop_S : forall nn s0 s1 s2 i,
    SNL i s0 s1 -> SNL (Loop nn i) s1 s2 ->
    SNL (Loop (S nn) i) s0 s2.

(* Sémantique Opérationnelle Structurelle (à petits pas) *)
Inductive config :=
| Inter : linstr -> state -> config
| Final : state -> config.

Inductive SOS_1: linstr -> state -> config -> Prop :=
| SOS_Skip : forall s,
    SOS_1 Skip s (Final s)
| SOS_Incr : forall v s,
    SOS_1 (Incr v) s (Final (incr_var v s))
| SOS_Reset : forall v s,
    SOS_1 (Reset v) s (Final (reset_var v s))
| SOS_Seqf     : forall i1 i2 s s1,
    SOS_1 i1 s (Final s1) ->
    SOS_1 (Seq i1 i2) s (Inter i2 s1)
| SOS_Seqi     : forall i1 i1' i2 s s1,
    SOS_1 i1 s (Inter i1' s1) ->
    SOS_1 (Seq i1 i2) s (Inter (Seq i1' i2) s1)
| SOS_Loop_0 : forall i s,
    SOS_1 (Loop 0 i) s (Final s)
| SOS_Loop_S : forall nn i s,
    SOS_1 (Loop (S nn) i) s (Inter (Seq i (Loop nn i)) s).

Inductive SOS : config -> config -> Prop :=
| SOS_stop  : forall c, SOS c c
| SOS_again : forall i1 s1 c2 c3,
              SOS_1 i1 s1 c2 -> SOS c2 c3 ->
              SOS (Inter i1 s1) c3.

(* Version fonctionnelle de SOS_1 *)
(* [**] Question 1 *)
Fixpoint SOS_f (i:linstr) (s:state) : config :=
  match i with
  | Skip => Final s
  | Incr v => Final (incr_var v s)
  | Reset v => Final (reset_var v s)
  | Seq i1 i2 => match SOS_f i1 s with
                 | Final s1 => Inter i2 s1
                 | Inter i1' s1 => Inter (Seq i1' i2) s1
                 end
  | Loop 0 i => Final s
  | Loop (S nn) i => Inter (Seq i (Loop nn i)) s
  end.

(* Exemples *)

Definition A:var := 0.

Definition A2_2 :=  Loop 2 (Loop 2 (Incr A)).

(* [**] Question 2.1 *)
Lemma SN_A2_2 : SNL (A2_2) [0] [4].
Proof.
  cbv [A2_2].
  eapply SN_Loop_S.
  eapply SN_Loop_S.
  apply SN_Incr.
  cbn.
  eapply SN_Loop_S.
  apply SN_Incr.
  cbn.
  eapply SN_Loop_0.
  eapply SN_Loop_S.
  eapply SN_Loop_S.
  apply SN_Incr.
  cbn.
  eapply SN_Loop_S.
  apply SN_Incr.
  cbn.
  eapply SN_Loop_0.
  apply SN_Loop_0.
Qed.

(* [**] Question 2.2 *)
Lemma SOS_A2_2 : SOS (Inter A2_2 [0]) (Inter (Loop 1 (Loop 2 (Incr A))) [2]).
Proof.
  eapply SOS_again.
  cbv[A2_2].
  eapply SOS_Loop_S.
  eapply SOS_again.
  eapply SOS_Seqi. eapply SOS_Loop_S.
  eapply SOS_again.
  eapply SOS_Seqi. eapply SOS_Seqf. eapply SOS_Incr.
  eapply SOS_again.
  eapply SOS_Seqi. eapply SOS_Loop_S.
  eapply SOS_again.
  eapply SOS_Seqi. eapply SOS_Seqf. eapply SOS_Incr.
  eapply SOS_again.
  eapply SOS_Seqf. eapply SOS_Loop_0.
  cbv.
  eapply SOS_stop.
Qed.

(* Trois questions de rattrapage
   si vous n'arrivez pas à faire des questions [**] ou [***] *)

Definition A1 := Seq (Incr A) (Seq (Reset A) (Incr A)).

(* [*] Question 3.1 *)
Lemma SN_A1 : SNL (A1) [0] [1].
Proof.
Admitted.

(* [*] Question 3.2 *)
Lemma SOS_A1 : SOS (Inter A1 [0]) (Final [1]).
Proof.
Admitted.

(* [*] Question 3.3 *)
Lemma loop_0 : forall x prog,
    SOS (Inter (Loop 0 prog) [x])
        (Final [x]).
Proof.
Admitted.

(* Lemme que l'on pourra utiliser sans démonstration ;
   vous pouvez aussi le démontrer *)
(* [***] Question 4 *)
Theorem SOS_trans : forall c1 c2 c3, SOS c1 c2 -> SOS c2 c3 -> SOS c1 c3.
Proof.
intros c1 c2 c3.
  intros c12 c23.
  induction c12 as [ | ].
  - apply c23.
  - eapply SOS_again.
    + apply H.
    + apply IHc12.
      apply c23.
Qed.

(* Lemme à utiliser SANS DÉMONSTRATION *)
Fixpoint SOS_seq i1 i2 s1 s2 (so : SOS (Inter i1 s1) (Final s2)) :
  SOS (Inter (Seq i1 i2) s1) (Inter i2 s2).
Admitted.

(* Suite de lemmes aboutissant au théorème MUL *)
(* Des lemmes arithmétiques utiles sont suggérés au besoin *)
(* [***] Question 5.1 *)
Check Nat.add_succ_r.
Lemma PLUS : forall p x,
    SOS (Inter (Loop p (Incr A)) [x]) (Final [p+x]).
Proof.
Admitted.

(* [**] Question 5.2 *)
Check Nat.add_comm.
Corollary PLUS_seq : forall p x prog,
    SOS (Inter (Seq (Loop p (Incr A)) prog) [x])
        (Inter                        prog  [x + p]).
Proof.
Admitted.

(* [**] Question 5.3 *)
Lemma MUL_S : forall n p x,
    SOS (Inter (Loop (S n) (Loop p (Incr A))) [x])
        (Inter (Loop n     (Loop p (Incr A))) [x + p]).
Proof.
Admitted.

(* [***] Question 5.4 *)
Check Nat.add_0_r.
Check Nat.add_assoc.
Lemma MUL_S_iter : forall n p x,
    SOS (Inter (Loop n (Loop p (Incr A))) [x])
        (Inter (Loop 0 (Loop p (Incr A))) [x + n * p]).
Proof.
Admitted.

(* [*] Question 5.5 *)
Lemma MUL_np : forall n p,
    SOS (Inter (Loop n (Loop p (Incr A))) [0])
        (Inter (Loop 0 (Loop p (Incr A))) [n * p]).
Proof.
Admitted.

(* [**] Question 5.6 *)
Theorem MUL : forall n p, SOS (Inter (Loop n (Loop p (Incr A))) [0]) (Final [n*p]).
Proof.
Admitted.

(* ================================================================================ *)

(* On essaie de donner une sémantique fonctionnelle au langage LOOP *)
(* La tentative suivante échoue *)
Fail Fixpoint evalL (i : linstr) (s : state) {struct i} : state :=
  match i with
  | Skip => s
  | Incr v => incr_var v s
  | Reset v => reset_var v s
  | Seq i1 i2 => evalL i2 (evalL i1 s)
  | Loop 0 i => s
  | Loop (S n) i => evalL (Loop n i) (evalL i s)
  end.

(* Voici une définition en deux temps qui est acceptée *)
Fixpoint iter_fun (n:nat) (f: state -> state) (s:state) : state :=
  match n with
  | 0 => s
  | S nn => f (iter_fun nn f s)
  end.

Fixpoint evalL (i : linstr) (s : state) {struct i} : state :=
  match i with
  | Skip => s
  | Incr v => incr_var v s
  | Reset v => reset_var v s
  | Seq i1 i2 => evalL i2 (evalL i1 s)
  | Loop n i => iter_fun n (evalL i) s
  end.

(* [***] Question 6 *)
(* Expliquer en remplissant ce commentaire

À REMPLIR

- La première tentative échoue parce que...

- La seconde définition est acceptée parce que...

 *)

(* ================================================================================ *)
(* Questions de rattrapage (à ne faire que si vous n'arrivez pas à
   faire au moins 2 des questions précédentes) *)

(* [*] Question 7 *)

Lemma loop_skip_nil : forall n, evalL (Loop n Skip) [] = [].
Proof.
Admitted.

(* [*]  Question 8 *)
(* Écrivez des versions de incr et reset qui fonctionnent avec un
   nombre quelconque de variables *)

Fixpoint reset_var_qq (v:var) (s:state) : state.
Admitted.

Fixpoint incr_var_qq (v:var) (s:state) : state.
Admitted.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Basic properties, definitions and hints about the [Classes.Graph] base-class *)

Require Import Common.
Require Import Classes.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section equal.

  Context {G: Graph}.
  Variables A B: T.

  (** projections, for auto, or to help in manual proofs *)
  Lemma equal_refl x: equal A B x x.
  Proof. intros; apply Equivalence_Reflexive. Qed.
  Lemma equal_sym x y: equal A B x y -> equal A B y x.
  Proof. intros; apply Equivalence_Symmetric; trivial. Qed.
  Lemma equal_trans x y z: equal A B x y -> equal A B y z -> equal A B x z.
  Proof. intros; eapply Equivalence_Transitive; eauto. Qed.

  (** Lemmas to solve automatically some index related goals (a la f_equal)*)
  Lemma equal_refl_f1 (f: nat -> X A B):
    forall i i', i = i' -> f i == f i'.
  Proof. intros; subst; reflexivity. Qed.
  Lemma equal_refl_f2 (f: nat -> nat -> X A B):
    forall i i' j j', i=i' -> j=j' -> f i j == f i' j'.
  Proof. intros; subst ; reflexivity. Qed.

  Lemma equal_refl_f1t Z (f: nat -> Z -> X A B):
    forall t i i', i = i' -> f i t == f i' t.
  Proof. intros; subst ; reflexivity. Qed.
  Lemma equal_refl_f2t Z (f: nat -> nat -> Z -> X A B):
    forall t i i' j j', i=i' -> j=j' -> f i j t == f i' j' t.
  Proof. intros; subst ; reflexivity. Qed.

  (** boolean test *)
  Definition xif (b: bool) (x y: X A B) := if b then x else y.

  Global Instance xif_compat: Proper (@eq bool ==> equal A B ==> equal A B ==> equal A B) xif.
  Proof. intros c b ->; repeat intro. destruct b; auto. Qed.

  Lemma xif_spec: forall b x y z, (b=true -> x==z) -> (b=false -> y==z) -> xif b x y == z.
  Proof. intros. destruct b; auto. Qed.

  Lemma xif_false: forall b x y, b=false -> xif b x y == y.
  Proof. intros ? ? ? ->; reflexivity. Qed.

  Lemma xif_true: forall b x y, b=true -> xif b x y == x.
  Proof. intros ? ? ? ->; reflexivity. Qed.

  Lemma xif_idem: forall b x, xif b x x == x.
  Proof. destruct b; reflexivity. Qed.

  Lemma xif_idem': forall b x y, x == y -> xif b x y == x.
  Proof. intros b x y H. rewrite H. apply xif_idem. Qed.

  Lemma xif_xif_and: forall b c x y, xif b (xif c x y) y == xif (b&&c) x y.
  Proof. destruct b; reflexivity. Qed.

  Lemma xif_xif_or: forall b c x y, xif b x (xif c x y) == xif (b||c) x y.
  Proof. destruct b; reflexivity. Qed.

  Lemma xif_negb: forall b x y, xif (negb b) x y == xif b y x.
  Proof. destruct b; reflexivity. Qed.

End equal.

Lemma fun_xif {G G': Graph} A B A' B' (f: @X G A B -> @X G' A' B') b x y: f (xif b x y) == xif b (f x) (f y).
Proof. destruct b; reflexivity. Qed.

Section leq.
  (** Basic properties of the underlying preorder *)
  Context `{SL: SemiLattice}.
  Variables A B: T.

  Global Instance leq_refl: Reflexive (leq A B).
  Proof. intro. apply plus_idem. Qed.

  Global Instance leq_trans: Transitive (leq A B).
  Proof.
    intros x y z E E'; unfold leq in *.
    rewrite <- E', plus_assoc, E; reflexivity.
  Qed.

  Global Instance equal_leq: subrelation (equal A B) (leq A B).
  Proof.
    intros x y E; unfold leq; rewrite E; apply plus_idem.
  Qed.

  Global Instance equal_geq: subrelation (equal A B) (Basics.flip (leq A B)).
  Proof. repeat intro; apply equal_leq; symmetry; auto. Qed.

  Definition leq_antisym: Antisymmetric _ _ (leq A B).
    intros x y H1 H2; unfold leq in *; rewrite <- H2, plus_com, H1; reflexivity.
  Qed.
End leq.

Global Hint Resolve equal_refl : core.
Global Hint Immediate equal_sym : core.

(* BUG : If we add [equal_refl_fit] as hints, they are added as eapply ...*)

Global Hint Resolve equal_refl_f1 equal_refl_f2 : core.
(* Hint Resolve @equal_refl_f1t @equal_refl_f2t *)

Global Hint Extern 1 (equal ?A ?B (?f _ ?t) (?f _ ?t)) => apply @equal_refl_f1t : core.
Global Hint Extern 2 (equal ?A ?B (?f _ _ ?t) (?f _ _ ?t)) => apply @equal_refl_f2t : core.

Global Hint Extern 3 (_ == _) => apply @xif_compat : core.


Require Import Ordinal.
Require Import OrdArith.
Require Import OrdIterFixpoint.
Require Import Coq.Strings.String.

Module Eps0NF.

(*
前面给出的On的元素是基于基本列递归定义的序数记号，这使得我们能统一讨论每种序数记号的基本列并混用各种记号，但也导致不方便讨论序数记号本身的结构
这里给出用统一格式的表达式表示的一定范围内的序数的一种方式；这样的表示方式更接近大数学中常用的表示方式
*)

(* 将类型T的序数记号展开一层 *)
Inductive ExprFS{T:Set}:Set :=
| ZeroE
| SucE(n:T)
| LimE(f:nat->T).

(* 命题：T到On的映射保持基本列的定义 *)
Definition toOn_FS{T:Set}(toOn:T->On)(toFS:T->ExprFS) :=
forall x:T, (toOn x) =
match (toFS x) with
| ZeroE => Zero
| SucE n0 => Suc (toOn n0)
| LimE f0 => Lim (fun n=>toOn (f0 n))
end.

(* 形如0或ω^a+b的表达式，用于表示ε0以内的序数 *)
Inductive Expr: Set :=
| expr0
| ωpowadd(a b:Expr).

(* 表达式对应的序数 *)
Fixpoint toOn(x:Expr) :=
match x with
| expr0 => Zero
| ωpowadd a b => oadd (ωpow (toOn a)) (toOn b)
end.

(* ω^表达式 *)
Definition ωpowE(x:Expr):Expr :=
ωpowadd x expr0.

(* ω^表达式*n *)
Fixpoint ωpowmulE(x:Expr)(n:nat):=
match n with
| O => expr0
| S n' => ωpowadd x (ωpowmulE x n')
end.

(*
w^0+0 = 0+1
w^(a+1)+0[n] = w^a*n
w^a+0[n] = w^(a[n]), a is Lim
w^a+(b+1) = (w^a+b)+1
(w^a+b)[n] = w^a+(b[n]), b is Lim
*)

(* 表达式的基本列 *)
Fixpoint toFS(x:Expr):ExprFS :=
match x with
| expr0 => ZeroE
| ωpowadd a b =>
  match (toFS b) with
  | ZeroE =>
    match (toFS a) with
    | ZeroE => SucE expr0
    | SucE n0 => LimE (fun n=>ωpowmulE n0 n)
    | LimE f0 => LimE (fun n=>ωpowE (f0 n))
    end
  | SucE n0 => SucE (ωpowadd a n0)
  | LimE f0 => LimE (fun n=>ωpowadd a (f0 n))
  end
end.

Section WithFuncExt.
(* 为了方便，引入函数外延公理 *)
Hypothesis func_ext : forall {A B: Type} {f g : A->B},
  (forall x, f x = g x) -> f = g.

(* 证明ω^x*n的定义和对应的序数兼容 *)
Lemma toOn_ωpowmulE: forall x n, toOn (ωpowmulE x n) = omult (opower ω (toOn x)) n.
intros x n.
induction n; auto.
simpl.
rewrite IHn.
generalize (toOn x). intro o.
rewrite omult_n_add_comm; auto.
Qed.

(* 证明ω^x的定义和对应的序数兼容 *)
Lemma toOn_ωpowE: forall x, toOn (ωpowE x) = ωpow (toOn x).
auto.
Qed.

(* 证明基本列的定义和对应的序数兼容 *)
Lemma Expr_toOn_FS: toOn_FS toOn toFS.
unfold toOn_FS.
intro x.
induction x; auto.
simpl.
induction (toFS x2); rewrite IHx2; auto.
simpl.
rewrite IHx1.
destruct (toFS x1); auto.
cbn.
apply inv.
unfold ωpow.
apply func_ext.
intro x.
rewrite <-(toOn_ωpowmulE n x).
apply eq_refl.
Qed.

(* repr(w)表示这种表达式能表示w和w的基本列递归展开出的所有序数 *)
Definition repr(w:On):= forall ls, exists e, toOn e = FSs w ls.

(* 证明如果x能表示，那么x的基本列递归展开的序数都能表示 *)
Lemma repr_trans e ls : exists e', (toOn e') = FSs (toOn e) ls.
intros.
induction ls; cbn.
- exists e; auto.
- destruct IHls as [x H].
  rewrite <-H.
  rewrite Expr_toOn_FS.
  unfold FS.
  destruct (toFS x).
  1: exists expr0.
  2: exists n.
  3: exists (f a).
  all: auto.
Qed.

(* 证明如果x能表示，则ω^x也能表示 *)
Lemma repr_ωpow: (forall x, repr x -> repr (ωpow x)).
unfold repr.
intros.
destruct (H nil).
cbn in H0.
rewrite <-H0.
rewrite <-toOn_ωpowE.
apply repr_trans.
Qed.

(* 证明ε0展开出的序数都能用这种表达式表示 *)
Theorem repr_ε0: forall n, repr (FS ε_0 n).
unfold repr.
intro n.
induction n; cbn.
- intros.
  apply (repr_trans expr0 ls).
- intros.
  cbn in IHn.
  apply repr_ωpow.
  unfold repr.
  apply IHn.
Qed.

End WithFuncExt.

(* 有了序数表达式，我们可以定义把自然数代入表达式中每个ω处求值 *)
Definition subst_nat(x0:Expr)(n:nat):nat :=
(fix FIX x :=
match x with
| expr0 => O
| ωpowadd a b => plus (Nat.pow n (FIX a)) (FIX b)
end) x0.

(* 接下来证明这种求值方式恰好和SGH的行为对应 *)
Theorem subst_nat_eq_g: forall x n, subst_nat x n = g (toOn x) n.
intro x.
induction x; auto.
intro n.
cbn.
rewrite g_oadd,g_ωpow.
rewrite <-IHx1,<-IHx2.
auto.
Qed.

Module Str.

Local Open Scope string_scope.

(* 用括号序列可以简洁地展示ω^a+b形式的表达式 *)
Fixpoint to_string(x:Expr): string :=
match x with
| expr0 => ""
| ωpowadd a b => "(" ++ (to_string a) ++ ")" ++ (to_string b)
end.

Goal
(to_string expr0)="" /\
(to_string (ωpowadd expr0 expr0))="()" /\
(to_string (ωpowadd expr0 (ωpowadd expr0 expr0)))="()()" /\
(to_string (ωpowadd (ωpowadd expr0 expr0) expr0))="(())"
.
repeat split.
Qed.

Definition FS' (x:Expr) (n:nat) :=
match (toFS x) with
| ZeroE => expr0
| SucE n0 => n0
| LimE f0 => f0 n
end.

Goal
(to_string (expr0))="" /\
(to_string (ωpowE expr0))="()" /\
(to_string (iter ωpowE 2 expr0))="(())" /\
(to_string (iter ωpowE 3 expr0))="((()))" /\
(to_string (iter ωpowE 4 expr0))="(((())))" /\
(to_string (FS' (iter ωpowE 4 expr0) 0))="(())" /\
(to_string (FS' (iter ωpowE 4 expr0) 1))="((()))" /\
(to_string (FS' (iter ωpowE 4 expr0) 2))="((()()))" /\
(to_string (FS' (iter ωpowE 4 expr0) 3))="((()()()))" /\
(to_string (FS' (FS' (iter ωpowE 4 expr0) 3) 1))="((()()))" /\
(to_string (FS' (FS' (iter ωpowE 4 expr0) 3) 2))="((()())(()()))" /\
(to_string (FS' (FS' (iter ωpowE 4 expr0) 3) 3))="((()())(()())(()()))" /\
(to_string (iter (fun x=>FS' x 3) 3 (iter ωpowE 4 expr0)))="((()())(()())(())(())(()))" /\
(to_string (iter (fun x=>FS' x 3) 4 (iter ωpowE 4 expr0)))="((()())(()())(())(())()()())" /\
True.
repeat split.
Qed.

End Str.

End Eps0NF.


Inductive TreeFamGood G F : treeFam->Set :=
	tfGoodUv : TreeFamGood G F Uv |
	tfGoodEl f la : (f < length G)->
		SimpParamGood G (fBump (S f) O (nth f G Uv)) la Uv->
		TreeFamGood G F (El (f,la)) |
	tfGoodPi A B : TreeFamGood G F A->TreeFamGood (A :: G) F B->
		TreeFamGood G F (Pi A B)
with SimpParamGood G F : list nat->treeFam->Set :=
	spGoodNil : SimpParamGood G F nil F |
	spGoodCons a la B : (a < length G)->
		SimpParamGood G F la (Pi (fBump (S a) O (nth a G Uv)) B)->
		TreeFamGood (fBump (S a) O (nth a G Uv) :: G) F B->
		SimpParamGood G F (a :: la) (fSubst B O a).

Section TFSPGoodMutRec.

Variable PF : list treeFam->treeFam->Type.
Variable PP : list treeFam->treeFam->list nat->treeFam->Type.

Variable PUv : forall G,PF G Uv.
Variable PEl : forall G f la,(f < length G)->
	PP G (fBump (S f) O (nth f G Uv)) la Uv->
	PF G (El (f,la)).
Variable PPi : forall G A B,PF G A->PF (A :: G) B->
	PF G (Pi A B).

Variable PNil : forall G F,PP G F nil F.
Variable PCons : forall G F a la B,(a < length G)->
	PP G F la (Pi (fBump (S a) O (nth a G Uv)) B)->
	PF (fBump (S a) O (nth a G Uv) :: G) B->
	PP G F (a :: la) (fSubst B O a).

Fixpoint TreeFamGood_mr G F T (X:TreeFamGood G F T) : PF G T := match X with
	tfGoodUv => PUv _ |
	tfGoodEl _ _ Hf Hla => PEl _ _ _ Hf (SimpParamGood_mr _ _ _ _ Hla) |
	tfGoodPi _ _ HA HB => PPi _ _ _ (TreeFamGood_mr _ _ _ HA) (TreeFamGood_mr _ _ _ HB)
end
with SimpParamGood_mr G F la T (X:SimpParamGood G F la T) : PP G F la T := match X with
	spGoodNil => PNil _ _ |
	spGoodCons _ _ _ Ha Hla HB => PCons _ _ _ _ _ Ha
		(SimpParamGood_mr _ _ _ _ Hla) (TreeFamGood_mr _ _ _ HB)
end.

Definition TreeFamGood_SimpParamGood_mr := (TreeFamGood_mr,SimpParamGood_mr).

End TFSPGoodMutRec.


Require Import Coq.Lists.List Coq.micromega.Psatz.
Require Import Crypto.Util.ListUtil Crypto.Util.ZUtil.
Require Import Coq.ZArith.ZArith Coq.ZArith.Zdiv.
Require Import Coq.omega.Omega Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Arith.
Require Import Crypto.LegacyArithmetic.BaseSystem.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Notations.
Import Morphisms.
Local Open Scope Z.

Local Hint Extern 1 (@eq Z _ _) => ring.

Section BaseSystemProofs.
  Context `(base_vector : BaseVector).

  Lemma decode'_truncate : forall bs us, decode' bs us = decode' bs (firstn (length bs) us).
  Proof using Type.
    unfold decode'; intros; f_equal; apply combine_truncate_l.
  Qed.

  Lemma decode'_splice : forall xs ys bs,
    decode' bs (xs ++ ys) =
    decode' (firstn (length xs) bs) xs + decode'  (skipn (length xs) bs) ys.
  Proof using Type.
    unfold decode'.
    induction xs; destruct ys, bs; boring.
    + rewrite combine_truncate_r.
      do 2 rewrite Z.add_0_r; auto.
    + unfold accumulate.
      apply Z.add_assoc.
  Qed.

  Lemma decode_nil : forall bs, decode' bs nil = 0.
  Proof using Type.

    auto.
  Qed.
  Hint Rewrite decode_nil.

  Lemma decode_base_nil : forall us, decode' nil us = 0.
  Proof using Type.
    intros; rewrite decode'_truncate; auto.
  Qed.

  Lemma mul_each_rep : forall bs u vs,
    decode' bs (mul_each u vs) = u * decode' bs vs.
  Proof using Type.
    unfold decode', accumulate; induction bs; destruct vs; boring; ring.
  Qed.

  Lemma base_eq_1cons: base = 1 :: skipn 1 base.
  Proof using Type*.
    pose proof (b0_1 0) as H.
    destruct base; compute in H; try discriminate; boring.
  Qed.

  Lemma decode'_cons : forall x1 x2 xs1 xs2,
    decode' (x1 :: xs1) (x2 :: xs2) = x1 * x2 + decode' xs1 xs2.
  Proof using Type.
    unfold decode', accumulate; boring; ring.
  Qed.
  Hint Rewrite decode'_cons.

  Lemma decode_cons : forall x us,
    decode base (x :: us) = x + decode base (0 :: us).
  Proof using Type*.
    unfold decode; intros.
    rewrite base_eq_1cons.
    autorewrite with core; ring_simplify; auto.
  Qed.

  Lemma decode'_map_mul : forall v xs bs,
    decode' (map (Z.mul v) bs) xs =
    Z.mul v (decode' bs xs).
  Proof using Type.
    unfold decode'.
    induction xs; destruct bs; boring.
    unfold accumulate; simpl; nia.
  Qed.

  Lemma decode_map_mul : forall v xs,
    decode (map (Z.mul v) base) xs =
    Z.mul v (decode base xs).
  Proof using Type.
    unfold decode; intros; apply decode'_map_mul.
  Qed.

  Lemma mul_each_base : forall us bs c,
      decode' bs (mul_each c us) = decode' (mul_each c bs) us.
  Proof using Type.
    induction us; destruct bs; boring; ring.
  Qed.

  Hint Rewrite (@nth_default_nil Z).
  Hint Rewrite (@firstn_nil Z).
  Hint Rewrite (@skipn_nil Z).

  Lemma peel_decode : forall xs ys x y, decode' (x::xs) (y::ys) = x*y + decode' xs ys.
  Proof using Type.
    boring.
  Qed.
  Hint Rewrite peel_decode.

  Hint Rewrite plus_0_r.

  Lemma set_higher : forall bs vs x,
    decode' bs (vs++x::nil) = decode' bs vs + nth_default 0 bs (length vs) * x.
  Proof using Type.
    intros.
    rewrite !decode'_splice.
    cbv [decode' nth_default]; break_match; ring_simplify;
      match goal with
      | [H:_ |- _] => unique pose proof (nth_error_error_length _ _ _ H)
      | [H:_ |- _] => unique pose proof (nth_error_value_length _ _ _ _ H)
      end;
      repeat match goal with
             | _ => solve [simpl;ring_simplify; trivial]
             | _ => progress ring_simplify
             | _ => progress rewrite skipn_all by trivial
             | _ => progress rewrite combine_nil_r
             | _ => progress rewrite firstn_all2 by trivial
             end.
    rewrite (combine_truncate_r vs bs); apply (f_equal2 Z.add); trivial; [].
    unfold combine; break_match.
    { let Heql := match goal with H : _ = nil |- _ => H end in
      apply (f_equal (@length _)) in Heql; simpl length in Heql; rewrite skipn_length in Heql; omega. }
    { cbv -[Z.add Z.mul]; ring_simplify; f_equal.
      assert (HH: nth_error (z0 :: l) 0 = Some z) by
          (
            pose proof @nth_error_skipn _ (length vs) bs 0;
            rewrite plus_0_r in *;
            congruence); simpl in HH; congruence. }
  Qed.
End BaseSystemProofs.