(************************************************************************)
(*         *   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)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(** This file defined the strong (course-of-value, well-founded) recursion
and proves its properties *)

Require Export NSub.

Ltac f_equiv' := repeat (repeat f_equiv; try intros ? ? ?; auto).

Module NStrongRecProp (Import N : NAxiomsRecSig').
Include NSubProp N.

Section StrongRecursion.

Variable A : Type.
Variable Aeq : relation A.
Variable Aeq_equiv : Equivalence Aeq.

(** [strong_rec] allows defining a recursive function [phi] given by
    an equation [phi(n) = F(phi)(n)] where recursive calls to [phi]
    in [F] are made on strictly lower numbers than [n].

    For [strong_rec a F n]:
    - Parameter [a:A] is a default value used internally, it has no
      effect on the final result.
    - Parameter [F:(N->A)->N->A] is the step function:
      [F f n] should return [phi(n)] when [f] is a function
      that coincide with [phi] for numbers strictly less than [n].
*)

Definition strong_rec (a : A) (f : (N.t -> A) -> N.t -> A) (n : N.t) : A :=
 recursion (fun _ => a) (fun _ => f) (S n) n.

(** For convenience, we use in proofs an intermediate definition
    between [recursion] and [strong_rec]. *)

Definition strong_rec0 (a : A) (f : (N.t -> A) -> N.t -> A) : N.t -> N.t -> A :=
 recursion (fun _ => a) (fun _ => f).

Lemma strong_rec_alt : forall a f n,
 strong_rec a f n = strong_rec0 a f (S n) n.
Proof.
reflexivity.
Qed.

Instance strong_rec0_wd :
 Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> N.eq ==> Aeq)
  strong_rec0.
Proof.
unfold strong_rec0; f_equiv'.
Qed.

Instance strong_rec_wd :
 Proper (Aeq ==> ((N.eq ==> Aeq) ==> N.eq ==> Aeq) ==> N.eq ==> Aeq) strong_rec.
Proof.
intros a a' Eaa' f f' Eff' n n' Enn'.
rewrite !strong_rec_alt; f_equiv'.
Qed.

Section FixPoint.

Variable f : (N.t -> A) -> N.t -> A.
Variable f_wd : Proper ((N.eq==>Aeq)==>N.eq==>Aeq) f.

Lemma strong_rec0_0 : forall a m,
 (strong_rec0 a f 0 m) = a.
Proof.
intros. unfold strong_rec0. rewrite recursion_0; auto.
Qed.

Lemma strong_rec0_succ : forall a n m,
 Aeq (strong_rec0 a f (S n) m) (f (strong_rec0 a f n) m).
Proof.
intros. unfold strong_rec0.
f_equiv.
rewrite recursion_succ; f_equiv'.
Qed.

Lemma strong_rec_0 : forall a,
 Aeq (strong_rec a f 0) (f (fun _ => a) 0).
Proof.
intros. rewrite strong_rec_alt, strong_rec0_succ; f_equiv'.
rewrite strong_rec0_0. reflexivity.
Qed.

(* We need an assumption saying that for every n, the step function (f h n)
calls h only on the segment [0 ... n - 1]. This means that if h1 and h2
coincide on values < n, then (f h1 n) coincides with (f h2 n) *)

Hypothesis step_good :
  forall (n : N.t) (h1 h2 : N.t -> A),
    (forall m : N.t, m < n -> Aeq (h1 m) (h2 m)) -> Aeq (f h1 n) (f h2 n).

Lemma strong_rec0_more_steps : forall a k n m, m < n ->
 Aeq (strong_rec0 a f n m) (strong_rec0 a f (n+k) m).
Proof.
 intros a k n. pattern n.
 apply induction; clear n.

 intros n n' Hn; setoid_rewrite Hn; auto with *.

 intros m Hm. destruct (nlt_0_r _ Hm).

 intros n IH m Hm.
 rewrite lt_succ_r in Hm.
 rewrite add_succ_l.
 rewrite 2 strong_rec0_succ.
 apply step_good.
 intros m' Hm'.
 apply IH.
 apply lt_le_trans with m; auto.
Qed.

Lemma strong_rec0_fixpoint : forall (a : A) (n : N.t),
 Aeq (strong_rec0 a f (S n) n) (f (fun n => strong_rec0 a f (S n) n) n).
Proof.
intros.
rewrite strong_rec0_succ.
apply step_good.
intros m Hm.
symmetry.
setoid_replace n with (S m + (n - S m)).
apply strong_rec0_more_steps.
apply lt_succ_diag_r.
rewrite add_comm.
symmetry.
apply sub_add.
rewrite le_succ_l; auto.
Qed.

Theorem strong_rec_fixpoint : forall (a : A) (n : N.t),
 Aeq (strong_rec a f n) (f (strong_rec a f) n).
Proof.
intros.
transitivity (f (fun n => strong_rec0 a f (S n) n) n).
rewrite strong_rec_alt.
apply strong_rec0_fixpoint.
f_equiv.
intros x x' Hx; rewrite strong_rec_alt, Hx; auto with *.
Qed.

(** NB: without the [step_good] hypothesis, we have proved that
    [strong_rec a f 0] is [f (fun _ => a) 0]. Now we can prove
    that the first argument of [f] is arbitrary in this case...
*)

Theorem strong_rec_0_any : forall (a : A)(any : N.t->A),
 Aeq (strong_rec a f 0) (f any 0).
Proof.
intros.
rewrite strong_rec_fixpoint.
apply step_good.
intros m Hm. destruct (nlt_0_r _ Hm).
Qed.

(** ... and that first argument of [strong_rec] is always arbitrary. *)

