From Hammer Require Import Hammer.

Require Import Ensembles Finite_sets.
Require Import MSetInterface MSetProperties OrdersEx.

Module WS_to_Finite_set (U:UsualDecidableType)(M: WSetsOn U).
Module MP:= WPropertiesOn U M.
Import M MP FM Ensembles Finite_sets.

Definition mkEns : M.t -> Ensemble M.elt :=
fun s x => M.In x s.

Notation " !! " := mkEns.

Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.In_In".
unfold In; compute; auto with extcore.
Qed.

Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.Subset_Included".
unfold Subset, Included, In, mkEns; intuition.
Qed.

Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).

Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.Equal_Same_set".
intros.
rewrite double_inclusion.
unfold Subset, Included, Same_set, In, mkEns; intuition.
Qed.

Lemma empty_Empty_Set : !!M.empty === Empty_set _.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.empty_Empty_Set".
unfold Same_set, Included, mkEns, In.
split; intro; set_iff; inversion 1.
Qed.

Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.Empty_Empty_set".
unfold Same_set, Included, mkEns, In.
split; intros.
destruct(H x H0).
inversion H0.
Qed.

Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.singleton_Singleton".
unfold Same_set, Included, mkEns, In.
split; intro; set_iff; inversion 1; try constructor; auto.
Qed.

Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.union_Union".
unfold Same_set, Included, mkEns, In.
split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
Qed.

Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.inter_Intersection".
unfold Same_set, Included, mkEns, In.
split; intro; set_iff; inversion 1; try constructor; auto.
Qed.

Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.add_Add".
unfold Same_set, Included, mkEns, In.
split; intro; set_iff; inversion 1; auto with sets.
inversion H0.
constructor 2; constructor.
constructor 1; auto.
Qed.

Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.Add_Add".
unfold Same_set, Included, mkEns, In.
split; intros.
red in H; rewrite H in H0.
destruct H0.
inversion H0.
constructor 2; constructor.
constructor 1; auto.
red in H; rewrite H.
inversion H0; auto.
inversion H1; auto.
Qed.

Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.remove_Subtract".
unfold Same_set, Included, mkEns, In.
split; intro; set_iff; inversion 1; auto with sets.
split; auto.
contradict H1.
inversion H1; auto.
Qed.

