Require Import Setoid Compare_dec Wf_nat.
Require Import Lambda.
Require Import ZF ZFpairs ZFnats ZFord ZFgrothendieck.
Require Import ZFfix.
Require Import Sat.

(** * The set of lambda-terms with constants *)

Module Lam.
Section LambdaTerms.

  (** Set of constants *)
  Variable A : set.

  Definition LAMf (X:set) :=
    prodcart (singl zero) N ∪
    prodcart (singl (succ zero)) A ∪
    (prodcart (singl (succ (succ zero))) (prodcart X X) ∪
     prodcart (singl (succ (succ (succ zero)))) X).

Instance LAMf_mono : Proper (incl_set ==> incl_set) LAMf.
do 2 red; intros.
unfold LAMf.
do 2 apply union2_mono; apply prodcart_mono; auto with *.
apply prodcart_mono; trivial.
Qed.

Instance LAMf_morph : Proper (eq_set ==> eq_set) LAMf.
apply Fmono_morph; apply LAMf_mono.
Qed.
  Definition Var n := couple zero n.
  Definition Cst x := couple (succ zero) x.
  Definition App a b := couple (succ (succ zero)) (couple a b).
  Definition Abs a := couple (succ (succ (succ zero))) a.

  Lemma LAMf_ind : forall X (P : set -> Prop),
    Proper (eq_set ==> iff) P ->
    (forall n, n ∈ N -> P (Var n)) ->
    (forall x, x ∈ A -> P (Cst x)) ->
    (forall a b, a ∈ X -> b ∈ X -> P (App a b)) ->
    (forall a, a ∈ X -> P (Abs a)) ->
    forall a, a ∈ LAMf X -> P a.
unfold LAMf; intros.
apply union2_elim in H4; destruct H4 as [H4|H4];
 apply union2_elim in H4; destruct H4.
  rewrite surj_pair with (1:=H4).
  rewrite (singl_elim _ _ (fst_typ _ _ _ H4)).
  apply H0.
  apply snd_typ in H4; trivial.

  rewrite surj_pair with (1:=H4).
  rewrite (singl_elim _ _ (fst_typ _ _ _ H4)).
  apply H1.
  apply snd_typ in H4; trivial.

  rewrite surj_pair with (1:=H4).
  rewrite (singl_elim _ _ (fst_typ _ _ _ H4)).
  apply snd_typ in H4.
  rewrite surj_pair with (1:=H4).
  apply H2.
   apply fst_typ in H4; trivial.
   apply snd_typ in H4; trivial.

  rewrite surj_pair with (1:=H4).
  rewrite (singl_elim _ _ (fst_typ _ _ _ H4)).
  apply H3.
  apply snd_typ in H4; trivial.
Qed.

  Lemma Var_typ : forall X n,
    n ∈ N -> Var n ∈ LAMf X.
intros.
unfold Var, LAMf.
apply union2_intro1; apply union2_intro1.
apply couple_intro;[apply singl_intro|trivial].
Qed.

  Lemma Cst_typ : forall X x,
    x ∈ A -> Cst x ∈ LAMf X.
intros.
unfold Cst, LAMf.
apply union2_intro1; apply union2_intro2.
apply couple_intro;[apply singl_intro|trivial].
Qed.

  Lemma App_typ : forall X a b,
    a ∈ X -> b ∈ X -> App a b ∈ LAMf X.
intros.
unfold App, LAMf.
apply union2_intro2; apply union2_intro1.
apply couple_intro;[apply singl_intro|trivial].
apply couple_intro; trivial.
Qed.

  Lemma Abs_typ : forall X a,
    a ∈ X -> Abs a ∈ LAMf X.
intros.
unfold Abs, LAMf.
apply union2_intro2; apply union2_intro2.
apply couple_intro;[apply singl_intro|trivial].
Qed.

  Definition Lamn n := TI LAMf (nat2ordset n).

  Lemma Lamn_incl_succ : forall k, Lamn k ⊆ Lamn (S k).
unfold Lamn; simpl; intros.
apply TI_incl; auto with *.
Qed.

  Lemma Lamn_eq : forall k, Lamn (S k) == LAMf (Lamn k).
unfold Lamn; simpl; intros.
apply TI_mono_succ; auto with *.
Qed.

  Lemma Lamn_incl : forall k k', (k <= k')%nat -> Lamn k ⊆ Lamn k'.
induction 1; intros.
 red; auto.
 red; intros.
 apply (Lamn_incl_succ m z); auto.
Qed.

  Definition Lambda := TI LAMf omega.

  Lemma Lambda_intro : forall k, Lamn k ⊆ Lambda.
unfold Lambda, Lamn; intros.
apply TI_incl; auto with *.
apply isOrd_sup_intro with (S k); simpl; auto.
apply lt_osucc; auto.
Qed.

  Lemma Lambda_elim : forall x,
    x ∈ Lambda -> exists k, x ∈ Lamn k.
unfold Lambda, Lamn; intros.
apply TI_elim in H; auto with *.
destruct H.
apply isOrd_sup_elim in H; destruct H.
exists x1.
apply TI_intro with x0; auto with *.
Qed.

  Lemma Lamn_case : forall k (P : set -> Prop),
    Proper (eq_set ==> iff) P ->
    (forall n, n ∈ N -> P (Var n)) ->
    (forall x, x ∈ A -> P (Cst x)) ->
    (forall a b k', (k' < k)%nat -> a ∈ Lamn k' -> b ∈ Lamn k' -> P (App a b)) ->
    (forall a k', (k' < k)%nat -> a ∈ Lamn k' -> P (Abs a)) ->
    forall a, a ∈ Lamn k -> P a.
destruct k; intros.
 unfold Lamn in H4.
 rewrite TI_initial in H4; auto with *.
 elim empty_ax with (1:=H4).

 rewrite Lamn_eq in H4.
 elim H4 using LAMf_ind; eauto.
Qed.

  Lemma Lambda_fix : forall (P:set->Prop),
    (forall k,
     (forall k' x, (k' < k)%nat -> x ∈ Lamn k' -> P x) ->
     (forall x, x ∈ Lamn k -> P x)) ->
    forall x, x ∈ Lambda -> P x.
intros.
apply Lambda_elim in H0; destruct H0.
revert x H0.
elim (lt_wf x0); intros.
eauto.
Qed.

  Lemma Lambda_ind : forall P : set -> Prop,
    Proper (eq_set ==> iff) P ->
    (forall n, n ∈ N -> P (Var n)) ->
    (forall x, x ∈ A -> P (Cst x)) ->
    (forall a b, a ∈ Lambda -> b ∈ Lambda -> P a -> P b -> P (App a b)) ->
    (forall a, a ∈ Lambda -> P a -> P (Abs a)) ->
    forall a, a ∈ Lambda -> P a.
intros.
elim H4 using Lambda_fix; intros.
elim H6 using Lamn_case; intros; eauto.
 apply H2; eauto.
  apply Lambda_intro in H8; trivial.
  apply Lambda_intro in H9; trivial.
 apply H3; eauto.
  apply Lambda_intro in H8; trivial.
Qed.

  Lemma Lambda_eqn : Lambda == LAMf Lambda.
