(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Matrices.operators.

Module Type TMatrices.

Parameter A : Set.
Parameter Aopp : A -> A.
Parameters (Aplus Amult Aminus : A -> A -> A).
Parameters (A0 : A) (A1 : A).
Parameter A_ring : ring_theory A0 A1 Aplus Amult Aminus Aopp (eq(A:=A)).

Parameter Lmatrix : nat -> nat -> Set.
Parameter
  addmatrix : forall n m : nat, Lmatrix n m -> Lmatrix n m -> Lmatrix n m.
Parameter
  prodmat : forall n m p : nat, Lmatrix m n -> Lmatrix p m -> Lmatrix p n.
Parameter oppmatrix : forall n m : nat, Lmatrix n m -> Lmatrix n m.
Parameter o : forall n m : nat, Lmatrix n m.
Parameter I : forall n : nat, Lmatrix n n.

Axiom
  addmatrix_sym :
    forall (n m : nat) (w w' : Lmatrix n m),
    addmatrix n m w w' = addmatrix n m w' w.

Axiom
  addmatrix_assoc :
    forall (n m : nat) (w w' w'' : Lmatrix n m),
    addmatrix n m (addmatrix n m w w') w'' =
    addmatrix n m w (addmatrix n m w' w'').

Axiom
  addmatrix_oppmatrix :
    forall (n m : nat) (w : Lmatrix n m),
    addmatrix n m w (oppmatrix n m w) = o n m.

Axiom
  addmatrix_zero_l :
    forall (n m : nat) (w : Lmatrix n m), addmatrix n m (o n m) w = w.

Axiom I_mat : forall (m n : nat) (w : Lmatrix n m), prodmat m m n (I m) w = w.
Axiom mat_I : forall (m n : nat) (w : Lmatrix n m), prodmat m n n w (I n) = w.

Axiom
  prodmat_distr_l :
    forall (n m p : nat) (a b : Lmatrix m n) (w : Lmatrix p m),
    prodmat n m p (addmatrix m n a b) w =
    addmatrix p n (prodmat n m p a w) (prodmat n m p b w).

Axiom
  prodmat_distr_r :
    forall (n m p : nat) (a b : Lmatrix p m) (w : Lmatrix m n),
    prodmat n m p w (addmatrix p m a b) =
    addmatrix p n (prodmat n m p w a) (prodmat n m p w b).

Axiom
  prodmat_assoc :
    forall (n m p q : nat) (a : Lmatrix m n) (b : Lmatrix p m)
      (c : Lmatrix q p),
    prodmat n p q (prodmat n m p a b) c = prodmat n m q a (prodmat m p q b c).

End TMatrices.

Module Matrices (C: Carrier) <: TMatrices with Definition A := C.A with
  Definition Aopp := C.Aopp with Definition Aplus := C.Aplus with
  Definition Amult := C.Amult with Definition Aminus := C.Aminus with
  Definition A0 := C.A0 with Definition A1 := C.A1 with
  Definition A_ring := C.A_ring.

Definition A := C.A.
Definition Aopp := C.Aopp.
Definition Aplus := C.Aplus.
Definition Amult := C.Amult.
Definition Aminus := C.Aminus.
Definition A0 := C.A0.
Definition A1 := C.A1.
Definition A_ring := C.A_ring.

Module MyVectors := Vectors C.
Import MyVectors.
Import C.

(* definitions *)
Definition Lmatrix (n m : nat) := vect (vect A n) m.
(* defined by rows : (Lmatrix A n m) have m rows and n columns
   the aim is to show the ring structure of n,n matrix *)

Definition eq_add_S_tr (n m : nat) (H : S n = S m) : n = m := f_equal pred H.

Fixpoint addmatrix (n m : nat) (v : Lmatrix n m) {struct v} :
 Lmatrix n m -> Lmatrix n m :=
  match v in (vect _ k) return (Lmatrix n k -> Lmatrix n k) with
  | vnil _ => fun v' => vnil (vect A n)
  | vcons _ m1 x1 v1 =>
      fun v' : Lmatrix n (S m1) =>
      match v' in (vect _ k) return (k = S m1 -> Lmatrix n k) with
      | vnil _ => fun h => vnil (vect A n)
      | vcons _ m2 x2 v2 =>
          fun h =>
          vcons (vect A n) m2 (addvect n x1 x2)
            (addmatrix n m2
               (eq_rec m1 (fun m : nat => Lmatrix n m) v1 m2
                  (eq_add_S_tr m1 m2 (sym_eq h))) v2)
      end (refl_equal (S m1))
  end.

Definition getline (n m : nat) (v : Lmatrix n m) (i : nat)
  (h : 0 < i) (h' : i <= m) : vect A n := nth (vect A n) i m v h h'.

Lemma getline_lemma :
 forall (m : nat) (w : Lmatrix 0 m) (i : nat) (H1 : 0 < i) (H2 : i <= m),
 getline 0 m w i H1 H2 = vnil A.
intros m w i H1 H2.
rewrite (uniq A (getline 0 m w i H1 H2)); trivial.
Qed.

Definition getcolumn (n m : nat) (v : Lmatrix n m)
  (i : nat) (h : 0 < i) (h' : i <= n) : vect A m :=
  map (vect A n) A (fun w : vect A n => nth A i n w h h') m v.

Lemma access_sym :
 forall (n m : nat) (w : Lmatrix n m) (i j : nat) (Hj1 : 0 < j)
   (Hj2 : j <= n) (Hi1 : 0 < i) (Hi2 : i <= m),
 nth A i m (getcolumn n m w j Hj1 Hj2) Hi1 Hi2 =
 nth A j n (getline n m w i Hi1 Hi2) Hj1 Hj2.
intros n m.
unfold getline, getcolumn in |- *.
intros w; elim w.
simpl in |- *.
intros i; elim i using two_step_ind.
intros j Hj1 Hj2 Hi1; inversion Hi1.
simpl in |- *.
intros j; elim j using two_step_ind.
intros Hj1; inversion Hj1.
intros Hj1 Hj2 Hi1 Hi2; inversion Hi2.
intros n0 Hj1 Hj2 Hi1 Hi2 Hi3; inversion Hi3.
intros i' HR j; elim j using two_step_ind.
intros Hj1; inversion Hj1.
intros Hh1 Hj2 Hi1 Hi2; inversion Hi2.
intros n0 Hj1 Hj2 Hi1 Hi2 Hi3; inversion Hi3.
intros n' a w' HR.
simpl in |- *.
intros i; elim i using two_step_ind.
intros j Hj1 Hj2 Hi1; inversion Hi1.
simpl in |- *; trivial.
intros i' HR' j Hj1 Hj2 Hi1 Hi2.
cut (0 < S i').
intros Hcut.
rewrite
 (nth_lemma A i' n' (nth A j n a Hj1 Hj2)
    (map (vect A n) A (fun w0 : vect A n => nth A j n w0 Hj1 Hj2) n' w') Hi1
    Hi2 Hcut).
rewrite (HR (S i')).
rewrite (nth_lemma (vect A n) i' n' a w' Hi1 Hi2 Hcut).
trivial.
omega.
Qed.

Lemma o1 : forall (m d : nat) (Hle : S d <= m), 0 < S m - S d.
exact last_o1.
Defined.

Lemma o2 : forall m d : nat, S m - S d <= m.
exact last_o2.
Defined.

Lemma o3 : forall d : nat, 0 <= d.
exact last_o3.
Defined.

Lemma o4 : forall (m d : nat) (Hle : S d <= m), d <= m.
exact (fun m d H => last_o4 d m H).
Defined.

Definition prodvectmatrix :
  forall (n m : nat) (v : vect A n) (w : Lmatrix m n) (c : nat),
  0 <= c -> c <= m -> vect A c.
intros n m v w.
fix 1.
intros c; case c.
intros H H'; apply vnil.
intros d Hlt Hle.
apply vcons.
apply (scalprod n v).
eapply (getcolumn m n w) with (i := S m - S d).
apply o1; assumption.
apply o2; assumption.
apply prodvectmatrix.
apply o3; assumption.
apply o4; assumption.
Defined.

Definition prodvectmat :
  forall (n m : nat) (v : vect A n) (w : Lmatrix m n), vect A m.
intros n m v w.
apply (prodvectmatrix n m v w m).
apply le_O_n.
apply le_n.
Defined.

Fixpoint prodmat (n m p : nat) (w1 : Lmatrix m n) {struct w1} :
 Lmatrix p m -> Lmatrix p n :=
  fun w2 : Lmatrix p m =>
  match w1 in (vect _ a) return (Lmatrix p a) with
  | vnil _ => vnil (vect A p)
  | vcons _ n' r1 rs =>
      vcons (vect A p) n' (prodvectmat m p r1 w2) (prodmat n' m p rs w2)
  end.

Fixpoint oppmatrix (n m : nat) (w : Lmatrix n m) {struct w} :
 Lmatrix n m :=
  match w as _ in (vect _ w) return (Lmatrix n w) with
  | vnil _ => vnil (vect A n)
  | vcons _ p v vs => vcons (vect A n) p (oppvect n v) (oppmatrix n p vs)
  end.

Fixpoint mkzero (n m : nat) {struct m} : Lmatrix n m :=
  match m as w return (Lmatrix n w) with
  | O => vnil (vect A n)
  | S p => vcons (vect A n) p (mkvect A0 n) (mkzero n p)
  end.

Definition o (n m : nat) : Lmatrix n m := mkzero n m.

Lemma o1' : forall m0 n : nat, 0 <= n - m0.
intros; omega.
Qed.

Lemma o2' : forall m0 n : nat, n - m0 <= n.
intros; apply last_o2; trivial.
Defined.

Lemma o3' : forall m0 n : nat, S m0 <= n -> m0 <= n.
exact last_o4.
Defined.

Definition I' : forall n m : nat, m <= n -> Lmatrix n m.
intros n; fix 1.
intros m; case m.
intros; apply (vnil (vect A n)).
intros m0 Hm0; unfold Lmatrix in |- *; apply (vcons (vect A n)).
apply mkrowI with (i := n - m0).
apply le_O_n.
apply o2'; assumption.
apply I'.
apply o3'; assumption.
Defined.

Definition I : forall n : nat, Lmatrix n n.
intros n; apply I'.
apply le_n.
Defined.

Lemma addmatrix_sym :
 forall (n m : nat) (w w' : Lmatrix n m),
 addmatrix n m w w' = addmatrix n m w' w.
intros n m w w'.
eapply
 (induc2 (vect A n)
    (fun (m : nat) (w w' : Lmatrix n m) =>
     addmatrix n m w w' = addmatrix n m w' w)).
simpl in |- *; trivial.
intros n0 w0 w0' HR w1 w1'.
simpl in |- *.
rewrite HR.
rewrite addvect_sym.
trivial.
Qed.

Lemma addmatrix_assoc :
 forall (n m : nat) (w w' w'' : Lmatrix n m),
 addmatrix n m (addmatrix n m w w') w'' =
 addmatrix n m w (addmatrix n m w' w'').
intros n m w w' w''.
eapply
 (induc3 (vect A n)
    (fun (m : nat) (w w' w'' : Lmatrix n m) =>
     addmatrix n m (addmatrix n m w w') w'' =
     addmatrix n m w (addmatrix n m w' w''))).
simpl in |- *; trivial.
intros n0 v v' v'' HR a b c; simpl in |- *.
rewrite HR.
rewrite addvect_assoc.
trivial.
Qed.

Lemma addmatrix_oppmatrix :
 forall (n m : nat) (w : Lmatrix n m),
 addmatrix n m w (oppmatrix n m w) = o n m.
intros n m w.
eapply
 (induc1 (vect A n)
    (fun (m : nat) (w : Lmatrix n m) =>
     addmatrix n m w (oppmatrix n m w) = o n m)).
simpl in |- *; trivial.
intros n0 v HR a.
simpl in |- *.
rewrite HR.
rewrite addvect_oppvect.
trivial.
Qed.

Lemma addmatrix_zero_l :
 forall (n m : nat) (w : Lmatrix n m), addmatrix n m (o n m) w = w.
intros n m w.
eapply
 (induc1 (vect A n)
    (fun (m : nat) (w : Lmatrix n m) => addmatrix n m (o n m) w = w))
 .
simpl in |- *; trivial.
intros n0 v0 HR a; simpl in |- *.
rewrite HR.
rewrite addvect_zero_l.
trivial.
Qed.

Lemma mkvectA0_prodvectmatrix :
 forall (n m c : nat) (w : Lmatrix m n) (H1 : 0 <= c) (H2 : c <= m),
 prodvectmatrix n m (mkvect A0 n) w c H1 H2 = mkvect A0 c.
intros n m c; generalize n m; clear n m; elim c.
simpl in |- *; trivial.
intros c' HR.
unfold mkvect in |- *; simpl in |- *.
intros n m w H1 H2; apply vcons_lemma.
rewrite scalprod_zero_l; trivial.
rewrite HR; trivial.
Qed.

Lemma mkvectA0_prodvectmat :
 forall (n m : nat) (w : Lmatrix m n),
 prodvectmat n m (mkvect A0 n) w = mkvect A0 m.
intros n m w; unfold prodvectmat in |- *; apply mkvectA0_prodvectmatrix.
Qed.

Lemma prodvectmatrix_last :
 forall (n m i : nat) (w : Lmatrix n m) (H1 : 0 < i)
   (H1' : 0 <= i) (H2 : i <= m) (c : nat) (Hc1 : 0 <= c)
   (Hc2 : c <= n),
 prodvectmatrix m n (mkrowI m i H1' H2) w c Hc1 Hc2 =
 last A n (getline n m w i H1 H2) c Hc1 Hc2.
intros n m i w H1 H1' H2 c; elim c.
intros Hc1 Hc2; simpl in |- *.
trivial.
intros c' HR Hc1' Hc2'.
simpl in |- *.
rewrite HR.
rewrite
 (mkrowI_nth m (getcolumn n m w (n - c') (o1 n c' Hc2') (o2 n c')) i H1' H1
    H2 H2).
rewrite (access_sym n m w i (n - c') (o1 n c' Hc2') (o2 n c') H1 H2).
unfold o1, o2, o3, o4 in |- *; trivial.
Qed.

Lemma mkrowI_prodvectmat :
 forall (n m i : nat) (w : Lmatrix m n) (H1 : 0 <= i)
   (H1' : 0 < i) (H2 : i <= n),
 prodvectmat n m (mkrowI n i H1 H2) w = getline m n w i H1' H2.
intros n m i w H1 H1' H2; try assumption.
rewrite <- (last_n' A m (getline m n w i H1' H2) (le_O_n m) (le_n m)).
unfold prodvectmat in |- *.
apply (prodvectmatrix_last m n i w H1' H1 H2 m (le_O_n m) (le_n m)).
Qed.

Lemma I'_simpl :
 forall (n m0 : nat) (H : S m0 <= n) (H2 : n - m0 <= n),
 I' n (S m0) H =
 vcons (vect A n) m0 (mkrowI n (n - m0) (le_O_n (n - m0)) H2)
   (I' n m0 (o3' m0 n H)).
intros n m0 H H2; try assumption.
simpl in |- *; trivial.
rewrite (proof_irr _ (o2' m0 n) H2).
trivial.
Qed.

Lemma I'_mat :
 forall (m n p : nat) (w : Lmatrix p n) (H1 : 0 <= m) (H2 : m <= n),
 prodmat m n p (I' n m H2) w = last (vect A p) n w m H1 H2.
intros m; elim m.
simpl in |- *; trivial.
intros m' HR n p w H1 H2.
rewrite (I'_simpl n m' H2 (last_o2 n m')).
generalize H1 H2 HR; clear H1 H2 HR; case w.
intros H1 H2 HR; cut False.
intros Hfalse; elim Hfalse.
omega.
intros n0' v' v0' H1 H2 HR.
cbv beta iota delta -[mkrowI scalprod minus nth map prodvectmatrix I' last]
 in |- *.
replace
 (fix prodmat (n0 m0 p0 : nat) (w1 : vect (vect A m0) n0)
              (w2 : vect (vect A p0) m0) {struct w1} :
  vect (vect A p0) n0 :=
    match w1 in (vect _ n1) return (vect (vect A p0) n1) with
    | vnil _ => vnil (vect A p0)
    | vcons _ n' r1 rs =>
        vcons (vect A p0) n'
          (prodvectmatrix m0 p0 r1 w2 p0 (le_O_n p0) (le_n p0))
          (prodmat n' m0 p0 rs w2)
    end) with prodmat; [ idtac | trivial ].
generalize
 (mkrowI_prodvectmat (S n0') p (S n0' - m') (vcons (vect A p) n0' v' v0')
    (le_O_n (S n0' - m')) (last_o1 (S n0') m' H2) (last_o2 (S n0') m')).
unfold prodvectmat in |- *.
intros H; rewrite H; clear H.
simpl in |- *.
apply vcons_lemma.
unfold getline in |- *; simpl in |- *; trivial.
unfold o3' in |- *.
apply
 (HR (S n0') p (vcons (vect A p) n0' v' v0') (last_o3 m')
    (last_o4 m' (S n0') H2)).
Qed.

Lemma I'_mat' :
 forall (n p : nat) (w : Lmatrix p n) (H2 : n <= n),
 prodmat n n p (I' n n H2) w = w.
intros n p w H2; try assumption.
transitivity (last (vect A p) n w n (le_O_n n) H2).
apply I'_mat.
apply (last_n' (vect A p) n w (le_O_n n) H2).
Qed.

Lemma I_mat : forall (m n : nat) (w : Lmatrix n m), prodmat m m n (I m) w = w.
intros m n w; try assumption.
unfold I in |- *.
apply I'_mat'.
Qed.

Lemma getcolumn_In :
 forall (m' i m : nat) (h : m' <= m) (h1 : 0 <= i)
   (h2 : i <= m) (h1'' : 0 <= m') (h2'' : m' <= m)
   (h1' : 0 < i),
 getcolumn m m' (I' m m' h) i h1' h2 =
 last A m (mkrowI m i h1 h2) m' h1'' h2''.
intros m'; elim m'.
unfold getcolumn in |- *; simpl in |- *; trivial.
intros n H i m h h1 h2 h1'' h2'' h1'; try assumption.
unfold getcolumn in |- *; simpl in |- *.
apply vcons_lemma.
rewrite <-
 (mkrowI_nth m (mkrowI m (m - n) (le_O_n (m - n)) (o2' n m)) i h1 h1' h2)
 .
rewrite <-
 (mkrowI_nth m (mkrowI m i h1 h2) (m - n) (le_O_n (m - n))
    (last_o1 m n h2'') (last_o2 m n)).
unfold scalprod in |- *.
rewrite scalprod_sym.
unfold o2' in |- *.
trivial.
unfold getcolumn in H.
apply H.
Qed.

Lemma mat_I_last_aux :
 forall (i m : nat) (v : vect A m) (h1' : 0 <= i) (h2' : i <= m),
 prodvectmatrix m m v (I m) i h1' h2' = last A m v i h1' h2'.
intros i; elim i.
simpl in |- *; trivial.
intros n H m v h1' h2'; try assumption.
simpl in |- *.
apply vcons_lemma.
cut (0 <= m - n); [ intros Hcuta | omega ].
rewrite <- (mkrowI_nth m v (m - n) Hcuta (last_o1 m n h2') (last_o2 m n)).
rewrite scalprod_sym.
unfold scalprod in |- *.
cut
 (getcolumn m m (I m) (m - n) (o1 m n h2') (o2 m n) =
  mkrowI m (m - n) Hcuta (last_o2 m n)).
intros Hrew'; rewrite Hrew'; trivial.
replace (mkrowI m (m - n) Hcuta (last_o2 m n)) with
 (last A m (mkrowI m (m - n) Hcuta (last_o2 m n)) m (le_O_n m) (le_n m)).
unfold I in |- *; apply getcolumn_In.
apply last_n'.
unfold o3, o4 in |- *; apply H.
Qed.

Lemma mat_I_last :
 forall (i n m : nat) (a : Lmatrix m n) (h1 : 0 <= i) (h2 : i <= n),
 prodmat _ _ _ (last (vect A m) n a i h1 h2) (I m) =
 last (vect A m) n a i h1 h2.
intros i; elim i.
simpl in |- *; trivial.
intros n H n0 m a h1 h2; try assumption.
simpl in |- *.
apply (vcons_lemma (vect A m) n).
unfold prodvectmat in |- *.
pattern (nth (vect A m) (n0 - n) n0 a (last_o1 n0 n h2) (last_o2 n0 n)) at 2
 in |- *;
 replace (nth (vect A m) (n0 - n) n0 a (last_o1 n0 n h2) (last_o2 n0 n)) with
  (last A m (nth (vect A m) (n0 - n) n0 a (last_o1 n0 n h2) (last_o2 n0 n)) m
     (le_O_n m) (le_n m)).
apply mat_I_last_aux.
apply last_n'.
apply (H n0 m a (last_o3 n) (last_o4 n n0 h2)).
Qed.

Lemma mat_I : forall (m n : nat) (w : Lmatrix n m), prodmat m n n w (I n) = w.
intros m n w; try assumption.
replace w with (last (vect A n) m w m (le_O_n m) (le_n m)).
apply mat_I_last.
apply last_n'.
Qed.

Lemma prodvectmatrix_distr_l :
 forall (n m : nat) (a b : vect A n) (w : Lmatrix m n)
   (c : nat) (H1 : 0 <= c) (H2 : c <= m),
 prodvectmatrix n m (addvect n a b) w c H1 H2 =
 addvect c (prodvectmatrix n m a w c H1 H2) (prodvectmatrix n m b w c H1 H2).
intros n m a b w c; elim c.
intros H1 H2; simpl in |- *; trivial.
intros n0 HR H1 H2; try assumption.
simpl in |- *.
apply vcons_lemma.
unfold scalprod in |- *.
rewrite scalprod_distr_l.
trivial.
rewrite HR.
trivial.
Qed.

Lemma prodvectmat_distr_l :
 forall (n m : nat) (a b : vect A n) (w : Lmatrix m n),
 prodvectmat n m (addvect n a b) w =
 addvect m (prodvectmat n m a w) (prodvectmat n m b w).
intros n m a b w; try assumption.
unfold prodvectmat in |- *.
apply prodvectmatrix_distr_l.
Qed.

Lemma prodmat_distr_l :
 forall (n m p : nat) (a b : Lmatrix m n) (w : Lmatrix p m),
 prodmat n m p (addmatrix m n a b) w =
 addmatrix p n (prodmat n m p a w) (prodmat n m p b w).
intros n m p a b w.
eapply
 (induc2 (vect A m)
    (fun (n0 : nat) (a0 b0 : Lmatrix m n0) =>
     prodmat n0 m p (addmatrix m n0 a0 b0) w =
     addmatrix p n0 (prodmat n0 m p a0 w) (prodmat n0 m p b0 w)))
 .
simpl in |- *; trivial.
intros n0 v v' HR a0 b0; try assumption.
simpl in |- *.
apply (vcons_lemma (vect A p) n0).
apply prodvectmat_distr_l.
rewrite HR.
trivial.
Qed.

Lemma getcolumn_addvect :
 forall (i p m : nat) (a b : Lmatrix p m) (h1 : 0 < i) (h2 : i <= p),
 getcolumn p m (addmatrix p m a b) i h1 h2 =
 addvect m (getcolumn p m a i h1 h2) (getcolumn p m b i h1 h2).
intros i p m a b; try assumption.
eapply
 (induc2 (vect A p)
    (fun (m : nat) (a b : Lmatrix p m) =>
     forall (h1 : 0 < i) (h2 : i <= p),
     getcolumn p m (addmatrix p m a b) i h1 h2 =
     addvect m (getcolumn p m a i h1 h2) (getcolumn p m b i h1 h2)))
 .
unfold getcolumn in |- *; simpl in |- *; trivial.
intros n v v' H a0 b0 h1 h2; try assumption.
unfold getcolumn in |- *; simpl in |- *.
apply vcons_lemma.
apply nth_addvect.
unfold getcolumn in H.
apply H.
Qed.

Lemma prodvectmatrix_distr_r :
 forall (i m p : nat) (a0 : vect A m) (a b : Lmatrix p m)
   (h1 : 0 <= i) (h2 : i <= p),
 prodvectmatrix m p a0 (addmatrix p m a b) i h1 h2 =
 addvect i (prodvectmatrix m p a0 a i h1 h2)
   (prodvectmatrix m p a0 b i h1 h2).
intros i; elim i.
simpl in |- *; trivial.
intros n H m p a0 a b h1 h2; try assumption.
simpl in |- *.
apply vcons_lemma.
unfold scalprod in |- *.
rewrite <- scalprod_distr_r.
apply scalprod_reg.
trivial.
apply getcolumn_addvect.
apply H.
Qed.

Lemma prodmat_distr_r :
 forall (n m p : nat) (a b : Lmatrix p m) (w : Lmatrix m n),
 prodmat n m p w (addmatrix p m a b) =
 addmatrix p n (prodmat n m p w a) (prodmat n m p w b).
intros n m p a b w; try assumption.
eapply
 (induc1 (vect A m)
    (fun (n : nat) (w : Lmatrix m n) =>
     prodmat n m p w (addmatrix p m a b) =
     addmatrix p n (prodmat n m p w a) (prodmat n m p w b)))
 .
simpl in |- *; trivial.
intros n0 v H a0; try assumption.
simpl in |- *.
apply (vcons_lemma (vect A p) n0).
unfold prodvectmat in |- *.
apply prodvectmatrix_distr_r.
apply H.
Qed.

(* assoc *)
Lemma prodvectmatrix_vnil :
 forall (p n : nat) (h1 : 0 <= p) (h2 : p <= n),
 prodvectmatrix 0 n (vnil A) (vnil (vect A n)) p h1 h2 = mkvect A0 p.
intros p; elim p.
unfold mkvect in |- *; simpl in |- *; trivial.
intros n H n0 h1 h2; try assumption.
unfold mkvect in |- *; simpl in |- *.
apply vcons_lemma.
trivial.
rewrite H; trivial.
Qed.

Lemma prodvectmatrix_vcons :
 forall (p' m' p : nat) (x : A) (vx : vect A m') (a : vect A p)
   (v : vect (vect A p) m') (Hp'1 : 0 <= p') (Hp'2 : p' <= p),
 prodvectmatrix (S m') p (vcons A m' x vx) (vcons (vect A p) m' a v) p' Hp'1
   Hp'2 =
 addvect p' (multscal x p' (last A p a p' Hp'1 Hp'2))
   (prodvectmatrix m' p vx v p' Hp'1 Hp'2).
intros p'; elim p'.
simpl in |- *; trivial.
intros n HR m' p x vx a v Hp'1 Hp'2; try assumption.
simpl in |- *.
apply vcons_lemma.
unfold o1, o2 in |- *; unfold getcolumn in |- *; trivial.
unfold o2, o4 in |- *; rewrite HR.
trivial.
Qed.

Lemma prodvectmat_vcons :
 forall (m' p : nat) (x : A) (vx : vect A m') (a : vect A p)
   (v : vect (vect A p) m'),
 prodvectmat (S m') p (vcons A m' x vx) (vcons (vect A p) m' a v) =
 addvect p (multscal x p a) (prodvectmat m' p vx v).
intros m' p x vx a v; try assumption.
pattern a at 2 in |- *; replace a with (last A p a p (le_O_n p) (le_n p)).
unfold prodvectmat in |- *.
apply prodvectmatrix_vcons.
apply last_n'.
Qed.

Lemma Aplus_Aplus :
 forall a b c d : A, a = b -> c = d -> Aplus a c = Aplus b d.
intros a b c d h h1; rewrite h; rewrite h1; trivial.
Qed.

Lemma nth_mkvect :
 forall (i : nat) (x : A) (n : nat) (hi1 : 0 < i) (hi2 : i <= n),
 nth A i n (mkvect x n) hi1 hi2 = x.
intros i; elim i.
intros x n hi1; inversion hi1.
intros i' HR x n0 hi1 hi2; try assumption.
simpl in |- *.
case (zerop i').
generalize hi2; clear hi2; case n0.
intros hi2; cut False; [ intros Hf; elim Hf | omega ].
simpl in |- *; trivial.
generalize hi2; case n0.
intros hi3 hi4; cut False; [ intros Hf; elim Hf | omega ].
intros n hi0 l; try assumption.
simpl in |- *.
rewrite HR.
trivial.
Qed.

Lemma scalprod_getcolumn_nth :
 forall (p q i : nat) (a0 : vect A p) (b : Lmatrix q p)
   (h3 : 0 < i) (h4 : i <= q),
 scalprod p a0 (getcolumn q p b i h3 h4) =
 nth A i q (prodvectmat p q a0 b) h3 h4.
intros p q i; try assumption.
intros a0; elim a0.
simpl in |- *.
intros b; rewrite (uniq (vect A q) b).
intros h3 h4; try assumption.
unfold prodvectmat in |- *.
rewrite (prodvectmatrix_vnil q q (le_O_n q) (le_n q)).
rewrite (nth_mkvect i A0 q h3).
trivial.
intros p' a v HR b h3 h4; try assumption.
elim (decompose (vect A q) p' b).
intros v' Hv; elim Hv; intros vs Hvs; rewrite Hvs; clear Hvs.
unfold prodvectmat in |- *.
rewrite (prodvectmatrix_vcons q p' q a v v' vs (le_O_n q) (le_n q)).
simpl in |- *.
unfold prodvectmat in |- *.
rewrite last_n'.
rewrite nth_addvect.
apply Aplus_Aplus.
symmetry  in |- *; apply nth_multscal.
replace (prodvectmatrix p' q v vs q (le_O_n q) (le_n q)) with
 (prodvectmat p' q v vs); [ idtac | trivial ].
unfold getcolumn in HR.
apply (HR vs h3 h4).
Qed.

Lemma prodvectmat_scalprod :
 forall (n : nat) (a b : vect A n),
 prodvectmat n 1 a (map A (vect A 1) (fun x : A => vcons A 0 x (vnil A)) n b) =
 vcons A 0 (scalprod n a b) (vnil A).
intros n a b; try assumption.
unfold prodvectmat in |- *; simpl in |- *.
apply vcons_lemma.
unfold getcolumn in |- *; simpl in |- *.
rewrite
 (map_2' A (vect A 1) n b (fun x : A => vcons A 0 x (vnil A))
    (fun w : vect A 1 => head A 1 w (le_S_lt_O 1 0 (o2 1 0)))
    (fun x : A => refl_equal x)).
trivial.
trivial.
Qed.

Lemma prodvectmat_scalprod' :
 forall (n : nat) (a b : vect A n),
 head A 1
   (prodvectmat n 1 a
      (map A (vect A 1) (fun x : A => vcons A 0 x (vnil A)) n b))
   (le_n 1) = scalprod n a b.
intros n a b; try assumption.
rewrite prodvectmat_scalprod.
simpl in |- *; trivial.
Qed.

Lemma prodmat_getcolumn :
 forall (m p q : nat) (a : Lmatrix p m) (b : Lmatrix q p)
   (i : nat) (h1 : 0 < i) (h2 : i <= q),
 prodmat m p 1 a
   (map A (vect A 1) (fun x : A => vcons A 0 x (vnil A)) p
      (getcolumn q p b i h1 h2)) =
 map A (vect A 1) (fun x : A => vcons A 0 x (vnil A)) m
   (getcolumn q m (prodmat m p q a b) i h1 h2).
intros m p q a; try assumption.
elim a.
simpl in |- *; trivial.
intros n a0 v H b i h1 h2; try assumption.
simpl in |- *.
apply (vcons_lemma (vect A 1) n).
rewrite prodvectmat_scalprod.
apply vcons_lemma.
apply scalprod_getcolumn_nth.
trivial.
rewrite H; trivial.
Qed.

Lemma map_prodmat_getcolumn :
 forall (m p q : nat) (v : vect A m) (a : Lmatrix p m)
   (b : Lmatrix q p) (i : nat) (h1 : 0 < i) (h2 : i <= q),
 scalprod m v
   (map (vect A 1) A (fun x : vect A 1 => head A 1 x (le_n 1)) m
      (prodmat m p 1 a
         (map A (vect A 1) (fun x : A => vcons A 0 x (vnil A)) p
            (getcolumn q p b i h1 h2)))) =
 scalprod m v (getcolumn q m (prodmat m p q a b) i h1 h2).
intros m p q v a b i h1 h2; try assumption.
rewrite prodmat_getcolumn.
rewrite
 (map_2' A (vect A 1) m (getcolumn q m (prodmat m p q a b) i h1 h2)
    (fun x : A => vcons A 0 x (vnil A))
    (fun x : vect A 1 => head A 1 x (le_n 1))).
trivial.
simpl in |- *; trivial.
Qed.

Lemma Amult_scalprod :
 forall (n : nat) (v w : vect A n) (a : A),
 Amult a (scalprod n v w) = scalprod n (multscal a n v) w.
intros n v w a;
 eapply
  (induc2 A
     (fun (n : nat) (v w : vect A n) =>
      Amult a (scalprod n v w) = scalprod n (multscal a n v) w))
  .
simpl in |- *.
ring.
intros n0 v0 v' H a0 b; try assumption.
simpl in |- *.
rewrite <- H.
ring.
Qed.

Lemma prodvectmatrix_map :
 forall (i p : nat) (a0 : A) (b1 : vect A p) (c : Lmatrix 1 p)
   (h1 : 0 <= i) (h2 : i <= 1),
 prodvectmatrix p 1 (multscal a0 p b1) c i h1 h2 =
 multscal a0 i (prodvectmatrix p 1 b1 c i h1 h2).
intros i; elim i.
simpl in |- *; trivial.
intros n H p a0 b1 c h1 h2; try assumption.
simpl in |- *.
apply vcons_lemma.
generalize h1 h2; clear h1 h2; case n.
2: intros n0 h1 h2; inversion h2.
2: inversion H1.
intros h1 h2; try assumption.
unfold getcolumn in |- *; simpl in |- *.
rewrite Amult_scalprod.
trivial.
apply H.
Qed.

Lemma prodvectmat_map :
 forall (p : nat) (a0 : A) (b1 : vect A p) (c : Lmatrix 1 p),
 prodvectmat p 1 (multscal a0 p b1) c = multscal a0 1 (prodvectmat p 1 b1 c).
intros p a0 b1 c; try assumption.
unfold prodvectmat in |- *; apply prodvectmatrix_map.
Qed.

Lemma prodvectmat_assoc_1 :
 forall (m p : nat) (a : vect A m) (b : Lmatrix p m) (c : Lmatrix 1 p),
 prodvectmat p 1 (prodvectmat m p a b) c =
 prodvectmat _ _ a (prodmat _ _ _ b c).
intros m p a; elim a.
intros b; rewrite (uniq (vect A p) b).
intros c; simpl in |- *.
unfold prodvectmat in |- *; rewrite prodvectmatrix_vnil.
unfold prodvectmat in |- *; rewrite mkvectA0_prodvectmatrix.
rewrite (prodvectmatrix_vnil 1 1 (le_O_n 1) (le_n 1)).
trivial.
intros n a0 v H b c; try assumption.
elim (decompose (vect A p) n b).
intros b1 Hb1; elim Hb1; intros bs Hbs; rewrite Hbs; clear Hb1 Hbs.
simpl in |- *.
rewrite prodvectmat_vcons.
rewrite prodvectmat_vcons.
rewrite prodvectmat_distr_l.
rewrite H.
apply addvect_reg.
apply prodvectmat_map.
trivial.
Qed.

Lemma prodvectmatrix_assoc :
 forall (v m p q : nat) (a : vect A m) (b : Lmatrix p m)
   (c : Lmatrix q p) (h1 : 0 <= v) (h2 : v <= q),
 prodvectmatrix p q (prodvectmatrix m p a b p (le_O_n p) (le_n p)) c v h1 h2 =
 prodvectmatrix m q a (prodmat m p q b c) v h1 h2.
intros v; elim v.
intros m p q a b c h1 h2; try assumption.
simpl in |- *; trivial.
intros n HR m p q a b c h1 h2; try assumption.
simpl in |- *.
apply vcons_lemma.
rewrite <- map_prodmat_getcolumn.
rewrite <-
 (prodvectmat_scalprod' m a
    (map (vect A 1) A (fun x : vect A 1 => head A 1 x (le_n 1)) m
       (prodmat m p 1 b
          (map A (vect A 1) (fun x : A => vcons A 0 x (vnil A)) p
             (getcolumn q p c (q - n) (o1 q n h2) (o2 q n))))))
 .
rewrite <- (prodvectmat_scalprod' p (prodvectmat m p a b)).
apply head_lemma_1.
rewrite (map_2' (vect A 1) A).
rewrite prodvectmat_assoc_1.
trivial.
intros x.
elim (decompose _ 0 x).
intros x1 Hx; elim Hx; intros xs Hxs; rewrite Hxs; clear Hx Hxs.
simpl in |- *; rewrite (uniq A xs); trivial.
apply HR.
Qed.

Lemma prodmat_assoc :
 forall (n m p q : nat) (a : Lmatrix m n) (b : Lmatrix p m) (c : Lmatrix q p),
 prodmat n p q (prodmat n m p a b) c = prodmat n m q a (prodmat m p q b c).
intros n m p q a b c; try assumption.
eapply
 (induc1 (vect A m)
    (fun (n0 : nat) (a0 : Lmatrix m n0) =>
     prodmat n0 p q (prodmat n0 m p a0 b) c =
     prodmat n0 m q a0 (prodmat m p q b c))).
simpl in |- *; trivial.
intros n0 v HR a0; try assumption.
simpl in |- *.
apply (vcons_lemma (vect A q) n0).
unfold prodvectmat in |- *; apply prodvectmatrix_assoc.
apply HR.
Qed.

End Matrices.

Module matrixZ := Matrices Zc.

(*
 Local Variables:
 mode: coq
 coq-prog-name: "/usr/local/coq-7.4/bin/coqtop -emacs -q"
 compile-command: "make matrix.vo"
 End:
*)


(************************************************************************)
(*                                                                      *)
(*                Quantitative Hoare Logic for Clight                   *)
(*                                                                      *)
(*  Author: Quentin Carbonneaux (c) 2014              Yale University   *)
(*                                                                      *)
(************************************************************************)

(* Proof of the stack consumption for
   a stupid Fibonacci function.
*)

Add LoadPath "..".
Require Import Coqlib.
Require Import Common.

Section FIBONACCI.
Context (F: fid -> Z) (FNN: forall f, 0 <= F f).

(* ---- PROGRAM DEFINITION *)

(*
    /* Fibonacci function from CompCert's benchmarks. */

    int fib(int n)
    {
      if (n < 2)
        return 1;
      else
        return fib(n-1) + fib(n-2);
    }

*)

(* --- Variable Identifiers *)

(* -- global variables *)
Definition fib_id  := 1%positive.

(* -- fib locals *)
Definition n_id    := 1%positive.
Definition tmp1_id := 2%positive.
Definition tmp2_id := 3%positive.

(* --- Fib Expressions *)

Definition n_e    := Etempvar n_id i32.
Definition tmp1_e := Etempvar tmp1_id i32.
Definition tmp2_e := Etempvar tmp2_id i32.

Definition one_e := Econst_int (Int.repr 1) i32.
Definition two_e := Econst_int (Int.repr 2) i32.

(* --- Fibonacci Function Definition *)

Definition fib_body :=
  let o op a b := Ebinop op a b i32 in
  (sif (o Olt n_e two_e)
       (* base case *)
       (sret (Some one_e))
       (* recursive case *)
       (sseq (scall (Some tmp1_id) fib_id (o Osub n_e one_e :: nil))
       (sseq (scall (Some tmp2_id) fib_id (o Osub n_e two_e :: nil))
             (sret (Some (o Oadd tmp1_e tmp2_e)))
       ))
  ).

Definition fib :=
  {| fi_name := fib_id
  ;  fi_locals := (tmp1_id, i32) :: (tmp2_id, i32) :: nil
  ;  fi_body := fib_body
  ;  fi_args := (n_id, i32) :: nil
  ;  fi_return := i32
  |}.

(* --- Global Environment Used *)

Definition ge: genv :=
  Genv.add_globals (@Genv.empty_genv _ _) (
    (fib_id, Gfun fib) ::
    nil
  ).

(* ---- STACK BOUND PROOF *)
Require Import Maps.

(* --- Expression Tools *)
Definition local s id n := s!id = Some (Vint n).

Lemma eval_local:
  forall c id n (LOC: local (c_stack c) id n)
         v (EVAL: eval ge c (Etempvar id i32) v),
  v = (Vint n, i32).
Proof.
simpl; intros until v.
destruct v; intros [? ?]; f_equal; auto.
eapply Clight.eval_expr_determ; eauto.
constructor; auto.
Qed.

Lemma eval_lt_k:
  forall
    (c: conf)
    k (KBOUND: Int.min_signed <= k <= Int.max_signed)
    n_id n (LOC: local (c_stack c) n_id n)
    vb (EVLTB: eval ge c
                 (Ebinop Olt (Etempvar n_id i32)
                             (Econst_int (Int.repr k) i32) i32) vb)
    b (BBOOL: val_bool vb b),

  if b then sint n < k
       else k <= sint n.

Proof.
intros.
destruct vb as [vb vbty].
destruct EVLTB as [EV ?]; simpl in *; subst.
inv EV.
replace v1 with (Vint n) in *.
replace v2 with (Vint (Int.repr k)) in *.
inv H6.
{ revert BBOOL. unfold Int.lt, sint.
  rewrite Int.signed_repr by assumption.
  destruct (zlt (Int.signed n) k);
   injection 1; intro; subst.
  change (Int.eq Int.one Int.zero) with false;
   simpl; assumption.
  change (Int.eq Int.zero Int.zero) with true;
   simpl; omega.
}
eapply Clight.eval_expr_determ; eauto;
 constructor.
eapply Clight.eval_expr_determ; eauto;
 constructor; assumption.
inv H.
Qed.

Lemma eval_sub:
  forall
    (c: conf)
    n_id n (LOC: local (c_stack c) n_id n)
    k (KBOUND: 0 <= k <= sint n)
    v (EV: eval ge c
             (Ebinop Osub (Etempvar n_id i32)
                          (Econst_int (Int.repr k) i32) i32) v),

  v = (Vint (Int.sub n (Int.repr k)), i32) /\
  sint (Int.sub n (Int.repr k)) = sint n - k.

Proof.
intros.
destruct v as [v ty].
destruct EV as [EV ?]; simpl in *.
subst; split.

+ inv EV.
  replace v1 with (Vint n) in *.
  replace v2 with (Vint (Int.repr k)) in *.
  inv H6; reflexivity.
  eapply Clight.eval_expr_determ; eauto.
   constructor.
  eapply Clight.eval_expr_determ; eauto.
   constructor. assumption.
  inv H.
+ unfold sint in *.
  generalize (Int.signed_range n); intro.
  generalize Int.min_signed_neg; intro.
  rewrite Int.sub_signed.
  repeat rewrite Int.signed_repr; omega.
Qed.

(* --- Ltac Hacks *)

(* -- destruct on steroids *)
Ltac destroids :=
  repeat match goal with
  | [ H: exists _, _ |- _ ] => destruct H
  | [ H: _ /\ _ |- _ ] => destruct H
  | [ H: True |- _ ] => clear H
  | [ H: False |- _ ] => elim H
  end.

(* -- kill arithmetic goals with Nat <-> Z conversions *)
Ltac zomg :=
  match goal with
  | [ |- context[ Z.of_nat (_ + _) ] ] => rewrite Nat2Z.inj_add
  | [ |- context[ Z.of_nat (Z.to_nat _) ] ] => rewrite Z2Nat.id by zomg
  | [ |- 0 <= F _ ] => apply FNN
  | [ |- _ ] => try rewrite Z.mul_sub_distr_r in *; omega
  end.

(* --- Proof For The Fib Function *)

Definition lin z phi := z * F fib_id <= Z.of_nat phi.

Theorem fibonacci_valid: forall i,
  let pre z (_: mem) args phi :=
    exists n,
      args = (Vint n, i32) :: nil /\
      0 <= sint n <= z /\
      lin z phi in
  let post z (_: mem) (_: option val) phi :=
    lin z phi in

  validf _ ge F (S i)
         pre fib_id post.
Proof. Opaque PTree.set.

intro. eapply validf_ind; [| apply validC_empty ].
clear i; intros i VALIDC.
unfold validf; intros. inv H.

apply sound_if; intros [].

(* 1. prove the base case (n < 2) *)

(* 1.1. prove the base case return *)
eapply weak_pre; [| apply sound_ret ].
unfold ifP; intros; destroids; auto.

(* 2. prove the recursive case (n >= 2) *)

(* first, we make the pre-condition nicer *)
apply weak_pre with
  (P := fun z c phi =>
    exists n,
      local (c_stack c) n_id n /\
      2 <= sint n /\
      0 <= sint n <= z /\
      lin z phi).
{ unfold ifP; intros.
  destroids; subst.
  inv H0.
  assert (FI: Some fib = Some fi) by assumption.
  replace fi with fib in * by congruence; clear FI.
  repeat match goal with
  | [ H: castl _ _ _ |- _ ] => inv H
  | [ H: val_cast (Vint _, _) _ = Some _ |- _ ] => inv H
  end.
  injection H9; clear H9; intro STACK.
  unfold stack, temp_env in *. rewrite <- STACK.
  repeat eexists; eauto.
  exploit eval_lt_k; eauto.
  split; compute; congruence.
  rewrite <- STACK; reflexivity.
  tauto.
}

pose (stack_frame z s :=        (* logical predicate on the stack *)
  exists n,
    local s n_id n /\
    2 <= sint n /\
    0 <= sint n <= z + 1
).

pose (pred z (c: conf) phi :=   (* assertion used in the sequel *)
  exists n,
    local (c_stack c) n_id n /\
    2 <= sint n /\
    0 <= sint n <= z /\
    lin z phi
).

apply sound_seq with
  (Q := fun _ => pred).
unfold pred; intros; destruct o; destroids; auto.

(* 2.1. prove the first recursive call *)
{ eapply sound_consequence;
   [| eapply sound_call1; eauto ].
  2: reflexivity.
  instantiate (1 := stack_frame).

  unfold wk, enter, leave, pls, pred, stack_frame;
   revert FNN; clear; intros.
  exists (z - 1); split; intros.

  + destruct H as [n ?]; destroids.
    assert (RFRAME: F fib_id <= Z.of_nat r).
    { unfold lin in *.
      assert (1 * F fib_id <= z * F fib_id).
      apply Z.mul_le_mono_nonneg_r; auto; omega.
      omega.
    }

    exists (Z.to_nat (Z.of_nat r - F fib_id)).
    repeat split; auto; intros.
    repeat match goal with
      [ H: evall _ _ _ _ |- _ ] => inv H end.
    exploit eval_sub; eauto. omega.
    intros [? SUBONE]; subst.
    unfold lin in *; repeat eexists; auto; repeat zomg.

    repeat eexists; eauto. omega.

    apply Nat2Z.inj. repeat zomg.

  + destruct o; try tauto.
    clear H; destroids; subst.
    unfold stack, temp_env in *.
    inv H. inv H0.
    repeat eexists; eauto.
    unfold local; rewrite PTree.gso;
     auto; compute; congruence.
    omega.
    unfold lin in *; repeat zomg.
}

apply sound_seq with
  (Q := fun _ => pred).
unfold pred; intros; destruct o; destroids; auto.

(* 2.2. prove the second recursive call *)
{ eapply sound_consequence;
   [| eapply sound_call1; eauto ].
  2: reflexivity.
  instantiate (1 := stack_frame).

  unfold wk, enter, leave, pls, pred, stack_frame;
   revert FNN; clear; intros.
  exists (z - 1); split; intros.

  + destruct H as [n ?]; destroids.
    assert (RFRAME: F fib_id <= Z.of_nat r).
    { unfold lin in *.
      assert (1 * F fib_id <= z * F fib_id).
      apply Z.mul_le_mono_nonneg_r; auto; omega.
      omega.
    }

    exists (Z.to_nat (Z.of_nat r - F fib_id)).
    repeat split; auto; intros.
    repeat match goal with
      [ H: evall _ _ _ _ |- _ ] => inv H end.
    exploit eval_sub; eauto. omega.
    intros [? SUBTWO]; subst.
    unfold lin in *; repeat eexists; auto; repeat zomg.

    repeat eexists; eauto. omega.

    apply Nat2Z.inj. repeat zomg.

  + destruct o; try tauto.
    clear H; destroids; subst.
    unfold stack, temp_env in *.
    inv H. inv H0.
    repeat eexists; eauto.
    unfold local; rewrite PTree.gso;
     auto; compute; congruence.
    omega.
    unfold lin in *; repeat zomg.
}

(* 2.3. prove the recursive return statement *)
{ eapply weak_pre; [| apply sound_ret ].
  unfold pred.
  simpl; intros; destroids; auto.
}
Qed.

End FIBONACCI.


(*|
#######################################################
Representing Higher-Order Functors as Containers in Coq
#######################################################

:Link: https://stackoverflow.com/q/54864518
|*)

(*|
Question
********

Following `this
<https://people.cs.kuleuven.be/~tom.schrijvers/Research/papers/haskell2014.pdf>`__
approach, I'm trying to model functional programs using effect
handlers in Coq, based on an implementation in Haskell. There are two
approaches presented in the paper:

- Effect syntax is represented as a functor and combined with the free
  monad.

  .. code-block:: haskell

      data Prog sig a = Return a | Op (sig (Prog sig a))

  Due to the termination check not liking non-strictly positive
  definitions, this data type can't be defined directly. However,
  containers can be used to represent strictly-positive functors, as
  described in `this paper <https://arxiv.org/pdf/1805.08059.pdf>`__.
  This approach works but since I need to model a scoped effect that
  requires explicit scoping syntax, mismatched begin/end tags are
  possible. For reasoning about programs, this is not ideal.

- The second approach uses higher-order functors, i.e. the following
  data type.

  .. code-block:: haskell

      data Prog sig a = Return a | Op (sig (Prog sig) a)

  Now sig has the type ``(* -> *) -> * -> *``. The data type can't be
  defined in Coq for the same reasons as before. I'm looking for ways
  to model this data type, so that I can implement scoped effects
  without explicit scoping tags.

My attempts of defining a container for higher-order functors have not
been fruitful and I can't find anything about this topic. I'm thankful
for pointers in the right direction and helpful comments.

Edit: One example of scoped syntax from the paper that I would like to
represent is the following data type for exceptions.

.. code-block:: haskell

    data HExc e m a = Throw' e | forall x. Catch' (m x) (e -> m x) (x -> m a)

Edit2: I have merged the suggested idea with my approach.
|*)

Inductive Ext Shape (Pos : Shape -> Type -> Type -> Type)
          (F : Type -> Type) A :=
  ext : forall s, (forall X, Pos s A X -> F X) -> Ext Shape Pos F A.

Class HContainer (H : (Type -> Type) -> Type -> Type) :=
  {
  Shape   : Type;
  Pos     : Shape -> Type -> Type -> Type;
  to      : forall M A, Ext Shape Pos M A -> H M A;
  from    : forall M A, H M A -> Ext Shape Pos M A;
  to_from : forall M A (fx : H M A), @to M A (@from M A fx) = fx;
  from_to : forall M A (e : Ext Shape Pos M A), @from M A (@to M A e) = e
  }.

Section Free.
  Variable H : (Type -> Type) -> Type -> Type.

  Inductive Free (HC__F : HContainer H) A :=
  | pure : A -> Free HC__F A
  | impure : Ext Shape Pos (Free HC__F) A -> Free HC__F A.
End Free.

(*|
The code can be found `here
<https://gist.github.com/nbun/3e3f2198eae099c8409bf41c04271b3c>`__.
The Lambda Calculus example works and I can prove that the container
representation is isomorphic to the data type. I have tried to to the
same for a simplified version of the exception handler data type but
it does not fit the container representation.

Defining a smart constructor does not work, either. In Haskell, the
constructor works by applying ``Catch'`` to a program where an
exception may occur and a continuation, which is empty in the
beginning.

.. code-block:: haskell

    catch :: (HExc <: sig) => Prog sig a -> Prog sig a
    catch p = inject (Catch' p return)

The main issue I see in the Coq implementation is that the shape needs
to be parameterized over a functor, which leads to all sorts of
problems.
|*)

(*|
Answer (Li-yao Xia)
*******************

This answer gives more intuition about how to derive containers from
functors than my previous one. I'm taking quite a different angle, so
I'm making a new answer instead of revising the old one.

Simple recursive types
======================

Let's consider a simple recursive type first to understand
non-parametric containers, and for comparison with the parameterized
generalization. Lambda calculus, without caring about scopes, is given
by the following functor:
|*)

Inductive LC_F (t : Type) : Type :=
| App : t -> t -> LC_F t
| Lam : t -> LC_F t.
Reset LC_F. (* .none *)

(*|
There are two pieces of information we can learn from this type:

- The *shape* tells us about the constructors (``App``, ``Lam``), and
  potentially also auxiliary data not relevant to the recursive nature
  of the syntax (none here). There are two constructors, so the shape
  has two values. ``Shape := App_S | Lam_S`` (``bool`` also works, but
  declaring shapes as standalone inductive types is cheap, and named
  constructors also double as documentation.)
- For every shape (i.e., constructor), the *position* tells us about
  recursive occurences of syntax in that constructor. ``App`` contains
  two subterms, hence we can define their two positions as booleans;
  ``Lam`` contains one subterm, hence its position is a unit. One
  could also make ``Pos (s : Shape)`` an indexed inductive type, but
  that is a pain to program with (just try).

.. coq::
|*)

(* Lambda calculus *)
Inductive ShapeLC :=
| App_S    (* The shape   App _ _ *)
| Lam_S.   (* The shape   Lam _ *)

Definition PosLC s :=
  match s with
  | App_S => bool
  | Lam_S => unit
  end.

(*|
Parameterized recursive types
=============================

Now, properly scoped lambda calculus:
|*)

Inductive LC_F (f : Type -> Type) (a : Type) : Type :=
| App : f a -> f a -> LC_F f a
| Lam : f (sum unit a) -> LC_F f a.

(*|
In this case, we can still reuse the ``Shape`` and ``Pos`` data from
before. But this functor encodes one more piece of information: how
each position changes the type parameter ``a``. I call this parameter
the context (``Ctx``).
|*)

Definition CtxLC (s : ShapeLC) : PosLC s -> Type -> Type :=
  match s with
  | App_S => fun _ a => a (* subterms of App reuse the same context *)
  | Lam_S => fun _ a => sum unit a
    (* Lam introduces one variable in the context of its subterm *)
  end.

(*|
This container ``(ShapeLC, PosLC, CtxLC)`` is related to the functor
``LC_F`` by an isomorphism: between the sigma ``{ s : ShapeLC & forall
p : PosLC s, f (CtxLC s p a) }`` and ``LC_F a``. In particular, note
how the function ``y : forall p, f (CtxLC s p)`` tells you exactly how
to fill the shape ``s = App_S`` or ``s = Lam_S`` to construct a value
``App (y true) (y false) : LC_F a`` or ``Lam (y tt) : LC_F a``.

My previous representation encoded ``Ctx`` in some additional type
indices of ``Pos``. The representations are equivalent, but this one
here looks tidier.

Exception handler calculus
==========================

We'll consider just the ``Catch`` constructor. It has four fields: a
type ``X``, the main computation (which returns an ``X``), an
exception handler (which also recovers an ``X``), and a continuation
(consuming the ``X``).
|*)

Inductive Exc_F (E : Type) (F : Type -> Type) (A : Type) :=
| ccatch : forall X, F X -> (E -> F X) -> (X -> F A) -> Exc_F E F A.

(*|
The shape is a single constructor, but you must include ``X``.
Essentially, look at all the fields (possibly unfolding nested
inductive types), and keep all the data that doesn't mention ``F``,
that's your shape.
|*)

Inductive ShapeExc :=
| ccatch_S (X : Type). (* The shape   ccatch X _ (fun e => _) (fun x => _) *)

(* equivalently, Definition ShapeExc := Type. *)

(*|
The position type lists all the ways to get an ``F`` out of an
``Exc_F`` of the corresponding shape. In particular, a position
contains the arguments to apply functions with, and possibly any data
to resolve branching of any other sort. In particular, you need to
know the exception type to store exceptions for the handler.

.. coq:: none
|*)

Set Implicit Arguments.
Set Contextual Implicit.
Variable getX : ShapeExc -> Type.

(*||*)

Inductive PosExc (E : Type) (s : ShapeExc) : Type :=
| main_pos                      (* F X *)
| handle_pos (e : E)            (* E -> F X *)
| continue_pos (x : getX s).    (* X -> F A *)

(* The function getX takes the type X contained in a ShapeExc value,
   by pattern-matching: getX (ccatch_S X) := X. *)

(*|
Finally, for each position, you need to decide how the context
changes, i.e., whether you're now computing an ``X`` or an ``A``:
|*)

Definition Ctx (E : Type) (s : ShapeExc) (p : PosExc E s) : Type -> Type :=
  match p with
  | main_pos | handle_pos _ => fun _ => getX s
  | continue_pos _ => fun A => A
  end.

(*|
Using the conventions from `your code
<https://gist.github.com/nbun/3e3f2198eae099c8409bf41c04271b3c>`__,
you can then encode the ``Catch`` constructor as follows:

.. code-block:: coq

    Definition Catch' {E X A}
               (m : Free (C__Exc E) X)
               (h : E -> Free (C__Exc E) X)
               (k : X -> Free (C__Exc E) A) : Free (C__Exc E) A :=
      impure (@ext (C__Exc E) (Free (C__Exc E)) A (ccatch_S X)
                   (fun p =>
                      match p with
                      | main_pos => m
                      | handle_pos e => h e
                      | continue_pos x => k x
                      end)).

    (* I had problems with type inference for some reason, hence @ext is
       explicitly applied *)

Full gist
https://gist.github.com/Lysxia/6e7fb880c14207eda5fc6a5c06ef3522

----

**Q:** This is a really helpful answer and detailed walk-through (and,
again, a good example of why I like the Coq/FP-community so much ; )).
Is there any citable publication/reference you've read/wrote that
gives similar details to the the usage of containers for more
complicated functors? Since you named your first gist
"FreeIndexedMonad", I was wondering if `Indexed Containers
<http://strictlypositive.org/indexed-containers.pdf>`__ are related?
After a first glance I couldn't tell if they are also capable of
handling similar examples to the one above.

**A:** Thanks! This paper is indeed closely related! The two
presentations here and in the paper are basically equivalent. They
actually represent higher-order functors ``(I -> Type) -> (O ->
Type)`` and you can generalize ``Ctx s : Pos s -> Type -> Type`` to
``Ctx s : Pos s -> O -> I`` to do the same here. Sadly I don't know
any publication to point to offhand otherwise.
|*)

(*|
Answer (Li-yao Xia)
*******************

The main trick in the "first-order" free monad encoding is to encode a
functor ``F : Type -> Type`` as a container, which is essentially a
dependent pair ``{ Shape : Type ; Pos : Shape -> Type }``, so that,
for all ``a``, the type ``F a`` is isomorphic to the sigma type ``{ s
: Shape & Pos s -> a }``.

Taking this idea further, we can encode a higher-order functor ``F :
(Type -> Type) -> (Type -> Type)`` as a container ``{ Shape : Type &
Pos : Shape -> Type -> (Type -> Type) }``, so that, for all ``f`` and
``a``, ``F f a`` is isomorphic to ``{ s : Shape & forall x : Type, Pos
s a x -> f x }``.

I don't quite understand what the extra ``Type`` parameter in ``Pos``
is doing there, but It Works(TM), at least to the point that you can
construct some lambda calculus terms in the resulting type.

For example, the lambda calculus syntax functor:
|*)

Reset Initial. (* .none *)
Inductive LC_F (f : Type -> Type) (a : Type) : Type :=
| App : f a -> f a -> LC_F f a
| Lam : f (sum unit a) -> LC_F f a.

(*| is represented by the container ``(Shape, Pos)`` defined as: |*)

(* LC container *)

Inductive App_F (a : Type) : Type -> Type :=
| App_ (b : bool) : App_F a a.

Inductive Lam_F (a : Type) : Type -> Type :=
| Lam_ : Lam_F a (sum unit a).

(* Two values in bool = two constructors in LC_F *)
Definition Shape : Type := bool.
Definition Pos (b : bool) : Type -> (Type -> Type) :=
  match b with
  | true => App_F
  | false => Lam_F
  end.

(*|
Then the free-like monad ``Prog`` (implicitly parameterized by
``(Shape, Pos)``) is given by:
|*)

Inductive Prog (a : Type) : Type :=
| Ret : a -> Prog a
| Op (s : Shape) : (forall b, Pos s a b -> Prog b) -> Prog a.

(*|
Having defined some boilerplate, you can write the following example:

.. code-block:: coq

    (* \f x -> f x x *)
    Definition omega {a} : LC a :=
      Lam (* f *) (Lam (* x *)
                     (let f := Ret (inr (inl tt)) in
                      let x := Ret (inl tt) in
                      App (App f x) x)).

Full gist:
https://gist.github.com/Lysxia/5485709c4594b836113736626070f488
|*)


(* Pigeonhole
   f : A → B & card B < card A → f non injective *)

(* borrowed 2021-01-17 from my development "coq_euler_prod_form" *)

Set Nested Proofs Allowed.
Require Import Utf8 Arith.
Require FinFun.
Import List List.ListNotations.

Require Import Misc.

Fixpoint find_dup f (la : list nat) :=
  match la with
  | [] => None
  | n :: la' =>
      match find (λ n', f n' =? f n) la' with
      | None => find_dup f la'
      | Some n' => Some (n, n')
      end
  end.

Definition pigeonhole_fun a (f : nat → nat) :=
  match find_dup f (seq 0 a) with
  | Some (n, n') => (n, n')
  | None => (0, 0)
  end.

Theorem List_in_split' :
  ∀ (A : Type) (eq_dec : ∀ x y : A, {x = y} + {x ≠ y}) (x : A) (l : list A),
  x ∈ l → ∃ l1 l2 : list A, l = l1 ++ x :: l2 ∧ x ∉ l1.
Proof.
intros * eq_dec * Hx.
revert x Hx.
induction l as [| y]; intros; [ easy | ].
destruct Hx as [Hx| Hx]. {
  subst y.
  now exists [], l.
}
specialize (IHl _ Hx) as H1.
destruct H1 as (l1 & l2 & Hll & Hl1).
rewrite Hll.
destruct (eq_dec y x) as [Hxy| Hxy]. {
  subst y.
  now exists [], (l1 ++ x :: l2).
}
exists (y :: l1), l2.
split; [ easy | ].
intros H; apply Hl1.
now destruct H.
Qed.

Theorem List_eq_dec_In_nth :
  ∀ (A : Type) (eq_dec : ∀ x y : A, {x = y} + {x ≠ y}) (l : list A) (x d : A),
  x ∈ l →
  ∃ n : nat, n < length l ∧ nth n l d = x ∧ ∀ m, m < n → nth m l d ≠ x.
Proof.
intros * eq_dec * Hxl.
revert x Hxl.
induction l as [| y]; intros; [ easy | ].
rewrite List_cons_length.
destruct Hxl as [Hxl| Hxl]. {
  subst y.
  exists 0.
  rewrite List_nth_0_cons.
  split; [ flia | easy ].
}
specialize (IHl x Hxl) as H1.
destruct H1 as (n & Hnl & Hyx & Hm).
destruct (eq_dec y x) as [Hxy| Hxy]. {
  subst y.
  exists 0.
  split; [ flia | easy ].
}
exists (S n).
rewrite List_nth_succ_cons.
split; [ now apply Nat.succ_lt_mono in Hnl | ].
split; [ easy | ].
intros m Hm'.
destruct m; [ easy | cbn ].
apply Nat.succ_lt_mono in Hm'.
now apply Hm.
Qed.

Theorem List_find_some_if :
  ∀ (A : Type) (eq_dec : ∀ x y : A, {x = y} + {x ≠ y}) f d (l : list A) x,
  find f l = Some x →
  ∃ i, i < length l ∧ x = nth i l d ∧ f x = true ∧
  ∀ j, j < i → f (nth j l d) = false.
Proof.
intros * eq_dec * Hf.
specialize (find_some _ _ Hf) as H1.
destruct H1 as (Hx, Hfx).
apply (List_eq_dec_In_nth A eq_dec l x d) in Hx.
destruct Hx as (i & Hi & Hix & Hx).
exists i.
split; [ easy | ].
split; [ easy | ].
split; [ easy | ].
intros j Hj.
revert i j Hi Hix Hx Hj.
induction l as [| a]; intros; [ easy | ].
cbn in Hf.
remember (f a) as b eqn:Hb; symmetry in Hb.
destruct b. {
  injection Hf; clear Hf; intros; subst a.
  clear Hb.
  destruct i; [ easy | ].
  now specialize (Hx 0 (Nat.lt_0_succ _)) as H1.
}
destruct i; [ easy | ].
cbn in Hi, Hix; apply Nat.succ_lt_mono in Hi.
destruct j; [ easy | cbn ].
apply Nat.succ_lt_mono in Hj.
apply IHl with (i := i); [ easy | easy | easy | | easy ].
intros m Hm.
specialize (Hx (S m)); cbn in Hx.
apply Hx.
now apply -> Nat.succ_lt_mono.
Qed.

Theorem find_dup_some : ∀ f x x' la,
  find_dup f la = Some (x, x')
  → f x = f x' ∧
    ∃ la1 la2 la3, la = la1 ++ x :: la2 ++ x' :: la3 ∧
    (∀ y y', y ∈ la1 → y' ∈ la → f y = f y' → y = y') ∧
    (∀ x'', x'' ∈ la1 ++ la2 → f x'' ≠ f x).
Proof.
intros * Hfd.
induction la as [| a]; [ easy | ].
cbn in Hfd.
remember (find (λ x', f x' =? f a) la) as r eqn:Hr.
symmetry in Hr.
destruct r as [n'| ]. {
  injection Hfd; clear Hfd; intros; subst x x'.
  apply (List_find_some_if _ Nat.eq_dec _ 0) in Hr.
  destruct Hr as (i & Hi & Hn'i & Heq & Hbef).
  apply Nat.eqb_eq in Heq.
  split; [ easy | ].
  exists []; cbn.
  assert (Hx'la : n' ∈ la) by now rewrite Hn'i; apply nth_In.
  apply (List_in_split' _ Nat.eq_dec) in Hx'la.
  destruct Hx'la as (l1 & l2 & Hla & Hn').
  exists l1, l2.
  rewrite Hla.
  split; [ easy | ].
  split; [ easy | ].
  intros n'' Hx''.
  assert (Hil : i = length l1). {
    rewrite Hla in Hn'i.
    destruct (Nat.lt_trichotomy i (length l1)) as [Hil| [Hil| Hil]]. {
      rewrite app_nth1 in Hn'i; [ | easy ].
      exfalso; apply Hn'; clear Hn'.
      now subst n'; apply nth_In.
    } {
      easy.
    } {
      rewrite app_nth2 in Hn'i; [ | flia Hil ].
      specialize (Hbef (length l1) Hil) as H1.
      apply Nat.eqb_neq in H1.
      rewrite Hla in H1.
      rewrite app_nth2 in H1; [ | now unfold ge ].
      now rewrite Nat.sub_diag in H1; cbn in H1.
    }
  }
  apply (List_eq_dec_In_nth _ Nat.eq_dec _ _ 0) in Hx''.
  destruct Hx'' as (j & Hj & Hjn & Hbefn).
  rewrite <- Hil in Hj.
  specialize (Hbef _ Hj) as H1.
  apply Nat.eqb_neq in H1.
  rewrite Hla in H1.
  rewrite app_nth1 in H1; [ | now rewrite Hil in Hj ].
  now rewrite Hjn in H1.
} {
  specialize (IHla Hfd).
  destruct IHla as (Hxx & la1 & la2 & la3 & Hll & H1stx & H1stx').
  split; [ easy | ].
  exists (a :: la1), la2, la3; rewrite Hll.
  split; [ easy | ].
  split. {
    intros y y' Hy Hy' Hyy.
    rewrite <- Hll in Hy'.
    destruct Hy as [Hy| Hy]. {
      subst y.
      destruct Hy' as [Hy'| Hy']; [ easy | ].
      specialize (find_none _ _ Hr y' Hy') as H1; cbn in H1.
      apply Nat.eqb_neq in H1.
      now symmetry in Hyy.
    }
    destruct Hy' as [Hy'| Hy']. {
      subst y'.
      specialize (find_none _ _ Hr y) as H1.
      assert (H : y ∈ la) by now rewrite Hll; apply in_or_app; left.
      specialize (H1 H); clear H.
      now apply Nat.eqb_neq in H1.
    }
    now apply H1stx.
  }
  intros x'' Hx''.
  destruct Hx'' as [Hx''| Hx'']. {
    subst x''.
    specialize (find_none _ _ Hr x) as H1.
    assert (H : x ∈ la). {
      rewrite Hll.
      now apply in_or_app; right; left.
    }
    specialize (H1 H); clear H.
    apply Nat.eqb_neq in H1.
    now apply Nat.neq_sym in H1.
  }
  now apply H1stx'.
}
Qed.

Theorem find_dup_none : ∀ f la,
  find_dup f la = None → NoDup (map f la).
Proof.
intros * Hnd.
induction la as [| a]; [ constructor | cbn ].
constructor. {
  cbn in Hnd.
  remember (find _ _) as b eqn:Hb; symmetry in Hb.
  destruct b; [ easy | ].
  specialize (find_none _ _ Hb) as H1; cbn in H1; cbn.
  intros Ha.
  specialize (IHla Hnd).
  clear - IHla H1 Ha.
  induction la as [ | b]; [ easy | ].
  cbn in Ha.
  cbn in IHla.
  destruct Ha as [Ha| Ha]. {
    specialize (H1 b (or_introl eq_refl)).
    now apply Nat.eqb_neq in H1.
  } {
    apply NoDup_cons_iff in IHla.
    destruct IHla as (Hn, Hnd).
    specialize (IHla0 Hnd).
    apply IHla0; [ | easy ].
    intros x Hx.
    now apply H1; right.
  }
} {
  apply IHla.
  cbn in Hnd.
  remember (find _ _) as b eqn:Hb; symmetry in Hb.
  now destruct b.
}
Qed.

Theorem not_NoDup_map_f_seq : ∀ a b f,
  b < a
  → (∀ x, x < a → f x < b)
  → NoDup (map f (seq 0 a))
  → False.
Proof.
intros * Hba Hf Hfd.
revert a f Hba Hf Hfd.
induction b; intros; [ now specialize (Hf _ Hba) | ].
destruct a; [ flia Hba | ].
apply Nat.succ_lt_mono in Hba.
remember (filter (λ i, f i =? b) (seq 0 (S a))) as la eqn:Hla.
symmetry in Hla.
destruct la as [| x1]. {
  assert (H : ∀ x, x < a → f x < b). {
    intros x Hx.
    destruct (Nat.eq_dec (f x) b) as [Hfxb| Hfxb]. {
      specialize (proj1 (List_filter_nil_iff _ _) Hla x) as H1.
      assert (H : x ∈ seq 0 (S a)). {
        apply in_seq.
        flia Hx.
      }
      specialize (H1 H); clear H; cbn in H1.
      now apply Nat.eqb_neq in H1.
    }
    assert (H : x < S a) by flia Hx.
    specialize (Hf x H); clear H.
    flia Hf Hfxb.
  }
  specialize (IHb a f Hba H); clear H.
  rewrite <- Nat.add_1_r in Hfd.
  rewrite seq_app in Hfd; cbn in Hfd.
  rewrite map_app in Hfd; cbn in Hfd.
  specialize (NoDup_remove_1 _ _ _ Hfd) as H1.
  now rewrite app_nil_r in H1.
}
destruct (Nat.eq_dec b 0) as [Hbz| Hbz]. {
  subst b.
  destruct a; [ flia Hba | ].
  specialize (Hf a) as H1.
  assert (H : a < S (S a)) by flia.
  specialize (H1 H); clear H.
  specialize (Hf (S a) (Nat.lt_succ_diag_r _)) as H2.
  apply Nat.lt_1_r in H1.
  apply Nat.lt_1_r in H2.
  do 2 rewrite <- Nat.add_1_r in Hfd.
  do 2 rewrite seq_app in Hfd; cbn in Hfd.
  rewrite <- app_assoc in Hfd.
  do 2 rewrite map_app in Hfd.
  cbn in Hfd.
  apply NoDup_remove_2 in Hfd.
  apply Hfd.
  apply in_app_iff; right.
  now rewrite H1, Nat.add_1_r, H2; left.
}
destruct la as [| x2]. {
  specialize (IHb a (λ i, if lt_dec i x1 then f i else f (i + 1)) Hba).
  cbn in IHb.
  assert (H : ∀ x, x < a → (if lt_dec x x1 then f x else f (x + 1)) < b). {
    intros x Hx.
    destruct (lt_dec x x1) as [Hxx| Hxx]. {
      assert (Hxb : f x ≠ b). {
        intros Hxb.
        assert (H : x ∈ filter (λ i, f i =? b) (seq 0 (S a))). {
          apply filter_In.
          split; [ apply in_seq; cbn; flia Hx | ].
          now apply Nat.eqb_eq.
        }
        rewrite Hla in H.
        destruct H as [H| H]; [ flia Hxx H| easy ].
      }
      specialize (Hf x).
      assert (H : x < S a) by flia Hx.
      specialize (Hf H); clear H.
      flia Hf Hxb.
    }
    apply Nat.nlt_ge in Hxx.
    specialize (Hf (x + 1)).
    assert (H : x + 1 < S a) by flia Hx.
    specialize (Hf H); clear H.
    assert (Hxb : f (x + 1) ≠ b). {
      intros Hxb.
      assert (H : x + 1 ∈ filter (λ i, f i =? b) (seq 0 (S a))). {
        apply filter_In.
        split; [ apply in_seq; cbn; flia Hx | ].
        now apply Nat.eqb_eq.
      }
      rewrite Hla in H.
      destruct H as [H| H]; [ flia Hxx H| easy ].
    }
    flia Hf Hxb.
  }
  specialize (IHb H); clear H.
  apply IHb; clear - Hfd.
  specialize (proj1 (NoDup_map_iff 0 _ _) Hfd) as H1.
  apply (NoDup_map_iff 0).
  intros x x' Hx Hx' Hxx.
  rewrite seq_length in Hx, Hx', H1.
  rewrite seq_nth in Hxx; [ | easy ].
  rewrite seq_nth in Hxx; [ cbn | easy ].
  cbn in Hxx.
  destruct (lt_dec x x1) as [Hxx1| Hxx1]. {
    destruct (lt_dec x' x1) as [Hx'x1| Hx'x1]. {
      apply H1; [ flia Hx | flia Hx' | ].
      rewrite seq_nth; [ | flia Hx ].
      rewrite seq_nth; [ easy | flia Hx' ].
    } {
      apply Nat.nlt_ge in Hx'x1.
      assert (H : x = x' + 1). {
        apply H1; [ flia Hx | flia Hx' | ].
        rewrite seq_nth; [ | flia Hx ].
        rewrite seq_nth; [ easy | flia Hx' ].
      }
      flia Hxx1 Hx'x1 H.
    }
  }
  apply Nat.nlt_ge in Hxx1.
  destruct (lt_dec x' x1) as [Hx'x1| Hx'x1]. {
    assert (H : x + 1 = x'). {
      apply H1; [ flia Hx | flia Hx' | ].
      rewrite seq_nth; [ | flia Hx ].
      rewrite seq_nth; [ easy | flia Hx' ].
    }
    flia Hxx1 Hx'x1 H.
  } {
    apply Nat.nlt_ge in Hx'x1.
    apply (Nat.add_cancel_r _ _ 1).
    apply H1; [ flia Hx | flia Hx' | ].
    rewrite seq_nth; [ | flia Hx ].
    rewrite seq_nth; [ easy | flia Hx' ].
  }
}
assert (Hx1 : x1 ∈ x1 :: x2 :: la) by now left.
assert (Hx2 : x2 ∈ x1 :: x2 :: la) by now right; left.
rewrite <- Hla in Hx1.
rewrite <- Hla in Hx2.
apply filter_In in Hx1.
apply filter_In in Hx2.
destruct Hx1 as (Hx1, Hfx1).
destruct Hx2 as (Hx2, Hfx2).
apply Nat.eqb_eq in Hfx1.
apply Nat.eqb_eq in Hfx2.
assert (H : x1 ≠ x2). {
  intros H; subst x2.
  clear - Hla.
  specialize (seq_NoDup (S a) 0) as H1.
  specialize (NoDup_filter (λ i, f i =? b) H1) as H2.
  rewrite Hla in H2.
  apply NoDup_cons_iff in H2.
  destruct H2 as (H2, _); apply H2.
  now left.
}
clear - Hfd Hx1 Hx2 H Hfx1 Hfx2.
remember (seq 0 (S a)) as l; clear a Heql.
apply H; clear H.
specialize (proj1 (NoDup_map_iff 0 l (λ x, f x)) Hfd) as H1.
cbn in H1.
apply (In_nth _ _ 0) in Hx1.
apply (In_nth _ _ 0) in Hx2.
destruct Hx1 as (n1 & Hn1 & Hx1).
destruct Hx2 as (n2 & Hn2 & Hx2).
specialize (H1 _ _ Hn1 Hn2) as H2.
rewrite Hx1, Hx2, Hfx1, Hfx2 in H2.
rewrite <- Hx1, <- Hx2.
f_equal.
now apply H2.
Qed.

Theorem pigeonhole : ∀ a b f,
  b < a
  → (∀ x, x < a → f x < b)
  → ∀ x x', pigeonhole_fun a f = (x, x')
  → x < a ∧ x' < a ∧ x ≠ x' ∧ f x = f x'.
Proof.
intros * Hba Hf * Hpf.
unfold pigeonhole_fun in Hpf.
remember (find_dup _ _) as fd eqn:Hfd.
symmetry in Hfd.
destruct fd as [(n, n') |]. {
  injection Hpf; clear Hpf; intros; subst n n'.
  specialize (find_dup_some f _ _ _ Hfd) as H.
  destruct H as (Hfxx & la1 & la2 & la3 & Hll & Hbef).
  assert (Hxy : x ∈ seq 0 a). {
    rewrite Hll.
    apply in_app_iff.
    now right; left.
  }
  apply in_seq in Hxy; cbn in Hxy.
  destruct Hxy as (_, Hxa).
  assert (Hx' : x' ∈ seq 0 a). {
    rewrite Hll.
    apply in_app_iff; right; right.
    now apply in_app_iff; right; left.
  }
  apply in_seq in Hx'.
  split; [ easy | ].
  split; [ easy | ].
  split; [ | easy ].
  specialize (seq_NoDup a 0) as H.
  rewrite Hll in H.
  apply NoDup_remove_2 in H.
  intros Hxx; apply H; subst x'.
  apply in_app_iff; right.
  now apply in_app_iff; right; left.
} {
  apply find_dup_none in Hfd.
  exfalso.
  now apply not_NoDup_map_f_seq in Hf.
}
Qed.

(* version list instead of fun *)

Fixpoint search_double_loop {A} eqb i (l : list A) :=
  match l with
  | a :: l' =>
      let j := List_rank (eqb a) l' in
      if lt_dec j (length l') then (i, j + 1)
      else search_double_loop eqb (S i) l'
  | [] => (0, 0)
  end.

Definition pigeonhole_comp_list l :=
  match find_dup (λ i, nth i l 0) (seq 0 (length l)) with
  | Some (n, n') => (n, n')
  | None => (0, 0)
  end.

Theorem seq_app_cons_app_cons : ∀ sta len x y la1 la2 la3,
  seq sta len = la1 ++ x :: la2 ++ y :: la3
  ↔ len = length la1 + length la2 + length la3 + 2 ∧
    x = sta + length la1 ∧
    y = S x + length la2 ∧
    la1 = seq sta (length la1) ∧
    la2 = seq (S x) (length la2) ∧
    la3 = seq (S y) (sta + len - S y).
Proof.
intros.
split. {
  intros Hs.
  generalize Hs; intros Hsv.
  move Hsv after Hs.
  rewrite (List_seq_cut3 (sta + length la1)) in Hs. 2: {
    apply in_seq.
    split; [ flia | ].
    apply Nat.add_lt_mono_l.
    clear Hsv.
    revert sta la1 Hs.
    induction len; intros; cbn. {
      now symmetry in Hs; apply app_eq_nil in Hs.
    }
    destruct la1 as [| a]; cbn; [ flia | ].
    apply -> Nat.succ_lt_mono.
    cbn in Hs.
    injection Hs; clear Hs; intros Hs Ha.
    now apply IHlen in Hs.
  }
  apply List_app_eq_app' in Hs. 2: {
    rewrite seq_length, Nat.add_comm.
    apply Nat.add_sub.
  }
  destruct Hs as (Hla1 & Hs); symmetry in Hla1.
  rewrite Nat.add_comm, Nat.add_sub in Hla1.
  cbn in Hs.
  injection Hs; clear Hs; intros Hs Hx; symmetry in Hx.
  move Hx after Hla1.
  split. {
    apply (f_equal length) in Hsv.
    rewrite seq_length in Hsv.
    rewrite app_length in Hsv; cbn in Hsv.
    rewrite app_length in Hsv; cbn in Hsv.
    flia Hsv.
  }
  split; [ easy | ].
  rewrite <- Hx in Hs.
  rewrite (List_seq_cut3 (S x + length la2)) in Hs. 2: {
    apply in_seq.
    split; [ flia | ].
    apply Nat.add_lt_mono_l.
    apply (f_equal length) in Hs.
    rewrite seq_length in Hs.
    rewrite app_length in Hs.
    cbn in Hs; flia Hs.
  }
  rewrite Nat.add_comm, Nat.add_sub in Hs.
  apply List_app_eq_app' in Hs; [ | now rewrite seq_length ].
  destruct Hs as (Hla2, Hs); symmetry in Hla2; cbn in Hs.
  injection Hs; clear Hs; intros Hla3 Hy.
  move Hy before Hx; symmetry in Hy.
  symmetry in Hla3; rewrite <- Hy in Hla3.
  rewrite Nat.add_sub_assoc in Hla3. 2: {
    rewrite Hx, <- Nat.add_succ_r.
    apply Nat.add_le_mono_l.
    apply (f_equal length) in Hsv.
    rewrite seq_length, app_length in Hsv; cbn in Hsv.
    flia Hsv.
  }
  rewrite Nat.add_comm in Hla3.
  rewrite <- (Nat.add_1_r x) in Hla3.
  rewrite Nat.sub_add_distr, Nat.add_sub in Hla3.
  rewrite <- Nat.sub_add_distr in Hla3; cbn in Hla3.
  now rewrite Nat.add_comm.
} {
  intros (Hlen & Hx & Hy & Hla1 & Hla2 & Hla3).
  rewrite (List_seq_cut3 x). 2: {
    apply in_seq; rewrite Hx.
    split; [ flia | ].
    apply Nat.add_lt_mono_l.
    flia Hlen.
  }
  cbn; rewrite Hx at 1.
  rewrite Nat.add_comm, Nat.add_sub, <- Hla1, Hla2.
  f_equal; f_equal.
  rewrite Hla3.
  rewrite cons_seq.
  rewrite Hy at 1.
  rewrite <- seq_app.
  f_equal.
  flia Hx Hy Hlen.
}
Qed.

Theorem pigeonhole_list : ∀ a l,
  a < length l
  → (∀ x, x ∈ l → x < a)
  → ∀ x x', pigeonhole_comp_list l = (x, x')
  → x < length l ∧ x' < length l ∧ x ≠ x' ∧ nth x l 0 = nth x' l 0.
Proof.
intros * Hal Hla * Hpcl.
unfold pigeonhole_comp_list in Hpcl.
remember (find_dup _ _) as fd eqn:Hfd.
symmetry in Hfd.
destruct fd as [(n, n') |]. {
  injection Hpcl; clear Hpcl; intros; subst n n'.
  apply find_dup_some in Hfd.
  destruct Hfd as (Hxx & la1 & la2 & la3 & Hll & H1stx & H1stx').
  assert (Hxy : x ∈ seq 0 (length l)). {
    rewrite Hll.
    apply in_app_iff.
    now right; left.
  }
  apply in_seq in Hxy; cbn in Hxy.
  destruct Hxy as (_, Hxa).
  assert (Hx' : x' ∈ seq 0 (length l)). {
    rewrite Hll.
    apply in_app_iff; right; right.
    now apply in_app_iff; right; left.
  }
  apply in_seq in Hx'.
  split; [ easy | ].
  split; [ easy | ].
  split; [ | easy ].
  specialize (seq_NoDup (length l) 0) as H.
  rewrite Hll in H.
  apply NoDup_remove_2 in H.
  intros Hxix; apply H; subst x'.
  apply in_app_iff; right.
  now apply in_app_iff; right; left.
} {
  apply find_dup_none in Hfd.
  exfalso; clear Hpcl.
  apply not_NoDup_map_f_seq with (b := a) in Hfd; [ easy | easy | ].
  intros y Hy.
  apply Hla.
  now apply nth_In.
}
Qed.

(* fin_t : finite type, implemented with type "sig" *)

Definition fin_t n := {a : nat | (a <? n) = true}.

Theorem fin_t_fun_le : ∀ m n (f : fin_t m → fin_t n) g,
  (∀ y, f (g y) = y) → n ≤ m.
Proof.
intros * Hfg.
specialize (pigeonhole) as H1.
specialize (H1 n m).
apply Nat.nlt_ge; intros Hmn.
set (f' := λ y : nat,
  match lt_dec y n with
  | left Hyn =>
      let H := proj2 (Nat.ltb_lt y n) Hyn in
      proj1_sig (g (exist (λ a, (a <? n) = true) y H))
  | right b => 0
  end).
specialize (H1 f' Hmn).
assert (H : ∀ x, x < n → f' x < m). {
  intros x Hx; unfold f'; cbn - [ "<?" ].
  destruct (lt_dec x n) as [H| H]; [ | flia Hx H ].
  remember (g _) as y eqn:Hy.
  destruct y as (y, py).
  now apply Nat.ltb_lt.
}
specialize (H1 H); clear H.
unfold pigeonhole_fun in H1.
remember (find_dup f' (seq 0 n)) as x eqn:Hx; symmetry in Hx.
destruct x as [(n1, n2)| ]; [ | now apply (H1 0 0 eq_refl) ].
specialize (H1 n1 n2 eq_refl).
destruct H1 as (Hn1n & Hn2n & Hnn & Hfnn).
unfold f' in Hfnn.
destruct (lt_dec n1 n) as [H1| H]; [ | flia Hn1n H ].
destruct (lt_dec n2 n) as [H2| H]; [ | flia Hn2n H ].
remember (g _) as x eqn:Hx' in Hfnn.
remember (g _) as y eqn:Hy' in Hfnn.
destruct x as (x, px).
destruct y as (y, py).
cbn in Hfnn.
subst y.
move py before px.
assert (H : px = py). {
  clear - px py.
  apply (Eqdep_dec.UIP_dec Bool.bool_dec).
}
destruct H.
rewrite Hy' in Hx'.
apply (f_equal f) in Hx'.
do 2 rewrite Hfg in Hx'.
now injection Hx'; intros H; symmetry in H.
Qed.

Theorem bijective_fin_t : ∀ m n (f : fin_t m → fin_t n),
  FinFun.Bijective f → m = n.
Proof.
intros * Hf.
destruct Hf as (g & Hgf & Hfg).
destruct (Nat.lt_trichotomy m n) as [Hmn| [Hmn| Hmn]]; [ | easy | ]. {
  exfalso.
  apply Nat.nle_gt in Hmn; apply Hmn; clear Hmn.
  now apply fin_t_fun_le in Hfg.
} {
  exfalso.
  apply Nat.nle_gt in Hmn; apply Hmn; clear Hmn.
  now apply fin_t_fun_le in Hgf.
}
Qed.

(* end fin_t *)


(** remove printing ~ *)

(** * Type Soundness *)

Set Implicit Arguments.

Require Import Coq.Program.Equality List String.
Require Import Sequences.
Require Import Binding CanonicalForms Definitions GeneralToTight InvertibleTyping Lookup Narrowing
        Reduction PreciseTyping RecordAndInertTypes ReplacementTyping
        Subenvironments Substitution TightTyping Weakening.

Close Scope string_scope.

(** ** Safety wrt Term Reduction ⟼*)

Section Safety.

(** *** Reasoning about the precise type of objects *)

(** If the rhs of a type declaration is a signleton type [q.type] then
    [q] is well-typed *)
Lemma defs_typing_sngl_rhs z bs G ds T a q :
  z; bs; G ⊢ ds :: T ->
  record_has T {a ⦂ {{ q }}} ->
  exists T, G ⊢ trm_path q : T.
Proof.
  induction 1; intros Hr.
  - destruct D; inversions Hr. inversions H. eauto.
  - inversions Hr; auto. inversions H5. inversions H0. eauto.
Qed.

(** The [lookup_fields_typ] notation [x ==> T =bs=> U] denotes that
    if [T] is a recursive type then we can "look up" or "go down" a path
    [x.bs] inside of [T] yielding a type [U]. For example, if
    [T = μ(x: {a: μ(y: {b: μ(z: ⊤)})})] then
    [x ==> T =b,a=>⊤] *)
Reserved Notation "x '==>' T '=' bs '=>' U" (at level 40, T at level 20).

(** If [x ==> T =bs=> U] we will say that looking up the path
    [x.bs] in [T] yields [U].*)
Inductive lookup_fields_typ : var -> typ -> list trm_label -> typ -> Prop :=
| lft_empty : forall x T,
    x ==> T =nil=> T
| lft_cons : forall T bs U x a S,
    x ==> T =bs=> μ U ->
    record_has (open_typ_p (p_sel (avar_f x) bs) U) {a ⦂ S} ->
    x ==> T =a::bs=> S

where "x '==>' T '=' bs '=>' U" := (lookup_fields_typ x T bs U).

Hint Constructors lookup_fields_typ.

(** **** Properties of [lookup_fields_typ] *)

(** Looking up a path inside of an inert type yields an inert type *)
Lemma lft_inert x T bs U :
  inert_typ T ->
  x ==> T =bs=> μ U ->
  inert_typ (μ U).
Proof.
  intros Hi Hl. gen x U. induction bs; introv Hl; inversions Hl; eauto.
  specialize (IHbs _ _ H3).
  apply (inert_record_has _ IHbs) in H5 as [Hin | [? [=]]]. auto.
Qed.

(** The [lookup_fields_typ] relation is functional. *)
Lemma lft_unique x S bs T U :
  inert_typ S ->
  x ==> S =bs=> T ->
  x ==> S =bs=> U ->
  T = U.
Proof.
  intros Hi Hl1. gen U. induction Hl1; introv Hl2.
  - inversion Hl2; auto.
  - inversions Hl2. specialize (IHHl1 Hi _ H4) as [= ->].
    pose proof (lft_inert Hi Hl1). inversions H0.
    eapply unique_rcd_trm. apply* open_record_type_p. eauto. eauto.
Qed.

(** If looking up a path in [T] yields a function type then we cannot
    look up a longer path in [T] *)
Lemma lft_typ_all_inv x S bs cs V T U:
  inert_typ S ->
  x ==> S =bs=> ∀(T) U ->
  x ==> S =cs++bs=> V ->
  cs = nil.
Proof.
  gen x S bs T U V. induction cs; introv Hin Hl1 Hl2; auto.
  rewrite <- app_comm_cons in Hl2.
  inversions Hl2. specialize (IHcs _ _ _ _ _ _ Hin Hl1 H3) as ->.
  rewrite app_nil_l in H3.
  pose proof (lft_unique Hin Hl1 H3) as [= <-].
Qed.

(** If looking up a path in [T] yields a singleton type then we cannot
    look up a longer path in [T] *)
Lemma lft_typ_sngl_inv x S bs p cs V :
  inert_typ S ->
  x ==> S =bs=> {{ p }} ->
  x ==> S =cs++bs=> V ->
  cs = nil.
Proof.
  gen x S bs p V. induction cs; introv Hin Hl1 Hl2; auto.
  rewrite <- app_comm_cons in Hl2.
  inversions Hl2. specialize (IHcs _ _ _ _ _ Hin Hl1 H3) as ->.
  rewrite app_nil_l in H3.
  pose proof (lft_unique Hin Hl1 H3) as [= <-].
Qed.

(** If the definitions [ds] that correspond to a path [p] (here, [z.bs])
    have a type [Tᵖ], and looking up the path [x.cs] for some [x]
    in [Tᵖ] yields a type [μ(U)] then nested in [ds] are some definitions
    [ds'] such that under the path [p.cs], [ds'] can be typed with [U]#p.cs#. *)
Lemma lfs_defs_typing : forall cs z bs G ds T S U,
  z; bs; G ⊢ ds :: open_typ_p (p_sel (avar_f z) bs) T ->
  inert_typ S ->
  z ==> S =bs=> μ T ->
  z ==> S =cs++bs=> μ U ->
  exists ds', z; (cs++bs); G ⊢ ds' :: open_typ_p (p_sel (avar_f z) (cs++bs)) U.
Proof.
  induction cs; introv Hds Hin Hl1 Hl2.
  - rewrite app_nil_l in*. pose proof (lft_unique Hin Hl1 Hl2) as [= ->]. eauto.
  - rewrite <- app_comm_cons in *. inversions Hl2.
    specialize (IHcs _ _ _ _ _ _ _ Hds Hin Hl1 H3) as [ds' Hds'].
    pose proof (record_has_ty_defs Hds' H5) as [d [Hdh Hd]].
    inversions Hd. eauto.
Qed.

(** Suppose the declaration [d] corresponding to a path [z.bs]
    has type [{b: V}], and that [V=...∧ {a: q.type} ∧...].
    Then [q] is well-typed.
    *)
Lemma def_typing_rhs z bs G d a q U S cs T b V :
  z; bs; G ⊢ d : {b ⦂ V} ->
  inert_typ S ->
  z ==> S =bs=> μ T ->
  record_has (open_typ_p (p_sel (avar_f z) bs) T) {b ⦂ V} ->
  z ==> S =cs++b::bs=> μ U ->
  record_has (open_typ_p (p_sel (avar_f z) (cs++b::bs)) U) {a ⦂ {{ q }}} ->
  exists W, G ⊢ trm_path q : W.
Proof.
  intros Hds Hin Hl1 Hrd Hl2 Hr. inversions Hds.
  - Case "def_all"%string.
    eapply lft_cons in Hl1; eauto.
    pose proof (lft_typ_all_inv _ Hin Hl1 Hl2) as ->.
    rewrite app_nil_l in *.
    pose proof (lft_unique Hin Hl1 Hl2) as [=].
  - Case "def_new"%string.
    pose proof (ty_def_new _ _ eq_refl H6 H7).
    assert (z ==> S =b::bs=> μ T0) as Hl1'. {
        eapply lft_cons. eauto. eauto.
    }
    pose proof (lfs_defs_typing _ H7 Hin Hl1' Hl2) as [ds' Hds'].
    pose proof (record_has_ty_defs Hds' Hr) as [d [Hdh Hd]].
    inversions Hd. eauto.
  - Case "def_path"%string.
    eapply lft_cons in Hl1; eauto.
    pose proof (lft_typ_sngl_inv _ Hin Hl1 Hl2) as ->.
    rewrite app_nil_l in *.
    pose proof (lft_unique Hin Hl1 Hl2) as [=].
Qed.

(** The same applies to the case where we type multiple declarations that contain
    [{b: V}] as a record. *)
Lemma defs_typing_rhs z bs G ds T a q U S cs T' b V :
  z; bs; G ⊢ ds :: T ->
  inert_typ S ->
  z ==> S =bs=> μ T' ->
  record_has (open_typ_p (p_sel (avar_f z) bs) T') {b ⦂ V} ->
  record_has T {b ⦂ V} ->
  z ==> S =cs++b::bs=> μ U ->
  record_has (open_typ_p (p_sel (avar_f z) (cs++b::bs)) U) {a ⦂ {{ q }}} ->
  exists V, G ⊢ trm_path q : V.
Proof.
  intros Hds Hin Hl1 Hr1 Hr2 Hl2 Hr.
  gen S a q U cs T' b V. dependent induction Hds; introv Hin; introv Hl1; introv Hl2; introv Hr Hr1 Hr2.
  - inversions Hr2. eapply def_typing_rhs; eauto.
  - specialize (IHHds _ Hin _ _ _ _ _ Hl1 _ Hl2 Hr _ Hr1).
    inversions Hr2; auto.
    inversions H4. clear IHHds.
    eapply def_typing_rhs; eauto.
Qed.

(** Looking up a path inside of a variable [x]'s environment type,
    given that we can type the path [x.bs] *)
Lemma pf_sngl_to_lft G x T bs W V :
  inert (G & x ~ μ T) ->
  G & x ~ (μ T) ⊢! p_sel (avar_f x) bs : W ⪼ V ->
  bs = nil \/
  exists b c bs' bs'' U V,
    bs = c :: bs' /\
    bs = bs'' ++ b :: nil /\
    x ==> (μ T) =bs'=> (μ U) /\
    record_has (open_typ x T) {b ⦂ V} /\
    record_has (open_typ_p (p_sel (avar_f x) bs') U) {c ⦂ W}.
Proof.
  intros Hi Hp. dependent induction Hp; eauto.
  simpl_dot. right. specialize (IHHp _ _ _ _ Hi JMeq_refl eq_refl)
    as [-> | [b [c [bs' [bs'' [S [V [-> [Hl [Hl2 [Hr1 Hr2]]]]]]]]]]].
  - Case "pf_bind"%string.
    pose proof (pf_binds Hi Hp) as ->%binds_push_eq_inv. repeat eexists; eauto.
    simpl. rewrite app_nil_l. eauto. rewrite open_var_typ_eq. eapply pf_record_has_T; eauto.
    eapply pf_record_has_T; eauto.
  - Case "pf_fld"%string.
    pose proof (pf_bnd_T2 Hi Hp) as [W ->].
    rewrite Hl.
    exists b a. eexists. exists (a :: bs''). repeat eexists; eauto.
    rewrite <- Hl. econstructor; eauto. rewrite <- Hl.
    apply* pf_record_has_T.
Qed.

(** Every value of type [T] has a precise type that is inert, well-formed,
    and is a subtype of [T]. *)
Lemma val_typing G x v T :
  inert G ->
  wf G ->
  G ⊢ trm_val v : T ->
  x # G ->
  exists T', G ⊢!v v : T' /\
        G ⊢ T' <: T /\
        inert_typ T' /\
        wf (G & x ~ T').
Proof.
  intros Hi Hwf Hv Hx. dependent induction Hv; eauto.
  - exists (∀(T) U). repeat split*. constructor; eauto. introv Hp.
    assert (binds x (∀(T) U) (G & x ~ ∀(T) U)) as Hb by auto. apply pf_bind in Hb; auto.
    destruct bs as [|b bs].
    + apply pf_binds in Hp; auto. apply binds_push_eq_inv in Hp as [=].
    + apply pf_sngl in Hp as [? [? [=]%pf_binds%binds_push_eq_inv]]; auto.
  - exists (μ T). assert (inert_typ (μ T)) as Hin. {
      apply ty_new_intro_p in H. apply* pfv_inert.
    }
    repeat split*. pick_fresh z. assert (z \notin L) as Hz by auto.
    specialize (H z Hz). assert (z # G) as Hz' by auto.
    constructor*. introv Hp.
    assert (exists W, G & x ~ (μ T) ⊢ trm_path q : W) as [W Hq]. {
      assert (inert (G & x ~ μ T)) as Hi' by eauto.
      pose proof (pf_sngl_to_lft Hi' Hp) as [-> | [b [c [bs' [bs'' [U [V [-> [Hl1 [Hl2 [Hr1 Hr2]]]]]]]]]]].
      { apply pf_binds in Hp as [=]%binds_push_eq_inv; auto. }
      assert (x; nil; G & x ~ open_typ x T ⊢ open_defs x ds :: open_typ x T)
        as Hdx%open_env_last_defs. {
        apply rename_defs with (x:=z); auto.
      }
      destruct bs'' as [|bs'h bs't].
      + rewrite app_nil_l in *. inversions Hl1. inversions Hl2.
        eapply defs_typing_sngl_rhs. apply Hdx. rewrite* open_var_typ_eq.
      + rewrite <- app_comm_cons in Hl1. inversions Hl1.
        eapply defs_typing_rhs.
        apply Hdx.
        apply Hin.
        eauto.
        rewrite open_var_typ_eq in Hr1. apply Hr1.
        auto.
        apply Hl2.
        apply Hr2.
      + auto.
    }
    apply pt3_exists in Hq as [? Hq'%pt2_exists]; auto.
  - specialize (IHHv _ Hi Hwf eq_refl Hx). destruct_all. eexists; split*.
Qed.

(** Helper tactics for proving Preservation *)

Ltac lookup_eq :=
  match goal with
  | [Hl1: ?s ⟦ _ ⤳* defv ?t1 ⟧,
     Hl2: ?s ⟦ _ ⤳* defv ?t2 ⟧ |- _] =>
     apply (lookup_func Hl1) in Hl2; inversions Hl2
  end.

Ltac invert_red :=
  match goal with
  | [Hr: (_, _) ⟼ (_, _) |- _] => inversions Hr
  end.

Ltac solve_IH :=
  match goal with
  | [IH: _ ⫶ _ ->
         inert _ ->
         wf _ ->
         forall t', (_, _) ⟼ (_, _) -> _,
       Wt: _ ⫶ _,
       In: inert _,
       Wf: wf _,
       Hr: (_, _) ⟼ (_, ?t') |- _] =>
    specialize (IH Wt In Wf t' Hr); destruct_all
  end;
  match goal with
  | [Hi: _ & ?G' ⊢ _ : _ |- _] =>
    exists G'; repeat split; auto
  end.

Ltac solve_let :=
  invert_red; solve_IH; fresh_constructor; eauto; apply* weaken_rules.

(** **** Preservation (Lemma 5.4) *)
(** If a term [γ|t] has type [T] and reduces to [γ'|t'] then the latter has
    the same type [T] under an extended environment that is inert, well-typed,
    and well-formed. *)
Lemma preservation: forall G γ t γ' t' T,
    γ ⫶ G ->
    inert G ->
    wf G ->
    (γ, t) ⟼ (γ', t') ->
    G ⊢ t : T ->
    exists G', inert G' /\
          wf (G & G') /\
          γ' ⫶ G & G' /\
          G & G' ⊢ t' : T.
Proof.
  introv Hwt Hi Hwf Hred Ht. gen t'.
  induction Ht; intros; try solve [invert_red].
  - Case "ty_all_elim"%string.
    match goal with
    | [Hp: _ ⊢ trm_path _ : ∀(_) _ |- _] =>
        pose proof (canonical_forms_fun Hi Hwf Hwt Hp) as [L [T' [t [Hl [Hsub Hty]]]]];
        invert_red
    end.
    lookup_eq.
    exists (@empty typ). rewrite concat_empty_r. repeat split; auto.
    pick_fresh y. assert (y \notin L) as FrL by auto. specialize (Hty y FrL).
    eapply subst_var_path; eauto. eauto. eauto.
  - Case "ty_let"%string.
    destruct t; try solve [solve_let].
     + SCase "[t = (let x = v in u)] where v is a value"%string.
      repeat invert_red.
      match goal with
        | [Hn: ?x # ?s |- _] =>
          pose proof (well_typed_notin_dom Hwt Hn) as Hng
      end.
      pose proof (val_typing Hi Hwf Ht Hng) as [V [Hv [Hs [Hin Hwf']]]].
      exists (x ~ V). repeat split; auto.
      ** rewrite <- concat_empty_l. constructor~.
      ** constructor~. apply (precise_to_general_v Hv).
      ** rewrite open_var_trm_eq. eapply subst_fresh_var_path with (L:=L \u dom G \u \{x}). apply* ok_push.
         intros. apply* weaken_rules. apply ty_sub with (T:=V); auto. apply* weaken_subtyp.
    + SCase "[t = (let x = p in u)] where a is p variable"%string.
      repeat invert_red.
      exists (@empty typ). rewrite concat_empty_r. repeat split; auto.
      apply* subst_fresh_var_path.
  - Case "ty_sub"%string.
    solve_IH.
    match goal with
    | [Hs: _ ⊢ _ <: _,
       Hg: _ & ?G' ⊢ _: _ |- _] =>
      apply weaken_subtyp with (G2:=G') in Hs;
      eauto
    end.
Qed.

(** **** Progress (Lemma 5.3) *)
(** Any well-typed term is either in normal form (i.e. a path or value) or can
    take a reduction step. *)
Lemma progress: forall G γ t T,
    inert G ->
    wf G ->
    γ ⫶ G ->
    G ⊢ t : T ->
    norm_form t \/ exists γ' t', (γ, t) ⟼ (γ', t').
Proof.
  introv Hi Hwf Hwt Ht.
  induction Ht; eauto.
  - Case "ty_all_elim"%string.
    pose proof (canonical_forms_fun Hi Hwf Hwt Ht1). destruct_all. right*.
  - Case "ty_let"%string.
    right. destruct t; eauto.
    + pick_fresh z. exists (γ & z ~ v). eauto.
    + specialize (IHHt Hi Hwf Hwt) as [Hn | [γ' [t' Hr]]].
      { inversion Hn. } eauto.
    + specialize (IHHt Hi Hwf Hwt) as [Hn | [γ' [t' Hr]]].
      { inversion Hn. } eauto.
Qed.

(** *** Safety *)

(** If a term [γ|t] has type [T] and reduces in a finite number of steps
    to [γ'|t'] then the latter is either in normal form and has type [T],
    or it can take a further step to a term [γ''|t''], where [t''] also
    has type [T]. *)
Lemma safety_helper G t1 t2 γ1 γ2 T :
  G ⊢ t1 : T ->
  inert G ->
  wf G ->
  γ1 ⫶ G ->
  (γ1, t1) ⟼* (γ2, t2) ->
  (exists γ3 t3 G3, (γ2, t2) ⟼ (γ3, t3) /\
               G3 ⊢ t3 : T /\
               γ3 ⫶ G3 /\
               wf G3 /\
               inert G3) \/
  (exists G2, norm_form t2 /\ G2 ⊢ t2 : T /\
               γ2 ⫶ G2 /\
               wf G2 /\
               inert G2).
Proof.
  intros Ht Hi Hwf Hwt Hr. gen G T. dependent induction Hr; introv Hi Hwf Hwt; introv Ht.
  - pose proof (progress Hi Hwf Hwt Ht) as [Hn | [γ' [t' Hr]]].
    right. exists G. eauto.
    left. pose proof (preservation Hwt Hi Hwf Hr Ht) as [G' [Hi' [Hwf' [Hwt' Ht']]]].
    exists γ' t' (G & G'). repeat split*. apply* inert_concat.
  - destruct b as [γ12 t12]. specialize (IHHr _ _ _ _ eq_refl eq_refl).
    pose proof (preservation Hwt Hi Hwf H Ht) as [G' [Hi' [Hwf' [Hwt' Ht']]]].
    specialize (IHHr _ (inert_concat Hi Hi' (well_typed_to_ok_G Hwt'))).
    eauto.
Qed.

Definition diverges := infseq red.
Definition cyclic_path γ p := infseq (lookup_step γ) (defp p).

(** **** Type Soundness (Theorem 5.1) *)
(** Reducing any well-typed program (i.e. term that can be typed in an empty context)
    results either
    - in a normal form (i.e. path or value) in a finite number of steps,
    - in an infinite reduction sequence. *)
Theorem safety t T :
  empty ⊢ t : T ->
  diverges (empty, t) \/
  (exists γ u G, (empty, t) ⟼* (γ, u) /\
            norm_form u /\
            G ⊢ u : T /\
            γ ⫶ G /\
            wf G /\
            inert G).
Proof.
  intros Ht.
  pose proof (infseq_or_finseq red (empty, t)) as [? | [[s u] [Hr Hn]]]; eauto.
  right. epose proof (safety_helper Ht inert_empty wfe_empty well_typed_empty Hr)
    as [[γ' [t' [G' [Hr' [Ht' Hwt]]]]] | [G [Hn' [Ht' [Hwt [Hwf Hi]]]]]].
  - false* Hn.
  - repeat eexists; eauto.
Qed.

End Safety.

(** ** Safety wrt Path Lookup ⤳ *)
Section PathSafety.

  (** Looking up any well-typed path in the value environment results either
    - in a value in a finite number of steps, or
    - in an infinite sequence of lookup operations, i.e. the path is cyclic *)
  Lemma path_safety G p T γ :
    inert G ->
    wf G ->
    γ ⫶ G ->
    G ⊢ trm_path p : T ->
    cyclic_path γ p \/ exists v, γ ⟦ defp p ⤳* defv v ⟧.
  Proof.
    intros Hi Hwf Hwt Hp.
    proof_recipe. apply repl_prec_exists in Hp as [U Hp].
    pose proof (infseq_or_finseq (lookup_step γ) (defp p)) as [? | [t [Hl Hirr]]]; eauto.
    right. destruct t; eauto.
    pose proof (lookup_pres Hi Hwf Hwt Hp Hl) as [S Hq].
    pose proof (typ_to_lookup3 Hi Hwf Hwt Hq) as [t Hl'].
    false* Hirr.
  Qed.

End PathSafety.

(** ** Extended Safety *)

Section ExtendedSafety.

  (** Extended reduction relation (combines term reduction ⟼ and lookup ⤳) *)
  Reserved Notation "t '↠' u" (at level 40).

  Inductive extended_red : sta * trm -> sta * trm -> Prop :=
  | er_red γ γ' t t':
      (γ, t) ⟼ (γ', t') ->
      (γ, t) ↠ (γ', t')
  | er_lookup γ p t:
      γ ⟦ p ⤳ t ⟧ ->
      (γ, trm_path p) ↠ (γ, deftrm t)
  where "t ↠ u" := (extended_red t u).

  Hint Constructors extended_red.

  (** Reflexive transitive closure of extended reduction *)
  Notation "t '↠*' u" := ((star extended_red) t u) (at level 40).

  (** Divergence of extended reduction *)
  Definition diverges' := infseq extended_red.

  Lemma extend_infseq γ t γ' t' :
        diverges' (γ, t) ->
        (γ', t') ↠* (γ, t) ->
        diverges' (γ', t').
  Proof.
    intros Hinf Hr. dependent induction Hr; auto.
    destruct b. specialize (IHHr _ _ _ _ Hinf eq_refl eq_refl).
    econstructor. apply H. auto.
  Qed.

  Lemma map_red_extend γ t γ' t':
    (γ, t) ⟼* (γ', t') ->
    (γ, t) ↠* (γ', t').
  Proof.
    intros Hr. dependent induction Hr; try destruct b; eauto.
  Qed.

  Lemma map_lookup_extend γ t t':
    star (lookup_step γ) t t' ->
    (γ, deftrm t) ↠*(γ, deftrm t').
  Proof.
    intros Hr. dependent induction Hr; eauto.
    destruct a. eapply star_trans. apply star_one. apply* er_lookup.
    auto. inversion H.
  Qed.

  (** **** Extended Soundness (Theorem 5.2) *)
  (** Reducing any well-typed program (i.e. term that can be typed in an empty context)
      using the extended reduction relation (that includes term reduction and path lookup)
      results either
      - in a value in a finite number of steps, or
      - in an infinite reduction sequence. *)
  Theorem extended_safety t T :
    empty ⊢ t : T ->
    diverges' (empty, t) \/ exists γ v, (empty, t) ↠* (γ, trm_val v).
  Proof.
    intros Ht. pose proof (safety Ht) as [Hd | [γ [u [G [Hr [Hn [Hu [Hwt [Hwf Hi]]]]]]]]].
    - Case "term diverges"%string.
      left. inversions Hd. inversions H0. apply infseq_step with (b:=b); destruct b; auto.
      destruct b0. econstructor. apply er_red. apply H1.
      apply infseq_coinduction_principle with
          (X := fun st => exists γ1 t1,
                    st = (γ1, t1) /\ infseq red (γ1, t1)).
      intros st [γ' [t' [-> Hinf]]].
      + inversions Hinf. destruct b. eexists; split*.
      + eauto.
    - Case "term evaluates to normal form"%string.
      inversions Hn.
      + SCase "term evaluates to a path"%string.
        pose proof (path_safety Hi Hwf Hwt Hu) as [Hd | Hn].
        * SSCase "path lookup diverges"%string.
          left. assert (infseq extended_red (γ, trm_path p)). {
            clear Hwf Hwt Hr Hu Ht Hi G T t.
            apply infseq_coinduction_principle with
                (X := fun st => exists u, st = (γ, deftrm u) /\ infseq (lookup_step γ) u).
            + intros st [du [-> Hinf]].
              inversions Hinf. destruct b, du; try solve [inversion H].
              eexists; split*; apply* er_lookup.
              inversions H0. inversion H1.
            + eexists. split*. simpl. auto.
          }
          assert (star extended_red (empty, t) (γ, trm_path p)). {
            apply* map_red_extend.
          }
          apply* extend_infseq.
        * SSCase "path looks up to value"%string.
          destruct Hn as [v Hv]. right. exists γ v.
          eapply star_trans. eapply map_red_extend. eauto.
          apply map_lookup_extend in Hv. eauto.
      + SCase "term evaluates to a value"%string.
        right. exists γ v. apply* map_red_extend.
  Qed.

End ExtendedSafety.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e129m25_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e166m5_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m481_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e129m25_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e166m5_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e321m9_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.