From RelationAlgebra Require Import lattice boolean.
From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun.
From mathcomp Require Import eqtype choice order seq tuple path div.
From mathcomp Require Import fintype finfun fingraph finmap.
From eventstruct Require Import utils seq.

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

Import Order.Theory.

Local Open Scope fset_scope.
Local Open Scope order_scope.

(******************************************************************************)
(* Auxiliary definitions and lemmas about partial orders.                     *)
(*                                                                            *)
(******************************************************************************)

Section POrderUtils.
Context {disp : unit} {T : porderType disp}.
Implicit Types (x y z : T).

Lemma le_ge_incomp x y :
  [|| (x <= y), (x >= y) | (x >< y)].
Proof.
  case: (x <= y)/idP=> //=.
  case: (y <= x)/idP=> //=.
  rewrite !negb_or=> /negP ? /negP ?; exact/andP.
Qed.

Lemma le_gt_incomp x y :
  [|| (x <= y), (x > y) | (x >< y)].
Proof.
  move: (le_ge_incomp x y)=> /or3P[->||->] //.
  rewrite le_eqVlt=> /orP[/eqP->|->] //.
  by rewrite le_refl.
Qed.

End POrderUtils.

Section Closure.
Context {disp : unit} {T : porderType disp}.
Implicit Types (x y z : T) (X : pred T).

Definition dw_closed (X : pred T) : Prop :=
  (* ca · [X] \<= [X] · ca; *)
  forall x y, x <= y -> X y -> X x.

Lemma eq_dw_closed X Y :
  X =1 Y -> dw_closed X <-> dw_closed Y.
Proof. move=> e; split=> dw ??; [rewrite -?e | rewrite ?e]; exact/dw. Qed.

End Closure.

Section POrderMorph.
Context {dispT : unit} {dispU : unit}.
Context {T : porderType dispT} {U : porderType dispU}.
Implicit Types (f : T -> U).
Implicit Types (x y z : T).

(* Definition monotone     f := { homo f : x y / x <= y}. *)
(* Definition antimonotone f := {ahomo f : x y / x <= y}. *)
(* Definition reflecting   f := { mono f : x y / x <= y}. *)

Lemma le_homo_lt_img f x y :
  {homo f : x y / x <= y} -> (f x < f y) -> (x < y) || (x >< y).
Proof.
  case lt_xy: (x < y)=> //= fmon lt_fxy.
  apply/negP=> /orP [].
  - rewrite le_eqVlt lt_xy orbF.
    by move: lt_fxy=> /[swap] /eqP<-; rewrite ltxx.
  move=> /fmon le_fyx.
  move: (lt_le_asym (f x) (f y)).
  by move=> /andP; apply; split=> //.
Qed.

Lemma lt_homo_le_img f x y :
  {homo f : x y / x < y} -> (f x <= f y) -> (x <= y) || (x >< y).
Proof.
  move=> fmon le_fxy.
  move: (le_gt_incomp x y)=> /or3P[-> | | ->] //.
  move=> /fmon lt_fyx; exfalso.
  move: (lt_le_asym (f y) (f x)).
  by move=> /andP; apply; split=> //.
Qed.

Lemma le_homo_mono f : {homo f : x y / x <= y} -> {ahomo f : x y / x <= y} ->
  {mono f : x y / x <= y}.
Proof.
  move=> fmon frefl x y.
  apply/idP/idP; [exact/frefl | exact/fmon].
Qed.

Lemma cancel_le_ahomo_homo f g : cancel g f ->
  {ahomo f : x y / x <= y} -> {homo g : x y / x <= y}.
Proof. by move=> K fmon x y le_xy; apply/fmon; rewrite !K. Qed.

Lemma le_mono_incomp f :
  {mono f : x y / x <= y} -> { mono f : x y / x >< y }.
Proof.
  move=> femb x y; apply: negbLR.
  by rewrite !negbK /Order.comparable !femb.
Qed.

Lemma le_homo_bij_total f : bijective f -> {homo f : x y / x <= y} ->
  total (<=%O : rel T) -> total (<=%O : rel U).
Proof.
  case=> g Kf Kg fmon tot x y.
  by move: (tot (g x) (g y))=> /orP[] /fmon; rewrite !Kg=> ->.
Qed.

(* TODO: equivalent to mathcomp.ssreflect.order.le_mono *)
Lemma lt_homo_total_mono f : {homo f : x y / x < y} -> total (<=%O : rel T) ->
  { mono f : e1 e2 / e1 <= e2 }.
Proof.
  move=> fmon tot x y.
  apply/idP/idP; last exact/ltW_homo.
  move=> /(lt_homo_le_img fmon)=> /orP[] //.
  by rewrite /Order.comparable; move: (tot x y) ->.
Qed.

Lemma dw_closed_preim f P :
  {homo f : x y / x <= y} -> dw_closed P -> dw_closed (preim f P).
Proof. move=> fmon dw_clos=> x y /fmon; exact/dw_clos. Qed.

End POrderMorph.

Section FinPOrderMorph.
Context {dispT : unit} {dispU : unit}.
Context {T : finPOrderType dispT} {U : finPOrderType dispU}.
Implicit Types (f : T -> U) (g : U -> T).
Implicit Types (x y z : T).

Lemma inj_le_homo_mono f g : injective f -> injective g ->
  {homo f : x y / x <= y} -> {homo g : x y / x <= y} -> {mono f : x y / x <= y}.
Proof.
  move=> finj ginj fmon gmon.
  move=> e1 e2; apply/idP/idP; last exact/fmon.
  pose h := g \o f.
  have hmon: {homo h : x y / x <= y}.
  - by move=> ?? /fmon /gmon.
  have : injective h by exact/inj_comp.
  move=> /cycle_orbit cyc.
  pose o1 := order h e1.
  pose o2 := order h e2.
  pose o  := lcmn o1 o2.
  have {2}<-: iter ((o %/ o1) * o1) h e1 = e1.
  - rewrite iter_mul_eq /o1 //.
    apply/(iter_order_cycle (cyc e1)); exact/in_orbit.
  have {2}<-: iter ((o %/ o2) * o2) h e2 = e2.
  - rewrite iter_mul_eq /o2 //.
    apply/(iter_order_cycle (cyc e2)); exact/in_orbit.
  rewrite !divnK; last first.
  - exact/dvdn_lcml.
  - exact/dvdn_lcmr.
  have: o = lcmn o1 o2 by done.
  case o=> [|{}o]; last first.
  - rewrite !iterSr=> ??; apply/homo_iter=> //; exact/gmon.
  move=> /esym /eqP.
  rewrite eqn0Ngt lcmn_gt0 negb_and ?/o1 ?/o2.
  move: (order_gt0 h e1) (order_gt0 h e2).
  by move=> ++ /orP[/negP|/negP].
Qed.

End FinPOrderMorph.

Module Export MaxSup.
Section Def.
Context {disp : unit} {T : porderType disp}.
Implicit Types (s : seq T) (x : T).

(* TODO: generalize to arbitary pred? *)
Definition is_sup s x :=
  (x \in s) && all (fun y => y <= x) s.

(* TODO: generalize to arbitary pred? *)
Definition is_max s x :=
  (x \in s) && all (fun y => ~~ (x < y)) s.

Definition max_seq x s :=
  foldr Order.max x s.

End Def.

Section Theory.
Context {disp : unit} {T : orderType disp}.
Implicit Types (s : seq T) (x : T).

Lemma is_supP s x :
  reflect (x \in s /\ {in s, forall y, y <= x}) (is_sup s x).
Proof. exact/(andPP idP allP). Qed.

Lemma is_maxP s x :
  reflect (x \in s /\ {in s, forall y, ~~ (x < y)}) (is_max s x).
Proof. exact/(andPP idP allP). Qed.

Lemma is_sup_in s x :
  is_sup s x -> x \in s.
Proof. by move=> /is_supP[]. Qed.

Lemma is_sup_uniq X x y :
  is_sup X x -> is_sup X y -> x = y.
Proof.
  case/is_supP=> i l.
  case/is_supP=> /l /[swap]/(_ _ i) lxy *.
  by apply/le_anti; rewrite lxy.
Qed.

Lemma is_sup0 x :
  ~~ is_sup [::] x.
Proof. done. Qed.

Lemma is_sup_eq s1 s2 :
  s1 =i s2 -> is_sup s1 =1 is_sup s2.
Proof. by move=> e x; rewrite /is_sup e (eq_all_r e). Qed.

Lemma is_sup1 x y :
  (is_sup [:: x] y) = (x == y).
Proof.
  rewrite /is_sup inE /= andbT andb_idr eq_sym //.
  by move=> /eqP->; rewrite lexx.
Qed.

Lemma max_seq_in d s :
  max_seq d s \in d :: s.
Proof.
  elim: s=> [|x s] //=; rewrite !inE //.
  by case: leP; rewrite ?eqxx //= => + /orP[|] ->.
Qed.

Lemma max_seq_dflt_le d s :
  d <= max_seq d s.
Proof.
  elim s=> //= x {}s IH.
  apply/(le_trans IH).
  by rewrite le_maxr lexx.
Qed.

Lemma max_seq_in_le d s x :
  x \in s -> x <= max_seq d s.
Proof.
  elim s=> //= y {}s IH.
  rewrite inE le_maxr=> /orP[/eqP->|/IH->] //=.
  by rewrite lexx.
Qed.

Lemma max_seq_all d s x :
  d <= x -> all (<=%O^~ x) s = (max_seq d s <= x).
Proof.
  move=> led; apply/idP/idP.
  - move: (max_seq_in d s); rewrite inE=> /orP[/eqP->|] //.
    by move=> /[swap] /allP; apply.
  elim s=> //= y {}s IH.
  by rewrite le_maxl=> /andP[->] /IH ->.
Qed.

Lemma max_seq_all_dflt d s :
  all (<=%O^~ d) s = (max_seq d s == d).
Proof.
  rewrite (@max_seq_all d) le_eqVlt orb_idr //.
  move=> /ltW ?; apply/eqP/le_anti/andP; split=> //.
  exact/max_seq_dflt_le.
Qed.

Lemma is_sup_max_seqE d s x :
  is_sup s x -> max_seq d s = Order.max d x.
