Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Uint63.
Require Import Coq.Init.Nat.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
identifier : type for variable and array names, a string
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Definition identifier: Type := string.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
aexpr : type representing an arithmetic expression
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive aexpr: Type :=
|Num (v: Z)
|Arr (id: identifier) (idx: aexpr)
|Var (id: identifier)
|Minus (lhs rhs: aexpr)
|Plus (lhs rhs: aexpr)
.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
bexpr : type representing a boolean expression
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive bexpr: Type :=
|Bool (b: bool)
|Lt (lhs rhs: aexpr)
|Lte (lhs rhs: aexpr)
|Eq (lhs rhs: aexpr)
|Neq (lhs rhs: aexpr)
|Gt (lhs rhs: aexpr)
|Gte (lhs rhs: aexpr)
|Nand (lhs rhs: bexpr)
.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
aexpr : type representing a label
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Record classic_label: Type := mkLabel
{
  n: nat;
  l: nat;
}.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
eq_label : checks equality between two labels
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Definition eq_label (l1 l2: classic_label): bool := (Nat.eqb (n l1) (n l2) ) && (Nat.eqb (l l1) (l l2) ) .

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
labelling : type representing a labelling, an at label, an after label
            and a break-to label (which is only used for the break statement)
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Record labelling  (A: Type ): Type := mkLabelling
{
  atl: A;
  af: A;
  br: A;
}.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
declaration : type representing the declaration of variables at the start of a program
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive declaration: Type :=
| ArrayInit (id: identifier) (size: int)
| VarInit (id: identifier)
.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
ne_list : type representing a list that can't be empty
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive ne_list (A: Type) :=
|Single (t:A)
|NECons (head:A) (tail: ne_list A)
.

Arguments Single {_} t.
Arguments NECons {_} head tail.

Notation "[| x |]" := (Single x ).
Infix "~~" := NECons (at level 60, right associativity) : list_scope.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
ne_length : computes the length of a non-empty list.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Definition ne_length (A : Type) : ne_list A -> nat :=
  fix ne_length l :=
  match l with
   | [|_|] => S 0
   | NECons _ l' => S (ne_length l')
  end.

Arguments ne_length {_}.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
Quick proof to show that the length of a ne_list > 0.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Theorem ne_list_length : forall (A:Type) , forall (nel: ne_list A), (ne_length nel) > 0.
Proof.
intros.
induction nel.
+ simpl. auto.
+ simpl. apply gt_Sn_O.
Qed.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
statement : type to represent the statements of a program TODO add error.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive statement (A: Type) : Type :=
| VarAssign (assignee: identifier) (assigned: aexpr) (l: labelling A)
| ArrAssign (assignee: identifier) (idx: aexpr) (assigned: aexpr) (l: labelling A)
| Emptystmt (l: labelling A)
| If (test: bexpr) (body: statement A) (l: labelling A)
| Ifelse (test: bexpr) (ibody ebody: statement A) (l: labelling A)
| While (test: bexpr) (body: statement A) (l: labelling A)
| Break (l: labelling A)
| Compound (sts: ne_list (statement A)) (l: labelling A)
| Breakable (sts: ne_list (statement A)) (l: labelling A)
.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
get_stmt : gets the labelling of a statement.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Definition get_stmt_labelling (A: Type) (s: statement A) : labelling A :=
match s with
| ArrAssign _ _ _ _ l => l
| VarAssign _ _ _ l => l
| Emptystmt _ l => l
| If _ _ _ l => l
| Ifelse _ _ _ _ l => l
| While _ _ _ l => l
| Break _ l => l
| Compound _ _ l => l
| Breakable _ _ l => l
end.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
prog: type to represent a program. a list of declared variables,
      a list of statements and a starting label.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive prog (A: Type) : Type :=
|Prog (decls: list declaration) (sts: statement A) (l: labelling A)
.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
ustatement : type to represent the ustatements of an unrolled program.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive ustatement (A: Type) : Type :=
| UVarAssign (assignee: identifier) (assigned: aexpr) (l: labelling A)
| UArrAssign (assignee: identifier) (idx: aexpr) (assigned: aexpr) (l: labelling A)
| UEmptystmt (l: labelling A)
| UIf (test: bexpr) (body: ustatement A) (l: labelling A)
| UIfelse (test: bexpr) (ibody ebody: ustatement A) (l: labelling A)
| UBreak (l: labelling A)
| UCompound (sts: ne_list (ustatement A)) (l: labelling A)
| UBreakable (sts: ne_list (ustatement A)) (l: labelling A)
| UErrorStmt (l: labelling A)
.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
get_stmt : gets the labelling of a ustatement.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Definition get_ustmt_labelling (A: Type) (s: ustatement A) : labelling A :=
match s with
| UArrAssign _ _ _ _ l => l
| UVarAssign _ _ _ l => l
| UEmptystmt _ l => l
| UIf _ _ _ l => l
| UIfelse _ _ _ _ l => l
| UBreak _ l => l
| UCompound _ _ l => l
| UBreakable _ _ l => l
| UErrorStmt _ l => l
end.

(*<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
prog: type to represent an unrolled program. a list of declared variables,
      a list of ustatements and a starting label.
<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>*)
Inductive uprog (A: Type) : Type :=
|UProg (decls: list declaration) (sts: ustatement A) (l: labelling A)
.


Set Implicit Arguments.
Require Import TLC.LibLN.
Require Import GFSubFull.

(*

RS is the declarative specification of subtyping, which
includes the built-in Sym rule.

*)

Inductive RS : env -> Mode -> typ -> typ -> Prop :=
| RSInt : forall m E, okt E -> RS E m typ_int typ_int
| RSTB1 : forall A m E, okt E -> wft E A -> RS E m A (mode_to_sub m)
| RSFun : forall A B C D m E, RS E (flip m) A C -> RS E m B D -> RS E m (typ_arrow A B) (typ_arrow C D)
| RSVarRefl : forall E X m, okt E -> wft E (typ_fvar X) -> RS E m (typ_fvar X) (typ_fvar X)
| RSVarBnd : forall E X m T F, binds X (bind_tRel m T) E -> RS E m T F -> RS E m (typ_fvar X) F
| RSAll : forall E L m1 m2 T1 T2 T3 T4,
  RS E (BindPosVariance m1 m2) T1 T2 ->
(forall X, X \notin L ->
  RS (E&(X !: m1 <>: (SelectBound m2 T1 T2))) m2 (T3 open_tt_var X) (T4 open_tt_var X))->
  RS E m2 (typ_all m1 T1 T3) (typ_all m1 T2 T4)
| RSSym : forall m A B E, RS E (flip m) B A -> RS E m A B.

Hint Constructors RS.

Lemma flip_flip : forall m, flip (flip m) = m.
  destruct m; simpl; eauto.
Defined.

Lemma sound : forall m A B E, R E m A B -> RS E m A B.
  intros.
  induction H; eauto.
  - apply RSSym.
    rewrite flip_flip. eauto.
Defined.

Lemma complete : forall m A B E, RS E m A B -> R E m A B.
  intros.
  induction H; eauto.
  - apply SVarBnd with (T := T); eauto.
  - apply SAll with (L := L). auto. auto.
  - apply sym2.
    auto.
Defined.

(*

R2 an algorithmic version that exploits duality for economy
of code.

*)

Inductive R2 : env -> bool -> Mode -> typ -> typ -> Prop :=
| R2Int : forall b m E, okt E -> R2 E b m typ_int typ_int
| R2TB1 : forall b A m E, okt E -> wft E A -> R2 E b m A (mode_to_sub m)
| R2Fun : forall b A B C D m E,
    R2 E true (flip m) A C ->
    R2 E true m B D ->
    R2 E b m (typ_arrow A B) (typ_arrow C D)
| R2VarRefl : forall E X m b, okt E -> wft E (typ_fvar X) -> R2 E b m (typ_fvar X) (typ_fvar X)
| R2VarBnd : forall E X m T F b, binds X (bind_tRel m T) E -> R2 E true m T F -> R2 E b m (typ_fvar X) F
| R2All : forall E L m1 m2 T1 T2 T3 T4 b,
  R2 E true (BindPosVariance m1 m2) T1 T2 ->
(forall X, X \notin L ->
  R2 (E&(X !: m1 <>: (SelectBound m2 T1 T2))) true m2 (T3 open_tt_var X) (T4 open_tt_var X))->
  R2 E b m2 (typ_all m1 T1 T3) (typ_all m1 T2 T4)
| R2Sym : forall m A B E,
    R2 E false (flip m) B A -> R2 E true m A B.

Hint Constructors R2.

(* Soundness of R2 *)

Require Import Program.Equality.

Lemma R2_false : forall m A B E, R2 E false m A B -> R2 E true m A B.
  intros.
  dependent induction H; eauto.
Defined.

Lemma invR2 : forall b m A B E, R2 E b m A B -> R2 E true (flip m) B A.
  intros.
  induction H; eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2Sym. rewrite flip_flip. eauto.
  - apply R2_false. auto.
Defined.

Lemma completeR : forall m A B E, R E m A B -> R2 E true m A B.
  intros.
  induction H; eauto.
  - apply R2Sym.
    rewrite flip_flip in *.
    eauto.
Defined.

Lemma soundR : forall m b A B E, R2 E b m A B -> R E m A B.
  intros.
  induction H; eauto.
  - apply SVarBnd with (T := T); eauto.
  - apply SAll with (L := L). auto. auto.
  - apply sym2. auto.
Defined.


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

(** This is a Coq implementation of the abstract intuitionistic proof
    of Ramsey's theorem by Thierry Coquand

           http://www.cse.chalmers.se/~coquand/ramsey2.pdf

    This implementation follows the argumentation and the notations
    of the paper as faithfully as possible, including the tailored
    double induction principles which are used in the proofs, and
    upto the symbols chosen.

    However,

    We rename the Ar(ity) predicate into US (for Ultimately Stable)
    and the AF (Almost Full) predicate into UF (for Ultimately Full)

    For short/easy proofs of lattice (in)equations, we use Setoid
    rewriting. Maybe some automation could be done here.

  *)

Require Import Wellfounded Coq.Setoids.Setoid.

Require Import base.

Set Implicit Arguments.

(** Symbols for copy/paste: ⊔ ⊓ ⊑ ≡  ⋅ ↑ ↓ ⇑ ⇓ ∀ ∃ *)