apply eq_intro; intros.
 apply Lambda_elim in H; destruct H.
 apply Lamn_incl_succ in H.
 rewrite Lamn_eq in H.
 eapply LAMf_mono with (Lamn x); trivial.
 apply Lambda_intro.

 elim H using LAMf_ind; intros.
  do 2 red; intros.
  rewrite H0; reflexivity.

  apply Lambda_intro with 1; rewrite Lamn_eq.
  apply Var_typ; trivial.

  apply Lambda_intro with 1; rewrite Lamn_eq.
  apply Cst_typ; trivial.

  apply Lambda_elim in H0; destruct H0 as (k,H0).
  apply Lambda_elim in H1; destruct H1 as (k',H1).
  destruct (le_gt_dec k k').
   assert (Lamn k ⊆ Lamn k').
    apply Lamn_incl; trivial.
   apply Lambda_intro with (S k'); rewrite Lamn_eq.
   apply App_typ; auto.

   assert (Lamn k' ⊆ Lamn k).
    apply Lamn_incl; auto with arith.
   apply Lambda_intro with (S k); rewrite Lamn_eq.
   apply App_typ; auto.

  apply Lambda_elim in H0; destruct H0 as (k,H0).
  apply Lambda_intro with (S k); rewrite Lamn_eq.
  apply Abs_typ; auto.
Qed.

  Lemma Var_typ0 : forall n,
    n ∈ N -> Var n ∈ Lambda.
intros.
rewrite Lambda_eqn; apply Var_typ; trivial.
Qed.

  Lemma Cst_typ0 : forall x,
    x ∈ A -> Cst x ∈ Lambda.
intros.
rewrite Lambda_eqn; apply Cst_typ; trivial.
Qed.

  Lemma App_typ0 : forall a b,
    a ∈ Lambda -> b ∈ Lambda -> App a b ∈ Lambda.
intros.
rewrite Lambda_eqn; apply App_typ; trivial.
Qed.

  Lemma Abs_typ0 : forall a,
    a ∈ Lambda -> Abs a ∈ Lambda.
intros.
rewrite Lambda_eqn; apply Abs_typ; trivial.
Qed.

End LambdaTerms.
End Lam.

Import Lam.
Import Lambda.

(** * Pure lambda-terms: no constants *)
Definition CCLam := Lambda zero.

Fixpoint iLAM (t:term) :=
  match t with
  | Ref n => Lam.Var (nat2set n)
  | Abs M => Lam.Abs (iLAM M)
  | App u v => Lam.App (iLAM u) (iLAM v)
  end.

Lemma iLAM_typ : forall t, iLAM t ∈ CCLam.
unfold CCLam; induction t; try destruct s; simpl;
 repeat
  (apply Var_typ0 || apply Cst_typ0 || apply App_typ0 || apply Abs_typ0 ||
   (apply succ_intro1; reflexivity) || apply succ_intro2 || apply nat2set_typ);
 trivial.
Qed.

Ltac inj_pre H :=
  unfold Var, Cst, Lam.App, Lam.Abs in H;
  change (succ (succ (succ zero))) with (nat2set 3) in H;
  change (succ (succ zero)) with (nat2set 2) in H;
  change (succ zero) with (nat2set 1) in H;
  change zero with (nat2set 0) in H.

Ltac inj_lam H :=
  (apply nat2set_inj in H; try discriminate H) ||
  (apply couple_injection in H;
   let H2 := fresh "H" in
   destruct H as (H,H2); inj_lam H; inj_lam H2) ||
  idtac.

Ltac injl H := inj_pre H; inj_lam H.

Lemma iLAM_inj : forall t u,
  iLAM t == iLAM u -> t=u.
fix IH 1.
destruct t; destruct u; simpl;
  intro H; trivial; injl H.
 rewrite H0; trivial.

 rewrite (IH _ _ H0); trivial.

 rewrite (IH _ _ H0); rewrite (IH _ _ H1); trivial.
Qed.

(** Embedding saturated sets in a set *)
Definition iSAT S :=
  subset CCLam (fun x => exists2 t, inSAT t S & x == iLAM t).

Instance iSAT_morph : Proper (eqSAT ==> eq_set) iSAT.
do 2 red; intros.
rewrite eqSAT_def in H.
unfold iSAT.
apply subset_ext; intros.
 apply subset_intro; trivial.
 destruct H1.
 exists x1; trivial.
 rewrite H; trivial.

 apply subset_elim1 in H0; trivial.

 apply subset_elim2 in H0.
 destruct H0.
 destruct H1.
 exists x1; trivial.
 exists x2; trivial.
 rewrite <- H; trivial.
Qed.

Definition complSAT (P:term->Prop) :=
  interSAT (fun p:{S|forall t, sn t -> P t -> inSAT t S} => proj1_sig p).

Definition sSAT x :=
  complSAT (fun t => iLAM t ∈ x).

Instance sSAT_morph : Proper (eq_set ==> eqSAT) sSAT.
do 2 red; intros.
unfold sSAT, complSAT.
apply interSAT_morph_subset; simpl; intros.
 split; intros.
  rewrite <- H in H2; auto.
  rewrite H in H2; auto.

 reflexivity.
Qed.

Lemma iSAT_id : forall S, eqSAT (sSAT (iSAT S)) S.
intros.
rewrite eqSAT_def.
unfold sSAT, complSAT.
intros.
rewrite <- interSAT_ax.
split; intros.
 assert (forall t, sn t -> iLAM t ∈ iSAT S -> inSAT t S).
  intros.
  unfold iSAT in H1.
  rewrite subset_ax in H1.
  destruct H1 as (_,(x,eq_x,(u,inS,eq_u))).
  rewrite eq_u in eq_x; apply iLAM_inj in eq_x.
  rewrite eq_x; trivial.
 exact (H (exist _ S H0)).

 destruct x; simpl.
 apply i.
  apply sat_sn in H; trivial.

  unfold iSAT.
  apply subset_intro.
   apply iLAM_typ.

   exists t; trivial; reflexivity.

 exists snSAT; intros.
 apply snSAT_intro; trivial.
Qed.

Definition SATset :=
  subset (power CCLam) (fun S => iSAT(sSAT S)==S).

Definition replSAT F :=
  replf (power CCLam) (fun P => F (sSAT P)).

Lemma replSAT_ax : forall f z,
  Proper (eqSAT ==> eq_set) f ->
  (z ∈ replSAT f <-> exists A, z == f A).
unfold replSAT.
intros.
rewrite replf_ax.
 split; intros.
  destruct H0 as (y,isSet,img).
  exists (sSAT y); trivial.

  destruct H0 as (S,eqz).
  exists (iSAT S).
   apply power_intro; intros.
   unfold iSAT in H0.
   apply subset_elim1 in H0; trivial.

   rewrite iSAT_id; trivial.

 do 2 red; intros.
 rewrite <- H1; reflexivity.
Qed.

Lemma G_CCLam U :
  grot_univ U ->
  omega ∈ U ->
  CCLam ∈ U.
intros.
assert (U_singl := G_singl _ H).
assert (U_N : ZFnats.N ∈ U).
 apply G_N; trivial.
assert (U_0 : ZFnats.zero ∈ U).
 apply G_inf_nontriv; trivial.
assert (U_succ : forall n, n ∈ U -> ZFnats.succ n ∈ U).
 intros.
 apply G_union2; auto.
unfold CCLam.
unfold Lam.Lambda.
apply G_TI; trivial.
 do 2 red; intros.
 unfold Lam.LAMf.
 rewrite H1; reflexivity.

 intros.
 unfold Lam.LAMf.
 auto 20 using G_union2, G_prodcart.
Qed.
Hint Resolve G_CCLam.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Lattice constructor: cartesian product.  *)

Set Implicit Arguments.

Require Import OrderedTypeEx Morphisms.
Require Import hpattern vgtac.
Require Import VocabA DLat.

Module ProdKey (A : KEY) (B : KEY) <: KEY.
  Include PairOrderedType A B.
  Definition eqb (x y : t) := if eq_dec x y then true else false.
  Definition zb_eq : zb_equiv eq :=
    {| zb_equiv_refl := eq_refl
     ; zb_equiv_sym := eq_sym
     ; zb_equiv_trans := eq_trans |}.
End ProdKey.

Module Prod (A : LAT) (B : LAT) <: LAT.

Definition t : Type := (A.t * B.t)%type.

(** * Lattice operations *)

Local Open Scope sumbool.

Definition le (x y : t) : Prop := A.le (fst x) (fst y) /\ B.le (snd x) (snd y).

Definition eq (x y : t) : Prop := A.eq (fst x) (fst y) /\ B.eq (snd x) (snd y).

Lemma le_refl : forall (x y : t) (Heq : eq x y), le x y.
Proof. inversion 1; econs; by eauto using A.le_refl, B.le_refl. Qed.
Lemma le_antisym : forall (x y : t) (le1 : le x y) (le2 : le y x), eq x y.
Proof.
  inversion 1; inversion 1; econs; by eauto using A.le_antisym, B.le_antisym.
Qed.
Lemma le_trans : forall (x y z : t) (le1 : le x y) (le2 : le y z), le x z.
Proof.
  inversion 1; inversion 1; econs; by eauto using A.le_trans, B.le_trans.
Qed.

Lemma eq_refl : forall (x : t), eq x x.
Proof. destruct x; econs; by eauto using A.eq_refl, B.eq_refl. Qed.
Lemma eq_sym : forall (x y : t) (Heq : eq x y), eq y x.
Proof. inversion 1; econs; by eauto using A.eq_sym, B.eq_sym. Qed.
Lemma eq_trans :
  forall (x y z : t) (eq1 : eq x y) (eq2 : eq y z), eq x z.
Proof.
  inversion 1; inversion 1; econs; by eauto using A.eq_trans, B.eq_trans.
Qed.

Definition le_dec (x y : t) : {le x y} + {~ le x y}.
refine
  ((if physical_eq x y as c return
       physical_eq x y = c -> {le x y} + {~ le x y} then fun Hc => left _
    else fun _ =>
           match x as x', y as y' return
                 x = x' -> y = y' -> {le x y} + {~ le x y} with
             | (x1, x2), (y1, y2) =>
               fun Hx Hy =>
                 if A.le_dec x1 y1 &&& B.le_dec x2 y2 then left _ else right _
           end Logic.eq_refl Logic.eq_refl) Logic.eq_refl); subst.
+ apply physical_eq_prop in Hc; subst; apply le_refl; by apply eq_refl.
+ des; econs; by vauto.
+ des; inversion 1; by vauto.
Qed.

Definition eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine
  ((if physical_eq x y as c return
       physical_eq x y = c -> {eq x y} + {~ eq x y} then fun Hc => left _
    else fun _ =>
           match x as x', y as y' return
                 x = x' -> y = y' -> {eq x y} + {~ eq x y} with
             | (x1, x2), (y1, y2) =>
               fun Hx Hy =>
                 if A.eq_dec x1 y1 &&& B.eq_dec x2 y2 then left _ else right _
           end Logic.eq_refl Logic.eq_refl) Logic.eq_refl); subst.
+ apply physical_eq_prop in Hc; subst; by apply eq_refl.
+ des; econs; by vauto.
+ des; inversion 1; by vauto.
Qed.

Definition bot : t := (A.bot, B.bot).

Lemma bot_prop : forall (x : t), le bot x.
Proof. i; split; auto using A.bot_prop, B.bot_prop. Qed.

Definition join (x y : t) : t :=
  if le_dec x y then y else
  if le_dec y x then x else
  (A.join (fst x) (fst y), B.join (snd x) (snd y)).

Lemma join_left : forall (x y : t), le x (join x y).
Proof.
  intros;unfold join.
  destruct (le_dec x y);auto.
  destruct (le_dec y x);[apply le_refl;apply eq_refl|].
  unfold le. simpl. split; [apply A.join_left|apply B.join_left].
Qed.

Lemma join_right : forall (x y : t), le y (join x y).
Proof.
  intros;unfold join.
  destruct (le_dec x y);[apply le_refl;apply eq_refl|].
  destruct (le_dec y x);auto.
  unfold le. simpl. split; [apply A.join_right|apply B.join_right].
Qed.

Lemma join_lub : forall (x y u : t) (Hx : le x u) (Hy : le y u), le (join x y) u.
Proof.
  unfold join, le; i; repeat dest_if_dec.
  destruct x, y, u; s.
  split; hdes; auto using A.join_lub, B.join_lub.
Qed.

Definition meet (x y : t) : t :=
  if le_dec x y then x else
  if le_dec y x then y else
    (A.meet (fst x) (fst y), B.meet (snd x) (snd y)).

Lemma meet_left : forall (x y : t), le (meet x y) x.
Proof.
  intros;unfold meet.
  destruct (le_dec x y);[apply le_refl;apply eq_refl|].
  destruct (le_dec y x);auto.
  unfold le. simpl. split; [apply A.meet_left|apply B.meet_left].
Qed.

Lemma meet_right : forall (x y : t), le (meet x y) y.
Proof.
  intros;unfold meet.
  destruct (le_dec x y);auto.
  destruct (le_dec y x);[apply le_refl;apply eq_refl|].
  unfold le. simpl. split; [apply A.meet_right|apply B.meet_right].
Qed.

Lemma meet_glb : forall (x y l : t) (Hx : le l x) (Hy : le l y), le l (meet x y).
Proof.
  unfold meet, le; i; repeat dest_if_dec.
  destruct x, y, l; s.
  split; hdes; auto using A.meet_glb, B.meet_glb.
Qed.

Definition widen (x y : t) : t :=
  if structural_eq x y then x else
  (A.widen (fst x) (fst y), B.widen (snd x) (snd y)).

Definition narrow (x y : t) : t :=
  if structural_eq x y then x else
  (A.narrow (fst x) (fst y), B.narrow (snd x) (snd y)).

Include JoinMeetProp.

End Prod.

(** Modules for generating lookup functions. *)

Module Get2.
  Definition fst {A B : Type} : A * B -> A :=
    Datatypes.fst.
  Definition snd {A B : Type} : A * B -> B :=
    Datatypes.snd.
End Get2.
Module Get3.
  Definition fst {A B C : Type} : A * B * C -> A :=
    Get2.fst <*> Datatypes.fst.
  Definition snd {A B C : Type} : A * B * C -> B :=
    Get2.snd <*> Datatypes.fst.
  Definition thrd {A B C : Type} : A * B * C -> C :=
    Datatypes.snd.
End Get3.
Module Get4.
  Definition fst {A B C D : Type} : A * B * C * D -> A :=
    Get3.fst <*> Datatypes.fst.
  Definition snd {A B C D : Type} : A * B * C * D -> B :=
    Get3.snd <*> Datatypes.fst.
  Definition thrd {A B C D : Type} : A * B * C * D -> C :=
    Get3.thrd <*> Datatypes.fst.
  Definition frth {A B C D : Type} : A * B * C * D -> D :=
    Datatypes.snd.
End Get4.
Module Get5.
  Definition fst {A B C D E : Type} : A * B * C * D * E -> A :=
    Get4.fst <*> Datatypes.fst.
  Definition snd {A B C D E : Type} : A * B * C * D * E -> B :=
    Get4.snd <*> Datatypes.fst.
  Definition thrd {A B C D E : Type} : A * B * C * D * E -> C :=
    Get4.thrd <*> Datatypes.fst.
  Definition frth {A B C D E : Type} : A * B * C * D * E -> D :=
    Get4.frth <*> Datatypes.fst.
  Definition fifth {A B C D E : Type} : A * B * C * D * E -> E :=
    Datatypes.snd.
End Get5.

(** * Cartesian product for multiple lattices *)

Module ProdKey2 (A:KEY) (B:KEY).
  Include ProdKey A B.
  Include Get2.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof. unfold eq; intros [x1 y1] [x2 y2] [Hfst Hsnd]; by auto. Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof. unfold eq; intros [x1 y1] [x2 y2] [Hfst Hsnd]; by auto. Qed.
End ProdKey2.

Module ProdKey3 (A:KEY) (B:KEY) (C:KEY).
  Module E2 := ProdKey A B.
  Include ProdKey E2 C.
  Include Get3.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof.
    unfold eq; intros [[x1 y1] z1] [[x2 y2] z2] [[Hfst Hsnd] Hthrd]. by auto.
  Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof.
    unfold eq; intros [[x1 y1] z1] [[x2 y2] z2] [[Hfst Hsnd] Hthrd]. by auto.
  Qed.
  Lemma thrd_mor : Proper (eq ==> C.eq) thrd.
  Proof.
    unfold eq; intros [[x1 y1] z1] [[x2 y2] z2] [[Hfst Hsnd] Hthrd]. by auto.
  Qed.
End ProdKey3.

Module ProdKey4 (A:KEY) (B:KEY) (C:KEY) (D:KEY).
  Module E2 := ProdKey A B.
  Module E3 := ProdKey E2 C.
  Include ProdKey E3 D.
  Include Get4.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
  Lemma thrd_mor : Proper (eq ==> C.eq) thrd.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
  Lemma frth_mor : Proper (eq ==> D.eq) frth.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
End ProdKey4.

Module ProdKey5 (A:KEY) (B:KEY) (C:KEY) (D:KEY) (E:KEY).
  Module E2 := ProdKey A B.
  Module E3 := ProdKey E2 C.
  Module E4 := ProdKey E3 D.
  Include ProdKey E4 E.
  Include Get5.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma thrd_mor : Proper (eq ==> C.eq) thrd.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma frth_mor : Proper (eq ==> D.eq) frth.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma fifth_mor : Proper (eq ==> E.eq) fifth.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
End ProdKey5.

Module Prod2 (A:LAT) (B:LAT).
  Include Prod A B.
  Include Get2.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof. unfold eq; intros [x1 y1] [x2 y2] [Hfst Hsnd]; by auto. Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof. unfold eq; intros [x1 y1] [x2 y2] [Hfst Hsnd]; by auto. Qed.
End Prod2.

Module Prod3 (A:LAT) (B:LAT) (C:LAT).
  Module E2 := Prod A B.
  Include Prod E2 C.
  Include Get3.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof.
    unfold eq; intros [[x1 y1] z1] [[x2 y2] z2] [[Hfst Hsnd] Hthrd]. by auto.
  Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof.
    unfold eq; intros [[x1 y1] z1] [[x2 y2] z2] [[Hfst Hsnd] Hthrd]. by auto.
  Qed.
  Lemma thrd_mor : Proper (eq ==> C.eq) thrd.
  Proof.
    unfold eq; intros [[x1 y1] z1] [[x2 y2] z2] [[Hfst Hsnd] Hthrd]. by auto.
  Qed.
End Prod3.

Module Prod4 (A:LAT) (B:LAT) (C:LAT) (D:LAT).
  Module E2 := Prod A B.
  Module E3 := Prod E2 C.
  Include Prod E3 D.
  Include Get4.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
  Lemma thrd_mor : Proper (eq ==> C.eq) thrd.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
  Lemma frth_mor : Proper (eq ==> D.eq) frth.
  Proof.
    unfold eq; intros [[[x1 y1] z1] a1] [[[x2 y2] z2] a2] [[[Hfst Hsnd] Hthrd] Hfrth]. by auto.
  Qed.
End Prod4.

Module Prod5 (A:LAT) (B:LAT) (C:LAT) (D:LAT) (E:LAT).
  Module E2 := Prod A B.
  Module E3 := Prod E2 C.
  Module E4 := Prod E3 D.
  Include Prod E4 E.
  Include Get5.

  Lemma fst_mor : Proper (eq ==> A.eq) fst.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma snd_mor : Proper (eq ==> B.eq) snd.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma thrd_mor : Proper (eq ==> C.eq) thrd.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma frth_mor : Proper (eq ==> D.eq) frth.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
  Lemma fifth_mor : Proper (eq ==> E.eq) fifth.
  Proof.
    unfold eq; intros [[[[x1 y1] z1] a1] b1] [[[[x2 y2] z2] a2] b2] [[[[Hfst Hsnd] Hthrd] Hfrth] Hfifth]. by auto.
  Qed.
End Prod5.


Require Import Nijn.Prelude.
Require Import Nijn.Syntax.Signature.
Require Import Nijn.Syntax.Signature.SubstitutionLemmas.
Require Import Nijn.Syntax.Signature.RewriteLemmas.
Require Import Nijn.Syntax.StrongNormalization.SN.
Require Import Nijn.Syntax.StrongNormalization.BetaNormalForm.
Require Import Coq.Program.Equality.

Local Open Scope type.

(** * Proving strong normalization of the STLC using logical relations *)

(** ** The logical relation on terms *)
Fixpoint logical_SN
         {B : Type}
         {F : Type}
         {ar : F -> ty B}
         {C : con B}
         {A : ty B}
  : tm ar C A -> Prop
  := match A with
     | Base b => term_is_beta_SN
     | A1 ⟶ A2 =>
       fun f =>
         forall (C2 : con B)
                (w : wk C2 C)
                (t : tm ar C2 A1),
           logical_SN t -> logical_SN (wkTm f w · t)
     end.

(** Preservation under weakening *)
Proposition wk_logical_SN
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            (w : wk C1 C2)
            {A : ty B}
            (t : tm ar C2 A)
            (Ht : logical_SN t)
  : logical_SN (wkTm t w).
Proof.
  destruct A.
  - simpl in *.
    apply wkTm_is_beta_SN.
    exact Ht.
  - intros C w' t' Ht'.
    rewrite wkTm_comp.
    exact (Ht _ (compWk w w') t' Ht').
Qed.

(** Preservation under beta reduction steps *)
Proposition beta_red_logical_SN
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C : con B}
            {A : ty B}
            {t1 t2 : tm ar C A}
            (Ht1 : logical_SN t1)
            (r : t1 ∼>β t2)
  : logical_SN t2.
Proof.
  revert C t1 t2 Ht1 r.
  induction A as [ b | A1 IHA1 A2 IHA2 ].
  - simpl ; intros.
    refine (red_to_beta_SN Ht1 _).
    apply betaRed_step.
    exact r.
  - intros C f1 f2 Hf1 r C' w t Ht.
    refine (IHA2 _ (wkTm f1 w · t) (wkTm f2 w · t) _ _).
    + exact (Hf1 _ _ _ Ht).
    + apply App_l.
      apply betaRed_step_Wk.
      exact r.
Qed.

(** ** The logical relation on substitutions *)
Definition logical_SN_sub
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           (s : sub ar C1 C2)
  : Prop
  := forall (A : ty B)
            (v : var C2 A),
    logical_SN (subVar v s).

(** Some constructions for logical substitutions *)
Proposition ToEmpty_logical_SN
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            (C : con B)
  : logical_SN_sub (@ToEmpty _ _ ar C).
Proof.
  intros A v.
  inversion v.
Qed.

Proposition Extend_logical_SN
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {s : sub ar C1 C2}
            {A : ty B}
            (t : tm ar C1 A)
            (p : logical_SN_sub s)
            (q : logical_SN t)
  : logical_SN_sub (s && t).
Proof.
  intros A' v.
  dependent destruction v ; simpl ; cbn.
  - exact q.
  - apply p.
Qed.

Proposition Extend_logical_SN_pr1
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {s : sub ar C1 C2}
            {A : ty B}
            (t : tm ar C1 A)
            (p : logical_SN_sub (s && t))
  : logical_SN_sub s.
Proof.
  intros A' v.
  assert (subVar v s
          =
          TmVar (wkVar v (dropId C2 _)) [ s && t ])
    as H.
  {
    rewrite wkVar_is_subVar.
    symmetry.
    etransitivity.
    {
      apply (subTm_comp (TmVar v)).
    }
    simpl.
    f_equal.
    rewrite dropSub_is_compSubWk.
    rewrite <- compSub_compWkSub.
    simpl ; cbn.
    rewrite wkToSub_id.
    rewrite Sub_id_left.
    rewrite compWkSub_id.
    reflexivity.
  }
  rewrite H.
  apply p.
Qed.

Proposition Extend_logical_SN_pr2
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {s : sub ar C1 C2}
            {A : ty B}
            (t : tm ar C1 A)
            (p : logical_SN_sub (s && t))
  : logical_SN t.
Proof.
  exact (p A Vz).
Qed.

(** ** Neutral terms *)

(** Our goal is to show that all neutral terms satisfy the logical relation *)
Inductive is_neutral
          {B : Type}
          {F : Type}
          {ar : F -> ty B}
          {C : con B}
  : forall {A : ty B}, tm ar C A -> Type
  :=
| BaseTm_is_neutral : forall (f : F), is_neutral (BaseTm f)
| Var_is_neutral : forall {A : ty B} (v : var C A), is_neutral (TmVar v)
| App_is_neutral : forall {A1 A2 : ty B} (f : tm ar C (A1 ⟶ A2)) (t : tm ar C A1),
    is_neutral f -> term_is_beta_SN t -> is_neutral (f · t).

(** Neutral terms are closed under weakening *)
Lemma wk_neutral
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C1 C2 : con B}
      (w : wk C1 C2)
      {A : ty B}
      (t : tm ar C2 A)
      (p : is_neutral t)
  : is_neutral (wkTm t w).
Proof.
  induction t as [ | | | ? ? ? t1 IHt1 t2 IHt2  ].
  - constructor.
  - constructor.
  - inversion p.
  - simpl in *.
    dependent destruction p.
    constructor.
    + apply IHt1.
      assumption.
    + apply wkTm_is_beta_SN.
      assumption.
Qed.

(** * Properties of the logical relation *)

(** We prove two properties of logical relations, namely that neutral terms satisfy it and that each element that satisfies the relation, is strongly normalizing. We do that by mutual induction. *)

(** Neutral terms reduce to neutral terms *)
Lemma neutral_beta
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A : ty B}
      {t t' : tm ar C A}
      (Ht : is_neutral t)
      (r : t ∼>β t')
  : is_neutral t'.
Proof.
  induction r.
  - dependent destruction Ht.
    apply App_is_neutral.
    + apply IHr.
      exact Ht.
    + exact t0.
  - dependent destruction Ht.
    apply App_is_neutral.
    + exact Ht.
    + refine (red_to_beta_SN _ (betaRed_step r)).
      assumption.
  - inversion Ht.
  - induction r.
    dependent destruction Ht.
    inversion Ht.
Qed.

(** If we apply a strongly normalizing neutral term to a strongly normalizing term, then we get another strongly normalizing term *)
Lemma neutral_beta_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 : ty B}
      (f : tm ar C (A1 ⟶ A2))
      (Hf1 : is_neutral f)
      (Hf2 : term_is_beta_SN f)
      (t : tm ar C A1)
      (Ht : term_is_beta_SN t)
  : term_is_beta_SN (f · t).
Proof.
  revert t Ht.
  induction Hf2 as [f2 Hf2 IHf2].
  intros t Ht.
  induction Ht as [t Ht IHt].
  apply single_step_SN.
  intros t' r.
  dependent destruction r.
  - specialize (IHf2 f0 (betaRed_step r) (neutral_beta Hf1 r)).
    apply IHf2.
    apply acc ; assumption.
  - exact (IHt x2 (TStep r)).
  - dependent destruction b.
    inversion Hf1.
Qed.

(** Neutral terms satisfy the logical relation and terms that satisfy the logical relation are strongly normalizing *)
Definition map_tm_logical_SN
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C : con B}
           {A1 A2 : ty B}
           (f : tm ar C (A1 ⟶ A2))
  : tm ar (A1 ,, C) A2
  := wkTm f (Drop _ (idWk C)) · TmVar Vz.

Lemma Rew_map_tm_logical_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 : ty B}
      {f1 f2 : tm ar C (A1 ⟶ A2)}
      (p : betaRed f1 f2)
  : betaRed (map_tm_logical_SN f1) (map_tm_logical_SN f2).
Proof.
  unfold map_tm_logical_SN.
  apply beta_App_l.
  apply betaRed_Wk.
  exact p.
Qed.

Lemma neutral_is_logical_SN_and_logical_SN_to_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {A : ty B}
  : forall {C : con B}
           (t : tm ar C A),
    (is_neutral t -> logical_SN t)
    /\
    (logical_SN t -> term_is_beta_SN t).
Proof.
  induction A as [ b | A1 IHA1 A2 IHA2 ] ; simpl.
  - intros C t.
    split ; intro p.
    + induction p.
      * apply baseTm_is_SN.
      * apply var_is_SN.
      * apply neutral_beta_SN ; assumption.
    + assumption.
  - intros C t.
    split ; intro p.
    + intros C' w t' q.
      apply IHA2.
      constructor.
      * apply wk_neutral.
        exact p.
      * apply IHA1.
        exact q.
    + pose (x := wkTm t (Drop A1 (idWk C)) · TmVar Vz).
      specialize (IHA2 _ x).
      unfold map_tm_logical_SN in IHA2.
      assert (logical_SN (wkTm t (Drop A1 (idWk C)) · TmVar Vz)) as w.
      {
        apply p.
        apply IHA1.
        constructor.
      }
      destruct IHA2 as [q IHA2].
      clear IHA1 q.
      specialize (IHA2 w).
      clear p w.
      dependent induction IHA2.
      apply acc.
      intros y Hy.
      apply (H0 (map_tm_logical_SN y)) ; auto.
      apply Rew_map_tm_logical_SN.
      exact Hy.
Qed.

(** Accessors for these properties *)
Proposition logical_SN_to_SN
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {A : ty B}
  : forall {C : con B}
           {t : tm ar C A}
           (p : logical_SN t),
    term_is_beta_SN t.
Proof.
  intros C t p.
  apply (neutral_is_logical_SN_and_logical_SN_to_SN t).
  exact p.
Qed.

Proposition neutral_is_logical_SN
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {A : ty B}
  : forall {C : con B}
           (t : tm ar C A)
           (p : is_neutral t),
    logical_SN t.
Proof.
  intros C t p.
  apply (neutral_is_logical_SN_and_logical_SN_to_SN t).
  exact p.
Qed.

(** Now we can conclude that variables and base terms satisfy the logical relation *)
Lemma var_is_logical_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {A : ty B}
      {C : con B}
      (v : var C A)
  : @logical_SN _ _ ar _ _ (TmVar v).
Proof.
  apply neutral_is_logical_SN ; cbn.
  constructor.
Qed.

Lemma base_is_logical_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      (f : F)
  : @logical_SN _ _ ar C _ (BaseTm f).
Proof.
  apply neutral_is_logical_SN ; cbn.
  constructor.
Qed.

(** * Closure under beta *)

(** We first define repeat applications. This is basically just a list of terms where they types agree. Note that [repeat_app ar C A1 A2] is a repeated application of a term of type [A1] and it gives a term of type [A2]. *)
Inductive repeat_app
          {B : Type}
          {F : Type}
          (ar : F -> ty B)
          (C : con B)
  : ty B -> ty B -> Type
  :=
  | empty : forall (A : ty B), repeat_app ar C A A
  | add_term : forall (A1 A2 A3 : ty B)
                      (t : tm ar C A2),
      logical_SN t
      -> repeat_app ar C A1 (A2 ⟶ A3)
      -> repeat_app ar C A1 A3.

Arguments empty {_ _ _ _ _}.
Arguments add_term {_ _ _ _ _ _ _} _ _.

(** The semantics of a repeated application *)
Fixpoint sem
         {B : Type}
         {F : Type}
         {ar : F -> ty B}
         {C : con B}
         {A1 A2 : ty B}
         (ps : repeat_app ar C A1 A2)
  : tm ar C A1 -> tm ar C A2
  := match ps with
     | empty => fun f => f
     | add_term t _ qs => fun f => sem qs f · t
     end.

Notation "f ·· ps" := (sem ps f) (at level 20).

(** Closure under weakening *)
Fixpoint wk_repeat_app
         {B : Type}
         {F : Type}
         {ar : F -> ty B}
         {C1 C2 : con B}
         {A1 A2 : ty B}
         (ps : repeat_app ar C2 A1 A2)
         (w : wk C1 C2)
  : repeat_app ar C1 A1 A2
  := match ps with
     | empty => empty
     | add_term t Ht qs => add_term (wkTm t w) (wk_logical_SN w _ Ht) (wk_repeat_app qs w)
     end.

Proposition sem_wk_repeat_app
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {A1 A2 : ty B}
            (ps : repeat_app ar C2 A1 A2)
            (w : wk C1 C2)
            (t : tm ar C2 A1)
  : wkTm t w ·· wk_repeat_app ps w = wkTm (t ·· ps) w.
Proof.
  induction ps as [ | ? ? ? ? ? qs IHqs ].
  - reflexivity.
  - simpl.
    rewrite IHqs.
    reflexivity.
Qed.

(** Repeated applications preserve the logical relation *)
Lemma sem_logical_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 : ty B}
      (ps : repeat_app ar C A1 A2)
      (t : tm ar C A1)
      (H : logical_SN t)
  : logical_SN (t ·· ps).
Proof.
  induction ps as [ | ? ? ? t' H' ps IHps ].
  - exact H.
  - intros ; simpl.
    specialize (IHps t H _ (idWk _) t' H').
    rewrite wkTm_id in IHps.
    exact IHps.
Qed.

Lemma app_is_not_lam
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 : ty B}
      {t : tm ar C A1}
      (ps : repeat_app ar C A1 A2)
      (Ht : ~(is_Lambda t))
  : ~(is_Lambda (t ·· ps)).