Proof.
  move=> /is_supP[xin lex].
  apply/le_anti/andP; split; case: (leP d)=> // xd; last 2 first.
  - exact/max_seq_in_le.
  - exact/max_seq_dflt_le.
  - rewrite -max_seq_all //; exact/allP.
  rewrite le_eqVlt -max_seq_all_dflt.
  apply/orP; left; apply/allP=> y /lex.
  move=> /le_trans; apply; exact/ltW.
Qed.

Lemma is_sup_le_max_seqE d s x :
  d <= x -> is_sup s x -> max_seq d s = x.
Proof. move=> dx supx; rewrite -(max_r dx); exact/is_sup_max_seqE. Qed.

Lemma max_seq_sup d s x :
  max_seq d s \in s -> is_sup s (max_seq d s).
Proof. move=> max_in; apply/is_supP; split=> //; exact/max_seq_in_le. Qed.

Lemma is_supE d s x :
  d <= x -> (is_sup s x) = (x \in s) && (max_seq d s == x).
Proof.
  move=> dx; apply/idP/idP; last first.
  - move=> /andP[] /[swap] /eqP<-; exact/max_seq_sup.
  move=> /[dup] /is_sup_in -> /(is_sup_max_seqE d) -> /=.
  by rewrite max_r.
Qed.

Section WithBottom.
Context {d : T}.
Hypothesis (dbot : forall x, d <= x).

Lemma max_seq_inNnil s :
  s != [::] -> max_seq d s \in s.
Proof.
  elim: s=> // x s IH /= _.
  case: (s == [::])/eqP=> [->|/eqP nl] /=.
  - rewrite max_l ?inE //.
  by case: leP; rewrite ?inE ?eqxx ?IH.
Qed.

Lemma max_set_eq s1 s2 :
  s1 =i s2 -> max_seq d s1 = max_seq d s2.
Proof.
  move=> eqm; case: (s1 == [::])/idP.
  - move=> /[dup] + /eqP ->.
    by rewrite (eq_mem0 eqm)=> /eqP->.
  move=> /negP; rewrite (eq_mem0 eqm)=> neq.
  apply/is_sup_le_max_seqE=> //.
  apply/is_supP; split.
  - by rewrite eqm; apply/max_seq_inNnil.
  by move=> x; rewrite eqm=> /max_seq_in_le.
Qed.

Lemma is_sup_NnilE s x :
  s != [::] -> is_sup s x = (max_seq d s == x).
Proof.
  rewrite (@is_supE d) // => neq.
  apply/idP/idP=> [/andP[? ->]|/eqP<-] //.
  rewrite eqxx andbT; exact/max_seq_inNnil.
Qed.

End WithBottom.

Section Monotone.
Variables (f : T -> T) (s : seq T) (x : T).

Hypothesis (finj : injective f).
Hypothesis (fmon : {mono f : x y / x <= y}).

Lemma is_sup_mon :
  is_sup [seq f y | y <- s] (f x) = is_sup s x.
Proof.
  rewrite /is_sup mem_map // all_map.
  apply/andb_id2l=> _; apply/eq_all.
  move=> y /=; exact/fmon.
Qed.

End Monotone.
End Theory.

End MaxSup.

Section DwSurjective.
Context {dispT : unit} {T : porderType dispT}.
Context {dispU : unit} {U : porderType dispU}.
Implicit Types (f : T -> U) (P : pred T) (Q : pred U).
Implicit Types (x y z : T).

(* TODO: consult literature to find relevant theory *)
Definition dw_surjective f :=
  forall x, {in (<= f x), surjective f}.

Definition dw_surjective_le f :=
  forall x, {in (<= f x), surjective [rst f | (<= x) : pred T] }.

Lemma eq_dw_surj f :
  dw_surjective f -> forall g, f =1 g -> dw_surjective g.
Proof. by move=> fdw g eqf x y; rewrite -?eqf=> /fdw [z] <-; exists z. Qed.

Lemma surj_dw_surj f :
  surjective f -> dw_surjective f.
Proof. by move=> fsurj x y _; move: (fsurj y)=> [z] <-; exists z. Qed.

Lemma eq_dw_surj_le f :
  dw_surjective_le f -> forall g, f =1 g -> dw_surjective_le g.
Proof.
  move=> fdw g eqf x y; rewrite -?eqf=> /fdw [z] <-; exists z.
  by rewrite /rst /= eqf.
Qed.

Lemma dw_surj_leW f :
  dw_surjective_le f -> dw_surjective f.
Proof. by move=> dwf x y /dwf[z] <-; rewrite /rst /=; exists (val z). Qed.

Lemma ahomo_dw_surj_le f :
  {ahomo f : x y / x <= y} -> dw_surjective f -> dw_surjective_le f.
Proof.
  move=> lef dwf x y /=.
  rewrite inE=> /[dup] /dwf[z] <-.
  by move=> /lef lez; exists (Sub z lez).
Qed.

Lemma dw_surj_le_in_ahomo_in f P : dw_surjective_le f -> dw_closed P ->
  {in P &, injective f} -> {in P &, {ahomo f : x y / x <= y}}.
Proof.
  move=> dwf dwX injf x y xin yin.
  move=> /dwf[[z]] /= zin.
  rewrite /rst /= => /injf <- //.
  by apply/dwX/yin.
Qed.

Lemma dw_surj_le_inj_ahomo f :
  dw_surjective_le f -> injective f -> {ahomo f : x y / x <= y}.
Proof.
  move=> dwf injf x y.
  apply/(@dw_surj_le_in_ahomo_in f predT)=> //.
  move=>> ??; exact/injf.
Qed.

Lemma dw_surj_le_closed f (X : pred T) (Y : pred U) :
  dw_surjective_le f -> {in Y, surjective f} -> (preim f Y) =1 X ->
    dw_closed X -> dw_closed Y.
Proof.
  move=> fdw fsurj fpreim dwX x y.
  move=> /[swap] /[dup] /fsurj [y'] <-.
  move=> /[swap] /fdw=> [[]] [x'] /= + <-.
  rewrite /rst /= => /dwX.
  by rewrite -fpreim -fpreim.
Qed.

End DwSurjective.

Module DwFinPOrder.

Module Export DwFinPOrder.
Section ClassDef.

Record mixin_of (T0 : Type)
                (b : Order.POrder.class_of T0)
                (* TODO: parametrize by disp? *)
                (T := Order.POrder.Pack tt b) := Mixin {
  pideal : T -> {fset T};
  _ : forall x y : T, x \in (pideal y) = (x <= y);
}.

Set Primitive Projections.
Record class_of (T : Type) := Class {
  base  : Order.POrder.class_of T;
  mixin : mixin_of base;
}.
Unset Primitive Projections.

Local Coercion base : class_of >-> Order.POrder.class_of.

Structure type := Pack { sort; _ : class_of sort }.

Local Coercion sort : type >-> Sortclass.

Variables (T : Type) (cT : type).

Definition class := let: Pack _ c as cT' := cT return class_of (sort cT') in c.
Definition clone c of phant_id class c := @Pack T c.

Definition pack :=
  fun bT b & phant_id (@Order.POrder.class tt bT) b =>
  fun m => Pack (@Class T b m).

Definition eqType := @Equality.Pack cT class.
Definition choiceType := @Choice.Pack cT class.
Definition porderType := @Order.POrder.Pack tt cT class.
End ClassDef.
End DwFinPOrder.

Module Export Exports.
Coercion base : class_of >-> Order.POrder.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Coercion eqType : type >-> Equality.type.
Coercion choiceType : type >-> Choice.type.
Coercion porderType : type >-> Order.POrder.type.
Notation dwFinPOrderType := type.
Canonical eqType.
Canonical choiceType.
Canonical porderType.
Notation DwFinPOrderType T m := (@pack T _ _ id m).
End Exports.

Module Export Def.
Section Def.
Context {T : dwFinPOrderType}.
Implicit Types (x : T) (X : {fset T}).

Definition pideal : T -> {fset T} :=
  DwFinPOrder.pideal (DwFinPOrder.class T).

Definition fin_ideal X : {fset T} :=
  \bigcup_(x <- X) (pideal x).

Definition up_clos : pred T -> pred T :=
  fun P x => [exists y : pideal x, P (val y)].

Definition dw_closedb X :=
  [forall x : fin_ideal X, val x \in X].

End Def.

Section Homo.
Context {T : dwFinPOrderType} {U : dwFinPOrderType}.
Implicit Types (f : T -> U).

Definition homo_pideal f :=
 forall x, pideal (f x) `<=` f @` (pideal x).

End Homo.
End Def.

Module Export Syntax.
Notation "{ 'homo' 'pideal' f }" := (homo_pideal f)
  (at level 0, f at level 99, format "{ 'homo'  'pideal'  f }") : order_scope.
End Syntax.

Module Export Theory.
Section Theory.
Context {T : dwFinPOrderType}.
Implicit Types (x y : T) (X : {fset T}).
Implicit Types (P Q : pred T).

Lemma pidealE x y :
  x \in (pideal y) = (x <= y).
Proof. by move: x y; case: T=> [? [? []]]. Qed.

(* TODO: rename? *)
Lemma pidealx x :
  x \in pideal x.
Proof. by rewrite pidealE. Qed.

Lemma fin_idealP X x :
  reflect (exists2 y, y \in X & x <= y) (x \in fin_ideal X).
Proof.
  apply/equivP; first exact/bigfcupP.
  by apply/exists2_equiv=> y; rewrite ?andbT ?pidealE.
Qed.

Lemma dw_closedP X :
  reflect (dw_closed (mem X)) (dw_closedb X).
Proof.
  apply/equivP; first apply/(fset_forallP); split.
  - move=> inX x y le_xy Xy.
    by apply/inX/fin_idealP; exists y.
  by move=> dwX x /fin_idealP [y] /dwX; apply.
Qed.

Lemma up_closP P x :
  reflect (exists2 y, y <= x & y \in P) (x \in up_clos P).
Proof.
  apply/(equivP idP).
  rewrite /up_clos !unfold_in /=; split.
  - move=> /existsP /= [y]; move: (valP y).
    by rewrite pidealE=> ??; exists (val y).
  move=> [y] le_yx Py; apply/existsP.
  have: y \in pideal x by rewrite pidealE.
  by move=> yi; exists (Sub y yi).
Qed.

(* Kuratowski closure axioms *)

Lemma up_clos0 :
  up_clos (pred0 : pred T) =1 pred0.
Proof.
  move=> x; apply/idP=> /=.
  by move=> /up_closP[y].
Qed.

Lemma up_clos_ext P :
  {subset P <= up_clos P}.
Proof. by move=> x Px; apply/up_closP; exists x. Qed.

Lemma up_clos_idemp P :
  up_clos (up_clos P) =1 up_clos P.
Proof.
  move=>>; apply/idP/idP; last exact/up_clos_ext.
  case/up_closP=>> l /up_closP[x] /le_trans/(_ l) *.
  apply/up_closP; by exists x.
Qed.

Lemma up_closU P Q :
  up_clos ([predU P & Q]) =1 [predU (up_clos P) & (up_clos Q)].
Proof.
  move=> x; apply/idP/idP=> /=.
  - move=> /up_closP[y] le_yx; rewrite inE.
    by move=> /orP[] ?; apply/orP; [left | right]; apply/up_closP; exists y.
   move=> /orP[] /up_closP[y] le_xy y_in; apply/up_closP; exists y=> //=.
   all: by rewrite !inE y_in ?orbT.
Qed.

(* ************************* *)

Lemma up_clos_subs P Q :
  {subsumes P <= Q : x y / y <= x } <-> {subset (up_clos P) <= (up_clos Q)}.
Proof.
  split=> [subs x | sub x]; last first.
  - move: up_clos_ext=> /[apply] x_in.
    by move: (sub x x_in)=> /up_closP[y] ??; exists y.
  move=> /up_closP[y] le_yx Py.
  apply/up_closP; move: (subs y Py)=> [z] z_in le_zy.
  exists z=> //; exact/(le_trans le_zy).
Qed.

End Theory.
End Theory.

(* TODO: better naming convention *)
Module Export AuxTheory.
Section AuxTheory.
Context {T U V : dwFinPOrderType}.
Implicit Types (f : T -> U) (g : U -> V).

Lemma homo_pidealE {T1 U1 : dwFinPOrderType} (f : T1 -> U1) :
  { homo pideal f } <-> dw_surjective_le f.
Proof.
  split=> [homf x y | subs].
  - rewrite inE -pidealE=> yin.
    move: (homf x)=> /fsubsetP /(_ y yin).
    move=> /imfsetP=> [[]] z /= + ->.
    by rewrite pidealE=> zle; exists (Sub z zle).
  move=> x; apply/fsubsetP=> y.
  rewrite pidealE=> yle.
  move: (subs x y yle)=> [[z]] /= zle.
  rewrite /rst /= => <-.
  apply/imfsetP; exists z=> //=.
  by rewrite pidealE.
Qed.

Lemma homo_pideal_comp g f :
  {homo pideal g} -> {homo pideal f} -> {homo pideal (g \o f)}.
Proof.
  rewrite !homo_pidealE=> hg hf x y /=.
  move=> /hg [[a]] /=; rewrite /rst /= => +   <-.
  move=> /hf [[b]] /=; rewrite /rst /= => bin <-.
  by exists (Sub b bin).
Qed.

Lemma dw_closedb_imfsetE f X : injective f -> {homo f : x y / x <= y} ->
  dw_surjective_le f -> dw_closedb (f @` X) = dw_closedb X.
