(* In this file, we construct the bicategory DAG of dagger categories as a displayed bicategory (over CAT) and we show that the displayed bicategory is univalent. *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.

Require Import UniMath.CategoryTheory.DaggerCategories.Categories.
Require Import UniMath.CategoryTheory.DaggerCategories.Functors.
Require Import UniMath.CategoryTheory.DaggerCategories.Transformations.
Require Import UniMath.CategoryTheory.DaggerCategories.Unitary.
Require Import UniMath.CategoryTheory.DaggerCategories.Univalence.
Require Import UniMath.CategoryTheory.DaggerCategories.FunctorCategory.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.

Local Definition CAT : bicat := bicat_of_cats.

Local Open Scope cat.

Section BicatOfDaggerCategories.

  Definition DAG_disp_cat_ob_mor
    : disp_cat_ob_mor CAT.
  Proof.
    exists (λ C, dagger C).
    exact (λ C D dC dD F, is_dagger_functor dC dD F).
  Defined.

  Definition DAG_disp_cat_id_comp
    : disp_cat_id_comp CAT DAG_disp_cat_ob_mor.
  Proof.
    exists (λ C dC, dagger_functor_id dC).
    exact (λ C D E F G dC dD dE dF dG, is_dagger_functor_comp dF dG).
  Qed.

  Definition DAG_disp_cat_data
    :  disp_cat_data CAT.
  Proof.
    exists DAG_disp_cat_ob_mor.
    exact DAG_disp_cat_id_comp.
  Defined.

  Definition DAG_disp_bicat : disp_bicat CAT
    := disp_cell_unit_bicat DAG_disp_cat_data.

  Definition DAG : bicat
    := total_bicat DAG_disp_bicat.

  Definition is_dagger_univalent (D : DAG)
    : UU
    := is_univalent_dagger (dagger_category_to_dagger D).

  Definition UDAG_disp_bicat : disp_bicat DAG
    := disp_fullsubbicat DAG (λ D, is_dagger_univalent D).

  Definition UDAG_sigma_disp_bicat := sigma_bicat _ _ UDAG_disp_bicat.

End BicatOfDaggerCategories.

Section Destructors.

  Definition DAG_to_cat (C : DAG) : category := pr1 C.
  Coercion DAG_to_cat : ob >-> category.

  Definition DAG_to_dagger (C : DAG) : dagger C := pr2 C.

End Destructors.

Section DaggerFunctorCategories.

  Local Definition hom_equals_dagger_functor_cat
             (C D : DAG)
    : hom C D = dagger_functor_cat (DAG_to_dagger C) (DAG_to_dagger D).
  Proof.
    use subtypePath.
    { intro ; apply isaprop_has_homsets. }
    use total2_paths_f.
    - apply idpath.
    - use proofirrelevance.
      repeat (apply isapropdirprod)
      ; repeat (apply impred_isaprop ; intro)
      ; apply (cellset_property (C := DAG)).
  Defined.

End DaggerFunctorCategories.

Section DagDisplayedUnivalence.

  Lemma DAG_disp_univalent_2_0 : disp_univalent_2_0 DAG_disp_bicat.
  Proof.
    intros C1 C2 p dag1 dag2.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros C udag1 udag2.
    apply isweqimplimpl.
    - intro a.
      apply dagger_equality.
      repeat (apply funextsec ; intro).
      apply (pr1 a _).
    - intro ; apply isaset_dagger.
    - intro a.
      apply (isaprop_disp_adjoint_equivalence_cell_unit_bicat a)
      ; apply isaprop_is_dagger_functor.
  Qed.

  Lemma DAG_disp_univalent_2_1 : disp_univalent_2_1 DAG_disp_bicat.
  Proof.
    apply disp_cell_unit_bicat_univalent_2_1.
    intro ; intros ; apply isaprop_is_dagger_functor.
  Qed.

  (* Notice that for global univalence, we don't use the premade lemma
     for disp_cell_unit_bicat, as is used in the local univalence.
     Otherwise, we would have to restrict ourselves to CatUniv instead of Cat
   *)

  Definition DAG_disp_univalent_2 : disp_univalent_2 DAG_disp_bicat
    := DAG_disp_univalent_2_0 ,, DAG_disp_univalent_2_1.

End DagDisplayedUnivalence.

Section Constructors.

  Definition make_dagger_transformation
             {C D : category}
             {F G : functor C D}
             (α : nat_trans F G)
             {dagC : dagger C} {dagD : dagger D}
             (dagF : is_dagger_functor dagC dagD F)
             (dagG : is_dagger_functor dagC dagD G)
    : (hom (C := DAG) (C,,dagC) (D,,dagD))
        ⟦make_dagger_functor _ _  dagF, make_dagger_functor _ _ dagG⟧
    := α ,, tt.

  Definition make_dagger_transformation'
             {C D : category}
             {F G : functor C D}
             {dagC : dagger C} {dagD : dagger D}
             (dagF : is_dagger_functor dagC dagD F)
             (dagG : is_dagger_functor dagC dagD G)
             {α : nat_trans_data F G}
             (αn : is_nat_trans _ _ α)
    : (hom (C := DAG) (C,,dagC) (D,,dagD))
        ⟦make_dagger_functor _ _ dagF, make_dagger_functor _ _ dagG⟧
    := make_nat_trans _ _ α αn ,, tt.

End Constructors.


(* The next couple of commands are from bool.v but their
needed to make sense of the first part of this file *)

Inductive bool : Type :=
	| true : bool
	| false: bool.

Definition negb (b:bool) : bool :=
  match b with
    | true => false
    | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => b2
    | false => false
   end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => true
    | false => b2
  end.

(* The Notation command defines a new symbolic notation for an existing definition *)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
    | true => negb b2
    | false => true
  end.

(* Every expression in Coq has a type, describing what sort of thing it computes.
The Check command asks Coq to print the type of an expression. *)

Check true.

Check negb true.

(* Functions like negb itself are also data values, just like true and false.
 Their types are called function types, and they are written with arrows. *)

Check negb.

(*  The response to the top can be read as: "Given an input of type bool, this function produces
 an output of type bool." *)

Check andb.

(* The types we have defined so far are examples of "enumerated types": their definitions explicitly
 enumerate a finite set of elements, each of which is just a bare constructor.*)

(* Compound types *)
Inductive rgb : Type :=
  | red : rgb (* Constructor expression *)
  | green : rgb (* Constructor expression *)
  | blue : rgb. (* Constructor expression *)

Inductive color : Type :=
  | black : color
  | white : color
  | primary : rgb -> color.

Definition monochrome (c:color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

(* TIP: Coq matches patterns in order from top to bottom *)

Definition isred (c:color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false (* "_" is the wildcard pattern *)
  end.

Example test_isred : (isred (primary red)) = true.
Proof. simpl. reflexivity. Qed.


From mathcomp Require Import all_ssreflect.
Require Export prosa.behavior.all.

(** In the following, we define a model of processors with variable execution
    speeds.

    NB: For now, the definition serves only to document how this can be done;
        it is not actually used anywhere in the library.  *)

Section State.

  (** Consider any type of jobs. *)
  Variable Job: JobType.

  (** We define the state of a variable-speed processor at a given time to be
      one of two possible cases: either a specific job is scheduled and
      progresses with a specific speed, or the processor is idle. *)
  Inductive processor_state :=
    Idle
  | Progress (j : Job) (speed : nat).

  (** Next, we define the semantics of the variable-speed processor state. *)
  Section Service.

    (** Consider any job [j]. *)
    Variable j : Job.

    (** Job [j] is scheduled in a given state [s] if [s] is not idle and [j]
        matches the job recorded in [s]. *)
    Definition varspeed_scheduled_on (s : processor_state) (_ : unit) : bool :=
      match s with
      | Idle => false
      | Progress j' _  => j' == j
      end.

    (** If it is scheduled in state [s], job [j] receives service proportional
        to the speed recorded in the state. *)
    Definition varspeed_service_in (s : processor_state) : nat :=
      match s with
      | Idle => 0
      | Progress j' speed  => if j' == j then speed else 0
      end.

  End Service.

  (** Finally, we connect the above definitions to the generic Prosa interface
      for processor states. *)
  Global Program Instance pstate_instance : ProcessorState Job processor_state :=
    {
      scheduled_on := varspeed_scheduled_on;
      service_in   := varspeed_service_in
    }.
  Next Obligation.
    move: H.
    case: s=>//= j' v /existsP.
    case: ifP=>//=_[].
    by exists.
  Defined.

End State.


Require Import init.

Require Export card_base.
Require Import card_order.
Require Import card_plus.
Require Import card_mult.
Require Import card_nat.
Require Import set.
Require Import zorn.
Require Import zorn_binary_function.
Require Import function.
Require Import nat.
Require Import order_minmax.
Require Import card_infinite1.

(* begin hide *)
Open Scope card_scope.

Module CardMultIdemp.
Section CardMultIdemp.

Variable A : Type.
Hypothesis A_inf : |nat| ≤ |A|.

Record fs := make_fs {
    fs_f : bin_set_function_type A A;
    fs_range : ∀ a b, bin_domain fs_f (fs_f⟨a, b⟩);
    fs_inj : ∀ a b c d, fs_f⟨a, b⟩ = fs_f⟨c, d⟩ → a = c ∧ b = d;
    fs_sur : ∀ c, bin_domain fs_f c → ∃ a b, fs_f⟨a, b⟩ = c;
}.

Definition fs_le f g := bin_func_le (fs_f f) (fs_f g).
Local Instance fs_le_class : Order fs := {
    le := fs_le
}.
Lemma fs_le_refl : ∀ f, f ≤ f.
Proof.
    intros f.
    unfold le; cbn.
    unfold fs_le.
    apply refl.
Qed.
Local Instance fs_le_refl_class : Reflexive le := {
    refl := fs_le_refl
}.
Lemma fs_le_antisym : ∀ f g, f ≤ g → g ≤ f → f = g.
Proof.
    intros f g.
    unfold le; cbn.
    unfold fs_le.
    intros fg gf.
    pose proof (antisym fg gf) as eq.
    destruct f as [f_f f_range f_inj f_sur].
    destruct g as [g_f g_range g_inj g_sur].
    cbn in *.
    subst.
    rewrite (proof_irrelevance f_range g_range).
    rewrite (proof_irrelevance f_inj g_inj).
    rewrite (proof_irrelevance f_sur g_sur).
    reflexivity.
Qed.
Local Instance fs_le_antisym_class : Antisymmetric le := {
    antisym := fs_le_antisym
}.
Lemma fs_le_trans : ∀ f g h, f ≤ g → g ≤ h → f ≤ h.
Proof.
    intros f g h.
    unfold le; cbn.
    unfold fs_le.
    apply trans.
Qed.
Local Instance fs_le_trans_class : Transitive le := {
    trans := fs_le_trans
}.

Section UpperBound.

Local Open Scope set_scope.

Variable C : fs → Prop.
Hypothesis C_chain : is_chain le C.

Definition C_union_set x := ∃ f, C f ∧ bin_domain (fs_f f) x.

Lemma combining_f_ex : ∀ x y : set_type (C_union_set),
    ∃ f, C f ∧ bin_domain (fs_f f) [x|] ∧ bin_domain (fs_f f) [y|].
Proof.
    intros [x [f1 [Cf1 f1x]]] [y [f2 [Cf2 f2y]]]; cbn.
    specialize (C_chain f1 f2 Cf1 Cf2) as [leq|leq].
    -   exists f2.
        repeat split; try assumption.
        apply leq.
        exact f1x.
    -   exists f1.
        repeat split; try assumption.
        apply leq.
        exact f2y.
Qed.

Definition C_union_f (x y : set_type (C_union_set)) :=
    fs_f (ex_val (combining_f_ex x y))⟨
        [_|land (rand (ex_proof (combining_f_ex x y)))],
        [_|rand (rand (ex_proof (combining_f_ex x y)))]
    ⟩.

Lemma all_equal : ∀ F G, C F → C G → ∀ a b
    (Fa : bin_domain (fs_f F) a) (Fb : bin_domain (fs_f F) b)
    (Ga : bin_domain (fs_f G) a) (Gb : bin_domain (fs_f G) b),
    (fs_f F)⟨[a|Fa], [b|Fb]⟩ = (fs_f G)⟨[a|Ga], [b|Gb]⟩.
Proof.
    intros F G CF CG a b Fa Fb Ga Gb.
    destruct (C_chain F G CF CG) as [[sub FG]|[sub GF]].
    -   specialize (FG [a|Fa] [b|Fb]); cbn in FG.
        rewrite (proof_irrelevance _ Ga) in FG.
        rewrite (proof_irrelevance _ Gb) in FG.
        exact FG.
    -   specialize (GF [a|Ga] [b|Gb]); cbn in GF.
        rewrite (proof_irrelevance _ Fa) in GF.
        rewrite (proof_irrelevance _ Fb) in GF.
        symmetry; exact GF.
Qed.

Lemma C_union_f_range : ∀ a b, C_union_set (C_union_f a b).
Proof.
    intros [x [f1 [Cf1 f1x]]] [y [f2 [Cf2 f2y]]]; cbn.
    unfold C_union_set, C_union_f; cbn.
    destruct (C_chain f1 f2 Cf1 Cf2) as [[sub leq]|[sub leq]];
        cbn in *; clear leq.
    -   exists f2.
        split; try assumption.
        unfold C_union_f; cbn.
        unfold ex_val, ex_proof.
        destruct (ex_to_type _) as [g [Cg [gx gy]]]; cbn.
        rewrite (proof_irrelevance _ gx).
        rewrite (proof_irrelevance _ gy).
        rewrite (all_equal g f2 Cg Cf2 x y gx gy (sub x f1x) f2y).
        apply (fs_range f2).
    -   exists f1.
        split; try assumption.
        unfold C_union_f; cbn.
        unfold ex_val, ex_proof.
        destruct (ex_to_type _) as [g [Cg [gx gy]]]; cbn.
        rewrite (proof_irrelevance _ gx).
        rewrite (proof_irrelevance _ gy).
        rewrite (all_equal g f1 Cg Cf1 x y gx gy (f1x) (sub y f2y)).
        apply (fs_range f1).
Qed.

Lemma C_union_f_inj : ∀ a b c d, C_union_f a b = C_union_f c d → a = c ∧ b = d.
Proof.
    intros [a Ca] [b Cb] [c Cc] [d Cd] eq.
    unfold C_union_f, ex_val, ex_proof in eq.
    destruct (ex_to_type _) as [f1 [Cf1 [f1a f1b]]].
    destruct (ex_to_type _) as [f2 [Cf2 [f2c f2d]]].
    cbn in *.
    rewrite (proof_irrelevance _ f1a) in eq.
    rewrite (proof_irrelevance _ f1b) in eq.
    rewrite (proof_irrelevance _ f2c) in eq.
    rewrite (proof_irrelevance _ f2d) in eq.
    destruct (C_chain f1 f2 Cf1 Cf2) as [[sub leq]|[sub leq]].
    -   rewrite leq in eq; cbn in eq.
        apply (fs_inj f2) in eq.
        destruct eq as [eq1 eq2].
        inversion eq1.
        inversion eq2.
        subst.
        split; apply set_type_eq; reflexivity.
    -   rewrite leq in eq; cbn in eq.
        apply (fs_inj f1) in eq.
        destruct eq as [eq1 eq2].
        inversion eq1.
        inversion eq2.
        subst.
        split; apply set_type_eq; reflexivity.
Qed.

Lemma C_union_f_sur : ∀ c, C_union_set c → ∃ a b, C_union_f a b = c.
Proof.
    intros c [f [Cf fc]].
    pose proof (fs_sur f c fc) as [[a fa] [[b fb] eq]].
    assert (C_union_set a) as Ca by (exists f; split; assumption).
    assert (C_union_set b) as Cb by (exists f; split; assumption).
    exists [a|Ca], [b|Cb].
    unfold C_union_f, ex_val, ex_proof.
    destruct (ex_to_type _) as [g [Cg [ga gb]]]; cbn in *.
    rewrite <- eq.
    apply all_equal; assumption.
Qed.

Lemma zorn_piece : has_upper_bound le C.
Proof.
    exists (make_fs
        (make_bin_set_function C_union_set C_union_f)
        C_union_f_range
        C_union_f_inj
        C_union_f_sur
    ).
    intros f Cf.
    unfold le; cbn.
    unfold fs_le; cbn.
    unfold bin_func_le; cbn.
    assert (bin_domain (fs_f f) ⊆ C_union_set) as sub.
    {
        intros x fx.
        exists f.
        split; assumption.
    }
    exists sub.
    intros [x fx] [y fy]; cbn.
    unfold C_union_f; cbn.
    unfold ex_val, ex_proof.
    destruct (ex_to_type _) as [g [Cg [gx gy]]]; cbn in *.
    rewrite (proof_irrelevance _ gx).
    rewrite (proof_irrelevance _ gy).
    specialize (C_chain f g Cf Cg) as [[sub2 fg]|[sub2 gf]].
    -   specialize (fg [x|fx] [y|fy]); cbn in fg.
        rewrite (proof_irrelevance _ gx) in fg.
        rewrite (proof_irrelevance _ gy) in fg.
        exact fg.
    -   specialize (gf [x|gx] [y|gy]); cbn in gf.
        rewrite (proof_irrelevance _ fx) in gf.
        rewrite (proof_irrelevance _ fy) in gf.
        symmetry; exact gf.
Qed.

End UpperBound.

Definition f := ex_val (zorn le zorn_piece).
Lemma f_max : ∀ g, ¬(f < g).
Proof.
    intros g.
    unfold f.
    rewrite_ex_val C0 H0. (* For some reason using H breaks it? *)
    apply H0.
Qed.

Definition X := bin_domain (fs_f f).

Lemma X_mult_idemp : |set_type X| * |set_type X| = |set_type X|.
Proof.
    unfold mult; equiv_simpl.
    exists (λ x, [fs_f f⟨fst x, snd x⟩ | fs_range f (fst x) (snd x)]).
    split; split.
    -   intros [a b] [c d] eq; cbn in *.
        inversion eq as [eq2].
        pose proof (fs_inj f a b c d eq2) as [eq3 eq4].
        subst.
        reflexivity.
    -   intros [y fy].
        pose proof (fs_sur f y fy) as [x1 [x2 x_eq]].
        exists (x1, x2).
        apply set_type_eq; cbn.
        exact x_eq.
Qed.

Lemma X_not_0 : |set_type X| ≠ 0.
Proof.
    intro contr.
    pose proof (card_le_sub _ _ A_inf) as [A' A'_eq].
    pose proof nat_mult_nat as eq.
    rewrite <- A'_eq in eq.
    unfold mult in eq; equiv_simpl in eq.
    destruct eq as [g g_bij].
    assert (∀ a b, A' [g (a, b)|]) as g_range.
    {
        intros a b.
        apply [|g (a, b)].
    }
    assert (∀ a b c d, [g (a, b)|] = [g (c, d)|] → a = c ∧ b = d) as g_inj.
    {
        intros a b c d eq.
        apply set_type_eq in eq.
        apply g_bij in eq.
        inversion eq.
        split; reflexivity.
    }
    assert (∀ c, A' c → ∃ a b, [g (a, b)|] = c) as g_sur.
    {
        intros c A'c.
        pose proof (sur g [c|A'c]) as [[a b] eq].
        exists a, b.
        rewrite eq.
        reflexivity.
    }
    apply (f_max (make_fs
        (make_bin_set_function A' (λ a b, [g (a, b)|]))
        g_range
        g_inj
        g_sur
    )).
    split.
    -   unfold le; cbn.
        unfold fs_le; cbn.
        assert (X = ∅)%set as X_empty.
        {
            apply empty_eq.
            intros x Xx.
            unfold zero in contr; cbn in contr.
            unfold nat_to_card in contr; equiv_simpl in contr.
            destruct contr as [f f_bij].
            contradiction (nat_lt_0_false (f [x|Xx])).
        }
        assert (X ⊆ A')%set as sub.
        {
            rewrite X_empty.
            apply empty_sub.
        }
        exists sub.
        intros a.
        unfold X in X_empty.
        exfalso.
        rewrite X_empty in a.
        destruct a; contradiction.
    -   intro contr2.
        assert (X = A') as X_eq.
        {
            unfold X.
            rewrite contr2.
            cbn.
            reflexivity.
        }
        rewrite X_eq in contr.
        rewrite contr in A'_eq.
        clear - A'_eq.
        pose proof (nat_is_finite 0) as [leq neq].
        contradiction.
Qed.

Lemma X_not_1 : |set_type X| ≠ 1.
Proof.
    intro contr.
    pose proof (card_le_sub _ _ A_inf) as [A' A'_eq].
    assert (|set_type (A' ∪ X)%set| = |set_type A'|) as A'X_eq.
    {
        apply antisym.
        -   apply (trans (card_plus_union _ _)).
            rewrite contr.
            rewrite inf_plus_fin.
            +   apply refl.
            +   rewrite A'_eq.
                apply refl.
            +   apply nat_is_finite.
        -   apply card_union_left.
    }
    rewrite <- A'X_eq in A'_eq.
    pose proof nat_mult_nat as eq.
    rewrite <- A'_eq in eq.
    unfold mult, plus in eq; equiv_simpl in eq.
    destruct eq as [g g_bij].
    assert (∃ x, X x) as [x Xx].
    {
        symmetry in contr.
        unfold one in contr; cbn in contr.
        unfold nat_to_card in contr; equiv_simpl in contr.
        destruct contr as [f f_bij].
        pose proof (nat_lt_suc 0) as one_pos.
        exists [f [0|one_pos]|].
        apply [|f [0|one_pos]].
    }
    assert (∀ y, X y → x = y) as x_unique.
    {
        intros y Xy.
        symmetry in contr.
        unfold one in contr; cbn in contr.
        unfold nat_to_card in contr; equiv_simpl in contr.
        destruct contr as [f f_bij].
        pose proof (sur f [x|Xx]) as [[m m_lt] m_eq].
        pose proof (sur f [y|Xy]) as [[n n_lt] n_eq].
        pose proof m_lt as m_lt2.
        pose proof n_lt as n_lt2.
        apply nat_lt_one_eq in m_lt2.
        apply nat_lt_one_eq in n_lt2.
        subst.
        rewrite (proof_irrelevance m_lt n_lt) in m_eq.
        rewrite m_eq in n_eq.
        inversion n_eq.
        reflexivity.
    }
    remember (g ([x|make_ror Xx], [x|make_ror Xx])) as gx.
    pose (g' (a b : (set_type (A' ∪ X)%set)) :=
        If a = [x|make_ror Xx] ∧ b = [x|make_ror Xx]
        then x
        else If g (a, b) = [x|make_ror Xx]
        then [gx|]
        else [g (a, b)|]).
    assert (∀ a b, (A' ∪ X)%set (g' a b)) as g_range.
    {
        intros a b.
        unfold g'.
        repeat case_if.
        -   right; exact Xx.
        -   apply [|gx].
        -   apply [|g (a, b)].
    }
    assert (∀ a b c d, g' a b = g' c d → a = c ∧ b = d) as g_inj.
    {
        intros [a a_in] [b b_in] [c c_in] [d d_in] eq.
        unfold g' in eq.
        case_if.
        -   case_if.
            +   destruct a0 as [eq1 eq2], a1 as [eq3 eq4].
                inversion eq1; inversion eq2; inversion eq3; inversion eq4.
                subst.
                split; apply set_type_eq; reflexivity.
            +   case_if.
                *   subst x.
                    destruct gx as [gx gx_in]; cbn in *.
                    rewrite (proof_irrelevance _ gx_in) in e.
                    rewrite Heqgx in e.
                    apply g_bij in e.
                    inversion e as [[eq1 eq2]].
                    subst.
                    exfalso; apply n; clear.
                    split; apply set_type_eq; reflexivity.
                *   subst x; clear g' g_range.
                    exfalso; apply n0; clear.
                    apply set_type_eq; cbn.
                    reflexivity.
        -   case_if.
            +   case_if.
                *   subst x.
                    destruct gx as [gx gx_in]; cbn in *.
                    rewrite (proof_irrelevance _ gx_in) in e.
                    rewrite Heqgx in e.
                    apply g_bij in e.
                    inversion e as [[eq1 eq2]].
                    subst.
                    exfalso; apply n; clear.
                    split; apply set_type_eq; reflexivity.
                *   case_if.
                    --  rewrite <- e0 in e.
                        apply g_bij in e.
                        inversion e as [[eq1 eq2]].
                        subst.
                        split; apply set_type_eq; reflexivity.
                    --  rewrite Heqgx in eq.
                        apply set_type_eq in eq.
                        apply g_bij in eq.
                        inversion eq as [[eq1 eq2]].
                        subst.
                        exfalso; apply n0.
                        split; apply set_type_eq; reflexivity.
            +   case_if.
                *   subst x.
                    exfalso; apply n0.
                    apply set_type_eq; cbn.
                    reflexivity.
                *   case_if.
                    --  rewrite Heqgx in eq.
                        apply set_type_eq in eq.
                        apply g_bij in eq.
                        inversion eq as [[eq1 eq2]].
                        subst.
                        exfalso; apply n.
                        split; apply set_type_eq; reflexivity.
                    --  apply set_type_eq in eq.
                        apply g_bij in eq.
                        inversion eq as [[eq1 eq2]].
                        subst.
                        split; apply set_type_eq; reflexivity.
    }
    assert (∀ c, (A' ∪ X)%set c → ∃ a b, g' a b = c) as g_sur.
    {
        intros c A'xc.
        classic_case (c = x) as [eq|neq].
        2: classic_case (c = [gx|]) as [eq|neq2].
        -   subst.
            exists [x|make_ror Xx], [x|make_ror Xx].
            unfold g'; cbn.
            case_if; try reflexivity.
            case_if.
            +   rewrite e.
                reflexivity.
            +   exfalso; apply n.
                split; reflexivity.
        -   subst c.
            pose proof (sur g [x|make_ror Xx]) as [[a b] eq].
            exists a, b.
            unfold g'; case_if.
            +   destruct a0; subst.
                rewrite eq in neq.
                contradiction.
            +   case_if; try reflexivity.
                contradiction.
        -   pose proof (sur g [c|A'xc]) as [[a b] eq].
            exists a, b.
            unfold g'.
            case_if.
            +   destruct a0; subst a b.
                rewrite <- Heqgx in eq.
                symmetry in eq.
                rewrite <- eq in neq2.
                contradiction.
            +   case_if.
                *   rewrite eq in e.
                    inversion e.
                    contradiction.
                *   rewrite eq.
                    reflexivity.
    }
    apply (f_max (make_fs
        (make_bin_set_function (A' ∪ X)%set g')
        g_range
        g_inj
        g_sur
    )).
    split.
    -   unfold le; cbn.
        unfold fs_le; cbn.
        exists (union_rsub _ _).
        intros [a Xa] [b Xb]; cbn.
        unfold g'.
        case_if.
        +   destruct a0 as [eq1 eq2].
            inversion eq1.
            inversion eq2.
            subst.
            symmetry; apply x_unique.
            apply (fs_range f).
        +   exfalso.
            rewrite not_and in n.
            destruct n as [neq|neq].
            *   apply neq.
                apply set_type_eq; cbn.
                symmetry; apply x_unique.
                exact Xa.
            *   apply neq.
                apply set_type_eq; cbn.
                symmetry; apply x_unique.
                exact Xb.
    -   intro contr2.
        assert (X = A' ∪ X)%set as XA'_eq.
        {
            unfold X.
            rewrite contr2.
            cbn.
            rewrite union_assoc.
            rewrite union_idemp.
            reflexivity.
        }
        clear contr2.
        assert (∃ y, A' y ∧ x ≠ y) as [y [A'y y_neq]].
        {
            rewrite A'X_eq in A'_eq.
            clear - A'_eq.
            symmetry in A'_eq.
            equiv_simpl in A'_eq.
            destruct A'_eq as [f f_bij].
            classic_case (x = [f 0|]) as [eq|neq].
            -   exists [f 1|].
                split.
                +   apply [|f 1].
                +   intro eq1; subst.
                    apply set_type_eq in eq1.
                    apply f_bij in eq1.
                    inversion eq1.
            -   exists [f 0|].
                split; try exact neq.
                apply [|f 0].
        }
        apply y_neq; clear y_neq.
        apply x_unique.
        rewrite XA'_eq.
        left.
        exact A'y.
Qed.

Section XInf.

Hypothesis contr : finite (|set_type X|).

Lemma X_fin_false : False.
Proof.
    apply fin_nat_ex in contr as [n eq1].
    assert (0 ≠ n) as n_neq_0.
    {
        intro contr; subst.
        symmetry in eq1.
        contradiction (X_not_0 eq1).
    }
    assert (1 ≠ n) as n_neq_1.
    {
        intro contr; subst.
        symmetry in eq1.
        contradiction (X_not_1 eq1).
    }
    pose proof X_mult_idemp as eq2.
    rewrite <- eq1 in eq2; clear eq1.
    rewrite nat_to_card_mult in eq2.
    apply nat_to_card_eq in eq2.
    nat_destruct n; try contradiction.
    nat_destruct n; try contradiction.
    clear n_neq_0 n_neq_1.
    rewrite nat_mult_lsuc in eq2.
    rewrite <- (plus_rid (nat_suc (nat_suc n))) in eq2 at 3.
    apply plus_lcancel in eq2.
    rewrite nat_mult_rsuc in eq2.
    rewrite nat_plus_lsuc in eq2.
    inversion eq2.
Qed.

End XInf.

Lemma X_inf : infinite (|set_type X|).
Proof.
    classic_contradiction contr.
    apply X_fin_false.
    unfold infinite in contr.
    rewrite nle_lt in contr.
    exact contr.
Qed.

Lemma X_ex : ∃ a, X a.
Proof.
    pose proof X_inf as inf.
    unfold infinite, le in inf; equiv_simpl in inf.
    destruct inf as [f f_inj].
    exists [f 0|].
    apply [|f 0].
Qed.

Lemma X_le : |set_type X| ≤ |A|.
Proof.
    unfold le; equiv_simpl.
    exists (λ x, [x|]).
    split.
    intros a b eq.
    apply set_type_eq in eq.
    exact eq.
Qed.

Section Contr.

Hypothesis contr : |set_type X| ≠ |A|.

Definition X' x := ¬X x.

Lemma XX'_eq : |set_type X| + |set_type X'| = |A|.
Proof.
    unfold plus; equiv_simpl.
    exists (λ x, match x with | inl x' => [x'|] | inr x' => [x'|] end).
    split; split.
    -   intros [[a Xa]|[a X'a]] [[b Xb]|[b X'b]] eq; cbn in eq; subst.
        +   apply f_equal.
            apply set_type_eq; reflexivity.
        +   contradiction.
        +   contradiction.
        +   apply f_equal.
            apply set_type_eq; reflexivity.
    -   intros c.
        classic_case (X c) as [Xc|X'c].
        +   exists (inl [c|Xc]); reflexivity.
        +   exists (inr [c|X'c]); reflexivity.
Qed.

Lemma X'_ge : |set_type X| ≤ |set_type X'|.
Proof.
    classic_contradiction ltq.
    rewrite nle_lt in ltq.
    apply contr.
    apply antisym; try exact X_le.
    rewrite <- XX'_eq.
    destruct ltq as [leq neq].
    apply le_lplus with (|set_type X|) in leq.
    apply (trans leq).
    rewrite <- (mult_lid (|set_type X|)) at 1 2.
    rewrite <- rdist.
    rewrite <- X_mult_idemp at 2.
    apply card_le_rmult.
    unfold one; cbn.
    rewrite nat_to_card_plus.
    apply (trans (land (nat_is_finite 2)) X_inf).
Qed.
Lemma f0_ex : ∃ f : set_type X → set_type X', Injective f.
Proof.
    pose proof X'_ge.
    unfold le in H; equiv_simpl in H.
    exact H.
Qed.

Definition f0 := ex_val f0_ex.
Definition Y y := ∃ x, [f0 x|] = y.

Lemma Y_eq : |set_type X| = |set_type Y|.
Proof.
    equiv_simpl.
    assert (∀ x, Y [f0 x|]) as f_in by (intro x; exists x; reflexivity).
    exists (λ x, [_|f_in x]).
    split; split.
    -   intros a b eq.
        inversion eq as [eq2].
        apply set_type_eq in eq2.
        apply (ex_proof f0_ex) in eq2.
        exact eq2.
    -   intros [y [x eq]].
        exists x.
        apply set_type_eq; cbn.
        exact eq.
Qed.

Lemma Y_eq2 :
    |set_type X| * |set_type Y| +
    |set_type Y| * |set_type X| +
    |set_type Y| * |set_type Y| = |set_type Y|.
Proof.
    rewrite <- Y_eq.
    rewrite X_mult_idemp.
    rewrite <- (mult_lid (|set_type X|)) at 1 2 3.
    do 2 rewrite <- rdist.
    assert (nat_to_card 3 = 2 + 1) as eq.
    {
        unfold one at 4 5 6; cbn.
        do 2 rewrite nat_to_card_plus.
        reflexivity.
    }
    rewrite <- eq; clear eq.
    apply antisym.
    -   rewrite <- X_mult_idemp at 2.
        apply card_le_rmult.
        pose proof (nat_is_finite 3) as three_fin.
        exact (trans (land three_fin) X_inf).
    -   rewrite <- (mult_lid (|set_type X|)) at 1.
        apply card_le_rmult.
        unfold one at 1; cbn.
        unfold nat_to_card, le; equiv_simpl.
        exists (λ (x : set_type (λ x, x < 1)),
            [[x|]|trans (trans [|x] (nat_lt_suc _)) (nat_lt_suc _)]).
        split.
        intros a b eq.
        apply set_type_eq.
        inversion eq.
        exact H0.
Qed.

Lemma f1_ex : ∃ f :
    set_type X * set_type Y +
    set_type Y * set_type X +
    set_type Y * set_type Y →
    set_type Y, Bijective f.
Proof.
    pose proof Y_eq2 as H.
    unfold plus, mult in H; equiv_simpl in H.
    exact H.
Qed.

Definition f1 := ex_val f1_ex.
Local Instance f1_bij : Bijective f1.
Proof.
    apply (ex_proof f1_ex).
Qed.

Local Open Scope set_scope.

Definition f_domain := X ∪ Y.

Definition f' (a b : set_type f_domain) :=
    match (or_to_strong _ _ [|a]), (or_to_strong _ _ [|b]) with
    | strong_or_left Xa, strong_or_left Xb => fs_f f⟨[[a|] | Xa], [[b|] | Xb]⟩
    | strong_or_left Xa, strong_or_right Yb => [f1 (inl (inl ([[a|] | Xa], [[b|] | Yb])))|]
    | strong_or_right Ya, strong_or_left Xb => [f1 (inl (inr ([[a|] | Ya], [[b|] | Xb])))|]
    | strong_or_right Ya, strong_or_right Yb => [f1 (inr ([[a|] | Ya], [[b|] | Yb]))|]
    end.

Lemma XY_not : ∀ a, X a → ¬ Y a.
Proof.
    intros a Xa Ya.
    destruct Ya as [c c_eq].
    pose proof [|f0 c] as H.
    rewrite c_eq in H.
    contradiction.
Qed.

Lemma f'_range : ∀ a b, f_domain (f' a b).
Proof.
    intros [a [Xa|Ya]] [b [Xb|Yb]].
    -   left.
        unfold f'; cbn.
        destruct (or_to_strong _ _ _) as [Xa'|Ya].
        1: destruct (or_to_strong _ _ _) as [Xb'|Yb].
        +   apply (fs_range f).
        +   contradiction (XY_not _ Xb Yb).
        +   contradiction (XY_not _ Xa Ya).
    -   right.
        unfold f'; cbn.
        destruct (or_to_strong _ _ _) as [Xa'|Ya].
        1: destruct (or_to_strong _ _ _) as [Xb|Yb'].
        +   contradiction (XY_not _ Xb Yb).
        +   apply [|f1 (inl (inl ([a|Xa'], [b|Yb'])))].
        +   contradiction (XY_not _ Xa Ya).
    -   right.
        unfold f'; cbn.
        destruct (or_to_strong _ _ _) as [Xa|Ya'].
        2: destruct (or_to_strong _ _ _) as [Xb'|Yb].
        +   contradiction (XY_not _ Xa Ya).
        +   apply [|f1 (inl (inr ([a|Ya'], [b|Xb'])))].
        +   contradiction (XY_not _ Xb Yb).
    -   right.
        unfold f'; cbn.
        destruct (or_to_strong _ _ _) as [Xa|Ya'].
        2: destruct (or_to_strong _ _ _) as [Xb|Yb'].
        +   contradiction (XY_not _ Xa Ya).
        +   contradiction (XY_not _ Xb Yb).
        +   apply [|f1 (inr ([a|Ya'], [b|Yb']))].
Qed.
Lemma f'_inj : ∀ a b c d, f' a b = f' c d → a = c ∧ b = d.
Proof.
    intros [a a_in] [b b_in] [c c_in] [d d_in] eq.
    unfold f' in eq; cbn in eq.
    destruct (or_to_strong _ _ _) as [Xa|Ya].
    all: destruct (or_to_strong _ _ b_in) as [Xb|Yb].
    all: destruct (or_to_strong _ _ c_in) as [Xc|Yc].
    all: destruct (or_to_strong _ _ d_in) as [Xd|Yd].
    -   apply (fs_inj f) in eq.
        destruct eq as [eq1 eq2].
        inversion eq1; inversion eq2.
        split; apply set_type_eq; assumption.
    -   pose proof (fs_range f [a|Xa] [b|Xb]) as Xf.
        rewrite eq in Xf.
        apply XY_not in Xf.
        pose proof [|f1 (inl (inl ([c|Xc], [d|Yd])))].
        contradiction.
    -   pose proof (fs_range f [a|Xa] [b|Xb]) as Xf.
        rewrite eq in Xf.
        apply XY_not in Xf.
        pose proof [|f1 (inl (inr ([c|Yc], [d|Xd])))].
        contradiction.
    -   pose proof (fs_range f [a|Xa] [b|Xb]) as Xf.
        rewrite eq in Xf.
        apply XY_not in Xf.
        pose proof [|f1 (inr ([c|Yc], [d|Yd]))].
        contradiction.
    -   pose proof (fs_range f [c|Xc] [d|Xd]) as Xf.
        rewrite <- eq in Xf.
        apply XY_not in Xf.
        pose proof [|f1 (inl (inl ([a|Xa], [b|Yb])))].
        contradiction.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
        subst.
        split; apply set_type_eq; reflexivity.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
    -   pose proof (fs_range f [c|Xc] [d|Xd]) as Xf.
        rewrite <- eq in Xf.
        apply XY_not in Xf.
        pose proof [|f1 (inl (inr ([a|Ya], [b|Xb])))].
        contradiction.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
        subst.
        split; apply set_type_eq; reflexivity.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
    -   pose proof (fs_range f [c|Xc] [d|Xd]) as Xf.
        rewrite <- eq in Xf.
        apply XY_not in Xf.
        pose proof [|f1 (inr ([a|Ya], [b|Yb]))].
        contradiction.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
    -   apply set_type_eq in eq; apply inj in eq.
        inversion eq.
        subst.
        split; apply set_type_eq; reflexivity.
Qed.
Lemma f'_sur : ∀ c, f_domain c → ∃ a b, f' a b = c.
Proof.
    intros c [Xc|Yc].
    -   pose proof (fs_sur f c Xc) as [[a Xa] [[b Xb] eq]].
        exists [a|make_lor Xa], [b|make_lor Xb].
        unfold f'; cbn.
        destruct (or_to_strong _ _ _) as [Xa'|Ya].
        1: destruct (or_to_strong _ _ _) as [Xb'|Yb].
        +   rewrite (proof_irrelevance Xa' Xa).
            rewrite (proof_irrelevance Xb' Xb).
            exact eq.
        +   clear eq.
            apply XY_not in Xb.
            contradiction.
        +   clear eq.
            apply XY_not in Xa.
            contradiction.
    -   pose proof (sur f1 [c|Yc])
            as [[[[[a Xa] [b Yb]] | [[a Ya] [b Xb]]] | [[a Ya] [b Yb]]] eq].
        +   exists [a|make_lor Xa], [b|make_ror Yb].
            unfold f'; cbn.
            destruct (or_to_strong _ _ _) as [Xa'|Ya].
            1: destruct (or_to_strong _ _ _) as [Xb|Yb'].
            *   exfalso; apply XY_not in Xb.
                contradiction.
            *   rewrite (proof_irrelevance Xa' Xa).
                rewrite (proof_irrelevance Yb' Yb).
                rewrite eq.
                reflexivity.
            *   clear eq; apply XY_not in Xa.
                contradiction.
        +   exists [a|make_ror Ya], [b|make_lor Xb].
            unfold f'; cbn.
            destruct (or_to_strong _ _ _) as [Xa|Ya'].
            2: destruct (or_to_strong _ _ _) as [Xb'|Yb].
            *   contradiction (XY_not _ Xa Ya).
            *   rewrite (proof_irrelevance Ya' Ya).
                rewrite (proof_irrelevance Xb' Xb).
                rewrite eq.
                reflexivity.
            *   contradiction (XY_not _ Xb Yb).
        +   exists [a|make_ror Ya], [b|make_ror Yb].
            unfold f'; cbn.
            destruct (or_to_strong _ _ _) as [Xa|Ya'].
            2: destruct (or_to_strong _ _ _) as [Xb|Yb'].
            *   contradiction (XY_not _ Xa Ya).
            *   contradiction (XY_not _ Xb Yb).
            *   rewrite (proof_irrelevance Ya' Ya).
                rewrite (proof_irrelevance Yb' Yb).
                rewrite eq.
                reflexivity.
Qed.

Lemma con : False.
Proof.
    pose (g := make_fs
        (make_bin_set_function f_domain f')
        f'_range
        f'_inj
        f'_sur
    ).
    apply (f_max g).
    split.
    -   unfold le; cbn.
        unfold fs_le.
        assert (bin_domain (fs_f f) ⊆ bin_domain (fs_f g)) as sub.
        {
            intros x fx.
            unfold g; cbn.
            left.
            exact fx.
        }
        exists sub.
        intros [a Xa] [b Xb]; cbn.
        unfold f'; cbn.
        destruct (or_to_strong _ _ _) as [Xa'|Ya].
        1: destruct (or_to_strong _ _ _) as [Xb'|Yb].
        +   rewrite (proof_irrelevance Xa Xa').
            rewrite (proof_irrelevance Xb Xb').
            reflexivity.
        +   destruct Yb as [c c_eq].
            pose proof [|f0 c] as X'b.
            rewrite c_eq in X'b.
            contradiction.
        +   destruct Ya as [c c_eq].
            pose proof [|f0 c] as X'a.
            rewrite c_eq in X'a.
            contradiction.
    -   intro eq.
        assert (bin_domain (fs_f f) = bin_domain (fs_f g)) as eq2.
        {
            subst g.
            rewrite eq.
            reflexivity.
        }
        destruct X_ex as [a Xa].
        assert (bin_domain (fs_f g) [f0 [a|Xa]|]) as fa_in.
        {
            right.
            exists [a|Xa].
            reflexivity.
        }
        rewrite <- eq2 in fa_in.
        pose proof [|f0 [a|Xa]] as H.
        contradiction.
Qed.

End Contr.

Lemma X_card : |set_type X| = |A|.
Proof.
    classic_contradiction contr.
    apply con.
    exact contr.
Qed.

Theorem card_mult_idemp : |A| * |A| = |A|.
Proof.
    rewrite <- X_card.
    apply X_mult_idemp.
Qed.

End CardMultIdemp.
End CardMultIdemp.
(* end hide *)
Theorem card_mult_idemp : ∀ κ, infinite κ → κ * κ = κ.
Proof.
    intros A A_inf.
    equiv_get_value A.
    apply CardMultIdemp.card_mult_idemp.
    exact A_inf.
Qed.

Theorem card_plus_lmax : ∀ κ μ, infinite κ → μ ≤ κ → κ + μ = κ.
Proof.
    intros κ μ κ_inf leq.
    apply antisym.
    -   apply le_lplus with κ in leq.
        apply (trans leq).
        rewrite <- (card_mult_idemp κ κ_inf) at 3.
        rewrite <- (mult_lid κ) at 1 2.
        rewrite <- rdist.
        unfold one; cbn.
        rewrite nat_to_card_plus.
        apply card_le_rmult.
        exact (trans (land (nat_is_finite _)) κ_inf).
    -   pose proof (refl (op := le) κ) as leq2.
        pose proof (card_le_zero μ) as leq3.
        pose proof (le_lrplus leq2 leq3) as leq4.
        rewrite plus_rid in leq4.
        exact leq4.
Qed.

Theorem card_plus_idemp : ∀ κ, infinite κ → κ + κ = κ.
Proof.
    intros κ κ_inf.
    apply (card_plus_lmax _ _ κ_inf).
    apply refl.
Qed.

Theorem card_mult_lmax : ∀ κ μ, infinite κ → 0 ≠ μ → μ ≤ κ → κ * μ = κ.
Proof.
    intros κ μ κ_inf μ_nz leq.
    apply antisym.
    -   rewrite <- (card_mult_idemp _ κ_inf) at 2.
        apply card_le_lmult.
        exact leq.
    -   rewrite <- (mult_rid κ) at 1.
        apply card_le_lmult.
        equiv_get_value μ.
        rename μ into A.
        assert A as x.
        {
            classic_contradiction contr.
            apply μ_nz; clear μ_nz.
            unfold zero; cbn; unfold nat_to_card; equiv_simpl.
            exists (λ x, (False_rect _ (nat_lt_0_false x))).
            split; split.
            -   intros a b eq.
                contradiction (nat_lt_0_false a).
            -   intros b.
                contradiction (contr b).
        }
        unfold one; cbn.
        unfold le, nat_to_card; equiv_simpl.
        exists (λ a, x).
        split.
        intros [a a_lt] [b b_lt] eq.
        apply set_type_eq; cbn.
        apply nat_lt_one_eq in a_lt.
        apply nat_lt_one_eq in b_lt.
        subst.
        reflexivity.
Qed.

Theorem card_plus_max : ∀ κ μ, infinite κ → infinite μ → κ + μ = max κ μ.
Proof.
    intros κ μ κ_inf μ_inf.
    unfold max; case_if.
    -   rewrite plus_comm.
        apply card_plus_lmax; assumption.
    -   rewrite nle_lt in n.
        destruct n.
        apply card_plus_lmax; assumption.
Qed.

Theorem card_mult_max : ∀ κ μ, infinite κ → infinite μ → κ * μ = max κ μ.
Proof.
    intros κ μ κ_inf μ_inf.
    unfold max; case_if.
    -   rewrite mult_comm.
        apply card_mult_lmax; try assumption.
        intro contr; subst.
        unfold infinite in κ_inf.
        pose proof (le_lt_trans κ_inf (nat_is_finite _)) as [C0 C1].
        contradiction.
    -   rewrite nle_lt in n.
        destruct n as [leq neq].
        apply card_mult_lmax; try assumption.
        intro contr; subst.
        unfold infinite in μ_inf.
        pose proof (le_lt_trans μ_inf (nat_is_finite _)) as [C0 C1].
        contradiction.
Qed.

Theorem card_inf_plus_mult : ∀ κ μ, infinite κ → infinite μ → κ + μ = κ * μ.
Proof.
    intros κ μ κ_inf μ_inf.
    rewrite card_plus_max by assumption.
    rewrite card_mult_max by assumption.
    reflexivity.
Qed.
(* begin hide *)
Close Scope card_scope.
(* end hide *)


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions sub.


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

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

Print Assumptions mul.


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

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

Print Assumptions sub.


Require Import SMTC.Tactic.
Require Import SMTC.Integers.
Require Import Coq.Strings.String.
Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.RIneq.
Set SMT Solver "z3".
Set SMT Debug.

Local Open Scope Z_scope.

Goal forall x y, x + y = y + x.
Proof.
  intros.
  smt solve.
Abort.

Goal Int64.max_unsigned + 1 = (Int.max_unsigned+1) * (Int.max_unsigned+1).
Proof.
  intros.
  smt solve.
Abort.

Goal forall x y, Int64.eq x y = true -> x = y.
Proof.
  intros.
  smt solve.
Abort.

Goal Int64.ltu (Int64.modu (Int64.repr 8) (Int64.repr Int.modulus)) Int64.iwordsize = true.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x:Z, x > 0.
Proof.
  intros.
  Fail smt solve.
Abort.

Goal forall v0 v1,
   (Int64.unsigned v0 <= 255)%Z ->
   (Int64.unsigned v1 <= 255)%Z ->
   (Int64.unsigned (Int64.add v0 (Int64.shl v1 (Int64.modu (Int64.repr 8) (Int64.repr Int.modulus)))) <=? Int.max_unsigned = true)%Z.
Proof.
  intros.
  smt solve.
Abort.

Goal 1 = 1.
Proof.
  intros.
  smt solve.
Abort.

Goal Int64.one = Int64.and Int64.one Int64.one.
Proof.
  intros.
  smt solve.
Abort.

Goal forall (n'''': int64) (x: Z), n'''' = Int64.and Int64.one Int64.one /\ x = 1 -> n'''' = Int64.one /\ x = 1.
Proof.
  intros.
  smt solve.
Abort.

Goal forall n: Z, n * 3 = 123 -> n = 41.
Proof.
  intros.
  smt solve.
Abort.

Goal forall (n: int64) (x: Z), n = Int64.and Int64.one Int64.one -> x = 1 -> x = Int64.unsigned n.
Proof.
  intros.
  smt solve.
Abort.

Goal forall (n: int64), n = Int64.repr (Int64.unsigned n).
Proof.
  intros.
  smt solve.
Abort.

Goal forall b: bool, b = b.
Proof.
  intros.
  smt solve.
Abort.

Goal true = false.
Proof.
  intros.
  Fail smt solve.
Abort.

Goal forall i0 i,
    Int64.ltu i0 i = false ->
    Int64.unsigned (Int64.add (Int64.divu (Int64.sub i0 i) (Int64.repr 2)) i) =
    (Int64.unsigned i + Int64.unsigned i0) /2.
Proof.
  intros.
(*   smt solve. *)
Abort.

Goal forall A B : Prop, A /\ B -> B.
Proof.
  intros.
  smt solve.
Abort.

Goal forall A B : Prop, True -> False -> A /\ B.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x : Z, x < 0 -> x + x < x.
Proof.
  intros.
  smt solve.
Abort.

Goal Z.neg (5) = -5.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x : Z, x = -1 \/ ~(x = -1).
Proof.
  intros.
  smt solve.
Abort.

Goal forall n: int, Int.and n (Int.repr 3) = Int.zero ->
  Int.and (Int.add n (Int.repr 4)) (Int.repr 3) = Int.zero.
Proof.
  intros.
  smt solve.
Abort.

Goal forall n: int64, Int64.and n (Int64.repr 3) = Int64.zero ->
  Int64.and (Int64.add n (Int64.repr 4)) (Int64.repr 3) = Int64.zero.
Proof.
  intros.
  smt solve.
Abort.

Goal forall n:int64, Int64.or n Int64.zero = n.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x y, (Int64.ltu x y = false) -> Int64.ltu y x = true \/ x = y.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x y, (Int.ltu x y = false) -> Int.ltu y x = true \/ x = y.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x, Int64.zero = x -> x = Int64.repr 0.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x, Int.zero = x -> x = Int.repr 0.
Proof.
  intros.
  smt solve.
Abort.

Goal forall (n:int) (m:int64), Int.unsigned n = 2 * Int64.unsigned m.
Proof.
  intros.
  Fail smt solve.
Abort.

Goal forall x:Z, x >= 0 -> x = Z.of_nat (Z.to_nat x).
Proof.
  intros.
  smt solve.
Abort.

Goal  Int.signed (Int.repr(-1)) = -1.
Proof.
  intros.
  smt solve.
Abort.

Goal  Int64.signed (Int64.repr(-1)) = -1.
Proof.
  intros.
  smt solve.
Abort.

Goal Int64.signed (Int64.add (Int64.repr(2-5)) (Int64.repr(-1))) = -4.
Proof.
  intros.
  smt solve.
Abort.

Goal forall n:int8, 0 <= Byte.unsigned n < 256.
Proof.
  intros.
  smt solve.
Abort.

Goal forall z, -128 <= z < 128 -> Byte.signed (Byte.repr (z)) = z.
Proof.
  intros.
  smt solve.
Abort.

Goal Byte.signed (Byte.repr 255) = -1.
Proof.
  intros.
  smt solve.
Abort.

Goal forall n:int8, -128 <= Byte.signed n < 128.
Proof.
  intros.
  smt solve.
Abort.

Goal forall a b, a >= 0 -> b >= 0 -> Z.modulo a b = Z.rem a b.
Proof.
  intros.
  smt solve.
Abort.

Goal Z.modulo 8 3 = 2 /\ Z.modulo (-8) 3 = 1 /\ Z.modulo 8 (-3) = -1 /\ Z.modulo (-8) (-3) = (-2) /\
     Z.rem 8 3 = 2 /\ Z.rem (-8) 3 = -2 /\ Z.rem 8 (-3) = 2 /\ Z.rem (-8) (-3) = (-2).
Proof.
  intros.
  smt solve.
Abort.

Goal forall x n, n < 0 -> Z.pow x n = 0.
Proof.
  intros.
  smt solve.
Abort.

Goal Z.shiftr (Z.shiftl 1 64) 60 = 16.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x, Z.pow x 1 = x.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x, Z.pow x 0 = 1.
Proof.
  intros.
(*   smt solve. *) (* z3' bug *)
Abort.

Goal forall x m n, Z.shiftl m x * Z.shiftl n x = Z.shiftl (m + n) x.
Proof.
  intros.
(*   smt solve. *) (* z3' bug *)
Abort.

Goal forall x, Z.shiftl 1 x = Z.pow 2 x.
Proof.
  intros.
(*   smt solve. *) (* z3' bug *)
Abort.

Local Open Scope nat_scope.

Goal forall x y, x + y = y + x.
Proof.
  intros.
  smt solve.
Abort.

Goal 1 + 3 - 2 * 4 = 0.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x:nat, x = Z.to_nat (Z.of_nat x).
Proof.
  intros.
  smt solve.
Abort.

Goal forall x:nat, x - 5 >= 0.
Proof.
  intros.
  smt solve.
Abort.

Inductive my_type:Type :=
  | my_O : my_type
  | my_S : my_type -> my_type.

Definition my_eq: my_type -> my_type -> Prop :=
  fun a b => a = b.

Goal forall A B, A /\ B -> A.
Proof.
  intros.
  smt solve.
Abort.

Goal forall B, (my_eq (my_S my_O) (my_O)) /\ B -> (my_eq (my_S my_O) (my_O)).
Proof.
  intros.
  smt solve.
Abort.

Goal forall B, (my_eq (my_S my_O) (my_O)) /\ B -> (my_eq (my_S my_O) (my_S my_O)).
Proof.
  intros.
  Fail smt solve.
Abort.

Local Open Scope R_scope.

Goal forall x y: R, x + y = y + x.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x : R, ~(x = -1).
Proof.
  intros.
  Fail smt solve.
Abort.

Goal forall x : R, x < 0 -> x + x < x.
Proof.
  intros.
  smt solve.
Abort.

Goal forall x : R, ~(x = 1).
Proof.
  intros.
  Fail smt solve.
Abort.

Goal forall x: R, 1/2 * 2/3 * 3/4 * 4/5 * 5/x = 1/x.
Proof.
  intros.
  smt solve.
Abort.


(* From Coq Require Import Arith.Arith. *)
From Coq Require Import Reals.Reals.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Require Coq.Classes.RelationClasses.

From LF Require Import Utils.
From LF Require Import App.

(** Terminal (position) in the input sentence *)
Definition term := nat.

(** Symbol assigned to a node in the grammar *)
Inductive symbol {nt t} : Type :=
  | NonTerm (x : nt)
  | Terminal (x : option t). (* terminal can be empty ([None]) *)

(** Weight represented as a real number *)
Definition weight := R.

(** We switch the scope to correctly interpret certain notation, e.g. "<=" *)
Open Scope R_scope.
(* About "<=". *)

(** Grammar representation.

The grammar is polymorphic on the vertex type ([vert]) and the non-terminal
type ([non_term]).  Making the grammar [vert] polymorphic makes it safe to
specify the grammar in terms of total functions ([root], [leaf], etc.).

Whatever we prove for this grammar representation should also hold in the
(sane) case where the vertex set is finite ([vert] can be in general
instantiated with a finite type).

In this grammar representation we assume no grammar compression at all.
That is, each node belongs to exactly one elementary tree (ET).
*)
Record Grammar {vert non_term : Type} := mkGram
  { vertices : list vert
      (* the list (=>set) of vertices in the grammar *)
  ; terminals : list term
      (* the list (=>set) of terminals in the grammar *)

  ; term_max : term
      (* the last position in the sentence *)
  ; term_max_correct : maximum terminals = Some term_max
  ; term_min_correct : minimum terminals = Some O (* O = Peano.0 *)

  ; root : vert -> bool
      (* is the given node a root of an ET? *)
  ; leaf : vert -> bool
      (* is the given node a leaf of an ET? *)
  ; sister : vert -> bool
      (* is the given node marked as a sister node? *)
  ; foot : vert -> bool
      (* is the given node marked as a sister node? *)
  ; anchor : vert -> term
      (* anchor terminal of the ET containing the given node *)
  ; label : vert -> @symbol non_term term
      (* node labeling function (either non-terminal or terminal
         is assigned to each vertex) *)

  ; root_non_term : forall v,
      root v = true ->
        exists x, label v = NonTerm x
      (* label assigned to a root is a non-terminal *)
  ; sister_is_root : forall v,
      sister v = true -> root v = true
      (* only root can be marked as a sister node *)
  ; foot_is_non_term_leaf : forall v,
      foot v = true ->
        leaf v = true /\ exists x, label v = NonTerm x
      (* only non terminal leaf can be marked as a sister node *)

  ; parent : vert -> option vert
      (* parent of the given vertex (root => None) *)
  ; children : vert -> list vert
      (* the list of children of the given vertex (leaf => nil) *)

  ; inf : vert -> list term
      (* the list (=>set) of terminals under and in the given node. *)
  ; sup : vert -> list term
      (* the list (=>set) of terminals over the given node. *)
  ; inf_plus_sup :
      forall n : vert,
        inf n ++ sup n = [anchor n]
      (* We assume that there is a single anchor in each ET;
         hence, the set of inferior plus the set of superior
         nodes will always contain this unique anchor. *)

  ; inf_root_anchor : forall v,
      root v = true ->
        inf v = [anchor v]
      (* [inf] of the grammar root contains its single anchor terminal *)

  ; inf' : vert * nat -> list term
      (* the list (=>set) of the processed terminals
         for the given dotted rule *)
  ; sup' : vert * nat -> list term
      (* the list (=>set) of the terminals remaining to match after
         for the given dotted rule *)
  ; inf_plus_sup' :
      forall (r : vert * nat),
        inf' r ++ sup' r = [anchor (fst r)]
      (* analog of [inf_plus_sup] for dotted rules *)

  ; tree_weight : vert -> weight
      (* weight of the ET containing the given node *)
  ; arc_weight : term -> term -> weight
      (* weight of the given (dependency, head) arc *)

  (** Some functions (e.g. [arc_weight], [min_tree_weight]) take terminals
     as arguments.  TODO: make sure this is safe and explain why.
  *)

  ; min_tree_weight : term -> weight
      (* minimal ET weight for the given terminal *)
  ; min_arc_weight : term -> weight
      (* minimal dependency weight for the given dependent *)

  ; min_tree_weight_le :
      forall (v : vert) (t : term),
        anchor v = t ->
          min_tree_weight t <= tree_weight v
      (* minimal ET weight smaller than others *)
  ; min_arc_weight_le :
      forall (dep hed : term),
        min_arc_weight dep <= arc_weight dep hed
      (* minimal dependency weight smaller than others *)
  ; min_tree_weight_ge_0 :
      forall (t : term),
        0 <= min_tree_weight t
      (* minimal ET weight at least 0 *)
  ; min_arc_weight_ge_0 :
      forall (dep : term),
        0 <= min_arc_weight dep
      (* minimal dependency weight at least 0 *)

  ; shift : vert * nat -> option (vert * (vert * nat))
      (* shift the dot in the dotted rule (if possible) *)

  (** Below follow various shift-related and other additional properties.
      The is not necessarily the smallest set!  Some properties could be
      possibly proved in terms of the others.
  *)

  ; shift_preserves_head : forall r r' v,
      shift r = Some (v, r') ->
        fst r = fst r'

  ; shift_inf : forall r r' v,
      shift r = Some (v, r') ->
        inf' r ++ inf v = inf' r'

  ; shift_inf_passive : forall r,
      shift r = None ->
        inf' r = inf (fst r)

(*
  ; shift_term_inf : forall r r' v i,
      shift r = Some (v, r') ->
      label v = Terminal (Some i) ->
        inf' r' = inf' r ++ [i]

  ; shift_empty_inf : forall r r' v,
      shift r = Some (v, r') ->
      label v = Terminal None ->
        inf' r' = inf' r
*)

  ; shift_non_term_leaf_inf : forall r r' v x,
      shift r = Some (v, r') ->
      leaf v = true ->
      label v = NonTerm x ->
        inf v = [] /\ inf' r' = inf' r

  ; no_shift_inf : forall r,
      shift r = None ->
        inf' r = inf (fst r)

  ; term_inf : forall v i,
      label v = Terminal (Some i) ->
        inf v = [i]

  ; empty_inf : forall v,
      label v = Terminal None ->
        inf v = []

  ; shift_preserves_tree_weight : forall l v l',
      shift l = Some (v, l') ->
        tree_weight v = tree_weight (fst l')

  ; shift_preserves_anchor : forall l v l',
      shift l = Some (v, l') ->
        anchor v = anchor (fst l')
  }.

(**
  Additional definitions
**)

(** Weight of the given (dependent, head) arc +
    weight of the dependent ET
*)
Definition omega {vt nt}
    (g : @Grammar vt nt) (dep gov : vt) : weight :=
  arc_weight g (anchor g dep) (anchor g gov) +
  tree_weight g dep.

(** The list (=>set) of production rules in the grammar *)
Definition rules {vt nt} (g : @Grammar vt nt) : list (vt*nat) :=
  let
    f v :=
      if leaf g v
      then None
      else Some (v, O)
  in
    map_maybe f (vertices g).

(**
  Various additional properties stemming from the grammar representation
**)

(** ET weight at least 0 *)
Lemma tree_weight_ge_0 : forall {vt nt}
  (g : @Grammar vt nt) (v : vt),
    0 <= tree_weight g v.
Proof.
  intros vt nt g v.
  apply (Rle_trans _ (min_tree_weight g (anchor g v))).
  - apply min_tree_weight_ge_0.
  - apply min_tree_weight_le. reflexivity.
Qed.

(** arc weight at least 0 *)
Lemma arc_weight_ge_0 : forall {vt nt}
  (g : @Grammar vt nt) x y,
    0 <= arc_weight g x y.
Proof.
  intros vt nt g x y.
  apply (Rle_trans _ (min_arc_weight g x)).
  - apply min_arc_weight_ge_0.
  - apply min_arc_weight_le.
Qed.

Lemma shift_term_inf : forall {vt nt}
  (g : @Grammar vt nt) (r r' : vt*nat) v i,
    shift g r = Some (v, r') ->
    label g v = Terminal (Some i) ->
      inf' g r' = inf' g r ++ [i].
Proof.
  intros vt nt g r r' v i.
  intros Sh Lb.
  apply shift_inf in Sh as Inf.
  rewrite <- Inf.
  apply app_pref_eq'.
  apply term_inf.
  apply Lb.
Qed.

Lemma shift_empty_inf : forall {vt nt}
  (g : @Grammar vt nt) (r r' : vt*nat) v,
    shift g r = Some (v, r') ->
    label g v = Terminal None ->
      inf' g r' = inf' g r.
Proof.
  intros vt nt g r r' v.
  intros Sh Lb.
  apply shift_inf in Sh as Inf.
  rewrite <- Inf.
  rewrite <- app_nil_r.
  apply app_pref_eq'.
  apply empty_inf.
  apply Lb.
Qed.

(** [inf'] can contain at most one terminal *)
Lemma inf'_tail_empty : forall {vt nt}
  (g : @Grammar vt nt) (r : vt * nat) x l,
    inf' g r = x :: l ->
      l = [].
Proof.
  intros vt nt g r x l.
  intros H.
  destruct (inf' g r) as [|x' l'] eqn:E.
  - discriminate H.
  - injection H as H1 H2.
    apply (app_pref_eq_r' _ _ (sup' g r)) in E.
    rewrite inf_plus_sup' in E.
    simpl in E. injection E as E.
    rewrite H2 in H.
    destruct l as [|h t] eqn:E'.
    + reflexivity.
    + simpl in H. discriminate H.
Qed.

Lemma shift_one_empty :  forall {vt nt}
  (g : @Grammar vt nt) (r r' : vt * nat) v,
      shift g r = Some (v, r') ->
        inf g v = [] \/ inf' g r = [].
Proof.

  intros vt nt g r r' v.
  intros H1.
  apply shift_inf in H1 as H2.
  destruct (inf' g r') as [|h t] eqn:E1.

  - destruct (inf' g r) as [|h' t'] eqn:E2.
    + right. reflexivity.
    + simpl in H2. discriminate H2.

  - apply inf'_tail_empty in E1 as E2.
    rewrite E2 in E1. rewrite E2 in H2.

    destruct (inf' g r) as [|h' t'] eqn:E3.
      + right. reflexivity.
      + simpl in H2.
        injection H2 as H3 H4.

        destruct t'.
        * simpl in H4. left. apply H4.
        * simpl in H4.  discriminate H4.
Qed.

Lemma shift_inf' :  forall {vt nt}
  (g : @Grammar vt nt) (r r' : vt * nat) v,
      shift g r = Some (v, r') ->
        inf g v ++ inf' g r = inf' g r'.
Proof.
  intros vt nt g r r' v H.

  destruct (inf' g r) as [|h t] eqn:E1.

  * rewrite <- E1.
    rewrite <- (shift_inf g r r' v).
    Focus 2. apply H.
    destruct (inf' g r) as [|h t] eqn:E2.
    - simpl. rewrite app_nil_r. reflexivity.
    - discriminate E1.

  * rewrite <- (shift_inf g r r' v).
    Focus 2. apply H.
    rewrite E1.

    destruct (inf g v) as [|h' t'] eqn:E2.
    - simpl. rewrite app_nil_r. reflexivity.
    - apply shift_one_empty in H as [H1 | H2].
      + rewrite H1 in E2. discriminate E2.
      + rewrite H2 in E1. discriminate E1.

Qed.

Lemma shift_sup_passive :  forall {vt nt}
  (g : @Grammar vt nt) (r : vt * nat),
    shift g r = None ->
      sup' g r = sup g (fst r).
Proof.
  (* NOTE: maybe a simpler proof could be devised? *)
  intros vt nt g r. intros H1.
  apply shift_inf_passive in H1 as H2.
  apply (app_pref_eq_r' _ _ (sup' g r)) in H2 as H3.
  apply (app_pref_eq_r' _ _ (sup g (fst r))) in H2.
  rewrite inf_plus_sup in H2.
  rewrite inf_plus_sup' in H3.
  rewrite H3 in H2.
  apply shift_inf_passive in H1 as H4.
  rewrite H4 in H2.
  apply (app_pref_eq) in H2.
  rewrite H2. reflexivity.
Qed.

Lemma head_inf_sup_eq : forall {vt nt}
    (g : @Grammar vt nt) (r r' : vt * nat),
  fst r' = fst r ->
    inf' g r' ++ sup' g r' = inf' g r ++ sup' g r.
Proof.
  intros vt nt g r r'. intros H.
  rewrite inf_plus_sup'.
  rewrite inf_plus_sup'.
  rewrite H. reflexivity.
Qed.

Lemma shift_non_term_leaf_sup : forall {vt nt}
  (g : @Grammar vt nt) r r' v x,
    shift g r = Some (v, r') ->
    leaf g v = true ->
    label g v = NonTerm x ->
      sup' g r' = sup' g r.
Proof.
  intros vt nt g r r' v x.
  intros Sh H H'.
  move Sh after H'.
  apply (shift_non_term_leaf_inf _ _ _ _ x) in Sh as E.
  destruct E as [_ InfEq].
  Focus 2. apply H. Focus 2. apply H'.
  apply shift_preserves_head in Sh as Head.
  apply (head_inf_sup_eq g) in Head as E.
  rewrite InfEq in E.
  apply app_pref_eq in E.
  rewrite E. reflexivity.
Qed.

Lemma shift_sup : forall {vt nt}
    (g : @Grammar vt nt) (r r' : vt*nat) (v : vt),
  shift g r' = Some (v, r) ->
    sup' g r' = inf g v ++ sup' g r.
Proof.
  intros vt nt g r r' w H.
  destruct (shift g r') as [r''|] eqn:E.
  - apply app_pref_eq with (pref := inf' g r').
    rewrite app_assoc.
    rewrite shift_inf with (r'0 := r).
    + apply head_inf_sup_eq.
      apply shift_preserves_head with (g0 := g) (v := w).
      rewrite E. apply H.
    + rewrite E. apply H.
  - discriminate H.
Qed.

Lemma shift_sup' : forall {vt nt}
    (g : @Grammar vt nt) (r r' : vt*nat) (v : vt),
  shift g r' = Some (v, r) ->
    sup g v = inf' g r' ++ sup' g r.
Proof.
  intros vt nt g r r' v H.
  destruct (shift g r') as [r''|] eqn:E.
  - apply app_pref_eq with (pref := inf g v).
    rewrite app_assoc. rewrite H in E.
    apply shift_inf' in E as E1.
    rewrite E1.
    rewrite inf_plus_sup.
    rewrite inf_plus_sup'.
    apply shift_preserves_anchor in E as E2.
    rewrite E2. reflexivity.
  - discriminate H.
Qed.

Lemma sup_destr : forall {vt nt}
  (g : @Grammar vt nt) (v : vt) (x : nat) (l : list nat),
    sup g v = x :: l ->
      x = anchor g v /\ l = [].
Proof.
  intros vt nt g v x l.
  intros H.
  apply (app_pref_eq' _ _ (inf g v)) in H as H'.
  rewrite inf_plus_sup in H'.
  destruct (inf g v) eqn:E.
  - simpl in H'.
    inversion H'.
    split.
    + reflexivity.
    + reflexivity.
  - inversion H'.
    destruct l0 eqn:E'.
    + simpl in H2. discriminate H2.
    + simpl in H2. discriminate H2.
Qed.

Lemma sup'_destr : forall {vt nt}
  (g : @Grammar vt nt) (r : vt*nat) (x : nat) (l : list nat),
    sup' g r = x :: l ->
      x = anchor g (fst r) /\ l = [].
Proof.
  intros vt nt g r x l.
  intros H.
  apply (app_pref_eq' _ _ (inf' g r)) in H as H'.
  rewrite inf_plus_sup' in H'.
  destruct (inf' g r) eqn:E.
  - simpl in H'.
    inversion H'.
    split.
    + reflexivity.
    + reflexivity.
  - inversion H'.
    destruct l0 eqn:E'.
    + simpl in H2. discriminate H2.
    + simpl in H2. discriminate H2.
Qed.

Lemma sup_root : forall {vt nt}
  (g : @Grammar vt nt) v,
    root g v = true ->
      sup g v = [].
Proof.
  intros vt nt g v H.
  apply (app_pref_eq _ _ (inf g v)).
  apply inf_root_anchor in H.
  rewrite inf_plus_sup.
  rewrite app_nil_r.
  rewrite <- H. reflexivity.
Qed.

Lemma sup'_root : forall {vt nt}
  (g : @Grammar vt nt) r,
    root g (fst r) = true ->
    shift g r = None ->
      sup' g r = [].
Proof.
  intros vt nt g r H1 H2.
  apply sup_root in H1.
  apply shift_sup_passive in H2.
  rewrite H1 in H2.
  apply H2.
Qed.

Lemma omega_ge_0 : forall {vt nt}
  (g : @Grammar vt nt) v u,
    0 <= omega g v u.
Proof.
  intros vt nt g v u.
  unfold omega.
  rewrite <- (Rplus_0_l 0).
  apply Rplus_le_compat.
  - apply arc_weight_ge_0.
  - apply tree_weight_ge_0.
Qed.

Close Scope R_scope.


(** * Zero Objects
  Zero objects are objects of precategory which are both initial objects and
  terminal object. *)
(** ** Contents
- Definition of Zero
- Coincides with the direct definition
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.initial.
Require Import UniMath.CategoryTheory.limits.graphs.terminal.
Require Import UniMath.CategoryTheory.limits.zero.

Local Open Scope cat.

(** * Definition of zero using limits and colimits *)
Section def_zero.

  Context {C : category}.

  (** An object c is zero if it initial and terminal. *)
  Definition isZero (c : C) : UU := (isInitial C c) × (isTerminal C c).

  (** Construction of isZero for an object c from the conditions that the space
    of all morphisms from c to any object d is contractible and and the space of
    all morphisms from any object d to c is contractible. *)
  Definition make_isZero (c : C) (H : (∏ (d : C), iscontr (c --> d))
                                      × (∏ (d : C), iscontr (d --> c))) :
    isZero c := make_isInitial c (dirprod_pr1 H),,make_isTerminal c (dirprod_pr2 H).

  (** Definition of Zero. *)
  Definition Zero : UU := ∑ c : C, isZero c.
  Definition make_Zero (c : C) (H : isZero c) : Zero := tpair _ c H.
  Definition ZeroObject (Z : Zero) : C := pr1 Z.

  (** Construction of Initial and Terminal from Zero. *)
  Definition Zero_to_Initial (Z : Zero) : Initial C :=
    make_Initial (pr1 Z) (dirprod_pr1 (pr2 Z)).
  Definition Zero_to_Terminal (Z : Zero) : Terminal C :=
    make_Terminal (pr1 Z) (dirprod_pr2 (pr2 Z)).

  (** The following lemmas show that the underlying objects of Initial
    and Terminal, constructed above, are equal to ZeroObject. *)
  Lemma ZeroObject_equals_InitialObject (Z : Zero) :
    ZeroObject Z = InitialObject (Zero_to_Initial Z).
  Proof.
    apply idpath.
  Defined.

  Lemma ZeroObject_equals_TerminalObject (Z : Zero) :
    ZeroObject Z = TerminalObject (Zero_to_Terminal Z).
  Proof.
    apply idpath.
  Defined.

  (** We construct morphisms from ZeroObject to any other object c and from any
    other object c to the ZeroObject. *)
  Definition ZeroArrowFrom (Z : Zero) (c : C) : C⟦ZeroObject Z, c⟧ :=
    InitialArrow (Zero_to_Initial Z) c.
  Definition ZeroArrowTo (Z : Zero) (c : C) : C⟦c, ZeroObject Z⟧ :=
    TerminalArrow (Zero_to_Terminal Z) c.

  (** In particular, we get a zero morphism between any objects. *)
  Definition ZeroArrow (Z : Zero) (c d : C) : C⟦c, d⟧ :=
    @compose C _ (ZeroObject Z) _ (ZeroArrowTo Z c) (ZeroArrowFrom Z d).

  (** We show that the above morphisms from ZeroObject and to ZeroObject are
    unique by using uniqueness of the morphism from InitialObject and uniqueness
    of the morphism to TerminalObject. *)
  Lemma ZeroArrowFromUnique (Z : Zero) (c : C) (f : C⟦ZeroObject Z, c⟧) :
    f = (ZeroArrowFrom Z c).
  Proof.
    apply (InitialArrowUnique (Zero_to_Initial Z) c f).
  Defined.

  Lemma ZeroArrowToUnique (Z : Zero) (c : C) (f : C⟦c, ZeroObject Z⟧) :
    f = (ZeroArrowTo Z c).
  Proof.
    apply (TerminalArrowUnique (Zero_to_Terminal Z) c f).
  Defined.

  (** Therefore, any two morphisms from the ZeroObject to an object c are
    equal and any two morphisms from an object c to the ZeroObject are equal. *)
  Corollary ArrowsFromZero (Z : Zero) (c : C) (f g : C⟦ZeroObject Z, c⟧) :
    f = g.
  Proof.
    eapply pathscomp0.
    apply (ZeroArrowFromUnique Z c f).
    apply pathsinv0.
    apply (ZeroArrowFromUnique Z c g).
  Defined.

  Corollary ArrowsToZero (Z : Zero) (c : C) (f g : C⟦c, ZeroObject Z⟧) :
    f = g.
  Proof.
    eapply pathscomp0.
    apply (ZeroArrowToUnique Z c f).
    apply pathsinv0.
    apply (ZeroArrowToUnique Z c g).
  Defined.

  (** It follows that any morphism which factors through 0 is the ZeroArrow. *)
  Corollary ZeroArrowUnique (Z : Zero) (c d : C) (f : C⟦c, ZeroObject Z⟧)
            (g : C⟦ZeroObject Z, d⟧) : f · g = ZeroArrow Z c d.
  Proof.
    rewrite (ZeroArrowToUnique Z c f).
    rewrite (ZeroArrowFromUnique Z d g).
    apply idpath.
  Defined.

  (** Compose any morphism with the ZeroArrow and you get the ZeroArrow. *)
  Lemma precomp_with_ZeroArrow (Z : Zero) (a b c : C) (f : C⟦a, b⟧) :
    f · ZeroArrow Z b c = ZeroArrow Z a c.
  Proof.
    unfold ZeroArrow at 1. rewrite assoc.
    apply ZeroArrowUnique.
  Defined.

  Lemma postcomp_with_ZeroArrow (Z : Zero) (a b c : C) (f : C⟦b, c⟧) :
    ZeroArrow Z a b · f = ZeroArrow Z a c.
  Proof.
    unfold ZeroArrow at 1. rewrite <- assoc.
    apply ZeroArrowUnique.
  Defined.

  (** An endomorphism of the ZeroObject is the identity morphism. *)
  Corollary ZeroEndo_is_identity (Z : Zero)
            (f : C⟦ZeroObject Z, ZeroObject Z⟧) :
    f = identity (ZeroObject Z).
  Proof.
    apply ArrowsFromZero.
  Defined.

  (** The morphism from ZeroObject to ZeroObject is an isomorphisms. *)
  Lemma isiso_from_Zero_to_Zero (Z Z' : Zero) :
    is_iso (ZeroArrowFrom Z (ZeroObject Z')).
  Proof.
    apply (is_iso_qinv _ (ZeroArrowFrom Z' (ZeroObject Z))).
    split; apply ArrowsFromZero.
  Defined.

  (** Using the above lemma we can construct an isomorphisms between any two
    ZeroObjects. *)
  Definition iso_Zeros (Z Z' : Zero) : iso (ZeroObject Z) (ZeroObject Z') :=
    tpair _ (ZeroArrowFrom Z (ZeroObject Z')) (isiso_from_Zero_to_Zero Z Z').

  Definition hasZero := ishinh Zero.

  (** Construct Zero from Initial and Terminal for which the underlying objects
    are isomorphic. *)
  Definition Initial_and_Terminal_to_Zero
             (I : Initial C) (T : Terminal C)
             (e: iso (InitialObject I) (TerminalObject T)) : Zero.
  Proof.
    use (make_Zero (InitialObject I)).
    split.
    - use (make_isInitial (InitialObject I)); intro b.
      apply make_iscontr with (x := (InitialArrow I b)), InitialArrowUnique.
    - use (make_isTerminal (InitialObject I)); intro a.
      apply (iscontrretract (postcomp_with (inv_from_iso e))
                            (postcomp_with (morphism_from_iso e))).
      intros y. unfold postcomp_with.
      rewrite <- assoc. rewrite (iso_inv_after_iso e).
      apply (remove_id_right _ _ _ y y _ (idpath _) (idpath _)).
      apply (make_iscontr (TerminalArrow T a)), TerminalArrowUnique.
  Defined.

  (** The following lemma verifies that the ZeroObject of the Zero,
    constructed from Initial and Terminal with InitialObject isomorphic to
    TerminalObject, is isomorphic to the InitialObject and isomorphic to the
    TerminalObject. *)
  Lemma Initial_and_Terminal_ob_equals_Zero_ob (I : Initial C)
        (T :Terminal C) (e : iso (InitialObject I) (TerminalObject T)) :
    (iso (InitialObject I) (ZeroObject (Initial_and_Terminal_to_Zero I T e)))
      × (iso (TerminalObject T)
             (ZeroObject (Initial_and_Terminal_to_Zero I T e))).
  Proof.
    exact(identity_iso (InitialObject I),,iso_inv_from_iso e).
  Defined.

End def_zero.

(** * Zero coincides with the direct definition *)
Section zero_coincides.

  Context {C : category}.

  (** ** isZero *)

  Lemma equiv_isZero1 (c : C) :
    limits.zero.isZero c -> isZero c.
  Proof.
    intros X.
    use make_isZero.
    split.
    - intros d. apply ((pr1 X) d).
    - intros d. apply ((pr2 X) d).
  Qed.

  Lemma equiv_isZero2 (c : C) :
    limits.zero.isZero c <- isZero c.
  Proof.
    intros X.
    set (XZ := make_Zero c X).

    split.
    - intros b.
      use tpair.
      apply (InitialArrow (Zero_to_Initial XZ) b).
      intros t.
      use (InitialArrowUnique (Zero_to_Initial XZ) b).
    - intros a.
      use tpair.
      apply (TerminalArrow (Zero_to_Terminal XZ) a).
      intros t.
      use (TerminalArrowUnique (Zero_to_Terminal XZ) a).
  Qed.

  (** ** Zero **)

  Definition equiv_Zero1 :
    limits.zero.Zero C -> @Zero C.
  Proof.
    intros Z.
    exact (make_Zero Z (equiv_isZero1 _ (pr2 Z))).
  Defined.

  Definition equiv_Zero2 :
    limits.zero.Zero C <- @Zero C.
  Proof.
    intros Z.
    exact (limits.zero.make_Zero
             (ZeroObject Z)
             (equiv_isZero2
                _ ((isInitial_Initial (Zero_to_Initial Z))
                     ,,(isTerminal_Terminal (Zero_to_Terminal Z))))).
  Defined.

  (** ** Arrows *)

  Lemma equiv_ZeroArrowTo (x : C) (Z : Zero) :
    @limits.zero.ZeroArrowTo C (equiv_Zero2 Z) x = ZeroArrowTo Z x.
  Proof.
    apply ZeroArrowToUnique.
  Qed.

  Lemma equiv_ZeroArrowFrom (x : C) (Z : Zero) :
    @limits.zero.ZeroArrowFrom C (equiv_Zero2 Z) x = ZeroArrowFrom Z x.
  Proof.
    apply ZeroArrowFromUnique.
  Qed.

  Lemma equiv_ZeroArrow (x y : C) (Z : Zero) :
    @limits.zero.ZeroArrow C (equiv_Zero2 Z) x y = ZeroArrow Z x y.
  Proof.
    unfold limits.zero.ZeroArrow. unfold ZeroArrow.
    rewrite equiv_ZeroArrowTo.
    rewrite equiv_ZeroArrowFrom.
    apply idpath.
  Qed.

End zero_coincides.

(** Following Initial and Terminal, we clear implicit arguments. *)
Arguments Zero : clear implicits.
Arguments isZero : clear implicits.


Require Import Util MapBasics Infra.Lattice Infra.PartialOrder DecSolve Terminating.

Set Implicit Arguments.

Inductive withTop (A:Type) :=
| Top : withTop A
| wTA (a:A) : withTop A.

Arguments Top [A].
Arguments wTA [A] a.

Instance withTop_eq_dec A `{EqDec A eq} : EqDec (withTop A) eq.
Proof.
  hnf. destruct x,y; eauto; try dec_solve.
  destruct (H a a0); try dec_solve.
  hnf in e. subst. left; eauto.
Qed.

Inductive withTop_le A R `{EqDec A R} : withTop A -> withTop A -> Prop :=
| WithTopLe_refl a b : R a b -> withTop_le (wTA a) (wTA b)
| WithTopLe_top a : withTop_le a Top.

Instance withTop_le_dec A R `{EqDec A R} (a b:withTop A) : Computable (withTop_le a b).
Proof.
  destruct a,b; hnf; eauto using withTop_le.
  - dec_solve.
  - decide (a === a0); dec_solve.
Defined.

Inductive withTop_eq A R `{EqDec A R} : withTop A -> withTop A -> Prop :=
| WithTopEq_refl a b : R a b -> withTop_eq (wTA a) (wTA b)
| WithTopEq_top : withTop_eq Top Top.

Lemma withTopEq_refl_sym A R `{EqDec A R} a b
  : poEq a b -> withTop_eq (wTA b) (wTA a).
Proof.
  econstructor. symmetry. eauto.
Qed.

Hint Resolve withTopEq_refl_sym.

Instance withTop_eq_comp A R `{EqDec A R} (a b:withTop A)
  : Computable (withTop_eq a b).
Proof.
  destruct a,b; hnf; eauto using withTop_eq.
  - dec_solve.
  - dec_solve.
  - decide (a === a0); dec_solve.
Defined.

Instance withTop_eq_equiv A R `{EqDec A R} : Equivalence (withTop_eq (A:=A) (R:=R)).
Proof.
  constructor.
  - hnf; intros []; eauto using @withTop_eq.
    econstructor. reflexivity.
  - hnf; intros [] []; inversion 1; subst; eauto using @withTop_eq.
    econstructor. symmetry. eauto.
  - hnf; intros [] [] [] X Y; inv X; inv Y; eauto using @withTop_eq.
    econstructor. etransitivity; eauto.
Qed.

Lemma withTop_le_refl A R `{EqDec A R}
  :  forall d d' : withTop A, withTop_eq d d' -> withTop_le d d'.
Proof.
  intros ? ? X; inv X; eauto using withTop_le.
Qed.

Instance withTop_le_Refl A R `{EqDec A R} : Reflexive (withTop_le (A:=A) (R:=R)).
Proof.
  hnf; intros.
  eapply withTop_le_refl. reflexivity.
Qed.

Instance withTop_le_trans A R `{EqDec A R}
  : Transitive (withTop_le (A:=A) (R:=R)).
Proof.
  hnf; intros [] [] [] X Y; inv X; inv Y; eauto using withTop_le.
  econstructor; etransitivity; eauto.
Qed.

Instance withTop_le_Trans A R `{EqDec A R} : Transitive (withTop_le (A:=A) (R:=R)).
Proof.
  hnf; intros.
  eapply withTop_le_trans. etransitivity; eauto. reflexivity.
Qed.

Instance withTop_le_anti A R `{EqDec A R}
  : Antisymmetric (withTop A) (withTop_eq (A:=A) (R:=R)) (withTop_le (A:=A) (R:=R)).
Proof.
  hnf; intros [] [] X Y; inv X; inv Y; eauto using withTop_eq.
Qed.

Instance withTop_PO A R `{EqDec A R} : PartialOrder (withTop A) :=
  {
    poLe := @withTop_le A R _ _;
    poEq := @withTop_eq A R _ _
  }.
Proof.
  - eapply withTop_le_refl.
Defined.

Lemma withTop_poLe_inv A R `{EqDec A R} (a b:A)
  : poLe (wTA a) (wTA b)
    -> a === b.
Proof.
  intros. inv H0. eapply H3.
Qed.

Smpl Add 100 match goal with
             | [ H : @poLe _ _ (wTA _) (wTA _) |- _ ] =>
               eapply withTop_poLe_inv in H
             | [ H : @poLe _ _ Top _ |- _ ] => invc H
             | [ H : @poLe _ _ _ (wTA _) |- _ ] => invc H
             | [ H : @poEq _ _ Top _ |- _ ] => invc H
             | [ H : @poEq _ _ _ Top |- _ ] => invc H
             | [ H : @poEq _ _ _ (wTA _) |- _ ] => invc H
             | [ H : @poEq _ _ (wTA _) _ |- _ ] => invc H
             | [ H : @withTop_le _ _ _ _ _ _ |- _ ] => invc H
             end : inv_trivial.

Definition withTop_generic_join A R `{EqDec A R} (a b:withTop A) :=
  match a, b with
  | Top, _ => Top
  | _, Top => Top
  | wTA a, wTA b => if [ a === b ] then wTA a else Top
  end.

Lemma withTop_generic_join_bound A R `{EqDec A R}
  : forall a b : withTop A, a ⊑ b -> withTop_generic_join a b ⊑ b.
Proof.
  intros []; simpl; intros; repeat cases; eauto; econstructor; eauto.
Qed.

Lemma withTop_generic_join_sym A R `{EqDec A R}
  : forall a b : withTop A, withTop_generic_join a b ≣ withTop_generic_join b a.
Proof.
  intros [] []; simpl; try econstructor.
  repeat cases; try econstructor; eauto.
  - exfalso; eapply NOTCOND. symmetry. eauto.
Qed.

Lemma withTop_generic_join_assoc A R `{EqDec A R}
  : forall a b c : withTop A,
    withTop_generic_join (withTop_generic_join a b) c
                         ≣ withTop_generic_join a (withTop_generic_join b c).
Proof.
  intros [] [] []; simpl; repeat (cases; simpl); eauto.
  - exfalso. eapply NOTCOND. rewrite <- COND. eauto.
  - exfalso. eapply NOTCOND. rewrite COND. eauto.
  - exfalso. eapply NOTCOND. eauto.
Qed.

Lemma poLe_withTopLe_refl A R `{EqDec A R} (a b : A)
  : R a b
    -> poLe (wTA a) (wTA b).
Proof.
  econstructor; eauto.
Qed.

Lemma poEq_withTopEq_refl A R `{EqDec A R} (a b : A)
  : R a b
    -> poEq (wTA a) (wTA b).
Proof.
  econstructor; eauto.
Qed.

Lemma poLe_withTopLe_top A R `{EqDec A R} (x:withTop A)
  : poLe x Top.
Proof.
  econstructor 2.
Qed.

Hint Resolve poEq_withTopEq_refl poLe_withTopLe_refl poLe_withTopLe_top.

Lemma withTop_generic_join_exp A R  `{EqDec A R}
  : forall a b : withTop A, a ⊑ withTop_generic_join a b.
Proof.
  intros [] []; simpl; repeat (cases; simpl); eauto.
Qed.

Instance withTop_generic_join_poEq A R `{EqDec A R}
  : Proper (poEq ==> poEq ==> poEq) (withTop_generic_join (A:=A) (R:=R)).
Proof.
  unfold Proper, respectful; intros.
  destruct x,y,x0,y0; simpl;
    repeat (cases; simpl); eauto;
      clear_trivial_eqs.
  - exfalso. eapply NOTCOND.
    rewrite <- H3, <- H4. eauto.
  - exfalso. eapply NOTCOND. rewrite H4, H3. eauto.
Qed.

Instance withTop_generic_join_poLe A R `{EqDec A R}
  : Proper (poLe ==> poLe ==> poLe) (withTop_generic_join (A:=A) (R:=R)).
Proof.
  unfold Proper, respectful; intros.
  destruct x,y,x0,y0; simpl; eauto using withTop_le;
    repeat (cases; simpl); eauto using withTop_le.
  - exfalso. eapply NOTCOND. rewrite H0, H1. eauto.
Qed.

Instance withTop_JSL A R `{EqDec A R} : JoinSemiLattice (withTop A) :=
  {
    join := @withTop_generic_join A R _ _
  }.
Proof.
  - eapply withTop_generic_join_bound.
  - eapply withTop_generic_join_sym.
  - eapply withTop_generic_join_assoc.
  - eapply withTop_generic_join_exp.
Defined.

Inductive withUnknown (A:Type) :=
| Known (a:A) : withUnknown A
| Unknown : withUnknown A.

Arguments Unknown [A].
Arguments Known [A] a.

Instance withUnknown_eq_dec A `{EqDec A eq} : EqDec (withUnknown A) eq.
Proof.
  hnf. destruct x,y; eauto; try dec_solve.
  destruct (H a a0); try dec_solve.
  hnf in e. subst. left; eauto.
Qed.

Inductive withUnknown_eq A R `{EqDec A R} : withUnknown A -> withUnknown A -> Prop :=
| WithUnknownEq_refl a b : R a b -> withUnknown_eq (Known a) (Known b)
| WithUnknownEq_top : withUnknown_eq Unknown Unknown.

Smpl Add 100 match goal with
             | [ H : Known _ === Known _ |- _ ] => invc H
             | [ H : withUnknown_eq _ _ |- _ ] => invc H
             end : inv_trivial.

Lemma withUnknownEq_refl_sym A `{PartialOrder A} a b
  : poEq a b -> withUnknown_eq (Known b) (Known a).
Proof.
  econstructor. symmetry. eauto.
Qed.

Hint Resolve withUnknownEq_refl_sym.

Instance withUnknown_eq_comp A R `{EqDec A R} (a b:withUnknown A)
  : Computable (withUnknown_eq a b).
Proof.
  destruct a,b; hnf; eauto using withUnknown_eq.
  - decide (a === a0); dec_solve.
  - dec_solve.
  - dec_solve.
Defined.

Instance withUnknown_eq_equiv A R `{EqDec A R}
  : Equivalence (withUnknown_eq (A:=A) (R:=R)).
Proof.
  constructor.
  - hnf; intros []; eauto using @withUnknown_eq.
    econstructor. reflexivity.
  - hnf; intros [] []; inversion 1; subst; eauto using @withUnknown_eq.
    econstructor. symmetry. eauto.
  - hnf; intros [] [] [] X Y; inv X; inv Y; eauto using @withUnknown_eq.
    econstructor. etransitivity; eauto.
Qed.

Instance withUnknown_PO A R `{EqDec A R} : PartialOrder (withUnknown A) :=
  {
    poLe := @withUnknown_eq A R _ _ ;
    poEq := @withUnknown_eq A R _ _
  }.
Proof.
  - eauto.
  - hnf; intros; eauto.
Defined.

Instance withUnknown_EqDec A R `{EqDec A R}
  : EqDec (withUnknown A) (@withUnknown_eq _ _ _ _).
Proof.
  hnf. eapply withUnknown_eq_comp.
Defined.

Inductive withBot (A:Type) :=
| Bot : withBot A
| WBElt (a:A) : withBot A.

Arguments Bot [A].
Arguments WBElt [A] a.

Instance withBot_eq_dec A `{EqDec A eq} : EqDec (withBot A) eq.
Proof.
  hnf. destruct x,y; eauto; try dec_solve.
  destruct (H a a0); try dec_solve.
  hnf in e. subst. left; eauto.
Qed.

Inductive withBot_le A `{PartialOrder A} : withBot A -> withBot A -> Prop :=
| WithBotLe_refl a b : poLe a b -> withBot_le (WBElt a) (WBElt b)
| WithBotLe_bot a : withBot_le Bot a.

Instance withBot_le_dec A `{PartialOrder A} (a b:withBot A) : Computable (withBot_le a b).
Proof.
  destruct a,b; hnf; eauto using withBot_le.
  - dec_solve.
  - decide (poLe a a0); dec_solve.
Defined.

Inductive withBot_eq A `{PartialOrder A} : withBot A -> withBot A -> Prop :=
| WithBotEq_refl a b : poEq a b -> withBot_eq (WBElt a) (WBElt b)
| WithBotEq_bot : withBot_eq Bot Bot.

Lemma withBotEq_refl_sym A `{PartialOrder A} a b
  : poEq a b -> withBot_eq (WBElt b) (WBElt a).
Proof.
  econstructor. symmetry. eauto.
Qed.

Hint Resolve withBotEq_refl_sym.

Instance withBot_eq_comp A `{PartialOrder A} (a b:withBot A)
  : Computable (withBot_eq a b).
Proof.
  destruct a,b; hnf; eauto using withBot_eq.
  - dec_solve.
  - dec_solve.
  - decide (poEq a a0); dec_solve.
Defined.

Instance withBot_eq_equiv A `{PartialOrder A} : Equivalence (withBot_eq (A:=A)).
Proof.
  constructor.
  - hnf; intros []; eauto using @withBot_eq.
  - hnf; intros [] []; inversion 1; subst; eauto using @withBot_eq.
  - hnf; intros [] [] [] X Y; inv X; inv Y; eauto using @withBot_eq.
    econstructor. etransitivity; eauto.
Qed.

Lemma withBotLe_refl A `{PartialOrder A}
  :  forall d d' : withBot A, withBot_eq d d' -> withBot_le d d'.
Proof.
  intros ? ? X; inv X; eauto using withBot_le.
Qed.

Instance withBot_le_trans A `{PartialOrder A}
  : Transitive (withBot_le (A:=A)).
Proof.
  hnf; intros [] [] [] X Y; inv X; inv Y; eauto using withBot_le.
Qed.

Instance withBot_le_anti A `{PartialOrder A}
  : Antisymmetric (withBot A) (withBot_eq (A:=A)) (withBot_le (A:=A)).
Proof.
  hnf; intros [] [] X Y; inv X; inv Y; eauto using withBot_eq.
  exploit poLe_antisymmetric; eauto.
Qed.

Instance withBot_PO A `{PartialOrder A} : PartialOrder (withBot A) :=
  {
    poLe := @withBot_le A _;
    poEq := @withBot_eq A _
  }.
Proof.
  - eapply withBotLe_refl.
Defined.

Instance withBot_lower_bounded A `{PartialOrder A} : LowerBounded (withBot A) :=
  {
    bottom := Bot
  }.
Proof.
  intros. destruct a; econstructor.
Qed.

Instance terminating_withTop X R `{EqDec X R}
  : Terminating (withTop X) poLt.
Proof.
  hnf; intros.
  destruct x.
  - econstructor; intros. exfalso.
    destruct H0; clear_trivial_eqs. eauto.
  - econstructor; intros.
    destruct H0. invc H0.
    + exfalso. eapply H1. econstructor. symmetry. eauto.
    + econstructor; intros. exfalso.
      destruct H0; clear_trivial_eqs. eauto.
Qed.