Proof.
  destruct ps ; auto.
Qed.

(** ** Reduction of substitutions *)
(** Since substitutions are just a list of terms, we can also define reduction on them. Beta reduction of a substitution is a beta step on one of the terms. We will use this to study how terms rewrite after a beta step. *)
Inductive sub_red
          {B : Type}
          {F : Type}
          {ar : F -> ty B}
  : forall {C1 C2 : con B}, sub ar C1 C2 -> sub ar C1 C2 -> Type
  :=
| ExtendSub_left : forall {C1 C2 : con B}
                          (s : sub ar C1 C2)
                          {A : ty B}
                          {t1 t2 : tm ar C1 A}
                          (r : t1 ∼>β t2),
    sub_red (s && t1) (s && t2)
| ExtendSub_right : forall {C1 C2 : con B}
                           (s1 s2 : sub ar C1 C2)
                           {A : ty B}
                           {t : tm ar C1 A},
    sub_red s1 s2 -> sub_red (s1 && t) (s2 && t).

Notation "s1 ∼>βs s2" := (sub_red s1 s2) (at level 70).

(** The reduction relation on some standard constructions *)
Definition dropSub_red
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           (A : ty B)
           {C1 C2 : con B}
           {s1 s2 : sub ar C1 C2}
           (r : s1 ∼>βs s2)
  : dropSub A s1 ∼>βs dropSub A s2.