Proof.
  move=> finj lef fdw.
  move: (imfset_preim_eq X finj)=> /eq_dw_closed dw_preim.
  apply/idP/idP=> /dw_closedP dw; apply/dw_closedP.
  - apply/dw_preim/dw_closed_preim=> //.
  apply/(dw_surj_le_closed fdw)=> //.
  - by move=> x /imfsetP [y] /= _ ->; exists y.
  exact/dw_preim.
Qed.

End AuxTheory.
End AuxTheory.

End DwFinPOrder.

Export DwFinPOrder.Exports.
Export DwFinPOrder.Def.
Export DwFinPOrder.Syntax.
Export DwFinPOrder.Theory.
Export DwFinPOrder.AuxTheory.


Set Implicit Arguments.

Require Import Arith_Max_extra.
Require Import LNameless_Meta.
Require Import LNameless_Meta_Env.
Require Import LNameless_Isomorphism.
Require Import LNameless_STLC_Iso.
Require Import LN_Template_One_Sort.

(** ** Pure Lambda Calculus *)

(** Reference: Chargueraud's POPLmark contribution using Locally Nameless style
   and cofinite quantification *)

(** Many of the generic properties about substitution, environments are
   already proved in a generic
   *)

(** [typ] and [trm] are already defined in LNameless_STLC_Iso.v
<<
Notation atm := nat.

Inductive typ : Type :=
| typ_var : atm -> typ
| typ_arrow  : typ -> typ -> typ.

Inductive trm : Set :=
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_abs  : trm -> trm
| trm_app  : trm -> trm -> trm.
>> *)

(** Module for terms with typing environment for term variables *)

Notation "{ k ~> u } t" := (Tbsubst t k u) (at level 67).
Notation "t ^^ u" := (Tbsubst t 0 u) (at level 67).
Notation "t ^ x" := (Tbsubst t 0 (trm_fvar x)).

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env typ -> trm -> typ -> Prop :=
| typing_var : forall E x T,
  uniq E ->
  binds x T E ->
  E |= (trm_fvar x) ~: T
| typing_abs : forall L E U T t1,
  (forall x, x `notin` L ->
    (x ~ U ++ E) |= t1 ^ x ~: T) ->
  E |= (trm_abs t1) ~: (typ_arrow U T)
| typing_app : forall S T E t1 t2,
  E |= t1 ~: (typ_arrow S T) ->
    E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

        where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
| value_abs : forall t1,
  TwfT (trm_abs t1) -> value (trm_abs t1).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
| red_beta : forall t1 t2,
  TwfT (trm_abs t1) ->
  value t2 ->
  red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