Section Ramsey.

  (** We start with some distributive lattice theory *)

  Variable (Σ : Type) (le : Σ -> Σ -> Prop) (lub glb : Σ -> Σ -> Σ) (bot top : Σ).

  Notation "x ⊑ y" := (le x y).

  Definition lattice_eq x y := x ⊑ y /\ y ⊑ x.

  Notation lat_eq := lattice_eq.

  Notation "x ≡ y" := (lattice_eq x y).
  Notation "x ⊓ y" := (glb x y).
  Notation "x ⊔ y" := (lub x y).

  Notation "⊥" := bot.
  Notation "⊤" := top.

  Hypothesis (le_refl : ∀x, x ⊑ x) (le_trans : ∀x y z, x ⊑ y -> y ⊑ z -> x ⊑ z).

  Hypothesis (lub_spec : ∀x y z, x ⊔ y ⊑ z <-> x ⊑ z /\ y ⊑ z)
             (glb_spec : ∀x y z, z ⊑ x ⊓ y <-> z ⊑ x /\ z ⊑ y)
             (bot_spec : ∀x, ⊥ ⊑ x)
             (top_spec : ∀x, x ⊑ ⊤).

 (* Notation least := (fun x => x ≡ ⊥). *)

  Hint Resolve le_refl.

  Fact lattice_eq_refl x : x ≡ x.
  Proof. split; auto. Qed.

  Fact lattice_eq_sym x y : x ≡ y -> y ≡ x.
  Proof. intros []; split; auto. Qed.

  Fact lattice_eq_trans x y z : x ≡ y -> y ≡ z -> x ≡ z.
  Proof. intros [] []; split; apply le_trans with y; auto. Qed.

  Hint Resolve lattice_eq_refl lattice_eq_sym.

  Add Parametric Relation: (Σ) (lattice_eq)
      reflexivity proved by lattice_eq_refl
      symmetry proved by lattice_eq_sym
      transitivity proved by lattice_eq_trans
    as lattice_eq_rst.

  Tactic Notation "lat" "sym" := apply eq_sym.

  Tactic Notation "lat" "trans" constr(x) :=
    match goal with
      | |- _ ⊑ _ => apply le_trans with x
      | |- _ ≡ _ => apply eq_trans with x
    end; auto.

  Fact lub_inc_lft x y : x ⊑ x ⊔ y.
  Proof. apply (lub_spec x y (x ⊔ y)); auto. Qed.

  Fact lub_inc_rt x y : y ⊑ x ⊔ y.
  Proof. apply (lub_spec x y (x ⊔ y)); auto. Qed.

  Fact glb_dec_lft x y : x ⊓ y ⊑ x.
  Proof. apply (glb_spec x y (x ⊓ y)); auto. Qed.

  Fact glb_dec_rt x y : x ⊓ y ⊑ y.
  Proof. apply (glb_spec x y (x ⊓ y)); auto. Qed.

  Hint Resolve le_refl
               lub_inc_lft lub_inc_rt
               glb_dec_lft glb_dec_rt.

  Tactic Notation "lat" "left" :=
    match goal with
      | |- _ ⊑ _ ⊔ _ => apply le_trans with (2 := lub_inc_lft _ _)
      | |- _ ⊓ _ ⊑ _ => apply le_trans with (1 := glb_dec_lft _ _)
    end; auto.

  Tactic Notation "lat" "right" :=
    match goal with
      | |- _ ⊑ _ ⊔ _ => apply le_trans with (2 := lub_inc_rt _ _)
      | |- _ ⊓ _ ⊑ _ => apply le_trans with (1 := glb_dec_rt _ _)
    end; auto.

  Fact lub_mono x1 x2 y1 y2 : x1 ⊑ y1 -> x2 ⊑ y2 -> x1 ⊔ x2 ⊑ y1 ⊔ y2.
  Proof. intros; apply lub_spec; split; [ lat left | lat right ]. Qed.

  Fact glb_mono x1 x2 y1 y2 : x1 ⊑ y1 -> x2 ⊑ y2 -> x1 ⊓ x2 ⊑ y1 ⊓ y2.
  Proof. intros; apply glb_spec; split; [ lat left | lat right ]. Qed.

  Hint Resolve lub_mono glb_mono.

  Add Parametric Morphism: (lub) with signature (lat_eq) ==> (lat_eq) ==> (le) as lattice_le_lub.
  Proof. intros ? ? [] ? ? []; auto. Qed.

  Add Parametric Morphism: (glb) with signature (lat_eq) ==> (lat_eq) ==> (le) as lattice_le_glb.
  Proof. intros ? ? [] ? ? []; auto. Qed.

  Add Parametric Morphism: (lub) with signature (lat_eq) ==> (lat_eq) ==> (lat_eq) as lattice_eq_lub.
  Proof. intros ? ? [] ? ? []; split; auto. Qed.

  Add Parametric Morphism: (glb) with signature (lat_eq) ==> (lat_eq) ==> (lat_eq) as lattice_eq_glb.
  Proof. intros ? ? [] ? ? []; split; auto. Qed.

  Add Parametric Morphism: (le) with signature (lat_eq) ==> (lat_eq) ==> (iff) as lattice_eq_le_iff.
  Proof.
    intros x1 y1 (H1 & H2) x2 y2 (H3 & H4); split; intros H5.
    + apply le_trans with (1 := H2), le_trans with (1 := H5); auto.
    + apply le_trans with (1 := H1), le_trans with (1 := H5); auto.
  Qed.

  Tactic Notation "lat" "mono" :=
    match goal with
      | |- _ ⊔ _ ⊑ _ ⊔ _ => apply lub_mono
      | |- _ ⊓ _ ⊑ _ ⊓ _ => apply glb_mono
      | |- _ ⊔ _ ≡ _ ⊔ _ => apply lattice_eq_lub
      | |- _ ⊓ _ ≡ _ ⊓ _ => apply lattice_eq_glb
    end; auto.

  Tactic Notation "lat" "spec" :=
    repeat (match goal with
      | |- _ ⊔ _ ⊑ _ => apply lub_spec
      | |- _ ⊑ _ ⊓ _ => apply glb_spec
    end; split; auto).

  Tactic Notation "lat" "absurd" := apply le_trans with ⊥; auto.

  Fact lub_comm_le x y : x ⊔ y ⊑ y ⊔ x.    Proof. rewrite lub_spec; split; auto. Qed.
  Fact glb_comm_le x y : x ⊓ y ⊑ y ⊓ x.    Proof. rewrite glb_spec; split; auto. Qed.

  Hint Resolve lub_comm_le glb_comm_le.

  Fact lub_comm x y : x ⊔ y ≡ y ⊔ x.       Proof. split; auto. Qed.
  Fact glb_comm x y : x ⊓ y ≡ y ⊓ x.       Proof. split; auto. Qed.

  Hint Immediate lub_comm glb_comm.

  Section idempotent.

    Let lub_idem_le x : x ⊔ x ⊑ x.    Proof. apply lub_spec; auto. Qed.
    Let glb_idem_le x : x ⊑ x ⊓ x.    Proof. apply glb_spec; auto. Qed.

    Fact lub_idem x : x ⊔ x ≡ x.      Proof. split; auto. Qed.
    Fact glb_idem x : x ⊓ x ≡ x.      Proof. split; auto. Qed.

  End idempotent.

  Fact le_lub_bot x y : x ⊑ ⊥ -> y ⊑ ⊥ -> x ⊔ y ⊑ ⊥.
  Proof. intros; rewrite <- (lub_idem ⊥); auto. Qed.

  Fact le_top_glb x y : ⊤ ⊑ x -> ⊤ ⊑ y -> ⊤ ⊑ x ⊓ y.
  Proof. intros; rewrite <- (glb_idem ⊤); auto. Qed.

  Section assoc.

    Let lub_assoc_1 x y z : x⊔(y⊔z) ⊑ (x⊔y)⊔z.
    Proof.
      apply lub_spec; split; auto.
      apply le_trans with (2 := lub_inc_lft _ _); auto.
    Qed.

    Let glb_assoc_1 x y z : x⊓(y⊓z) ⊑ (x⊓y)⊓z.
    Proof.
      apply glb_spec; split; auto.
      apply le_trans with (1 := glb_dec_rt _ _); auto.
    Qed.

    Fact lub_assoc x y z : x⊔(y⊔z) ≡ (x⊔y)⊔z.
    Proof.
      split; auto.
      rewrite lub_comm, (lub_comm x), (lub_comm x (y ⊔ z)), (lub_comm y z); auto.
    Qed.

    Fact glb_assoc x y z : x⊓(y⊓z) ≡ (x⊓y)⊓z.
    Proof.
      split; auto.
      rewrite glb_comm, (glb_comm x), (glb_comm x (y ⊓ z)), (glb_comm y z); auto.
    Qed.

  End assoc.

  Fact le_glb_eq x y : x ⊑ y <-> x ≡ x ⊓ y.
  Proof.
    split.
    + split; auto; lat spec.
    + intros (H & _); apply le_trans with (1 := H); auto.
  Qed.

  Fact le_lub_eq x y : x ⊑ y <-> y ≡ x ⊔ y.
  Proof.
    split.
    + split; auto; lat spec.
    + intros (_ & H); apply le_trans with (2 := H); auto.
  Qed.

  Fact glb_lub_eq x y : x ≡ x ⊓ (x ⊔ y).
  Proof. apply le_glb_eq; auto. Qed.

  Fact lub_glb_eq x y : x ≡ x ⊔ (x ⊓ y).
  Proof. rewrite lub_comm; apply le_lub_eq; auto. Qed.

  Fact lub_bot x : ⊥ ⊔ x ≡ x.      Proof. split; auto; lat spec. Qed.
  Fact glb_bot x : ⊥ ⊓ x ≡ ⊥.      Proof. split; auto. Qed.
  Fact lub_top x : ⊤ ⊔ x ≡ ⊤.      Proof. split; auto. Qed.
  Fact glb_top x : ⊤ ⊓ x ≡ x.      Proof. split; auto; lat spec. Qed.

  Fact le_glb_simpl x y : x ⊑ y -> x ⊓ y ≡ x.    Proof. symmetry; apply le_glb_eq; auto. Qed.
  Fact le_lub_simpl x y : x ⊑ y -> x ⊔ y ≡ y.    Proof. symmetry; apply le_lub_eq; auto. Qed.

  Fact le_bot_eq x : x ⊑ ⊥ -> x ≡ ⊥.        Proof. split; auto. Qed.
  Fact le_top_eq x : ⊤ ⊑ x -> x ≡ ⊤.        Proof. split; auto. Qed.

  Hypothesis (distrib : ∀x y z, (x ⊔ y) ⊓ z ⊑ (x ⊓ z) ⊔ (y ⊓ z)).

  Fact glb_distrib x y z : (x ⊔ y) ⊓ z ≡ (x ⊓ z) ⊔ (y ⊓ z).
  Proof. split; auto; lat spec. Qed.

  Fact lub_distrib x y z : (x ⊓ y) ⊔ z ≡ (x ⊔ z) ⊓ (y ⊔ z).
  Proof.
    rewrite glb_distrib.
    rewrite (glb_comm x (_ ⊔ _)).
    rewrite (glb_comm z (_ ⊔ _)).
    repeat rewrite glb_distrib.
    rewrite glb_idem, (@le_lub_simpl (y ⊓ z) z); auto.
    rewrite <- lub_assoc, (@le_lub_simpl (z ⊓ x) z); auto.
    rewrite glb_comm; auto.
  Qed.

  Fact distrib_glb_rt x y z : z ⊓ (x ⊔ y) ≡ (z ⊓ x) ⊔ (z ⊓ y).
  Proof. rewrite glb_comm, glb_distrib, glb_comm, (glb_comm _ y); auto. Qed.

  Fact distrib_lub_rt x y z : z ⊔ (x ⊓ y) ≡ (z ⊔ x) ⊓ (z ⊔ y).
  Proof. rewrite lub_comm, lub_distrib, lub_comm, (lub_comm _ y); auto. Qed.

  (** Now we come to the abstract proof of Ramsey by Th. Coquand
      Notation that we now denotes a,b,r,s for elements of type Σ
      whereas lifts are denoted by a[x] where x : X, as done in
      the paper proof
  *)

  Variables (X : Type) (op : X -> Σ -> Σ).

  Notation "a ⋅ x" := (op x a).
  Hypothesis op_mono : ∀ a b x, a ⊑ b -> a⋅x ⊑ b⋅x.
  Hypothesis op_glb  : ∀ a b x, a⋅x ⊓ b⋅x ⊑ (a⊓b)⋅x.
  Hypothesis op_lub  : ∀ a b x, (a⊔b)⋅x ⊑ a⋅x ⊔ b⋅x.
  Hypothesis op_bot  : ∀ x, ⊥⋅x ⊑ ⊥.

  Add Parametric Morphism (x : X): (op x) with signature (lat_eq) ==> (lat_eq) as eq_op.
  Proof. intros ? ? []; split; auto. Qed.

  Fact lub_op a b x : (a⊔b)⋅x ≡ a⋅x ⊔ b⋅x.
  Proof. split; auto; lat spec. Qed.

  Fact glb_op a b x : (a⊓b)⋅x ≡ a⋅x ⊓ b⋅x.
  Proof. split; auto; lat spec. Qed.

  Fact bot_op x : ⊥⋅x ≡ ⊥.
  Proof. split; auto. Qed.

  Fact least_op a : a ≡ ⊥ -> ∀x, a⋅x ≡ ⊥.
  Proof. intros H x; simpl; rewrite <- (bot_op x), H; auto. Qed.

  Notation stable := (fun a => ∀x, a⋅x ≡ a).

  Add Parametric Morphism: (stable) with signature (lat_eq) ==> (iff) as stable_eq.
  Proof.
    intros x y E; split; intros.
    + rewrite <- E; auto.
    + rewrite E; auto.
  Qed.

  (** Ultimately stable: lifting x with _⋅a, it ultimately becomes stable

      this corresponds to Ar in the paper
    *)

  Inductive US a : Prop :=
    | in_US_0 : stable a       -> US a
    | in_US_1 : (∀x, US (a⋅x)) -> US a.

  Section Ramsey_1st_induction.

    (** A double/simultaneous induction principle on US r & US s

        First induction principle used in the proof of Theorem 0.4
    *)

    Variables (P : Σ -> Σ -> Prop)
              (HP0 : ∀ r s, stable r -> P r s)
              (HP1 : ∀ r s, stable s -> P r s)
              (HP2 : ∀ r s, (∀x, P (r⋅x) (s⋅x)) -> P r s).

    Theorem Ramsey_1st_induction r s : US r -> US s -> P r s.
    Proof.
      intros H1 H2; revert r H1 s H2.
      induction 1.
      * intros ? _; apply HP0; auto.
      * induction 1.
        + apply HP1; auto.
        + apply HP2; auto.
    Qed.

  End Ramsey_1st_induction.

  Definition lift x a := a ⊔ a⋅x.

  Notation "a '[' x ']'" := (lift x a) (at level 11, format "a [ x ]", left associativity).

  Fact lift_mono a b : a ⊑ b -> forall x, a[x] ⊑ b[x].
  Proof. intros H x; cbv; lat mono. Qed.

  Hint Resolve lift_mono.

  Add Parametric Morphism (x : X): (lift x) with signature (lat_eq) ==> (lat_eq) as lift_morphism.
  Proof. intros ? ? []; split; auto. Qed.

  Fact lift_le a x : a ⊑ a[x] .
  Proof. cbv; auto. Qed.

  Hint Resolve lift_le.

  Fact lub_lift a b x : (a⊔b)[x] ≡ a[x] ⊔ b[x].
  Proof. cbv; split; lat spec; rewrite lub_op; auto. Qed.

  Fact stable_lift_eq a x : stable a -> a[x] ≡ a.
  Proof. intros Hx; simpl in Hx; unfold lift; rewrite Hx, lub_idem; auto. Qed.

  Hint Resolve stable_lift_eq.

  Fact stable_lift_stable a : stable a -> ∀x, stable (a[x]).
  Proof. simpl; intros Hr x y; unfold lift; rewrite Hr, lub_idem, Hr; auto. Qed.

  Fact stable_op_glb a b x : stable a -> (a⊓b)⋅x ≡ a⊓b⋅x.
  Proof. simpl; intros Hx; rewrite glb_op, Hx; auto. Qed.

  Hint Resolve stable_op_glb stable_lift_stable.

  Fact stable_lift_glb a b x : stable a -> (a⊓b)[x] ≡ a⊓b[x].
  Proof.
    simpl; intros Hx; unfold lift.
    rewrite glb_op, Hx, glb_comm, (glb_comm a), <- glb_distrib, glb_comm; auto.
  Qed.

  Hint Resolve stable_lift_glb.

  (** Ultimately Full: lifting x with [a], it ultimately becomes ⊤

      this corresponds to AF in the paper
   *)

  Inductive UF a : Prop :=
    | in_UF_0 : a ≡ ⊤           -> UF a
    | in_UF_1 : (∀x, UF (a[x])) -> UF a.

  (* UF is monotone *)

  Proposition UF_mono a b : UF a -> a ⊑ b -> UF b.
  Proof.
    intros H1; revert H1 b.
    induction 1 as [ a Ha | ? ? IHa ]; intros ? ?.
    * constructor 1; apply le_top_eq; rewrite <- Ha; auto.
    * constructor 2; intros x; apply IHa with x; auto.
  Qed.

  Corollary UF_mono_alt a b : a ⊑ b -> UF a -> UF b.
  Proof. intros ? H; apply UF_mono with (1 := H); auto. Qed.

  Section UF_lub_ind.

    (* This one does not appear directly in the paper but it
       is usefull to show more complicated induction principles,
       typically double inductions on UF (_⊔_) *)

    Variables (P : Σ -> Σ -> Prop)
              (HP0 : ∀ a b, a⊔b ≡ ⊤ -> P a b)
              (HP1 : ∀ a b, (∀x, UF ((a⊔b)[x]))
                         -> (∀x, P (a[x]) (b[x]))
                         -> P a b).

    Let UF_lub_rec a : UF a -> ∀ b c, a ⊑ b⊔c -> P b c.
    Proof.
      induction 1 as [ a Ha | a Ha IHa ]; intros b c Hbc.
      * apply HP0; apply le_top_eq; rewrite <- Ha; auto.
      * generalize (lift_mono Hbc); intros H.
        apply HP1.
        - intros x; apply UF_mono with (2 := H x); auto.
        - intros x; apply IHa with x.
          apply le_trans with (1 := H x), lub_lift.
    Qed.

    Theorem UF_lub_ind a b : UF (a⊔b) -> P a b.
    Proof. intros H; apply UF_lub_rec with (1 := H); auto. Qed.

  End UF_lub_ind.

  Check UF_lub_ind.

  Section UF_lub_induction.

    (* This one is used more or less implicitely in the paper
       as a justification for the upcomming UF_double_lub_induction

       Notice the condition on P where r[a] is replaced by r⋅a

     *)

    Variables (r : Σ)
              (P : Σ -> Prop)
              (HP1 : ∀a, a⊔r ≡ ⊤ -> P a)
              (HP2 : ∀a,   (∀x, UF (a[x]⊔r[x]))
                        -> (∀x, P  (a[x]⊔r⋅x))
                        -> P a).

    Let UF_lub_rec a : UF a -> forall b, a ⊑ b⊔r -> P b.
    Proof.
      induction 1 as [ a Ha | a Ha IHa ]; intros b Hb.
      * apply HP1; apply le_top_eq; rewrite <- Ha; auto.
      * generalize (lift_mono Hb); intros H.
        apply HP2.
        + intros x; eapply UF_mono.
          apply (Ha x).
          apply le_trans with (1 := H x), lub_lift.
        + intros x; apply IHa with x.
          apply le_trans with (1 := H x).
          rewrite lub_lift, <- lub_assoc, (lub_comm _ r); auto.
    Qed.

    Theorem UF_lub_induction a : UF (a⊔r) -> P a.
    Proof. intros H; apply UF_lub_rec with (1 := H); auto. Qed.

  End UF_lub_induction.

  Check UF_lub_induction.

  Section UF_double_lub_induction.

    (* This one is the most important induction principle of the
       paper. Notice the extensionality condition on P which
       holds when P is UF *)

    Variables (r s : Σ)
              (P : Σ -> Prop)
              (HP0 : ∀ a b, a ≡ b -> P a -> P b)
              (HP1 : ∀ a b, a⊔r ≡ ⊤ -> UF (b⊔s) -> P (a⊔b))
              (HP2 : ∀ a b, b⊔s ≡ ⊤ -> UF (a⊔r) -> P (a⊔b))
              (HP3 : ∀ a b, (∀x, P (a[x] ⊔ b ⊔ r⋅x))
                         -> (∀x, P (a ⊔ b[x] ⊔ s⋅x))
                         -> P (a⊔b)).

    Theorem UF_double_lub_induction a b : UF (a⊔r) -> UF (b⊔s) -> P (a⊔b).
    Proof.
      intros H1; revert b.
      pattern a; revert a H1.
      apply UF_lub_induction; auto.
      intros a Ha IHa b Hb.
      pattern b; revert b Hb.
      apply UF_lub_induction.
      + intros b Hb; apply HP2; auto.
        constructor 2; intros x.
        apply UF_mono with (1 := Ha x).
        rewrite lub_lift; auto.
      + intros b Hb IHb.
        apply HP3.
        * intros x.
          eapply HP0.
          2: apply (IHa x b).
          - rewrite <- lub_assoc, (lub_comm _ b), lub_assoc; auto.
          - constructor 2; intros y.
            apply UF_mono with (1 := Hb y).
            rewrite lub_lift; auto.
        * intros x.
          eapply HP0.
          2: apply (IHb x).
          rewrite lub_assoc; auto.
    Qed.

  End UF_double_lub_induction.

  Check UF_double_lub_induction.

  Section Ramsey_2nd_induction.

    (** This is the instance of UF_double_lub_induction that is
        actually used in the paper, after Ramsey_1st_induction *)

    Variables (r s : Σ)
              (HP1 : ∀ a b, a⊔r ≡ ⊤ -> UF (b⊔s) -> UF (a⊔b⊔(r⊓s)))
              (HP2 : ∀ a b, b⊔s ≡ ⊤ -> UF (a⊔r) -> UF (a⊔b⊔(r⊓s)))
              (HP3 : ∀ a b, (∀x, UF (a[x] ⊔ b ⊔ (r⊓s) ⊔ r⋅x))
                         -> (∀x, UF (a ⊔ b[x] ⊔ (r⊓s) ⊔ s⋅x))
                         -> UF (a⊔b⊔(r⊓s))).

    Theorem Ramsey_2nd_induction : ∀ a b, UF (a⊔r) -> UF (b⊔s) -> UF (a⊔b⊔(r⊓s)).
    Proof.
      apply UF_double_lub_induction with (P := fun u => UF (u⊔(r⊓s))); auto.
      * intros ? ? []; apply UF_mono_alt; auto.
      * intros a b Ha Hb.
        eapply UF_mono.
        apply (@HP3 a b).
        3: auto.
        + intros x; apply UF_mono with (1 := Ha x).
          do 2 rewrite <- (lub_assoc (_[_] ⊔ _)); lat mono.
        + intros x; apply UF_mono with (1 := Hb x).
          do 2 rewrite <- (lub_assoc (_ ⊔ _[_])); lat mono.
    Qed.

  End Ramsey_2nd_induction.

  Check Ramsey_2nd_induction.

  Section Ramsey_a_la_Coquand.

    Local Definition lemma_01 := UF_mono_alt.

    Hint Resolve least_op.

    Section lemma_02.

      (* The next three are somewhat easy with setoid rewriting ...
         much less with handwritten congruence proofs *)

      Let le_02_00 a b r s : a⊔b⊔(r⊓s) ≡ (a⊔r⊔b)⊓(a⊔(b⊔s)).
      Proof.
        rewrite lub_comm, lub_distrib, lub_assoc, (lub_comm r a); lat mono.
        rewrite (lub_comm a), lub_assoc, lub_comm; lat mono.
      Qed.

      Let le_02_01 a b r s : a⊔r ≡ ⊤ -> b⊔s ≡ ⊤ -> a⊔b⊔(r⊓s) ≡ ⊤.
      Proof.
        intros H1 H2.
        rewrite le_02_00, H1, H2, lub_top, glb_top, lub_comm, lub_top; auto.
      Qed.

      Let le_02_02 a b r s x : a⊔r ≡ ⊤ -> a ⊔ b[x] ⊔ (r ⊓ s[x]) ⊑ (a ⊔ b ⊔ (r ⊓ s))[x].
      Proof.
        intros H1.
        rewrite (lub_comm a b), <- (lub_assoc b a), (lub_comm a (_⊓_)),
                lub_distrib, (lub_comm r a), H1, glb_top,
                (lub_comm s a), (lub_assoc b), (lub_comm b a),
                lub_lift, lub_lift.
        lat mono.
      Qed.

      (* By induction over UF (b⊔s) with fixed a r *)

      Local Lemma lemma_02 a b r s : a⊔r ≡ ⊤ -> UF (b⊔s) -> UF (a⊔b⊔(r⊓s)).
      Proof.
        intros H1 H2; pattern b, s; revert b s H2.
        apply UF_lub_ind.
        * intros; constructor 1; auto.
        * intros ? ? ? H3; constructor 2; intros x.
          apply UF_mono with (1 := H3 x); auto.
      Qed.

    End lemma_02.

    (* The symmetric version by monotonicity *)

    Hint Resolve lemma_02.

    Local Corollary lemma_02_sym a b r s : b⊔s ≡ ⊤ -> UF (a⊔r) -> UF (a⊔b⊔(r⊓s)).
    Proof. intros; apply UF_mono with (b⊔a⊔(s⊓r)); auto. Qed.

    (* By induction over UF (a⊔r) *)

    Local Lemma lemma_03 a b r s : stable r -> UF (a⊔r) -> UF (b⊔s) -> UF (a⊔b⊔(r⊓s)).
    Proof.
      intros H1 H2 H3; revert H1; pattern a, r; revert a r H2.
      apply UF_lub_ind.
      * intros; auto.
      * intros a r H1 H2 H4; constructor 2; intros x.
        eapply UF_mono.
        apply (H2 x); auto.
        rewrite lub_lift, lub_lift; lat mono.
        rewrite (@stable_lift_eq r); unfold lift; auto.
    Qed.

    Hint Resolve lemma_03.

    (* The symmetric version by monotonicity *)

    Local Corollary lemma_03_sym a b r s : stable s -> UF (a⊔r) -> UF (b⊔s) -> UF (a⊔b⊔(r⊓s)).
    Proof. intros; apply UF_mono with (b⊔a⊔(s⊓r)); auto. Qed.

    Hint Resolve lemma_02_sym lemma_03_sym.

    (** By double induction on US r & US s using Ramsey_1st_induction
        then for fixed r&s, by double induction UF (x⊔r) & UF (y⊔s) using Ramsey_2nd_induction

        I did not think it could work this way, but indeed it does, thanks to these
        tailored induction principles.
      *)

    Local Theorem theorem_04 a b r s : US r -> US s -> UF (a⊔r) -> UF (b⊔s) -> UF (a⊔b⊔(r⊓s)).
    Proof.
      intros H1 H2; revert a b.
      pattern r, s; revert r s H1 H2.
      apply Ramsey_1st_induction; intros r s IH; auto.
      apply Ramsey_2nd_induction; intros a b IHa IHb; auto.
      constructor 2; intros x.
      eapply UF_mono.
      apply IH with (1 := IHa x) (2 := IHb x).
      do 2 rewrite lub_lift.
      lat spec; lat right.
      unfold lift; rewrite glb_op; auto.
    Qed.

    Theorem Ramsey_lattice r s : US r -> US s -> UF r -> UF s -> UF (r⊓s).
    Proof.
      intros H1 H2 H3 H4.
      eapply UF_mono.
      apply (@theorem_04 ⊥ ⊥ _ _ H1 H2).
      revert H3; apply UF_mono_alt; auto.
      revert H4; apply UF_mono_alt; auto.
      repeat rewrite lub_bot; auto.
    Qed.

  End Ramsey_a_la_Coquand.

  Check Ramsey_lattice.

