Require Import Reals Epsilon.
From Coquelicot Require Import Hierarchy.
From mathcomp Require Import ssreflect ssrnat ssrbool ssrfun eqtype bigop ssralg
  matrix fintype zmodp.
Require Import coquelicotComplements vect.
From ZornsLemma Require Import ZornsLemma.

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

Import List Classical_Prop Classical_Pred_Type Iter.

Local Open Scope classical_set_scope.
Local Open Scope ring_scope.

Module TopologicalSpace.

Record mixin_of (T : Type) := Mixin {
  open : set T -> Prop ;
  op_setU : forall (I : eqType) (f : I -> set T),
    (forall i, open (f i)) -> open (\bigcup_i f i) ;
  op_setI : forall (A B : set T), open A -> open B -> open (A `&` B) ;
  op_setT : open setT
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort; _ : class_of sort ; _ : Type }.
Local Coercion sort : type >-> Sortclass.
Definition class (cT : type) := let: Pack _ c _ := cT return class_of cT in c.

End ClassDef.

Module Exports.

Coercion sort : type >-> Sortclass.
Notation TopologicalSpace := type.

End Exports.

End TopologicalSpace.

Export TopologicalSpace.Exports.

Section TopologicalSpaceTheory.

Context {T : TopologicalSpace}.

Definition open (A : set T) :=
  TopologicalSpace.open (TopologicalSpace.class T) A.

Lemma open_setU (I : eqType) (f : I -> set T) :
  (forall i, open (f i)) -> open (\bigcup_i f i).
Proof. exact: TopologicalSpace.op_setU. Qed.

Lemma open_setI (A B : set T) : open A -> open B -> open (A `&` B).
Proof. exact: TopologicalSpace.op_setI. Qed.

Lemma open_setT : open setT.
Proof. exact: TopologicalSpace.op_setT. Qed.

Definition neighbour (p : T) (A : set T) := open A /\ A p.

Lemma neighbour_setT (p : T) : neighbour p setT.
Proof. by split=> //; apply: open_setT. Qed.

Lemma neighbour_setI (p : T) (A B : set T) :
  neighbour p A -> neighbour p B -> neighbour p (A `&` B).
Proof.
by move=> [Aop Ap] [Bop Bp]; split; [apply: open_setI|split].
Qed.

Definition cluster (F : set (set T)) (p : T) :=
  forall A B, F A -> neighbour p B -> A `&` B !=set0.

End TopologicalSpaceTheory.

(* Module FilteredSpace. *)

(* Record mixin_of (T : Type) := Mixin { *)
(*   locally : T -> set (set T) ; *)
(*   locally_filter : forall p : T, ProperFilter (locally p) *)
(* }. *)

(* Notation class_of := mixin_of (only parsing). *)

(* Section ClassDef. *)

(* Structure type := Pack { sort; _ : class_of sort ; _ : Type }. *)
(* Local Coercion sort : type >-> Sortclass. *)
(* Definition class (cT : type) := let: Pack _ c _ := cT return class_of cT in c. *)

(* End ClassDef. *)

(* Module Exports. *)

(* Coercion sort : type >-> Sortclass. *)
(* Notation FilteredSpace := type. *)

(* End Exports. *)

(* End FilteredSpace. *)

(* Export FilteredSpace.Exports. *)

(* Section FilteredSpaceTheory. *)

(* Context {T : FilteredSpace}. *)

(* Definition locally (p : T) := FilteredSpace.locally (FilteredSpace.class T) p. *)

(* Global Instance locally_filter (p : T) : ProperFilter (locally p). *)
(* Proof. exact: FilteredSpace.locally_filter. Qed. *)

(* End FilteredSpaceTheory. *)

(* Section FilteredIsTopological. *)

(* Context (T : FilteredSpace). *)

(* Definition filter_open (A : set T) := forall p, A p -> locally p A. *)

(* Lemma filter_op_setU (I : eqType) (f : I -> set T) : *)
(*   (forall i, filter_open (f i)) -> filter_open (\bigcup_i f i). *)
(* Proof. *)
(* by move=> fop p [i _ /fop]; apply: filter_imp => q fiq; exists i. *)
(* Qed. *)

(* Lemma filter_op_setI (A B : set T) : *)
(*   filter_open A -> filter_open B -> filter_open (A `&` B). *)
(* Proof. *)
(* by move=> Aop Bop p [/Aop p_A /Bop p_B]; apply: filter_and. *)
(* Qed. *)

(* Lemma filter_op_setT : filter_open setT. *)
(* Proof. by move=> ??; apply: filter_true. Qed. *)

(* Definition filteredTopologyMixin := *)
(*   TopologicalSpace.Mixin filter_op_setU filter_op_setI filter_op_setT. *)

(* Definition filteredTopologicalSpace := *)
(*   TopologicalSpace.Pack filteredTopologyMixin T. *)

(* End FilteredIsTopological. *)

(* Section TopologicalIsFiltered. *)

(* Context (T : TopologicalSpace). *)

(* Definition topo_locally (p : T) (A : set T) := *)
(*   exists B, neighbour p B /\ B `<=` A. *)

