Require Import Logic.Axiom.LEM.

Require Import Logic.Fol.Syntax.

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Equal.

Require Import Logic.Lang1.Syntax.
Require Import Logic.Lang1.Context.
Require Import Logic.Lang1.SemanCtx.
Require Import Logic.Lang1.Semantics.
Require Import Logic.Lang1.Environment.

Open Scope Set_Incl_scope.

(* Lemma 'inclRefl' expressed in set theory abstract syntax.                    *)
Definition inclReflF (n:nat) : Formula := All n (Sub n n).

(* The intent is to provide some validation to our semantics by going through   *)
(* several key set theoretic results and proving the equivalence between the    *)
(* evaluated abstract syntax and the corresponding Coq statement. However, the  *)
(* value of such exercise is limited as a Coq equivalence 'A <-> B' can always  *)
(* be proved whenever A and B are themselves provable. So 'A <-> B' does not in *)
(* itself prove that the propositions A and B are the 'same'. For our defense,  *)
(* we are proving the equivalence 'A <-> B' without using any result which      *)
(* asserts A or B. In particular, we make no use of the lemma 'inclRefl'.       *)
(* With this caveat in mind, we assert that evaluating inclReflF in any         *)
(* environment (and for any choice of variable name 'n') yields a proposition   *)
(* which is equivalent to the lemma inclRefl.                                   *)
Import Semantics.
Lemma evalInclReflF : forall (e:Env) (n:nat),
    eval e (inclReflF n) <-> forall (x:set), x <= x.
Proof.
    intros e n. unfold inclReflF. rewrite evalAll. split; intros H x.
    - remember (H x) as H' eqn:E. clear E.
      rewrite evalSub in H'.
        + rewrite bindSame in H'. assumption.
    - rewrite evalSub.
        + rewrite bindSame. apply H.
Qed.

Import SemanCtx.
Lemma evalInclReflFCtx : forall (G:Context) (n:nat),
    G :- (inclReflF n) >> forall (x:set), x <= x.
Proof.
    intros G n. unfold inclReflF.
    apply evalAll. intros x. apply evalSub; apply FindZ.
Qed.

(* An approximation of lemma 'inclNil' expressed in set theory abstract syntax. *)
(* This formulation is correct when variables n and m are distinct.             *)
Definition inclNilF (n m:nat) : Formula :=
    All n (Imp (Empty n) (All m (Sub n m))).

Import Semantics.
(* Evaluating  inclNilF in any environment 'yields' the lemma inclNil.          *)
Lemma evalInclNilF : forall (e:Env) (n m:nat),
    m <> n ->
    eval e (inclNilF n m )
        <->
    forall (x:set), x == Nil -> forall (y:set), x <= y.
Proof.
    intros e n m Hmn. unfold inclNilF. rewrite evalAll. split; intros H x.
    - remember (H x) as H' eqn:E. clear E H. rewrite evalImp in H'.
      rewrite evalEmpty in H'. rewrite bindSame in H'. intro H.
      remember (H' H) as H0 eqn:E. clear E H H'. rewrite evalAll in H0.
      intros y. remember (H0 y) as H eqn:E. clear E H0.
      rewrite evalSub in H. rewrite bindSame in H. rewrite bindDiff in H.
      rewrite bindSame in H.
        + assumption.
        + assumption.
    - rewrite evalImp, evalEmpty, bindSame, evalAll. intros H' y.
      rewrite evalSub, bindSame, bindDiff, bindSame. apply H.
        + assumption.
        + assumption.
Qed.

Import SemanCtx.
Lemma evalInclNilFCtx : LEM -> forall (G:Context) (n m:nat),
    n <> m ->
    G :- (inclNilF n m )  >>
        forall (x:set), x == Nil -> forall (y:set), x <= y.
Proof.
    intros L G n m H1. unfold inclNilF.
    apply evalAll. intros x. apply evalImp.
    - apply evalEmpty, FindZ.
    - apply evalAll. intros y. apply evalSub; try (apply FindZ).
      apply FindS; try assumption. apply FindZ.
Qed.


(** * Finite Modular Maps: RBT Proofs *)

(** Author: Pierre Letouzey (Université de Paris - INRIA),
    adapted from earlier works in Coq Standard Library, see README.md.
    License: LGPL-2.1-only, see file LICENSE. *)

(** This is a complement to [MMaps.RBT], proving the Red/Black balancing
    invariants for the code in [MMaps.RBT], and hence the logarithmic
    depth bound. These extra proofs are not even loaded during a regular
    usage of [MMaps.RBT], which already provides proofs of observational
    correctness (the binary search tree invariants).

    This is an adapation of Coq [MSetRBT.BalanceProps] to maps. *)

From Coq Require Import Bool BinPos Pnat Setoid SetoidList Arith.
From Coq Require Import Orders OrdersFacts OrdersLists.
From MMaps Require Import Interface GenTree RBT.

Local Set Implicit Arguments.
Local Unset Strict Implicit.
Import ListNotations.

(* For nicer extraction, we create inductive principles
   only when needed *)
Local Unset Elimination Schemes.

Module BalanceProps(K:OrderedType).
Include MMaps.RBT.MakeRaw K.
Import GenTree.PairNotations. (* #1 and #2 for fst and snd *)
Local Open Scope lazy_bool_scope.
Local Notation color := Color.t.
Local Arguments Leaf {elt}.
Local Notation Rd := (@Node _ Red).
Local Notation Bk := (@Node _ Black).

(** ** Red-black invariants *)

(** In a red-black tree :
    - a red node has no red children
    - the black depth at each node is the same along all paths.
    The black depth is here an argument of the predicate. *)

Inductive rbt elt : nat -> tree elt -> Prop :=
 | RB_Leaf : rbt 0 Leaf
 | RB_Rd n l k e r :
   notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k e r)
 | RB_Bk n l k e r : rbt n l -> rbt n r -> rbt (S n) (Bk l k e r).

(** A red-red tree is almost a red-black tree, except that it has
    a _red_ root node which _may_ have red children. Note that a
    red-red tree is hence non-empty, and all its strict subtrees
    are red-black. *)

Inductive rrt elt (n:nat) : tree elt -> Prop :=
 | RR_Rd l k e r : rbt n l -> rbt n r -> rrt n (Rd l k e r).

(** An almost-red-black tree is almost a red-black tree, except that
    it's permitted to have two red nodes in a row at the very root (only).
    We implement this notion by saying that a quasi-red-black tree
    is either a red-black tree or a red-red tree. *)

Inductive arbt elt (n:nat)(t:tree elt) : Prop :=
 | ARB_RB : rbt n t -> arbt n t
 | ARB_RR : rrt n t -> arbt n t.

(** The main exported invariant : being a red-black tree for some
    black depth. *)

Class Rbt elt (t:tree elt) :=  RBT : exists d, rbt d t.

(** ** Basic tactics and results about red-black trees *)

Scheme rbt_ind := Induction for rbt Sort Prop.
Local Hint Constructors rbt rrt arbt : map.
Local Hint Extern 0 (notred _) => (exact I) : map.
Ltac invrb := intros; inv rrt; inv rbt; try contradiction.
Ltac descolor := destruct_all Color.t.
Ltac destree t := destruct t as [|[|] ? ? ? ?].
Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end.
Ltac nonzero n := destruct n as [|n]; [try split; invrb|].

Notation notredred := (rrcase (fun _ _ _ _ _ _ _ => False) (fun _ => True)).

Section Elt.
Variable elt : Type.
Implicit Type t s l r : tree elt.
Implicit Type e v : elt.

Lemma rr_nrr_rb n t :
 rrt n t -> notredred t -> rbt n t.
Proof.
 destruct 1 as [l x e r Hl Hr].
 unfold rrcase; destmatch; now autom.
Qed.

Local Hint Resolve rr_nrr_rb : map.

Lemma arb_nrr_rb n t :
 arbt n t -> notredred t -> rbt n t.
Proof.
 destruct 1; autom.
Qed.

Lemma arb_nr_rb n t :
 arbt n t -> notred t -> rbt n t.
Proof.
 destruct 1; destruct t; descolor; invrb; autom.
Qed.

Local Hint Resolve arb_nrr_rb arb_nr_rb : map.

(** ** A red-black tree has a logarithmic depth *)

Definition redcarac s :=
 rcase (elt:=elt) (fun _ _ _ _ => 1) (fun _ => 0) s.

Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s.
Proof.
 induction 1.
 - simpl; auto.
 - replace (redcarac l) with 0 in * by now destree l.
   replace (redcarac r) with 0 in * by now destree r.
   simpl maxdepth. simpl redcarac.
   rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
   now apply Nat.max_lub.
 - simpl. rewrite <- Nat.succ_le_mono.
   apply Nat.max_lub; eapply Nat.le_trans; eauto;
   [destree l | destree r]; simpl;
   rewrite !Nat.add_0_r, ?Nat.add_1_r; auto with arith.
Qed.

Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s.
Proof.
 induction 1; simpl.
 - trivial.
 - rewrite Nat.add_succ_r.
   apply -> Nat.succ_le_mono.
   replace (redcarac l) with 0 in * by now destree l.
   replace (redcarac r) with 0 in * by now destree r.
   now apply Nat.min_glb.
 - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r.
   apply Nat.min_glb; eauto with arith.
Qed.

Lemma maxdepth_upperbound s : Rbt s ->
 maxdepth s <= 2 * Nat.log2 (S (cardinal s)).
Proof.
 intros (n,H).
 eapply Nat.le_trans; [eapply rb_maxdepth; eauto|].
 transitivity (2*(n+redcarac s)).
 - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l.
   rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r.
   auto with arith.
 - apply Nat.mul_le_mono_l.
   transitivity (mindepth s).
   + now apply rb_mindepth.
   + apply mindepth_log_cardinal.
Qed.

Lemma maxdepth_lowerbound s : s<>Leaf ->
 Nat.log2 (cardinal s) < maxdepth s.
Proof.
 apply maxdepth_log_cardinal.
Qed.

(** ** Singleton *)

Lemma singleton_rb x e : Rbt (singleton x e).
Proof.
 unfold singleton. exists 1; autom.
Qed.

(** ** makeBlack and makeRed *)

Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t).
Proof.
 destruct t as [|[|] l x e r].
 - exists 0; simpl; autom.
 - destruct 1; invrb; exists (S n); simpl; autom.
 - exists n; autom.
Qed.

Lemma makeRed_rr t n :
 rbt (S n) t -> notred t -> rrt n (makeRed t).
Proof.
 destruct t as [|[|] l x e r]; invrb; simpl; autom.
Qed.

(** ** Balancing *)

Lemma lbal_rb n l k e r :
 arbt n l -> rbt n r -> rbt (S n) (lbal l k e r).
Proof.
case lbal_match; intros; desarb; invrb; autom.
Qed.

Lemma rbal_rb n l k e r :
 rbt n l -> arbt n r -> rbt (S n) (rbal l k e r).
Proof.
case rbal_match; intros; desarb; invrb; autom.
Qed.

Lemma rbal'_rb n l k e r :
 rbt n l -> arbt n r -> rbt (S n) (rbal' l k e r).
Proof.
case rbal'_match; intros; desarb; invrb; autom.
Qed.

Lemma lbalS_rb n l x e r :
 arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x e r).
Proof.
 intros Hl Hr Hr'.
 destruct r as [|[|] rl rx rv rr]; invrb. clear Hr'.
 revert Hl.
 case lbalS_match.
 - destruct 1; invrb; autom.
 - intros. apply rbal'_rb; autom.
Qed.

Lemma lbalS_arb n l x e r :
 arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x e r).
Proof.
 case lbalS_match.
 - destruct 1; invrb; autom.
 - clear l. intros l Hl Hl' Hr.
   destruct r as [|[|] rl rx rv rr]; invrb.
   * destruct rl as [|[|] rll rlx rlv rlr]; invrb.
     right; auto using rbal'_rb, makeRed_rr with map.
   * left; apply rbal'_rb; autom.
Qed.

Lemma rbalS_rb n l x e r :
 rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x e r).
Proof.
 intros Hl Hl' Hr.
 destruct l as [|[|] ll lx lv lr]; invrb. clear Hl'.
 revert Hr.
 case rbalS_match.
 - destruct 1; invrb; autom.
 - intros. apply lbal_rb; autom.
Qed.

Lemma rbalS_arb n l x e r :
 rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x e r).
Proof.
 case rbalS_match.
 - destruct 2; invrb; autom.
 - clear r. intros r Hr Hr' Hl.
   destruct l as [|[|] ll lx lv lr]; invrb.
   * destruct lr as [|[|] lrl lrx lrv lrr]; invrb.
     right; auto using lbal_rb, makeRed_rr with map.
   * left; apply lbal_rb; autom.