Lemma strong_rec_any_fst_arg : forall a a' n,
 Aeq (strong_rec a f n) (strong_rec a' f n).
Proof.
intros a a' n.
generalize (le_refl n).
set (k:=n) at -2. clearbody k. revert k. pattern n.
apply induction; clear n.
(* compat *)
intros n n' Hn. setoid_rewrite Hn; auto with *.
(* 0 *)
intros k Hk. rewrite le_0_r in Hk.
rewrite Hk, strong_rec_0. symmetry. apply strong_rec_0_any.
(* S *)
intros n IH k Hk.
rewrite 2 strong_rec_fixpoint.
apply step_good.
intros m Hm.
apply IH.
rewrite succ_le_mono.
apply le_trans with k; auto.
rewrite le_succ_l; auto.
Qed.

End FixPoint.
End StrongRecursion.

Arguments strong_rec [A] a f n.

End NStrongRecProp.


(*
Lattice development from Daniel W.H. James and Ralf Hinze
http://www.cs.ox.ac.uk/people/daniel.james/lattice.html

Updated to accomodate non-extensional equalities
*)

Require Export Containers.OrderedType Setoid Coq.Classes.Morphisms Computable.
Require Export Util Get MoreList PartialOrder.
Require Import EqDec DecSolve List AllInRel OptionPO.

Class JoinSemiLattice (A : Type) `{PartialOrder A} :=
  {
      join : A -> A -> A;

      join_bound : forall a b, poLe a b -> poLe (join a b) b;
      join_commutative : forall a b, poEq (join a b) (join b a);
      join_associative : forall a b c, poEq (join (join a b) c) (join a (join b c));
      join_poLe : forall a b, poLe a (join a b);

      join_respects_eq :> Proper (poEq ==> poEq ==> poEq) join;
      join_respects_le :> Proper (poLe ==> poLe ==> poLe) join
  }.

Arguments join : simpl never.

Lemma join_wellbehaved
  : forall A `{JoinSemiLattice A} x y, poEq x (join x y) <-> poLe y x.
  split.
  - intros. rewrite H1. rewrite join_commutative. eapply join_poLe.
  - intros. eapply poLe_antisymmetric. eapply join_poLe.
    rewrite join_commutative.
    rewrite join_bound; eauto.
Qed.

Lemma join_poLe_right X `{JoinSemiLattice X} x y
  : poLe y (join x y).
Proof.
  rewrite join_commutative. eapply join_poLe.
Qed.

Hint Immediate join_poLe_right.

Lemma join_idempotent
  :  forall A `{JoinSemiLattice A} x, poEq (join x x) x.
Proof.
  intros. symmetry. rewrite join_wellbehaved. reflexivity.
Qed.

Lemma join_idempotent'
  :  forall A `{JoinSemiLattice A} x y, poLe x y -> poEq (join x y) y.
Proof.
  intros. symmetry. rewrite join_commutative.
  eapply join_wellbehaved. eauto.
Qed.

Class LowerBounded (A : Type) `{PartialOrder A} :=
  {
    bottom : A;
    bottom_least : forall a, poLe bottom a;
  }.

Infix "⊔" := join (at level 70, no associativity).
Notation "⊥" := bottom (at level 70, no associativity).

Arguments bottom : simpl never.

Instance pair_semilattice A B `{JoinSemiLattice A} `{JoinSemiLattice B}
  : JoinSemiLattice (A * B) := {
  join x y := (join (fst x) (fst y), join (snd x) (snd y))
}.
Proof.
  - intros [a1 b2] [b1 b3]; split; simpl; clear_trivial_eqs;
      eapply join_bound; eauto.
  - intros [a1 a2] [b1 b2]; split; simpl; eapply join_commutative.
  - intros [a1 a2] [b1 b2] [c1 c2]; split; simpl; eapply join_associative.
  - intros [a1 a2] [b1 b2]; split; simpl; eapply join_poLe.
  - intros [a1 a2] [b1 b2] [EQa EQb] [c1 c2] [d1 d2] [EQc EQd]; simpl in *;
      split; eapply join_respects_eq; eauto.
  - intros [a1 a2] [b1 b2] [LEa LEb] [c1 c2] [d1 d2] [LEc LEd]; simpl in *;
      split; eapply join_respects_le; eauto.
Defined.

Instance pair_boundedsemilattice A B `{LowerBounded A} `{LowerBounded B}
  : LowerBounded (A * B) := {
  bottom := (bottom, bottom);
}.
Proof.
  - intros [a b]; split; simpl; eapply bottom_least.
Defined.

Instance bool_joinsemilattice
  : JoinSemiLattice bool := {
  join := orb
}.
Proof.
  - intros []; simpl; eauto.
  - intros [] []; simpl; eauto.
  - intros [] [] []; simpl; eauto.
  - intros [] []; simpl; eauto.
  - intros [] [] LE [] [] LE'; simpl in *; eauto.
Defined.

Instance bool_lowerbounded : LowerBounded bool :=
  {
    bottom := false
  }.
Proof.
  intros; econstructor.
Defined.

Definition ojoin A join (x y:option A) :=
  match x, y with
  | x, None => x
  | None, y => y
  | Some x, Some y => Some (join x y)
  end.

Instance ojoin_poEq A `{JoinSemiLattice A}
  : Proper (poEq ==> poEq ==> poEq) (ojoin A join).
Proof.
  unfold Proper, respectful.
  intros ? ? EQ ? ? EQ'; inversion EQ; inversion EQ'; subst; simpl; eauto.
  econstructor. rewrite H1, H4. reflexivity.
Qed.

Instance ojoin_poLe A `{JoinSemiLattice A}
  : Proper (poLe ==> poLe ==> poLe) (ojoin A join).
Proof.
  unfold Proper, respectful.
  intros ? [y|] EQ ? [y'|] EQ'; inversion EQ; inversion EQ'; subst; simpl;
    eauto.
  - econstructor. rewrite H5. rewrite join_commutative. eapply join_poLe.
  - econstructor. rewrite H3. eapply join_poLe.
  - econstructor. rewrite H3. rewrite H6. reflexivity.
Qed.

Instance option_boundedsemilattice A `{JoinSemiLattice A}
  : @JoinSemiLattice (option A) (PartialOrder_option_fstNoneOrR _) := {
  join := ojoin _ join
}.
Proof.
  - intros [a|] [b|]; simpl; intros; clear_trivial_eqs;
      econstructor; eauto using join_bound.
  - intros [a|] [b|]; simpl; econstructor; eauto using join_commutative.
  - intros [a1|] [b1|] [c1|]; simpl; econstructor; eauto using join_associative.
  - intros [a|] [b|]; simpl; econstructor; eauto using join_poLe.
Defined.

Lemma join_struct T `{JoinSemiLattice T} (a b a' b':T)
  : a ⊑ a'
    -> b ⊑ b'
    -> a ⊔ b ⊑ (a' ⊔ b').
Proof.
  intros A B. rewrite A, B. reflexivity.
Qed.

Lemma join_struct_eq T `{JoinSemiLattice T} (a b a' b':T)
  : a ≣ a'
    -> b ≣ b'
    -> a ⊔ b ≣ (a' ⊔ b').
Proof.
  intros A B. rewrite A, B. reflexivity.
Qed.

Lemma fold_left_join_struct T `{JoinSemiLattice T} (A A':list T) (b b':T)
  : PIR2 poLe A A'
    -> b ⊑ b'
    -> fold_left join A b ⊑ fold_left join A' b'.
Proof.
  intros pir. revert b b'.
  induction pir; simpl; eauto.
  intros. eapply IHpir.
  eapply join_struct; eauto.
Qed.

Lemma PIR2_bottom_least A B `{LowerBounded A} (ZL:list B) (l:list A)
  : ❬ZL❭ = ❬l❭
    -> PIR2 poLe (tab (⊥) ‖ZL‖) l.
Proof.
  intros. eapply PIR2_get; intros; inv_get; eauto with len.
  eapply bottom_least.
Qed.

Lemma fold_left_join_start_swap X `{JoinSemiLattice X} (a b:X) A
  : poEq (fold_left join A (join a b)) (join b (fold_left join A a)).
Proof.
  general induction A; simpl.
  - simpl. rewrite join_commutative. reflexivity.
  - rewrite !IHA.
    rewrite <- !join_associative.
    setoid_rewrite join_commutative at 2.
    reflexivity.
Qed.

Lemma proj1_sig_poEq X `{PartialOrder X} P (a b:{ x : X | P x })
  : poEq a b -> poEq (proj1_sig a) (proj1_sig b).
Proof.
  destruct a,b; eauto.
Qed.

Lemma join_false_left x
  : false ⊔ x = x.
Proof.
  destruct x; reflexivity.
Qed.

Lemma join_false_right x
  : x ⊔ false = x.
Proof.
  destruct x; reflexivity.
Qed.

Ltac clear_join_false :=
  match goal with
  | [ H : context [false ⊔ _] |- _ ] => rewrite join_false_left in H
  | [ H : context [_ ⊔ false] |- _ ] => rewrite join_false_right in H
  end.

Smpl Add clear_join_false : inv_trivial.

Lemma join_poLe_left (X : Type) (H : PartialOrder X) (H0 : JoinSemiLattice X)
      (x y z : X)
  : x ⊑ z -> y ⊑ z -> x ⊔ y ⊑ z.
Proof.
  intros.
  rewrite H1, H2.
  rewrite (join_idempotent _ z).
  reflexivity.
Qed.


(** ** Sub(pre)categories

Authors: Benedikt Ahrens, Chris Kapulkin, Mike Shulman (January 2013)
Reorganized and expanded: Langston Barrett (@siddharthist) (March 2018)

*)

(** ** Contents :

- Subprecategories
  - A sub-precategory forms a precategory ([carrier_of_sub_precategory])
  - (Inclusion) functor from a sub-precategory to the ambient precategory
    ([sub_precategory_inclusion])
- Subcategories ([subcategory])
- Restriction of a functor to a subcategory
*)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.

Local Open Scope cat.

(** ** Definitions *)

(** A sub-precategory is specified through a predicate on objects
    and a dependent predicate on morphisms
    which is compatible with identity and composition
*)

Definition is_sub_precategory {C : category}
    (C' : hsubtype C)
    (Cmor' : ∏ a b : C, hsubtype (a --> b)) :=
  (∏ a : C, C' a ->  Cmor' _ _ (identity a)) ×
  (∏ (a b c : C) (f: a --> b) (g : b --> c),
            Cmor' _ _ f -> Cmor' _ _  g -> Cmor' _ _  (f · g)).

Definition sub_precategories (C : category) :=
  total2 (fun C' : (hsubtype (ob C)) × (∏ a b:ob C, hsubtype (a --> b)) =>
           is_sub_precategory (pr1 C') (pr2 C')).

(** We have a coercion [carrier] turning every predicate [P] on a type [A] into the
     total space [ { a : A & P a} ].

   For later, we define some projections with the appropriate type, also to
   avoid confusion with the aforementioned coercion.
*)

Definition sub_precategory_predicate_objects {C : category}
     (C': sub_precategories C):
       hsubtype (ob C) := pr1 (pr1 C').

Definition sub_ob {C : category}(C': sub_precategories C): UU :=
     (*carrier*) (sub_precategory_predicate_objects C').

Definition sub_precategory_predicate_morphisms {C : category}
        (C':sub_precategories C) (a b : C) : hsubtype (a --> b) := pr2 (pr1 C') a b.

Definition sub_precategory_morphisms {C : category}(C':sub_precategories C)
      (a b : C) : UU :=  sub_precategory_predicate_morphisms C' a b.

(** Projections for compatibility of the predicate with identity and
    composition.
*)

Definition sub_precategory_id (C : category) (C':sub_precategories C) :
   ∏ a : ob C,
       sub_precategory_predicate_objects C' a ->
       sub_precategory_predicate_morphisms  C' _ _ (identity a) :=
         dirprod_pr1 (pr2 C').

Definition sub_precategory_comp (C : category) (C':sub_precategories C) :
   ∏ (a b c: ob C) (f: a --> b) (g : b --> c),
          sub_precategory_predicate_morphisms C' _ _ f ->
          sub_precategory_predicate_morphisms C' _ _ g ->
          sub_precategory_predicate_morphisms C' _ _  (f · g) :=
        dirprod_pr2 (pr2 C').

(** An object of a subprecategory is an object of the original precategory. *)

Definition precategory_object_from_sub_precategory_object (C:category)
         (C':sub_precategories C) (a : sub_ob C') :
    ob C := pr1 a.
Coercion precategory_object_from_sub_precategory_object :
     sub_ob >-> ob.

(** A morphism of a subprecategory is also a morphism of the original precategory. *)

Definition precategory_morphism_from_sub_precategory_morphism (C:category)
          (C':sub_precategories C) (a b : ob C)
           (f : sub_precategory_morphisms C' a b) : a --> b := pr1 f .
Coercion precategory_morphism_from_sub_precategory_morphism :
         sub_precategory_morphisms >-> precategory_morphisms.

(** *** A sub-precategory forms a precategory. *)

Definition sub_precategory_ob_mor (C : category)(C':sub_precategories C) :
     precategory_ob_mor.
Proof.
  exists (sub_ob C').
  exact (λ a b, @sub_precategory_morphisms _ C' a b).
Defined.

(*
Coercion sub_precategory_ob_mor : sub_precategories >-> precategory_ob_mor.
*)

Definition sub_precategory_data (C : category)(C':sub_precategories C) :
      precategory_data.
Proof.
  exists (sub_precategory_ob_mor C C').
  split.
    intro c.
    exists (identity (C:=C) (pr1 c)).
    apply sub_precategory_id.
    apply (pr2 c).
  intros a b c f g.
  exists (compose (pr1 f) (pr1 g)).
  apply sub_precategory_comp.
  apply (pr2 f). apply (pr2 g).
Defined.

(** A useful lemma for equality in the sub-precategory. *)

Lemma eq_in_sub_precategory (C : category)(C':sub_precategories C)
      (a b : sub_ob C') (f g : sub_precategory_morphisms C' a b) :
          pr1 f = pr1 g -> f = g.
Proof.
  intro H.
  apply (total2_paths_f H).
  apply proofirrelevance.
  apply pr2.
Qed.

(*
Lemma eq_in_sub_precategory2 (C : precategory)(C':sub_precategories C)
     (a b : sub_ob C') (f g : a --> b)
 (pf : sub_precategory_predicate_morphisms C' _ _ f)
 (pg : sub_precategory_predicate_morphisms C' _ _ g):
  f = g -> (tpair (λ f, sub_precategory_predicate_morphisms _ _ _ f) f pf) =
      (tpair (λ f, sub_precategory_predicate_morphisms _ _ _ f) g pg).
Proof.
  intro H.
  apply (two_arg_paths_f H).
  destruct H.
  apply (two_arg_paths_f (idpath _ )).
*)

Definition is_precategory_sub_precategory (C : category)(C':sub_precategories C) :
    is_precategory (sub_precategory_data C C').
Proof.
  repeat split;
  simpl; intros.
  unfold sub_precategory_comp;
  apply eq_in_sub_precategory; simpl;
  apply id_left.
  apply eq_in_sub_precategory. simpl.
  apply id_right.
  apply eq_in_sub_precategory.
  cbn.
  apply assoc.
  apply eq_in_sub_precategory.
  cbn.
  apply assoc'.
Defined.

Definition carrier_of_sub_precategory (C : category)(C':sub_precategories C) :
   precategory := tpair _ _ (is_precategory_sub_precategory C C').

Definition has_homsets_carrier_of_subcategory (C : category) (C' : sub_precategories C)
  : has_homsets (carrier_of_sub_precategory C C').
Proof.
  intros a b.
  cbn.
  apply (isofhleveltotal2 2).
  - apply C.
  - intro f.
    apply hlevelntosn.
    apply propproperty.
Qed.

Definition carrier_of_sub_category (C : category) (C' : sub_precategories C)
  : category
  := make_category _ (has_homsets_carrier_of_subcategory C C').

Coercion carrier_of_sub_category : sub_precategories >-> category.

(** An object satisfying the predicate is an object of the subprecategory *)
Definition precategory_object_in_subcat {C : category} {C':sub_precategories C}
   (a : ob C) (p : sub_precategory_predicate_objects C' a) :
       ob C' := tpair _ a p.

(** A morphism satisfying the predicate is a morphism of the subprecategory *)
Definition precategory_morphisms_in_subcat {C : category} {C':sub_precategories C}
   {a b : ob C'}(f : pr1 a --> pr1 b)
   (p : sub_precategory_predicate_morphisms C' (pr1 a) (pr1 b) (f)) :
       precategory_morphisms (C:=C') a b := tpair _ f p.

(** A (z-)isomorphism of a subprecategory is also a (z-)isomorphism of the original precategory. *)
Lemma is_z_iso_from_is_z_iso_in_subcategory (C:category) (C':sub_precategories C)
  (a b : C') (f : C'⟦ a , b ⟧)
  (H: is_z_isomorphism f)
  : is_z_isomorphism
    (precategory_morphism_from_sub_precategory_morphism _ _ _ _ f).
Proof.
  induction H as (g,(gl,gr)).
  induction g as (g_und,?).
  use make_is_z_isomorphism.
  + exact g_und.
  + split.
    - exact (maponpaths pr1 gl).
    - exact (maponpaths pr1 gr).
Defined.

(** *** (Inclusion) functor from a sub-precategory to the ambient precategory *)

Definition sub_precategory_inclusion_data (C : category) (C':sub_precategories C):
  functor_data C' C.
Proof.
  exists (@pr1 _ _ ).
  intros a b.
  exact (@pr1 _ _ ).
Defined.

Definition is_functor_sub_precategory_inclusion (C : category)
         (C':sub_precategories C) :
    is_functor  (sub_precategory_inclusion_data C C').
Proof.
  split; simpl.
  unfold functor_idax . intros.  apply (idpath _ ).
  unfold functor_compax . intros.  apply (idpath _ ).
Qed.

Definition sub_precategory_inclusion (C : category) (C' : sub_precategories C) :
    functor C' C := tpair _ _ (is_functor_sub_precategory_inclusion C C').

(** ** Subcategories *)

(** The hom-types of a subprecategory are sets if the hom-types of the original
    category are. *)

Lemma is_set_sub_precategory_morphisms {C : category}
                                       (C' : sub_precategories C) (a b : ob C) :
  isaset (sub_precategory_morphisms C' a b).
Proof.
  apply isofhlevel_hsubtype, C.
Defined.

Definition sub_precategory_morphisms_set {C : category}
  (C':sub_precategories C) (a b : ob C) : hSet :=
    tpair _ (sub_precategory_morphisms C' a b)
        (is_set_sub_precategory_morphisms C' a b).

Definition subcategory (C : category) (C' : sub_precategories C) : category.
Proof.
  use make_category.
  - exact (carrier_of_sub_precategory C C').
  - intros ? ?.
    apply is_set_sub_precategory_morphisms.
Defined.

(** ** Restriction of a functor to a subcategory *)

Definition restrict_functor_to_sub_precategory {C D : category}
           (C' : sub_precategories C) (F : functor C D) : functor C' D.
Proof.
  use make_functor.
  - use make_functor_data.
    + exact (F ∘ precategory_object_from_sub_precategory_object _ C')%functions.
    + intros ? ?.
      apply (# F ∘ precategory_morphism_from_sub_precategory_morphism _ C' _ _)%functions.
  - use make_dirprod.
    + intro; apply (functor_id F).
    + intros ? ? ? ? ?; apply (functor_comp F).
Defined.


Require Import Coq.Arith.PeanoNat.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Setoids.Setoid.
Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeMath.
Require Import DschingisKhan.Prelude.PreludeUtil.
Require Import DschingisKhan.Math.BasicPosetTheory.
Require Import DschingisKhan.Math.BooleanAlgebra.

Module SyntaxOfPL.

  Definition propLetter : Set := nat.

  Inductive formula : Set :=
  | AtomF (i : propLetter) : formula
  | ContradictionF : formula
  | NegationF (p1 : formula) : formula
  | ConjunctionF (p1 : formula) (p2 : formula) : formula
  | DisjunctionF (p1 : formula) (p2 : formula) : formula
  | ImplicationF (p1 : formula) (p2 : formula) : formula
  | BiconditionalF (p1 : formula) (p2 : formula) : formula
  .

  Global Instance formulaEqDec
    : EqDec formula.
  Proof with try ((left; congruence) || (right; congruence)).
    change (forall lhs : formula, forall rhs : formula, {lhs = rhs} + {lhs <> rhs}).
    induction lhs as [i | | p1 IH1 | p1 IH1 p2 IH2 | p1 IH1 p2 IH2 | p1 IH1 p2 IH2 | p1 IH1 p2 IH2], rhs as [i' | | p1' | p1' p2' | p1' p2' | p1' p2' | p1' p2']...
    { pose proof (eq_dec i i') as [i_eq_i' | i_ne_i']... }
    { pose proof (IH1 p1') as [p1_eq_p1' | p1_ne_p1']... }
    { pose proof (IH1 p1') as [p1_eq_p1' | p1_ne_p1']; pose proof (IH2 p2') as [p2_eq_p2' | p2_ne_p2']... }
    { pose proof (IH1 p1') as [p1_eq_p1' | p1_ne_p1']; pose proof (IH2 p2') as [p2_eq_p2' | p2_ne_p2']... }
    { pose proof (IH1 p1') as [p1_eq_p1' | p1_ne_p1']; pose proof (IH2 p2') as [p2_eq_p2' | p2_ne_p2']... }
    { pose proof (IH1 p1') as [p1_eq_p1' | p1_ne_p1']; pose proof (IH2 p2') as [p2_eq_p2' | p2_ne_p2']... }
  Defined.

  Section ENUMERATE_FORMULA.

  Fixpoint getRankOfFormula (p : formula) {struct p} : nat :=
    match p with
    | AtomF i => 0
    | ContradictionF => 1
    | NegationF p1 => S (getRankOfFormula p1)
    | ConjunctionF p1 p2 => S (max (getRankOfFormula p1) (getRankOfFormula p2))
    | DisjunctionF p1 p2 => S (max (getRankOfFormula p1) (getRankOfFormula p2))
    | ImplicationF p1 p2 => S (max (getRankOfFormula p1) (getRankOfFormula p2))
    | BiconditionalF p1 p2 => S (max (getRankOfFormula p1) (getRankOfFormula p2))
    end
  .

  Local Notation plus6 i := (S (S (S (S (S (S i)))))).

  Fixpoint enumFormula' (rank : nat) (seed0 : nat) {struct rank} : formula :=
    match rank with
    | zero => AtomF seed0
    | suc rank' =>
      let seed1 : nat := fst (cantor_pairing seed0) in
      let piece : nat := snd (cantor_pairing seed0) in
      let seed2 : nat := fst (cantor_pairing seed1) in
      let seed3 : nat := snd (cantor_pairing seed1) in
      match piece with
      | 0 => ContradictionF
      | 1 => NegationF (enumFormula' rank' seed1)
      | 2 => ConjunctionF (enumFormula' rank' seed2) (enumFormula' rank' seed3)
      | 3 => DisjunctionF (enumFormula' rank' seed2) (enumFormula' rank' seed3)
      | 4 => ImplicationF (enumFormula' rank' seed2) (enumFormula' rank' seed3)
      | 5 => BiconditionalF (enumFormula' rank' seed2) (enumFormula' rank' seed3)
      | plus6 i => AtomF i
      end
    end
  .

  Local Tactic Notation "tac_aux1" :=
    match goal with
    | [ H : cantor_pairing ?seed = ?rhs |- _ ] => rewrite H; simpl
    end
  .

  Local Tactic Notation "tac_aux2" :=
    match goal with
    | [ H : enumFormula' ?rank ?seed = ?p |- _ ] => rewrite <- H
    end
  .

  Local Tactic Notation "tac" := (unfold enumFormula'); (repeat tac_aux1); (repeat tac_aux2); (eauto).

  Lemma specOf_enumFormula' (p : formula) (rank : nat)
    (RANK_LE : getRankOfFormula p <= rank)
    : {seed0 : nat | enumFormula' rank seed0 = p}.
  Proof with tac.
    revert p rank RANK_LE.
    pose proof (claim1 := fun x : nat => fun y : nat => fun z : nat => proj2 (cantor_pairing_spec x y z)).
    induction p as [i | | p1 IH1 | p1 IH1 p2 IH2 | p1 IH1 p2 IH2 | p1 IH1 p2 IH2 | p1 IH1 p2 IH2]; simpl.
    { intros [ | r'] H.
      - exists (i)...
      - assert (H0 : cantor_pairing (sum_from_0_to (0 + plus6 i) + plus6 i) = (0, plus6 i)) by now apply claim1.
        exists (sum_from_0_to (0 + plus6 i) + plus6 i)...
    }
    all: intros r H; set (rank := pred r); (assert (H0 : S rank = r) by now apply (suc_pred_n_eq_n_if_m_lt_n H)); rewrite <- H0.
    { set (piece := 0).
      exists (piece)...
    }
    { set (piece := 1).
      assert (H1 : getRankOfFormula p1 <= rank) by now apply n_le_pred_m_if_n_lt_m.
      pose proof (IH1 rank H1) as [seed2 H2].
      assert (H3 : cantor_pairing (sum_from_0_to (seed2 + piece) + piece) = (seed2, piece)) by now apply claim1.
      exists (sum_from_0_to (seed2 + piece) + piece)...
    }
    { set (piece := 2).
      assert (H1 : max (getRankOfFormula p1) (getRankOfFormula p2) <= rank) by now apply n_le_pred_m_if_n_lt_m.
      assert (H2 : getRankOfFormula p1 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      assert (H3 : getRankOfFormula p2 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      pose proof (IH1 rank H2) as [seed2 H4].
      pose proof (IH2 rank H3) as [seed3 H5].
      assert (H6 : cantor_pairing (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece) = (sum_from_0_to (seed2 + seed3) + seed3, piece)) by now apply claim1.
      assert (H7 : cantor_pairing (sum_from_0_to (seed2 + seed3) + seed3) = (seed2, seed3)) by now apply claim1.
      exists (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece)...
    }
    { set (piece := 3).
      assert (H1 : max (getRankOfFormula p1) (getRankOfFormula p2) <= rank) by now apply n_le_pred_m_if_n_lt_m.
      assert (H2 : getRankOfFormula p1 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      assert (H3 : getRankOfFormula p2 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      pose proof (IH1 rank H2) as [seed2 H4].
      pose proof (IH2 rank H3) as [seed3 H5].
      assert (H6 : cantor_pairing (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece) = (sum_from_0_to (seed2 + seed3) + seed3, piece)) by now apply claim1.
      assert (H7 : cantor_pairing (sum_from_0_to (seed2 + seed3) + seed3) = (seed2, seed3)) by now apply claim1.
      exists (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece)...
    }
    { set (piece := 4).
      assert (H1 : max (getRankOfFormula p1) (getRankOfFormula p2) <= rank) by now apply n_le_pred_m_if_n_lt_m.
      assert (H2 : getRankOfFormula p1 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      assert (H3 : getRankOfFormula p2 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      pose proof (IH1 rank H2) as [seed2 H4].
      pose proof (IH2 rank H3) as [seed3 H5].
      assert (H6 : cantor_pairing (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece) = (sum_from_0_to (seed2 + seed3) + seed3, piece)) by now apply claim1.
      assert (H7 : cantor_pairing (sum_from_0_to (seed2 + seed3) + seed3) = (seed2, seed3)) by now apply claim1.
      exists (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece)...
    }
    { set (piece := 5).
      assert (H1 : max (getRankOfFormula p1) (getRankOfFormula p2) <= rank) by now apply n_le_pred_m_if_n_lt_m.
      assert (H2 : getRankOfFormula p1 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      assert (H3 : getRankOfFormula p2 <= rank) by now apply (le_elim_max_n1_n2_le_m (getRankOfFormula p1) (getRankOfFormula p2)).
      pose proof (IH1 rank H2) as [seed2 H4].
      pose proof (IH2 rank H3) as [seed3 H5].
      assert (H6 : cantor_pairing (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece) = (sum_from_0_to (seed2 + seed3) + seed3, piece)) by now apply claim1.
      assert (H7 : cantor_pairing (sum_from_0_to (seed2 + seed3) + seed3) = (seed2, seed3)) by now apply claim1.
      exists (sum_from_0_to ((sum_from_0_to (seed2 + seed3) + seed3) + piece) + piece)...
    }
  Qed.

  Definition enumFormula (seed : nat) : formula :=
    let rank : nat := fst (cantor_pairing seed) in
    let seed0 : nat := snd (cantor_pairing seed) in
    enumFormula' rank seed0
  .

  Theorem formula_is_enumerable (p : formula)
    : {seed : nat | enumFormula seed = p}.
  Proof.
    pose proof (specOf_enumFormula' p (getRankOfFormula p) le_reflexivity) as [seed0 H_EQ].
    exists (cantor_pairing_inv (getRankOfFormula p) seed0). unfold cantor_pairing_inv, enumFormula.
    now repeat rewrite <- cantor_pairing_is_surjective.
  Qed.

  Corollary enumFormula_isSurjective
    : isSurjective enumFormula.
  Proof. intros p. pose proof (formula_is_enumerable p) as [seed H_EQ]. now exists (seed). Qed.

  Global Instance formula_isCountable : isCountable formula :=
    { enum := enumFormula
    ; enum_isSurjective := enumFormula_isSurjective
    }
  .

  Corollary enumFormula_isSurjection
    : isSurjection enumFormula.
  Proof. intros p. pose proof (formula_is_enumerable p) as [seed H_EQ]. now exists (seed). Qed.

  Global Instance formula_isRecursivelyEnumerable : isRecursivelyEnumerable formula :=
    { RecursivelyEnumerable_requiresCountable := formula_isCountable
    ; enum_isSurjection := enumFormula_isSurjection
    }
  .

  End ENUMERATE_FORMULA.

End SyntaxOfPL.

Module FormulaNotationsOfPL.

  Import SyntaxOfPL.

  Global Declare Scope pl_formula_scope.
  Global Bind Scope pl_formula_scope with formula.
  Global Declare Custom Entry pl_formula_viewer.
  Global Open Scope pl_formula_scope.

  Global Notation " 'p_{' i  '}' " := (AtomF i) (in custom pl_formula_viewer at level 0).
  Global Notation " '_|_' " := (ContradictionF) (in custom pl_formula_viewer at level 0, no associativity).
  Global Notation " '~' p1 " := (NegationF p1) (in custom pl_formula_viewer at level 1, right associativity).
  Global Notation " p1 '/\' p2 " := (ConjunctionF p1 p2) (in custom pl_formula_viewer at level 1, right associativity).
  Global Notation " p1 '\/' p2 " := (DisjunctionF p1 p2) (in custom pl_formula_viewer at level 2, right associativity).
  Global Notation " p1 '->' p2 " := (ImplicationF p1 p2) (in custom pl_formula_viewer at level 2, right associativity).
  Global Notation " p1 '<->' p2 " := (BiconditionalF p1 p2) (in custom pl_formula_viewer at level 2, no associativity).
  Global Notation " p " := p (in custom pl_formula_viewer at level 0, p ident).
  Global Notation " '(' p ')' " := p (in custom pl_formula_viewer, p at level 3).
  Global Notation " '\pl[' p  ']' " := p (p custom pl_formula_viewer at level 3, at level 0, no associativity) : pl_formula_scope.

End FormulaNotationsOfPL.

Module SemanticsOfPL.

  Import SyntaxOfPL FormulaNotationsOfPL.

  Definition truthValue : Type := Prop.

  Global Delimit Scope type_scope with truthValue.

  Definition truthValueAssignment : Type := propLetter -> truthValue.

  Fixpoint evalFormula (env : truthValueAssignment) (p : formula) {struct p} : truthValue :=
    match p with
    | \pl[ p_{ i } ] => env i
    | \pl[ _|_ ] => False
    | \pl[ ~ p1 ] => ~ evalFormula env p1
    | \pl[ p1 /\ p2 ] => evalFormula env p1 /\ evalFormula env p2
    | \pl[ p1 \/ p2 ] => evalFormula env p1 \/ evalFormula env p2
    | \pl[ p1 -> p2 ] => evalFormula env p1 -> evalFormula env p2
    | \pl[ p1 <-> p2 ] => evalFormula env p1 <-> evalFormula env p2
    end
  .

  Global Reserved Infix " `satisfies` " (at level 70, no associativity).

  Variant satisfies (env : truthValueAssignment) (A : formula) : Prop :=
  | IsModel
    (EVAL_TO_TRUE : evalFormula env A)
    : env `satisfies` A
  where " env `satisfies` A " := (satisfies env A) : type_scope.

  Definition entails (Gamma : ensemble formula) (A : formula) : Prop :=
    forall env : truthValueAssignment, forall env_satisfies : forall B : formula, forall B_IN : B \in Gamma, env `satisfies` B, env `satisfies` A
  .

  Global Infix " ⊧ " := entails (at level 70, no associativity) : type_scope.

  Global Notation " Gamma ⊭ C " := (~ Gamma ⊧ C) (at level 70, no associativity) : type_scope.

  Lemma extend_entails (Gamma : ensemble formula) (Gamma' : ensemble formula) (C : formula)
    (ENTAILS : Gamma ⊧ C)
    (Gamma_isSubsetOf_Gamma' : isSubsetOf Gamma Gamma')
    : Gamma' ⊧ C.
  Proof. ii. eauto with *. Qed.

  Definition isStructure (Gamma : ensemble formula) : Prop :=
    forall A : formula, A \in Gamma <-> evalFormula (preimage AtomF Gamma) A
  .

  Lemma structure_gives_its_subset_to_model (Gamma : ensemble formula) (Gamma' : ensemble formula)
    (IS_STRUCTURE : isStructure Gamma')
    (SUBSET : isSubsetOf Gamma Gamma')
    : << MODEL : forall B : formula, B \in Gamma -> preimage AtomF Gamma' `satisfies` B >>.
  Proof. ii. econstructor. eapply IS_STRUCTURE. eauto with *. Qed.

End SemanticsOfPL.

Module InferenceRulesOfPL.

  Import SyntaxOfPL FormulaNotationsOfPL.

  Global Reserved Infix " ⊢ " (at level 70, no associativity).

  Inductive infers (Gamma : ensemble formula) : forall C : formula, Prop :=
  | ByAssumption :
    forall C : formula,
    C \in Gamma ->
    Gamma ⊢ C
  | ContradictionI :
    forall A : formula,
    Gamma ⊢ A ->
    Gamma ⊢ NegationF A ->
    Gamma ⊢ ContradictionF
  | ContradictionE :
    forall A : formula,
    Gamma ⊢ ContradictionF ->
    Gamma ⊢ A
  | NegationI :
    forall A : formula,
    insert A Gamma ⊢ ContradictionF ->
    Gamma ⊢ NegationF A
  | NegationE :
    forall A : formula,
    insert (NegationF A) Gamma ⊢ ContradictionF ->
    Gamma ⊢ A
  | ConjunctionI :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ A ->
    Gamma ⊢ B ->
    Gamma ⊢ ConjunctionF A B
  | ConjunctionE1 :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ ConjunctionF A B ->
    Gamma ⊢ A
  | ConjunctionE2 :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ ConjunctionF A B ->
    Gamma ⊢ B
  | DisjunctionI1 :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ A ->
    Gamma ⊢ DisjunctionF A B
  | DisjunctionI2 :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ B ->
    Gamma ⊢ DisjunctionF A B
  | DisjunctionE :
    forall A : formula,
    forall B : formula,
    forall C : formula,
    Gamma ⊢ DisjunctionF A B ->
    insert A Gamma ⊢ C ->
    insert B Gamma ⊢ C ->
    Gamma ⊢ C
  | ImplicationI :
    forall A : formula,
    forall B : formula,
    insert A Gamma ⊢ B ->
    Gamma ⊢ ImplicationF A B
  | ImplicationE :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ ImplicationF A B ->
    Gamma ⊢ A ->
    Gamma ⊢ B
  | BiconditionalI :
    forall A : formula,
    forall B : formula,
    insert A Gamma ⊢ B ->
    insert B Gamma ⊢ A ->
    Gamma ⊢ BiconditionalF A B
  | BiconditionalE1 :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ BiconditionalF A B ->
    Gamma ⊢ A ->
    Gamma ⊢ B
  | BiconditionalE2 :
    forall A : formula,
    forall B : formula,
    Gamma ⊢ BiconditionalF A B ->
    Gamma ⊢ B ->
    Gamma ⊢ A
  where " Gamma ⊢ C " := (infers Gamma C) : type_scope.

  Local Hint Constructors infers : core.

  Global Notation " Gamma ⊬ C " := (~ Gamma ⊢ C) (at level 70, no associativity) : type_scope.

  Lemma Law_of_Excluded_Middle (A : formula)
    : empty ⊢ \pl[ A \/ ~ A ].
  Proof with exact (eq_refl).
    eapply NegationE, ContradictionI.
    - eapply DisjunctionI2, NegationI, ContradictionI.
      + eapply DisjunctionI1, ByAssumption. left...
      + eapply ByAssumption. right; left...
    - eapply ByAssumption. left...
  Qed.

  Lemma Cut_property (Gamma : ensemble formula) (A : formula) (B : formula)
    (INFERS : Gamma ⊢ A)
    (CUT : insert A Gamma ⊢ B)
    : Gamma ⊢ B.
  Proof. assert (claim1 : Gamma ⊢ \pl[ A -> B ]); eauto with *. Qed.

  Lemma extend_infers (Gamma : ensemble formula) (Gamma' : ensemble formula) (C : formula)
    (INFERS : Gamma ⊢ C)
    (Gamma_isSubsetOf_Gamma' : isSubsetOf Gamma Gamma')
    : Gamma' ⊢ C.
  Proof with eauto with *.
    revert Gamma' Gamma_isSubsetOf_Gamma'.
    induction INFERS; ii.
    - eapply ByAssumption...
    - eapply ContradictionI...
    - eapply ContradictionE...
    - eapply NegationI...
    - eapply NegationE...
    - eapply ConjunctionI...
    - eapply ConjunctionE1...
    - eapply ConjunctionE2...
    - eapply DisjunctionI1...
    - eapply DisjunctionI2...
    - eapply DisjunctionE...
    - eapply ImplicationI...
    - eapply ImplicationE...
    - eapply BiconditionalI...
    - eapply BiconditionalE1...
    - eapply BiconditionalE2...
  Qed.

End InferenceRulesOfPL.

Module LindenbaumBooleanAlgebraOfPL.

  Import ListNotations BooleanAlgebra CountableBooleanAlgebra SyntaxOfPL InferenceRulesOfPL.

  Global Instance formula_hasBooleanAlgebraMethods : BooleanAlgebra_sig formula :=
    { andBA := ConjunctionF
    ; orBA := DisjunctionF
    ; notBA := NegationF
    ; trueBA := ImplicationF ContradictionF ContradictionF
    ; falseBA := ContradictionF
    }
  .

  Local Obligation Tactic := intros.

  Global Program Instance formula_isSetoid : isSetoid formula :=
    { eqProp (lhs : formula) (rhs : formula) := singleton lhs ⊢ rhs /\ singleton rhs ⊢ lhs }.
  Next Obligation with eauto with *.
    split.
    - ii. split; eapply ByAssumption...
    - ii. des...
    - ii. des.
      all: eapply Cut_property...
      all: eapply extend_infers...
      all: ii; left...
  Qed.

  Local Instance LBA_obeysBooleanAlgebra_axiom
    : BooleanAlgebra_axiom formula (requiresSetoid := formula_isSetoid) (requiresBooleanAlgebraMethods := formula_hasBooleanAlgebraMethods).
  Proof with reflexivity || eauto with *.
    split; iis; simpl in *; des.
    { eapply ConjunctionI.
      - eapply Cut_property with (A := lhs1).
        + eapply ConjunctionE1, ByAssumption...
        + eapply extend_infers... ii; left...
      - eapply Cut_property with (A := lhs2).
        + eapply ConjunctionE2, ByAssumption...
        + eapply extend_infers... ii; left...
    }
    { eapply ConjunctionI.
      - eapply Cut_property with (A := rhs1).
        + eapply ConjunctionE1, ByAssumption...
        + eapply extend_infers... ii; left...
      - eapply Cut_property with (A := rhs2).
        + eapply ConjunctionE2, ByAssumption...
        + eapply extend_infers... ii; left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply DisjunctionI1, extend_infers... ii; left...
      - eapply DisjunctionI2, extend_infers... ii; left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply DisjunctionI1, extend_infers... ii; left...
      - eapply DisjunctionI2, extend_infers... ii; left...
    }
    { eapply NegationI. eapply ContradictionI with (A := lhs1).
      - eapply extend_infers... ii; left...
      - eapply ByAssumption. right...
    }
    { eapply NegationI. eapply ContradictionI with (A := rhs1).
      - eapply extend_infers... ii; left...
      - eapply ByAssumption. right...
    }
    { eapply ConjunctionI.
      - eapply ConjunctionI.
        + eapply ConjunctionE1, ByAssumption...
        + eapply ConjunctionE1, ConjunctionE2, ByAssumption...
      - eapply ConjunctionE2, ConjunctionE2, ByAssumption...
    }
    { eapply ConjunctionI.
      - eapply ConjunctionE1, ConjunctionE1, ByAssumption...
      - eapply ConjunctionI.
        + eapply ConjunctionE2, ConjunctionE1, ByAssumption...
        + eapply ConjunctionE2, ByAssumption...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply DisjunctionI1, DisjunctionI1, ByAssumption. left...
      - eapply DisjunctionE.
        + eapply ByAssumption. left...
        + eapply DisjunctionI1, DisjunctionI2, ByAssumption. left...
        + eapply DisjunctionI2, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply DisjunctionE.
        + eapply ByAssumption. left...
        + eapply DisjunctionI1, ByAssumption. left...
        + eapply DisjunctionI2, DisjunctionI1, ByAssumption. left...
      - eapply DisjunctionI2, DisjunctionI2, ByAssumption. left...
    }
    { eapply ConjunctionI.
      - eapply ConjunctionE2, ByAssumption...
      - eapply ConjunctionE1, ByAssumption...
    }
    { eapply ConjunctionI.
      - eapply ConjunctionE2, ByAssumption...
      - eapply ConjunctionE1, ByAssumption...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply DisjunctionI2, ByAssumption. left...
      - eapply DisjunctionI1, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply DisjunctionI2, ByAssumption. left...
      - eapply DisjunctionI1, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ConjunctionE2, ByAssumption...
      - eapply DisjunctionI1, ConjunctionI.
        + eapply ConjunctionE1, ByAssumption. right...
        + eapply ByAssumption. left...
      - eapply DisjunctionI2, ConjunctionI.
        + eapply ConjunctionE1, ByAssumption. right...
        + eapply ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ConjunctionI.
        + eapply ConjunctionE1, ByAssumption. left...
        + eapply DisjunctionI1, ConjunctionE2, ByAssumption. left...
      - eapply ConjunctionI.
        + eapply ConjunctionE1, ByAssumption. left...
        + eapply DisjunctionI2, ConjunctionE2, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ConjunctionE1, ByAssumption...
      - eapply DisjunctionI1, ConjunctionI.
        + eapply ByAssumption. left...
        + eapply ConjunctionE2, ByAssumption. right...
      - eapply DisjunctionI2, ConjunctionI.
        + eapply ByAssumption. left...
        + eapply ConjunctionE2, ByAssumption. right...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ConjunctionI.
        + eapply DisjunctionI1, ConjunctionE1, ByAssumption. left...
        + eapply ConjunctionE2, ByAssumption. left...
      - eapply ConjunctionI.
        + eapply DisjunctionI2, ConjunctionE1, ByAssumption. left...
        + eapply ConjunctionE2, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ConjunctionI.
        + eapply DisjunctionE.
          * eapply ByAssumption. right...
          * eapply DisjunctionI1, ByAssumption. left...
          * eapply DisjunctionI2, ConjunctionE1, ByAssumption. left...
        + eapply DisjunctionE.
          * eapply ByAssumption. right...
          * eapply DisjunctionI1, ByAssumption. left...
          * eapply DisjunctionI2, ConjunctionE2, ByAssumption. left...
      - eapply ConjunctionI.
        + eapply DisjunctionE.
          * eapply ByAssumption. right...
          * eapply DisjunctionI1, ByAssumption. left...
          * eapply DisjunctionI2, ConjunctionE1, ByAssumption. left...
        + eapply DisjunctionE.
          * eapply ByAssumption. right...
          * eapply DisjunctionI1, ByAssumption. left...
          * eapply DisjunctionI2, ConjunctionE2, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ConjunctionE1, ByAssumption...
      - eapply DisjunctionI1, ByAssumption. left...
      - eapply DisjunctionE.
        + eapply ConjunctionE2, ByAssumption. right...
        + eapply DisjunctionI1, ByAssumption. left...
        + eapply DisjunctionI2, ConjunctionI.
          * eapply ByAssumption. right; left...
          * eapply ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ConjunctionI.
        + eapply DisjunctionI1, ConjunctionE1, ByAssumption. left...
        + eapply DisjunctionI1, ConjunctionE2, ByAssumption. left...
      -  eapply ConjunctionI.
        + eapply DisjunctionI2, ByAssumption. left...
        + eapply DisjunctionI2, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ConjunctionE1, ByAssumption...
      - eapply DisjunctionE.
        + eapply ConjunctionE2, ByAssumption. right...
        + eapply DisjunctionI1, ConjunctionI.
          * eapply ByAssumption. right; left...
          * eapply ByAssumption. left...
        + eapply DisjunctionI2, ByAssumption. left...
      - eapply DisjunctionI2, ByAssumption. left...
    }
    { eapply ConjunctionE2, ByAssumption... }
    { eapply ConjunctionI.
      - eapply ImplicationI, ByAssumption. left...
      - eapply ByAssumption...
    }
    { eapply ConjunctionE1, ByAssumption... }
    { eapply ConjunctionI.
      - eapply ByAssumption...
      - eapply ImplicationI, ByAssumption. left...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ContradictionE, ByAssumption. left...
      - eapply ByAssumption. left...
    }
    { eapply DisjunctionI2, ByAssumption... }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ByAssumption. left...
      - eapply ContradictionE, ByAssumption. left...
    }
    { eapply DisjunctionI1, ByAssumption... }
    { eapply ConjunctionE1, ByAssumption... }
    { eapply ConjunctionI.
      - eapply ByAssumption...
      - eapply ContradictionE, ByAssumption...
    }
    { eapply ConjunctionE2, ByAssumption... }
    { eapply ConjunctionI.
      - eapply ContradictionE, ByAssumption...
      - eapply ByAssumption...
    }
    { eapply ImplicationI, ByAssumption. left... }
    { eapply DisjunctionI1, ImplicationI, ByAssumption. left... }
    { eapply ImplicationI, ByAssumption. left... }
    { eapply DisjunctionI2, ImplicationI, ByAssumption. left... }
    { eapply ConjunctionE1, ByAssumption... }
    { eapply ConjunctionI; eapply ByAssumption... }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ByAssumption. left...
      - eapply ByAssumption. left...
    }
    { eapply DisjunctionI1, ByAssumption... }
    { eapply ConjunctionE1, ByAssumption... }
    { eapply ConjunctionI.
      - eapply ByAssumption...
      - eapply DisjunctionI1, ByAssumption...
    }
    { eapply DisjunctionE.
      - eapply ByAssumption...
      - eapply ByAssumption. left...
      - eapply ConjunctionE1, ByAssumption. left...
    }
    { eapply DisjunctionI1, ByAssumption... }
    { eapply ContradictionI with (A := x).
      - eapply ConjunctionE1, ByAssumption...
      - eapply ConjunctionE2, ByAssumption...
    }
    { eapply ContradictionE, ByAssumption... }
    { eapply ImplicationI, ByAssumption. left... }
    { eapply extend_infers.
      - eapply Law_of_Excluded_Middle.
      - eapply isSubsetOf_empty_if.
    }
  Qed.

  Global Instance LBA_pl : isBooleanAlgebra formula (requiresSetoid := formula_isSetoid) :=
    { hasBooleanAlgebraMethods := formula_hasBooleanAlgebraMethods
    ; BooleanAlgebra_obeysBooleanAlgebra_axiom := LBA_obeysBooleanAlgebra_axiom
    }
  .

  Global Instance LBA_pl_asCBA : isCBA formula (requiresSetoid := formula_isSetoid) :=
    { CBA_requiresBooleanAlgebra := LBA_pl
    ; CBA_requiresCountable := formula_isCountable
    }
  .

  Lemma leBA_iff (lhs : formula) (rhs : formula)
    : lhs =< rhs <-> singleton lhs ⊢ rhs.
  Proof with reflexivity || trivial.
    simpl. split.
    - intros [INFERS INFERS'].
      eapply Cut_property with (A := ConjunctionF lhs rhs)...
      eapply ConjunctionE2, ByAssumption. left...
    - intros INFERS. split.
      + eapply ConjunctionE1, ByAssumption...
      + eapply ConjunctionI...
        eapply ByAssumption...
  Qed.

  Lemma andsBA_le_iff (xs : list formula) (b : formula)
    : andsBA xs =< b <-> << INFERS : exists X : ensemble formula, isListRepOf xs X /\ X ⊢ b >>.
  Proof with reflexivity || trivial || eauto.
    rewrite leBA_iff. revert b.
    induction xs as [ | x xs IH]; ii.
    { split; unnw.
      - intros INFERS. exists (empty). split.
        + eapply isListRepOf_nil.
        + eapply Cut_property with (A := andsBA []).
          * eapply ImplicationI, ByAssumption. left...
          * eapply extend_infers... ii. left...
      - intros [X [X_empty INFERS]].
        eapply extend_infers...
        intros z z_in. now apply X_empty in z_in.
    }
    { split; unnw.
      - intros INFERS.
        assert (claim1 : singleton (andsBA xs) ⊢ ImplicationF x b).
        { eapply ImplicationI. eapply Cut_property with (A := andsBA (x :: xs)).
          - simpl. eapply ConjunctionI.
            + eapply ByAssumption. left...
            + eapply ByAssumption. right...
          - eapply extend_infers...
            ii. left...
        }
        pose proof (proj1 (IH (ImplicationF x b)) claim1) as [X [xs_repr_X INFERS']].
        exists (insert x X). split.
        + eapply isListRepOf_cons...
        + eapply ImplicationE.
          * eapply extend_infers...
            ii. right...
          * eapply ByAssumption. left...
      - intros [X [repr_X INFERS]].
        pose proof (in_dec formulaEqDec x xs) as [H_in | H_not_in].
        + assert (claim1 : exists X : ensemble formula, isListRepOf xs X /\ X ⊢ b).
          { exists (X). split...
            intros z. transitivity (In z (x :: xs))...
            simpl. split... intros [x_eq_z | z_in_xs]... now subst z.
          }
          pose proof (proj2 (IH b) claim1) as INFERS'.
          eapply Cut_property with (A := andsBA xs).
          * simpl. eapply ConjunctionE2, ByAssumption...
          * eapply extend_infers...
            ii. left...
        + assert (claim1 : exists X : ensemble formula, isListRepOf xs X /\ X ⊢ ImplicationF x b).
          { exists (delete x X). split.
            - intros z. split; intros z_in.
              + eapply in_delete_iff.
                assert (x_ne_z : x <> z) by now intros H_false; subst z.
                split... eapply repr_X. simpl...
              + apply in_delete_iff in z_in. destruct z_in as [x_ne_z z_in].
                pose proof (proj2 (repr_X z) z_in) as [x_eq_z | H_in]...
                contradiction.
            - eapply ImplicationI. eapply extend_infers...
              intros z z_in. rewrite in_insert_iff, in_delete_iff.
              pose proof (formulaEqDec x z) as [x_eq_z | x_ne_z]...
          }
          pose proof (proj2 (IH (ImplicationF x b)) claim1) as INFERS'.
          eapply ImplicationE with (A := x).
          { simpl. eapply Cut_property with (A := andsBA xs).
            - eapply ConjunctionE2, ByAssumption...
            - eapply extend_infers... ii. left...
          }
          { simpl. eapply ConjunctionE1, ByAssumption... }
    }
  Qed.

  Global Add Parametric Morphism :
    infers with signature (eqProp ==> eqProp ==> iff)
    as infers_compatWith_eqProp.
  Proof.
    intros X X' X_eq_X' b b' [INFERS1 INFERS2]. split.
    - intros INFERS. eapply Cut_property with (A := b).
      + eapply extend_infers; eauto. now rewrite X_eq_X'.
      + eapply extend_infers; eauto. ii. now left.
    - intros INFERS. eapply Cut_property with (A := b').
      + eapply extend_infers; eauto. now rewrite X_eq_X'.
      + eapply extend_infers; eauto. ii. now left.
  Qed.

End LindenbaumBooleanAlgebraOfPL.

Module ConstructiveMetaTheoryOnPropositonalLogic. (* Reference: << Constructive Completeness Proofs and Delimited Control >> written by "Danko Ilik" *)

  Import ListNotations BooleanAlgebra CountableBooleanAlgebra SyntaxOfPL SemanticsOfPL InferenceRulesOfPL LindenbaumBooleanAlgebraOfPL.

  Variant Th (X : ensemble formula) (b : formula) : Prop :=
  | In_Th (INFERS : X ⊢ b) : b \in Th X
  .

  Local Hint Constructors Th : core.

  Global Add Parametric Morphism :
    Th with signature (eqProp ==> eqProp)
    as Th_lifts_eqProp.
  Proof.
    intros X X' X_eq_X' b. split; intros [INFERS]; econstructor.
    - now rewrite <- X_eq_X'.
    - now rewrite -> X_eq_X'.
  Qed.

  Lemma lemma1_of_1_3_8 (X : ensemble formula)
    : isFilter (Th X).
  Proof with reflexivity || eauto.
    eapply isFilter_intro.
    - exists (trueBA). econstructor.
      eapply ImplicationI, ByAssumption. left...
    - ii; desnw. destruct x1_inFilter as [INFERS1]. destruct x2_inFilter as [INFERS2].
      econstructor. eapply ConjunctionI...
    - ii; desnw. destruct x_inFilter as [INFERS]. apply leBA_iff in x_le_x'.
      econstructor. eapply Cut_property...
      eapply extend_infers; eauto. ii. left...
  Qed.

  Lemma cl_isSubsetOf_Th (X : ensemble formula)
    : isSubsetOf (cl X) (Th X).
  Proof with eauto.
    intros b [xs [? ?]]; desnw.
    apply andsBA_le_iff in andsBA_xs_le; unnw.
    destruct andsBA_xs_le as [X' [xs_repr_X' INFERS]].
    econstructor. eapply extend_infers...
    intros z z_in. eapply xs_isFiniteSubsetOf, xs_repr_X'...
  Qed.

  Theorem inference_is_finite (X : ensemble formula) (b : formula)
    (INFERS : X ⊢ b)
    : exists xs : list formula, exists X' : ensemble formula, isFiniteSubsetOf xs X /\ isListRepOf xs X' /\ X' ⊢ b.
  Proof with eauto with *.
    pose proof (lemma1 := @isListRepOf_append formula).
    pose proof (lemma2 := @isFiniteSubsetOf_append formula).
    pose proof (lemma3 := @isListRepOf_remove formula formulaEqDec).
    pose proof (lemma4 := @isFiniteSubsetOf_remove formula formulaEqDec).
    induction INFERS.
    - exists ([C]), (singleton C).
      split.
      { intros z [z_eq_C | []]. now subst z. }
      split.
      { intros z. ensemble_rewrite. simpl. tauto. }
      { eapply ByAssumption... }
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      exists (xs1 ++ xs2), (union X1' X2').
      split... split...
      eapply ContradictionI with (A := A).
      + eapply extend_infers...
        ii; left...
      + eapply extend_infers...
        ii; right...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (xs), (X').
      split... split...
      eapply ContradictionE...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (remove eq_dec A xs), (delete A X').
      split... split...
      eapply NegationI.
      eapply extend_infers...
      ii. ensemble_rewrite. pose proof (formulaEqDec A x) as [? | ?]...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (remove eq_dec (NegationF A) xs), (delete (NegationF A) X').
      split... split...
      eapply NegationE.
      eapply extend_infers...
      ii. ensemble_rewrite. pose proof (formulaEqDec (NegationF A) x) as [? | ?]...
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      exists (xs1 ++ xs2), (union X1' X2').
      split... split...
      eapply ConjunctionI.
      + eapply extend_infers...
        ii; left...
      + eapply extend_infers...
        ii; right...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (xs), (X').
      split... split...
      eapply ConjunctionE1...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (xs), (X').
      split... split...
      eapply ConjunctionE2...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (xs), (X').
      split... split...
      eapply DisjunctionI1...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (xs), (X').
      split... split...
      eapply DisjunctionI2...
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      destruct IHINFERS3 as [xs3 [X3' [? [? ?]]]].
      exists (xs1 ++ (remove eq_dec A xs2 ++ remove eq_dec B xs3)), (union X1' (union (delete A X2') (delete B X3'))).
      split... split...
      eapply DisjunctionE with (A := A) (B := B).
      + eapply extend_infers...
        ii; left...
      + eapply extend_infers with (Gamma := X2')...
        ii. ensemble_rewrite. pose proof (formulaEqDec A x) as [? | ?]...
      + eapply extend_infers with (Gamma := X3')...
        ii. ensemble_rewrite. pose proof (formulaEqDec B x) as [? | ?]...
    - destruct IHINFERS as [xs [X' [? [? ?]]]].
      exists (remove eq_dec A xs), (delete A X').
      split... split...
      eapply ImplicationI.
      eapply extend_infers...
      ii. ensemble_rewrite. pose proof (formulaEqDec A x) as [? | ?]...
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      exists (xs1 ++ xs2), (union X1' X2').
      split... split...
      eapply ImplicationE.
      + eapply extend_infers...
        ii; left...
      + eapply extend_infers...
        ii; right...
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      exists (remove eq_dec A xs1 ++ remove eq_dec B xs2), (union (delete A X1') (delete B X2')).
      split... split...
      eapply BiconditionalI.
      + eapply extend_infers...
        ii. ensemble_rewrite. pose proof (formulaEqDec A x) as [? | ?]...
      + eapply extend_infers...
        ii. ensemble_rewrite. pose proof (formulaEqDec B x) as [? | ?]...
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      exists (xs1 ++ xs2), (union X1' X2').
      split... split...
      eapply BiconditionalE1.
      + eapply extend_infers...
        ii; left...
      + eapply extend_infers...
        ii; right...
    - destruct IHINFERS1 as [xs1 [X1' [? [? ?]]]].
      destruct IHINFERS2 as [xs2 [X2' [? [? ?]]]].
      exists (xs1 ++ xs2), (union X1' X2').
      split... split...
      eapply BiconditionalE2.
      + eapply extend_infers...
        ii; left...
      + eapply extend_infers...
        ii; right...
  Qed.

  Corollary Th_isSubsetOf_cl (X : ensemble formula)
    : isSubsetOf (Th X) (cl X).
  Proof.
    intros b [INFERS].
    pose proof (inference_is_finite X b INFERS) as [xs [X' [? [? ?]]]].
    exists (xs). unnw. split; eauto.
    eapply andsBA_le_iff. exists (X'). eauto.
  Qed.

  Corollary cl_eq_Th (X : ensemble formula)
    : cl X == Th X.
  Proof.
    iis.
    - eapply cl_isSubsetOf_Th.
    - eapply Th_isSubsetOf_cl.
  Qed.

  Lemma inconsistent_cl_iff (X : ensemble formula)
    : inconsistent (cl X) <-> X ⊢ ContradictionF.
  Proof.
    change (inconsistent (cl X) <-> X ⊢ falseBA). split.
    - intros [botBA [botBA_in botBA_eq_falseBA]].
      pose proof (cl_isSubsetOf_Th X botBA botBA_in) as [INFERS].
      now rewrite <- botBA_eq_falseBA.
    - intros INFERS. exists (falseBA). split; eauto with *.
      eapply Th_isSubsetOf_cl; eauto.
  Qed.

  Local Hint Resolve fact1_of_1_2_8 fact2_of_1_2_8 fact3_of_1_2_8 fact4_of_1_2_8 fact5_of_1_2_8 lemma1_of_1_2_11 inconsistent_compatWith_isSubsetOf inconsistent_cl_iff : core.

  Lemma filters_is_inconsistent_iff (F : ensemble formula)
    (F_isFilter : isFilter F)
    : inconsistent F <-> F ⊢ ContradictionF.
  Proof with eauto with *.
    split; intros INCONSISTENT.
    - eapply inconsistent_cl_iff.
      eapply inconsistent_compatWith_isSubsetOf with (X := F)...
    - eapply inconsistent_compatWith_isSubsetOf with (X := cl F)...
      eapply inconsistent_cl_iff...
  Qed.

  Fixpoint axiom_set (X : ensemble formula) (n : nat) {struct n} : ensemble formula :=
    match n with
    | O => X
    | S n' => union (axiom_set X n') (insertion (improveFilter (Th X) n') n')
    end
  .

  Lemma lemma1_of_1_3_9 (X : ensemble formula) (n : nat)
    : improveFilter (Th X) n == Th (axiom_set X n).
  Proof with eauto with *.
    revert X. induction n as [ | n IH]; [reflexivity | intros X b].
    simpl. unfold Insertion. rewrite cl_eq_Th, IH. split; intros b_in.
    - rewrite <- cl_eq_Th. rewrite <- cl_eq_Th in b_in. revert b b_in.
      change (isSubsetOf (cl (union (Th (axiom_set X n)) (insertion (Th (axiom_set X n)) n))) (cl (union (axiom_set X n) (insertion (Th (axiom_set X n)) n)))).
      transitivity (cl (cl (union (axiom_set X n) (insertion (Th (axiom_set X n)) n)))).
      + eapply fact4_of_1_2_8. intros b [b_in | b_in].
        * rewrite <- cl_eq_Th in b_in. revert b b_in. eapply fact4_of_1_2_8. ii; left...
        * rewrite cl_eq_Th. econstructor. eapply ByAssumption. right...
      + eapply fact5_of_1_2_8...
    - rewrite <- cl_eq_Th. rewrite <- cl_eq_Th in b_in. revert b b_in.
      eapply fact4_of_1_2_8. intros b [b_in | b_in].
      + left. econstructor. eapply ByAssumption...
      + right...
  Qed.

  Lemma completeness_theorem_prototype (X : ensemble formula) (b : formula) (env : truthValueAssignment)
    (ENTAILS : X ⊧ b)
    (EQUICONSISTENT : equiconsistent (Th (insert (NegationF b) X)) (evalFormula env))
    (SUBSET : isSubsetOf (Th (insert (NegationF b) X)) (evalFormula env))
    (IS_FILTER : isFilter (evalFormula env))
    : X ⊢ b.
  Proof with eauto with *.
    revert EQUICONSISTENT SUBSET IS_FILTER.
    keep (evalFormula env) as X' into (ensemble formula).
    fold X'. ii.
    assert (claim1 : env `satisfies` b).
    { eapply ENTAILS. ii. econstructor.
      eapply SUBSET. econstructor.
      eapply ByAssumption. right...
    }
    assert (claim2 : inconsistent (cl X')).
    { eapply inconsistent_cl_iff.
      eapply ContradictionI with (A := b).
      - eapply ByAssumption. inversion claim1...
      - eapply ByAssumption. eapply SUBSET.
        econstructor. eapply ByAssumption. left...
    }
    assert (claim3 : inconsistent (Th (insert (NegationF b) X))).
    { eapply EQUICONSISTENT. eapply inconsistent_compatWith_isSubsetOf with (X := cl X')... }
    eapply NegationE. eapply inconsistent_cl_iff. rewrite cl_eq_Th...
  Qed.

  Definition MaximalConsistentSet (X : ensemble formula) : ensemble formula :=
    completeFilterOf (Th X)
  .

  Variant full_axiom_set (X : ensemble formula) (b : formula) : Prop :=
  | In_full_axiom_set (n : nat)
    (ELEM : member b (axiom_set X n))
    : member b (full_axiom_set X)
  .

  Lemma lemma2_of_1_3_9 (X : ensemble formula)
    : isSubsetOf (MaximalConsistentSet X) (Th (full_axiom_set X)).
  Proof.
    intros z [n z_in].
    pose proof (proj1 (lemma1_of_1_3_9 X n z) z_in) as [INFERS].
    econstructor. eapply extend_infers; eauto. ii. now exists (n).
  Qed.

  Lemma lemma3_of_1_3_9_aux1 (xs : list formula) (X : ensemble formula)
    (xs_isFiniteSubsetOf : isFiniteSubsetOf xs (full_axiom_set X))
    : exists m : nat, isFiniteSubsetOf xs (improveFilter (Th X) m).
  Proof with eauto with *.
    revert X xs_isFiniteSubsetOf. unfold isFiniteSubsetOf.
    induction xs as [ | x xs IH]; simpl; ii.
    - exists (0). tauto.
    - assert (claim1 : forall z : formula, In z xs -> z \in full_axiom_set X) by now firstorder.
      assert (claim2 : x \in full_axiom_set X) by now firstorder.
      inversion claim2.
      assert (claim3 : member x (improveFilter (Th X) n)).
      { eapply lemma1_of_1_3_9. econstructor. eapply ByAssumption... }
      pose proof (IH X claim1) as [m claim4].
      pose proof (n_le_m_or_m_lt_n_holds_for_any_n_and_any_m m n) as [m_le_n | n_lt_m].
      + exists (n). intros z [x_eq_z | z_in_xs].
        { subst z... }
        { eapply lemma1_of_1_2_12... }
      + exists (m). intros z [x_eq_z | z_in_xs].
        { subst z.
          assert (n_le_m : n <= m) by now eapply le_S, lt_elim_n_lt_S_m in n_lt_m.
          eapply lemma1_of_1_2_12...
        }
        { eapply claim4... }
  Qed.

  Lemma lemma3_of_1_3_9 (X : ensemble formula)
    : isSubsetOf (Th (full_axiom_set X)) (MaximalConsistentSet X).
  Proof with eauto with *.
    intros z [INFERS].
    pose proof (inference_is_finite (full_axiom_set X) z INFERS) as [xs [X' [xs_isFiniteSubsetOf [xs_isListRepOf INFERS']]]].
    pose proof (lemma3_of_1_3_9_aux1 xs X xs_isFiniteSubsetOf) as [m claim1].
    assert (claim2 : isFilter (improveFilter (Th X) m)).
    { eapply @lemma1_of_1_2_11 with (requiresCBA := LBA_pl_asCBA). eapply lemma1_of_1_3_8. }
    inversion claim2. exists (m). unnw.
    eapply CLOSED_UPWARD with (x := andsBA xs).
    - eapply fact5_of_1_2_8... exists (xs)...
    - eapply andsBA_le_iff. now firstorder.
  Qed.

  Variant MaximalConsistentSet_spec (X : ensemble formula) (F : ensemble formula) : Prop :=
  | MaximalConsistentSetSpec_areTheFollowings
    (SUBSET : isSubsetOf (Th X) F)
    (EQUICONSISTENT : equiconsistent (Th X) F)
    (CLOSED_infers : forall b : formula, member b F <-> F ⊢ b)
    (META_DN : forall b : formula, << NEGATION : member (NegationF b) F -> member ContradictionF F >> -> member b F)
    (IMPLICATION_FAITHFUL : forall b : formula, forall b' : formula, member (ImplicationF b b') F <-> << IMPLICATION : member b F -> member b' F >>)
    : MaximalConsistentSet_spec X F
  .

  Theorem theorem_of_1_3_10 (X : ensemble formula)
    : MaximalConsistentSet_spec X (MaximalConsistentSet X).
  Proof with eauto with *.
    pose proof (lemma1 := @lemma1_of_1_3_8).
    pose proof (theorem_of_1_2_14 (Th X) (lemma1 X)) as [? ? ? ?].
    fold (MaximalConsistentSet X) in SUBSET, IS_FILTER, COMPLETE, EQUICONSISTENT.
    assert (CLOSED_infers : forall b : formula, b \in MaximalConsistentSet X <-> MaximalConsistentSet X ⊢ b).
    { intros b. split; intros b_in.
      - enough (to_show : member b (Th (MaximalConsistentSet X))) by now inversion to_show.
        rewrite <- cl_eq_Th. eapply fact3_of_1_2_8...
      - eapply fact5_of_1_2_8...
        rewrite -> cl_eq_Th...
    }
    assert (META_DN : forall b : formula, (NegationF b \in MaximalConsistentSet X -> ContradictionF \in MaximalConsistentSet X) -> b \in MaximalConsistentSet X).
    { intros b NEGATION. eapply COMPLETE. split.
      - intros INCONSISTENT.
        eapply inconsistent_compatWith_isSubsetOf...
        transitivity (insert b (MaximalConsistentSet X)).
        + ii; right...
        + eapply fact3_of_1_2_8.
      - intros INCONSISTENT.
        assert (claim1 : insert b (MaximalConsistentSet X) ⊢ ContradictionF).
        { now eapply inconsistent_cl_iff. }
        exists (ContradictionF). split...
        eapply NEGATION, CLOSED_infers, NegationI...
    }
    assert (IMPLICATION_FAITHFUL : forall b : formula, forall b' : formula, member (ImplicationF b b') (MaximalConsistentSet X) <-> (member b (MaximalConsistentSet X) -> member b' (MaximalConsistentSet X))).
    { intros b b'. split.
      - intros IMPLICATION b_in.
        eapply CLOSED_infers. eapply ImplicationE with (A := b).
        + eapply CLOSED_infers...
        + eapply CLOSED_infers...
      - intros IMPLICATION. eapply META_DN.
        intros H_in. eapply CLOSED_infers.
        assert (claim1 : insert (ImplicationF b b') (MaximalConsistentSet X) ⊢ ContradictionF).
        { eapply ContradictionI with (A := ImplicationF b b').
          - eapply ByAssumption. left...
          - eapply extend_infers with (Gamma := MaximalConsistentSet X).
            + eapply CLOSED_infers...
            + ii; right...
        }
        assert (claim2 : MaximalConsistentSet X ⊢ ConjunctionF b (NegationF b')).
        { eapply DisjunctionE with (A := b) (B := NegationF b).
          - eapply extend_infers with (Gamma := empty).
            + eapply Law_of_Excluded_Middle.
            + eapply isSubsetOf_empty_if.
          - eapply DisjunctionE with (A := b') (B := NegationF b').
            + eapply extend_infers with (Gamma := empty).
              { eapply Law_of_Excluded_Middle. }
              { eapply isSubsetOf_empty_if. }
            + eapply ContradictionE.
              eapply Cut_property with (A := ImplicationF b b').
              { eapply ImplicationI, ByAssumption. right; left... }
              { eapply extend_infers...
                eapply isSubsetOf_insert_if. ii; right; right...
              }
            + eapply ConjunctionI.
              { eapply ByAssumption. right; left... }
              { eapply ByAssumption. left... }
          - eapply ContradictionE.
            eapply Cut_property with (A := ImplicationF b b').
            + eapply ImplicationI, ContradictionE.
              eapply ContradictionI with (A := b).
              { eapply ByAssumption. left... }
              { eapply ByAssumption. right; left... }
            + eapply extend_infers...
              eapply isSubsetOf_insert_if. ii; right...
        }
        assert (claim3 : MaximalConsistentSet X ⊢ b).
        { eapply ConjunctionE1... }
        assert (claim4 : MaximalConsistentSet X ⊢ NegationF b').
        { eapply ConjunctionE2... }
        eapply ContradictionI with (A := b')...
        eapply CLOSED_infers, IMPLICATION, CLOSED_infers...
    }
    split...
  Qed.

End ConstructiveMetaTheoryOnPropositonalLogic.


Require Import ssreflect ssrfun ssrbool.

Require Import PG32.pg32_inductive PG32.pg32_proofs.
Require Import PG32.pg32_spreads.
Require Import PG32.pg32_spreads_collineations.
Require Import PG32.pg32_spreads_packings.
Require Import PG32.pg32_packings_collineations.
Require Import PG32.pg32_automorphisms.

Require Import List.
Import ListNotations.

Lemma l_can_be_built_from_two_points : forall l, exists p1 p2, p1<>p2 /\ l = l_from_points p1 p2.
Proof.
intros l; destruct l.
exists P0; exists P1; split; [discriminate | reflexivity].
exists P0; exists P3; split; [discriminate | reflexivity].
exists P0; exists P6; split; [discriminate | reflexivity].
exists P0; exists P7; split; [discriminate | reflexivity].
exists P0; exists P10; split; [discriminate | reflexivity].
exists P0; exists P11; split; [discriminate | reflexivity].
exists P0; exists P13; split; [discriminate | reflexivity].
exists P1; exists P4; split; [discriminate | reflexivity].
exists P1; exists P8; split; [discriminate | reflexivity].
exists P1; exists P12; split; [discriminate | reflexivity].
exists P1; exists P7; split; [discriminate | reflexivity].
exists P1; exists P13; split; [discriminate | reflexivity].
exists P1; exists P3; split; [discriminate | reflexivity].
exists P2; exists P7; split; [discriminate | reflexivity].
exists P2; exists P11; split; [discriminate | reflexivity].
exists P2; exists P3; split; [discriminate | reflexivity].
exists P2; exists P12; split; [discriminate | reflexivity].
exists P2; exists P4; split; [discriminate | reflexivity].
exists P2; exists P8; split; [discriminate | reflexivity].
exists P3; exists P10; split; [discriminate | reflexivity].
exists P3; exists P8; split; [discriminate | reflexivity].
exists P3; exists P9; split; [discriminate | reflexivity].
exists P3; exists P7; split; [discriminate | reflexivity].
exists P4; exists P9; split; [discriminate | reflexivity].
exists P4; exists P8; split; [discriminate | reflexivity].
exists P4; exists P10; split; [discriminate | reflexivity].
exists P4; exists P7; split; [discriminate | reflexivity].
exists P5; exists P8; split; [discriminate | reflexivity].
exists P5; exists P7; split; [discriminate | reflexivity].
exists P5; exists P9; split; [discriminate | reflexivity].
exists P5; exists P10; split; [discriminate | reflexivity].
exists P6; exists P7; split; [discriminate | reflexivity].
exists P6; exists P8; split; [discriminate | reflexivity].
exists P6; exists P9; split; [discriminate | reflexivity].
exists P6; exists P10; split; [discriminate | reflexivity].
Qed.

Lemma fp_ext :
  forall (fp:Point->Point) (fp':Point->Point), (forall (p:Point), fp p = fp' p) -> fp = fp'.
Admitted.

Lemma fl_ext :
  forall (fl:Line->Line) (fl':Line->Line), (forall (l:Line), fl l = fl' l) -> fl = fl'.
Admitted.

Lemma is_c_diffP : forall fp fl, is_collineation fp fl -> forall x y z, x<>y -> fp x = z -> fp y = z -> False.
Proof.
intros fp fl Hcol x y z  Hyz fp_x fp_z.
destruct Hcol as [[Hinjfp Hsurjfp][HinjL1 Hincid1]].
rewrite <- fp_z in fp_x.
apply Hyz; apply Hinjfp; assumption.
Qed.

Lemma is_c_diffL : forall fp fl, is_collineation fp fl -> forall  x y z, x<>y -> fl x = z -> fl y = z -> False.
Proof.
intros fp fl Hcol x y z Hyz fp_x fp_z.
destruct Hcol as [HbijP [[Hinjl Hsurjl] Hincid]].
rewrite <- fp_z in fp_x.
apply Hyz; apply Hinjl; assumption.
Qed.

Ltac not_bijP :=
  match goal with H:?fp ?P = ?Q, H':?fp ?R = ?Q |- _ =>
                  eapply (is_c_diffP fp _ _ P R Q); solve [assumption | discriminate] end.

Ltac not_bijL :=
  match goal with H:?fl ?P = ?Q, H':?fl ?R = ?Q |- _ =>
                  eapply (is_c_diffL _ fl _ P R Q); solve [assumption | discriminate] end.

Lemma is_collineation_l_from_points :
  forall fp fl, is_collineation fp fl ->
                forall Pa Pb, Pa<>Pb -> fl (l_from_points Pa Pb) = l_from_points (fp Pa) (fp Pb).
Proof.
intros fp fl [HbijP [HbijL Hincid]].
intros Pa Pb HPaPb.
assert (HPa : (incid_lp Pa (l_from_points Pa Pb))) by apply incid_lp_l_from_point1.
assert (HPb : (incid_lp Pb (l_from_points Pa Pb))) by apply incid_lp_l_from_point2.
generalize (Hincid Pa (l_from_points Pa Pb) HPa); clear HPa; intros HPa.
generalize (Hincid Pb (l_from_points Pa Pb) HPb); clear HPb; intros Hpb.
assert (HPa' : incid_lp (fp Pa) (l_from_points (fp Pa) (fp Pb))) by apply incid_lp_l_from_point1.
assert (HPb' : incid_lp (fp Pb) (l_from_points (fp Pa) (fp Pb))) by apply incid_lp_l_from_point2.
eapply (a1_unique (fp Pa)  (fp Pb)); try assumption.
intro; apply HPaPb; destruct HbijP as [HinjP HsurjP]; apply HinjP; assumption.
Qed.

Lemma Point_dec' : forall T U:Point, {T=U}+{~T=U}.
Proof.
  intros T U; case T; case U;
    solve [left; exact (@erefl Point _) | right; discriminate].
Defined.

Definition points_from_line (l:Line) :=
match l with
| L0  =>  [P0;P1;P2]
| L1  =>  [P0;P3;P4]
| L2  =>  [P0;P5;P6]
| L3  =>  [P0;P7;P8]
| L4  =>  [P0;P10;P9]
| L5  =>  [P0;P11;P12]
| L6  =>  [P0;P13;P14]
| L7  =>  [P1;P4;P6]
| L8  =>  [P1;P8;P10]
| L9  =>  [P1;P12;P14]
| L10  =>  [P1;P7;P9]
| L11  =>  [P1;P13;P11]
| L12  =>  [P1;P3;P5]
| L13  =>  [P2;P7;P10]
| L14  =>  [P2;P11;P14]
| L15  =>  [P2;P3;P6]
| L16  =>  [P2;P12;P13]
| L17  =>  [P2;P4;P5]
| L18  =>  [P2;P8;P9]
| L19  =>  [P3;P10;P14]
| L20  =>  [P3;P8;P12]
| L21  =>  [P3;P9;P13]
| L22  =>  [P3;P7;P11]
| L23  =>  [P4;P9;P14]
| L24  =>  [P4;P8;P11]
| L25  =>  [P4;P10;P13]
| L26  =>  [P4;P7;P12]
| L27  =>  [P5;P8;P14]
| L28  =>  [P5;P7;P13]
| L29  =>  [P5;P9;P11]
| L30  =>  [P5;P10;P12]
| L31  =>  [P6;P7;P14]
| L32  =>  [P6;P8;P13]
| L33  =>  [P6;P9;P12]
| L34  =>  [P6;P10;P11]
end.

Definition third (A B:Point) :=
  match (points_from_line (l_from_points A B)) with
    [x1;x2;x3] =>
    if (Point_dec' x1 A)
    then
      if (Point_dec' x2 B)
      then x3
      else x2
    else
      if (Point_dec' x1 B) then
        if (Point_dec' x2 A)
        then x3
        else x2
      else x1 | _ => P0 end.

Lemma incid_lp_l_from_points : forall A B, A<>B -> forall x, incid_lp x (l_from_points A B) -> x=A \/ x=B \/x=third A B.
Proof.
intros A B HAB.
destruct A; destruct B; try (apply False_ind; apply HAB; reflexivity);
intros x Hx; destruct x; try solve [left; reflexivity | right; left; reflexivity | right; right; reflexivity | discriminate Hx].
Qed.

Lemma fp_lemma : forall fp fl, is_collineation fp fl -> forall X Y, X<>Y -> fp (third X Y) = third (fp X) (fp Y).
Proof.
intros fp fl Hfpfl X Y HXY.
pose (l:=l_from_points X Y).
assert (Hi: (incid_lp (third X Y) l)) by (destruct X; destruct Y; unfold l; try solve [ reflexivity | (apply False_ind; apply HXY; reflexivity)]).
assert (Hi':(incid_lp (fp (third X Y)) (fl l))) by (destruct Hfpfl as [HbijP [HbijL Hincid]]; apply Hincid; assumption).
assert (HFXFY:fp X <> fp Y) by (intro Heq; destruct Hfpfl as [[HinjP _] [HbijL Hincid]]; apply HXY;  apply (HinjP _ _ Heq)).
rewrite (is_collineation_l_from_points fp fl Hfpfl  _ _ HXY) in Hi'.
destruct (incid_lp_l_from_points (fp X) (fp Y) HFXFY (fp (third X Y)) Hi') as [Heq | [Heq | Heq]].
revert Heq; destruct X; destruct Y;
  try solve [apply False_ind; apply HXY; reflexivity |
             intros Heq; destruct Hfpfl as [[HinjP _] [HbijL Hincid]]; apply HinjP in Heq; discriminate Heq].
revert Heq; destruct X; destruct Y;
  try solve [apply False_ind; apply HXY; reflexivity |
             intros Heq; destruct Hfpfl as [[HinjP _] [HbijL Hincid]]; apply HinjP in Heq; discriminate Heq].
assumption.
Qed.

Lemma simple_rewrite : forall fp fl , is_collineation fp fl -> forall (T U Z:Point), fp T=Z -> fp U=Z -> T=U.
Proof.
  intros fp fl Hfpfl T U Z HTZ HUZ.
  assert (fp T=fp U).
  transitivity Z; [assumption | symmetry; assumption].
  destruct Hfpfl as [[HinjP _]]; apply HinjP in H; assumption.
Qed.

Ltac elim_degen_cases fp fl Hfpfl := match goal with HX : fp ?X = _, HY : fp ?Y = _ |- _ =>
                  let Hnew := fresh in
                  assert (Hnew:(fp (third X Y)) = third (fp X) (fp Y))
                    by (apply (fp_lemma fp fl Hfpfl); discriminate);  rewrite HX in Hnew; rewrite HY in Hnew; cbn in Hnew  end;
                  match goal with HT : fp ?T = ?Z, HU : fp ?U = ?Z |- _ =>
                      let Hnew2 := fresh in assert (Hnew2:T =U) by (apply (simple_rewrite fp fl Hfpfl T U Z HT HU));
                      discriminate end.


From TLA Require Import logic.
From TLA.examples.mutex Require Import
  spec wait_set nodup automation.

Implicit Types (σ: State) (s: Config) (t: Tid).
Implicit Types (l: bool) (q: list Tid).

Definition exclusion_inv: Config → Prop :=
  λ s, (∀ tid, s.(tp) !! tid = Some pc.critical_sec →
               s.(state).(lock) = true) ∧
       safe s.

Lemma exclusion_inv' s :
  exclusion_inv s ↔
    (∀ t t', s.(tp) !! t = Some pc.critical_sec →
             s.(tp) !! t' = Some pc.critical_sec →
             t = t' ∧ s.(state).(lock) = true).
Proof.
  unfold exclusion_inv, safe.
  split; intros; destruct_and?; eauto.
  split; intros.
  - pose proof (H tid tid); intuition eauto.
  - pose proof (H tid tid'); intuition eauto.
Qed.

Lemma exclusion_inv_ok :
  spec ⊢ □⌜exclusion_inv⌝.
Proof.
  unfold spec.
  tla_clear fair.
  apply init_invariant.
  - unfold exclusion_inv.
    stm; intuition auto.
    { pose proof (H1 _ _ H); congruence. }
    { pose proof (H1 _ _ H); congruence. }
  - intros [σ tp] [σ' tp']; simpl.
    intros Hinv Hnext.
    apply next_inv in Hnext as
        [[[=] ?] |
          (t & pc & pc' & Hlookup & Hstep & ?)]; subst; eauto.

    apply exclusion_inv' => t' t'' /= Ht' Ht''.
    destruct Hinv as [Hlocked Hsafe]; unfold safe in *; simpl in *.
    destruct (decide (t' = t'')); subst.
    { split; first done.
      destruct (decide (t = t'')); destruct_step; stm. }

    destruct (decide (t = t''));
      destruct (decide (t = t'));
      subst; lookup_simp; eauto;
      assert (σ.(lock) = true) by eauto.
    { destruct_step; stm. }
    { destruct_step; stm. }
    { split; eauto. }
Qed.

Theorem safety :
  spec ⊢ □ ⌜safe⌝.
Proof.
  rewrite exclusion_inv_ok /exclusion_inv.
  apply always_impl_proper.
  unseal; stm.
Qed.

Definition lock_held (s: Config) (t: Tid) :=
  s.(tp) !! t = Some pc.unlock_store.

Definition locked_inv : Config → Prop :=
  λ s, s.(state).(lock) = true →
       ∃ t, lock_held s t.

Lemma locked_inv_ok :
  spec ⊢ □⌜locked_inv⌝.
Proof.
  unfold spec.
  tla_clear fair.
  apply init_invariant.
  - unfold locked_inv; stm.
  - unfold locked_inv; intros [σ tp] [σ' tp'] Hinv Hnext.
    apply next_inv in Hnext as
        [[[=] ?] |
          (t & pc & pc' & Hlookup & Hstep & ?)]; subst; eauto.
    unfold lock_held in *; simpl in *.
    destruct_step;
      repeat (stm_simp
              ||  match goal with
                  | t: Tid |- _ => exists t; lookup_simp; by eauto
                  end).
Qed.

Definition nodup_inv s :=
  NoDup s.(state).(queue).

Definition waiting_inv s :=
  ∀ t, t ∈ s.(state).(queue) →
        s.(tp) !! t = Some pc.kernel_wait.

(* these need to be proven together *)
Definition nodup_helper_inv s :=
  nodup_inv s ∧ waiting_inv s.

Lemma NoDup_pop (l: list Tid) :
  NoDup l → NoDup (pop l).
Proof.
  destruct l; simpl; auto.
  inversion 1; subst; auto.
Qed.

Lemma elem_of_pop t (l: list Tid) :
  t ∈ pop l →
  t ∈ l.
Proof.
  unfold pop.
  destruct l; set_solver.
Qed.

(* this hints are just for proving these invariants *)
#[local]
Hint Resolve NoDup_nil_2 NoDup_pop NoDup_app1_fwd elem_of_pop : core.

#[local]
Hint Extern 2 (_ ∉ _) => set_solver : core.
#[local]
Hint Extern 2 (_ ∈ _) => set_solver : core.

Lemma nodup_helper_inv_ok :
  spec ⊢ □⌜nodup_helper_inv⌝.
Proof.
  unfold spec.
  tla_clear fair.
  rewrite /nodup_helper_inv /nodup_inv /waiting_inv.
  apply init_invariant.
  - stm.
    set_solver+.
  - intros [σ tp] [σ' tp'] [Hnodup Hwait] Hnext.
    apply next_inv in Hnext as
        [[[=] ?] |
          (t & pc & pc' & Hlookup & Hstep & ?)]; subst; eauto.
    destruct_step; stm; intros;
      try (destruct (decide (t0 = t)); lookup_simp; eauto;
          let n := numgoals in guard n <= 1);
      try match goal with
          | H: ?t ∈ _ |- _ => apply Hwait in H; congruence
          end.
    + assert (t ∈ q) as Hel by auto.
      apply Hwait in Hel; congruence.
Qed.

Lemma nodup_inv_ok :
  spec ⊢ □⌜nodup_inv⌝.
Proof.
  tla_pose nodup_helper_inv_ok.
  tla_clear spec.
  apply always_impl_proper.
  apply state_pred_impl; rewrite /nodup_helper_inv; naive_solver.
Qed.

Lemma queue_invs :
  spec ⊢ □⌜λ s, exclusion_inv s ∧ nodup_inv s⌝.
Proof.
  tla_pose exclusion_inv_ok.
  tla_pose nodup_inv_ok.
  tla_clear spec.
  rewrite -always_and; tla_simp.
Qed.

(*|
We'll now prove an invariant `lock_free_queue_inv` to cover the situation where the queue has some head thread `t` (which must be in `kernel_wait`, a simple inductive invariant) but the lock is free. It'll show the existence of some other thread `t'` that will help make progress. We don't need to worry about the case where the lock is held, because then the lock holder will release the lock and signal, so progress is relatively easy in that case.

If the queue has a head element `t` but the lock is free, then some thread `t'` must have acquired the lock, then released it (because the code only starts waiting if the lock is still held, according to the semantics of `futex_wait()`). To make this an inductive invariant, we need to also consider that `t'` next signalled to some thread `t''`, in which case `t''` is in `kernel_wait` and enabled. Finally, `t''` in turn may have already run and is now back in `lock_cas`, so this third case is also needed to make the invariant inductive. These three cover all the cases because the lock is free, so `t''` couldn't have acquired the lock yet.
|*)

(* NOTE: this is incorrectly named, it's just a thread that can help make
progress in general *)
Definition thread_can_signal t' s :=
  s.(tp) !! t' = Some pc.unlock_wake ∨
  (s.(tp) !! t' = Some pc.kernel_wait ∧
  t' ∉ s.(state).(queue)) ∨
  s.(tp) !! t' = Some pc.lock_cas.

Definition lock_free_queue_inv s :=
  ∀ t ts,
    s.(state).(queue) = t::ts →
    s.(state).(lock) = false →
    ∃ t', thread_can_signal t' s.

Lemma lock_free_queue_inv_ok :
  spec ⊢ □⌜lock_free_queue_inv⌝.
Proof.
  tla_pose nodup_helper_inv_ok.
  tla_pose exclusion_inv_ok.
  rewrite /lock_free_queue_inv /thread_can_signal.
  unfold spec. tla_clear fair.
  rewrite -always_and combine_state_preds.
  rewrite combine_preds.
  apply init_invariant.
  - intros s. stm.
  - move => [[l q] tp] [[l' q'] tp'] /=.
    intros Hinv [Hnext [Hinvs _]] t0 ts0 -> ->; simpl in *.
    destruct Hinvs as ([Hnodup Hwait] & [Hexcl _]); simpl in *.
    rewrite /nodup_inv /= in Hnodup.
    apply next_inv in Hnext as
        [[[=] ?] |
          (t & pc & pc' & Hlookup & Hstep & ?)]; subst; eauto.

(*|
This proof is done carefully to illustrate all the cases above.
|*)
    destruct_step; try solve [ exfalso; stm ].
    + stm_simp.
      (* futex_wait -> lock_cas *)
      destruct (Hinv _ _ ltac:(eauto) ltac:(auto)) as [t' Ht'];
        destruct_or!; destruct_and?;
          try solve [ exists t'; lookup_simp; eauto ].
      (* doesn't affect t', all cases are proven automatically *)
    + stm_simp.
      (* kernel_wait -> lock_cas *)
      destruct (Hinv _ _ ltac:(eauto) ltac:(auto)) as [t' Ht'];
        destruct_or!; destruct_and?;
          try solve [ exists t'; lookup_simp; eauto ].
      (* t' was in kernel_wait but now it's in lock_cas *)
      assert (tp !! t' = Some pc.kernel_wait) as _ by assumption.
      exists t; lookup_simp; eauto.
    + stm_simp.
      (* unlock_store -> unlock_wake *)
      assert (l = true) by eauto; subst.
      (* this is the easy case where we got here because a thread just released
      the lock *)
      exists t; lookup_simp; eauto.
    + stm_simp.
      (* unlock_wake -> finished *)
(*|
There may no longer be thread still in `unlock_wake`, so we'll instead show
there's now a `kernel_wait` thread that's enabled.
|*)
      (* this invariant only concerns the queue being non-empty, so signalling
      must have signalled some other thread [t1] just in front of t0 *)
      destruct q as [|t'' q']; [ by inversion H2 | simpl in H2; subst ].
      assert (t'' ∉ t0 :: ts0) by (inversion Hnodup; eauto).
      rewrite /waiting_inv /= in Hwait.
      (* follows from [t''] being in the queue *)
      assert (tp !! t'' = Some pc.kernel_wait) by eauto.
      exists t''; lookup_simp; eauto.
Qed.

Record all_invs s :=
  { Hexcl: exclusion_inv s;
    Hlocked: locked_inv s;
    Hnodup: nodup_inv s;
    Hwaiting: waiting_inv s;
    Hcan_lock: lock_free_queue_inv s;
  }.

Lemma all_invs_ok :
  spec ⊢ □⌜all_invs⌝.
Proof.
  tla_pose exclusion_inv_ok.
  tla_pose locked_inv_ok.
  tla_pose nodup_helper_inv_ok.
  tla_pose lock_free_queue_inv_ok.
  tla_clear spec.
  rewrite -!always_and.
  tla_simp.
  apply always_impl_proper.
  apply state_pred_impl.
  rewrite /nodup_helper_inv.
  intuition idtac.
  constructor; auto.
Qed.

#[export]
Hint Unfold exclusion_inv locked_inv
  nodup_inv waiting_inv
  lock_free_queue_inv : inv.


From Hammer Require Import Hammer.

From Topology Require Export TopologicalSpaces.
From Topology Require Export WeakTopology.
From ZornsLemma Require Import DependentTypeChoice.
From Topology Require Export FilterLimits.
From Topology Require Export Compactness.

Section product_topology.

Variable A:Type.
Variable X:forall a:A, TopologicalSpace.

Definition product_space_point_set : Type :=
forall a:A, point_set (X a).
Definition product_space_proj (a:A) : product_space_point_set ->
point_set (X a) :=
fun (x:product_space_point_set) => x a.

Definition ProductTopology : TopologicalSpace :=
WeakTopology product_space_proj.

Lemma product_space_proj_continuous: forall a:A,
continuous (product_space_proj a) (X:=ProductTopology).
Proof. hammer_hook "ProductTopology" "ProductTopology.product_space_proj_continuous".
apply weak_topology_makes_continuous_funcs.
Qed.

Lemma product_net_limit: forall (I:DirectedSet)
(x:Net I ProductTopology) (x0:point_set ProductTopology),
inhabited (DS_set I) ->
(forall a:A, net_limit (fun i:DS_set I => x i a) (x0 a)) ->
net_limit x x0.
Proof. hammer_hook "ProductTopology" "ProductTopology.product_net_limit".
intros.
apply net_limit_in_projections_impl_net_limit_in_weak_topology;
trivial.
Qed.

Lemma product_filter_limit:
forall (F:Filter (point_set ProductTopology))
(x0:point_set ProductTopology),
(forall a:A, filter_limit (filter_direct_image
(product_space_proj a) F) (x0 a)) ->
filter_limit F x0.
Proof. hammer_hook "ProductTopology" "ProductTopology.product_filter_limit".
intros.
assert (subbasis
(weak_topology_subbasis product_space_proj)
(X:=ProductTopology)).
apply Build_TopologicalSpace_from_subbasis_subbasis.
red; intros.
red; intros U ?.
destruct H1.
destruct H1 as [U' []].
cut (In (filter_family F) U').
intro.
apply filter_upward_closed with U'; trivial.
destruct H1.
destruct (subbasis_cover _ _ H0 _ _ H3 H1) as
[B [? [V [? []]]]].
cut (In (filter_family F) (IndexedIntersection V)).
intro.
apply filter_upward_closed with (1:=H8); trivial.
apply filter_finite_indexed_intersection; trivial.

intro b.
pose proof (H5 b).
inversion H8.
apply H.
constructor.
apply open_neighborhood_is_neighborhood.
constructor; trivial.
destruct H6.
pose proof (H6 b).
rewrite <- H9 in H11.
destruct H11.
exact H11.
Qed.

Theorem TychonoffProductTheorem:
(forall a:A, compact (X a)) -> compact ProductTopology.
Proof. hammer_hook "ProductTopology" "ProductTopology.TychonoffProductTheorem".
intro.
apply ultrafilter_limit_impl_compact; intros.
destruct (choice_on_dependent_type (fun (a:A) (x:point_set (X a)) =>
filter_limit (filter_direct_image (product_space_proj a) U) x))
as [choice_fun].
intro.
destruct (compact_impl_filter_cluster_point _ (H a)
(filter_direct_image (product_space_proj a) U)) as [xa].
exists xa.
apply ultrafilter_cluster_point_is_limit; trivial.
red; intros.
destruct (H0 (inverse_image (product_space_proj a) S));
[left | right]; constructor; try rewrite inverse_image_complement; trivial.
exists choice_fun.
apply product_filter_limit; trivial.
Qed.

End product_topology.

Arguments ProductTopology {A}.
Arguments product_space_proj {A} {X}.

Lemma product_map_continuous: forall {A:Type}
(X:TopologicalSpace) (Y:A->TopologicalSpace)
(f:forall a:A, point_set X -> point_set (Y a)) (x:point_set X),
(forall a:A, continuous_at (f a) x) ->
continuous_at (fun x:point_set X => (fun a:A => f a x)) x
(Y:=ProductTopology Y).
Proof. hammer_hook "ProductTopology" "ProductTopology.product_map_continuous".
intros.
apply func_preserving_net_limits_is_continuous.
intros.
apply product_net_limit.
destruct (H0 Full_set) as [i].
apply open_full.
constructor.
exists; exact i.
intros.
apply continuous_func_preserves_net_limits; trivial.
Qed.

Require Import FunctionalExtensionality.
From ZornsLemma Require Import FiniteIntersections.

Section product_topology2.

Variable X Y:TopologicalSpace.

Inductive twoT := | twoT_1 | twoT_2.
Let prod2_fun (i:twoT) := match i with
| twoT_1 => X | twoT_2 => Y end.
Let prod2 := ProductTopology prod2_fun.

Let prod2_conv1 (p:point_set prod2) : point_set X * point_set Y :=
(p twoT_1, p twoT_2).
Let prod2_conv2 (p : point_set X * point_set Y) : point_set prod2 :=
let (x,y):=p in fun i:twoT => match i with
| twoT_1 => x | twoT_2 => y
end.

Lemma prod2_comp1: forall p:point_set prod2,
prod2_conv2 (prod2_conv1 p) = p.
Proof. hammer_hook "ProductTopology" "ProductTopology.prod2_comp1".
intros.
extensionality i.
destruct i; trivial.
Qed.

Lemma prod2_comp2: forall p:point_set X * point_set Y,
prod2_conv1 (prod2_conv2 p) = p.
Proof. hammer_hook "ProductTopology" "ProductTopology.prod2_comp2".
intros.
destruct p as [x y].
trivial.
Qed.

Let prod2_proj := fun i:twoT =>
match i return (point_set X * point_set Y ->
point_set (prod2_fun i)) with
| twoT_1 => @fst (point_set X) (point_set Y)
| twoT_2 => @snd (point_set X) (point_set Y)
end.

Definition ProductTopology2 : TopologicalSpace :=
WeakTopology prod2_proj.

Lemma prod2_conv1_cont: continuous prod2_conv1 (Y:=ProductTopology2).
Proof. hammer_hook "ProductTopology" "ProductTopology.prod2_conv1_cont".
apply pointwise_continuity.
intros p.
apply func_preserving_net_limits_is_continuous.
intros.
apply net_limit_in_projections_impl_net_limit_in_weak_topology.
destruct (H Full_set).
apply open_full.
constructor.
exact (inhabits x0).
destruct a.
simpl.
apply net_limit_in_weak_topology_impl_net_limit_in_projections
with (a:=twoT_1) in H.
exact H.
simpl.
apply net_limit_in_weak_topology_impl_net_limit_in_projections
with (a:=twoT_2) in H.
exact H.
Qed.

Lemma prod2_conv2_cont: continuous prod2_conv2 (X:=ProductTopology2).
Proof. hammer_hook "ProductTopology" "ProductTopology.prod2_conv2_cont".
apply pointwise_continuity.
destruct x as [x y].
apply func_preserving_net_limits_is_continuous.
intros.
apply net_limit_in_projections_impl_net_limit_in_weak_topology.
destruct (H Full_set).
apply open_full.
constructor.
exact (inhabits x1).
destruct a.
unfold product_space_proj.
simpl.
replace (fun i:DS_set I => prod2_conv2 (x0 i) twoT_1) with
(fun i:DS_set I => fst (x0 i)).
apply net_limit_in_weak_topology_impl_net_limit_in_projections
with (a:=twoT_1) in H.
simpl in H.
trivial.
extensionality i.
destruct (x0 i) as [xi yi].
trivial.
unfold product_space_proj.
simpl.
replace (fun i:DS_set I => prod2_conv2 (x0 i) twoT_2) with
(fun i:DS_set I => snd (x0 i)).
apply net_limit_in_weak_topology_impl_net_limit_in_projections
with (a:=twoT_2) in H.
simpl in H.
trivial.
extensionality i.
destruct (x0 i) as [xi yi].
trivial.
Qed.

Lemma product2_fst_continuous:
continuous (@fst (point_set X) (point_set Y))
(X:=ProductTopology2).
Proof. hammer_hook "ProductTopology" "ProductTopology.product2_fst_continuous".
exact (weak_topology_makes_continuous_funcs
_ _ _ prod2_proj twoT_1).
Qed.

Lemma product2_snd_continuous:
continuous (@snd (point_set X) (point_set Y))
(X:=ProductTopology2).
Proof. hammer_hook "ProductTopology" "ProductTopology.product2_snd_continuous".
exact (weak_topology_makes_continuous_funcs
_ _ _ prod2_proj twoT_2).
Qed.

Lemma product2_map_continuous: forall (W:TopologicalSpace)
(f:point_set W -> point_set X) (g:point_set W -> point_set Y)
(w:point_set W),
continuous_at f w -> continuous_at g w ->
continuous_at (fun w:point_set W => (f w, g w)) w
(Y:=ProductTopology2).
Proof. hammer_hook "ProductTopology" "ProductTopology.product2_map_continuous".
intros.
replace (fun w:point_set W => (f w, g w)) with
(fun w:point_set W => prod2_conv1
(fun i:twoT => match i with
| twoT_1 => f w
| twoT_2 => g w end)).
apply (@continuous_composition_at W prod2 ProductTopology2
prod2_conv1
(fun w:point_set W =>
fun i:twoT => match i with
| twoT_1 => f w | twoT_2 => g w end)).
apply continuous_func_continuous_everywhere.
apply prod2_conv1_cont.
apply product_map_continuous.
destruct a; trivial.
extensionality w0.
trivial.
Qed.

Inductive ProductTopology2_basis :
Family (point_set ProductTopology2) :=
| intro_product2_basis_elt:
forall (U:Ensemble (point_set X))
(V:Ensemble (point_set Y)),
open U -> open V ->
In ProductTopology2_basis
[ p:point_set ProductTopology2 |
let (x,y):=p in (In U x /\ In V y) ].

Lemma ProductTopology2_basis_is_basis:
open_basis ProductTopology2_basis.
Proof. hammer_hook "ProductTopology" "ProductTopology.ProductTopology2_basis_is_basis".
assert (open_basis (finite_intersections (weak_topology_subbasis prod2_proj))
(X:=ProductTopology2)) by apply
Build_TopologicalSpace_from_open_basis_basis.
apply eq_ind with (1:=H).
apply Extensionality_Ensembles; split; red; intros U ?.
induction H0.
replace (@Full_set (point_set X * point_set Y)) with
[ p:point_set ProductTopology2 |
let (x,y):=p in (In Full_set x /\ In Full_set y) ].
constructor; try apply open_full.
apply Extensionality_Ensembles; split; red; intros.
constructor.
destruct x.
constructor; split; constructor.
destruct H0.
destruct a.
replace (inverse_image (prod2_proj twoT_1) V) with
[ p:point_set ProductTopology2 |
let (x,y):=p in (In V x /\ In Full_set y) ].
constructor; trivial.
apply open_full.
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct x.
destruct H1.
constructor.
trivial.
destruct H1.
destruct x.
constructor.
split; trivial.
constructor.
replace (inverse_image (prod2_proj twoT_2) V) with
[ p:point_set ProductTopology2 |
let (x,y):=p in (In Full_set x /\ In V y) ].
constructor; trivial.
apply open_full.
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct x.
destruct H1.
constructor.
trivial.
destruct H1.
destruct x.
constructor.
split.
constructor.
trivial.

destruct IHfinite_intersections as [U1 V1].
destruct IHfinite_intersections0 as [U2 V2].
replace (@Intersection (point_set X * point_set Y)
[p:point_set ProductTopology2 | let (x,y):=p in In U1 x /\ In V1 y]
[p:point_set ProductTopology2 | let (x,y):=p in In U2 x /\ In V2 y])
with
[p:point_set ProductTopology2 | let (x,y):=p in
(In (Intersection U1 U2) x /\ In (Intersection V1 V2) y)].
constructor; apply open_intersection2; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
destruct x.
destruct H6.
destruct H6.
destruct H7.
constructor.
constructor.
split; trivial.
constructor.
split; trivial.
destruct H6.
destruct H6.
destruct H7.
destruct x.
destruct H6.
destruct H7.
constructor.
split; constructor; trivial.

destruct H0.
replace [p:point_set ProductTopology2 | let (x,y):=p in
In U x /\ In V y] with
(Intersection (inverse_image (prod2_proj twoT_1) U)
(inverse_image (prod2_proj twoT_2) V)).
constructor 3.
constructor.
constructor; trivial.
constructor.
constructor; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H2.
destruct H2.
destruct H3.
constructor.
destruct x.
split; trivial.
destruct H2.
destruct x.
destruct H2.
constructor; constructor; trivial.
Qed.

End product_topology2.

Section two_arg_convenience_results.

Variable X Y Z:TopologicalSpace.
Variable f:point_set X -> point_set Y -> point_set Z.

Definition continuous_2arg :=
continuous (fun p:point_set X * point_set Y =>
let (x,y):=p in f x y)
(X:=ProductTopology2 X Y).
Definition continuous_at_2arg (x:point_set X) (y:point_set Y) :=
continuous_at (fun p:point_set X * point_set Y =>
let (x,y):=p in f x y)  (x, y)
(X:=ProductTopology2 X Y).

Lemma continuous_2arg_func_continuous_everywhere:
continuous_2arg -> forall (x:point_set X) (y:point_set Y),
continuous_at_2arg x y.
Proof. hammer_hook "ProductTopology" "ProductTopology.continuous_2arg_func_continuous_everywhere".
intros.
apply continuous_func_continuous_everywhere; trivial.
Qed.

Lemma pointwise_continuity_2arg:
(forall (x:point_set X) (y:point_set Y),
continuous_at_2arg x y) -> continuous_2arg.
Proof. hammer_hook "ProductTopology" "ProductTopology.pointwise_continuity_2arg".
intros.
apply pointwise_continuity.
intros.
destruct x as [x y].
apply H.
Qed.

End two_arg_convenience_results.

Arguments continuous_2arg {X} {Y} {Z}.
Arguments continuous_at_2arg {X} {Y} {Z}.

Lemma continuous_composition_at_2arg:
forall (W X Y Z:TopologicalSpace)
(f:point_set X -> point_set Y -> point_set Z)
(g:point_set W -> point_set X) (h:point_set W -> point_set Y)
(w:point_set W),
continuous_at_2arg f (g w) (h w) ->
continuous_at g w -> continuous_at h w ->
continuous_at (fun w:point_set W => f (g w) (h w)) w.
Proof. hammer_hook "ProductTopology" "ProductTopology.continuous_composition_at_2arg".
intros.
apply (continuous_composition_at
(fun p:point_set (ProductTopology2 X Y) =>
let (x,y):=p in f x y)
(fun w:point_set W => (g w, h w))).
exact H.
apply product2_map_continuous; trivial.
Qed.