Proof.
  induction r ; simpl.
  - constructor.
    apply betaRed_step_Wk.
    exact r.
  - constructor.
    exact IHr.
Qed.

Definition keepSub_red
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           (A : ty B)
           {C1 C2 : con B}
           {s1 s2 : sub ar C1 C2}
           (r : s1 ∼>βs s2)
  : keepSub A s1 ∼>βs keepSub A s2.
Proof.
  unfold keepSub.
  constructor.
  apply dropSub_red.
  exact r.
Qed.

Definition beta_sub_red
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C : con B}
           {A : ty B}
           {t1 t2 : tm ar C A}
           (r : t1 ∼>β t2)
  : beta_sub t1 ∼>βs beta_sub t2.
Proof.
  unfold beta_sub.
  constructor.
  exact r.
Qed.

(** The next propositions say the possibilities if we substitute a variable for a term that can be rewritten *)
Proposition subVar_red_or_eq
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {s1 s2 : sub ar C1 C2}
            (r : s1 ∼>βs s2)
            {A : ty B}
            (v : var C2 A)
  : subVar v s1 ∼>β* subVar v s2.
Proof.
  induction v.
  - dependent destruction r ; simpl ; cbn.
    + left.
      apply betaRed_step.
      assumption.
    + right.
      reflexivity.
  - dependent destruction r ; simpl ; cbn.
    + right.
      reflexivity.
    + exact (IHv _ _ r).
Qed.

Proposition subTm_red_or_eq
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {s1 s2 : sub ar C1 C2}
            (r : s1 ∼>βs s2)
            {A : ty B}
            (t : tm ar C2 A)
  : t [ s1 ] ∼>β* t [ s2 ].
Proof.
  revert C1 s1 s2 r.
  induction t as [ b | ? ? v | ? ? ? f IHf | ? ? ? f IHf t IHt ]
  ; simpl ; intros C1 s1 s2 r.
  - right ; reflexivity.
  - apply subVar_red_or_eq.
    exact r.
  - specialize (IHf _ (keepSub _ s1) (keepSub _ s2) (keepSub_red _ r)).
    destruct IHf as [p | p].
    + left.
      apply beta_Lam.
      exact p.
    + right.
      rewrite p.
      reflexivity.
  - specialize (IHf _ _ _ r).
    specialize (IHt _ _ _ r).
    destruct IHf as [p | p], IHt as [q | q].
    + left.
      exact (beta_Trans (beta_App_l _ p) (beta_App_r _ q)).
    + left.
      rewrite q.
      apply beta_App_l.
      exact p.
    + left.
      rewrite p.
      apply beta_App_r.
      exact q.
    + right.
      rewrite p, q.
      reflexivity.
Qed.

Proposition sub_beta_red_or_eq
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C : con B}
            {A1 A2 : ty B}
            (f : tm ar (A1 ,, C) A2)
            {t1 t2 : tm ar C A1}
            (r : t1 ∼>β t2)
  : f [ beta_sub t1 ] ∼>β* f [ beta_sub t2 ].
Proof.
  exact (subTm_red_or_eq (beta_sub_red r) f).
Qed.

(** ** Reduction of repeated applications *)
Inductive repeat_app_red
          {B : Type}
          {F : Type}
          {ar : F -> ty B}
          {C : con B}
  : forall {A1 A2 : ty B}, repeat_app ar C A1 A2 -> repeat_app ar C A1 A2 -> Type
  :=