Qed.

(** ** Insertion *)

(** The next lemmas combine simultaneous results about rbt and arbt.
    A first solution here: statement with [if ... then ... else] *)

Definition ifred s (A B:Prop) := rcase (fun _ _ _ _ => A) (fun _ => B) s.

Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B).
Proof.
 destruct s; descolor; simpl; intuition.
Qed.

Lemma ifred_or s A B : ifred s A B -> A\/B.
Proof.
 destruct s; descolor; simpl; intuition.
Qed.

Lemma ins_rr_rb x e s n : rbt n s ->
 ifred s (rrt n (ins x e s)) (rbt n (ins x e s)).
Proof.
induction 1 as [ | n l k v r | n l k v r Hl IHl Hr IHr ].
- simpl; autom.
- simpl. rewrite ifred_notred in * by trivial.
  destmatch; autom.
- rewrite ifred_notred by autom.
  cbn. destmatch; intro.
  * autom.
  * apply lbal_rb; trivial. apply ifred_or in IHl; intuition (auto with map).
  * apply rbal_rb; trivial. apply ifred_or in IHr; intuition (auto with map).
Qed.

Lemma ins_arb x e s n : rbt n s -> arbt n (ins x e s).
Proof.
 intros H. apply (ins_rr_rb x e), ifred_or in H. intuition (auto with map).
Qed.

#[export] Instance add_rb x e s : Rbt s -> Rbt (add x e s).
Proof.
 intros (n,H). unfold add. now apply (@makeBlack_rb n), ins_arb.
Qed.

(** ** Deletion *)

(*TODO: share with RBT *)

Ltac append_tac l r :=
 induction l as [| lc ll _ lx lv lr IHlr];
 [intro r; simpl
 |induction r as [| rc rl IHrl rx rv rr _];
   [simpl
   |destruct lc, rc;
     [specialize (IHlr rl); clear IHrl
     |simpl;
      assert (Hr:notred (Bk rl rx rv rr)) by (simpl; trivial);
      set (r:=Bk rl rx rv rr) in *; clearbody r; clear IHrl rl rx rv rr;
      specialize (IHlr r)
     |change (append _ _) with (Rd (append (Bk ll lx lv lr) rl) rx rv rr);
      assert (Hl:notred (Bk ll lx lv lr)) by (simpl; trivial);
      set (l:=Bk ll lx lv lr) in *; clearbody l; clear IHlr ll lx lv lr
     |specialize (IHlr rl); clear IHrl]]].

Fact append_rr_match ll lx lv lr rl rx rv rr :
 rspec
  (fun a x e b => Rd (Rd ll lx lv a) x e (Rd b rx rv rr))
  (fun t => Rd ll lx lv (Rd t rx rv rr))
  (append lr rl)
  (append (Rd ll lx lv lr) (Rd rl rx rv rr)).
Proof.
 exact (rmatch _ _ _).
Qed.

Fact append_bb_match ll lx lv lr rl rx rv rr :
 rspec
  (fun a x e b => Rd (Bk ll lx lv a) x e (Bk b rx rv rr))
  (fun t => lbalS ll lx lv  (Bk t rx rv rr))
  (append lr rl)
  (append (Bk ll lx lv lr) (Bk rl rx rv rr)).
Proof.
 exact (rmatch _ _ _).
Qed.

(** A second approach here: statement with ... /\ ... *)

Lemma append_arb_rb n l r : rbt n l -> rbt n r ->
 (arbt n (append l r)) /\
 (notred l -> notred r -> rbt n (append l r)).
Proof.
revert r n.
append_tac l r.
- split; autom.
- split; autom.
- (* Red / Red *)
  intros n. invrb.
  case (IHlr n); auto; clear IHlr.
  case append_rr_match.
  + intros a x v b _ H; split; invrb.
    assert (rbt n (Rd a x v b)) by autom. invrb. autom.
  + split; invrb; autom.
- (* Red / Black *)
  split; invrb. destruct (IHlr n) as (_,IH); autom.
- (* Black / Red *)
  split; invrb. destruct (IHrl n) as (_,IH); autom.
- (* Black / Black *)
  nonzero n.
  invrb.
  destruct (IHlr n) as (IH,_); auto; clear IHlr.
  revert IH.
  case append_bb_match.
  + intros a x v b IH; split; destruct IH; invrb; autom.
  + split; [left | invrb]; auto using lbalS_rb with map.
Qed.

Ltac induct' m :=
 induction m as [|c l IHl x' vx' r IHr]; simpl; intros;
 [|case K.compare_spec; intros].