(* Instance topo_locally_filter (p : T) : ProperFilter (topo_locally p). *)
(* Proof. *)
(* split; first by move=> A [B [[_ Bp] sBA]]; exists p; apply: sBA. *)
(* split; first by exists setT; split=> //; apply: neighbour_setT. *)
(*   move=> A B [C [p_C sCA]] [D [p_D sDB]]. *)
(*   exists (C `&` D); split; first exact: neighbour_setI. *)
(*   by move=> q [/sCA Aq /sDB Bq]; split. *)
(* move=> A B sAB [C [p_C sCA]]. *)
(* by exists C; split=> //; apply: subset_trans sAB. *)
(* Qed. *)

(* Definition topologicalFilteredMixin := *)
(*   FilteredSpace.Mixin topo_locally_filter. *)

(* Definition topologicalFilteredSpace := *)
(*   FilteredSpace.Pack topologicalFilteredMixin T. *)

(* End TopologicalIsFiltered. *)

Definition continuous (S T : TopologicalSpace) (f : S -> T) :=
  forall A : set T, open A -> open (f @^-1` A).

Definition cv (U : TopologicalSpace) (F : set (set U)) p := F --> neighbour p.

Lemma cv_cluster (U : TopologicalSpace) (F : set (set U)) p :
  ProperFilter F ->
  cluster F p <-> exists G : set (set U), ProperFilter G /\ cv G p /\ F `<=` G.
Proof.
move=> Fproper; split=> [clFp|[G [Gproper [cvGp sFG]]] A B]; last first.
  by move=> /sFG GA /cvGp GB; apply:filter_ex; apply: filter_and.
exists ([set A | exists B, B `<=` A /\
  (\bigcup_(C in F) [set C `&` D | D in neighbour p]) B]); split.
  split.
    move=> A [B [sBA [C FC [D p_D CD_eqB]]]].
    by have := clFp _ _ FC p_D; rewrite CD_eqB => - [q /sBA]; exists q.
  split.
  - exists setT; split=> //; exists setT ; first exact: filter_true.
    by exists setT; [split=> //; apply: open_setT|apply: setIT].
  - move=> A1 A2 [B1 [sBA1 [C1 FC1 [D1 [D1op D1p] CD_eqB1]]]]
      [B2 [sBA2 [C2 FC2 [D2 [D2op D2p] CD_eqB2]]]].
    exists (B1 `&` B2); split; first by move=> ? [/sBA1 ? /sBA2].
    exists (C1 `&` C2); first exact: filter_and.
    exists (D1 `&` D2); first by split; [apply: open_setI|].
    by rewrite setIA [C2 `&` _]setIC setIA [_ `&` C2]setIC -setIA CD_eqB1
      CD_eqB2.
  - move=> A B sAB [C [sCA FIneighp_C]].
    by exists C; split=> //; apply: subset_trans sAB.
split.
  move=> A p_A; exists A; split=> //; exists setT; first exact: filter_true.
  by exists A => //; rewrite setIC subsetI_eq.
move=> A FA; exists A; split=> //; exists A => //; exists setT.
  by split=> //; apply: open_setT.
by rewrite subsetI_eq.
Qed.

Section Uniform_Topology.

Context {U : UniformSpace}.

Definition uopen (A : set U) := Hierarchy.open A.

Lemma uop_setU (I : eqType) (g : I -> set U) :
  (forall i, uopen (g i)) -> uopen (\bigcup_i g i).
Proof. by move=> gop; apply: open_bigcup => i _; apply: gop. Qed.

Lemma uop_setI (A B : set U) : uopen A -> uopen B -> uopen (A `&` B).
Proof. exact: open_and. Qed.

Lemma uop_setT : uopen setT.
Proof. exact: open_true. Qed.

Definition uniformTopologyMixin :=
  TopologicalSpace.Mixin uop_setU uop_setI uop_setT.

Canonical uniformTopologicalSpace :=
  TopologicalSpace.Pack uniformTopologyMixin U.

End Uniform_Topology.

Lemma neighbourP (U : UniformSpace) p (A : set U) :
  neighbour p A -> locally p A.
Proof. by move=> [Aop Ap]; apply: Aop. Qed.

Lemma clusterP (U : UniformSpace) (F : set (set U)) (p : U) :
  cluster F p <-> coquelicotComplements.cluster F p.
Proof.
split=> clFp A B FA p_B.
  suff [q [Aq Bint_q]] : A `&` interior B !=set0.
    by exists q; split=> //; apply: interior_subset.
  by apply: clFp FA _; split=> //; apply: open_interior.
by apply: clFp FA _; apply: neighbourP.
Qed.

Definition compact (T : TopologicalSpace) A := forall (F : set (set T)), F A ->
  ProperFilter F -> A `&` cluster F !=set0.

Lemma uniform_compactP (U : UniformSpace) (A : set U) :
  coquelicotComplements.compact A <-> compact A.
Proof.
split=> Aco F FA Fproper.
  have [p [Ap clFp]] : A `&` (coquelicotComplements.cluster F) !=set0.
    exact: Aco.
  by exists p; split=> //; apply/clusterP.
have [p [Ap clFp]] : A `&` (cluster F) !=set0 by exact: Aco.
by exists p; split=> //; apply/clusterP.
Qed.

Section Weak_topology.

Variable (S : Type) (T : TopologicalSpace) (f : S -> T).

Definition wopen (A : set S) := exists B : set T, open B /\ A = f @^-1` B.

Lemma wop_setU (I : eqType) (g : I -> set S) :
  (forall i, wopen (g i)) -> wopen (\bigcup_i g i).
Proof.
move=> gop.
have {gop} gop : forall i, {B : set T | open B /\ g i = f @^-1` B}.
  by move=> i; apply/constructive_indefinite_description/gop.
have g_preim : forall i, g i = f @^-1` sval (gop i).
  by move=> i; have [] := svalP (gop i).
have gopi : forall i, open (sval (gop i)).
  by move=> i; have [] := svalP (gop i).
exists (\bigcup_i sval (gop i)); split; first exact: open_setU.
apply/funext=> p; apply/propext; split=> [[i _]|[i _]].
  by rewrite g_preim; exists i.
by rewrite -[sval _ _]/((f @^-1` _) _) -g_preim; exists i.
Qed.

Lemma wop_setI (A B : set S) : wopen A -> wopen B -> wopen (A `&` B).
Proof.
move=> [C [Cop ->]] [D [Dop ->]]; exists (C `&` D).
by split; [apply: open_setI|rewrite preimage_setI].
Qed.

Lemma wop_setT : wopen setT.
Proof.
exists setT; split; first exact: open_setT.
by apply/funext=> ?; apply/propext; split.
Qed.

Definition weakTopologyMixin :=
  TopologicalSpace.Mixin wop_setU wop_setI wop_setT.

Definition weakTopologicalSpace := TopologicalSpace.Pack weakTopologyMixin T.

Lemma weak_continuous : @continuous weakTopologicalSpace _ f.
Proof. by move=> A Aop; exists A. Qed.

Lemma cv_image (F : set (set S)) (s : S) :
  f @` setT = setT -> Filter F ->
  @cv weakTopologicalSpace F s <-> cv [set f @` A | A in F] (f s).
Proof.
move=> fsurj Ffilt; split=> [cvFs|cvfFfs].
  move=> A [/weak_continuous [B [Bop preim_AeqB]] Afs].
  exists (f @^-1` B); last by rewrite -preim_AeqB image_preimage.
  by apply: cvFs; split; [apply/weak_continuous|rewrite -preim_AeqB].
move=> _ [[B [Bop ->]] Bfs].
have /cvfFfs [C FC <-] : neighbour (f s) B by [].
by apply: filter_imp FC; apply: preimage_image.
Qed.

End Weak_topology.

Lemma weak_weakest (S T : TopologicalSpace) (f : S -> T) :
  continuous f -> forall A : set S, @open (weakTopologicalSpace f) A -> open A.
Proof. by move=> fcont _ [B [Bop ->]]; apply: fcont. Qed.

Section Sup_topology.

Variable (T : Type) (I : eqType) (i : I)
  (Tm : I -> TopologicalSpace.mixin_of T).

Let TS := fun i => TopologicalSpace.Pack (Tm i) T.

Definition fin_setI (A : set T) :=
  exists (J : finType) (toI : J -> I) (f : J -> set T),
  (forall j : J, @open (TS (toI j)) (f j)) /\
  A = \bigcap_(j : J) f j.

Definition sopen (A : set T) :=
  exists (f : {J : Type & J -> set T}),
  (forall j, fin_setI (projT2 f j)) /\ A = \bigcup_(j : projT1 f) projT2 f j.

Lemma sop_setU (J : eqType) (f : J -> set T) :
  (forall j, sopen (f j)) -> sopen (\bigcup_j f j).
Proof.
move=> fop.
have {fop} fop : forall j, {g : {K : Type & K -> set T} |
  (forall k, fin_setI (projT2 g k)) /\ f j = \bigcup_k projT2 g k}.
  by move=> j; apply/constructive_indefinite_description/fop.
set K := fun j => projT1 (sval (fop j)).
set g := fun j => projT2 (sval (fop j)).
set K' := sigT K; set g' : K' -> set T := fun p => g (projT1 p) (projT2 p).
exists (existT _ K' g'); split.
  by move=> [j Kj] /=; have [finI _] := svalP (fop j); apply: finI.
apply/funext=> p; apply/propext; split=> /=.
  move=> [j _ fjp]; have [_ fjval] := svalP (fop j).
  by move: fjp; rewrite fjval => - [k]; exists (existT _ j k).
move=> [[j Kj] _ ?]; exists j => //.
by have [_ ->] := svalP (fop j); exists Kj.
Qed.

Lemma sop_setI (A B : set T) : sopen A -> sopen B -> sopen (A `&` B).
Proof.
move=> [[J1 f1] /= [finIf1] ->] [[J2 f2] /= [finIf2] ->]; rewrite bigcupI.
exists (existT (fun J => J -> set T) _ (fun ij => f1 ij.1 `&` f2 ij.2)).
split=> /=; last first.
  by apply/funext=> p; apply/propext; split=> [[ij _ []]|[ij]]; exists ij.
move=> ij.
have [K1 [toI1 [g1 [g1op ->]]]] := finIf1 ij.1.
have [K2 [toI2 [g2 [g2op ->]]]] := finIf2 ij.2.
rewrite bigcapI; exists [finType of sum K1 K2].
exists (fun k => match k with | inl i => toI1 i | inr j => toI2 j end).
exists (fun k => match k with | inl i => g1 i | inr j => g2 j end).
split; first by case=> ?; [apply: g1op|apply: g2op].
by apply/funext=> p; apply/propext; split=> Igp k _; apply: (Igp k); case: k.
Qed.

Lemma sop_setT : sopen setT.
Proof.
exists (existT _ 'I_1 (fun _ => setT)); split; last first.
  by apply/funext=> p; apply/propext; split=> // _; exists ord0.
move=> _ /=; exists [finType of unit]; exists (fun _ => i);
  exists (fun _ => setT).
split; first by move=> _; apply: open_setT.
by apply/funext=> p; apply/propext.
Qed.

Definition supTopologyMixin :=
  TopologicalSpace.Mixin sop_setU sop_setI sop_setT.

Definition supTopologicalSpace := TopologicalSpace.Pack supTopologyMixin T.

Lemma cv_sup (F : set (set T)) (t : T) :
  Filter F -> @cv supTopologicalSpace F t <-> forall i, @cv (TS i) F t.
Proof.
move=> Ffilt; split=> cvFt.
  move=> j A [Aop At]; apply: cvFt; split=> //.
  exists (existT _ 'I_1 (fun _ => A)); split; last first.
    by apply/funext=> p; apply/propext; split=> [Ap|[]] //; exists ord0.
  move=> _ /=; exists [finType of 'I_1]; exists (fun _ => j);
    exists (fun _ => A).
  split=> //; apply/funext=> p; apply/propext; split=> [?|Ap] //.
  exact: (Ap ord0).
move=> A [[[J f] /= [finIf ->]] [j _ fjt]].
suff : F (f j) by apply: filter_imp; exists j.
have [K [toI [g [gop fjval]]]] := finIf j.
rewrite fjval; apply: filter_bigcap.
  by exists (enum K) => k; split=> // _; apply/In_mem; rewrite mem_enum.
move=> k Kk; apply: (cvFt (toI k)); split; first exact: gop.
by move: fjt; rewrite fjval; apply.
Qed.

End Sup_topology.

Section Product_topology.

Variable (T : TopologicalSpace) (I : eqType) (i : I).

Definition prodTopologicalSpace :=
  supTopologicalSpace i (fun i => weakTopologyMixin (fun f : I -> T => f i)).

Lemma cv_prod (F : set (set (I -> T))) (f : I -> T) :
  Filter F ->
  @cv prodTopologicalSpace F f <->
  forall i, @cv (weakTopologicalSpace (fun g => g i)) F f.
Proof. exact: cv_sup. Qed.

End Product_topology.

Class UltraFilter T (F : set (set T)) := {
  ultra_proper :> ProperFilter F ;
  max_filter : forall G : set (set T), ProperFilter G -> F `<=` G -> G = F
}.

Lemma ultraFilterLemma T (F : set (set T)) :
  ProperFilter F -> exists G, UltraFilter G /\ F `<=` G.
Proof.
move=> Fproper.
set filter_preordset := ({G : set (set T) & ProperFilter G /\ F `<=` G}).
set preorder := fun G1 G2 : filter_preordset => projT1 G1 `<=` projT1 G2.
suff [G Gmax] : exists G : filter_preordset, premaximal preorder G.
  have [Gproper sFG] := projT2 G.
  exists (projT1 G); split=> //; split=> // H Hproper sGH.
  have sFH : F `<=` H by apply: subset_trans sGH.
  suff sHG : preorder (existT _ H (conj Hproper sFH)) G.
    by apply/funext => ?; apply/propext; split=> [/sHG|/sGH].
  exact: Gmax.
apply: ZornsLemmaForPreorders.
  by constructor=> [?|G H I sGH sHI ? /sGH /sHI].
move=> S Schain.
apply: or_ind (classic (Inhabited S)) => [[G SG]|S0]; last first.
  have sFF : F `<=` F by [].
  exists (existT _ F (conj Fproper sFF)).
  by move=> G SG; exfalso; apply: S0; apply: Inhabited_intro SG.
have [Gproper sFG] := projT2 G.
have USproper : ProperFilter (\bigcup_(H in S) projT1 H).
  constructor.
    move=> A [H SH HA]; have [Hproper _] := projT2 H.
    exact: filter_ex HA.
  constructor.
  - by exists G => //; apply: filter_true.
  - move=> A B [H1 SH1 H1A] [H2 SH2 H2B].
    apply: or_ind (Schain _ _ SH1 SH2) => [sH12|sH21].
      have /sH12 H2A := H1A; have [H2proper _] := projT2 H2.
      by exists H2 => //; apply: filter_and.
    have /sH21 H1B := H2B; have [H1proper _] := projT2 H1.
    by exists H1 => //; apply: filter_and.
  - move=> A B sAB [H SH HA]; have [Hproper _] := projT2 H.
    by exists H => //; apply: filter_imp HA.
have sFUS : F `<=` \bigcup_(H in S) projT1 H.
  by move=> A FA; exists G => //; apply: sFG.
exists (existT _ (\bigcup_(H in S) projT1 H) (conj USproper sFUS)).
by move=> H SH A HA; exists H.
Qed.

Lemma subset_fin_inter_ultra T Ti (f : family T Ti) :
  finite_inter f -> exists F, UltraFilter F /\ forall i, ind f i -> F (f i).
Proof.
move=> /fin_inter_proper /ultraFilterLemma [F [Fultra sfF]].
exists F; split=> // j fij; apply: sfF.
by exists (Ff (finfam_sing j f)); split; [split=> // ? ->|move=> ?; apply].
Qed.

Lemma ultra_cv_cluster (T : TopologicalSpace) (F : set (set T)) p :
  UltraFilter F -> cluster F p <-> cv F p.
Proof.
move=> Fultra; split.
  by move=> /cv_cluster [G [Gproper [cvGp /max_filter <-]]].
move=> cvFp; apply/cv_cluster; exists F.
by split; [apply: ultra_proper|split].
Qed.

Lemma compact_ultra (T : TopologicalSpace) A :
  compact A <->
  forall F : set (set T), F A -> UltraFilter F -> A `&` cv F !=set0.
Proof.
split=> Aco F FA Ffilt.
  suff [p [Ap clFp]] : A `&` cluster F !=set0.
    by exists p; split=> //; apply/ultra_cv_cluster.
  exact: Aco.
have [G [Gultra sFG]] := ultraFilterLemma Ffilt.
have /Aco /(_ Gultra) [p [Ap cvGp]] : G A by apply: sFG.
exists p; split=> //; apply/cv_cluster; exists G; split=> //.
exact: ultra_proper.
Qed.

Instance filter_image (U V : Type) (f : U -> V) (F : set (set U)) :
  f @` setT = setT -> Filter F -> Filter [set f @` A | A in F].
Proof.
move=> fsurj Ffilt; split.
- by exists setT => //; apply: filter_true.
- move=> _ _ [A FA <-] [B FB <-].
  exists (f @^-1` (f @` A `&` f @` B)); last by rewrite image_preimage.
  have sAB : A `&` B `<=` f @^-1` (f @` A `&` f @` B).
    by move=> x [Ax Bx]; split; exists x.
  by apply: filter_imp sAB _; apply: filter_and.
- move=> A B sAB [C FC fC_eqA].
  exists (f @^-1` B); last by rewrite image_preimage.
  apply: filter_imp FC => p Cp.
  by apply: sAB; rewrite -fC_eqA; exists p.
Qed.

Instance proper_image (U V : Type) (f : U -> V) (F : set (set U)) :
  f @` setT = setT -> ProperFilter F -> ProperFilter [set f @` A | A in F].
Proof.
move=> fsurj Fproper; split; last exact: filter_image.
by move=> _ [A FA <-]; have /filter_ex [p Ap] := FA; exists (f p); exists p.
Qed.

Fixpoint nodup T (l : list T) :=
  match l with
  | nil => True
  | t :: l => ~ In t l /\ nodup l
  end.

Lemma undup_list T (l : list T) :
  exists l', nodup l' /\ (In (A:=T))^~ l `=` (In (A:=T))^~ l'.
Proof.
elim: l => [|t l [l' [ndupl' leql']]]; first by exists nil.
case: (classic (In t l)) => [lt|nlt].
  exists l'; split=> // s; split=> [|ls]; last by right; apply/leql'.
  by apply: or_ind => [<-|ls]; apply/leql'.
exists (t :: l'); split; first by split=> // /leql'.
move=> s; split; by apply: or_ind => [->|/leql' l's]; [left|right].
Qed.

Lemma sub_finite_set T (A B : set T) : A `<=` B -> finite_set B -> finite_set A.
Proof.
move=> sAB [l' Beql']; have [l [ndupl l'eql]] := undup_list l'.
have Beql : B `=` (In (A:=T))^~ l by move=> t; apply: iff_trans (l'eql t).
move=> {Beql' l'eql l'}.
elim: l ndupl A B sAB Beql=> [_ A B sAB Beql|t l ihl [nlt ndupl A B sAB Beqtl]].
  by exists nil => ?; split=> // /sAB /Beql.
move: ihl; move=> /(_ ndupl) ihl.
case: (classic (A t)) => [At|nAt].
  suff [l' Anteql'] : finite_set (A `\ t).
    exists (t :: l') => s; split; last by apply: or_ind => [<-|/Anteql' []].
    move=> sA; case: (classic (s = t))=> [->|snet]; first by left.
    by right; apply/Anteql'.
  have sAntBnt : A `\ t `<=` B `\ t by move=> ? [/sAB].
  apply: ihl sAntBnt _ => s; split=> [[/Beqtl]|ls].
    by apply: or_ind => // -> /(_ (Logic.eq_refl _)).
  by split; [apply/Beqtl; right|move=> seqt; move: ls; rewrite seqt].
have sABnt : A `<=` B `\ t.
  by move=> s As; split; [apply: sAB|move=> seqt; apply: nAt; rewrite -seqt].
apply: ihl sABnt _ => s; split=> [[]|ls]; last first.
  by split; [apply/Beqtl; right|move=> seqt; apply: nlt; rewrite -seqt].
by move/Beqtl; apply: or_ind => [-> /(_ (Logic.eq_refl _))|].
Qed.

Lemma in_ultra_setVsetC U (F : set (set U)) (A : set U) :
  UltraFilter F -> F A \/ F (~` A).
Proof.
move=> Fultra; case: (classic (F (~` A))); first by right.
move=> nFnA; left.
have AIFn0 : forall B, F B -> A `&` B !=set0.
  apply: NNPP.
  move=> /not_all_ex_not [B /(imply_to_and (F _)) [FB /not_ex_all_not AB0]].
  by apply: nFnA; apply: filter_imp FB => p Bp Ap; apply: (AB0 p).
have : finite_inter (mkfamily (F `|` [set A]) id).
  move=> f [ind_sfFA ideqf].
  case: (classic (ind f A))=> [fA|nfA]; last first.
    have : sub_family (mkfamily F id) f.
      split=> // B fB; have /ind_sfFA := fB; apply: or_ind=> // BeqA.
      by exfalso; apply: nfA; rewrite -BeqA.
    exact: filter_finite_inter.
  suff [p [Ap fnAIp]] : A `&` inter_fam (mkfamily (ind f `\ A) f) !=set0.
    exists p => B fB; case: (classic (B = A)) => [->|BneA]; last exact: fnAIp.
    by have /ideqf := Ap; apply.
  apply: AIFn0; apply: filter_bigcap; last first.
    move=> B [fB BneA]; have /ind_sfFA := fB; apply: or_ind=> //.
    suff -> : f B = B by [].
    by apply/funext=> ?; apply/propext; apply: iff_sym; have := ideqf _ fB;
      apply.
  have sfinAfi : ind f `\ A `<=` ind f by move=> ? [].
  by apply: sub_finite_set sfinAfi _; apply: hfam.
move=> /subset_fin_inter_ultra [G [Gultra sFAG]].
have -> : F = G by apply/Logic.eq_sym/max_filter => B FB; apply: sFAG; left.
by apply: sFAG; right.
Qed.

Instance ultra_image (U V : Type) (f : U -> V) (F : set (set U)) :
  f @` setT = setT -> UltraFilter F -> UltraFilter [set f @` A | A in F].
Proof.
move=> fsurj Fultra; split; first exact: proper_image.
move=> G Gproper sfFG; apply/funext=> A; apply/propext; split; last exact: sfFG.
move=> GA; exists (f @^-1` A); last by rewrite image_preimage.
apply: or_ind (in_ultra_setVsetC (f @^-1` A) Fultra)=> // FnpreimA; exfalso.
have : ~ G (f @` (~` (f @^-1` A))).
  rewrite preimage_setC image_preimage // => GnA.
  by have /filter_ex [? []] : G (A `&` (~` A)) by apply: filter_and.
by apply; apply: sfFG; exists (~` (f @^-1` A)).
Qed.

Lemma tychonoff (T : TopologicalSpace) (I : eqType) (i : I) (A : I -> set T) :
  (forall i, compact (A i)) ->
  @compact (prodTopologicalSpace T i) [set f : I -> T | forall i, A i (f i)].
Proof.
move=> Aco; apply/compact_ultra => F FA Fultra.
set pr := fun i (f : I -> T) => f i.
have prT p f j :  pr j (fun k => if j == k then p else f k) = p.
  by rewrite /pr ifT.
have [f Af] := filter_ex _ FA.
have pr_surj : forall i, pr i @` setT = setT.
  move=> j; apply/funext => p; apply/propext; split => // _.
  by exists (fun k => if j == k then p else f k).
set pF := fun i => [set pr i @` B | B in F].
have pFultra : forall i, UltraFilter (pF i).
  by move=> j; apply ultra_image.
have pFA : forall i, pF i (A i).
  move=> j; exists [set w : I -> T | forall i, A i (w i)]=> //.
  apply/funext=> p; apply/propext; split; first by move=> [w Aw <-]; apply: Aw.
  move=> Ajp; exists (fun k => if j == k then p else f k) => // k.
  by case: (eqVneq j k)=> [<-|].
have cvpFA : forall i, {p | (A i `&` cv (pF i)) p}.
  move=> j; apply: constructive_indefinite_description.
  have [p [Ap clpFp]] : A j `&` cluster (pF j) !=set0.
    by apply: (Aco j).
  by exists p; split=> //; apply/ultra_cv_cluster.
set g := fun i => sval (cvpFA i).
exists g; split; first by move=> j; have [] := svalP (cvpFA j).
apply/cv_prod => j; apply/cv_image; first exact: pr_surj.
by have [] := svalP (cvpFA j).
Qed.

Lemma continuous_component (U : UniformSpace) n i (v : 'I_n -> U) :
  Continuity.continuous (fun w : 'I_n -> U => w i) v.
Proof. by move=> A [e vie_A]; exists e => w ve_w; apply/vie_A/ve_w. Qed.

Lemma bigRmin_gt (I : finType) (P : pred I) (i : I) F x :
  P i -> (forall j, P j -> x < F j) -> x < \big[Rmin/(F i)]_(j in P) F j.
Proof.
move=> Pi Fgtx; rewrite unlock.
elim: (index_enum I)=> [|j l ihl] /=; first exact: Fgtx.
have := Fgtx j; rewrite /in_mem /=; case: (P j) => // xltFj.
by apply: Rmin_glb_lt ihl; apply: xltFj.
Qed.

Lemma bigRmin_le (I : finType) (P : pred I) (i : I) F j :
  P i -> P j -> \big[Rmin/(F i)]_(k in P) F k <= F j.
Proof.
have := mem_index_enum j; rewrite unlock; elim: (index_enum I) => //= k l ihl.
rewrite seq.in_cons => /orP; apply: or_ind=> [/eqP<- Pi Pj|lj Pi Pj].
  by rewrite ifT //; apply: Rmin_l.
by case: (k \in P); [apply: Rle_trans (Rmin_r _ _) _|]; apply: ihl.
Qed.

Lemma row_simpl U n (w : 'rV[U]_n.+1) : \row_j (w ord0 j) = w.
Proof. by apply/rowP => ?; rewrite mxE. Qed.

Lemma vect_prod_topologyP (U : UniformSpace) n (A : set 'rV[U]_n.+1) :
  @open uniformTopologicalSpace A <->
  @open (prodTopologicalSpace _ ord0) [set f : 'I_n.+1 -> U | A (\row_j f j)].
Proof.
set B := [set f : 'I_n.+1 -> U | A (\row_j f j)].
set pr := fun j => (fun g : 'I_n.+1 -> U => g j).
split=> [Aop|].
  have {Aop} Bop : @open uniformTopologicalSpace B.
    move=> f /Aop [e fe_A]; exists e => g fe_g; apply: fe_A.
    by move=> ?; rewrite !mxE; apply: fe_g.
  have {Bop} Bop : forall f, B f -> {e : posreal | ball f e `<=` B}.
    by move=> f /Bop; apply: constructive_indefinite_description.
  exists (existT (fun J => J -> set ('I_n.+1 -> U)) _
    (fun f => interior (ball (projT1 f) (sval (Bop _ (projT2 f)))))) => /=.
  split; last first.
    apply/funext=> f; apply/propext; split=> [Bf|[[g Bg] _ bgf]].
      by exists (existT _ f Bf)=> //=; apply: locally_ball.
    by apply: (svalP (Bop _ Bg)); apply: interior_subset.
  move=> [f Bf] /=; exists [finType of 'I_n.+1]; exists id.
  exists (fun j => pr j @^-1` (interior (pr j @` (ball f (sval (Bop f Bf)))))).
  split.
    move=> j; exists (interior (pr j @` (ball f (sval (Bop f Bf))))).
    by split=> //; apply: open_interior.
  have prT p g i :  pr i (fun j => if i == j then p else g j) = p.
    by rewrite /pr ifT.
  apply/funext=> g; apply/propext; split.
    move=> [e ge_bf] j _; exists e=> p bpjgp.
    exists (fun i => if j == i then p else g i) => //; apply: ge_bf => i.
    by case: (eqVneq j i) => [<-|jnei] //; apply: ball_center.
  move=> Ibfg; have {Ibfg} Ibfg : forall j, {ej : posreal |
    ball (g j) ej `<=` pr j @` ball f (sval (Bop f Bf))}.
    by move=> j; apply: constructive_indefinite_description; apply: Ibfg.
  set e := fun j => sval (Ibfg j); set eps := \big[Rmin/(e ord0 : R)]_j e j.
  have eps_gt0 : 0 < eps by apply: bigRmin_gt => // j _; apply: cond_pos.
  exists (mkposreal _ eps_gt0) => h geps_h j.
  suff /(svalP (Ibfg j)) [h' bfh' <-] : ball (g j) (e j) (h j) by apply: bfh'.
  by apply: (ball_le _ eps); [apply: (@bigRmin_le _ predT)|apply: geps_h].
move=> [[J f] /= [finIf BeqUf]] v Av.
have : B (v ord0) by rewrite /B row_simpl.
rewrite BeqUf => - [j _ fjv]; have [K [toI [g [gop fjeqIg]]]] := finIf j.
suff [e ve_fj] : locally (v ord0 : _ -> _) (f j).
  exists e => w ve_w; rewrite -[w]row_simpl -[A _]/(B _) BeqUf; exists j => //.
  exact: ve_fj.
have := fjv; rewrite fjeqIg => Igv.
have v_g : forall k, locally (v ord0 : _ -> _) (g k).
  move=> k; have [C [Cop geqCpreim]] := gop k.
  rewrite geqCpreim; apply: locally_preimage (@continuous_component _ _ _ _) _.
  by apply: Cop; have := Igv k; rewrite geqCpreim; apply.
have {v_g} v_g : forall k, {ek : posreal | ball (v ord0 : _ -> _) ek `<=` g k}.
  by move=> k; apply: constructive_indefinite_description; apply: v_g.
have := mem_enum K; case: (enum K)=> [K0|k l kleqK].
  by exists (mkposreal _ Rlt_0_1)=> ?? i; have := K0 i.
set e := fun k => sval (v_g k); set eps := \big[Rmin/(e k : R)]_j e j.
have eps_gt0 : 0 < eps by apply: bigRmin_gt => // k' _; apply: cond_pos.
exists (mkposreal _ eps_gt0) => h geps_h k' _; apply: (svalP (v_g k')).
by apply: (ball_le _ eps); [apply: (@bigRmin_le _ predT)|apply: geps_h].
Qed.

Lemma simpl_row U n (f : 'I_n -> U) : (\row_j f j) ord0 = f.
Proof. by apply/funext=> ?; rewrite mxE. Qed.

Lemma vect_compactP (U : UniformSpace) n (A : set 'rV[U]_n.+1) :
  @compact uniformTopologicalSpace A <->
  @compact (prodTopologicalSpace _ ord0)
    [set f : 'I_n.+1 -> U | A (\row_j f j)].
Proof.
have set_simpl C : [set v : 'rV[U]_n.+1 | C (\row_j (v ord0 j))] = C.
  by apply/funext=> ?; rewrite row_simpl.
have simpl_set C : [set f | C ((\row_j f j) ord0)] = C.
  by apply/funext=> ?; rewrite simpl_row.
split=> Aco F FA Fproper.
  set G := [set [set v : 'rV[U]_n.+1 | B (v ord0)] | B in F].
  suff [v [Av clGv]] : A `&` @cluster uniformTopologicalSpace G !=set0.
    exists (v ord0); split; first by rewrite row_simpl.
    move=> B C FB [Cop Cv].
    have GB : G [set v | B (v ord0)] by exists B.
    have v_C : @neighbour uniformTopologicalSpace v [set v | C (v ord0)].
      by split=> //; apply/vect_prod_topologyP; rewrite simpl_set.
    by have [w []] := clGv _ _ GB v_C; exists (w ord0).
  have Gproper : ProperFilter G.
    split.
      move=> _ [B FB <-]; have /filter_ex [f Bf] := FB.
      by exists (\row_j f j); rewrite simpl_row.
    split.
    - by exists setT=> //; apply: filter_true.
    - by move=> _ _ [B FB <-] [C FC <-]; exists (B `&` C) => //;
        apply: filter_and.
    - move=> B C sBC [D FD DeqB].
      exists [set f | C (\row_j f j)] => //; apply: filter_imp FD.
      by move=> f Df; apply/sBC; rewrite -DeqB simpl_row.
  by apply: Aco; exists [set f | A (\row_j f j)].
set G := [set [set f : 'I_n.+1 -> U | B (\row_j f j)] | B in F].
suff [f [Af clGf]] :
  [set f | A (\row_j f j)] `&` @cluster (prodTopologicalSpace _ ord0) G !=set0.
  exists (\row_j f j); split=> // B C FB [Cop Cf].
  have GB : G [set g | B (\row_j g j)] by exists B.
  have f_C :
    @neighbour (prodTopologicalSpace _ ord0) f [set g | C (\row_j g j)].
    by split=> //; apply/vect_prod_topologyP.
  by have [g []] := clGf _ _ GB f_C; exists (\row_j g j).
have Gproper : ProperFilter G.
split.
  move=> _ [B FB <-]; have /filter_ex [v Bv] := FB.
  by exists (v ord0); rewrite row_simpl.
split.
- by exists setT => //; apply: filter_true.
- by move=> _ _ [B FB <-] [C FC <-]; exists (B `&` C) => //; apply: filter_and.
- move=> B C sBC [D FD DeqB].
  exists [set v : 'rV[U]_n.+1 | C (v ord0)]; last by rewrite simpl_set.
  by apply: filter_imp FD => v Dv; apply/sBC; rewrite -DeqB row_simpl.
by apply: Aco; exists A.
Qed.

Lemma vect_compact (U : UniformSpace) n (A : 'I_n.+1 -> set U) :
  (forall i, coquelicotComplements.compact (A i)) ->
  coquelicotComplements.compact
    [set v : 'rV[U]_n.+1 | forall i, A i (v ord0 i)].
Proof.
move=> Aico; apply/uniform_compactP/vect_compactP.
have -> :
  [set f | forall i, A i ((\row_j f j) ord0 i)] = [set f | forall i, A i (f i)].
  by apply/funext=> ?; rewrite simpl_row.
by apply: tychonoff => i; apply/uniform_compactP/Aico.
Qed.

Lemma bounded_closed_compact n (A : set 'rV[R]_n.+1) :
  is_bounded A -> is_closed A -> coquelicotComplements.compact A.
Proof.
move=> [M normAltM] Acl.
have Mnco : coquelicotComplements.compact
  [set v : 'rV[R]_n.+1 | forall i, seg (- M) M (v ord0 i)].
  by apply: (@vect_compact _ _ (fun _ => seg (- M) M)) => _; apply: seg_compact.
apply: subclosed_compact Acl Mnco _ => v /normAltM normvltM i.
suff /Rabs_def2 [/Rlt_le ? /Rlt_le] : norm (v ord0 i) < M by [].
apply: Rle_lt_trans normvltM.
apply: (@bigRmax_leq _ (fun i => norm (v ord0 i))) (Rle_refl _) _.
by move=> ?; apply: norm_ge_0.
Qed.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Inductive sll (x : ptr) (len : nat) (lo : nat) (hi : nat) (h : heap) : Prop :=
| sll_1 of (x) == (null) of
  (hi) == (0) /\ (len) == (0) /\ (lo) == (7) /\ h = empty
| sll_2 of ~~ ((x) == (null)) of
  exists (len1 : nat) (v : nat) (hi1 : nat) (lo1 : nat) (nxt : ptr),
  exists h_sll_nxtlen1lo1hi1_0,
  (0) <= (len1) /\ (0) <= (v) /\ (hi) == ((if (hi1) <= (v) then v else hi1)) /\ (len) == ((1) + (len1)) /\ (lo) == ((if (v) <= (lo1) then v else lo1)) /\ (v) <= (7) /\ h = x :-> (v) \+ x .+ 1 :-> (nxt) \+ h_sll_nxtlen1lo1hi1_0 /\ sll nxt len1 lo1 hi1 h_sll_nxtlen1lo1hi1_0.

Inductive srtl (x : ptr) (len : nat) (lo : nat) (hi : nat) (h : heap) : Prop :=
| srtl_1 of (x) == (null) of
  (hi) == (0) /\ (len) == (0) /\ (lo) == (7) /\ h = empty
| srtl_2 of ~~ ((x) == (null)) of
  exists (len1 : nat) (v : nat) (hi1 : nat) (lo1 : nat) (nxt : ptr),
  exists h_srtl_nxtlen1lo1hi1_1,
  (0) <= (len1) /\ (0) <= (v) /\ (hi) == ((if (hi1) <= (v) then v else hi1)) /\ (len) == ((1) + (len1)) /\ (lo) == ((if (v) <= (lo1) then v else lo1)) /\ (v) <= (7) /\ (v) <= (lo1) /\ h = x :-> (v) \+ x .+ 1 :-> (nxt) \+ h_srtl_nxtlen1lo1hi1_1 /\ srtl nxt len1 lo1 hi1 h_srtl_nxtlen1lo1hi1_1.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^256 - 4294968273
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 32;
    bitwidth := 32;
    s := 2^256;
    c := [(1, 4294968273)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Raft.

Section OneLeaderPerTermInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition one_leader_per_term (net : network) :=
    forall h h',
      currentTerm (nwState net h) = currentTerm (nwState net h') ->
      type (nwState net h) = Leader ->
      type (nwState net h') = Leader ->
      h = h'.

  Class one_leader_per_term_interface : Prop :=
    {
      one_leader_per_term_invariant :
        forall net,
          raft_intermediate_reachable net -> one_leader_per_term net
    }.
End OneLeaderPerTermInterface.


From iris.base_logic Require Import base_logic.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type*".
Import uPred.

(** Least and greatest fixpoint of a monotone function, defined entirely inside
    the logic.  *)
Class BIMonoPred {M} {A : ofeT} (F : (A → uPred M) → (A → uPred M)) := {
  bi_mono_pred Φ Ψ : ((□ ∀ x, Φ x -∗ Ψ x) → ∀ x, F Φ x -∗ F Ψ x)%I;
  bi_mono_pred_ne Φ : NonExpansive Φ → NonExpansive (F Φ)
}.
Arguments bi_mono_pred {_ _ _ _} _ _.
Local Existing Instance bi_mono_pred_ne.

Definition uPred_least_fixpoint {M} {A : ofeT}
    (F : (A → uPred M) → (A → uPred M)) (x : A) : uPred M :=
  (∀ Φ : A -n> uPredC M, □ (∀ x, F Φ x → Φ x) → Φ x)%I.

Definition uPred_greatest_fixpoint {M} {A : ofeT}
    (F : (A → uPred M) → (A → uPred M)) (x : A) : uPred M :=
  (∃ Φ : A -n> uPredC M, □ (∀ x, Φ x → F Φ x) ∧ Φ x)%I.

Section least.
  Context {M} {A : ofeT} (F : (A → uPred M) → (A → uPred M)) `{!BIMonoPred F}.

  Global Instance least_fixpoint_ne : NonExpansive (uPred_least_fixpoint F).
  Proof. solve_proper. Qed.

  Lemma least_fixpoint_unfold_2 x : F (uPred_least_fixpoint F) x ⊢ uPred_least_fixpoint F x.
  Proof.
    iIntros "HF" (Φ) "#Hincl".
    iApply "Hincl". iApply (bi_mono_pred _ Φ); last done.
    iIntros "!#" (y) "Hy". iApply "Hy". done.
  Qed.

  Lemma least_fixpoint_unfold_1 x :
    uPred_least_fixpoint F x ⊢ F (uPred_least_fixpoint F) x.
  Proof.
    iIntros "HF". iApply ("HF" $! (CofeMor (F (uPred_least_fixpoint F))) with "[#]").
    iIntros "!#" (y) "Hy". iApply bi_mono_pred; last done. iIntros "!#" (z) "?".
    by iApply least_fixpoint_unfold_2.
  Qed.

  Corollary least_fixpoint_unfold x :
    uPred_least_fixpoint F x ≡ F (uPred_least_fixpoint F) x.
  Proof.
    apply (anti_symm _); auto using least_fixpoint_unfold_1, least_fixpoint_unfold_2.
  Qed.

  Lemma least_fixpoint_ind (Φ : A → uPred M) `{!NonExpansive Φ} :
    □ (∀ y, F Φ y → Φ y) ⊢ ∀ x, uPred_least_fixpoint F x → Φ x.
  Proof.
    iIntros "#HΦ" (x) "HF". by iApply ("HF" $! (CofeMor Φ) with "[#]").
  Qed.

  Lemma least_fixpoint_strong_ind (Φ : A → uPred M) `{!NonExpansive Φ} :
    □ (∀ y, F (λ x, Φ x ∧ uPred_least_fixpoint F x) y → Φ y)
    ⊢ ∀ x, uPred_least_fixpoint F x → Φ x.
  Proof.
    trans (∀ x, uPred_least_fixpoint F x → Φ x ∧ uPred_least_fixpoint F x)%I.
    { iIntros "#HΦ". iApply least_fixpoint_ind; first solve_proper.
      iIntros "!#" (y) "H". iSplit; first by iApply "HΦ".
      iApply least_fixpoint_unfold_2. iApply (bi_mono_pred with "[] H").
      by iIntros "!# * [_ ?]". }
    by setoid_rewrite and_elim_l.
  Qed.
End least.

Section greatest.
  Context {M} {A : ofeT} (F : (A → uPred M) → (A → uPred M)) `{!BIMonoPred F}.

  Global Instance greatest_fixpoint_ne : NonExpansive (uPred_greatest_fixpoint F).
  Proof. solve_proper. Qed.

  Lemma greatest_fixpoint_unfold_1 x :
    uPred_greatest_fixpoint F x ⊢ F (uPred_greatest_fixpoint F) x.
  Proof.
    iDestruct 1 as (Φ) "[#Hincl HΦ]".
    iApply (bi_mono_pred Φ (uPred_greatest_fixpoint F)).
    - iIntros "!#" (y) "Hy". iExists Φ. auto.
    - by iApply "Hincl".
  Qed.

  Lemma greatest_fixpoint_unfold_2 x :
    F (uPred_greatest_fixpoint F) x ⊢ uPred_greatest_fixpoint F x.
  Proof.
    iIntros "HF". iExists (CofeMor (F (uPred_greatest_fixpoint F))).
    iIntros "{$HF} !#" (y) "Hy". iApply (bi_mono_pred with "[] Hy").
    iIntros "!#" (z) "?". by iApply greatest_fixpoint_unfold_1.
  Qed.

  Corollary greatest_fixpoint_unfold x :
    uPred_greatest_fixpoint F x ≡ F (uPred_greatest_fixpoint F) x.
  Proof.
    apply (anti_symm _); auto using greatest_fixpoint_unfold_1, greatest_fixpoint_unfold_2.
  Qed.

  Lemma greatest_fixpoint_coind (Φ : A → uPred M) `{!NonExpansive Φ} :
    □ (∀ y, Φ y → F Φ y) ⊢ ∀ x, Φ x → uPred_greatest_fixpoint F x.
  Proof. iIntros "#HΦ" (x) "Hx". iExists (CofeMor Φ). by iIntros "{$Hx} !#". Qed.
End greatest.


Require Export SystemFR.ReducibilityOpenEquivalent.

Opaque reducible_values.
Opaque makeFresh.

#[export] Hint Rewrite PeanoNat.Nat.leb_le: primitives.
#[export] Hint Rewrite PeanoNat.Nat.leb_gt: primitives.
#[export] Hint Rewrite PeanoNat.Nat.ltb_lt: primitives.
#[export] Hint Rewrite PeanoNat.Nat.ltb_ge: primitives.

Opaque PeanoNat.Nat.leb.
Opaque PeanoNat.Nat.ltb.

Lemma last_step_unary_primitive:
  forall v1 v o,
    cbv_value v1 ->
    cbv_value v ->
    unary_primitive o v1 ~>* v ->
    unary_primitive o v1 ~> v.
Proof.
  intros.
  inversion H1; clear H1.
  destruct v; steps; step_inversion cbv_value.
  force_invert scbv_step;
    repeat star_smallstep_value || steps || constructor || no_step ; eauto with values smallstep ;
      try solve [eapply scbv_step_same; [constructor |]; steps].
Qed.

Lemma last_step_binary_primitive:
  forall v1 v2 v o,
    cbv_value v1 ->
    cbv_value v2 ->
    cbv_value v ->
    binary_primitive o v1 v2 ~>* v ->
    binary_primitive o v1 v2 ~> v.
Proof.
  intros.
  inversion H2; clear H2.
  destruct v; steps; step_inversion cbv_value.
  force_invert scbv_step;
    repeat star_smallstep_value || steps || constructor || no_step ; eauto with values smallstep ;
      try solve [eapply scbv_step_same; [constructor |]; steps].
Qed.

Ltac last_step_binary_primitive :=
    apply_anywhere last_step_binary_primitive; eauto with values;
    force_invert scbv_step; repeat build_nat_inj || steps || autorewrite with primitives in *.

Ltac reducible_values_primitive :=
  unfold reduces_to; intros ;
  repeat simp_red ;
  repeat is_nat_value_buildable ; steps ;
      (unfold closed_term; repeat light || rewrite app_eq_nil_iff ; eauto 1 with fv wf erased) ||
      (eexists; split; [ idtac | (apply star_one; constructor; try reflexivity )] ;
      eauto using is_nat_value_build_nat).

Ltac reducible_primitive f :=
  intros;
  repeat top_level_unfold reduces_to || steps || simp_red || is_nat_value_buildable;
  eapply star_backstep_reducible;
    try apply star_smallstep_binary_primitive; eauto ;
    repeat steps || list_utils || simp_red || apply f || eauto with values cbvlemmas ; t_closer.

(* Not *)

Lemma reducible_values_primitive_Not:
  forall ρ v1,
    [ ρ ⊨ v1 : T_bool ]v ->
    [ ρ ⊨ unary_primitive Not v1 : T_bool ].
Proof.
  unfold reduces_to;
    repeat steps || simp_red; t_closer ;
      solve [
          eexists ; split ; [idtac | (apply star_one ; constructor ; try reflexivity)] ;  steps ].
  Qed.

Lemma reducible_primitive_Not:
  forall ρ t1,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_bool ] ->
    [ ρ ⊨ unary_primitive Not t1 : T_bool ].
Proof.
  reducible_primitive reducible_values_primitive_Not.
  Qed.

Lemma open_reducible_primitive_Not:
  forall Θ Γ t1,
    [ Θ;Γ ⊨ t1 : T_bool ] ->
    [ Θ;Γ ⊨ unary_primitive Not t1 : T_bool ].
Proof. unfold open_reducible; steps;  eauto using reducible_primitive_Not. Qed.

(* Plus *)

Lemma reducible_values_primitive_Plus:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Plus v1 v2 : T_nat ].
Proof. reducible_values_primitive. Qed.

Lemma reducible_primitive_Plus:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Plus t1 t2 : T_nat ].
Proof. reducible_primitive reducible_values_primitive_Plus. Qed.

Lemma open_reducible_primitive_Plus:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Plus t1 t2 : T_nat].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Plus. Qed.

(* Minus *)

Lemma reducible_values_primitive_Minus:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ binary_primitive Geq v1 v2 ≡ ttrue ] ->
    [ ρ ⊨ binary_primitive Minus v1 v2 : T_nat ].
Proof.
  reducible_values_primitive.
  apply_anywhere equivalent_true.
  last_step_binary_primitive.
Qed.

Lemma reducible_primitive_Minus:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ binary_primitive Geq t1 t2 ≡ ttrue ] ->
    [ ρ ⊨ binary_primitive Minus t1 t2 : T_nat ].
Proof. reducible_primitive reducible_values_primitive_Minus.
       eapply equivalent_trans; eauto.
       apply equivalent_sym, equivalent_star; eauto with cbvlemmas smallstep wf fv; t_closer.
       apply star_smallstep_binary_primitive; eauto with values.
Qed.

Lemma open_reducible_primitive_Minus:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Geq t1 t2 ≡ ttrue ] ->
    [Θ; Γ ⊨ binary_primitive Minus t1 t2 : T_nat].
Proof. unfold open_reducible, open_equivalent; steps;
         eauto using reducible_primitive_Minus.
Qed.

(* Mul *)

Lemma reducible_values_primitive_Mul:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Mul v1 v2 : T_nat ].
Proof. reducible_values_primitive. Qed.

Lemma reducible_primitive_Mul:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Mul t1 t2 : T_nat ].
Proof. reducible_primitive reducible_values_primitive_Mul. Qed.

Lemma open_reducible_primitive_Mul:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Mul t1 t2 : T_nat].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Mul. Qed.

(* Div *)

Lemma reducible_values_primitive_Div:
  forall ρ v1 v2 ,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ binary_primitive Gt v2 zero ≡ ttrue] ->
    [ ρ ⊨ binary_primitive Div v1 v2 : T_nat ].
Proof. reducible_values_primitive. apply_anywhere equivalent_true. last_step_binary_primitive. Qed.

Lemma reducible_primitive_Div:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ binary_primitive Gt t2 zero ≡ ttrue] ->
    [ ρ ⊨ binary_primitive Div t1 t2 : T_nat ].
Proof.
  reducible_primitive reducible_values_primitive_Div.
  eapply equivalent_trans; eauto.
  apply equivalent_sym, equivalent_star; eauto with cbvlemmas smallstep wf fv; t_closer.
Qed.

Lemma open_reducible_primitive_Div:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Gt t2 zero ≡ ttrue ] ->
    [Θ; Γ ⊨ binary_primitive Div t1 t2 : T_nat].
Proof. unfold open_reducible, open_equivalent; steps ; eauto using reducible_primitive_Div. Qed.

(* Lt *)

Lemma reducible_values_primitive_Lt:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Lt v1 v2 : T_bool ].
Proof. reducible_values_primitive. steps. Qed.

Lemma reducible_primitive_Lt:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Lt t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Lt. Qed.

Lemma open_reducible_primitive_Lt:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Lt t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Lt. Qed.

(* Leq *)

Lemma reducible_values_primitive_Leq:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Leq v1 v2 : T_bool ].
Proof. reducible_values_primitive. steps. Qed.

Lemma reducible_primitive_Leq:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Leq t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Leq. Qed.

Lemma open_reducible_primitive_Leq:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Leq t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Leq. Qed.

(* Gt *)

Lemma reducible_values_primitive_Gt:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Gt v1 v2 : T_bool ].
Proof. reducible_values_primitive. steps. Qed.

