(* generated by Ott 0.25, locally-nameless lngen from: Fsub.ott *)
Require Import Metatheory.
(** syntax *)
Definition typvar := var.
Definition expvar := var.

Inductive typ : Set :=
 | typ_top : typ
 | typ_var_b (_:nat)
 | typ_var_f (X:typvar)
 | typ_arrow (T1:typ) (T2:typ)
 | typ_all (T1:typ) (T2:typ).

Inductive binding : Set :=
 | bind_sub (T:typ)
 | bind_typ (T:typ).

Inductive exp : Set :=
 | exp_var_b (_:nat)
 | exp_var_f (x:expvar)
 | exp_abs (T:typ) (e:exp)
 | exp_app (e1:exp) (e2:exp)
 | exp_tabs (T:typ) (e:exp)
 | exp_tapp (e:exp) (T:typ).

Definition env : Set := list (atom*binding).

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
Definition is_value_of_exp (e_5:exp) : Prop :=
  match e_5 with
  | (exp_var_b nat) => False
  | (exp_var_f x) => False
  | (exp_abs T e) => (True)
  | (exp_app e1 e2) => False
  | (exp_tabs T e) => (True)
  | (exp_tapp e T) => False
end.

(** arities *)
(** opening up abstractions *)
Fixpoint open_typ_wrt_typ_rec (k:nat) (T_5:typ) (T__6:typ) {struct T__6}: typ :=
  match T__6 with
  | typ_top => typ_top
  | (typ_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => typ_var_b nat
        | inleft (right _) => T_5
        | inright _ => typ_var_b (nat - 1)
      end
  | (typ_var_f X) => typ_var_f X
  | (typ_arrow T1 T2) => typ_arrow (open_typ_wrt_typ_rec k T_5 T1) (open_typ_wrt_typ_rec k T_5 T2)
  | (typ_all T1 T2) => typ_all (open_typ_wrt_typ_rec k T_5 T1) (open_typ_wrt_typ_rec (S k) T_5 T2)
end.

Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (exp_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => exp_var_b nat
        | inleft (right _) => e_5
        | inright _ => exp_var_b (nat - 1)
      end
  | (exp_var_f x) => exp_var_f x
  | (exp_abs T e) => exp_abs T (open_exp_wrt_exp_rec (S k) e_5 e)
  | (exp_app e1 e2) => exp_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (exp_tabs T e) => exp_tabs T (open_exp_wrt_exp_rec k e_5 e)
  | (exp_tapp e T) => exp_tapp (open_exp_wrt_exp_rec k e_5 e) T
end.

Fixpoint open_exp_wrt_typ_rec (k:nat) (T_5:typ) (e_5:exp) {struct e_5}: exp :=
  match e_5 with
  | (exp_var_b nat) => exp_var_b nat
  | (exp_var_f x) => exp_var_f x
  | (exp_abs T e) => exp_abs (open_typ_wrt_typ_rec k T_5 T) (open_exp_wrt_typ_rec k T_5 e)
  | (exp_app e1 e2) => exp_app (open_exp_wrt_typ_rec k T_5 e1) (open_exp_wrt_typ_rec k T_5 e2)
  | (exp_tabs T e) => exp_tabs (open_typ_wrt_typ_rec k T_5 T) (open_exp_wrt_typ_rec (S k) T_5 e)
  | (exp_tapp e T) => exp_tapp (open_exp_wrt_typ_rec k T_5 e) (open_typ_wrt_typ_rec k T_5 T)
end.

Definition open_binding_wrt_typ_rec (k:nat) (T5:typ) (b5:binding) : binding :=
  match b5 with
  | (bind_sub T) => bind_sub (open_typ_wrt_typ_rec k T5 T)
  | (bind_typ T) => bind_typ (open_typ_wrt_typ_rec k T5 T)
end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

Definition open_exp_wrt_typ T_5 e_5 := open_exp_wrt_typ_rec 0 e_5 T_5.

Definition open_typ_wrt_typ T_5 T__6 := open_typ_wrt_typ_rec 0 T__6 T_5.

Definition open_binding_wrt_typ T5 b5 := open_binding_wrt_typ_rec 0 b5 T5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_typ *)
Inductive lc_typ : typ -> Prop :=    (* defn lc_typ *)
 | lc_typ_top :
     (lc_typ typ_top)
 | lc_typ_var_f : forall (X:typvar),
     (lc_typ (typ_var_f X))
 | lc_typ_arrow : forall (T1 T2:typ),
     (lc_typ T1) ->
     (lc_typ T2) ->
     (lc_typ (typ_arrow T1 T2))
 | lc_typ_all : forall (T1 T2:typ),
     (lc_typ T1) ->
      ( forall X , lc_typ  ( open_typ_wrt_typ T2 (typ_var_f X) )  )  ->
     (lc_typ (typ_all T1 T2)).

(* defns LC_binding *)
Inductive lc_binding : binding -> Prop :=    (* defn lc_binding *)
 | lc_bind_sub : forall (T:typ),
     (lc_typ T) ->
     (lc_binding (bind_sub T))
 | lc_bind_typ : forall (T:typ),
     (lc_typ T) ->
     (lc_binding (bind_typ T)).

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_exp_var_f : forall (x:expvar),
     (lc_exp (exp_var_f x))
 | lc_exp_abs : forall (T:typ) (e:exp),
     (lc_typ T) ->
      ( forall x , lc_exp  ( open_exp_wrt_exp e (exp_var_f x) )  )  ->
     (lc_exp (exp_abs T e))
 | lc_exp_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (exp_app e1 e2))
 | lc_exp_tabs : forall (T:typ) (e:exp),
     (lc_typ T) ->
      ( forall X , lc_exp  ( open_exp_wrt_typ e (typ_var_f X) )  )  ->
     (lc_exp (exp_tabs T e))
 | lc_exp_tapp : forall (e:exp) (T:typ),
     (lc_exp e) ->
     (lc_typ T) ->
     (lc_exp (exp_tapp e T)).
(** free variables *)
Fixpoint fv_typ_in_typ (T_5:typ) : vars :=
  match T_5 with
  | typ_top => {}
  | (typ_var_b nat) => {}
  | (typ_var_f X) => {{X}}
  | (typ_arrow T1 T2) => (fv_typ_in_typ T1) \u (fv_typ_in_typ T2)
  | (typ_all T1 T2) => (fv_typ_in_typ T1) \u (fv_typ_in_typ T2)
end.

Definition fv_typ_in_binding (b5:binding) : vars :=
  match b5 with
  | (bind_sub T) => (fv_typ_in_typ T)
  | (bind_typ T) => (fv_typ_in_typ T)
end.

Fixpoint fv_exp_in_exp (e_5:exp) : vars :=
  match e_5 with
  | (exp_var_b nat) => {}
  | (exp_var_f x) => {{x}}
  | (exp_abs T e) => (fv_exp_in_exp e)
  | (exp_app e1 e2) => (fv_exp_in_exp e1) \u (fv_exp_in_exp e2)
  | (exp_tabs T e) => (fv_exp_in_exp e)
  | (exp_tapp e T) => (fv_exp_in_exp e)
end.

Fixpoint fv_typ_in_exp (e_5:exp) : vars :=
  match e_5 with
  | (exp_var_b nat) => {}
  | (exp_var_f x) => {}
  | (exp_abs T e) => (fv_typ_in_typ T) \u (fv_typ_in_exp e)
  | (exp_app e1 e2) => (fv_typ_in_exp e1) \u (fv_typ_in_exp e2)
  | (exp_tabs T e) => (fv_typ_in_typ T) \u (fv_typ_in_exp e)
  | (exp_tapp e T) => (fv_typ_in_exp e) \u (fv_typ_in_typ T)
end.

(** substitutions *)
Fixpoint subst_typ_in_typ (T_5:typ) (X5:typvar) (T__6:typ) {struct T__6} : typ :=
  match T__6 with
  | typ_top => typ_top
  | (typ_var_b nat) => typ_var_b nat
  | (typ_var_f X) => (if eq_var X X5 then T_5 else (typ_var_f X))
  | (typ_arrow T1 T2) => typ_arrow (subst_typ_in_typ T_5 X5 T1) (subst_typ_in_typ T_5 X5 T2)
  | (typ_all T1 T2) => typ_all (subst_typ_in_typ T_5 X5 T1) (subst_typ_in_typ T_5 X5 T2)
end.

Definition subst_typ_in_binding (T5:typ) (X5:typvar) (b5:binding) : binding :=
  match b5 with
  | (bind_sub T) => bind_sub (subst_typ_in_typ T5 X5 T)
  | (bind_typ T) => bind_typ (subst_typ_in_typ T5 X5 T)
end.

Fixpoint subst_exp_in_exp (e_5:exp) (x5:expvar) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (exp_var_b nat) => exp_var_b nat
  | (exp_var_f x) => (if eq_var x x5 then e_5 else (exp_var_f x))
  | (exp_abs T e) => exp_abs T (subst_exp_in_exp e_5 x5 e)
  | (exp_app e1 e2) => exp_app (subst_exp_in_exp e_5 x5 e1) (subst_exp_in_exp e_5 x5 e2)
  | (exp_tabs T e) => exp_tabs T (subst_exp_in_exp e_5 x5 e)
  | (exp_tapp e T) => exp_tapp (subst_exp_in_exp e_5 x5 e) T
end.

Fixpoint subst_typ_in_exp (T_5:typ) (X5:typvar) (e_5:exp) {struct e_5} : exp :=
  match e_5 with
  | (exp_var_b nat) => exp_var_b nat
  | (exp_var_f x) => exp_var_f x
  | (exp_abs T e) => exp_abs (subst_typ_in_typ T_5 X5 T) (subst_typ_in_exp T_5 X5 e)
  | (exp_app e1 e2) => exp_app (subst_typ_in_exp T_5 X5 e1) (subst_typ_in_exp T_5 X5 e2)
  | (exp_tabs T e) => exp_tabs (subst_typ_in_typ T_5 X5 T) (subst_typ_in_exp T_5 X5 e)
  | (exp_tapp e T) => exp_tapp (subst_typ_in_exp T_5 X5 e) (subst_typ_in_typ T_5 X5 T)
end.

(** definitions *)

(* defns Jwf_typ *)
Inductive wf_typ : env -> typ -> Prop :=    (* defn wf_typ *)
 | wf_typ_top : forall (E:env),
     wf_typ E typ_top
 | wf_typ_var : forall (E:env) (X:typvar) (U:typ),
      binds ( X ) ( (bind_sub U) ) ( E )  ->
     wf_typ E (typ_var_f X)
 | wf_typ_arrow : forall (E:env) (T1 T2:typ),
     wf_typ E T1 ->
     wf_typ E T2 ->
     wf_typ E (typ_arrow T1 T2)
 | wf_typ_all : forall (L:vars) (E:env) (T1 T2:typ),
     wf_typ E T1 ->
      ( forall X , X \notin  L  -> wf_typ  ( X ~ (bind_sub T1)  ++  E )   ( open_typ_wrt_typ T2 (typ_var_f X) )  )  ->
     wf_typ E (typ_all T1 T2).

(* defns Jwf_env *)
Inductive wf_env : env -> Prop :=    (* defn wf_env *)
 | wf_env_empty :
     wf_env  nil
 | wf_env_sub : forall (E:env) (X:typvar) (T:typ),
     wf_env E ->
     wf_typ E T ->
      ( X  `notin` dom ( E ))  ->
     wf_env  ( X ~ (bind_sub T)  ++  E )
 | wf_env_typ : forall (E:env) (x:expvar) (T:typ),
     wf_env E ->
     wf_typ E T ->
      ( x  `notin` dom ( E ))  ->
     wf_env  ( x ~ (bind_typ T)  ++  E ) .

(* defns Jsub *)
Inductive sub : env -> typ -> typ -> Prop :=    (* defn sub *)
 | sub_top : forall (E:env) (S:typ),
     wf_env E ->
     wf_typ E S ->
     sub E S typ_top
 | sub_refl_tvar : forall (E:env) (X:typvar),
     wf_env E ->
     wf_typ E (typ_var_f X) ->
     sub E (typ_var_f X) (typ_var_f X)
 | sub_trans_tvar : forall (E:env) (X:typvar) (T U:typ),
      binds ( X ) ( (bind_sub U) ) ( E )  ->
     sub E U T ->
     sub E (typ_var_f X) T
 | sub_arrow : forall (E:env) (S1 S2 T1 T2:typ),
     sub E T1 S1 ->
     sub E S2 T2 ->
     sub E (typ_arrow S1 S2) (typ_arrow T1 T2)
 | sub_all : forall (L:vars) (E:env) (S1 S2 T1 T2:typ),
     sub E T1 S1 ->
      ( forall X , X \notin  L  -> sub  ( X ~ (bind_sub T1)  ++  E )   ( open_typ_wrt_typ S2 (typ_var_f X) )   ( open_typ_wrt_typ T2 (typ_var_f X) )  )  ->
     sub E (typ_all S1 S2) (typ_all T1 T2).