(** A third approach : Lemma ... with ... *)

Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s)
with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s).
Proof.
{ revert n.
  induct' s; descolor; try easy; invrb.
  - apply append_arb_rb; assumption.
  - assert (IHl' := del_rb l x). clear IHr del_arb del_rb.
    destruct l as [|[|] ll lx lv lr]; autom.
    nonzero n. apply lbalS_arb; autom.
  - assert (IHr' := del_rb r x). clear IHl del_arb del_rb.
    destruct r as [|[|] rl rx rv rr]; autom.
    nonzero n. apply rbalS_arb; auto. }
{ revert n.
  induct' s; descolor; try easy; invrb.
  - apply append_arb_rb; assumption.
  - assert (IHl' := del_arb l x). clear IHr del_arb del_rb.
    destruct l as [|[|] ll lx lv lr]; autom.
    nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; autom.
  - assert (IHr' := del_arb r x). clear IHl del_arb del_rb.
    destruct r as [|[|] rl rx rv rr]; autom.
    nonzero n. apply rbalS_rb; auto. }
Qed.

#[export] Instance remove_rb s x : Rbt s -> Rbt (remove x s).
Proof.
 intros (n,H). unfold remove.
 destruct s as [|[|] l y v r].
 - apply (@makeBlack_rb n). autom.
 - apply (@makeBlack_rb n). left. apply del_rb; simpl; autom.
 - nonzero n. apply (@makeBlack_rb n). apply del_arb; simpl; autom.
Qed.

(** ** Treeify *)

Local Notation ifpred p n := (if p then pred n else n%nat).
Local Notation treeify_t := (klist elt -> tree elt * klist elt).

Definition treeify_rb_invariant size depth (f:treeify_t) :=
 forall acc,
 size <= length acc ->
  rbt depth (fst (f acc)) /\
  size + length (snd (f acc)) = length acc.

Lemma treeify_zero_rb : treeify_rb_invariant 0 0 (@treeify_zero elt).
Proof.
 intros acc _; simpl; autom.
Qed.

Lemma treeify_one_rb : treeify_rb_invariant 1 0 (@treeify_one elt).
Proof.
 intros [|(x,e) acc]; simpl; autom; inversion 1.
Qed.

Lemma treeify_cont_rb f g size1 size2 size d :
 treeify_rb_invariant size1 d f ->
 treeify_rb_invariant size2 d g ->
 size = S (size1 + size2) ->
 treeify_rb_invariant size (S d) (treeify_cont f g).
Proof.
 intros Hf Hg H acc Hacc.
 unfold treeify_cont.
 specialize (Hf acc).
 destruct (f acc) as (l, acc1). simpl in *.
 destruct Hf as (Hf1, Hf2). { subst. eauto with arith. }
 destruct acc1 as [|(x,e) acc2]; simpl in *.
 - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2.
   auto with arith.
 - specialize (Hg acc2).
   destruct (g acc2) as (r, acc3). simpl in *.
   destruct Hg as (Hg1, Hg2).
   { revert Hacc.
     rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono.
     apply Nat.add_le_mono_l. }
   split; autom.
   now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc.
Qed.

Lemma treeify_aux_rb n :
 exists d, forall (b:bool),
  treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n).
Proof.
 induction n as [n (d,IHn)|n (d,IHn)| ].
 - exists (S d). intros b.
   eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ].
   rewrite Pos2Nat.inj_xI.
   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
   destruct b; simpl; intros; rewrite Nat.add_0_r; trivial.
   now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial.
 - exists (S d). intros b.
   eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ].
   rewrite Pos2Nat.inj_xO.
   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
   rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial.
   destruct b; simpl; intros; rewrite Nat.add_0_r; trivial.
   symmetry. now apply Nat.add_pred_l.
 - exists 0; destruct b;
    [ apply treeify_zero_rb | apply treeify_one_rb ].
Qed.

(** The black depth of [treeify l] is actually a log2, but
    we don't need to mention that. *)

#[export] Instance treeify_rb (l:klist elt) : Rbt (treeify l).
Proof.
 unfold treeify.
 destruct (treeify_aux_rb (plength l)) as (d,H).
 exists d.
 apply H.
 now rewrite plength_spec.
Qed.

#[export] Instance filter_rb (f:key->elt->bool) m : Rbt m -> Rbt (filter f m).
Proof.
 unfold filter. intros. apply treeify_rb.
Qed.

#[export] Instance partition_rb1 (f:key->elt->bool) m :
 Rbt m -> Rbt (fst (partition f m)).
Proof.
 unfold partition. intros. destruct partition_aux. apply treeify_rb.
Qed.

#[export] Instance partition_rb2 (f:key->elt->bool) m :
 Rbt m -> Rbt (snd (partition f m)).
Proof.
 unfold partition. intros. destruct partition_aux. apply treeify_rb.
Qed.

End Elt.

#[export] Instance map_rb {elt elt'}(f:elt->elt') m : Rbt m -> Rbt (map f m).
Proof.
 intros (n,H). exists n. induction H; simpl; constructor; auto.
 destruct l; auto.
 destruct r; auto.
Qed.

#[export] Instance mapi_rb {elt elt'}(f:key->elt->elt') m : Rbt m -> Rbt (mapi f m).
Proof.
 intros (n,H). exists n. induction H; simpl; constructor; auto.
 destruct l; auto.
 destruct r; auto.
Qed.

#[export] Instance merge_rb {elt elt' elt''}
 (f:key -> option elt -> option elt' -> option elt'') m m' :
 Rbt m -> Rbt m' -> Rbt (merge f m m').
Proof.
 unfold merge. intros. apply treeify_rb.
Qed.

End BalanceProps.

(** We could hence define [Ok m] as [Bst m /\ Rbt m] and re-validate
    the [Raw.S] signature. This would be more robust in case new ops
    are added in the signature. But that would be yet another wrapper,
    so we don't do it for the moment. *)


From Hammer Require Import Hammer.

Require Import Arith.
From Lambda Require Import Terms.
From Lambda Require Import Reduction.
From Lambda Require Import Redexes.
From Lambda Require Import Test.

Fixpoint mark (e : lambda) : redexes :=
match e with
| Ref n => Var n
| Abs M => Fun (mark M)
| App M N => Ap false (mark M) (mark N)
end.

Fixpoint unmark (e : redexes) : lambda :=
match e with
| Var n => Ref n
| Fun U => Abs (unmark U)
| Ap b U V => App (unmark U) (unmark V)
end.

Lemma inverse : forall M : lambda, M = unmark (mark M).
Proof. hammer_hook "Marks" "Marks.inverse".
simple induction M; simpl in |- *; trivial; simple induction 1; trivial.
simple induction 1; trivial.
Qed.

Lemma comp_unmark_eq : forall U V : redexes, comp U V -> unmark U = unmark V.
Proof. hammer_hook "Marks" "Marks.comp_unmark_eq".
simple induction 1; simpl in |- *; trivial.
simple induction 2; trivial.
simple induction 2; simple induction 2; trivial.
Qed.


Require Import IntuitionisticLogic.base.
Import LogicNotation.
Local Open Scope IPC_scope.

Section TrivialSemantic.

Context {venv: Var_env}.

Fixpoint denote (f: Var -> Prop) (t: Term) : Prop :=
  match t with
  | andp t1 t2 => denote f t1 /\ denote f t2
  | orp t1 t2 => denote f t1 \/ denote f t2
  | impp t1 t2 => denote f t1 -> denote f t2
  | falsep => False
  | varp x => f x
  end.

Definition Trivial_sem: Semantic := mk_sem (Var -> Prop) denote.

End TrivialSemantic.

Require Import IntuitionisticLogic.IPC.

Lemma sound_Trivial_IPC: forall {venv: Var_env}, sound Trivial_sem IPC.
Proof.
  unfold sound.
  intros.
  induction H; intros M CONTEXT.
  + apply CONTEXT.
    auto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    tauto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    specialize (IHIPC_derive2 M CONTEXT).
    simpl in IHIPC_derive1, IHIPC_derive2 |- *.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    destruct IHIPC_derive1.
    - assert (CONTEXT_a: forall t0 : Term, (ctx;; a) t0 = true -> M |= t0).
      Focus 1. {
        intros.
        unfold ExtendContext in H3.
        destruct (term_eq t0 a).
        + subst; exact H2.
        + apply CONTEXT; auto.
      } Unfocus.
      exact (IHIPC_derive2 M CONTEXT_a).
    - assert (CONTEXT_b: forall t0 : Term, (ctx;; b) t0 = true -> M |= t0).
      Focus 1. {
        intros.
        unfold ExtendContext in H3.
        destruct (term_eq t0 b).
        + subst; exact H2.
        + apply CONTEXT; auto.
      } Unfocus.
      exact (IHIPC_derive3 M CONTEXT_b).
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    tauto.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    tauto.
  + specialize (IHIPC_derive1 M CONTEXT).
    specialize (IHIPC_derive2 M CONTEXT).
    simpl in IHIPC_derive1, IHIPC_derive2 |- *.
    tauto.
  + simpl; intros.
    assert (CONTEXT_a: forall t0 : Term, (ctx;; a) t0 = true -> M |= t0).
    Focus 1. {
      intros.
      unfold ExtendContext in H1.
      destruct (term_eq t0 a).
      + subst; exact H0.
      + apply CONTEXT; auto.
    } Unfocus.
    specialize (IHIPC_derive M CONTEXT_a).
    exact IHIPC_derive.
  + specialize (IHIPC_derive M CONTEXT).
    simpl in IHIPC_derive |- *.
    tauto.
Qed.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Init.Byte.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.BitArithmeticProperties.
Require Import Cava.Util.Byte.
Require Import Cava.Util.Nat.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.
Require Import HmacSpec.SHA256.
Import ListNotations.
Local Open Scope N_scope.

Local Ltac lia' := Zify.zify; Z.to_euclidean_division_equations; lia.
Local Ltac t := cbv [k]; lia'.

(* k is a solution to the equation:
     l + 1 + k = 448 (mod 512) *)
Lemma k_correct msg : (l msg + 1 + k msg) mod 512 = 448.
Proof. t. Qed.

(* Prove that k < 512 *)
Lemma k_small msg : k msg < 512.
Proof. t. Qed.

(* Prove that k is the smallest non-negative solution to the equation *)
Lemma k_smallest msg n : (l msg + 1 + n) mod 512 = 448 -> n >= k msg.
Proof. t. Qed.

Lemma H0_length : length H0 = 8%nat.
Proof. reflexivity. Qed.
Hint Rewrite @H0_length using solve [eauto] : push_length.

Lemma sha256_compress_length W H t :
  length (sha256_compress W H t) = 8%nat.
Proof. reflexivity. Qed.
Hint Rewrite @sha256_compress_length : push_length.

Lemma fold_left_sha256_compress_length W H ts :
  length H = 8%nat ->
  length (fold_left (sha256_compress W) ts H) = 8%nat.
Proof.
  intros. apply fold_left_invariant with (I:=fun H => length H = 8%nat); auto.
Qed.
#[export] Hint Resolve fold_left_sha256_compress_length : length.

Lemma sha256_step_length msg H i :
  length H = 8%nat -> length (sha256_step msg H i) = 8%nat.
Proof.
  intro Hlen; cbv [sha256_step]. push_length.
  repeat (push_length || rewrite Hlen || rewrite fold_left_sha256_compress_length); lia.
Qed.
#[export] Hint Resolve sha256_step_length : length.

Lemma fold_left_sha256_step_length msg H idxs :
  length H = 8%nat -> length (fold_left (sha256_step msg) idxs H) = 8%nat.
Proof.
  intros. apply fold_left_invariant with (I:=fun H => length H = 8%nat); auto.
  intros; length_hammer.
Qed.
#[export] Hint Resolve fold_left_sha256_step_length : length.

(* length of the padded message (in bytes) is the smallest number of 512-bit
   (64-byte) blocks that can fit the message plus 9 more bytes (one for the
   extra 1 bit and 8 for the length -- extra 1 bit needs a full byte because
   message must be byte-aligned) *)
Definition padded_message_size (msg : list byte) : nat :=
  (Nat.ceiling (length msg + 9) 64) * 64.

Lemma padded_message_bytes_length msg :
  length (SHA256.padded_msg_bytes msg) = padded_message_size msg.
Proof.
  cbv [SHA256.padded_msg_bytes SHA256.padding padded_message_size].
  push_length. rewrite !Nat.ceiling_equiv. cbv [SHA256.k SHA256.l].
  destruct_one_match; prove_by_zify.
Qed.
Hint Rewrite @padded_message_bytes_length : push_length.

Lemma padded_message_bytes_longer_than_input msg :
  (length msg + 9 <= padded_message_size msg)%nat.
Proof.
  cbv [padded_message_size].
  pose proof Nat.ceiling_range (length msg + 9) 64 ltac:(lia) ltac:(lia).
  lia.
Qed.

Lemma min_padded_message_size msg : (64 <= padded_message_size msg)%nat.
Proof.
  cbv [padded_message_size].
  pose proof Nat.ceiling_range (length msg + 9) 64 ltac:(lia) ltac:(lia).
  lia.
Qed.

Lemma padded_message_size_modulo msg :
  (padded_message_size msg mod 64 = 0)%nat.
Proof. apply Nat.mod_mul. lia. Qed.

(* Adding data cannot decrease padded message size *)
Lemma padded_message_size_mono msg data :
  (padded_message_size msg <= padded_message_size (msg ++ data))%nat.
Proof.
  cbv [padded_message_size]. push_length.
  replace (length msg + length data + 9)%nat
    with (length msg + 9 + length data)%nat by lia.
  pose proof Nat.ceiling_add_le_mono (length msg + 9) 64 (length data).
  lia.
Qed.

Lemma padded_message_length msg :
  length (SHA256.padded_msg msg) = (padded_message_size msg / 4)%nat.
Proof.
  cbv [SHA256.padded_msg]. change (N.to_nat SHA256.w / 8)%nat with 4%nat.
  length_hammer.
Qed.
Hint Rewrite @padded_message_length : push_length.

(* Helper lemma for converting to words *)
Lemma padded_message_size_modulo4 msg :
  (padded_message_size msg mod 4 = 0)%nat.
Proof.
  pose proof padded_message_size_modulo msg.
  prove_by_zify.
Qed.

Lemma nth_padded_msg msg i :
  nth i (SHA256.padded_msg msg) 0%N
  = BigEndianBytes.concat_bytes
      [nth (i*4) (SHA256.padded_msg_bytes msg) x00
       ; nth (i*4 + 1) (SHA256.padded_msg_bytes msg) x00
       ; nth (i*4 + 2) (SHA256.padded_msg_bytes msg) x00
       ; nth (i*4 + 3) (SHA256.padded_msg_bytes msg) x00].
Proof.
  cbv [SHA256.padded_msg]. change (N.to_nat SHA256.w / 8)%nat with 4%nat.
  rewrite nth_bytes_to_Ns by (push_length; auto using padded_message_size_modulo4).
  cbn [List.map seq]. natsimpl. reflexivity.
Qed.

Lemma nth_padding_0 msg : nth 0 (SHA256.padding msg) x00 = x80.
Proof. reflexivity. Qed.
Hint Rewrite nth_padding_0 : push_nth.

Lemma padding_length msg :
  length (SHA256.padding msg) = (padded_message_size msg - length msg - 8)%nat.
Proof.
  rewrite <-padded_message_bytes_length.
  cbv [SHA256.padded_msg_bytes]. push_length.
  lia.
Qed.
Hint Rewrite @padding_length : push_length.

Lemma nth_padding_succ msg i :
  nth (S i) (SHA256.padding msg) x00 = x00.
Proof.
  destr (S i <? length (SHA256.padding msg))%nat;
    [ | apply nth_overflow; lia ].
  cbv [SHA256.padding] in *. autorewrite with push_length in *.
  push_nth. reflexivity.
Qed.
Hint Rewrite nth_padding_succ : push_nth.

Lemma nth_padding_nonzero msg i :
  (0 < i)%nat -> nth i (SHA256.padding msg) x00 = x00.
Proof.
  destruct i; [ lia | ]. intros.
  apply nth_padding_succ.
Qed.

(* Alternate definitions that work with padded_msg as an argument instead of msg *)
Module SHA256Alt.
  Section WithPaddedMessage.
    Context (padded_msg : list N).

    Definition M (j i : nat) : N := nth (i*16 + j) padded_msg 0.

    Definition W (i : nat) : list N :=
      fold_left (fun (W : list N) t =>
                   let wt :=
                       if (t <? 16)%nat
                       then M t i
                       else
                         let W_tm2 := nth (t-2) W 0 in
                         let W_tm7 := nth (t-7) W 0 in
                         let W_tm15 := nth (t-15) W 0 in
                         let W_tm16 := nth (t-16) W 0 in
                         add_mod
                           (add_mod
                              (add_mod (sigma1 W_tm2) W_tm7)
                              (sigma0 W_tm15))
                           W_tm16 in
                   W ++ [wt])
                (seq 0 64) [].

    (* See steps in section 6.2.2. *)
    Definition sha256_step
               (H : list N) (i : nat) : list N :=
      (* steps 2-3 : compression loop *)
      let H' := fold_left (sha256_compress (W i)) (seq 0 64) H in
      (* step 4 : get ith intermediate hash value by adding each element *)
      map2 add_mod H H'.

    (* Full SHA-256 computation: loop of sha256_step *)
    Definition sha256 :=
      let nblocks := (length padded_msg / (512 / N.to_nat w))%nat in
      let H := fold_left sha256_step (seq 0 nblocks) H0 in
      concat_digest H.
  End WithPaddedMessage.
End SHA256Alt.

Lemma M_alt_equiv msg : SHA256Alt.M (padded_msg msg) = M msg.
Proof. reflexivity. Qed.

Lemma W_alt_equiv msg i : SHA256Alt.W (padded_msg msg) i = W msg i.
Proof. cbv [W SHA256Alt.W]. rewrite M_alt_equiv. reflexivity. Qed.

Lemma sha256_step_alt_equiv msg H i :
  SHA256Alt.sha256_step (padded_msg msg) H i = sha256_step msg H i.
Proof.
  cbv [SHA256Alt.sha256_step sha256_step].
  rewrite W_alt_equiv. reflexivity.
Qed.

Lemma sha256_alt_equiv msg :
  SHA256Alt.sha256 (padded_msg msg) = sha256 msg.
Proof.
  cbv [SHA256Alt.sha256 sha256].
  apply f_equal. apply fold_left_ext; intros.
  rewrite sha256_step_alt_equiv. reflexivity.
Qed.

Lemma sha256_step_alt_length msg H i :
  length H = 8%nat -> length (SHA256Alt.sha256_step msg H i) = 8%nat.
Proof.
  intro Hlen; cbv [SHA256Alt.sha256_step]. push_length.
  repeat (push_length || rewrite Hlen || rewrite fold_left_sha256_compress_length); lia.
Qed.
#[export] Hint Resolve sha256_step_alt_length : length.

Lemma fold_left_sha256_step_alt_length msg H idxs :
  length H = 8%nat -> length (fold_left (SHA256Alt.sha256_step msg) idxs H) = 8%nat.
Proof.
  intros. apply fold_left_invariant with (I:=fun H => length H = 8%nat); auto.
  intros; length_hammer.
Qed.
#[export] Hint Resolve fold_left_sha256_step_alt_length : length.

(* Formula for the nth element of W (n > 15) *)
Lemma nth_W_alt msg (i t : nat) :
  (t < 64)%nat ->
  nth t (SHA256Alt.W msg i) 0 =
  if (t <? 16)%nat
  then SHA256Alt.M msg t i
  else
    let W_tm2 := nth (t - 2) (SHA256Alt.W msg i) 0 in
    let W_tm7 := nth (t - 7) (SHA256Alt.W msg i) 0 in
    let W_tm15 := nth (t - 15) (SHA256Alt.W msg i) 0 in
    let W_tm16 := nth (t - 16) (SHA256Alt.W msg i) 0 in
    SHA256.add_mod
      (SHA256.add_mod
         (SHA256.add_mod
            (SHA256.sigma1 W_tm2) W_tm7) (SHA256.sigma0 W_tm15))
      W_tm16.
Proof.
  intros.
  (* extract the formula for an element of W and remember it *)
  lazymatch goal with
    | |- nth t ?W ?d = ?rhs =>
      let f := lazymatch (eval pattern t in rhs) with
               | ?f _ => f end in
      let f := lazymatch (eval pattern W in f) with
               | ?f _ => f end in
      set (W_formula:=f);
        change (nth t W d = W_formula W t)
  end.
  (* use an invariant *)
  apply fold_left_invariant_seq
    with (I:= fun n W =>
                length W = n /\
                forall t, (t < n)%nat -> nth t W 0 = W_formula W t)
         (P:=fun W => nth t W 0 = W_formula W t);
    [ intros; ssplit; length_hammer
    | | intros; ssplit; logical_simplify; solve [auto] ].
  intros. autorewrite with natsimpl push_nth in *.
  logical_simplify. ssplit; [ length_hammer | ]. intros.
  lazymatch goal with H : (?t < S ?n)%nat |- context [nth ?t] =>
                      destr (t <? n)%nat; [ | replace t with n in * by lia ]
  end; subst W_formula; cbn beta zeta; push_nth; natsimpl;
    [ solve [auto] | ].
  destruct_one_match; push_nth; reflexivity.
Qed.

Lemma nth_W msg (i t : nat) :
  (t < 64)%nat ->
  nth t (SHA256.W msg i) 0 =
  if (t <? 16)%nat
  then SHA256.M msg t i
  else
    let W_tm2 := nth (t - 2) (SHA256.W msg i) 0 in
    let W_tm7 := nth (t - 7) (SHA256.W msg i) 0 in
    let W_tm15 := nth (t - 15) (SHA256.W msg i) 0 in
    let W_tm16 := nth (t - 16) (SHA256.W msg i) 0 in
    SHA256.add_mod
      (SHA256.add_mod
         (SHA256.add_mod
            (SHA256.sigma1 W_tm2) W_tm7) (SHA256.sigma0 W_tm15))
      W_tm16.
Proof.
  intros. rewrite <-W_alt_equiv, <-M_alt_equiv.
  auto using nth_W_alt.
Qed.

(* M returns the same result regardless of blocks above the current block
   index *)
Lemma sha256_M_alt_truncate msg1 msg2 j i :
  (S i * 16 <= length msg1)%nat -> (j < 16)%nat ->
  SHA256Alt.M (msg1 ++ msg2) j i = SHA256Alt.M msg1 j i.
Proof. cbv [SHA256Alt.M]. intros. apply app_nth1. lia. Qed.

(* W returns the same result regardless of blocks above the current block
   index *)
Lemma sha256_W_alt_truncate msg1 msg2 i :
  (S i * 16 <= length msg1)%nat -> SHA256Alt.W (msg1 ++ msg2) i = SHA256Alt.W msg1 i.
Proof.
  cbv [SHA256Alt.W]. intros.
  eapply fold_left_ext_In. intros *; rewrite in_seq; natsimpl; intros.
  destruct_one_match; [ | reflexivity ].
  rewrite sha256_M_alt_truncate by lia.
  reflexivity.
Qed.

(* sha256_step returns the same result regardless of blocks above the current index *)
Lemma sha256_step_alt_truncate msg1 msg2 i H :
  (S i * 16 <= length msg1)%nat ->
  SHA256Alt.sha256_step (msg1 ++ msg2) H i = SHA256Alt.sha256_step msg1 H i.
Proof.
  cbv [SHA256Alt.sha256_step]. intros. apply f_equal2; [ reflexivity | ].
  apply fold_left_ext_In; intros *. rewrite in_seq; natsimpl; intros.
  rewrite sha256_W_alt_truncate by lia. reflexivity.
Qed.

(* alternate phrasing of sha256_step_alt_truncate *)
Lemma sha256_step_alt_firstn msg i H n :
  (S i * 16 <= n)%nat ->
  SHA256Alt.sha256_step (firstn n msg) H i
  = SHA256Alt.sha256_step msg H i.
Proof.
  intros. destr (length msg <? n)%nat; [ push_firstn; reflexivity | ].
  erewrite <-(sha256_step_alt_truncate (firstn n msg) (skipn n msg))
    by length_hammer.
  rewrite firstn_skipn; reflexivity.
Qed.

Lemma slice0_W_alt msg block i :
  (i * 16 = length msg)%nat -> length block = 16%nat ->
  List.slice 0%N (SHA256Alt.W (msg ++ block) i) 0 16 = block.
Proof.
  intros.
  etransitivity;
    [ | apply resize_noop with (d:=0%N) (n:=16%nat); lia ].
  rewrite resize_map_nth. rewrite slice_map_nth.
  apply map_ext_in; intros *; rewrite in_seq; intros.
  rewrite nth_W_alt by lia. destruct_one_match; try lia; [ ].
  cbv [SHA256Alt.M]. rewrite app_nth2 by length_hammer.
  f_equal; lia.
Qed.

Lemma firstn_padded_msg_truncate n msg1 msg2  :
  (n * 4 <= length msg1)%nat ->
  firstn n (SHA256.padded_msg (msg1 ++ msg2)) = firstn n (SHA256.padded_msg msg1).
Proof.
  intros. pose proof padded_message_size_mono msg1 msg2.
  pose proof padded_message_bytes_longer_than_input msg1.
  rewrite !firstn_map_nth with (d:=0%N) by (push_length; prove_by_zify).
  eapply map_ext_in. intros *; rewrite in_seq; intros.
  rewrite !nth_padded_msg. cbv [SHA256.padded_msg_bytes].
  rewrite <-!app_assoc. push_nth. reflexivity.
Qed.

Lemma slicen_padded_msg_truncate n msg1 msg2 c d :
  (n * 4 + c * 4 <= length msg1)%nat ->
  List.slice d (SHA256.padded_msg (msg1 ++ msg2)) n c = List.slice d (SHA256.padded_msg msg1) n c.
Proof.
  intros. pose proof padded_message_size_mono msg1 msg2.
  pose proof padded_message_bytes_longer_than_input msg1.
  cbv [List.slice List.resize].
  push_length.
  assert (c - (padded_message_size msg1 / 4 - n) = 0)%nat by prove_by_zify.
  assert (c - (padded_message_size (msg1 ++ msg2) / 4 - n) = 0)%nat by prove_by_zify.
  rewrite H2, H3.
  rewrite ?firstn_skipn_comm.
  now rewrite firstn_padded_msg_truncate by lia.
Qed.

Lemma fold_left_sha256_step_alt_firstn i H msg :
  fold_left (SHA256.sha256_step msg) (seq 0 i) H =
  fold_left (SHA256Alt.sha256_step (firstn (i * 16) (SHA256.padded_msg msg))) (seq 0 i) H.
Proof.
  intros; eapply fold_left_ext_In; intros *.
  rewrite in_seq; intros.
  rewrite sha256_step_alt_firstn by lia.
  rewrite sha256_step_alt_equiv; reflexivity.
Qed.

Lemma fold_left_sha256_step_alt_firstn' i j H msg :
  (j <= i)%nat ->
  fold_left (SHA256.sha256_step msg) (seq 0 j) H =
  fold_left (SHA256Alt.sha256_step (firstn (i * 16) (SHA256.padded_msg msg))) (seq 0 j) H.
Proof.
  intros; eapply fold_left_ext_In; intros *.
  rewrite in_seq; intros.
  rewrite sha256_step_alt_firstn by lia.
  rewrite sha256_step_alt_equiv; reflexivity.
Qed.

(* M returns the same result regardless of blocks above the current block
   index *)
Lemma sha256_M_truncate msg1 msg2 j i :
  (S i * 64 <= length msg1)%nat -> (j < 16)%nat ->
  SHA256.M (msg1 ++ msg2) j i = SHA256.M msg1 j i.
Proof.
  cbv [SHA256.M]; intros.
  rewrite !nth_padded_msg. apply f_equal.
  cbv [SHA256.padded_msg_bytes].
  rewrite <-!app_assoc; push_nth.
  reflexivity.
Qed.

(* W returns the same result regardless of blocks above the current block
   index *)
Lemma sha256_W_truncate msg1 msg2 i :
  (S i * 64 <= length msg1)%nat -> SHA256.W (msg1 ++ msg2) i = SHA256.W msg1 i.
Proof.
  cbv [SHA256.W]. intros.
  eapply fold_left_ext_In. intros *; rewrite in_seq; natsimpl; intros.
  destruct_one_match; [ | reflexivity ].
  rewrite sha256_M_truncate by lia.
  reflexivity.
Qed.

(* sha256_step returns the same result regardless of blocks above the current index *)
Lemma sha256_step_truncate msg1 msg2 i H :
  (S i * 64 <= length msg1)%nat ->
  SHA256.sha256_step (msg1 ++ msg2) H i = SHA256.sha256_step msg1 H i.
Proof.
  cbv [SHA256.sha256_step]. intros. apply f_equal2; [ reflexivity | ].
  apply fold_left_ext_In; intros *. rewrite in_seq; natsimpl; intros.
  rewrite sha256_W_truncate by lia. reflexivity.
Qed.

Lemma sha256_add_mod_bounded x y: (SHA256.add_mod x y < 2 ^ 32)%N.
Proof.
  cbv [SHA256.add_mod SHA256.w].
  apply N.mod_upper_bound; cbn; lia.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_assoc: forall l1 l2 l3,
  append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
induction l1.
  - simpl. intros. rewrite IHl1. reflexivity.
  - reflexivity.
Qed.

Lemma lem3: forall l, append l Nil = l.
Proof.
induction l.
  - simpl. rewrite IHl. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
induction x.
- intros. simpl.
  lfind. Admitted.


Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Delimit Scope object_scope with object.
Delimit Scope morphism_scope with morphism.
Delimit Scope category_scope with category.
Delimit Scope functor_scope with functor.

Local Open Scope category_scope.

Record SpecializedCategory (obj : Type) :=
  {
    Object :> _ := obj;
    Morphism : obj -> obj -> Type;

    Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d'
  }.

Bind Scope category_scope with SpecializedCategory.
Bind Scope object_scope with Object.
Bind Scope morphism_scope with Morphism.

Arguments Object {obj%type} C%category / : rename.
Arguments Morphism {obj%type} !C%category s d : rename. (* , simpl nomatch. *)
Arguments Compose {obj%type} [!C%category s%object d%object d'%object] m1%morphism m2%morphism : rename.

Record Category := {
  CObject : Type;

  UnderlyingCategory :> @SpecializedCategory CObject
}.

Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category.
  refine {| CObject := C.(Object) |}; auto. (* Changing this [auto] to [assumption] removes the universe inconsistency. *)
Defined.

Coercion GeneralizeCategory : SpecializedCategory >-> Category.

Record SpecializedFunctor
       `(C : @SpecializedCategory objC)
       `(D : @SpecializedCategory objD)
  := {
      ObjectOf :> objC -> objD;
      MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
    }.

Section Functor.
  Context (C D : Category).

  Definition Functor := SpecializedFunctor C D.
End Functor.

Bind Scope functor_scope with SpecializedFunctor.
Bind Scope functor_scope with Functor.

Arguments SpecializedFunctor {objC} C {objD} D.
Arguments Functor C D.
Arguments ObjectOf {objC%type C%category objD%type D%category} F%functor c%object : rename, simpl nomatch.
Arguments MorphismOf {objC%type} [C%category] {objD%type} [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.

Section FunctorComposition.
  Context `(B : @SpecializedCategory objB).
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(E : @SpecializedCategory objE).

  Definition ComposeFunctors (G : SpecializedFunctor D E) (F : SpecializedFunctor C D) : SpecializedFunctor C E
    := Build_SpecializedFunctor C E
                                (fun c => G (F c))
                                (fun _ _ m => G.(MorphismOf) (F.(MorphismOf) m)).
End FunctorComposition.

Record SpecializedNaturalTransformation
       `{C : @SpecializedCategory objC}
       `{D : @SpecializedCategory objD}
       (F G : SpecializedFunctor C D)
  := {
      ComponentsOf :> forall c, D.(Morphism) (F c) (G c)
    }.

Definition ProductCategory
           `(C : @SpecializedCategory objC)
           `(D : @SpecializedCategory objD)
: @SpecializedCategory (objC * objD)%type
  := @Build_SpecializedCategory _
                                (fun s d => (C.(Morphism) (fst s) (fst d) * D.(Morphism) (snd s) (snd d))%type)
                                (fun s d d' m2 m1 => (Compose (fst m2) (fst m1), Compose (snd m2) (snd m1))).

Infix "*" := ProductCategory : category_scope.

Section ProductCategoryFunctors.
  Context `{C : @SpecializedCategory objC}.
  Context `{D : @SpecializedCategory objD}.

  Definition fst_Functor : SpecializedFunctor (C * D) C
    := Build_SpecializedFunctor (C * D) C
                                (@fst _ _)
                                (fun _ _ => @fst _ _).

  Definition snd_Functor : SpecializedFunctor (C * D) D
    := Build_SpecializedFunctor (C * D) D
                                (@snd _ _)
                                (fun _ _ => @snd _ _).
End ProductCategoryFunctors.

Definition OppositeCategory `(C : @SpecializedCategory objC) : @SpecializedCategory objC :=
  @Build_SpecializedCategory objC
                             (fun s d => Morphism C d s)
                             (fun _ _ _ m1 m2 => Compose m2 m1).

Section OppositeFunctor.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Variable F : SpecializedFunctor C D.
  Let COp := OppositeCategory C.
  Let DOp := OppositeCategory D.

  Definition OppositeFunctor : SpecializedFunctor COp DOp
    := Build_SpecializedFunctor COp DOp
                                (fun c : COp => F c : DOp)
                                (fun (s d : COp) (m : C.(Morphism) d s) => MorphismOf F (s := d) (d := s) m).
End OppositeFunctor.

Section FunctorProduct.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(D' : @SpecializedCategory objD').

  Definition FunctorProduct (F : Functor C D) (F' : Functor C D') : SpecializedFunctor C (D * D').
    match goal with
      | [ |- SpecializedFunctor ?C0 ?D0 ] =>
        refine (Build_SpecializedFunctor
                  C0 D0
                  (fun c => (F c, F' c))
                  (fun s d m => (MorphismOf F m, MorphismOf F' m)))
    end.
  Defined.
End FunctorProduct.

Section FunctorProduct'.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(C' : @SpecializedCategory objC').
  Context `(D' : @SpecializedCategory objD').
  Variable F : Functor C D.
  Variable F' : Functor C' D'.

  Definition FunctorProduct' : SpecializedFunctor  (C * C') (D * D')
    := FunctorProduct (ComposeFunctors F fst_Functor) (ComposeFunctors F' snd_Functor).
End FunctorProduct'.

(** XXX TODO(jgross): Change this to [FunctorProduct]. *)
Infix "*" := FunctorProduct' : functor_scope.

Definition TypeCat : @SpecializedCategory Type :=
  (@Build_SpecializedCategory Type
                              (fun s d => s -> d)
                              (fun _ _ _ f g => (fun x => f (g x)))).

Section HomFunctor.
  Context `(C : @SpecializedCategory objC).
  Let COp := OppositeCategory C.

  Definition CovariantHomFunctor (A : COp) : SpecializedFunctor C TypeCat
    := Build_SpecializedFunctor C TypeCat
                                (fun X : C => C.(Morphism) A X : TypeCat)
                                (fun X Y f => (fun g : C.(Morphism) A X => Compose f g)).

  Definition hom_functor_object_of (c'c : COp * C) := C.(Morphism) (fst c'c) (snd c'c) : TypeCat.

  Definition hom_functor_morphism_of (s's : (COp * C)%type) (d'd : (COp * C)%type) (hf : (COp * C).(Morphism) s's d'd) :
    TypeCat.(Morphism) (hom_functor_object_of s's) (hom_functor_object_of d'd).
    unfold hom_functor_object_of in *.
    destruct s's as [ s' s ], d'd as [ d' d ].
    destruct hf as [ h f ].
    intro g.
    exact (Compose f (Compose g h)).
  Defined.

  Definition HomFunctor : SpecializedFunctor (COp * C) TypeCat
    := Build_SpecializedFunctor (COp * C) TypeCat
                                (fun c'c : COp * C => C.(Morphism) (fst c'c) (snd c'c) : TypeCat)
                                (fun X Y (hf : (COp * C).(Morphism) X Y) => hom_functor_morphism_of hf).
End HomFunctor.

Section FullFaithful.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Variable F : SpecializedFunctor C D.
  Let COp := OppositeCategory C.
  Let DOp := OppositeCategory D.
  Let FOp := OppositeFunctor F.

  Definition InducedHomNaturalTransformation :
    SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F))
    := (Build_SpecializedNaturalTransformation (HomFunctor C) (ComposeFunctors (HomFunctor D) (FOp * F))
                                               (fun sd : (COp * C) =>
                                                  MorphismOf F (s := _) (d := _))).
End FullFaithful.

Definition FunctorCategory
           `(C : @SpecializedCategory objC)
           `(D : @SpecializedCategory objD)
: @SpecializedCategory (SpecializedFunctor C D).
  refine (@Build_SpecializedCategory _
                                     (SpecializedNaturalTransformation (C := C) (D := D))
                                     _);
  admit.
Defined.

Notation "C ^ D" := (FunctorCategory D C) : category_scope.

Section Yoneda.
  Context `(C : @SpecializedCategory objC).
  Let COp := OppositeCategory C.

  Section Yoneda.
    Let Yoneda_NT s d (f : COp.(Morphism) s d) : SpecializedNaturalTransformation (CovariantHomFunctor C s) (CovariantHomFunctor C d)
      := Build_SpecializedNaturalTransformation
           (CovariantHomFunctor C s)
           (CovariantHomFunctor C d)
           (fun c : C => (fun m : C.(Morphism) _ _ => Compose m f)).

    Definition Yoneda : SpecializedFunctor COp (TypeCat ^ C)
      := Build_SpecializedFunctor COp (TypeCat ^ C)
                                  (fun c : COp => CovariantHomFunctor C c : TypeCat ^ C)
                                  (fun s d (f : Morphism COp s d) => Yoneda_NT s d f).
  End Yoneda.
End Yoneda.

Section FullyFaithful.
  Context `(C : @SpecializedCategory objC).

  Set Printing Universes.
  Check InducedHomNaturalTransformation (Yoneda C).
  (* Error: Universe inconsistency (cannot enforce Top.865 = Top.851 because
Top.851 < Top.869 <= Top.864 <= Top.865). *)
End FullyFaithful.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Lagrange.v

    Proof of Lagrange theorem:
      the oder of a subgroup divides the order of a group

    Definition: lagrange
  **********************************************************************)
Require Import List.
Require Import UList.
Require Import ListAux.
Require Import ZAux.
Require Import NatAux.
Require Import FGroup.

Open Scope Z_scope.

Section Lagrange.

Variable A: Type.

Variable A_dec: forall a b: A, {a = b} + {~ a = b}.

Variable op: A -> A -> A.

Variable G: (FGroup op).

Variable H:(FGroup op).

Hypothesis G_in_H: (incl G.(s)  H.(s)).

(**************************************
   A group and a subgroup have the same neutral element
 **************************************)

Theorem same_e_for_H_and_G: H.(e) = G.(e).
apply trans_equal with (op H.(e) H.(e)); sauto.
apply trans_equal with (op H.(e) (op G.(e) (H.(i) G.(e)))); sauto.
eq_tac; sauto.
apply trans_equal with (op G.(e) (op G.(e) (H.(i) G.(e)))); sauto.
repeat rewrite  H.(assoc); sauto.
eq_tac; sauto.
apply trans_equal with G.(e); sauto.
apply trans_equal with (op G.(e) H.(e)); sauto.
eq_tac; sauto.
Qed.

(**************************************
   The proof works like this.
   If G = {e, g1, g2, g3, .., gn} and {e, h1, h2, h3, ..., hm}
   we construct the list mkGH
    {e, g1, g2, g3, ...., gn
     hi*e, hi * g1, hi * g2, ..., hi * gn   if hi does not appear before
     ....
     hk*e, hk * g1, hk * g2, ..., hk * gn   if hk does not appear before
     }
     that contains all the element of H.
   We show that this list does not contain double (ulist).
 **************************************)

Fixpoint mkList (base l: (list A)) { struct l}  : (list A) :=
  match l with
   nil => nil
 | cons a l1 => let r1 := mkList base l1 in
                         if (In_dec A_dec a r1) then r1 else
                          (map (op a) base) ++ r1
  end.

Definition mkGH := mkList G.(s) H.(s).

Theorem mkGH_length:  divide (length G.(s)) (length mkGH).
unfold mkGH; elim H.(s); simpl.
exists 0%nat; auto with arith.
intros a l1 (c, H1); case (In_dec A_dec a (mkList  G.(s) l1)); intros H2.
exists c; auto.
exists (1 + c)%nat; rewrite ListAux.length_app; rewrite ListAux.length_map; rewrite H1; ring.
Qed.

Theorem mkGH_incl: incl H.(s) mkGH.
assert (H1: forall l, incl l H.(s) -> incl l  (mkList G.(s) l)).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2.
case  (In_dec A_dec a (mkList (s G) l1)); auto with datatypes.
intros H3; assert (H4: incl l1 (mkList (s G) l1)).
apply H1; auto with datatypes.
intros b H4; apply H2; auto with datatypes.
intros b; simpl; intros [H5 | H5]; subst; auto.
intros _ b; simpl; intros [H3 | H3]; subst; auto.
apply in_or_app; left.
cut (In H.(e) G.(s)).
elim (s G); simpl; auto.
intros c l2 Hl2 [H3 | H3]; subst; sauto.
assert (In b H.(s)); sauto.
apply (H2 b); auto with datatypes.
rewrite same_e_for_H_and_G; sauto.
apply in_or_app; right.
apply H1; auto with datatypes.
apply incl_tran with (2:= H2); auto with datatypes.
unfold mkGH; apply H1; auto with datatypes.
Qed.

Theorem incl_mkGH: incl mkGH H.(s).
assert (H1: forall l, incl l H.(s) -> incl (mkList G.(s) l) H.(s)).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2.
case  (In_dec A_dec a (mkList (s G) l1)); intros H3; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
apply incl_app.
intros b H4.
case ListAux.in_map_inv with (1:= H4); auto.
intros c (Hc1, Hc2); subst; sauto.
apply internal; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
unfold mkGH; apply H1; auto with datatypes.
Qed.

Theorem ulist_mkGH: ulist mkGH.
assert (H1: forall l, incl l H.(s) -> ulist  (mkList G.(s) l)).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2.
case  (In_dec A_dec a (mkList (s G) l1)); intros H3; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
apply ulist_app; auto.
apply ulist_map; sauto.
intros x y H4 H5 H6; apply g_cancel_l with (g:= H) (a := a); sauto.
apply H2; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
intros b H4 H5.
case ListAux.in_map_inv with (1:= H4); auto.
intros c (Hc, Hc1); subst.
assert (H6: forall l a b,  In b G.(s) -> incl l H.(s) -> In a (mkList G.(s) l) -> In (op a b) (mkList G.(s) l)).
intros ll u v; elim ll; simpl; auto with datatypes.
intros w ll1 T0 T1 T2.
case  (In_dec A_dec w (mkList (s G) ll1)); intros T3 T4; auto with datatypes.
apply T0; auto; apply incl_tran with (2:= T2); auto with datatypes.
case in_app_or with (1 := T4); intros T5; auto with datatypes.
apply in_or_app; left.
case ListAux.in_map_inv with (1:= T5); auto.
intros z (Hz1, Hz2); subst.
replace (op (op w z) v) with (op w (op z v)); sauto.
apply in_map; sauto.
apply assoc with H; auto with datatypes.
apply in_or_app; right; auto with datatypes.
apply T0; try apply incl_tran with (2 := T2); auto with datatypes.
case H3; replace a with (op  (op a c) (G.(i) c)); auto with datatypes.
apply H6; sauto.
apply incl_tran with (2 := H2); auto with datatypes.
apply trans_equal with (op a (op c (G.(i) c))); sauto.
apply sym_equal; apply assoc with H; auto with datatypes.
replace (op c (G.(i) c)) with (G.(e)); sauto.
rewrite <- same_e_for_H_and_G.
assert (In a H.(s)); sauto; apply (H2 a); auto with datatypes.
unfold mkGH; apply H1; auto with datatypes.
Qed.

(**************************************
  Lagrange theorem
 **************************************)

Theorem lagrange: (g_order G | (g_order H)).
unfold g_order.
rewrite Permutation.permutation_length with  (l := H.(s)) (m:= mkGH).
case mkGH_length; intros x H1; exists (Z_of_nat x).
rewrite H1; rewrite Zmult_comm; apply inj_mult.
apply ulist_incl2_permutation; auto.
apply ulist_mkGH.
apply mkGH_incl.
apply incl_mkGH.
Qed.

End Lagrange.


Require Import List.

Set Universe Polymorphism.

Fixpoint zip A B xs ys {struct xs} : list (A*B) :=
  match xs with
  | nil => nil
  | x::xs' => match ys with
        | nil => nil
        | y::ys' => (x, y) :: zip A B xs' ys'
        end
end.

Fixpoint zip_with A B C (f : A->B->C) xs ys {struct xs} : list C :=
  match xs with
  | nil => nil
  | x::xs' => match ys with
        | nil => nil
        | y::ys' => f x y :: zip_with A B C f xs' ys'
        end
end.

(** Assert that a predicate is true for each element of a list. *)
Definition foreach A (xs : list A) (P : A -> Prop) :=
  fold_right and True (map P xs).

(** When we have [foreach xs P] then indexing with [nth_error] into
    [xs] gives something with [P] *)
Lemma foreach_member : forall A P v n xs,
    foreach A xs P -> value v = nth_error xs n -> P v.
Proof.
 induction n; simpl; intros; destruct xs; try discriminate.
  unfold foreach in H.
  simpl in H.
  inversion H0.
  cut (P a); intuition.
 firstorder.
Qed.

(** Assert that a (Type-valued) predicate is true for each element of a list. *)
Definition foreach_ty A (xs : list A) (P : A -> Type) :=
  fold_right (fun x y => x*y)%type True (map P xs).

(** Assert that all corresponding elements of two lists stand in a certain relation. *)
Definition foreach2 A B (xs : list A) (ys : list B ) (P : A -> B -> Prop) :=
  fold_right and True
    (map (fun pr:A*B => let (x, y) := pr in P x y)
         (zip A B xs ys)).

Lemma foreach2_member : forall A B R v w n xs ys,
    (foreach2 A B xs ys R) ->
    value v = nth_error xs n ->
    value w = nth_error ys n ->
    R v w.
Proof.
 induction n; simpl; intros; destruct xs; destruct ys; try discriminate.
  unfold foreach2 in H.
  simpl in H.
  inversion H0.
  inversion H1.
  firstorder.
 firstorder.
Qed.

(** Assert that all corresponding elements of two lists stand in a
    certain (Type-valued) relation. *)
Definition foreach2_ty A B (xs : list A) (ys : list B ) (P : A -> B -> Type) :=
  fold_right
    (fun x y => x*y)%type
    unit%type
    (map (fun pr:A*B => let (x, y) := pr in P x y) (zip A B xs ys)).

Lemma foreach2_ty_member : forall A B R v w n xs ys,
    (foreach2_ty A B xs ys R) ->
    value v = nth_error xs n ->
    value w = nth_error ys n ->
    R v w.
Proof.
 induction n; simpl; intros; destruct xs; destruct ys; try discriminate.
  unfold foreach2_ty in X.
  simpl in X.
  inversion H.
  inversion H0.
  firstorder.
 firstorder.
Qed.

(* Unused: remove? *)
Lemma foreach_cut A (P Q : A -> Prop) xs:
   (forall x, In x xs -> P x -> Q x) -> foreach _ xs P -> foreach _ xs Q.
Proof.
 induction xs; firstorder.
Qed.

(* Unused: remove? *)
Lemma foreach2_cut A B (P Q : A -> B -> Prop):
  forall xs ys,
    (forall x y, In x xs -> In y ys -> P x y -> Q x y) ->
    foreach2 _ _ xs ys P -> foreach2 _ _ xs ys Q.
Proof.
 induction xs; [idtac|destruct ys]; firstorder.
Qed.

Lemma foreach2_ty_cons :
  forall A B x xs y ys R,
  foreach2_ty A B (x::xs) (y::ys) R =
   (R x y * foreach2_ty A B xs ys R)%type.
Proof.
 intuition.
Qed.

Hint Resolve foreach2_ty_cons.

(* Unused: remove? *)
Lemma foreach2_ty_cut A B (P Q : A -> B -> Type):
  forall xs ys,
    (forall x y, In x xs -> In y ys -> P x y -> Q x y) ->
    foreach2_ty _ _ xs ys P -> foreach2_ty _ _ xs ys Q.
Proof.
 induction xs; [idtac|destruct ys]; firstorder.
Qed.

Lemma foreach_ty_map :
  forall A f P xs,
    foreach_ty A (map f xs) P = foreach_ty A xs (fun x => P (f x)).
Proof.
 induction xs; unfold foreach_ty; auto.
 rewrite map_map.
 trivial.
Qed.

Lemma foreach_ty_impl :
  forall A P Q xs,
    (forall x, P x -> Q x) -> foreach_ty A xs P -> foreach_ty A xs Q.
Proof.
 unfold foreach_ty.
 unfold fold_right.
 induction xs; simpl; intros P_impl_Q H.
  auto.
 inversion H.
 split.
  auto.
 apply IHxs; auto.
Qed.

Lemma foreach_ty_member : forall A P v,
  forall n xs,
    (foreach_ty A xs P) ->
    value v = nth_error xs n -> P v.
Proof.
 induction n; simpl; intros; destruct xs; try discriminate.
  unfold foreach_ty in X.
  simpl in X.
  inversion H.
  intuition.
 firstorder.
Qed.

Lemma foreach_universal:
  forall A (f:A->Prop), (forall x, f x) -> forall xs, foreach _ xs f.
Proof.
 induction xs; unfold foreach; simpl; intros.
  auto.
 auto.
Qed.

Lemma zip_map_diamond:
  forall A B1 B2 (f1:A->B1) (f2:A->B2) xs,
    zip _ _ (map f1 xs) (map f2 xs) = map (fun x => (f1 x, f2 x)) xs.
Proof.
 induction xs; simpl; intros.
  auto.
 f_equal.
 auto.
Qed.


(** * Records: Adding Records to STLC *)

Require Import SF.SfLib.
Require Import SF.Maps.
Require Import SF.Imp.
Require Import SF.Smallstep.
Require Import SF.Stlc.

(* ###################################################################### *)
(** * Adding Records *)

(** We saw in chapter [MoreStlc] how records can be treated as just
    syntactic sugar for nested uses of products.  This is OK for
    simple examples, but the encoding is informal (in reality, if we
    actually treated records this way, it would be carried out in the
    parser, which we are eliding here), and anyway it is not very
    efficient.  So it is also interesting to see how records can be
    treated as first-class citizens of the language.  This chapter
    shows how.

    Recall the informal definitions we gave before: *)

(**
    Syntax:

       t ::=                          Terms:
           | {i1=t1, ..., in=tn}         record
           | t.i                         projection
           | ...

       v ::=                          Values:
           | {i1=v1, ..., in=vn}         record value
           | ...

       T ::=                          Types:
           | {i1:T1, ..., in:Tn}         record type
           | ...

   Reduction:

                                 ti ==> ti'                            (ST_Rcd)
    --------------------------------------------------------------------
    {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}

                                 t1 ==> t1'
                               --------------                        (ST_Proj1)
                               t1.i ==> t1'.i

                          -------------------------                (ST_ProjRcd)
                          {..., i=vi, ...}.i ==> vi

   Typing:

               Gamma |- t1 : T1     ...     Gamma |- tn : Tn
             --------------------------------------------------         (T_Rcd)
             Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                       Gamma |- t : {..., i:Ti, ...}
                       -----------------------------                   (T_Proj)
                             Gamma |- t.i : Ti

*)

(* ###################################################################### *)
(** * Formalizing Records *)

Module STLCExtendedRecords.

(* ###################################################################### *)
(** *** Syntax and Operational Semantics *)

(** The most obvious way to formalize the syntax of record types would
    be this: *)

Module FirstTry.

Definition alist (X : Type) := list (id * X).

Inductive ty : Type :=
  | TBase     : id -> ty
  | TArrow    : ty -> ty -> ty
  | TRcd      : (alist ty) -> ty.

(** Unfortunately, we encounter here a limitation in Coq: this type
    does not automatically give us the induction principle we expect:
    the induction hypothesis in the [TRcd] case doesn't give us
    any information about the [ty] elements of the list, making it
    useless for the proofs we want to do.  *)

(* Check ty_ind.
   ====>
    ty_ind :
      forall P : ty -> Prop,
        (forall i : id, P (TBase i)) ->
        (forall t : ty, P t -> forall t0 : ty, P t0
                            -> P (TArrow t t0)) ->
        (forall a : alist ty, P (TRcd a)) ->    (* ??? *)
        forall t : ty, P t
*)

End FirstTry.

(** It is possible to get a better induction principle out of Coq, but
    the details of how this is done are not very pretty, and the
    principle we obtain is not as intuitive to use as the ones Coq
    generates automatically for simple [Inductive] definitions.

    Fortunately, there is a different way of formalizing records that
    is, in some ways, even simpler and more natural: instead of using
    the standard Coq [list] type, we can essentially incorporate its
    constructors ("nil" and "cons") in the syntax of our types. *)

Inductive ty : Type :=
  | TBase : id -> ty
  | TArrow : ty -> ty -> ty
  | TRNil : ty
  | TRCons : id -> ty -> ty -> ty.

(** Similarly, at the level of terms, we have constructors [trnil],
    for the empty record, and [trcons], which adds a single field to
    the front of a list of fields. *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  (* records *)
  | tproj : tm -> id -> tm
  | trnil :  tm
  | trcons : id -> tm -> tm -> tm.

(** Some examples... *)

Notation a := (Id 0).
Notation f := (Id 1).
Notation g := (Id 2).
Notation l := (Id 3).
Notation A := (TBase (Id 4)).
Notation B := (TBase (Id 5)).
Notation k := (Id 6).
Notation i1 := (Id 7).
Notation i2 := (Id 8).

(** [{ i1:A }] *)

(* Check (TRCons i1 A TRNil). *)

(** [{ i1:A->B, i2:A }] *)

(* Check (TRCons i1 (TArrow A B)
           (TRCons i2 A TRNil)). *)

(* ###################################################################### *)
(** *** Well-Formedness *)

(** One issue with generalizing the abstract syntax for records from
    lists to the nil/cons presentation is that it introduces the
    possibility of writing strange types like this... *)

Definition weird_type := TRCons X A B.

(** where the "tail" of a record type is not actually a record type! *)

(** We'll structure our typing judgement so that no ill-formed types
    like [weird_type] are ever assigned to terms.  To support this, we
    define predicates [record_ty] and [record_tm], which identify
    record types and terms, and [well_formed_ty] which rules out the
    ill-formed types. *)

(** First, a type is a record type if it is built with just [TRNil]
    and [TRCons] at the outermost level. *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty TRNil
  | RTcons : forall i T1 T2,
        record_ty (TRCons i T1 T2).

(** With this, we can define well-formed types. *)

Inductive well_formed_ty : ty -> Prop :=
  | wfTBase : forall i,
        well_formed_ty (TBase i)
  | wfTArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (TArrow T1 T2)
  | wfTRNil :
        well_formed_ty TRNil
  | wfTRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (TRCons i T1 T2).

Hint Constructors record_ty well_formed_ty.

(** Note that [record_ty] and [record_tm] are not recursive -- they
    just check the outermost constructor.  The [well_formed_ty]
    property, on the other hand, verifies that the whole type is well
    formed in the sense that the tail of every record (the second
    argument to [TRCons]) is a record.

    Of course, we should also be concerned about ill-formed terms, not
    just types; but typechecking can rules those out without the help
    of an extra [well_formed_tm] definition because it already
    examines the structure of terms.  All we need is an analog of
    [record_ty] saying that a term is a record term if it is built
    with [trnil] and [trcons]. *)

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (trcons i t1 t2).

Hint Constructors record_tm.

(* ###################################################################### *)
(** *** Substitution *)

(** Substitution extends easily. *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar y => if beq_id x y then s else t
  | tabs y T t1 => tabs y T
                     (if beq_id x y then t1 else (subst x s t1))
  | tapp t1 t2 => tapp (subst x s t1) (subst x s t2)
  | tproj t1 i => tproj (subst x s t1) i
  | trnil => trnil
  | trcons i t1 tr1 => trcons i (subst x s t1) (subst x s tr1)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ###################################################################### *)
(** *** Reduction *)

(** A record is a value if all of its fields are. *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (tabs x T11 t12)
  | v_rnil : value trnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (trcons i v1 vr).

Hint Constructors value.

(** To define reduction, we'll need a utility function for extracting
    one field from record term: *)

Fixpoint tlookup (i:id) (tr:tm) : option tm :=
  match tr with
  | trcons i' t tr' => if beq_id i i' then Some t else tlookup i tr'
  | _ => None
  end.

(** The [step] function uses this term-level lookup function in the
    projection rule. *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (tapp (tabs x T11 t12) v2) ==> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  | ST_Proj1 : forall t1 t1' i,
        t1 ==> t1' ->
        (tproj t1 i) ==> (tproj t1' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        (tproj tr i) ==> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 ==> t1' ->
        (trcons i t1 tr2) ==> (trcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 ==> tr2' ->
        (trcons i v1 tr2) ==> (trcons i v1 tr2')

where "t1 '==>' t2" := (step t1 t2).

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

(* ###################################################################### *)
(** *** Typing *)

(** Next we define the typing rules.  These are nearly direct
    transcriptions of the inference rules shown above: the only
    significant difference is the use of [well_formed_ty].  In the
    informal presentation we used a grammar that only allowed
    well-formed record types, so we didn't have to add a separate
    check.

    One sanity condition that we'd like to maintain is that, whenever
    [has_type Gamma t T] holds, will also be the case that
    [well_formed_ty T], so that [has_type] never assigns ill-formed
    types to terms.  In fact, we prove this theorem below.  However,
    we don't want to clutter the definition of [has_type] with
    unnecessary uses of [well_formed_ty].  Instead, we place
    [well_formed_ty] checks only where needed: where an inductive call
    to [has_type] won't already be checking the well-formedness of a
    type.  For example, we check [well_formed_ty T] in the [T_Var]
    case, because there is no inductive [has_type] call that would
    enforce this.  Similarly, in the [T_Abs] case, we require a proof
    of [well_formed_ty T11] because the inductive call to [has_type]
    only guarantees that [T12] is well-formed. *)

Fixpoint Tlookup (i:id) (Tr:ty) : option ty :=
  match Tr with
  | TRCons i' T Tr' =>
      if beq_id i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- (tvar x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (update Gamma x T11) |- t12 \in T12 ->
      Gamma |- (tabs x T11 t12) \in (TArrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (TArrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (tapp t1 t2) \in T2
  (* records: *)
  | T_Proj : forall Gamma i t Ti Tr,
      Gamma |- t \in Tr ->
      Tlookup i Tr = Some Ti ->
      Gamma |- (tproj t i) \in Ti
  | T_RNil : forall Gamma,
      Gamma |- trnil \in TRNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- (trcons i t tr) \in (TRCons i T Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ###################################################################### *)
(** ** Examples *)

(** **** Exercise: 2 stars (examples)  *)
(** Finish the proofs below.  Feel free to use Coq's automation
    features in this proof.  However, if you are not confident about
    how the type system works, you may want to carry out the proofs
    first using the basic features ([apply] instead of [eapply], in
    particular) and then perhaps compress it using automation.  Before
    starting to prove anything, make sure you understand what it is
    saying.*)

Lemma typing_example_2 :
  empty |-
    (tapp (tabs a (TRCons i1 (TArrow A A)
                      (TRCons i2 (TArrow B B)
                       TRNil))
              (tproj (tvar a) i2))
            (trcons i1 (tabs a A (tvar a))
            (trcons i2 (tabs a B (tvar a))
             trnil))) \in
    (TArrow B B).
Proof.
  (* FILL IN HERE *) Admitted.

Example typing_nonexample :
  ~ exists T,
      (update empty a (TRCons i2 (TArrow A A)
                                TRNil)) |-
               (trcons i1 (tabs a B (tvar a)) (tvar a)) \in
               T.
Proof.
  (* FILL IN HERE *) Admitted.

Example typing_nonexample_2 : forall y,
  ~ exists T,
    (update empty y A) |-
           (tapp (tabs a (TRCons i1 A TRNil)
                     (tproj (tvar a) i1))
                   (trcons i1 (tvar y) (trcons i2 (tvar y) trnil))) \in
           T.
Proof.
  (* FILL IN HERE *) Admitted.

(* ###################################################################### *)
(** ** Properties of Typing *)

(** The proofs of progress and preservation for this system are
    essentially the same as for the pure simply typed lambda-calculus,
    but we need to add some technical lemmas involving records. *)

(* ###################################################################### *)
(** *** Well-Formedness *)

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve by inversion.
  - (* TRCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (beq_id i i0)...
    inversion H0. subst...  Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr ==> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.

Lemma has_type__wf : forall Gamma t T,
  Gamma |- t \in T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
Qed.

(* ###################################################################### *)
(** *** Field Lookup *)

(** Lemma: If [empty |- v : T] and [Tlookup i T] returns [Some Ti],
     then [tlookup i v] returns [Some ti] for some term [ti] such
     that [empty |- ti \in Ti].

    Proof: By induction on the typing derivation [Htyp].  Since
      [Tlookup i T = Some Ti], [T] must be a record type, this and
      the fact that [v] is a value eliminate most cases by inspection,
      leaving only the [T_RCons] case.

      If the last step in the typing derivation is by [T_RCons], then
      [t = trcons i0 t tr] and [T = TRCons i0 T Tr] for some [i0],
      [t], [tr], [T] and [Tr].

      This leaves two possiblities to consider - either [i0 = i] or
      not.

      - If [i = i0], then since [Tlookup i (TRCons i0 T Tr) = Some
        Ti] we have [T = Ti].  It follows that [t] itself satisfies
        the theorem.

      - On the other hand, suppose [i <> i0].  Then

        Tlookup i T = Tlookup i Tr

        and

        tlookup i t = tlookup i tr,

        so the result follows from the induction hypothesis. []

    Here is the formal statement:
*)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ empty |- ti \in Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  induction Htyp; subst; try solve by inversion...
  - (* T_RCons *)
    simpl in Hget. simpl. destruct (beq_id i i0).
    + (* i is first *)
      simpl. inversion Hget. subst.
      exists t...
    + (* get tail *)
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

(* ###################################################################### *)
(** *** Progress *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.
Proof with eauto.
  (* Theorem: Suppose empty |- t : T.  Then either
       1. t is a value, or
       2. t ==> t' for some t'.
     Proof: By induction on the given typing derivation. *)
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  induction Ht; intros HeqGamma; subst.
  - (* T_Var *)
    (* The final rule in the given typing derivation cannot be
       [T_Var], since it can never be the case that
       [empty |- x : T] (since the context is empty). *)
    inversion H.
  - (* T_Abs *)
    (* If the [T_Abs] rule was the last used, then
    [t = tabs x T11 t12], which is a value. *)
    left...
  - (* T_App *)
    (* If the last rule applied was T_App, then [t = t1 t2],
       and we know from the form of the rule that
         [empty |- t1 : T1 -> T2]
         [empty |- t2 : T1]
       By the induction hypothesis, each of t1 and t2 either is a value
       or can take a step. *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
      (* If both [t1] and [t2] are values, then we know that
         [t1 = tabs x T11 t12], since abstractions are the only
         values that can have an arrow type.  But
         [(tabs x T11 t12) t2 ==> [x:=t2]t12] by [ST_AppAbs]. *)
        inversion H; subst; try (solve by inversion).
        exists ([x:=t2]t12)...
      * (* t2 steps *)
        (* If [t1] is a value and [t2 ==> t2'], then
           [t1 t2 ==> t1 t2'] by [ST_App2]. *)
        destruct H0 as [t2' Hstp]. exists (tapp t1 t2')...
    + (* t1 steps *)
      (* Finally, If [t1 ==> t1'], then [t1 t2 ==> t1' t2]
         by [ST_App1]. *)
      destruct H as [t1' Hstp]. exists (tapp t1' t2)...
  - (* T_Proj *)
    (* If the last rule in the given derivation is [T_Proj], then
       [t = tproj t i] and
           [empty |- t : (TRcd Tr)]
       By the IH, [t] either is a value or takes a step. *)
    right. destruct IHHt...
    + (* rcd is value *)
      (* If [t] is a value, then we may use lemma
         [lookup_field_in_value] to show [tlookup i t = Some ti]
         for some [ti] which gives us [tproj i t ==> ti] by
         [ST_ProjRcd]. *)
      destruct (lookup_field_in_value _ _ _ _ H0 Ht H)
        as [ti [Hlkup _]].
      exists ti...
    + (* rcd_steps *)
      (* On the other hand, if [t ==> t'], then
         [tproj t i ==> tproj t' i] by [ST_Proj1]. *)
      destruct H0 as [t' Hstp]. exists (tproj t' i)...
  - (* T_RNil *)
    (* If the last rule in the given derivation is [T_RNil],
       then [t = trnil], which is a value. *)
    left...
  - (* T_RCons *)
    (* If the last rule is [T_RCons], then [t = trcons i t tr] and
         [empty |- t : T]
         [empty |- tr : Tr]
       By the IH, each of [t] and [tr] either is a value or can
       take a step. *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2; try reflexivity.
      * (* tail is a value *)
      (* If [t] and [tr] are both values, then [trcons i t tr]
         is a value as well. *)
        left...
      * (* tail steps *)
        (* If [t] is a value and [tr ==> tr'], then
           [trcons i t tr ==> trcons i t tr'] by
           [ST_Rcd_Tail]. *)
        right. destruct H2 as [tr' Hstp].
        exists (trcons i t tr')...
    + (* head steps *)
      (* If [t ==> t'], then
         [trcons i t tr ==> trcons i t' tr]
         by [ST_Rcd_Head]. *)
      right. destruct H1 as [t' Hstp].
      exists (trcons i t' tr)...  Qed.

(* ###################################################################### *)
(** *** Context Invariance *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (tabs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (tproj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (trcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (trcons i ti tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t \in S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     Gamma' |- t \in S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (beq_idP x y)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; inversion Hafi; subst...
  - (* T_Abs *)
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_beq_id in Hctx...
Qed.

(* ###################################################################### *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     (update Gamma x U) |- t \in S  ->
     empty |- v \in U   ->
     Gamma |- ([x:=v]t) \in S.
Proof with eauto.
  (* Theorem: If Gamma,x:U |- t : S and empty |- v : U, then
     Gamma |- ([x:=v]t) S. *)
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  (* Proof: By induction on the term t.  Most cases follow
     directly from the IH, with the exception of tvar,
     tabs, trcons. The former aren't automatic because we
     must reason about how the variables interact. In the
     case of trcons, we must do a little extra work to show
     that substituting into a term doesn't change whether
     it is a record term. *)
  induction t;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  - (* tvar *)
    simpl. rename i into y.
    (* If t = y, we know that
         [empty |- v : U] and
         [Gamma,x:U |- y : S]
       and, by inversion, [update Gamma x U y = Some S].
       We want to show that [Gamma |- [x:=v]y : S].

       There are two cases to consider: either [x=y] or [x<>y]. *)
    unfold update, t_update in H0.
    destruct (beq_idP x y) as [Hxy|Hxy].
    + (* x=y *)
    (* If [x = y], then we know that [U = S], and that
       [[x:=v]y = v]. So what we really must show is that
       if [empty |- v : U] then [Gamma |- v : U].  We have
        already proven a more general version of this theorem,
        called context invariance! *)
      subst.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra)
        as [T' HT']...
      inversion HT'.
    + (* x<>y *)
    (* If [x <> y], then [Gamma y = Some S] and the substitution
       has no effect.  We can show that [Gamma |- y : S] by
       [T_Var]. *)
      apply T_Var...
  - (* tabs *)
    rename i into y. rename t into T11.
    (* If [t = tabs y T11 t0], then we know that
         [Gamma,x:U |- tabs y T11 t0 : T11->T12]
         [Gamma,x:U,y:T11 |- t0 : T12]
         [empty |- v : U]
       As our IH, we know that forall S Gamma,
         [Gamma,x:U |- t0 : S -> Gamma |- [x:=v]t0 S].

       We can calculate that
       [ [x:=v]t = tabs y T11 (if beq_id x y then t0 else [x:=v]t0) ],
       and we must show that [Gamma |- [x:=v]t : T11->T12].  We know
       we will do so using [T_Abs], so it remains to be shown that:
         [Gamma,y:T11 |- if beq_id x y then t0 else [x:=v]t0 : T12]
       We consider two cases: [x = y] and [x <> y]. *)
    apply T_Abs...
    destruct (beq_idP x y) as [Hxy|Hxy].
    + (* x=y *)
      (* If [x = y], then the substitution has no effect.  Context
         invariance shows that [Gamma,y:U,y:T11] and [Gamma,y:T11] are
         equivalent.  Since [t0 : T12] under the former context,
         this is also the case under the latter. *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (beq_id y x)...
    + (* x<>y *)
      (* If [x <> y], then the IH and context invariance allow
         us to show that
           [Gamma,x:U,y:T11 |- t0 : T12]       =>
           [Gamma,y:T11,x:U |- t0 : T12]       =>
           [Gamma,y:T11 |- [x:=v]t0 : T12] *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (beq_idP y z)...
      subst. rewrite false_beq_id...
  - (* trcons *)
    apply T_RCons... inversion H7; subst; simpl...
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t ==> t'  ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT.
  (* Theorem: If [empty |- t : T] and [t ==> t'], then
     [empty |- t' : T]. *)
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  (* Proof: By induction on the given typing derivation.
     Many cases are contradictory ([T_Var], [T_Abs]) or follow
     directly from the IH ([T_RCons]).  We show just the
     interesting ones. *)
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    (* If the last rule used was [T_App], then [t = t1 t2],
       and three rules could have been used to show [t ==> t']:
       [ST_App1], [ST_App2], and [ST_AppAbs]. In the first two
       cases, the result follows directly from the IH. *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      (* For the third case, suppose
           [t1 = tabs x T11 t12]
         and
           [t2 = v2].  We must show that [empty |- [x:=v2]t12 : T2].
         We know by assumption that
             [empty |- tabs x T11 t12 : T1->T2]
         and by inversion
             [x:T1 |- t12 : T2]
         We have already proven that substitution_preserves_typing and
             [empty |- v2 : T1]
         by assumption, so we are done. *)
      apply substitution_preserves_typing with T1...
      inversion HT1...
  - (* T_Proj *)
    (* If the last rule was [T_Proj], then [t = tproj t1 i].
       Two rules could have caused [t ==> t']: [T_Proj1] and
       [T_ProjRcd].  The typing of [t'] follows from the IH
       in the former case, so we only consider [T_ProjRcd].

       Here we have that [t] is a record value.  Since rule
       [T_Proj] was used, we know [empty |- t \in Tr] and
       [Tlookup i Tr = Some Ti] for some [i] and [Tr].
       We may therefore apply lemma [lookup_field_in_value]
       to find the record element this projection steps to. *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    (* If the last rule was [T_RCons], then [t = trcons i t tr]
       for some [i], [t] and [tr] such that [record_tm tr].  If
       the step is by [ST_Rcd_Head], the result is immediate by
       the IH.  If the step is by [ST_Rcd_Tail], [tr ==> tr2']
       for some [tr2'] and we must also use lemma [step_preserves_record_tm]
       to show [record_tm tr2']. *)
    apply T_RCons... eapply step_preserves_record_tm...
Qed.
(** [] *)

End STLCExtendedRecords.

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


Require Export BasicBlock.

Module Type CFGType.

Parameter toPaths : nat -> nat -> list (bool*(list nat)) -> list (list nat).

End CFGType.

Module CFG <: CFGType.

Fixpoint nthBlockEdges (blk:nat) (graph:list (bool*(list nat))) : bool*(list nat) :=
  match blk with
  | O => (false,[])
  | S O => match graph with
    | [] => (false,[])
    | g::gs => g
    end
  | S (S n) => match graph with
    | [] => (false,[])
    | g::gs => nthBlockEdges (S n) gs
    end
  end.

Fixpoint visitNthBlock (blk:nat) (graph:list (bool*(list nat))) : (list (bool*(list nat))) :=
  match blk with
  | 0 => graph
  | S O => match graph with
    | [] => []
    | (_,lst)::gs => (true,lst)::gs
    end
  | S (S n) => match graph with
    | [] => []
    | g::gs => g::(visitNthBlock (S n) gs)
    end
  end.

Fixpoint toAcyclicUptoNPaths (n:nat) (blk:nat) (graph:list (bool*(list nat))) : list (list nat) :=
  match n with
  | O => [[]]
  | (S n) => match blk with
    | O => [[O]]
    | _ => match (nthBlockEdges blk graph) with
      | (true,_) => [[]]
      | (false,lst) => (fold (map lst (fun x =>
        (map (toAcyclicUptoNPaths n x (visitNthBlock blk graph)) (fun y=>blk::y))))
        (fun x => fun y => fold x (fun x2 => fun y2 => x2::y2) y) [])
      end
    end
  end.

Definition pathsWith (blk:nat) (paths:list (list nat)) : list (list nat) :=
  filter paths (fun x => findIf x (areEqualNum blk)).

Fixpoint uptoBlockIn (blk:nat) (path:list nat) : list nat :=
  match path with
  | [] => []
  | x::xs => match areEqualNum x blk with
    | true => []
    | false => x::(uptoBlockIn blk xs)
    end
  end.

Definition uptoBlock (blk:nat) (paths:list (list nat)) : list (list nat) :=
  map paths (uptoBlockIn blk).

Definition toPathsAcyc (blk:nat) (graph:list (list nat)) : list (list nat) :=
  (toAcyclicUptoNPaths (S (length graph)) blk (map graph (fun x=>(false,x)))).

(* Must handle case of 0 paths i.e. dead code/ stuck code*)

Definition sdom (blks:list nat) (graph:list (list nat)) (paths:list (list nat)) : list (nat*(list nat)) :=
  map blks (fun blk =>
  (blk,(fold (uptoBlock blk (pathsWith blk paths))
  (fun x=> fun y=>intersection x y areEqualNum)
  (nToZero (length graph))))).

Definition findSdom (blk:nat) (sd:list (nat*(list nat))) : list nat :=
  fold sd (fun x=>fun y=>match x with | (x1,x2) => match (areEqualNum x1 blk) with | true => x2 | false => y end end) [].

Definition idom (blks:list nat) (graph:list (list nat)) (paths:list (list nat)) : list (nat*(list nat)) :=
  (fun sd=>map blks (fun blk=>(blk,((fun ls=>fold (map ls (fun x=>findSdom x sd)) (fun x => fun y=>difference y x areEqualNum) ls) (findSdom blk sd)))))
  (sdom blks graph paths).

Definition fdom (blks:list nat) (graph:list (list nat)) : list (nat*(list nat)) :=
  map blks (fun blk=>(blk,difference ((fun paths=>(fold paths (fun x=>fun y=>intersection x y areEqualNum)
    (match paths with | [] => [] | _ => (nToZero (length graph)) end)))
    (toPathsAcyc blk graph))
    [blk] areEqualNum)).

Definition findFdom (blk:nat) (fd:list (nat*(list nat))) : list nat :=
  fold fd (fun x=>fun y=>match x with | (x1,x2) => match (areEqualNum x1 blk) with | true => x2 | false => y end end) [].

Definition ifdom (blks:list nat) (graph:list (list nat)) : list (nat*(list nat)) :=
  (fun fd=>map blks (fun blk=>(blk,(fun ls=> fold ls (fun x=> fun y=> difference y (findFdom x fd) areEqualNum) ls) (findFdom blk fd))))
  (fdom blks graph).

Definition tripFrom (blk:nat) (path:list nat) := match (fold path (fun x=> fun y=> match (areEqualNum x blk),y with
  | true,(_,y1) => (x::y1,[])
  | false,(y1,y2) => (y1,x::y2) end) ([],[])) with | (y1,y2) => y2 end.

Fixpoint toPaths2 (n:nat) (blk:nat) (graph:list (bool*(list nat))) : list (list (bool*(list nat))) :=
  match n with
  | O => [graph]
  | (S n) => match blk with
    | O => [graph]
    | _ => match (nthBlockEdges blk graph) with
      | (true,_) => []
      | (false,lst) => (fold (map lst (fun x =>
        (toPaths2 n x (visitNthBlock blk graph))))
        (fun x => fun y => fold x (fun x2 => fun y2 => x2::y2) y) [])
      end
    end
  end.

Require Export Example.

Definition tillIfDom (blks:list nat) (graph:list (list nat)) : list (nat*(list nat)) := (fun ifd => (map blks (fun blk=> (fun paths =>
  (blk,(fold (fold (findFdom blk ifd) (fun dom=>uptoBlock dom) paths) (fun x=>fun y=> x++y )[])))
  (map (toPathsAcyc blk graph) (fun x=>difference x [blk] areEqualNum)))))
  (ifdom blks graph).

Compute (tillIfDom [1;2;3;4;0;0] (BasicBlock.toBlocks3 mb1)).

Definition g1 := map (BasicBlock.toBlocks3 mb1) (fun x => (false,x)).

Compute (pathsWith 4 (toAcyclicUptoNPaths 6 1 g1)).


(* Empezamos por definir tries binarios como en el artículo. *)
Inductive binTrie1: Type :=
| empty1 : binTrie1
| leaf1: nat -> binTrie1
| trie1: binTrie1 -> binTrie1 -> binTrie1.


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

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

Print Assumptions square.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Rel.Definitions.
Require Import Rel.BasicFacts.
Require Import Util.Subset.
Require Import Lang.Static.
Require Import Lang.StaticFacts.
Set Implicit Arguments.

Section section_compat_tm_app.

Context (EV HV V : Set).
Context (Ξ : XEnv EV HV).
Context (Γ : V → ty EV HV ∅).
Context (P : HV → F).
Context (S T : ty EV HV ∅).
Context (𝓔 : eff EV HV ∅).
Context (t₁ t₂ : tm EV HV V ∅).
Context (s₁ s₂ : tm EV HV V ∅).

Hint Resolve subset_trans postfix_refl postfix_is_subset.

Lemma compat_tm_app n :
n ⊨ ⟦ Ξ P Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_fun S T 𝓔) # 𝓔 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ s₁ ≼ˡᵒᵍ s₂ : S # 𝓔 ⟧ →
n ⊨ ⟦ Ξ P Γ ⊢ (tm_app t₁ s₁) ≼ˡᵒᵍ (tm_app t₂ s₂) : T # 𝓔 ⟧.
Proof.
intros Ht Hs.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hρ ; iintro Hγ.

iespecialize Ht.
repeat (ispecialize Ht ; [ eassumption | ]).
simpl.
generalize Ht.
generalize (subst_tm δ₁ ρ₁ γ₁ t₁), (subst_tm δ₂ ρ₂ γ₂ t₂).
clear Ht t₁ t₂ ; intros t₁ t₂ Ht.
bind_app1.
eapply plug0 with (ξ₁ := ξ₁) (ξ₂ := ξ₂) ; [crush|crush| |auto|auto|exact Ht].
iintro ξ₁' ; iintro ξ₂' ; iintro v₁ ; iintro v₂ ;
iintro Hξ₁' ; iintro Hξ₂' ; iintro Hv.
ielim_prop Hξ₁' ; ielim_prop Hξ₂'.

ispecialize Hs ξ₁' ; ispecialize Hs ξ₂' ;
ispecialize Hs δ₁ ; ispecialize Hs δ₂ ; ispecialize Hs δ ;
ispecialize Hs ρ₁ ; ispecialize Hs ρ₂ ; ispecialize Hs ρ ;
ispecialize Hs γ₁ ; ispecialize Hs γ₂.
ielim_prop Hξ ; destruct Hξ as [Hξ₁ Hξ₂].
ielim_prop cl_ρ₁ρ₂.
ispecialize Hs.
{ clear - Hξ₁ Hξ₂ Hξ₁' Hξ₂'.
  iintro_prop ; split ; eauto.
}
ispecialize Hs.
{ clear - cl_δ Hξ₁' Hξ₂'.
  eapply closed_δ_monotone ; eauto.
}
ispecialize Hs.
{ clear - cl_ρ₁ρ₂ Hξ₁' Hξ₂'.
  iintro_prop ; eapply closed_ρ_monotone ; eauto.
}
ispecialize Hs.
{ clear - Hρ Hξ₁' Hξ₂'.
  eapply 𝑷_monotone ; eauto.
}
ispecialize Hs.
{ clear - Hγ Hξ₁' Hξ₂'.
  eapply 𝜞_monotone ; eauto.
}
simpl.
generalize Hs.
generalize (subst_tm δ₁ ρ₁ γ₁ s₁), (subst_tm δ₂ ρ₂ γ₂ s₂).
clear Hs s₁ s₂.
intros s₁ s₂ Hs.
bind_app2.
eapply plug0 with (ξ₁ := ξ₁') (ξ₂ := ξ₂') ; [crush|crush| |auto|auto|exact Hs].
iintro ξ₁'' ; iintro ξ₂'' ; iintro u₁ ; iintro u₂ ;
iintro Hξ₁'' ; iintro Hξ₂'' ; iintro Hu.
ielim_prop Hξ₁'' ; ielim_prop Hξ₂''.

clear - Hv Hu Hξ₁' Hξ₂' Hξ₁'' Hξ₂''.
simpl in Hv |- *.
ispecialize Hv ξ₁'' ; ispecialize Hv ξ₂''.
repeat (ispecialize Hv ; [ eauto | ]).
iespecialize Hv.
ispecialize Hv ; [ eassumption | ].
exact Hv.

Qed.

End section_compat_tm_app.