Lemma reducible_primitive_Gt:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Gt t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Gt. Qed.

Lemma open_reducible_primitive_Gt:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Gt t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Gt. Qed.

(* Geq *)

Lemma reducible_values_primitive_Geq:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Geq v1 v2 : T_bool ].
Proof. reducible_values_primitive. steps. Qed.

Lemma reducible_primitive_Geq:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Geq t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Geq. Qed.

Lemma open_reducible_primitive_Geq:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Geq t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Geq. Qed.

(* Eq *)

Lemma reducible_values_primitive_Eq:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Eq v1 v2 : T_bool ].
Proof. reducible_values_primitive. steps. Qed.

Lemma reducible_primitive_Eq:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Eq t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Eq. Qed.

Lemma open_reducible_primitive_Eq:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Eq t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Eq. Qed.

(* Neq *)

Lemma reducible_values_primitive_Neq:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_nat ]v ->
    [ ρ ⊨ v2 : T_nat ]v ->
    [ ρ ⊨ binary_primitive Neq v1 v2 : T_bool ].
Proof. reducible_values_primitive. steps. Qed.

Lemma reducible_primitive_Neq:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_nat ] ->
    [ ρ ⊨ t2 : T_nat ] ->
    [ ρ ⊨ binary_primitive Neq t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Neq. Qed.

Lemma open_reducible_primitive_Neq:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_nat] ->
    [Θ; Γ ⊨ t2 : T_nat] ->
    [Θ; Γ ⊨ binary_primitive Neq t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Neq. Qed.

(* And *)

Lemma reducible_values_primitive_And:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_bool ]v ->
    [ ρ ⊨ v2 : T_bool ]v ->
    [ ρ ⊨ binary_primitive And v1 v2 : T_bool ].