Lemma mkEns_Finite : forall s, Finite _ (!!s).
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.mkEns_Finite".
intro s; pattern s; apply set_induction; clear s; intros.
intros; replace (!!s) with (Empty_set elt); auto with sets.
symmetry; apply Extensionality_Ensembles.
apply Empty_Empty_set; auto.
replace (!!s') with (Add _ (!!s) x).
constructor 2; auto.
symmetry; apply Extensionality_Ensembles.
apply Add_Add; auto.
Qed.

Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.mkEns_cardinal".
intro s; pattern s; apply set_induction; clear s; intros.
intros; replace (!!s) with (Empty_set elt); auto with sets.
rewrite MP.cardinal_1; auto with sets.
symmetry; apply Extensionality_Ensembles.
apply Empty_Empty_set; auto.
replace (!!s') with (Add _ (!!s) x).
rewrite (cardinal_2 H0 H1); auto with sets.
symmetry; apply Extensionality_Ensembles.
apply Add_Add; auto.
Qed.

Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e ->
exists s:M.t, !!s === e.
Proof. hammer_hook "MSetToFiniteSet" "MSetToFiniteSet.WS_to_Finite_set.Ens_to_MSet".
induction 1.
exists M.empty.
apply empty_Empty_Set.
destruct IHFinite as (s,Hs).
exists (M.add x s).
apply Extensionality_Ensembles in Hs.
rewrite <- Hs.
apply add_Add.
Qed.

End WS_to_Finite_set.

Module S_to_Finite_set (U:UsualOrderedType)(M: SetsOn U) :=
WS_to_Finite_set U M.


Require Import Hask.Prelude.
Require Import Omega.

Ltac inv H  := inversion H; subst; simpl; clear H.
Ltac contra := intros top; contradiction top; clear top.
Ltac invert := intros top; inversion top; clear top.

Tactic Notation "invert" "as" simple_intropattern(pat) :=
  intros top; inversion top as pat; clear top.

Lemma ltn_leq_trans : forall n m p : nat, m < n -> n <= p -> m < p.
Proof. intros. omega. Qed.

Definition comp {a b c} (f : b -> c) (g : a -> b) (x : a) : c := f (g x).
Arguments comp {a b c} f g x /.

Infix "\o" := comp (at level 50).

Theorem comp_id_left : forall {A B : Set} (f : A -> B), id \o f = f.
Proof. reflexivity. Qed.

Hint Resolve comp_id_left.

Theorem comp_id_right : forall {A B : Set} (f : A -> B), f \o id = f.
Proof. reflexivity. Qed.

Hint Resolve comp_id_right.

Theorem comp_assoc : forall {A B C D : Set} (f : C -> D) (g : B -> C) (h : A -> B),
  f \o (g \o h) = (f \o g) \o h.
Proof. reflexivity. Qed.

Hint Resolve comp_assoc.

Theorem uncompose : forall {A B C : Set} (f : B -> C) (g : A -> B) (x : A) (y : C),
  (f \o g) x = f (g x).
Proof. reflexivity. Qed.

Ltac uncompose k :=
  rewrite <- (uncompose k);
  repeat (rewrite <- comp_assoc).


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Module STLC.

Inductive ty : Type :=
  | Ty_Bool : ty
  | Ty_Arrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tm_var : string -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  | tm_true : tm
  | tm_false : tm
  | tm_if : tm -> tm -> tm -> tm.

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.
Notation "'Bool'" := Ty_Bool (in custom stlc at level 0).
Notation "'if' x 'then' y 'else' z" :=
  (tm_if x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).
Notation "'true'" := true (at level 1).
Notation "'true'" := tm_true (in custom stlc at level 0).
Notation "'false'" := false (at level 1).
Notation "'false'" := tm_false (in custom stlc at level 0).

Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Hint Unfold x : core.
Hint Unfold y : core.
Hint Unfold z : core.

Notation idB :=
  <{ \x:Bool, x }>.
Notation idBB :=
  <{ \x:Bool->Bool, x }>.
Notation idBBBB :=
  <{\x:((Bool->Bool)->(Bool->Bool)), x}>.
Notation k := <{\x:Bool, \y:Bool, x}>.
Notation notB := <{\x:Bool, if x then false else true}>.

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value <{ \x:T2, t1 }>
  | v_true :
      value <{true}>
  | v_false :
      value <{false}>.
Hint Constructors value : core.

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> => <{([x:=s] t1) ([x:=s] t2)}>
  | <{true}> => <{true}>
  | <{false}> => <{false}>
  | <{if t1 then t2 else t3}> =>
      <{if ([x:=s] t1) then ([x:=s] t2) else ([x:=s] t3)}>
  end
where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

Check <{[x:=true] x}>.

Inductive substi (s : tm) (x : string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tm_var x) s
  | s_var2 : forall y,
      ~(x = y) ->
      substi s x (tm_var y) (tm_var y)
  | s_app : forall l r l' r',
      substi s x l l' ->
      substi s x r r' ->
      substi s x (tm_app l r) (tm_app l' r')
  | s_abs_bound : forall t b,
      substi s x (tm_abs x t b) (tm_abs x t b)
  | s_abs_free : forall a t b b',
      ~(x = a) ->
      substi s x b b' ->
      substi s x (tm_abs a t b) (tm_abs a t b')
  | s_true :
      substi s x tm_true tm_true
  | s_false :
      substi s x tm_false tm_false
  | s_if : forall b b' l l' r r',
      substi s x b b' ->
      substi s x l l' ->
      substi s x r r' ->
      substi s x (tm_if b l r) (tm_if b' l' r')
.
Hint Constructors substi : core.

Search (eqb_string ?s ?s = true).

Theorem substi_correct_fw : forall s x t t',
  <{ [x:=s]t }> = t'  ->  substi s x t t'.
Proof.
  intros s x t.
  induction t; intros t' H; simpl in H.
  + (*var*) unfold eqb_string in H.
    destruct (string_dec x s0); subst.
    * constructor.
    * constructor. apply n.
  + (*app*)
    subst.
    eapply s_app.
    apply IHt1. reflexivity.
    apply IHt2. reflexivity.
  + (*abs*) unfold eqb_string in H.
    destruct (string_dec x s0); subst.
    * constructor.
    * constructor.
      assumption.
      apply IHt. reflexivity.
  + (*true*)  subst. constructor.
  + (*false*) subst. constructor.
  + (*if*) subst. constructor; auto.
Qed.

Theorem substi_correct_bw : forall s x t t',
  substi s x t t'  ->  <{ [x:=s]t }> = t'.
Proof.
  intros s x t t' H.
  induction H.
  - (*var*) simpl. unfold eqb_string.
    destruct (string_dec x x); subst.
    + reflexivity.
    + exfalso. apply n. reflexivity.
  - (*var not eq*)
    simpl. unfold eqb_string.
    destruct (string_dec x y0); subst.
    + exfalso. apply H. reflexivity.
    + reflexivity.
  - (*app*)
    subst. simpl. reflexivity.
  - (*abs bound*) simpl. unfold eqb_string.
    destruct (string_dec x x); subst.
    + reflexivity.
    + exfalso. apply n. reflexivity.
  - (*abs free*) simpl. unfold eqb_string.
    destruct (string_dec x a); subst.
    + exfalso. apply H. reflexivity.
    + reflexivity.
  - (*true*) reflexivity.
  - (*false*) reflexivity.
  - (*if*) simpl. subst. reflexivity.
Qed.

Theorem substi_correct : forall s x t t',
  <{ [x:=s]t }> = t'  <->  substi s x t t'.
Proof.
  intros s x t t'.
  split.
  - apply substi_correct_fw.
  - apply substi_correct_bw.
Qed.

Reserved Notation "t '-->' t'" (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1 t2'}>
  | ST_IfTrue : forall t1 t2,
      <{if true then t1 else t2}> --> t1
  | ST_IfFalse : forall t1 t2,
      <{if false then t1 else t2}> --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      <{if t1 then t2 else t3}> --> <{if t1' then t2 else t3}>
where "t '-->' t'" := (step t t').
Hint Constructors step : core.

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
  <{idBB idB}> -->* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl. Qed.

Lemma step_example5 :
       <{idBBBB idBB idB}>  -->* idB.
Proof.
    eapply multi_step.
      apply ST_App1.
      - apply ST_AppAbs. constructor.
      - simpl.
        eapply multi_step. apply ST_AppAbs.
        + constructor.
        + simpl.
          apply multi_refl. Qed.

Lemma step_example5_with_normalize :
       <{idBBBB idBB idB}>  -->* idB.
Proof. normalize. Qed.

Definition context := partial_map ty.
Reserved Notation "Gamma '|-' t '\in' T"
            (at level 101, t custom stlc, T custom stlc at level 0).
Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T1,
      Gamma x = Some T1 ->
      Gamma |- x \in T1
  | T_Abs : forall Gamma x T1 T2 t1,
      (x |-> T2 ; Gamma) |- t1 \in T1 ->
      Gamma |- \x:T2, t1 \in (T2 -> T1)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (T2 -> T1) ->
      Gamma |- t2 \in T2 ->
      Gamma |- t1 t2 \in T1
  | T_True : forall Gamma,
       Gamma |- true \in Bool
  | T_False : forall Gamma,
       Gamma |- false \in Bool
  | T_If : forall t1 t2 t3 T1 Gamma,
       Gamma |- t1 \in Bool ->
       Gamma |- t2 \in T1 ->
       Gamma |- t3 \in T1 ->
       Gamma |- if t1 then t2 else t3 \in T1
where "Gamma '|-' t '\in' T" := (has_type Gamma t T).
Hint Constructors has_type : core.

Example typing_example_1 :
  empty |- \x:Bool, x \in (Bool -> Bool).
Proof.
  apply T_Abs. apply T_Var. reflexivity. Qed.

Example typing_example_2_full :
  empty |-
    \x:Bool,
       \y:Bool->Bool,
          (y (y x)) \in
    (Bool -> (Bool -> Bool) -> Bool).
Proof.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (T2 := <{ Bool }> ).
  - apply T_Var. unfold "|->", t_update. simpl. reflexivity.
  - apply T_App with (T2 := <{ Bool }> ).
    + apply T_Var. unfold "|->", t_update. simpl. reflexivity.
    + apply T_Var. unfold "|->", t_update. simpl. reflexivity.
Qed.

Example typing_example_3 :
  exists T,
    empty |-
      \x:Bool->Bool,
         \y:Bool->Bool,
            \z:Bool,
               (y (x z)) \in
      T.
Proof.
  eexists.
  apply T_Abs.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (T2 := <{ Bool }> ).
  - apply T_Var. unfold "|->", t_update. simpl. reflexivity.
  - apply T_App with (T2 := <{ Bool }> ).
    + apply T_Var. unfold "|->", t_update. simpl. reflexivity.
    + apply T_Var. unfold "|->", t_update. simpl. reflexivity.
Qed.

Example typing_nonexample_1 :
  ~ exists T,
      empty |-
        \x:Bool,
            \y:Bool,
               (x y) \in
        T.
Proof.
  intros Hc. destruct Hc as [T Hc].
  (* The clear tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion Hc; subst; clear Hc.
  inversion H4; subst; clear H4.
  inversion H5; subst; clear H5 H4.
  inversion H2; subst; clear H2.
  discriminate H1.
Qed.

Lemma qwe: forall t1 t2, <{t1 -> t2 }> = t1 -> False.
Proof.
  intros t1.
  induction t1; intros t2 H.
  - discriminate H.
  - injection H as H.
    apply (IHt1_1 _ H).
Qed.

Example typing_nonexample_3 :
  ~ (exists S T,
        empty |-
          \x:S, x x \in T).
Proof.
  intros [ S [ T HT ]].
  inversion HT; subst.
  inversion H4; subst.
  inversion H2; subst.
  inversion H5; subst.
  injection H1 as H1.
  injection H3 as H3.
  rewrite H1 in H3.
  apply (qwe T2 T1 H3).
Qed.

End STLC.


Set Implicit Arguments.
Require Export Coq.Program.Equality.
From Dblib Require Import DblibTactics DeBruijn Environments.

(* ---------------------------------------------------------------------------- *)

(* The syntax of untyped lambda-terms. *)

Inductive term :=
  | TVar: nat -> term
  | TAbs: term -> term
  | TApp: term -> term -> term.

(* ---------------------------------------------------------------------------- *)

(* The following definitions allow us to use the [DeBruijn] library. In
   particular, [traverse_term] defines the binding structure of terms. *)

Instance Var_term : Var term := {
  var := TVar (* avoid eta-expansion *)
}.

Fixpoint traverse_term (f : nat -> nat -> term) l t :=
  match t with
  | TVar x =>
      f l x
  | TAbs t =>
      TAbs (traverse_term f (1 + l) t)
  | TApp t1 t2 =>
      TApp (traverse_term f l t1) (traverse_term f l t2)
  end.

Instance Traverse_term : Traverse term term := {
  traverse := traverse_term
}.

Instance TraverseVarInjective_term : @TraverseVarInjective term _ term _.
Proof.
  constructor. prove_traverse_var_injective.
Qed.

Instance TraverseFunctorial_term : @TraverseFunctorial term _ term _.
Proof.
  constructor. prove_traverse_functorial.
Qed.

Instance TraverseRelative_term : @TraverseRelative term term _.
Proof.
  constructor. prove_traverse_relative.
Qed.

Instance TraverseIdentifiesVar_term : @TraverseIdentifiesVar term _ _.
Proof.
  constructor. prove_traverse_identifies_var.
Qed.

Instance TraverseVarIsIdentity_term : @TraverseVarIsIdentity term _ term _.
Proof.
  constructor. prove_traverse_var_is_identity.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The following lemmas characterize [lift] and [subst]. In principle, the
   user does not need to explicitly state these lemmas, and that is fortunate.
   Here, we prove these lemmas only in order to illustrate how the tactics
   [simpl_lift] and [simpl_subst] can simplify applications of [lift] and
   [subst]. *)

Lemma lift_TVar:
  forall w k x,
  lift w k (TVar x) = TVar (lift w k x).
Proof.
  intros. simpl_lift_goal. reflexivity.
Qed.

Lemma lift_TApp:
  forall w k t1 t2,
  lift w k (TApp t1 t2) = TApp (lift w k t1) (lift w k t2).
Proof.
  (* [simpl_lift_goal] can also be used as a hint for [eauto].
     This is useful when this equality goal occurs as a leaf
     within a larger automated proof. *)
  eauto with simpl_lift_goal.
Qed.

Lemma lift_TAbs:
  forall w k t,
  lift w k (TAbs t) = TAbs (lift w (1 + k) t).
Proof.
  eauto with simpl_lift_goal.
Qed.

Lemma subst_TVar:
  forall v k x,
  subst v k (TVar x) = subst_idx v k x.
Proof.
  intros. simpl_subst_goal. reflexivity.
Qed.

Lemma subst_TApp:
  forall v k t1 t2,
  subst v k (TApp t1 t2) = TApp (subst v k t1) (subst v k t2).
Proof.
  eauto with simpl_subst_goal.
Qed.

Lemma subst_TAbs:
  forall v k t,
  subst v k (TAbs t) = TAbs (subst (shift 0 v) (1 + k) t).
Proof.
  eauto with simpl_subst_goal.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Reduction semantics. *)

Inductive red : term -> term -> Prop :=
  | RedBeta:
      forall t1 t2 t,
      subst t2 0 t1 = t ->
      red (TApp (TAbs t1) t2) t
  | RedContextTAbs:
      forall t1 t2,
      red t1 t2 ->
      red (TAbs t1) (TAbs t2)
  | RedContextTAppLeft:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t1 t) (TApp t2 t)
  | RedContextTAppRight:
      forall t1 t2 t,
      red t1 t2 ->
      red (TApp t t1) (TApp t t2).

(* The reduction judgement is compatible with weakening. *)

Lemma red_weakening:
  forall t1 t2,
  red t1 t2 ->
  forall x,
  red (shift x t1) (shift x t2).
Proof.
  induction 1; intros; subst; simpl_lift_goal;
  econstructor; eauto with lift_subst.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Working with closedness. *)

(* Again, we prove the following lemmas only in order to illustrate
   the use of the tactic [inversion_closed]. *)

Lemma inversion_closed_TVar:
  forall k x,
  x >= k ->
  closed k (TVar x) ->
  False.
Proof.
  intros. inversion_closed. eauto using closed_var.
Qed.

Lemma inversion_closed_TApp_1:
  forall t1 t2 k,
  closed k (TApp t1 t2) ->
  closed k t1.
Proof.
  intros. inversion_closed. assumption.
Qed.

Lemma inversion_closed_TApp_2:
  forall t1 t2 k,
  closed k (TApp t1 t2) ->
  closed k t2.
Proof.
  intros. inversion_closed. assumption.
Qed.

Lemma inversion_closed_TAbs:
  forall t k,
  closed k (TAbs t) ->
  closed (1 + k) t.
Proof.
  intros. inversion_closed. assumption.
Qed.

(* Reduction preserves closedness. *)

Lemma red_closed:
  forall t1 t2,
  red t1 t2 ->
  forall k,
  closed k t1 ->
  closed k t2.
Proof.
  induction 1; intros; subst; inversion_closed; try construction_closed.
  (* Case RedBeta. *)
  eauto using @subst_preserves_closed with typeclass_instances.
Qed.

(* ---------------------------------------------------------------------------- *)

(* Simple types. *)

(* These types do not contain any variables. They have no binding structure. *)

Inductive ty :=
  | TyIota: ty
  | TyArrow: ty -> ty -> ty.

(* The typing judgement of the simply-typed lambda-calculus. *)

Inductive j : env ty -> term -> ty -> Prop :=
  | JVar:
      forall E x T,
      lookup x E = Some T ->
      j E (TVar x) T
  | JAbs:
      forall E t T1 T2,
      j (insert 0 T1 E) t T2 ->
      j E (TAbs t) (TyArrow T1 T2)
  | JApp:
      forall E t1 t2 T1 T2,
      j E t1 (TyArrow T1 T2) ->
      j E t2 T1 ->
      j E (TApp t1 t2) T2.

Hint Constructors j : j.

(* ---------------------------------------------------------------------------- *)

(* The typing judgement is compatible with weakening, i.e., inserting a new
   term variable. *)

Lemma weakening:
  forall E t T,
  j E t T ->
  forall x U E',
  insert x U E = E' ->
  j E' (shift x t) T.
Proof.
  induction 1; intros; subst; simpl_lift_goal;
  econstructor; eauto with lookup_insert insert_insert.
Qed.

(* The typing judgement is compatible with substitution, i.e., substituting a
   well-typed term for a term variable. *)

Lemma substitution:
  forall E x t2 T1 T2,
  j (insert x T1 E) t2 T2 ->
  forall t1,
  j E t1 T1 ->
  j E (subst t1 x t2) T2.
Proof.
  do 5 intro; intro h; dependent induction h; intros; simpl_subst_goal;
  (* General rule. *)
  try solve [ econstructor; eauto using weakening with insert_insert ].
  (* Case TVar. *)
  unfold subst_idx. dblib_by_cases; lookup_insert_all; eauto with j.
Qed.

(* The typing judgement is preserved by reduction. Note that this is
   proved for an arbitrary environment [E]: we do not restrict our
   attention to closed terms. *)

Lemma type_preservation:
  forall t1 t2,
  red t1 t2 ->
  forall E T,
  j E t1 T ->
  j E t2 T.
Proof.
  induction 1; intros ? ? h; subst; dependent destruction h; eauto with j.
  (* Case RedBeta. *)
  match goal with h: j _ (TAbs _) _ |- _ =>
    inversion h; clear h; subst
  end.
  eauto using substitution.
Qed.

(* ---------------------------------------------------------------------------- *)

(* The following lemmas are not needed here, but could be useful in other
   settings. *)

(* A term that is well-typed under the empty environment is closed. *)

Lemma j_closed:
  forall E t T,
  j E t T ->
  forall k,
  length E <= k ->
  closed k t.
Proof.
  induction 1; intros; construction_closed.
Qed.

(* A term that is well-typed under the empty environment is well-typed
   under every environment. *)

Lemma j_agree:
  forall E1 t T,
  j E1 t T ->
  forall E2 k,
  agree E1 E2 k ->
  length E1 <= k ->
  j E2 t T.
Proof.
  induction 1; intros; eauto with j length agree lia.
Qed.

Lemma j_empty:
  forall E t T,
  j (@empty _) t T ->
  j E t T.
Proof.
  eauto using j_agree with length agree.
Qed.


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

- Leo Ducas, 2007-08-06

auxiliary lemmas on Coq's sort and lelistA predicates
and on Coq's multiplicity function
*)

Set Implicit Arguments.

From Coq Require Export Sorting.
From Coq Require Import List Morphisms Lia.
From CoLoR Require Import RelUtil LogicUtil.

(***********************************************************************)
(** lelistA and sort *)

Lemma sort_incl_aux : forall B (T S : relation B) a l,
  T << S -> lelistA T a l  -> lelistA S a l.

Proof. induction l; intros. intuition. destruct H0; intuition. Qed.

Lemma sort_incl : forall B (T S : relation B) l,
  T << S -> sort T l -> sort S l.

Proof.
intros; induction l. intuition.
inversion H0. apply cons_sort; intuition. subst.
eapply sort_incl_aux; ehyp.
Qed.

Lemma sort_transitive : forall B (a : B) L rel,
  transitive rel -> sort rel (a::L) -> forall x, In x L -> rel a x.

Proof.
intros. induction L. destruct H1.
simpl in H1; destruct H1. subst. inversion H0; subst; auto.
inversion H4; subst; auto. apply IHL; auto. inversion H0; inversion H4.
subst. apply cons_sort. subst; auto. inversion H5. subst. inversion H9.
apply nil_leA. subst. apply cons_leA. eapply H; eauto.
Qed.

Lemma lelistA_map A (R : relation A) B (S : relation B) (f : A->B)
      (f_mon : Proper (R ==> S) f) a :
  forall l, lelistA R a l -> lelistA S (f a) (map f l).

Proof.
  induction l; intro h; simpl.
  apply nil_leA.
  inversion h; subst. apply cons_leA. apply f_mon. hyp.
Qed.

Lemma sort_map A (R : relation A) B (S : relation B) (f : A->B)
      (f_mon : Proper (R ==> S) f) :
  forall l, sort R l -> sort S (map f l).

Proof.
  induction l; intro h; simpl.
  apply nil_sort.
  inversion h; subst. apply cons_sort.
  apply IHl. hyp.
  eapply lelistA_map. apply f_mon. hyp.
Qed.

From CoLoR Require Import ListNodup.

Lemma nodup_lelistA_strict : forall B a S (mb : list B)
  (HL : nodup (a::mb)), lelistA (S%) a mb -> lelistA S a mb.

Proof.
intros. induction mb; intuition.
simpl in *. inversion H; subst. apply cons_leA.
destruct H1; subst; try tauto.
Qed.

Lemma nodup_sort_strict : forall B S (mb : list B)
  (HL : nodup mb), sort (S%) mb -> sort S mb.

Proof.
intros. induction mb. apply nil_sort.
gen HL; intro. simpl in HL0. inversion H; subst.
assert (sort S mb). tauto.
clear IHmb. apply cons_sort; auto. apply nodup_lelistA_strict; auto.
Qed.

(***********************************************************************)
(** multiplicity *)

From CoLoR Require Import ListPermutation.

Section multiplicity.

  Variables (B : Type) (B_eq_dec : forall x y : B, {x=y}+{x<>y}).

  Lemma In_multiplicity : forall mb a, In a mb ->
    multiplicity (list_contents B_eq_dec mb) a >= 1.

  Proof.
    intros; induction mb; simpl in *; try tauto.
    destruct H; destruct (B_eq_dec a0 a); subst; try congruence; simpl;
      try lia.
    tauto.
  Qed.

  Lemma multiplicity_nodup : forall mb,
    (forall a, multiplicity (list_contents B_eq_dec mb) a <= 1) -> nodup mb.

  Proof.
    intros. induction mb; simpl; auto. simpl in H. split.
    ded (H a). intuition. ded (In_multiplicity _ _ H1).
    destruct (B_eq_dec a a); auto. lia.
    apply IHmb. intros. ded (H a0). destruct (B_eq_dec a a0); simpl in *; lia.
  Qed.

End multiplicity.

(***********************************************************************)
(** Sorted *)

From Coq Require Import Morphisms.
From CoLoR Require Import NatUtil.

Section Sorted.

  Variables (A : Type) (lt : relation A) (lt_trans : Transitive lt) (d : A).

  Lemma Sorted_nth_S : forall l i, Sorted lt l ->
    i < length l -> S i < length l -> lt (nth i l d) (nth (S i) l d).

  Proof.
    induction l; destruct i; simpl; intros. lia. lia.
    inversion H. subst. destruct l. simpl in H1. lia.
    inversion H5. hyp.
    inversion H. apply IHl. hyp. lia. lia.
  Qed.

  Lemma HdRel_nth : forall l i n, Sorted lt l ->
    HdRel lt n l -> i < length l -> lt n (nth i l d).

  Proof.
    induction l; destruct i; simpl; intros.
    lia. lia. inversion H0. hyp.
    apply IHl. inversion H. hyp.
    destruct l. apply HdRel_nil. apply HdRel_cons.
    inversion H0. inversion H. inversion H8. subst. trans a; hyp. lia.
  Qed.

  Lemma Sorted_nth : forall j l i, Sorted lt l ->
    i < length l -> j < length l -> i < j -> lt (nth i l d) (nth j l d).

  Proof.
    induction j; intros. lia.
    destruct l; simpl in *. lia.
    inversion H. subst. destruct i; simpl.
    apply HdRel_nth. hyp. hyp. lia.
    apply IHj. hyp. lia. lia. lia.
  Qed.

End Sorted.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Shared definitions for containers                                       *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect
  LibRelation LibOperation LibInt LibStruct.
Generalizable Variables A B K T.

(* ********************************************************************** *)
(** * Operators *)

(* ---------------------------------------------------------------------- *)
(** ** Definitions *)

Class BagEmpty T := { empty : T }.
Class BagSingle A T := { single : A -> T }.
Class BagSingleBind A B T := { single_bind : A -> B -> T }.
Class BagIn A T := { is_in : A -> T -> Prop }.
Class BagBinds A B T := { binds : T -> A -> B -> Prop }.
Class BagRead A B T := { read : T -> A -> B }.
Class BagUpdate A B T := { update : T -> A -> B -> T }.
Class BagUnion T := { union : T -> T -> T }.
Class BagInter T := { inter : T -> T -> T }.
Class BagIncl T := { incl : binary T }.
Class BagDisjoint T := { disjoint : binary T }.
Class BagRestrict T K := { restrict : T -> K -> T }.
Class BagRemove T K := { remove : T -> K -> T }.
Class BagFold I F T := { fold : monoid_def I -> F -> T -> I }.
Class BagCard T := { card : T -> nat }.
Class BagDom T Ks := { dom : T -> Ks }.
Class BagIndex T A := { index : T -> A -> Prop }.

Definition notin `{BagIn A T} x m :=
  ~ (is_in x m).

(* ---------------------------------------------------------------------- *)
(** ** Notation *)

Notation "\{}" := (empty)
  : container_scope.
Notation "\{ x }" := (single x)
  : container_scope.
Notation "x '\in' m" := (is_in x m)
  (at level 39) : container_scope.
Notation "x '\notin' E" := (notin x E)
  (at level 39) : container_scope.
Notation "x \:= v" := (single_bind x v)
  (at level 29) : container_scope.
Notation "m \( x )" := (read m x)
  (at level 33, format "m \( x )") : container_scope.
Notation "m \( x := v )" := (update m x v)
  (at level 33, format "m \( x := v )") : container_scope.
(* todo :
Notation "m \[ x ]" := (read m x)
  (at level 29) : container_scope.
Notation "m \[ x := v ]" := (update m x v)
  (at level 29) : container_scope.
*)

Notation "m1 '\c' m2" := (incl m1 m2)
  (at level 38) : container_scope.
Notation "m1 '\u' m2" := (union m1 m2)
  (at level 37, right associativity) : container_scope.
Notation "m1 '\n' m2" := (inter m1 m2)
  (at level 36, right associativity) : container_scope.
Notation "m1 '\-' m2" := (remove m1 m2)
  (at level 35) : container_scope.
Notation "m1 '\|' m2" := (restrict m1 m2)
  (at level 34) : container_scope.
Notation "m1 '\#' m2" := (disjoint m1 m2)
  (at level 37, right associativity) : container_scope.

Open Scope container_scope.

(* todo: bug with spaces *)
Notation "''{' x '}'" := (single x) (format "''{' x '}'")
  : container_scope.

Notation "M \-- i" := (M \- \{i}) (at level 35) : container_scope.

(* ---------------------------------------------------------------------- *)
(** ** [forall x \in E, P x] notation *)

Notation "'forall_' x '\in' E ',' P" :=
  (forall x, x \in E -> P)
  (at level 200, x ident) : container_scope.
Notation "'forall_' x y '\in' E ',' P" :=
  (forall x y, x \in E -> y \in E -> P)
  (at level 200, x ident, y ident) : container_scope.
Notation "'forall_' x y z '\in' E ',' P" :=
  (forall x y z, x \in E -> y \in E -> z \in E -> P)
  (at level 200, x ident, y ident, z ident) : container_scope.

(* ---------------------------------------------------------------------- *)
(** ** [exists x \in E st P x] notation *)

Notation "'exists_' x '\in' E ',' P" :=
  (exists x, x \in E /\ P)
  (at level 200, x ident) : container_scope.
Notation "'exists_' x y '\in' E ',' P" :=
  (exists x, x \in E /\ y \in E /\ P)
  (at level 200, x ident, y ident) : container_scope.
Notation "'exists_' x y z '\in' E ',' P" :=
  (exists x, x \in E /\ y \in E /\ z \in E /\ P)
  (at level 200, x ident, y ident, z ident) : container_scope.

(* ---------------------------------------------------------------------- *)
(** ** Foreach *)

Definition foreach `{BagIn A T} (P:A->Prop) (E:T) :=
  forall x, x \in E -> P x.

(* ---------------------------------------------------------------------- *)
(** ** [index] for natural numbers *)

Instance int_index : BagIndex int int.
Proof. intros. constructor. exact (fun n (i:int) => 0 <= i < n). Defined.

Lemma int_index_def : forall (n i : int),
  index n i = (0 <= i < n).
Proof. auto. Qed.

Global Opaque int_index.

Lemma int_index_le : forall i n m : int,
  index n i -> n <= m -> index m i.
Proof. introv. do 2 rewrite @int_index_def. math. Qed.

Lemma int_index_prove : forall (n i : int),
  0 <= i -> i < n -> index n i.
Proof. intros. rewrite~ int_index_def. Qed.

Lemma int_index_succ : forall n i, n >= 0 ->
  index (n + 1) i = (index n i \/ i = n).
Proof.
  introv P. do 2 rewrite int_index_def. extens. iff H.
  apply classic_left. math.
  destruct H; math.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Derivable *)

(** Bag update can be defined as bag union with a singleton bag *)

Instance bag_update_as_union_single : forall A B T
  `{BagSingleBind A B T} `{BagUnion T},
  BagUpdate A B T.
  constructor. apply (fun m k v => m \u (k \:= v)). Defined.

Global Opaque bag_update_as_union_single.

(* ---------------------------------------------------------------------- *)
(** ** Properties *)

(** Membership *)

Class In_empty_eq `{BagIn A T, BagEmpty T} :=
  { in_empty_eq : forall x, x \in \{} = False }.
Class In_empty `{BagIn A T, BagEmpty T} :=
  { in_empty : forall x, x \in \{} -> False }.

Implicit Arguments in_empty [[A] [T] [H] [H0] [In_empty]].

Class In_single_eq `{BagIn A T, BagSingle A T} :=
  { in_single_eq : forall x y, x \in \{y} = (x = y) }.
Class In_single `{BagIn A T, BagSingle A T} :=
  { in_single : forall x y, x \in \{y} -> x = y }.
Class In_single_self `{BagIn A T, BagSingle A T} :=
  { in_single_self : forall x, x \in \{x} }.

Implicit Arguments in_single_eq [[A] [T] [H] [H0] [In_single_eq]].
Implicit Arguments in_single [[A] [T] [H] [H0] [In_single] x y].
Implicit Arguments in_single_self [[A] [T] [H] [H0] [In_single_self]].

Class In_union_eq `{BagIn A T, BagUnion T} :=
  { in_union_eq : forall x (E F : T), x \in (E \u F) = (x \in E \/ x \in F) }.
Class In_union_l `{BagIn A T, BagUnion T} :=
  { in_union_l : forall x E F, x \in E -> x \in (E \u F) }.
Class In_union_r `{BagIn A T, BagUnion T} :=
  { in_union_r : forall x E F, x \in F -> x \in (E \u F) }.
Class In_union_inv `{BagIn A T, BagUnion T} :=
  { in_union_inv : forall x (E F : T), x \in (E \u F) -> (x \in E \/ x \in F) }.

Implicit Arguments in_union_eq [[A] [T] [H] [H0] [In_union_eq]].
Implicit Arguments in_union_l [[A] [T] [H] [H0] [In_union_l] x E F].
Implicit Arguments in_union_r [[A] [T] [H] [H0] [In_union_r] x E F].
Implicit Arguments in_union_inv [[A] [T] [H] [H0] [In_union_inv] x E F].

Class In_inter_eq `{BagIn A T, BagInter T} :=
  { in_inter_eq : forall x E F, x \in (E \n F) = (x \in E /\ x \in F) }.
Class In_inter `{BagIn A T, BagInter T} :=
  { in_inter : forall x E F, x \in E -> x \in F -> x \in (E \n F) }.
Class In_inter_inv `{BagIn A T, BagInter T} :=
  { in_inter_inv : forall x E F, x \in (E \n F) -> x \in E /\ x \in F }.

Implicit Arguments in_inter_eq [[A] [T] [H] [H0] [In_inter_eq]].
Implicit Arguments in_inter [[A] [T] [H] [H0] [In_inter] x E F].
Implicit Arguments in_inter_inv [[A] [T] [H] [H0] [In_inter_inv] x E F].

Class In_remove_eq `{BagIn A T, BagRemove T T} :=
  { in_remove_eq : forall x (E F : T), x \in (E \- F) = (x \in E /\ x \notin F) }.

Implicit Arguments in_remove_eq [[A] [T] [H] [H0] [In_remove_eq]].

Class In_double_eq `{BagIn A T} :=
  { in_double_eq : forall E F, (forall x, x \in E = x \in F) -> E = F }.
Class In_double `{BagIn A T} :=
  { in_double : forall E F, (forall x, x \in E <-> x \in F) -> E = F }.

Implicit Arguments in_double_eq [[A] [T] [H] [In_double_eq]].
Implicit Arguments in_double [[A] [T] [H] [In_double]].

Class Incl_in `{BagIn A T, BagIncl T} :=
  { incl_in : forall x E F, E \c F -> x \in E -> x \in F}.

Implicit Arguments incl_in [[A] [T] [H] [H0] [Incl_in] x E F].

Class Incl_refl `{BagIncl T} :=
  { incl_refl : refl incl }.
Class Incl_trans `{BagIncl T} :=
  { incl_trans : trans incl }.
Class Double_incl `{BagIncl T} :=
  { double_incl : antisym incl }.
Class Incl_order `{BagIncl T} :=
  { incl_order : LibOrder.order incl }.

Implicit Arguments incl_refl [[T] [H] [Incl_refl]].
Implicit Arguments incl_trans [[T] [H] [Incl_trans] x z].

(* todo: add implicit
Implicit Arguments double_incl [[T] [H] [Double_incl] x E F].
Implicit Arguments incl_order [[T] [H] [Incl_order] x E F].*)

Class Empty_incl `{BagEmpty T, BagIncl T} :=
  { empty_incl : forall E, \{} \c E }.
Class Incl_empty `{BagEmpty T, BagIncl T} :=
  { incl_empty : forall E, (E \c \{}) = (E = \{}) }.
Class Incl_empty_inv `{BagEmpty T, BagIncl T} :=
  { incl_empty_inv : forall E, E \c \{} -> E = \{} }.

Implicit Arguments empty_incl [[T] [H] [H0] [Empty_incl]].
Implicit Arguments incl_empty [[T] [H] [Incl_empty]].
Implicit Arguments incl_empty_inv [[T] [H] [Incl_empty_inv] E].

(* todo: add implicit arguments in the rest of the file *)

Class Single_incl `{BagSingle A T, BagIn A T, BagIncl T} :=
  { single_incl : forall x E, (\{x} \c E) = (x \in E) }.
Class Incl_single `{BagSingle A T, BagIn A T, BagIncl T, BagEmpty T} :=
  { incl_single : forall x E, (E \c \{x}) -> (E = \{} \/ E = \{x}) }.

Class Incl_union_l `{BagUnion T, BagIncl T} :=
  { incl_union_l : forall E F G, E \c F -> E \c (F \u G) }.
Class Incl_union_r `{BagUnion T, BagIncl T} :=
  { incl_union_r : forall E F G, E \c G -> E \c (F \u G) }.

Class Union_incl_eq `{BagUnion T, BagIncl T} :=
  { union_incl_eq : forall E F G, (E \u F) \c G = (E \c G /\ F \c G) }.
Class Union_incl `{BagUnion T, BagIncl T} :=
  { union_incl : forall E F G, E \c G -> F \c G -> (E \u F) \c G }.
Class Union_incl_inv `{BagUnion T, BagIncl T} :=
  { union_incl_inv : forall E F G, (E \u F) \c G -> E \c G /\ F \c G }.

Class Incl_inter_b `{BagInter T, BagIncl T} :=
  { incl_inter_b : forall E F G, E \c (F \n G) = (E \c F /\ E \c G) }.
Class Incl_inter `{BagInter T, BagIncl T} :=
  { incl_inter : forall E F G, E \c F -> E \c G -> E \c (F \n G) }.
Class Incl_inter_inv `{BagInter T, BagIncl T} :=
  { incl_inter_inv : forall E F G, E \c (F \n G) -> E \c F /\ E \c G }.

(** Union *)

Class Union_assoc `{BagUnion T} :=
  { union_assoc : assoc union }.
Class Union_comm `{BagUnion T} :=
  { union_comm : comm union }.
Class Union_comm_assoc `{BagUnion T} :=
  { union_comm_assoc : comm_assoc union }.
Class Union_empty_l `{BagUnion T, BagEmpty T} :=
  { union_empty_l : neutral_l union empty }.
Class Union_empty_r `{BagUnion T, BagEmpty T} :=
  { union_empty_r : neutral_r union empty }.
Class Union_empty_inv `{BagUnion T, BagEmpty T} :=
  { union_empty_inv : forall E F,
     E \u F = \{} -> E = \{} /\ F = \{} }.
Class Union_self `{BagUnion T} :=
  { union_self : idempotent2 union }.

(* todo: union_comm_monoid *)

(** Intersection *)

Class Inter_assoc `{BagInter T} :=
  { inter_assoc : assoc inter }.
Class Inter_comm `{BagInter T} :=
  { inter_comm : comm inter }.
Class Inter_empty_l `{BagInter T, BagEmpty T} :=
  { inter_empty_l : absorb_l inter empty }.
Class Inter_empty_r `{BagInter T, BagEmpty T} :=
  { inter_empty_r : absorb_r inter empty }.
Class Inter_self `{BagInter T} :=
  { inter_self : idempotent2 inter }.

(** Removal *)

(** Disjointness *)

(** Restriction *)

(** Cardinal *)

Class Card_empty `{BagEmpty T, BagCard T} :=
  { card_empty : card \{} = 0%nat }.
Class Card_single `{BagSingle A T, BagCard T} :=
  { card_single : forall X, card \{X} = 1%nat }.
Class Card_union `{BagUnion T, BagCard T} :=
  { card_union : forall E F, card (E \u F) = (card E + card F)%nat }.
Class Card_union_le `{BagUnion T, BagCard T} :=
  { card_union_le : forall E F, card (E \u F) <= (card E + card F)%nat }.

(* ---------------------------------------------------------------------- *)
(** ** Derived Properties *)

(** Membership *)

Instance in_empty_from_in_empty_eq :
  forall `{BagIn A T, BagEmpty T},
  In_empty_eq -> In_empty.
Proof. constructor. introv I. rewrite~ in_empty_eq in I. Qed.

Instance in_single_from_in_single_eq :
  forall `{BagSingle A T, BagIn A T},
  In_single_eq -> In_single.
Proof. constructor. introv I. rewrite~ in_single_eq in I. Qed.

Instance in_single_self_from_in_single_eq :
  forall `{BagSingle A T, BagIn A T},
  In_single_eq -> In_single_self.
Proof. constructor. intros. rewrite~ in_single_eq. Qed.

Instance in_union_r_from_in_union_eq :
  forall `{BagIn A T, BagUnion T},
  In_union_eq -> In_union_r.
Proof. constructor. introv I. rewrite in_union_eq. rew_reflect*. Qed.

Instance in_union_l_from_in_union_eq :
  forall `{BagIn A T, BagUnion T},
  In_union_eq -> In_union_l.
Proof. constructor. introv I. rewrite in_union_eq. rew_reflect*. Qed.

Instance in_union_inv_from_in_union_eq :
  forall `{BagIn A T, BagUnion T},
  In_union_eq -> In_union_inv.
Proof. constructor. introv I. rewrite~ @in_union_eq in I. Qed.

Instance in_inter_from_in_inter_eq :
  forall `{BagIn A T, BagInter T},
  In_inter_eq -> In_inter.
Proof. constructor. introv I1 I2. rewrite in_inter_eq. rew_reflect*. Qed.

(** Union *)

Instance union_empty_r_from_union_empty_l :
  forall `{BagUnion T, BagEmpty T},
  Union_empty_l -> Union_comm -> Union_empty_r.
Proof. constructor. intros_all. rewrite union_comm. apply union_empty_l. Qed.

(** Intersection *)

Instance inter_empty_r_from_inter_empty_l :
  forall `{BagInter T, BagEmpty T},
  Inter_empty_l -> Inter_comm -> Inter_empty_r.
Proof. constructor. intros_all. rewrite inter_comm. apply inter_empty_l. Qed.

(* Inclusion *)

Instance incl_refl_from_incl_order :
  forall `{BagIncl T},
  Incl_order -> Incl_refl.
Proof. constructor. apply order_refl. apply incl_order. Qed.

Instance incl_trans_from_incl_order :
  forall `{BagIncl T},
  Incl_order -> Incl_trans.
Proof. constructor. apply order_trans. apply incl_order. Qed.

Instance double_incl_from_incl_order :
  forall `{BagIncl T},
  Incl_order -> Double_incl.
Proof. constructor. apply order_antisym. apply incl_order. Qed.

Instance incl_empty_inv_from_incl_empty :
  forall `{BagEmpty T, BagIncl T},
  Incl_empty -> Incl_empty_inv.
Proof. constructor. introv I. rewrite~ incl_empty in I. Qed.

Instance incl_union_r_from_incl_union_l :
  forall `{BagUnion T, BagIncl T},
  Incl_union_l -> Union_comm -> Incl_union_r.
Proof. constructor. introv I. rewrite union_comm. apply~ incl_union_l. Qed.

Instance union_incl_from_union_incl_eq :
  forall `{BagUnion T, BagIncl T},
  Union_incl_eq -> Union_incl_eq.
Proof. constructor. intros_all. rewrite union_incl_eq. rew_reflect*. Qed.

Instance union_incl_inv_from_union_incl_eq :
  forall `{BagUnion T, BagIncl T},
  Union_incl_eq -> Union_incl_inv.
Proof. constructor. introv I. rewrite union_incl_eq in I. destruct* I. Qed.

Instance in_double_eq_from_in_double :
  forall `{BagIn A T},
  In_double -> In_double_eq.
Proof. constructor. introv I. apply in_double. intros. rewrite* I. Qed.

(** Union and inter from Extensionality *)

Hint Rewrite @in_union_eq @in_inter_eq
  @in_empty_eq @in_single_eq : rew_in_eq.

Tactic Notation "contain_by_in_double" :=
  intros_all; apply in_double; intros;
  autorewrite with rew_in_eq; rew_reflect;
  intuition (try solve [auto|eauto|auto_false|false]).

Section UnionDouble.
Context `{BagIn A T, BagUnion T}.

Global Instance union_assoc_from_in_union :
  In_double -> In_union_eq -> Union_assoc.
Proof. constructor. contain_by_in_double. Qed.

Global Instance union_comm_from_in_union :
  In_double -> In_union_eq -> Union_comm.
Proof. constructor. contain_by_in_double. Qed.

Global Instance union_empty_l_from_in_union :
  forall `{BagEmpty T},
  In_double -> In_union_eq -> In_empty_eq -> Union_empty_l.
Proof. constructor. contain_by_in_double. Qed.

Global Instance union_self_from_in_union :
  In_double -> In_union_eq -> Union_self.
Proof. constructor. contain_by_in_double. Qed.

End UnionDouble.

Section InterDouble.
Context `{BagIn A T, BagInter T}.

Global Instance inter_assoc_from_in_inter :
  In_double -> In_inter_eq -> Inter_assoc.
Proof. constructor. contain_by_in_double. Qed.

Global Instance inter_comm_from_in_inter :
  In_double -> In_inter_eq -> Inter_comm.
Proof. constructor. contain_by_in_double. Qed.

Global Instance inter_empty_l_from_in_inter :
  forall `{BagEmpty T},
  In_double -> In_inter_eq -> In_empty_eq -> Inter_empty_l.
Proof. constructor. contain_by_in_double. Qed.

Global Instance inter_self_from_in_inter :
  In_double -> In_inter_eq -> Inter_self.
Proof. constructor. contain_by_in_double. Qed.

End InterDouble.

Instance union_comm_assoc_from_assoc_and_comm
  `{Union_assoc} {UH: Union_comm} : Union_comm_assoc.
Proof.
  constructor. intros_all. do 2 rewrite union_assoc.
  rewrite (union_comm _ x). auto.
Qed.

(* todo: comm_assoc_l and _r *)


(**  Pierre Castéran, LaBRI and University of Bordeaux  *)

(** Technical definitions and lemmas about variants bounded by some ordinal
    les than [epsilon0]
 *)

From hydras Require Import Hydra_Lemmas Epsilon0 Canon Paths O2H.
From Coq Require Import Relation_Operators.

Open Scope t1_scope.

(* begin snippet theContext:: no-out *)
Section Bounded.

  Context (B: Battle)
          (mu: T1)
          (Hmu: nf mu)
          (m : Hydra -> T1)
          (Var : Hvariant  T1_wf B m)
          (Hy : BoundedVariant  Var mu).

  Hypothesis m_decrease : forall  i h h', round_n i h h'-> m h' t1< m h.
  (* end snippet theContext *)

  Lemma  nf_m : forall h, nf (m h).
  Proof. intro h0; now destruct (m_bounded h0). Qed.

  #[local] Hint Resolve Rem0 : hydra.

  Lemma mu_positive : mu <> T1.zero.
  Proof.
    intro H; subst;  specialize (m_bounded (hyd1 head)).
    intro H0;  destruct (not_LT_zero H0).
  Qed.

  (* begin snippet mGe0:: no-out *)
  Lemma m_ge_0 alpha:  nf alpha -> alpha t1<= m (iota alpha).
  (* end snippet mGe0 *)
 Proof.
    transfinite_induction_lt alpha;
      clear alpha; intros alpha Hrec H.
    destruct (T1_eq_dec alpha T1.zero).
    + subst;  repeat split; auto with T1.
      now apply nf_m .
    +   destruct (T1.zero_limit_succ_dec H).
        * destruct s.
          { subst ; now destruct n. }
          { eapply strict_lub_lub with (s := fun i => canon alpha (S i)).
            apply canonS_limit_lub; auto.
            intro i0;
              assert (round_n i0 (iota alpha) (iota (canon alpha (S i0)))).
            {   apply canonS_iota_i;  auto. }
            apply LE_trans with (m (iota (canon alpha (S i0)))); auto.
            { apply Hrec; auto.
              - apply nf_canon;  auto.
              - destruct (canonS_limit_lub H); auto.
                destruct (H1 i0);   tauto.
              - eapply nf_canon;auto.
            }
            apply LE_r; eapply m_decrease; eapply  H0.
          }
        *  destruct s as [x [H0 e]]; subst.
           assert (x t1< m (iota (T1.succ x))).
           {
             apply LE_LT_trans with (m (iota x)).
             apply Hrec; auto.
             apply lt_succ; auto.
             eapply m_decrease.
             clear Hrec; destruct x.
             - left;  apply iota_succ_R1; eauto.
             - left;  apply iota_succ_R1; eauto.
           }
           now  apply LT_succ_LE.
           Unshelve.
           exact 0.
 Qed.

 (* begin snippet mGeGeneric:: no-out  *)
 Definition big_h := iota mu.
 Definition beta_h := m big_h.
 Definition small_h := iota beta_h.

 Lemma mu_beta_h : acc_from mu beta_h.
 Proof. apply LT_acc_from, m_bounded.  Qed.

 Corollary m_ge_generic : m big_h t1<= m small_h.
 Proof. apply m_ge_0, nf_m. Qed.

End Bounded.
(* end snippet mGeGeneric *)


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
   induction l1.
   - intros. simpl. f_equal. apply IHl1.
   - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
   induction l.
   - simpl. f_equal. apply IHl.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (append x y)) (len (append y x)).
Proof.
   induction x.
   - intros. simpl. rewrite IHx. apply lem.
   - intros. simpl. lfind. Admitted.


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order uniform.
From discprob.monad Require Import monad permutation.
From discprob.monad Require quicksort quicksort_cost counter.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coq Require Import Reals Fourier Psatz Program.Wf Omega.

Definition binomial := counter.binomial.
Fixpoint leader_elect (rounds: nat) (players: nat) : ldist (nat * nat) :=
  match rounds with
  | O => mret (O, players)
  | S rounds' =>
    match players with
      | O => mret (rounds, O)
      | 1 => mret (rounds, S O)
      | S (S _) =>
        (surv ← binomial players;
         (if sval surv == O then
            (* no one survived, so all current players repeat in next round *)
            leader_elect rounds' players
          else
            leader_elect rounds' (sval surv)))
    end
  end.

Lemma leader_elect_unfold (rounds: nat) (players: nat):
  leader_elect rounds players =
  match rounds with
  | O => mret (O, players)
  | S rounds' =>
    match players with
      | O => mret (rounds, O)
      | 1 => mret (rounds, S O)
      | S (S _) =>
        (surv ← binomial players;
         (if sval surv == O then
            leader_elect rounds' players
          else
            leader_elect rounds' (sval surv)))
    end
  end.
Proof. destruct rounds, players => //=. Qed.


Require Export lambda_coq.
Require Export final_sem.

Set Implicit Arguments.

Section to_coq.
Variable W:Set.
Parameter semW:forall (w:W)(i:nat)(ty:semType),trans_type ty.

Definition deep_to_shallow(ct:cst W): trans_type (type_cst ct).
elim ct.
intro l;elim l.
simpl.
intros P Q;exact (P/\Q).
simpl.
intro f.
exact (exists x:E, (f x)).
simpl;intro f.
exact ((exists x:E, (f x)) /\ (forall (x y:E), f x->f y-> x=y)).
simpl;intro f.
exact (forall x, f x).
simpl;intros P Q;exact (P \/ Q).
simpl;intros P Q;exact (P -> Q).
simpl.
intros w i ty.
exact (semW w i ty).
Defined.

End to_coq.

 Definition pretty_printer(W:Set) (l:lambda_terms (cst W))(ty:semType)
(p:isWellTyped (type_cst (W:=W)) nil l ty) (q:no_hyps_inside l) :(trans_type ty):=
(trans_lamb (getSemTypeX:= type_cst (W:=W)) (deep_to_shallow (W:=W)) p q (nil_trans)).

(* the pretty printer will be refined in a future release *)


Require Import Coq.Strings.String.
(** Require the monad definitions **)
Require Import ExtLib.Structures.Monads.
(** Use the instances for exceptions **)
Require Import ExtLib.Data.Monads.EitherMonad.
(** Strings will be used for error messages **)
Require Import ExtLib.Data.String.

Set Implicit Arguments.
Set Strict Implicit.

(** Syntax and values of a simple language **)
Inductive value : Type :=
| Int : nat -> value
| Bool : bool -> value.

Inductive exp : Type :=
| ConstI : nat -> exp
| ConstB : bool -> exp
| Plus : exp -> exp -> exp
| If : exp -> exp -> exp -> exp.

Section monadic.
  (** Going to work over any monad [m] that is:
   ** 1) a Monad, i.e. [Monad m]
   ** 2) has string-valued exceptions, i.e. [MonadExc string m]
   **)
  Variable m : Type -> Type.
  Context {Monad_m : Monad m}.
  Context {MonadExc_m : MonadExc string m}.

  (** Use the notation for monads **)
  Import MonadNotation.
  Local Open Scope monad_scope.

  (** Functions that get [nat] or [bool] values from a [value] **)
  Definition asInt (v : value) : m nat :=
    match v with
      | Int n => ret n
      | _ =>
        (** if we don't have an integer, signal an error using
         ** [raise] from the MoandExc instance
         **)
        raise ("expected integer got bool")%string
    end.

  Definition asBool (v : value) : m bool :=
    match v with
      | Bool b => ret b
      | _ => raise ("expected bool got integer")%string
    end.

  (** The main evaluator routine returns a [value], but since we are
   ** working in the [m] monad, we return [m value]
   **)
  Fixpoint eval' (e : exp) : m value :=
    match e with
        (** when there is no error, we can just return (i.e. [ret])
         ** the answer
         **)
      | ConstI i => ret (Int i)
      | ConstB b => ret (Bool b)
      | Plus l r =>
        (** evaluate the sub-terms to numbers **)
        l <- eval' l ;;
        l <- asInt l ;;
        r <- eval' r ;;
        r <- asInt r ;;
        (** Combine the result **)
        ret (Int (l + r))
      | If t tr fa =>
        (** evaluate the test condition to a boolean **)
        t <- eval' t ;;
        t <- asBool t ;;
        (** case split and perform the appropriate recursion **)
        if (t : bool) then
          eval' tr
        else
          eval' fa
    end.

End monadic.

(** Wrap the [eval] function up with the monad instance that we
 ** want to use
 **)
Definition eval : exp -> string + value :=
  eval' (m := sum string).

(** Some tests **)
Eval compute in eval (Plus (ConstI 1) (ConstI 2)).
Eval compute in eval (Plus (ConstI 1) (ConstB false)).

(** Other useful monads:
 ** * Reader - for handling lexicographic environments
 ** * State - for handling non-lexical state, like a heap
 ** * MonadFix - for handling unbounded recursion
 **)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Typeclass-based setoids, tactics and standard instances.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Set Implicit Arguments.
Unset Strict Implicit.

Generalizable Variables A.

Require Import Coq.Program.Program.

Require Import Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.

(** A setoid wraps an equivalence. *)

Class Setoid A := {
  equiv : relation A ;
  setoid_equiv :> Equivalence equiv }.

(* Too dangerous instance *)
(* Program Instance [ eqa : Equivalence A eqA ] =>  *)
(*   equivalence_setoid : Setoid A := *)
(*   equiv := eqA ; setoid_equiv := eqa. *)

(** Shortcuts to make proof search easier. *)

Definition setoid_refl `(sa : Setoid A) : Reflexive equiv.
Proof. typeclasses eauto. Qed.

Definition setoid_sym `(sa : Setoid A) : Symmetric equiv.
Proof. typeclasses eauto. Qed.

Definition setoid_trans `(sa : Setoid A) : Transitive equiv.
Proof. typeclasses eauto. Qed.

Existing Instance setoid_refl.
Existing Instance setoid_sym.
Existing Instance setoid_trans.

(** Standard setoids. *)

(* Program Instance eq_setoid : Setoid A := *)
(*   equiv := eq ; setoid_equiv := eq_equivalence. *)

Program Instance iff_setoid : Setoid Prop :=
  { equiv := iff ; setoid_equiv := iff_equivalence }.

(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *)

(** Subset objects should be first coerced to their underlying type, but that notation doesn't work in the standard case then. *)
(* Notation " x == y " := (equiv (x :>) (y :>)) (at level 70, no associativity) : type_scope. *)

Notation " x == y " := (equiv x y) (at level 70, no associativity) : type_scope.

Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : type_scope.

(** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *)

Ltac clsubst H :=
  lazymatch type of H with
    ?x == ?y => substitute H ; clear H x
  end.

Ltac clsubst_nofail :=
  match goal with
    | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail
    | _ => idtac
  end.

(** [subst*] will try its best at substituting every equality in the goal. *)

Tactic Notation "clsubst" "*" := clsubst_nofail.

Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z.
Proof with auto.
  intros; intro.
  assert(z == y) by (symmetry ; auto).
  assert(x == y) by (transitivity z ; eauto).
  contradiction.
Qed.

Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z.
Proof.
  intros; intro.
  assert(y == x) by (symmetry ; auto).
  assert(y == z) by (transitivity x ; eauto).
  contradiction.
Qed.

Ltac setoid_simplify_one :=
  match goal with
    | [ H : (?x == ?x)%type |- _ ] => clear H
    | [ H : (?x == ?y)%type |- _ ] => clsubst H
    | [ |- (?x =/= ?y)%type ] => let name:=fresh "Hneq" in intro name
  end.

Ltac setoid_simplify := repeat setoid_simplify_one.

Ltac setoidify_tac :=
  match goal with
    | [ s : Setoid ?A, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H
    | [ s : Setoid ?A |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y)
  end.

Ltac setoidify := repeat setoidify_tac.

(** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *)

Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv :=
  proper_prf.

Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) :=
  proper_prf.

(** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *)

Class PartialSetoid (A : Type) :=
  { pequiv : relation A ; pequiv_prf :> PER pequiv }.

(** Overloaded notation for partial setoid equivalence. *)

Infix "=~=" := pequiv (at level 70, no associativity) : type_scope.

(** Reset the default Program tactic. *)

Obligation Tactic := program_simpl.


From Cdcl Require Import Itauto. #[local] Tactic Notation "itauto" := itauto auto.
From stdpp Require Import prelude.
From Coq Require Import Classical.
From sets Require Import Functions.

Section sec_ensemble.

Definition Ensemble (idomain : Type) : Type := idomain -> Prop.

Definition top (idomain : Type) : Ensemble idomain := const true.

Context
  [idomain : Type].

#[export] Instance pow_set_elem_of : ElemOf idomain (Ensemble idomain) := fun x A => A x.
#[export] Instance pow_set_empty : Empty (Ensemble idomain) := const False.
#[export] Instance pow_set_singleton : Singleton idomain (Ensemble idomain) :=
  fun x => fun y => y = x.
#[export] Instance pow_set_union : Union (Ensemble idomain) :=
  fun A B => fun x => x ∈ A \/ x ∈ B.
#[export] Instance pow_set_intersection : Intersection (Ensemble idomain) :=
  fun A B => fun x => x ∈ A /\ x ∈ B.
#[export] Instance pow_set_difference : Difference (Ensemble idomain) :=
  fun A B => fun x => x ∈ A /\ x ∉ B.
#[export] Instance pow_set_semiset : SemiSet idomain (Ensemble idomain).
Proof. by split; [inversion 1 |..]. Qed.
#[export] Instance pow_set_set : Set_ idomain (Ensemble idomain).
Proof. by split; [typeclasses eauto |..]. Qed.

Definition complement (A : Ensemble idomain) : Ensemble idomain := fun a => a ∉ A.

Lemma elem_of_equiv_top X : X ≡ top idomain ↔ ∀ x, x ∈ X.
Proof. set_solver. Qed.

Lemma top_subseteq_equiv A : top idomain ⊆ A <-> A ≡ top idomain.
Proof. by split; intro Hsub; [split; [done |] | intro]; apply Hsub. Qed.

Definition filtered_union
    `(P : index -> Prop) (A : index -> (Ensemble idomain)) : (Ensemble idomain) :=
  fun a => exists i, P i /\ a ∈ A i.

Lemma elem_of_filtered_union
    a `(P : index -> Prop) (A : index -> (Ensemble idomain)) :
  a ∈ filtered_union P A <-> exists i, P i /\ a ∈ A i.
Proof. done. Qed.

Lemma member_of_filtered_union `(P : index -> Prop) (A : index -> (Ensemble idomain)) i :
  P i -> A i ⊆ filtered_union P A.
Proof. by intros Hi a HAi; apply elem_of_filtered_union; eexists. Qed.

Lemma empty_filtered_union `(P : index -> Prop) (A : index -> (Ensemble idomain)) :
  filtered_union P A ≡ ∅ <-> forall i, P i -> A i ≡ ∅.
Proof.
  split.
  - intros Hunion i; rewrite elem_of_equiv_empty; intros Hi a Ha.
    by apply (Hunion a), elem_of_filtered_union; eexists.
  - intro Hunion; rewrite elem_of_equiv_empty; intro a.
    rewrite elem_of_filtered_union; intros (? & ? & ?).
    by eapply Hunion.
Qed.

Definition indexed_union {index} : (index -> (Ensemble idomain)) -> (Ensemble idomain) :=
  filtered_union (const True).

Lemma elem_of_indexed_union a `(A : index -> (Ensemble idomain)) :
  a ∈ indexed_union A <-> exists i, a ∈ A i.
Proof.
  unfold indexed_union; rewrite elem_of_filtered_union.
  by split; intros [i Hi]; exists i; [apply Hi | split].
Qed.

Lemma member_of_indexed_union `(A : index -> (Ensemble idomain)) i :
  A i ⊆ indexed_union A.
Proof. by apply member_of_filtered_union. Qed.

Lemma empty_indexed_union `(A : index -> (Ensemble idomain)) :
  indexed_union A ≡ ∅ <-> forall i, A i ≡ ∅.
Proof.
  unfold indexed_union; rewrite empty_filtered_union.
  cbn; itauto.
Qed.

Definition filtered_intersection
    `(P : index -> Prop) (A : index -> (Ensemble idomain)) : (Ensemble idomain) :=
  fun a => forall i, P i -> a ∈ A i.

Lemma elem_of_filtered_intersection
    a `(P : index -> Prop) (A : index -> (Ensemble idomain)) :
  a ∈ filtered_intersection P A <-> forall i, P i -> a ∈ A i.
Proof. done. Qed.

Lemma member_of_filtered_intersection `(P : index -> Prop) (A : index -> (Ensemble idomain)) i :
  P i -> filtered_intersection P A ⊆ A i.
Proof. by intros Hi a; rewrite elem_of_filtered_intersection; intros HA; apply HA. Qed.

Lemma filtered_intersection_empty_top
    `(P : index -> Prop) (A : index -> (Ensemble idomain)) :
  (forall i, ~ P i) -> filtered_intersection P A ≡ top idomain.
Proof.
  intros HnP; apply elem_of_equiv_top; intro a.
  apply elem_of_filtered_intersection; intros i HPi.
  by exfalso; eapply HnP.
Qed.

Definition indexed_intersection {index} : (index -> (Ensemble idomain)) -> (Ensemble idomain) :=
  filtered_intersection (const True).

Lemma elem_of_indexed_intersection a `(A : index -> (Ensemble idomain)) :
  a ∈ indexed_intersection A <-> forall i, a ∈ A i.
Proof.
  unfold indexed_intersection; rewrite elem_of_filtered_intersection.
  by split; intros Hall **; apply Hall.
Qed.

Lemma member_of_indexed_intersection `(A : index -> (Ensemble idomain)) i :
  indexed_intersection A ⊆ A i.
Proof. by apply member_of_filtered_intersection. Qed.

Lemma filtered_intersection_subseteq_filtered_union
  `(P : index -> Prop) (A : index -> (Ensemble idomain)) :
   (exists i, P i) -> filtered_intersection P A ⊆ filtered_union P A.
Proof.
  intros [] a; rewrite elem_of_filtered_intersection, elem_of_filtered_union.
  by intros Hall; eexists; split; [| apply Hall].
Qed.

Lemma indexed_intersection_subseteq_indexed_union
  `{Inhabited index} (A : index -> (Ensemble idomain)) :
  indexed_intersection A ⊆ indexed_union A.
Proof.
  apply filtered_intersection_subseteq_filtered_union.
  by exists inhabitant.
Qed.

Definition intersection_list : list (Ensemble idomain) → Ensemble idomain :=
  fold_right (∩) (top idomain).
Notation "⋂ l" := (intersection_list l) (at level 20, format "⋂ l") : stdpp_scope.

Lemma elem_of_intersection_list Xs x : x ∈ ⋂ Xs ↔ forall X, X ∈ Xs -> x ∈ X.
Proof.
  split.
  - induction Xs; simpl; intros HXs; [inversion 1|].
    setoid_rewrite elem_of_cons. rewrite elem_of_intersection in HXs. naive_solver.
  - induction Xs; intro HXs; [done |].
    simpl; apply elem_of_intersection; split; [apply HXs | apply IHXs]; [left |].
    by intros; apply HXs; right.
Qed.

Definition sym_diff (A B : (Ensemble idomain)) : (Ensemble idomain) := (A ∖ B) ∪ (B ∖ A).

#[export] Instance complement_subseteq_proper : Proper ((⊆) --> (⊆)) complement.
Proof.
  intros B C Hbc a; unfold complement, elem_of, pow_set_elem_of.
  by intro Hb; contradict Hb; apply Hbc.
Qed.

Lemma complement_subseteq_iff_classic B C : B ⊆ C <-> complement C ⊆ complement B.
Proof.
  split; [apply complement_subseteq_proper |].
  intros Hbc b Hb.
  destruct (classic (b ∈ C)); [done |].
  by contradict Hb; apply Hbc.
Qed.

#[export] Instance complement_equiv_proper : Proper ((≡) ==> (≡)) complement.
Proof.
  intros B C; rewrite !set_equiv_subseteq.
  intros [Hbc Hcb]; split.
  - by rewrite <- Hcb.
  - by rewrite <- Hbc.
Qed.

Lemma complement_equiv_proper_iff_classic B C : B ≡ C <-> complement B ≡ complement C.
Proof.
  by rewrite !set_equiv_subseteq, <- !complement_subseteq_iff_classic; set_solver.
Qed.

Lemma elem_of_complement a A : a ∈ complement A <-> a ∉ A.
Proof. done. Qed.

Lemma complement_top A : complement A ≡ top idomain <-> A ≡ ∅.
Proof.
  split; [| intros ->].
  - intros Hcompl a; split; [| done]; intro Ha.
    destruct (Hcompl a) as [_ Hcompl'].
    by feed specialize Hcompl'.
  - by rewrite elem_of_equiv_top; intro; apply elem_of_complement, not_elem_of_empty.
Qed.

Lemma complement_twice_classic A : complement (complement A) ≡ A.
Proof.
  intro a; rewrite !elem_of_complement.
  split; [| by intros ? ?].
  by intro; apply NNPP.
Qed.

Lemma complement_empty_classic A : complement A ≡ ∅ <-> A ≡ top idomain.
Proof.
  by rewrite <- complement_top, complement_twice_classic.
Qed.

Lemma complement_union_classic A B :
  complement (A ∪ B) ≡ complement A ∩ complement B.
Proof.
  intro a; rewrite elem_of_intersection, !elem_of_complement, elem_of_union.
  by split; [apply not_or_and | intros [] []].
Qed.

Lemma complement_intersection_classic A B :
  complement (A ∩ B) ≡ complement A ∪ complement B.
Proof.
  intro a; rewrite elem_of_union, !elem_of_complement, elem_of_intersection.
  by split; [apply not_and_or | intros [] []].
Qed.

Lemma complement_filtered_union `(P : index -> Prop) (A : index -> (Ensemble idomain)) :
  complement (filtered_union P A) ≡ filtered_intersection P (complement ∘ A).
Proof.
  intro x; rewrite elem_of_filtered_intersection; setoid_rewrite elem_of_complement;
    rewrite elem_of_filtered_union.
  split; [| by intros Hix (i & Hi & Hx); eapply Hix].
  by intros Hnix i Hi; contradict Hnix; eexists.
Qed.

Lemma complement_indexed_union `(f : index -> (Ensemble idomain)) :
  complement (indexed_union f) ≡ indexed_intersection (complement ∘ f).
Proof. by unfold indexed_union; rewrite complement_filtered_union. Qed.

Lemma complement_filtered_intersection_classic `(P : index -> Prop) `(A : index -> (Ensemble idomain)) :
  complement (filtered_intersection P A) ≡ filtered_union P (complement ∘ A).
Proof.
  intro x; rewrite elem_of_filtered_union; setoid_rewrite elem_of_complement;
    rewrite elem_of_filtered_intersection.
  split; [| by intros (i & Hi & Hx); contradict Hx; apply Hx].
  intros Hnot; apply not_all_ex_not in Hnot as [i Hnot].
  by eexists; apply imply_to_and in Hnot.
Qed.

Lemma complement_indexed_intersection_classic `(f : index -> (Ensemble idomain)) :
  complement (indexed_intersection f) ≡ indexed_union (complement ∘ f).
Proof.
  by unfold indexed_intersection; rewrite complement_filtered_intersection_classic.
Qed.

#[export]  Instance intersection_empty_l : LeftId (≡@{(Ensemble idomain)}) (top idomain) (∩).
Proof. intros X. set_solver. Qed.
#[export] Instance intersection_empty_r : RightId (≡@{(Ensemble idomain)}) (top idomain) (∩).
Proof. intros X. set_solver. Qed.

Lemma top_intersection A B : A ∩ B ≡ top idomain <-> A ≡ top idomain /\ B ≡ top idomain.
Proof. set_solver. Qed.

Lemma top_filtered_intersection `(P : index -> Prop) (f : index -> (Ensemble idomain)) :
  filtered_intersection P f ≡ top idomain
    <->
  forall B, P B -> f B ≡ top idomain.
Proof.
  setoid_rewrite elem_of_equiv_top; setoid_rewrite elem_of_filtered_intersection.
  itauto.
Qed.

Lemma top_indexed_intersection (f : Ensemble idomain -> Ensemble idomain) :
  indexed_intersection f ≡ top idomain
    <->
  forall B, f B ≡ top idomain.
Proof.
  unfold indexed_intersection. rewrite top_filtered_intersection; cbn; itauto.
Qed.

Lemma intersection_list_cons X Xs : ⋂ (X :: Xs) = X ∩ ⋂ Xs.
Proof. done. Qed.

Lemma top_intersection_list Xs :
  ⋂ Xs ≡ top idomain <-> Forall (fun X => X ≡ top idomain) Xs.
Proof.
  induction Xs; [by cbn; split; [constructor |] |].
  by rewrite intersection_list_cons, top_intersection, Forall_cons, IHXs.
Qed.

Lemma difference_alt A B : A ∖ B ≡ A ∩ complement B.
Proof. set_solver. Qed.

Lemma subseteq_empty_difference_classic (X Y : (Ensemble idomain)) : X ⊆ Y <-> X ∖ Y ≡ ∅.
Proof.
  split; [apply subseteq_empty_difference |].
  intros Hxy a Ha; destruct (Hxy a) as [Hxy' _].
  rewrite elem_of_difference in Hxy'.
  destruct (classic (a ∈ Y)); [done | exfalso].
  by apply Hxy'.
Qed.

#[export] Instance sym_diff_proper : Proper ((≡) ==> (≡) ==> (≡)) sym_diff.
Proof. by intros A B Hab C D Hcd; unfold sym_diff; rewrite Hab, Hcd. Qed.

Lemma sym_diff_empty_classic A B : sym_diff A B ≡ ∅ <-> A ≡ B.
Proof.
  unfold sym_diff; split; [| intros ->].
  - intros Hab x; specialize (Hab x).
    rewrite elem_of_union, !elem_of_difference in Hab; split.
    + intros Ha.
      destruct (classic (x ∈ B)); [done |].
      by exfalso; apply Hab; left; split.
    + intros Hb.
      destruct (classic (x ∈ A)); [done |].
      by exfalso; apply Hab; right; split.
  - apply elem_of_equiv_empty; intro x.
    rewrite elem_of_union, !elem_of_difference.
    by intros [[] | []].
Qed.

Inductive CrispSet (A : Ensemble idomain) : Prop :=
| cs_empty : A ≡ ∅ -> CrispSet A
| cs_top : A ≡ top idomain -> CrispSet A.

Definition ascending_chain (C : nat -> Ensemble idomain) : Prop :=
  forall n, C n ⊆ C (S n).

Lemma ascending_chain_skipping (C : nat -> Ensemble idomain) :
  ascending_chain C -> forall m n, m <= n -> C m ⊆ C n.
Proof.
  intros HC m n; revert m; induction n.
  - by intros m Hm; replace m with 0 by lia.
  - intros m Hm; destruct (decide (m = S n)); [by subst |].
    etransitivity; [| apply HC].
    apply IHn; lia.
Qed.

Lemma proper_compose_ascending_chain
  (F : Ensemble idomain -> Ensemble idomain) `{!Proper ((⊆) ==> (⊆)) F}
  (C : nat -> Ensemble idomain) :
  ascending_chain C -> ascending_chain (F ∘ C).
Proof. by intros HC n; apply Proper0, HC. Qed.

Definition descending_chain (C : nat -> Ensemble idomain) : Prop :=
  forall n, C (S n) ⊆ C n.

Lemma descending_chain_skipping (C : nat -> Ensemble idomain) :
  descending_chain C -> forall m n, m <= n -> C n ⊆ C m.
Proof.
  intros HC m n; revert m; induction n.
  - by intros m Hm; replace m with 0 by lia.
  - intros m Hm; destruct (decide (m = S n)); [by subst |].
    etransitivity; [apply HC |].
    apply IHn; lia.
Qed.

Lemma proper_compose_descending_chain
  (F : Ensemble idomain -> Ensemble idomain) `{!Proper ((⊆) ==> (⊆)) F}
  (C : nat -> Ensemble idomain) :
  descending_chain C -> descending_chain (F ∘ C).
Proof. by intros HC n; apply Proper0, HC. Qed.

Lemma ascending_chain_descending (C : nat -> Ensemble idomain) :
  ascending_chain C -> descending_chain (complement ∘ C).
Proof.
  intros Hasc n; cbn; intro a; cbn; rewrite !elem_of_complement.
  by unfold ascending_chain in Hasc; set_solver.
Qed.

Lemma descending_chain_ascending (C : nat -> Ensemble idomain) :
  descending_chain C -> ascending_chain (complement ∘ C).
Proof.
  intros Hasc n; cbn; intro a; cbn; rewrite !elem_of_complement.
  by unfold descending_chain in Hasc; set_solver.
Qed.

End sec_ensemble.

Section sec_ensemble_maps.

Definition image `(F : A -> Ensemble B) (X : Ensemble A) : Ensemble B :=
  filtered_union (fun x : A => x ∈ X) F.

Lemma image_singleton `(F : A -> Ensemble B) (a : A) :
  F a ≡ image F {[ a ]}.
Proof.
  intro x; unfold image.
  rewrite elem_of_filtered_union.
  setoid_rewrite elem_of_singleton.
  by set_solver.
Qed.

Lemma elem_of_image `(F : A -> Ensemble B) (X : Ensemble A) (b : B) :
  b ∈ image F X <-> exists a, a ∈ X /\ b ∈ F a.
Proof. by apply elem_of_filtered_union. Qed.

Definition fiber `(F : A -> Ensemble B) (y : B) : Ensemble A :=
  filtered_union (fun x : A => y ∈ F x) singleton.

Lemma elem_of_fiber `(F : A -> Ensemble B) (b : B) (a : A) :
  a ∈ fiber F b <-> b ∈ F a.
Proof.
  unfold fiber; rewrite elem_of_filtered_union.
  by set_solver.
Qed.

Definition preimage {A B : Type} : (A -> Ensemble B) -> Ensemble B -> Ensemble A :=
  image ∘ fiber.

Lemma elem_of_preimage `(F : A -> Ensemble B) (Y : Ensemble B) (a : A) :
  a ∈ preimage F Y <-> exists y, y ∈ Y /\ y ∈ F a.
Proof.
  unfold preimage; cbn.
  rewrite elem_of_image.
  by setoid_rewrite elem_of_fiber.
Qed.

End sec_ensemble_maps.

Notation "⋂ l" := (intersection_list l) (at level 20, format "⋂ l") : stdpp_scope.

Section SecKnasterTarski.

Context
  {idomain : Type}
  (F : Ensemble idomain -> Ensemble idomain)
  `{!Proper ((⊆) ==> (⊆)) F}.

Definition pre_fixpoint (B : Ensemble idomain) : Prop := F B ⊆ B.
Definition post_fixpoint (B : Ensemble idomain) : Prop := B ⊆ F B.
Definition fixpoint (B : Ensemble idomain) : Prop := F B ≡ B.

Definition lfp : Ensemble idomain := filtered_intersection pre_fixpoint id.

Lemma elem_of_lfp x : x ∈ lfp <-> forall A, pre_fixpoint A -> x ∈ A.
Proof. by apply elem_of_filtered_intersection. Qed.

Lemma knaster_tarsky_least_pre_fixpoint A :
  pre_fixpoint A -> lfp ⊆ A.
Proof.
  intros HA a; rewrite elem_of_lfp.
  by intro Hall; apply Hall in HA.
Qed.

Lemma knaster_tarsky_lfp_least A :
  fixpoint A -> lfp ⊆ A.
Proof.
  intro HA; apply set_equiv_subseteq in HA as [HA _].
  by apply knaster_tarsky_least_pre_fixpoint.
Qed.

Lemma knaster_tarsky_lfp_fix : fixpoint lfp.
Proof.
  apply set_equiv_subseteq.
  cut (pre_fixpoint lfp); [intros Hincl; split; [done |] |].
  - intro a; rewrite elem_of_lfp.
    by intro Hall; apply Proper0, Hall in Hincl.
  - intro a; rewrite elem_of_lfp.
    intros Ha B HB.
    apply HB.
    assert (Hincl : lfp ⊆ B)
      by (apply knaster_tarsky_least_pre_fixpoint; done).
    by apply Proper0 in Hincl; apply Hincl.
Qed.

Lemma knaster_tarsky_lfp_fix_sub A : A ⊆ lfp -> F A ⊆ lfp.
Proof.
  intro Hincl.
  transitivity (F lfp); [by apply Proper0 |].
  by apply set_equiv_subseteq; symmetry; apply knaster_tarsky_lfp_fix.
Qed.

Definition gfp : Ensemble idomain := filtered_union post_fixpoint id.

Lemma elem_of_gfp x : x ∈ gfp <-> exists A, post_fixpoint A /\ x ∈ A.
Proof. by apply elem_of_filtered_union. Qed.

Lemma knaster_tarsky_greatest_post_fixpoint A :
  post_fixpoint A -> A ⊆ gfp.
Proof.
  by intros HA a Ha; rewrite elem_of_gfp; eexists.
Qed.

Lemma knaster_tarsky_gfp_greatest A :
  fixpoint A -> A ⊆ gfp.
Proof.
  intro HA; apply set_equiv_subseteq in HA as [_ HA].
  by apply knaster_tarsky_greatest_post_fixpoint.
Qed.

Lemma knaster_tarsky_gfp_fix : fixpoint gfp.
Proof.
  apply set_equiv_subseteq.
  cut (post_fixpoint gfp); [intros Hincl; split; [| done] |].
  - intros a Ha; rewrite elem_of_gfp.
    by apply Proper0 in Hincl; eexists.
  - intro a; rewrite elem_of_gfp.
    intros (A & HA & Ha).
    assert (Hincl : A ⊆ gfp)
      by (apply knaster_tarsky_greatest_post_fixpoint; done).
    by apply Proper0 in Hincl; apply Hincl, HA.
Qed.

Lemma knaster_tarsky_gfp_fix_sub A : gfp ⊆ A -> gfp ⊆ F A.
Proof.
  intro Hincl.
  transitivity (F gfp); [| by apply Proper0].
  by apply set_equiv_subseteq; apply knaster_tarsky_gfp_fix.
Qed.

End SecKnasterTarski.

Section sec_fix_points_props.

Context
  {idomain : Type}
  (F G : Ensemble idomain -> Ensemble idomain)
  (Hext : forall A, F A ≡ G A).

Lemma pre_fixpoint_equiv B :
  pre_fixpoint F B <-> pre_fixpoint G B.
Proof. by unfold pre_fixpoint; rewrite Hext. Qed.

Lemma post_fixpoint_equiv B :
  post_fixpoint F B <-> post_fixpoint G B.
Proof. by unfold post_fixpoint; rewrite Hext. Qed.

Lemma fixpoint_equiv B :
  fixpoint F B <-> fixpoint G B.
Proof. by unfold fixpoint; rewrite Hext. Qed.

End sec_fix_points_props.

Class Continuous {idomain : Type} (F : Ensemble idomain -> Ensemble idomain) : Prop :=
{
  continuous : forall (C : nat -> Ensemble idomain),
    F (indexed_union C) ≡ indexed_union (F ∘ C)
}.

Class OmegaContinuous {idomain : Type} (F : Ensemble idomain -> Ensemble idomain) : Prop :=
{
  omega_continuous : forall (C : nat -> Ensemble idomain),
    ascending_chain C -> F (indexed_union C) ≡ indexed_union (F ∘ C)
}.

#[export] Instance ContinuousOmega `{Continuous idomain F} : OmegaContinuous F.
Proof. by constructor; intros; apply continuous. Qed.

Class CoContinuous {idomain : Type} (F : Ensemble idomain -> Ensemble idomain) : Prop :=
{
  co_continuous : forall (C : nat -> Ensemble idomain),
    F (indexed_intersection C) ≡ indexed_intersection (F ∘ C)
}.

Class CoOmegaContinuous {idomain : Type} (F : Ensemble idomain -> Ensemble idomain) : Prop :=
{
  co_omega_continuous : forall (C : nat -> Ensemble idomain),
    descending_chain C -> F (indexed_intersection C) ≡ indexed_intersection (F ∘ C)
}.

#[export] Instance CoContinuousOmega `{CoContinuous idomain F} : CoOmegaContinuous F.
Proof. by constructor; intros; apply co_continuous. Qed.

Section SecKleeneFixPoint.

Context
  {idomain : Type}
  (F : Ensemble idomain -> Ensemble idomain)
  `{!Proper ((⊆) ==> (⊆)) F}.

#[export] Instance pow_compose_monotone n : Proper ((⊆) ==> (⊆)) (pow_compose F n).
Proof.
  induction n; cbn; [by typeclasses eauto |].
  by intros ? ? ?; apply Proper0, IHn.
Qed.

Lemma pre_fixpoint_pow_compose A n : pre_fixpoint F A -> pow_compose F n A ⊆ A.
Proof.
  intros Hpre; induction n; [done |].
  by etransitivity; [apply Proper0 | apply Hpre].
Qed.

Definition klfp : Ensemble idomain := indexed_union (fun n => pow_compose F n ∅).

Lemma elem_of_klfp x : x ∈ klfp <-> exists n, x ∈ pow_compose F n ∅.
Proof. by apply elem_of_indexed_union. Qed.

Lemma member_of_klfp n : pow_compose F n ∅ ⊆ klfp.
Proof. by apply (member_of_indexed_union (fun n => pow_compose F n ∅)). Qed.

Lemma klfp_unfold :
  klfp ≡ indexed_union (F ∘ (λ n : nat, pow_compose F n ∅)).
Proof.
  intro a; rewrite elem_of_indexed_union, elem_of_klfp; cbn; split.
  - by intros [[] Ha]; [by contradict Ha; apply not_elem_of_empty | exists n].
  - by intros [n Ha]; exists (S n).
Qed.

Lemma kleene_ascending_chain : ascending_chain (fun n => pow_compose F n ∅).
Proof. by intro n; induction n; [set_solver | apply Proper0]. Qed.

Lemma klfp_post_fixpoint : post_fixpoint F klfp.
Proof.
  unfold post_fixpoint.
  etransitivity; [by rewrite klfp_unfold |].
  intro a; rewrite elem_of_indexed_union.
  cbn; intros [n Ha].
  cut (F (pow_compose F n ∅) ⊆ F klfp); [by set_solver |].
  by apply Proper0, member_of_klfp.
Qed.

Lemma pow_compose_F_n_empty_subseteq_pre_fixpoint
  A (HA : pre_fixpoint F A) n :
  pow_compose F n ∅ ⊆ A.
Proof.
  induction n; cbn; [by set_solver |].
  by transitivity (F A); [apply Proper0 |].
Qed.

Lemma kleene_least_pre_fixpoint A : pre_fixpoint F A -> klfp ⊆ A.
Proof.
  intros HA a; rewrite elem_of_klfp.
  intros [n Ha].
  by eapply pow_compose_F_n_empty_subseteq_pre_fixpoint.
Qed.

Lemma klfp_subseteq_lfp : klfp ⊆ lfp F.
Proof.
  intros x Hx; apply elem_of_lfp.
  by intros A HA; apply kleene_least_pre_fixpoint.
Qed.

Lemma kleene_lfp_least A :
  fixpoint F A -> klfp ⊆ A.
Proof.
  intro HA; etransitivity.
  - by apply klfp_subseteq_lfp.
  - by apply knaster_tarsky_lfp_least.
Qed.

Lemma klfp_fixpoint_elim :
  pre_fixpoint F klfp -> fixpoint F klfp.
Proof.
  by intro; apply set_equiv_subseteq; split; [| apply klfp_post_fixpoint].
Qed.

Lemma Omega_continuous_klfp_fixpoint `{!OmegaContinuous F} : fixpoint F klfp.
Proof.
  unfold fixpoint.
  etransitivity; [| by rewrite klfp_unfold].
  by apply omega_continuous, kleene_ascending_chain.
Qed.

Lemma kleene_knaster_tarsky_lfp_equiv :
  fixpoint F klfp -> lfp F ≡ klfp.
Proof.
  intro Hfix; apply set_equiv_subseteq; split.
  - by apply knaster_tarsky_lfp_least, Hfix.
  - by apply klfp_subseteq_lfp.
Qed.

Definition kgfp : Ensemble idomain :=
  indexed_intersection (fun n => pow_compose F n (top idomain)).

Lemma elem_of_kgfp x : x ∈ kgfp <-> forall n, x ∈ pow_compose F n (top idomain).
Proof. by apply elem_of_indexed_intersection. Qed.

Lemma member_of_kgfp n : kgfp ⊆ pow_compose F n (top idomain).
Proof. apply (member_of_indexed_intersection (fun n => pow_compose F n (top idomain))). Qed.

Lemma kleene_descending_chain : descending_chain (fun n => pow_compose F n (top idomain)).
Proof. by intro n; induction n; [set_solver | apply Proper0]. Qed.

Lemma kgfp_unfold :
  kgfp ≡ indexed_intersection (F ∘ (λ n : nat, pow_compose F n (top idomain))).
Proof.
  intro a; rewrite elem_of_indexed_intersection, elem_of_kgfp; cbn; split.
  - by intros Hall n; apply (Hall (S n)).
  - by intros Hall []; [| apply Hall].
Qed.

Lemma kgfp_pre_fixpoint : pre_fixpoint F kgfp.
Proof.
  unfold pre_fixpoint.
  etransitivity; [| by rewrite kgfp_unfold].
  intro a; rewrite elem_of_indexed_intersection.
  cbn; intros Ha n.
  cut (F kgfp ⊆ F (pow_compose F n (top idomain))); [by set_solver |].
  by apply Proper0, member_of_kgfp.
Qed.

Lemma kgfp_fixpoint_elim :
  post_fixpoint F kgfp -> fixpoint F kgfp.
Proof.
  by intro; apply set_equiv_subseteq; split; [apply kgfp_pre_fixpoint |].
Qed.

Lemma co_Omega_continuous_kgfp_fixpoint `{!CoOmegaContinuous F} :
  fixpoint F kgfp.
Proof.
  unfold fixpoint.
  etransitivity; [| by rewrite kgfp_unfold].
  by apply co_omega_continuous, kleene_descending_chain.
Qed.

Lemma kleene_greatest_post_fixpoint A : post_fixpoint F A -> A ⊆ kgfp.
Proof.
  intros HA.
  cut (forall n, A ⊆ pow_compose F n (top idomain)).
  - by intros Hall a Ha; apply elem_of_kgfp; intro n; apply Hall.
  - induction n; [by set_solver | cbn].
    transitivity (F A); [done |].
    by apply Proper0.
Qed.

Lemma kleene_gfp_greatest A :
  fixpoint F A -> A ⊆ kgfp.
Proof.
  intro HA; apply set_equiv_subseteq in HA as [_ HA].
  by apply kleene_greatest_post_fixpoint.
Qed.

Lemma kleene_knaster_tarsky_gfp_equiv :
  fixpoint F kgfp -> gfp F ≡ kgfp.
Proof.
  intro Hfix; apply set_equiv_subseteq; split.
  - by apply kleene_gfp_greatest, knaster_tarsky_gfp_fix.
  - by apply knaster_tarsky_gfp_greatest, Hfix.
Qed.

End SecKleeneFixPoint.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
Require Import monae_lib hierarchy monad_lib fail_lib state_lib.
Require Import monad_transformer.

(******************************************************************************)
(*               Examples of programs using monad transformers                *)
(*                                                                            *)
(* reference:                                                                 *)
(* - R. Affeldt, D. Nowak, Extending Equational Monadic Reasoning with Monad  *)
(*   Transformers, https://arxiv.org/abs/2011.03463                           *)
(******************************************************************************)

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

Local Open Scope monae_scope.

Definition evalStateT (N : monad) (S : UU0) (M : stateRunMonad S N)
    {A : UU0} (m : M A) (s : S) : N A :=
  runStateT m s >>= fun x => Ret x.1.

Section FastProduct.
Variables (N : exceptMonad) (M : exceptStateRunMonad nat N).

Fixpoint fastProductRec l : M unit :=
  match l with
  | [::] => Ret tt
  | 0 :: _ => fail
  | n.+1 :: l' => get >>= fun m => put (m * n.+1) >> fastProductRec l'
  end.

Definition fastProduct l : M _ :=
  catch (put 1 >> fastProductRec l >> get) (Ret 0 : M _).

Lemma fastProductCorrect l n :
  evalStateT (fastProduct l) n = Ret (product l).
Proof.
rewrite /fastProduct -(mul1n (product _)); move: 1.
elim: l => [ | [ | x] l ih] m.
- rewrite muln1 bindA bindretf putget.
  rewrite /evalStateT runStateTcatch runStateTbind runStateTput bindretf.
  by rewrite runStateTret runStateTret catchret bindretf.
- rewrite muln0.
  rewrite /evalStateT runStateTcatch runStateTbind runStateTbind runStateTput.
  by rewrite bindretf runStateTfail bindfailf catchfailm runStateTret bindretf.
- rewrite [fastProductRec _]/=.
  by rewrite -bindA putget bindA bindA bindretf -bindA -bindA putput ih mulnA.
Qed.

End FastProduct.

(* The following fail-state monad is such that it does not backtrack the
   state. *)
Module PersistentState.
Section persistentstate.
Variable S : UU0.

Definition failPState (A : UU0) : UU0 :=
S -> option A * S.

Definition runFailPState {A : UU0} (m : failPState A) (s : S) : option A * S :=
m s.

Definition ret {A : UU0} (a : A) : failPState A :=
fun s => (Some a, s).

Definition bind {A B : UU0} (m : failPState A) (f : A -> failPState B) :
failPState B :=
fun s => match m s with
| (None, s') => (None, s')
| (Some a, s') => f a s'
end.

Lemma bindretf (A B : UU0) (a : A) (f : A -> failPState B) :
bind (ret a) f = f a.
Proof.
reflexivity.
Qed.

Lemma bindmret (A : UU0) (m : failPState A) :
bind m ret = m.
Proof.
apply boolp.funext => s.
unfold bind.
destruct (m s) as [[|]]; reflexivity.
Qed.

Lemma bindA
  (A B C : UU0) (m : failPState A)
  (f : A -> failPState B) (g : B -> failPState C) :
bind (bind m f) g = bind m (fun x => bind (f x) g).
Proof.
apply boolp.funext => s.
unfold bind.
destruct (m s) as [[|]]; reflexivity.
Qed.

Definition fail {A : UU0} : failPState A := fun s => (None, s).

Definition catch {A : UU0} (m1 m2 : failPState A) :=
fun s => match m1 s with
| (Some a, s') => (Some a, s')
| (None, s') => m2 s'
end.

Definition get : failPState S := fun s => (Some s, s).

Definition put (s : S) : failPState unit := fun _ => (Some tt, s).

End persistentstate.
Arguments runFailPState {_ _} _ _.
Arguments ret {_ _} _.
Arguments bind {_ _ _} _ _.
Arguments fail {_ _}.
Arguments get {_}.
Arguments put {_} _.

Local Notation "m >>> f" := (bind m (fun _ => f)) (at level 49).

(* The following example illustrates how the state is NOT backtracked when a
   failure is catched. *)
Goal
  runFailPState (put 1 >>> catch (put 2 >>> fail) get) 0 =
  (Some 2, 2).
Proof.
reflexivity.
Qed.
End PersistentState.

Section incr_fail_incr.

Section with_failStateReifyMonad.
Variables M : failStateReifyMonad nat.
Let incr : M unit := get >>= (put \o succn).
Let prog (B : UU0) : M unit := incr >> @fail _ B >> incr.

Goal forall T, prog T = @fail _ _.
Proof.
move=> T; rewrite /prog.
rewrite bindA.
rewrite bindfailf.
by rewrite bindmfail.
Abort.
End with_failStateReifyMonad.

Section with_stateT_of_failMonad.
Variable N : failMonad.
Let M : monad := stateT nat N.
Let incr : M unit := get >>= (put \o succn).
Let prog T : M unit := incr >> Lift [the monadT of stateT nat] N T fail >> incr.
Goal forall T, prog T = Lift [the monadT of stateT nat] N unit fail.
Proof.
move=> T; rewrite /prog.
rewrite bindA.
rewrite bindLfailf. (* fail laws are not sufficient *)
Abort.
End with_stateT_of_failMonad.

Section with_exceptT_of_stateMonad.
Definition LGet S (M : stateMonad S) :=
  Lift [the monadT of exceptT unit] M S (@get S M).
Definition LPut S (M : stateMonad S) :=
  Lift [the monadT of exceptT unit] M unit \o (@put S M).

Variable N : stateMonad nat.
Let M : monad := exceptT unit N.
Let incr : M unit := LGet N >>= (LPut N \o succn).
Let prog T : M unit := incr >> (fail : _ T) >> incr.

Goal forall T, prog T = @fail _ unit.
Proof.
move=> T; rewrite /prog.
Abort.
End with_exceptT_of_stateMonad.

End incr_fail_incr.

Require Import monad_model.

Section incr_fail_incr_model.

Lemma bindLmfail (M := [the monad of option_monad]) S T U (m : stateT S M U)
    (FAIL := @throw unit T tt) :
  m >> Lift [the monadT of stateT S] M T FAIL =
  Lift [the monadT of stateT S] M T FAIL.
Proof.
rewrite /= /liftS boolp.funeqE => s.
rewrite except_bindE.
rewrite {1}bindE /= MS_mapE {1}/bindS /=.
by case (m s) => // -[].
Qed.

Section fail_model_sufficient.
Let N : failMonad := [the failMonad of option_monad].
Let M : monad := [the stateMonad nat of MS nat N].
Let FAIL T := @throw unit T tt.

Let incr : M unit := get >>= (put \o succn).
Let prog T : M unit :=
  incr >> Lift [the monadT of stateT nat] N T (@FAIL T) >> incr.
Goal forall T, prog T = Lift [the monadT of stateT nat] N unit (@FAIL unit).
Proof.
move=> T; rewrite /prog.
rewrite bindLmfail.
by rewrite bindLfailf.
Abort.
End fail_model_sufficient.

End incr_fail_incr_model.