| red_app_1 : forall t1 t1' t2,
  TwfT t2 ->
  red t1 t1' ->
    red (trm_app t1 t2) (trm_app t1' t2)
| red_app_2 : forall t1 t2 t2',
  value t1 ->
  red t2 t2' ->
    red (trm_app t1 t2) (trm_app t1 t2').

Notation "t ---> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
    t ---> t' ->
    E |= t' ~: T.

Definition progress := forall t T,
  empty_env |= t ~: T ->
    value t
    \/ exists t', t ---> t'.


(* -*- mode: coq; mode: visual-line -*-  *)
Require Import HoTT.Basics HoTT.Types.
Require Import Extensions Factorization.
Require Import Truncations.Core Modalities.Modality.

Local Open Scope path_scope.
Local Open Scope trunc_scope.

(** * Varieties of constant function *)

(** Recall that a function [f : X -> Y] is *weakly constant*, [WeaklyConstant f], if [forall x y, f x = f y].  We show, following Kraus, Escardo, Coquand, and Altenkirch, that the type of fixed points of a weakly constant endofunction is an hprop.  However, to avoid potential confusion with [Coq.Init.Wf.Fix], instead of their notation [Fix], we denote this type by [FixedBy]. *)

Definition FixedBy {X : Type} (f : X -> X) := {x : X & f x = x}.

Global Instance ishprop_fix_wconst {X : Type} (f : X -> X)
       `{WeaklyConstant _ _ f}
: IsHProp (FixedBy f).
Proof.
  apply hprop_inhabited_contr; intros [x0 p0].
  refine (contr_equiv' {x:X & f x0 = x} _); unfold FixedBy.
  apply equiv_functor_sigma_id. intros x.
  apply equiv_concat_l.
  apply wconst.
Defined.

(** It follows that if a type [X] admits a weakly constant endofunction [f], then [FixedBy f] is equivalent to [merely X]. *)
Definition equiv_fix_merely {X : Type} (f : X -> X)
           `{WeaklyConstant _ _ f}
: FixedBy f <~> merely X.
Proof.
  apply equiv_iff_hprop.
  - intros [x p]; exact (tr x).
  - apply Trunc_rec; intros x.
    exists (f x).
    apply wconst.
Defined.

(** Therefore, a type is collapsible (admits a weakly constant endomap) if and only if [merely X -> X] (it has "split support"). *)
Definition splitsupp_collapsible {X} `{Collapsible X}
: merely X -> X.
Proof.
  refine (_ o (equiv_fix_merely collapse)^-1).
  apply pr1.
Defined.

Definition collapsible_splitsupp {X} (s : merely X -> X)
: Collapsible X.
Proof.
  refine (Build_Collapsible _ (s o tr) _); intros x y.
  apply (ap s), path_ishprop.
Defined.

(**  We say that [f] is *conditionally constant* if it factors through the propositional truncation [merely X], and *constant* if it factors through [Unit]. *)

Definition ConditionallyConstant {X Y : Type} (f : X -> Y)
  := ExtensionAlong (@tr (-1) X) (fun _ => Y) f.

(** We don't yet have a need for a predicate [Constant] on functions; we do already have the operation [const] which constructs the constant function at a given point.  Every such constant function is, of course, conditionally constant. *)
Definition cconst_const {X Y} (y : Y)
: ConditionallyConstant (@const X Y y).
Proof.
  exists (const y); intros x; reflexivity.
Defined.

(** The type of conditionally constant functions is equivalent to [merely X -> Y]. *)
Definition equiv_cconst_from_merely `{Funext} (X Y : Type)
: { f : X -> Y & ConditionallyConstant f } <~> (merely X -> Y).
Proof.
  refine (_ oE (equiv_sigma_symm _)).
  refine (equiv_sigma_contr _).
Defined.

(** If a function factors through any hprop, it is conditionally constant. *)
Definition cconst_factors_hprop {X Y : Type} (f : X -> Y)
           (P : Type) `{IsHProp P}
           (g : X -> P) (h : P -> Y) (p : h o g == f)
: ConditionallyConstant f.
Proof.
  pose (g' := Trunc_rec g : merely X -> P).
  exists (h o g'); intros x.
  apply p.
Defined.

(** Thus, if it factors through a type that [X] implies is contractible, then it is also conditionally constant. *)
Definition cconst_factors_contr `{Funext}  {X Y : Type} (f : X -> Y)
           (P : Type) `{Pc : X -> Contr P}
           (g : X -> P) (h : P -> Y) (p : h o g == f)
: ConditionallyConstant f.
Proof.
  assert (merely X -> IsHProp P).
  { apply Trunc_rec.            (** Uses funext *)
    intros x; pose (Pc x); apply istrunc_succ. }
  pose (g' := Trunc_ind (fun _ => P) g : merely X -> P).
  exists (h o g'); intros x.
  apply p.
Defined.

(** Any weakly constant function with collapsible domain is conditionally constant. *)
Definition cconst_wconst_collapsible {X Y : Type} (f : X -> Y)
           `{Collapsible X} `{WeaklyConstant _ _ f}
: ConditionallyConstant f.
Proof.
  exists (f o splitsupp_collapsible); intros x.
  unfold splitsupp_collapsible; simpl.
  apply wconst.
Defined.

(** Any weakly constant function with hset codomain is conditionally constant. *)
Definition cconst_wconst_hset `{Funext} {X Y : Type} (f : X -> Y)
           `{Ys : X -> IsHSet Y} `{WeaklyConstant _ _ f}
: ConditionallyConstant f.
Proof.
  assert (Ys' : merely X -> IsHSet Y).
  { apply Trunc_rec. intros x; exact (Ys x). }
  simple refine (cconst_factors_hprop f (image (-1) f) _ _ _).
  - apply hprop_allpath; intros [y1 p1] [y2 p2].
    apply path_sigma_hprop; simpl.
    pose proof (Ys' (Trunc_functor (-1) pr1 p1)).
    strip_truncations.
    destruct p1 as [x1 q1], p2 as [x2 q2].
    exact (q1^ @ wconst x1 x2 @ q2).
  - apply factor1.
  - apply factor2.
  - apply fact_factors.
Defined.

(** We can decompose this into an "induction principle" and its computation rule. *)
Definition merely_rec_hset `{Funext} {X Y : Type} (f : X -> Y)
           `{Ys : X -> IsHSet Y} `{WeaklyConstant _ _ f}
: merely X -> Y
  := (cconst_wconst_hset f).1.

Definition merely_rec_hset_beta `{Funext} {X Y : Type} (f : X -> Y)
           `{Ys : X -> IsHSet Y} `{WeaklyConstant _ _ f}
           (x : X)
: merely_rec_hset f (tr x) = f x
  := (cconst_wconst_hset f).2 x.

(** More generally, the type of weakly constant functions [X -> Y], when [Y] is a set, is equivalent to [merely X -> Y]. *)
Definition equiv_merely_rec_hset `{Funext} (X Y : Type)
           `{Ys : X -> IsHSet Y}
: { f : X -> Y & WeaklyConstant f } <~> (merely X -> Y).
Proof.
  assert (Ys' : merely X -> IsHSet Y).
  { apply Trunc_rec. intros x; exact (Ys x). }
  simple refine (equiv_adjointify
            (fun fc => @merely_rec_hset _ _ _ fc.1 _ fc.2)
            (fun g => (g o tr ; _)) _ _); try exact _.
  - intros x y; apply (ap g), path_ishprop.
  - intros g; apply path_arrow; intros mx.
    pose proof (Ys' mx).
    strip_truncations; reflexivity.
  - intros [f ?].
    refine (path_sigma_hprop _ _ _).
    + intros f'; apply hprop_allpath; intros w1 w2.
      apply path_forall; intros x; apply path_forall; intros y.
      pose (Ys x); apply path_ishprop.
    + apply path_arrow; intros x; reflexivity.
Defined.


(* Author : CESally *)
Require Export Notions BinInt.
Close Scope Z_scope.
Close Scope N_scope.

Reserved Notation "x @ y" (at level 20, left associativity).

(* Declare Scope Groups. *)

Open Scope group_scope.

Module lGroups.
Section Defn.
Context {C : Type}.

Record t : Type := mklgroup {
  carrier  : Ensemble C;
  op : C -> C -> C;
  e  : C;
  inv: C -> C;
  closure : closed_b carrier op;
  assoc   : is_assoc carrier op;

  ein : e ∈ carrier;
  lid : l_ident carrier op e;

  invin : closed_u carrier inv;
  linv  : l_inv carrier op e inv
}.
End Defn.

Section Basics.
Context {C : Type}.
Variable (G: @t C).
Variable (a b c id: C).
Hypothesis Ga : a ∈ G.(carrier).
Hypothesis Gb : b ∈ G.(carrier).
Hypothesis Gc : c ∈ G.(carrier).
Hypothesis Gi : id ∈ G.(carrier).
Local Notation e := (e G).
Local Notation op := (op G).
Local Notation assoc := (assoc G).
Local Infix "@" := op (at level 20, left associativity).
Local Notation "a '''" := (inv G a) (at level 2, left associativity).

Hint Resolve (closure G) ein (invin G)  : lgrp.
Hint Rewrite @assoc : lgrp.

Theorem left_can : forall z x y,
  z ∈ G.(carrier) ->
  x ∈ G.(carrier) ->
  y ∈ G.(carrier) ->
  z @ x = z @ y -> x = y.
Proof with auto with lgrp.
  intros * Gz Gx Gy H.
  rewrite <- G.(lid), <- (G.(lid) y)...
  rewrite <- (G.(linv) z)...
  repeat rewrite assoc...
  rewrite H...
Qed.

Theorem lft_id_is_id: r_ident G.(carrier) op e.
Proof with auto with lgrp.
  intros ? **.
  apply (left_can (x '))...
  rewrite <- assoc...
  repeat rewrite linv...
  rewrite lid...
Qed.

Theorem lft_inv_is_inv: r_inv G.(carrier) op e G.(inv).
Proof with auto with lgrp.
  intros ? **. apply (left_can (x '))...
  rewrite <- assoc, G.(linv),
          G.(lid), lft_id_is_id...
Qed.

End Basics.
End lGroups.

Section Defn.
Context {C : Type}.

Record Group : Type := mkgroup {
  carrier  : Ensemble C;
  op : C -> C -> C;
  e  : C;
  inv: C -> C;
  closure : closed_b carrier op;
  assoc   : is_assoc carrier op;

  ein : e ∈ carrier;
  lid : l_ident carrier op e;
  rid : r_ident carrier op e;

  invin : closed_u carrier inv;
  linv  : l_inv carrier op e inv;
  rinv  : r_inv carrier op e inv
}.

Definition is_Group (carrier : Ensemble C) (op: C -> C -> C)
                   (e: C) (inv: C -> C):=
  closed_b carrier op /\
  is_assoc carrier op /\
  e ∈ carrier /\
  l_ident carrier op e /\
  r_ident carrier op e /\
  closed_u carrier inv /\
  l_inv carrier op e inv /\
  r_inv carrier op e inv.

Definition isn't_Group (carrier : Ensemble C) (op: C -> C -> C)
                   (e: C) (inv: C -> C):=
  ~ closed_b carrier op \/
  ~ is_assoc carrier op \/
  ~ e ∈ carrier \/
  ~ l_ident carrier op e \/
  ~ r_ident carrier op e \/
  ~ closed_u carrier inv \/
  ~ l_inv carrier op e inv \/
  ~ r_inv carrier op e inv.

Section Subgroups.
Variable (H N G: Group) (h n g g1 g2: C).
Hypothesis Hh: h ∈ H.(carrier).
Hypothesis Nn: n ∈ N.(carrier).
Hypothesis Gg: g ∈ G.(carrier).
Hypothesis G1: g1 ∈ G.(carrier).
Hypothesis G2: g2 ∈ G.(carrier).
Local Infix "@" := G.(op) (at level 20, left associativity).
Local Notation "a '''" := (inv G a) (at level 2, left associativity).

Inductive subgroup_ind : Prop :=
  Definition_of_sgrp :
    H.(carrier) ⊆ G.(carrier) ->
    H.(op) = G.(op) -> subgroup_ind.

Definition subgroup_prop : Prop :=
    H.(carrier) ⊆ G.(carrier) /\
    H.(op) = G.(op).

Local Notation subgroup := subgroup_prop.

Definition normal_subgroup : Prop :=
  subgroup /\
  n @ g @ (N.(inv) n) ∈ N.(carrier).

Definition normal_comm : Prop :=
  g1 @ g2 ∈ N.(carrier) <-> g2 @ g1 ∈ N.(carrier).

Export BinPos.Pos.
Close Scope positive_scope.
Definition rep_aux (x: C) := iter (fun y => x @ y) G.(e).

Definition rep (n: Z) : C :=
  match n with
  | Zpos p => rep_aux g p
  | Zneg p => rep_aux (g ') p
  | Z0     => G.(e)
  end.

(* Definition cyclic_subgroup : Prop :=
  subgroup /\
  ∀ (n: Z), rep n ∈ H.(carrier). *)

Inductive left_coset : Ensemble C :=
  lft_cs: subgroup ->
        g @ h ∈ (left_coset).

Inductive right_coset (g: C): Ensemble C :=
  rgt_cs: subgroup ->
          h @ g ∈ (right_coset g).
End Subgroups.
End Defn.

Arguments subgroup_ind [_].
Arguments subgroup_prop [_].
Local Notation subgroup := subgroup_prop.
Notation "A ≤ B" := (subgroup A B) (at level 70) : group_scope.

Section Homomorphisms.
Section top.
Context {C D: Type}.
Variable (G: @Group C) (H: @Group D).
Variable (g g1 g2: C) (h h1 h2: D).
Hypothesis Gg: g ∈ G.(carrier).
Hypothesis G1: g1 ∈ G.(carrier).
Hypothesis G2: g2 ∈ G.(carrier).
Hypothesis Hh: h ∈ H.(carrier).
Hypothesis H1: h1 ∈ H.(carrier).
Hypothesis H2: h2 ∈ H.(carrier).
Infix "@" := G.(op) (at level 20, left associativity).
Infix "+" := H.(op) (at level 50, left associativity).

Definition fn := C -> D.
(* carrier to carrier *)
Definition c2c (f:fn) := ∀ x (Gx: x ∈ G.(carrier)), f x ∈ H.(carrier).
Definition structure_preserving (f: fn) := c2c f /\
  ∀ a b, (f:fn) (a @ b) = (f:fn) a + (f:fn) b.
Definition homomorphism :=
  {f: fn |  structure_preserving f}.
Definition homo2fn (h: homomorphism) : fn := proj1_sig h.
Coercion   homo2fn : homomorphism >-> fn.
Definition homosp (h: homomorphism) := proj2_sig h.

Lemma homo_img_in : ∀ (f: homomorphism) x,
  x ∈ G.(carrier) -> (f:fn) x ∈ H.(carrier).
Proof.
  intros f. destruct f as [f [ghomo sp]].
  exact ghomo.
Qed.

Lemma homo_img_in' : ∀ (f: fn) x, c2c f ->
  x ∈ G.(carrier) -> (f:fn) x ∈ H.(carrier).
Proof. intros **. apply H0; auto. Qed.

Variable (f: homomorphism).
Definition kernel : Ensemble C := fun g => (f: fn) g = H.(e).
Definition image  : Ensemble D := fun h => forall g, (f: fn) g = h.

End top.

Arguments structure_preserving [_ _ _ _].

Section inverse.
Context {C D: Type}.
Variable (G: @Group C) (H: @Group D).
Variable (g g1 g2: C) (h h1 h2: D).
Hypothesis Gg: g  ∈ G.(carrier).
Hypothesis G1: g1 ∈ G.(carrier).
Hypothesis G2: g2 ∈ G.(carrier).
Hypothesis Hh: h  ∈ H.(carrier).
Hypothesis H1: h1 ∈ H.(carrier).
Hypothesis H2: h2 ∈ H.(carrier).
Infix "@" := G.(op) (at level 20, left associativity).
Infix "+" := H.(op) (at level 50, left associativity).

(* Require Import FinFun. *)
Definition Bijective (f: homomorphism G H) :=
  ∃ f' : (homomorphism H G),
    (∀ x, x ∈ G.(carrier) -> (f':fn) ((f :fn) x) = x) /\
    (∀ y, y ∈ H.(carrier) -> (f :fn) ((f':fn) y) = y).

Definition Injective (f: homomorphism G H) :=
  ∀ x y, x ∈ G.(carrier) -> y ∈ G.(carrier) ->
  (f:fn) x = (f:fn) y -> x = y.

Definition Surjective (f: homomorphism G H) :=
  ∀ y, y ∈ H.(carrier) -> ∃ x, x ∈ G.(carrier) /\
  (f:fn) x = y.

(* Require Import FinFun. *)
Definition isomorphism :=
  {f: homomorphism G H | Bijective f}.
Definition iso2homo (h: isomorphism): homomorphism G H := proj1_sig h.
Coercion   iso2homo : isomorphism >-> homomorphism.
Definition iso2fn (h: isomorphism) : fn := (proj1_sig (proj1_sig h)).
Coercion   iso2fn : isomorphism >-> fn.
Definition isosp (h: isomorphism) := (proj2_sig (proj1_sig h)).
Definition isob (h: isomorphism) := proj2_sig h.

Lemma Bi2I : ∀ {f: homomorphism G H}, Bijective f -> Injective f.
Proof with auto.
  intros * [f' [f'f ff']] x y Gx Gy fxfy.
  rewrite <- f'f, <- (f'f x), fxfy...
Qed.

Lemma Bi2S : ∀ {f: homomorphism G H}, Bijective f -> Surjective f.
Proof with auto.
  intros * [f' [f'f ff']] y Hy.
  exists ((f':fn) y). split...
  apply homo_img_in...
Qed.

Lemma Bi2I_S : ∀ {f: homomorphism G H}, Bijective f -> Injective f /\ Surjective f.
Proof with auto.
  intros * [f' [f'f ff']].
  split.
  - intros x y Gx Gy fxfy. rewrite <- f'f, <- (f'f x), fxfy...
  - intros y Hy. exists ((f':fn) y). split... apply homo_img_in...
Qed.

(* Lemma I_S2Bi : ∀ {f: homomorphism G H},
  Injective f -> Surjective f -> Bijective f.
Proof with auto.
Admitted. *)

End inverse.
End Homomorphisms.

Arguments Bi2I_S [_ _ _ _ _].
Arguments rep [_ _].

Ltac b2is bi := destruct (Bi2I_S bi) as [?inj ?sur].
Ltac b2is' bi := destruct (Bi2I_S bi) as [inj sur];
                 unfold Injective in inj; unfold Surjective in sur;
                 simpl in *.
Ltac dhomo f := destruct f as [bbob [?ghomo ?sp]]; simpl in *;
                clear f; rename bbob into f.
Ltac diso  f := destruct f as [[bbob [?ghomo ?sp]] bi];
                b2is' bi; destruct bi as [f' [f'f ff']];

                clear f; rename bbob into f; simpl in *.
Close Scope group_scope.

Create HintDb grp.
Hint Resolve homo_img_in : grp.
Hint Unfold is_assoc l_ident r_ident l_inv r_inv
            In Included carrier lid rid linv rinv: grp.
Local Hint Resolve @closure @ein @lid @rid
                   @invin @linv @rinv
                   : grp.
Local Hint Rewrite @assoc : grp.
Ltac atg := auto with grp.

Close Scope group_scope.


Load Cost.

Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Lia.
Require Import ArithRing.

Undelimit Scope nat_scope.
Delimit Scope nat_scope with Nat.

Undelimit Scope Z_scope.
Delimit Scope Z_scope with Int.

Open Scope Z_scope.
Open Scope nat_scope.

Inductive list {A} : Type :=
  | Nil : list
  | Cons : A -> list -> list.

Arguments list : clear implicits.

Notation "x :: l" := (Cons x l).

Notation "[ ]" := Nil (format "[ ]").
Notation "[ x ]" := (Cons x Nil).
Notation "[ x ; y ; .. ; z ]" := (Cons x (Cons y .. (Cons z Nil) ..)).

Fixpoint app {A} (l1 l2 : list A) :=
  match l1 with
  | [] => l2
  | x :: l1' => x :: app l1' l2
  end.

Infix "++" := app (right associativity, at level 60).

Definition length {A} :=
  fix length (l : list A) :=
    match l with
    | [] => 0
    | x :: l' => S (length l')
    end.

Definition filter {A} (predicate : A -> bool) :=
  fix filter (l : list A) :=
    match l with
    | [] => []
    | x :: l' =>
      if predicate x
      then x :: (filter l')
      else filter l'
    end.

Fixpoint rev {A} (l : list A) :=
  match l with
  | [] => []
  | x :: l' => rev l' ++ [x]
  end.

Fixpoint list_forall {A} f (l : list A) :=
  match l with
  | [] => True
  | x :: l' => f x /\ list_forall f l'
  end.

Fixpoint list_in {A} a (l : list A) :=
  match l with
  | [] => False
  | x :: l' => x = a \/ list_in a l'
  end.

Theorem nat_strong_induction :
  forall (P : nat -> Prop),
  (forall n, (forall m, m < n -> P m) -> P n) ->
  forall n, P n.
Proof.
  intros ? ? ?. cut (forall m, m <= n -> P m).
  - intros ?. specialize (H0 n). apply H0. lia.
  - induction n.
    + intros ? ?. apply H. intros k ?. lia.
    + intros ? ?. apply H. intros k ?. apply IHn. lia.
Qed.

Lemma le_trans_rev : forall n m p, m <= p -> n <= m -> n <= p.
Proof.
  eauto using le_trans.
Qed.

Ltac le_chain_l H :=
  match type of H with
  | ?a <= ?b =>
    match goal with
    | [ |- ?a <= ?b ] => exact H
    | [ |- ?l <= S ?c ] => eapply le_trans_rev; [apply le_n_S; le_chain_l H | apply le_refl]
    | [ |- ?l <= ?c + ?d ] => eapply le_trans_rev; [apply plus_le_compat_l; le_chain_l H | apply le_refl]
    | [ |- ?l <= ?c + ?d ] => eapply le_trans_rev; [apply plus_le_compat_r; le_chain_l H | apply le_refl]
    | [ |- ?l <= ?c * ?d ] => eapply le_trans_rev; [apply mult_le_compat_l; le_chain_l H | apply le_refl]
    | [ |- ?l <= ?c * ?d ] => eapply le_trans_rev; [apply mult_le_compat_r; le_chain_l H | apply le_refl]
    end
  end.

Ltac le_chain_r H :=
  match type of H with
  | ?a <= ?b =>
    match goal with
    | [ |- ?a <= ?b ] => exact H
    | [ |- S ?c <= ?r ] => eapply le_trans; [apply le_n_S; le_chain_r H | apply le_refl]
    | [ |- ?c + ?d <= ?r ] => eapply le_trans; [apply plus_le_compat_l; le_chain_r H | apply le_refl]
    | [ |- ?c + ?d <= ?r ] => eapply le_trans; [apply plus_le_compat_r; le_chain_r H | apply le_refl]
    | [ |- ?c * ?d <= ?r ] => eapply le_trans; [apply mult_le_compat_l; le_chain_r H | apply le_refl]
    | [ |- ?c * ?d <= ?r ] => eapply le_trans; [apply mult_le_compat_r; le_chain_r H | apply le_refl]
    end
  end.

Ltac le_chain H := first[eapply le_trans_rev; [le_chain_l H |] | eapply le_trans; [le_chain_r H |]].

Ltac clear_S :=
  simpl; repeat match goal with
  | [ |- context[S ?n] ] => progress (rewrite <- (Nat.add_1_r n); simpl)
  end.

Theorem list_empty_or_not_empty : forall {A} (l : list A), {l = []} + {l <> []}.
Proof.
  intros ? l. destruct l.
  - left. auto.
  - right. discriminate.
Qed.

Theorem list_forall_positive :
  forall {A} f g (l : list A),
  (forall a, (f a : Prop) -> (g a : Prop)) ->
  list_forall f l -> list_forall g l.
Proof.
  intros ? ? ? ? ? ?. induction l.
  - auto.
  - destruct H0 as (? & ?). split.
    + auto.
    + auto.
Qed.

Theorem list_forall_list_in :
  forall {A} f (l : list A),
  list_forall f l <-> (forall a, list_in a l -> f a).
Proof.
  intros ? ? l. induction l.
  - simpl. intuition auto.
  - simpl. split.
    + intros (? & ?) b [? | ?].
      * subst b. auto.
      * apply IHl; auto.
    + intros ?. split.
      * apply H. left. auto.
      * apply IHl. intuition auto.
Qed.

Theorem app_assoc : forall {A} (l1 l2 l3 : list A), (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros ? l1 l2 l3. induction l1.
  - auto.
  - simpl. f_equal. auto.
Qed.

Theorem app_nil_inversion : forall {A} (l1 l2 : list A), l1 ++ l2 = [] -> l1 = [] /\ l2 = [].
Proof.
  intros ? ? ? ?. destruct l1, l2; auto; discriminate.
Qed.

Theorem length_app : forall {A} (l1 l2 : list A), length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros ? ? ?. induction l1.
  - auto.
  - simpl. auto.
Qed.

Theorem length_filter_le : forall {A} f (l : list A), length (filter f l) <= length l.
Proof.
  intros ? ? ?. induction l.
  - auto.
  - simpl. destruct (f a); simpl; lia.
Qed.

Theorem list_in_app : forall {A} a (l1 l2 : list A), list_in a (l1 ++ l2) <-> list_in a l1 \/ list_in a l2.
Proof.
  intros ? a l1 l2. induction l1.
  - simpl. intuition auto.
  - rename a0 into b. simpl. rewrite IHl1. intuition auto.
Qed.

Theorem list_forall_app :
  forall {A} f (l1 l2 : list A),
  list_forall f (l1 ++ l2) <-> list_forall f l1 /\ list_forall f l2.
Proof.
  setoid_rewrite list_forall_list_in. setoid_rewrite list_in_app. intuition auto.
Qed.

Theorem list_in_insert : forall {A} a (l1 l2 : list A), list_in a (l1 ++ a :: l2).
Proof.
  intros ? ? ? ?. induction l1.
  - simpl. intuition auto.
  - simpl. intuition auto.
Qed.

Theorem list_in_filter : forall {A} a f (l : list A), list_in a (filter f l) <-> list_in a l /\ f a = true.
Proof.
  intros ? ? ? ?. induction l.
  - simpl. intuition auto.
  - rename a0 into b. simpl. remember (f b) as f_b. destruct f_b.
    + simpl. split.
      * intros [-> | ?].
        -- auto.
        -- intuition auto.
      * intuition auto.
    + split.
      * intuition auto.
      * intros ([-> | ?] & ?).
        -- rewrite H in Heqf_b. discriminate.
        -- intuition auto.
Qed.


(*|
=============================================================
 6.822 Formal Reasoning About Programs, Spring 2021 - Pset 8
=============================================================
|*)

Require Import Pset8Sig.

(*|
Introduction
============

Computer programs commonly manipulate data from different sources, at different levels of privacy or trust.  An e-commerce website, for example, might keep track of the contents of each individual cart, and it would be a severe issue if one user got access to the content of another user's cart.

Such “information-flow” issues are of a different nature from the functionality bugs that we usually think of, but they are also pervasive and tricky to detect and fix: for example, for a few weeks in 2011, Facebook's abuse-reporting tool made it possible to access a user's private photos by reporting one of their *public* photos for abuse: the tool would then conveniently offer to report other photos, *including private ones* that the reporter was not allowed to access. (https://www.zdnet.com/article/facebook-flaw-allows-access-to-private-photos/)

In this pset, we will see how type systems can help with information-flow issues.  We will operate in a simplified setting in which all information is either “public” or “private”, and we will concern ourselves only with *confidentiality*, the property that private inputs should not influence public program outputs.

Informally, we'll prove the correctness of a type system such that type-safe programs do not leak private data: that is, we'll prove that changing the private inputs of a well-typed program does not change its public outputs.  We'll say that well-typed programs are “confidential”.

Note that this formulation doesn't rule out side channels: changing the private inputs of a program might change its runtime or even whether it terminates.

Language definition
===================

This is as usual:
|*)

Module Impl.
Inductive bop := Plus | Minus | Times.

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Bop (b : bop) (e1 e2 : arith).

Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Declare Scope  arith_scope.
Notation "a + b" := (Bop Plus a b) : arith_scope.
Notation "a - b" := (Bop Minus a b) : arith_scope.
Notation "a * b" := (Bop Times a b) : arith_scope.
Delimit Scope arith_scope with arith.

Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (thn els : cmd)
| While (e : arith) (body : cmd).

(* Here are some notations for the language, which again we won't really
 * explain. *)
Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";;" := Sequence (at level 76). (* This one changed slightly, to avoid parsing clashes. *)
Notation "'when' e 'then' thn 'else' els 'done'" := (If e%arith thn els) (at level 75, e at level 0).
Notation "'while' e 'loop' body 'done'" := (While e%arith body) (at level 75).

(*|
Program semantics
=================

And the semantics of the language are as expected; the language is made deterministic by defaulting to 0 when a variable is undefined.
|*)

Definition valuation := fmap var nat.

Fixpoint interp (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match v $? x with
    | None => 0
    | Some n => n
    end
  | Bop bp e1 e2 =>
    match bp with
    | Plus => Nat.add
    | Minus => Nat.sub
    | Times => Nat.mul
    end (interp e1 v) (interp e2 v)
  end.

Inductive eval : valuation -> cmd -> valuation -> Prop :=
| EvalSkip : forall v,
    eval v Skip v
| EvalAssign : forall v x e,
    eval v (Assign x e) (v $+ (x, interp e v))
| EvalSeq : forall v c1 v1 c2 v2,
    eval v c1 v1
    -> eval v1 c2 v2
    -> eval v (Sequence c1 c2) v2
| EvalIfTrue : forall v e thn els v',
    interp e v <> 0
    -> eval v thn v'
    -> eval v (If e thn els) v'
| EvalIfFalse : forall v e thn els v',
    interp e v = 0
    -> eval v els v'
    -> eval v (If e thn els) v'
| EvalWhileTrue : forall v e body v' v'',
    interp e v <> 0
    -> eval v body v'
    -> eval v' (While e body) v''
    -> eval v (While e body) v''
| EvalWhileFalse : forall v e body,
    interp e v = 0
    -> eval v (While e body) v.

(*|
Typing judgment
===============

The `Confidential` judgment below indicates that a program respects confidentiality.  It takes a set of public variables and a command and returns a `Prop` indicating whether the program is safe.  Take the time to understand exactly how `Confidential` works (or, even better, take a few moments to think how you would define a `Confidential` predicate.

In full generality, information-flow systems associate a label to each variable.  We'll simplify things and classify variables as “public” or “private”, and instead of having a map giving the label of each value, we'll keep track of the set of all public variables.

First, we need a way to collect the variables of an expression (we haven't seen the `set` type too often; see ``Hints.v`` for a quick recap).
|*)

Fixpoint vars (e: arith) : set var :=
  match e with
  | Const n => {} (** A constant has no variables **)
  | Var x => {x} (** A variable has… one variable! **)
  | Bop _ e1 e2 => vars e1 \cup vars e2 (** An operator's variables are the variables of its subterms **)
  end.

(*|
The parameter `pub` below represents the set of all public variables.  This is pre-declared and fixed.  But there is also a distinct `set var` argument.  This is because we need to consider *implicit* as well as *explicit* flows.

- An explicit flow happens when assigning to a variable.  If `e` mentions variable `x`, then `y := e` may cause data to flow from `x` into `y`.  If `x` is private and `y` is public, we want to rule that out.

- An implicit flow happens when assigning to a variable *under a conditional*.  If `e` mentions variable `x`, then `when e then y := 1` may cause data to flow from `x` to `y` (can you see why?).  There, too, if `x` is private and `y` is public, we want to disallow this flow.

This is why we have the second `set var` (`pc`) argument below: in addition to the set of public variables, we keep track of the set of variables from which data may flow implicitly.  We call that set “pc”, for “program counter”.
|*)

Inductive Confidential (pub: set var) : set var (* pc *) -> cmd (* program *) -> Prop :=
| ConfidentialSkip : forall pc,
    Confidential pub pc Skip
(** A `Skip` is safe. **)
| ConfidentialAssignPrivate : forall pc x e,
    ~ x \in pub ->
    Confidential pub pc (Assign x e)
(** Assigning to a private variable is safe. **)
| ConfidentialAssignPublic : forall pc x e,
    vars e \subseteq pub ->
    pc \subseteq pub ->
    Confidential pub pc (Assign x e)
(** Assigning to a public variable variable is safe as long as the expression does not mention private variables and we are not under a conditional that depends on private variables. **)
| ConfidentialSeq : forall pc c1 c2,
    Confidential pub pc c1 ->
    Confidential pub pc c2 ->
    Confidential pub pc (Sequence c1 c2)
(** A sequence is safe if both halves of it are safe. **)
| ConfidentialIf : forall pc e thn els,
    Confidential pub (pc \cup vars e) thn ->
    Confidential pub (pc \cup vars e) els ->
    Confidential pub pc (If e thn els)
(** A conditional is safe if both branches are safe, noting that the branches run with additional variables in the `pc`. **)
| ConfidentialWhile : forall pc e body,
    Confidential pub (pc \cup vars e) body ->
    Confidential pub pc (While e body).
(** A while loop is safe if its body is safe, noting that the body runs with additional variables in the `pc`. **)

(*|
Here are a few examples:
|*)

Definition pub_example := {"x", "y", "z"}. (* Variables x, y, z are public. *)

Example confidential_prog :=
  ("x" <- "y" + 1;;
   "a" <- "a" * "b";;
   when "y" then "a" <- 0 else "b" <- 0 done).

Goal Confidential pub_example {} confidential_prog.
Proof.
  unfold confidential_prog, pub_example.
  apply ConfidentialSeq; simplify.
  - apply ConfidentialSeq; simplify.
    + apply ConfidentialAssignPublic; simplify.
      * sets.
      * sets.
    + apply ConfidentialAssignPrivate; simplify.
      sets.
  - apply ConfidentialIf; simplify.
    + apply ConfidentialAssignPrivate; simplify.
      sets.
    + apply ConfidentialAssignPrivate; simplify.
      sets.
Qed.

Example leaky_prog :=
  (when "a" then "x" <- 1 else "x" <- 2 done).

Goal ~ Confidential pub_example {} leaky_prog.
Proof.
  unfold leaky_prog, pub_example, not; simplify.
  invert H; simplify.
  invert H3; simplify.
  - sets.
  - pose proof @subseteq_In _ "a" _ _ H4.
    sets.
Qed.

(*|
Proof of noninterference
=========================

We first need a relation to characterize “equivalent” valuations — that is, valuations that agree on all public variables.  `restrict s m` means restrict the valuation `m` to just the keys in `s`:
|*)

Definition same_public_state pub (v1 v2: valuation) :=
  restrict pub v1 = restrict pub v2.

(*|
Then we're ready to prove noninterference!  Have a look at ``Hints.v`` for tips.
|*)

Theorem non_interference :
  forall pub c v1 v1' v2 v2',
    eval v1 c v1' ->
    eval v2 c v2' ->
    Confidential pub {} c ->
    same_public_state pub v1 v2 ->
    same_public_state pub v1' v2'.
Proof.
Admitted.

(*|
Congratulations, you have proved that our type system is *sound*: it catches all leaky programs!  But it is not *complete*: there are some good programs that it rejects, too.  In other words, it *overapproximates* the set of unsafe programs.

Can you give an example of a safe program (a program that does not leak data) that our system would reject?
|*)

Definition tricky_example : cmd. Admitted.

Lemma tricky_rejected : ~ Confidential pub_example {} tricky_example.
Proof.
Admitted.

Lemma tricky_confidential :
  forall v1 v1' v2 v2',
    eval v1 tricky_example v1' ->
    eval v2 tricky_example v2' ->
    same_public_state pub_example v1 v2 ->
    same_public_state pub_example v1' v2'.
Proof.
Admitted.
End Impl.

Module ImplCorrect : Pset8Sig.S := Impl.

(* Authors:
   Clément Pit-Claudel *)


Require Import Coq.Logic.ProofIrrelevance.
From mathcomp Require Import ssreflect ssrfun eqtype choice fintype div.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".

Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Basis FreeModules Projective.

(* We examine the correctness of the algebra libraries
  By constructing some examples of some ring modules and
  other objects *)

(* We start with a family of finite rings,
  the positive integers modulo some natural number *)

Section NatMod.
  Variable (n : nat) (n_neq_0 : n != 0).
  Definition type := 'I_(S n).
  Definition nm_zero := @Ordinal (S n) 0 is_true_true.

  Definition modulo (m : nat) : type :=
    @Ordinal _ (modn m (S n)) (ltn_pmod _ (is_true_true : 0 < n.+1)).

  Definition nm_add (i j : type) : type := modulo (i + j).

  Definition nm_neg  (i : type) : type := modulo ((S n) - i).

  Definition nm_mul  (i j : type) : type := modulo (i * j).

  Definition nm_one : type := modulo 1.

  Lemma addA : associative nm_add.
  Proof. rewrite /nm_add=>x y z.
    rewrite /modulo(rwP eqP)/eq_op=>/=.
    by rewrite modnDmr modnDml addnA.
  Qed.
  Lemma addC : commutative nm_add.
  Proof. rewrite /nm_add=>x y.
    by rewrite addnC. Qed.

  Lemma add0 : left_id nm_zero nm_add.
  Proof. rewrite /nm_add=>x; destruct x as [m Hm].
    rewrite /modulo(rwP eqP)/eq_op add0n=>/=.
    by rewrite {2}(divn_eq m (S n)) (divn_small Hm) mul0n add0n.
  Qed.

  Lemma addI : left_inverse nm_zero nm_neg nm_add.
  Proof. rewrite /nm_add=>x; destruct x as [m Hm].
    rewrite /modulo(rwP eqP)/eq_op=>/=.
    case (m == 0) as []eqn:E. {
    apply (rwP eqP) in E.
    by rewrite E subn0 addn0 modnn mod0n.
    } {
    rewrite (@modn_small (n.+1 - m) _).
    rewrite subnK.
    by rewrite modnn.
    by rewrite (ltnW Hm).
    case m as []eqn:M.
    by rewrite eq_refl in E.
    by rewrite ltnS subSS leq_subr.
    }
  Qed.

  Definition ZmodMixin_mod := ZmodMixin addA addC add0 addI.
  Canonical Zmod_Type := Eval hnf in ZmodType type ZmodMixin_mod.

  Lemma mulA : associative nm_mul.
  Proof. rewrite /nm_mul=>x y z.
    rewrite /modulo(rwP eqP)/eq_op=>/=.
    by rewrite modnMmr modnMml mulnA.
  Qed.

  Lemma mul0l : left_id nm_one nm_mul.
  Proof. rewrite /nm_mul=>x; destruct x as [m Hm].
    rewrite /modulo(rwP eqP)/eq_op=>/=.
    by rewrite modnMml mul1n (modn_small Hm).
  Qed.

  Lemma mul0r : right_id nm_one nm_mul.
  Proof. rewrite /nm_mul=>x; destruct x as [m Hm].
    rewrite /modulo(rwP eqP)/eq_op=>/=.
    by rewrite modnMmr muln1 (modn_small Hm).
  Qed.

  Lemma mulDl : left_distributive nm_mul nm_add.
  Proof. rewrite /nm_mul/nm_add=>x y r.
    rewrite /modulo(rwP eqP)/eq_op=>/=.
  Admitted.

  Lemma mulDr : right_distributive nm_mul nm_add.
  Proof. rewrite /nm_mul/nm_add=>x y r.
    rewrite /modulo(rwP eqP)/eq_op=>/=.
  Admitted.

  Lemma neq01 : is_true (~~ (nm_one == nm_zero)).
  Proof. rewrite /nm_one/nm_zero.
    rewrite /modulo/eq_op.
    apply (rwP negP)=>/=.
    induction n=>//=.
  Qed.

  Definition RingMixin_mod := RingMixin mulA mul0l mul0r mulDl mulDr neq01.
  Canonical RingType_mod := RingType type RingMixin_mod.

  Lemma scale_comp : forall (a b : type) (v : type),
   nm_scale a (nm_scale b v) = nm_scale (a * b)%R v.
  Proof.
    rewrite/nm_scale=>a b v.
    rewrite /modulo(rwP eqP)/eq_op=>/=.
    by rewrite modnMmr -mulnA.
  Qed.
End NatMod.


Require Import Sumbool String List FMapInterface Vector Equality Le Lt EqNat Plus Omega.

Inductive typ : Set :=
| NumT : typ
| StrT : typ.

Inductive exp : Set :=
| V : nat -> exp
| Num : nat -> exp
| Str : string -> exp
| Plus : exp -> exp -> exp
| Times : exp -> exp -> exp
| Cat : exp -> exp -> exp
| Len : exp -> exp
| Let_ : exp -> exp -> exp.
Notation "e1 + e2" := (Plus e1 e2)
  (at level 50, left associativity).
Notation "e1 * e2" := (Times e1 e2)
  (at level 40, left associativity).
Notation "s1 ^ s2" := (Cat s1 s2)
  (at level 30, right associativity).

Definition ctx := Vector.t typ.

Reserved Notation "G |- e @ t" (at level 60, no associativity).
Inductive wtexp : forall {n}, ctx n -> exp -> typ -> Prop :=
| OkVar : forall n (G : ctx n) (x : nat) (xLn : x < n), G |- V x @ nth_order G xLn
| OkStr : forall n (G : ctx n) s, G |- Str s @ StrT
| OkNum : forall n (G : ctx n) c, G |- Num c @ NumT
| OkPlus : forall n (G : ctx n) e1 e2,
  G |- e1 @ NumT -> G |- e2 @ NumT -> G |- e1 + e2 @ NumT
| OkTimes : forall n (G : ctx n) e1 e2,
  G |- e1 @ NumT -> G |- e2 @ NumT -> G |- e1 * e2 @ NumT
| OkCat : forall n (G : ctx n) s1 s2,
  G |- s1 @ StrT -> G |- s2 @ StrT -> G |- s1 ^ s2 @ StrT
| OkLen : forall n (G : ctx n) s, G |- s @ StrT -> G |- Len s @ NumT
| OkLet : forall n (G : ctx n) e1 t1 e2 t2,
  G |- e1 @ t1 -> Vector.cons _ t1 _ G |- e2 @ t2 -> G |- Let_ e1 e2 @ t2
where "G |- e @ t" := (wtexp G e t).

(*
Lemma nth_append_skip : forall {elt n m} (xs : Vector.t elt n) (ys : Vector.t elt m) xLm,
  nth_order (Vector.append xs ys) (n + x) = nth_order ys xLm.
Proof.
  intros elt n m xs ys x.
  induction x; induction n; dependent destruction xs; simpl; try reflexivity; apply IHn.
    intro; apply IHx.
Qed.
*)

(*
Lemma weaken_inv : forall {m} {G' : ctx m} {n} {G : ctx n} {x t},
  Vector.append G' G |- V (plusNat m x) @ t -> G |- V x @ nth G x.
Proof.
  intros m G' n G x t okv.
  dependent destruction okv; apply OkVar.
Qed.

Lemma typing_unicity : forall n (G : ctx n) (e : exp n) t,
  G |- e @ t -> forall t', G |- e @ t' -> t = t'.
Proof.
  intros n G e t oke t' oke'.
  dependent induction oke.
    dependent destruction oke'.
      reflexivity.
      apply nth_append_skip.
    assert (G |- V x @ nth G x) by apply OkVar.
    dependent destruction oke'.
      symmetry; apply nth_append_skip.
      reflexivity.
    cut (t1 = t0).
      destruct 1; apply IHoke2; assumption.
      apply IHoke1; assumption.
Qed.
*)

Lemma of_nat_lt_irr :
  forall n m (nLm1 nLm2 : n < m), Fin.of_nat_lt nLm1 = Fin.of_nat_lt nLm2.
Proof.
  induction n; intros m nLm1 nLm2; destruct m.
    inversion nLm1.
    reflexivity.
    inversion nLm1.
    unfold Fin.of_nat_lt.
    f_equal.
    apply IHn.
Qed.

Lemma nth_order_order_irr :
  forall {e} n (G : Vector.t e n) x (xLn : x < n) y (yLn : y < n),
    x = y -> nth_order G xLn = nth_order G yLn.
Proof.
  intros e n G x xLn y yLn xEy.
  destruct xEy.
  unfold nth_order, Fin.of_nat_lt.
  f_equal.
  apply of_nat_lt_irr.
Qed.

Lemma typing_unicity : forall n (G : ctx n) (e : exp) t,
  G |- e @ t -> forall t', G |- e @ t' -> t = t'.
Proof.
  intros n G e t oke t' oke'.
  dependent induction oke; dependent destruction oke'; try reflexivity.
    apply nth_order_order_irr; reflexivity.
    cut (t1 = t0).
      destruct 1; apply IHoke2; assumption.
      apply IHoke1; assumption.
Qed.

Fixpoint esuc (e : exp) : exp :=
  match e with
    | V x => V (1 + x)
    | Num c => Num c
    | Str s => Str s
    | c1 + c2 => esuc c1 + esuc c2
    | c1 * c2 => esuc c1 * esuc c2
    | s1 ^ s2 => esuc s1 ^ esuc s2
    | Len e1 => Len (esuc e1)
    | Let_ e1 e2 => Let_ (esuc e1) (esuc e2)
  end.

Fixpoint dist (n m : nat) :=
  match n, m with
    | n, O => n
    | O, m => m
    | S n', S m' => dist n' m'
  end.

(*
    m
Gl, t1, t2, Gr
==> |Gl| = m
==> x = m   => S x
    x = S m => x
*)

Fixpoint eswapn (m : nat) (e : exp) : exp :=
  match e with
    | V x =>
      if beq_nat x m then V (S m)
        else if beq_nat x (S m) then V m
          else V x
    | Num c => Num c
    | Str s => Str s
    | e1 + e2 => eswapn m e1 + eswapn m e2
    | e1 * e2 => eswapn m e1 * eswapn m e2
    | s1 ^ s2 => eswapn m s1 ^ eswapn m s2
    | Len e1 => Len (eswapn m e1)
    | Let_ e1 e2 => Let_ (eswapn m e1) (eswapn (S m) e2)
  end.
Definition eswap (e : exp) : exp := eswapn 0 e.

Lemma cons_append_comm : forall {e} x {n} (xs : Vector.t e n) {m} (ys : Vector.t e m),
  Vector.cons _ x _ (Vector.append xs ys) = Vector.append (Vector.cons _ x _ xs) ys.
Proof.
  intros e x n xs m ys.
  induction xs; simpl; reflexivity.
Qed.

Lemma eq_to_JMeq : forall A (x y : A), x = y -> x ~= y.
Proof.
  intros A x y xEy; rewrite xEy; reflexivity.
Qed.

Lemma strengthen_var : forall n (G : ctx n) x t t1,
  cons _ t1 _ G |- V (S x) @ t -> G |- V x @ t.
Proof.
  intros n G x t t1 okv.
  dependent destruction okv.
    unfold nth_order, nth.
    apply OkVar.
Qed.

Lemma nth_order_cons :
  forall {e n} (x : e) (xs : Vector.t e n) y (yLn : y < n) (SyLSn : S y < S n),
    nth_order xs yLn = nth_order (cons _ x _ xs) SyLSn.
Proof.
  intros e n x xs y yLn SyLSn.
  destruct y; destruct n.
    inversion yLn.
    reflexivity.
    inversion yLn.
    unfold nth_order, nth.
    simpl.
    f_equal.
    f_equal.
    apply of_nat_lt_irr.
Qed.

(* FIXME *)
Lemma nth_order_append :
  forall {e n} (ws : Vector.t e n) {m} (xs : Vector.t e m)
         y (yLm : y < m) z (zEp : z = y + n) (zL : z < n + m),
    nth_order xs yLm = nth_order (append ws xs) zL.
Proof.
  intros e n ws m xs y yLm z zL.
  induction ws.
    simpl; apply (nth_order_order_irr _ xs y yLm _ zL).
      rewrite plus_comm; reflexivity.
    rewrite <- cons_append_comm.
    rewrite (nth_order_cons ).
Qed.

Lemma weaken_var : forall n (G : ctx n) x t t1,
  G |- V x @ t -> cons _ t1 _ G |- V (S x) @ t.
Proof.
  intros n G x t t1 okv.
  dependent destruction okv.
    rewrite (nth_order_cons t1 _ _ _ (lt_n_S _ _ xLn)).
    apply OkVar.
Qed.

Lemma exchange : forall n (Gl : ctx n) m (Gr : ctx m) (e : exp) t t1 t2,
  Vector.append Gl (Vector.cons _ t1 _ (Vector.cons _ t2 _ Gr)) |- e @ t ->
  Vector.append Gl (Vector.cons _ t2 _ (Vector.cons _ t1 _ Gr)) |- eswapn (S n) e @ t.
Proof.
  intros n Gl m Gr e t t1 t2 oke.
  dependent induction oke.
  unfold eswapn.
  remember (beq_nat x (S n)).
  destruct b.
    assert (S n = x) by admit.
    destruct H.
    unfold nth_order, nth.
    simpl.

  induction n.
    destruct x.
      dependent destruction Gl.
      refine (OkVar _ (cons _ t2 _ (cons _ t1 _ Gr)) 1 _); apply lt_n_S; apply lt_0_Sn.
      destruct x.
        dependent destruction Gl.
        refine (OkVar _ (cons _ t2 _ (cons _ t1 _ Gr)) 0 _); apply lt_0_Sn.
        dependent destruction Gl.
        simpl in xLn.
        rewrite <- (nth_order_cons t1 (cons _ t2 _ Gr) _ (lt_S_n _ _ xLn) _).
        rewrite <- (nth_order_cons t2 Gr _ (lt_S_n _ _ (lt_S_n _ _ xLn)) _).
        apply weaken_var.
        apply weaken_var.
        apply OkVar.
    destruct x.
      destruct n.
      dependent destruction Gl.
      simpl.
      unfold nth_order, nth.
      simpl.
      assert (h = nth_order (cons typ h (S (S m)) (append Gl (cons typ t2 (S m) (cons typ t1 m Gr)))) xLn).
        unfold nth_order, nth.
        reflexivity.
      rewrite H.
      apply OkVar.
      simpl.
      dependent destruction Gl.
      unfold nth_order, nth.
      simpl.
      assert (h = nth_order (cons typ h (S (n + S (S m)))
                              (append Gl (cons typ t2 (S m) (cons typ t1 m Gr)))) xLn).
        unfold nth_order, nth.
        reflexivity.
      rewrite H.
      apply OkVar.

  destruct x.
    destruct n.
      dependent destruction Gl.
      simpl.
      refine (OkVar (S (S m)) (cons _ t2 _ (cons _ t1 _ Gr)) 1 _).
      apply le_n_S; apply le_n_S; apply le_0_n.
        destruct n; dependent destruction Gl.
          refine (OkVar _ (append (cons _ h _ Gl) (cons _ t2 _ (cons _ t1 _ Gr))) 0 _).
            apply le_n_S; apply le_0_n.
          refine (OkVar _ (append (cons _ h _ Gl) (cons _ t2 _ (cons _ t1 _ Gr))) 0 _).
            apply le_n_S; apply le_0_n.
      destruct n.
        dependent destruction Gl.
        destruct x.
          refine (OkVar _ (cons _ t2 _ (cons _ t1 _ Gr)) 0 _).
            apply le_n_S; apply le_0_n.
          simpl.
          simpl in xLn.
          rewrite <- (nth_order_cons t1 (cons _ t2 _ Gr) _ (lt_S_n _ _ xLn) _).
          rewrite <- (nth_order_cons t2 Gr _ (lt_S_n _ _ (lt_S_n _ _ xLn)) _).
          apply weaken_var.
          apply weaken_var.
          apply OkVar.
          simpl.
          dependent destruction Gl.
          destruct (dist x n).

| OkVar : forall n (G : ctx n) (x : nat) (xLn : x < n), G |- V x @ nth_order G xLn
        unfold nth_order, nth.
        simpl.
        apply OkVar.

    apply OkStr.
    apply OkNum.
    apply OkPlus; [apply IHoke1 | apply IHoke2]; reflexivity.
    apply OkTimes; [apply IHoke1 | apply IHoke2]; reflexivity.
    apply OkCat; [apply IHoke1 | apply IHoke2]; reflexivity.
    apply OkLen; apply IHoke; reflexivity.
    unfold eswap, eswapn.
    fold eswapn.
    apply (OkLet _ _ (eswapn n e1) t0 (eswapn (S n) e2)).
      apply IHoke1; reflexivity.
      rewrite cons_append_comm.
      apply (IHoke2 (S n) (cons _ t0 _ Gl) _ Gr t1 t2).
        reflexivity.
        apply eq_to_JMeq; apply cons_append_comm.
Qed.

Lemma weakening : forall n (G : ctx n) (e : exp n) t,
  G |- e @ t -> forall xt, Vector.cons _ xt _ G |- esuc e @ t.
Proof.
  intros n G e t oke.
  dependent induction oke; intros xt.
    apply (OkVar (S n) (Vector.cons _ xt _ G) (Fin.FS x)).
    apply OkStr.
    apply OkNum.
    simpl; apply OkPlus; [apply IHoke1 | apply IHoke2].
    apply OkTimes; [apply IHoke1 | apply IHoke2].
    apply OkCat; [apply IHoke1 | apply IHoke2].
    apply OkLen; apply IHoke.
    simpl. apply (OkLet (S n) (Vector.cons _ xt _ G) (esuc e1) t1).
      apply IHoke1.
      apply (IHoke2 t1).
      admit.
      admit.
Qed.

Import ListNotations.
Fixpoint fv' (vs : list var) (e : exp) : list var :=
  match e with
    | V x => if existsb (fun y => projT1 (bool_of_sumbool (VarEqDec.eq_dec x y))) vs
               then [x] else []
    | Num n => []
    | Str s => []
    | e1 + e2 => fv' vs e1 ++ fv' vs e2
    | e1 * e2 => fv' vs e1 ++ fv' vs e2
    | s1 ^ s2 => fv' vs s1 ++ fv' vs s2
    | Len e1 => fv' vs e1
    | Let_ y e1 e2 => fv' vs e1 ++ fv' (y :: vs) e2
  end.
Definition fv : exp -> list var := fv' [].

Program Fixpoint subst (b : exp) (x : var) (e : exp) : exp :=
  match e with
    | V y => match VarEqDec.eq_dec x y  with
               | left xEy => b
               | right xNy => V y
             end
    | Num n => Num n
    | Str s => Str s
    | e1 + e2 => Plus (subst b x e1) (subst b x e2)
    | e1 * e2 => Times (subst b x e1) (subst b x e2)
    | s1 ^ s2 => Cat (subst b x s1) (subst b x s2)
    | Len e1 => Len (subst b x e1)
    | Let_ y e1 e2 =>
  end.


From QuickChick Require Import QuickChick Tactics.
Require Import String. Open Scope string.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Import GenLow GenHigh.
Require Import List.
Import ListNotations.
Import QcDefaultNotation. Open Scope qc_scope.

Import QcDoNotation.

Set Bullet Behavior "Strict Subproofs".

Inductive ty : nat -> Type :=
| pi : forall n i , i <= n -> ty n.

Program Definition gen_ty (p : nat) :  G (ty p) :=
  bindGen' (choose (0, p)) (fun m H =>
  returnGen (pi p m  _) ).
Next Obligation.
  apply semChoose in H; auto.
Defined.