| add_term_top : forall {A1 A2 A3 : ty B}
                        {t1 t2 : tm ar C A2}
                        (Ht1 : logical_SN t1)
                        (Ht2 : logical_SN t2)
                        (ps : repeat_app ar C A1 (A2 ⟶ A3)),
    t1 ∼>β t2
    ->
    repeat_app_red (add_term t1 Ht1 ps) (add_term t2 Ht2 ps)
| add_term_rest : forall {A1 A2 A3 : ty B}
                         {t : tm ar C A2}
                         (Ht : logical_SN t)
                         (ps qs : repeat_app ar C A1 (A2 ⟶ A3)),
    repeat_app_red ps qs
    ->
    repeat_app_red (add_term t Ht ps) (add_term t Ht qs).

Notation "ps ∼>βr qs" := (repeat_app_red ps qs) (at level 70).

(** Rewriting in a repeated application *)
Definition repeat_app_left
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C : con B}
           {A1 A2 : ty B}
           (ps : repeat_app ar C A1 A2)
           {t1 t2 : tm ar C A1}
           (r : t1 ∼>β+ t2)
  : t1 ·· ps ∼>β+ t2 ·· ps.
Proof.
  induction ps as [ | ? ? ? ? ? ps IHps ] ; simpl.
  - exact r.
  - apply beta_App_l.
    apply IHps.
    exact r.
Qed.

Definition repeat_app_right
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C : con B}
           {A1 A2 : ty B}
           (ps qs : repeat_app ar C A1 A2)
           {t : tm ar C A1}
           (r : ps ∼>βr qs)
  : t ·· ps ∼>β t ·· qs.
Proof.
  induction r as [ ? ? ? ? ? ? ? ? b | ? ? ? ? ? ? ? r IHr ] ; simpl.
  - apply App_r.
    exact b.
  - apply App_l.
    apply IHr.
Qed.

(** Beta reduction of repeated applications is well-founded *)
Definition repeat_app_red_Wf
           {B : Type}
           {F : Type}
           (ar : F -> ty B)
           (C : con B)
           (A1 A2 : ty B)
  : Wf (fun (ps1 ps2 : repeat_app ar C A1 A2) => ps1 ∼>βr ps2).
Proof.
  intro ps.
  induction ps as [ | ? ? ? t Ht ps IHps ].
  - apply acc.
    intros.
    inversion X.
  - revert t Ht.
    induction IHps as [ ps Hps IHps ].
    intros t Ht.
    pose (logical_SN_to_SN Ht) as Ht'.
    induction Ht' as [t ? IHt].
    apply acc.
    intros qs r.
    dependent destruction r.
    + apply IHt.
      apply betaRed_step.
      exact b.
    + apply IHps.
      exact r.
Qed.