Proof. reducible_values_primitive. Qed.

Lemma reducible_primitive_And:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_bool ] ->
    [ ρ ⊨ t2 : T_bool ] ->
    [ ρ ⊨ binary_primitive And t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_And. Qed.

Lemma open_reducible_primitive_And:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_bool] ->
    [Θ; Γ ⊨ t2 : T_bool] ->
    [Θ; Γ ⊨ binary_primitive And t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_And. Qed.

(* Or *)

Lemma reducible_values_primitive_Or:
  forall ρ v1 v2,
    [ ρ ⊨ v1 : T_bool ]v ->
    [ ρ ⊨ v2 : T_bool ]v ->
    [ ρ ⊨ binary_primitive Or v1 v2 : T_bool ].
Proof. reducible_values_primitive. Qed.

Lemma reducible_primitive_Or:
  forall ρ t1 t2,
    valid_interpretation ρ ->
    [ ρ ⊨ t1 : T_bool ] ->
    [ ρ ⊨ t2 : T_bool ] ->
    [ ρ ⊨ binary_primitive Or t1 t2 : T_bool ].
Proof. reducible_primitive reducible_values_primitive_Or. Qed.

Lemma open_reducible_primitive_Or:
  forall Θ Γ t1 t2,
    [Θ; Γ ⊨ t1 : T_bool] ->
    [Θ; Γ ⊨ t2 : T_bool] ->
    [Θ; Γ ⊨ binary_primitive Or t1 t2 : T_bool].
Proof. unfold open_reducible; steps ; eauto using reducible_primitive_Or. Qed.

#[export]
Hint Resolve open_reducible_primitive_And: primitives.
#[export]
Hint Resolve open_reducible_primitive_Div: primitives.
#[export]
Hint Resolve open_reducible_primitive_Eq: primitives.
#[export]
Hint Resolve open_reducible_primitive_Geq: primitives.
#[export]
Hint Resolve open_reducible_primitive_Gt: primitives.
#[export]
Hint Resolve open_reducible_primitive_Leq: primitives.
#[export]
Hint Resolve open_reducible_primitive_Lt: primitives.
#[export]
Hint Resolve open_reducible_primitive_Minus: primitives.
#[export]
Hint Resolve open_reducible_primitive_Mul: primitives.
#[export]
Hint Resolve open_reducible_primitive_Neq: primitives.
#[export]
Hint Resolve open_reducible_primitive_Or: primitives.
#[export]
Hint Resolve open_reducible_primitive_Plus: primitives.
#[export]
Hint Resolve open_reducible_primitive_Not: primitives.


(************************************************
 *          Row Subtyping - Kinding             *
 *                 Leo White                    *
 ************************************************)

(* Lemmas and automation for kinding proofs *)

Set Implicit Arguments.
Require Import LibLN Utilities Cofinite Disjoint Definitions
        Opening FreeVars Environments Subst Wellformedness
        Weakening Substitution.

(* *************************************************************** *)
(** Kinding inversions *)

Lemma kinding_constructor_inv : forall E1 E2 c T K,
    kinding E1 E2 (typ_constructor c T) K ->
    kinding (E1 & E2) empty T knd_type.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_or_inv_l : forall E1 E2 T1 T2 cs1 cs2 cs3,
    kinding E1 E2 (typ_or cs1 cs2 T1 T2) (knd_row cs3) ->
    kinding E1 E2 T1 (knd_row cs1).
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_or_inv_r : forall E1 E2 T1 T2 cs1 cs2 cs3,
    kinding E1 E2 (typ_or cs1 cs2 T1 T2) (knd_row cs3) ->
    kinding E1 E2 T2 (knd_row cs2).
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_proj_inv : forall E1 E2 T cs1 cs2 cs3,
    kinding E1 E2 (typ_proj cs1 cs2 T) (knd_row cs3) ->
    kinding E1 E2 T (knd_row cs1).
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_variant_inv : forall E1 E2 T,
    kinding E1 E2 (typ_variant T) knd_type ->
    kinding (E1 & E2) empty T knd_row_all.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_arrow_inv_l : forall E1 E2 T1 T2,
    kinding E1 E2 (typ_arrow T1 T2) knd_type ->
    kinding (E1 & E2) empty T1 knd_type.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_arrow_inv_r : forall E1 E2 T1 T2,
    kinding E1 E2 (typ_arrow T1 T2) knd_type ->
    kinding (E1 & E2) empty T2 knd_type.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_ref_inv : forall E1 E2 T,
    kinding E1 E2 (typ_ref T) knd_type ->
    kinding (E1 & E2) empty T knd_type.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_prod_inv_l : forall E1 E2 T1 T2,
    kinding E1 E2 (typ_prod T1 T2) knd_type ->
    kinding (E1 & E2) empty T1 knd_type.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_prod_inv_r : forall E1 E2 T1 T2,
    kinding E1 E2 (typ_prod T1 T2) knd_type ->
    kinding (E1 & E2) empty T2 knd_type.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_meet_inv_l : forall E1 E2 T1 T2 K,
    kinding E1 E2 (typ_meet T1 T2) K ->
    kinding E1 E2 T1 K.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_meet_inv_r : forall E1 E2 T1 T2 K,
    kinding E1 E2 (typ_meet T1 T2) K ->
    kinding E1 E2 T2 K.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_join_inv_l : forall E1 E2 T1 T2 K,
    kinding E1 E2 (typ_join T1 T2) K ->
    kinding E1 E2 T1 K.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

Lemma kinding_join_inv_r : forall E1 E2 T1 T2 K,
    kinding E1 E2 (typ_join T1 T2) K ->
    kinding E1 E2 T2 K.
Proof.
  introv Hk.
  inversion Hk; auto.
Qed.

(* *************************************************************** *)
(** Kinding of an unrolling *)

Lemma kinding_unroll : forall E1 E2 T1 K,
    kinding E1 E2 (typ_mu K T1) K ->
    type_environment E1 ->
    type_environment_extension E1 E2 ->
    kinding E1 E2 (typ_open T1 (typ_mu K T1 :: nil)) K.
Proof.
  introv Hk He1 He2.
  inversion Hk; subst.
  pick_fresh X.
  rewrite typ_subst_intro with (Xs := cons X nil);
    auto with wellformed.
  rewrite <- tenv_subst_fresh
    with (E := E1) (Xs := cons X nil) (Us := cons (typ_mu K T1) nil);
    auto.
  rewrite <- tenv_subst_fresh
    with (E := E2) (Xs := cons X nil) (Us := cons (typ_mu K T1) nil);
    auto.
  apply kinding_typ_subst_rec_single with (R := rng_all K); auto.
  rewrite tenv_subst_fresh; auto.
  rewrite tenv_subst_fresh; auto.
Qed.

(* *************************************************************** *)
(** Kinding from valid type environments *)

Lemma valid_range_from_valid_tenv_rec : forall X v E1 E2 E3 R,
    valid_tenv_rec v E1 E2 E3 ->
    binds X R E2 ->
    valid_range v (E1 & E2) E3 R.
Proof.
  introv He Hb.
  induction He.
  - apply binds_empty_inv in Hb; contradiction.
  - destruct (binds_push_inv Hb) as [[Hx Hbnd]|[Hx Hbnd]]; subst.
    + rewrite concat_assoc.
      apply valid_range_extend; auto.
      rewrite <- concat_empty_l.
      auto with wellformed.
    + rewrite concat_assoc.
      apply valid_range_extend; auto.
      rewrite <- concat_empty_l.
      auto with wellformed.
Qed.

Lemma valid_range_empty_from_valid_tenv_extension :
  forall X v E1 E2 R,
    valid_tenv_extension v E1 E2 ->
    binds X R E2 ->
    valid_range v (E1 & E2) empty R.
Proof.
  introv He Hb.
  eauto using valid_range_from_valid_tenv_rec.
Qed.

Lemma valid_range_empty_from_valid_tenv : forall X v E R,
    valid_tenv v E ->
    binds X R E ->
    valid_range v E empty R.
Proof.
  introv He Hb.
  rewrite <- concat_empty_l with (E := E).
  eauto using valid_range_empty_from_valid_tenv_extension.
Qed.

Lemma kinding_empty_from_valid_tenv_lower : forall X v E T1 T2 K,
    valid_tenv v E ->
    binds X (Rng T1 T2 K) E ->
    kinding E empty T1 K.
Proof.
  introv He Hb.
  assert (valid_range v E empty (Rng T1 T2 K)) as Hr
    by eauto using valid_range_empty_from_valid_tenv.
  inversion Hr; subst.
  assumption.
Qed.

Lemma kinding_empty_from_valid_tenv_upper : forall X v E T1 T2 K,
    valid_tenv v E ->
    binds X (Rng T1 T2 K) E ->
    kinding E empty T2 K.
Proof.
  introv He Hb.
  assert (valid_range v E empty (Rng T1 T2 K)) as Hr
    by eauto using valid_range_empty_from_valid_tenv.
  inversion Hr; subst.
  assumption.
Qed.

Lemma valid_range_from_valid_tenv : forall X v E1 E2 R,
    valid_tenv v E1 ->
    type_environment_extension E1 E2 ->
    binds X R E1 ->
    valid_range v E1 E2 R.
Proof.
  introv He1 He2 Hb.
  rewrite <- concat_empty_r with (E := E2).
  rewrite <- concat_empty_l with (E := E2).
  apply valid_range_weakening_rec;
    autorewrite with rew_env_concat; auto with wellformed.
  eauto using valid_range_empty_from_valid_tenv.
Qed.

Lemma kinding_from_valid_tenv_lower : forall X v E1 E2 T1 T2 K,
    valid_tenv v E1 ->
    type_environment_extension E1 E2 ->
    binds X (Rng T1 T2 K) E1 ->
    kinding E1 E2 T1 K.
Proof.
  introv He1 He2 Hb.
  assert (valid_range v E1 E2 (Rng T1 T2 K)) as Hr
    by eauto using valid_range_from_valid_tenv.
  inversion Hr; subst.
  assumption.
Qed.

Lemma kinding_from_valid_tenv_upper : forall X v E1 E2 T1 T2 K,
    valid_tenv v E1 ->
    type_environment_extension E1 E2 ->
    binds X (Rng T1 T2 K) E1 ->
    kinding E1 E2 T2 K.
Proof.
  introv He1 He2 Hb.
  assert (valid_range v E1 E2 (Rng T1 T2 K)) as Hr
    by eauto using valid_range_from_valid_tenv.
  inversion Hr; subst.
  assumption.
Qed.

(* *************************************************************** *)
(** Extending valid type environments *)

Lemma valid_tenv_rec_extend : forall v E1 E2 E3 E4,
  valid_tenv_rec v E1 E2 E3 ->
  valid_tenv_rec v (E1 & E2) E4 E3 ->
  type_environment E1 ->
  type_environment_extension (E1 & E2) E3 ->
  valid_tenv_rec v E1 (E2 & E4) E3.
Proof.
  introv He1 He2 He3 He4.
  remember (E1 & E2) as E12.
  induction He2; subst; autorewrite with rew_env_concat; auto.
  apply valid_tenv_rec_push; autorewrite with rew_env_concat; auto.
  auto using valid_tenv_rec_weakening_rec_r,
    type_environment_extension_rev_push with wellformed.
Qed.

Lemma valid_tenv_extend : forall v E1 E2,
  valid_tenv v E1 ->
  valid_tenv_extension v E1 E2 ->
  valid_tenv v (E1 & E2).
Proof.
  unfold valid_tenv in *.
  unfold valid_tenv_extension in *.
  introv He1 He2.
  apply valid_tenv_rec_extend;
    autorewrite with rew_env_concat; auto.
Qed.

Lemma valid_tenv_extension_empty : forall v E,
  valid_tenv_extension v E empty.
Proof.
  auto.
Qed.

(* *************************************************************** *)
(** Kinding from valid store types *)

Lemma kinding_from_valid_store_type : forall l E T P,
    valid_store_type E P ->
    binds l T P ->
    kinding E empty T knd_type.
Proof.
  introv Hp Hb.
  induction Hp.
  - apply binds_empty_inv in Hb; contradiction.
  - destruct (binds_push_inv Hb) as [[Hx Hbnd]|[Hx Hbnd]];
      subst; auto.
Qed.

(* *************************************************************** *)
(** Kinding from type equality *)

Lemma type_equal_kinding_both : forall v E1 E2 Q1 Q2 T1 T2 K,
    type_equal v E1 E2 Q1 Q2 T1 T2 K ->
    valid_tenv v E1 ->
    valid_tenv_extension v E1 E2 ->
    kinding E1 E2 T1 K /\ kinding E1 E2 T2 K.
Proof.
  introv Hte He1 He2.
  induction Hte;
    repeat match goal with
    | IH : valid_tenv v (E1 & E2) ->
           valid_tenv_extension v (E1 & E2) empty ->
           kinding (E1 & E2) empty _ _ /\
           kinding (E1 & E2) empty _ _ |- _ =>
      destruct IH; auto using valid_tenv_extend
    | IH : valid_tenv v E1 ->
           valid_tenv_extension v E1 E2 ->
           kinding E1 E2 _ _ /\
           kinding E1 E2 _ _ |- _ =>
      destruct IH; auto
    | _ => auto
    end.
  - split; eauto using kinding_weakening_rec_empty,
      kinding_from_valid_tenv_lower with wellformed.
  - split; eauto using kinding_weakening_rec_empty,
      kinding_from_valid_tenv_upper with wellformed.
Qed.

Lemma type_equal_kinding_1 : forall v E1 E2 Q1 Q2 T1 T2 K,
    type_equal v E1 E2 Q1 Q2 T1 T2 K ->
    valid_tenv v E1 ->
    valid_tenv_extension v E1 E2 ->
    kinding E1 E2 T1 K.
Proof.
  introv Hte He1 He2.
  destruct (type_equal_kinding_both Hte He1 He2).
  assumption.
Qed.

Lemma type_equal_kinding_2 : forall v E1 E2 Q1 Q2 T1 T2 K,
    type_equal v E1 E2 Q1 Q2 T1 T2 K ->
    valid_tenv v E1 ->
    valid_tenv_extension v E1 E2 ->
    kinding E1 E2 T2 K.
Proof.
  introv Hte He1 He2.
  destruct (type_equal_kinding_both Hte He1 He2).
  assumption.
Qed.

Lemma subtype_kinding_1 : forall v E1 E2 Q1 Q2 T1 T2 K,
    subtype v E1 E2 Q1 Q2 T1 T2 K ->
    valid_tenv v E1 ->
    valid_tenv_extension v E1 E2 ->
    kinding E1 E2 T1 K.
Proof.
  introv Hs He1 He2.
  unfold subtype in Hs.
  eauto using type_equal_kinding_1.
Qed.

Lemma subtype_kinding_2 : forall v E1 E2 Q1 Q2 T1 T2 K,
    subtype v E1 E2 Q1 Q2 T1 T2 K ->
    valid_tenv v E1 ->
    valid_tenv_extension v E1 E2 ->
    kinding E1 E2 T2 K.
Proof.
  introv Hs He1 He2.
  unfold subtype in Hs.
  assert (kinding E1 E2 (typ_meet T1 T2) K) as Hk
    by eauto using type_equal_kinding_2.
  inversion Hk; subst.
  auto.
Qed.

(* *************************************************************** *)
(** Valid empty schemes *)

Lemma valid_scheme_aux_empty : forall v L E T,
  kinding E empty T knd_type
  <-> valid_scheme_aux v L E (sch_empty T).
Proof.
  split.
  - introv Hk.
    constructor.
    introv Hf.
    apply fresh_zero in Hf.
    unfold bind_sch_ranges; subst; simpl;
      rewrite instance_vars_empty_nil, singles_nil.
    constructor; autorewrite with rew_env_concat; auto.
  - introv Hv.
    inversion Hv; subst.
    assert
      (valid_tenv_extension_and_type v E
        (nil ~: sch_empty T)
        (instance_vars (sch_empty T) nil))
      as Het by auto.
    inversion Het;
      unfold bind_sch_ranges in *; subst; simpl in *;
      rewrite instance_vars_empty_nil, singles_nil in *;
        autorewrite with rew_env_concat in *; auto.
Qed.

Lemma valid_scheme_empty : forall v E T,
  kinding E empty T knd_type
  <-> valid_scheme v E (sch_empty T).
Proof.
  split.
  - introv Hk.
    rewrite valid_scheme_aux_empty
      with (v := v) (L := \{}) (E := E) in Hk.
    eauto.
  - introv Hv.
    inversion Hv; subst.
    rewrite valid_scheme_aux_empty
      with (v := v) (L := L) (E := E).
    auto.
Qed.

(* Direct versions for using with auto. *)

Lemma valid_scheme_empty_of_kinding : forall v E T,
  kinding E empty T knd_type ->
  valid_scheme v E (sch_empty T).
Proof.
  introv Hk.
  rewrite <- valid_scheme_empty.
  assumption.
Qed.

Lemma kinding_of_valid_scheme_empty : forall v E T,
  valid_scheme v E (sch_empty T) ->
  kinding E empty T knd_type.
Proof.
  introv Hs.
  rewrite valid_scheme_empty with (v := v).
  assumption.
Qed.

(* *************************************************************** *)
(** Useful lemma to avoid needing rewrite *)

Lemma kinding_concat_empty : forall E1 E2 T K,
    kinding E1 E2 T K ->
    kinding (E1 & empty) E2 T K.
Proof.
  introv Hk.
  rewrite concat_empty_r.
  assumption.
Qed.

(* *************************************************************** *)
(** Kinding automation *)

Ltac extract_kinding E H T :=
  match type of H with
  | kinding ?E3 ?E4 T _ =>
    match E with
    | E3 & E4 =>
      match goal with
      | He : type_environment_extension E3 E4 |- _ =>
        exact (kinding_extend_empty H He)
      | He : valid_tenv_extension _ E3 E4 |- _ =>
        exact (kinding_extend_empty H
                 (wellformed_valid_tenv_extension He))
      end
    | _ =>
      match E3 with
      | E & empty =>
        rewrite <- concat_empty_r with (E := E); exact H
      | _ => exact H
      end
    end
  | kinding _ _ (typ_constructor _ _) _ =>
      extract_kinding E (kinding_constructor_inv H) T
  | kinding _ _ (typ_or _ _ ?T1 _) _ =>
      match T1 with
      | context[T] => extract_kinding E (kinding_or_inv_l H) T
      | _ => extract_kinding E (kinding_or_inv_r H) T
      end
  | kinding _ _ (typ_proj _ _ _) _ =>
      extract_kinding E (kinding_proj_inv H) T
  | kinding _ _ (typ_variant _) _ =>
      extract_kinding E (kinding_variant_inv H) T
  | kinding _ _ (typ_arrow ?T1 _) _ =>
      match T1 with
      | context[T] => extract_kinding E (kinding_arrow_inv_l H) T
      | _ => extract_kinding E (kinding_arrow_inv_r H) T
      end
  | kinding _ _ (typ_ref _) _ =>
      extract_kinding E (kinding_ref_inv H) T
  | kinding _ _ (typ_prod ?T1 _) _ =>
      match T1 with
      | context[T] => extract_kinding E (kinding_prod_inv_l H) T
      | _ => extract_kinding E (kinding_prod_inv_r H) T
      end
  | kinding _ _ (typ_meet ?T1 _) _ =>
      match T1 with
      | context[T1] => extract_kinding E (kinding_meet_inv_l H) T
      | _ => extract_kinding E (kinding_meet_inv_r H) T
      end
  | kinding _ _ (typ_join ?T1 _) _ =>
      match T1 with
      | context[T] => extract_kinding E (kinding_join_inv_l H) T
      | _ => extract_kinding E (kinding_join_inv_r H) T
      end
  end.

Ltac kinding :=
  match goal with
  | |- kinding ?E _ ?T _ =>
    match goal with
    | H : kinding _ _ ?Th _ |- _ =>
      match Th with
      | context[T] => extract_kinding E H T
      end
    | H : ?Pre -> kinding _ _ ?Th _, Hpre : ?Pre |- _ =>
      match Th with
      | context[T] => extract_kinding E (H Hpre) T
      end
    | H : ?Pre1 -> ?Pre2 -> kinding _ _ ?Th _,
      Hpre1 : ?Pre1, Hpre2 : ?Pre2 |- _ =>
      match Th with
      | context[T] => extract_kinding E (H Hpre1 Hpre2) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : type_equal ?v ?E1 ?E2 _ _ ?Th _ _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E (type_equal_kinding_1 H He1 He2) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : type_equal ?v ?E1 ?E2 _ _ _ ?Th _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E (type_equal_kinding_2 H He1 He2) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : type_equal ?v (?E1 & ?E2) empty _ _ ?Th _ _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E
            (type_equal_kinding_1 H (valid_tenv_extend He1 He2)
               (@valid_tenv_rec_empty v (E1 & E2) empty)) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : type_equal ?v (?E1 & ?E2) empty _ _ _ ?Th _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E
            (type_equal_kinding_2 H (valid_tenv_extend He1 He2)
               (@valid_tenv_rec_empty v (E1 & E2) empty)) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : subtype ?v ?E1 ?E2 _ _ ?Th _ _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E (subtype_kinding_1 H He1 He2) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : subtype ?v ?E1 ?E2 _ _ _ ?Th _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E (subtype_kinding_2 H He1 He2) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : subtype ?v (?E1 & ?E2) empty _ _ ?Th _ _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E
            (subtype_kinding_1 H (valid_tenv_extend He1 He2)
               (@valid_tenv_rec_empty v (E1 & E2) empty)) T
      end
    | He1 : valid_tenv ?v ?E1,
      He2 : valid_tenv_extension ?v ?E1 ?E2,
      H : subtype ?v (?E1 & ?E2) empty _ _ _ ?Th _ |- _ =>
      match Th with
      | context[T] =>
          extract_kinding E
            (subtype_kinding_2 H (valid_tenv_extend He1 He2)
               (@valid_tenv_rec_empty v (E1 & E2) empty)) T
      end
    end
  end.

Hint Extern 1 (kinding _ _ _ _) => kinding : kinding.


(** * Typeclass-based reification *)
Require Import Reify.ReifyCommon.
Require Import Coq.NArith.NArith.
Require Import PerformanceExperiments.Harness.
Require Import Reify.BenchmarkExtraUtil.

Module TypeClasses.
  Local Generalizable Variables x y rx ry f rf.
  Section with_var.
    Context {var : Type}.

    Class reify_of (term : nat) (rterm : @expr var) := {}.
    Global Program Instance reify_NatMul `{reify_of x rx, reify_of y ry}
      : reify_of (x * y) (rx * ry).
    Global Program Instance reify_LetIn `{reify_of x rx}
            `{forall y ry, reify_of y (Var ry) -> reify_of (f y) (rf ry)}
      : reify_of (dlet y := x in f y) (elet ry := rx in rf ry).
    Global Program Instance reify_S `{reify_of x rx}
      : reify_of (S x) (NatS rx).
    Global Program Instance reify_O
      : reify_of O NatO.
  End with_var.

  (** This must be commented out pre-8.6; it tells Coq to not try to
    infer reifications if it doesn't fully know what term it's
    reifying. *)

  Global Hint Mode reify_of - ! - : typeclass_instances.
  Global Hint Opaque Nat.mul Let_In : typeclass_instances.

  Ltac reify var x :=
    let c := constr:(_ : @reify_of var x _) in
    lazymatch type of c with
    | reify_of _ ?rx => rx
    end.

  Ltac Reify x :=
    let c := constr:(fun var => (_ : @reify_of var x _)) in
    lazymatch type of c with
    | forall var, reify_of _ (@?rx var) => rx
    end.

  Ltac do_Reify_rhs
       do_trans
       restart_timer_norm_reif finish_timing_norm_reif
       restart_timer_actual_reif finish_timing_actual_reif
       restart_timer_eval_lazy finish_timing_eval_lazy
       time_lazy_beta_iota time_transitivity_Denote_rv
       _ :=
    do_Reify_rhs_of
      do_trans
      restart_timer_norm_reif finish_timing_norm_reif
      restart_timer_actual_reif finish_timing_actual_reif
      restart_timer_eval_lazy finish_timing_eval_lazy
      time_lazy_beta_iota time_transitivity_Denote_rv
      Reify ().
  Ltac post_Reify_rhs do_trans _ := ReifyCommon.post_Reify_rhs do_trans ().
  Ltac Reify_rhs
       do_trans
       restart_timer_norm_reif finish_timing_norm_reif
       restart_timer_actual_reif finish_timing_actual_reif
       restart_timer_eval_lazy finish_timing_eval_lazy
       time_lazy_beta_iota time_transitivity_Denote_rv
       _ :=
    Reify_rhs_of
      do_trans
      restart_timer_norm_reif finish_timing_norm_reif
      restart_timer_actual_reif finish_timing_actual_reif
      restart_timer_eval_lazy finish_timing_eval_lazy
      time_lazy_beta_iota time_transitivity_Denote_rv
      Reify ().
End TypeClasses.

Module TypeClassesBodyHOAS.
  (** We can also do typeclass-based reification where we return the
      reified term in the body rather than in the type.  However, this
      method does not work well with PHOAS binders, because there's no
      easy way to eliminate the dependency on the unreified binder
      when reifying to PHOAS. *)

  Local Generalizable Variables x y rx ry f rf.
  Class reify_of (term : nat) := rterm : @expr nat.

  (** We use [| 100] so this gets triggered late. *)

  Global Instance reify_Var {x} : reify_of x | 100 := Var x.
  Global Instance reify_NatMul `{rx : reify_of x, ry : reify_of y}
    : reify_of (x * y) := (rx * ry)%expr.
  Global Instance reify_S `{rx : reify_of x}
    : reify_of (S x) := NatS rx.
  Global Instance reify_O
    : reify_of O := NatO.
  Global Instance reify_LetIn `{rx : reify_of x}
         `{rf : forall y, reify_of (f y)}
    : reify_of (dlet y := x in f y) := (elet ry := rx in rf ry)%expr.

  (** This must be commented out pre-8.6; it tells Coq to not try to
    infer reifications if it doesn't fully know what term it's
    reifying. *)

  Global Hint Mode reify_of ! : typeclass_instances.
  Global Hint Opaque Nat.mul Let_In : typeclass_instances.

  Ltac Reify x :=
    constr:(_ : @reify_of x).

  Ltac do_Reify_rhs
       do_trans
       restart_timer_norm_reif finish_timing_norm_reif
       restart_timer_actual_reif finish_timing_actual_reif
       restart_timer_eval_lazy finish_timing_eval_lazy
       time_lazy_beta_iota time_transitivity_Denote_rv
       _ :=
    do_Reify_rhs_of_with_denote
      do_trans
      restart_timer_norm_reif finish_timing_norm_reif
      restart_timer_actual_reif finish_timing_actual_reif
      restart_timer_eval_lazy finish_timing_eval_lazy
      time_lazy_beta_iota time_transitivity_Denote_rv
      Reify denote ().
  Ltac post_Reify_rhs do_trans _ := ReifyCommon.post_Reify_rhs do_trans ().
  Ltac Reify_rhs
       do_trans
       restart_timer_norm_reif finish_timing_norm_reif
       restart_timer_actual_reif finish_timing_actual_reif
       restart_timer_eval_lazy finish_timing_eval_lazy
       time_lazy_beta_iota time_transitivity_Denote_rv
       _ :=
    Reify_rhs_of
      do_trans
      restart_timer_norm_reif finish_timing_norm_reif
      restart_timer_actual_reif finish_timing_actual_reif
      restart_timer_eval_lazy finish_timing_eval_lazy
      time_lazy_beta_iota time_transitivity_Denote_rv
      Reify ().
End TypeClassesBodyHOAS.

Module TypeClassesBodyFlatPHOAS.
  (** We can also do typeclass-based reification where we return the
      reified term in the body rather than in the type.  However, this
      method does not work well with binders, because there's no easy
      way to eliminate the dependency on the unreified binder when
      reifying to PHOAS. *)

  Local Generalizable Variables x y rx ry f rf.
  Section with_var.
    Context {var : Type}.

    Class reify_of (term : nat) := rterm : @expr var.
    Global Instance reify_NatMul `{rx : reify_of x, ry : reify_of y}
      : reify_of (x * y) := (rx * ry)%expr.
    Global Instance reify_S `{rx : reify_of x}
      : reify_of (S x) := NatS rx.
    Global Instance reify_O
      : reify_of O := NatO.
  End with_var.

  (** This must be commented out pre-8.6; it tells Coq to not try to
    infer reifications if it doesn't fully know what term it's
    reifying. *)

  Global Hint Mode reify_of - ! : typeclass_instances.
  Global Hint Opaque Nat.mul : typeclass_instances.

  Ltac reify var x :=
    constr:(_ : @reify_of var x).

  Ltac Reify x :=
    constr:(_ : forall var, @reify_of var x).

  Ltac do_Reify_rhs
       do_trans
       restart_timer_norm_reif finish_timing_norm_reif
       restart_timer_actual_reif finish_timing_actual_reif
       restart_timer_eval_lazy finish_timing_eval_lazy
       time_lazy_beta_iota time_transitivity_Denote_rv
       _ :=
    do_Reify_rhs_of
      do_trans
      restart_timer_norm_reif finish_timing_norm_reif
      restart_timer_actual_reif finish_timing_actual_reif
      restart_timer_eval_lazy finish_timing_eval_lazy
      time_lazy_beta_iota time_transitivity_Denote_rv
      Reify ().
  Ltac post_Reify_rhs do_trans _ := ReifyCommon.post_Reify_rhs do_trans ().
  Ltac Reify_rhs
       do_trans
       restart_timer_norm_reif finish_timing_norm_reif
       restart_timer_actual_reif finish_timing_actual_reif
       restart_timer_eval_lazy finish_timing_eval_lazy
       time_lazy_beta_iota time_transitivity_Denote_rv
       _ :=
    Reify_rhs_of
      do_trans
      restart_timer_norm_reif finish_timing_norm_reif
      restart_timer_actual_reif finish_timing_actual_reif
      restart_timer_eval_lazy finish_timing_eval_lazy
      time_lazy_beta_iota time_transitivity_Denote_rv
      Reify ().
End TypeClassesBodyFlatPHOAS.

Global Open Scope N_scope.

Inductive kind := BodyFlatPHOAS | ArgPHOAS (is_flat : bool) | BodyHOAS (is_flat : bool).
Inductive representation_kind := PHOAS | HOAS.
Definition is_flat (k : kind) : bool
  := match k with
     | BodyFlatPHOAS => true
     | ArgPHOAS is_flat => is_flat
     | BodyHOAS is_flat => is_flat
     end.
Definition representation (k : kind) : representation_kind
  := match k with
     | BodyFlatPHOAS => PHOAS
     | ArgPHOAS _ => PHOAS
     | BodyHOAS _ => HOAS
     end.

Definition args_of_size (k : kind) (s : size) : list N
  := match representation k, is_flat k, s with
     | _    , _    , Sanity => List.firstn 4 sequence
     | PHOAS, true , SuperFast => args_of_max_n   300
     | PHOAS, true , Fast      => args_of_max_n  6000
     | PHOAS, true , Medium    => args_of_max_n 30000
     | PHOAS, false, SuperFast => args_of_max_n    40
     | PHOAS, false, Fast      => args_of_max_n    85
     | PHOAS, false, Medium    => args_of_max_n   300
     | PHOAS, _    , _         => args_of_max_n 30000
     | HOAS , true , SuperFast => args_of_max_n   300
     | HOAS , true , Fast      => args_of_max_n  6000
     | HOAS , true , Medium    => args_of_max_n 30000
     | HOAS , false, SuperFast => args_of_max_n   185
     | HOAS , false, Fast      => args_of_max_n   375
     | HOAS , false, Medium    => args_of_max_n  2000
     | HOAS , _    , _         => args_of_max_n 30000
     end.

Ltac mkgoal kind := let is_flat := (eval cbv in (is_flat kind)) in BenchmarkExtraUtil.mkgoal is_flat (* n *).
Ltac redgoal _ := idtac.
Ltac describe_goal n := idtac "Params: n=" n.
Ltac time_solve_goal kind sz :=
  let kind := (eval cbv in kind) in
  let is_flat := (eval cbv in (is_flat kind)) in
  let representation := (eval cbv in (representation kind)) in
  let do_cbv := BenchmarkExtraUtil.do_cbv in
  let do_trans := (eval lazy in (do_trans_of_size sz)) in
  let pre_reify := BenchmarkExtraUtil.noop in
  let do_reify := lazymatch kind with
                  | BodyFlatPHOAS => TypeClassesBodyFlatPHOAS.do_Reify_rhs do_trans
                  | ArgPHOAS _ => TypeClasses.do_Reify_rhs do_trans
                  | BodyHOAS _ => TypeClassesBodyHOAS.do_Reify_rhs do_trans
                  end in
  let post_reify := lazymatch kind with
                    | BodyFlatPHOAS => TypeClassesBodyFlatPHOAS.post_Reify_rhs do_trans
                    | ArgPHOAS _ => TypeClasses.post_Reify_rhs do_trans
                    | BodyHOAS _ => TypeClassesBodyHOAS.post_Reify_rhs do_trans
                    end in
  lazymatch kind with
  | BodyFlatPHOAS
    => let restart_timer_norm_reif   := ltac:(restart_timer                   "norm reif for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_norm_reif   := ltac:(finish_timing ("Tactic call")   "norm reif for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*)) in
       let restart_timer_actual_reif := ltac:(restart_timer                 "actual reif for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_actual_reif := ltac:(finish_timing ("Tactic call") "actual reif for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*)) in
       let restart_timer_eval_lazy   := ltac:(restart_timer                   "eval lazy for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_eval_lazy   := ltac:(finish_timing ("Tactic call")   "eval lazy for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*)) in
       let time_lazy_beta_iota tac   := time                             "lazy beta iota for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*) tac in
       let time_transitivity_Denote_rv tac := time             "transitivity (Denote rv) for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*) tac in
       let do_reify := do_reify restart_timer_norm_reif finish_timing_norm_reif restart_timer_actual_reif finish_timing_actual_reif restart_timer_eval_lazy finish_timing_eval_lazy time_lazy_beta_iota time_transitivity_Denote_rv in
       let do_cbv     x := time  "cbv for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*) do_cbv     x in
       let pre_reify  x := time  "pre for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*) pre_reify  x in
       let do_reify   x := time "reif for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*) do_reify   x in
       let post_reify x := time "post for TypeClassesBodyFlatPHOAS with big_flat"(*-regression-quadratic*) post_reify x in
       BenchmarkExtraUtil.time_solve_goal do_cbv pre_reify do_reify post_reify
  | ArgPHOAS true
    => let restart_timer_norm_reif   := ltac:(restart_timer                   "norm reif for TypeClassesPHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_norm_reif   := ltac:(finish_timing ("Tactic call")   "norm reif for TypeClassesPHOAS with big_flat"(*-regression-quadratic*)) in
       let restart_timer_actual_reif := ltac:(restart_timer                 "actual reif for TypeClassesPHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_actual_reif := ltac:(finish_timing ("Tactic call") "actual reif for TypeClassesPHOAS with big_flat"(*-regression-quadratic*)) in
       let restart_timer_eval_lazy   := ltac:(restart_timer                   "eval lazy for TypeClassesPHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_eval_lazy   := ltac:(finish_timing ("Tactic call")   "eval lazy for TypeClassesPHOAS with big_flat"(*-regression-quadratic*)) in
       let time_lazy_beta_iota tac   := time                             "lazy beta iota for TypeClassesPHOAS with big_flat"(*-regression-quadratic*) tac in
       let time_transitivity_Denote_rv tac := time             "transitivity (Denote rv) for TypeClassesPHOAS with big_flat"(*-regression-quadratic*) tac in
       let do_reify := do_reify restart_timer_norm_reif finish_timing_norm_reif restart_timer_actual_reif finish_timing_actual_reif restart_timer_eval_lazy finish_timing_eval_lazy time_lazy_beta_iota time_transitivity_Denote_rv in
       let do_cbv     x := time  "cbv for TypeClassesPHOAS with big_flat"(*-regression-quadratic*) do_cbv     x in
       let pre_reify  x := time  "pre for TypeClassesPHOAS with big_flat"(*-regression-quadratic*) pre_reify  x in
       let do_reify   x := time "reif for TypeClassesPHOAS with big_flat"(*-regression-quadratic*) do_reify   x in
       let post_reify x := time "post for TypeClassesPHOAS with big_flat"(*-regression-quadratic*) post_reify x in
       BenchmarkExtraUtil.time_solve_goal do_cbv pre_reify do_reify post_reify
  | ArgPHOAS false
    => let restart_timer_norm_reif   := ltac:(restart_timer                   "norm reif for TypeClassesPHOAS with big"(*-regression-quadratic*)) in
       let finish_timing_norm_reif   := ltac:(finish_timing ("Tactic call")   "norm reif for TypeClassesPHOAS with big"(*-regression-quadratic*)) in
       let restart_timer_actual_reif := ltac:(restart_timer                 "actual reif for TypeClassesPHOAS with big"(*-regression-quadratic*)) in
       let finish_timing_actual_reif := ltac:(finish_timing ("Tactic call") "actual reif for TypeClassesPHOAS with big"(*-regression-quadratic*)) in
       let restart_timer_eval_lazy   := ltac:(restart_timer                   "eval lazy for TypeClassesPHOAS with big"(*-regression-quadratic*)) in
       let finish_timing_eval_lazy   := ltac:(finish_timing ("Tactic call")   "eval lazy for TypeClassesPHOAS with big"(*-regression-quadratic*)) in
       let time_lazy_beta_iota tac   := time                             "lazy beta iota for TypeClassesPHOAS with big"(*-regression-quadratic*) tac in
       let time_transitivity_Denote_rv tac := time             "transitivity (Denote rv) for TypeClassesPHOAS with big"(*-regression-quadratic*) tac in
       let do_reify := do_reify restart_timer_norm_reif finish_timing_norm_reif restart_timer_actual_reif finish_timing_actual_reif restart_timer_eval_lazy finish_timing_eval_lazy time_lazy_beta_iota time_transitivity_Denote_rv in
       let do_cbv     x := time  "cbv for TypeClassesPHOAS with big"(*-regression-quadratic*) do_cbv     x in
       let pre_reify  x := time  "pre for TypeClassesPHOAS with big"(*-regression-quadratic*) pre_reify  x in
       let do_reify   x := time "reif for TypeClassesPHOAS with big"(*-regression-quadratic*) do_reify   x in
       let post_reify x := time "post for TypeClassesPHOAS with big"(*-regression-quadratic*) post_reify x in
       BenchmarkExtraUtil.time_solve_goal do_cbv pre_reify do_reify post_reify
  | BodyHOAS true
    => let restart_timer_norm_reif   := ltac:(restart_timer                   "norm reif for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_norm_reif   := ltac:(finish_timing ("Tactic call")   "norm reif for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*)) in
       let restart_timer_actual_reif := ltac:(restart_timer                 "actual reif for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_actual_reif := ltac:(finish_timing ("Tactic call") "actual reif for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*)) in
       let restart_timer_eval_lazy   := ltac:(restart_timer                   "eval lazy for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*)) in
       let finish_timing_eval_lazy   := ltac:(finish_timing ("Tactic call")   "eval lazy for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*)) in
       let time_lazy_beta_iota tac   := time                             "lazy beta iota for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*) tac in
       let time_transitivity_Denote_rv tac := time             "transitivity (Denote rv) for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*) tac in
       let do_reify := do_reify restart_timer_norm_reif finish_timing_norm_reif restart_timer_actual_reif finish_timing_actual_reif restart_timer_eval_lazy finish_timing_eval_lazy time_lazy_beta_iota time_transitivity_Denote_rv in
       let do_cbv     x := time  "cbv for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*) do_cbv     x in
       let pre_reify  x := time  "pre for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*) pre_reify  x in
       let do_reify   x := time "reif for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*) do_reify   x in
       let post_reify x := time "post for TypeClassesBodyHOAS with big_flat"(*-regression-quadratic*) post_reify x in
       BenchmarkExtraUtil.time_solve_goal do_cbv pre_reify do_reify post_reify
  | BodyHOAS false
    => let restart_timer_norm_reif   := ltac:(restart_timer                   "norm reif for TypeClassesBodyHOAS with big"(*-regression-quadratic*)) in
       let finish_timing_norm_reif   := ltac:(finish_timing ("Tactic call")   "norm reif for TypeClassesBodyHOAS with big"(*-regression-quadratic*)) in
       let restart_timer_actual_reif := ltac:(restart_timer                 "actual reif for TypeClassesBodyHOAS with big"(*-regression-quadratic*)) in
       let finish_timing_actual_reif := ltac:(finish_timing ("Tactic call") "actual reif for TypeClassesBodyHOAS with big"(*-regression-quadratic*)) in
       let restart_timer_eval_lazy   := ltac:(restart_timer                   "eval lazy for TypeClassesBodyHOAS with big"(*-regression-quadratic*)) in
       let finish_timing_eval_lazy   := ltac:(finish_timing ("Tactic call")   "eval lazy for TypeClassesBodyHOAS with big"(*-regression-quadratic*)) in
       let time_lazy_beta_iota tac   := time                             "lazy beta iota for TypeClassesBodyHOAS with big"(*-regression-quadratic*) tac in
       let time_transitivity_Denote_rv tac := time             "transitivity (Denote rv) for TypeClassesBodyHOAS with big"(*-regression-quadratic*) tac in
       let do_reify := do_reify restart_timer_norm_reif finish_timing_norm_reif restart_timer_actual_reif finish_timing_actual_reif restart_timer_eval_lazy finish_timing_eval_lazy time_lazy_beta_iota time_transitivity_Denote_rv in
       let do_cbv     x := time  "cbv for TypeClassesBodyHOAS with big"(*-regression-quadratic*) do_cbv     x in
       let pre_reify  x := time  "pre for TypeClassesBodyHOAS with big"(*-regression-quadratic*) pre_reify  x in
       let do_reify   x := time "reif for TypeClassesBodyHOAS with big"(*-regression-quadratic*) do_reify   x in
       let post_reify x := time "post for TypeClassesBodyHOAS with big"(*-regression-quadratic*) post_reify x in
       BenchmarkExtraUtil.time_solve_goal do_cbv pre_reify do_reify post_reify
  | ?kind => fail 0 "Unrecognized kind:" kind
  end.

Ltac do_verify kind :=
  let is_flat := (eval cbv in (is_flat kind)) in
  BenchmarkExtraUtil.do_verify is_flat.

(**
<<<

#!/usr/bin/env python3

print(r'''(**
<<<
''')
print(open(__file__, 'r').read())
print(r'''>>>
 *)''')

for i, kind in enumerate(('BodyFlatPHOAS', 'ArgPHOAS true', 'ArgPHOAS false', 'BodyHOAS true', 'BodyHOAS false')):
    print(f'Ltac mkgoal{i} := mkgoal constr:({kind}).\nLtac time_solve_goal{i} := time_solve_goal constr:({kind}).\nLtac verify{i} := do_verify constr:({kind}).\nLtac run{i} sz := Harness.runtests_verify_sanity (args_of_size ({kind})) describe_goal mkgoal{i} redgoal ltac:(time_solve_goal{i} sz) verify{i} sz.\n')

>>>
 *)
Ltac mkgoal0 := mkgoal constr:(BodyFlatPHOAS).
Ltac time_solve_goal0 := time_solve_goal constr:(BodyFlatPHOAS).
Ltac verify0 := do_verify constr:(BodyFlatPHOAS).
Ltac run0 sz := Harness.runtests_verify_sanity (args_of_size (BodyFlatPHOAS)) describe_goal mkgoal0 redgoal ltac:(time_solve_goal0 sz) verify0 sz.

Ltac mkgoal1 := mkgoal constr:(ArgPHOAS true).
Ltac time_solve_goal1 := time_solve_goal constr:(ArgPHOAS true).
Ltac verify1 := do_verify constr:(ArgPHOAS true).
Ltac run1 sz := Harness.runtests_verify_sanity (args_of_size (ArgPHOAS true)) describe_goal mkgoal1 redgoal ltac:(time_solve_goal1 sz) verify1 sz.

Ltac mkgoal2 := mkgoal constr:(ArgPHOAS false).
Ltac time_solve_goal2 := time_solve_goal constr:(ArgPHOAS false).
Ltac verify2 := do_verify constr:(ArgPHOAS false).
Ltac run2 sz := Harness.runtests_verify_sanity (args_of_size (ArgPHOAS false)) describe_goal mkgoal2 redgoal ltac:(time_solve_goal2 sz) verify2 sz.

Ltac mkgoal3 := mkgoal constr:(BodyHOAS true).
Ltac time_solve_goal3 := time_solve_goal constr:(BodyHOAS true).
Ltac verify3 := do_verify constr:(BodyHOAS true).
Ltac run3 sz := Harness.runtests_verify_sanity (args_of_size (BodyHOAS true)) describe_goal mkgoal3 redgoal ltac:(time_solve_goal3 sz) verify3 sz.

Ltac mkgoal4 := mkgoal constr:(BodyHOAS false).
Ltac time_solve_goal4 := time_solve_goal constr:(BodyHOAS false).
Ltac verify4 := do_verify constr:(BodyHOAS false).
Ltac run4 sz := Harness.runtests_verify_sanity (args_of_size (BodyHOAS false)) describe_goal mkgoal4 redgoal ltac:(time_solve_goal4 sz) verify4 sz.

Global Open Scope N_scope.

(*
Goal True.
  run4 Sanity.
*)


From Undecidability.L Require Import L_facts.
From Undecidability.L.Datatypes Require Import LTerm Lists LSum.
From Complexity.Libs Require Import PSLCompat.
From Complexity.Complexity Require Import NP Monotonic PolyTimeComputable.
From Complexity.NP.L Require Import CanEnumTerm_def.
From Undecidability.L.AbstractMachines Require Import FlatPro.Programs.
From Complexity.L.AbstractMachines Require Import FlatPro.Computable.LPro Computable.Compile Computable.Decompile.

From Complexity Require Export CanEnumTerm_def.

Lemma terms_enum_themselves : canEnumTerms term.
Proof with try eauto;smpl_inO.
  exists id id. 2-4:unfold id...
  evar (time : nat -> nat). [time]:intros n.
  eexists time.
  extract. solverec.
  now cbv;reflexivity.
  1,2:unfold time...
  exists id...
Qed.

Lemma pro_enum_term : canEnumTerms Pro.
Proof.
  evar (fsize : nat -> nat). [fsize]:intros n0.
  eexists (fun P => match decompile 0 P [] with inl [s] => s | _ => var 0 end) fsize.
  2:{ intros s. exists (compile s). rewrite decompile_correct. split. easy.
      rewrite compile_enc_size,LTerm.size_term_enc_r.
      set (size (enc s)). unfold fsize. reflexivity.
  }
  2,3:now unfold fsize;smpl_inO.
  clear fsize. evar (time : nat -> nat). [time]:intros n0.
  exists time.
  {extract. solverec. all:rewrite time_decompile_nice_leq.
   all:unfold time_decompile_nice.
   all:rewrite size_list_enc_r.
   all:set (size (enc x)).
   all:unfold time. 3:reflexivity. all:nia.
  }
  1,2:now unfold time;smpl_inO.
  clear time. evar (fsize : nat -> nat). [fsize]:intros n0.
  enough (mono__f:monotonic fsize).
  exists fsize. 3:assumption.
  {intros x.
   destruct decompile as [[ |? []]| ] eqn:eq.
   2:{
     apply decompile_resSize in eq as Hle. cbn in Hle. rewrite Nat.add_0_r in Hle. rewrite LTerm.size_term_enc,Hle.
     set (n0:=(sumn (map sizeT x))).
     erewrite <- (mono__f n0). now unfold fsize;reflexivity.
     subst n0. rewrite size_list. rewrite <- Nat.le_add_r.
     apply sumn_map_le_pointwise. intros;now rewrite size_Tok_enc_r.
   }
   all:unfold fsize.
   all:do 2 (unfold enc at 1;cbn). all:rewrite (size_list x);cbn; unfold c__listsizeNil;easy.
  }
  all:unfold fsize;smpl_inO.
Qed.

Module boollist_enum.

  Function boollist_term (bs : list bool) (A : list Tok) :=
    match bs,A with
      true::true::bs,_ => boollist_term bs (varT 0::A)
    | true::false::bs,varT n::A => boollist_term bs (varT (S n)::A)
    | false::true::bs,_ => boollist_term bs (appT::A)
    | false::false::false::bs,_ => boollist_term bs (lamT::A)
    | false::false::true::bs,_ => boollist_term bs (retT::A)
    | _,P => P
    end.

  Lemma _term_boollist_term :
    { time : UpToC (fun bs => length bs + 1)
             & computableTime' boollist_term (fun bs _ => (5,fun _ _ => (time bs ,tt)))}.
  Proof.
    evar (c1:nat).
    exists_UpToC (fun l => c1 * length l + c1).
    extract. [c1]:refine 20. unfold c1. solverec.
    smpl_upToC_solve.
  Qed.

  Global Instance term_boollist_term : computableTime' boollist_term _ := projT2 _term_boollist_term.

  Fixpoint pro_to_boollist (P:Pro) : list bool :=
    match P with
    | varT n ::P => pro_to_boollist P ++ [true;true] ++concat (repeat [true;false] n)
    | appT ::P => pro_to_boollist P ++ [false;true]
    | lamT ::P => pro_to_boollist P ++ [false;false;false]
    | retT ::P => pro_to_boollist P ++ [false;false;true]
    | [] => []
    end.

  Lemma boollist_term_inv' P bs A:
    boollist_term (pro_to_boollist P ++bs) A = boollist_term bs (P++A).
  Proof.
    induction P as [ | t P]in bs,A|-*. reflexivity.
    destruct t. all:cbn;repeat rewrite <- app_assoc;rewrite IHP. 2-4:easy.
    cbn. change n with (0+n) at 2. generalize 0 as k;intros k.
    induction n in k|-*. now cbn.
    cbn. now rewrite IHn.
  Qed.

  Lemma boollist_term_inv P:
    boollist_term (pro_to_boollist P) [] = P.
  Proof.
    specialize (boollist_term_inv' P [] []) as H. autorewrite with list in H. easy.
  Qed.

  Lemma pro_to_boollist_size : (fun P => size (enc (pro_to_boollist P))) <=c fun P => size (enc P).
  Proof.
    evar (c:nat). exists c. intros P. rewrite !size_list. induction P as [ | [] P].
    all:cbn.
    all:autorewrite with list;cbn.
    2:rewrite concat_map,map_repeat,sumn_concat,map_repeat. 2:cbn [map].
    all:set (et:=size (enc true));cbv in et;subst et. all:set (et:=size (enc false));cbv in et;subst et.
    2:cbn [sumn];rewrite sumn_repeat. all:try rewrite size_Tok_enc.
    all:ring_simplify.
    [c]:exact 5. all:subst c; unfold c__listsizeNil, c__listsizeCons in *; lia.
  Qed.

  Import FunInd.

  Lemma boollist_term_size bs A:  size (enc (boollist_term bs A)) <= size (enc bs) + size (enc A).
  Proof.
    rewrite !size_list. functional induction (boollist_term bs A).
    all:cbn.
    all:autorewrite with list;cbn. all:try rewrite IHl. all:cbn; rewrite ?size_Tok_enc,?LBool.size_bool_enc.
    all:ring_simplify. all: unfold c__listsizeNil, c__listsizeCons in *; nia.
  Qed.

  Lemma boollists_enum_term : canEnumTerms (list bool).
  Proof.
    evar (fsize : nat -> nat). [fsize]:intros n.
    cut (monotonic fsize). intros mono_fsize.
    eexists (fun bs => f__toTerm pro_enum_term (boollist_term bs [])) fsize.
    2:{ intros s. specialize (complete__toTerm pro_enum_term) as (P&Hf&Hfsize).
        exists (pro_to_boollist P).
        split. now rewrite boollist_term_inv.
        rewrite (correct__leUpToC pro_to_boollist_size), Hfsize.
        set (size _). unfold fsize. reflexivity.
    }
    3:easy.
    2,3:unfold fsize;smpl_inO.
    eapply polyTimeComputable_composition. 2:now apply comp__toTerm.
    clear. evar (time : nat -> nat). [time]:intros n0.
    exists time.
    {extract. solverec. rewrite UpToC_le, size_list_enc_r. set (size (enc x)). unfold time. reflexivity.  }
    1,2:now unfold time;smpl_inO;eapply inOPoly_comp;smpl_inO.
    clear time. evar (fsize : nat -> nat). [fsize]:intros n0.
    exists fsize.
    {intros x. rewrite boollist_term_size. rewrite (size_list []). cbn.
     set (n0:=size _). unfold fsize. reflexivity. }
    all:unfold fsize;smpl_inO.
  Qed.
End boollist_enum.