(* 7. Hierarchies *)
(* 7.1 Structure interface *)

(* Mathcomp Book Z-module *)
(* algebra/zmodp.v をもとに、修正した。 *)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import fintype finset fingroup ssralg finalg.

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

Local Open Scope ring_scope.

Section Ord.

  (* ordinal の定義 *)
  Locate "'I_ _".                           (* ordinal n *)
  Print ordinal.
  (* Inductive ordinal (n : nat) : predArgType :=
    Ordinal : forall m : nat, m < n -> 'I_n *)
  Check @Ordinal : forall n m : nat, m < n -> 'I_n.

(*
Ordinal n m H : 'I_n
Ordinal は値コンストラクタであり、'I_n 型の（自然数にすると）m になる値である。
H2_3 は m < n であることの証明。
 *)
  Variable H2_3 : 2 < 3.
  Check @Ordinal 3 2 H2_3 : 'I_3.
End Ord.

Section ZpDef.

  Variable p' : nat.
  Local Notation p := p'.+1.

  Implicit Types x y z : 'I_p.
  Check 'I_p : predArgType.

  (* dが0より大きいとき、dで割った余りは、dより小さい。 *)
  Check ltn_pmod : forall m d : nat, 0 < d -> m %% d < d.

  (* +1 したものは、0より大きい。 *)
  Check ltn0Sn : forall n : nat, 0 < n.+1.

  (* Standard injection; val (inZp i) = i %% p *)
  (* 'I_p 型の（自然数にすると）(i %% p) になる値である。 *)
  Definition inZp i := @Ordinal p (i %% p) (ltn_pmod i (ltn0Sn p')).
(* Definition inZp i := Ordinal            (ltn_pmod i (ltn0Sn p')). *)
  Check inZp 0 : 'I_p.
  Check inZp p.-1 : 'I_p.
  Check inZp p : 'I_p.
  Check inZp p.+1 : 'I_p.

  (* *************** *)
  (* zmod Operations *)
  (* *************** *)

  Definition Zp0 : 'I_p := ord0.
  Definition Zp1 := inZp 1.
  Definition Zp_opp x := inZp (p - x).
  Definition Zp_add x y := inZp (x + y).
  Definition Zp_mul x y := inZp (x * y).
  Definition Zp_inv x := if coprime p x then inZp (egcdn x p).1 else x.
  (* coprime 互いに素。egcdn 拡張GCD。 *)

  (* Additive group structure. *)

  Lemma modZp x : x %% p = x.
  Proof.
      by rewrite modn_small ?ltn_ord.
  Qed.

  Lemma modZp2 x : x %% p = (x + p) %% p.   (* suhara *)
  Proof.
    rewrite modnDr.
      by rewrite modn_small ?ltn_ord.
  Qed.

  Lemma modZp3 x : forall m n, (x + m * p) %% p = (x + n * p) %% p.   (* suhara *)
  Proof.
    move=> m n.
    rewrite addnC modnMDl.
    rewrite addnC modnMDl.
    done.
  Qed.

  Lemma valZpK x : inZp x = x.
  Proof.
      by apply: val_inj; rewrite /= modZp.
  Qed.

  Lemma valZpK2 x : inZp x = inZp (x + p).  (* suhara *)
  Proof.
    apply: val_inj.
    Check val : 'I_p -> nat.                (* これが単射であることをつかう。 *)
    rewrite /= modZp2.
    done.
    Restart.
      by apply: val_inj; rewrite /= modZp2.
  Qed.

  Lemma valZpK3 x : forall m n, inZp (x + m * p) = inZp (x + n * p).  (* suhara *)
  Proof.
    move=> m n.
    apply: val_inj.
    rewrite /=.
    Check modZp3 x m n.
    by rewrite (modZp3 x m n).
  Qed.

  Lemma Zp_add0z : left_id Zp0 Zp_add.
  Proof.
    exact: valZpK.
  Qed.

  Lemma Zp_addNz : left_inverse Zp0 Zp_opp Zp_add.
  Proof.
      by move=> x; apply: val_inj; rewrite /= modnDml subnK ?modnn // ltnW.
  Qed.

  Lemma Zp_addA : associative Zp_add.
  Proof.
      by move=> x y z; apply: val_inj; rewrite /= modnDml modnDmr addnA.
  Qed.

  Lemma Zp_addC : commutative Zp_add.
  Proof.
      by move=> x y; apply: val_inj; rewrite /= addnC.
  Qed.

  Fail Check inZp 0 + inZp 1.

  (* zmod : additive abelian groups , see ssralg *)
  Definition Zp_zmodMixin := ZmodMixin Zp_addA Zp_addC Zp_add0z Zp_addNz. (* ssralg *)
  Canonical Zp_zmodType := Eval hnf in ZmodType 'I_p Zp_zmodMixin. (* ssralg *)
  Canonical Zp_finZmodType := Eval hnf in [finZmodType of 'I_p]. (* finalg *)
  Canonical Zp_baseFinGroupType := Eval hnf in [baseFinGroupType of 'I_p for +%R].
  Canonical Zp_finGroupType := Eval hnf in [finGroupType of 'I_p for +%R].

  (* *************** *)
  (* Ring operations *)
  (* *************** *)

  Lemma Zp_mul1z : left_id Zp1 Zp_mul.
  Proof.
      by move=> x; apply: val_inj; rewrite /= modnMml mul1n modZp.
  Qed.

  Lemma Zp_mulC : commutative Zp_mul.
  Proof.
      by move=> x y; apply: val_inj; rewrite /= mulnC.
  Qed.

  Lemma Zp_mulz1 : right_id Zp1 Zp_mul.
  Proof.
      by move=> x; rewrite Zp_mulC Zp_mul1z.
  Qed.

  Lemma Zp_mulA : associative Zp_mul.
  Proof.
      by move=> x y z; apply: val_inj; rewrite /= modnMml modnMmr mulnA.
  Qed.

  Lemma Zp_mul_addr : right_distributive Zp_mul Zp_add.
  Proof.
      by move=> x y z; apply: val_inj; rewrite /= modnMmr modnDm mulnDr.
  Qed.

  Lemma Zp_mul_addl : left_distributive Zp_mul Zp_add.
  Proof. by move=> x y z; rewrite -!(Zp_mulC z) Zp_mul_addr. Qed.

  Lemma Zp_mulVz x : coprime p x -> Zp_mul (Zp_inv x) x = Zp1.
  Proof.
    move=> co_p_x; apply: val_inj; rewrite /Zp_inv co_p_x /= modnMml.
      by rewrite -(chinese_modl co_p_x 1 0) /chinese addn0 mul1n mulnC.
  Qed.

  Lemma Zp_mulzV x : coprime p x -> Zp_mul x (Zp_inv x) = Zp1.
  Proof.
      by move=> Ux; rewrite /= Zp_mulC Zp_mulVz.
  Qed.

  Lemma Zp_intro_unit x y : Zp_mul y x = Zp1 -> coprime p x.
  Proof.
    case=> yx1; have:= coprimen1 p.
      by rewrite -coprime_modr -yx1 coprime_modr coprime_mulr; case/andP.
  Qed.

  Lemma Zp_inv_out x : ~~ coprime p x -> Zp_inv x = x.
  Proof.
      by rewrite /Zp_inv => /negPf->.
  Qed.

  Lemma Zp_mulrn x n : x *+ n = inZp (x * n).
  Proof.
    apply: val_inj => /=; elim: n => [|n IHn]; first by rewrite muln0 modn_small.
      by rewrite !GRing.mulrS /= IHn modnDmr mulnS.
  Qed.

  Import GroupScope.

  Lemma Zp_mulgC : @commutative 'I_p _ mulg.
  Proof.
    exact: Zp_addC.
  Qed.

  Lemma Zp_abelian : abelian [set: 'I_p].
  Proof.
    exact: FinRing.zmod_abelian.
  Qed.

  Lemma Zp_expg x n : x ^+ n = inZp (x * n).
  Proof.
    exact: Zp_mulrn.
  Qed.

  Lemma Zp1_expgz x : Zp1 ^+ x = x.
  Proof.
      by rewrite Zp_expg; apply: Zp_mul1z.
  Qed.

  Lemma Zp_cycle : setT = <[Zp1]>.
  Proof.
      by apply/setP=> x; rewrite -[x]Zp1_expgz inE groupX ?mem_gen ?set11.
  Qed.

  Lemma order_Zp1 : #[Zp1] = p.
  Proof.
      by rewrite orderE -Zp_cycle cardsT card_ord.
  Qed.
End ZpDef.

Implicit Arguments Zp0 [[p']].
Implicit Arguments Zp1 [[p']].
Implicit Arguments inZp [[p']].

Section ZpRing.

  Variable p' : nat.
  Local Notation p := p'.+2.

  Check 'I_p.
  Check Zp1 : 'I_p.
  Check 0 : 'I_p.

  Lemma Zp_nontrivial : Zp1 != 0 :> 'I_p.
  Proof.
      by [].
  Qed.

  Print GRing.ComRing.RingMixin.
  Definition Zp_ringMixin :=
    ComRingMixin (@Zp_mulA _) (@Zp_mulC _) (@Zp_mul1z _) (@Zp_mul_addl _)
                 Zp_nontrivial.
  Canonical Zp_ringType := Eval hnf in RingType 'I_p Zp_ringMixin.
  Canonical Zp_finRingType := Eval hnf in [finRingType of 'I_p].
  Canonical Zp_comRingType := Eval hnf in ComRingType 'I_p (@Zp_mulC _).
  Canonical Zp_finComRingType := Eval hnf in [finComRingType of 'I_p].

  (* inverse の unit をもつ ring *)
  Definition Zp_unitRingMixin :=
    ComUnitRingMixin (@Zp_mulVz _) (@Zp_intro_unit _) (@Zp_inv_out _).
  Canonical Zp_unitRingType := Eval hnf in UnitRingType 'I_p Zp_unitRingMixin.
  Canonical Zp_finUnitRingType := Eval hnf in [finUnitRingType of 'I_p].
  Canonical Zp_comUnitRingType := Eval hnf in [comUnitRingType of 'I_p].
  Canonical Zp_finComUnitRingType := Eval hnf in [finComUnitRingType of 'I_p].

  Lemma Zp_nat n : n%:R = inZp n :> 'I_p.
  Proof.
      by apply: val_inj; rewrite [n%:R]Zp_mulrn /= modnMml mul1n.
  Qed.

  Lemma natr_Zp (x : 'I_p) : x%:R = x.
  Proof.
      by rewrite Zp_nat valZpK.
  Qed.

  Lemma natr_negZp (x : 'I_p) : (- x)%:R = - x.
  Proof.
      by apply: val_inj; rewrite /= Zp_nat /= modn_mod.
  Qed.

  Import GroupScope.

  Lemma unit_Zp_mulgC : @commutative {unit 'I_p} _ mulg.
  Proof.
      by move=> u v; apply: val_inj; rewrite /= GRing.mulrC.
  Qed.

  Lemma unit_Zp_expg (u : {unit 'I_p}) n :
    val (u ^+ n) = inZp (val u ^ n) :> 'I_p.
  Proof.
    apply: val_inj => /=; elim: n => [|n IHn] //.
      by rewrite expgS /= IHn expnS modnMmr.
  Qed.

End ZpRing.

Definition Zp_trunc p := p.-2.

Notation "''Z_' p" := 'I_(Zp_trunc p).+2
                         (at level 8, p at level 2, format "''Z_' p") : type_scope.

Section EQ.
  Variable p' : nat.
  Local Notation p := p'.+1.
  Canonical Zp_eqType := [eqType of 'Z_p].

  Goal inZp 1 = inZp 1 :> 'Z_p.
  Proof.
    rewrite /inZp.
    Undo 1.
    by apply/eqP.
  Qed.
End EQ.

(* ***** *)
(* Mathcomp Book Original *)
(* ***** *)

Section MCB.
  Variable m n : nat.

  Definition Zmn := ('Z_m * 'Z_n)%type.
  Canonical Zmn_eqType := [eqType of Zmn].
  Canonical Zmn_zmodType := [zmodType of Zmn].
  Canonical Zmn_ringType := [ringType of Zmn].

  Check 0 : 'Z_m.
  Check 0 : 'Z_n.
  Check (0, 0) : Zmn.
  Goal (0, 0) = (0, 0) :> Zmn.
  Proof.
    by apply/eqP.
  Qed.

(* have Zp_mulrAC := @mulrAC [ringType of 'Z_p]. *)

End MCB.

(* END *)

Check @Zp0 3 : 'I_4.
Check @inZp 3 0 : 'I_4.                     (* 0 *)

Check @Zp1 3 : 'I_4.
Check @inZp 3 1 : 'I_4.                     (* 1 *)

Check @inZp 3 2 : 'I_4.                     (* 2 *)
Check @inZp 3 3 : 'I_4.                     (* 3 *)
Check @inZp 3 4 : 'I_4.                     (* 0 *)
Check @inZp 3 5 : 'I_4.                     (* 1 *)
Check @inZp 3 6 : 'I_4.                     (* 2 *)
Check @inZp 3 7 : 'I_4.                     (* 3 *)

Goal @inZp 3 0 = @inZp 3 4.
Proof.
  Check 0 : 'I_4.
  Fail Check 4 : 'I_4.
  Check inZp 0 : 'I_4.
  Check inZp 4 : 'I_4.

  Set Printing Implicit.                    (* XXXX *)
  Check @valZpK2 3 0.
  apply (@valZpK2 3 0).
Qed.

Locate "_ + _".                             (* Zmodule の add でない。 *)


Require Import List Wellfounded.

Section Acc_incomp.

  Variables (X : Type) (R T : X -> X -> Prop) (P : X -> Prop).

  Hypothesis (H1 : forall x y, T x y -> P y -> R x y)
             (H2 : forall x y, T x y -> P y -> P x).

  Fact Acc_incomp x : Acc R x -> P x -> Acc T x.
  Proof. induction 1; constructor; eauto. Qed.

End Acc_incomp.

Section wf_finite.

  Variables (X : Type) (HX : exists l, forall x : X, In x l)
            (R : X -> X -> Prop).

  Infix "<" := R.

  Hypothesis X_irrefl : forall x, ~ x < x.
  Hypothesis X_trans : forall x y z, x < y -> y < z -> x < z.

  Local Definition restr l x y := In x l /\ x < y.

  Local Lemma wf_restr l : well_founded (restr l).
  Proof.
    induction l as [ | x l IHl ].
    + constructor; intros y ([] & _).
    + (* every point below x is Acc for restr (x::l) *)
      assert (Acc_lt_x : forall y, y < x -> Acc (restr (x::l)) y).
      1: { intros y H.
           specialize (IHl y); revert y IHl H.
           apply Acc_incomp.
           * intros a ? ([] & ?) G; subst.
             - destruct (X_irrefl a); eauto.
             - red; auto.
           * intros ? ? ([] & ?); subst; eauto. }
      (* so x is Acc for restr (x::l) *)
      assert (Acc_x : Acc (restr (x::l)) x).
      1: { constructor; intros ? []; auto. }
      (* so every point is Acc for restr (x::l) *)
      intros y.
      specialize (IHl y); revert y IHl.
      induction 1 as [ y _ IHy ].
      constructor; intros z ([] & ?); subst; auto.
      apply IHy; red; auto.
  Qed.

  Theorem wf_finite : well_founded R.
  Proof.
    destruct HX as (l & Hl).
    generalize (wf_restr l).
    apply wf_incl.
    split; auto.
  Qed.

End wf_finite.

Check wf_finite.


Require Export XR_Rlt_0_1.
Require Export XR_Rplus_lt_compat_l.

Local Open Scope R_scope.

Lemma Rlt_plus_1 : forall r,
  r < r + R1.
Proof.
  intros x.
  pattern x at 1 ; rewrite <- Rplus_0_r.
  apply Rplus_lt_compat_l.
  exact Rlt_0_1.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import Cat.Cat.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations.

(** The category of functors.

– Objects: functors from C to C'
– Arrows: natural transformations
*)
Program Definition Func_Cat (C C' : Category) : Category :=
{|
  Obj := (C --> C')%functor;

  Hom := NatTrans;

  compose := @NatTrans_compose _ _;

  id := @NatTrans_id _ _;

  assoc := fun _ _ _ _ _ _ _ => @NatTrans_compose_assoc _ _ _ _ _ _ _ _ _;

  assoc_sym :=
    fun _ _ _ _ _ _ _ => eq_sym (@NatTrans_compose_assoc _ _ _ _ _ _ _ _ _);

  id_unit_right := @NatTrans_id_unit_right _ _;

  id_unit_left := @NatTrans_id_unit_left _ _
|}.

Section Opposite_Func_Cat.
  Context (C D : Category).

  (** Functor from functor category to its opposite. Maps each functor
       to its opposite. *)
  Program Definition Op_Func_Cat_to_Func_Cat_Op
    : ((Func_Cat C D)^op --> (Func_Cat (C^op) (D^op)))%functor :=
    {|
      FO := Opposite_Functor;
      FA := fun _ _ => Opposite_NatTrans;
      F_id := fun _ => NatTrans_id_Op _;
      F_compose := fun _ _ _ _ _ => NatTrans_compose_Op _ _
    |}.

  (** Functor from the opposite of a functor category to it. Maps each functor
      to its opposite. *)
  Program Definition Func_Cat_Op_to_Op_Func_Cat
    : ((Func_Cat (C^op) (D^op)) --> (Func_Cat C D)^op)%functor :=
    {|
      FO := Opposite_Functor;
      FA := fun _ _ => Opposite_NatTrans;
      F_id := fun F => NatTrans_id_Op F;
      F_compose := fun _ _ _ N N' => NatTrans_compose_Op N N'
    |}.

  (** The opposite of the category of functors from C to D is naturally
       isomorphic to the category of functors from C^op to D^op. *)
  Program Definition Func_Cat_Op_Iso
    : ((((Func_Cat C D)^op)%category)
         ≃≃ (Func_Cat (C^op) (D^op)) ::> Cat) %isomorphism :=
    {|
      iso_morphism := Op_Func_Cat_to_Func_Cat_Op;
      inverse_morphism := Func_Cat_Op_to_Op_Func_Cat
    |}.

End Opposite_Func_Cat.


(** Adapted from "Elements of Set Theory" Chapter 6 **)
(** Coq coding by choukh, Aug 2020 **)

Require Import Relation_Definitions.
Require Export RelationClasses.
Require Import ZFC.Lib.WosetMin.
Require Export ZFC.Lib.Natural.
Require Export ZFC.Lib.FuncFacts.

(*** EST第六章1：等势，康托定理，鸽笼原理，有限基数 ***)

(** 等势 **)
Definition equinumerous : relation set :=
  λ A B, ∃ F, F: A ⟺ B.
Notation "A ≈ B" := ( equinumerous A B) (at level 70).
Notation "A ≉ B" := (¬equinumerous A B) (at level 70).

(* 等势是等价关系 *)
Lemma eqnum_equiv : Equivalence equinumerous.
Proof.
  split.
  - intros A. exists (Ident A). apply ident_bijection.
  - intros A B [f H]. exists (f⁻¹). apply inv_bijection. auto.
  - intros A B C [f Hf] [g Hg]. exists (g ∘ f).
    eapply compo_bijection; eauto...
Qed.
Existing Instance eqnum_equiv.

(* 集合与空集等势当且仅当它是空集 *)
Lemma eqnum_empty : ∀ A, A ≈ ∅ ↔ A = ∅.
Proof.
  split. intros [f Hf]. now apply bijection_to_empty in Hf.
  intros. now subst A.
Qed.

(* 单集与1等势 *)
Lemma eqnum_single : ∀ a, {a,} ≈ 1.
Proof with auto.
  intros. set (Func {a,} 1 (λ _, 0)) as F.
  exists F. apply meta_bijection.
  - intros _ _. apply suc_has_n.
  - intros x1 H1 x2 H2 Heq.
    apply SingE in H1. apply SingE in H2. subst...
  - intros y Hy. rewrite one in Hy. apply SingE in Hy.
    exists a. split...
Qed.

(* 真配对与2等势 *)
Lemma eqnum_pair : ∀ a b, a ≠ b → {a, b} ≈ 2.
Proof with eauto; try congruence.
  intros a b Hnq.
  set (Func {a, b} 2 (λ x, match (ixm (x = a)) with
    | inl _ => 0
    | inr _ => 1
  end)) as F.
  exists F. apply meta_bijection.
  - intros x Hx. destruct (ixm (x = a))...
    apply BUnionI1... apply BUnionI2...
  - intros x1 H1 x2 H2 Heq.
    apply PairE in H1 as []; apply PairE in H2 as []...
    + destruct (ixm (x1 = a))... destruct (ixm (x2 = a))...
      exfalso. eapply suc_neq_0...
    + destruct (ixm (x1 = a))... destruct (ixm (x2 = a))...
      exfalso. eapply suc_neq_0...
  - intros y Hy. rewrite two in Hy. apply TwoE in Hy as [].
    + exists a. split. apply PairI1. destruct (ixm (a = a))...
    + exists b. split. apply PairI2. destruct (ixm (b = a))... rewrite one...
Qed.

(* 集合与1等势当且仅当它是单集 *)
Lemma eqnum_one_iff : ∀ A, A ≈ 1 ↔ ∃ a, A = {a,}.
Proof with auto.
  split.
  - intros Hqn. symmetry in Hqn.
    destruct Hqn as [f [[Hf _] [Hd Hr]]].
    subst A. exists (f[∅]).
    ext y Hy.
    + apply ranE in Hy as [x Hp].
      apply domI in Hp as Hx. rewrite Hd in Hx.
      rewrite one in Hx. apply SingE in Hx. subst x.
      apply func_ap in Hp... subst y...
    + apply SingE in Hy. subst y. eapply ap_ran.
      split... rewrite Hd. apply BUnionI2...
  - intros [a Heq]. subst A. apply eqnum_single.
Qed.

(* 集合与2等势当且仅当它是真配对 *)
Lemma eqnum_two_iff : ∀ A, A ≈ 2 ↔ ∃ a b, a ≠ b ∧ A = {a, b}.
Proof with eauto.
  split.
  - intros Hqn. symmetry in Hqn.
    destruct Hqn as [f [Hinj [Hd Hr]]].
    assert (H := Hinj). destruct H as [Hf _].
    subst A. exists (f[∅]), (f[1]). split.
    + intros Heq. apply injectiveE in Heq...
      rewrite Hd. apply BUnionI1...
      rewrite Hd. apply BUnionI2...
    + ext y Hy.
      * apply ranE in Hy as [x Hp].
        apply domI in Hp as Hx. rewrite Hd in Hx.
        rewrite two in Hx. apply TwoE in Hx as []; subst x;
        apply func_ap in Hp; auto; subst y...
        apply PairI1. rewrite <- one. apply PairI2.
      * apply PairE in Hy as []; subst y; eapply ap_ran.
        split... apply BUnionI1... split... apply BUnionI2...
  - intros [a [b [Hnq Heq]]]. subst A. apply eqnum_pair...
Qed.

(* 配对与贰等势 *)
Lemma eqnum_pair_two : ∀ a b, a ≠ b → {a, b} ≈ 2.
Proof with eauto; try congruence.
  intros * Hnq. set (Func {a, b} 2 (λ x, match (ixm (x = a)) with
    | inl _ => 0
    | inr _ => 1
  end)) as F.
  assert (H1_2: 1 ∈ 2). apply suc_has_n.
  assert (H0_2: 0 ∈ 2) by (apply suc_has_0; apply ω_inductive; nauto).
  exists F. apply meta_bijection.
  - intros x Hx. destruct (ixm (x = a))...
  - intros x1 Hx1 x2 Hx2 Heq.
    destruct (ixm (x1 = a)); destruct (ixm (x2 = a));
    apply PairE in Hx1 as []; apply PairE in Hx2 as []...
    exfalso; eapply suc_neq_0... exfalso; eapply suc_neq_0...
  - intros y Hy. rewrite two in Hy. apply PairE in Hy as [].
    exists a. split. apply PairI1. destruct (ixm (a = a))...
    exists b. split. apply PairI2. destruct (ixm (b = a))... rewrite one...
Qed.

(* 所有的单集等势 *)
Lemma all_single_eqnum : ∀ a b, {a,} ≈ {b,}.
Proof. intros. now repeat rewrite eqnum_single. Qed.
Global Hint Immediate all_single_eqnum : core.

(* 集合与单集的笛卡尔积与原集合等势 *)
Lemma eqnum_cprd_single : ∀ A a, A ≈ A × {a,}.
Proof with auto.
  intros. set (Func A (A × { a ,}) (λ x, <x, a>)) as F.
  exists F. apply meta_bijection.
  - intros x Hx. apply CPrdI...
  - intros x1 Hx1 x2 Hx2 Heq.
    apply op_iff in Heq as []...
  - intros y Hy. apply CPrdE1 in Hy as [b [Hb [c [Hc Heq]]]].
    apply SingE in Hc. subst. exists b. split...
Qed.

(* 笛卡尔积在等势意义下满足交换律 *)
Lemma eqnum_cprd_comm : ∀ A B, A × B ≈ B × A.
Proof with auto.
  intros. set (Func (A × B) (B × A) (λ x, <π2 x, π1 x>)) as F.
  exists F. apply meta_bijection.
  - intros x Hx.
    apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
    subst. zfc_simple. apply CPrdI...
  - intros x1 Hx1 x2 Hx2 Heq.
    apply CPrdE1 in Hx1 as [a [Ha [b [Hb Hx1]]]].
    apply CPrdE1 in Hx2 as [c [Hc [d [Hd Hx2]]]].
    subst. zfc_simple.
    apply op_iff in Heq as []. congruence.
  - intros y Hy.
    apply CPrdE1 in Hy as [a [Ha [c [Hc Hy]]]].
    exists <c, a>. split. apply CPrdI... zfc_simple.
Qed.

(* 笛卡尔积在等势意义下满足结合律 *)
Lemma eqnum_cprd_assoc : ∀ A B C, (A × B) × C ≈ A × (B × C).
Proof with auto.
  intros.
  set (Func ((A × B) × C) (A × (B × C)) (λ x,
    <π1 (π1 x), <π2 (π1 x), π2 x>>
  )) as F.
  exists F. apply meta_bijection.
  - intros x Hx.
    apply CPrdE1 in Hx as [d [Hd [c [Hc H1]]]].
    apply CPrdE1 in Hd as [a [Ha [b [Hb H2]]]].
    subst. zfc_simple. apply CPrdI... apply CPrdI...
  - intros x1 Hx1 x2 Hx2 Heq.
    apply CPrdE1 in Hx1 as [d1 [Hd1 [c1 [Hc1 H11]]]].
    apply CPrdE1 in Hd1 as [a1 [Ha1 [b1 [Hb1 H12]]]].
    apply CPrdE1 in Hx2 as [d2 [Hd2 [c2 [Hc2 H21]]]].
    apply CPrdE1 in Hd2 as [a2 [Ha2 [b2 [Hb2 H22]]]].
    apply op_iff in Heq as [H1 H2].
    apply op_iff in H2 as [H2 H3]. subst. zfc_simple.
  - intros y Hy.
    apply CPrdE1 in Hy as [a [Ha [d [Hd H1]]]].
    apply CPrdE1 in Hd as [b [Hb [c [Hc H2]]]].
    exists <a, b, c>. split. apply CPrdI... apply CPrdI... zfc_simple.
Qed.

(* 任意集合的幂集与该集合到贰的所有函数的集合等势 *)
Lemma power_eqnum_func_to_2 : ∀ A, 𝒫 A ≈ A ⟶ 2.
Proof with neauto.
  intros.
  set (λ B, Func A 2 (λ x,
    match (ixm (x ∈ B)) with
      | inl _ => 1
      | inr _ => 0
    end
  )) as ℱ.
  set (Func (𝒫 A) (A ⟶ 2) (λ B, ℱ B)) as G.
  assert (H1_2: 1 ∈ 2). apply suc_has_n.
  assert (H0_2: 0 ∈ 2) by (apply suc_has_0; apply ω_inductive; nauto).
  exists G. apply meta_bijection.
  - intros B HB. apply arrow_iff. split...
    apply func_is_func. split.
    + ext Hx.
      * apply domE in Hx as [y Hp]. apply SepE1 in Hp.
        apply CPrdE2 in Hp as []...
      * destruct (classic (x ∈ B)). {
          eapply domI. apply SepI.
          - apply CPrdI. apply Hx. apply H1_2.
          - zfc_simple. destruct (ixm (x ∈ B))... exfalso...
        } {
          eapply domI. apply SepI.
          - apply CPrdI. apply Hx. apply H0_2.
          - zfc_simple. destruct (ixm (x ∈ B))... exfalso...
        }
    + intros x Hx. destruct (classic (x ∈ B)).
      * cut ((ℱ B)[x] = 1). congruence.
        apply func_ap... apply func_is_func.
        apply SepI. apply CPrdI... zfc_simple.
        destruct (ixm (x ∈ B))... exfalso...
      * cut ((ℱ B)[x] = 0). congruence.
        apply func_ap... apply func_is_func.
        apply SepI. apply CPrdI... zfc_simple.
        destruct (ixm (x ∈ B))... exfalso...
  - intros B1 H1 B2 H2 Heq.
    apply PowerAx in H1. apply PowerAx in H2.
    ext a Hab.
    + assert (Hp: <a, 1> ∈ ℱ B1). {
        apply SepI. apply CPrdI... zfc_simple.
        destruct (ixm (a ∈ B1))... exfalso...
      }
      rewrite Heq in Hp. apply SepE2 in Hp. zfc_simple.
      destruct (ixm (a ∈ B2))... exfalso. eapply suc_neq_0...
    + assert (Hp: <a, 1> ∈ ℱ B2). {
        apply SepI. apply CPrdI... zfc_simple.
        destruct (ixm (a ∈ B2))... exfalso...
      }
      rewrite <- Heq in Hp. apply SepE2 in Hp. zfc_simple.
      destruct (ixm (a ∈ B1))... exfalso. eapply suc_neq_0...
  - intros y Hy. set {x ∊ A | y[x] = 1} as B.
    exists B. split. apply PowerAx. apply sep_sub.
    apply SepE in Hy as [Hy [Hfy [Hdy Hry]]]. apply PowerAx in Hy.
    ext x Hxy.
    + apply SepE in Hxy as [Hx Heq].
      apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
      subst x. zfc_simple. rewrite <- Hdy in Ha.
      destruct (ixm (a ∈ B)) as [H|H]; subst b.
      * apply SepE in H as [].
        rewrite <- H0. apply func_correct...
      * apply func_correct in Ha as Hap...
        apply ranI in Hap. apply Hry in Hap.
        rewrite two in Hap. apply TwoE in Hap as []... {
          rewrite pred, <- H0. apply func_correct...
        } {
          exfalso. apply H. apply SepI.
          rewrite <- Hdy... rewrite one...
        }
    + apply Hy in Hxy as Hxp. apply SepI...
      apply CPrdE1 in Hxp as [a [Ha [b [Hb Hx]]]].
      subst x. zfc_simple. destruct (ixm (a ∈ B)) as [H|H].
      * apply SepE2 in H as Hap. rewrite <- Hap.
        symmetry. apply func_ap...
      * rewrite two in Hb. apply TwoE in Hb as []...
        exfalso. subst b. rewrite <- one in Hxy.
        apply H. apply SepI... apply func_ap...
Qed.

(* 康托定理：任意集合都不与自身的幂集等势 *)
Theorem Cantor's : ∀ A, A ≉ 𝒫 A.
Proof with auto.
  intros A [f [[Hf _] [Hd Hr]]].
  set {x ∊ A | x ∉ f[x]} as B.
  assert (Hsub: B ⊆ A) by apply sep_sub.
  apply PowerAx in Hsub as HB. rewrite <- Hr in HB.
  apply ranE in HB as [x Hap]. apply domI in Hap as Hx.
  rewrite Hd in Hx. apply func_ap in Hap...
  destruct (classic (x ∈ B)).
  - apply SepE2 in H. apply H. rewrite Hap. apply SepI...
  - apply H. apply SepI... rewrite Hap...
Qed.

(* 鸽笼原理引理：任意自然数到自身的单射是满射 *)
Lemma injection_between_same_nat_surjective :
  ∀n ∈ ω, ∀ f, f: n ⇔ n → ran f = n.
Proof with neauto; try congruence.
  intros n Hn.
  ω_induction n. {
    intros f [_ [_ Hr]]. apply sub_antisym...
    intros x Hx. exfalso0.
  }
  rename m into k.
  assert (Hstar: ∀ f, f: k⁺ ⇔ k⁺ → (∀p ∈ k, f[p] ∈ k) → ran f = k⁺). {
    intros f [[Hf Hs] [Hd Hr]] H.
    assert (Hr': ran (f ↾ k) = k). {
      apply IH. split. apply restr_injective... split...
      split... apply restr_dom... rewrite Hd...
      intros y Hy. apply ranE in Hy as [x Hp].
      apply restrE2 in Hp as [Hp Hx]...
      apply func_ap in Hp... subst. apply H...
    }
    assert (Hkd: k ∈ dom f) by (rewrite Hd; nauto).
    assert (Hfk: f[k] = k). {
      apply domE in Hkd as [y Hp]. apply ranI in Hp as Hy.
      apply Hr in Hy. apply BUnionE in Hy as [Hy|Hy].
      - exfalso. rewrite <- Hr' in Hy.
        apply ranE in Hy as [x Hp'].
        apply restrE2 in Hp' as [Hp' Hx]...
        eapply singrE in Hp... subst.
        eapply nat_irrefl...
      - apply SingE in Hy; subst. apply func_ap...
    }
    apply sub_antisym... intros p Hp.
    rewrite (ran_split_by_restr _ _ _ Hd).
    apply BUnionE in Hp as [].
    + apply BUnionI1. rewrite Hr'...
    + apply BUnionI2. rewrite ran_of_restr_to_single...
  }
  clear Hn n IH. intros f Hf.
  destruct (classic (∀p ∈ k, f[p] ∈ k)). { apply Hstar... }
  rewrite set_not_all_ex_not in H. destruct H as [p [Hp Hout]].
  assert (Hpw: p ∈ ω) by (eapply ω_trans; eauto).
  assert (Hpd: p ∈ k⁺) by (apply BUnionI1; nauto).
  assert (Hkd: k ∈ k⁺) by nauto.
  pose proof (injection_swap_value f k⁺ k⁺ p Hpd k Hkd Hf) as [Hf' Hreq].
  remember (FuncSwapValue f p k) as f'.
  rewrite <- Hreq. apply Hstar... clear Hstar Hreq.
  assert (Hfp: f[p] = k). {
    cut (f[p] ∈ k⁺). intros.
    - apply BUnionE in H as [|Hfp]. exfalso... apply SingE in Hfp...
    - eapply ap_ran... apply injection_is_func...
  }
  destruct Hf as [[Hf Hs] [Hd Hr]].
  assert (Hfk: f[k] ∈ k). {
    rewrite <- Hd in Hkd. apply func_correct in Hkd as Hpr...
    apply ranI in Hpr as Hyr. apply Hr in Hyr.
    apply BUnionE in Hyr as [|Hyr]... apply SingE in Hyr.
    exfalso. cut (k = p). intros. rewrite H in Hp.
    eapply nat_irrefl... eapply injectiveE... split...
  }
  destruct Hf' as [[Hf' _] [Hd' _]]. intros x Hx.
  destruct (classic (x = p)) as [Hxp|Hxp]; [|
  destruct (classic (x = k)) as [Hxk|Hxk]].
  - subst x. rewrite <- Hd' in Hpd.
    apply domE in Hpd as [y Hpr]. apply func_ap in Hpr as Hap...
    rewrite Heqf' in Hpr. apply SepE in Hpr as [_ Hpr]. zfc_simple.
    destruct (ixm (p = p))...
  - subst x. exfalso. eapply nat_irrefl...
  - assert (Hxd: x ∈ dom f) by (rewrite Hd; apply BUnionI1; auto).
    assert (Hxd': x ∈ dom f') by (rewrite Hd'; apply BUnionI1; auto).
    apply domE in Hxd' as [y Hpr]. apply func_ap in Hpr as Hap...
    rewrite Heqf' in Hpr. apply SepE in Hpr as [_ Hpr]. zfc_simple.
    destruct (ixm (x = p))... destruct (ixm (x = k))...
    subst y. rewrite Hap. clear Hap n n0 Hx Hxk.
    apply domE in Hxd as [y Hpr].
    apply domI in Hpr as Hxd. apply ranI in Hpr as Hy.
    apply func_ap in Hpr... subst y. apply Hr in Hy.
    apply BUnionE in Hy as []... apply SingE in H.
    exfalso. apply Hxp. eapply injectiveE... split...
Qed.

Import WosetMin.SimpleVer.

(* 任意自然数到自身的满射是单射 *)
Lemma surjection_between_same_nat_injective :
  ∀n ∈ ω, ∀ f, f: n ⟹ n → injective f.
Proof with eauto; try congruence.
  intros n Hn f [Hf [Hd Hr]].
  set (λ y, {n ∊ ω | f[n] = y}) as 𝒩.
  set (Func n n (λ y, (Min Lt)[𝒩 y])) as g.
  assert (Hg: g: n ⇒ n). {
    apply meta_function.
    intros y Hy. rewrite <- Hr in Hy.
    apply ranE in Hy as [x Hp]. apply domI in Hp as Hx.
    rewrite Hd in Hx. apply func_ap in Hp...
    assert (Hxw: x ∈ ω). { eapply ω_trans... }
    assert (Hxn: x ∈ 𝒩 y). { apply SepI... }
    specialize (ω_min (𝒩 y)) as [Hm Hle].
    + exists x...
    + intros w Hw. apply SepE1 in Hw...
    + apply SepE in Hm as [Hm _].
      apply Hle in Hxn as [].
      * apply (nat_trans n Hn _ x)...
      * subst...
  }
  assert (Hfgy: ∀y ∈ n, f[g[y]] = y). {
    intros y Hy. unfold g.
    rewrite meta_func_ap...
    specialize (ω_min (𝒩 y)) as [H _]...
    - rewrite <- Hr in Hy. apply ranE in Hy as [x Hp].
      apply domI in Hp as Hx. apply func_ap in Hp...
      exists x. apply SepI... eapply ω_trans...
    - intros x Hx. apply SepE1 in Hx...
    - apply SepE2 in H...
  }
  assert (Hig: g: n ⇔ n). {
    destruct Hg as [Hfg [Hdg Hrg]]. split... split...
    intros y Hy. rewrite <- unique_existence.
    split. apply ranE in Hy...
    intros y1 y2 H1 H2.
    apply domI in H1 as Hy1. apply func_ap in H1...
    apply domI in H2 as Hy2. apply func_ap in H2...
    assert (f[g[y1]] = f[g[y2]])...
    rewrite Hfgy, Hfgy in H...
  }
  apply injection_between_same_nat_surjective in Hig as Hrg...
  destruct Hg as [Hfg [Hdg _]].
  split... intros y Hy. rewrite <- unique_existence.
  split. apply ranE in Hy...
  intros x1 x2 H1 H2.
  apply domI in H1 as Hx1. rewrite Hd, <- Hrg in Hx1.
  apply domI in H2 as Hx2. rewrite Hd, <- Hrg in Hx2.
  apply ranE in Hx1 as [y1 Hg1]. apply domI in Hg1 as Hy1.
  apply ranE in Hx2 as [y2 Hg2]. apply domI in Hg2 as Hy2.
  apply func_ap in H1... apply func_ap in Hg1...
  apply func_ap in H2... apply func_ap in Hg2...
  assert (f[g[y1]] = f[g[y2]])...
  rewrite Hfgy, Hfgy in H...
Qed.

(* 鸽笼原理：任意自然数都不与自身的真子集等势 *)
Theorem pigeonhole : ∀ k, ∀n ∈ ω, k ⊂ n → n ≉ k.
Proof with eauto.
  intros k n Hn [Hsub Hnq] [f [[Hf Hs] [Hd Hr]]].
  apply Hnq. rewrite <- Hr. eapply injection_between_same_nat_surjective...
  split; split... rewrite Hr...
Qed.

(* 有限集与无限集的定义 *)
Definition finite : set → Prop := λ A, ∃n ∈ ω, A ≈ n.
Definition infinite : set → Prop := λ A, ¬finite A.

(* 空集是有限集 *)
Fact empty_finite : finite ∅.
Proof. exists ∅. now split; nauto. Qed.
Global Hint Resolve empty_finite : core.

(* 单集是有限集 *)
Fact single_finite : ∀ a, finite {a,}.
Proof. exists 1. split. nauto. apply eqnum_single. Qed.
Global Hint Resolve single_finite : core.

(* 配对是有限集 *)
Fact pair_finite : ∀ a b, a ≠ b → finite {a, b}.
Proof. exists 2. split. nauto. apply eqnum_pair_two. apply H. Qed.

(* 自然数是有限集 *)
Fact nat_finite : ∀n ∈ ω, finite n.
Proof.
  intros n Hn. exists n. split. apply Hn. reflexivity.
Qed.

(* 无限集非空 *)
Fact infinite_set_nonempty : ∀ A, infinite A → ⦿ A.
Proof.
  intros A Hinf. apply EmptyNE.
  intros H. apply Hinf. subst. auto.
Qed.

(* 集合有限当且仅当其存在有限集与其等势 *)
Lemma set_finite_iff_eqnum_finite_set : ∀ A,
  finite A ↔ ∃ B, A ≈ B ∧ finite B.
Proof with auto.
  split. intros [n [Hn Hqn]]. exists n. split... apply nat_finite...
  intros [B [H1 [n [Hn H2]]]]. exists n. split... rewrite <- H2...
Qed.

(* 鸽笼原理推论：任意有限集都不与自身的真子集等势 *)
Corollary no_fin_set_eqnum_its_proper_subset : ∀ A B,
  finite A → B ⊂ A → A ≉ B.
Proof with eauto.
  intros * [n [Hn [g Hg]]] Hsub [f Hf].
  assert (Hf': f: A ⇔ A). {
    destruct Hf as [Hf [Hd Hr]]. destruct Hsub as [Hsub _].
    split... split... rewrite <- Hr in Hsub...
  }
  pose proof (injection_transform f g A n Hf' Hg) as [Hih [Hdh Hrh]].
  remember (g ∘ f ∘ g⁻¹) as h.
  assert (Hrh': ran h ⊂ n). {
    destruct Hf as [_ [_ Hrf]].
    destruct Hg as [Hig [Hdg Hrg]].
    assert (Hig' := Hig). destruct Hig' as [Hg Hsg].
    apply comp_nonempty in Hsub as [a Ha].
    apply CompE in Ha as [Ha Ha'].
    apply properSub_intro... exists (g[a]). split.
    - rewrite <- Hrg. eapply ranI.
      apply func_correct... rewrite Hdg...
    - intros Hga. apply ranE in Hga as [x Hp]. rewrite Heqh in Hp.
      apply compoE in Hp as [y [_ Hp]].
      apply compoE in Hp as [z [H1 H2]].
      apply domI in H2 as Hzd. apply func_ap in H2...
      apply injectiveE in H2; auto; [|rewrite Hdg]...
      clear Hzd. subst z. apply ranI in H1. rewrite Hrf in H1...
  }
  apply (pigeonhole (ran h) n)... exists h. split...
Qed.

(* 与自身的真子集等势的集合是无限集 *)
Corollary infinite_if_eqnum_proper_sub : ∀ A B,
  B ⊂ A → A ≈ B → infinite A.
Proof.
  intros A B Hsub Heqn Hfin.
  eapply no_fin_set_eqnum_its_proper_subset; eauto.
Qed.

(* ω是无限集 *)
Corollary ω_infinite : infinite ω.
Proof with nauto.
  set (ω - {0,}) as B.
  assert (H0: 0 ∉ B). {
    intros H. apply SepE in H as [_ H]. apply H...
  }
  assert (Hsub: B ⊂ ω). {
    apply properSub_intro...
    intros n Hn. apply CompE in Hn as []...
    exists 0. split...
  }
  eapply infinite_if_eqnum_proper_sub. apply Hsub.
  destruct σ_function as [Hf [Hd _]].
  exists σ. split; split...
  - intros y Hy. rewrite <- unique_existence.
    split. apply ranE in Hy...
    intros x1 x2 H1 H2.
    apply ReplAx in H1 as [m [Hm H1]].
    apply ReplAx in H2 as [n [Hn H2]].
    apply op_iff in H1 as [];
    apply op_iff in H2 as []; subst.
    apply suc_injective in H3...
  - ext y Hy.
    + apply ranE in Hy as [x Hp].
      apply domI in Hp as Hx. rewrite Hd in Hx.
      apply func_ap in Hp... subst y. rewrite σ_ap...
      apply CompI. apply ω_inductive... apply SingNI...
    + apply CompE in Hy as [Hy Hy']. apply SingNE in Hy'.
      ω_destruct y. exfalso...
      eapply ranI. apply ReplAx. exists y. split...
Qed.

(* 与自然数等势的集合是无限集 *)
Corollary eqnum_to_ω_impl_infinite : ∀ A, A ≈ ω → infinite A.
Proof.
  intros A H1 [n [Hn H2]].
  apply ω_infinite. exists n. split. apply Hn.
  rewrite <- H1, <- H2. reflexivity.
Qed.

(* 有限集与唯一自然数等势 *)
Corollary fin_set_eqnum_unique_nat : ∀ A, finite A →
  ∃! n, n ∈ ω ∧ A ≈ n.
Proof with eauto.
  intros A Hfin. rewrite <- unique_existence. split...
  intros m n [Hm H1] [Hn H2].
  contra.
  rewrite H1 in H2.
  apply nat_connected in H as []...
  - apply lt_iff_psub in H... apply (no_fin_set_eqnum_its_proper_subset n m)...
    apply nat_finite... symmetry...
  - apply lt_iff_psub in H...
    apply (no_fin_set_eqnum_its_proper_subset m n)... apply nat_finite...
Qed.

(* 等势的自然数相等 *)
Corollary nat_eqnum_eq : ∀ m n ∈ ω, m ≈ n → m = n.
Proof with auto.
  intros m Hm n Hn Hqn.
  contra.
  apply nat_connected in H as []...
  - apply lt_iff_psub in H... apply (no_fin_set_eqnum_its_proper_subset n m)...
    apply nat_finite... symmetry...
  - apply lt_iff_psub in H...
    apply (no_fin_set_eqnum_its_proper_subset m n)... apply nat_finite...
Qed.

(* 有限基数 *)
Definition FinCard : set → set := λ A, ⋃{n ∊ ω | A ≈ n}.

(* 有限基数定义为与有限集自身等势的自然数 *)
Lemma fin_card_correct : ∀ A, finite A →
  ∃n ∈ ω, FinCard A = n ∧ A ≈ n.
Proof with auto.
  intros A Hfin. assert (Hfin' := Hfin).
  destruct Hfin' as [n [Hn H1]]. exists n. repeat split...
  ext Hx.
  - apply UnionAx in Hx as [m [Hm Hx]].
    apply SepE in Hm as [Hm H2].
    cut (m = n). congruence.
    eapply unique_existence.
    apply (fin_set_eqnum_unique_nat A)... easy. easy.
  - apply UnionAx. exists n. split... apply SepI...
Qed.

(* 有限集与其基数等势 *)
Lemma fin_set_eqnum_its_card : ∀ A, finite A → A ≈ FinCard A.
Proof.
  intros A Hfin.
  apply fin_card_correct in Hfin as [n [_ [Hc Hqn]]].
  congruence.
Qed.

(* 两个有限集等势当且仅当它们的基数相等 *)
Lemma fin_sets_eqnum_iff_cards_eq : ∀ A B, finite A → finite B →
  FinCard A = FinCard B ↔ A ≈ B.
Proof with auto.
  intros A B H1 H2.
  apply fin_card_correct in H1 as [m [Hm [H11 H12]]].
  apply fin_card_correct in H2 as [n [Hn [H21 H22]]].
  split; intros.
  - rewrite H12. symmetry. congruence.
  - cut (m ≈ n). intros Hqn.
    + apply nat_eqnum_eq in Hqn... congruence.
    + rewrite <- H12, <- H22...
Qed.

(* 自然数的基数与该自然数相等 *)
Lemma fin_card_n : ∀n ∈ ω, FinCard n = n.
Proof with auto.
  intros n Hn.
  ext Hx.
  - apply UnionAx in Hx as [m [Hm Hx]].
    apply SepE in Hm as [Hm Hqn].
    apply nat_eqnum_eq in Hqn... congruence.
  - apply UnionAx. exists n. split... now apply SepI...
Qed.

(* 自然数的子集是有限集 *)
Lemma subset_of_ω_is_finite : ∀n ∈ ω, ∀ C,
  C ⊂ n → ∃m ∈ ω, m ∈ n ∧ C ≈ m.
Proof with neauto.
  intros n Hn.
  ω_induction n; intros C [Hsub Hnq].
  - exfalso. apply Hnq. apply EmptyI.
    intros x Hx. apply Hsub in Hx. exfalso0.
  - rename m into k. rename Hm into Hk.
    (* C = {0, 1 ... k-1} | k *)
    destruct (classic (C = k)) as [|Hnq']. {
      exists k. split... split... now subst.
    }
    destruct (classic (k ∈ C)) as [Hkc|Hkc]; revgoals.
    + (* C = {0, 1 ... k-2} | k-1, k *)
      assert (Hps: C ⊂ k). {
        split... intros x Hx. apply Hsub in Hx as Hxk.
        apply BUnionE in Hxk as []... exfalso.
        apply SingE in H. subst...
      }
      apply IH in Hps as [m [Hmw [Hmk Hqn]]].
      exists m. split... split... apply BUnionI1...
    + (* C = {0, 1 ... k-2, k} | k-1 *)
      assert (HC: C = (C ∩ k) ∪ {k,}). {
        ext Hx.
        - destruct (classic (x = k)).
          + apply BUnionI2. subst...
          + apply BUnionI1. apply BInterI...
            apply Hsub in Hx. apply BUnionE in Hx as [|Hx]...
            exfalso. apply SingE in Hx...
        - apply BUnionE in Hx as [Hx|Hx].
          + apply BInterE in Hx as []...
          + apply SingE in Hx. subst...
      }
      assert (Hps: C ∩ k ⊂ k). {
        split. intros x Hx. apply BInterE in Hx as []...
        intros H. rewrite binter_comm, <- ex2_17_1_4 in H.
        apply Hnq. ext Hx.
        - apply Hsub in Hx...
        - apply BUnionE in Hx as []. apply H in H0...
          apply SingE in H0. subst...
      }
      apply IH in Hps as [m [Hmw [Hmk [f Hf]]]].
      exists (m⁺). split. apply ω_inductive... split.
      apply suc_preserve_lt in Hmk...
      exists (f ∪ {<k, m>,}). rewrite HC.
      apply bijection_add_point...
      * intros H. apply BInterE in H as [_ H].
        eapply nat_irrefl; revgoals...
      * eapply nat_irrefl...
Qed.

(* 单射的定义域与该单射的像等势 *)
Lemma dom_of_injection_eqnum_img :
  ∀ F A, injective F → A ⊆ dom F → A ≈ F⟦A⟧.
Proof with eauto.
  intros F A Hi Hsub. exists (F ↾ A).
  split... apply restr_injective...
  split. apply restr_dom... destruct Hi... reflexivity.
Qed.

(* 有限集的子集是有限集 *)
Corollary subset_of_finite_is_finite : ∀ A B,
  A ⊆ B → finite B → finite A.
Proof with neauto.
  intros A B H1 [n [Hn [f [Hi [Hd Hr]]]]].
  rewrite <- Hd in H1. apply dom_of_injection_eqnum_img in H1...
  pose proof (img_included f A) as H2. rewrite Hr in H2.
  destruct (classic (f⟦A⟧ = n)) as [Heq|Hnq].
  - exists n. split... rewrite <- Heq...
  - assert (Hps: f⟦A⟧ ⊂ n) by (split; auto).
    apply subset_of_ω_is_finite in Hps as [m [Hm [Hmn Hqn]]]...
    exists m. split... rewrite H1...
Qed.

(* 无限集的父集是无限集 *)
Corollary parent_set_of_infinite_is_infinite : ∀ A B,
  A ⊆ B → infinite A → infinite B.
Proof.
  intros * Hsub Hinf Hfin. apply Hinf.
  eapply subset_of_finite_is_finite; eauto.
Qed.

Lemma cprd_disjoint_l : ∀ A B C D,
  disjoint A C → disjoint (A × B) (C × D).
Proof.
  intros * Hdj. apply disjointI. intros [x [H1 H2]].
  apply CPrdE1 in H1 as [a [Ha [b [Hb Hx]]]]. subst x.
  apply CPrdE2 in H2 as [Ha' _].
  eapply disjointE; eauto.
Qed.

Lemma cprd_disjoint_r : ∀ A B C D,
  disjoint B D → disjoint (A × B) (C × D).
Proof.
  intros * Hdj. apply disjointI. intros [x [H1 H2]].
  apply CPrdE1 in H1 as [a [Ha [b [Hb Hx]]]]. subst x.
  apply CPrdE2 in H2 as [_ Hb'].
  eapply disjointE; eauto.
Qed.

(* 不交化：通过笛卡尔积构造出分别与原集合等势但不交的两个集合 *)
Lemma cprd_disjointify : ∀ A B m n,
  m ≠ n → disjoint (A × {m,}) (B × {n,}).
Proof.
  intros. apply cprd_disjoint_r.
  apply disjointI. intros [x [H1 H2]].
  apply SingE in H1. apply SingE in H2. congruence.
Qed.

Corollary disjointify_0_1 : ∀ A B, disjoint (A × {0,}) (B × {1,}).
Proof.
  intros. apply cprd_disjointify. intro. eapply suc_neq_0. eauto.
Qed.

(* 任意自然数与自身的单集不交 *)
Lemma nat_disjoint : ∀n ∈ ω, disjoint n {n,}.
Proof.
  intros n Hn. apply disjointI. intros [x [H1 H2]].
  apply SingE in H2. subst. eapply nat_irrefl; eauto.
Qed.

(* 等势的集合分别除去一个元素仍然等势 *)
Lemma eqnum_sets_removing_one_element_still_eqnum :
  ∀ A B a b, A ∪ {a,} ≈ B ∪ {b,} →
  disjoint A {a,} → disjoint B {b,} → A ≈ B.
Proof with eauto; try congruence.
  intros * [f Hf] Hdja Hdjb. assert (Hf' := Hf).
  destruct Hf' as [Hi [Hd Hr]].
  set (FuncSwapValue f a f⁻¹[b]) as g.
  assert (Ha: a ∈ A ∪ {a,}) by (apply BUnionI2; auto).
  assert (Hbr: b ∈ ran f). { rewrite Hr. apply BUnionI2... }
  assert (Hb: f⁻¹[b] ∈ A ∪ {a,}). {
    destruct Hi as [Hff Hs].
    rewrite <- Hd, <- inv_ran. eapply ap_ran. split...
    apply inv_func_iff_sr... rewrite inv_dom...
  }
  apply (bijection_swap_value _ _ _ _ Ha _ Hb) in Hf as Hg.
  assert (Hga: g[a] = b). {
    apply func_ap... destruct Hg as [[Hg _] _]...
    apply SepI. apply CPrdI... zfc_simple.
    destruct (ixm (a = a))... rewrite inv_ran_reduction...
  }
  clear Hf Hi Hd Hr Ha Hbr Hb.
  destruct Hg as [Hi [Hd Hr]]. assert (Hi' := Hi).
  destruct Hi as [Hg Hs].
  exists (g ↾ A). split; [|split].
  - apply restr_injective...
  - apply restr_dom... intros x Hx. subst g.
    rewrite Hd. apply BUnionI1...
  - ext y Hy.
    + apply ranE in Hy as [x Hp].
      apply restrE2 in Hp as [Hp Hx].
      apply ranI in Hp as Hy. subst g. rewrite Hr in Hy.
      apply BUnionE in Hy as []...
      apply SingE in H. subst y. apply func_ap in Hp...
      rewrite <- Hp in Hga. cut (a = x).
      * intros H. subst x. exfalso. eapply disjointE.
        apply Hdja. apply Hx. apply SingI.
      * eapply injectiveE...
        rewrite Hd. apply BUnionI2...
        rewrite Hd. apply BUnionI1...
    + assert (y ∈ ran g). { subst g. rewrite Hr. apply BUnionI1... }
      apply ranE in H as [x Hp]. apply domI in Hp as Hx.
      subst g. rewrite Hd in Hx. apply BUnionE in Hx as [].
      * eapply ranI. apply restrI...
      * apply SingE in H. subst x. apply func_ap in Hp...
        rewrite <- Hp, Hga in Hy. exfalso. eapply disjointE.
        apply Hdjb. apply Hy. apply SingI.
Qed.

(* 从有限集中取出一个元素则基数减1 *)
Corollary finite_set_remove_one_member : ∀ A a, ∀n ∈ ω,
  (A - {a,}) ∪ {a,} ≈ n⁺ → A - {a,} ≈ n.
Proof with eauto.
  intros A a n Hn Hqn.
  eapply eqnum_sets_removing_one_element_still_eqnum...
  apply disjointI. intros [x [H1 H2]]. apply SepE2 in H1...
  apply nat_disjoint...
Qed.


Require Export Modal_syntax.
Require Export List.
Import ListNotations.
Open Scope modal_scope.

(* Returns a list of propvars in phi. *)
Fixpoint pv_in (phi : Modal) : list propvar :=
  match phi with
    #p => [p]
  | m~ ψ => pv_in ψ
  | ψ1 m∧ ψ2 => (pv_in ψ1) ++ (pv_in ψ2)
  | ψ1 m∨ ψ2 => (pv_in ψ1) ++ (pv_in ψ2)
  | ψ1 m→ ψ2 => (pv_in ψ1) ++ (pv_in ψ2)
  | [.] ψ => pv_in ψ
  | <.> ψ => pv_in ψ
  end.


Require Import Autosubst.Autosubst.
Require Import Arith MSets.

Module VarSet := MSetList.Make (Nat_as_OT).
Include VarSet.
Include (WProperties (VarSet)).

Definition fresh s :=
  match max_elt s with
  | None => 0
  | Some n => S n
  end.

Lemma fresh_spec : forall s, ~ In (fresh s) s.
Proof.
  unfold fresh.
  intros s ?.
  remember (max_elt s) as m.
  symmetry in Heqm.
  destruct m.
  - eapply max_elt_spec2; eauto.
  - apply max_elt_spec3 in Heqm.
    destruct (Heqm _ H).
Qed.

Hint Extern 1 (In _ (union _ _)) =>
  apply union_spec.
Hint Extern 1 (In _ (singleton _)) =>
  apply singleton_spec.


Require Import Logic.Axiom.Extensionality.

Require Import Logic.Rel.R.
Require Import Logic.Rel.Id.
Require Import Logic.Rel.Include.
Require Import Logic.Rel.Converse.
Require Import Logic.Rel.Intersect.
Require Import Logic.Rel.Composition.
Require Import Logic.Rel.Coreflexive.

(* Range of a relation defined as coreflexive relation rather than set          *)
Inductive rng (a b:Type) (r:R a b) : Rel b :=
| mkDom : forall (y:b), (exists (x:a), r x y) -> rng a b r y y
.

Arguments rng {a} {b}.

Lemma rng_corefl : forall (a b:Type) (r:R a b), coreflexive (rng r).
Proof.
    unfold coreflexive. intros a b r. apply incl_charac. intros x y H1.
    destruct H1. constructor.
Qed.

Lemma rng_universal : forall (a b:Type) (r:R a b) (s:Rel b), s <= id ->
    rng r <= s <-> r <= s ; r.
Proof.
    intros a b r s H1. split; intros H2; apply incl_charac; intros x y H3.
    - unfold comp. exists y. split; try assumption.
      assert (rng r y y) as H4.
        { constructor. exists x. assumption. }
      apply incl_charac_to with (rng r); assumption.
    - destruct H3 as [y [x H3]].
      apply (incl_charac_to _ _ _ (s ; r)) in H3; try assumption.
      unfold comp in H3. destruct H3 as [z [H3 H4]]. generalize H4. intros H4'.
      apply (incl_charac_to _ _ _ id) in H4'; try assumption.
      destruct H4'. assumption.
Qed.

Lemma rng_inter : forall (a b:Type) (r:R a b),
    rng r = ((r ; conv r) /\ id).
Proof.
    intros a b r. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [y [x H1]]. unfold inter, conv, comp. split.
        + exists x. split; assumption.
        + constructor.
    - unfold inter in H1. destruct H1 as [H1 H2]. destruct H2 as [y].
      constructor. unfold comp in H1. destruct H1 as [x [H1 H2]].
      exists x. assumption.
Qed.

Lemma rng_comp_self : forall (a b:Type) (r:R a b), r = rng r ; r.
Proof.
    intros a b r. apply Ext. intros x y. unfold comp. split; intros H1.
    - exists y. split; try assumption. constructor. exists x. assumption.
    - destruct H1 as [z [H1 H2]]. destruct H2. assumption.
Qed.

Lemma rng_comp : forall (a b c:Type) (r:R a b) (s:R b c),
    rng (s ; r) = rng (s ; rng r).
Proof.
    intros a b c r s. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [y [x H1]]. constructor. unfold comp in H1.
      destruct H1 as [z [H1 H2]]. exists z. unfold comp. exists z.
      split; try assumption. constructor. exists x. assumption.
    - destruct H1 as [y [x H1]]. constructor. unfold comp in H1.
      destruct H1 as [z [H1 H2]]. destruct H1 as [z [x H1]].
      exists x. exists z. split; assumption.
Qed.

Lemma rng_comp_incl : forall (a b c:Type) (r:R a b) (s:R b c),
    rng (s ; r) <= rng s.
Proof.
    intros a b c r s. apply incl_charac. intros x y H1.
    destruct H1 as [z [x [y [H1 H2]]]]. constructor. exists y. assumption.
Qed.

Lemma rng_inter_conv : forall (a b:Type) (r s:R a b),
    rng (s /\ r) = (id /\ (r ; conv s)).
Proof.
    intros a b r s. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [y [x [H1 H2]]]. split; try constructor.
      exists x. split; assumption.
    - destruct H1 as [H1 [z [H2 H3]]]. destruct H1. constructor.
      exists z. split; assumption.
Qed.

Lemma rng_incl_compat : forall (a b:Type) (r s:R a b),
    r <= s -> rng r <= rng s.
Proof.
    intros a b r s H1. apply incl_charac. intros x y H2.
    destruct H2 as [y [x H2]]. constructor. exists x.
    apply incl_charac_to with r; assumption.
Qed.

Lemma rng_ex4_12 : forall (a b:Type) (r:R a b) (c:Rel b),
    coreflexive c -> rng (c ; r) = c ; rng r.
Proof.
    intros a b r c H1. apply Ext. intros x y. split; intros H2.
    - destruct H2 as [y [x [z [H2 H3]]]].
      apply (incl_charac_to _ _ c id z y) in H1; try assumption.
      destruct H1 as [y]. exists y. split; try assumption. constructor.
      exists x. assumption.
    - destruct H2 as [z [[y' [x' H2]] H3]].
      apply (incl_charac_to _ _ c id y' y) in H1; try assumption.
      destruct H1 as [y]. constructor. exists x'. exists y. split; assumption.
Qed.

Lemma rng_ex4_16 : forall (a b c:Type) (r:R a b) (s:R b c) (t:R a c),
    rng (t /\ (s ; r)) = rng ((t ; conv r) /\ s).
Proof.
    intros a b c r s t. apply Ext. intros x y. split; intros H1.
    - destruct H1 as [z [x [H1 [y [H2 H3]]]]]. constructor. exists y.
      split; try assumption. exists x. split; assumption.
    - destruct H1 as [z [y [[x [H1 H2]] H3]]]. constructor. exists x.
      split; try assumption. exists y. split; assumption.
Qed.


Require Import Iron.Language.SystemF2r.SubstTypeType.
Require Import Iron.Language.SystemF2r.SubstTypeExp.
Require Import Iron.Language.SystemF2r.TyJudge.

(* Substitution of exps in exps preserves typing *)
Theorem subst_exp_exp_ix
 :  forall ix ke te x1 t1 x2 t2
 ,  get  ix te = Some t2
 -> TYPE ke te           x1 t1
 -> TYPE ke (delete ix te) x2 t2
 -> TYPE ke (delete ix te) (substXX ix x2 x1) t1.
Proof.
 intros. gen ix ke te t1 x2 t2.
 induction x1; intros; inverts_type; simpl; eauto.

 Case "XVar".
  fbreak_nat_compare.
  SCase "n = ix".
   rewrite H in H3. inverts H3. auto.

  SCase "n < ix".
   apply TYVar; auto.

  SCase "n > ix".
   apply TYVar; auto.
   rewrite <- H3.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below; burn.

 Case "XLAM".
  eapply (IHx1 ix) in H5.
  apply TYLAM.
   unfold liftTE. rewrite map_delete. eauto.
   eapply get_map. eauto.
   unfold liftTE. rewrite <- map_delete.
    apply type_kienv_weaken. auto.

 Case "XLam".
  apply TYLam; auto.
   rewrite delete_rewind.
   eauto using type_tyenv_weaken.
Qed.

Theorem subst_exp_exp
 :  forall ke te x1 t1 x2 t2
 ,  TYPE ke (te :> t2) x1 t1
 -> TYPE ke te x2 t2
 -> TYPE ke te (substXX 0 x2 x1) t1.
Proof.
 intros.
 rrwrite (te = delete 0 (te :> t2)).
 eapply subst_exp_exp_ix; burn.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Instance.Proset.

Require Import Coq.Classes.Equivalence.
Require Import Coq.Relations.Relation_Definitions.

Generalizable All Variables.

(* Any partially-ordered set forms a category (directly from its preorder,
   since it simply adds asymmetry). See also [Pos], the category of
   partially-ordered sets (where the sets are the objects, and morphisms are
   monotonic mappings.

   Wikipedia: "Every poset (and every preorder) may be considered as a
   category in which every hom-set has at most one element. More explicitly,
   let hom(x, y) = {(x, y)} if x ≤ y (and otherwise the empty set) and (y, z)
   ∘ (x, y) = (x, z). Such categories are sometimes called posetal.

   Posets are equivalent to one another if and only if they are isomorphic. In
   a poset, the smallest element, if it exists, is an initial object, and the
   largest element, if it exists, is a terminal object. Also, every preordered
   set is equivalent to a poset. Finally, every subcategory of a poset is
   isomorphism-closed." *)

Definition Poset {C : Category} `{R : relation C}
           `(P : PreOrder C R) `{Asymmetric C R} : Category := Proset P.


Require Import Coqlib.

Require Export Extensionality.

Ltac spec H :=
  match type of H with ?a -> _ =>
    let H1 := fresh in (assert (H1: a); [|generalize (H H1); clear H H1; intro H]) end.

Lemma f_equal_Some: forall A (x y: A), x=y -> Some x = Some y.
Proof.
intros; f_equal; auto.
Qed.

Lemma f_equal_prod: forall A B (x1 x2: A) (y1 y2: B), x1=x2 -> y1=y2 -> (x1,y1) = (x2,y2).
Proof.
intros; f_equal; auto.
Qed.

Hint Resolve f_equal_Some f_equal_prod.

Unset Implicit Arguments.

Lemma list_norepet_append_inv:
  forall (A : Set) (l1 l2 : list A),
   list_norepet (l1 ++ l2) ->
  list_norepet l1 /\ list_norepet l2 /\ list_disjoint l1 l2.
Proof.
induction l1; simpl; intros.
repeat split; auto. constructor. do 3 intro.
contradiction H0.
inversion H; clear H; subst.
destruct (IHl1 l2 H3) as [? [? ?]].
repeat split; auto.
constructor 2.
intro. contradiction H2. apply in_or_app. auto.
auto.
do 4 intro. intro.
subst.
simpl in H4. destruct H4.
subst. contradiction H2.
apply in_or_app. auto.
unfold list_disjoint in H1.
contradiction (H1 y y H4 H5); auto.
Qed.

Set Implicit Arguments.

(*  The built-in "remember" tactic is weaker than this one!
  The built-in one can lead to "Error: The correctness of the conclusion relies on the body of a"
  where this one will succeed.
  [this comment may be obsolete, perhaps from Coq 8.2 or before
Tactic Notation "remember" constr(a) "as" ident(x) :=
   let x := fresh x in
  let H := fresh "Heq" x in
  (set (x:=a) in *; assert (H: x=a) by reflexivity; clearbody x).
*)

Tactic Notation "if_tac" := match goal with |- context [if ?a then _ else _] => destruct a as [?H | ?H] end.
Tactic Notation "if_tac" simple_intropattern(H)
   := match goal with |- context [if ?a then _ else _] => destruct a as H end.
Tactic Notation "if_tac" "in" hyp(H0)
 := match type of H0 with context [if ?a then _ else _] => destruct a as [?H | ?H] end.
Ltac if_tac_in H := match type of H with context [if ?a then _ else _] => destruct a as [?H0 | ?H0] end.
Tactic Notation "if_tac" simple_intropattern(H) "in" hyp(H1)
 := match type of H1 with context [if ?a then _ else _] => destruct a as H end.

Lemma predicate_max:
  forall (F: nat -> Prop) (Fdec: forall n, {F n}+{~ F n}) n,
  F 0%nat ->
  ~ F n ->
  exists i, F i /\ (i<n)%nat /\ ~ F (S i).
Proof.
intros.
assert (forall m, (m <= n)%nat ->
         (forall k, (k<m)%nat -> F k) \/
         (exists i, F i /\ (i<m)%nat /\ ~ F (S i))).
induction m.
left; intros.
omegaContradiction.
intro.
assert (m<=n)%nat; try omega.
destruct (IHm H2).
assert (m < n \/ m = n)%nat; try omega.
destruct H4.
destruct (Fdec m) as [?H|?H].
left.
intros.
assert (k < m \/ k = m)%nat; try omega.
destruct H7.
auto.
subst k; auto.
right.
exists (Peano.pred m).
destruct m.
contradiction.
replace (Peano.pred (S m)) with m; try omega.
split.
apply H3; try omega.
split; try omega.
auto.
subst m.
right.
destruct n.
contradiction.
exists n; repeat split; auto; try omega.
right.
destruct H3 as [i H4].
destruct H4.
destruct H4.
exists i; repeat split; auto; omega.
assert (n <= n)%nat; try omega.
destruct (H1 _ H2).
destruct n; try contradiction.
exists n; repeat split; auto; try omega.
auto.
Qed.


(*
I hereby assign copyright in my past and future contributions
to the Software Foundations project to the Author of Record of
each volume or component, to be licensed under the same terms
as the rest of Software Foundations. I understand that, at present,
the Authors of Record are as follows: For Volumes 1 and 2, known
until 2016 as "Software Foundations" and from 2016 as (respectively)
"Logical Foundations" and "Programming Foundations," and for Volume 4,
"QuickChick: Property-Based Testing in Coq," the Author of Record is
Benjamin C. Pierce. For Volume 3, "Verified Functional Algorithms",
the Author of Record is Andrew W. Appel. For components outside of
designated volumes (e.g., typesetting and grading tools and other
software infrastructure), the Author of Record is Benjamin Pierce.
*)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Import ListNotations.

From LF Require Import Maps.

Module AExp.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2  => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof. reflexivity. Qed.

Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2   => leb (aeval a1) (aeval a2)
  | BNot b1     => negb (beval b1)
  | BAnd b1 b2  => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
Proof. reflexivity. Qed.

Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a. induction a.
  - (* ANum *) reflexivity.
  - (* APlus *) destruct a1.
    + (* a1 = ANum n *) destruct n.
      * (* n = 0 *)  simpl. apply IHa2.
      * (* n <> 0 *) simpl. rewrite IHa2. reflexivity.
    + (* a1 = APlus a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    + (* a1 = AMinus a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    + (* a1 = AMult a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
  - (* AMinus *)
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.
  - (* AMult *)
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.  Qed.

Theorem silly1 : forall ae, aeval ae = aeval ae.
Proof. try reflexivity. (* this just does [reflexivity] *) Qed.

Theorem silly2 : forall (P : Prop), P -> P.
Proof.
  intros P HP.
  try reflexivity. (* just [reflexivity] would have failed *)
  apply HP. (* we can still finish the proof in some other way *)
Qed.

Lemma foo : forall n, leb 0 n = true.
Proof.
  intros.
  destruct n.
    - (* n=0 *) simpl. reflexivity.
    - (* n=Sn' *) simpl. reflexivity.
Qed.

Lemma foo' : forall n, leb 0 n = true.
Proof.
  intros.
  (* [destruct] the current goal *)
  destruct n;
  (* then [simpl] each resulting subgoal *)
  simpl;
  (* and do [reflexivity] on each resulting subgoal *)
  reflexivity.
Qed.

Theorem optimize_0plus_sound': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
    (* Most cases follow directly by the IH... *)
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
    (* ... but the remaining cases -- ANum and APlus --
       are different: *)
  - (* ANum *) reflexivity.
  - (* APlus *)
    destruct a1;
      (* Again, most cases follow directly by the IH: *)
      try (simpl; simpl in IHa1; rewrite IHa1;
           rewrite IHa2; reflexivity).
    (* The interesting case, on which the [try...]
       does nothing, is when [e1 = ANum n]. In this
       case, we have to destruct [n] (to see whether
       the optimization applies) and rewrite with the
       induction hypothesis. *)
    + (* a1 = ANum n *) destruct n;
      simpl; rewrite IHa2; reflexivity.   Qed.

Theorem optimize_0plus_sound'': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
    (* Most cases follow directly by the IH *)
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);
    (* ... or are immediate by definition *)
    try reflexivity.
  (* The interesting case is when a = APlus a1 a2. *)
  - (* APlus *)
    destruct a1; try (simpl; simpl in IHa1; rewrite IHa1;
                      rewrite IHa2; reflexivity).
    + (* a1 = ANum n *) destruct n;
      simpl; rewrite IHa2; reflexivity. Qed.

Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.

Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; try (left; reflexivity)).
Qed.

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *)
  match b with
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b' => BNot (optimize_0plus_b b')
  | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  | _ => b
  end.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  (* FILL IN HERE *)
  intros.
  induction b;
    try (simpl; reflexivity);
    try (simpl; rewrite optimize_0plus_sound;
         rewrite optimize_0plus_sound; reflexivity).
    simpl. rewrite IHb. reflexivity.
    simpl. rewrite IHb1. rewrite IHb2. reflexivity.
  Qed.

Tactic Notation "simpl_and_try" tactic(c) :=
  simpl;
  try c.

Example silly_presburger_example : forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 ->
  m <= p.
Proof.
  intros. omega.
Qed.

Module aevalR_first_try.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum  : forall (n: nat),
      aevalR (ANum n) n
  | E_APlus : forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus: forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult : forall (e1 e2: aexp) (n1 n2: nat),
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMult e1 e2) (n1 * n2).

Notation "e '\\' n"
         := (aevalR e n)
            (at level 50, left associativity)
         : type_scope.

End aevalR_first_try.

Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult :  forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where "e '\\' n" := (aevalR e n) : type_scope.

Theorem aeval_iff_aevalR : forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
 split.
 - (* -> *)
   intros H.
   induction H; simpl.
   + (* E_ANum *)
     reflexivity.
   + (* E_APlus *)
     rewrite IHaevalR1.  rewrite IHaevalR2.  reflexivity.
   + (* E_AMinus *)
     rewrite IHaevalR1.  rewrite IHaevalR2.  reflexivity.
   + (* E_AMult *)
     rewrite IHaevalR1.  rewrite IHaevalR2.  reflexivity.
 - (* <- *)
   generalize dependent n.
   induction a;
      simpl; intros; subst.
   + (* ANum *)
     apply E_ANum.
   + (* APlus *)
     apply E_APlus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   + (* AMinus *)
     apply E_AMinus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   + (* AMult *)
     apply E_AMult.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
Qed.

Theorem aeval_iff_aevalR' : forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
  (* WORKED IN CLASS *)
  split.
  - (* -> *)
    intros H; induction H; subst; reflexivity.
  - (* <- *)
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
       try apply IHa1; try apply IHa2; reflexivity.
Qed.

Inductive bevalR: bexp -> bool -> Prop :=
  | E_BTrue: bevalR BTrue true
  | E_BFalse: bevalR BFalse false
  | E_BEq1: forall a1 a2 n1 n2,
            aevalR a1 n1 -> aevalR a2 n2 -> n1 = n2 -> bevalR (BEq a1 a2) true
  | E_BEq2: forall a1 a2 n1 n2,
            aevalR a1 n1 -> aevalR a2 n2 -> n1 <> n2 -> bevalR (BEq a1 a2) false
  | E_BLe1: forall a1 a2 n1 n2,
            aevalR a1 n1 -> aevalR a2 n2 -> n1 <= n2 -> bevalR (BLe a1 a2) true
  | E_BLe2: forall a1 a2 n1 n2,
            aevalR a1 n1 -> aevalR a2 n2 -> n2 < n1 -> bevalR (BLe a1 a2) false
  | E_BNot: forall b bb, bevalR b bb -> bevalR (BNot b) (negb bb)
  | E_BAnd: forall b1 b2 bb1 bb2,
            bevalR b1 bb1 -> bevalR b2 bb2 -> bevalR (BAnd b1 b2) (bb1 && bb2).

Lemma n_le_m:
  forall n m,
  leb n m = false -> m < n.

Proof.
  unfold lt.
  intros.
  rewrite <- leb_iff.
  generalize dependent m.
  induction n.
  - intros. simpl in H. inversion H.
  - intros. simpl. simpl in H. destruct m.
    + reflexivity.
    + apply (IHn m H).
  Qed.

Lemma beval_iff_bevalR : forall b bv,
  bevalR b bv <-> beval b = bv.
Proof.
  (* FILL IN HERE *)
  split.
  - intros. induction H;
      try (reflexivity); (*BTrue and BFalse*)
      try (simpl; subst; reflexivity); (*BNot and BAnd*)
      try (apply aeval_iff_aevalR in H; apply aeval_iff_aevalR in H0; simpl;
      subst). (*BEq1,2, BLe1,2 partially*)
      + rewrite H1. rewrite <- beq_nat_refl. reflexivity.
      + rewrite <- beq_nat_false_iff in H1. assumption.
      + apply leb_correct. assumption.
      + apply leb_iff_conv. assumption.
  - generalize dependent bv. induction b.
    + simpl. intros. subst. constructor.
    + simpl. intros. subst. constructor.
    + simpl. intros. destruct bv.
      * apply (E_BEq1 _ _ (aeval a) (aeval a0)).
        apply aeval_iff_aevalR'. reflexivity.
        apply aeval_iff_aevalR'. reflexivity.
        apply beq_nat_true. assumption.
      * apply (E_BEq2 _ _ (aeval a) (aeval a0)).
        apply aeval_iff_aevalR'. reflexivity.
        apply aeval_iff_aevalR'. reflexivity.
        apply beq_nat_false. assumption.
    + simpl. intros. destruct bv.
      * apply (E_BLe1 _ _ (aeval a) (aeval a0)).
        apply aeval_iff_aevalR'. reflexivity.
        apply aeval_iff_aevalR'. reflexivity.
        apply leb_iff. assumption.
      * apply (E_BLe2 _ _ (aeval a) (aeval a0)).
        apply aeval_iff_aevalR'. reflexivity.
        apply aeval_iff_aevalR'. reflexivity.
        apply n_le_m. assumption.
    + simpl. intros. subst. constructor.
      apply IHb. reflexivity.
    + simpl. intros. subst. constructor.
      apply IHb1. reflexivity.
      apply IHb2. reflexivity.
  Qed.

End AExp.

Module aevalR_division.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp
  | ADiv : aexp -> aexp -> aexp.   (* <--- new *)

Reserved Notation "e '\\' n"
                  (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult :  forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)
  | E_ADiv :  forall (a1 a2: aexp) (n1 n2 n3: nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (n2 > 0) ->
      (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_division.

Module aevalR_extended.

Reserved Notation "e '\\' n" (at level 50, left associativity).

Inductive aexp : Type :=
  | AAny  : aexp                   (* <--- NEW *)
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_Any : forall (n:nat),
      AAny \\ n                 (* <--- new *)
  | E_ANum : forall (n:nat),
      (ANum n) \\ n
  | E_APlus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus : forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult :  forall (a1 a2: aexp) (n1 n2 : nat),
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_extended.

(*New Session*)

Open Scope string_scope.

Definition state := total_map nat.

Definition empty_state : state :=
  t_empty 0.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : string -> aexp                (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.
Definition bool_to_bexp (b: bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.

Bind Scope aexp_scope with aexp.
Infix "+" := APlus : aexp_scope.
Infix "-" := AMinus : aexp_scope.
Infix "*" := AMult : aexp_scope.
Bind Scope bexp_scope with bexp.
Infix "<=" := BLe : bexp_scope.
Infix "=" := BEq : bexp_scope.
Infix "&&" := BAnd : bexp_scope.
Notation "'!' b" := (BNot b) (at level 60) : bexp_scope.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x                                (* <----- NEW *)
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => leb (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Notation "{ a --> x }" :=
  (t_update { --> 0 } a x) (at level 0).
Notation "{ a --> x ; b --> y }" :=
  (t_update ({ a --> x }) b y) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z }" :=
  (t_update ({ a --> x ; b --> y }) c z) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z ; d --> t }" :=
    (t_update ({ a --> x ; b --> y ; c --> z }) d t) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }" :=
  (t_update ({ a --> x ; b --> y ; c --> z ; d --> t }) e u) (at level 0).
Notation "{ a --> x ; b --> y ; c --> z ; d --> t ; e --> u ; f --> v }" :=
  (t_update ({ a --> x ; b --> y ; c --> z ; d --> t ; e --> u }) f v) (at level 0).

Example aexp1 :
  aeval { X --> 5 } (3 + (AMult X 2))
  = 13.
Proof. reflexivity. Qed.

Example bexp1 :
  beval { X --> 5 } (true && BNot (BLe X 4))
  = true.
Proof. reflexivity. Qed.

Inductive com : Type :=
  | CSkip : com
  | CAss : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Bind Scope com_scope with com.
Notation "'SKIP'" :=
   CSkip : com_scope.
Notation "x '::=' a" :=
  (CAss x a) (at level 60) : com_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : com_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : com_scope.
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity) : com_scope.

Open Scope com_scope.

Definition fact_in_coq : com :=
  Z ::= X;;
  Y ::= 1;;
  WHILE ! (BEq Z 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END.

Definition plus2 : com :=
  X ::= X + 2.

Definition XtimesYinZ : com :=
  Z ::= X * Y.

Definition subtract_slowly_body : com :=
  Z ::= Z - 1 ;;
  X ::= X - 1.

Definition subtract_slowly : com :=
  WHILE ! (BEq X 0) DO
    subtract_slowly_body
  END.

Definition subtract_3_from_5_slowly : com :=
  X ::= 3 ;;
  Z ::= 5 ;;
  subtract_slowly.

Definition loop : com :=
  WHILE true DO
    SKIP
  END.

Fixpoint ceval_fun_no_while (st : state) (c : com)
                          : state :=
  match c with
    | SKIP =>
        st
    | x ::= a1 =>
        st & { x --> (aeval st a1) }
    | c1 ;; c2 =>
        let st' := ceval_fun_no_while st c1 in
        ceval_fun_no_while st' c2
    | IFB b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_fun_no_while st c1
          else ceval_fun_no_while st c2
    | WHILE b DO c END =>
        st  (* bogus *)
  end.

Reserved Notation "c1 '/' st '\\' st'"
                  (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st \\ st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st \\ st & { x --> n }
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  \\ st' ->
      c2 / st' \\ st'' ->
      (c1 ;; c2) / st \\ st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st \\ st' ->
      (IFB b THEN c1 ELSE c2 FI) / st \\ st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st \\ st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      c / st \\ st' ->
      (WHILE b DO c END) / st' \\ st'' ->
      (WHILE b DO c END) / st \\ st''

  where "c1 '/' st '\\' st'" := (ceval c1 st st').

Example ceval_example1:
    (X ::= 2;;
     IFB X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI)
   / { --> 0 } \\ { X --> 2 ; Z --> 4 }.
Proof.
  (* We must supply the intermediate state *)
  apply E_Seq with { X --> 2 }.
  - (* assignment command *)
    apply E_Ass. reflexivity.
  - (* if command *)
    apply E_IfFalse.
      reflexivity.
      apply E_Ass. reflexivity.  Qed.

(*Exercise 1*)
Example ceval_example2:
  (X ::= 0;; Y ::= 1;; Z ::= 2) / { --> 0 } \\
  { X --> 0 ; Y --> 1 ; Z --> 2 }.
Proof.
  apply E_Seq with (t_update empty_state X 0).
  - apply E_Ass. reflexivity.
  - apply E_Seq with (t_update (t_update empty_state X 0) Y 1).
    + apply E_Ass. reflexivity.
    + apply E_Ass. reflexivity.
Qed.

(*Exercise 2*)
(** Write an Imp program that sums the numbers from [1] to
   [X] (inclusive: [1 + 2 + ... + X]) in the variable [Y].
   Prove that this program executes as intended for [X] = [2]
   (this is trickier than you might expect). *)

Definition pup_to_n : com :=
  (Y ::= (ANum 0) ;; (WHILE (BLe (ANum 1) (AId X))
         DO (Y ::= (APlus (AId X) (AId Y)) ;; X ::= (AMinus (AId X) (ANum 1))) END)).

Theorem pup_to_2_ceval :
  pup_to_n / { X --> 2 }
     \\ { X --> 2 ; Y --> 0 ; Y --> 2 ; X --> 1 ; Y --> 3 ; X --> 0 }.
Proof.
  unfold pup_to_n. apply E_Seq with (t_update (t_update empty_state X 2) Y 0).
  - apply E_Ass. simpl. reflexivity.
  - apply E_WhileTrue with (t_update (t_update (t_update (t_update empty_state X 2) Y 0) Y 2) X 1).
    + simpl. reflexivity.
    + apply E_Seq with (t_update (t_update (t_update empty_state X 2) Y 0) Y 2).
      * apply E_Ass. simpl. rewrite t_update_eq. reflexivity.
      * apply E_Ass. simpl. reflexivity.
    + apply E_WhileTrue with (t_update (t_update (t_update (t_update (t_update (t_update empty_state X 2) Y 0) Y 2) X 1) Y 3) X 0).
      * simpl. reflexivity.
      * apply E_Seq with (t_update (t_update (t_update (t_update (t_update empty_state X 2) Y 0) Y 2) X 1) Y 3).
        { apply E_Ass. simpl. rewrite t_update_shadow. rewrite t_update_permute.
          - rewrite t_update_eq. reflexivity.
          - apply beq_string_false_iff. destruct (beq_string Y X) eqn: H.
            + inversion H.
            + reflexivity. }
        { apply E_Ass. simpl. reflexivity. }
      * apply E_WhileFalse. simpl. reflexivity.
Qed.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st \\ st1  ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1;
           intros st2 E2; inversion E2; subst.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
  - (* E_IfTrue, b1 evaluates to true *)
      apply IHE1. assumption.
  - (* E_IfTrue,  b1 evaluates to false (contradiction) *)
      rewrite H in H5. inversion H5.
  - (* E_IfFalse, b1 evaluates to true (contradiction) *)
    rewrite H in H5. inversion H5.
  - (* E_IfFalse, b1 evaluates to false *)
      apply IHE1. assumption.
  - (* E_WhileFalse, b1 evaluates to false *)
    reflexivity.
  - (* E_WhileFalse, b1 evaluates to true (contradiction) *)
    rewrite H in H2. inversion H2.
  - (* E_WhileTrue, b1 evaluates to false (contradiction) *)
    rewrite H in H4. inversion H4.
  - (* E_WhileTrue, b1 evaluates to true *)
      assert (st' = st'0) as EQ1.
      { (* Proof of assertion *) apply IHE1_1; assumption. }
      subst st'0.
      apply IHE1_2. assumption.  Qed.

Theorem plus2_spec : forall st n st',
  st X = n ->
  plus2 / st \\ st' ->
  st' X = (n + 2).
Proof.
  intros st n st' HX Heval.

  inversion Heval. subst. clear Heval. simpl.
  apply t_update_eq.  Qed.

(*Exercise 3*)
Theorem loop_never_stops : forall st st',
  ~(loop / st \\ st').
Proof.
intros st st' contra.
  unfold loop in contra.
  remember (WHILE true DO SKIP END) as loopdef.
  induction contra; inversion Heqloopdef.
  rewrite H1 in H. simpl in H. inversion H.
  apply IHcontra2. subst. reflexivity.
Qed.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP =>
      true
  | _ ::= _ =>
      true
  | c1 ;; c2 =>
      andb (no_whiles c1) (no_whiles c2)
  | IFB _ THEN ct ELSE cf FI =>
      andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END  =>
      false
  end.

(*Exercise 4*)
(*Using [Inductive], write a property [no_whilesR] such that
    [no_whilesR c] is provable exactly when [c] is a program with no
    while loops.  Then prove its equivalence with [no_whiles]. *)

Inductive no_whilesR: com -> Prop :=
  | NW_Skip :  no_whilesR CSkip
  | NW_Ass : forall a x, no_whilesR (CAss x a)
  | NW_Seq : forall c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR (c1;;c2)
  | NW_If : forall b c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR (CIf b c1 c2).

(*Exercise 5*)
Theorem no_whiles_eqv:
   forall c, no_whiles c = true <-> no_whilesR c.
Proof.
  split; intros.
  induction c.
  apply NW_Skip.
  apply NW_Ass.
  apply NW_Seq; simpl in H; [apply IHc1 | apply IHc2]; apply andb_true_iff in H; apply H.
  apply NW_If; simpl in H; apply andb_true_iff in H; [apply IHc1 | apply IHc2]; apply H.
  inversion H.

  induction c; try (simpl); try (reflexivity);
  try (apply andb_true_iff); try(split); try(apply IHc1); try(apply IHc2);
  inversion H; assumption.
Qed.

(*Exercise 6*)
(** Imp programs that don't involve while loops always terminate.
    State and prove a theorem [no_whiles_terminating] that says this. *)
(** Use either [no_whiles] or [no_whilesR], as you prefer. *)
Theorem no_whiles_terminating : forall c st, no_whilesR c -> exists st', c / st \\ st'.
Proof.
intros.
  generalize dependent st.
  induction H.
    intros.
    exists st. apply E_Skip.
    intros.
    Admitted.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics HoTT.Types.
Require Import Modality.

Local Open Scope path_scope.

(** * The double negation modality *)

(** This is Exercise 7.12 in the book.  Note that it is (apparently) *not* accessible unless we assume propositional resizing. *)

Definition NotNot `{Funext} : Modality.
Proof.
  snrapply easy_modality.
  - intros X; exact (~ (~ X)).
  - intros T x nx; exact (nx x).
  - intros A B f z nBz.
    apply z; intros a.
    exact (f a (transport (fun x => ~ (B x))
                          (path_ishprop _ _)
                          nBz)).
  - intros A B f a.
    apply path_ishprop.
  - intros A z z'.
    refine (isequiv_iff_hprop _ _).
    intros; apply path_ishprop.
Defined.


Require Import Coq.Logic.FunctionalExtensionality.

Definition em := forall A: Prop, A \/ ~ A.
Definition or_dist := forall A B C: Prop, (A -> B \/ C) -> (A -> B) \/ (A -> C).

Lemma em_implies_or_dist: em -> or_dist.
unfold em. unfold or_dist.
intros.
specialize H with A.
destruct H.
- apply H0 in H. destruct H.
  + left. intros. auto.
  + right. intros. auto.
- unfold not in *.
  left. intros. apply H in H1. inversion H1.
Qed.

Lemma silly: forall A: Prop, A -> A \/ A.
intros. auto.
Qed.


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

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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint half (half_arg0 : natural) : natural
           := match half_arg0 with
              | Zero => Zero
              | Succ Zero => Zero
              | Succ (Succ n) => Succ (half n)
              end.

Lemma lem: forall m n, plus (Succ m) n = plus m (Succ n).
Proof.
intros. simpl. induction m.
  - simpl. rewrite IHm. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (half (plus x x)) x.
Proof.
induction x.
  - simpl. destruct x.
    * simpl. lfind. Admitted.


Require Import ZArith.
Require Import Coq.Lists.List coqutil.Datatypes.List.
Require Import coqutil.Z.Lia.
Require Import coqutil.Map.Interface coqutil.Map.OfFunc.
Require Import coqutil.Map.Properties.
Require Import coqutil.Tactics.autoforward.
Require Import coqutil.Tactics.Tactics.
Import Interface.map MapKeys.map OfFunc.map.
Require Import coqutil.Word.Interface coqutil.Word.Properties.

Module map.
  Section __. Local Set Default Proof Using "All".
    Context {width} {word : word width} {word_ok : word.ok word}.
    Add Ring __wring: (@word.ring_theory width word word_ok).
    Context {value : Type} {map : map word value} {ok : map.ok map}.

    Definition of_list_word (xs : list value) : map :=
      map.of_func
      (fun w => nth_error xs (Z.to_nat (word.unsigned w)))
      (List.map (fun n => word.of_Z (Z.of_nat n)) (seq 0 (length xs))).
    Definition of_list_word_at (a : word) (xs : list value) : map :=
      map_keys (word.add a) (of_list_word xs).
    Lemma get_of_list_word xs i : get (of_list_word xs) i
      = nth_error xs (Z.to_nat (word.unsigned i)).
    Proof.
      pose proof (word.eqb_spec (word_ok:=word_ok)).
      cbv [of_list_word].
      erewrite get_of_func_Some_supported; trivial; intros.
      pose proof word.unsigned_range k.
      eapply in_map_iff; exists (Z.to_nat (word.unsigned k));
        rewrite ?in_seq; repeat split; rewrite ?Znat.Z2Nat.id;
        try blia; try solve [eapply word.of_Z_unsigned].
      apply nth_error_Some. congruence.
    Qed.
    Lemma get_of_list_word_at a xs i : get (of_list_word_at a xs) i
      = nth_error xs (Z.to_nat (word.unsigned (word.sub i a))).
    Proof.
      cbv [of_list_word_at].
      replace i with (word.add a (word.sub i a)) by ring.
      rewrite get_map_keys_always_invertible, get_of_list_word.
      2: { intros ? ? H.
           assert (A:word.sub (word.add a k) a = word.sub (word.add a k') a).
           { rewrite H; trivial. }
           ring_simplify in A; exact A. }
      f_equal. f_equal. f_equal. ring.
    Qed.

    Lemma get_of_list_word_at_domain a xs i :
      get (of_list_word_at a xs) i <> None
      <->
      (0 <= word.unsigned (word.sub i a) < Z.of_nat (length xs))%Z.
    Proof.
      pose proof word.unsigned_range (word.sub i a).
      rewrite get_of_list_word_at, nth_error_Some.
      rewrite Nat2Z.inj_lt, ?Znat.Z2Nat.id; intuition.
    Qed.

    Lemma of_list_word_at_app a xs ys :
      of_list_word_at a (xs ++ ys) =
      putmany (of_list_word_at (word.add a (word.of_Z (Z.of_nat (length xs)))) ys) (of_list_word_at a xs).
    Proof.
      eapply map_ext; intros k.
      rewrite get_of_list_word_at.
      pose proof word.unsigned_range (word.sub k a) as Hrange.
      pose proof proj1 (nth_error_Some xs (Z.to_nat (word.unsigned (word.sub k a)))) as Hlength.
      destruct (nth_error xs (Z.to_nat (word.unsigned (word.sub k a)))) as [v|] eqn:Hv.
      { specialize (Hlength ltac:(discriminate)).
        erewrite Properties.map.get_putmany_right;
          rewrite ?nth_error_app1, ?get_of_list_word_at by blia; eassumption. }
      clear Hlength; pose proof Hv as H'v; eapply nth_error_None in Hv; rename Hv into Hlength.
      rewrite Properties.map.get_putmany_left; rewrite get_of_list_word_at; trivial.
      rewrite nth_error_app2 by assumption.
      f_equal.
      transitivity (Z.to_nat (word.unsigned (word.sub k a) - Z.of_nat (length xs))); try blia.
      f_equal.
      transitivity (word.unsigned (word.sub (word.sub k a) (word.of_Z (Z.of_nat (length xs))))).
      2: f_equal; ring.
      symmetry.
      rewrite word.unsigned_sub.
      rewrite (word.unsigned_of_Z (Z.of_nat (length xs))).
      cbv [word.wrap]; rewrite (Z.mod_small (Z.of_nat (length xs))) by blia.
      eapply Z.mod_small.
      split; blia.
    Qed.

    Lemma adjacent_arrays_disjoint a xs ys (H : (Z.of_nat (length xs) + Z.of_nat (length ys) <= 2^width)%Z) :
      disjoint (of_list_word_at (word.add a (word.of_Z (Z.of_nat (length xs)))) ys) (of_list_word_at a xs).
    Proof.
      intros k y x Hy Hx.
      assert ((Z.of_nat (length xs) <= 2^width)%Z) by blia.
      assert ((Z.of_nat (length ys) <= 2^width)%Z) by blia.
      pose proof word.unsigned_range (word.sub k a) as Hrange.
      pose proof word.unsigned_range (word.sub k (word.add a (word.of_Z (Z.of_nat (length xs))))) as Hr2.
      rewrite get_of_list_word_at in *.
      repeat match goal with H: nth_error ?l ?i = Some _ |- _ =>
          let HH := fresh H in pose proof proj1 (nth_error_Some l i) as HH;
          destruct (nth_error l i) in *; specialize (HH ltac:(discriminate));
          inversion H; subst; clear H
      end.
      replace (length xs) with (Z.to_nat (Z.of_nat (length xs))) in Hx0 by blia; eapply Z2Nat.inj_lt in Hx0; try blia.
      replace (length ys) with (Z.to_nat (Z.of_nat (length ys))) in Hy0 by blia; eapply Z2Nat.inj_lt in Hy0; try blia.

      replace (word.sub k (word.add a (word.of_Z (Z.of_nat (length xs)))))
         with (word.sub (word.sub k a) (word.of_Z (Z.of_nat (length xs)))) in Hy0 by ring.
      set (word.sub k a) as i in *.
      rewrite (word.unsigned_sub i), word.unsigned_of_Z in Hy0; cbv [word.wrap] in Hy0.
      rewrite Zminus_mod_idemp_r in Hy0.
      rewrite <-(Z_mod_plus _ 1), Z.mul_1_l in Hy0 by blia.
      rewrite Z.mod_small in Hy0; blia.
    Qed.

    Lemma of_list_word_at_app_n
      (a : word) (xs ys : list value)
      lxs (Hlxs : Z.of_nat (length xs) = lxs)
      : of_list_word_at a (xs ++ ys)
      = putmany (of_list_word_at (word.add a (word.of_Z lxs)) ys) (of_list_word_at a xs).
    Proof. subst lxs; eapply of_list_word_at_app. Qed.

    Lemma adjacent_arrays_disjoint_n
      (a : word) (xs ys : list value)
      lxs (Hlxs : Z.of_nat (length xs) = lxs)
      (H : (Z.of_nat (length xs) + Z.of_nat (length ys) <= 2 ^ width)%Z)
      : disjoint (of_list_word_at (word.add a (word.of_Z lxs)) ys) (of_list_word_at a xs).
    Proof. subst lxs. auto using adjacent_arrays_disjoint. Qed.

    Lemma of_list_word_nil k : of_list_word_at k nil = empty.
    Proof using ok. apply Properties.map.fold_empty. Qed.

    Lemma of_list_word_singleton k v : of_list_word_at k (cons v nil) = put empty k v.
    Proof.
      cbv [of_list_word_at of_list_word seq length List.map of_func update].
      rewrite word.unsigned_of_Z_0, Znat.Z2Nat.inj_0; cbv [MapKeys.map.map_keys nth_error].
      rewrite Properties.map.fold_singleton.
      f_equal; cbn [Z.of_nat].
      eapply word.unsigned_inj; rewrite word.unsigned_add; cbv [word.wrap]; rewrite word.unsigned_of_Z_0, Z.add_0_r, Z.mod_small; trivial; eapply word.unsigned_range.
    Qed.

    Import ListNotations.
    Local Notation "xs $@ a" := (of_list_word_at a xs) (at level 10, format "xs $@ a").
    Local Open Scope Z_scope.
    Local Coercion Z.of_nat : nat >-> Z.
    Local Coercion word.unsigned : word.rep >-> Z.
    Lemma of_list_word_at_cons b bs a :
      (b :: bs)$@a = map.put (bs$@(word.add a (word.of_Z 1))) a b :> map.
    Proof.
      change (b::bs) with ([b]++bs).
      rewrite of_list_word_at_app, of_list_word_singleton; cbn.
      rewrite <-map.put_putmany_commute, map.putmany_empty_r. trivial.
    Qed.

    Lemma of_list_word_at_snoc b bs a
      (H : length bs < 2 ^ width)
      : (bs ++ [b])$@a = map.put (bs$@a) (word.add a (word.of_Z (length bs))) b :> map.
    Proof.
      rewrite of_list_word_at_app, of_list_word_singleton; cbn.
      rewrite map.putmany_comm; cycle 1.
      { intros k ? ?; rewrite map.get_put_dec.
        destruct (@word.eqb _ _ _ _) eqn:Hbr;
          autoforward with typeclass_instances in Hbr;
          rewrite ?map.get_empty, get_of_list_word_at; inversion 1; subst.
        intro HX.
        rewrite word.word_sub_add_l_same_l in HX.
        eapply List.nth_error_Some_bound_index in HX.
        rewrite word.unsigned_of_Z in HX; cbv [word.wrap] in HX.
        rewrite Z.mod_small in HX by Lia.lia; Lia.lia. }
      rewrite <-map.put_putmany_commute, map.putmany_empty_r. trivial.
    Qed.

    Lemma remove_head_of_list_word_at_cons b bs a
      (H : length bs < 2^width) :
      map.remove ((b :: bs)$@a) a = bs$@(word.add a (word.of_Z 1)) :> map.
    Proof.
      rewrite of_list_word_at_cons, map.remove_put_same, map.remove_not_in; trivial.
      rewrite get_of_list_word_at. eapply List.nth_error_None.
      enough (word.unsigned (word.sub a (word.add a (word.of_Z 1))) =2^width-1) by Lia.lia.
      rewrite word.unsigned_sub, word.unsigned_add, word.unsigned_of_Z_1; cbv [word.wrap].
      rewrite Zdiv.Zminus_mod_idemp_r.
      replace (a - (a + 1)) with (Z.opp 1) by Lia.lia.
      rewrite Zdiv.Z_mod_nz_opp_full; rewrite ?Z.mod_small; ssplit; trivial; try Lia.lia.
      all : enough (2^1 <= 2^width) by Lia.lia; pose proof word.width_pos.
      all : eapply Z.pow_le_mono_r; Lia.lia.
    Qed.

    Lemma remove_last_of_list_word_at_snoc b bs a
      (H : length bs < 2 ^ width)
      a' (Ha' : a' = word.add a (word.of_Z (length bs)))
      : map.remove ((bs ++ [b])$@a) a' = bs$@a :> map.
    Proof.
      subst a'.
      rewrite of_list_word_at_snoc, map.remove_put_same, map.remove_not_in; trivial.
      rewrite get_of_list_word_at; eapply List.nth_error_None.
      rewrite word.word_sub_add_l_same_l.
      rewrite word.unsigned_of_Z; cbv [word.wrap]; rewrite Z.mod_small; Lia.lia.
    Qed.
  End __.
End map.


Require Export ZArith.

Section little_semantics.
 Variables Var aExp bExp : Set.
 Inductive inst : Set :=
 | Skip : inst
 | Assign : Var->aExp->inst
 | Sequence : inst->inst->inst
 | WhileDo : bExp->inst->inst.

 Variables
  (state : Set)
  (update : state->Var->Z -> option state)
  (evalA : state->aExp -> option Z)
  (evalB : state->bExp -> option bool).

 Inductive exec : state->inst->state->Prop :=
 | execSkip : forall s:state, exec s Skip s
 | execAssign :
    forall (s s1:state)(v:Var)(n:Z)(a:aExp),
     evalA s a = Some n -> update s v n = Some s1 ->
     exec s (Assign v a) s1
 | execSequence :
    forall (s s1 s2:state)(i1 i2:inst),
     exec s i1 s1 -> exec s1 i2 s2 ->
     exec s (Sequence i1 i2) s2
 | execWhileFalse :
    forall (s:state)(i:inst)(e:bExp),
     evalB s e = Some false -> exec s (WhileDo e i) s
 | execWhileTrue :
    forall (s s1 s2:state)(i:inst)(e:bExp),
     evalB s e = Some true ->
     exec s i s1 ->
     exec s1 (WhileDo e i) s2 ->
     exec s (WhileDo e i) s2.

Theorem HoareSequenceRule :
 forall (P1 P2 P3:state->Prop)(i1 i2:inst)(s s':state),
  (forall s1 s2, exec s1 i1 s2 -> P1 s1 -> P2 s2)->
  (forall s1 s2, exec s1 i2 s2 -> P2 s1 -> P3 s2)->
  exec s (Sequence i1 i2) s' -> P1 s -> P3 s'.
Proof.
 intros P1 P2 P3 i1 i2 s s' HP12 HP23 Hexec Hp1.
 inversion Hexec.
 match goal with
   id1 : exec s i1 _ , id2 : exec _ i2 s' |- _ =>
     try (apply (HP23 _ _ id2); apply (HP12 _ _ id1); assumption)
 end.
Qed.

End little_semantics.


(**********************************************************************

 The full subcategory of enriched category

 We show that the full subcategory of an enriched category is again
 enriched over the same monoidal category. We also show that the
 inclusion is an enriched functor.

 Contents
 1. The enrichment over the full subcategory
 2. The enrichment of the inclusion

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Local Open Scope cat.
Local Open Scope moncat.

Section FullSub.
  Context (V : monoidal_cat)
          {C : category}
          (E : enrichment C V)
          (P : C → hProp).

  (**
   1. The enrichment over the full subcategory
   *)
  Definition fullsub_enrichment_data
    : enrichment_data
        (subcategory C (full_sub_precategory P))
        V.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - exact (λ x y, E ⦃ pr1 x , pr1 y ⦄).
    - exact (λ x, enriched_id E (pr1 x)).
    - exact (λ x y z, enriched_comp E (pr1 x) (pr1 y) (pr1 z)).
    - exact (λ x y f, enriched_from_arr E (pr1 f)).
    - exact (λ x y f, enriched_to_arr E f ,, tt).
  Defined.

  Definition fullsub_enrichment_laws
    : enrichment_laws fullsub_enrichment_data.
  Proof.
    repeat split ; intros ; cbn.
    - apply enrichment_id_left.
    - apply enrichment_id_right.
    - apply enrichment_assoc.
    - use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      apply enriched_to_from_arr.
    - apply enriched_from_to_arr.
    - use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      apply enriched_to_arr_id.
    - use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      apply enriched_to_arr_comp.
  Qed.

  Definition fullsub_enrichment
    : enrichment
        (subcategory C (full_sub_precategory P))
        V.
  Proof.
    simple refine (_ ,, _).
    - exact fullsub_enrichment_data.
    - exact fullsub_enrichment_laws.
  Defined.

  (**
   2. The enrichment of the inclusion
   *)
  Definition fullsub_inclusion_enrichment
    : functor_enrichment
        (sub_precategory_inclusion _ _)
        fullsub_enrichment
        E.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y, identity _).
    - repeat split.
      + abstract
          (cbn ; intro x ;
           apply id_right).
      + abstract
          (cbn ; intros x y z ;
           rewrite id_right ;
           rewrite tensor_id_id ;
           rewrite id_left ;
           apply idpath).
      + abstract
          (cbn ; intros x y f ;
           rewrite id_right ;
           apply idpath).
  Defined.

  Definition fullsub_inclusion_enrichment_fully_faithful
    : fully_faithful_enriched_functor
        fullsub_inclusion_enrichment.
  Proof.
    intros x y.
    apply is_z_isomorphism_identity.
  Defined.
End FullSub.