End Ramsey.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-28

Some results concerning permutations of lists.
*)

Set Implicit Arguments.

From Coq Require Import Setoid Morphisms Basics.
From CoLoR Require Import ListExtras NatUtil LogicUtil.
From Coq Require Export Permutation PermutSetoid Multiset.

Arguments list_contents [A eqA] _ _.
Arguments permutation [A eqA] _ _ _.

Section Multiplicity.

  Variables
    (A : Type) (eqA : relation A)
    (eqA_dec : forall x y, {eqA x y} + {~eqA x y})
    (eqA_Equivalence : Equivalence eqA).

  Lemma multiplicity_in: forall l x,
    multiplicity (list_contents eqA_dec l) x > 0 ->
    exists x', eqA x' x /\ In x' l.

  Proof.
    induction l; simpl; intros.
    omega.
    destruct (eqA_dec a x).
    exists a; auto.
    destruct (IHl x) as [x' [x'x x'l]]; trivial.
    exists x'; split; auto.
  Qed.

  Lemma in_multiplicity: forall l a,
    In a l ->
    multiplicity (list_contents eqA_dec l) a > 0.

  Proof.
    induction l; simpl; intros.
    omega.
    destruct H.
    destruct (eqA_dec a a0).
    omega.
    absurd (eqA a a0); trivial.
    rewrite H; intuition.
    set (w := IHl a0 H); omega.
  Qed.

  Lemma multiplicity_countIn: forall l el,
    multiplicity (list_contents eqA_dec l) el = countIn eqA eqA_dec el l.

  Proof.
    induction l; simpl; intros; trivial.
    destruct (eqA_dec a el); destruct (eqA_dec el a).
    rewrite IHl; omega.
    absurd (eqA el a); intuition.
    absurd (eqA a el); intuition.
    rewrite IHl; omega.
  Qed.

  Lemma multiplicity_dropNth_eq: forall l p el el',
    nth_error l p = Some el' ->
    eqA el el' ->
    multiplicity (list_contents eqA_dec (drop_nth l p)) el =
    multiplicity (list_contents eqA_dec l) el - 1.

  Proof.
    intros.
    rewrite !multiplicity_countIn.
    apply countIn_dropNth_eq with el'; trivial.
  Qed.

  Lemma multiplicity_dropNth_neq: forall l p el el',
    nth_error l p = Some el' ->
    ~eqA el el' ->
    multiplicity (list_contents eqA_dec (drop_nth l p)) el =
    multiplicity (list_contents eqA_dec l) el.

  Proof.
    intros.
    rewrite !multiplicity_countIn.
    apply countIn_dropNth_neq with el'; trivial.
  Qed.

End Multiplicity.

Section Permutation.

  Variables
    (A : Type) (eqA : relation A)
    (eqA_dec : forall x y, {eqA x y} + {~eqA x y})
    (eqA_Equivalence : Equivalence eqA).

  Lemma permutation_sym: forall l l',
    permutation eqA_dec l l' -> permutation eqA_dec l' l.

  Proof. intros; intro; auto. Qed.

  Lemma permutation_in: forall l l' a, permutation eqA_dec l l' ->
    In a l -> exists a', eqA a' a /\ In a' l'.

  Proof.
    intros.
    destruct (multiplicity_in eqA eqA_dec l' a) as [a' [aa' a'l']].
    rewrite <- (H a); trivial.
    apply in_multiplicity; trivial.
    exists a'; split; trivial.
  Qed.

  Lemma permutation_drop: forall (l l': list A) a b p,
    eqA a b -> nth_error l' p = Some b ->
    permutation eqA_dec (a :: l) l' -> permutation eqA_dec l (drop_nth l' p).

  Proof.
    intros; intro el.
    destruct (eqA_dec a el).
    assert (eqA el b).
    apply (Seq_trans A eqA eqA_Equivalence) with a; intuition.
    rewrite (multiplicity_dropNth_eq eqA_dec eqA_Equivalence l' p el H0 H2).
    set (w := H1 el); simpl in w.
    replace (if eqA_dec a el then 1 else 0) with 1 in w.
    omega.
    clear w; destruct (eqA_dec a el); [trivial | contr].
    assert (~eqA el b).
    intro elb.
    absurd (eqA a el); trivial.
    apply (Seq_trans A eqA eqA_Equivalence) with b; intuition.
    rewrite (multiplicity_dropNth_neq eqA_dec eqA_Equivalence l' p el H0 H2).
    set (w := H1 el); simpl in w.
    replace (if eqA_dec a el then 1 else 0) with 0 in w.
    omega.
    clear w; destruct (eqA_dec a el); [contr | trivial].
  Qed.

  Lemma permutation_cons: forall l l' a,
    permutation eqA_dec (a :: l) l' ->
    exists p a',
      nth_error l' p = Some a' /\
      eqA a a' /\
      permutation eqA_dec l (drop_nth l' p).

  Proof.
    intros.
    destruct (permutation_in a H) as [a' [aa' a'l']].
    auto with datatypes.
    destruct (list_In_nth l' a' a'l') as [p l'p].
    exists p; exists a'; split; [idtac | split]; trivial.
    intuition.
    apply permutation_drop with a a'; trivial.
    intuition.
  Qed.

  Lemma permutation_length: forall (l l': list A),
    permutation eqA_dec l l' ->
    length l = length l'.

  Proof.
    induction l; intros.
     (* base *)
    simpl.
    destruct l'; trivial.
    unfold permutation in H.
    exfalso.
    assert (w := H a); simpl in w; clear H.
    destruct (eqA_dec a a).
    omega.
    intuition.
     (* step *)
    destruct (permutation_cons H) as [p [a' [l'p [aa' ll'p]]]].
    simpl.
    rewrite (IHl (drop_nth l' p)); trivial.
    set (w := nth_some l' p l'p).
    rewrite drop_nth_in_length; trivial.
    omega.
  Qed.

  Lemma insert_nth_permut: forall (l: list A) el n,
    permutation eqA_dec (insert_nth l n el) (el::l).

  Proof.
    induction l; intros.
    unfold insert_nth, finalSeg; destruct n; simpl; apply permut_refl.
    destruct n; unfold insert_nth; simpl.
    rewrite finalSeg_full; apply permut_refl.
    unfold finalSeg; simpl.
    fold (finalSeg l n); fold (insert_nth l n el).
    apply permut_tran with (a :: el :: l).
    apply permut_cons.
    apply IHl.
    change (el :: a :: l) with ((el :: nil) ++ a :: l).
    change (a :: el :: l) with (a :: (el :: nil) ++ l).
    apply permut_middle.
  Qed.

  Lemma insert_nth_permut': forall (l l': list A) el n,
    permutation eqA_dec l l' ->
    permutation eqA_dec (insert_nth l n el) (el::l').

  Proof.
    intros; intro w.
    unfold insert_nth.
    change (el :: finalSeg l n) with ((el :: nil) ++ finalSeg l n).
    change (el :: l') with ((el :: nil) ++ l').
    rewrite !list_contents_app.
    simpl.
    rewrite plus_0_r.
    match goal with
    | |- ?a + (?b + ?c) = ?d => replace (a + (b + c)) with (a + c + b)
    end.
    replace (multiplicity (list_contents eqA_dec (initialSeg l n)) w +
      multiplicity (list_contents eqA_dec (finalSeg l n)) w)
    with (multiplicity
      (list_contents eqA_dec (initialSeg l n ++ finalSeg l n)) w).
    rewrite initialSeg_finalSeg_full; trivial.
    rewrite (H w); auto with arith.
    rewrite list_contents_app; trivial.
    omega.
  Qed.

End Permutation.

Section ListSim.

  Variable A : Type.
  Variable B : Type.
  Variable R : A -> B -> Prop.

  Inductive list_sim: list A -> list B -> Prop :=
  | conv_empty:
      list_sim nil nil
  | conv_cons: forall x y xs ys,
      R x y ->
      list_sim xs ys ->
      list_sim (x::xs) (y::ys).

  Lemma list_sim_nth : forall p l l' a, list_sim l l' ->
    nth_error l p = Some a ->
    exists b, nth_error l' p = Some b /\ R a b.

  Proof.
    induction p.
    intros.
    inversion H.
    rewrite <- H1 in H0; discr.
    exists y; split; auto.
    replace a with x; trivial.
    rewrite <- H3 in H0; inversion H0; trivial.
    intros.
    destruct l; destruct l'; try discr.
    inversion H.
    inversion H.
    destruct (IHp l l' a); trivial.
    destruct H7.
    exists x0; split; trivial.
  Qed.

  Lemma list_sim_nth_rev : forall p l l' b, list_sim l l' ->
    nth_error l' p = Some b ->
    exists a, nth_error l p = Some a /\ R a b.

  Proof.
    induction p.
    intros.
    inversion H.
    rewrite <- H2 in H0; discr.
    exists x; split; auto.
    replace b with y; trivial.
    rewrite <- H4 in H0; inversion H0; trivial.
    intros.
    destruct l; destruct l'; try discr.
    inversion H.
    inversion H.
    destruct (IHp l l' b); trivial.
    destruct H7.
    exists x0; split; trivial.
  Qed.

  Lemma list_sim_app : forall l1 l1' l2 l2',
    list_sim l1 l1' -> list_sim l2 l2' -> list_sim (l1 ++ l2) (l1' ++ l2').

  Proof.
    induction l1; intros.
    inversion H; trivial.
    inversion H.
    simpl; constructor; trivial.
    apply IHl1; trivial.
  Qed.

  Lemma list_sim_unique : forall l m m',
    (forall x y y', In x l -> In y m -> In y' m' ->
      R x y -> R x y' -> y = y') ->
    list_sim l m -> list_sim l m' -> m = m'.

  Proof.
    induction l; intros; inversion H0; inversion H1; trivial.
    rewrite (H x y y0).
    rewrite (IHl ys ys0); trivial.
    intros.
    destruct (list_In_nth l x1 H12) as [p lp].
    apply H with x1; trivial.
    right; trivial.
    rewrite <- H5; right; trivial.
    rewrite <- H10; right; trivial.
    rewrite H2; auto with datatypes.
    rewrite <- H5; left; trivial.
    rewrite <- H10; left; trivial.
    rewrite H2; trivial.
    rewrite H2; trivial.
  Qed.

  Lemma list_sim_insert_nth : forall p l l' a a', nth_error l p = Some a ->
    nth_error l' p = Some a' -> R a a' ->
    list_sim (drop_nth l p) (drop_nth l' p) -> list_sim l l'.

  Proof.
    induction p; intros.
     (* induction base *)
    destruct l; destruct l'.
    constructor.
    inversion H2; discr.
    inversion H2; discr.
    constructor.
    inversion H; inversion H0; trivial.
    rewrite !drop_nth_cons in H2; trivial.
     (* induction step *)
    destruct l; destruct l'.
    constructor.
    inversion H2; discr.
    inversion H2; discr.
    rewrite !drop_nth_succ in H2.
    inversion H2.
    constructor; trivial.
    apply IHp with a a'; trivial.
  Qed.

  Lemma list_sim_length : forall l l', list_sim l l' -> length l = length l'.

  Proof.
    induction l; intros.
    inversion H; trivial.
    destruct l'.
    inversion H.
    simpl.
    rewrite (IHl l'); trivial.
    inversion H; trivial.
  Qed.

  Lemma list_sim_tail : forall l l',
    list_sim l l' -> list_sim (tail l) (tail l').

  Proof.
    intros.
    destruct H; trivial.
    simpl; constructor.
  Qed.

End ListSim.

Section ListSim_iso.

  Variables
    (A : Type) (P eqA : relation A)
    (eqA_dec : forall x y, {eqA x y} + {~eqA x y})
    (eqA_Equivalence : Equivalence eqA)
    (P_eqA_comp : Proper (eqA ==> eqA ==> impl) P).

  Definition list_simA := @list_sim A A P.

  Lemma list_sim_permutation : forall l l' m,
    list_simA l l' -> permutation eqA_dec l m ->
    exists m', list_simA m m' /\ permutation eqA_dec l' m'.

  Proof.
    unfold Setoid_Theory in eqA_Equivalence.
    induction l; intros.
     (* induction base *)
    exists (nil (A:=A)); split.
    destruct m.
    constructor.
    set (w := H0 a); inversion w.
    destruct (eqA_dec a a).
    omega.
    absurd (eqA a a); intuition.
    inversion H.
    apply permut_refl.
     (* induction step *)
    destruct l'.
    inversion H.
    destruct (permutation_cons eqA_Equivalence H0) as [p [a' [mp [aa' lm]]]].
    destruct (IHl l' (drop_nth m p)) as [m' [mm' l'm']]; trivial.
    inversion H; trivial.
    assert (length m' >= p).
    rewrite <- (list_sim_length mm').
    set (h := nth_some m p mp).
    set (w := drop_nth_length m p).
    omega.
    exists (insert_nth m' p a0); split.
    unfold list_simA; apply list_sim_insert_nth with p a' a0; trivial.
    apply nth_insert_nth; trivial.
    apply P_eqA_comp with a a0; intuition.
    inversion H; intuition.
    rewrite drop_nth_insert_nth; trivial.
    apply permutation_sym.
    apply insert_nth_permut'.
    apply permutation_sym; trivial.
  Qed.

End ListSim_iso.


Require Export Iron.Language.Simple.Exp.
Require Import Iron.Language.Simple.Ty.

(* Substitution of expressions in expressions preserves typing.

   Inductively, we must reason about performing substitutions at any
   depth, hence we must prove a property about (subst' d x2 x1) instead
   of the weaker (subst x2 x1) which assumes the substitution is taking
   place at top level. *)
Lemma subst_exp_exp_ix
 :  forall ix te x1 x2 t1 t2
 ,  get  ix te = Some t2
 -> TYPE te             x1 t1
 -> TYPE (delete ix te) x2 t2
 -> TYPE (delete ix te) (substX ix x2 x1) t1.
Proof.
 rip. gen ix te x2 t1.
 induction_type x1.

 Case "XVar".
  fbreak_nat_compare; burn.

  SCase "n > ix".
   eapply TYVar.
    destruct n; burn.
     simpl. nnat. down. apply get_delete_below. omega.

 Case "XLam".
  apply TYLam.
  rewrite delete_rewind.
  apply IHx1; burn.
Qed.

Theorem subst_exp_exp
 :  forall te x1 x2 t1 t2
 ,  TYPE (te :> t2) x1 t1
 -> TYPE te         x2 t2
 -> TYPE te (substX 0 x2 x1) t1.
Proof.
 rip. lets D: subst_exp_exp_ix 0 (te :> t2). burn.
Qed.


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

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

Print Assumptions mul.


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

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

Print Assumptions add.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


Require Export Category DiscreteCategory IndiscreteCategory.
Require Import Common.

Set Universe Polymorphism.

Fixpoint CardinalityRepresentative (n : nat) : Set :=
  match n with
    | 0 => Empty
    | 1 => Unit
    | S n' => (CardinalityRepresentative n' + Unit)%type
  end.

Coercion CardinalityRepresentative : nat >-> Sortclass.

Instance trunc_CardinalityRepresentative (n : nat)
: IsHSet (CardinalityRepresentative n).
Proof.
  induction n; [ typeclasses eauto |].
  induction n; [ typeclasses eauto |].
  intros [x|x] [y|y];
  typeclasses eauto.
Qed.

Definition NatCategory (n : nat) :=
  match n with
    | 0 => IndiscreteCategory 0
    | 1 => IndiscreteCategory 1
    | S (S n') => DiscreteCategory (S (S n'))
  end.

Coercion NatCategory : nat >-> PreCategory.

Notation "1" := (NatCategory 1) : category_scope.

Typeclasses Transparent NatCategory.
Hint Unfold NatCategory.
Arguments NatCategory / .


Require Import Lia ZArith.
Require Import Cdcl.Itauto.
Open Scope Z_scope.

Axiom width: Z.

Goal forall (W : Type) (left right : W) (Lxs : nat) (w2z : W -> Z)
            (v : nat) (x1 x2 : W) (Lx : nat) (q r : Z),
    (w2z right - w2z left) mod 2 ^ width = 8 * Z.of_nat Lxs ->
    (w2z x2 - w2z x1) mod 2 ^ width = 8 * Z.of_nat Lx ->
    (w2z x2 - w2z x1) mod 2 ^ width <> 0 ->
    0 <= 8 * Z.of_nat Lx < 2 ^ width ->
    Z.of_nat Lx = Z.of_nat v ->
    0 <= Z.of_nat Lxs ->
    0 <= Z.of_nat Lx ->
    0 <= Z.of_nat v ->
    (2 ^ 4 <> 0 -> 8 * Z.of_nat Lx = 2 ^ 4 * q + r) ->
    (0 < 2 ^ 4 -> 0 <= r < 2 ^ 4) ->
    (2 ^ 4 < 0 -> 2 ^ 4 < r <= 0) ->
    8 * q < 8 * Z.of_nat Lx.
Proof.
  intros.
  (* lia. (* succeeds *) *)
  itauto lia. (* fails with 4 "Cannot find witness" errors *)
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e216m2e108m1_8limbs.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 VST.progs.conclib.
Require Import VST.floyd.sublist.

Set Bullet Behavior "Strict Subproofs".

(* Maps are represented as partial association lists, with entries with key 0 considered to be empty. *)
Fixpoint index_of (m : list (Z * Z)) (k : Z) :=
  match m with
  | [] => None
  | (k1, v1) :: rest => if eq_dec k1 k then Some 0
                        else option_map Z.succ (index_of rest k)
  end.

Lemma index_of_spec : forall k m, match index_of m k with
  | Some i => 0 <= i < Zlength m /\ fst (Znth i m) = k /\ Forall (fun x => fst x <> k) (sublist 0 i m)
  | None => ~In k (map fst m) end.
Proof.
  induction m; simpl; auto; intros.
  destruct a.
  rewrite Zlength_cons.
  pose proof (Zlength_nonneg m).
  destruct (eq_dec z k).
  { split; [omega|].
    rewrite sublist_nil; auto. }
  destruct (index_of m k); simpl.
  - destruct IHm as (? & ? & ?); unfold Z.succ.
    rewrite Znth_cons_eq, Z.add_simpl_r.
    if_tac; [omega|].
    split; [omega|].
    split; auto.
    rewrite sublist_0_cons, Z.add_simpl_r by omega; constructor; auto.
  - tauto.
Qed.

(* Abstract properties of hashtables *)
Class hash_fun := { size : Z; hash : Z -> Z; size_pos : size > 0; hash_range : forall i, 0 <= hash i < size }.

Section Hashtable.

Context {hf : hash_fun}.
Hint Resolve size_pos hash_range.

Definition rebase {A} (m : list A) i := rotate m (Zlength m - i) (Zlength m).

Definition well_chained (m : list (Z * Z)) := forall k i, index_of (rebase m (hash k)) k = Some i ->
  Forall (fun x => fst x <> 0) (sublist 0 i (rebase m (hash k))).

Definition wf_map (m : list (Z * Z)) := NoDup (map fst m).

Definition indices i j := (map (fun x => (i + x) mod size) (upto (Z.to_nat ((j - i) mod size)))).

Fixpoint index_of' (m : list (Z * Z)) k :=
  match m with
  | [] => None
  | (k1, v1) :: rest => if eq_dec k1 0 then Some 0 else
                        if eq_dec k1 k then Some 0
                        else option_map Z.succ (index_of' rest k)
  end.

Definition lookup (m : list (Z * Z)) (k : Z) :=
  option_map (fun i => (i + hash k) mod size) (index_of' (rebase m (hash k)) k).

Definition set m k v := option_map (fun i => upd_Znth i m (k, v)) (lookup m k).

Definition get m k := match lookup m k with Some i => let '(k', v') := Znth i m in
  if eq_dec k' 0 then None else Some v' | None => None end.

Lemma rebase_0 : forall {A} {d : Inhabitant A} (m : list A) i, 0 <= i < Zlength m -> Znth 0 (rebase m i) = Znth i m.
Proof.
  intros; unfold rebase.
  destruct (eq_dec (Zlength m) 0).
  { apply Zlength_nil_inv in e; subst.
    rewrite rotate_nil, !Znth_nil; auto. }
  pose proof (Zlength_nonneg m).
  rewrite Znth_rotate; try omega.
  f_equal.
  rewrite <- Z.mod_add with (b := 1) by auto.
  replace (0 - (Zlength m - i) + 1 * Zlength m) with i by omega.
  apply Zmod_small; auto.
Qed.

Lemma index_of'_spec : forall k m, match index_of' m k with
  | Some i => 0 <= i < Zlength m /\ (fst (Znth i m) = k \/ fst (Znth i m) = 0) /\
              Forall (fun x => fst x <> 0 /\ fst x <> k) (sublist 0 i m)
  | None => ~In k (map fst m) /\ ~In 0 (map fst m)
  end.
Proof.
  induction m; simpl; auto; intros.
  destruct a.
  rewrite Zlength_cons.
  pose proof (Zlength_nonneg m).
  destruct (eq_dec z 0).
  { subst; split; [omega|].
    rewrite sublist_nil, Znth_cons_eq; split; auto. }
  destruct (eq_dec z k).
  { subst; split; [omega|].
    rewrite sublist_nil, Znth_cons_eq; split; auto. }
  destruct (index_of' m k); simpl.
  - destruct IHm as (? & ? & ?); unfold Z.succ; rewrite Znth_cons_eq, Z.add_simpl_r.
    split; [omega|].
    if_tac; [omega|].
    split; auto.
    rewrite sublist_0_cons, Z.add_simpl_r by omega; constructor; auto.
  - tauto.
Qed.

Lemma Znth_rebase : forall {A} {d : Inhabitant A} (m : list A) i j, 0 <= i < Zlength m -> 0 <= j < Zlength m ->
  Znth i (rebase m j) = Znth ((i + j) mod Zlength m) m.
Proof.
  intros; unfold rebase.
  destruct (eq_dec (Zlength m) 0); [omega|].
  rewrite Znth_rotate by omega; f_equal.
  rewrite Z.sub_sub_distr, <- Z.add_sub_swap.
  replace (i + j - Zlength m) with (i + j + (-1 * Zlength m)) by omega.
  rewrite Z.mod_add; auto.
Qed.

Corollary Znth_rebase' : forall {A} {d : Inhabitant A} (m : list A) i j, 0 <= i < Zlength m -> 0 <= j < Zlength m ->
  Znth ((i - j) mod Zlength m) (rebase m j) = Znth i m.
Proof.
  intros; rewrite Znth_rebase; auto.
  - rewrite Zplus_mod_idemp_l, Z.sub_simpl_r, Zmod_small; auto.
  - apply Z_mod_lt; omega.
Qed.

Lemma index_of'_upd : forall m k v i (Hrange : 0 <= i < Zlength m)
  (Hi : fst (Znth i m) = k \/ fst (Znth i m) = 0),
  index_of' (upd_Znth i m (k, v)) k = index_of' m k.
Proof.
  intros.
  pose proof (index_of'_spec k m) as Hk; pose proof (index_of'_spec k (upd_Znth i m (k, v))) as Hk'.
  destruct (index_of' m k), (index_of' (upd_Znth i m (k, v)) k); auto.
  - rewrite upd_Znth_Zlength in Hk' by auto.
    destruct Hk as (? & Hk & ?).
    destruct Hk' as (? & Hz & Hall).
    destruct (zlt i z0).
    { rewrite sublist_upd_Znth_lr in Hall by omega.
      rewrite Forall_forall in Hall; specialize (Hall _ (upd_Znth_In _ _ _)); tauto. }
    rewrite sublist_upd_Znth_l in Hall by omega.
    f_equal; destruct (eq_dec i z0); [subst | rewrite upd_Znth_diff' in Hz by auto];
      eapply (Forall_sublist_first(A := Z * Z)); eauto; omega.
  - rewrite <- upd_Znth_map in Hk'; destruct Hk' as (Hk' & _); contradiction Hk'.
    apply upd_Znth_In.
  - destruct Hk as (Hk & Hz); destruct Hi; [contradiction Hk | contradiction Hz]; rewrite in_map_iff;
      do 2 eexists; eauto; apply Znth_In; auto.
Qed.

Lemma Zlength_rebase : forall {A} (m : list A) i, 0 <= i < Zlength m -> Zlength (rebase m i) = Zlength m.
Proof.
  intros; unfold rebase; rewrite Zlength_rotate; auto; omega.
Qed.

Lemma rebase_upd : forall {A} (m : list A) i j x, 0 <= i < Zlength m -> 0 <= j < Zlength m ->
  rebase (upd_Znth i m x) j = upd_Znth ((i - j) mod Zlength m) (rebase m j) x.
Proof.
  intros; unfold rebase.
  destruct (eq_dec (Zlength m) 0); [omega|].
  rewrite upd_rotate; auto; try omega.
  rewrite upd_Znth_Zlength by auto.
  f_equal; f_equal.
  rewrite Zminus_mod_idemp_l.
  replace (i - j - (Zlength m - j)) with (i + (-1 * Zlength m)) by omega.
  rewrite Z.mod_add, Zmod_small; auto.
  { apply Z_mod_lt; omega. }
Qed.

Corollary rebase_upd' : forall {A} (m : list A) i j x, 0 <= i < Zlength m -> 0 <= j < Zlength m ->
  rebase (upd_Znth ((i + j) mod Zlength m) m x) j = upd_Znth i (rebase m j) x.
Proof.
  intros; rewrite rebase_upd; auto.
  - rewrite Zminus_mod_idemp_l, Z.add_simpl_r, Zmod_small; auto.
  - apply Z_mod_lt; omega.
Qed.

Lemma lookup_set : forall m k v m', set m k v = Some m' -> Zlength m = size -> lookup m' k = lookup m k.
Proof.
  unfold set; intros.
  destruct (lookup m k) eqn: Hlookup; [inv H | discriminate].
  unfold lookup in *.
  pose proof (hash_range k).
  pose proof (index_of'_spec k (rebase m (hash k))) as Hspec.
  destruct (index_of' (rebase m (hash k)) k) eqn: Hindex; [|discriminate].
  simpl in Hlookup; inv Hlookup.
  rewrite Zlength_rebase in Hspec by omega; destruct Hspec as (? & Hz & ?).
  replace size with (Zlength m); rewrite rebase_upd' by (auto; omega).
  rewrite index_of'_upd, Hindex; auto.
  { rewrite Zlength_rebase; omega. }
Qed.

Lemma lookup_range : forall m k i, lookup m k = Some i -> Zlength m = size -> 0 <= i < Zlength m.
Proof.
  unfold lookup; intros.
  pose proof (index_of'_spec k (rebase m (hash k))) as Hspec.
  destruct (index_of' (rebase m (hash k)) k); [inv H | discriminate].
  replace (Zlength m) with size; apply Z_mod_lt; auto.
Qed.

Lemma index_of'_upd2 : forall m k i k' v' (Hrange : 0 <= i < Zlength m)
  (Hi : index_of' m k <> Some i) (Hdiff : k' <> k /\ k' <> 0),
  index_of' (upd_Znth i m (k', v')) k = index_of' m k.
Proof.
  intros.
  pose proof (index_of'_spec k m) as Hk; pose proof (index_of'_spec k (upd_Znth i m (k', v'))) as Hk'.
  destruct (index_of' m k), (index_of' (upd_Znth i m (k', v')) k); auto.
  - rewrite upd_Znth_Zlength in Hk' by auto.
    destruct Hk as (? & Hk & ?).
    destruct Hk' as (? & Hz & Hall).
    destruct (eq_dec z0 i).
    { subst; rewrite upd_Znth_same in Hz by auto; tauto. }
    rewrite upd_Znth_diff' in Hz by auto.
    f_equal; apply Z.le_antisymm.
    + eapply (Forall_sublist_le(A := Z * Z)); try eassumption; simpl; try omega.
      { rewrite upd_Znth_Zlength; auto; omega. }
      rewrite upd_Znth_diff' by auto.
      destruct Hk as [-> | ->]; tauto.
    + eapply (Forall_sublist_le(A := Z * Z)); try eassumption; omega.
  - destruct Hk as (? & Hk & ?).
    erewrite <- upd_Znth_diff' with (j := i) in Hk by auto.
    destruct Hk' as (Hk' & Hz'); destruct Hk; [contradiction Hk' | contradiction Hz'];
      rewrite in_map_iff; do 2 eexists; eauto; apply Znth_In; rewrite upd_Znth_Zlength; auto.
  - destruct Hk' as (Hrange' & Hz & ?).
    destruct (eq_dec z i).
    { subst; rewrite upd_Znth_same in Hz by auto; tauto. }
    rewrite upd_Znth_Zlength in Hrange' by auto.
    rewrite upd_Znth_diff' in Hz by auto.
    destruct Hk as (Hk' & Hz'); destruct Hz; [contradiction Hk' | contradiction Hz'];
      rewrite in_map_iff; do 2 eexists; eauto; apply Znth_In; auto.
Qed.

Lemma lookup_upd_same : forall m k i v', lookup m k = Some i -> Zlength m = size -> 0 <= i < Zlength m ->
  lookup (upd_Znth i m (k, v')) k = lookup m k.
Proof.
  unfold lookup; intros.
  pose proof (hash_range k).
  rewrite rebase_upd by (auto; omega).
  rewrite index_of'_upd; auto.
  - rewrite Zlength_rebase by omega.
    apply Z_mod_lt; omega.
  - pose proof (index_of'_spec k (rebase m (hash k))) as Hspec.
    destruct (index_of' (rebase m (hash k)) k); inv H.
    replace size with (Zlength m).
    rewrite Zminus_mod_idemp_l, Z.add_simpl_r.
    destruct Hspec as (Hz & ? & ?).
    rewrite Zlength_rebase in Hz by omega.
    rewrite Zmod_small; auto.
Qed.

Lemma lookup_upd_diff : forall m k i k' v', lookup m k <> Some i -> Zlength m = size -> 0 <= i < Zlength m ->
  k' <> k /\ k' <> 0 ->
  lookup (upd_Znth i m (k', v')) k = lookup m k.
Proof.
  unfold lookup; intros.
  pose proof (hash_range k).
  rewrite rebase_upd by (auto; omega).
  rewrite index_of'_upd2; auto.
  - rewrite Zlength_rebase by omega.
    apply Z_mod_lt; omega.
  - intro X; rewrite X in H; simpl in H.
    replace size with (Zlength m) in H.
    rewrite Zplus_mod_idemp_l, Z.sub_simpl_r, Zmod_small in H by omega; contradiction H; auto.
Qed.

Lemma Zlength_set : forall m k v m', set m k v = Some m' -> Zlength m = size ->
  Zlength m' = size.
Proof.
  unfold set; intros.
  destruct (lookup m k) eqn: Hlookup; inv H.
  rewrite upd_Znth_Zlength; auto.
  eapply lookup_range; eauto.
Qed.

Lemma get_set_same : forall m k v m', set m k v = Some m' -> Zlength m = size -> k <> 0 ->
  get m' k = Some v.
Proof.
  intros.
  exploit lookup_set; eauto; intro Heq.
  unfold set, get in *.
  destruct (lookup m k) eqn: Hlookup; [inv H | discriminate].
  exploit (lookup_range _ _ _ Hlookup); auto; intro.
  rewrite Heq, upd_Znth_same by auto.
  if_tac; [absurd (k = 0)|]; auto.
Qed.

Lemma get_override : forall m k v m' v', set m k v = Some m' -> Zlength m = size -> set m' k v' = set m k v'.
Proof.
  intros; unfold set.
  exploit lookup_set; eauto; intros ->.
  unfold set in H.
  destruct (lookup m k) eqn: Hlookup; auto; inv H; simpl.
  exploit lookup_range; eauto; intro.
  rewrite upd_Znth_twice; auto.
Qed.

Lemma index_of_app : forall k m1 m2, index_of (m1 ++ m2) k =
  match index_of m1 k with Some i => Some i | None => option_map (Z.add (Zlength m1)) (index_of m2 k) end.
Proof.
  induction m1; simpl; intros.
  - destruct (index_of m2 k); auto.
  - destruct a.
    destruct (eq_dec z k); auto.
    rewrite IHm1; destruct (index_of m1 k); auto; simpl.
    destruct (index_of m2 k); auto; simpl.
    rewrite Zlength_cons; f_equal; omega.
Qed.

Lemma index_of_out : forall k m, Forall (fun x => fst x <> k) m -> index_of m k = None.
Proof.
  intros.
  pose proof (index_of_spec k m) as Hk.
  destruct (index_of m k); auto.
  destruct Hk as (? & ? & ?); eapply Forall_Znth in H; eauto.
  subst; contradiction H; eauto.
Qed.

Lemma index_of_sublist : forall m a b i k (HNoDup : NoDup (map fst m))
  (Hi : index_of (sublist a b m) k = Some i) (Ha : 0 <= a) (Hb : b <= Zlength m),
  index_of m k = Some (i + a).
Proof.
  intros.
  destruct (Z_le_dec b a); [rewrite sublist_nil_gen in Hi by auto; discriminate|].
  assert (m = sublist 0 a m ++ sublist a b m ++ sublist b (Zlength m) m) as Hm.
  { rewrite !sublist_rejoin, sublist_same; auto; omega. }
  rewrite Hm, index_of_app, index_of_out, index_of_app, Hi; simpl.
  rewrite Zlength_sublist by omega.
  f_equal; omega.
  { rewrite Hm, !map_app in HNoDup; apply NoDup_app in HNoDup.
    destruct HNoDup as (_ & _ & HNoDup).
    rewrite Forall_forall; intros ???.
    exploit (HNoDup k); try contradiction.
    * rewrite in_map_iff; eauto.
    * rewrite in_app; left.
      pose proof (index_of_spec k (sublist a b m)) as Hspec; rewrite Hi in Hspec.
      destruct Hspec as (? & ? & ?).
      rewrite in_map_iff; do 2 eexists; eauto.
      apply Znth_In; auto. }
Qed.

Lemma index_of_rotate : forall m n k, 0 <= n <= Zlength m -> NoDup (map fst m) ->
  index_of (rotate m n (Zlength m)) k = option_map (fun i => (i + n) mod Zlength m) (index_of m k).
Proof.
  intros.
  destruct (eq_dec (Zlength m) 0).
  { apply Zlength_nil_inv in e; subst.
    unfold rotate; rewrite !sublist_of_nil; auto. }
  unfold rotate; rewrite !index_of_app.
  destruct (index_of (sublist (Zlength m - n) (Zlength m) m) k) eqn: Hk2.
  - pose proof (index_of_spec k (sublist (Zlength m - n) (Zlength m) m)) as Hspec.
    rewrite Hk2 in Hspec; destruct Hspec as (Hrange & ?).
    apply index_of_sublist in Hk2; auto; try omega.
    rewrite Hk2; simpl.
    rewrite Zlength_sublist in Hrange by omega.
    replace (z + _ + _) with (z + Zlength m) by omega.
    rewrite Z.add_mod, Z_mod_same_full, Z.add_0_r, Zmod_mod by auto.
    rewrite Zmod_small; auto; omega.
  - replace (index_of m k) with
      (index_of (sublist 0 (Zlength m - n) m ++ sublist (Zlength m - n) (Zlength m) m) k)
      by (rewrite sublist_rejoin, sublist_same; auto; omega).
    rewrite index_of_app, Hk2.
    pose proof (index_of_spec k (sublist 0 (Zlength m - n) m)) as Hspec.
    destruct (index_of (sublist 0 (Zlength m - n) m) k); auto; simpl.
    rewrite Zlength_sublist in Hspec by omega.
    rewrite Zlength_sublist, Zmod_small by omega.
    f_equal; omega.
Qed.

Corollary index_of_rebase : forall m n k, 0 <= n <= Zlength m -> NoDup (map fst m) ->
  index_of (rebase m n) k = option_map (fun i => (i - n) mod Zlength m) (index_of m k).
Proof.
  intros; unfold rebase.
  destruct (eq_dec (Zlength m) 0).
  { apply Zlength_nil_inv in e; subst.
    rewrite rotate_nil; auto. }
  rewrite index_of_rotate by (auto; omega).
  destruct (index_of m k); auto; simpl.
  replace (z + (Zlength m - n)) with (z - n + (1 * Zlength m)) by omega.
  rewrite Z.mod_add; auto.
Qed.

Lemma index_of'_succeeds : forall k m i (Hi : 0 <= i < Zlength m)
  (Hnz : Forall (fun x => fst x <> 0 /\ fst x <> k) (sublist 0 i m))
  (Hk : fst (Znth i m) = k \/ fst (Znth i m) = 0), index_of' m k = Some i.
Proof.
  intros.
  pose proof (index_of'_spec k m).
  destruct (index_of' m k).
  - destruct H as (? & Hz & Hnz').
    f_equal; eapply (Forall_sublist_first(A := Z * Z)); eauto; omega.
  - destruct H as (Hk' & Hz'); destruct Hk; [contradiction Hk' | contradiction Hz'];
      rewrite in_map_iff; do 2 eexists; eauto; apply Znth_In; auto.
Qed.

Lemma lookup_spec : forall m k (Hwf : wf_map m) (Hchain : well_chained m) (Hlen : Zlength m = size)
  (Hnz : k <> 0) (Hin : In k (map fst m)), lookup m k = index_of m k.
Proof.
  intros.
  destruct (eq_dec (Zlength m) 0).
  { apply Zlength_nil_inv in e; subst; contradiction. }
  specialize (Hchain k).
  pose proof (hash_range k).
  assert (0 <= hash k <= Zlength m) by omega.
  rewrite index_of_rebase in Hchain by auto.
  unfold lookup.
  pose proof (index_of_spec k m) as Hspec; destruct (index_of m k) eqn: Hk; [|contradiction].
  specialize (Hchain _ eq_refl).
  destruct Hspec as (? & Hz & ?).
  assert (0 <= (z - hash k) mod Zlength m < Zlength m) by (apply Z_mod_lt; omega).
  assert (((z - hash k) mod Zlength m + hash k) mod Zlength m = z) as Hmod.
  { rewrite Zplus_mod_idemp_l, Z.sub_simpl_r, Zmod_small; auto. }
  assert (fst (Znth ((z - hash k) mod Zlength m) (rebase m (hash k))) = k).
  { rewrite Znth_rebase, Hmod; auto; omega. }
  erewrite index_of'_succeeds; eauto; simpl.
  rewrite <- Hlen, Hmod; auto.
  + rewrite Zlength_rebase; auto; omega.
  + rewrite Forall_forall; intros ? Hin'.
    split; [rewrite Forall_forall in Hchain; apply Hchain; rewrite !Hlen in *; auto|].
    intro Heq; apply In_Znth in Hin' as (i & Hi & ?); subst x.
    rewrite Zlength_sublist in Hi; try omega.
    rewrite Znth_sublist, Znth_rebase, Z.add_0_r in Heq by omega.
    eapply NoDup_Znth_inj with (i0 := z)(j := (i + hash k) mod (Zlength m)) in Hwf.
    subst z.
    rewrite Zminus_mod_idemp_l, Z.add_simpl_r, Z.sub_0_r, Zmod_small in Hi; try omega.
    * destruct Hi; split; auto.
      etransitivity; eauto.
      apply Z_mod_lt; omega.
    * rewrite Zlength_map; auto.
    * rewrite Zlength_map; apply Z_mod_lt; omega.
    * rewrite !Znth_map; subst k; eauto.
      apply Z_mod_lt; omega.
    * rewrite Zlength_rebase; omega.
Qed.

End Hashtable.

Lemma sepcon_rebase : forall l m, 0 <= m <= Zlength l ->
  fold_right sepcon emp l = fold_right sepcon emp (rebase l m).
Proof.
  intros; unfold rebase, rotate.
  rewrite sepcon_app, subsub1, sepcon_comm, <- sepcon_app, sublist_rejoin, sublist_same by omega; auto.
Qed.

Lemma rebase_map : forall {A B} (f : A -> B) l m, rebase (map f l) m = map f (rebase l m).
Proof.
  intros; unfold rebase.
  rewrite Zlength_map; apply rotate_map.
Qed.


Require Import nat.
Require Import list.
Require Import dictionary.
Require Import state.
Require Import ISA.
Require Import compile.
Require Import execute.

Example test_execute1 : s_execute emptyState []
  [SPush 5, SPush 3, SPush 1, SMinus] = [2,5].
Proof. reflexivity. Qed.

Example test_execute2 : s_execute (t_update emptyState x 3) [3,4]
  [SPush 4, SLoad x, SMult, SPlus] = [15,4].
Proof. reflexivity. Qed.


(**
  [TypeTheory.CwF.CwF_def]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**
Contents:

- the definition of CwFs à la Fiore: [cwf_structure], [cwf]
- equivalence between cwf structures and relative universe structures on Yoneda, [weq_cwf_structure_RelUnivYo]
- type of representations is a proposition if [C] is univalent [isaprop_cwf_representation]
- transport of a CwF structure along weak equivalence [transfer_cwf_weak_equiv]

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import UniMath.CategoryTheory.rezk_completion.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.
Require Import TypeTheory.Auxiliary.TypeOfMorphisms.

Require Import TypeTheory.RelUniv.RelativeUniverses.
Require Import TypeTheory.RelUniv.Transport_along_Equivs.
Require Import TypeTheory.RelUniv.RelUnivYonedaCompletion.

(** * Definition of a CwF

A (Fiore-style) CwF consists of:

- a base category C;
- two presheaves on C, connected by a morphism Tm —p—> Ty;
- a _representation_ of p (see below).

  This is a mild reformulation of Dybjer’s original definition of CwF’s, replacing the functor [C --> FAM] with an arrow in [preShv C].

  Specifically, we follow: Marcelo Fiore, slides 32–34 of _Discrete Generalised Polynomial Functors_ , from talk at ICALP 2012,
  #(link)#

  See also: Marcelo Fiore, _Algebraic Type Theory_, 2008
  #(link)#

*)

Section Fix_Category.

Context {C : category}.

(** ** Representations of maps of presheaves

A *representation* of a map Tm —p—> Ty of presheaves consists of data illustrating that “every fibre of _p_ is representable”; that is, giving for each (A : Ty Γ), some object and map (π A) : Γ.A Γ, along with a term (te A) over A which is “universal”, in that it represents the fiber of p over A. *)

Section Representation.

Context (pp : mor_total (preShv C)).

Definition Ty : functor _ _ := target pp.
Definition Tm : functor _ _ := source pp.

Definition map_into (Γ : C) : UU
:= ∑ (ΓA : C), C ⟦ΓA, Γ⟧.

Definition cwf_tm_of_ty {Γ : C} (A : Ty Γ : hSet) : UU
:= ∑ t : (Tm Γ : hSet), pp $nt t = A.

(* Lemma: convert an equality giving the type of a term
          into commutativity of a square of maps of presheaves. *)
Lemma cwf_square_comm {Γ} {A}
  {ΓA : C} {π : ΓA --> Γ}
  {t : Tm ΓA : hSet} (e : pp $nt t = # Ty π A)
  : #Yo π ;; (@yy C Ty Γ) A = (@yy C Tm ΓA) t ;; pp.
Proof.
  apply pathsinv0.
  etrans. 2: { apply yy_natural. }
  etrans. apply yy_comp_nat_trans.
  apply maponpaths, e.
Qed.

Definition cwf_fiber_representation {Γ : C} (A : Ty Γ : hSet) : UU
  := ∑ (ΓAπ : map_into Γ) (te : cwf_tm_of_ty (# Ty (pr2 ΓAπ) A)),
     isPullback (cwf_square_comm (pr2 te)).
(* See below for an alternative version [cwf_fiber_representation'], separated into data + axioms *)

Definition cwf_representation : UU
  := ∏ Γ (A : Ty Γ : hSet), cwf_fiber_representation A.

End Representation.

(** ** Definition of CwF structure, CwF *)

Definition cwf_structure : UU := ∑ pp, (cwf_representation pp).

(* TODO: add notations, coercions, access functions to make this usable! Or perhaps below, after the date-plus-axioms reformulation? *)

End Fix_Category.

Arguments cwf_structure C : clear implicits.

Definition cwf := ∑ C, cwf_structure C.

Arguments cwf_square_comm {C pp Γ A _ _ _} e.

(** ** Misc lemmas on CwF’s *)
Section CwF_Lemmas.

Context {C : category} (pp : mor_total (preShv C)).

Lemma cwf_square_comm_converse {Γ : C} {A : Ty pp Γ : hSet}
    {ΓA : C} {π : ΓA --> Γ}
    {t : Tm pp ΓA : hSet}
    (e : #Yo π ;; (@yy C (Ty pp) Γ) A = (@yy C (Tm pp) ΓA) t ;; pp)
  : pp $nt t = # (Ty pp) π A.
Proof.
  etrans.
  { apply maponpaths, pathsinv0, functor_id_pshf. }
  etrans.
  { assert (e' := nat_trans_eq_pointwise e ΓA); clear e; cbn in e'.
    refine (toforallpaths (!e') (identity _)).
  }
  unfold yoneda_morphisms_data.
  apply maponpaths_2, id_left.
Qed.

End CwF_Lemmas.

(** * Useful facts about representations *)

Section Representation_Facts.

Context {C : category} (pp : mor_total (preShv C)).

(** ** Data+properties reformulation of definition of representation *)

Section Representation_Regrouping.

Definition cwf_fiber_rep_data {Γ:C} (A : Ty pp Γ : hSet) : UU
  := ∑ (ΓA : C), C ⟦ΓA, Γ⟧ × (Tm pp ΓA : hSet).

Definition cwf_fiber_rep_ax {Γ:C} {A : Ty pp Γ : hSet}
    (ΓAπt : cwf_fiber_rep_data A) : UU
  := ∑ (H : pp $nt (pr2 (pr2 ΓAπt))
            = #(Ty pp) (pr1 (pr2 ΓAπt)) A),
    isPullback (cwf_square_comm H).

Definition cwf_fiber_representation' {Γ:C} (A : Ty pp Γ : hSet) : UU
  := ∑ ΓAπt : cwf_fiber_rep_data A, cwf_fiber_rep_ax ΓAπt.

Definition cwf_fiber_representation_weq {Γ:C} (A : Ty pp Γ : hSet)
  : cwf_fiber_representation pp A ≃ cwf_fiber_representation' A.
Proof.
  unfold cwf_fiber_representation, cwf_fiber_representation'.
  eapply weqcomp.   (* (ΓA,π), ((v,e),P) *)
  eapply weqfibtototal. intro x.
    apply weqtotal2asstor. simpl. (*  (ΓA,π), (v, (e,P)) *)
  eapply weqcomp; [eapply invweq; apply weqtotal2asstol |]; simpl.
  apply invweq.
  eapply weqcomp.
  apply weqtotal2asstor. cbn.
  apply weqfibtototal. intro ΓA.
  apply weqtotal2asstor.
Defined.

End Representation_Regrouping.

(** ** Uniqueness of representations, when C saturated *)

(* TODO: can this be simplified? *)
Lemma isaprop_cwf_fiber_representation' {Γ:C} (A : Ty pp Γ : hSet)
  : is_univalent C -> isaprop (cwf_fiber_representation' A).
Proof.
  intros isC.
  apply invproofirrelevance.
  intros x x'. apply subtypePath.
  { intro t.
    apply isofhleveltotal2.
    - apply setproperty.
    - intro. apply isaprop_isPullback.
  }
  use total2_paths_f; simpl.
  { apply isotoid. { assumption. }
    apply (invmap (weq_ff_functor_on_z_iso (yoneda_fully_faithful _) _ _)).
    refine (z_iso_from_Pullback_to_Pullback
                (make_Pullback _ (pr22 x))
                (make_Pullback _ (pr22 x'))).
  }
  etrans. { apply (transportf_dirprod'
                       (λ a', C ⟦ a', _ ⟧) (λ a', (Tm pp a' : hSet))). }
  apply pathsdirprod.
  - rewrite transportf_isotoid.
    cbn.
    etrans. { apply yoneda_postcompose. }
    etrans. {
      refine (toforallpaths _ (identity _)).
      refine (toforallpaths _ _).
      apply maponpaths,
        (PullbackArrow_PullbackPr1 (make_Pullback _ (pr22 x))).
    }
    cbn; unfold yoneda_morphisms_data.
    apply id_left.
  - etrans. { apply transportf_pshf'. }
    rewrite idtoiso_inv.
    rewrite idtoiso_isotoid.
    cbn.
    match goal with | [ |- _ (_ ?f) _ = _]
                      => set (i := f :  preShv C ⟦ _, _ ⟧) end.
    refine (@pathscomp0 _ _
                 ((i ;; yy _) $nt (identity _)) _ _ _).
    { apply idpath. }
    subst i; unfold from_Pullback_to_Pullback.
    rewrite (PullbackArrow_PullbackPr2 (make_Pullback _ (pr22 x))).
    cbn. apply functor_id_pshf.
Qed.

Lemma isaprop_cwf_fiber_representation {Γ:C} (A : Ty pp Γ : hSet)
  : is_univalent C -> isaprop (cwf_fiber_representation pp A).
Proof.
  intro H.
  refine (isofhlevelweqb _ _ _).
  - apply cwf_fiber_representation_weq.
  - apply isaprop_cwf_fiber_representation'.
    apply H.
Defined.

End Representation_Facts.

(* TODO: perhaps move the following section into a separate file [CwF_RelUniv_Yoneda], to make this file more self-contained?
*)

(** * Equivalence with relative universe structures on Yoneda *)
Section CwF_RelUnivYo.

Context {C : category}.

(** ** Construction of the equivalence *)

Section Representation_FComprehension.

Context (pp : mor_total (preShv C)).

(* TODO: there is considerable redundancy between this and [cwf_fiber_representation_weq] above; in particular, the same reassociation is used. Try to consolidate? *)
Definition weq_cwf_fiber_representation_fpullback {Γ : C} (A : Ty pp Γ : hSet)
  : cwf_fiber_representation pp A
      ≃ fpullback (yoneda C) pp ((@yy C (Ty pp) Γ) A).
Proof.
  unfold cwf_fiber_representation, fpullback.
  (* reassociate the RHS to match the LHS:
       ((ΓA,(π,v)),(e,p))
    -> (((ΓA,π),v),(e,p))
    -> ((ΓA,π),(v,(e,p)))
    -> ((ΓA,π),((v,e),p))
  *)
  eapply weqcomp.
  2: { refine (weqfp _ _). apply weqtotal2asstor'. }
  eapply weqcomp.
  2: { eapply weqtotal2asstol. }
  eapply weqcomp.
  2: { refine (weqfibtototal _ _ _).
    intro. apply weqtotal2asstor'.
  }
  (* convert the term argument under [yy] *)
  apply weqfibtototal. intros [ΓA π]; simpl.
  use weqbandf.
    use weqbandf.
      apply yy.
  (* show the two forms of the equality axiom are equivalent *)
  - intros v; simpl.
    apply weqimplimpl.
    + apply @cwf_square_comm.
    + apply @cwf_square_comm_converse.
    + apply setproperty.
    + apply isaset_nat_trans.
      apply has_homsets_HSET.
  - intros [v e]; cbn.
    apply idweq.
Defined.

Lemma weq_cwf_representation_rel_universe_structure
  : cwf_representation pp ≃ rel_universe_structure Yo pp.
Proof.
  apply weqonsecfibers. intro Γ.
  (* convert the type argument under [yy] *)
  eapply weqcomp.
  2: { eapply invweq.
    refine (weqonsecbase _ _). apply yy.
  }
  apply weqonsecfibers. intro A.
  apply  weq_cwf_fiber_representation_fpullback.
Defined.

End Representation_FComprehension.

Definition weq_cwf_structure_RelUnivYo
  : cwf_structure C ≃ @relative_universe C _ Yo.
Proof.
  apply weqfibtototal.
  intro pp.
  apply weq_cwf_representation_rel_universe_structure.
Defined.

End CwF_RelUnivYo.

Arguments weq_cwf_structure_RelUnivYo _ : clear implicits.

(** The above equivalences allow us to easily deduce a few more nice facts about representations and CwF-structures from the corresponding facts about relative universes. *)

(** ** Consequences of the equivalence: Representations vs representability *)

(*
    When the underlying category is univalent [is_univalent C],
    then representations of a map of presheaves are unique,
    and hence there is no distinction between “represented” and
    “representable” morphisms of presheaves.

    For more on this comparison see [RepMaps.v].
*)

Lemma isaprop_cwf_representation {C : category}
    (Ccat : is_univalent C) (pp : mor_total (preShv C))
  : isaprop (cwf_representation pp).
Proof.
  use isofhlevelweqb.
  - exact (rel_universe_structure Yo pp).
  - apply weq_cwf_representation_rel_universe_structure.
  - apply isaprop_rel_universe_structure.
    + apply Ccat.
    + apply yoneda_fully_faithful.
Qed.

(** * Transport along a weak equivalence *)

(** ** General case of transport, and recovery of the original map *)

Definition transfer_cwf_weak_equiv {C D : category} (F : C ⟶ D)
           (F_ff : fully_faithful F) (F_es : essentially_surjective F)
           (Dcat : is_univalent D)
  : cwf_structure C → cwf_structure D.
Proof.
  intro CC.
  apply (invmap (@weq_cwf_structure_RelUnivYo _)).
  apply (Transfer_of_RelUnivYoneda F F_ff F_es Dcat).
  apply (weq_cwf_structure_RelUnivYo _).
  exact CC.
Defined.

(**  Recovering the original morphism of presheaves after transport *)

Section CwF_Ftransport_recover.

Context {C D : category}
        (F : C ⟶ D)
        (F_ff : fully_faithful F)
        (F_es : essentially_surjective F)
        (Dcat : is_univalent D)
        (T : cwf_structure C).

Let DD : univalent_category := (D,,Dcat).
Let T' : cwf_structure D := transfer_cwf_weak_equiv F F_ff F_es Dcat T.
Let TM : preShv C := Tm (pr1 T).
Let TM' : preShv DD := Tm (pr1 T').
Let TY : preShv C := Ty (pr1 T).
Let TY' : preShv D := Ty (pr1 T').

Let pp : _ ⟦ TM , TY ⟧ := pr1 T.
Let pp' : _ ⟦ TM' , TY' ⟧ := pr1 T'.

Let ηη : functor (preShv D) (preShv C) :=
  pre_composition_functor C^op D^op _ (functor_opp F).

Let isweq_Fcomp : isweq (pr1 (pr1 (Fop_precomp F))) :=
adj_equiv_of_cats_is_weq_of_objects
               _ _
               (is_univalent_functor_category _ _ is_univalent_HSET )
               (is_univalent_functor_category _ _ is_univalent_HSET )
               _
               (equiv_Fcomp F F_ff F_es).

Lemma Tm_transfer_recover :
      TM = ηη TM'.
Proof.
  assert (XT := homotweqinvweq (make_weq _ isweq_Fcomp) TM).
  apply pathsinv0.
  apply XT.
Defined.

Lemma Ty_transfer_recover :
   TY = ηη TY'.
Proof.
  assert (XT := homotweqinvweq (make_weq _ isweq_Fcomp) TY).
  apply pathsinv0.
  apply XT.
Defined.

Let Fopequiv : adj_equivalence_of_cats _  := equiv_Fcomp F F_ff F_es.

Definition pp'_eta :
  preShv C ⟦ ηη TM' , ηη TY' ⟧.
Proof.
  apply (# ηη pp').
Defined.

Definition Tm_iso : z_iso (ηη TM') TM.
Proof.
  apply (counit_pointwise_z_iso_from_adj_equivalence Fopequiv TM).
Defined.

Definition Ty_iso : z_iso (ηη TY') TY.
Proof.
  apply (counit_pointwise_z_iso_from_adj_equivalence Fopequiv TY).
Defined.

Lemma Morphism_of_presheaves_transfer_recover
  : Tm_iso ;; pp = pp'_eta ;; Ty_iso.
Proof.
  apply pathsinv0.
  apply (nat_trans_ax (counit_from_left_adjoint Fopequiv) pp).
Qed.

End CwF_Ftransport_recover.

(** ** Special case of transport: Descent along Rezk-completion *)
(** The construction below is also a special case of [transfer_cwf_weak_equiv] *)
Definition Rezk_on_cwf_structures {C : category} (CC : cwf_structure C)
  : cwf_structure (Rezk_completion C).
Proof.
  apply (invmap (@weq_cwf_structure_RelUnivYo _)).
  apply (Rezk_on_RelUnivYoneda C).
  apply (weq_cwf_structure_RelUnivYo _).
  exact CC.
Defined.

Section CwF_RC_recover.

Context {C : category} (T : cwf_structure C).

Let RC : univalent_category := Rezk_completion C.
Let T' : cwf_structure RC := Rezk_on_cwf_structures T.
Let TM : preShv C := Tm (pr1 T).
Let TM' : preShv RC := Tm (pr1 T').
Let TY : preShv C := Ty (pr1 T).
Let TY' : preShv RC := Ty (pr1 T').

Let pp : _ ⟦ TM , TY ⟧ := pr1 T.
Let pp' : _ ⟦ TM' , TY' ⟧ := pr1 T'.

Let ηη : functor (preShv RC) (preShv C) :=
  pre_composition_functor C^op RC^op _ (functor_opp (Rezk_eta C)).

Lemma Tm_Rezk_completion_recover :
 (*  Tm = functor_composite (functor_opp (Rezk_eta C _ )) Tm'.*)
      TM = ηη TM'.
Proof.
  set (XR := Rezk_opp_weq C HSET is_univalent_HSET).
  assert (XT := homotweqinvweq XR TM).
  apply pathsinv0.
  apply XT.
Defined.

Lemma Ty_Rezk_completion_recover :
(*   Ty = functor_composite (functor_opp (Rezk_eta C _ )) Ty'. *)
   TY = ηη TY'.
Proof.
  set (XR := Rezk_opp_weq C HSET is_univalent_HSET).
  assert (XT := homotweqinvweq XR TY).
  apply pathsinv0.
  apply XT.
Defined.

Let RCequiv : adj_equivalence_of_cats _  := Rezk_op_adj_equiv C
          HSET is_univalent_HSET.

Lemma has_homsets_preShv (D : category) : has_homsets (preShv D).
Proof.
  apply functor_category_has_homsets.
Defined.

Definition RC_pp'_eta :
  preShv C ⟦ ηη TM' , ηη TY' ⟧.
Proof.
  apply (# ηη pp').
Defined.

Definition RC_Tm_iso : z_iso (ηη TM') TM.
Proof.
  set (XR':=  counit_pointwise_z_iso_from_adj_equivalence RCequiv TM).
  apply XR'.
Defined.

Definition RC_Ty_iso : z_iso (ηη TY') TY.
Proof.
  set (XR':=  counit_pointwise_z_iso_from_adj_equivalence RCequiv TY).
  apply XR'.
Defined.

Lemma RC_morphism_of_presheaves_recover
  : RC_Tm_iso ;; pp = RC_pp'_eta ;; RC_Ty_iso.
Proof.
  apply pathsinv0.
  apply (nat_trans_ax (counit_from_left_adjoint RCequiv) pp).
Qed.

End CwF_RC_recover.


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import Template.Template.

Require Import List.

(* Run TemplateProgram (genParamInd [] false true true "ReflParam.matchR.list"). *)

Fixpoint list_RF (A A₂ : Type) (A_R : A -> A₂ -> Type)
                                  (l : list A) (l₂ : list A₂) {struct l} :
   Type :=
   match l with
   | nil =>
       match l₂ with
       | nil => True
       | cons _ _ => False
       end
   | cons h tl =>
       match l₂ with
       | nil  => False
       | cons h₂ tl₂ =>
           A_R h h₂ * list_RF A A₂ A_R tl tl₂
       end
   end.

Inductive list_R (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) : list A₁ -> list A₂ -> Type :=
| nil_R : list_R A₁ A₂ A_R [] []
| cons_R : forall (h : A₁) (h₂ : A₂),
    A_R h h₂ ->
    forall (tl : list A₁) (tl₂ : list A₂),
    list_R A₁ A₂ A_R tl tl₂ -> list_R A₁ A₂ A_R (h :: tl) (h₂ :: tl₂).

About list_R.

Check  ((list_R nat nat (fun _ _ => True) [] []):Set).
Fail Check  ((list_RF nat nat (fun _ _ => True) [] []):Set).
About list.

Fail Check  ((list_R nat nat (fun _ _ => True) [] []):Prop).
Fail Check  ((list_RF nat nat (fun _ _ => True) [] []):Prop).

(* Parametricity Recursive Datatypes.list.

    Definition LT:= forall A:Type, list A->nat.
    Parametricity Recursive LT.
*)