Require Import Coq.Lists.List.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Coq.setoid_ring.Ring.
Require Import Coq.setoid_ring.Ring_theory.
Require Import Field_theory.
Require Import Field_tac.
Require Import PeanoNat.
Require Import Arith.
Require Import Omega.
Require Import Matrix.
Require Import MyHelpers.

Section MatrixInversion.
  Variable E: MatrixElem.
  Variable M: @Matrix E.
  Add Field MatrixInversionEtField' : MEfield.
  Variable n: nat.

  Set Implicit Arguments.
  Parameter is_eq_dec : forall x y: MEt, { eq x y } + { ~ eq x y }.

  Lemma non_trivial_ring:
    e0 <> e1.
  Proof.
    Print field_theory.
    intro.
    symmetry in H.
    apply MEfield.(F_1_neq_0).
    assumption.
  Qed.

  Lemma  normal_field_knowledge:
    forall r, r <> e0 -> MEinv r <> e0.
  Proof.
    intros.
    assert (MEinv r *e r = e1) by (field; assumption).
    unfold not; intros.
    rewrite H1 in H0.
    assert (e0 *e r = e0) by field.
    rewrite H2 in H0.
    assert (e0 <> e1) by (apply non_trivial_ring).
    contradiction.
  Qed.

  Definition I := @I n E M.
  Definition e := @e n E M.
  Definition row_mul := @row_mul n E M.
  Definition row_add_to_row := @row_add_to_row n E M.
  Definition swap := @swap n E M.

  Definition invertible (M : Mt n n) :=
    exists M', M @* M' @= I /\ M' @* M @= I.

  Lemma I_is_invertible:
    invertible I.
  Proof.
    exists I.
    split; apply I_is_identity.
  Qed.

  Lemma AB_BA:
    forall A B, invertible A -> A @* B @= I -> B @* A @= I.
  Proof.
    intros.
    unfold invertible in H.
    inversion H.
    inversion H1.
    rename x into B'.
    assert (B' @* (A @* B) @= B' @* I).
    {
      setoid_rewrite H0.
      reflexivity.
    }

    rewrite <- mult_assoc in H4.
    rewrite H3 in H4.
    rewrite I_is_left_identity in H4.
    rewrite I_is_right_identity in H4.
    rewrite H4.
    assumption.
  Qed.

  Fixpoint GE_elemdown (A: Mt n n) (x: nat) (cur: nat) :=
    match cur with
    | O => (I, A)
    | S cur' =>
      let ee := row_add_to_row (n - cur) x (MEopp (Mget A (n - cur) x)) in
      let (E', EA') := GE_elemdown (ee @* A) x cur' in
      (E' @* ee, EA')
    end.

  Fixpoint get_first_none_zero (A: Mt n n) (i: nat) (y: nat) :=
    match i with
    | O => n
    | S i' =>
      if (is_eq_dec (Mget A (n - i) y) MEzero) then
        get_first_none_zero A i' y
      else
        n - i
    end.

  Fixpoint GE_stage1 (A: Mt n n) (i: nat) :=
    match i with
    | O => Some (I, A)
    | S i' =>
      let r := get_first_none_zero A i (n - i) in
      if (r =? n) then
        None
      else
        let A0 := (swap (n - i) r) @* A in
        let ee := (row_mul (n - i) (MEinv (Mget A0 (n - i) (n - i)))) in
        let (E', EA') := GE_elemdown (ee @* A0) (n - i) (i - 1) in
        let ret := GE_stage1 EA' i' in
        match ret with
        | None => None
        | Some (E'', EA'') => Some (E'' @* E' @* ee @* swap (n - i) r, EA'')
        end
    end.

  Fixpoint GE_elemup (A: Mt n n) (x: nat) (i: nat) :=
    match i with
    | O => (I, A)
    | S i' =>
      let ee := row_add_to_row i' x (MEopp (Mget A i' x)) in
      let (E', EA') := GE_elemup (ee @* A) x i' in
      (E' @* ee, EA')
    end.

  Fixpoint GE_stage2 (A: Mt n n) (i: nat) :=
    match i with
    | O => (I, A)
    | S i' =>
        let (E', EA') := GE_elemup (A) i' i' in
        let (E'', EA'') := GE_stage2 EA' i' in
        (E'' @* E', EA'')
    end.

  Definition Inversion (A: Mt n n) :=
    match GE_stage1 A n with
    | None => None
    | Some (E, EA) => Some (fst (GE_stage2 EA n) @* E)
    end.

  Hint Rewrite @Mfill_correct @Melementwise_op_correct @get_element_e  @get_element_row_mul @get_element_row_add_to_row @get_element_swap: MMM.
  Ltac urgh :=
    repeat match goal with
    | _ => discriminate
    | _ => progress subst
    | _ => field
    | _ => progress auto
    | _ => omega
    | _ => progress autorewrite with MMM
    | [ |- context[let (_, _) := ?x in _]] => destruct x eqn: ?
    | _ => progress elim_bool

    | [ |- context[?x <? ?y]] => destruct (x <? y) eqn: ?
    | [ |- context[?x <=? ?y]] => destruct (x <=? y) eqn: ?

    | [ |- context[match ?x with | _ => _ end]] => destruct (x) eqn: ?

    | [H: context[let (_, _) := ?x in _] |- _] => destruct x eqn: ?

    | [H: context[?x =? ?y] |- _] => destruct (x =? y) eqn: ?

    | [H: context[?x <? ?y] |- _] => destruct (x <? y) eqn: ?
    | [H: context[?x <=? ?y] |- _] => destruct (x <=? y) eqn: ?
    | [H: context[match ?x with | _ => _ end] |- _] => destruct (x) eqn: ?
    end.

  Lemma GE_elemdown_correct_1 :
    forall A x cur,
      x < n -> cur < n - x ->
      (fst (GE_elemdown A x cur) @* A) @= snd (GE_elemdown A x cur).
  Proof.
    intros.
    generalize dependent A.
    induction cur.
    - intros. simpl. apply I_is_identity.
    - assert (cur < n - x) by omega. intros.
      eapply IHcur in H1.
      simpl.
      destruct (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur) eqn: eq.
      simpl.
      rewrite eq in H1. simpl in H1.
      rewrite <- mult_assoc in H1.
      assumption.
  Qed.

  Lemma GE_elemdown_correct_keep :
    forall A x cur,
      x < n -> cur < n - x -> Mget A x x = e1 ->
      forall i j, i < n - cur -> j < n -> Mget (snd (GE_elemdown A x cur)) i j = Mget A i j.
  Proof.
    intros.
    generalize dependent A.
    generalize dependent i.
    generalize dependent j.
    induction cur.
    - intros.
      simpl.
      reflexivity.
    - intros.
      simpl.
      destruct (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur) eqn: eq.
      simpl.
      assert (snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)@[i, j] = (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A)@[i, j]).
      {
        apply IHcur; auto; try omega.
        rewrite get_element_row_add_to_row; auto; try omega.
        elim_bool; auto.
        omega.
      }
      rewrite eq in H4. simpl in H4.
      rewrite H4.
      rewrite get_element_row_add_to_row; auto; try omega.
      elim_bool; auto.
      omega.
  Qed.

  Lemma GE_elemdown_correct_2 :
    forall A x cur,
      x < n -> cur < n - x -> Mget A x x = e1 ->
      forall y, y >= n - cur -> y < n -> Mget (snd (GE_elemdown A x cur)) y x = e0.
  Proof.
    intros.
    generalize dependent A.
    generalize dependent y.
    induction cur.
    - intros.
      simpl. omega.
    - intros.
      destruct (beq_nat y (n - S cur)) eqn: eq; elim_bool.
      + simpl.
        destruct (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur) eqn: eq2.
        simpl.
        assert (m0@[y, x] = (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A)@[y, x]).
        {
          assert (m0 = snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)) by (rewrite eq2; auto).
          rewrite H4.
          apply GE_elemdown_correct_keep; auto; try omega.
          rewrite get_element_row_add_to_row; auto; try omega.
          elim_bool; auto. omega.
        }
        rewrite H4.
        rewrite get_element_row_add_to_row; auto; try omega.
        elim_bool; auto; try omega.
        rewrite <- eq0.
        rewrite H1.
        ring.
      + simpl.
        destruct (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur) eqn: eq2.
        simpl.
        assert (m0 = snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)) by (rewrite eq2; auto).
        rewrite H4.
        apply IHcur; auto; try omega.
        rewrite get_element_row_add_to_row; auto; try omega.
        elim_bool; auto. omega.
  Qed.

  Definition lower_left_zeros (A: Mt n n) (L: nat) :=
    forall i j,
      i < n -> j < n -> j < L -> i > j -> Mget A i j = e0.

  Lemma GE_elemdown_correct_keep_0:
    forall A x cur,
      x < n -> cur < n - x -> Mget A x x = e1 -> lower_left_zeros A x ->
      lower_left_zeros (snd (GE_elemdown A x cur)) x.
  Proof.
    intros.
    generalize dependent A.
    induction cur.
    - intros.
      simpl.
      assumption.
    - intros.
      simpl.
      destruct (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A)  x cur) eqn: eq.
      simpl.
      unfold lower_left_zeros in *.
      intros.
      destruct (i <? (n - S cur)) eqn: eq2.
      + elim_bool.
        replace (m0) with (snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)) by (rewrite eq; auto).
        assert (e0 = (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A)@[i, j]).
        {
          rewrite get_element_row_add_to_row; auto; try omega.
          elim_bool; auto; try omega.
          rewrite H2; auto.
        }
        rewrite H7.
        apply GE_elemdown_correct_keep; auto; try omega.
        rewrite get_element_row_add_to_row; auto; try omega.
        elim_bool; auto; try omega.
      + destruct (i =? (n - S cur)) eqn: eq3; elim_bool; auto; try omega.
        * subst.
          replace (m0) with (snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)) by (rewrite eq; auto).
          assert (e0 = (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A)@[n - S cur, j]).
          {
            rewrite get_element_row_add_to_row; auto; try omega.
            elim_bool; auto; try omega.
            rewrite H2; auto.
            replace (A@[x, j]) with e0 by (rewrite H2; auto).
            ring.
          }
          rewrite H7.
          apply GE_elemdown_correct_keep; auto; try omega.
          rewrite get_element_row_add_to_row; auto; try omega.
          elim_bool; auto; try omega.
        * replace (m0) with (snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)) by (rewrite eq; auto).
          apply IHcur; auto; try omega.
          --- rewrite get_element_row_add_to_row; auto; try omega.
              elim_bool; auto; try omega.
          --- intros.
              rewrite get_element_row_add_to_row; auto; try omega.
              elim_bool; auto; try omega.
              rewrite H2; auto.
              replace (A@[x, j0]) with e0 by (rewrite H2; auto).
              ring.
  Qed.

  Lemma GE_elemdown_correct_extend_0:
    forall A x,
      x < n -> Mget A x x = e1 -> lower_left_zeros A x ->
      lower_left_zeros (snd (GE_elemdown A x (n - x - 1))) (x + 1).
  Proof.
    intros.
    unfold lower_left_zeros.
    intros.
    destruct (j =? x) eqn: eq; elim_bool.
    - rewrite eq. apply GE_elemdown_correct_2; auto; omega.
    - apply GE_elemdown_correct_keep_0; auto; omega.
  Qed.

  Lemma  get_first_none_zero_at_least:
    forall A i j, get_first_none_zero A i j >= n - i.
  Proof.
    intros.
    induction i.
    - simpl. omega.
    - simpl.
      destruct (is_eq_dec (A@[n - S i, j]) e0); omega.
  Qed.

  Lemma  get_first_none_zero_at_most:
    forall A i j, get_first_none_zero A i j <= n.
  Proof.
    intros.
    induction i.
    - simpl. omega.
    - simpl.
      destruct (is_eq_dec (A@[n - S i, j]) e0); omega.
  Qed.

  Lemma  get_first_none_zero_correct:
    forall A i j, get_first_none_zero A i j < n -> A@[get_first_none_zero A i j, j] <> e0.
  Proof.
    intros.
    induction i.
    - simpl. simpl in H. omega.
    - simpl; urgh.
      simpl in H.
      urgh.
  Qed.

  Lemma GE_stage1_correct_1:
    forall A i E EA,
      i <= n -> GE_stage1 A i = Some (E, EA) ->
      E @* A @= EA.
  Proof.
    intros.
    generalize dependent A.
    generalize dependent E0.
    generalize dependent EA.
    induction i; intros.
    - simpl in H0. inversion H0; subst.
      apply I_is_left_identity.
    - unfold GE_stage1 in H0.
      fold GE_stage1  in H0.
      urgh.
      remember (swap (n - S i) (get_first_none_zero A (S i) (n - S i)) @* A) as A0.
        remember (row_mul (n - S i) (MEinv (A0@[n - S i, n - S i])) @* A0) as A1.
        inversion H0.
        replace ((if is_eq_dec (A@[n - S i, n - S i]) e0
     then get_first_none_zero A i (n - S i)
                  else n - S i)) with (get_first_none_zero A (S i) (n - S i)) by (auto).
        rewrite mult_assoc.
        rewrite <- HeqA0.
        assert (m  @* A1 @= m0).
        {
          replace m with (fst (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite Heqp; auto).
          replace m0 with (snd (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite Heqp; auto).
          apply GE_elemdown_correct_1; urgh.
        }
      destruct (GE_stage1 m0 i) eqn: eq3.
      * destruct p.
        apply IHi in eq3; try omega.

        rewrite mult_assoc.
        rewrite mult_assoc.
        rewrite <- HeqA1.
        rewrite H1.
        rewrite <- H3.
        inversion Heqo.
        rewrite <- H5.
        rewrite <- H6.
        assumption.
      * inversion Heqo.
  Qed.

  Lemma GE_stage1_correct_keep :
    forall A i E EA,
      i <= n -> GE_stage1 A i = Some (E, EA) ->
      forall x y, x < n - i -> y < n -> Mget EA x y = Mget A x y.
  Proof.
    intros A i.
    generalize dependent A.
    induction i; intros.
    - simpl in H0.
      inversion H0; subst.
      reflexivity.
    - simpl in H0; urgh.
      +
        remember (swap (n - S i) (get_first_none_zero A i (n - S i)) @* A) as A0.
        remember (row_mul (n - S i) (MEinv (A0@[n - S i, n - S i])) @* A0) as A1; try rewrite <- HeqA0 in *; try rewrite <- HeqA1 in *.
        inversion H0.
        rewrite <- H5.
        rewrite IHi with (A := m0) (EA := m2) (E0 := m1); auto; try omega.
        replace (m0) with (snd (GE_elemdown A1 (n - S i) (i - 0))) by (rewrite Heqp; auto).
        rewrite GE_elemdown_correct_keep; auto; try omega.
        *
          apply transitivity with (y0 := A0@[x, y]).
          --- rewrite HeqA1.
              rewrite get_element_row_mul; urgh;
              assert (get_first_none_zero A i (n - S i) <= n) by apply  get_first_none_zero_at_most;
              omega.
          --- rewrite HeqA0.
              rewrite get_element_swap; urgh.
              assert (get_first_none_zero A i (n - S i) >= n - i) by apply get_first_none_zero_at_least.
              omega.
              assert (get_first_none_zero A i (n - S i) <= n) by apply get_first_none_zero_at_most.
              omega.
        * rewrite HeqA1.
          rewrite get_element_row_mul; urgh.
          apply get_first_none_zero_correct.
          assert (get_first_none_zero A i (n - S i) <= n) by apply  get_first_none_zero_at_most;
            omega.

          assert (get_first_none_zero A i (n - S i) <= n) by apply  get_first_none_zero_at_most;
              omega.
      + remember (swap (n - S i) (n - S i) @* A) as A0; remember (row_mul (n - S i) (MEinv (A0@[n - S i, n - S i])) @* A0) as A1; try rewrite <- HeqA0 in *; try rewrite <- HeqA1 in *.
        inversion H0.
        rewrite <- H5.
        rewrite IHi with (A := m0) (EA := m2) (E0 := m1); auto; try omega.
        replace (m0) with (snd (GE_elemdown A1 (n - S i) (i - 0))) by (rewrite Heqp; auto).
        rewrite GE_elemdown_correct_keep; auto; try omega.
        *
          apply transitivity with (y0 := A0@[x, y]).
          --- rewrite HeqA1.
              rewrite get_element_row_mul; urgh.
          --- rewrite HeqA0.
              rewrite get_element_swap; urgh.
        * rewrite HeqA1.
          rewrite get_element_row_mul; urgh.
  Qed.

  Definition Diag_ones (A: Mt n n) (L: nat) :=
    forall i,
      i < n -> i < L -> Mget A i i = e1.

  Lemma GE_stage1_extend_ones :
    forall A i E EA,
      i <= n -> Diag_ones A (n - i) -> GE_stage1 A i = Some (E, EA) ->
      Diag_ones EA n.
  Proof.
    intros.
    generalize dependent A.
    generalize dependent E0.
    generalize dependent EA.
    induction i; intros; urgh.
    - simpl in H1. inversion H1; subst.
      replace n with (n - 0) by omega.
      assumption.
    - unfold Diag_ones.
      intros.
      unfold GE_stage1 in H1; urgh. fold GE_stage1 in *.
      remember (swap (n - S i) (get_first_none_zero A (S i) (n - S i)) @* A) as A0.
      remember (row_mul (n - S i) (MEinv (A0@[n - S i, n - S i])) @* A0) as A1; try rewrite <- HeqA0 in *; try rewrite <- HeqA1 in *.

      assert (get_first_none_zero A (S i) (n - S i) <= n) by apply get_first_none_zero_at_most.
      assert (get_first_none_zero A (S i) (n - S i) >= n - S i) by apply get_first_none_zero_at_least.

      assert (Diag_ones m0 (n - i)).
      {
        unfold Diag_ones; intros.
        replace (m0) with (snd (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite Heqp; auto).
        rewrite GE_elemdown_correct_keep; auto; try omega.
        + rewrite HeqA1.
          rewrite get_element_row_mul; elim_bool; auto; try omega.
          * rewrite eq; field.
            rewrite HeqA0. rewrite get_element_swap; urgh.
            --- apply get_first_none_zero_correct.
                omega.
          * rewrite HeqA0.
            rewrite get_element_swap; urgh.
            apply H0; urgh.
        + rewrite HeqA1; urgh.
          apply get_first_none_zero_correct.
          omega.
      }
      apply IHi with (E0:=m1) (EA:=m2) in H6 ; auto; try omega.
      inversion H1.
      rewrite <- H9.
      apply H6; auto.
  Qed.

  Lemma GE_stage1_extend_zeros :
    forall A i E EA,
      i <= n -> lower_left_zeros A (n - i) -> GE_stage1 A i = Some (E, EA) ->
      lower_left_zeros EA n.
  Proof.
    intros A i.
    generalize dependent A.
    induction i; intros; urgh.
    - replace n with (n - 0) by omega.
      simpl in H1.
      inversion H1.
      rewrite <- H4.
      assumption.
    - unfold GE_stage1 in H1; urgh. fold GE_stage1 in *.
      remember (swap (n - S i) (get_first_none_zero A (S i) (n - S i)) @* A) as A0.
      remember (row_mul (n - S i) (MEinv (A0@[n - S i, n - S i])) @* A0) as A1; try rewrite <- HeqA0 in *; try rewrite <- HeqA1 in *.

      assert (get_first_none_zero A (S i) (n - S i) <= n) by apply get_first_none_zero_at_most.
      assert (get_first_none_zero A (S i) (n - S i) >= n - S i) by apply get_first_none_zero_at_least.

      assert (lower_left_zeros m0 (n - i)).
      {
        unfold lower_left_zeros.
        intros.
        replace (m0) with (snd (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite Heqp; auto).
        replace (S i - 1) with (n - (n - S i) - 1) by omega.
        apply GE_elemdown_correct_extend_0 with (x := n - S i); urgh.
        +
          apply get_first_none_zero_correct; urgh.
        + unfold lower_left_zeros; intros.
          rewrite get_element_row_mul; urgh.
          * replace ( A@[get_first_none_zero A (S i) (n - S i), j0]) with e0 by (rewrite <- H0; auto; omega).
            ring.
          * rewrite <- H0; auto; omega.
      }
      apply IHi with (A := m0) (E0 := m1); auto; try omega.
      inversion H1.
      rewrite <- H7.
      assumption.
  Qed.

  Definition normalized_upper_triangle (A: Mt n n) :=
    Diag_ones A n /\ lower_left_zeros A n.

  Theorem GE_stage1_correct:
    forall A E EA,
      GE_stage1 A n = Some (E, EA) ->
      E @* A @= EA /\ normalized_upper_triangle EA.
  Proof.
    intros.
    split.
    - eapply GE_stage1_correct_1; eauto.
    - unfold normalized_upper_triangle.
      split.
      + eapply GE_stage1_extend_ones; eauto.
        unfold Diag_ones. intros. omega.
      + eapply GE_stage1_extend_zeros; eauto.
        unfold lower_left_zeros; intros. omega.
  Qed.

  Lemma GE_elemup_correct_1 :
    forall A x i,
      x < n -> i <= x ->
      (fst (GE_elemup A x i) @* A) @= snd (GE_elemup A x i).
  Proof.
    intros.
    generalize dependent A.
    induction i.
    - intros. simpl. apply I_is_identity.
    - assert (i <= x) by omega. intros.
      eapply IHi in H1.
      simpl.
      destruct (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i) eqn: eq.
      simpl.
      rewrite eq in H1. simpl in H1.
      rewrite <- mult_assoc in H1.
      assumption.
  Qed.

  Definition upper_right_zeros (A: Mt n n) (L: nat) :=
    forall i j,
      i < n -> j < n -> j >= n - L -> i < j -> Mget A i j = e0.

  Lemma nut_preserve:
    forall A x i',
      x < n -> i' < x -> normalized_upper_triangle A ->
      normalized_upper_triangle ((row_add_to_row i' x (MEopp (Mget A i' x))) @* A).
  Proof.
    intros.
    unfold normalized_upper_triangle.
    inversion H1.
    unfold Diag_ones in H2. unfold lower_left_zeros in H3.
    split.
    + unfold Diag_ones; intros.
      rewrite get_element_row_add_to_row; auto; try omega.
      elim_bool; auto; try omega.
      replace (A@[x, i]) with e0 by (rewrite H3; auto; omega).
      replace (A@[i, i]) with e1 by (rewrite H2; auto; omega).
      ring.
    + unfold lower_left_zeros; intros.
      rewrite get_element_row_add_to_row; auto; try omega.
      elim_bool; auto; try omega.
      replace (A@[i, j]) with e0 by (rewrite H3; auto; omega).
      replace (A@[x, j]) with e0 by (rewrite H3; auto; omega).
      ring.
  Qed.

  Lemma GE_elemup_correct_2 :
    forall A x i,
      x < n -> i <= x -> normalized_upper_triangle A
           -> normalized_upper_triangle (snd (GE_elemup A x i)).
  Proof.
    intros.
    generalize dependent A.
    generalize dependent x.

    induction i; intros.
    - simpl. assumption.
    - simpl.
      destruct (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i) eqn: eq.
      replace (snd (m @* row_add_to_row i x (MEopp (A@[i, x])), m0)) with (snd (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i)) by (rewrite eq; auto).
      apply IHi; auto; try omega.
      apply nut_preserve; auto.
  Qed.

  Lemma GE_elemup_correct_keep :
    forall A x i,
      x < n -> i <= x -> normalized_upper_triangle A ->
      forall i' j, i' < n -> i' >= i -> j < n -> Mget (snd (GE_elemup A x i)) i' j = Mget A i' j.
  Proof.
    intros.
    generalize dependent A.
    generalize dependent i.
    generalize dependent j.
    generalize dependent i'.
    generalize dependent x.
    induction i.
    - intros.
      simpl.
      reflexivity.
    - intros.
      simpl.
      destruct (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i) eqn: eq.
      simpl.
      assert (snd (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i)@[i', j] = (row_add_to_row i x (MEopp (A@[i, x])) @* A)@[i', j]).
      {
        apply IHi; auto; try omega.
        apply nut_preserve; auto; try omega.
      }
      rewrite eq in H5. simpl in H5.
      rewrite H5.
      rewrite get_element_row_add_to_row; auto; try omega.
      elim_bool; auto.
      omega.
  Qed.

  Lemma GE_elemup_correct_3 :
    forall A x i,
      x < n -> i <= x -> normalized_upper_triangle A ->
      (forall i0, i0 < i -> (snd (GE_elemup A x i))@[i0, x] = e0).
  Proof.
    intros.
    generalize dependent A.
    generalize dependent x.
    generalize dependent i.
    generalize dependent i0.
    induction i; intros.
    - simpl. omega.
    - simpl.
      inversion H1.
      unfold Diag_ones in H3.
      unfold lower_left_zeros in H4.
      destruct (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i) eqn: eq.
      replace (snd (m @* row_add_to_row i x (MEopp (A@[i, x])), m0)) with (snd (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i)) by (rewrite eq; auto).
      destruct (i0 =? i) eqn: eq2; elim_bool; auto.
      + rewrite GE_elemup_correct_keep; auto; try omega.
        * rewrite get_element_row_add_to_row; auto; try omega.
          elim_bool; auto; try omega.
          replace (A@[x, x]) with e1 by (rewrite H3; auto; omega).
          rewrite eq0.
          ring.
        * apply nut_preserve; auto; try omega.
      + rewrite IHi; auto; try omega.
        apply nut_preserve; auto; try omega.
  Qed.

  Lemma GE_elemup_correct_4 :
    forall A x i L ,
      x < n -> i <= x -> L < n - x -> normalized_upper_triangle A -> upper_right_zeros A L ->
      upper_right_zeros (snd (GE_elemup A x i)) L.
  Proof.
    intros.
    generalize dependent A.
    generalize dependent x.
    generalize dependent L.
    induction i; intros; try assumption.
    simpl.
    destruct (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i) eqn: eq.
    replace (snd (m @* row_add_to_row i x (MEopp (A@[i, x])), m0)) with (snd (GE_elemup (row_add_to_row i x (MEopp (A@[i, x])) @* A) x i)) by (rewrite eq; auto).
    apply IHi; auto; try omega.
    - apply nut_preserve; auto; omega.
    - unfold upper_right_zeros.
      intros.
      rewrite get_element_row_add_to_row; auto; try omega.
      elim_bool; auto; try omega.
      rewrite eq0.
      replace (A@[i, j]) with e0 by (rewrite H3; auto; omega).
      replace (A@[x, j]) with e0 by (rewrite H3; auto; omega).
      ring.
  Qed.

  Lemma GE_elemup_correct_5:
    forall A x,
      x < n -> normalized_upper_triangle A -> upper_right_zeros A (n - x - 1) ->
      upper_right_zeros (snd (GE_elemup A x x)) (n - x).
  Proof.
    intros.
    unfold upper_right_zeros.
    intros.
    destruct (j =? x) eqn: eq; elim_bool; auto.
    - rewrite eq. apply GE_elemup_correct_3; auto; try omega.
    - rewrite GE_elemup_correct_4 with (L := n - x - 1);auto; try omega.
  Qed.

  Lemma GE_stage2_correct_1:
    forall A i,
      i <= n ->
      fst (GE_stage2 A i) @* A @= snd (GE_stage2 A i).
  Proof.
    intros.
    generalize dependent A.
    induction i.
    - intros; simpl.
      apply I_is_identity.
    - intros.
      simpl.
      destruct (GE_elemup A i i) eqn: eq1.
      destruct (GE_stage2 m0 i) eqn: eq2.
      simpl.
      rewrite mult_assoc.
      replace (m) with (fst (GE_elemup A i i)) by (rewrite eq1; auto).
      rewrite GE_elemup_correct_1; auto; try omega.
      replace (m1) with (fst (GE_stage2 m0 i)) by (rewrite eq2; auto).
      replace (m2) with (snd (GE_stage2 m0 i)) by (rewrite eq2; auto).
      replace (m0) with (snd (GE_elemup A i i)) by (rewrite eq1; auto).
      apply IHi; auto; try omega.
  Qed.

  Lemma GE_stage2_correct_2:
    forall A i,
      i <= n -> normalized_upper_triangle A ->
      normalized_upper_triangle (snd (GE_stage2 A i)).
  Proof.
    intros.
    generalize dependent A.
    induction i.
    - intros. simpl. assumption.
    - intros; simpl.
      destruct (GE_elemup A i i) eqn: eq1.
      destruct (GE_stage2 m0 i) eqn: eq2.
      simpl.
      replace (m2) with (snd (GE_stage2 m0 i)) by (rewrite eq2; auto).
      apply IHi; auto; try omega.
      replace (m0) with (snd (GE_elemup A i i)) by (rewrite eq1; auto).
      apply GE_elemup_correct_2; auto; try omega.
  Qed.

  Lemma GE_stage2_correct_3:
    forall A i,
      i <= n -> normalized_upper_triangle A -> upper_right_zeros A (n - i) ->
      upper_right_zeros (snd (GE_stage2 A i)) n.
  Proof.
    intros.
    generalize dependent A.
    induction i.
    - intros; simpl. replace (n) with (n - 0) by omega. assumption.
    - intros; simpl.
      destruct (GE_elemup A i i) eqn: eq1.
      destruct (GE_stage2 m0 i) eqn: eq2.
      simpl.
      replace (m2) with (snd (GE_stage2 m0 i)) by (rewrite eq2; auto).
      apply IHi; auto; try omega.
      + replace (m0) with (snd (GE_elemup A i i)) by (rewrite eq1; auto).
        apply GE_elemup_correct_2; auto; try omega.
      + replace (m0) with (snd (GE_elemup A i i)) by (rewrite eq1; auto).
        apply GE_elemup_correct_5; auto; try omega.
        replace (n - i - 1) with (n - S i) by omega.
        assumption.
  Qed.

  Theorem GE_stage2_correct:
    forall A,
      normalized_upper_triangle A ->
      fst (GE_stage2 A n) @* A @= snd (GE_stage2 A n) /\ snd (GE_stage2 A n) @= I.
  Proof.
    intros.
    split.
    - apply GE_stage2_correct_1. auto.
    - unfold "@=".
      intros.
      destruct (j <=? i) eqn: eq; elim_bool; auto; try omega.
      + destruct (j =? i) eqn: eq2; elim_bool; auto; try omega.
        * subst.
          unfold I. unfold Matrix.I.
          rewrite Mfill_correct; elim_bool; auto; try omega.
          apply GE_stage2_correct_2; auto.
        * unfold I. unfold Matrix.I.
          rewrite Mfill_correct; elim_bool; auto; try omega.
          apply GE_stage2_correct_2; auto; omega.
      + unfold I. unfold Matrix.I.
        rewrite Mfill_correct; elim_bool; auto; try omega.
        apply GE_stage2_correct_3; auto; try omega.
        unfold upper_right_zeros; intros.
        omega.
  Qed.

  Theorem Inversion_correct:
    forall A E,
      Inversion A = Some E -> E @* A @= I.
  Proof.
    intros.
    unfold Inversion in H.
    destruct (GE_stage1 A n) eqn: eq; try inversion H.
    clear H1.
    destruct p.
    inversion H. clear H.
    assert (m @* A @= m0 /\ normalized_upper_triangle m0) by (apply GE_stage1_correct; assumption).
    inversion H. clear H.
    rewrite mult_assoc.
    rewrite H0.
    assert ((snd (GE_stage2 m0 n)) @= I) by (apply GE_stage2_correct; auto).
    rewrite <- H.
    apply GE_stage2_correct.
    assumption.
  Qed.

  Lemma invertible_closed:
    forall A B,
      invertible A -> invertible B -> invertible (A @* B).
  Proof.
    intros.
    unfold invertible in *.
    inversion H.
    inversion H0.
    exists (x0 @* x).
    split.
    - rewrite mult_assoc.
      assert (B @* (x0 @* x) @= ((B @* x0) @* x)) by (rewrite mult_assoc; reflexivity).
      rewrite H3.
      inversion H2.
      rewrite H4.
      rewrite I_is_left_identity.
      apply H1.
    - rewrite mult_assoc.
      assert ((x @* (A @* B)) @= ((x @* A) @* B)) by (rewrite mult_assoc; reflexivity).
      rewrite H3.
      inversion H1.
      rewrite H5.
      rewrite I_is_left_identity.
      apply H2.
  Qed.

  Lemma row_mul_invertible:
    forall i x,
      i < n -> x <> MEzero -> invertible (row_mul i x).
  Proof.
    intros.
    unfold invertible.
    exists (row_mul i (MEinv x)).
    split.
    - unfold Meq.
      intros.
      rewrite get_element_row_mul; auto; try omega.
      destruct (i0 =? i) eqn: eq; elim_bool.
      + unfold row_mul. unfold Matrix.row_mul. rewrite Mfill_correct; urgh.
        * unfold I; unfold Matrix.I; urgh.
        * unfold I; unfold Matrix.I; urgh.
      + unfold row_mul; unfold Matrix.row_mul; urgh.
        * unfold I; unfold Matrix.I; urgh.
        * unfold I; unfold Matrix.I; urgh.
    - unfold Meq; intros.
      rewrite get_element_row_mul; urgh.
      + unfold row_mul; unfold Matrix.row_mul; unfold I; unfold Matrix.I; urgh.
      + unfold row_mul; unfold Matrix.row_mul; unfold I; unfold Matrix.I; urgh.
  Qed.

  Lemma row_add_to_row_invertible:
    forall x y c,
      x < n -> y < n -> x <> y -> invertible (row_add_to_row x y c).
  Proof.
    intros.
    unfold invertible.
    exists (row_add_to_row x y (MEopp c)).
    split; unfold Meq; intros; rewrite get_element_row_add_to_row; urgh; unfold row_add_to_row; unfold Matrix.row_add_to_row; unfold I; unfold Matrix.I; unfold e; unfold Matrix.e; urgh; simpl in *; try inversion eq7; try inversion eq8;  try inversion eq4; try field.
  Qed.

  Lemma swap_invertible:
    forall x y,
      x < n -> y < n -> invertible (swap x y).
  Proof.
    intros.
    unfold invertible.
    exists (swap x y).
    split; unfold Meq; intros; unfold I; unfold Matrix.I; unfold swap; unfold Matrix.swap; urgh; simpl; rewrite Mtimes_correct; auto; urgh.
    - remember (if j =? x then y else if j =? y then x else j) as t.
      apply sum_single with (x0 := t); intros; try rewrite Heqt; unfold I; unfold Matrix.I; unfold e; unfold Matrix.e; urgh.
    - apply sum_e0';intros; unfold I; unfold Matrix.I; unfold e; unfold Matrix.e; urgh.
    - remember (if j =? x then y else if j =? y then x else j) as t.
      apply sum_single with (x0 := t); intros; try rewrite Heqt; unfold I; unfold Matrix.I; unfold e; unfold Matrix.e; urgh.
    - apply sum_e0';intros; unfold I; unfold Matrix.I; unfold e; unfold Matrix.e; urgh.
  Qed.

  Lemma GE_elemdown_preserve_invertibility:
    forall A x cur,
      x < n -> cur < n - x -> invertible A ->
      invertible (snd (GE_elemdown A x cur)).
  Proof.
    intros.
    generalize dependent A.
    generalize dependent x.
    induction cur; intros.
    - simpl. assumption.
    - simpl.
      destruct (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur) eqn: eq.
      simpl.
      replace (m0) with (snd (GE_elemdown (row_add_to_row (n - S cur) x (MEopp (A@[n - S cur, x])) @* A) x cur)) by (rewrite eq; auto).
      apply IHcur; try omega.
      apply invertible_closed; try assumption.
      apply row_add_to_row_invertible; omega.
  Qed.

  Lemma kernal_span:
    forall F: (nat -> nat -> MEt), forall i: nat,
        (forall j k, j <= i -> k > j -> k < n -> F j k = e0) ->
        (forall j, j < i -> F j j = e1) ->
        F i i = e0 ->
        (exists c: nat -> MEt, forall k, k < n -> F i k = sum i (fun j => (c j) *e (F j k))).
  Proof.
    intros.
    generalize dependent F.
    induction i.
    - intros.
      exists (fun x => e0).
      intros.
      simpl.
      destruct (k =? 0) eqn: eq; urgh.
      apply H; omega.
    - intros.
      assert (exists c: nat -> MEt, forall k: nat, k < n -> (if i <? i then F i k else F (S i) k -e F i k *e F (S i) i) = sum i (fun j => (c j) *e (if j <? i then F j k else F (S i) k -e F i k *e F (S i) i))).
      {
        apply IHi with (F := (fun x y => if x <? i  then F x y else (F (S i) y) -e (F i y *e F (S i) i))).
        - intros.
          urgh.
          assert (i = j) by omega.
          rewrite <- H5 in H3.
          destruct (k =? i) eqn: eq2; urgh.
          assert (F (S j) k = e0).
          {
            destruct (k =? S j) eqn: eq3; urgh.
            rewrite H; try omega; reflexivity.
          }
          rewrite H5.
          rewrite H; try omega.
          ring.
        - intros.
          urgh.
        - urgh.
          rewrite H0; try omega.
          ring.
      }
      inversion H2.
      remember (x) as c'.
      clear H2 Heqc' x.
      exists (fun x => if x =? i then F (S i) i else c' x).
      intros.
      apply H3 in H2.
      urgh.
      rewrite sum_eq with (g := fun x => c' x *e F x k) in H2 .
      + rewrite sum_split with (g := fun x => (if x =? i then e0 else c' x) *e F x k) (h := fun x => (if x =? i then F (S i) i else e0) *e F x k).
        * assert (fold_nat (S i)
                           (fun (acc : MEt) (x : nat) => acc +e (if x =? i then e0 else c' x) *e F x k) e0 = F (S i) k -e F i k *e F (S i) i).
          {
            simpl.
            urgh.
            rewrite sum_eq with (g := fun x => c' x *e F x k).
            - rewrite <- H2.
              ring.
            - intros.
              urgh.
          }
          rewrite H4.
          rewrite sum_single with (x := i) (y := F (S i) i *e F i k); urgh; try ring.
          intros.
          urgh.
        * intros.
          urgh.
      + intros.
        urgh.
  Qed.

  Lemma get_first_none_zero_invertibility_lemma:
    forall A i,
      i <= n -> 0 < i -> invertible A -> Diag_ones A (n - i) -> lower_left_zeros A (n - i + 1) -> Mget A (n - i) (n - i) = e0 -> False.
  Proof.
    intros.
    inversion H1.
    inversion H5.
    remember x as B.
    clear H5 H6 HeqB x.
    assert ((exists c: nat -> MEt, forall k, k < n -> Mget A k (n - i) = sum (n - i) (fun j => (c j) *e (Mget A k j)))).
    {
      apply kernal_span with (F := fun i j => Mget A j i).
      - intros. unfold lower_left_zeros in H2.
        apply H3; try omega.
      - intros.
        apply H2; try omega.
      - assumption.
    }
    inversion H5.
    remember (x) as c.
    clear H5 Heqc x.
    assert (forall j, j < n - i -> sum n (fun k => Mget B (n - i) k *e Mget A k j) = e0).
    {
      intros.
      unfold Meq in H7.
      rewrite <- Mtimes_correct; try omega.
      rewrite H7; try omega.
      unfold I; unfold Matrix.I; urgh.
    }
    assert (sum n (fun k => Mget B (n - i) k *e Mget A k (n - i)) = e1).
    {
      intros.
      unfold Meq in H7.
      rewrite <- Mtimes_correct; try omega.
      rewrite H7; try omega.
      unfold I; unfold Matrix.I; urgh.
    }
    assert (sum n (fun k => Mget B (n - i) k *e Mget A k (n - i)) = e0).
    {
      rewrite sum_eq with (g := fun x => sum (n - i) (fun (y : nat) => B@[n - i, x] *e (c y *e A@[x, y]))).
      - rewrite sum_swap with (n0 := n) (m := n - i).
        apply sum_e0'.
        intros.
        rewrite sum_eq with (g := fun x => c i0 *e (B@[n - i, x] *e A@[x, i0])).
        + rewrite <- sum_multiply_l.
          rewrite H5; auto.
          ring.
        + intros.
          ring.
      - intros.
        rewrite <- sum_multiply_l.
        rewrite <- H6; auto.
    }
    remember (sum n (fun k : nat => B@[n - i, k] *e A@[k, n - i])) as x.
    rewrite H9 in H8.
    assert (e0 <> e1) by apply non_trivial_ring.
    rewrite H8 in H10.
    unfold not in H10.
    apply H10.
    reflexivity.
  Qed.

  Lemma get_first_none_zero_less_condition:
    forall A i j,
      i <= n -> (get_first_none_zero A i j = n -> (forall k, k >= n - i -> k < n -> Mget A k j = e0)).
  Proof.
    intros.
      generalize dependent k.
      induction i.
      + intros.
        omega.
      + intros.
        destruct (k =? n - S i) eqn: eq; urgh.
        * simpl in H0.
          rewrite eq. (* Needed in 8.6 *)
          urgh.
        * apply IHi; try omega.
          simpl in H0.
          urgh.
  Qed.

  Lemma get_first_none_zero_invertibility:
          forall A i,
            i <= n -> 0 < i -> invertible A -> Diag_ones A (n - i) -> lower_left_zeros A (n - i) -> get_first_none_zero A i (n - i) < n.
  Proof.
    intros.
    assert (get_first_none_zero A i (n - i) <= n) by (apply get_first_none_zero_at_most).
    assert (get_first_none_zero A i (n - i) < n <-> get_first_none_zero A i (n - i) <> n) by (split; omega).
    apply H5.
    clear H4 H5.
    unfold not.
    intros.
    assert ((forall k, k >= n - i -> k < n -> Mget A k (n - i) = e0)) by (apply get_first_none_zero_less_condition; omega).
    clear H4.
    apply get_first_none_zero_invertibility_lemma with (A := A) (i := i); urgh.
    - unfold lower_left_zeros.
      intros.
      destruct (j =? n - i) eqn: eq; urgh.
      + apply H5; omega.
      + apply H3; omega.
    - apply H5; omega.
  Qed.

  Lemma GE_stage1_preserve_invertibility:
    forall A i,
      i <= n -> lower_left_zeros A (n - i) -> invertible A -> Diag_ones A (n - i) ->
      GE_stage1 A i <> None.
  Proof.
    intros.
    generalize dependent A.
    induction i.
    - intros.
      unfold not.
      intros.
      inversion H3.
    - intros.

      remember (swap (n - S i) (get_first_none_zero A (S i) (n - S i)) @* A) as A0; remember (row_mul (n - S i) (MEinv (A0@[n - S i, n - S i])) @* A0) as A1.
      assert (get_first_none_zero A (S i) (n - S i) <= n) by apply get_first_none_zero_at_most.
        assert (get_first_none_zero A (S i) (n - S i) >= n - S i) by apply get_first_none_zero_at_least.
      assert (forall m m0, get_first_none_zero A (S i) (n - S i) <> n -> GE_elemdown A1 (n - S i) (S i - 1) = (m, m0) -> GE_stage1 m0 i <> None).
      {
        intros.
        apply IHi; try omega.
        - try rewrite <- HeqA0 in *; try rewrite <- HeqA1 in *.
            unfold lower_left_zeros.
            intros.
            replace (m0) with (snd (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite H6; auto).
            replace (S i - 1) with (n - (n - S i) - 1) by omega.
            apply GE_elemdown_correct_extend_0 with (x := n - S i); urgh.
            + apply get_first_none_zero_correct; urgh.
            + unfold lower_left_zeros; intros.
              urgh.
              * replace ( A@[get_first_none_zero A (S i) (n - S i), j0]) with e0 by (rewrite <- H0; auto; try omega).
                ring.
              *  rewrite <- H0; auto; omega.
        - replace (m0) with (snd (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite H6; auto).
          apply GE_elemdown_preserve_invertibility; urgh.
          apply invertible_closed.
          + apply row_mul_invertible; try omega.
            urgh.
            * assert (get_first_none_zero A (S i) (n - S i) <= n) by apply get_first_none_zero_at_most.
              assert (A@[get_first_none_zero A (S i) (n - S i), n - S i] <> e0) by (apply get_first_none_zero_correct; omega).
              remember (A@[get_first_none_zero A (S i) (n - S i), n - S i]) as r.
              apply normal_field_knowledge.

              assumption.
          + apply invertible_closed; try assumption.
            apply swap_invertible; try omega.
        -
          unfold Diag_ones; intros.
          replace (m0) with (snd (GE_elemdown A1 (n - S i) (S i - 1))) by (rewrite H6; auto).
          rewrite GE_elemdown_correct_keep; auto; try omega.
          + rewrite HeqA1.
            rewrite get_element_row_mul; elim_bool; auto; try omega.
            * rewrite eq; field.
              rewrite HeqA0. rewrite get_element_swap; urgh.
              --- apply get_first_none_zero_correct.
                  omega.
            * rewrite HeqA0.
              rewrite get_element_swap; urgh.
              apply H2; urgh.
          + urgh. apply get_first_none_zero_correct.
            omega.
      }

      Ltac urgh2 :=
    repeat (try
      ( let eq := fresh "eq" in
        match goal with
        | [ |- context[?x =? ?y]] => destruct (x =? y) eqn: eq
        | [ |- context[?x <? ?y]] => destruct (x <? y) eqn: eq
        | [ |- context[?x <=? ?y]] => destruct (x <=? y) eqn: eq
        | [ |- context[Mfill _ ]] => rewrite Mfill_correct
        | [ |- context [Melementwise_op _ _ _]] => rewrite Melementwise_op_correct
        | [ |- context[let (_, _) := ?x in _]] => destruct x eqn: eq
        | [ |- context[match ?x with | _ => _ end]] => destruct (x) eqn: eq
        | [H: context[let (_, _) := ?x in _] |- _] => destruct x eqn: eq
        | [H: context[?x =? ?y] |- _] => destruct (x =? y) eqn: eq
        | [H: context[?x <? ?y] |- _] => destruct (x <? y) eqn: eq
        | [H: context[?x <=? ?y] |- _] => destruct (x <=? y) eqn: eq
        | [H: context[match ?x with | _ => _ end] |- _] => destruct (x) eqn: eq               | [H: Some _ = None |- _] => inversion H
        | [H: None = Some _|- _] => inversion H
        | [H: true = false|- _] => inversion H
        | [H: false = true|- _] => inversion H
        | [ |- context[((e _ _ _) @* _)@[_, _]]] => rewrite get_element_e
        | [ |- context[((row_mul _ _) @* _)@[_, _]]] => rewrite get_element_row_mul
        | [ |- context[((row_add_to_row _ _ _) @* _)@[_, _]]] => rewrite get_element_row_add_to_row
        | [ |- context[((swap _ _) @* _)@[_, _]]] => rewrite get_element_swap
      end);
  try elim_bool;
  auto;
  try omega).

      unfold GE_stage1; urgh2; try rewrite HeqA1 in *; try rewrite HeqA0 in *.
      +
        assert (get_first_none_zero A (S i) (n - S i) < n) by (apply get_first_none_zero_invertibility; try assumption; omega).
        omega.
      +
        unfold not.
        intros.
        inversion H6.
      +
        rewrite <- eq1 at 1.
        fold GE_stage1 in *.
        apply H5 with (m:= m); assumption.

  Qed.

  Definition default_get {A: Type} (d: A) (c: option A) :=
    match c with
    | None => d
    | Some c' => c'
    end.

  Theorem Inversion_very_correct:
    forall A,
      invertible A -> default_get I (Inversion A) @* A @= I.
  Proof.
    intros.
    assert (GE_stage1 A n <> None).
    {
      apply GE_stage1_preserve_invertibility; urgh.
      - unfold lower_left_zeros; intros; urgh.
      - unfold Diag_ones; intros; urgh.
    }
    unfold default_get.
    unfold Inversion.
    urgh.
    - apply Inversion_correct.
      unfold Inversion.
      urgh.
      subst.
      inversion Heqo0; subst.
      assumption.
    - unfold not in H0.
      assert (False) by auto.
      inversion H1.
  Qed.

End MatrixInversion.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega.

Set Implicit Arguments.

Tactic Notation "eq" "goal" "with" hyp(H) :=
  match goal with |- ?b => match type of H with ?t => replace b with t; auto end end.

Theorem nat_rev_ind (P : nat -> Prop) (HP : forall n, P (S n) -> P n) x y : x <= y -> P y -> P x.
Proof. induction 1; auto. Qed.

Reserved Notation "f ↑ n" (at level 1, left associativity).

Fixpoint iter X (f : X -> X) n x :=
  match n with
    | 0 => x
    | S n => f (f↑n x)
  end
where "f ↑ n" := (@iter _ f n).

Fact iter_plus X f a b (x : X) : f↑(a+b) x = f↑a (f↑b x).
Proof. induction a; simpl; f_equal; auto. Qed.

Tactic Notation "rew" "iter" constr(f) :=
  repeat match goal with
    | |- context[f ?x]           => change (f x) with (f↑1 x)
    | |- context[f↑?a (f↑?b ?x)] => rewrite <- (iter_plus f a b)
  end.

Section Tortoise_and_Hare_tail_recursive.

  Variables (X : Type) (eqdec : forall x y : X, { x = y } + { x <> y }).

  Infix "=?" := eqdec (at level 70).

  Variable (f : X -> X) (x0 : X)
           (Hx0 : exists τ, 0 < τ /\ f↑τ x0 = f↑(2*τ) x0).

  Let R (c d : X*X) := match d with (x,y) => x<>y /\ c = (f x, f (f y)) end.

  Let tortoise_hare_tail_rec :
    forall i x y, Acc R (x,y) -> { k | i <= k /\ f↑(k-i) x = f↑(2*(k-i)) y }.
  Proof.
    refine (fix loop i x y H { struct H } :=
           match x =? y with
             | left E  => exist _ i _
             | right C => match loop (S i) (f x) (f (f y)) _ with
                            | exist _ k Hk => exist _ k _
                          end
           end).
    * split; f_equal; auto; omega.
    * apply Acc_inv with (1 := H); constructor; trivial.
    * destruct Hk; split; try omega.
      revert H1; rew iter f; intros H1.
      eq goal with H1; do 2 f_equal; omega.
  Qed.

  Let Acc_eq x y : x = y -> Acc R (x,y).
  Proof.
    intros; constructor 1.
    intros [] (? & _); tauto.
  Qed.

  Let Acc_f0_ff0 : Acc R (f x0, f (f x0)).
  Proof.
    destruct Hx0 as (k & H1 & H2).
    apply Acc_eq in H2.
    revert k H1 H2; apply nat_rev_ind.
    intros ? H.
    constructor 1.
    intros (u,v) (_ & Huv).
    inversion Huv; subst.
    rew iter f; eq goal with H; do 3 f_equal; omega.
  Qed.

  Definition tortoise_hare_tail : { τ | 0 < τ /\ f↑τ x0 = f↑(2*τ) x0 }.
  Proof.
    refine (match tortoise_hare_tail_rec 1 Acc_f0_ff0 with
      | exist _ k Hk => exist _ k _
    end).
    destruct Hk as (? & Hk); split; try omega.
    revert Hk; rew iter f; intros Hk.
    eq goal with Hk; do 2 f_equal; omega.
  Defined.

End Tortoise_and_Hare_tail_recursive.

Recursive Extraction tortoise_hare_tail.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(** ** FRACTRAN termination is Diophantine *)

(* Require Import dio_expr dio_logic dio_elem dio_poly. *)

Require Import List Arith Omega.

Require Import utils_tac utils_list sums rel_iter pos vec.
Require Import fractran_defs prime_seq.
Require Import dio_logic dio_bounded dio_rt_closure dio_single.

Set Implicit Arguments.

Section fractran_dio.

  Notation "l /F/ x → y" := (fractran_step l x y) (at level 70, no associativity).

  (* Fractran step is a diophantine relation *)

  Lemma dio_rel_fractran_step l x y : 𝔻P x -> 𝔻P y -> 𝔻R (fun ν => l /F/ x ν → y ν).
  Proof.
    intros Hx Hy.
    induction l as [ | (p,q) l IHl ].
    + apply dio_rel_equiv with (fun _ => False); auto.
      intros v; rewrite fractran_step_nil_inv; split; tauto.
    + apply dio_rel_equiv with (1 := fun v => fractran_step_cons_inv p q l (x v) (y v)); auto.
  Defined.

  Hint Resolve dio_rel_fractran_step.

  (* Hence Fractan step* (refl. trans. closure) is diophantine *)

  Theorem dio_rel_fractran_rt l x y :
                     𝔻P x -> 𝔻P y -> 𝔻R (fun ν => fractran_compute l (x ν) (y ν)).
  Proof.
    intros; apply dio_rel_exst, dio_rel_rel_iter; auto.
  Defined.

  (* Fractran stop is a diophantine relation *)

  Theorem dio_rel_fractran_stop l x : 𝔻P x -> 𝔻R (fun ν => fractran_stop l (x ν)).
  Proof.
    intros Hx.
    induction l as [ | (p,q) l IHl ].
    + apply dio_rel_equiv with (fun _ => True); auto.
      intro v; split; auto; intros _ ?.
      rewrite fractran_step_nil_inv; auto.
    + apply dio_rel_equiv with (1 := fun v => fractan_stop_cons_inv p q l (x v)); auto.
  Defined.

  Hint Resolve dio_rel_fractran_rt dio_rel_fractran_stop.

  (* We start with the case of regular Fractran programs that do not
     contain (_,0) "fractions" *)

  (* Hence Halting from the value x is diophantine *)

  Theorem FRACTRAN_HALTING_on_diophantine ll x :
                      𝔻P x -> 𝔻R (fun ν => FRACTRAN_HALTING (ll,x ν)).
  Proof.
    intros; apply dio_rel_exst, dio_rel_conj; auto.
  Defined.

  Theorem FRACTRAN_HALTING_diophantine_0 ll : 𝔻R (fun ν => FRACTRAN_HALTING (ll,ν 0)).
  Proof.
    intros; apply FRACTRAN_HALTING_on_diophantine; auto.
  Defined.

  Theorem FRACTRAN_HALTING_diophantine l x : 𝔻R (fun _ => FRACTRAN_HALTING (l,x)).
  Proof. apply FRACTRAN_HALTING_on_diophantine; auto. Defined.

End fractran_dio.

Local Notation power := (mscal mult 1).

Fact power_expo x y : power x y = y^x.
Proof.
  induction x as [ | x IHx ]; simpl.
  + rewrite power_0; auto.
  + rewrite power_S; f_equal; auto.
Qed.

Theorem FRACTRAN_HALTING_dio_single l x : { e : dio_single nat Empty_set | l /F/ x ↓ <-> dio_single_pred e (fun _ => 0) }.
Proof.
  generalize (@FRACTRAN_HALTING_on_diophantine l (fun _ => x)); intros H1.
  spec in H1; auto.
  destruct dio_rel_single with (1 := H1) as ((p,q) & He).
  unfold FRACTRAN_HALTING in He.
  exists (dp_inst_par (fun _ => 0) p, dp_inst_par (fun _ => 0) q).
  rewrite He with (ν := fun _ => 0).
  unfold dio_single_pred; simpl.
  split; intros (phi & Hphi); exists phi; revert Hphi;
    repeat rewrite dp_inst_par_eval; auto.
Qed.

Section exp_diophantine.

  (* for fixed n i j, the function v => exp i <v(j),...,v(n-1+j)> has a diophantine representation *)

  Let exp_dio n i j y : 𝔻P y -> 𝔻R (fun v => y v = exp i (fun2vec j n v)).
  Proof.
    revert j i y; induction n as [ | n IHn ]; intros j i y Hy.
    + simpl; dio_rel_auto.
    + assert (H : forall v, y v = exp i (fun2vec j (S n) v)
                        <-> exists q1 q2, y v = q1*q2
                                       /\ q1 = power (v j) (qs i)
                                       /\ q2 = exp (S i) (fun2vec (S j) n v)).
      { intros v; simpl fun2vec; rewrite exp_cons; split.
        * exists (qs i^v j), (exp (S i) (fun2vec (S j) n v));
            rewrite power_expo; auto.
        * intros (q1 & q2 & H & ? & ?); subst.
          rewrite H, power_expo; auto. }
      apply dio_rel_equiv with (1 := H); clear H.
      do 2 apply dio_rel_exst.
      apply dio_rel_conj; auto.
      apply dio_rel_conj; auto.
      assert (H : dio_rel (fun v => v 0 = exp (S i) (fun2vec (3+j) n v))).
      { apply IHn; auto. }
      revert H; apply dio_rel_equiv.
      intros v; rewrite fun2vec_lift with (f := fun i => v (S i)).
      rewrite fun2vec_lift; simpl; tauto.
  Qed.

  (* for a fixed n, the relation

         ν 0 = ps 1 * (qs 1)^(ν 1) * ... * (qs n)^(ν n)

     has a diophantine representation *)

  Hint Resolve exp_dio.

  Fact exp_diophantine n : 𝔻R (fun ν => ν 0 = ps 1 * exp 1 (fun2vec 0 n (fun x => ν (S x)))).
  Proof.
    apply dio_rel_equiv with (fun v => exists y, v 0 = ps 1 * y
                                    /\ y = exp 1 (fun2vec 0 n (fun x => v (S x)))).
    + intro v; split.
      * exists (exp 1 (fun2vec 0 n (fun x => v (S x)))); auto.
      * intros (y & H1 & <-); auto.
    + apply dio_rel_exst, dio_rel_conj; auto.
      apply dio_rel_equiv with (fun v => v 0 = exp 1 (fun2vec 2 n v)); auto.
      intro; repeat rewrite <- fun2vec_lift; tauto.
  Qed.

End exp_diophantine.

Hint Resolve exp_diophantine.

Theorem FRACTRAN_HALTING_on_exp_diophantine n l :
                     𝔻R (fun ν => l /F/ ps 1 * exp 1 (fun2vec 0 n ν) ↓).
Proof.
  apply dio_rel_compose with (R := fun x v => l /F/ x ↓); auto.
  apply FRACTRAN_HALTING_on_diophantine; auto.
Qed.

Check FRACTRAN_HALTING_on_exp_diophantine.
Print Assumptions FRACTRAN_HALTING_on_exp_diophantine.


Definition N := 16.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


(** * IterFlip.v: An example of probabilistic termination *)

Require Export Prog.
Require ZArith.
Set Implicit Arguments.

Module IterFlip (Univ:Universe).
Module RP := (Rules Univ).
(* begin hide *)
Import Univ.
Import RP.
Import RP.PP.
Import RP.PP.MP.
Import RP.PP.MP.UP.
(* end hide *)
(** ** Definition of a random walk
We interpret the probabilistic program
<<
let rec iter x = if flip() then iter (x+1) else x
>>*)
Import ZArith.

Definition Fiter (f: Z -> (distr Z)) (x:Z) := Mif Flip (f (Zsucc x)) (Munit x).

Lemma Fiter_mon : forall f g : Z -> distr Z,
  (forall n, le_distr (f n) (g n)) -> forall n, le_distr (Fiter f n) (Fiter g n).
unfold Fiter; intros.
apply Mif_mon; auto.
Qed.

Definition iterflip : Z -> (distr Z) := Mfix Fiter Fiter_mon.

(** ** Main result
     Probability for [iter] to terminate is $1$ *)
(** *** Auxiliary function $p_n$
   Definition $ p_n = 1 - \frac{1}{2^n} $ *)

Fixpoint p (n : nat) : U := match n with O => 0 | (S n) => [1/2] * p n + [1/2] end.

Lemma p_eq : forall n:nat, p n == [1-]([1/2]^n).
induction n; simpl; auto.
setoid_rewrite IHn.
apply Ueq_trans with ([1/2] * [1-]([1/2]^n) + [1-][1/2]);auto.
Qed.
Hint Resolve p_eq.

Lemma p_le : forall n:nat, [1-]([1/]1+n) <= p n.
intro; setoid_rewrite (p_eq n).
apply Uinv_le_compat.
induction n; simpl; intros; auto.
apply Ule_trans with ([1/2] * ([1/]1+n)); auto.
Qed.

Hint Resolve p_le.

Lemma lim_p_one : 1 <= lub p.
apply Ule_lt_lim; intros.
assert (exc (fun n : nat => t <= [1-] ([1/]1+n))).
assert (~(0==[1-] t)).
red; intro; apply H; auto.
apply Ule_trans with ([1-] 0); auto.
apply (archimedian H0); auto; intros m H1.
apply exc_intro with m; auto.
apply H0; auto; intros.
apply Ule_trans with (p x); auto.
apply Ule_trans with ([1-] ([1/]1+x)); auto.
Qed.

Hint Resolve lim_p_one.

(** *** Proof of probabilistic termination  *)
Definition q1 (z1 z2:Z) := 1.

Lemma iterflip_term : okfun (fun k => 1) iterflip q1.
unfold iterflip; intros.
apply okfun_le_compat with (fun (k:Z) => lub p) q1; auto.
apply fixrule with (p:= fun (x:Z) => p); auto; intros.
red; simpl; intros.
unfold Fiter.
red.
setoid_rewrite (Mif_eq Flip (f (Zsucc x)) (Munit x) (q1 x)); simpl.
unfold unit; simpl.
setoid_rewrite flip_ctrue.
setoid_rewrite flip_cfalse.
unfold q1 at 2.
setoid_rewrite (Umult_one_left [1/2]).
apply Uplus_le_compat_left.
apply Ule_trans with (p i * [1/2]); auto.
apply Umult_le_compat_left; auto.
apply (H (Zsucc x)%Z).
Qed.

End IterFlip.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task.
Require Import prosa.classic.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect eqtype ssrbool ssrnat seq bigop.

(* Definitions of deadline miss. *)
Module Schedulability.

  Import Schedule SporadicTaskset Job.

  Section SchedulableDefs.

    Context {sporadic_task: eqType}.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any multiprocessor schedule of these jobs. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    Section ScheduleOfJobs.

      (* Let j be any job. *)
      Variable j: Job.

      (* We say that job j misses no deadline in sched if it completed by its absolute deadline. *)
      Definition job_misses_no_deadline :=
        completed job_cost sched j (job_arrival j + job_deadline j).

    End ScheduleOfJobs.

    Section ScheduleOfTasks.

      (* Consider any task tsk. *)
      Variable tsk: sporadic_task.

      (* Task tsk doesn't miss its deadline iff all of its jobs don't miss their deadline. *)
      Definition task_misses_no_deadline :=
        forall j,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          job_misses_no_deadline j.

      (* Task tsk doesn't miss its deadline before time t' iff all of its jobs don't miss
         their deadline by that time. *)
      Definition task_misses_no_deadline_before (t': time) :=
        forall j,
          arrives_in arr_seq j ->
          job_task j = tsk ->
          job_arrival j + job_deadline j < t' ->
          job_misses_no_deadline j.

    End ScheduleOfTasks.

  End SchedulableDefs.

  Section BasicLemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any schedule of these jobs... *)
    Context {num_cpus : nat}.
    Variable sched: schedule Job num_cpus.

    (* ... where jobs dont execute after completion. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    Section SpecificJob.

      (* Then, for any job j ...*)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.

      (* ...that doesn't miss a deadline in this schedule, ... *)
      Hypothesis no_deadline_miss:
        job_misses_no_deadline job_arrival job_cost job_deadline sched j.

      (* the service received by j at any time t' after its deadline is 0. *)
      Lemma service_after_job_deadline_zero :
        forall t',
          t' >= job_arrival j + job_deadline j ->
          service_at sched j t' = 0.
      Proof.
        intros t' LE.
        rename no_deadline_miss into RT,
               H_completed_jobs_dont_execute into EXEC.
        unfold job_misses_no_deadline, completed, completed_jobs_dont_execute in *.
        apply/eqP; rewrite -leqn0.
        eapply completion_monotonic in RT; eauto 2.
        apply completed_implies_not_scheduled in RT; eauto 2.
          by move: RT; rewrite not_scheduled_no_service; move => /eqP RT; rewrite RT.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_job_deadline_zero :
        forall t' t'',
          t' >= job_arrival j + job_deadline j ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        ins; apply/eqP; rewrite -leqn0.
        rewrite big_nat_cond; rewrite -> eq_bigr with (F2 := fun i => 0);
          first by rewrite big_const_seq iter_addn mul0n addn0 leqnn.
        intro i; rewrite andbT; move => /andP [LE _].
        by rewrite service_after_job_deadline_zero;
          [by ins | by apply leq_trans with (n := t')].
      Qed.

    End SpecificJob.

    Section AllJobs.

      (* Consider any task tsk ...*)
      Variable tsk: sporadic_task.

      (* ... that doesn't miss any deadline. *)
      Hypothesis no_deadline_misses:
        task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched tsk.

      (* Then, for any valid job j of this task, ...*)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Hypothesis H_job_of_task: job_task j = tsk.
      Hypothesis H_valid_job:
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

      (* the service received by job j at any time t' after the deadline is 0. *)
      Lemma service_after_task_deadline_zero :
        forall t',
          t' >= job_arrival j + task_deadline tsk ->
          service_at sched j t' = 0.
      Proof.
        rename H_valid_job into PARAMS; unfold valid_sporadic_job in *; des; intros t'.
        rewrite -H_job_of_task -PARAMS1.
        by apply service_after_job_deadline_zero, no_deadline_misses.
      Qed.

      (* The same applies for the cumulative service of job j. *)
      Lemma cumulative_service_after_task_deadline_zero :
        forall t' t'',
          t' >= job_arrival j + task_deadline tsk ->
          \sum_(t' <= t < t'') service_at sched j t = 0.
      Proof.
        rename H_valid_job into PARAMS; unfold valid_sporadic_job in *; des; intros t' t''.
        rewrite -H_job_of_task -PARAMS1.
        by apply cumulative_service_after_job_deadline_zero, no_deadline_misses.
      Qed.

    End AllJobs.

  End BasicLemmas.

End Schedulability.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
(* -*- coding : utf-8 -*- *)

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat choice seq fintype.

(*****************************************************************************)
(* Provided a base type T, this files defines an interface for quotients Q   *)
(* of the type T with explicit functions for canonical surjection (\pi       *)
(* : T -> Q) and for choosing a representative (repr : Q -> T).  It then     *)
(* provide a helper to quotient T by a decidable equivalence relation (e     *)
(* : rel T) if T is a choiceType (or encodable as a choiceType modulo e).    *)
(*                                                                           *)
(* See "Pragamatic Quotient Types in Coq", proceedings of ITP2013,           *)
(* by Cyril Cohen.                                                           *)
(*                                                                           *)
(* *** Generic Quotienting ***                                               *)
(*   QuotClass (reprK : cancel repr pi) == builds the quotient which         *)
(*              canonical surjection function is pi and which                *)
(*              representative selection function is repr.                   *)
(*   QuotType Q class == packs the quotClass class to build a quotType       *)
(*                       You may declare such elements as Canonical          *)
(*            \pi_Q x == the class in Q of the element x of T                *)
(*              \pi x == the class of x where Q is inferred from the context *)
(*             repr c == canonical representative in T of the class c        *)
(*    [quotType of Q] == clone of the canonical quotType structure of Q on T *)
(*     x = y %[mod Q] := \pi_Q x = \pi_Q y                                   *)
(*                    <-> x and y are equal modulo Q                         *)
(*    x <> y %[mod Q] := \pi_Q x <> \pi_Q y                                  *)
(*    x == y %[mod Q] := \pi_Q x == \pi_Q y                                  *)
(*    x != y %[mod Q] := \pi_Q x != \pi_Q y                                  *)
(*                                                                           *)
(* The quotient_scope is delimited by %qT                                    *)
(* The most useful lemmas are piE and reprK                                  *)
(*                                                                           *)
(* *** Morphisms ***                                                         *)
(* One may declare existing functions and predicates as liftings of some     *)
(* morphisms for a quotient.                                                 *)
(*    PiMorph1 pi_f == where pi_f : {morph \pi : x / f x >-> fq x}           *)
(*                     declares fq : Q -> Q as the lifting of f : T -> T     *)
(*    PiMorph2 pi_g == idem with pi_g : {morph \pi : x y / g x y >-> gq x y} *)
(*     PiMono1 pi_p == idem with pi_p : {mono \pi : x / p x >-> pq x}        *)
(*     PiMono2 pi_r == idem with pi_r : {morph \pi : x y / r x y >-> rq x y} *)
(*   PiMorph11 pi_f == idem with pi_f : {morph \pi : x / f x >-> fq x}       *)
(*                     where fq : Q -> Q' and f : T -> T'.                   *)
(*       PiMorph eq == Most general declaration of compatibility,            *)
(*                     /!\ use with caution /!\                              *)
(* One can use the following helpers to build the liftings which may or      *)
(* may not satisfy the above properties (but if they do not, it is           *)
(* probably not a good idea to define them):                                 *)
(*       lift_op1 Q f := lifts f : T -> T                                    *)
(*       lift_op2 Q g := lifts g : T -> T -> T                               *)
(*      lift_fun1 Q p := lifts p : T -> R                                    *)
(*      lift_fun2 Q r := lifts r : T -> T -> R                               *)
(*   lift_op11 Q Q' f := lifts f : T -> T'                                   *)
(* There is also the special case of constants and embedding functions       *)
(* that one may define and declare as compatible with Q using:               *)
(*    lift_cst Q x := lifts x : T to Q                                       *)
(*       PiConst c := declare the result c of the previous construction as   *)
(*                    compatible with Q                                      *)
(*  lift_embed Q e := lifts e : R -> T to R -> Q                             *)
(*       PiEmbed f := declare the result f of the previous construction as   *)
(*                    compatible with Q                                      *)
(*                                                                           *)
(* *** Quotients that have an eqType structure ***                           *)
(* Having a canonical (eqQuotType e) structure enables piE to replace terms  *)
(* of the form (x == y) by terms of the form (e x' y') if x and y are        *)
(* canonical surjections of some x' and y'.                                  *)
(*    EqQuotType e Q m == builds an (eqQuotType e) structure on Q from the   *)
(*                        morphism property m                                *)
(*                        where m : {mono \pi : x y / e x y >-> x == y}      *)
(*   [eqQuotType of Q] == clones the canonical eqQuotType structure of Q     *)
(*                                                                           *)
(* *** Equivalence and quotient by an equivalence ***                        *)
(*  EquivRel r er es et == builds an equiv_rel structure based on the        *)
(*                         reflexivity, symmetry and transitivity property   *)
(*                         of a boolean relation.                            *)
(*          {eq_quot e} == builds the quotType of T by equiv                 *)
(*                         where e : rel T is an equiv_rel                   *)
(*                         and T is a choiceType or a (choiceTypeMod e)      *)
(*                         it is canonically an eqType, a choiceType,        *)
(*                         a quotType and an eqQuotType.                     *)
(*    x = y %[mod_eq e] := x = y %[mod {eq_quot e}]                          *)
(*                      <-> x and y are equal modulo e                       *)
(*    ...                                                                    *)
(*****************************************************************************)

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

Reserved Notation "\pi_ Q" (at level 0, format "\pi_ Q").
Reserved Notation "\pi" (at level 0, format "\pi").
Reserved Notation "{pi_ Q a }"
         (at level 0, Q at next level, format "{pi_ Q  a }").
Reserved Notation "{pi a }" (at level 0, format "{pi  a }").
Reserved Notation "x == y %[mod_eq e ]" (at level 70, y at next level,
  no associativity,   format "'[hv ' x '/'  ==  y '/'  %[mod_eq  e ] ']'").
Reserved Notation "x = y %[mod_eq e ]" (at level 70, y at next level,
  no associativity,   format "'[hv ' x '/'  =  y '/'  %[mod_eq  e ] ']'").
Reserved Notation "x != y %[mod_eq e ]" (at level 70, y at next level,
  no associativity,   format "'[hv ' x '/'  !=  y '/'  %[mod_eq  e ] ']'").
Reserved Notation "x <> y %[mod_eq e ]" (at level 70, y at next level,
  no associativity,   format "'[hv ' x '/'  <>  y '/'  %[mod_eq  e ] ']'").
Reserved Notation "{eq_quot e }" (at level 0, e at level 0,
  format "{eq_quot  e }", only parsing).

Delimit Scope quotient_scope with qT.
Local Open Scope quotient_scope.

(*****************************************)
(* Definition of the quotient interface. *)
(*****************************************)

Section QuotientDef.

Variable T : Type.

Record quot_mixin_of qT := QuotClass {
  quot_repr : qT -> T;
  quot_pi : T -> qT;
  _ : cancel quot_repr quot_pi
}.

Notation quot_class_of := quot_mixin_of.

Record quotType := QuotTypePack {
  quot_sort :> Type;
  quot_class : quot_class_of quot_sort
}.

Variable qT : quotType.
Definition pi_phant of phant qT := quot_pi (quot_class qT).
Local Notation "\pi" := (pi_phant (Phant qT)).
Definition repr_of := quot_repr (quot_class qT).

Lemma repr_ofK : cancel repr_of \pi.
Proof. by rewrite /pi_phant /repr_of /=; case: qT=> [? []]. Qed.

Definition QuotType_clone (Q : Type) qT cT
  of phant_id (quot_class qT) cT := @QuotTypePack Q cT.

End QuotientDef.

Arguments repr_ofK {T qT}.

(****************************)
(* Protecting some symbols. *)
(****************************)

Module Type PiSig.
Parameter f : forall (T : Type) (qT : quotType T), phant qT -> T -> qT.
Axiom E : f = pi_phant.
End PiSig.

Module Pi : PiSig.
Definition f := pi_phant.
Definition E := erefl f.
End Pi.

Module MPi : PiSig.
Definition f := pi_phant.
Definition E := erefl f.
End MPi.

Module Type ReprSig.
Parameter f : forall (T : Type) (qT : quotType T), qT -> T.
Axiom E : f = repr_of.
End ReprSig.

Module Repr : ReprSig.
Definition f := repr_of.
Definition E := erefl f.
End Repr.

(*******************)
(* Fancy Notations *)
(*******************)

Notation repr := Repr.f.
Notation "\pi_ Q" := (@Pi.f _ _ (Phant Q)) : quotient_scope.
Notation "\pi" := (@Pi.f _ _ (Phant _))  (only parsing) : quotient_scope.
Notation "x == y %[mod Q ]" := (\pi_Q x == \pi_Q y) : quotient_scope.
Notation "x = y %[mod Q ]" := (\pi_Q x = \pi_Q y) : quotient_scope.
Notation "x != y %[mod Q ]" := (\pi_Q x != \pi_Q y) : quotient_scope.
Notation "x <> y %[mod Q ]" := (\pi_Q x <> \pi_Q y) : quotient_scope.

Local Notation "\mpi" := (@MPi.f _ _ (Phant _)).
Canonical mpi_unlock := Unlockable MPi.E.
Canonical pi_unlock := Unlockable Pi.E.
Canonical repr_unlock := Unlockable Repr.E.

Notation quot_class_of := quot_mixin_of.
Notation QuotType Q m := (@QuotTypePack _ Q m).
Notation "[ 'quotType' 'of' Q ]" := (@QuotType_clone _ Q _ _ id)
 (at level 0, format "[ 'quotType'  'of'  Q ]") : form_scope.

Arguments repr {T qT} x.

(************************)
(* Exporting the theory *)
(************************)

Section QuotTypeTheory.

Variable T : Type.
Variable qT : quotType T.

Lemma reprK : cancel repr \pi_qT.
Proof. by move=> x; rewrite !unlock repr_ofK. Qed.

Variant pi_spec (x : T) : T -> Type :=
  PiSpec y of x = y %[mod qT] : pi_spec x y.

Lemma piP (x : T) : pi_spec x (repr (\pi_qT x)).
Proof. by constructor; rewrite reprK. Qed.

Lemma mpiE : \mpi =1 \pi_qT.
Proof. by move=> x; rewrite !unlock. Qed.

Lemma quotW P : (forall y : T, P (\pi_qT y)) -> forall x : qT, P x.
Proof. by move=> Py x; rewrite -[x]reprK; apply: Py. Qed.

Lemma quotP P : (forall y : T, repr (\pi_qT y) = y -> P (\pi_qT y))
  -> forall x : qT, P x.
Proof. by move=> Py x; rewrite -[x]reprK; apply: Py; rewrite reprK. Qed.

End QuotTypeTheory.

Arguments reprK {T qT} x.

(*******************)
(* About morphisms *)
(*******************)

(* This was pi_morph T (x : T) := PiMorph { pi_op : T; _ : x = pi_op }. *)
Structure equal_to T (x : T) := EqualTo {
   equal_val : T;
   _         : x = equal_val
}.
Lemma equal_toE (T : Type) (x : T) (m : equal_to x) : equal_val m = x.
Proof. by case: m. Qed.

Notation piE := (@equal_toE _ _).

Canonical equal_to_pi T (qT : quotType T) (x : T) :=
  @EqualTo _ (\pi_qT x) (\pi x) (erefl _).

Arguments EqualTo {T x equal_val}.

Section Morphism.

Variables T U : Type.
Variable (qT : quotType T).
Variable (qU : quotType U).

Variable (f : T -> T) (g : T -> T -> T) (p : T -> U) (r : T -> T -> U).
Variable (fq : qT -> qT) (gq : qT -> qT -> qT) (pq : qT -> U) (rq : qT -> qT -> U).
Variable (h : T -> U) (hq : qT -> qU).
Hypothesis pi_f : {morph \pi : x / f x >-> fq x}.
Hypothesis pi_g : {morph \pi : x y / g x y >-> gq x y}.
Hypothesis pi_p : {mono \pi : x / p x >-> pq x}.
Hypothesis pi_r : {mono \pi : x y / r x y >-> rq x y}.
Hypothesis pi_h : forall (x : T), \pi_qU (h x) = hq (\pi_qT x).
Variables (a b : T) (x : equal_to (\pi_qT a)) (y : equal_to (\pi_qT b)).

(* Internal Lemmmas : do not use directly *)
Lemma pi_morph1 : \pi (f a) = fq (equal_val x). Proof. by rewrite !piE. Qed.
Lemma pi_morph2 : \pi (g a b) = gq (equal_val x) (equal_val y). Proof. by rewrite !piE. Qed.
Lemma pi_mono1 : p a = pq (equal_val x). Proof. by rewrite !piE. Qed.
Lemma pi_mono2 : r a b = rq (equal_val x) (equal_val y). Proof. by rewrite !piE. Qed.
Lemma pi_morph11 : \pi (h a) = hq (equal_val x). Proof. by rewrite !piE. Qed.

End Morphism.

Arguments pi_morph1 {T qT f fq}.
Arguments pi_morph2 {T qT g gq}.
Arguments pi_mono1 {T U qT p pq}.
Arguments pi_mono2 {T U qT r rq}.
Arguments pi_morph11 {T U qT qU h hq}.

Notation "{pi_ Q a }" := (equal_to (\pi_Q a)) : quotient_scope.
Notation "{pi a }" := (equal_to (\pi a)) : quotient_scope.

(* Declaration of morphisms *)
Notation PiMorph pi_x := (EqualTo pi_x).
Notation PiMorph1 pi_f :=
  (fun a (x : {pi a}) => EqualTo (pi_morph1 pi_f a x)).
Notation PiMorph2 pi_g :=
  (fun a b (x : {pi a}) (y : {pi b}) => EqualTo (pi_morph2 pi_g a b x y)).
Notation PiMono1 pi_p :=
  (fun a (x : {pi a}) => EqualTo (pi_mono1 pi_p a x)).
Notation PiMono2 pi_r :=
  (fun a b (x : {pi a}) (y : {pi b}) => EqualTo (pi_mono2 pi_r a b x y)).
Notation PiMorph11 pi_f :=
  (fun a (x : {pi a}) => EqualTo (pi_morph11 pi_f a x)).

(* lifiting helpers *)
Notation lift_op1 Q f := (locked (fun x : Q => \pi_Q (f (repr x)) : Q)).
Notation lift_op2 Q g :=
  (locked (fun x y : Q => \pi_Q (g (repr x) (repr y)) : Q)).
Notation lift_fun1 Q f := (locked (fun x : Q => f (repr x))).
Notation lift_fun2 Q g := (locked (fun x y : Q => g (repr x) (repr y))).
Notation lift_op11 Q Q' f := (locked (fun x : Q => \pi_Q' (f (repr x)) : Q')).

(* constant declaration *)
Notation lift_cst Q x := (locked (\pi_Q x : Q)).
Notation PiConst a := (@EqualTo _ _ a (lock _)).

(* embedding declaration, please don't redefine \pi *)
Notation lift_embed qT e := (locked (fun x => \pi_qT (e x) : qT)).

Lemma eq_lock T T' e : e =1 (@locked (T -> T') (fun x : T => e x)).
Proof. by rewrite -lock. Qed.
Prenex Implicits eq_lock.

Notation PiEmbed e :=
  (fun x => @EqualTo _ _ (e x) (eq_lock (fun _ => \pi _) _)).

(********************)
(* About eqQuotType *)
(********************)

Section EqQuotTypeStructure.

Variable T : Type.
Variable eq_quot_op : rel T.

Definition eq_quot_mixin_of (Q : Type) (qc : quot_class_of T Q)
  (ec : Equality.class_of Q) :=
  {mono \pi_(QuotTypePack qc) : x y /
   eq_quot_op x y >-> @eq_op (Equality.Pack ec) x y}.

Record eq_quot_class_of (Q : Type) : Type := EqQuotClass {
  eq_quot_quot_class :> quot_class_of T Q;
  eq_quot_eq_mixin :> Equality.class_of Q;
  pi_eq_quot_mixin :> eq_quot_mixin_of eq_quot_quot_class eq_quot_eq_mixin
}.

Record eqQuotType : Type := EqQuotTypePack {
  eq_quot_sort :> Type;
  _ : eq_quot_class_of eq_quot_sort;

}.

Implicit Type eqT : eqQuotType.

Definition eq_quot_class eqT : eq_quot_class_of eqT :=
  let: EqQuotTypePack _ cT as qT' := eqT return eq_quot_class_of qT' in cT.

Canonical eqQuotType_eqType eqT := EqType eqT (eq_quot_class eqT).
Canonical eqQuotType_quotType eqT := QuotType eqT (eq_quot_class eqT).

Coercion eqQuotType_eqType : eqQuotType >-> eqType.
Coercion eqQuotType_quotType : eqQuotType >-> quotType.

Definition EqQuotType_pack Q :=
  fun (qT : quotType T) (eT : eqType) qc ec
  of phant_id (quot_class qT) qc & phant_id (Equality.class eT) ec =>
    fun m => EqQuotTypePack (@EqQuotClass Q qc ec m).

Definition EqQuotType_clone (Q : Type) eqT cT
  of phant_id (eq_quot_class eqT) cT := @EqQuotTypePack Q cT.

Lemma pi_eq_quot eqT : {mono \pi_eqT : x y / eq_quot_op x y >-> x == y}.
Proof. by case: eqT => [] ? []. Qed.

Canonical pi_eq_quot_mono eqT := PiMono2 (pi_eq_quot eqT).

End EqQuotTypeStructure.

Notation EqQuotType e Q m := (@EqQuotType_pack _ e Q _ _ _ _ id id m).
Notation "[ 'eqQuotType' e 'of' Q ]" := (@EqQuotType_clone _ e Q _ _ id)
 (at level 0, format "[ 'eqQuotType'  e  'of'  Q ]") : form_scope.

(**************************************************************************)
(* Even if a quotType is a natural subType, we do not make this subType   *)
(* canonical, to allow the user to define the subtyping he wants. However *)
(* one can:                                                               *)
(* - get the eqMixin and the choiceMixin by subtyping                     *)
(* - get the subType structure and maybe declare it Canonical.            *)
(**************************************************************************)

Module QuotSubType.
Section SubTypeMixin.

Variable T : eqType.
Variable qT : quotType T.

Definition Sub x (px : repr (\pi_qT x) == x) := \pi_qT x.

Lemma qreprK x Px : repr (@Sub x Px) = x.
Proof. by rewrite /Sub (eqP Px). Qed.

Lemma sortPx (x : qT) : repr (\pi_qT (repr x)) == repr x.
Proof. by rewrite !reprK eqxx. Qed.

Lemma sort_Sub (x : qT) : x = Sub (sortPx x).
Proof. by rewrite /Sub reprK. Qed.

Lemma reprP K (PK : forall x Px, K (@Sub x Px)) u : K u.
Proof. by rewrite (sort_Sub u); apply: PK. Qed.

Canonical subType  := SubType _ _ _ reprP qreprK.
Definition eqMixin := Eval hnf in [eqMixin of qT by <:].

Canonical eqType := EqType qT eqMixin.

End SubTypeMixin.

Definition choiceMixin (T : choiceType) (qT : quotType T) :=
  Eval hnf in [choiceMixin of qT by <:].
Canonical choiceType (T : choiceType) (qT : quotType T) :=
  ChoiceType qT (@choiceMixin T qT).

Definition countMixin (T : countType) (qT : quotType T) :=
  Eval hnf in [countMixin of qT by <:].
Canonical countType (T : countType) (qT : quotType T) :=
  CountType qT (@countMixin T qT).

Section finType.
Variables (T : finType) (qT : quotType T).
Canonical subCountType := [subCountType of qT].
Definition finMixin := Eval hnf in [finMixin of qT by <:].
End finType.

End QuotSubType.

Notation "[ 'subType' Q 'of' T 'by' %/ ]" :=
(@SubType T _ Q _ _ (@QuotSubType.reprP _ _) (@QuotSubType.qreprK _ _))
(at level 0, format "[ 'subType'  Q  'of'  T  'by'  %/ ]") : form_scope.

Notation "[ 'eqMixin' 'of' Q 'by' <:%/ ]" :=
  (@QuotSubType.eqMixin _ _: Equality.class_of Q)
  (at level 0, format "[ 'eqMixin'  'of'  Q  'by'  <:%/ ]") : form_scope.

Notation "[ 'choiceMixin' 'of' Q 'by' <:%/ ]" :=
  (@QuotSubType.choiceMixin _ _: Choice.mixin_of Q)
  (at level 0, format "[ 'choiceMixin'  'of'  Q  'by'  <:%/ ]") : form_scope.

Notation "[ 'countMixin' 'of' Q 'by' <:%/ ]" :=
  (@QuotSubType.countMixin _ _: Countable.mixin_of Q)
  (at level 0, format "[ 'countMixin'  'of'  Q  'by'  <:%/ ]") : form_scope.

Notation "[ 'finMixin' 'of' Q 'by' <:%/ ]" :=
  (@QuotSubType.finMixin _ _: Finite.mixin_of Q)
  (at level 0, format "[ 'finMixin'  'of'  Q  'by'  <:%/ ]") : form_scope.

(****************************************************)
(* Definition of a (decidable) equivalence relation *)
(****************************************************)

Section EquivRel.

Variable T : Type.

Lemma left_trans (e : rel T) :
  symmetric e -> transitive e -> left_transitive e.
Proof. by move=> s t ? * ?; apply/idP/idP; apply: t; rewrite // s. Qed.

Lemma right_trans (e : rel T) :
  symmetric e -> transitive e -> right_transitive e.
Proof. by move=> s t ? * x; rewrite ![e x _]s; apply: left_trans. Qed.

Variant equiv_class_of (equiv : rel T) :=
  EquivClass of reflexive equiv & symmetric equiv & transitive equiv.

Record equiv_rel := EquivRelPack {
  equiv :> rel T;
  _ : equiv_class_of equiv
}.

Variable e : equiv_rel.

Definition equiv_class :=
  let: EquivRelPack _ ce as e' := e return equiv_class_of e' in ce.

Definition equiv_pack (r : rel T) ce of phant_id ce equiv_class :=
  @EquivRelPack r ce.

Lemma equiv_refl x : e x x. Proof. by case: e => [] ? []. Qed.
Lemma equiv_sym : symmetric e. Proof. by case: e => [] ? []. Qed.
Lemma equiv_trans : transitive e. Proof. by case: e => [] ? []. Qed.

Lemma eq_op_trans (T' : eqType) : transitive (@eq_op T').
Proof. by move=> x y z; move/eqP->; move/eqP->. Qed.

Lemma equiv_ltrans: left_transitive e.
Proof. by apply: left_trans; [apply: equiv_sym|apply: equiv_trans]. Qed.

Lemma equiv_rtrans: right_transitive e.
Proof. by apply: right_trans; [apply: equiv_sym|apply: equiv_trans]. Qed.

End EquivRel.

Hint Resolve equiv_refl : core.

Notation EquivRel r er es et := (@EquivRelPack _ r (EquivClass er es et)).
Notation "[ 'equiv_rel' 'of' e ]" := (@equiv_pack _ _ e _ id)
 (at level 0, format "[ 'equiv_rel'  'of'  e ]") : form_scope.

(**************************************************)
(* Encoding to another type modulo an equivalence *)
(**************************************************)

Section EncodingModuloRel.

Variables (D E : Type) (ED : E -> D) (DE : D -> E) (e : rel D).

Variant encModRel_class_of (r : rel D) :=
  EncModRelClassPack of (forall x, r x x -> r (ED (DE x)) x) & (r =2 e).

Record encModRel := EncModRelPack {
  enc_mod_rel :> rel D;
  _ : encModRel_class_of enc_mod_rel
}.

Variable r : encModRel.

Definition encModRelClass :=
  let: EncModRelPack _ c as r' := r return encModRel_class_of r' in c.

Definition encModRelP (x : D) : r x x -> r (ED (DE x)) x.
Proof. by case: r => [] ? [] /= he _ /he. Qed.

Definition encModRelE : r =2 e. Proof. by case: r => [] ? []. Qed.

Definition encoded_equiv : rel E := [rel x y | r (ED x) (ED y)].

End EncodingModuloRel.

Notation EncModRelClass m :=
  (EncModRelClassPack (fun x _ => m x) (fun _ _ => erefl _)).
Notation EncModRel r m := (@EncModRelPack _ _ _ _ _ r (EncModRelClass m)).

Section EncodingModuloEquiv.

Variables (D E : Type) (ED : E -> D) (DE : D -> E) (e : equiv_rel D).
Variable (r : encModRel ED DE e).

Lemma enc_mod_rel_is_equiv : equiv_class_of (enc_mod_rel r).
Proof.
split => [x|x y|y x z]; rewrite !encModRelE //; first by rewrite equiv_sym.
by move=> exy /(equiv_trans exy).
Qed.

Definition enc_mod_rel_equiv_rel := EquivRelPack enc_mod_rel_is_equiv.

Definition encModEquivP (x : D) : r (ED (DE x)) x.
Proof. by rewrite encModRelP ?encModRelE. Qed.

Local Notation e' := (encoded_equiv r).

Lemma encoded_equivE : e' =2 [rel x y | e (ED x) (ED y)].
Proof. by move=> x y; rewrite /encoded_equiv /= encModRelE. Qed.
Local Notation e'E := encoded_equivE.

Lemma encoded_equiv_is_equiv : equiv_class_of e'.
Proof.
split => [x|x y|y x z]; rewrite !e'E //=; first by rewrite equiv_sym.
by move=> exy /(equiv_trans exy).
Qed.

Canonical encoded_equiv_equiv_rel := EquivRelPack encoded_equiv_is_equiv.

Lemma encoded_equivP x : e' (DE (ED x)) x.
Proof. by rewrite /encoded_equiv /= encModEquivP. Qed.

End EncodingModuloEquiv.

(**************************************)
(* Quotient by a equivalence relation *)
(**************************************)

Module EquivQuot.
Section EquivQuot.

Variables (D : Type) (C : choiceType) (CD : C -> D) (DC : D -> C).
Variables (eD : equiv_rel D) (encD : encModRel CD DC eD).
Notation eC := (encoded_equiv encD).

Definition canon x := choose (eC x) (x).

Record equivQuotient := EquivQuotient {
  erepr : C;
  _ : (frel canon) erepr erepr
}.

Definition type_of of (phantom (rel _) encD) := equivQuotient.

Lemma canon_id : forall x, (invariant canon canon) x.
Proof.
move=> x /=; rewrite /canon (@eq_choose _ _ (eC x)).
  by rewrite (@choose_id _ (eC x) _ x) ?chooseP ?equiv_refl.
by move=> y; apply: equiv_ltrans; rewrite equiv_sym /= chooseP.
Qed.

Definition pi := locked (fun x => EquivQuotient (canon_id x)).

Lemma ereprK : cancel erepr pi.
Proof.
unlock pi; case=> x hx; move/eqP:(hx)=> hx'.
exact: (@val_inj _ _ [subType for erepr]).
Qed.

Local Notation encDE := (encModRelE encD).
Local Notation encDP := (encModEquivP encD).
Canonical encD_equiv_rel := EquivRelPack (enc_mod_rel_is_equiv encD).

Lemma pi_CD (x y : C) : reflect (pi x = pi y) (eC x y).
Proof.
apply: (iffP idP) => hxy.
  apply: (can_inj ereprK); unlock pi canon => /=.
  rewrite -(@eq_choose _ (eC x) (eC y)); last first.
    by move=> z; rewrite /eC /=; apply: equiv_ltrans.
  by apply: choose_id; rewrite ?equiv_refl //.
rewrite (equiv_trans (chooseP (equiv_refl _ _))) //=.
move: hxy => /(f_equal erepr) /=; unlock pi canon => /= ->.
by rewrite equiv_sym /= chooseP.
Qed.

Lemma pi_DC (x y : D) :
  reflect (pi (DC x) = pi (DC y)) (eD x y).
Proof.
apply: (iffP idP)=> hxy.
  apply/pi_CD; rewrite /eC /=.
  by rewrite (equiv_ltrans (encDP _)) (equiv_rtrans (encDP _)) /= encDE.
rewrite -encDE -(equiv_ltrans (encDP _)) -(equiv_rtrans (encDP _)) /=.
exact/pi_CD.
Qed.

Lemma equivQTP : cancel (CD \o erepr) (pi \o DC).
Proof.
by move=> x; rewrite /= (pi_CD _ (erepr x) _) ?ereprK /eC /= ?encDP.
Qed.

Local Notation qT := (type_of (Phantom (rel D) encD)).
Definition quotClass := QuotClass equivQTP.
Canonical quotType := QuotType qT quotClass.

Lemma eqmodP x y : reflect (x = y %[mod qT]) (eD x y).
Proof. by apply: (iffP (pi_DC _ _)); rewrite !unlock. Qed.

Fact eqMixin : Equality.mixin_of qT. Proof. exact: CanEqMixin ereprK. Qed.
Canonical eqType := EqType qT eqMixin.
Definition choiceMixin := CanChoiceMixin ereprK.
Canonical choiceType := ChoiceType qT choiceMixin.

Lemma eqmodE x y : x == y %[mod qT] = eD x y.
Proof. exact: sameP eqP (@eqmodP _ _). Qed.

Canonical eqQuotType := EqQuotType eD qT eqmodE.

End EquivQuot.
End EquivQuot.

Canonical EquivQuot.quotType.
Canonical EquivQuot.eqType.
Canonical EquivQuot.choiceType.
Canonical EquivQuot.eqQuotType.

Arguments EquivQuot.ereprK {D C CD DC eD encD}.

Notation "{eq_quot e }" :=
(@EquivQuot.type_of _ _ _ _ _ _ (Phantom (rel _) e)) : quotient_scope.
Notation "x == y %[mod_eq r ]" := (x == y %[mod {eq_quot r}]) : quotient_scope.
Notation "x = y %[mod_eq r ]" := (x = y %[mod {eq_quot r}]) : quotient_scope.
Notation "x != y %[mod_eq r ]" := (x != y %[mod {eq_quot r}]) : quotient_scope.
Notation "x <> y %[mod_eq r ]" := (x <> y %[mod {eq_quot r}]) : quotient_scope.

(***********************************************************)
(* If the type is directly a choiceType, no need to encode *)
(***********************************************************)

Section DefaultEncodingModuloRel.

Variables (D : choiceType) (r : rel D).

Definition defaultEncModRelClass :=
  @EncModRelClassPack D D id id r r (fun _ rxx => rxx) (fun _ _ => erefl _).

Canonical defaultEncModRel := EncModRelPack defaultEncModRelClass.

End DefaultEncodingModuloRel.

(***************************************************)
(* Recovering a potential countable type structure *)
(***************************************************)

Section CountEncodingModuloRel.

Variables (D : Type) (C : countType) (CD : C -> D) (DC : D -> C).
Variables (eD : equiv_rel D) (encD : encModRel CD DC eD).
Notation eC := (encoded_equiv encD).

Fact eq_quot_countMixin : Countable.mixin_of {eq_quot encD}.
Proof. exact: CanCountMixin EquivQuot.ereprK. Qed.
Canonical eq_quot_countType := CountType {eq_quot encD} eq_quot_countMixin.

End CountEncodingModuloRel.

Section EquivQuotTheory.

Variables (T : choiceType) (e : equiv_rel T) (Q : eqQuotType e).

Lemma eqmodE x y : x == y %[mod_eq e] = e x y.
Proof. by rewrite pi_eq_quot. Qed.

Lemma eqmodP x y : reflect (x = y %[mod_eq e]) (e x y).
Proof. by rewrite -eqmodE; apply/eqP. Qed.

End EquivQuotTheory.

Prenex Implicits eqmodE eqmodP.

Section EqQuotTheory.

Variables (T : Type) (e : rel T) (Q : eqQuotType e).

Lemma eqquotE x y : x == y %[mod Q] = e x y.
Proof. by rewrite pi_eq_quot. Qed.

Lemma eqquotP x y : reflect (x = y %[mod Q]) (e x y).
Proof. by rewrite -eqquotE; apply/eqP. Qed.

End EqQuotTheory.

Prenex Implicits eqquotE eqquotP.


Require Import List.

(* Filter *)

Section Filter.
  Variable X : Type.
  Implicit Types (x y: X) (A B C: list X) (p q: X -> bool).

  Local Notation "x 'el' L" := (In x L) (at level 50).

  Lemma in_filter_iff x p A :
    x el filter p A <-> x el A /\ p x = true.
  Proof.
    induction A as [|y A]; cbn.
    - tauto.
    - destruct (p y) eqn:E; cbn;
      rewrite IHA; intuition; subst; auto. congruence.
  Qed.

  Local Notation "A '<<=' B" := (incl A B) (at level 50).

  Lemma filter_incl p A :
    filter p A <<= A.
  Proof.
    intros x D. apply in_filter_iff in D. apply D.
  Qed.

  Lemma filter_mono p A B :
    A <<= B -> filter p A <<= filter p B.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_id p A :
    (forall x, x el A -> p x = true) -> filter p A = A.
  Proof.
    intros D.
    induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:E.
      + f_equal. eapply IHA. intros y H. apply D. cbn. eauto.
      + exfalso. rewrite D in E. congruence. cbn. eauto.
  Qed.

  Lemma filter_app p A B :
    filter p (A ++ B) = filter p A ++ filter p B.
  Proof.
    induction A as [|y A]; cbn.
    - reflexivity.
    - rewrite IHA. destruct (p y); reflexivity.
  Qed.

  Lemma filter_fst p x A :
    p x = true -> filter p (x::A) = x::filter p A.
  Proof.
    cbn. destruct (p x); auto. congruence.
  Qed.

  Lemma filter_fst' p x A :
    p x = false -> filter p (x::A) = filter p A.
  Proof.
    cbn. destruct (p x); auto; congruence.
  Qed.

  Lemma filter_pq_mono p q A :
    (forall x, x el A -> p x = true -> q x = true) -> filter p A <<= filter q A.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_pq_eq p q A :
    (forall x, x el A -> p x = q x) -> filter p A = filter q A.
  Proof.
    intros C; induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:D, (q x) eqn:E.
      + f_equal. eapply IHA. intros. eapply C. cbn. eauto.
      + exfalso. enough (p x = q x) by congruence. firstorder.
      + exfalso. enough (p x = q x) by congruence. firstorder.
      + firstorder.
  Qed.

  Lemma filter_and p q A :
    filter p (filter q A) = filter (fun x => andb (p x) (q x)) A.
  Proof.
    induction A as [|x A]; cbn. reflexivity.
    destruct (p x) eqn:E, (q x); cbn;
      try rewrite E; now rewrite IHA.
  Qed.

  Lemma filter_comm p q A :
    filter p (filter q A) = filter q (filter p A).
  Proof.
    rewrite !filter_and. apply filter_pq_eq.
    intros x _. now destruct (p x), (q x).
  Qed.

End Filter.


Set Universe Polymorphism.

(*
We show how to prove the induction principle of parametrized lists
from the induction principle for indexed lists.
*)

(*
When trying to prove the parametric induction principle for list T,
given P : list T -> Type you can take as your predicate
P' : forall T', list T' -> Type such that P T' l := forall e : T = T', (transp P e) l.
This way you always have an equality between T (which you know things about)
and an arbitrary T' which you can use to specialize.
*)

Inductive list_param@{i j | i <= j} (T : Type@{i}) : Type@{j} :=
  | nilp : list_param T
  | consp : T -> list_param T -> list_param T.
Check list_param_rect.
(*
list_param_rect
     : forall (T : Type) (P : list_param T -> Type),
       P (nilp T) ->
       (forall (t : T) (l : list_param T), P l -> P (consp T t l)) ->
       forall l : list_param T, P l
*)

Inductive list_index@{i j | i < j} : Type@{i} -> Type@{j} :=
  | nili : forall (A : Type@{i}), list_index A
  | consi : forall (A : Type@{i}), A -> list_index A -> list_index A
  .
Check list_index_rect.
(*
list_index_rect
     : forall P : forall T : Type, list_index T -> Type,
       (forall A : Type, P A (nili A)) ->
       (forall (A : Type) (a : A) (l : list_index A), P A l -> P A (consi A a l)) ->
       forall (T : Type) (l : list_index T), P T l
*)

Definition list_param_rect_from_index_rect (T : Type) (P : list_index T -> Type)
  (step_nil : P (nili T))
  (step_cons : forall (t : T) (l : list_index T), P l -> P (consi T t l))
  (l : list_index T)
  : P l
  := let P' T' (l : list_index T') : Type
      := forall e : T = T',
         (eq_rect T (fun T => list_index T -> Type) P T' e) l
     in
     list_index_rect P'
     (* nil case *)
     (fun A e =>
      match e in _ = A
      return
        (eq_rect T (fun T => list_index T -> Type) P A e) (nili A)
      with eq_refl => step_nil
      end)
     (* cons case *)
     (fun A a l IH e =>
      match e in _ = A
      return
        forall a l, P' A l ->
        (eq_rect T (fun T => list_index T -> Type) P A e) (consi A a l)
      with eq_refl => fun a l IH => step_cons a l (IH eq_refl)
      end a l IH)
     T
     l
     eq_refl.


From sflib Require Import sflib.

Lemma Forall2_refl
      A (f: A -> A -> Prop) (a: list A)
      (REFL: forall x, f x x):
  List.Forall2 f a a.
Proof.
  induction a; eauto.
Qed.

Lemma Forall2_symm
      A (f: A -> A -> Prop) (a b: list A)
      (SYMM: forall x y, f x y -> f y x)
      (FORALL: List.Forall2 f a b):
  List.Forall2 f b a.
Proof.
  induction FORALL; eauto.
Qed.

Lemma Forall2_trans
      A (f: A -> A -> Prop) (a b c: list A)
      (TRANS: forall x y z, f x y -> f y z -> f x z)
      (FORALL1: List.Forall2 f a b)
      (FORALL2: List.Forall2 f b c):
  List.Forall2 f a c.
Proof.
  revert c FORALL2.
  induction FORALL1; eauto. i.
  inv FORALL2. econs; eauto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(** Properties of decidable propositions *)

Definition decidable (P:Prop) := P \/ ~ P.

Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P.
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_True : decidable True.
Proof.
unfold decidable; auto.
Qed.

Theorem dec_False : decidable False.
Proof.
unfold decidable, not; auto.
Qed.

Theorem dec_or :
 forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_and :
 forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_imp :
 forall A B:Prop, decidable A -> decidable B -> decidable (A -> B).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_iff :
 forall A B:Prop, decidable A -> decidable B -> decidable (A<->B).
Proof.
unfold decidable; tauto.
Qed.

Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P.
Proof.
unfold decidable; tauto.
Qed.

Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B.
Proof.
tauto.
Qed.

Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B.
Proof.
unfold decidable; tauto.
Qed.

Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B.
Proof.
unfold decidable; tauto.
Qed.

Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B.
Proof.
unfold decidable; tauto.
Qed.

Theorem not_iff :
  forall A B:Prop, decidable A -> decidable B ->
    ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B).
Proof.
unfold decidable; tauto.
Qed.

(** Results formulated with iff, used in FSetDecide.
    Negation are expanded since it is unclear whether setoid rewrite
    will always perform conversion. *)

(** We begin with lemmas that, when read from left to right,
    can be understood as ways to eliminate uses of [not]. *)

Theorem not_true_iff : (True -> False) <-> False.
Proof.
tauto.
Qed.

Theorem not_false_iff : (False -> False) <-> True.
Proof.
tauto.
Qed.

Theorem not_not_iff : forall A:Prop, decidable A ->
  (((A -> False) -> False) <-> A).
Proof.
unfold decidable; tauto.
Qed.

Theorem contrapositive : forall A B:Prop, decidable A ->
  (((A -> False) -> (B -> False)) <-> (B -> A)).
Proof.
unfold decidable; tauto.
Qed.

Lemma or_not_l_iff_1 : forall A B: Prop, decidable A ->
  ((A -> False) \/ B <-> (A -> B)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_l_iff_2 : forall A B: Prop, decidable B ->
  ((A -> False) \/ B <-> (A -> B)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_r_iff_1 : forall A B: Prop, decidable A ->
  (A \/ (B -> False) <-> (B -> A)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_r_iff_2 : forall A B: Prop, decidable B ->
  (A \/ (B -> False) <-> (B -> A)).
Proof.
unfold decidable. tauto.
Qed.

Lemma imp_not_l : forall A B: Prop, decidable A ->
  (((A -> False) -> B) <-> (A \/ B)).
Proof.
unfold decidable. tauto.
Qed.

(** Moving Negations Around:
    We have four lemmas that, when read from left to right,
    describe how to push negations toward the leaves of a
    proposition and, when read from right to left, describe
    how to pull negations toward the top of a proposition. *)

Theorem not_or_iff : forall A B:Prop,
  (A \/ B -> False) <-> (A -> False) /\ (B -> False).
Proof.
tauto.
Qed.

Lemma not_and_iff : forall A B:Prop,
  (A /\ B -> False) <-> (A -> B -> False).
Proof.
tauto.
Qed.

Lemma not_imp_iff : forall A B:Prop, decidable A ->
  (((A -> B) -> False) <-> A /\ (B -> False)).
Proof.
unfold decidable. tauto.
Qed.

Lemma not_imp_rev_iff : forall A B : Prop, decidable A ->
  (((A -> B) -> False) <-> (B -> False) /\ A).
Proof.
unfold decidable. tauto.
Qed.

(** With the following hint database, we can leverage [auto] to check
    decidability of propositions. *)

Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff
 : decidable_prop.

(** [solve_decidable using lib] will solve goals about the
    decidability of a proposition, assisted by an auxiliary
    database of lemmas.  The database is intended to contain
    lemmas stating the decidability of base propositions,
    (e.g., the decidability of equality on a particular
    inductive type). *)

Tactic Notation "solve_decidable" "using" ident(db) :=
  match goal with
   | |- decidable _ =>
     solve [ auto 100 with decidable_prop db ]
  end.

Tactic Notation "solve_decidable" :=
  solve_decidable using core.