(** Now we look at the shape of reductions in a repeated application and in a beta redex. *)
Definition red_repeat_app
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C : con B}
           {A1 A2 : ty B}
           {t : tm ar C A1}
           {ps : repeat_app ar C A1 A2}
           {u : tm ar C A2}
           (Ht : ~(is_Lambda t))
           (r : t ·· ps ∼>β u)
  : { t' : tm ar C A1 & (t ∼>β t') * (u = t' ·· ps)}
    + { ps' : repeat_app ar C A1 A2 & (ps ∼>βr ps') * (u = t ·· ps')}.
Proof.
  induction ps.
  - simpl in *.
    left.
    exists u.
    split ; try reflexivity.
    exact r.
  - simpl in *.
    dependent destruction r.
    + destruct (IHps t f2 Ht r).
      * left.
        destruct s as [x H].
        exists x.
        split.
        ** apply H.
        ** f_equal.
           apply H.
      * right.
        destruct s as [x H].
        exists (add_term t0 l x).
        simpl.
        split.
        ** apply add_term_rest.
           apply H.
        ** f_equal.
           apply H.
    + right.
      exists (add_term _ (beta_red_logical_SN l r) ps).
      split ; simpl.
      * apply add_term_top.
        exact r.
      * reflexivity.
    + pose (app_is_not_lam ps Ht) as n.
      simpl in n.
      dependent destruction b.
      rewrite <- x in n.
      simpl in n.
      contradiction.
Qed.

Definition red_beta_redex
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C : con B}
           {A1 A2 : ty B}
           {f : tm ar (A1 ,, C) A2}
           {t : tm ar C A1}
           {u : tm ar C A2}
           (r : (λ f) · t ∼>β u)
  : (u = f [ beta_sub t ])
    + { t' : tm ar C A1 & (t ∼>β t') * (u = (λ f) · t') }
    + { f' : tm ar (A1 ,, C) A2 & (f ∼>β f') * (u = (λ f') · t)}.
Proof.
  dependent destruction r.
  - dependent destruction r.
    + right.
      exists f0.
      split ; try reflexivity.
      exact r.
    + dependent destruction r.
  - left ; right.
    exists x2.
    split ; try reflexivity.
    exact r.
  - dependent destruction b.
    left ; left.
    reflexivity.
Qed.

(** The next two lemmata express that the logical relation is closed under beta reduction *)
Lemma logical_SN_beta_help_base
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 A3 : ty B}
      (f : tm ar (A1 ,, C) A2)
      (t : tm ar C A1)
      (ps : repeat_app ar C A2 A3)
      (Hsub : term_is_beta_SN (f [ beta_sub t ] ·· ps))
      (Hf : term_is_beta_SN f)
      (Ht : term_is_beta_SN t)
  : term_is_beta_SN (((λ f) · t) ·· ps).
Proof.
  revert t Ht ps Hsub.
  induction Hf as [f Hf IHf].
  intros t Ht.
  induction Ht as [t Ht IHt].
  intros ps Hsub.
  induction (repeat_app_red_Wf ar C A2 A3 ps) as [ps Hps IHps].
  apply single_step_SN ; intros t' r.
  assert (W : ~(is_Lambda ((λ f) · t))) by auto.
  destruct (red_repeat_app W r) as [ [u  [r' H]] | [ps' [ r' p ]] ].
  - destruct (red_beta_redex r') as [ [ p | [ u' [ p H' ]]] | [ f' [ p H' ]]].
    + subst.
      exact Hsub.
    + subst.
      apply (IHt u' (TStep p)).
      destruct (sub_beta_red_or_eq f p) as [q | q].
      * refine (red_to_beta_SN Hsub _).
        apply repeat_app_left.
        exact q.
      * rewrite <- q.
        exact Hsub.
    + subst.
      apply (IHf f' (TStep p) t).
      * apply acc ; assumption.
      * apply (red_to_beta_SN Hsub).
        apply repeat_app_left.
        apply betaRed_sub.
        apply TStep.
        exact p.
  - subst.
    apply IHps.
    + exact r'.
    + refine (red_to_beta_SN Hsub _).
      apply betaRed_step.
      apply repeat_app_right.
      exact r'.
Qed.

Lemma logical_SN_beta_help
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 A3 : ty B}
      (f : tm ar (A1 ,, C) A2)
      (t : tm ar C A1)
      (Hsub : logical_SN (f [ beta_sub t ]))
      (Hf : logical_SN f)
      (Ht : logical_SN t)
      (ps : repeat_app ar C A2 A3)
  : logical_SN (((λ f) · t) ·· ps).
Proof.
  revert ps Ht Hf Hsub.
  revert t f.
  revert A1 A2.
  revert C.
  induction A3 as [ b | A31 IHA31 A32 IHA32 ] ; intros C A1 A2 t f ps Ht Hf Hsub.
  - simpl.
    pose (H := sem_logical_SN ps _ Hsub).
    apply logical_SN_beta_help_base ; apply logical_SN_to_SN ; assumption.
  - intros ? w t' Ht'.
    specialize (IHA32
                  _ _ _
                  (wkTm t w) (wkTm f (Keep A1 w))
                  (add_term t' Ht' (wk_repeat_app ps w))).
    simpl in IHA32.
    rewrite <- sem_wk_repeat_app.
    apply IHA32.
    + apply wk_logical_SN.
      exact Ht.
    + apply wk_logical_SN.
      exact Hf.
    + rewrite wkTm_is_subTm.
      rewrite subTm_comp.
      simpl ; cbn.
      rewrite dropSub_is_compSubWk.
      rewrite <- compSub_compWkSub.
      simpl ; cbn.
      rewrite compWkSub_id.
      rewrite Sub_id_right.
      unfold beta_sub in Hf.
      pose (wk_logical_SN w _ Hsub) as l.
      rewrite wkTm_is_subTm in l.
      rewrite subTm_comp in l.
      simpl in l.
      rewrite Sub_id_left in l.
      rewrite <- wkTm_is_subTm in l.
      exact l.
Qed.

Lemma logical_SN_beta
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A1 A2 : ty B}
      (f : tm ar (A1 ,, C) A2)
      (t : tm ar C A1)
      (Hsub : logical_SN (f [ beta_sub t ]))
      (Hf : logical_SN f)
      (Ht : logical_SN t)
  : logical_SN ((λ f) · t).
Proof.
  exact (logical_SN_beta_help f t Hsub Hf Ht empty).
Qed.

(** ** The fundamental theorem of logical relations *)
Theorem fundamental_thm_relations
        {B : Type}
        {F : Type}
        {ar : F -> ty B}
        {C1 C2 : con B}
        (s : sub ar C1 C2)
        {A : ty B}
        (t : tm ar C2 A)
        (p : logical_SN_sub s)
  : logical_SN (t [ s ]).
Proof.
  revert p.
  revert s.
  revert C1.
  induction t ; intros C1 s p ; simpl.
  - apply base_is_logical_SN.
  - induction s.
    + inversion v.
    + dependent induction v ; simpl ; cbn.
      * exact (Extend_logical_SN_pr2 _ p).
      * apply IHs.
        exact (Extend_logical_SN_pr1 _ p).
  - intros x w t' Ht'.
    apply logical_SN_beta.
    + rewrite wkTm_is_subTm.
      rewrite !subTm_comp.
      unfold beta_sub.
      simpl ; cbn.
      rewrite !dropSub_is_compSubWk.
      rewrite <- !compSub_compWkSub.
      simpl ; cbn.
      rewrite compWkSub_id.
      rewrite compWkSub_id.
      rewrite Sub_id_right.
      apply IHt.
      apply Extend_logical_SN ; try assumption.
      intros ? v.
      specialize (p _ v).
      rewrite <- subVar_comp.
      rewrite <- wkTm_is_subTm.
      apply wk_logical_SN.
      assumption.
    + rewrite wkTm_is_subTm.
      rewrite subTm_comp.
      apply IHt.
      simpl ; cbn ; unfold keepSub.
      rewrite !dropSub_is_compSubWk.
      rewrite <- !compSub_compWkSub.
      simpl ; cbn.
      rewrite compWkSub_id.
      apply Extend_logical_SN.
      * intros ? v.
        rewrite <- dropSub_is_compSubWk.
        rewrite <- subVar_comp.
        pose (wkTm_is_subTm (subVar v s) (Drop A1 w)) as q.
        simpl in q.
        rewrite <- q ; clear q.
        apply wk_logical_SN.
        apply p.
      * apply var_is_logical_SN.
    + exact Ht'.
  - specialize (IHt2 _ s p).
    pose (IHt1 _ s p _ (idWk _) _ IHt2).
    rewrite wkTm_id in l.
    exact l.
Qed.

Lemma logical_SN_wk
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C1 C2 : con B}
      (w : wk C1 C2)
  : @logical_SN_sub _ _ ar _ _ (wkToSub w).
Proof.
  intros A v.
  rewrite <- wkVar_is_subVar.
  apply neutral_is_logical_SN.
  constructor.
Qed.

Lemma idSub_is_logical_SN_sub
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
  : logical_SN_sub (idSub C ar).
Proof.
  rewrite <- wkToSub_id.
  apply logical_SN_wk.
Qed.

(** Now we can conclude SN of the STLC *)
Lemma all_is_logical_SN
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C : con B}
      {A : ty B}
      (t : tm ar C A)
  : logical_SN t.
Proof.
  pose (fundamental_thm_relations (idSub C ar) t) as l.
  rewrite subTm_id in l.
  apply l.
  apply idSub_is_logical_SN_sub.
Qed.

(** ** The STLC is SN *)
Theorem BetaRed_SN
        {B : Type}
        {F : Type}
        (ar : F -> ty B)
        (C : con B)
        (A : ty B)
  : Wf (fun (t1 t2 : tm ar C A) => betaRed t1 t2).
Proof.
  intro t.
  apply logical_SN_to_SN.
  apply all_is_logical_SN.
Qed.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.finite Require Import monad monad_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Coq.omega.Omega Coq.Program.Wf.
Local Open Scope nat_scope.

Definition compare (x y: nat) := (* cost (compare_nat x y (x < y) (y < x) (x == y)) := *)
  (1, ltngtP x y).

Record splitting (A: Type) := mkSplit { lower : seq A; middle: seq A; upper : seq A}.
Arguments mkSplit {_}.
Arguments lower {_}.
Arguments middle {_}.
Arguments upper {_}.

Definition splitting_eq_bool {A: eqType} (a b : splitting A) : bool :=
  (lower a == lower b) && (middle a == middle b) && (upper a == upper b).
Lemma eq_spl {A: eqType} : Equality.axiom (@splitting_eq_bool A).
Proof.
move=> [l1 m1 u1] [l2 m2 u2].
apply: (iffP idP); rewrite /splitting_eq_bool //=.
- move /andP => [Hand ?].
  move /andP in Hand. destruct Hand as (?&?).
  f_equal; apply /eqP; done.
- inversion 1; subst.
  apply /andP; split; auto.
  apply /andP; split; auto.
Qed.

Canonical splitting_eqMixin A := EqMixin (@eq_spl A).
Canonical splitting_eqType A := Eval hnf in EqType (splitting _) (splitting_eqMixin A).

Fixpoint partition (n: nat) (l: list nat) : cost (splitting nat) :=
  match l with
    | [::] => mret {| lower := [::]; middle := [::]; upper := [::]|}
    | m :: l =>
      spl ← partition n l;
      let '(ll, leq, lu) := (lower spl, middle spl, upper spl) in
      (cmp ← compare m n;
      match cmp with
        | CompareNatLt _ => mret (mkSplit (m :: ll) leq lu)
        | CompareNatEq _ => mret (mkSplit ll (m :: leq) lu)
        | CompareNatGt _ => mret (mkSplit ll leq (m :: lu))
      end)
  end.

Lemma partition_perm_eq l:
  ∀ n, perm_eq (lower (partition n l).2 ++ middle (partition n l).2 ++ upper (partition n l).2) l.
Proof.
  induction l => n; first by (rewrite //=).
  rewrite //=. case (ltngtP a n) => Hcmp //=.
  - by rewrite perm_cons.
  - eapply (perm_trans).
    { erewrite perm_cat2l. rewrite perm_catC cat_cons. erewrite perm_cons. done. }
    rewrite -cat_cons perm_catCA cat_cons perm_cons.
    rewrite -perm_catCA.
    eapply (perm_trans); last apply (IHl n).
    rewrite perm_cat2l perm_catC //.
  - rewrite -cat_cons perm_catCA // cat_cons perm_cons.
    rewrite perm_catCA //.
Qed.

Lemma partition_middle_size l:
  ∀ n, n \in l → 0 < size (middle (partition n l).2).
Proof.
  induction l => //= n Hin.
  intros. case (ltngtP a n) => //=; intros Hcmp; apply IHl;
  move: Hin; rewrite in_cons; move /orP => [HeqP|] //; exfalso;
  move /eqP in HeqP; subst; rewrite ltnn in Hcmp; done.
Qed.

Definition partition' (n: nat) (l: list nat) :
  cost { x : splitting nat | perm_eq (lower x ++ middle x ++ upper x) l &&
                             ((n \in l) ==> (0 < size (middle x)))}.
Proof.
  refine (fst (partition n l), exist _ (snd (partition n l)) _).
  apply /andP; split.
  - apply partition_perm_eq.
  - apply /implyP/partition_middle_size.
Defined.

Lemma partition_cost l: ∀ n, (partition n l).1 = (size l).
Proof.
  induction l as [| a l'] => //= n.
  rewrite /cost_bind//=. case (ltngtP a n) => //=; rewrite IHl';
  destruct (partition n l') as [? [? ? ?]] => //= ?; ring.
Qed.

Require Import Reals Fourier FunctionalExtensionality.
Local Open Scope R_scope.

Program Definition unif n : ldist_cost { x : nat | (leq x n) } :=
  mklDist [ seq (1/(INR (n.+1)), (O, exist _ (nat_of_ord i) _)) | i <- enum 'I_(n.+1) ] _ _.
Next Obligation. rewrite -ltnS. done. Qed.
Next Obligation.
  apply /allP => r.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  rewrite //=. induction (iota 1 n) => //=.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR. omega.
  - rewrite in_cons. move /orP => [Heq|Hin]; eauto.
    move /eqP in Heq. rewrite Heq.
    destruct (Rle_dec 0 (1 / _)) as [|Hn]; [ by auto | exfalso; apply Hn].
    left. apply Rdiv_lt_0_compat; first fourier.
    destruct n; first by fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); intros; first by fourier.
    apply lt_INR; omega.
Qed.
Next Obligation.
  rewrite -map_comp //= (@eq_map _ _ _ (λ x, 1 / INR (S n))); last by done.
  rewrite (nat_of_ord_map_iota (S n) (λ x, 1 / INR (S n))).
  cut (∀ o k, \big[Rplus/0]_(a<-[seq (1 / INR n.+1) | i <- iota k o]) a
            = INR (o) / INR (n.+1)).
  {
    intros Hcut. specialize (Hcut (n.+1) O). rewrite //= in Hcut.
    rewrite Hcut. apply /eqP => //=. field.
    apply Rgt_not_eq.
    destruct n; first fourier.
    replace 0 with (INR O) by auto.
    cut (INR 0 < INR (S n)); first by intros; fourier.
    apply lt_INR; omega.
  }
  induction o => k.
  - rewrite big_nil. replace (INR 0) with 0 by auto. rewrite /Rdiv Rmult_0_l //.
  - rewrite big_cons. rewrite (S_INR o).
    rewrite Rdiv_plus_distr IHo. ring.
Qed.

Program Definition draw_pivot (a : nat) (l: list nat) : ldist_cost { x : nat | x \in (a :: l) } :=
  idx ← unif (size l);
  mret (exist _ (nth O (a :: l) (sval idx)) _).
Next Obligation. rewrite mem_nth //. Qed.

Definition qs : list nat → ldist_cost (list nat).
  refine(Fix (measure_wf lt_wf size) (fun _ => ldist_cost (list nat))
  (fun l qs =>
  match l as l' return (l = l' → ldist_cost (list nat)) with
    | [::] => λ eq, mret ([::])
    | [::a] => λ eq, mret ([::a])
    | (a :: b :: l') => λ eq,
      p ← draw_pivot a (b :: l');
      spl ← dist_ret _ (partition' (sval p) l);
      lls ← qs (lower (sval spl)) _;
      lus ← qs (upper (sval spl)) _;
      mret (lls ++ (middle (sval spl)) ++ lus)
  end (Init.Logic.eq_refl))); rewrite /MR; auto.
  - abstract (destruct spl as (spl&pf) => //=; move /andP in pf;
    destruct pf as (pf1&pf2); move /implyP in pf2;
    rewrite -(perm_size pf1) //= ?size_cat -?plusE;
    assert (0 < size (middle spl))%coq_nat by
    ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=); omega).
  - abstract (destruct spl as (spl&pf) => //=; move /andP in pf;
    destruct pf as (pf1&pf2); move /implyP in pf2;
    rewrite -(perm_size pf1) //= ?size_cat -?plusE;
    assert (0 < size (middle spl))%coq_nat by
    ( apply /ltP; apply pf2 => //=; destruct p; eauto; subst; rewrite //=); omega).
Defined.

Lemma easy_fix_eq:
  ∀ (A : Type) (R : A → A → Prop) (Rwf : well_founded R) (P : A → Type)
    (F : ∀ x : A, (∀ y : A, R y x → P y) → P x),
    ∀ x : A, Fix Rwf P F x = F x (λ (y : A) (_ : R y x), Fix Rwf P F y).
Proof.
  intros. apply Init.Wf.Fix_eq.
  intros. assert (f = g) as ->; last done.
  apply functional_extensionality_dep => ?.
  apply functional_extensionality_dep => ?. done.
Qed.

Lemma qs_unfold_aux l:
  qs l =
  match l as l' return (l = l' → ldist_cost (list nat)) with
    | [::] => λ eq, mret ([::])
    | [:: a] => λ eq, mret ([:: a])
    | (a :: b :: l') => λ eq,
      p ← draw_pivot a (b :: l');
      spl ← dist_ret _ (partition' (sval p) l);
      lls ← qs (lower (sval spl));
      lus ← qs (upper (sval spl));
      mret (lls ++ (middle (sval spl)) ++ lus)
  end (Init.Logic.eq_refl).
Proof. rewrite /qs easy_fix_eq; done. Qed.

Lemma qs_unfold l:
  qs l =
  (match l as l
  with
    | [::] => mret ([::])
    | [::a] => mret ([::a])
    | (a :: l) =>
      p ← draw_pivot a l;
      spl ← dist_ret _ (partition' (sval p) (a :: l));
      lls ← qs (lower (sval spl));
      lus ← qs (upper (sval spl));
      mret (lls ++ (middle (sval spl)) ++ lus)
  end).
Proof.
  rewrite qs_unfold_aux. destruct l => //. destruct l => //.
Qed.


From pv Require Export library.

(* 1.2 Syntax *)

Inductive term :=
  | Const : nat -> term
  | true : term
  | false : term
  | Fun : string -> type -> term -> term
  | unit : term
  | Var : string -> term
  | Plus : term -> term -> term
  | If : term -> term -> term -> term
  | App : term -> term -> term
  | RNil : term
  | RCons : string -> term -> term -> term
  | Sel : term -> string -> term
with type :=
  | TBool : type
  | TNat : type
  | TFun : type -> type -> type
  | TUnit : type
  | TRNil : type
  | TRCons : string -> type -> type -> type.
  (*
  | TTop : type
  | TBot : type.
  *)

Inductive val : term -> Prop :=
  | VConst n : val (Const n)
  | Vtrue : val true
  | Vfalse : val false
  | VFun x T M : val (Fun x T M)
  | Vunit : val unit
  | VRNil : val RNil
  | VRCons l v1 vr:
    val v1 ->
    val vr ->
    val (RCons l v1 vr).

Inductive rec_term : term -> Prop :=
  | RMNil :
    rec_term RNil
  | RMCons l M MR :
    rec_term (RCons l M MR).

Inductive rec_type : type -> Prop :=
  | RTNil :
    rec_type TRNil
  | RTCons l T TR :
    rec_type (TRCons l T TR).

Inductive wf_type : type -> Prop :=
  | wfTBool : wf_type TBool
  | wfTNat : wf_type TNat
  | wfTFun T1 T2 :
    wf_type T1 ->
    wf_type T2 ->
    wf_type (TFun T1 T2)
  | wfTUnit : wf_type TUnit
  | wfTRNil : wf_type TRNil
  | wfTRCons l T TR :
    wf_type T ->
    wf_type TR ->
    rec_type TR ->
    wf_type (TRCons l T TR).

Fixpoint rec_term_lookup (l : string) (MR : term) : option term :=
  match MR with
  | RCons l' M MR' => if String.eq_dec l l' then Some M else rec_term_lookup l MR'
  | _ => None
  end.

Fixpoint rec_type_lookup (l : string) (TR : type) : option type :=
  match TR with
  | TRCons l' T TR' => if String.eq_dec l l' then Some T else rec_type_lookup l TR'
  | _ => None
  end.

Fixpoint subst (x : string) (N : term) (M : term) : term :=
  match M with
  | Var y => if String.eq_dec x y then N else M
  | Plus M1 M2 => Plus (subst x N M1) (subst x N M2)
  | If M1 M2 M3 => If (subst x N M1) (subst x N M2) (subst x N M3)
  | Fun y T M' => if String.eq_dec x y then M else Fun y T (subst x N M')
  | App M1 M2 => App (subst x N M1) (subst x N M2)
  | RCons l M' MR => RCons l (subst x N M') (subst x N MR)
  | Sel M' l => Sel (subst x N M') l
  | _ => M
  end.

(* 1.3 Operational Semantics *)

Inductive step : term -> term -> Prop :=
  | Sum n1 n2 n :
    n1 + n2 = n ->
    step (Plus (Const n1) (Const n2)) (Const n)
  | Sum_left M N M' :
    step M M' ->
    step (Plus M N) (Plus M' N)
  | Sum_right M v M' :
    val v ->
    step M M' ->
    step (Plus v M) (Plus v M')
  | If_true M N :
    step (If true M N) M
  | If_false M N :
    step (If false M N) N
  | If_step M1 M1' M2 M3 :
    step M1 M1' -> step (If M1 M2 M3) (If M1' M2 M3)
  | Beta x T M v :
    val v ->
    step (App (Fun x T M) v) (subst x v M)
  | App1 M N M' :
    step M M' ->
    step (App M N) (App M' N)
  | App2 v M M' :
    val v ->
    step M M' ->
    step (App v M) (App v M')
  | Select l vr v :
    val vr ->
    rec_term_lookup l vr = Some v ->
    step (Sel vr l) v
  | Eval_Select M M' l :
    step M M' -> step (Sel M l) (Sel M' l)
  | Eval_Record_Head l M M' MR :
    step M M' ->
    step (RCons l M MR) (RCons l M' MR)
  | Eval_Record_Tail l v MR MR' :
    val v ->
    step MR MR' ->
    step (RCons l v MR) (RCons l v MR').

Inductive steps : term -> term -> Prop :=
  | steps_refl M :
     steps M M
  | steps_step M1 M2 M3 :
     step M1 M2 ->
     steps M2 M3 ->
     steps M1 M3.

(* Subtyping *)

(*
Inductive subtype : type -> type -> Prop :=
  | Reflex T :
      subtype T T
  | Trans S U T :
      subtype S U ->
      subtype U T ->
      subtype S T
  | Sub_Width l T TR :
    wf_type (TRCons l T TR) ->
    subtype (TRCons l T TR) TRNil
  | Sub_Depth l S T SR TR :
    subtype S T ->
    subtype SR TR ->
    rec_type SR ->
    rec_type TR ->
    subtype (TRCons l S SR) (TRCons l T TR)
  | Sub_Perm l1 l2 T1 T2 TR :
    wf_type (TRCons l1 T1 (TRCons l2 T2 TR)) ->
    ~ (l1 = l2) ->
    subtype (TRCons l1 T1 (TRCons l2 T2 TR)) (TRCons l2 T2 (TRCons l1 T1 TR))
  | Arrow S1 S2 T1 T2 :
      subtype T1 S1 ->
      subtype S2 T2 ->
      subtype (TFun S1 S2) (TFun T1 T2).
*)

(* 3 Simple types *)

Inductive typed : stringmap type -> term -> type -> Prop :=
  | T_True Gamma :
    typed Gamma true TBool
  | T_False Gamma :
    typed Gamma false TBool
  | T_Int Gamma n :
    typed Gamma (Const n) TNat
  | T_Fun Gamma x M T1 T2 :
    wf_type T1 ->
    StringMap.lookup Gamma x = None ->
    typed (StringMap.insert x T1 Gamma) M T2 ->
    typed Gamma (Fun x T1 M) (TFun T1 T2)
  | T_Var Gamma x T :
     StringMap.lookup Gamma x = Some T ->
     wf_type T ->
     typed Gamma (Var x) T
  | T_Sum Gamma M N :
     typed Gamma M TNat ->
     typed Gamma N TNat ->
     typed Gamma (Plus M N) TNat
  | T_IfThenElse Gamma M1 M2 M3 T :
     typed Gamma M1 TBool->
     typed Gamma M2 T ->
     typed Gamma M3 T ->
     typed Gamma (If M1 M2 M3) T
  | T_App Gamma M N T1 T2 :
     typed Gamma M (TFun T1 T2) ->
     typed Gamma N T1 ->
     typed Gamma (App M N) T2
  | T_Unit Gamma :
    typed Gamma unit TUnit
  | T_RNil Gamma :
    typed Gamma RNil TRNil
  | T_RCons Gamma l M T MR TR :
    typed Gamma M T ->
    typed Gamma MR TR ->
    rec_term MR ->
    rec_type TR ->
    typed Gamma (RCons l M MR) (TRCons l T TR)
  | T_Select Gamma M l T TR :
    typed Gamma M TR ->
    rec_type_lookup l TR = Some T ->
    typed Gamma (Sel M l) T.
  (*
  | Subsumption Gamma M S T :
    typed Gamma M S ->
    subtype S T ->
    typed Gamma M T.
  *)

Definition well_typed (M : term) : Prop :=
  exists T, exists Gamma, typed Gamma M T.

Definition stuck M :=
  ~(val M) /\ ~(exists M', step M M').

(* Exercises *)

Definition term_1_1 : term :=
  Fun "f" (TFun TBool TBool) (Fun "x" TBool true).

Lemma exercise_1_1 :
  typed StringMap.empty term_1_1 (TFun (TFun TBool TBool) (TFun TBool TBool)).
Proof.
  apply T_Fun.
  - apply wfTFun; apply wfTBool.
  - apply StringMap.lookup_empty.
  - apply T_Fun.
    + apply wfTBool.
    + rewrite StringMap.lookup_insert.
      apply String.eq_dec_neq.
      congruence.
    + apply T_True.
Qed.

Definition term_1_2 : term :=
  Fun "f" (TFun TBool TNat) (Fun "x" TBool (Const 0)).

Lemma exercise_1_2 :
  typed StringMap.empty term_1_2 (TFun (TFun TBool TNat) (TFun TBool TNat)).
Proof.
  apply T_Fun.
  - apply wfTFun.
    + apply wfTBool.
    + apply wfTNat.
  - apply StringMap.lookup_empty.
  - apply T_Fun.
    + apply wfTBool.
    + rewrite StringMap.lookup_insert.
      apply String.eq_dec_neq.
      congruence.
    + apply T_Int.
Qed.

Definition term_2 : term :=
  App (Fun "x" TNat true) false.

Lemma exercise_2 :
  ~ well_typed term_2.
Proof.
  unfold well_typed.
  intros H.
  inv H.
  inv H0.
  inv H.
  inv H3.
  inv H5.
Qed.

Definition term_3 : term :=
  App (App (Var "z") (Var "x")) (Var "y").

Lemma exercise_3 :
  exists Gamma, typed Gamma term_3 TBool.
Proof.
  exists (StringMap.insert "z" (TFun TBool (TFun TBool TBool)) (StringMap.insert "y" TBool (StringMap.singleton "x" TBool))).
  eapply T_App.
  - eapply T_App.
    + apply T_Var.
      * rewrite StringMap.lookup_insert.
        apply String.eq_dec_eq.
      * apply wfTFun.
        -- apply wfTBool.
        -- apply wfTFun.
          ++ apply wfTBool.
          ++ apply wfTBool.
    + apply T_Var.
      * rewrite StringMap.lookup_insert.
        rewrite String.eq_dec_neq; try congruence.
        rewrite StringMap.lookup_insert.
        rewrite String.eq_dec_neq; try congruence.
        rewrite StringMap.lookup_singleton.
        apply String.eq_dec_eq.
      * apply wfTBool.
  - eapply T_Var.
    + rewrite StringMap.lookup_insert.
      rewrite String.eq_dec_neq; try congruence.
      rewrite StringMap.lookup_insert.
      apply String.eq_dec_eq.
    + apply wfTBool.
Qed.

Definition term_4 : term :=
  App (Var "x") (Var "x").

Lemma exercise_4 :
  ~ well_typed term_4.
Proof.
  unfold well_typed.
  intros H.
  inv H.
  destruct H0 as [Gamma H0].
  inv H0.
  inv H3.
  inv H5.
  induction T1; try inv H.
  - apply IHT1_1.
    + rewrite <-H3 in H0.
      apply H0.
    + apply H4.
    + inv H4.
      apply H5.
    + apply H3.
Qed.

Definition term_5 : term :=
  Fun "x" (TFun TBool TNat) (Fun "y" TBool (If (Var "y") (Const 1) (Plus (Var "x") (Var "y")))).

Lemma exercise_5 :
  ~ well_typed term_5.
Proof.
  unfold well_typed.
  intros H.
  inv H.
  inv H0.
  inv H.
  inv H7.
  inv H9.
  inv H11.
  inv H9.
  rewrite StringMap.lookup_insert in H0.
  rewrite String.eq_dec_eq in H0.
  inv H0.
Qed.

Definition term_15_1 T1 T2 :=
  Fun "x" T1 (Fun "y" T2 (If (Var "y") (Var "x") true)).

Lemma exercise_15_1 :
  exists T1, exists T2, well_typed (term_15_1 T1 T2).
Proof.
  eexists.
  eexists.
  eexists.
  exists StringMap.empty.
  apply T_Fun.
  - constructor.
  - apply StringMap.lookup_empty.
  - apply T_Fun.
    + constructor.
    + rewrite StringMap.lookup_insert.
      apply String.eq_dec_neq.
      congruence.
    + apply T_IfThenElse.
      * apply T_Var; constructor.
      * apply T_Var; constructor.
      * apply T_True.
Qed.

Definition term_15_2 :=
  Fun "x" (TFun TNat TBool) (Var "x").

Lemma exercise_15_2 :
  well_typed term_15_2.
Proof.
  eexists.
  exists StringMap.empty.
  apply T_Fun; repeat constructor.
Qed.

(* 3.1 Properties of the type system *)

(* Inversion for Typing *)

(*
Lemma inversion_plus Gamma M N T :
  typed Gamma (Plus M N) T ->
  T = TNat /\ typed Gamma M TNat /\ typed Gamma N TNat.
Proof.
Admitted.

Lemma inversion_if Gamma M1 M2 M3 T :
  typed Gamma (If M1 M2 M3) T ->
  typed Gamma M1 TBool /\ typed Gamma M2 T /\ typed Gamma M3 T.
Proof.
Admitted.

Lemma inversion_fun Gamma x S1 M T :
  typed Gamma (Fun x S1 M) T ->
  exists T1, exists T2, T = (TFun T1 T2) /\ subtype T1 S1 /\ typed (StringMap.insert x S1 Gamma) M T2.
Proof.
Admitted.

Lemma inversion_app Gamma M N T :
  typed Gamma (App M N) T ->
  exists T1, typed Gamma M (TFun T1 T) /\ typed Gamma N T1.
Proof.
Admitted.
*)

(* Canonical forms *)

(*
Lemma canonical_forms_bool Gamma v :
  val v ->
  typed Gamma v TBool ->
  v = true \/ v = false.
Proof.
Admitted.

Lemma canonical_forms_nat Gamma v :
  val v ->
  typed Gamma v TNat ->
  exists n, v = Const n.
Proof.
Admitted.

Lemma canonical_forms_fun Gamma v T1 T2 :
  val v ->
  typed Gamma v (TFun T1 T2) ->
  exists x S1 M, v = Fun x S1 M.
Proof with eauto.
Admitted.
*)

Lemma lookup_field_in_value Gamma vr TR l T :
  val vr ->
  typed Gamma vr TR ->
  rec_type_lookup l TR = Some T ->
  exists v, rec_term_lookup l vr = Some v /\ typed Gamma v T.
Proof.
  intros Hval Htyp Hget.
  induction Htyp; simpl in *; try congruence; try inv Hval.
  destruct (String.eq_dec l l0).
  - injection Hget as Hget. subst.
    exists M.
    split.
    + reflexivity.
    + apply Htyp1.
  - destruct IHHtyp2 as [vi [Hgeti Htypi]].
    + apply H5.
    + apply Hget.
    + exists vi.
      split.
      * apply Hgeti.
      * apply Htypi.
Qed.

Theorem progress M T :
  typed StringMap.empty M T ->
  (val M) \/ (exists M', step M M').
Proof.
  intros.
  remember StringMap.empty as Gamma' eqn:HGamma'.
  induction H; intros.
  - left. constructor.
  - left. constructor.
  - left. constructor.
  - left. constructor.
  - rewrite HGamma' in H.
    rewrite StringMap.lookup_empty in H.
    discriminate.
  - destruct IHtyped1.
    + apply HGamma'.
    + inv H; inv H1.
      destruct IHtyped2.
      * reflexivity.
      * inv H; inv H0.
        right.
        exists (Const (n + n0)).
        eapply Sum.
        reflexivity.
      * right.
        destruct H as [N' H].
        exists (Plus (Const n) N').
        apply Sum_right.
        -- constructor.
        -- apply H.
    + right.
      destruct H1 as [M' H1].
      exists (Plus M' N).
      apply Sum_left.
      apply H1.
  - destruct IHtyped1.
    + apply HGamma'.
    + inv H2;
      inv H.
      * right.
        exists M2.
        apply If_true.
      * right.
        exists M3.
        apply If_false.
    + right.
      destruct H2 as [M1' H2].
      exists (If M1' M2 M3).
      apply If_step.
      apply H2.
  - destruct IHtyped1.
    + apply HGamma'.
    + inv H1;
      inv H.
      destruct IHtyped2.
      * reflexivity.
      * right.
        eexists.
        apply Beta.
        apply H.
      * right.
        destruct H as [N' H].
        eexists.
        apply App2.
        ++ constructor.
        ++ apply H.
    + right.
      destruct H1 as [M' H1].
      exists (App M' N).
      apply App1.
      apply H1.
  - left. constructor.
  - left. constructor.
  - destruct IHtyped1.
    + apply HGamma'.
    + destruct IHtyped2.
      * apply HGamma'.
      * left. constructor.
        -- apply H3.
        -- apply H4.
      * right.
        destruct H4 as [MR' H4].
        eexists.
        apply Eval_Record_Tail.
        -- apply H3.
        -- apply H4.
    + right.
      destruct H3 as [M' H3].
      eexists.
      apply Eval_Record_Head.
      apply H3.
  - right.
    destruct IHtyped.
    + apply HGamma'.
    + inv H1;
      inv H.
      destruct (String.eq_dec l l0).
      * eexists.
        apply Select.
        -- constructor.
          ++ apply H2.
          ++ apply H3.
        -- simpl.
           subst.
           rewrite String.eq_dec_eq.
           reflexivity.
      * destruct (lookup_field_in_value StringMap.empty vr TR0 l T) as [vi [Hlkup _] ].
        -- apply H3.
        -- apply H8.
        -- apply H0.
        -- exists vi.
           apply Select.
           ++ constructor.
              ** apply H2.
              ** apply H3.
           ++ simpl.
              rewrite String.eq_dec_neq.
              ** apply Hlkup.
              ** apply n.
    + destruct H1 as [M' H1].
      exists (Sel M' l).
      apply Eval_Select.
      apply H1.
Qed.

(*
Definition alpha_equivalence x y T M :=
  Fun x T M = Fun y T (subst x (Var y) M).
*)

Lemma weakening Gamma x M S T :
  typed Gamma M T ->
  StringMap.lookup Gamma x = None ->
  typed (StringMap.insert x S Gamma) M T.
Proof.
  intros.
  induction H; intros.
  - apply T_True.
  - apply T_False.
  - apply T_Int.
  - admit.
  - apply T_Var.
    + rewrite StringMap.lookup_insert.
      destruct String.eq_dec.
      * rewrite e in H.
        rewrite H in H0.
        discriminate.
      * apply H.
    + apply H1.
  - apply T_Sum.
    + apply IHtyped1.
      apply H0.
    + apply IHtyped2.
      apply H0.
  - apply T_IfThenElse.
    + apply IHtyped1.
      apply H0.
    + apply IHtyped2.
      apply H0.
    + apply IHtyped3.
    apply H0.
  - eapply T_App.
    + apply IHtyped1.
      apply H0.
    + apply IHtyped2.
      apply H0.
  - apply T_Unit.
  - apply T_RNil.
  - apply T_RCons.
    + apply IHtyped1.
      apply H0.
    + apply IHtyped2.
      apply H0.
    + apply H2.
    + apply H3.
  - eapply T_Select.
    + apply IHtyped.
      apply H0.
    + apply H1.
Admitted.

Lemma substitution Gamma x M N S T :
  typed (StringMap.insert x S Gamma) M T ->
  typed Gamma N S ->
  typed Gamma (subst x N M) T.
Proof.
  intros.
  remember (StringMap.insert x S Gamma) as Gamma' eqn:HGamma'.
  revert H0.
  revert Gamma HGamma'.
  induction H; intros.
  - apply T_True.
  - apply T_False.
  - apply T_Int.
  - rewrite HGamma' in H0.
      rewrite StringMap.lookup_insert in H0.
      simpl.
      destruct (String.eq_dec); subst.
      -- inv H0.
      -- rewrite String.eq_dec_neq.
        ++ apply T_Fun.
          ** apply H.
          ** apply H0.
          ** eapply weakening in H2.
            * apply IHtyped in H2.
            { apply H2. }
              { rewrite StringMap.insert_insert.
              rewrite String.eq_dec_neq.
              { reflexivity. }
              { congruence. }}
            * apply H0.
        ++ congruence.
  - simpl.
    rewrite HGamma' in H.
    rewrite StringMap.lookup_insert in H.
    destruct (String.eq_dec x x0); destruct (String.eq_dec x0 x); try congruence.
    apply T_Var.
    + apply H.
    + apply H0.
  - simpl.
    apply IHtyped1 in HGamma' as H2.
    + apply IHtyped2 in HGamma' as H3.
      * apply T_Sum.
        -- apply H2.
        -- apply H3.
      * apply H1.
    + apply H1.
  - simpl.
    apply IHtyped1 in HGamma' as H3;
    apply IHtyped2 in HGamma' as H4;
    apply IHtyped3 in HGamma' as H5;
    try apply H2.
    apply T_IfThenElse.
    + apply H3.
    + apply H4.
    + apply H5.
  - simpl.
    apply IHtyped1 in HGamma' as H3;
    apply IHtyped2 in HGamma' as H4;
    try apply H1.
    eapply T_App.
    + apply H3.
    + apply H4.
  - apply T_Unit.
  - apply T_RNil.
  - simpl.
    apply T_RCons.
    + apply IHtyped1.
      * apply HGamma'.
      * apply H3.
    + apply IHtyped2.
      * apply HGamma'.
      * apply H3.
    + inv H1; constructor.
    + inv H2; constructor.
  - simpl.
    eapply T_Select.
    + apply IHtyped.
      * apply HGamma'.
      * apply H1.
    + apply H0.
Qed.

Lemma step_preserves_record_term TR TR' :
  rec_term TR ->
  step TR TR' ->
  rec_term TR'.
Proof.
  intros Hrt Hstp.
  inv Hrt.
  - inv Hstp.
  - inv Hstp.
    + constructor.
    + constructor.
Qed.

Theorem type_preservation Gamma M M' T :
  typed Gamma M T ->
  step M M' ->
  typed Gamma M' T.
Proof.
  intros.
  revert H.
  revert T.
  induction H0; intros.
  - inv H.
    inv H0.
    apply T_Int.
  - inv H.
    apply IHstep in H4.
    apply T_Sum.
    + apply H4.
    + apply H6.
  - inv H1.
    apply IHstep in H7.
    apply T_Sum.
    + apply H5.
    + apply H7.
  - inv H.
    apply H6.
  - inv H.
    apply H7.
  - inv H.
    apply IHstep in H5.
    apply T_IfThenElse.
    + apply H5.
    + apply H7.
    + apply H8.
  - inv H0.
    inv H4.
    eapply substitution.
    + apply H10.
    + apply H6.
  - inv H.
    apply IHstep in H4.
    eapply T_App.
    + apply H4.
    + apply H6.
  - inv H1.
    apply IHstep in H7.
    eapply T_App.
    + apply H5.
    + apply H7.
  - inv H1.
    destruct (lookup_field_in_value Gamma vr TR l T) as [vi [Hget Htyp] ].
    + apply H.
    + apply H5.
    + apply H7.
    + rewrite H0 in Hget. injection Hget as Hget. subst.
      apply Htyp.
  - inv H.
    apply IHstep in H4.
    eapply T_Select.
    + apply H4.
    + apply H6.
  - inv H.
    apply IHstep in H4.
    apply T_RCons.
    + apply H4.
    + apply H6.
    + apply H8.
    + apply H9.
  - inv H1.
    apply IHstep in H7.
    apply T_RCons.
    + apply H5.
    + apply H7.
    + eapply step_preserves_record_term.
      * apply H9.
      * apply H0.
    + apply H10.
Qed.

Corollary extended_type_preservation M M' T :
  typed StringMap.empty M T ->
  steps M M' ->
  typed StringMap.empty M' T.
Proof.
  intros.
  induction H0.
  - apply H.
  - apply IHsteps.
    eapply type_preservation.
    + apply H.
    + apply H0.
Qed.

Theorem safety M M' T :
  typed StringMap.empty M T ->
  steps M M' ->
  ~(stuck M').
Proof.
  intros H H1 H2.
  destruct H2.
  apply (extended_type_preservation M M' T) in H.
  - apply progress in H.
    destruct H; tauto.
  - apply H1.
Qed.