(* defns Jtyping *)
Inductive typing : env -> exp -> typ -> Prop :=    (* defn typing *)
 | typing_var : forall (E:env) (x:expvar) (T:typ),
     wf_env E ->
      binds ( x ) ( (bind_typ T) ) ( E )  ->
     typing E (exp_var_f x) T
 | typing_abs : forall (L:vars) (E:env) (T1:typ) (e:exp) (T2:typ),
      ( forall x , x \notin  L  -> typing  ( x ~ (bind_typ T1)  ++  E )   ( open_exp_wrt_exp e (exp_var_f x) )  T2 )  ->
     typing E (exp_abs T1 e) (typ_arrow T1 T2)
 | typing_app : forall (E:env) (e1 e2:exp) (T2 T1:typ),
     typing E e1 (typ_arrow T1 T2) ->
     typing E e2 T1 ->
     typing E (exp_app e1 e2) T2
 | typing_tabs : forall (L:vars) (E:env) (T1:typ) (e:exp) (T2:typ),
      ( forall X , X \notin  L  -> typing  ( X ~ (bind_sub T1)  ++  E )   ( open_exp_wrt_typ e (typ_var_f X) )   ( open_typ_wrt_typ T2 (typ_var_f X) )  )  ->
     typing E (exp_tabs T1 e) (typ_all T1 T2)
 | typing_tapp : forall (E:env) (e1:exp) (T T2 T1:typ),
     typing E e1 (typ_all T1 T2) ->
     sub E T T1 ->
     typing E (exp_tapp e1 T)  (open_typ_wrt_typ  T2   T )
 | typing_sub : forall (E:env) (e:exp) (T S:typ),
     typing E e S ->
     sub E S T ->
     typing E e T.

