Generalizable All Variables.
Set Implicit Arguments.

Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.ilist
        Fiat.Common.ilist2.

Section i2list.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Vectors.Vector.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)
  Variable C : forall a, B a ->  Type. (* The type of doubly-indexed elements. *)

  Fixpoint i2list {n}
           {l : Vector.t A n}
    : ilist2 (B := B) l -> Type :=
    match l return ilist2 (B := B) l -> Type with
    | [] => fun _ => unit
    | a :: l' => fun il => @prim_prod (C (ilist2_hd il))
                                      (i2list (ilist2_tl il))
    end.

  Definition i2cons
             {a : A}
             {n}
             {l : Vector.t A n}
             {b : B a}
             {il : ilist2 l}
             (c : C b)
             (il2 : i2list il)
  : i2list (icons2 b il)
    := {| prim_fst := c; prim_snd := il2 |}.

  Definition i2nil : i2list inil2 := tt.

  (* Get the car of an i2list. *)
  Definition i2list_hd {n}
             (As : Vector.t A n)
             (Bs : ilist2 As)
             (i2l : i2list Bs) :
    match As return forall Bs : ilist2 As, i2list Bs -> Type with
    | a :: As' => fun Bs i2l => C (ilist2_hd Bs)
      | [] => fun _ _ => unit
    end Bs i2l :=
    match As as As' return
          forall Bs i2l,
          match As' return forall Bs : ilist2 As', i2list Bs -> Type with
          | a :: As' => fun Bs i2l => C (ilist2_hd Bs)
          | [] => fun _ _ => unit
          end Bs i2l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_fst il
    end Bs i2l.

  (* Get the cdr of an i2list. *)
  Definition i2list_tl {n}
             (As : Vector.t A n)
             (Bs : ilist2 As)
             (i2l : i2list Bs) :
    match As return forall Bs : ilist2 As, i2list Bs -> Type with
    | a :: As' => fun Bs i2l => i2list (ilist2_tl Bs)
    | [] => fun _ _ => unit
    end Bs i2l :=
    match As as As' return
          forall Bs i2l,
          match As' return forall Bs : ilist2 As', i2list Bs -> Type with
          | a :: As' => fun Bs i2l => i2list (ilist2_tl Bs)
          | [] => fun _ _ => unit
          end Bs i2l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_snd il
    end Bs i2l.

  Fixpoint i2th
           {m : nat}
           {As : Vector.t A m}
           {Bs : ilist2 As}
           (i2l : i2list Bs)
           (n : Fin.t m)
           {struct n}
    : C (ith2 Bs n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist2 As),
            i2list Bs
            -> C (ith2 Bs n) with
    | Fin.F1 k =>
      fun As Bs i2l =>
        Vector.caseS (fun n As =>
                        forall (Bs : ilist2 As), i2list Bs
                                   -> C (ith2 Bs (@Fin.F1 n)))
                     (fun a' n' As' (Bs' : ilist2 (a' :: As')) i2l' => prim_fst i2l' ) As Bs i2l
    | Fin.FS k n'' =>
      fun As Bs i2l =>
        Vector_caseS' Fin.t
                      (fun n' As i =>
                        forall (Bs'' : ilist2 As),
                          i2list Bs''
                          -> C (ith2 Bs'' (@Fin.FS n' i)))
                     (fun a' n' As' n'' (Bs' : ilist2 (a' :: As')) i2l' => i2th (prim_snd i2l') n'')
                     As n'' Bs i2l
    end As Bs i2l.

End i2list.

Arguments i2cons [_ _ _ _ _ _ _ _] _ _.
Arguments i2nil {_ _ _}.
Arguments i2th [_ _ _ _ _ _] _ _.

Section i2list_replace.

  (* Replacing an element of an indexed list. *)
  Variable A : Type. (* The indexing type. *)
  Variable B : A -> Type. (* The two types of indexed elements. *)
  Variable C : forall a, B a -> Type. (* The type of doubly-indexed elements. *)

  Import Vectors.Vector.VectorNotations.

  Fixpoint replace2_Index2
          {m : nat}
          {As : Vector.t A m}
          {Bs : ilist2 As}
          (i2l : i2list C Bs)
          (n : Fin.t m)
          (new_c : C (ith2 Bs n))
    : i2list C Bs :=
        match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist2 As),
            i2list C Bs
            -> C (ith2 Bs n)
            -> i2list C Bs with
        | Fin.F1 k =>
          fun As Bs i2l new_c =>
            Vector.caseS (fun n As =>
                            forall (Bs : ilist2 As), i2list C Bs
                                                     -> C (ith2 Bs (@Fin.F1 n))
                                                     -> i2list C Bs)
                         (fun a' n' As' (Bs' : ilist2 (a' :: As')) i2l' new_c => i2cons new_c (prim_snd i2l') ) As Bs i2l new_c
    | Fin.FS k n'' =>
      fun As Bs i2l new_c =>
        Vector.caseS (fun n' As =>
                        forall (i : Fin.t n') (Bs'' : ilist2 As),
                          i2list C Bs''
                          -> C (ith2 Bs'' (@Fin.FS n' i))
                          -> i2list C Bs'')
                     (fun a' n' As' n'' (Bs' : ilist2 (a' :: As')) i2l' new_c => i2cons (prim_fst i2l') (replace2_Index2 (prim_snd i2l') n'' new_c))
                     As n'' Bs i2l new_c
        end As Bs i2l new_c.

  Lemma i2th_replace_Index_neq
    : forall {m : nat}
             {As : Vector.t A m}
             {Bs : ilist2 As}
             (i2l : i2list C Bs)
             (n n' : Fin.t m)
             (new_c : C (ith2 Bs n)),
      n <> n'
      -> i2th (replace2_Index2 i2l n new_c) n' =
         i2th i2l n'.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert n' As Bs i2l new_c H IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *
      end.
      + intros n n'; pattern n, n';
        match goal with
          |- ?P n n' => simpl; apply (@Fin.caseS P); clear n n'; intros; simpl in *;
                        eauto; congruence
        end.
      + intros n p n'; revert p; pattern n, n';
        match goal with
          |- ?P n n' => simpl; apply (@Fin.caseS P); clear n n'; intros; simpl in *;
                        eauto
        end.
        eapply IHAs; congruence.
  Qed.

  Lemma i2th_replace_Index_eq
    : forall {m : nat}
             {As : Vector.t A m}
             {Bs : ilist2 As}
             (i2l : i2list C Bs)
             (n : Fin.t m)
             (new_c : C (ith2 Bs n)),
      i2th (replace2_Index2 i2l n new_c) n = new_c.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert As Bs i2l new_c IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *; eauto
      end.
  Qed.

  (*Program Fixpoint replace_Index2'
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (new_c : Dep_Option_elim_P C (ith_error Bs n))
           {struct Cs} : i2list C Bs :=
    match n return
          Dep_Option_elim_P C (ith_error Bs n)
            -> i2list C Bs with
      | 0 => match Cs in i2list _ Bs return
                   Dep_Option_elim_P C (ith_error Bs 0)
                   -> i2list C Bs with
                 | i2nil Bs =>
                   fun _ => i2nil _ Bs
                 | i2cons a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons Bs' new_c i2l'
               end
      | S n => match Cs in i2list _ Bs return
                     Dep_Option_elim_P C (ith_error Bs (S n))
                     -> i2list C Bs with
                 | i2nil Bs => fun _ => i2nil _ Bs
                 | i2cons a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons Bs' c (@replace_Index2' n As' (ilist_tl Bs') i2l' new_c)
               end
    end new_c.

  Lemma i2th_replace_Index'_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith_error Bs n')),
      n <> n'
      -> i2th_error' (replace_Index2' n' Cs new_c) n =
         i2th_error' Cs n.
  Proof.
    induction n; simpl; destruct Cs; intros; icons_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    unfold replace_Index2.
    eapply IHn; congruence.
  Qed.

  Lemma i2th_replace_Index'_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list C Bs)
      (new_c : Dep_Option_elim_P C (ith_error Bs n)),
      i2th_error' (replace_Index2' n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Cs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed. *)

End i2list_replace.


Require Export basic.
Require Import Sublogic.
Require Export ZFdef.

(** We assume the existence of a model of IZF: *)
Require ZFskolEm.
Module IZF : IZF_R_sig CoqSublogicThms := ZFskolEm.IZF_R.
(*Import IZF.*)
Include IZF.

Notation morph1 := (Proper (eq_set ==> eq_set)).
Notation morph2 := (Proper (eq_set ==> eq_set ==> eq_set)).

Instance eq_set_equiv: Equivalence eq_set.
Proof.
split; red; intros; rewrite eq_set_ax in *; intros.
 reflexivity.
 symmetry; trivial.
 transitivity (x0 ∈ y); trivial.
Qed.

Lemma eq_set_morph : Proper (eq_set ==> eq_set ==> iff) eq_set.
auto with *.
Qed.

Lemma eq_intro : forall x y,
  (forall z, z ∈ x -> z ∈ y) ->
  (forall z, z ∈ y -> z ∈ x) ->
  eq_set x y.
intros.
rewrite eq_set_ax; split; auto.
Qed.

Lemma eq_elim : forall x y y',
  y == y' ->
  x ∈ y ->
  x ∈ y'.
intros.
rewrite eq_set_ax in H.
destruct (H x); auto.
Qed.

Instance in_set_morph : Proper (eq_set ==> eq_set ==> iff) in_set.
apply morph_impl_iff2; auto with *.
do 4 red; intros.
apply in_reg with x; trivial.
apply eq_elim with x0; trivial.
Qed.

Definition incl_set x y := forall z, z ∈ x -> z ∈ y.

Notation "x ⊆ y" := (incl_set x y).

Instance incl_set_pre : PreOrder incl_set.
split; do 2 red; intros; eauto.
Qed.

Instance incl_set_morph : Proper (eq_set ==> eq_set ==> iff) incl_set.
apply morph_impl_iff2; auto with *.
unfold incl_set; do 4 red; intros.
rewrite <- H0; rewrite <- H in H2; auto.
Qed.

Lemma incl_eq x y : x ⊆ y -> y ⊆ x -> x == y.
intros.
apply eq_intro; auto.
Qed.

Lemma eq_incl x y : x == y -> x ⊆ y.
intro h; rewrite h; reflexivity.
Qed.

Instance Fmono_morph F : Proper (incl_set==>incl_set) F -> morph1 F.
do 2 red; intros.
apply incl_eq; apply H; rewrite H0; reflexivity.
Qed.
Hint Resolve Fmono_morph.

(** Extensional equivalences *)

Definition eq_fun dom F G :=
  forall x x', x ∈ dom -> x == x' -> F x == G x'.

Instance eq_fun_sym : forall dom, Symmetric (eq_fun dom).
do 2 red; intros.
rewrite H1 in H0.
symmetry in H1.
symmetry; apply H; auto.
Qed.

Instance eq_fun_trans : forall dom, Transitive (eq_fun dom).
do 2 red; intros.
transitivity (y x'); auto.
apply H0.
 rewrite <- H2; trivial.
 reflexivity.
Qed.

Definition ext_fun dom f := eq_fun dom f f.

Definition ext_fun2 A B f :=
  forall x x' y y', x ∈ A -> x == x' -> y ∈ B x -> y == y' -> f x y == f x' y'.

Lemma eq_fun_ext : forall dom F G, eq_fun dom F G -> ext_fun dom F.
red; intros.
transitivity G; trivial.
symmetry; trivial.
Qed.

Lemma morph_is_ext : forall F X, morph1 F -> ext_fun X F.
red; red; intros.
apply H; trivial.
Qed.
Hint Resolve morph_is_ext.

Lemma cst_is_ext : forall X o, ext_fun o (fun _ => X).
do 2 red; reflexivity.
Qed.
Hint Resolve cst_is_ext.

Definition eq_pred dom (P Q : set -> Prop) :=
  forall x, x ∈ dom -> (P x <-> Q x).

Instance eq_pred_set : forall dom, Equivalence (eq_pred dom).
firstorder.
Qed.

Definition ext_rel dom (R:set->set->Prop) :=
  forall x x' y y', x ∈ dom -> x == x' -> y == y' -> (R x y <-> R x' y').

Definition eq_index x F y G :=
  (forall a, a ∈ x -> exists2 b, b ∈ y & F a == G b) /\
  (forall b, b ∈ y -> exists2 a, a ∈ x & F a == G b).

Lemma eq_index_sym : forall x F y G, eq_index x F y G -> eq_index y G x F.
destruct 1; split; intros.
 apply H0 in H1; destruct H1.
 symmetry in H2.
 exists x0; trivial.

 apply H in H1; destruct H1.
 symmetry in H2.
 exists x0; trivial.
Qed.

Lemma eq_index_eq : forall x F y G,
  x == y ->
  eq_fun x F G ->
  eq_index x F y G.
red; intros.
split; intros.
 exists a.
  rewrite H in H1; trivial.
  apply H0; auto with *.
 rewrite <- H in H1; trivial.
 exists b; trivial.
 apply H0; auto with *.
Qed.

Definition typ_fun f A B := forall x, x ∈ A -> f x ∈ B.

Instance typ_fun_morph0 : Proper (eq ==> eq_set ==> eq_set ==> iff) typ_fun.
apply morph_impl_iff3; auto with *.
do 6 red; intros.
subst y.
rewrite <- H1; rewrite <- H0 in H3; auto.
Qed.

(** Rephrasing axioms *)

Lemma empty_ext : forall e, (forall x, ~x ∈ e) -> e == empty.
Proof.
intros.
apply eq_intro; intros.
 elim H with (1 := H0).
 elim empty_ax with (1 := H0).
Qed.

Lemma pair_intro1 : forall x y, x ∈ pair x y.
Proof.
intros.
elim (pair_ax x y x); intros; auto.
apply H0; left; reflexivity.
Qed.

Lemma pair_intro2 : forall x y, y ∈ pair x y.
Proof.
intros.
elim (pair_ax x y y); intros; auto.
apply H0; right; reflexivity.
Qed.

Hint Resolve pair_intro1 pair_intro2.

Lemma pair_elim : forall x a b, x ∈ pair a b -> x == a \/ x == b.
Proof.
intros.
elim (pair_ax a b x); auto.
Qed.

Lemma pair_ext : forall p a b,
  a ∈ p -> b ∈ p -> (forall x, x ∈ p -> x == a \/ x == b) ->
  p == pair a b.
Proof.
intros; apply eq_intro; intros.
 elim H1 with (1 := H2); intro x_eq;  rewrite x_eq; trivial.
 elim pair_elim with (1 := H2); intro x_eq;  rewrite x_eq; trivial.
Qed.

Instance pair_morph : morph2 pair.
do 3 red; intros.
apply pair_ext; intros.
 rewrite <- H; apply pair_intro1.
 rewrite <- H0; apply pair_intro2.

 rewrite <- H; rewrite <- H0.
 apply pair_elim in H1; auto.
Qed.

Lemma union_intro : forall x y z, x ∈ y -> y ∈ z -> x ∈ union z.
Proof.
intros.
elim (union_ax z x); intros.
apply H2.
exists y; trivial.
Qed.

Lemma union_elim : forall x z, x ∈ union z -> exists2 y, x ∈ y & y ∈ z.
Proof.
intros.
elim (union_ax z x); auto.
Qed.

Lemma union_ext :
  forall u z,
  (forall x y, x ∈ y -> y ∈ z -> x ∈ u) ->
  (forall x, x ∈ u -> exists2 y, x ∈ y & y ∈ z) ->
  u == union z.
Proof.
intros; apply eq_intro; intros.
 elim H0 with (1 := H1); intros.
   apply union_intro with x; trivial.
 elim union_elim with (1 := H1); intros; eauto.
Qed.

Instance union_morph : morph1 union.
do 2 red; intros.
apply union_ext; intros.
  eapply union_intro;  eauto.
  rewrite H; trivial.
 elim union_elim with (1 := H0); intros.
 exists x1; trivial.
 rewrite <- H; trivial.
Qed.

Instance union_mono : Proper (incl_set ==> incl_set) union.
do 3 red; intros.
apply union_elim in H0.
destruct H0.
apply union_intro with x0; auto.
Qed.

Lemma union_empty_eq : union empty == empty.
Proof.
symmetry  in |- *.
apply union_ext; intros.
 elim empty_ax with (1 := H0).
 elim empty_ax with (1 := H).
Qed.

Lemma power_intro :
  forall x y, (forall z, z ∈ x -> z ∈ y) -> x ∈ power y.
Proof.
intros.
elim (power_ax y x); intros; auto.
Qed.

Lemma power_elim : forall x y z, x ∈ power y -> z ∈ x -> z ∈ y.
Proof.
intros.
elim (power_ax y x); intros; auto.
Qed.

Lemma power_mono : Proper (incl_set ==> incl_set) power.
do 3 red; intros.
apply power_intro; intros.
apply H.
apply power_elim with z; trivial.
Qed.

Lemma power_ext :
  forall p a,
  (forall x, (forall y, y ∈ x -> y ∈ a) -> x ∈ p) ->
  (forall x y, x ∈ p -> y ∈ x -> y ∈ a) ->
  p == power a.
Proof.
intros; apply eq_intro; intros.
 apply power_intro; eauto.
 apply H; intros;  eapply power_elim;  eauto.
Qed.

Instance power_morph : morph1 power.
do 2 red; intros.
apply power_ext; intros.
 apply power_intro; intros.
    rewrite H; auto.
  rewrite <- H.
    eapply power_elim;  eauto.
Qed.

Lemma empty_incl_all a : empty ⊆ a.
red; intros; apply empty_ax in H; contradiction.
Qed.

Lemma empty_in_power : forall x, empty ∈ power x.
Proof.
intros.
apply power_intro; intros.
elim empty_ax with (1:=H).
Qed.

Hint Resolve empty_incl_all empty_in_power.

Lemma union_in_power :
    forall x X, x ⊆ power X -> union x ∈ power X.
intros.
apply power_intro; intros.
elim union_elim with (1:=H0); clear H0; intros.
apply power_elim with x0; auto.
Qed.

Lemma subset_ax' x P z :
  Proper (eq_set==>iff) P ->
  (z ∈ subset x P <-> z ∈ x /\ P z).
intros.
rewrite subset_ax.
apply and_iff_morphism; auto with *.
split; intros.
 destruct H0.
 rewrite H0; trivial.

 exists z; auto with *.
Qed.

Lemma subset_intro : forall a (P:set->Prop) x,
  x ∈ a -> P x -> x ∈ subset a P.
Proof.
intros.
elim (subset_ax a P x); intros.
apply H2; split; trivial.
exists x; trivial; reflexivity.
Qed.

Lemma subset_elim1 : forall a (P:set->Prop) x, x ∈ subset a P -> x ∈ a.
Proof.
intros.
elim (subset_ax a P x); intros.
elim H0; trivial.
Qed.

Lemma subset_elim2 : forall a (P:set->Prop) x, x ∈ subset a P ->
  exists2 x', x==x' & P x'.
Proof.
intros.
elim (subset_ax a P x); intros.
elim H0; trivial.
Qed.

Lemma subset_ext :
  forall s a (P:set->Prop),
  (forall x, x ∈ a -> P x -> x ∈ s) ->
  (forall x, x ∈ s -> x ∈ a) ->
  (forall x, x ∈ s -> exists2 x', x==x' & P x') ->
  s == subset a P.
Proof.
intros; apply eq_intro; intros.
 elim H1 with (1:=H2); intros.
 rewrite H3.
 apply subset_intro; auto.
 rewrite <- H3; auto.
 elim subset_elim2 with (1:=H2); intros.
 rewrite H3.
 apply H; trivial.
 rewrite <- H3.
 apply subset_elim1 with P; auto.
Qed.

Lemma subset_morph :
  forall x x', x == x' ->
  forall (P P':set->Prop), eq_pred x P P' ->
  subset x P == subset x' P'.
intros.
apply subset_ext; intros.
 rewrite <- H in H1.
 apply subset_intro; auto.
 red in H0.
 rewrite H0; trivial.

 rewrite <- H.
 apply subset_elim1 in H1; trivial.

 specialize subset_elim2 with (1:=H1); intro.
 destruct H2.
 apply subset_elim1 in H1.
 exists x1; trivial.
 red in H0.
 rewrite <- H0; trivial.
 rewrite <- H2; trivial.
Qed.

Lemma union_subset_singl : forall x (P:set->Prop) y y',
  y ∈ x ->
  y == y' ->
  P y' ->
  (forall y y', y ∈ x -> y' ∈ x -> P y -> P y' -> y == y') ->
  union (subset x P) == y.
intros.
symmetry; apply union_ext; intros.
 setoid_replace y with y0; trivial.
 elim subset_elim2 with (1:=H4); intros.
 rewrite H5.
 rewrite H0.
 apply H2; trivial.
 rewrite <- H0; trivial.
 rewrite <- H5.
 apply subset_elim1 with (1:=H4).

 exists y; trivial.
 rewrite H0.
 apply subset_intro; trivial.
 rewrite <- H0; trivial.
Qed.

(*Parameter replf : set -> (set->set) -> set.*)
Definition replf a (F:set->set) :=
  repl a (fun x y => y == F x).

Instance replf_mono_raw :
  Proper (incl_set ==> (eq_set ==> eq_set) ==> incl_set) replf.
unfold replf.
do 4 red; intros.
assert (xm : morph1 x0).
 do 2 red; intros.
 transitivity (y0 y1); auto.
 symmetry; apply H0; reflexivity.
assert (ym : morph1 y0).
 do 2 red; intros.
 transitivity (x0 x1); auto.
 symmetry; apply H0; reflexivity.
rewrite repl_ax in H1.
 rewrite repl_ax.
  destruct H1.
  exists x1; auto.
  rewrite H2; apply H0; reflexivity.

  intros.
  rewrite <- H4; rewrite H5; auto.

  intros.
  rewrite H3; rewrite H4; reflexivity.

 intros.
 rewrite <- H4; rewrite H5; auto.

 intros.
 rewrite H3; rewrite H4; reflexivity.
Qed.

Instance replf_morph_raw :
  Proper (eq_set ==> (eq_set ==> eq_set) ==> eq_set) replf.
do 3 red; intros.
apply eq_intro.
 apply replf_mono_raw; auto.
 rewrite H; reflexivity.

 symmetry in H0.
 apply replf_mono_raw; auto.
 rewrite H; reflexivity.
Qed.

Lemma replf_ax : forall a F z,
  ext_fun a F ->
  (z ∈ replf a F <-> exists2 x, x ∈ a & z == F x).
unfold replf; intros.
rewrite repl_ax; intros.
 split; intros.
  destruct H0.
  exists x; trivial.

  destruct H0.
  exists x; trivial.

 rewrite <- H2; rewrite H3; auto.

 rewrite H2; trivial.
Qed.

Lemma replf_intro : forall a F y x,
  ext_fun a F -> x ∈ a -> y == F x -> y ∈ replf a F.
Proof.
intros a F y x Fext H1 H2.
rewrite replf_ax; trivial.
exists x; trivial.
Qed.

Lemma replf_elim : forall a F y,
  ext_fun a F -> y ∈ replf a F -> exists2 x, x ∈ a & y == F x.
Proof.
intros a F y Fext H1.
rewrite replf_ax in H1; trivial.
Qed.

Lemma replf_ext : forall p a F,
  ext_fun a F ->
  (forall x, x ∈ a -> F x ∈ p) ->
  (forall y, y ∈ p -> exists2 x, x ∈ a & y == F x) ->
  p == replf a F.
intros.
apply eq_intro; intros.
 apply H1 in H2; destruct H2.
 apply replf_intro with x; auto.

 apply replf_elim in H2; trivial; destruct H2.
 rewrite H3; auto.
Qed.

Lemma replf_mono2 : forall x y F,
  ext_fun y F ->
  x ⊆ y ->
  replf x F ⊆ replf y F.
red; intros.
assert (ext_fun x F).
 do 2 red; auto.
apply replf_elim in H1; trivial.
destruct H1.
apply replf_intro with x0; auto.
Qed.

Lemma replf_morph_gen : forall x1 x2 F1 F2,
  ext_fun x1 F1 ->
  ext_fun x2 F2 ->
  eq_index x1 F1 x2 F2 ->
  replf x1 F1 == replf x2 F2.
Proof.
destruct 3.
apply replf_ext; intros; trivial.
 apply H2 in H3; destruct H3.
 apply replf_intro with x0; trivial.
 symmetry; trivial.

 apply replf_elim in H3; trivial; destruct H3.
 apply H1 in H3; destruct H3.
 rewrite H5 in H4.
 exists x0; auto.
Qed.

Lemma replf_morph : forall x1 x2 F1 F2,
  x1 == x2 ->
  eq_fun x1 F1 F2 ->
  replf x1 F1 == replf x2 F2.
intros.
apply replf_morph_gen; intros.
 apply eq_fun_ext in H0; trivial.

 do 2 red; intros.
 rewrite <- H in H1.
 transitivity (F1 x); auto.
 symmetry; apply H0; trivial; reflexivity.

 apply eq_index_eq; trivial.
Qed.

Lemma replf_empty : forall F, replf empty F == empty.
Proof.
intros.
apply empty_ext.
red; intros.
apply replf_elim in H.
 destruct H.
 elim empty_ax with (1:=H).

 do 2 red; intros.
 elim empty_ax with (1:=H0).
Qed.

Lemma compose_replf : forall A F G,
  ext_fun A F ->
  ext_fun (replf A F) G ->
  replf (replf A F) G == replf A (fun x => G (F x)).
intros.
assert (eGF : ext_fun A (fun x => G (F x))).
 red; red; intros.
 apply H0; auto.
 rewrite replf_ax; trivial.
 exists x; auto with *.
apply eq_intro; intros.
 rewrite replf_ax in H1; trivial.
 destruct H1.
 rewrite replf_ax in H1; trivial.
 destruct H1.
 rewrite replf_ax; trivial.
 exists x0; trivial.
 rewrite H2; apply H0; trivial.
 rewrite replf_ax; trivial.
 exists x0; trivial.

 rewrite replf_ax in H1; trivial.
 destruct H1.
 rewrite replf_ax; trivial.
 exists (F x); trivial.
 rewrite replf_ax; trivial.
 exists x; auto with *.
Qed.

(** Conditional set *)

  Definition cond_set P x := subset x (fun _ => P).

  Instance cond_set_morph : Proper (iff ==> eq_set ==> eq_set) cond_set.
do 3 red; intros.
apply subset_morph; trivial.
red; auto.
Qed.

  Lemma cond_set_ax P x z :
    z ∈ cond_set P x <-> (z ∈ x /\ P).
unfold cond_set.
rewrite subset_ax.
split; destruct 1; split; trivial.
 destruct H0; trivial.
 exists z; auto with *.
Qed.

 (* A more precise morphism lemma *)
 Lemma cond_set_morph2 : forall P Q x y,
    (P <-> Q) ->
    (P -> x == y) ->
    cond_set P x == cond_set Q y.
intros.
apply subset_ext; intros.
 rewrite <- H in H2.
 apply subset_intro; trivial.
 rewrite H0; trivial.

 rewrite cond_set_ax in H1; destruct H1.
 rewrite <- H0; trivial.

 rewrite cond_set_ax in H1; destruct H1.
 exists x0; auto with *.
 rewrite <- H; trivial.
Qed.

  Lemma cond_set_ok (P:Prop) x : P -> cond_set P x == x.
intro p.
apply eq_intro; intros.
 apply subset_elim1 in H; trivial.

 apply subset_intro; trivial.
Qed.

  Lemma cond_set_mt P x : ~P -> cond_set P x == empty.
intros.
apply empty_ext; red; intros.
rewrite cond_set_ax in H0.
destruct H0; auto.
Qed.

(** other properties of axioms *)

Lemma pair_commut : forall x y, pair x y == pair y x.
Proof.
intros.
apply pair_ext; intros; auto.
elim pair_elim with (1:=H); auto.
Qed.

Lemma pair_inv : forall x y x' y',
  pair x y == pair x' y' -> (x==x' /\ y==y') \/ (x==y' /\ y==x').
Proof.
intros.
assert (x ∈ pair x' y').
 rewrite <- H; auto.
 assert (y ∈ pair x' y').
  rewrite <- H; auto.
  elim pair_elim with (1 := H0); intros; elim pair_elim with (1 := H1);
   intros; auto.
   left; split; trivial.
     assert (y' ∈ pair x y).
    rewrite H; auto.
     rewrite H2 in H4.
       rewrite H3 in H4.
       rewrite H3.
      symmetry  in |- *.
      elim pair_elim with (1:=H4); trivial.
   right; split; trivial.
     assert (x' ∈ pair x y).
    rewrite H; auto.
     rewrite H2 in H4.
       rewrite H3 in H4.
       rewrite H3.
      symmetry  in |- *.
      elim pair_elim with (1:=H4); trivial.
Qed.

Lemma discr_mt_pair : forall a b, ~ empty == pair a b.
red; intros.
apply (empty_ax a).
rewrite H.
apply pair_intro1.
Qed.

(** macros *)
Definition singl x := pair x x.

Lemma singl_intro : forall x, x ∈ singl x.
Proof.
unfold singl in |- *; auto.
Qed.

Lemma singl_intro_eq : forall x y, x == y -> x ∈ singl y.
Proof.
intros.
 rewrite H; apply singl_intro.
Qed.

Lemma singl_elim : forall x y, x ∈ singl y -> x == y.
Proof.
unfold singl; intros.
elim pair_elim with (1:=H); auto.
Qed.

Lemma singl_ext :
  forall y x,
  x ∈ y ->
  (forall z, z ∈ y -> z == x) ->
  y == singl x.
Proof.
intros; apply eq_intro; intros.
 apply singl_intro_eq; auto.
  rewrite (singl_elim _ _ H1); trivial.
Qed.

Instance singl_morph : morph1 singl.
unfold singl; do 2 red; intros.
rewrite H; reflexivity.
Qed.

Lemma union_singl_eq : forall x, union (singl x) == x.
Proof.
intros; apply eq_intro; intros.
 elim union_elim with (1 := H); intros.
    rewrite <- (singl_elim _ _ H1); trivial.
 apply union_intro with (1 := H).
   apply singl_intro.
Qed.

Lemma singl_inj : forall x y, singl x == singl y -> x == y.
Proof.
intros.
rewrite <- (union_singl_eq x); rewrite <- (union_singl_eq y).
apply union_morph;trivial.
Qed.

(** Union of 2 sets *)
Definition union2 x y := union (pair x y).

Infix "∪" := union2.

Lemma union2_intro1: forall x y z, z ∈ x -> z ∈ union2 x y.
Proof.
unfold union2 in |- *; intros.
apply union_intro with x; trivial.
Qed.

Lemma union2_intro2: forall x y z, z ∈ y -> z ∈ union2 x y.
Proof.
unfold union2 in |- *; intros.
apply union_intro with y; trivial.
Qed.

Lemma union2_elim : forall x y z, z ∈ x ∪ y -> z ∈ x \/ z ∈ y.
Proof.
unfold union2; intros.
elim union_elim with (1:=H); intros.
elim pair_elim with (1:=H1); intro x0_eq; rewrite <- x0_eq; auto.
Qed.

Lemma union2_ax x y z : z ∈ x ∪ y <-> z ∈ x \/ z ∈ y.
split; intros.
 apply union2_elim in H; trivial.

 destruct H; [apply union2_intro1|apply union2_intro2]; auto.
Qed.

Lemma union2_mono : forall A A' B B',
  A ⊆ A' -> B ⊆ B' -> A ∪ B ⊆ A' ∪ B'.
red; intros.
red in H,H0|-.
elim union2_elim with (1:=H1); intros.
 apply union2_intro1; auto.
 apply union2_intro2; auto.
Qed.

Instance union2_morph : morph2 union2.
unfold union2; do 3 red; intros.
rewrite H; rewrite H0; reflexivity.
Qed.

Lemma union2_commut : forall x y, x ∪ y == y ∪ x.
Proof.
intros.
unfold union2; rewrite pair_commut; reflexivity.
Qed.

Lemma union2_mt_l x : empty ∪ x == x.
apply eq_set_ax; intros z; rewrite union2_ax.
split; auto.
destruct 1; trivial.
elim empty_ax with (1:=H).
Qed.

Lemma union2_mt_r x : x ∪ empty == x.
apply eq_set_ax; intros z; rewrite union2_ax.
split; auto.
destruct 1; trivial.
elim empty_ax with (1:=H).
Qed.

(** subtraction *)
Definition minus2 x y := subset x (fun x' => ~ (x' ∈ y)).

(** Upper bound of a family of sets *)

Definition sup x F := union (replf x F).

Lemma sup_ax : forall x F z,
  ext_fun x F ->
  (z ∈ sup x F <-> exists2 y, y ∈ x & z ∈ F y).
intros.
unfold sup.
rewrite union_ax.
split; destruct 1; intros.
 apply replf_elim in H1; auto; destruct H1.
 rewrite H2 in H0; clear H2.
 exists x1; trivial.

 exists (F x0); trivial.
 apply replf_intro with x0; trivial.
 reflexivity.
Qed.

Lemma sup_ext : forall y a F,
  ext_fun a F ->
  (forall x, x ∈ a -> F x ⊆ y) ->
  (forall z, z ∈ y -> exists2 x, x ∈ a & z ∈ F x) ->
  y == sup a F.
intros.
apply eq_intro; intros.
 rewrite sup_ax; auto.

 rewrite sup_ax in H2; trivial; destruct H2.
 apply H0 in H3; trivial.
Qed.

Lemma sup_morph_gen : forall a F b G,
  ext_fun a F ->
  ext_fun b G ->
  eq_index a F b G ->
  sup a F == sup b G.
unfold sup; intros.
apply union_morph; apply replf_morph_gen; trivial.
Qed.

Lemma sup_morph : forall a F b G,
  a == b ->
  eq_fun a F G ->
  sup a F == sup b G.
intros.
apply sup_morph_gen; intros.
 apply eq_fun_ext in H0; trivial.

 do 2 red; intros.
 rewrite <- H in H1.
 transitivity (F x); auto.
 symmetry; apply H0; trivial; reflexivity.

 apply eq_index_eq; trivial.
Qed.

Lemma sup_incl : forall a F x,
  ext_fun a F -> x ∈ a -> F x ⊆ sup a F.
intros.
red; intros.
rewrite sup_ax; trivial.
exists x; trivial.
Qed.
Hint Resolve sup_incl.

Lemma sup_lub x f A :
  ext_fun x f ->
  (forall y, y ∈ x -> f y ⊆ A) ->
  sup x f ⊆ A.
red; intros.
apply sup_ax in H1; trivial.
destruct H1 as (y,?,?).
apply H0 with (y:=y); trivial.
Qed.

Lemma replf_is_sup A F :
  ext_fun A F ->
  replf A F == sup A (fun x => singl (F x)).
intros.
assert (fm : ext_fun A (fun x => singl (F x))).
 do 2 red; intros; apply singl_morph; apply H; trivial.
apply eq_intro; intros.
 rewrite sup_ax; trivial.
 rewrite replf_ax in H0; trivial.
 revert H0; apply ex2_morph; red; intros; auto with *.
 split; intros.
  apply singl_elim in H0; trivial.
  rewrite H0; apply singl_intro.

 rewrite replf_ax; trivial.
 rewrite sup_ax in H0; trivial.
 revert H0; apply ex2_morph; red; intros; auto with *.
 split; intros.
  rewrite H0; apply singl_intro.
  apply singl_elim in H0; trivial.
Qed.

Lemma union_is_sup a :
  union a == sup a (fun x => x).
apply eq_intro; intros.
 rewrite sup_ax;[|do 2 red; auto].
 apply union_elim in H; destruct H.
 eauto.

 rewrite sup_ax in H;[|do 2 red; auto].
 destruct H; eauto using union_intro.
Qed.

Lemma power_sup_closed a I f :
  ext_fun I f ->
  (forall x, x ∈ I -> f x ∈ power a) ->
  sup I f ∈ power a.
intros fext tyf; apply power_intro; intros.
apply sup_ax in H; trivial.
destruct H as (?,?,tyz).
apply power_elim with (f x); auto.
Qed.

(** Conditional set *)

Definition if_prop P x y :=
  cond_set P x ∪ cond_set (~P) y.

Instance if_prop_morph : Proper (iff ==> eq_set ==> eq_set ==> eq_set) if_prop.
do 4 red; intros.
unfold if_prop.
apply union2_morph.
 apply cond_set_morph; auto.
 apply cond_set_morph; auto.
 rewrite H; reflexivity.
Qed.

Lemma if_left (P:Prop) x y : P -> if_prop P x y == x.
unfold if_prop; intros.
apply eq_intro; intros.
 apply union2_elim in H0; destruct H0.
  rewrite cond_set_ax in H0.
  destruct H0; trivial.

  rewrite cond_set_ax in H0; destruct H0; contradiction.

 apply union2_intro1; rewrite cond_set_ax; auto.
Qed.

Lemma if_right (P:Prop) x y : ~P -> if_prop P x y == y.
unfold if_prop; intros.
apply eq_intro; intros.
 apply union2_elim in H0; destruct H0.
  rewrite cond_set_ax in H0; destruct H0; contradiction.

  rewrite cond_set_ax in H0.
  destruct H0; trivial.

 apply union2_intro2; rewrite cond_set_ax; auto.
Qed.

(** Russel's paradox *)

Section Russell.

Variable U : set.
Variable universal : forall x, x ∈ U.

Definition russell_omega := subset U (fun x => ~ x ∈ x).

Lemma omega_not_in_omega : ~ russell_omega ∈ russell_omega.
Proof.
unfold russell_omega at 2 in |- *.
red in |- *; intro.
elim subset_elim2 with (1 := H); intros.
rewrite <- H0 in H1.
exact (H1 H).
Qed.

Lemma omega_in_omega : russell_omega ∈ russell_omega.
Proof.
unfold russell_omega at 2 in |- *.
apply subset_intro; trivial.
exact omega_not_in_omega.
Qed.

Lemma no_universal_set : False.
Proof (omega_not_in_omega omega_in_omega).

End Russell.

(** intersection *)

Definition inter x := subset (union x) (fun y => forall z, z ∈ x -> y ∈ z).

Lemma inter_empty_eq : inter empty == empty.
Proof.
unfold inter in |- *.
apply empty_ext; red in |- *; intros.
specialize subset_elim1 with (1 := H).
 rewrite union_empty_eq.
apply empty_ax.
Qed.

Lemma inter_intro :
  forall x a,
  (forall y, y ∈ a -> x ∈ y) ->
  (exists w, w ∈ a) -> (* non empty intersection *)
  x ∈ inter a.
Proof.
unfold inter in |- *; intros.
apply subset_intro; auto.
destruct H0 as (w,?).
apply union_intro with w; auto.
Qed.

Lemma inter_elim : forall x a y, x ∈ inter a -> y ∈ a -> x ∈ y.
Proof.
unfold inter in |- *; intros.
elim subset_elim2 with (1 := H); intros.
rewrite H1; auto.
Qed.

Lemma inter_non_empty :
  forall x y, y ∈ inter x -> exists2 w, w ∈ x & y ∈ w.
intros.
apply subset_elim1 in H.
rewrite union_ax in H; destruct H; eauto.
Qed.

Lemma inter_wit : forall X F, morph1 F ->
 forall x, x ∈ inter (replf X F) ->
 exists y, y ∈ X.
intros.
destruct inter_non_empty with (1:=H0).
rewrite replf_ax in H1.
2:red;red;intros; apply H; trivial.
destruct H1; eauto.
Qed.

Lemma inter_ext :
  forall i a,
  (forall y, y ∈ a -> i ⊆ y) ->
  (forall x, (forall y, y ∈ a -> x ∈ y) -> x ∈ i) ->
  (exists w, w ∈ a) ->
  i == inter a.
Proof.
unfold incl_set in |- *.
intros; apply eq_intro; intros.
 apply inter_intro; auto.

 apply H0; intros.
 apply inter_elim with (1 := H2); trivial.
Qed.

Instance inter_morph : morph1 inter.
unfold inter in |- *; do 2 red; intros.
apply subset_morph; intros;  eauto.
 apply union_morph; trivial.

 red in |- *; intros.
 split; intros.
 rewrite <- H in H2; auto.
 rewrite H in H2; auto.
Qed.

(** Binary intersection *)

Definition inter2 x y := inter (pair x y).

Infix "∩" := inter2.

Instance inter2_morph: morph2 inter2.
do 3 red; intros; apply inter_morph; apply pair_morph; trivial.
Qed.

Lemma inter2_def : forall x y z,
  z ∈ x ∩ y <-> z ∈ x /\ z ∈ y.
unfold inter2.
split; intros.
 split; apply inter_elim with (1:=H);
   [apply pair_intro1|apply pair_intro2].

 destruct H.
 apply inter_intro; [intros|exists x; apply pair_intro1].
 apply pair_elim in H1; destruct H1; rewrite H1; trivial.
Qed.

Instance inter2_mono : Proper (incl_set==>incl_set==>incl_set) inter2.
do 4 red; intros.
apply inter2_def in H1; destruct H1.
apply inter2_def; split; auto.
Qed.

Lemma inter2_incl1 : forall x y, x ∩ y ⊆ x.
red; intros.
rewrite inter2_def in H; destruct H; trivial.
Qed.

Lemma inter2_incl2 : forall x y, x ∩ y ⊆ y.
red; intros.
rewrite inter2_def in H; destruct H; trivial.
Qed.

Lemma inter2_incl a x y : a ⊆ x -> a ⊆ y -> a ⊆ x ∩ y.
red; intros; rewrite inter2_def; split; auto.
Qed.

Lemma incl_inter2 x y: x ⊆ y -> x ∩ y == x.
intros; apply eq_intro; intro z; rewrite inter2_def; auto.
destruct 1; trivial.
Qed.

Lemma inter2_comm x y :
  x ∩ y == y ∩ x.
apply eq_intro; intro z; do 2 rewrite inter2_def; destruct 1; auto.
Qed.


Require Import List Arith.
Require Import FSets FSetAVL FSetFacts FSetEqProperties FSetProperties.
Require Import Tools.

Ltac blast := solve [ auto |  discriminate | contradiction ].
Ltac cauto := try blast.
Lemma discr_rev {A} u (o : A) : ~ u = u++o::nil.
Proof.
  induction u.
  apply app_cons_not_nil.
  intro h;inversion h;cauto.
Qed.

Module Nat <: OrderedType.
  Definition t := nat.
  Definition eq (a b : t) := a=b.
  Definition lt (a b : t) := a<b.

  Lemma eq_refl : forall x : t, eq x x.
  Proof.
    intro; unfold eq; auto.
  Qed.

  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof.
    intro;unfold eq;auto.
  Qed.

  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof.
    intros x y z h h';unfold eq in *; rewrite h in *;auto.
  Qed.

  Definition lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z :=
    lt_trans.

  Definition lt_not_eq : forall x y : t, lt x y -> ~ eq x y :=
    NPeano.Nat.lt_neq.

  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    SearchAbout ({ _ } +  { _ } + { _ } ).
    intros x y; case (lt_eq_lt_dec x y) as [[h|h]|h];
    [apply LT
    |apply EQ
    |apply GT];auto.
  Qed.
  Definition eq_dec := eq_nat_dec.
End Nat.

Module NSet := FSetAVL.Make(Nat).
Module NF := FSetFacts.Facts NSet.
Module NP := FSetProperties.Properties NSet.

Lemma Equal_add : forall x s s', NSet.eq s s' ->
                                 NSet.eq (NSet.add x s) (NSet.add x s').
Proof.
  intros x s s' he.
  apply NP.Add_Equal;simpl; intro y;
  case (eq_nat_dec x y) as [->|h];split;intro h';
  [left
  |apply NSet.add_1
  |right;apply he;apply NSet.add_3 in h'
  |case h' as [->|h'];
    [absurd (y = y)
    |apply NSet.add_2;apply he]
  ]; auto.
Qed.

Variable L : nat.

Variable wd : nat.
Variable uf : nat.
Variable ub : nat.
Variable rd : nat.

Variable cmem :nat.

Inductive op_type : Set :=
| F : op_type
| Fb : op_type
| Wm  : op_type
| Wd  : op_type
| Rm  : op_type
| Rd  : op_type
| Dm  : op_type
| Dd  : op_type.

Definition op := (op_type * nat)%type.

Definition type (oi : op) :=
  match oi with
    | (o,i) => o
  end.
Definition index (oi : op) :=
  match oi with
    | (o,i) => i
  end.

Lemma eq_op_dec : forall x y : op, {x = y} + {x <> y}.
Proof.
  destruct x as (x,i);destruct x; destruct y as (y,j); destruct y;
  try (right;intro; blast);
  case (eq_nat_dec i j) as [ -> | h ];
    try (left;blast);
  right;intro h';inversion h';blast.
Qed.

Definition schedule := list op.

Definition cost (o : op) : nat :=
  match type o with
    | F => uf
    | Fb => ub
    | Wd => wd
    | Rd => rd
    | _ => 0
  end.

Definition cost_schedule (s : schedule) :=
  fold_left (fun c o => c + cost o) s 0.

Definition optimal s := forall s', cost_schedule s <= cost_schedule s'.

Lemma opt_leq s1 s2 : optimal s1 -> cost_schedule s2 <= cost_schedule s1 ->
                      optimal s2.
Proof.
  intros h1 h2 s; apply (le_trans _ (cost_schedule s1)); cauto.
Qed.

Lemma cost_unit : forall u op , cost_schedule (op::u) = cost op + cost_schedule u.
Proof.
  assert (forall u k l, fold_left (fun (c : nat) (o : op) => c + cost o) u (k + l)=
                      k + fold_left plus (map cost u) l).
  induction u;auto.
  unfold cost_schedule in *;simpl.
  intros k l;rewrite IHu;auto.
  rewrite<- plus_assoc;f_equal;auto.
  rewrite<- IHu.
  apply eq_trans with (0+fold_left plus (map cost u) (l + cost a));auto;rewrite<- IHu;auto.

  intros u op; unfold cost_schedule;simpl.
  replace (cost op) with (cost op+0);repeat rewrite H;auto.
  rewrite<- plus_assoc;f_equal;auto.
  simpl;replace (0) with (0+0);auto;rewrite H;auto.
Qed.

Lemma cost_app u v :
  cost_schedule (u++v) = cost_schedule u + cost_schedule v.
Proof.
  induction u.
  auto.
  simpl;repeat rewrite cost_unit;rewrite<- plus_assoc;f_equal;auto.
Qed.

Lemma cost_rev : forall u, cost_schedule u = cost_schedule (rev u).
Proof.
  assert (forall u k, fold_left (fun (c : nat) (o : op) => c + cost o) u k=
                     fold_left plus (map cost u) k).
  induction u;auto.
  unfold cost_schedule in *;simpl.
  intros k;rewrite IHu;auto.

  assert (forall u k, fold_right (fun y x : nat => x + y) k u =
                      fold_right plus k u).
  induction u;intro;simpl;try rewrite IHu;auto with arith.

  intro u; unfold cost_schedule;repeat rewrite H.
  rewrite<- fold_left_rev_right.
  rewrite map_rev.
  rewrite fold_symmetric;auto with arith.
Qed.

Definition memory := NSet.t.
Definition disk := NSet.t.
Definition buffer := nat.
Definition state := (buffer * buffer * memory * disk) %type.
Definition get_top (e : state) :=
  match e with (t,b,m,d) => t end.
Definition get_bottom (e : state) :=
  match e with (t,b,m,d) => b end.
Definition get_memory (e : state) :=
  match e with (t,b,m,d) => m end.
Definition get_disk (e : state) :=
  match e with (t,b,m,d) => d end.

Definition equiv e f :=
  get_top e = get_top f
  /\ get_bottom e = get_bottom f
  /\ NSet.eq (get_memory e) (get_memory f)
  /\ NSet.eq (get_disk e) (get_disk f).

Notation "e ≡ f" := (equiv e f) (at level 20).

Lemma equiv_refl e :
  e ≡ e.
Proof.
repeat split; auto.
Qed.

Lemma equiv_sym e f :
  e ≡ f -> f ≡ e.
Proof.
intro H. destruct H as (h0 & h1 & h2 & h3).
unfold equiv; rewrite h1 in *.
split ; [|split;[|split]];auto;apply NSet.eq_sym; auto.
Qed.

Lemma equiv_trans f e g :
  e ≡ f -> f ≡ g -> e ≡ g .
Proof.
intros (h0 & h1 & h2 & h3) (hh0 & hh1 & hh2 & hh3).
unfold equiv; rewrite h0 in *.
rewrite h1 in *; rewrite h2 in *; rewrite h3 in *; rewrite hh1 in *.
split ; [|split;[|split]];auto;apply NSet.eq_sym; auto.
Qed.

Definition size_memory e := NSet.cardinal (get_memory e).

Definition bound_memory e :=
  size_memory e <= cmem.

Definition rmv := remove (eq_nat_dec).

Definition eval_op o e : state :=
  let i := index o in
  match type o with
    | F => (i+1,get_bottom e,get_memory e,get_disk e)
    | Fb => (i,i,get_memory e, get_disk e)
    | Wm => (i,get_bottom e,NSet.add i (get_memory e),get_disk e)
    | Wd => (i,get_bottom e,get_memory e,NSet.add i (get_disk e))
    | Rm => (i,get_bottom e,get_memory e,get_disk e)
    | Rd => (i,get_bottom e,get_memory e,get_disk e)
    | Dm => (get_top e,get_bottom e,NSet.remove i (get_memory e),get_disk e)
    | Dd => (get_top e,get_bottom e,get_memory e,NSet.remove i (get_disk e))
  end.

Definition eval_schedule e s :=
  fold_right eval_op e s.

Definition useless e o :=
  eval_op o e ≡ e.

Definition valid_op e o : Prop :=
  let i := index o in
  match type o with
    | F => get_top e = i
    | Fb => get_top e = i /\ get_bottom e = i+1
    | Wm => get_top e = i /\ size_memory e < cmem
    | Wd => get_top e = i
    | Rm => NSet.In i (get_memory e)
    | Rd => NSet.In i (get_disk e)
    | Dm => NSet.In i (get_memory e)
    | Dd => NSet.In i (get_disk e)
  end.

Inductive valid_schedule : state -> schedule -> Prop :=
| vempty e s : s = nil -> valid_schedule e s
| vcons e o s : valid_op (eval_schedule e s) o -> valid_schedule e s ->
                valid_schedule e (o::s).

Hint Constructors valid_schedule.

Lemma same_size_mem e f :
  e ≡ f -> size_memory e = size_memory f.
Proof.
  intros (h1 & h2 & h3 & h4).
  apply NP.Equal_cardinal;cauto.
Qed.

Lemma equiv_valid_op e f :
  e ≡ f -> (forall o, valid_op e o -> valid_op f o ).
Proof.
intros (h0 & h1 & h2 & h3) o h. unfold valid_op in *.
destruct o as (o & i); destruct o; simpl in *;
try rewrite <- h0;try rewrite <- h1;try apply h2;try apply h3;auto.
destruct h as (h4 & h5c);
  split;
  [|replace (size_memory f) with (size_memory e);
     [|apply same_size_mem;split;[|split;[|split]]]];auto.
Qed.

Lemma equiv_eval_op e f :
  e ≡ f -> (forall o, eval_op o e ≡ eval_op o f ).
Proof.
  intros (h0 & h1& h2 & h3) (o & i); unfold eval_op; destruct o;simpl.
  repeat (split;auto).
  repeat (split;auto).
  split;[|split;[|split]];auto;apply Equal_add; auto.
  split;[|split;[|split]];auto;apply Equal_add; auto.
  repeat (split;auto).
  repeat (split;auto).
  split;[|split;[|split]];auto;apply NP.Equal_remove;auto.
  split;[|split;[|split]];auto;apply NP.Equal_remove;auto.
Qed.

(*
Lemma valid_prefix e :
  forall a s, valid_schedule e (a::s) ->
     (valid_op e a /\ valid_schedule (eval_op e a) s).
Proof.
Admitted.
*)
Lemma equiv_eval e f :
  e ≡ f -> (forall s, eval_schedule e s ≡ eval_schedule f s ).
Proof.
  cut (forall s e f, e ≡ f -> eval_schedule e s ≡ eval_schedule f s);
  [intros h1 h2 s;apply (h1 _ e)
  |induction s; intros e' f' h1;  unfold eval_schedule in * ; simpl;
   [|apply equiv_eval_op;apply IHs]]; assumption.
Qed.
Lemma equiv_valid e f :
  e ≡ f -> (forall s, valid_schedule e s -> valid_schedule f s ).
Proof.
  cut (forall s e f, e ≡ f -> valid_schedule e s -> valid_schedule f s);
  [ intros h1 h2 s;apply (h1 _ e)
   |induction s;
     [|intros e' f' h1 h2;inversion h2;
       [|apply vcons;
          [apply (equiv_valid_op (eval_schedule e' s));[apply equiv_eval|]|]]]];cauto.
  apply (IHs e');cauto.
Qed.

Lemma eval_app s1 s2 :
  forall e,
    eval_schedule e (s1 ++ s2) = eval_schedule (eval_schedule e s2) s1.
Proof.
  intros;unfold eval_schedule;rewrite fold_right_app;auto.
Qed.

(** Décomposition de la validité d'un schedule le long d'une concaténation. *)
Lemma valid_app s1 s2 : forall e,
  valid_schedule e (s1 ++ s2) <->
  valid_schedule e s2 /\ valid_schedule (eval_schedule e s2) s1.
Proof.
  induction s1;split; intro Hvs.
  rewrite app_nil_l in *;split;[|apply vempty]; cauto.
  rewrite app_nil_l; destruct Hvs; simpl in *; cauto.

  inversion Hvs;cauto;
  apply IHs1 in H3 as (h1&h2);split;
  [|apply vcons;
     [unfold eval_schedule in *;rewrite<- fold_right_app|]];cauto.
  destruct Hvs as (h1 & h2);simpl;inversion h2;cauto;apply vcons.
  unfold eval_schedule in *;rewrite fold_right_app;cauto.
  apply IHs1;auto.

Qed.

Notation "[ a , b ]" := ((a,b)::nil) (at level 50).

Inductive effacement (P : list op -> op -> Prop) :
  list op -> list op -> Prop :=
| effnil : effacement P nil nil
| effcons1 u v x : effacement P u v -> P u x ->
                   effacement P (x::u) v
| effcons2 u v x : effacement P u v -> ~ P u x ->
                   effacement P (x::u) (x::v).

Lemma invert_eff P u v :
  effacement P u v ->
  (u = nil /\ v = nil)
  \/ (exists x u1, u = x::u1 /\ effacement P u1 v /\ P u1 x)
  \/ (exists x u1 v1, u = x::u1 /\ v=x::v1 /\ effacement P u1 v1 /\ ~P u1 x).
Proof.
  intro h; induction h.
  left;auto.
  right;left;exists x;exists u;auto.
  right;right;exists x;exists u;exists v;auto.
Qed.

Lemma eff_cost P u v : effacement P u v -> cost_schedule v <= cost_schedule u.
Proof.
  intro h;induction h;simpl in *;auto;
  repeat rewrite cost_unit;auto with arith.
  rewrite plus_comm; apply le_plus_trans;auto.
Qed.

Lemma eff_opt P u v : effacement P u v -> optimal u -> optimal v.
Proof.
  intros h1 h2;apply eff_cost in h1;apply (opt_leq u);auto.
Qed.

Lemma eff_eval (P : list op -> op -> Prop) :
  (forall u x, P u x -> forall e, useless (eval_schedule e u) x) ->
  forall u v, effacement P u v ->
              forall e, (eval_schedule e u) ≡ (eval_schedule e v).
Proof.
  intros h.
  induction u;intros;auto.
  destruct v;auto.
  simpl;repeat split;auto.
  apply invert_eff in H as [(h1 & h2)|[(x & u & h1 & h2 & h3)|(x & u & v1 & h1 & h2 & h3 & h4)]];
  simpl in *;cauto.
  apply invert_eff in H as [(h1 & h2)|[(o & u1 & h1 & h2 & h3)|(o & u1 & v1 & h1 & h2 & h3 & h4)]];
    simpl in *;cauto.
  inversion h1.
  apply (equiv_trans ( eval_schedule e u1 )).
  unfold useless  in h;  apply (h _ _ );cauto.
  rewrite <- H1 in *;apply IHu;auto.
  rewrite  h2 in *;inversion h1;rewrite <- H1 in *;  simpl;apply equiv_eval_op;
  apply IHu;auto.
Qed.

Lemma eff_valid (P : list op -> op -> Prop) :
  (forall u x, P u x -> forall e, useless (eval_schedule e u) x) ->
  forall u v, effacement P u v ->
              forall e, (valid_schedule e u) -> (valid_schedule e v).
Proof.
  intros h.
  induction u;intros;auto.
  destruct v;auto.
  simpl;repeat split;auto.
  apply invert_eff in H as [(h1 & h2)|[(x & u & h1 & h2 & h3)|(x & u & v1 & h1 & h2 & h3 & h4)]];
  simpl in *;cauto.
  apply invert_eff in H as [(h1 & h2)|[(o & u1 & h1 & h2 & h3)|(o & u1 & v1 & h1 & h2 & h3 & h4)]];
    simpl in *;cauto.
  inversion h1;  apply IHu; rewrite H2;auto.
  rewrite H2 in *;inversion H0;cauto.

  inversion H0;cauto.
  inversion h1; rewrite <- H7 in *;rewrite H6 in *; clear H H1 H6 H7 H2; rewrite h2 in *;apply vcons.
  apply (equiv_valid_op (eval_schedule e u));cauto.
  apply (eff_eval P);cauto.

  apply IHu;cauto.
Qed.

(*
Definition no_double_write_mem_i s (i : nat) :=
  ~ (exists s1 s2 s3, s = s1 ++ [Wm,i] ++ s2 ++ [Wm,i] ++ s3
                      /\ ~ In (Dm,i) s2).

Fixpoint remove_write_mem_i s (i : nat) :=
  match s with
    | nil => nil
    | (Dm,j)::s => if beq_nat i j
                   then (Dm,j)::s
                   else (Dm,j)::(remove_write_mem_i s i)
    | (Wm,j)::s => if beq_nat i j
                   then remove_write_mem_i s i
                   else (Wm,j)::(remove_write_mem_i s i)
    | oi::s => oi::(remove_write_mem_i s i)
  end.*)

Lemma ndw_eff_ex :
   forall s : list op, exists s',
                         effacement
                           (fun u x => exists i, x = (Wm,i)
                                                   /\ exists u1 u2, u = u1 ++ [Wm,i] ++ u2
                                                                      /\ ~ In (Dm,i) u1)
                           s s'.
Proof.
  induction s.
  exists nil;apply effnil.
  destruct IHs as (s' & IHs).
  set (op:=a);assert (op=a) as hop;auto.
  destruct a as (o,k); destruct o; simpl;
  try (exists (op::s');rewrite hop in *;
              apply effcons2;
              try intros (i & hx & hu);blast).
  assert  (forall u0,
             (exists u1 u2, u0 = u1 ++ (Wm, k) :: u2 /\ ~ In (Dm, k) u1)\/
             ~(exists u1 u2, u0 = u1 ++ (Wm, k) :: u2 /\ ~ In (Dm, k) u1)).
  induction u0.
  right;intros (u1 & u2 & h1 & h2); apply app_cons_not_nil in h1;auto.
  destruct IHu0 as [(u1 & u2 & h1 & h2)| h].
  case (eq_op_dec (Dm,k) a) as [<-|h].
  right;intros (u3 & u4 & h3 & h4).
  destruct u3;simpl in *;cauto.
  inversion h3.
  contradict h4;left;auto.
  left;exists (a::u1);exists u2;split;simpl.
  f_equal;auto.
  intros [ha|hu];[symmetry in ha|];cauto.
  case (eq_op_dec (Wm,k) a) as [<-|ha].
  left;exists nil;exists u0;split;auto.
  right;intros (u3 & u4 & h3 & h4).
  apply h.
  destruct u3.
  contradict ha;simpl in *;inversion h3;auto.
  exists u3; exists u4.
  inversion h3;split;[|intro;apply h4;right];auto.

  case (eq_op_dec (Wm,k) op) as [<-|h];
    [case (H s) as [(u1 & u2 & h1 & h2)|hp]|];
    [exists s'|exists ((Wm,k)::s')  |exists (op::s')];
  [apply effcons1;[|exists k;split];auto;
   exists u1;exists u2;auto| |];
  apply effcons2;auto.
  intros (i & h & hp');inversion h.
  rewrite H1 in *;cauto.
Qed.

(*Fixpoint remove_double_write_mem s :=
  match s with
    | nil => nil
    | (Wm,i)::s =>
      (Wm,i)::(remove_write_mem_i (remove_double_write_mem s) i)
    | oi::s => oi::(remove_double_write_mem s)
  end.*)

(*
Lemma correct_rdwm s e :
  eval_schedule e s ≡ eval_schedule e (remove_double_write_mem s).
Admitted.
Lemma valid_rdwm s e :
  valid_schedule e s ->
  valid_schedule e (remove_double_write_mem s).
Admitted.
Lemma optimal_rdwm s e :
  optimal_schedule e s ->
  optimal_schedule e (remove_double_write_mem s).
Admitted.*)

(** tentative motif *)

Definition motif P (u : schedule) :=
  exists u1 u2 u3, u = u1 ++ u2 ++ u3 /\ P u1 u2 u3.

Definition ppt1 (u1 u2 u3 : schedule) :=
  exists i v, u2 = (Wm,i)::v++(Wm,i)::nil /\ ~ In (Dm,i) v.

Definition motif1 := motif ppt1.

Definition f1 (u2 :schedule) :=
  match u2 with
    | nil => nil
    | a::v => v
  end.

Lemma strong_induction :
  forall n P,
    P 0 -> (forall n, (forall m, m<n -> P m) -> P n)
    -> P n.
Proof.
  cut (forall n P, (forall k, k <= 0 -> P k) ->
                   (forall n, (forall m, m <= n -> P m)
                              -> (forall m, m<= S n -> P m))
                ->  (forall m, m<= n -> P m)).
  intros h n P p0 hind.
  apply (h n);auto.
  intros k hk;apply le_n_0_eq in hk as <-;auto.
  intros m hind2 k hk.
  apply hind;intros l hl.
  apply hind2;
  apply lt_n_Sm_le;apply (lt_le_trans _ k);auto.

  intros n P p0 hind.
  induction n.
  intros;auto.
  apply hind;auto.
Qed.

Lemma strong_induction_list {A}  :
  forall f (P : list A -> Prop), (forall l, f l = 0 -> P l) ->
            (forall l, (forall m, f m < f l -> P m) -> P l)
            -> forall l, P l.
Proof.
  intros f P h0 hind l; set (ln := f l);
  assert (f l = ln) as hln; auto.
  cut (forall l, f l = ln -> P l).
  intros h1;auto.
  apply (strong_induction ln).
  apply h0.
  intros n hi m hm.
  apply hind.
  intros k hk; apply (hi (f k)).
  rewrite <- hm;auto.
  auto.
Qed.

Lemma destruct_motif P :
  (forall u1 u2 u3, Decidable.decidable (P u1 u2 u3)) ->
  forall u, (motif P u \/ ~ motif P u).
Proof.
Admitted.

Lemma fun_no_motif
      (P : schedule -> schedule -> schedule -> Prop)
      (dejafait : schedule -> Prop) :
  forall f : schedule -> schedule,
  forall mes : schedule -> nat,
    (forall u1 u2, mes (u1 ++ u2) = mes u1 + mes u2) ->
    (forall u1 u2 u3, Decidable.decidable (P u1 u2 u3)) ->
    (forall u2 u1 u3,
       P u1 u2 u3 ->
       ~ (P u1 (f u2) u3)
       /\ mes (f u2) < mes u2
       /\ cost_schedule (f u2) <= cost_schedule u2
       /\ (forall e,
             eval_schedule e ((f u2) ++ u3) ≡ eval_schedule e (u2++u3))
       /\ (forall e,
             valid_schedule e (u2++ u3) ->
             valid_schedule e ((f u2)++u3))
       /\ (dejafait (u1++(f u2)++u3) -> dejafait (u1++u2++u3)))
    -> forall (u : schedule),
       exists v,
         ~ motif P v
         /\ (cost_schedule v <= cost_schedule u)
         /\ (forall e, eval_schedule e u ≡ eval_schedule e v)
         /\ (forall e, valid_schedule e u -> valid_schedule e v)
         /\ (dejafait v -> dejafait u).
Proof.
  intros f mes hmes hdec h.
  apply (strong_induction_list mes);
    intros.
  case (destruct_motif P hdec l) as [(u1 & u2 & u3 & hl & hp )|mot].
  apply h in hp as (hp & hm & hc & he & hv & hd).
  exfalso.
  apply (lt_n_0 (mes (f u2))).
  apply (lt_le_trans _ (mes u2));auto.
  rewrite <- H;rewrite hl;repeat rewrite hmes.
  rewrite plus_comm;rewrite <- plus_assoc;
  auto with arith.
  exists l;repeat split;auto.
  case (destruct_motif P hdec l) as [(u1 & u2 & u3 & hl & hp )|mot].
  apply h in hp as (hp & hm & hc & he & hv & hd).
  assert (mes (u1++ f u2 ++ u3) < mes l).
  rewrite hl;repeat rewrite hmes.
  apply plus_lt_compat_l; apply plus_lt_compat_r;auto.
  apply H in H0 as (v & hmot & hcost & hev & hval & hdej).
  rewrite hl in *;
    exists v; split;[|split;[|split;[|split]]];intros; auto.
  apply (le_trans _ (cost_schedule (u1 ++ f u2 ++ u3))).
  auto.
  repeat rewrite cost_app.
  apply plus_le_compat_l.
  apply plus_le_compat_r.
  auto.
  apply (equiv_trans (eval_schedule e (u1 ++ f u2 ++ u3))).
  repeat rewrite (eval_app u1);apply equiv_eval;apply equiv_sym;auto.
  apply hev.
  apply hval;rewrite valid_app in H0;
  destruct H0 as (hu1 & hu2);auto.
  apply valid_app;split.
  apply hv;auto.
  apply (equiv_valid (eval_schedule e (u2 ++ u3)));auto.
  apply equiv_sym; apply he;auto.
  exists l; split;[|split;[|split]];auto.
  intros;apply equiv_refl.
Qed.

Lemma mot1 :
forall u, optimal u -> (forall e, valid_schedule e u)
->
       exists v,
         ~ motif ppt1 v
         /\ (cost_schedule v <= cost_schedule u)
         /\ (forall e, eval_schedule e u ≡ eval_schedule e v)
         /\ (forall e, valid_schedule e u -> valid_schedule e v).


Require Import Gc.Util.
Require Import Bool Arith String List ListSet Vector CpdtTactics.

(** model pointers as nats *)
Definition ptr := nat.
Definition ptr_eq_dec := eq_nat_dec.

(** model vars as nats too, a bit silly so probably change later *)
Definition var := string.
Definition var_eq_dec := string_dec.

Definition var_ptr_eq_dec : forall (l r: var * ptr), {l = r} + {l <> r}.
  Hint Resolve ptr_eq_dec var_eq_dec.
  decide equality.
Qed.

(** Types of values we can have in the heap *)
Inductive val : Type :=
| Int : nat -> val
| Pointer : ptr -> val
.

(** We will model heaps as lists of pointers and values. *)
Definition heap_t := list (ptr * list val).

Inductive valexp :=
| IntExp : nat -> valexp       (* n *)
| Deref : var -> nat -> valexp (* v[n] *)
.

Inductive com :=
| New : var -> list valexp -> com         (* var = malloc(length l) ; var[:] = l *)
| AssignMem : var -> nat -> valexp -> com (* var[i] = val *)
| AssignVar : var -> valexp -> com        (* assert(type(val) = Ptr) : var = val *)
| Drop : var -> com                       (* del var *)
| Out : valexp -> com                     (* assert(type(val) = Int) ; print(val) *)
.

(** roots is the top level var to pointers, output is ouput of the program *)
Definition roots_t := list (var * ptr).

Fixpoint roots_get (v:var) (r:roots_t) : option ptr :=
match r with
| List.nil => None
| (hv, hp)::t => if var_eq_dec hv v then Some hp else (roots_get v t)
end.
Definition roots_set (r: roots_t) (v: var) (p:ptr) : roots_t := (v,p)::r.
Definition roots_unset (r: roots_t) (v: var) : roots_t :=
  match roots_get v r with
  | Some p => List.remove var_ptr_eq_dec (v,p) r
  | None => r
  end.

Definition roots_maps (r: roots_t) (v: var) (p: ptr) : Prop :=
  List.In (v,p) r.

Lemma roots_maps_get :
  forall r v p,
    roots_maps r v p ->
    roots_get v r = Some p.
Proof.
Admitted.

Lemma roots_get_maps :
  forall r v p,
    roots_get v r = Some p ->
    roots_maps r v p.
Proof.
Admitted.

Lemma roots_maps_uniq :
  forall r v p p',
    roots_maps r v p ->
    roots_maps r v p' ->
    p = p'.
Proof.
Admitted.

Lemma roots_unset_1 :
  forall r v p,
    roots_maps (roots_unset r v) v p ->
    False.
Proof.
Admitted.

Lemma roots_unset_2 :
  forall r v v' p,
    v' <> v ->
    roots_maps r v p ->
    roots_maps (roots_unset r v') v p.
Proof.
Admitted.

Lemma roots_unset_3 :
  forall r v v' p,
    v' <> v ->
    roots_maps (roots_unset r v') v p ->
    roots_maps r v p.
Proof.
Admitted.

Lemma roots_set_1 :
  forall r v p p1,
    roots_maps (roots_set r v p) v p1 ->
    p = p1.
Proof.
Admitted.

Lemma roots_set_2 :
  forall r v p,
    roots_maps (roots_set r v p) v p.
Proof.
Admitted.

Lemma roots_set_3 :
  forall r v v1 p p1,
    v <> v1 ->
    roots_maps (roots_set r v p) v1 p1 ->
    roots_maps r v1 p1.
Proof.
Admitted.

Lemma roots_set_4 :
  forall r v v1 p p1,
    v <> v1 ->
    roots_maps r v1 p1 ->
    roots_maps (roots_set r v p) v1 p1.
Proof.
Admitted.

Definition output_t := list nat.

Fixpoint heap_get_struct (p:ptr) (h:heap_t) : option (list val) :=
match h with
| List.nil => None
| (hp, hv)::t =>
  if ptr_eq_dec hp p then
    Some hv
  else
    (heap_get_struct p t)
end.

(** val evaluation and helpers *)
Definition heap_get (p:ptr) (k: nat) (h:heap_t) : option val :=
match heap_get_struct p h with
| None => None
| Some hv => List.nth_error hv k
end.

Definition heap_maps (h: heap_t) (p: ptr) (k: nat) (v: val) : Prop :=
  heap_get p k h = Some v
.

Definition heap_maps_struct (h: heap_t) (p: ptr) (vs: list val) : Prop :=
  heap_get_struct p h = Some vs
.

Fixpoint set_nth {A: Type} (n: nat) (v: A) (l: list A) : option (list A) :=
  match n, l with
  | 0, h::t => Some (v::t)
  | S(n'), h::t =>
    match set_nth n' v t with
    | Some l' => Some (h::l')
    | None => None
    end
  | _, _ => None
  end.

Fixpoint heap_set_k (h: heap_t) (p: ptr) (k: nat) (v: val) : option heap_t :=
match h with
| List.nil => None
| (hp, hv)::t =>
  if ptr_eq_dec hp p then
    match set_nth k v hv with
    | Some hv' => Some ((hp,hv')::t)
    | None => None
    end
  else
    match heap_set_k t p k v with
    | Some h' => Some ((hp,hv)::h')
    | None => None
    end
end
.

Ltac funfold name :=
  unfold name in * ; fold name in *.

Lemma heap_sets_implies_exists_heap_maps_struct :
  forall h h' p k v,
    heap_set_k h p k v = Some h' ->
    exists vs, heap_maps_struct h p vs.
Proof.
  induction h. crush.
  intros.
  funfold heap_set_k.
  destruct a.
  funfold heap_maps_struct.
  funfold heap_get_struct.
  destruct (ptr_eq_dec p0 p).
  * eauto.
  * destruct (heap_set_k h p k v) eqn:?.
    - crush.
      specialize (IHh h0 p k v).
      intuition.
    - discriminate.
Qed.

Lemma heap_set_fails_implies_no_exists_heap_maps_struct :
  forall h p k v,
    heap_set_k h p k v = None ->
    ~exists vs, heap_maps_struct h p vs.
Proof.
  induction h ; unfold not ; intros.
  * funfold heap_maps_struct.
    funfold heap_get_struct.
    destruct H0.
    discriminate.
  * funfold heap_set_k.
    destruct a.
    destruct (ptr_eq_dec p0 p) eqn:?.
    - destruct (set_nth k v l) eqn:?.
      discriminate.
      destruct H0.
Admitted.

Lemma heap_sets_implies_heap_maps_1 :
  forall h h' p k v,
    heap_set_k h p k v = Some h' ->
    heap_maps h' p k v.
Proof.
Admitted.

Lemma heap_sets_implies_heap_maps_2 :
  forall h h' p p' k k' v v',
    heap_set_k h p k v = Some h' ->
    (p <> p' \/ k <> k') ->
    heap_maps h  p' k' v' ->
    heap_maps h' p' k' v'.
Proof.
Admitted.

Lemma heap_sets_implies_heap_maps_3 :
  forall h h' p p' k k' v v',
    heap_set_k h p k v = Some h' ->
    (p <> p' \/ k <> k') ->
    heap_maps h' p' k' v' ->
    heap_maps h  p' k' v'.
Proof.
Admitted.

Lemma set_nth_sets : forall {A: Type} k v (l l0: list A),
  set_nth k v l = Some l0 ->
  List.nth_error l0 k = Some v.
Proof.
  induction k; intros.
  * simpl in *.
    destruct l; crush.
  * simpl in *.
    destruct l.
    - crush.
    - destruct (set_nth k v l) eqn:?.
      + crush; eauto.
      + discriminate.
Qed.

(* Must be proven for liveness *)
Theorem heap_maps_struct_indexable : forall p h vs,
  heap_maps_struct h p vs ->
  forall a, List.In a vs ->
  exists k, heap_maps h p k a
.
Proof.
  Hint Resolve In_nth_error.
  Hint Unfold heap_maps heap_get.
  intros.
  unfold heap_maps.
  unfold heap_get.
  destruct p; crush.
Qed.

Theorem heap_get_implies_heap_maps : forall p h vs k v,
  heap_get_struct p h = Some vs ->
  nth_error vs k = Some v ->
  heap_maps h p k v
.
Proof.
  intros.
  unfold heap_maps.
  unfold heap_get.
  crush.
Qed.

Lemma heap_maps_implies_heap_get :
  forall h p n v,
  heap_maps h p n v ->
  exists vs,
    heap_get_struct p h = Some vs
    /\
    List.nth_error vs n = Some v
.
Proof.
  induction h ; intros.
  * inversion H.
  * specialize IHh with p n v.
    destruct a.
    unfold heap_get_struct.
    unfold heap_maps in *.
    unfold heap_get in *.
    destruct (ptr_eq_dec p0 p) eqn:?.
    - exists l. crush.
      destruct (ptr_eq_dec p p); crush.
    - crush.
      destruct (ptr_eq_dec p0 p); crush.
Qed.

Lemma heap_maps_struct_cons :
  forall h p p1 l vs,
    heap_maps_struct ((p1, l) :: h) p vs ->
    p <> p1 ->
    heap_maps_struct h p vs
.
Proof.
  intros.
  unfold heap_maps_struct in H.
  unfold heap_get_struct in H.
  fold heap_get_struct in H.
  destruct (ptr_eq_dec p1 p); crush.
Qed.

Lemma heap_get_in :
  forall p v h,
    heap_get_struct p h = Some v ->
    List.In p (fst (split h)).
Proof.
  induction h. crush.
  destruct a.
  unfold heap_get_struct in * ; fold heap_get_struct in *.
  edestruct ptr_eq_dec.
  + intros. subst.
    eapply in_split_l_ht. apply ptr_eq_dec. right. reflexivity.
  + intuition.
    eapply in_split_l_ht. apply ptr_eq_dec. left. auto.
Qed.

Record state := mkState {
                    roots : roots_t;
                    heap : heap_t;
                    output: output_t;
                  }.

Fixpoint max_heap_idx (h: heap_t) : ptr :=
  match h with
  | List.nil => 0
  | (p,_)::t =>
    if le_gt_dec p (max_heap_idx t) then
      (max_heap_idx t)
    else
      p
  end.

Fixpoint max_struct_val (l: list val) : ptr :=
  match l with
  | List.nil => 0
  | (Int _) :: t => max_struct_val t
  | (Pointer p) :: t =>
    if le_gt_dec p (max_struct_val t) then
      (max_struct_val t)
    else
      p
  end.

Fixpoint max_heap_val (h: heap_t) : ptr :=
  match h with
  | List.nil => 0
  | (_,v)::t =>
    if le_gt_dec (max_struct_val v) (max_heap_val t) then
      (max_heap_val t)
    else
      (max_struct_val v)
  end.

Definition max_heap (h: heap_t) : ptr :=
  if le_gt_dec (max_heap_idx h) (max_heap_val h) then
    (max_heap_val h)
  else
    (max_heap_idx h)
.

Fixpoint max_root (r: roots_t) : ptr :=
  match r with
  | List.nil => 0
  | (_,p)::t =>
    if le_gt_dec p (max_root t) then
      (max_root t)
    else
      p
  end.

Definition max_state (s: state) :=
  if le_gt_dec (max_heap (heap s)) (max_root (roots s)) then
    (max_root (roots s))
  else
    (max_heap (heap s))
.

Definition fresh_ptr (s: state) : ptr :=
  S (max_state s).

Definition eval_valexp (r: roots_t) (h: heap_t) (v: valexp) : option val :=
  match v with
  | IntExp i => Some (Int i)
  | Deref var idx =>
    match roots_get var r with
    | Some p => heap_get p idx h
    | None => None
    end
  end.

Definition update_heap (r: roots_t) (h: heap_t) (lhv: var) (lhidx: nat) (rhv: val) : option heap_t :=
  match roots_get lhv r with
  | None => None
  | Some lhp =>
    match heap_set_k h lhp lhidx rhv with
    | Some h' => Some h'
    | None => None
    end
  end.

Notation "x <-- A ; B" := (match A with | Some x => B | None => None end)
                            (right associativity, at level 84).

Fixpoint option_eval (r: roots_t) (h: heap_t) (vals: list valexp) :=
  match vals with
  | List.nil => Some List.nil
  | vexp::t =>
    match eval_valexp r h vexp, option_eval r h t with
    | Some v, Some rest =>
      Some (List.cons v rest)
    | _, _ => None
    end
  end.

Definition handle_small_step (s: state) (c: com) : option state :=
  let r := roots s in
  let h := heap s in
  let o := output s in
  match c with
  | New var vals =>
    let p := fresh_ptr s in
    let r' := roots_set r var p in
    match option_eval r h vals with
    | Some vals =>
      let h' := (p, vals)::h in
      Some (mkState r' h' o)
    | None =>
      None
    end
  | AssignMem lhvar lhidx rhv =>
    rhv <-- eval_valexp r h rhv ;
      h' <-- update_heap r h lhvar lhidx rhv ;
      Some (mkState r h' o)
  | AssignVar var val =>
    match eval_valexp r h val with
    | Some (Pointer p) =>
      let r' := roots_set r var p in
      Some (mkState r' h o)
    | _ => None
    end
  | Drop var =>
    let r' := roots_unset r var in
    Some (mkState r' h o)
  | Out val =>
    match eval_valexp r h val with
    | Some (Int i) => Some (mkState r h (i::o))
    | _ => None
    end
  end.


Theorem A2P1 : ∀ a m n x y : Z, (a | m) ⇒ (a | n) ⇒ (a | m * x + n * y).
Proof.
intros.
unfold divide in H .
unfold divide in H0 .
destruct H.
destruct H0.
unfold divide.
rewrite H.
rewrite H0.
rewrite M1.
rewrite <-M2.
rewrite (M1 (x1*a) y) .
rewrite <-(M2 y x1 a).
rewrite <-D1.
exists (x*x0 + y*x1).
tauto.
Qed.

Theorem A2P2: ∀ a b c : Z, (a | b) ⇒ (b | c) ⇒ (a | c).
Proof.
intros.
unfold divide in H.
unfold divide in H0.
destruct H.
destruct H0.
rewrite H in H0.
unfold divide.
rewrite <-M2 in H0.
exists (x0*x).
tauto.
Qed.

Theorem A2P3 : 0 ≠ 1.
Proof.
pose proof Putz.
tauto.
Qed.

Theorem A2P4 : ∀ a b c : Z, a * c = b * c ⇒ c ≠ 0 ⇒ a = b.
Proof.
intros.
apply (S1 (a*c) (b*c) (-(b*c))) in H.
rewrite A4 in H.
rewrite <-A1P7 in H.
rewrite <-M2 in H.
rewrite A1P7 in H.
rewrite <-D1 in H.
apply A1P11 in H.
destruct H.
apply (S1 (a+ - b) 0 b) in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
rewrite A1P1 in H.
tauto.
tauto.
Qed.
Theorem Davi : ∀ m : Z , m>0 -> m=1 ∨ m>1.
intros.
pose proof (W1 ℕ).
pose proof AGORA.
apply H0 in H1.
destruct H1.
destruct H1.
pose proof (H2 1).
pose proof (H2 m) as H45.
pose proof I778.
unfold lt in H4.
auto.
rewrite G in H4.
rewrite PORRA in H4.
rewrite A3 in H4.
apply H3 in H4.
destruct H4.
rewrite lt_N_elt in H1.
pose proof H1 as H67.
pose proof (O2 0 x x).
apply H5 in H1.
rewrite A1P6 in H1.
pose proof (O2 x 1 x).
apply H6 in H4.
rewrite A1P3 in H4.
pose proof (H2 (x*x)).
rewrite <-lt_N_elt in H1.
apply H7 in H1.
destruct H1.
pose proof (I7 x (x*x)).
apply H8 in H4.
contradiction.
symmetry in H1.
apply A1P10 in H1.
destruct H1.
pose proof (lt_N_elt m).
destruct H8.
apply H9 in H.
pose proof H as H78.
apply H45 in H.
destruct H.
rewrite H1 in H.
right.
exact H.
auto.
rewrite H1 in H.
left.
symmetry in H.
exact H.
pose proof (lt_N_elt m).
destruct H8.
apply H9 in H.
apply H45 in H.
destruct H.
rewrite H1 in H.
apply H9 in H.
apply H45 in H.
destruct H.
rewrite H1 in H4.
rewrite A1P6 in H4.
pose proof OBVIO.
pose proof (I8 0).
apply H11 in H10.
contradiction.
pose proof (I9 0 0).
pose proof H10 as H46.
apply H12 in H10.
tauto.
rewrite H1 in H67.
pose proof (I9 0 0).
pose proof (Dan (0=0)).
destruct H11.
apply H10 in H11.
tauto.
tauto.
rewrite H1 in H67.
pose proof (I9 0 0).
pose proof (Dan (0=0)).
destruct H11.
apply H10 in H11.
tauto.
tauto.
exact H67.
exact H67.
pose proof (lt_N_elt m).
destruct H5.
apply H6 in H.
apply H45 in H.
destruct H.
rewrite H4 in H.
right.
exact H.
rewrite H4 in H.
symmetry in H.
left.
exact H.
congruence.
Qed.
Theorem Davi2 : ∀ m : Z , m<0 -> m=-1 ∨ m< -1.
intros.
pose proof (I3 0 m).
apply H0 in H.
rewrite PORRA in H.
pose proof (Davi (-m)).
apply H1 in H.
destruct H.
apply (S2 (-m) 1 (-1)) in H.
rewrite M1 in H.
rewrite A1P7 in H.
rewrite A1P5 in H.
rewrite <-M3 in H.
rewrite M2 in H.
rewrite A1P7 in H.
rewrite M1 in H.
rewrite M3 in H.
left.
exact H.
right.
apply (O1 1 (-m) (m-1)) in H.
rewrite G in H.
rewrite A1 in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
rewrite <-A2 in H.
rewrite A1P2 in H.
rewrite A1P1 in H.
tauto.

Qed.
Theorem Sena : ∀ m a : Z , m>a -> m=a+1 ∨ m>a+1.
Proof.
intros.
pose proof (Davi (m-a)).
apply (O1 a m (-a)) in H.
rewrite A4 in H.
rewrite <-G in H.
apply H0 in H.
destruct H.
apply (S1 (m-a) 1 a) in H.
rewrite G in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
rewrite A1 in H.
tauto.
apply ( O1 1 (m-a ) a ) in H.
rewrite G in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
right.
rewrite A1 in H.
tauto.
Qed.
Theorem Sena2 : ∀ m a : Z , m<a -> m=a-1 ∨ m<a-1.
Proof.
intros.
pose proof (Davi2 (m-a)).
apply (O1 m a (-a)) in H.
rewrite A4 in H.
rewrite <-G in H.
apply H0 in H.
destruct H.
apply (S1 (m-a) (-1) a) in H.
rewrite G in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
rewrite A1 in H.
tauto.
apply ( O1 (m-a ) (-1) a ) in H.
rewrite G in H.
rewrite A2 in H.
rewrite A1P2 in H.
rewrite A3 in H.
right.
rewrite A1 in H.
tauto.
Qed.

Theorem SD :∀ a b : Z, a*b=1 -> (a=1 ∧ b=1)∨(a= -1 ∧ b=-1).
Proof.
intros.
 destruct (T b) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
destruct (Y a 1) as [[H4 [H5 H6]] | [[H4 [H5 H6]] | [H4 [H5 H6]]]].
pose proof (O2 1 a b).
pose proof H0 as H56.
apply Davi in H0.
destruct H0.
rewrite H0 in H.
rewrite M3 in H.
tauto.
apply H3 in H4.
rewrite M1 in H4.
rewrite M3 in H4.
rewrite H in H4.
pose proof (I7 b 1).
apply H7 in H0.
tauto.
exact H56.
rewrite H5 in H.
rewrite M1 in H.
rewrite M3 in H.
tauto.
pose proof (O2 a 1 b).
pose proof H6 as H79.
apply H3 in H6.
rewrite A1P3 in H6.
pose proof (Sena 1 a).
apply H7 in H79.
destruct H79.
apply (S1 1 (a+1) (-1)) in H8.
rewrite A4 in H8.
rewrite A2 in H8.
rewrite A4 in H8.
rewrite A3 in H8.
symmetry in H8.
rewrite H8 in H.
rewrite A1P6 in H.
pose proof A2P3.
tauto.
apply (O1 (a+1) 1 (-1)) in H8.
rewrite A2 in H8.
rewrite A4 in H8.
rewrite A3 in H8.
pose proof (Davi2 a).
apply H9 in H8.
destruct H8.
rewrite H8 in H.
rewrite A1P7 in H.
apply (S2 (-b) 1 (-1)) in H.
rewrite NOW in H.
rewrite A1P5 in H.
rewrite M1 in H.
rewrite M3 in H.
tauto.
apply I3 in H8.
rewrite H in H6.
rewrite A1P5 in H8.
pose proof (O2 1 (-a) b).

apply H10 in H8.
rewrite M1 in H8.
rewrite M3 in H8.
pose proof (conj H6 H8).
pose proof (R3 1 b ((-a)*b)).
apply H12 in H11.
rewrite <-A1P7 in H11.
rewrite M2 in H11.
apply I3 in H11.
rewrite A1P7  in H11.
rewrite A1P5 in H11.
rewrite H in H11.
pose proof (I778).
pose proof H13 as H14.
apply I3 in H14.
rewrite PORRA in H14.
auto.
pose proof (R3 (-1) 0 1).
pose proof (conj H14 H13).
apply H15 in H16.
apply I7 in H16.
tauto.
exact H0.
exact H0.
rewrite H1 in H.
rewrite M1 in H.
rewrite A1P6 in H.
pose proof A2P3.
tauto.
pose proof (Davi2 b).
apply H3 in H2.
destruct H2.
rewrite H2 in H.
rewrite NOW in H.
apply (S2 (-a) 1 (-1)) in H.
rewrite NOW in H.
rewrite A1P5 in H.
rewrite M1 in H.
rewrite M3 in H.
tauto.
destruct (Y a 1) as [[H4 [H5 H6]] | [[H4 [H5 H6]] | [H4 [H5 H6]]]].
apply I3 in H2.
rewrite A1P5 in H2.
pose proof I778.
pose proof (R3 0 1 a).
pose proof (conj H7 H4).
apply H8 in H9.
pose proof (O2 1 (-b) a).
apply H10 in H2.
rewrite M1 in H2.
rewrite M3 in H2.
rewrite <-A1P7 in H2.
rewrite M2 in H2.
rewrite M1 in H.
rewrite H in H2.
rewrite  M3 in H2.
pose proof (R3 1 a (-1)).
pose proof (conj H4 H2).
apply H11 in H12.
auto.
pose proof (R3 0 (1) (-1)).
pose proof (conj H7 H12).
apply H13 in H14.
apply (O1 0 (-1) 1) in H14.
rewrite A1 in H14.
rewrite A3 in H14.
rewrite A1 in H14.
rewrite A4 in H14.
apply I7 in H14.
tauto.
exact H9.
rewrite H5 in H.
rewrite M1 in H.
rewrite M3 in H.
tauto.
pose proof (Sena2 a 1).
apply H7 in H6.
destruct H6.
rewrite G in H6.
rewrite A4 in H6.
rewrite H6 in H.
rewrite A1P6 in H.
pose proof (A2P3).
tauto.
rewrite G in H6.
rewrite A4 in H6.
pose proof (Davi2 a).
apply H8 in H6.
destruct H6.
rewrite H6 in H.
rewrite A1P7 in H.
apply (S2 (-b) 1 (-1)) in H.
rewrite M1 in H.
rewrite A1P7 in H.
rewrite A1P5 in H.
rewrite M1 in H.
rewrite M3 in H.
tauto.
apply I3 in H6.
apply I3 in H2.
rewrite A1P5 in H2, H6.
pose proof I778.
pose proof (R3 0 1 (-a)).
pose proof (conj H9 H6).
apply H10 in H11.
pose proof (O2 1 (-b) (-a)).
apply H12 in H2.
rewrite M1 in H2.
rewrite M3 in H2.
pose proof (R3 1 (-a) ((-b)*(-a))).
pose proof (conj H6 H2).
apply H13 in H14.
rewrite <-A1P7  in H14 .
rewrite M1 in H14.
rewrite <-M2 in H14.
rewrite NOW in H14.
rewrite A1P5 in H14.
rewrite H in H14.
pose proof (PORRA2 1).
apply I9 in H15.

tauto.
exact H11.
Qed.
Theorem Deusmeajude :∀ x b : Z,  ¬ ( x < b) -> (x=b ∨ b < x).
Proof.
intros.
destruct (Y x b) as [[H0 [H1 H2]] | [[H0 [H1 H2]] | [H0 [H1 H2]]]].
tauto.
tauto.
tauto.
Qed.

Theorem A2P5 : ∀ a b : Z, (a | b) ⇒ (b | a) ⇒ a = ± b.
Proof.
intros.
unfold divide in H, H0.
destruct H,  H0.
unfold pm.
rewrite H in H0.
rewrite <-M2 in H0.
symmetry in H0.
rewrite M1 in H0.
apply A1P10 in H0.
destruct H0.
apply SD in H0.
destruct H0.
destruct H0.
rewrite H1 in H.
rewrite M1 in H.
rewrite M3 in H.
symmetry in H.
tauto.
destruct H0.
rewrite H1 in H.
rewrite A1P7 in H.
symmetry in H.
apply (S2 (-a) b (-1)) in H.
rewrite M1 in H.
rewrite A1P7 in H.
rewrite A1P5 in H.
rewrite NOW in H.
tauto.
rewrite H0 in H.
rewrite M1 in H.
rewrite A1P6 in H.
rewrite <-H in H0.
tauto.
Qed.


Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.

(* Preliminaries, selectively snagged from Software Foundations (which is MI_D
   licensed. Annoyingly, the only reason we are doing this rather than just
   importing is that the |- notation used for typing judgments in SF blocks
   the |- notation in Ltac, which is kind of a Big Problem, so we tweak the
   |- notation a little bit. *)

(****
 **** Begin preliminaries
 ****)
(**** from SfLib.v ****)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   Case "n1 = n2".
     left. rewrite Heq. reflexivity.
   Case "n1 <> n2".
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

Definition relation (X:Type) := X -> X -> Prop.

Definition partial__function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Definition Reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Definition Irreflexive {X: Type} (R: relation X) :=
  forall a : X, ~ R a a.

Definition Transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Definition Antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Definition Symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

Definition Equivalence {X:Type} (R: relation X) :=
  (Reflexive R) /\ (Symmetric R) /\ (Transitive R).

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition Partialorder {X:Type} (R: relation X) :=
  (Reflexive R) /\ (Antisymmetric R) /\ (Transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition Preorder {X:Type} (R: relation X) :=
  (Reflexive R) /\ (Transitive R).

(* Reflexive Transitive Closures: RT_closure and S(imple)RT_closure *)

Inductive RT_clo {X: Type} (R: relation X) : relation X :=
    | RT_step  : forall (x y: X),
                 R x y ->
                 RT_clo R x y
    | RT_refl  : forall (x : X),
                 RT_clo R x x
    | RT_trans : forall (x y z : X),
                 RT_clo R x y ->
                 RT_clo R y z ->
                 RT_clo R x z.

(* This is easier to work with because of issues that arise from indeterminism in regards to the
   cut step in applying RT_trans:
            RT_clo (R a b) -> RT_clo (R b c) implies RT_clo (R a c)
   can sometimes require creative selection of the witness (R b c).
   Here's an alternative that seems easier to use:
 *)

Inductive reflexive_transitive_closure {X:Type} (R: relation X) : relation X :=
    | rtc_refl  : forall (x : X),
                  reflexive_transitive_closure R x x
    | rtc_step : forall (x y z : X),
                  R x y ->
                  reflexive_transitive_closure R y z ->
                  reflexive_transitive_closure R x z.

(* Given a relation R, R is in SRT_clo.  *)
Theorem R_in_RTC : forall (X:Type) (R:relation X) (x y : X),
        R x y -> reflexive_transitive_closure R x y.
Proof.
  intros.
  apply rtc_step with y.
  apply H. apply rtc_refl.
Qed.

(* the reflexive_transitive_closure is _transitive_ *)
Theorem trans_RTC : forall (X:Type) (R: relation X) (x y z : X),
                    reflexive_transitive_closure R x y  ->
                    reflexive_transitive_closure R y z ->
                    reflexive_transitive_closure R x z.
Proof.
  intros.
  induction H. assumption.
  apply rtc_step with y. assumption.
  apply IHreflexive_transitive_closure. assumption.
Qed.

Inductive list (X:Type) : Type :=
  | nil  : list X
  | cons : X -> list X -> list X.

Arguments nil {X}.
Arguments cons {X} _ _.

Notation "[_]" := nil (at level 0) : type_scope.
Notation "l :: r" := (cons l r) (at level 60, right associativity).
Notation "[ x , .. , y ]" := (cons x .. (cons y [_]) ..) : list_scope.

Fixpoint append (X : Type) (fs fs' : list X) : (list X) :=
  match fs with
  | [_]      => fs'
  | cons h t => cons h (append X t fs')
  end.

Fixpoint rcons (X:Type) (fs :list X) (v:X) : (list X) :=
  match fs with
  | [_]      => (v :: [_])
  | t :: b   => (t :: (rcons X b v))
  end.

Fixpoint reverse (X:Type) (fs :list X) : (list X) :=
  match fs with
  | [_]      => [_]
  | t :: b   => rcons X (reverse X b) t
  end.

Fixpoint sizeof (X:Type) (fs : list X) : nat :=
  match fs with
  | [_]      => 0
  | t :: b   => S (sizeof X b)
  end.

Arguments sizeof {X} fs.
Arguments append {X} fs fs'.
Arguments reverse {X} fs.
Arguments rcons {X} fs v.

(****
 **** End preliminaries
 ****)


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
(* Require Import ReflParam.paramDirect ReflParam.indType. *)

Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Inductive multInd (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i)
  : forall i:I, B i -> Set  :=
mlind : forall a, multInd A I B f g (f a) (g (f a)).

Require Import SquiggleEq.UsefulTypes.

(* Run TemplateProgram (genParamInd [] false true true "Top.multIndices2Eq.multInd"). *)

(*
Definition multInd_RR :=
(fix
 Top_multIndices2Eq_multInd_RR0 (A A₂ : Set) (A_R : A -> A₂ -> Prop)
                                (I I₂ : Set) (I_R : I -> I₂ -> Prop)
                                (B : I -> Set) (B₂ : I₂ -> Set)
                                (B_R : forall (H : I) (H0 : I₂),
                                       I_R H H0 -> B H -> B₂ H0 -> Prop)
                                (f : A -> I) (f₂ : A₂ -> I₂)
                                (f_R : forall (H : A) (H0 : A₂),
                                       A_R H H0 -> I_R (f H) (f₂ H0))
                                (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
                                (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
                                       B_R i i₂ i_R (g i) (g₂ i₂))
                                (i : I) (i₂ : I₂) (i_R : I_R i i₂)
                                (H : B i) (H0 : B₂ i₂) (H1 : B_R i i₂ i_R H H0)
                                (H2 : multInd A I B f g i H)
                                (H3 : multInd A₂ I₂ B₂ f₂ g₂ i₂ H0) {struct H2} : Prop :=
   match
     H2 in (multInd _ _ _ _ _ i0 H4)
     return (forall i_R0 : I_R i0 i₂, B_R i0 i₂ i_R0 H4 H0 -> Prop)
   with
   | mlind _ _ _ _ _ a =>
       match
         H3 in (multInd _ _ _ _ _ i₂0 H4)
         return (forall i_R0 : I_R (f a) i₂0, B_R (f a) i₂0 i_R0 (g (f a)) H4 -> Prop)
       with
       | mlind _ _ _ _ _ a₂ =>
           fun (i_R0 : I_R (f a) (f₂ a₂))
             (H4 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))) =>
           {a_R : A_R a a₂ &
           existT
             (fun i_R1 : I_R (f a) (f₂ a₂) =>
              {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True})
             (f_R a a₂ a_R)
             (existT
                (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) Logic.I) =
           existT
             (fun i_R1 : I_R (f a) (f₂ a₂) =>
              {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True}) i_R0
             (existT (fun _ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) => True) H4
                Logic.I)}
       end
   end i_R H1).

Definition mlind_RRInv :=
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I0 I₂ : Set) (I_R : I0 -> I₂ -> Prop)
   (B : I0 -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I0) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I0) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I0, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I0) (i₂ : I₂) (i_R : I_R i i₂), B_R i i₂ i_R (g i) (g₂ i₂))
   (a : A) (a₂ : A₂) (i_R : I_R (f a) (f₂ a₂))
   (H : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)))
   (sigt_R : {a_R : A_R a a₂ &
             existT
               (fun i_R0 : I_R (f a) (f₂ a₂) =>
                {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True})
               (f_R a a₂ a_R)
               (existT
                  (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                  (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I) =
             existT
               (fun i_R0 : I_R (f a) (f₂ a₂) =>
                {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True}) i_R
               (existT (fun _ : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)) => True) H I)})
   (retTyp_R : forall (i_R0 : I_R (f a) (f₂ a₂))
                 (H0 : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂))),
               {a_R : A_R a a₂ &
               existT
                 (fun i_R1 : I_R (f a) (f₂ a₂) =>
                  {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True})
                 (f_R a a₂ a_R)
                 (existT
                    (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                    (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I) =
               existT
                 (fun i_R1 : I_R (f a) (f₂ a₂) =>
                  {_ : B_R (f a) (f₂ a₂) i_R1 (g (f a)) (g₂ (f₂ a₂)) & True}) i_R0
                 (existT (fun _ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) => True) H0
                    I)} -> Set)
   (_ : forall a_R : A_R a a₂,
        retTyp_R (f_R a a₂ a_R) (g_R (f a) (f₂ a₂) (f_R a a₂ a_R))
          (existT
             (fun a_R0 : A_R a a₂ =>
              existT
                (fun i_R0 : I_R (f a) (f₂ a₂) =>
                 {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True})
                (f_R a a₂ a_R0)
                (existT
                   (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R0) (g (f a)) (g₂ (f₂ a₂)) => True)
                   (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) I) =
              existT
                (fun i_R0 : I_R (f a) (f₂ a₂) =>
                 {_ : B_R (f a) (f₂ a₂) i_R0 (g (f a)) (g₂ (f₂ a₂)) & True})
                (f_R a a₂ a_R)
                (existT
                   (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
                   (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I)) a_R eq_refl)) =>
 fiat (retTyp_R i_R H sigt_R)).

Definition mlind_RR :=
(fun (A A₂ : Set) (A_R : A -> A₂ -> Prop) (I0 I₂ : Set) (I_R : I0 -> I₂ -> Prop)
   (B : I0 -> Set) (B₂ : I₂ -> Set)
   (B_R : forall (H : I0) (H0 : I₂), I_R H H0 -> B H -> B₂ H0 -> Prop)
   (f : A -> I0) (f₂ : A₂ -> I₂)
   (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
   (g : forall i : I0, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
   (g_R : forall (i : I0) (i₂ : I₂) (i_R : I_R i i₂), B_R i i₂ i_R (g i) (g₂ i₂))
   (a : A) (a₂ : A₂) (a_R : A_R a a₂) =>
 existT
   (fun a_R0 : A_R a a₂ =>
    existT
      (fun i_R : I_R (f a) (f₂ a₂) =>
       {_ : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)) & True})
      (f_R a a₂ a_R0)
      (existT (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R0) (g (f a)) (g₂ (f₂ a₂)) => True)
         (g_R (f a) (f₂ a₂) (f_R a a₂ a_R0)) I) =
    existT
      (fun i_R : I_R (f a) (f₂ a₂) =>
       {_ : B_R (f a) (f₂ a₂) i_R (g (f a)) (g₂ (f₂ a₂)) & True})
      (f_R a a₂ a_R)
      (existT (fun _ : B_R (f a) (f₂ a₂) (f_R a a₂ a_R) (g (f a)) (g₂ (f₂ a₂)) => True)
         (g_R (f a) (f₂ a₂) (f_R a a₂ a_R)) I)) a_R eq_refl).

Print multInd_rect.
Print nat_rect.

*)

(*
Declare ML Module "paramcoq".
Parametricity Recursive multInd_recs.
*)

Definition multInd_recs :=
fun (A I : Set) (B : I -> Set) (f : A -> I) (g : forall i : I, B i)
  (P : forall (i : I) (b : B i), multInd A I B f g i b -> Set)
  (f0 : forall a : A, P (f a) (g (f a)) (mlind A I B f g a)) (i : I)
  (a : B i) (m : multInd A I B f g i a) =>
match m as m0 in (multInd _ _ _ _ _ i0 a0) return (P i0 a0 m0) with
| mlind _ _ _ _ _ x => f0 x
end.

Definition multInd_RR (A A₂ : Set) (A_R : A -> A₂ -> Prop)
                              (I I₂ : Set) (I_R : I -> I₂ -> Prop)
                              (B : I -> Set) (B₂ : I₂ -> Set)
                              (B_R : forall (H : I) (H0 : I₂),
                                     I_R H H0 -> B H -> B₂ H0 -> Prop)
                              (f : A -> I) (f₂ : A₂ -> I₂)
                              (f_R : forall (H : A) (H0 : A₂), A_R H H0 -> I_R (f H) (f₂ H0))
                              (g : forall i : I, B i) (g₂ : forall i₂ : I₂, B₂ i₂)
                              (g_R : forall (i : I) (i₂ : I₂) (i_R : I_R i i₂),
                                     B_R i i₂ i_R (g i) (g₂ i₂))
                              (i : I) (i₂ : I₂) (i_R : I_R i i₂)
                              (H : B i) (H0 : B₂ i₂) (H1 : B_R i i₂ i_R H H0)
                              (H2 : multInd A I B f g i H)
                              (H3 : multInd A₂ I₂ B₂ f₂ g₂ i₂ H0) : Prop.
refine (
   let reT i1 i2 b1 b2 := forall (ir : I_R i1 i2) (br : B_R i1 i2 ir b1 b2), Prop in
   (match H2 in multInd _ _ _ _ _ i1 b1 return reT i1 i₂ b1 H0 with
   | mlind _ _ _ _ _ a => match
     H3 in multInd _ _ _ _ _ i2 b2 return reT (f a) i2 (g (f a)) b2 with
         | mlind _ _ _ _ _ a₂ => fun ir br =>
                  {ar : A_R a a₂ &
  @existT _ _ (f_R a a₂ ar) (g_R _ _ (f_R a a₂ ar)) =
      @existT _ (fun ir => B_R (f a) (f₂ a₂) ir (g (f a)) (g₂ (f₂ a₂))) ir br
                  }
              end
   end) i_R H1 ).
Defined.
SearchAbout multInd.

Print sigT.
Lemma eta_sigt {A : Type} {P : A -> Type} (x: sigT P):
x = existT _ (projT1 x) (projT2 x).
Proof using.
  intros. destruct x. simpl. refl.
Defined.

(* this property is crucial *)
Lemma eta_sigt_eqrefl {A : Type} {P : A -> Type} (a:A) (p: P a):
eta_sigt (existT _ a p) = eq_refl.
Proof using.
  simpl. reflexivity.
Defined.

(* delete *)
Lemma eq_rect2
     : forall (T : Type) (x : T) (P : forall t : T, eq x t -> Type),
       P x (eq_refl x) -> forall (y : T) (e : eq x y), P y e.
Proof.
  intros.
  rewrite <-e. assumption.
Defined.

(* delete *)
Lemma eq_rect2_rev
     : forall (T : Type) (x : T) (P : forall t : T, eq t x -> Type),
       P x (eq_refl x) -> forall (y : T) (e : eq y x), P y e.
Proof.
  intros. subst.
  assumption.
Defined.

(* these can be manually proved before hand? *)
Lemma eq_rect_sigt (A : Type) (PT : A -> Type) :
let T := sigT PT in
forall (x : T) (P : forall (a:A) (p: PT a), eq x (existT _ a p) -> Type),
       P (projT1 x) (projT2 x) (eta_sigt x) -> forall (a:A) (p: PT a) (e : eq x (existT _ a p)),
        P a p e.
Proof.
  intros. subst. exact X.
Defined.

Lemma eq_rect_sigt2 (A : Type) (PT : A -> Type) :
let T := sigT PT in
forall (x : T) (P : forall (a:A) (p: PT a), eq x (existT _ a p) -> Type),
       P (projT1 x) (projT2 x) (eta_sigt x) -> forall (a:A) (p: PT a) (e : eq x (existT _ a p)),
        P a p e.
Proof.
  intros. revert X. revert P. revert e. revert x.
  apply (eq_rect2_rev _ _ (fun x e=>
  forall (P : forall (a0 : A) (p0 : PT a0), x = existT _ a0 p0 -> Type),
P (projT1 x) (projT2 x) (eta_sigt x) -> P a p e
)). simpl. intros. exact X.
Defined.

Eval compute in eq_rect_sigt.
Arguments existT {A} {P} x p.

Definition mlind_RR  (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set)
         (I_R : I₁ -> I₂ -> Prop) (B₁ : I₁ -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I₁) (H0 : I₂), I_R H H0 -> B₁ H -> B₂ H0 -> Prop)
         (f₁ : A₁ -> I₁) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (f₁ H) (f₂ H0))
         (g₁ : forall i : I₁, B₁ i) (g₂ : forall i : I₂, B₂ i)
         (g_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂), B_R i₁ i₂ i_R (g₁ i₁) (g₂ i₂))
         (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂):
       multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R
         (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R) (g₁ (f₁ a₁)) (g₂ (f₂ a₂))
         (g_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R)) (mlind A₁ I₁ B₁ f₁ g₁ a₁)
         (mlind A₂ I₂ B₂ f₂ g₂ a₂).
Proof.
  simpl. exists a_R. reflexivity.
Defined.

Definition multIndices_recs:
forall (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Prop) (I₁ I₂ : Set)
         (I_R : I₁ -> I₂ -> Prop) (B₁ : I₁ -> Set) (B₂ : I₂ -> Set)
         (B_R : forall (H : I₁) (H0 : I₂), I_R H H0 -> B₁ H -> B₂ H0 -> Prop)
         (f₁ : A₁ -> I₁) (f₂ : A₂ -> I₂)
         (f_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> I_R (f₁ H) (f₂ H0))
         (g₁ : forall i : I₁, B₁ i) (g₂ : forall i : I₂, B₂ i)
         (g_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂), B_R i₁ i₂ i_R (g₁ i₁) (g₂ i₂))
         (P₁ : forall (i : I₁) (b : B₁ i), multInd A₁ I₁ B₁ f₁ g₁ i b -> Set)
         (P₂ : forall (i : I₂) (b : B₂ i), multInd A₂ I₂ B₂ f₂ g₂ i b -> Set)
         (P_R : forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂) (b₁ : B₁ i₁)
                  (b₂ : B₂ i₂) (b_R : B_R i₁ i₂ i_R b₁ b₂)
                  (H : multInd A₁ I₁ B₁ f₁ g₁ i₁ b₁) (H0 : multInd A₂ I₂ B₂ f₂ g₂ i₂ b₂),
                multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R i₁ i₂ i_R b₁ b₂
                  b_R H H0 -> P₁ i₁ b₁ H -> P₂ i₂ b₂ H0 -> Set)
         (f0₁ : forall a : A₁, P₁ (f₁ a) (g₁ (f₁ a)) (mlind A₁ I₁ B₁ f₁ g₁ a))
         (f0₂ : forall a : A₂, P₂ (f₂ a) (g₂ (f₂ a)) (mlind A₂ I₂ B₂ f₂ g₂ a)),
       (forall (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂),
        P_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R) (g₁ (f₁ a₁)) (g₂ (f₂ a₂))
          (g_R (f₁ a₁) (f₂ a₂) (f_R a₁ a₂ a_R)) (mlind A₁ I₁ B₁ f₁ g₁ a₁)
          (mlind A₂ I₂ B₂ f₂ g₂ a₂)
          (mlind_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R a₁ a₂ a_R)
          (f0₁ a₁) (f0₂ a₂)) ->
       forall (i₁ : I₁) (i₂ : I₂) (i_R : I_R i₁ i₂) (a₁ : B₁ i₁)
         (a₂ : B₂ i₂) (a_R : B_R i₁ i₂ i_R a₁ a₂) (m₁ : multInd A₁ I₁ B₁ f₁ g₁ i₁ a₁)
         (m₂ : multInd A₂ I₂ B₂ f₂ g₂ i₂ a₂)
         (m_R : multInd_RR A₁ A₂ A_R I₁ I₂ I_R B₁ B₂ B_R f₁ f₂ f_R g₁ g₂ g_R i₁ i₂ i_R a₁ a₂
                  a_R m₁ m₂),
       P_R i₁ i₂ i_R a₁ a₂ a_R m₁ m₂ m_R (multInd_recs A₁ I₁ B₁ f₁ g₁ P₁ f0₁ i₁ a₁ m₁)
         (multInd_recs A₂ I₂ B₂ f₂ g₂ P₂ f0₂ i₂ a₂ m₂).
Proof using.
  intros.
  rename a_R into b_R.
  revert m_R.
  destruct m₁.
  destruct m₂.
  intros ?.
  simpl in *.
  unfold mlind_RR in H.
  destruct m_R as [a_R peq].
  (* do the remaining in a separate C_RRinv construct? *)
  specialize (H _ _ a_R).
  (* here, peq needs to change to eq_refl *)
  generalize peq.
  generalize b_R.
  generalize i_R.
  apply eq_rect_sigt. (* need to add the extra I *)
  simpl.
  exact H.
Defined.

(* see the exact below
  exact ( eq_rect_sigt (I_R (f₁ a) (f₂ a0))
           (fun ir : I_R (f₁ a) (f₂ a0) => B_R (f₁ a) (f₂ a0) ir (g₁ (f₁ a)) (g₂ (f₂ a0)))
           (existT (f_R a a0 a_R) (g_R (f₁ a) (f₂ a0) (f_R a a0 a_R)))
           (fun (a1 : I_R (f₁ a) (f₂ a0))
              (p : B_R (f₁ a) (f₂ a0) a1 (g₁ (f₁ a)) (g₂ (f₂ a0)))
              (e : existT (f_R a a0 a_R) (g_R (f₁ a) (f₂ a0) (f_R a a0 a_R)) = existT a1 p)
            =>
            P_R (f₁ a) (f₂ a0) a1 (g₁ (f₁ a)) (g₂ (f₂ a0)) p (mlind A₁ I₁ B₁ f₁ g₁ a)
              (mlind A₂ I₂ B₂ f₂ g₂ a0) (existT a_R e) (f0₁ a)
              (f0₂ a0)) (H _ _ a_R) i_R b_R peq).
*)