(* defns Jop *)
Inductive red : exp -> exp -> Prop :=    (* defn red *)
 | red_app_1 : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     red e1 e1' ->
     red (exp_app e1 e2) (exp_app e1' e2)
 | red_app_2 : forall (e2 e2' v1:exp),
     is_value_of_exp v1 ->
     lc_exp v1 ->
     red e2 e2' ->
     red (exp_app v1 e2) (exp_app v1 e2')
 | red_tapp_1 : forall (e1:exp) (T:typ) (e1':exp),
     lc_typ T ->
     red e1 e1' ->
     red (exp_tapp e1 T) (exp_tapp e1' T)
 | red_abs : forall (T:typ) (e1 v2:exp),
     is_value_of_exp v2 ->
     lc_typ T ->
     lc_exp (exp_abs T e1) ->
     lc_exp v2 ->
     red (exp_app  ( (exp_abs T e1) )  v2)  (open_exp_wrt_exp  e1   v2 )
 | red_tabs : forall (T1:typ) (e1:exp) (T2:typ),
     lc_typ T1 ->
     lc_exp (exp_tabs T1 e1) ->
     lc_typ T2 ->
     red (exp_tapp  ( (exp_tabs T1 e1) )  T2)  (open_exp_wrt_typ  e1   T2 ) .

(** infrastructure *)
Hint Constructors wf_typ wf_env sub typing red lc_typ lc_binding lc_exp.


Require Export Smten.
Require Export SmtenProp.

Module SmtenS1.
Import Smten.Smten.
Import SmtenProp.SmtenProp.

(* S1 pulls empty, single, and union to the top *)

Inductive valueS1 : tm -> Prop :=
  | vS1_empty : forall T, valueS1 (temptyS T)
  | vS1_single : forall t, valueS1 (tsingleS t)
  | vS1_union : forall t1 t2, valueS1 (tunionS t1 t2)
  .

Hint Constructors valueS1.

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

Inductive stepS1 : tm -> tm -> Prop :=
  | STS1_Pure : forall t t',
      t ==> t' ->
      t =S1=> t'
  | STS1_MapEmpty : forall T1 T2 t,
      empty |- t \in TArrow T1 T2 ->
      tmapS t (temptyS T1) =S1=> temptyS T2
  | STS1_MapSingle : forall t1 t2,
      tmapS t1 (tsingleS t2) =S1=> tsingleS (tapp t1 t2)
  | STS1_MapUnion : forall t1 t2 t3,
      tmapS t1 (tunionS t2 t3) =S1=> tunionS (tmapS t1 t2) (tmapS t1 t3)
  | STS1_Map : forall t1 t2 t2',
      t2 =S1=> t2' ->
      tmapS t1 t2 =S1=> tmapS t1 t2'
  | STS1_JoinEmpty : forall T,
      tjoinS (temptyS (TS T)) =S1=> temptyS T
  | STS1_JoinSingle : forall t1,
      tjoinS (tsingleS t1) =S1=> t1
  | STS1_JoinUnion : forall t1 t2,
      tjoinS (tunionS t1 t2) =S1=> tunionS (tjoinS t1) (tjoinS t2)
  | STS1_Join : forall t1 t1',
      t1 =S1=> t1' ->
      tjoinS t1 =S1=> tjoinS t1'

where "t1 '=S1=>' t2" := (stepS1 t1 t2).

Tactic Notation "stepS1_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "STS1_Pure"
  | Case_aux c "STS1_MapEmpty" | Case_aux c "STS1_MapSingle"
  | Case_aux c "STS1_MapUnion" | Case_aux c "STS1_Map"
  | Case_aux c "STS1_JoinEmpty" | Case_aux c "STS1_JoinSingle"
  | Case_aux c "STS1_JoinUnion" | Case_aux c "STS1_Join" ].

Hint Constructors stepS1.

Notation multistepS1 := (multi stepS1).
Notation "t1 '=S1=>*' t2" := (multistepS1 t1 t2) (at level 40).

Lemma pure_stepsS1 : forall t T,
    empty |- t \in T ->
    ~ (value t) ->
    exists t', t =S1=> t'.
Proof.
  intros t T HT Hnv.
  destruct (progress t T HT).
  Case "t is a value". contradiction.
  Case "t pure steps".
    destruct H as [t'].
    exists t'.
    apply STS1_Pure ; assumption.
Qed.

Theorem progressS1 : forall t T,
    empty |- t \in T ->
    (exists T1 : ty, T = TS T1) ->
    valueS1 t \/ exists t', t =S1=> t'.

Proof with eauto.
  intros t T Ht HSt.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case ; subst Gamma.
  Ltac is_valueS1 xx := left ; apply xx.
  Ltac not_type_S HSt :=
     (* Contradiction: The type of t is not of the form TS T *)
     destruct HSt ; discriminate H.
  Ltac pure_progress t T HT :=
     (* The term pure steps, so it s1-steps *)
     assert (Hnvalue : ~ (value t)) ;
     [ unfold not ; intro Hvalue ; inversion Hvalue
     | right ; apply (pure_stepsS1 t T HT Hnvalue)].
  Case "T_Var". inversion H. (* var not well typed in empty context *)
  Case "T_Abs". not_type_S HSt.
  Case "T_App". pure_progress (tapp t1 t2) T12 (T_App T11 T12 empty t1 t2 Ht1 Ht2).
  Case "T_Unit". not_type_S HSt.
  Case "T_Pair". not_type_S HSt.
  Case "T_Fst". pure_progress (tfst t) T1 (T_Fst empty t T1 T2 Ht).
  Case "T_Snd". pure_progress (tsnd t) T2 (T_Snd empty t T1 T2 Ht).
  Case "T_Inl". not_type_S HSt.
  Case "T_Inr". not_type_S HSt.
  Case "T_Case". pure_progress (tcase t1 t2 t3) T3 (T_Case empty t1 t2 t3 T1 T2 T3 Ht1 Ht2 Ht3).
  Case "T_Fix". pure_progress (tfix t) T (T_Fix empty t T Ht).
  Case "T_ReturnIO". not_type_S HSt.
  Case "T_BindIO". not_type_S HSt.
  Case "T_SearchIO". not_type_S HSt.
  Case "T_EmptyS". is_valueS1 vS1_empty.
  Case "T_SingleS". is_valueS1 vS1_single.
  Case "T_UnionS". is_valueS1 vS1_union.
  Case "T_MapS".
     (* mapS t1 t2:
        by induction, t1 is either an s1-value, or s1-steps.
          s1-value empty: MapEmpty applies
          s1-value single: MapSIngle applies
          s1-value union: MapUnion applies
          s1-steps: Map applies
     *)
     right.
     destruct (IHHt2 (eq_refl empty) (ex_intro (fun T2 => TS T1 = TS T2) T1 eq_refl)).
     SCase "t1 is a valueS1". inversion H ; subst.
      SSCase "t1 is emptyS".
         inversion Ht2. subst.
         exists (temptyS T2).
         exact (STS1_MapEmpty T1 T2 t1 Ht1).
      SSCase "t1 is singleS t".
         exists (tsingleS (tapp t1 t)). apply STS1_MapSingle.
      SSCase "t1 is unionS".
         exists (tunionS (tmapS t1 t0) (tmapS t1 t3)). apply STS1_MapUnion.
     SCase "t1 steps".
         destruct H as [t2'].
         exists (tmapS t1 t2').
         apply STS1_Map ; assumption.
  Case "T_JoinS".
      (* joinS t1:
        by induction, t1 is either an s1-value, or s1-steps.
          s1-value empty: JoinZero applies
          s1-value single: JoinSingle applies
          s1-value union: JoinUnion applies
          s1-steps: Join applies
     *)
     right.
     destruct (IHHt (eq_refl empty) (ex_intro (fun T1 => TS (TS T) = TS T1) (TS T) eq_refl)).
     SCase "t1 is a valueS1". inversion H ; subst.
      SSCase "t1 is emptyS".
         inversion Ht.
         exists (temptyS T). apply STS1_JoinEmpty ; assumption.
      SSCase "t1 is singleS t".
         exists (t0). apply STS1_JoinSingle.
      SSCase "t1 is unionS".
         exists (tunionS (tjoinS t1) (tjoinS t2)). apply STS1_JoinUnion.
     SCase "t1 steps".
         destruct H as [t1'].
         exists (tjoinS t1').
         apply STS1_Join ; assumption.
Qed.

Theorem preservationS1 : forall t t' T,
     empty |- t \in T ->
     t =S1=> t' ->
     empty |- t' \in T.

Proof.
   intros t t' T HT Hstep.
   generalize dependent T.
   stepS1_cases (induction Hstep) Case; intros TT HT.
   Case "STS1_Pure".
     (* preservationS1 comes because we have pure preservation *)
     apply preservation with t ; assumption.
   Case "STS1_MapEmpty".
     (* Types T2 and TT are equal because typing is unique. *)
     inversion HT ; subst.
     assert (Htarreq : TArrow T1 T2 = TArrow T0 T3).
     apply unique_typing with empty t ; assumption.
     injection Htarreq.
     intros ; subst.
     apply T_EmptyS.
   Case "STS1_MapSingle".
     (* Given HT, tsingle (tapp t2 t1) must have type TT by T_App *)
     inversion HT; subst ; inversion H4 ; subst.
     apply T_SingleS; apply T_App with T1 ; assumption.
   Case "STS1_MapUnion".
     inversion HT ; subst ; inversion H4 ; subst.
     apply T_UnionS ; apply T_MapS with T1 ; assumption.
   Case "STS1_Map".
     (* by induction on t1 preserving typing *)
     inversion HT ; subst.
     apply T_MapS with T1 . assumption.
     apply IHHstep ; assumption.
   Case "STS1_JoinEmpty".
     inversion HT ; subst ; inversion H1 ; subst.
     apply T_EmptyS.
   Case "STS1_JoinSingle".
     inversion HT ; subst.
     inversion H1 ; subst.
     assumption.
   Case "STS1_JoinUnion".
     inversion HT ; subst . inversion H1 ; subst.
     apply T_UnionS ; apply T_JoinS ; assumption.
   Case "STS1_Join".
     (* by induction on t1 preserving typing *)
     inversion HT ; subst.
     apply T_JoinS.
     apply IHHstep ; assumption.
Qed.

Definition stuckS1 (t:tm) : Prop :=
  (normal_form stepS1) t /\ ~ valueS1 t.

Corollary soundnessS1 : forall t t' T,
  empty |- t \in T ->
  (exists T1, T = TS T1) ->
  t =S1=>* t' ->
  ~(stuckS1 t').
Proof.
  intros t t' T Hhas_type Hs Hmulti. unfold stuckS1.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti. apply Hnot_val.
   destruct (progressS1 x0 T).
   apply Hhas_type. apply Hs. apply H.
   contradiction.

   apply IHHmulti.
   apply (preservationS1 x0 y0). apply Hhas_type. apply H.
   apply Hnf. apply Hnot_val.
Qed.

Theorem stepS1_deterministic : forall t t1 t2 T,
   empty |- t \in T ->
   t =S1=> t1 ->
   t =S1=> t2 ->
   t1 = t2
   .

Proof.
  intro t.
  t_cases (induction t) Case; intros tx ty T HT Hstep1 Hstep2.
  Ltac sts1_pure tx T :=
    (* Determinism of stepS1 comes directly from determinism of step,
       because only sts1-pure applies .*)
    inversion Hstep1 ; inversion Hstep2 ;
    apply step_deterministic with tx T; assumption.
  Ltac doesnt_step_S1 := inversion Hstep1; inversion H.
  Case "tvar". sts1_pure (tvar i) T.
  Case "tapp". sts1_pure (tapp t1 t2) T.
  Case "tabs". sts1_pure (tabs i t t0) T.
  Case "tunit". sts1_pure tunit T.
  Case "tpair". sts1_pure (tpair t1 t2) T.
  Case "tfst". sts1_pure (tfst t) T.
  Case "tsnd". sts1_pure (tsnd t) T.
  Case "tinl". sts1_pure (tinl t t0) T.
  Case "tinr". sts1_pure (tinr t t0) T.
  Case "tcase". sts1_pure (tcase t1 t2 t3) T.
  Case "tfix". sts1_pure (tfix t) T.
  Case "treturnIO". doesnt_step_S1.
  Case "tbindIO". doesnt_step_S1.
  Case "tsearchIO". doesnt_step_S1.
  Case "temptyS". doesnt_step_S1.
  Case "tsingleS". doesnt_step_S1.
  Case "tunionS". doesnt_step_S1.
  Case "tmapS".
    inversion Hstep1 ; subst.
    SCase "pure step to tx".
       (* there is no pure step from (mapS t1 t2), so this can't happen *)
       inversion H.
    SCase "MapEmpty to tx".
       inversion Hstep2.
       SSCase "pure step to ty". inversion H.
       SSCase "MapEmpty to ty".
         assert (Htarreq : TArrow T1 T2 = TArrow T1 T3).
         apply unique_typing with empty t1 ; assumption.
         injection Htarreq. intros ; subst ; reflexivity.
       SSCase "Map to ty". inversion H3. inversion H4.
    SCase "MapSingle to tx".
       inversion Hstep2.
       SSCase "pure step to ty". inversion H.
       SSCase "MapSingle to ty". reflexivity.
       SSCase "Map to ty".
         (* this would require singleS to s1-step, but it doesn't *)
         inversion H2. inversion H3.
    SCase "MapUnion to tx".
       inversion Hstep2.
       SSCase "pure to ty". inversion H.
       SSCase "MapUnion to ty". reflexivity.
       SSCase "Map to ty". inversion H2. inversion H3.
    SCase "Map to tx".
       inversion Hstep2 ; subst.
       SSCase "pure to ty". inversion H.
       SSCase "MapEmpty to ty".
         inversion H2. inversion H.
       SSCase "MapSingle to ty".
         inversion H2. inversion H.
       SSCase "MapUnion to ty".
         inversion H2. inversion H.
       SSCase "Map to ty".
         f_equal.
         inversion HT.
         apply IHt2 with (TS T1) ; assumption.
  Case "tjoinS".
    inversion Hstep1 ; subst.
    SCase "pure step to tx".
       (* there is no pure step from (joinS t), so this can't happen *)
       inversion H.
    SCase "JoinEmpty to tx".
       inversion Hstep2.
       SSCase "pure step to ty". inversion H.
       SSCase "JoinEmpty to ty". reflexivity.
       SSCase "Join to ty". inversion H0. inversion H2.
    SCase "JoinSingle to tx".
       inversion Hstep2.
       SSCase "pure step to ty". inversion H.
       SSCase "JoinSingle to ty". reflexivity.
       SSCase "Join to ty".
         (* this would require singleS to s1-step, but it doesn't *)
         inversion H0. inversion H2.
    SCase "JoinUnion to tx".
       inversion Hstep2.
       SSCase "pure to ty". inversion H.
       SSCase "JoinUnion to ty". reflexivity.
       SSCase "Join to ty". inversion H0. inversion H2.
    SCase "Join to tx".
       inversion Hstep2 ; subst.
       SSCase "pure to ty". inversion H.
       SSCase "JoinEmpty to ty".
         inversion H0. inversion H.
       SSCase "JoinSingle to ty".
         inversion H0. inversion H.
       SSCase "JoinUnion to ty".
         inversion H0. inversion H.
       SSCase "Join to ty".
         f_equal.
         inversion HT.
         apply IHt with (TS (TS T0)) ; assumption.
Qed.

End SmtenS1.


(* PUBLIC DOMAIN *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
Require Import Logic.FunctionalExtensionality.
Require Import Coq.Program.Wf.
(* AIM
1) PROVE transitivity
   1.1) DEFINE relation as Type.
*)

Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.
Inductive Terms : Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.

Definition rela : forall (x y:Terms), Prop.
Proof.
fix rela 2.
intros x y.
destruct y as [s|f t].
+ exact False.
+ refine (or _ _).
  exact (Vector.In x t).
  simple refine (@Vector.fold_left Terms Prop _ False (fsv f) t).
  intros Q e.
  exact (or Q (rela x e)).
Defined.

(*Definition rela : forall (x y:Terms), Type.
Proof.
fix rela 2.
intros x y.
destruct y as [s|f t].
+ exact False.
+ refine (or _ _).
  exact (Vector.In x t).
  simple refine (@Vector.fold_left Terms Type _ False (fsv f) t).
  intros Q e.
  exact (or Q (rela x e)).
Defined.*)

Definition snglV {A} (a:A) := Vector.cons A a 0 (Vector.nil A).

Fixpoint Tra (a b c:Terms) (Hc : rela c b) (Hb : rela b a) {struct a}: rela c a.
destruct a.
+ simpl in * |- *.
  exact Hb.
+ simpl in * |- *.
  destruct Hb.
    destruct H.
    * apply or_introl.
      constructor 1.

  - apply Tra with b.
    trivial.
    simpl in * |- *.
    destruct H.
    * apply or_introl.
      constructor 1.
    * apply or_introl.
      constructor 2.
      assumption.

  - apply Tra with b.
    trivial.
    simpl in * |- *.
    apply or_intror.
    assumption.
Defined.

    destruct H.
    * apply or_introl.
      constructor 1.
    * apply or_introl.
      constructor 2.
      assumption.

@Vector.In
contructor.
unfold Vector.In.
simpl.

    * apply or_intror.
      simpl in * |- *.

      apply or_intror.

  simpl in * |- *.

Admitted.

Definition wfr : @well_founded Terms rela.
Proof.
clear.
unfold well_founded.
assert (H : forall (n:Terms) (a:Terms), (rela a n) -> Acc rela a).
{ fix iHn 1.
  destruct n.
  + simpl. intros a b. exfalso. exact b.
  + simpl. intros a Q. destruct Q as [L|R].
    * destruct L.
      (*pose (G:= iHn m).*)
      apply Acc_intro. intros q Hq.
      apply Acc_intro. intros m Hm.
      apply Acc_intro. intros q Hq.
      apply (iHn a). apply Tra with m; assumption.
    * apply Acc_intro. intros m Hm.
      apply Acc_intro. intros q Hq.
      apply (iHn a). apply Tra with m; assumption.

(*      simpl in * |- *.
 exact Hm.

 admit.  (*apply Acc_intro. intros m Hm. apply (iHn a). exact Hm. *)
    * admit.  (* like in /Arith/Wf_nat.v *)*)
}
intros a.
simple refine (H _ _ _).
exact (FSC (Build_FSV 0 1) (snglV a)).
simpl.
apply or_introl.
constructor.
Defined.


(* partie 1 *)

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

Compute tminus 5 3.
Compute tminus 5 6.

Require Import Arith.

Fixpoint pminus (n m : nat) : m <= n -> nat.
Abort.

Lemma O_le_5 : 3 <= 5.
Proof.
auto.
Qed.

Fail Compute pminus 5 3 O_le_5.

Fixpoint iminus (n m : nat) : m <= n -> { k : nat | k + m = n }.
Abort.

Fail Compute (proj1_sig (iminus 5 3 O_le_5)).

Fixpoint sminus (n m : nat) : m <= n -> { k : nat | k + m = n }.
Abort.

(* partie 2 *)

Definition var := nat.

Inductive exp :=
| exp_var : var -> exp
| cst : nat -> exp
| mul : exp -> exp -> exp
| sub : exp -> exp -> exp.

Inductive bexp :=
| equa : exp -> exp -> bexp
| neg : bexp -> bexp.

Inductive cmd : Type :=
| assign : var -> exp -> cmd
| seq : cmd -> cmd -> cmd
| while : bexp -> cmd -> cmd.

Definition state := var -> nat.

Definition sample_state : state :=
  fun x =>
    match x with
    | O => 4
    | 1 => 5
    | _ => O
    end.

Require Import Arith.

Definition upd (v : var) (a : nat) (s : state) : state :=
  fun x => match Nat.eq_dec x v with
           | left _ (* x = y *) => a
           | right _ => s x
           end.

Fixpoint eval e s :=
  match e with
  | exp_var v => s v
  | cst n => n
  | mul v1 v2 => eval v1 s * eval v2 s
  | sub v1 v2 => eval v1 s - eval v2 s
  end.

Fixpoint beval b s :=
  match b with
    | equa e1 e2 => eval e1 s = eval e2 s
    | neg b => ~ beval b s
  end.

Definition ret : var := O.
Definition x : var := 1.

Compute eval (mul (exp_var ret) (exp_var x)) sample_state.

Lemma eval_upd_same str v s : eval (exp_var str) (upd str v s) = v.
Proof.
simpl.
unfold upd.
destruct Nat.eq_dec.
apply eq_refl.
tauto.
Qed.

Lemma eval_upd_diff str str' v s : str <> str' -> eval (exp_var str) (upd str' v s) = eval (exp_var str) s.
Proof.
intros H.
simpl.
unfold upd.
destruct Nat.eq_dec.
  tauto.
apply eq_refl.
Qed.

Definition assert := state -> Prop.

Definition imp (P Q : assert) := forall s, P s -> Q s.

Inductive hoare : assert -> cmd -> assert -> Prop :=
| hoare_assign : forall (Q : assert) v e,
  hoare (fun s => Q (upd v (eval e s) s)) (assign v e) Q
| hoare_seq : forall Q P R c d,
  hoare P c Q -> hoare Q d R ->
  hoare P (seq c d) R
| hoare_conseq : forall (P' Q' P Q : assert) c,
  imp P P' -> imp Q' Q -> hoare P' c Q' ->
  hoare P c Q
| hoare_while : forall P b c,
  hoare (fun s => P s /\ beval b s) c P ->
  hoare P (while b c) (fun s => P s /\ ~ (beval b s)).

Lemma hoare_stren : forall (P' P Q : assert) c,
  imp P P' -> hoare P' c Q -> hoare P c Q.
Proof.
intros P' P Q c PP' H.
apply (hoare_conseq P' Q).
auto.
unfold imp.
auto.
auto.
Qed.

Definition facto (x ret : var) :=
  while (neg (equa (exp_var x) (cst O)))
    (seq
       (assign ret (mul (exp_var ret) (exp_var x)))
       (assign x (sub (exp_var x) (cst 1)))).

Require Import Omega.
Require Import Factorial.

Lemma fact_fact n : 1 <= n -> fact (n - 1) * n = fact n.
Proof.
destruct n as [|n].
omega.
intros _.
simpl.
rewrite Nat.sub_0_r.
rewrite Nat.mul_succ_r.
rewrite Nat.mul_comm.
omega.
Qed.

Require Import Omega.
Require Import Factorial.

Lemma facto_fact x X ret : x <> ret ->
  hoare
    (fun s => eval (exp_var x) s = X /\
              eval (exp_var ret) s = 1)
    (facto x ret)
    (fun s => eval (exp_var ret) s = fact X).
Proof.
intros xret.
set (P' := fun s : state => eval (exp_var ret) s *
  fact (eval (exp_var x) s) = fact X).
set (Q' := fun s : state => eval (exp_var ret) s *
  fact (eval (exp_var x) s) = fact X /\
   ~ (beval (neg (equa (exp_var x) (cst O))) s)).
apply (hoare_conseq P' Q').
Abort.


Generalizable All Variables.
Set Implicit Arguments.

Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.ilist
        Fiat.Common.ilist2.

Section ilist2_pair.

  (* Lists of elements whose types depend on two indexing sets.  *)

  Import Vectors.Vector.VectorNotations.

  Context {A A' : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)
  Context {C : forall a (a' : A'), B a -> Type}.

  Fixpoint ilist2_pair {n}
           {l : Vector.t A n}
           (il : ilist2 l)
           (l' : Vector.t A' n)
    : Type :=
    match n return forall (l :Vector.t A n),
        ilist2 l -> Vector.t A' n -> Type with
    | 0 => fun _ _ _ => unit
    | S n' => fun l il l' =>
                   @prim_prod (C (Vector.hd l') (ilist2_hd' il))
                              (ilist2_pair (ilist2_tl' il) (Vector.tl l'))
    end l il l'.

  Definition icons2_pair
             {a : A}
             {b : B a}
             {a' : A'}
             {n}
             {l : Vector.t A n}
             {l' : Vector.t A' n}
             (il : ilist2 l)
             (ilp : ilist2_pair il l')
             (c : C a' b)
  : ilist2_pair (icons2 b il) (a' :: l')
    := {| prim_fst := c; prim_snd := ilp |}.

  Definition inil2_pair : ilist2_pair inil2 [] := tt.

  (* Get the car of an ilist2_pair. *)
  (*Definition ilist2_pair_hd {n}
             (As : Vector.t A n)
             (As' : Vector.t A' n)
             (il : ilist2_pair As As') :
    match n return
          forall (As : Vector.t A n)
                 (As' : Vector.t A' n)
                 (il : ilist2_pair As As'), Type with
    | 0 => fun As As' il => unit
    | S n' => fun As As' il' => B (Vector.hd As) (Vector.hd As')
    end As As' il :=
    match n return forall As As' il,
        match n return forall (As : Vector.t A n)
                              (As' : Vector.t A' n)
                              (il : ilist2_pair As As'), Type with
        | 0 => fun As As' il => unit
        | S n' => fun As As' il => B (Vector.hd As) (Vector.hd As')
        end As As' il with
    | 0 => fun _ _ _ => tt
    | S n' => fun As As' il => prim_fst il
    end As As' il.

  (* Get the cdr of an ilist2_pair. *)
  Definition ilist2_pair_tl {n}
             (As : Vector.t A n)
             (As' : Vector.t A' n)
             (il : ilist2_pair As As') :
    match n return
          forall (As : Vector.t A n)
                 (As' : Vector.t A' n)
                 (il : ilist2_pair As As'), Type with
    | 0 => fun As As' il => unit
    | S n' => fun As As' il' => ilist2_pair (Vector.tl As) (Vector.tl As')
    end As As' il :=
    match n return forall As As' il,
        match n return forall (As : Vector.t A n)
                              (As' : Vector.t A' n)
                              (il : ilist2_pair As As'), Type with
        | 0 => fun As As' il => unit
        | S n' => fun As As' il => ilist2_pair (Vector.tl As) (Vector.tl As')
        end As As' il with
    | 0 => fun _ _ _ => tt
    | S n' => fun As As' il => prim_snd il
    end As As' il. *)

  Fixpoint ith2_pair
           {m : nat}
           {As : Vector.t A m}
           {As' : Vector.t A' m}
           {il : ilist2 As}
           (ilp : ilist2_pair il As')
           (n : Fin.t m)
           {struct n}
    : C (Vector.nth As' n) (ith2 il n) .
        revert il ilp n; pattern m, As, As'.
        match goal with
          |- ?f m As As' => simpl; apply (Vector.rect2 f); simpl; intros
        end.
        - inversion n.
        - revert v1 v2 a b il ilp X; pattern n, n0.
          apply Fin.caseS; simpl.
          + intros; exact (prim_fst ilp).
          + intros; exact (X _ (prim_snd ilp) _).
  Defined.
End ilist2_pair.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Theory.Ordinal.
Require Import BBST.Theory.OrdinalOperation.

Section 序数递归.
Variable y₀ : 集合.
Variable F : 函数类型.

Definition 序数递归 := 序数递归 y₀ F.

Fact 序数递归的前段性质 : ∀α ⋵ 𝐎𝐍, ∀β ∈ α, (序数递归 ↑ β⁺)[β] = (序数递归 ↑ α)[β].
Proof. intros. rewrite <- 类函数限制之应用, <- 类函数限制之应用; auto. Qed.

End 序数递归.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Class SeparatingSemantics
      (L: Language)
      {sL: SeparationLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
{
  denote_sepcon: forall x y, Same_set _ (Kdenotation M (x * y)) (WeakSemantics.sepcon (Kdenotation M x) (Kdenotation M y));
  denote_wand: forall x y, Same_set _ (Kdenotation M (x -* y)) (StrongSemantics.wand (Kdenotation M x) (Kdenotation M y))
}.

Class EmpSemantics
      (L: Language)
      {sL: SeparationLanguage L}
      {s'L: SeparationEmpLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_emp: Same_set _ (Kdenotation M emp) StrongSemantics.emp.

Lemma sat_sepcon
      {L: Language}
      {sL: SeparationLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {usSM: SeparatingSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x * y <->
    exists m1 m2, join m1 m2 m /\
                  KRIPKE: M , m1 |= x /\
                  KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_sepcon x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_wand
      {L: Language}
      {sL: SeparationLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {usSM: SeparatingSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x -* y <->
    forall m0 m1 m2, m <= m0 ->
                     join m0 m1 m2 ->
                     KRIPKE: M , m1 |= x ->
                     KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_wand x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_emp
      {L: Language}
      {sL: SeparationLanguage L}
      {s'L: SeparationEmpLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {ueSM: EmpSemantics L MD M SM}:
  forall (m: Kworlds M), KRIPKE: M, m |= emp <-> increasing' m.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct denote_emp.
  split; [apply H | apply H0].
Qed.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


Require Import Sets.Ensembles.
Require Import Sets.Classical_sets.
Require Import Sets.Powerset.
Require Import Logic.
Require Import ClassicalFacts.
Require Import Omega.
Require Import Coq.Arith.Wf_nat.

(**** WP tactics library ****)
Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo.
Require Import Ranalysis.
Require Import Integration.
Require Import micromega.Lra.
Require Import Omega.
Require Import Max.
(* Require Import Unicode.Utf8. *)
Require Import Sets.Ensembles.
Require Import Sets.Classical_sets.

(** Guarantee indentation and introduce custom notation for forall *)
Notation "'for' 'all' x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' for  all  x .. y ']' , '//'  P ']'") : type_scope.

Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  only parsing) : type_scope.

Notation "'there' 'exists' x .. y , P " := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' there  exists  x .. y  ']' , '//'  P ']'") : type_scope.

Notation "∃ x .. y , P " := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  only parsing) : type_scope.

Notation "'fun' x .. y '↦' t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' 'fun' x .. y ']' '↦' '/' t ']'").

Notation "x ∨ y" := (x \/ y) (at level 85, right associativity) : type_scope.
Notation "x ∧ y" := (x /\ y) (at level 80, right associativity) : type_scope.
Notation "x → y" := (x -> y)
  (at level 99, y at level 200, right associativity,
   only parsing): type_scope.
Notation "x ⇒ y" := (x -> y)
  (at level 99, y at level 200, right associativity,
   only parsing): type_scope.
(* the notation below is fun, but is no good for functions *)
(* need to see if this can be adapted so it only uses
   this notation for propositions *)
(*Notation "'if' x 'then' y" := (x -> y)
  (at level 99, y at level 200, right associativity): prop_scope.*)
Notation "x ⇨ y" := (x -> y)
  (at level 99, y at level 200, right associativity): type_scope.

Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
Notation "x ⇔ y" := (x <-> y) (at level 95, no associativity): type_scope.
Notation "¬ x" := (~x) (at level 75, right associativity) : type_scope.
Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.

Notation "x ≤ y" := (le x y) (at level 70, no associativity) : nat_scope.
Notation "x ≥ y" := (ge x y) (at level 70, no associativity) : nat_scope.

Notation "x ≤ y" := (x <= y)%R (at level 70, no associativity) : R_scope.
Notation "x ≥ y" := (x >= y)%R (at level 70, no associativity) : R_scope.

Open Scope nat_scope.
Open Scope R_scope.

(* TODO: the below definition doesn't work very nicely *)
Notation "x ↦ y" := (fun x => y) (at level 0).

Notation "'ℕ'" := (nat).
Notation "'ℝ'" := (R).

(** Add field and lra to tactics to try automatically *)

Hint Extern 3 ( _ = _ ) => field : real.
Hint Extern 3 ( _ <= _ ) => lra : real.
Hint Extern 3 ( _ >= _ ) => lra : real.
Hint Extern 3 ( _ < _ ) => lra : real.
Hint Extern 3 ( _ > _ ) => lra : real.

Ltac wp_power :=
  timeout 5 (first [ solve [auto with *]
        | solve [eauto with *]
        | solve [firstorder (auto with *)]
        | solve [firstorder (eauto with *)]]).

Ltac intro_strict s t :=
  match goal with
    | [ |- forall _ : t, _ ] => intro s
  end.

Tactic Notation "Take" ident(s) ":" constr(t):=
  intro_strict s t.

Ltac assume_strict s t :=
  match goal with
    | [ |- ?u -> _ ] => (change u with t; intro s)
  end.

Tactic Notation "Assume" ident(s) :=
  intro s.

Tactic Notation "Assume" ident(s) ":" constr(t) :=
  assume_strict s t.

Ltac goal_check t :=
  tryif (change t)
    then (idtac "We indeed need to show that" t)
    else fail "This is not the current goal".

(** Make it possible to verify the goal t by writing
    "We need to show that t". *)
Tactic Notation "We" "need" "to" "show" "that" constr(t) :=
  goal_check t.

(** Make it possible to verify the goal t by writing
    "To show : t". *)
Tactic Notation "To" "show" ":" constr(t) :=
  goal_check t.

(** The tactic (hypo_check s t) checks if t is one of the
    current hypothesis, and if so, it renames it into s *)
Ltac hypo_check s t:=
match goal with
| [H : t |- _] => rename H into s
| _ => fail
end.

Tactic Notation "Choose" constr(t):=
  exists t.

Tactic Notation "Choose" ident(s) ":=" constr(t) :=
  pose (s := t);
  exists s.

Tactic Notation "Choose" ident(s)
                "such" "that" ident(u)
                "according" "to" constr(v) (*":" constr(t)*):=
  destruct v as [s u].

(*Tactic Notation "Choose" ident(s)
                "such" "that" ident(u)
                "according" "to" ident(v)
                "with" constr(t) :=
  destruct v with t as [s u]. *)

Tactic Notation "Choose" ident(s)
                "such" "that" ident(u)
                "according" "to" constr(v)
                "with" constr(t) :=
  destruct v with t as [s u].

Tactic Notation "Because" ident(s)
  "both" ident(u) "and" ident(v) :=
  destruct s as [u v].

Tactic Notation "Because" ident(s)
  "both" ident(u) ":" constr(t_u)
  "and"  ident(v) ":" constr(t_v):=
  destruct s as [u v].

Tactic Notation "Because" ident(s)
  "either" ident(u) "or" ident(v) :=
  destruct s as [u | v].

(** Apply with goal check
    The next tactics verify whether certain steps have the desired effect. *)
Ltac new_goal_verified_apply s t :=
  apply s;
  match goal with
  | [|- t] => idtac "Expected goal was produced"
  | _ => fail "Lemma did not produce expected outcome"
  end.

(*Tactic Notation "By" constr(s)
  "it" "suffices" "to" "show" "that"
  constr(t) :=
  new_goal_verified_apply s t.*)

(** A powerful forward reasoning tactic.
    The sequential trying of auto and eauto
    is there because eauto can be much slower.
    TODO: is this what we want? *)
Ltac new_hyp_verified_pose_proof s t u:=
  assert (u : t) by timeout 5 (first [ solve [auto using s with *]
                          | solve [eauto using s with *]
                          | solve [firstorder using s]
                          | solve [firstorder (eauto with *) using s]
                          | idtac "Waterproof could not find a proof. If you believe the statement should hold, try making a smaller step"]).

Tactic Notation "By" constr(s)
  "it" "holds" "that" constr(t) "("ident(u)")"
  := new_hyp_verified_pose_proof s t u.

(*Tactic Notation "By" constr(s0) "," constr(s1)
  "it" "holds" "that" constr(t) "("ident(u)")"
  :=*)

(* TODO: align syntax with "By ... it holds that" *)
Tactic Notation "It" "holds" "that"
  constr(t) "(" ident(u) ")" :=
  assert (u : t) by first [ wp_power
                          | idtac "Waterproof could not find a proof. If you believe the statement should hold, try making a smaller step"].

Ltac conclude_proof t :=
  match goal with
  | [|-t] => idtac
  | _ => (idtac "Warning: The statement you provided does not exactly correspond to the current goal. This can make your proof less readable."; change t || fail "The provided statement cannot be converted to the current goal. If you are trying to prove an intermediate step, add a name to your hypothesis between brackets at the end of the sentence.")
  end; first [wp_power | fail "Waterproof could not find a proof. Try making a smaller step."].

Tactic Notation "It" "holds" "that" constr(t) :=
  conclude_proof t.

Tactic Notation "It" "follows" "that" constr(t) :=
  conclude_proof t.

Tactic Notation "It" "suffices" "to" "show" "that"
  constr(t) :=
  enough t by ( wp_power || fail "Waterproof could not confirm that proving the statement would be enough.").

Tactic Notation "It" "suffices" "to" "show" "that"
  constr(t) "by" tactic(tac) :=
  enough t by tac.

Tactic Notation "Write" "goal" "using" constr(t) "as"
  constr(s) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u;
  enough s by wp_power;
  clear u.

Tactic Notation "Write" ident(H) "using" constr(t) "as"
  constr(s) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u in H;
  clear u.

Tactic Notation "This" "follows" "by" "assumption" :=
  assumption.

Tactic Notation "We" "claim" "that"
  constr(t) "(" ident(u) ")" :=
  assert (u : t).

Tactic Notation "Rewrite" "using" constr(t) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u;
  clear u.

Tactic Notation "rewrite" "using" constr(t) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u;
  clear u.

Tactic Notation "Rewrite" "using" constr(t) "in" ident(s):=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u in s;
  clear u.

Tactic Notation "rewrite" "using" constr(t) "in" ident(s):=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite u in s;
  clear u.

Tactic Notation "Rewrite" "<-" "using" constr(t) :=
  let u := fresh in
    assert (u : t) by wp_power;
  rewrite<-u;
  clear u.

Tactic Notation "replacing" constr(s) "with" constr(t) :=
  replace s with t by wp_power.

Tactic Notation "Apply" uconstr(t) :=
  apply t.

Tactic Notation "Unfold" constr(t) :=
  unfold t.

Tactic Notation "Unfold" constr(t) "in" ident(s):=
  unfold t in s.

Tactic Notation "Expand" "the" "definition" "of" reference(t) :=
  unfold t.

Tactic Notation "Expand" "the" "definition" "of"
  reference(t) "in" ident(s) :=
  unfold t in s.

Tactic Notation "Write" ident(s) "as" constr(t) :=
  change t in s.

Ltac trans_ineq eq_or_ineq :=
  match goal with
  | [|-?x ≤ ?z] =>
    match (type of eq_or_ineq) with
    | (x ≤ ?y) => apply (Rle_trans x y z eq_or_ineq)
    | _ => idtac "not a less-than-or-equal-to inequality"
    end
  | _ => idtac "Goal is not a less-than-or-equal-to inequality."
  end.

Tactic Notation "Define" ident(u) ":=" constr(t) :=
  set (u := t).

Tactic Notation "This" "follows" "by" "reflexivity" :=
  reflexivity.

Tactic Notation "Simplify" "what" "we" "need" "to" "show" :=
  simpl.

Hint Resolve Rmult_gt_0_compat : real.
Hint Resolve Rmult_lt_0_compat : real.

Ltac contra :=
  match goal with
  | [|- ?X] => destruct (classic X); try assumption
  | _ => idtac "failure of tactic"
  end.

Tactic Notation "We" "argue" "by" "contradiction" :=
  contra.

Tactic Notation "Contradiction" := contradiction.

Hint Resolve not_all_not_ex : contra_hints.
Hint Resolve not_all_ex_not : contra_hints.
Hint Resolve not_ex_all_not : contra_hints.
Hint Resolve ex_not_not_all : contra_hints.
Hint Resolve all_not_not_ex : contra_hints.

(********* own notations *************)

Notation "'subset' U" :=
  (Ensemble U) (at level 50).

Notation "'setOfSubsets' U" :=
  (Ensemble (subset U)) (at level 50).

Variable U : Type.

Notation "∅" :=
  (Empty_set U).

Notation "'Ω'" :=
  (Full_set U) (at level 0).

Notation "A ∩ B" :=
  (Intersection _ A B) (at level 50).

Notation "A ∪ B" :=
  (Union _ A B) (at level 50).

Notation "A \ B" :=
  (Setminus _ A B) (at level 50).

Notation "x ∈ A" :=
  (In _ A x) (at level 55).

Notation "x ∉ A" :=
  (¬ In _ A x) (at level 55).

Notation "A ⊂ B" :=
  (Included _ A B) (at level 50).

Notation "A B 'are disjoint'" :=
  (Disjoint _ A B) (at level 50).

Notation "｛ x : T | P ｝" :=
  (fun (x : T) ↦ P) (x at level 99).

Tactic Notation "We" "prove" "equality" "by" "proving" "two" "inclusions" :=
   apply Extensionality_Ensembles;
   unfold Same_set;
   unfold Included;
   split.

Tactic Notation "We" "prove" "by" "induction" "on" ident(x) :=
  induction x.
(*Not nicest formulation, but 'Proof' is already taken*)

(* horrible notation, just to test and probably to be
   replaced. Problem is that
  writing 'By ... it holds that ... (name)' does not
  conclude the proof.
*)
Tactic Notation "By" constr(u) "it" "holds" "that" constr(t) "which" "concludes" ident(the) "proof":=
  By u it holds that t (the);
  Apply the.

Ltac intros_strict x y t :=
  match goal with
    | [ |- forall _ _ : t, _] => intros x y
  end.

Tactic Notation "Take" ident(x) ident(y) ":" constr(t):=
  intros_strict x y t.
(*
Tactic Notation "Let" ident(A) "be" "a" "set" :=
  Take A : (subset U).

Tactic Notation "Let" ident(F) "be" "a" "set" "of" "sets" :=
  Take F : (setOfSubsets U).
*)
Hint Resolve Full_intro : measure_theory.  (*nieuwe database measure theory*)
Hint Resolve Intersection_intro : measure_theory.
Hint Resolve Union_introl Union_intror : measure_theory.
Hint Resolve Disjoint_intro : measure_theory.

Definition is_π_system (Π : setOfSubsets U)
  : Prop :=
    ∀ A : subset U, A ∈ Π ⇒
      ∀ B : subset U, B ∈ Π ⇒
         (A ∩ B) ∈ Π.

Notation "A is_a_π-system" :=
  (is_π_system A) (at level 50).

Definition Countable_union (A : (ℕ → subset U) )
  : subset U :=
    ｛ x:U | ∃n : ℕ, x ∈ (A n)｝.

Definition full_set_in_set (Λ : setOfSubsets U)
  : Prop :=
    Ω ∈ Λ.

Definition complement_in_set (Λ : setOfSubsets U)
  : Prop :=
    ∀A  : subset U, A ∈ Λ
      ⇒ (Ω \ A) ∈ Λ.

Definition closed_under_disjoint_countable_union (Λ : setOfSubsets U)
  : Prop :=
    ∀C : (ℕ → (subset U)),
      (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (C m) (C n))
        ⇒ (∀ n : ℕ, (C n) ∈ Λ) ⇒  (Countable_union C) ∈ Λ.

Definition closed_under_countable_union (Λ : setOfSubsets U)
  : Prop :=
    ∀C : (ℕ → (subset U)), (∀ n : ℕ, (C n) ∈ Λ)
      ⇒ (Countable_union C) ∈ Λ.

Definition is_λ_system (Λ : setOfSubsets U)
  : Prop :=
    full_set_in_set Λ ∧
    complement_in_set Λ ∧
    closed_under_disjoint_countable_union Λ.

Notation "A is_a_λ-system" :=
  (is_λ_system A) (at level 50).

Definition is_σ_algebra (F : setOfSubsets U)
  : Prop :=
    full_set_in_set F ∧
    complement_in_set F ∧
    closed_under_countable_union F.

Inductive σ_algebra : setOfSubsets U :=
  | σ_alg_omeg : full_set_in_set σ_algebra
  | σ_alg_comp : complement_in_set σ_algebra
  | σ_alg_cuCU : closed_under_countable_union σ_algebra.

Notation "A is_a_σ-algebra" :=
  (is_σ_algebra A) (at level 50).

Definition  σ_algebra_generated_by (A : setOfSubsets U)
  : (setOfSubsets U) :=
    ｛B : subset U | ∀ F : setOfSubsets U, F is_a_σ-algebra ⇒ (A ⊂ F ⇒ B ∈ F)｝ .

Notation "σ( A )" :=
 (σ_algebra_generated_by A) (at level 50).

Definition restriction (F : setOfSubsets U) (A : (subset U))
  : (setOfSubsets U) :=
    ｛C : subset U | ∃B : subset U, B ∈ F ⇒ C = A ∩ B｝.

(* ≤ only works for Reals *)
Definition finite_union (C : (ℕ ⇨ subset U) ) (n : ℕ)
  : subset U :=
    ｛x:U | (∃i : ℕ,  ((i ≤ n)%nat ∧ x ∈ (C i)))｝.

Definition finite_union_up_to (C : (ℕ ⇨ subset U) ) (n : ℕ)
  : (subset U) :=
    ｛x : U | (∃i : ℕ,  ((i < n)%nat ∧ x ∈ (C i)))｝.

Definition disjoint_seq (C : (ℕ ⇨ subset U) )
  : (ℕ ⇨ subset U)  :=
    fun (n:ℕ) ↦ (C n \ (finite_union_up_to C n)).
(**********************************)

Lemma complement_full_is_empty :
  ∅ = (Ω \ Ω).

Proof.
We prove equality by proving two inclusions.
Take x : U; Assume x_in_empty.
Contradiction.

Take x : U; Assume x_in_complement_full.
Because x_in_complement_full
  both x_in_full and not_x_in_full.
Contradiction.
Qed.

Lemma setminus_empty :
  ∀ A : subset U, A \ ∅ = A.

Proof.
Take A : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_A_wo_empty.
It holds that (x ∈ A).

Take x : U; Assume x_in_A.
It holds that (x ∈ (A \ ∅)).
Qed.

Lemma intersection_full :
  ∀ A : subset U, (Ω ∩ A) = A.

Proof.
Take A : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_intersection.
destruct x_in_intersection.
It holds that (x ∈ A).

Take x : U; Assume x_in_A.
It holds that (x ∈ Ω) (x_in_omega).
It follows that (x ∈ (Ω ∩ A)).
Qed.

Lemma intersection_empty :
  ∀ A : subset U, (A ∩ ∅) = ∅.

Proof.
Take A : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_intersection.
destruct x_in_intersection.
Contradiction.

Take x : U; Assume x_in_empty.
Contradiction.
Qed.

Lemma empty_disjoint :
  ∀ A : subset U, Disjoint _ A ∅.

Proof.
Take A : (subset U).
It suffices to show that (∀ x:U, x ∉ (A ∩ ∅)).
Take x : U.
By intersection_empty it holds that
  ((A ∩ ∅) = ∅) (int_empty).
Write goal using ((A ∩ ∅) = ∅) as (x ∉ ∅).
It holds that (x ∉ ∅).
Qed.

Lemma complement_as_intersection :
  ∀ A B : subset U,
    A \ B = (Ω \ B) ∩ A.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.

Take x : U.
Assume x_in_A_without_B.
It holds that (x ∈ ((Ω \ B) ∩ A)).

Take x : U.
Assume x_in_rhs.
By x_in_rhs it holds that
  (x ∈ (Ω \ B) ∧ (x ∈ A)) (x_in_A_and_comp_B).
It holds that (x ∈ (A \ B)).
Qed.

Lemma intersection_symmetric :
  ∀ A B : subset U, A ∩ B = B ∩ A.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_AB.
destruct x_in_AB.
It holds that (x ∈ (B ∩ A)).

Take x : U; Assume x_in_BA.
destruct x_in_BA.
It holds that (x ∈ (A ∩ B)).
Qed.

Lemma disjoint_symmetric :
  ∀ A B : subset U, (Disjoint _ A B) ⇒ (Disjoint _ B A).

Proof.
Take A B : (subset U).
Assume A_B_disjoint.
destruct A_B_disjoint.
By intersection_symmetric it holds that
  ((A ∩ B) = (B ∩ A)) (AB_is_BA).
Write H using ((A ∩ B) = (B ∩ A))
  as (∀ x : U, x ∉ (B ∩ A)).
It follows that (Disjoint U B A).
Qed.
(*include last two in library? Should be trivial. *)
Open Scope nat.

Lemma not_in_comp :
  ∀ A : subset U, ∀ x : U,
    x ∉ (Ω \ A) ⇒ x ∈ A.

Proof.
Take A : (subset U); Take x : U.
Assume x_not_in_complement.
We argue by contradiction.
It holds that (x ∈ (Ω \ A)) (x_in_complement).
Contradiction.
Qed.

Lemma neq_equiv : ∀ x y : ℕ,
  (x ≠ y) ⇒ (x < y ∨ y < x).

Proof.
intros x y. omega.
Qed.

Lemma leq_equiv : ∀ x y : ℕ,
  (x <= y) ⇒ (x < y ∨ x = y).

Proof.
intros x y. omega.
Qed.

Lemma geq_equiv : ∀ x y : ℕ,
  (x >= y) ⇒ (x = y ∨ x > y).

Proof.
intros x y. omega.
Qed.

Lemma union_to_or :
  ∀ A B : (subset U), ∀ x : U,
    x ∈ (A ∪ B) ⇒ (x ∈ A ∨ x ∈ B).

Proof.
Take A B : (subset U).
Take x : U; Assume x_in_union.
destruct x_in_union.
(* x ∈ A: *)
It follows that (x ∈ A ∨ x ∈ B).
(* x ∈ B: *)
It follows that (x ∈ A ∨ x ∈ B).
Qed.

Lemma FU_up_to_0_empty :
  ∀ C : (ℕ ⇨ subset U), finite_union_up_to C 0 = ∅.

Proof.
Take C : (ℕ ⇨ subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_FU_0.
Write x_in_FU_0 as
  (x ∈ ｛x : U | ∃ i : ℕ , i < 0 ∧ x ∈ C i｝).
It holds that (¬(∃i : ℕ, i<0 ∧ x ∈ C i)) (no_N_l_0).
Contradiction.

Take x : U; Assume x_in_empty.
Contradiction.
Qed.

Lemma disj_seq_disjoint :
  ∀ C : (ℕ ⇨ subset U),
    (∀ m n : ℕ, m ≠ n ⇒ Disjoint _
      (disjoint_seq C m) (disjoint_seq C n)).

Proof.
Take C : (ℕ ⇨ subset U).
Take m n : ℕ.
Assume m_neq_n.
By neq_equiv it holds that
  (m ≠ n ⇒ (m < n) ∨ (m > n)) (m_l_g_n).
It holds that ((m < n) ∨ (m > n)) (m_lg_n).
We argue by contradiction.
It holds that (∃ x : U,
  x ∈ ((disjoint_seq C m) ∩ (disjoint_seq C n))) (int_not_empty).
Choose x such that x_in_int according to int_not_empty.
By x_in_int it holds that
  (x ∈ disjoint_seq C m
    ∧ x ∈ disjoint_seq C n) (x_in_m_and_n).
By x_in_m_and_n it holds that
  (x ∈ disjoint_seq C m) (x_in_m).
By x_in_m_and_n it holds that
  (x ∈ disjoint_seq C n) (x_in_n).
It holds that
  ((x ∉ finite_union_up_to C m)
    ∧ (x ∉ finite_union_up_to C m)) (x_not_in_FU_mn).
It holds that
  (¬(∃i : ℕ,  (i < m ∧ x ∈ (C i)))
    ∧ ¬(∃i : ℕ,  (i < n ∧ x ∈ (C i)))) (no_i).
Because no_i both no_i_m and no_i_n.
Because m_lg_n either m_l_n or m_g_n.
(* m < n: *)
By no_i_m it holds that ((x ∉  C m)) (x_not_in_Cm).
By x_in_m it holds that (x ∈ C m) (x_in_Cm).
Contradiction.
(* m > n: *)
By no_i_n it holds that ((x ∉ C n)) (x_not_in_Cn).
By x_in_m it holds that (x ∈ C n) (x_in_Cn).
Contradiction.
Qed.

Lemma CU_sets_disjointsets_equal :
  ∀ C : (ℕ ⇨ subset U),
    Countable_union (disjoint_seq C) = Countable_union C.

Proof.
Take C : (ℕ ⇨ subset U).
Define D := (disjoint_seq C).
We prove equality by proving two inclusions.

(* CU disjoint sets in CU C: *)
Take x : U; Assume x_in_CU_D.
It holds that (x ∈ Countable_union C).

(* CU C in CU disjoint sets: *)
Take x : U; Assume x_in_CU_C.
(*now choose minimal n such that x is in disj_C n*)
Choose n such that x_in_C_n according to x_in_CU_C.
Define aux_prop := (fun (n : ℕ) ↦ (x ∈ C n)).
By classic it holds that
  (∀ n, aux_prop n ∨ ¬aux_prop n) (aux_prop_decidable).
By dec_inh_nat_subset_has_unique_least_element it holds that
  (has_unique_least_element le aux_prop) (exists_least_n).
Choose n1 such that x_in_C_minimal_n according to exists_least_n.

It holds that (x ∈ Countable_union D).
Qed.

Lemma complements_in_π_and_λ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ∧ F is_a_λ-system
    ⇒ ∀ A B : subset U, A ∈ F ∧ B ∈ F
      ⇒ A \ B ∈ F.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_and_λ_system.
By F_is_π_and_λ_system
  it holds that (F is_a_π-system) (F_is_π_system).
By F_is_π_and_λ_system
  it holds that (F is_a_λ-system) (F_is_λ_system).
Take A B : (subset U).
Assume A_and_B_in_F.
By F_is_λ_system it holds that
  (Ω \ B ∈ F) (comp_B_in_F).
By F_is_π_system it holds that
  (A ∩ (Ω \ B) ∈ F) (set_in_F).
By complement_as_intersection it holds that
  (A \ B = (Ω \ B) ∩ A) (set_is_complement).
Write goal using (A \ B = ((Ω \ B) ∩ A))
  as (((Ω \ B) ∩ A) ∈ F).
It holds that (((Ω \ B) ∩ A) ∈ F).
Qed.

Lemma union_as_complements :
  ∀ A B : subset U,
    (A ∪ B) = (Ω \ ((Ω \ A) ∩ (Ω \ B))).

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_union.
By union_to_or it holds that
  (x ∈ A ∨ x ∈ B) (x_in_A_or_B).
By classic it holds that
  (¬((x ∉ A) ∧ (x ∉ B))) (not_not_A_and_not_B).
By not_not_A_and_not_B it holds that
  (¬(x ∈ (Ω \ A) ∧ x ∈ (Ω \ B))) (not_compA_and_compB).
By not_compA_and_compB it holds that
  (x ∉ ((Ω \ A) ∩ (Ω \ B))) (not_compA_int_compB).
It holds that (x ∈ (Ω \ ((Ω \ A) ∩ (Ω \ B)))).

Take x : U; Assume x_in_comp.
We argue by contradiction.
By union_to_or it holds that (¬ (x ∈ A ∨ x ∈ B)) (not_A_or_B).

It holds that
  (x ∉ ((Ω \ A) ∩ (Ω \ B))) (not_compA_int_compB).
By not_compA_int_compB it holds that
  (¬(x ∈ (Ω \ A) ∧ x ∈ (Ω \ B))) (not_compA_and_compB).
By not_compA_and_compB it holds that
  (¬((x ∉ A) ∧ (x ∉ B))) (not_not_A_and_not_B).
By not_not_A_and_not_B it holds that
  ((x ∈ A ∨ x ∈ B)) (A_or_B).
Contradiction.
Qed.

Lemma unions_in_π_and_λ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ⇒ F is_a_λ-system
    ⇒ ∀ A B : subset U, A ∈ F ⇒ B ∈ F
      ⇒ A ∪ B ∈ F.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_system; Assume F_is_λ_system.
Take A B : (subset U).
Assume A_in_F; Assume B_in_F.

By union_as_complements it holds that
  ((A ∪ B) = (Ω \ ((Ω \ A) ∩ (Ω \ B)))) (union_is_comp).
Write goal using
  ((A ∪ B) = (Ω \ ((Ω \ A) ∩ (Ω \ B))))
    as ((Ω \ ((Ω \ A) ∩ (Ω \ B))) ∈ F).
By F_is_λ_system it holds that
  ((Ω \ A) ∈ F) (comp_A_in_F).
By F_is_λ_system it holds that
  ((Ω \ B) ∈ F) (comp_B_in_F).
By F_is_π_system it holds that
  ((Ω \ A) ∩ (Ω \ B) ∈ F) (int_in_F).
It holds that ((Ω \ ((Ω \ A) ∩ (Ω \ B))) ∈ F).
Qed.

Lemma empty_in_λ :
  ∀ F : setOfSubsets U,
    F is_a_λ-system ⇒ ∅ ∈ F.

Proof.
Take F : (setOfSubsets U); Assume F_is_λ_system.
By complement_full_is_empty it holds that
  (∅ = (Ω \ Ω)) (comp_full_empty).
Write goal using (∅ = (Ω \ Ω)) as ((Ω \ Ω) ∈ F).
It holds that ((Ω \ Ω) ∈ F).
Qed.

Lemma FU_S_as_union :
  ∀ C : (ℕ → (subset U)), ∀ n : ℕ,
    finite_union_up_to C (S n)
      = (finite_union_up_to C n) ∪ (C n).

Proof.
Take C : (ℕ → (subset U)).
Take n : ℕ.
We prove equality by proving two inclusions.
Take x : U; Assume x_in_FU_S.
Choose n0 such that x_in_C_n0 according to x_in_FU_S.
It holds that (n0 <= n) (n0_le_n). (*avoid %nat? *)
By leq_equiv it holds that
  (n0 < n ∨ n0 = n) (n0_l_e_n).
Because  n0_l_e_n either n0_l_n or n0_is_n.
(*n0 < n*)
It holds that (x ∈ (finite_union_up_to C n)) (x_in_FU).
It holds that (x ∈ (finite_union_up_to C n ∪ C n)).
(*n0 = n*)
Write goal using (n = n0) as
  (x ∈ (finite_union_up_to C n0 ∪ C n0)).
It holds that (x ∈ C n0) (x_in_Cn0).
It holds that ( x ∈ (finite_union_up_to C n0 ∪ C n0)).

Take x : U; Assume x_in_FU_with_Cn.
By union_to_or it holds that
  ((x ∈ (finite_union_up_to C n)) ∨ (x ∈ C n)) (x_in_FU_or_Cn).
It holds that (x ∈ finite_union_up_to C (S n)).
Qed.

Lemma FU_in_π_and_λ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ⇒ F is_a_λ-system
    ⇒ ∀ C : (ℕ → (subset U)), (∀ n : ℕ, (C n) ∈ F)
      ⇒ ∀ n : ℕ, (finite_union_up_to C n) ∈ F.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_system.
Assume F_is_λ_system.
Take C : (ℕ ⇨ subset U).
Assume all_Cn_in_F.
Take n : ℕ.
We prove by induction on n.
(* Base case: *)
By FU_up_to_0_empty it holds that
  (finite_union_up_to C 0 = ∅) (FU0_is_empty).
Write goal using (finite_union_up_to C 0 = ∅)
  as (∅ ∈ F).
Apply empty_in_λ; Apply F_is_λ_system.
(* Induction step: *)
By FU_S_as_union it holds that
  (finite_union_up_to C (S n)
    = (finite_union_up_to C n) ∪ (C n)) (FU_union).
Write goal using
  (finite_union_up_to C (S n)
    = (finite_union_up_to C n) ∪ (C n))
      as ((finite_union_up_to C n) ∪ (C n) ∈ F).
By all_Cn_in_F it holds that (C n ∈ F) (Cn_in_F).
By unions_in_π_and_λ it holds that
  ((finite_union_up_to C n ∪ C n) ∈ F) (xx).
Apply xx.
Qed.

Lemma π_and_λ_is_σ :
  ∀ F : setOfSubsets U,
    F is_a_π-system ⇒ F is_a_λ-system
      ⇒ F is_a_σ-algebra.

Proof.
Take F : (setOfSubsets U).
Assume F_is_π_system.
Assume F_is_λ_system.
It holds that
  (closed_under_disjoint_countable_union F) (cu_disj_CU).
We need to show that (full_set_in_set F
  ∧ complement_in_set F
    ∧ closed_under_countable_union F).
split. (*WP version for split?*)
It holds that (full_set_in_set F) .
split.
It holds that (complement_in_set F).

We need to show that (∀ C : ℕ ⇨ subset U,
  (∀ n : ℕ, C n ∈ F)
    ⇒ Countable_union C ∈ F).
Take C : (ℕ ⇨ subset U); Assume all_C_n_in_F.
By classic it holds that
  ((∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (C m) (C n)) ∨
  ¬(∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (C m) (C n))) (all_or_not_all_disjoint).
Because all_or_not_all_disjoint
  either all_disjoint or not_all_disjoint.
(*Case 1: all C_n disjoint.*)
It holds that (Countable_union C ∈ F).
(*Case 2: not all C_n disjoint. *)
By CU_sets_disjointsets_equal it holds that
  (Countable_union (disjoint_seq C) = Countable_union C) (CUdisj_is_CU).
Write goal using
  (Countable_union C = Countable_union (disjoint_seq C))
    as (Countable_union (disjoint_seq C) ∈ F).

We claim that (∀ n : ℕ, disjoint_seq C n ∈ F) (disj_in_F).
Take n : ℕ.
By FU_in_π_and_λ it holds that
  ((finite_union_up_to C n) ∈ F) (FU_in_F).
By complements_in_π_and_λ it holds that
  ((C n) \ (finite_union_up_to C n) ∈ F) (comp_in_F).
Write goal using
  (disjoint_seq C n = (C n \ finite_union_up_to C n))
    as ((C n \ finite_union_up_to C n) ∈ F).
Apply comp_in_F.

By disj_seq_disjoint it holds that
  ((∀ m n : ℕ, m ≠ n ⇒
    Disjoint _
      (disjoint_seq C m) (disjoint_seq C n))) (disj_seq_disj).
It holds that (Countable_union (disjoint_seq C) ∈ F).
Qed.

Lemma generated_system_is_λ :
  ∀ A : setOfSubsets U,
    λ(A) is_a_λ-system.

Proof.
Take A : (setOfSubsets U).
We need to show that (full_set_in_set (λ(A))
  ∧ complement_in_set (λ(A))
    ∧ closed_under_disjoint_countable_union (λ(A))).
It holds that (∀ Λ : setOfSubsets U,
  Λ is_a_λ-system ⇒ (full_set_in_set Λ)
    ∧ complement_in_set Λ
      ∧ closed_under_disjoint_countable_union Λ)
        (lambda_props_for_all).
split.
It follows that (full_set_in_set (λ(A))).
split.
It follows that (complement_in_set (λ(A))).

We need to show that (∀ C : ℕ ⇨ set,
  (∀ m n : ℕ, m ≠ n ⇒ Disjoint U (C m) (C n))
    ⇒ (∀ n : ℕ, C n ∈ λ(A))
      ⇒ Countable_union C ∈ λ(A)).
Take C : (ℕ ⇨ subset U).
Assume all_Cn_disjoint.
Assume all_Cn_in_λA.

We claim that (∀ Λ : setOfSubsets U,
  Λ is_a_λ-system ⇒ A ⊂ Λ
    ⇒ (Countable_union C) ∈ Λ) (CU_in_all).
Take Λ : (setOfSubsets U).
Assume Λ_is_λ_system.
Assume A_subs_Λ.
It holds that
  (closed_under_disjoint_countable_union Λ)
    (closed_under_disj_CU).
It holds that (
  (∀ m n : ℕ, m ≠ n ⇨ Disjoint U (C m) (C n))
    ⇒ ∀ n : ℕ, C n ∈ Λ) (disj_implies_all_Cn_in_Λ).
It follows that (Countable_union C ∈ Λ).
It follows that (Countable_union C ∈ λ(A)).
Qed.

Fixpoint aux_seq (A B : subset U) (n : ℕ) {struct n}
  : (subset U) :=
    match n with
      0 => A
    | 1 => B
    | n => ∅
    end.

Lemma CU_aux_is_union :
  ∀ A B : subset U, Countable_union (aux_seq A B) = A ∪ B.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_CU.
Choose n such that x_in_C_n according to x_in_CU.
We prove by induction on n.
It holds that (x ∈ (A ∪ B)).
We prove by induction on n.
It holds that (x ∈ (A ∪ B)).

(* Write x_in_C_n as (x ∈ ∅).  *)
Contradiction.

Take x : U; Assume x_in_intersection.
destruct x_in_intersection.
It holds that (x ∈ aux_seq A B 0) (x_in_aux0).
We need to show that
  (x ∈ ｛x0 : U | ∃ n : ℕ, x0 ∈ aux_seq A B n｝).
It holds that (∃ n : ℕ, x ∈ aux_seq A B n) (exists_n_A).
It follows that (x ∈ Countable_union (aux_seq A B)).

It holds that (x ∈ aux_seq A B 1) (x_in_aux0).
We need to show that
  (x ∈ ｛x0 : U | ∃ n : ℕ, x0 ∈ aux_seq A B n｝).
It holds that (∃ n : ℕ, x ∈ aux_seq A B n) (exists_n_B).
It follows that (x ∈ Countable_union (aux_seq A B)).
Qed.

Lemma disjoint_aux :
  ∀ A B : subset U, (Disjoint _ A B)
    ⇒ (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (aux_seq A B m) (aux_seq A B n)).

Proof.
Take A B : (subset U).
Assume A_B_disjoint.
Take m n : ℕ.
Assume m_neq_n.
We prove by induction on m.
We prove by induction on n.
(*Case m = n = 0:*)
Contradiction.
(*Case m=0, n=1:*)
We prove by induction on n.
Write goal using (aux_seq A B 1 = B) as (Disjoint U (aux_seq A B 0) B).
Write goal using (aux_seq A B 0 = A) as (Disjoint U A B).
It holds that (Disjoint U A B).
(*Case m=0, n>1*)
Write goal using (aux_seq A B (S (S n)) = ∅)
  as (Disjoint U (aux_seq A B 0) ∅).
By empty_disjoint it holds that
  (Disjoint U (aux_seq A B 0) ∅) (xx).
Apply xx.
(*Case m =1, n=0: *)
We prove by induction on m.
We prove by induction on n.
Write goal using (aux_seq A B 1 = B)
  as (Disjoint U B (aux_seq A B 0)).
Write goal using (aux_seq A B 0 = A)
  as (Disjoint U B A).
By disjoint_symmetric it holds that
  ((Disjoint _ B A)) (xx).
Apply xx.
(*Case m=n=1: *)
We prove by induction on n.
Contradiction.
(*Case m=1, n>1: *)
Write goal using (aux_seq A B (S (S n)) = ∅)
  as (Disjoint U (aux_seq A B 1) ∅).
By empty_disjoint it holds that
  (Disjoint U (aux_seq A B 1) ∅) (xx).
Apply xx.
(*Case m>n: *)
Write goal using (aux_seq A B (S (S m)) = ∅)
  as (Disjoint U ∅ (aux_seq A B n)).
By disjoint_symmetric it holds that
  (Disjoint U (aux_seq A B n) ∅
    ⇒ Disjoint U ∅ (aux_seq A B n)) (disj_symm).
It suffices to show that (Disjoint U (aux_seq A B n) ∅).
Apply empty_disjoint.
Qed.

Lemma disj_union_in_λ_system :
  ∀ Λ : setOfSubsets U, Λ is_a_λ-system
    ⇒ ∀ A B : subset U, A ∈ Λ ⇒ B ∈ Λ
      ⇒ Disjoint _ A B ⇒ A ∪ B ∈ Λ.

Proof.
Take Λ : (setOfSubsets U); Assume Λ_is_a_λ_system.
Take A B : (subset U).
Assume A_in_Λ; Assume B_in_Λ.
Assume A_B_disjoint.

We claim that (∀ n : ℕ, aux_seq A B n ∈ Λ) (all_aux_in_Λ).
Take n : ℕ.
We prove by induction on n.
It holds that (aux_seq A B 0 ∈ Λ).
We prove by induction on n. (*0 and 1 defined, rest inductively. Other way? *)
It holds that (aux_seq A B 1 ∈ Λ).
Write goal using (aux_seq A B (S (S n)) = ∅)
  as (∅ ∈ Λ).
By empty_in_λ it holds that
  (∅ ∈ Λ) (empty_in_Λ).
Apply empty_in_Λ.

By CU_aux_is_union it holds that
  (A ∪ B = Countable_union (aux_seq A B)) (union_to_CU).
Write goal using (A ∪ B = Countable_union (aux_seq A B))
  as (Countable_union (aux_seq A B) ∈ Λ).

By disjoint_aux it holds that
  (∀ m n : ℕ, m ≠ n ⇒ Disjoint _ (aux_seq A B m) (aux_seq A B n)) (aux_disjoint).
By Λ_is_a_λ_system it holds that
  (closed_under_disjoint_countable_union Λ) (closed_under_disj_CU).
It holds that ((∀ m n : ℕ, m ≠ n ⇒ Disjoint U (aux_seq A B m) (aux_seq A B n))
    ⇒ (for all n : ℕ, aux_seq A B n ∈ Λ)) (props_cu_disj_CU).
By closed_under_disj_CU it holds that ((Countable_union (aux_seq A B)) ∈ Λ) (xx).
Apply xx.
Qed.

Lemma intersection_and_complement_disjoint :
  ∀ A B : subset U, Disjoint _ (A ∩ B) (Ω \ B).

Proof.
Take A B : (subset U).
It suffices to show that (∀ x : U, x ∉ ((A ∩ B) ∩ (Ω \ B))).
Take x : U.
We argue by contradiction.
We claim that (x ∈ ((A ∩ B) ∩ (Ω \ B))) (x_in_AB_and_comp).
Apply NNPP; Apply H.
destruct x_in_AB_and_comp.
destruct H0.
By H1 it holds that (x ∉ B) (x_not_in_B).
Contradiction.
Qed.

Lemma complement_as_union_intersection :
  ∀ A B : subset U, (Ω \ ((A ∩ B) ∪ (Ω \ B))) = (Ω \ A) ∩ B.

Proof.
Take A B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_lhs.
destruct x_in_lhs.
By H0 it holds that
  ((x ∉ (A ∩ B)) ∧ (x ∉ (Ω \ B))) (x_not_in_int_comp).
Because x_not_in_int_comp
  both x_not_in_int and x_not_in_comp.
By x_not_in_int it holds that
  (x ∉ A) (x_not_in_A).
It holds that (x ∈ (Ω \ A)) (x_in_comp_A).
By not_in_comp it holds that (x ∈ B) (x_in_B).
It follows that (x ∈ ((Ω \ A) ∩ B)).

Take x : U; Assume x_in_rhs.
destruct x_in_rhs. (*"Because x_in_rhs both x_in_comp_A and x_in_B" doesn't work*)
By H it holds that (x ∉ A) (x_not_in_A).
By H0 it holds that (x ∉ (Ω \ B)) (x_not_in_comp).

We claim that (x ∉ (A ∩ B)) (x_not_in_AB).
We argue by contradiction.
We claim that (x ∈ (A ∩ B)) (x_in_AB).
Apply NNPP; Apply H1.
destruct x_in_AB.
Contradiction.

We claim that (x ∉ ((A ∩ B) ∪ (Ω \ B))) (x_not_in_union).
We argue by contradiction.
We claim that (x ∈ ((A ∩ B) ∪ (Ω \ B))) (x_in_union).
Apply NNPP; Apply H1.
Because x_in_union either x_in_AB or x_in_comp.
Contradiction.
Contradiction. (*tactic 'contradiction in both cases'? *)
It follows that (x ∈ (Ω \ ((A ∩ B) ∪ (Ω \ B)))).
Qed.

Definition H (B : subset U) (λΠ : setOfSubsets U)
  : setOfSubsets U :=
    ｛A : (subset U) | (A ∩ B ∈ λΠ) ｝.

Definition seq_intersection (C : (ℕ ⇨ subset U)) (B : subset U)
  : ℕ ⇨ set :=
    fun (n : ℕ) ↦ ((C n) ∩ B).

Lemma C_int_B_disjoint :
  ∀ C : (ℕ ⇨ subset U), ∀ B : subset U,
    (∀ m n : ℕ, m ≠ n ⇨ Disjoint U (C m) (C n))
      ⇒ ∀ m n : ℕ, m ≠ n
        ⇒ Disjoint U (seq_intersection C B m) (seq_intersection C B n).

Proof.
Take C : (ℕ ⇨ subset U); Take B : (subset U).
Assume all_Cn_disjoint.
Take m n : ℕ.
Assume m_neq_n.
By all_Cn_disjoint it holds that
  (Disjoint U (C m) (C n)) (Cm_Cn_disj).
We argue by contradiction.
By H0 it holds that
  (∃ x : U, x ∈ ((C m ∩ B) ∩ (C n ∩ B))) (exists_x_in_CmB_CnB).
Choose x such that x_in_CmB_CnB
  according to exists_x_in_CmB_CnB.
By x_in_CmB_CnB it holds that
  (x ∈ (C m ∩ B) ∧ x ∈ (C n ∩ B)) (x_in_CmB_and_CnB).
Because x_in_CmB_and_CnB
  both x_in_CmB and x_in_CnB.
By x_in_CmB it holds that
  (x ∈ C m ∧ x ∈ B) (x_in_Cm_and_B).
It holds that (x ∈ C m) (x_in_Cm).
By x_in_CnB it holds that
  (x ∈ C n ∧ x ∈ B) (x_in_Cn_and_B).
It holds that (x ∈ C n) (x_in_Cn).
It holds that
  (x ∈ C n ∧ x ∈ C m) (x_in_Cm_and_Cn).
By x_in_Cm_and_Cn it holds that
  (x ∈ (C m ∩ C n)) (x_in_Cm_Cn).
destruct Cm_Cn_disj.
By H1 it holds that (x ∉ (C m ∩ C n)) (x_not_in_Cm_Cn).
Contradiction.
Qed.

Lemma CU_seq_int_is_CU_int :
  ∀ C : (ℕ ⇨ subset U), ∀ B : subset U,
    Countable_union (seq_intersection C B) = (Countable_union C) ∩ B.

Proof.
Take C : (ℕ ⇨ subset U); Take B : (subset U).
We prove equality by proving two inclusions.
Take x : U; Assume x_in_lhs.
Choose n such that x_in_seq_Cn according to x_in_lhs.
destruct x_in_seq_Cn.
By H0 it holds that (x ∈ Countable_union C) (x_in_CU).
By H1 it holds that (x ∈ B) (x_in_B).
It follows that (x ∈ (Countable_union C ∩ B)).

Take x : U; Assume x_in_rhs.
By x_in_rhs it holds that
  (x ∈ Countable_union C ∧ x ∈ B) (x_in_CU_and_B).
Because x_in_CU_and_B both x_in_CU and x_in_B.
Choose n such that x_in_Cn according to x_in_CU.
It holds that (x ∈ C n ∧ x ∈ B) (x_in_Cn_and_B).
By x_in_Cn_and_B it holds that
  (x ∈ ((C n) ∩ B)) (x_in_CnB).
It holds that (x ∈ (seq_intersection C B n)) (x_in_seq_n).
It follows that (x ∈ Countable_union (seq_intersection C B)).
Qed.

Lemma H_is_λ_system :
  ∀ Π : setOfSubsets U, Π is_a_π-system
    ⇒ ∀ B : subset U, B ∈ (λ(Π))
      ⇒ (H B (λ(Π))) is_a_λ-system.

Proof.
Take Π : (setOfSubsets U); Assume Π_is_a_π_system.
Take B : (subset U); Assume B_in_λΠ.
Define H := (H B (λ(Π))).
We need to show that (full_set_in_set H
  ∧ complement_in_set H
    ∧ closed_under_disjoint_countable_union H).
split.

We claim that (Ω ∩ B ∈ λ(Π)) (omega_int_B_in_λΠ).
By intersection_full it holds that
  (Ω ∩ B = B) (omega_int_B_is_B).
Write goal using (Ω ∩ B = B) as (B ∈ λ(Π)).
It holds that (B ∈ (λ(Π))).
It follows that (full_set_in_set H).

split.
We need to show that (∀ A : subset U,
  A ∈ H ⇒ (Ω \ A) ∈ H).
Take A : (subset U); Assume A_in_H.
We claim that (((A ∩ B) ∪ (Ω \ B)) ∈ λ(Π)) (union_in_λΠ).
Apply disj_union_in_λ_system.
By generated_system_is_λ it holds that
  ((λ(Π)) is_a_λ-system) (xx).
Apply xx.
It holds that (A ∩ B ∈ λ(Π)).
It holds that (Ω \ B ∈ λ(Π)).
By intersection_and_complement_disjoint it holds that
  (Disjoint _ (A ∩ B) (Ω \ B)) (xx).
Apply xx.

It holds that ((Ω \ ((A ∩ B) ∪ (Ω \ B))) ∈ λ(Π)) (comp_in_λΠ).
By complement_as_union_intersection it holds that
  ((Ω \ ((A ∩ B) ∪ (Ω \ B))) = (Ω \ A) ∩ B) (to_int).
Write comp_in_λΠ using
  ((Ω \ ((A ∩ B) ∪ (Ω \ B))) = (Ω \ A) ∩ B)
    as ((Ω \ A) ∩ B ∈ λ(Π)).
By comp_in_λΠ it holds that ((Ω \ A) ∈ H) (xx).
Apply xx.

We need to show that (∀ C : ℕ ⇨ set,
  (∀ m n : ℕ, m ≠ n ⇒ Disjoint U (C m) (C n))
    ⇒ (∀ n : ℕ, C n ∈ H)
      ⇒ Countable_union C ∈ H).
Take C : (ℕ ⇨ subset U).
Assume all_Cn_disjoint; Assume all_Cn_in_H.
By all_Cn_in_H it holds that
  (∀ n : ℕ, ((C n) ∩ B) ∈ λ(Π)) (all_CnB_in_λΠ).
By C_int_B_disjoint it holds that
  (∀ m n : ℕ, m ≠ n ⇒ Disjoint _
    (seq_intersection C B m)
      (seq_intersection C B n)) (all_CnB_disjoint).
We claim that (Countable_union (seq_intersection C B) ∈ λ(Π)) (CU_in_λΠ).
By generated_system_is_λ it holds that
  ((λ(Π)) is_a_λ-system) (λΠ_is_λ).
By λΠ_is_λ it holds that
  (closed_under_disjoint_countable_union (λ(Π))) (λΠ_closed_under_CU).
It follows that (Countable_union (seq_intersection C B) ∈ (λ( Π))).
By CU_seq_int_is_CU_int it holds that
  (Countable_union (seq_intersection C B) = (Countable_union C) ∩ B) (CUs_equal).
Write CU_in_λΠ using
  (Countable_union (seq_intersection C B) = (Countable_union C) ∩ B)
    as ((Countable_union C) ∩ B ∈ (λ( Π))).
It follows that (Countable_union C ∈ H).
Qed.

Lemma Π_subset_H :
  ∀ Π : setOfSubsets U, Π is_a_π-system
    ⇒ ∀ B : subset U, B ∈ Π
        ⇒ Π ⊂ H B (λ(Π)).

Proof.
Take Π : (setOfSubsets U); Assume Π_is_π_system.
Take B : (subset U); Assume B_in_Π.
We need to show that (∀ C : subset U,
  C ∈ Π ⇒ C ∈ H B (λ( Π))).
Take C : (subset U); Assume C_in_Π.
By Π_is_π_system it holds that
  (C ∩ B ∈ Π) (CB_in_Π).
It follows that (C ∈ H B (λ(Π))).
Qed.

Lemma int_in_λΠ :
  ∀ Π : setOfSubsets U, Π is_a_π-system
    ⇒ ∀ A : subset U, A ∈(λ(Π))
      ⇒ ∀ B : subset U, B ∈ Π
        ⇒ (A ∩ B) ∈ (λ(Π)).

Proof.
Take Π : (setOfSubsets U); Assume Π_is_π_system.
Take A : (subset U); Assume A_in_λΠ.
Take B : (subset U); Assume B_in_Π.
It holds that (B ∈ λ(Π)) (B_in_λΠ).
By H_is_λ_system it holds that
  ((H B (λ(Π))) is_a_λ-system) (H_is_λ_system).
By Π_subset_H it holds that
  (Π ⊂ H B (λ(Π))) (Π_subs_H).
It holds that (λ(Π) ⊂ H B (λ(Π))) (λΠ_subs_H).
It holds that (A ∈ H B (λ(Π))) (A_in_H).
It follows that ((A ∩ B) ∈ λ(Π)).
Qed.

Lemma λΠ_is_σ_algebra :
  ∀ Π : setOfSubsets U, Π is_a_π-system
    ⇒ λ(Π) is_a_σ-algebra.

Proof.
Take Π : (setOfSubsets U).
Assume Π_is_π_system.
We claim that (λ(Π) is_a_π-system) (λΠ_is_π).
We need to show that (
  ∀ A : subset U, A ∈ (λ(Π))
    ⇒ ∀ B : subset U, B ∈ (λ(Π))
      ⇒ (A ∩ B) ∈ (λ(Π))).
Take A : (subset U); Assume A_in_λΠ.
Take B : (subset U); Assume B_in_λΠ.
We claim that (Π ⊂ H B (λ(Π))) (Π_subs_H).
We need to show that
  (∀ C : subset U, C ∈ Π ⇒ C ∈ H B (λ(Π))).
Take C : (subset U); Assume C_in_Π.
By int_in_λΠ it holds that
  ((B ∩ C) ∈ λ(Π)) (BC_in_λΠ).
By intersection_symmetric it holds that
  (B ∩ C = C ∩ B) (CB_is_BC).
Write BC_in_λΠ using (B ∩ C = C ∩ B)
  as ((C ∩ B) ∈ λ(Π)).
It follows that (C ∈ H B (λ(Π))).

By H_is_λ_system it holds that
  ((H B (λ(Π))) is_a_λ-system) (H_is_λ_system).
It holds that (λ(Π) ⊂ H B (λ(Π))) (λΠ_subs_H).
It holds that (A ∈ H B (λ(Π))) (A_in_H).
It follows that ((A ∩ B) ∈ (λ(Π))).
By generated_system_is_λ it holds that
  (λ(Π) is_a_λ-system) (λΠ_is_λ).
By π_and_λ_is_σ it holds that
  ((λ(Π)) is_a_σ-algebra) (xx).
Apply xx.
Qed.

Theorem π_λ_theorem :
  ∀ Π Λ : setOfSubsets U,
    Π is_a_π-system ∧ Λ is_a_λ-system ∧ Π ⊂ Λ
    ⇒ (σ(Π)) ⊂ Λ.

Proof.
Take Π : (setOfSubsets U); Take Λ : (setOfSubsets U).
Assume Π_Λ_included_systems.

We need to show that (∀ x : subset U,
  x ∈ (σ(Π)) ⇒ x ∈ Λ).
Take A : (subset U); Assume A_in_σΠ.
By Π_Λ_included_systems it holds that
  (Π is_a_π-system) (Π_is_π).
By λΠ_is_σ_algebra it holds that
  (λ(Π) is_a_σ-algebra) (λΠ_is_σ_algebra).
By A_in_σΠ it holds that
  (∀ F : setOfSubsets U,
    F is_a_σ-algebra ⇒ Π ⊂ F
      ⇒ A ∈ F) (A_in_all_σ).
It holds that
  (λ(Π) is_a_σ-algebra
    ⇒ Π ⊂ (λ(Π))) (Π_in_λΠ).
By A_in_all_σ it holds that
  (A ∈(λ(Π))) (A_in_λΠ).
It holds that (Λ is_a_λ-system ⇒ Π ⊂ Λ) (Π_in_Λ).
It holds that (A ∈ Λ).
Qed.