Require Export Db.Spec.
Require Export Db.Tactics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Export Coq.Program.Equality.
Require Export Coq.Program.Tactics.

Create HintDb ws.
#[export]
Hint Constructors wsIx : ws.

Local Tactic Notation "crush'" tactic(T) :=
  cbn; intros;
  repeat
    (cbn;
     repeat crushDbSyntaxMatchH;
     crushRewriter;
     T);
  auto.

Lemma ap_wks {X Y} {vrX: Vr X} {wkX: Wk X} {vrY: Vr Y} {wkY: Wk Y}
  {apXY: Ap X Y} {apWkXY: LemApWk X Y} {apYY: Ap Y Y}
  {apCompXY: LemApComp X Y Y} {apWkYY: LemApWk Y Y} :
  ∀ (δ: Dom) (x: X), @wks X _ _ δ x = x[@wkms Y _ _ δ].
Proof.
  induction δ; crush' rewrite ?ap_wk, ?ap_comp.
  f_equal; extensionality i;
    cbn; now rewrite ap_wk.
Qed.

Definition ap_id'      := @ap_id.
Definition ap_comp'    := @ap_comp.
Definition ap_vr'      := @ap_vr.
Definition ap_lift'    := @ap_lift.
Definition ap_wk'      := @ap_wk.
Definition ap_wks'     := @ap_wks.
Definition comp_up'    := @comp_up.
Definition lift_vr'    := @lift_vr.
Definition ap_liftSub' := @ap_liftSub.

Arguments ap_id _ _ {_ _} x.
Arguments ap_comp' _ _ _ {_ _ _ _ _ _} x ξ ζ.
Arguments ap_vr' _ _ {_ _ _ _ _} ξ i.
Arguments ap_lift' _ _ _ {_ _ _ _ _ _ _} ζ x.
Arguments ap_wk' _ _ {_ _ _ _ _ _} x.
Arguments ap_wks' _ _ {_ _ _ _ _ _ _ _ _} δ x.
Arguments comp_up' _ _ {_ _ _ _ _ _} ξ ζ.
Arguments lift_vr' _ _ {_ _ _} i.
Arguments ap_liftSub' _ _ {_ _ _ _} t ξ.

(** *** Domains *)

Lemma dunion_assoc (δ₁ δ₂ δ₃: Dom) :
  δ₁ ∪ (δ₂ ∪ δ₃) = (δ₁ ∪ δ₂) ∪ δ₃.
Proof. induction δ₃; cbn; congruence. Qed.

Section Lemmas.

  Local Ltac crush :=
    crush' rewrite ?ap_vr, ?comp_up.

  (* Injectivity is closed under up. *)
  Lemma InjSubIxUp (ξ: Sub Ix) :
    Inj ξ → Inj (ξ ↑).
  Proof.
    intros ? [|?] [|?] ?; cbn in *;
      auto; discriminate.
  Qed.

  (* The following lemmas have more generic versions, but we stick to the
     specialized Ix versions to make proof search easier. *)
  Section Indices.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    (* Up commutes with lift. *)
    Lemma up_liftSub (ξ: Sub Ix) : ⌈ξ⌉↑ = ⌈ξ↑⌉.
    Proof.
      extensionality i; destruct i;
        cbn; now rewrite ?wk_vr.
    Qed.

    Lemma ups_liftSub (δ: Dom) :
      ∀ (ξ: Sub Ix), ⌈ξ⌉ ↑⋆ δ = ⌈ξ ↑⋆ δ⌉.
    Proof.
      induction δ; cbn; intros.
      - reflexivity.
      - now rewrite ?IHδ, ?up_liftSub.
    Qed.
    (* (* Lifting the identity yields the identity. *) *)
    (* Lemma liftSub_id : ⌈idm Ix⌉ = idm X. *)
    (* Proof. reflexivity. Qed. *)

    (* The weakening substitution is just the lifted
         weakening renaming. *)
    Lemma liftSub_wkm : ⌈@wkm Ix _ _⌉ = @wkm X _ _.
    Proof. extensionality i; crush. Qed.

    Lemma liftSub_wkms (δ: Dom) : ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ.
    Proof.
      extensionality i; induction δ; cbn in *.
      - reflexivity.
      - rewrite <- IHδ; cbn.
        rewrite wk_vr; reflexivity.
    Qed.

    Context {apX : Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma liftSub_comp (ξ ζ: Sub Ix) :
      @liftSub Ix _ X _  _ (ξ >=> ζ) = ⌈ξ⌉ >=> ⌈ζ⌉.
    Proof. extensionality i; crush. Qed.

    (* Up commutes with the composition with a lifting
       on the left-hand side .*)
    Lemma up_comp_lift (ξ: Sub Ix) (ζ: Sub X):
      (⌈ξ⌉ >=> ζ)↑ = ⌈ξ↑⌉ >=> ζ↑.
    Proof. extensionality i; destruct i; crush. Qed.

  End Indices.

  Section Weakening.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.

    Lemma up_idm : up (idm X) = idm X.
    Proof.
      extensionality i; destruct i; cbn;
        now rewrite ?wk_vr.
    Qed.

    Lemma ups_idm (δ: Dom) : ups (idm X) δ = idm X.
    Proof.
      induction δ; cbn;
        now rewrite ?IHδ, ?up_idm.
    Qed.

    Lemma ups_dunion (ξ: Sub X) δ₁ δ₂ :
       ξ ↑⋆ (δ₁ ∪ δ₂) = (ξ ↑⋆ δ₁) ↑⋆ δ₂.
    Proof. induction δ₂; crush. Qed.

    Lemma ups_up (ξ : Sub X) δ : (ξ ↑⋆ δ) ↑ = ξ ↑⋆ (S δ).
    Proof. reflexivity. Qed.

    Lemma wkm_snoc0 : wkm · vr 0 = idm X.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_zero : wkms 0 = idm X.
    Proof. reflexivity. Qed.

    Lemma apply_ups_wks (ξ: Sub X) (δ: Dom) (i: Ix) :
      (ξ ↑⋆ δ) (wks δ i) = wks δ (ξ i).
    Proof. induction δ; crush. Qed.

    Lemma wks_comm δ (ξ: Sub X) :
      ∀ i, wks δ (ξ i) = (ξ ↑⋆ δ) (wks δ i).
    Proof. induction δ; crush. Qed.

    (* Point-wise the weakening substitution is the
       variable injection of the weakening action on
       indices. *)
    Lemma apply_wkms (δ: Dom) (i: Ix) :
      @wkms X _ _ δ i = vr (wks δ i).
    Proof. induction δ; crush. Qed.

    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.

    Lemma apply_up_def_O (ζ: Sub X) :
      (ζ ↑) 0 = vr 0.
    Proof. crush. Qed.

    Lemma apply_up_def_S (ζ: Sub X) :
      ∀ (i: Ix), (ζ ↑) (S i) = (ζ i)[wkm].
    Proof. crush. Qed.

    Lemma up_def (ζ: Sub X) :
      ζ ↑ = (ζ >=> wkm) · vr 0.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma wkms_succ (δ: Dom) : wkms (S δ) = wkms δ >=> @wkm X _ _.
    Proof. extensionality i; crush. Qed.

  End Weakening.

  Section Application.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.

    Section Het.
      Context {S: Type}.
      Context {vrS : Vr S}.
      Context {wkS : Wk S}.
      Context {apXS: Ap X S}.

      Lemma comp_id_right (ζ: Sub X) :
        ζ >=> idm S = ζ.
      Proof. extensionality i; crush. Qed.

    End Het.

    Context {apVrX: LemApVr X X}.

    Lemma comp_id_left (ζ: Sub X) :
      @idm X _ >=> ζ = ζ.
    Proof. extensionality i; crush. Qed.

    Lemma comp_snoc (ζ₁ ζ₂: Sub X) t :
      (ζ₁ · t) >=> ζ₂ = (ζ₁ >=> ζ₂) · t[ζ₂].
    Proof. extensionality i; destruct i; reflexivity. Qed.

    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma apply_wk_ap (x: X) (ζ: Sub X) :
      (wk x)[ζ] = x[wkm >=> ζ].
    Proof. now rewrite ap_wk. Qed.

    Lemma apply_wks_ap δ (x: X) (ζ: Sub X) :
      (wks δ x)[ζ] = x[wkms δ >=> ζ].
    Proof. now rewrite ap_wks, ap_comp. Qed.

    (* Always try to associate to the left in rewriting. *)
    Lemma comp_assoc (ζ₁ ζ₂ ζ₃: Sub X) :
      ζ₁ >=> (ζ₂ >=> ζ₃) = (ζ₁ >=> ζ₂) >=> ζ₃.
    Proof. extensionality i; crush. Qed.

    Lemma wkms_comm δ (ξ: Sub X) :
      ξ      >=> wkms δ =
      wkms δ >=> (ξ ↑⋆ δ).
    Proof.
      pose proof apply_wkms.
      pose proof apply_ups_wks.
      pose proof ap_wks.
      extensionality i; crush.
    Qed.

    Lemma wkm_comm (ξ: Sub X) :
      ξ   >=> wkm =
      wkm >=> ξ↑.
    Proof. apply (wkms_comm 1). Qed.

    Context {Y: Type}.
    Context {vrY: Vr Y}.
    Context {wkY: Wk Y}.
    Context {apXY: Ap X Y}.
    Context {compUpX : LemCompUp X Y}.

    Lemma comp_ups (ξ: Sub X) (ζ: Sub Y) (δ: Dom) :
      (ξ >=> ζ) ↑⋆ δ  = (ξ ↑⋆ δ) >=> (ζ ↑⋆ δ).
    Proof. induction δ; crush. Qed.

  End Application.

  Section BetaInteraction.

    Context {X : Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX : Ap X X}.
    Context {apWkX: LemApWk X X}.
    Context {apVrX: LemApVr X X}.
    Context {apCompX: LemApComp X X X}.

    Lemma beta_comm δ (ζ₁ ζ₂: Sub X) :
      beta δ ζ₁  >=> ζ₂  =
      (ζ₂ ↑⋆ δ)  >=> beta δ (ζ₁ >=> ζ₂).
    Proof.
      extensionality i. crush. revert ζ₁ ζ₂ i.
      induction δ; crush.
      destruct i; crush.
      rewrite ap_wk, ap_comp; crush.
      f_equal; extensionality j; crush.
    Qed.

    Lemma apply_beta_wks (δ: Dom) :
      ∀ (ξ: Sub X) i, beta δ ξ (wks δ i) = vr i.
    Proof. induction δ; crush. Qed.

    Lemma wkms_beta_cancel δ (ξ: Sub X) :
      wkms δ >=> beta δ ξ = idm X.
    Proof.
      pose proof apply_wkms.
      pose proof apply_beta_wks.
      extensionality i; crush.
    Qed.

    Lemma beta1_comm (x : X) (ζ: Sub X) :
      beta1 x >=> ζ  =
      (ζ ↑)   >=> beta1 x[ζ].
    Proof. apply (beta_comm 1). Qed.

    Lemma wkm_beta1_cancel (x: X) :
      wkm >=> beta1 x = idm X.
    Proof. apply (wkms_beta_cancel 1). Qed.

  End BetaInteraction.

  Section Misc.

    Context {X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apX: Ap X X}.
    Context {apVrX: LemApVr X X}.

    Lemma wkm_snoc_cancel (ζ: Sub X) t : wkm >=> (ζ · t) = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

    Lemma snoc_eta_red (ζ: Sub X) : (wkm >=> ζ) · ζ 0 = ζ.
    Proof. extensionality i; destruct i; crush. Qed.

  End Misc.

  (* This subsection contains pointful variables of the pointfree lemmas of the
     previous subsection. These are intended to be user-facing. The Db.Inst
     module populates the infrastructure database with these lemmas and some
     others such that it results in a terminating rewrite system (hopefully). *)
  Section Pointful.

    Context {T X: Type}.
    Context {vrX: Vr X}.
    Context {wkX: Wk X}.
    Context {apTX: Ap T X}.
    Context {apXX: Ap X X}.
    Context {apCompTX: LemApComp T X X}.
    Context {apVrX: LemApVr X X}.
    Context {apWkX: LemApWk X X}.
    Context {apCompX: LemApComp X X X}.
    Context {compUpX: LemCompUp X X}.

    Local Ltac crushPointful :=
      (* (* Convert renamings into substitutions *) *)
      (* rewrite <- ?ap_liftSub; *)
      (* Go point-free *)
      rewrite ?ap_comp; f_equal;
      (* Flow ups outside *)
      rewrite <- ?comp_up, <- ?comp_ups;
      (* (* Convert lifted weakening renaming into weakening substitution *) *)
      (* rewrite <- ?liftSub_wkm; *)
      (* Apply the point-free lemmas *)
      rewrite ?wkm_comm,
              ?wkm_beta1_cancel,
              ?beta1_comm;
      (* Get rid of identities *)
      rewrite ?up_idm, ?ups_idm, ?ap_id;
      reflexivity.

    Lemma apply_wkm_comm (t: T) (ξ: Sub X) :
      t[ξ][wkm] = t[wkm][ξ↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_cancel (t: T) (x: X) :
      t[wkm][beta1 x] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_comm (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x][ζ] = t[ζ↑][beta1 x[ζ]].
    Proof. crushPointful. Qed.

    (* 1 up variant *)
    Lemma apply_wkm_up_comm (t: T) (ξ: Sub X) :
      t[ξ↑][wkm↑] = t[wkm↑][ξ↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up_cancel (t: T) (x: X) :
      t[wkm↑][(beta1 x)↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑][ζ↑] = t[ζ↑↑][(beta1 x[ζ])↑].
    Proof. crushPointful. Qed.

    (* 2 ups variant *)
    Lemma apply_wkm_up2_comm (t: T) (ξ: Sub X) :
      t[ξ↑↑][wkm↑↑] = t[wkm↑↑][ξ↑↑↑].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_up2_cancel (t: T) (x: X) :
      t[wkm↑↑][(beta1 x)↑↑] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_up2_comm (t: T) (x: X) (ζ: Sub X) :
      t[(beta1 x)↑↑][ζ↑↑] = t[ζ↑↑↑][(beta1 x[ζ])↑↑].
    Proof. crushPointful. Qed.

    (* δ ups variant *)
    Lemma apply_wkm_ups_comm (δ: Dom) (t: T) (ξ: Sub X) :
      t[ξ ↑⋆ δ][wkm ↑⋆ δ] = t[wkm ↑⋆ δ][ξ↑ ↑⋆ δ].
    Proof. crushPointful. Qed.

    Lemma apply_wkm_beta1_ups_cancel (δ: Dom) (t: T) (x: X) :
      t[wkm ↑⋆ δ][beta1 x ↑⋆ δ] = t.
    Proof. crushPointful. Qed.

    Lemma apply_beta1_ups_comm (δ: Dom) (t: T) (x: X) (ζ: Sub X) :
      t[beta1 x ↑⋆ δ][ζ ↑⋆ δ] = t[ζ↑ ↑⋆ δ][beta1 x[ζ] ↑⋆ δ].
    Proof. crushPointful. Qed.

  End Pointful.

End Lemmas.

Ltac crushDbLemmasMatchH :=
  match goal with
    | H: context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] |- _ =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) in H by
          refine (eq_sym (ap_vr ξ i))

    | |- context[@up ?X ?vrX ?wkX ?ζ O        ] =>
      change (@up X vrX wkX ζ O) with (@vr X vrX O)
    | |- context[@up _ _ ?wkX (idm _)         ] => rewrite (@up_idm _ _ wkX)
    | |- context[@ups _ _ ?wkX (idm _) ?δ     ] => rewrite (@ups_idm _ _ wkX δ)
    | |- context[@ap ?X ?X ?vrX _ ?ξ (@vr ?X ?vrX ?i)] =>
      replace (@ap X X vrX _ ξ (@vr X vrX i)) with (ξ i) by
          refine (eq_sym (ap_vr ξ i))
  end.

Ltac crushDbLemmasRewriteH :=
  rewrite
    ?dunion_assoc, ?ups_dunion, ?comp_up, ?comp_ups,
    (* ?up_liftSub, ?ups_liftSub, *)
    (* ?ap_liftSub, ?liftSub_wkm, ?liftSub_wkms, ?ap_lift, *)
    <- ?ap_comp,
    ?apply_wkm_comm,     ?apply_wkm_beta1_cancel,     ?apply_beta1_comm,
    ?apply_wkm_up_comm,  ?apply_wkm_beta1_up_cancel,  ?apply_beta1_up_comm,
    ?apply_wkm_up2_comm, ?apply_wkm_beta1_up2_cancel, ?apply_beta1_up2_comm,
    ?apply_wkm_ups_comm, ?apply_wkm_beta1_ups_cancel, ?apply_beta1_ups_comm.

    (* Print liftSub_wkm. *)

    (* Unset Printing Notations. *)
    (* Set Printing Implicit. *)
    (* Print ups_idm. *)

    (* | [|- context[(@liftSub Ix _ ?X _ _ ?ξ)↑]] => replace (@liftSub Ix _ X _ _ ξ)↑ *)
    (*                                                 with (@liftSub Ix _ X _ _ ξ↑) by *)
    (*                                                   exact (eq_sym (up_liftSub ξ)) *)
    (* | [|- context[@liftSub Ix _ ?X _ _ ?ξ ↑⋆ ?δ]] => replace (@liftSub Ix _ X _ _ ξ ↑⋆ δ) *)
    (*                                                 with (@liftSub Ix _ X _ _ (ξ ↑⋆ δ)) by *)
    (*                                                   exact (eq_sym (ups_liftSub δ ξ)) *)

  (* liftSub_id : ⌈idm Ix⌉ = idm X. *)
  (* liftSub_wkm  ⌈@wkm Ix _ _⌉ = @wkm X _ _. *)
  (* liftSub_wkms  ⌈@wkms Ix _ _ δ⌉ = @wkms X _ _ δ. *)


Set Implicit Arguments.

Require Import RelationClasses.
Require Import List.

From sflib Require Import sflib.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Axioms.

Require Import ITreeLang.

Module Opt3.

  Record t :=
    mk_opt3
      {
        gdata: Type;
        bot_g: gdata;
        expr_g: gdata -> Inst.expr -> gdata;
        inst_g: gdata -> Inst.t -> gdata;
        join_g: gdata -> gdata -> gdata;

        le_g: gdata -> gdata -> Prop;
        le_g_PreOrder: PreOrder le_g;
        le_g_PartialOrder: PartialOrder eq le_g;

        bot_g_spec: forall gd, le_g bot_g gd;

        expr_g_inc: forall ex gd, le_g gd (expr_g gd ex);
        expr_g_mon: forall ex gd1 gd2 (LE: le_g gd1 gd2), le_g (expr_g gd1 ex) (expr_g gd2 ex);
        expr_g_big: forall ex gd (BIG: le_g (expr_g bot_g ex) gd), expr_g gd ex = gd;

        inst_g_inc: forall gd i, le_g gd (inst_g gd i);
        inst_g_mon: forall gd1 gd2 i (LE: le_g gd1 gd2), le_g (inst_g gd1 i) (inst_g gd2 i);
        inst_g_big: forall gd i (BIG: le_g (inst_g bot_g i) gd), inst_g gd i = gd;
        inst_g_skip: forall gd, inst_g gd (Inst.skip) = gd;

        join_g_refl: forall a, join_g a a = a;
        join_le_g_l: forall a b, le_g a (join_g a b);
        join_le_g_r: forall a b, le_g b (join_g a b);
        join_g_mon: forall a b c d (LE1: le_g a c) (LE2: le_g b d), le_g (join_g a b) (join_g c d);

        datum: Type;
        data := list datum;
        analyze: block -> data;

        update_g: gdata -> datum -> gdata;
        update_g_inc: forall g d, le_g g (update_g g d);
        update_g_mon: forall a b d (LE: le_g a b), le_g (update_g a d) (update_g b d);

        intro_inst: gdata -> datum -> Inst.t;
      }
  .

  Global Program Instance le_g_PreOrder_i: forall T, PreOrder (le_g T).
  Next Obligation.
  Proof.
    eapply PreOrder_Reflexive. Unshelve. apply (le_g_PreOrder T).
  Qed.
  Next Obligation.
  Proof.
    eapply PreOrder_Transitive. Unshelve. apply (le_g_PreOrder T).
  Qed.

  Global Program Instance le_g_PartialOrder_i: forall T, PartialOrder eq (le_g T).
  Next Obligation.
  Proof.
    assert (Antisymmetric (gdata T) eq (le_g T)).
    { eapply partial_order_antisym. eapply (le_g_PartialOrder T). }
    unfold relation_equivalence, relation_conjunction.
    unfold predicate_equivalence, predicate_intersection.
    unfold pointwise_lifting, pointwise_extension.
    i. split; i.
    - split.
      + clarify. refl.
      + unfold flip. clarify. refl.
    - des. eapply antisymmetry; eauto.
  Qed.

End Opt3.

Section OPT.

  Variable O3: Opt3.t.

  Let gdata: Type := Opt3.gdata O3.
  Let bot_g: gdata := Opt3.bot_g O3.
  Let expr_g: gdata -> Inst.expr -> gdata := Opt3.expr_g O3.
  Let inst_g: gdata -> Inst.t -> gdata := Opt3.inst_g O3.
  Let join_g: gdata -> gdata -> gdata := Opt3.join_g O3.

  Fixpoint block_g (gd: gdata) (blk: block) : gdata :=
    match blk with
    | nil => gd
    | cons hd tl =>
      match hd with
      | inst i =>
        let gd1 := inst_g gd i in
        block_g gd1 tl

      | ite ex b1 b2 =>
        let gd1 := block_g gd b1 in
        let gd2 := block_g gd b2 in
        let gd3 := join_g gd1 gd2 in
        let gd4 := expr_g gd3 ex in
        block_g gd4 tl

      | while ex b =>
        let gd1 := block_g gd b in
        let gd2 := expr_g gd1 ex in
        block_g gd2 tl
      end
    end
  .

  Let le_g: gdata -> gdata -> Prop := Opt3.le_g O3.
  Let le_g_PreOrder: PreOrder le_g := Opt3.le_g_PreOrder O3.
  Let le_g_PartialOrder: PartialOrder eq le_g := Opt3.le_g_PartialOrder O3.

  Global Program Instance le_g_PreOrder_i: PreOrder le_g.
  Global Program Instance le_g_PartialOrder_i: PartialOrder eq le_g.

  Definition lt_g gd1 gd2 := (le_g gd1 gd2) /\ (gd1 <> gd2).

  Global Program Instance lt_g_Transitive_i: Transitive lt_g.
  Next Obligation.
  Proof.
    unfold lt_g in *. des. split.
    - etrans; eauto.
    - ii. clarify. hexploit (partial_order_antisym le_g_PartialOrder). i.
      assert (AS: y = z).
      { eapply antisymmetry; eauto. }
      apply H1; auto.
  Qed.

  Lemma le_g_lt_g:
    forall a b c (LE: le_g a b) (LT: lt_g b c), lt_g a c.
  Proof.
    i. unfold lt_g in *. des. split.
    - etrans; eauto.
    - ii. clarify. assert (AS: b = c).
      { eapply antisymmetry; eauto. }
      clarify.
  Qed.

  Lemma le_g_lt_g2:
    forall a b c (LE: lt_g a b) (LT: le_g b c), lt_g a c.
  Proof.
    i. unfold lt_g in *. des. split.
    - etrans; eauto.
    - ii. clarify. assert (AS: c = b).
      { eapply antisymmetry; eauto. }
      clarify.
  Qed.

  Let bot_g_spec: forall gd, le_g bot_g gd := Opt3.bot_g_spec O3.

  Let expr_g_inc: forall ex gd, le_g gd (expr_g gd ex) := Opt3.expr_g_inc O3.
  Let expr_g_mon: forall ex gd1 gd2 (LE: le_g gd1 gd2), le_g (expr_g gd1 ex) (expr_g gd2 ex) := Opt3.expr_g_mon O3.
  Let expr_g_big: forall ex gd (BIG: le_g (expr_g bot_g ex) gd), expr_g gd ex = gd := Opt3.expr_g_big O3.

  Let inst_g_inc: forall gd i, le_g gd (inst_g gd i) := Opt3.inst_g_inc O3.
  Let inst_g_mon: forall gd1 gd2 i (LE: le_g gd1 gd2), le_g (inst_g gd1 i) (inst_g gd2 i) := Opt3.inst_g_mon O3.
  Let inst_g_big: forall gd i (BIG: le_g (inst_g bot_g i) gd), inst_g gd i = gd := Opt3.inst_g_big O3.
  Let inst_g_skip: forall gd, inst_g gd (Inst.skip) = gd := Opt3.inst_g_skip O3.

  Let join_g_refl: forall a, join_g a a = a := Opt3.join_g_refl O3.
  Let join_le_g_l: forall a b, le_g a (join_g a b) := Opt3.join_le_g_l O3.
  Let join_le_g_r: forall a b, le_g b (join_g a b) := Opt3.join_le_g_r O3.
  Let join_g_mon: forall a b c d (LE1: le_g a c) (LE2: le_g b d), le_g (join_g a b) (join_g c d) := Opt3.join_g_mon O3.

  Lemma block_g_inst:
    forall gd (i: Inst.t) blk, block_g gd (cons i blk) = block_g (inst_g gd i) blk.
  Proof. ss. Qed.

  Lemma block_g_ite:
    forall gd ex b1 b2 blk, block_g gd (cons (ite ex b1 b2) blk) = block_g (expr_g (join_g (block_g gd b1) (block_g gd b2)) ex) blk.
  Proof. ss. Qed.

  Lemma block_g_while:
    forall gd ex b blk, block_g gd (cons (while ex b) blk) = block_g (expr_g (block_g gd b) ex) blk.
  Proof. ss. Qed.

  Lemma block_g_inc:
    forall blk gd, le_g gd (block_g gd blk).
  Proof.
    induction blk using block_ind2; i; ss; eauto.
    - refl.
    - etrans. 2: eapply IHblk. eapply inst_g_inc.
    - etrans. 2: eapply IHblk3. etrans. 2: eapply expr_g_inc. etrans. 2: eapply join_le_g_l. eauto.
    - etrans. 2: eapply IHblk2. etrans. 2: eapply expr_g_inc. eauto.
  Qed.

  Lemma block_g_mon:
    forall blk gd1 gd2 (LE: le_g gd1 gd2),
      le_g (block_g gd1 blk) (block_g gd2 blk).
  Proof.
    induction blk using block_ind2; i; ss; eauto.
    eapply IHblk3. eapply expr_g_mon. eapply join_g_mon; eauto.
  Qed.

  Lemma block_g_big:
    forall blk gd (BIG: le_g (block_g bot_g blk) gd),
      (block_g gd blk) = gd.
  Proof.
    induction blk using block_ind2; i; ss; eauto.
    - rewrite inst_g_big.
      2:{ etrans. 2: eapply BIG. eapply block_g_inc. }
      eapply IHblk. etrans. 2: eapply BIG. eapply block_g_mon. eapply bot_g_spec.
    - rewrite IHblk1.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. apply join_le_g_l. }
      rewrite IHblk2.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. apply join_le_g_r. }
      rewrite join_g_refl. rewrite expr_g_big.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. eapply expr_g_mon. eapply bot_g_spec. }
      eapply IHblk3. etrans. 2: eapply BIG. eapply block_g_mon. eapply bot_g_spec.
    - rewrite IHblk1.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. refl. }
      rewrite expr_g_big.
      2:{ etrans. 2: eapply BIG. etrans. 2: eapply block_g_inc. eapply expr_g_mon. eapply bot_g_spec. }
      eapply IHblk2. etrans. 2: eapply BIG. eapply block_g_mon. eapply bot_g_spec.
  Qed.

  Lemma block_g_add_block:
    forall b1 b2 gd, block_g gd (add_block b1 b2) = block_g (block_g gd b1) b2.
  Proof.
    induction b1 using block_ind2; i; ss; eauto.
  Qed.

  Let datum: Type := Opt3.datum O3.
  Let data := Opt3.data O3.
  Let analyze: block -> data := Opt3.analyze O3.

  Let update_g: gdata -> datum -> gdata := Opt3.update_g O3.
  Definition update_gs: gdata -> data -> gdata :=
    fun gd ds => fold_left update_g ds gd.

  Let update_g_inc: forall g d, le_g g (update_g g d) := Opt3.update_g_inc O3.
  Let update_g_mon: forall a b d (LE: le_g a b), le_g (update_g a d) (update_g b d) := Opt3.update_g_mon O3.

  Lemma update_gs_inc: forall ds g, le_g g (update_gs g ds).
  Proof.
    induction ds; i; ss. refl.
    etrans. 2: eapply IHds. eapply update_g_inc.
  Qed.

  Lemma update_gs_mon: forall ds a b (LE: le_g a b), le_g (update_gs a ds) (update_gs b ds).
  Proof.
    induction ds; i; ss. eapply IHds. eapply update_g_mon. auto.
  Qed.

  Let intro_inst: gdata -> datum -> Inst.t := Opt3.intro_inst O3.
  Fixpoint intro_insts (g: gdata) (ds: data) : block :=
    match ds with
    | [] => nil
    | d :: tl =>
      cons (intro_inst g d) (intro_insts (update_g g d) tl)
    end.

  (* "scope" of each global data is limited to each while-body *)
  Fixpoint opt (gd: gdata) (blk: block) : block :=
    match blk with
    | nil => nil
    | cons hd tl =>
      match hd with
      | inst i =>
        let utl := opt gd tl in
        cons hd utl
      | ite c b1 b2 =>
        let ub1 := opt gd b1 in
        let ub2 := opt gd b2 in
        let utl := opt gd tl in
        cons (ite c ub1 ub2) utl
      | while c b =>
        let ds := analyze b in
        let ugd := update_gs gd ds in
        let ub := opt ugd b in
        let utl := opt gd tl in
        add_block (intro_insts gd ds) (cons (while c ub) utl)
      end
    end
  .

  Lemma opt_add_comm:
    forall b1 b2 gd,
      opt gd (add_block b1 b2) = add_block (opt gd b1) (opt gd b2).
  Proof.
    induction b1 using block_ind2; i; ss.
    - f_equal. eauto.
    - f_equal. eauto.
    - rewrite add_block_assoc. f_equal. rewrite cons_add_block_comm. f_equal. eauto.
  Qed.

  Lemma opt_eval_inst:
    forall gd blk (i: Inst.t), opt gd (cons i blk) = cons i (opt gd blk).
  Proof. ss. Qed.

  Lemma opt_eval_ite:
    forall gd e b1 b2 blk,
      opt gd (cons (ite e b1 b2) blk) =
      cons (ite e (opt gd b1) (opt gd b2)) (opt gd blk).
  Proof. ss. Qed.

  Lemma opt_eval_while:
    forall gd e b blk,
      opt gd (cons (while e b) blk) =
      add_block (intro_insts gd (analyze b))
                (cons (while e (opt (update_gs gd (analyze b)) b)) (opt gd blk)).
  Proof. ss. Qed.

  (* gdata = global data from the original code *)
  Inductive match_code3 (gd: gdata): block -> block -> Prop :=
  | match_code3_nil
    :
      match_code3 gd nil nil

  | match_code3_inst
      (i_same: Inst.t) b_src b_tgt

      (GD: le_g (inst_g gd i_same) gd)
      (MC0: match_code3 gd b_src b_tgt)
    :
      match_code3 gd (cons i_same b_src) (cons i_same b_tgt)

  | match_code3_ite
      (s_src s_tgt: stmt) b_src b_tgt
      e (sb1 sb2 tb1 tb2: block)

      (SSRC: s_src = ite e sb1 sb2)
      (STGT: s_tgt = ite e tb1 tb2)

      (MC0: match_code3 gd b_src b_tgt)
      (MCT: match_code3 gd sb1 tb1)
      (MCF: match_code3 gd sb2 tb2)
    :
      match_code3 gd (cons s_src b_src) (cons s_tgt b_tgt)

  | match_code3_while
      (s_src s_tgt: stmt) b_src b_tgt src tgt
      e (sb tb: block)

      (SSRC: s_src = while e sb)
      (STGT: s_tgt = while e tb)

      (SRC: src = cons s_src b_src)
      (TGT: tgt = cons s_tgt b_tgt)

      (MC0: match_code3 gd b_src b_tgt)
      (MCL: match_code3 (update_gs gd (analyze sb)) sb tb)
    :
      match_code3 gd src tgt

  | match_code3_opt
      src tgt
      gd1 ds

      (GD: le_g gd gd1)
      (mc0: match_code3 gd src tgt)
    :
      match_code3 gd src (add_block (intro_insts gd1 ds) tgt)
  .

  Lemma mc_add_block
        src1 src2 tgt1 tgt2 gd
        (MC1: match_code3 gd src1 tgt1)
        (MC2: match_code3 gd src2 tgt2)
    :
      match_code3 gd (add_block src1 src2) (add_block tgt1 tgt2).
  Proof.
    depgen src2. depgen tgt2. induction MC1; i; ss; clarify.
    - econs 2; eauto.
    - econs 3; eauto.
    - rewrite ! cons_add_block_comm. econs 4; eauto.
    - rewrite add_block_assoc. econs 5; eauto.
  Qed.

  Lemma mc_mon_gdata
        src tgt gd1 gd2
        (GD: le_g (block_g gd1 src) gd1)
        (LE: le_g gd1 gd2)
        (MC: match_code3 gd2 src tgt)
    :
      match_code3 gd1 src tgt.
  Proof.
    depgen gd1. induction MC; i; ss; clarify.
    - econs 1.
    - econs 2; eauto.
      { etrans. 2: eapply GD0. etrans. 2: eapply block_g_inc. refl. }
      eapply IHMC; eauto. etrans. 2: eapply GD0. eapply block_g_mon. eapply inst_g_inc.
    - econs 3; eauto.
      + eapply IHMC1; eauto. etrans. 2: eapply GD. eapply block_g_mon. etrans. 2: eapply expr_g_inc.
        etrans. 2: eapply join_le_g_l. eapply block_g_inc.
      + eapply IHMC2; eauto. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc.
        eapply join_le_g_l.
      + eapply IHMC3; eauto. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc.
        eapply join_le_g_r.
    - ss. econs 4; eauto.
      + eapply IHMC1; eauto. etrans. 2: eapply GD. eapply block_g_mon. etrans. 2: eapply expr_g_inc. eapply block_g_inc.
      + eapply IHMC2; eauto.
        * rewrite block_g_big. refl. etrans. 2: eapply update_gs_inc. etrans. 2: eapply GD.
          etrans. 2: eapply block_g_inc. etrans. 2: eapply expr_g_inc. eapply block_g_mon. eapply bot_g_spec.
        * eapply update_gs_mon. auto.
    - econs 5; eauto. etrans; eauto.
  Qed.

  Lemma opt_mc0:
    forall src gd (GD: le_g (block_g gd src) gd), match_code3 gd src (opt gd src).
  Proof.
    induction src using block_ind2; i; ss.
    - econs 1.
    - econs 2; eauto.
      { etrans. 2: eapply GD. eapply block_g_inc. }
      eapply IHsrc. etrans. 2: eapply GD. eapply block_g_mon. eapply inst_g_inc.
    - econs 3; eauto.
      + eapply IHsrc3. etrans. 2: eapply GD. eapply block_g_mon.
        etrans. 2: eapply expr_g_inc. etrans. 2: eapply join_le_g_l. eapply block_g_inc.
      + eapply IHsrc1. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc.
        etrans. 2: eapply expr_g_inc. eapply join_le_g_l.
      + eapply IHsrc2. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc.
        etrans. 2: eapply expr_g_inc. eapply join_le_g_r.
    - econs 5; eauto. refl. econs 4; eauto.
      + eapply IHsrc2. etrans. 2: eapply GD. eapply block_g_mon. etrans. 2: eapply expr_g_inc. eapply block_g_inc.
      + eapply IHsrc1. rewrite block_g_big. refl.
        etrans. 2: eapply update_gs_inc. etrans. 2: eapply GD. etrans. 2: eapply block_g_inc.
        etrans. 2: eapply expr_g_inc. eapply block_g_mon. eapply bot_g_spec.
  Qed.

  Lemma opt_mc:
    forall src gd (GD: lt_g (block_g bot_g src) gd), match_code3 gd src (opt gd src).
  Proof.
    i. eapply opt_mc0. rewrite block_g_big. refl. unfold lt_g in GD. des; auto.
  Qed.

End OPT.


Require Import CoqChess.Util.All.

Inductive Player :=
  | White : Player
  | Black : Player.

#[export]
Instance Player_Discrete : Discrete Player.
Proof.
  constructor; unfold decision; decide equality.
Defined.

Definition opp : Player -> Player :=
  fun p =>
    match p with
    | White => Black
    | Black => White
    end.

Lemma opp_invol : forall p, opp (opp p) = p.
Proof.
  intro p; destruct p; reflexivity.
Qed.

Lemma opp_inj : forall p p',
  opp p = opp p' -> p = p'.
Proof.
  intros p p' Hpp'.
  destruct p, p'; auto.
Qed.

Lemma player_id_or_opp : forall p p',
  p = p' \/ opp p = p'.
Proof.
  destruct p, p'; auto.
Qed.

Lemma player_id_or_opp_r_t : forall p p',
  { p = p' } + { p = opp p' }.
Proof.
  intros.
  destruct p, p'; auto.
Defined.

Lemma opp_no_fp : forall p, opp p <> p.
Proof.
  destruct p; discriminate.
Qed.


Require Import VST.floyd.proofauto.
Require Import cprogs.sumarray2_prog.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* Some definitions relating to the functional spec of this particular program.  *)
Definition sum_Z : list Z -> Z := fold_right Z.add 0.

Lemma sum_Z_app:
  forall a b, sum_Z (a++b) =  sum_Z a + sum_Z b.
Proof.
  intros. induction a; simpl; omega.
Qed.


Require Import Arith Bool String.

Infix "==s" := string_dec (no associativity, at level 50).
Infix "==nat" := eq_nat_dec (no associativity, at level 50).
Infix "<nat" := le_gt_dec (no associativity, at level 50).

Notation "f $ x" := (f x) (at level 60, right associativity, only parsing).

Ltac invert x := inversion x; subst; clear x.

(* This tactic due to Clement Pit-Claudel with some minor additions by JDP to
   allow the result to be named: https://pit-claudel.fr/clement/MSc/#org96a1b5f *)
Inductive Learnt {A: Type} (a: A) :=
| AlreadyKnown : Learnt a.

Ltac learn_tac fact name :=
  lazymatch goal with
  | [ H: Learnt fact |- _ ] =>
    fail 0 "fact" fact "has already been learnt"
  | _ => let type := type of fact in
        lazymatch goal with
        | [ H: @Learnt type _ |- _ ] =>
          fail 0 "fact" fact "of type" type "was already learnt through" H
        | _ => let learnt := fresh "Learn" in
              pose proof (AlreadyKnown fact) as learnt; pose proof fact as name
        end
  end.

Tactic Notation "learn" constr(fact) := let name := fresh "H" in learn_tac fact name.
Tactic Notation "learn" constr(fact) "as" simple_intropattern(name) := learn_tac fact name.

Ltac nicify_hypotheses :=
  repeat match goal with
         | [ H : ex _ |- _ ] => invert H
         | [ H : Some _ = Some _ |- _ ] => invert H
         | [ H : ?x = ?x |- _ ] => clear H
         | [ H : ?x = ?x -> _ |- _ ] => assert (x = x) as ?EQ by reflexivity; apply H in EQ; clear H
         | [ H : _ /\ _ |- _ ] => invert H
         end.

Ltac nicify_goals :=
  repeat match goal with
         | [ |- _ /\ _ ] => split
         | [ |- Some _ = Some _ ] => f_equal
         | [ |- S _ = S _ ] => f_equal
         end.

Ltac kill_bools :=
  repeat match goal with
         | [ H : _ && _ = true |- _ ] => apply andb_prop in H
         | [ H : _ || _ = false |- _ ] => apply orb_false_elim in H
         end.

Ltac substpp :=
  repeat match goal with
         | [ H1 : ?x = Some _, H2 : ?x = Some _ |- _ ] =>
           let EQ := fresh "EQ" in
           learn H1 as EQ; rewrite H2 in EQ; invert EQ
         | _ => idtac
         end.

Ltac simplify := intros; simpl in *;
                 repeat (nicify_hypotheses; nicify_goals; kill_bools; substpp);
                 simpl in *.

Ltac restrict x := destruct x; simplify; try discriminate; try congruence; eauto.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q : Universe, ((wd_ P Q /\ (wd_ B Q /\ (wd_ A B /\ (wd_ P B /\ (wd_ C B /\ (wd_ A C /\ (col_ B A P /\ col_ A B Q))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************)
(*                       QUEUE.v                     *)
(*                     Yijia CHEN                    *)
(*                                                   *)
(*****************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Require Import Arith.
Require Import Comp.

Section QUEUE_DEF.

Variable Domain : Set.

Variable err : Domain.

Variable weight : Domain -> nat.

(**********************************************)
(* max(d1,d2) = d1 if weight(d1) > weight(d2) *)
(*            = d2 otherwise                  *)
(* so if weight(d1) == weight(d2)             *)
(*    then max(d1,d2) = d2                    *)
(**********************************************)

Let max (d1 d2 : Domain) : Domain :=
  if less (weight d2) (weight d1) then d1 else d2.

Inductive Queue : Set :=
  | empty : Queue
  | push : Domain -> Queue -> Queue.

Fixpoint queue_length (q : Queue) : nat :=
  match q with
  | empty => 0
  | push d q' => S (queue_length q')
  end.

(************************************************)
(*  pop_ele(q) = the oldest element in q        *)
(*               with minimal weight            *)
(************************************************)

Fixpoint pop_ele (q : Queue) : Domain :=
  match q with
  | empty => err
  | push d q' =>
      match q' with
      | empty => d
      | push d' p'' => max d (pop_ele q')
      end
  end.

(************************************************)
(*  pop_que(q) = q - pop_ele(q)                 *)
(************************************************)

Fixpoint pop_que (q : Queue) : Queue :=
  match q with
  | empty => empty
  | push d q' =>
      match q' with
      | empty => empty
      | push _ _ =>
          if less (weight d) (weight (pop_ele q'))
          then q'
          else push d (pop_que q')
      end
  end.

(************************************************)
(*  del_que(q,P) = q - {e | Pe}                 *)
(************************************************)

Fixpoint del_que (q1 : Queue) : Queue -> (Domain -> Prop) -> Prop :=
  match q1 with
  | empty =>
      fun q2 : Queue =>
      match q2 with
      | empty => fun P : Domain -> Prop => True
      | push d2 q2' => fun P : Domain -> Prop => False
      end
  | push d1 q1' =>
      fun (q2 : Queue) (P : Domain -> Prop) =>
      (P d1 -> del_que q1' q2 P) /\
      (~ P d1 ->
       match q2 with
       | empty => False
       | push d2 q2' => d1 = d2 /\ del_que q1' q2' P
       end)
  end.

(************************************************)
(*  push_ram(q,a) = q + a (randomly)            *)
(************************************************)

Fixpoint push_ram (q1 q2 : Queue) {struct q2} : Domain -> Prop :=
  match q1, q2 with
  | empty, empty => fun d : Domain => False
  | empty, push d2 q2' => fun d : Domain => d2 = d /\ q2' = empty
  | push d1 q1', empty => fun d : Domain => False
  | push d1 q1', push d2 q2' =>
      fun d : Domain =>
      (d2 = d -> q2' = q1) /\ (d2 <> d -> d1 = d2 /\ push_ram q1' q2' d)
  end.

End QUEUE_DEF.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose     : Complex number
  author      : ZhengPu Shi
  date        : 2022.08

  ref         :
  1. 《复变函数与积分变换》第4版 华中科技大学 李红
  2. Coqtail project
  3. Coquelicot project

  remark      :
  1. Record定义，可以用 let (a,b,c) := x 来分解各个字段，也还可以 intro [x y z]
   来分解，相比显式的写出 buildXX 这个构造函数名要简洁不少。
*)

(* Require Import ProofIrrelevance. (* proof_irrelevance *) *)

Require Export RExt.
Open Scope R.

(** * 自动化策略，后期会移动至全局位置 *)

(** 逻辑运算的化简 *)
Ltac logic_simp :=
  (* 将合取式、蕴涵式等去掉，转换为简单的形式 *)
  repeat match goal with
    (* 目标是合取式 *)
    | |- _ /\ _ => split
    (* 目标是蕴涵式 *)
    | |- _ -> _ => intros
    end.

(** 解决“可能以不同方向重写前提，并最终完成目标”的问题？
    例如：前提中有 E1,E2,...En 这么多等式，要证明目标，可能的形式有：
         Ei,Ej,Ek'
    其中，Ei 表示重写第 i 个等式，Ek' 表示反向重写第k个等式。
    换言之，解决路径是：
       开始: e1 或 e1'; reflexivity
       e1: e2 或 e2'; reflexivity
       e1': e2 或 e2'; reflexivity
       e2: e3 或 e3'; reflexivity
       如此迭代。

    暂时写不出比较通用的算法，但可以手动建立有限的几种形式。
 *)
(* Require Import CpdtTactics. *)
Module Export Try_Rewrite.
  Open Scope R.

  Ltac rewriteHyp :=
    let u H := (rewrite H) in
    let v H := (rewrite <- H) in
    match goal with
    | H1:_=_, H2:_=_, H3:_=_ |- _ =>
        try (u H1; u H2; u H3; reflexivity);
        try (u H1; u H2; v H3; reflexivity);
        try (u H1; v H2; u H3; reflexivity);
        try (u H1; v H2; v H3; reflexivity);
        try (v H1; u H2; u H3; reflexivity);
        try (v H1; u H2; v H3; reflexivity);
        try (v H1; v H2; u H3; reflexivity);
        try (v H1; v H2; v H3; reflexivity)
    | H1:_=_, H2:_=_ |- _ =>
        try (u H1; u H2; reflexivity);
        try (u H1; v H2; reflexivity);
        try (v H1; u H2; reflexivity);
        try (v H1; v H2; reflexivity)
    | H1:_=_ |- _ =>
        try (u H1; reflexivity);
        try (v H1; reflexivity)
    end.

  (** 示例1。subst,auto,lra,ring 等都不能解决 *)
  Goal forall a b c (f:R->R),
      a + b = b + c ->
      a + c = b + c ->
      f (a + b) = f (a + c).
  Proof.
    (* 测试了 crush，虽然能解决，但是花费了 0.5 s *)
    (* Time crush. (* 0.5s *) *)

    (* 手动证明：H,H0' *)
    (* logic_simp. *)
    (* rewrite H; rewrite <- H0; reflexivity. *)

    (* 自动证明 *)
    logic_simp.
    rewriteHyp.
  Qed.

End Try_Rewrite.

(* ======================================================================= *)
(** ** 1.1 复数 *)

(* --------------------------------------------------------------------- *)
(** *** 1.1.1 复数的基本概念 *)

(* 声明作用域 *)
Declare Scope C_scope.
Delimit Scope C_scope with C.
Open Scope C_scope.

(* 关于复数的定义，第一版定义为 pair，目前第二版定义为记录。
原因是，复数有不同的表示，可以是直角坐标表示，比如这里，也可以是三角表示，
所以，单独使用对偶容易混淆。暂时使用专门的名称来表示 *)

(** 复数的定义 *)
Record C := mkC {
  Cre : R;  (* 实部 *)
  Cim : R   (* 虚部 *)
}.

(** 用户友好的记号 *)
Notation "a '+i' b" := (mkC a b) (at level 10) : C_scope.

(** 由两个实数构造复数 *)
Definition RR2C (x y : R) : C := x +i y.

(** 由复数得到两个实数 *)
Definition C2RR (z : C) : R * R := (Cre z, Cim z).

(** 实数到复数，作为实部，虚部赋0 *)
Definition IRC (x : R) : C := x +i 0.

Coercion IRC : R >-> C.

(** 由复数得到实数，只保留实部，丢弃虚部 *)
Definition C2R (z : C) : R := Cre z.

(** 一些常数 *)
Definition C0 := RR2C 0 0.
Definition C1 := RR2C 1 0.
Definition Ci := RR2C 0 1.

(* 绑定作用域 *)
Bind Scope C_scope with C Cre Cim C0 C1.

Section ex.
  Let z : C := (sqrt 2) +i 1.

  Goal Cre z = sqrt 2. reflexivity. Qed.
  Goal Cim z = 1. auto. Qed.
End ex.

(** 复数为零，iff，x=y=0 *)
Lemma Ceq0_iff_re0_im0 : forall z : C, z = 0 <-> (Cre z = 0 /\ Cim z = 0).
Proof.
  intros [x y]. split; intros H.
  - inversion H. simpl. auto.
  - simpl in *. destruct H. subst. auto.
Qed.

(** 非零复数，iff，x^2 + y^2 <> 0 *)
Lemma Cneq0_iff_plus_sqr_re_sqr_im_neq0 : forall z : C, z <> 0 <->
  Cre z * Cre z + Cim z * Cim z <> 0.
Proof.
  intros [x y]. split; simpl; intros H.
  - intro. apply Rplus_sqr_eq_0 in H0. destruct H0; subst. auto.
  - intro. inversion H0; subst. lra.
Qed.

(** 非零复数 iff 实部和虚部不全为零 *)
Lemma Cneq0_iff_re_neq0_or_im_neq0 : forall z : C,
  z <> 0 <-> (Cre z <> 0 \/ Cim z <> 0).
Proof.
  intros [x y]; simpl; split; intro H.
  - case (Req_EM_T x 0); case (Req_EM_T y 0); intros Ha Hb; subst; auto.
  - intros H1. inversion H1. subst. destruct H; auto.
Qed.

(** 共轭复数 *)
Definition Cconj (z : C) : C := let (x, y) := z in (x +i (-y)).

Notation "\ z" := (Cconj z) (at level 30, right associativity) : C_scope.

(** 共轭的共轭等于自身 *)
Lemma Cconj_conj : forall z : C, \\z = z.
Proof. intros [x y]. simpl. f_equal. ring. Qed.

(* --------------------------------------------------------------------- *)
(** *** 1.1.2 复数的四则运算 *)

(** 若前提中有复数，则先分解为两个实数 *)
Ltac CtoR := match goal with
  | z:C |- _ => destruct z as [?r ?r]
  end.

(** 证明复数运算等式 *)
Ltac ceq :=
  intros;
  (* 将前提中所有复数分解为实数 *)
  repeat CtoR;
  (* 化简 *)
  compute;
  (* 若是复数等式，则转换为两个实数等式 *)
  try (match goal with | |- @eq C _ _ => f_equal end);
  (* 若是实数等式，则进行等式求解 *)
  try (match goal with | |- @eq R _ _ => try ring; try field end).

(** 复数的加法运算 *)
Definition Cadd (z1 : C) (z2 : C) : C :=
  let (x1, y1) := z1 in
  let (x2, y2) := z2 in
    (x1 + x2) +i (y1 + y2).
Infix "+" := Cadd : C_scope.

(** 复数加法满足结合律 *)
Lemma Cadd_assoc : forall z1 z2 z3, (z1 + z2) + z3 = z1 + (z2 + z3).
Proof. ceq. Qed.

(** 复数加法满足交换律 *)
Lemma Cadd_comm : forall z1 z2, z1 + z2 = z2 + z1.
Proof. ceq. Qed.

(** 复数的取反运算 *)
Definition Copp (z : C) : C :=
  let (x, y) := z in
    (-x) +i (-y).
Notation "- z" := (Copp z) : C_scope.

(** 复数的减法运算 *)
Definition Csub (z1 : C) (z2 : C) : C :=
  let (x1, y1) := z1 in
  let (x2, y2) := z2 in
    (x1 - x2) +i (y1 - y2).
Infix "-" := Csub : C_scope.

(** 复数减法满足反对称性 *)
Lemma Csub_antisym : forall z1 z2 : C, z1 - z2 = - (z2 - z1).
Proof. ceq. Qed.

(** 复数的乘法运算 *)
Definition Cmul (z1 : C) (z2 : C) : C :=
  let (x1, y1) := z1 in
  let (x2, y2) := z2 in
    (x1 * x2 - y1 * y2) +i (x1 * y2 + x2 * y1).
Infix "*" := Cmul : C_scope.

(** 复数乘法满足结合律 *)
Lemma Cmul_assoc : forall z1 z2 z3, (z1 * z2) * z3 = z1 * (z2 * z3).
Proof. ceq. Qed.

(** 复数乘法满足交换律 *)
Lemma Cmul_comm : forall z1 z2, z1 * z2 = z2 * z1.
Proof. ceq. Qed.

(** 复数乘法对加法满足分配律 *)
Lemma Cmul_add_distr_l : forall z1 z2 z3, z1 * (z2 + z3) = z1 * z2 + z1 * z3.
Proof. ceq. Qed.

Lemma Cmul_add_distr_r : forall z1 z2 z3, (z1 + z2) * z3 = z1 * z3 + z2 * z3.
Proof. ceq. Qed.

Section ex.
  Goal 2 +i (-3) * 4 +i 5 = 23 +i (-2). ceq. Qed.
  Goal Ci * Ci = -1. ceq. Qed.
End ex.

(** 实数乘以复数，即数乘 *)
Definition Cscal (a : R) (z : C) : C :=
  let (x, y) := z in (a * x) +i (a * y).

(** 复数的倒数 *)
Definition Cinv (z : C) : C :=
  let (x, y) := z in
  let r := (x * x + y * y)%R in
    (x / r) +i (-y / r).
Notation "/ z" := (Cinv z) : C_scope.

(** 复数的除法运算 *)
Definition Cdiv (z1 : C) (z2 : C) : C :=
  let (x1, y1) := z1 in
  let (x2, y2) := z2 in
  let r2 := (x2 * x2 + y2 * y2)%R in
  let u := ((x1 * x2 + y1 * y2) / r2)%R in
  let v := ((x2 * y1 - x1 * y2) / r2)%R in
    u +i v.
Infix "/" := Cdiv : C_scope.

(** 验证除法定义 *)
Lemma Cdiv_ok : forall z1 z2 : C, z2 <> 0 -> z1 = z2 * (z1 / z2).
Proof.
  ceq.
  all: apply Cneq0_iff_plus_sqr_re_sqr_im_neq0 in H; auto.
Qed.

(** 乘以自身的共轭的化简式 *)
Lemma Cmul_conj_self : forall z : C, z * \z =
  let (x,y) := z in (x*x+y*y) +i 0.
Proof. ceq. Qed.

(** 乘以某个共轭复数的化简式 *)
Lemma Cmul_conj_any : forall z1 z2 : C, z1 * \z2 =
  let (x1,y1) := z1 in
  let (x2,y2) := z2 in
    (x1 * x2 + y1 * y2) +i (x2 * y1 - x1 * y2).
Proof. ceq. Qed.

(** 利用上述性质得到复数除法的另一种形式 *)
Lemma Cdiv_eq : forall z1 z2 : C, z2 <> 0 ->
  z1 / z2 = (z1 * \z2) / (z2 * \z2).
Proof.
  intros [x1 y1] [x2 y2] H. unfold Cdiv at 1.
  rewrite Cmul_conj_self.
  rewrite Cmul_conj_any. simpl. f_equal; field.
  all: apply (Cneq0_iff_plus_sqr_re_sqr_im_neq0 (x2+i y2)); auto.
Qed.

Section ex.
  Goal 3 +i (-2) / 2 +i 3 = -Ci. ceq. Qed.
End ex.

(** 共轭复数运算的一些性质 *)

(** 相加以后再共轭，等于共轭后再相加 *)
Lemma Cconj_add : forall z1 z2 : C, \(z1 + z2) = \z1 + \z2.
Proof. ceq. Qed.

(** 相减以后再共轭，等于共轭后再相减 *)
Lemma Cconj_sub : forall z1 z2 : C, \(z1 - z2) = \z1 - \z2.
Proof. ceq. Qed.

(** 相乘以后再共轭，等于共轭后再相乘 *)
Lemma Cconj_mul : forall z1 z2 : C, \(z1 * z2) = \z1 * \z2.
Proof. ceq. Qed.

(** 相除以后再共轭，等于共轭后再相除 *)
Lemma Cconj_div : forall z1 z2 : C, z2 <> 0 -> \(z1 / z2) = \z1 / \z2.
Proof.
  intros. ceq.
  all: replace (- r0 * - r0)%R with (r0 * r0)%R; try ring;
  apply Cneq0_iff_plus_sqr_re_sqr_im_neq0 in H; auto.
Qed.

(** 乘以共轭，等于模的平方 *)
Lemma Cmul_conj : forall z : C, z * \z =
  let (x, y) := z in (x * x + y * y) +i 0.
Proof. ceq. Qed.

(** 实部用共轭来表示 *)
Lemma Cre_eq : forall z : C, Cre z = C2R ((1/2) * (z + \z)).
Proof. ceq. Qed.

(** 虚部用共轭来表示 *)
Lemma Cim_eq : forall z : C, Cim z = C2R ((1 / (2 * Ci)) * (z - \z)).
Proof. ceq. Qed.

(** 例1 *)
Example ex1_1 : forall z1 z2,
  (2 * Cre (z1 * \z2))%R = C2R (z1 * \z2 + \z1 * z2).
Proof. ceq. Qed.

(** 再次理解，复数是什么？
  1. 复数是用两个实数x,y同 i,+ 连接而成的这样一种形式，而i,+是什么，未说明。
  2. 现在，可以将复数 z = x + i y 理解为实数乘法和加法，只是 i 是特殊的。
  3. 历史上，第一次引进 -1 的平方根作为数时，作为想象中的数，称为“虚数”，
    后来把形如 x + i y 的数叫做复数，意思是“复合”起来的数。
*)

(** 用实数运算及i来构造复数 *)
Module complex_construction_by_real.

  Open Scope R.
  (** 因为 i 已经被使用，所以用 j 来代替 i *)
  Parameter j : R.
  Parameter sqr_neg1 : j * j = -1.

  Definition Complex (x y : R) : R := x + y * j.

  Lemma eq1 : forall x, x = Complex x 0.
  Proof. ceq. Qed.

  Lemma eq2 : j = 0 + 1 * j.
  Proof. ceq. Qed.

  Lemma eq3 : forall x y, (x + 0 * j) + (0 + 1 * j) * (y + 0 * j) = Complex x y.
  Proof. ceq. Qed.

  (** 形式上，已经构造出了复数。
      但是，由于假设了一个“在实数域中存在数j，使得j * j = -1”的前提，
      而该前提是错误的，因此后续证明都不可信。
      也许，复数与二维平面上的点一一映射，这种理解更加合理，i只是一个记号而已。
   *)

End complex_construction_by_real.

(* --------------------------------------------------------------------- *)
(** *** 1.1.3 复（数）平面 *)

(** 实数对、复数、坐标平面上的点三者的对应关系。
 复数集合、坐标平面 一个复数 x+iy 唯一对应一个有序实数对 (x,y)，
 而有序实数对与坐标平面上的点一一对应。
 现在，坐标平面上的点写成 x + i y，那么横轴上的点表示实数，纵轴上的点表示纯序数，
 整个坐标平面可称为复平面。
 今后，复数、复平面不加区分。
 在点、数等同的观点下，复数集合就是一个平面点集。
 于是，某些特殊的平面点集可用复数所满足的某种关系式来表示。
*)

Section cplane.

  (** 上半平面 *)
  Let set1 : Prop := forall z : C, Cim z >= 0.

  (** 以 0,1,1+i,i 为顶点的正方形 *)
  Let set2 : Prop := forall z : C,
    let (x, y) := (Cre z, Cim z) in
    (0 <= x <= 1 /\ 0 <= y <= 1).

  (** 实部为1的一条直线 *)
  Let set3 : Prop := forall z : C, Cre z = 1.

End cplane.

(* ======================================================================= *)
(** ** 1.2 复数的三角表示 *)

(* --------------------------------------------------------------------- *)
(** *** 1.2.1 复数的模与辐角 *)

(** 除了将复数实部和虚部分别看做是直角坐标系下的横坐标与纵坐标，
 复数还可以与平面向量对应，将实部和虚部分别看做向量的水平和垂直分量。
 需要注意的是，向量具有平移不变性（即，起点可以放在任意一点），
 若把向量的起点放在（复平面的）坐标原点，则此向量与向量的终点恰好对应于同一个复数。
 即：复数x+iy, 平面一点(x,y)，向量x+iy[起点放在原点后]，这三者彼此对应。
*)

(** 提示：由于复数可以表示平面向量，所以有关平面向量的问题可能利用复变函数来研究。
 于是，复变函数论逐渐被应用于理论物理、弹性力学、流体力学等学科，成为重要的数学工具。
 同时，人们也改变了对复数的看法，不再认为是虚无缥缈的东西。*)

(** 复数的模：复数z不为0时，它所对应向量的长度称为z的模
 复数的模，也称绝对值、幅值 *)

(*  - - - - - - - - -  - - - - - - - - - - - - - - - - - - - - - - - - *)
(** **** 复数的模 *)

(** 复数的模的平方 *)
Definition Cnorm2 (z : C) : R := let (x, y) := z in x * x + y * y.

(** 复数的模 *)
Definition Cnorm (z : C) : R := sqrt (Cnorm2 z).

Notation "| z |" := (Cnorm z) (at level 20) : C_scope.

(** 模相等，iff，模平方相等 *)
Lemma Cnormeq_iff_norm2eq : forall z1 z2, |z1| = |z2| <-> Cnorm2 z1 = Cnorm2 z2.
Proof. intros. ceq. logic_simp. auto with R. rewriteHyp. Qed.

(** 复数为零，iff，模平方为0 *)
Lemma Ceq0_iff_norm2_eq0 : forall z : C, (z = 0) <-> (Cnorm2 z = 0).
Proof.
  intros [x y]. unfold Cnorm2; split; intros.
  - inversion H. subst. compute. ring.
  - apply Rplus_sqr_eq_0 in H. destruct H; subst; auto.
Qed.

(** 复数为零，iff，模为0 *)
Lemma Ceq0_iff_norm_eq0 : forall z : C, (z = 0) <-> (|z| = 0).
Proof.
  intros [x y]. rewrite Ceq0_iff_norm2_eq0.
  unfold Cnorm, Cnorm2. split; intros H.
  - rewrite H. autorewrite with R; auto.
  - apply Rsqrt_plus_sqr_eq0_iff in H. destruct H; subst; ring.
Qed.

(** 复数的模平方非负 *)
Lemma Cnorm2_ge0 : forall z : C, 0 <= Cnorm2 z.
Proof.
  destruct z. unfold Cnorm2; simpl.
  apply Rplus_le_le_0_compat; apply Rle_0_sqr.
Qed.

(** 复数的模非负 *)
Lemma Cnorm_ge0 : forall z : C, 0 <= |z|.
Proof. intros z. unfold Cnorm. apply sqrt_pos. Qed.

(** 复数的模平方等于模的平方 *)
Lemma Cnorm2_eq : forall z : C, Cnorm2 z = (|z|)².
Proof.
  intros z. unfold Cnorm. rewrite Rsqr_sqrt; auto.
  apply Cnorm2_ge0.
Qed.

(** 复数不为零，iff，模平方不为0 *)
Lemma Cneq0_iff_norm2_neq0 : forall z : C, z <> 0 <-> Cnorm2 z <> 0.
Proof.
  intros [x y].
  rewrite Cneq0_iff_plus_sqr_re_sqr_im_neq0. simpl. tauto.
Qed.

(** 复数不为零，iff，模不为0 *)
Lemma Cneq0_iff_norm_neq0 : forall z : C, z <> 0 <-> |z| <> 0.
Proof.
  intros. split; intros H H1.
  - apply Ceq0_iff_norm_eq0 in H1. auto.
  - apply Ceq0_iff_norm_eq0 in H1. auto.
Qed.

(** 复数的模平方恒正，iff，该复数非零 *)
Lemma Cnorm2_pos_iff_neq0 : forall z : C, 0 < Cnorm2 z <-> z <> 0.
Proof.
  intros [x y]. unfold Cnorm2. split; intros.
  - intro. inversion H0. subst. lra.
  - apply Cneq0_iff_re_neq0_or_im_neq0 in H. simpl in *. destruct H.
    + apply Rplus_lt_le_0_compat; try apply Rle_0_sqr.
      apply Rsqr_pos_lt; auto.
    + apply Rplus_le_lt_0_compat; try apply Rle_0_sqr.
      apply Rsqr_pos_lt; auto.
Qed.

(** 模的平方等于乘以共轭 *)
Lemma Cnorm2_eq_mulConj : forall z, Cnorm2 z = C2R (z * \z).
Proof. ceq. Qed.

(** 复数的倒数等于 共轭除以模平方 *)
Lemma Cinv_eq_conjDivNorm2 : forall z : C, z <> 0 -> Cinv z = \z / (Cnorm2 z).
Proof.
  assert (H: forall a b, a +i b <> 0 -> (a*a + b*b <> 0)%R).
  { ra. intro. apply Rplus_sqr_eq0_iff in H0. destruct H0.
    destruct H. ceq;auto. }
  intros. ceq; apply H; auto.
Qed.

(** 实数提升为复数后的模等于原本实数的绝对值 *)
Lemma Cnorm_IRC : forall x : R, |IRC x| = Rabs x.
Proof.
  intros x. unfold Cnorm, Cnorm2; simpl.
  autorewrite with R. auto.
Qed.

(** 复数求模再求模结果不变。 | |z| | = |z|，其实是 | IRC (|z|) | = |z| *)
Lemma Cnorm_norm : forall z : C, | |z| | = |z|.
Proof.
  intro z; rewrite Cnorm_IRC.
  apply Rabs_right.
  apply Rle_ge; apply Cnorm_ge0.
Qed.

(** 共轭的模等于原本的模 *)
Lemma Cnorm_conj : forall z : C, |\z| = |z|.
Proof. intros [x y]. apply Cnormeq_iff_norm2eq. ceq. Qed.

(** 相反数的模等于原本的模 *)
Lemma Cnorm_opp : forall z : C, | -z | = |z|.
Proof. intros [x y]. simpl. apply Cnormeq_iff_norm2eq. simpl. ring. Qed.

(** 差的模满足对称性 *)
Lemma Cnorm_sub_sym : forall z1 z2 : C, |z1 - z2| = |z2 - z1|.
Proof. intros; rewrite Csub_antisym; rewrite Cnorm_opp; auto. Qed.

(** 数乘的模等于数乘以模 *)
Lemma Cnorm_scal : forall (a : R) (z : C), |Cscal a z| = ((Rabs a) * |z|)%R.
Proof.
  intros a [x y]. simpl. unfold Cnorm,Cnorm2.
  replace (a * x * (a * x) + a * y * (a * y))%R
  with ((a * a) * (x * x + y * y))%R; try ring.
  rewrite sqrt_mult_alt; auto with R; try nra.
  autorewrite with R; auto.
Qed.

(** 乘积的模等于模的乘积 *)
Lemma Cnorm_mul : forall z1 z2 : C, |z1 * z2| = (|z1| * |z2|)%R.
Proof.
  intros [x1 y1] [x2 y2]. unfold Cnorm,Cnorm2. simpl.
  rewrite <- sqrt_mult. f_equal. ring.
  all: apply Rplus_sqr_ge0.
Qed.

(** 非零复数，倒数的模等于模的倒数 *)

(** ToDo:
    在这个证明中，使用了 inv_sqrt 引理，但从 8.16 开始，提示这个引理即将弃用，
    不过我觉得这里有个问题：

    Check inv_sqrt. (* inv_sqrt
     : forall x : R, 0 < x -> (/ sqrt x)%R = sqrt (/ x) *)

    Check sqrt_inv. (* sqrt_inv
     : forall x : R, sqrt (/ x) = (/ sqrt x)%R *)

    看起来，sqrt_inv 少了一个前提，简单了。
    但是，这个引理到底对吗？当 x = 0 时，作何解释？
 *)
Lemma Cnorm_inv : forall z : C, z <> 0 -> | /z | = (/(|z|))%R.
Proof.
  intros [x y] H. unfold Cnorm, Cnorm2; simpl.
  match goal with
  | |- sqrt ?a = (/(sqrt ?b))%R =>
    replace a with (/b)%R; try field
  end.
  - rewrite sqrt_inv; auto.
  - apply Cneq0_iff_norm2_neq0 in H. auto.
Qed.

(*  - - - - - - - - -  - - - - - - - - - - - - - - - - - - - - - - - - *)
(** **** 辐角 *)

(** 复数的主辐角，本书规定 (-pi,pi]，有的书固定 [0,pi) *)
(*
  算法伪代码：
  if (x = 0) {
    if (y < 0) { -pi/2 } else { pi/2 }
  } else {
    if (x < 0) {
      if (y < 0) { atan(y/x) - pi } else { atan(y/x) + pi }
    } else {
      atan(y/x)
    }
  }

  ToDo: 由于复数为0时，俯角是任意值，这里隐含定义了俯角为 pi/2，不确定有没有问题?
*)
Definition Carg (z : C) : R :=
  let (x, y) := (Cre z, Cim z) in
  let r : R := atan (y / x)%R in
    if (Req_EM_T x 0)
    then (if Rcase_abs y then (- (PI / 2))%R else (PI / 2)%R)
    else (if Rcase_abs x
      then (if Rcase_abs y then (r - PI)%R else (r + PI)%R)
      else r).

Notation "∠ z" := (Carg z) (at level 10) : C_scope.

(** 自动分解 Req_EM_T, Rcase_abs 情形，以证明 Carg 有关的等式 *)
Ltac tacCarg :=
  intros;
  cbn;
  repeat (match goal with
  | |- context [Req_EM_T ?a ?b] => destruct Req_EM_T; try lra
  end);
  repeat (match goal with
  | |- context [Rcase_abs ?a] => destruct Rcase_abs; try lra
  end).

Lemma Carg_case1 : forall x y, x > 0 -> ∠ (x +i y) = atan (y/x).
Proof. tacCarg. Qed.

Lemma Carg_case2 : forall x y, x = 0 -> y > 0 -> ∠ (x +i y) = (PI / 2)%R.
Proof. tacCarg. Qed.

Lemma Carg_case3 : forall x y, x < 0 -> y >= 0 -> ∠ (x +i y) = (atan(y/x)+PI)%R.
Proof. tacCarg. Qed.

Lemma Carg_case4 : forall x y, x < 0 -> y < 0 -> ∠ (x +i y) = (atan(y/x)-PI)%R.
Proof. tacCarg. Qed.

Lemma Carg_case5 : forall x y, x = 0 -> y < 0 -> ∠ (x +i y) = (- PI/2)%R.
Proof. tacCarg. Qed.

(** 负实数的辐角 *)
Lemma Carg_negR : forall x, x < 0 -> ∠ x = PI.
Proof.
  intros x H. tacCarg.
  unfold Rdiv. rewrite Rmult_0_l. rewrite atan_0. ring.
Qed.

(** 负实数的共轭的辐角 *)
Lemma Carg_conj_negR : forall x, x < 0 -> ∠ (\x) = PI.
Proof.
  intros x H. tacCarg.
  rewrite Ropp_0. unfold Rdiv. rewrite Rmult_0_l. rewrite atan_0. ring.
Qed.

(** 非零且非负实数的共轭的辐角 *)
Lemma Carg_conj_non0_nonnegR : forall z,
  z <> 0 -> (~(Cre z < 0 /\ Cim z = 0)) ->
  ∠ (\z) = ∠ z.
Proof.
  intros x H. tacCarg. all: rewrite Ropp_0; auto.
Qed.

(** 辐角的定义，是多值函数 *)
Definition CArg (c : C) : Z -> R := fun k => (∠c + 2 * (IZR k) * PI)%R.

(** 将任意角度规范化在主辐角的范围内，即 [-π,π)
步骤：
  0) r1 ∈ (-∞, +∞)
  1) r2 = r1 / 2π
  2) z1 = floor r2
  3) r3 = r1 - z1 * 2π, r3 ∈ [0, 2π)
  4) r4 = r3 - π, r4 ∈ [-π,π)
*)
Definition CargNorm (theta : R) : R :=
  let r1 : R := theta in
  let r2 : R := (r1 / (2*PI))%R in
  let z1 : Z := R2Z_floor r2 in
  let r3 : R := (r1 - (Z2R z1) * 2 * PI)%R in
    r3 - PI.

(** 定义辅角之间的等价关系：辅角规范化后相等的角 *)
Definition CArgeq (theta1 theta2 : R) : Prop := CargNorm theta1 = CargNorm theta2.
Infix "∠=" := (CArgeq) (at level 70) : C_scope.

Lemma CargNorm_range_left : forall r : R, - PI <= CargNorm r.
Proof.
  intros. unfold CargNorm.
  assert (0 <= r - Z2R (R2Z_floor (r / (2 * PI))) * 2 * PI); ra.
  rewrite Rmult_assoc.
  remember (2 * PI)%R as a.
  remember (Z2R (R2Z_floor (r / a))) as b.
  assert (b <= (r / a)%R).
  - rewrite Heqb.
    apply Z2R_R2Z_floor_le.
  - assert (0 < a).
    { rewrite Heqa. apply mult_PI_gt0; ra. }
    apply Rmult_le_compat_r with (r:=a) in H; auto with R.
    unfold Rdiv in H. rewrite Rmult_assoc in H.
    rewrite Rinv_l in H; ra.
Qed.

Lemma CargNorm_range_right : forall r : R, CargNorm r < PI.
Proof.
  intros. unfold CargNorm.
  assert (r - Z2R (R2Z_floor (r / (2 * PI))) * (2 * PI) < (2 * PI)); ra.
  remember (2 * PI)%R as a.
  remember (Z2R (R2Z_floor (r / a))) as b.
  assert (b * a > r - a); ra.
  assert (0 < a).
  { rewrite Heqa. apply mult_PI_gt0; ra. }
  assert (b > r / a - 1)%R.
  { rewrite Heqb. apply Rlt_gt. apply Z2R_R2Z_floor_gt. }
  (* 自动化能力还是太弱，这类问题还要手动证？？*)
  apply Rmult_gt_compat_r with (r:=a) in H0; auto.
  ring_simplify in H0.
  replace (a * (r / a))%R with r in H0; auto. field. auto with R.
Qed.

Lemma CargNorm_range : forall r : R, (- PI) <= CargNorm r < PI.
Proof.
  intros. split.
  apply CargNorm_range_left.
  apply CargNorm_range_right.
Qed.

(** 非零复数 -> 实部等于模乘以辐角余弦 *)
Lemma Cre_eq_mul_norm_cos_arg : forall z : C, z <> 0 ->
  Cre z = (|z| * cos(∠z))%R.
Proof.
  intros [x y] H; unfold Cnorm,Cnorm2,Carg; simpl.
  destruct Req_EM_T.
  - subst; autorewrite with R.
    destruct Rcase_abs; autorewrite with R; auto.
  - destruct Rcase_abs; autorewrite with R; auto.
    + replace
      (cos (if Rcase_abs y then atan (y / x) - PI else atan (y / x) + PI))%R
      with (- cos (atan (y / x)))%R.
      * rewrite cos_atan.
        (* x = sqrt(x^2+y^2) * (-1 / sqrt(1 + (y/x)^2) *)
        unfold Rdiv at 1. rewrite Rinv_sqrt_plus_1_sqr_div_a_b; auto.
        replace (Rabs x) with (- x)%R; try field.
        { autorewrite with R. field. auto with R. }
        { rewrite Rabs_left; auto. }
      * destruct Rcase_abs; autorewrite with R; auto.
    + rewrite cos_atan.
      unfold Rdiv at 1. rewrite Rinv_sqrt_plus_1_sqr_div_a_b; auto.
      replace (Rabs x) with (x)%R; try field.
      { autorewrite with R. field. auto with R. }
      { rewrite Rabs_right; auto. }
Qed.

(** 非零复数 -> 虚部等于模乘以辐角正弦 *)
Lemma Cim_eq_mul_norm_sin_arg : forall z : C, z <> 0 ->
  Cim z = (|z| * sin(∠z))%R.
Proof.
  intros [x y] H; unfold Cnorm,Cnorm2,Carg; simpl.
  destruct Req_EM_T.
  - subst; autorewrite with R.
    destruct Rcase_abs; autorewrite with R; auto with R.
    assert (Rabs y = -y)%R; auto with R. ra.
  - destruct Rcase_abs; autorewrite with R; auto.
    + replace
      (sin (if Rcase_abs y then atan (y / x) - PI else atan (y / x) + PI))%R
      with (- sin (atan (y / x)))%R.
      * rewrite sin_atan.
        (* x = sqrt(x^2+y^2) * (-1 / sqrt(1 + (y/x)^2) *)
        unfold Rdiv at 1. rewrite Rinv_sqrt_plus_1_sqr_div_a_b; auto.
        autorewrite with R.
        replace (Rabs x) with (- x)%R; try field; auto with R.
      * destruct Rcase_abs; autorewrite with R; auto with R.
    + rewrite sin_atan.
      unfold Rdiv at 1. rewrite Rinv_sqrt_plus_1_sqr_div_a_b; auto.
      autorewrite with R.
      replace (Rabs x) with (x)%R; try field; auto with R.
Qed.

(** 非零复数 -> 辐角余弦等于实部除以模 *)
Lemma cos_Carg_eq_div_cre_norm : forall z : C, z <> 0 ->
  cos(∠z) = (Cre z / |z|)%R.
Proof.
  intros. rewrite Cre_eq_mul_norm_cos_arg; auto. field.
  apply Cneq0_iff_norm_neq0; auto.
Qed.

(** 非零复数 -> 辐角正弦等于虚部除以模 *)
Lemma sin_Carg_eq_div_cim_norm : forall z : C, z <> 0 ->
  sin(∠z) = (Cim z / |z|)%R.
Proof.
  intros. rewrite Cim_eq_mul_norm_sin_arg; auto. field.
  apply Cneq0_iff_norm_neq0; auto.
Qed.

(* --------------------------------------------------------------------- *)
(** *** 1.2.2 复数模的三角不等式 *)

(** 实部的绝对值小于等于模 *)
Lemma Cre_le_norm : forall z, Rabs (Cre z) <= |z|.
Proof.
  intros [x y]; unfold Cnorm, Cnorm2; simpl.
  rewrite <- sqrt_Rsqr_abs.
  apply sqrt_le_1_alt.
  apply Rle_trans with (x²+0)%R. intuition.
  apply Rplus_le_compat_l. auto with R.
Qed.

(** 虚部的绝对值小于等于模 *)
Lemma Cim_le_norm : forall z, Rabs (Cim z) <= |z|.
Proof.
  intros [x y]; unfold Cnorm, Cnorm2; simpl.
  rewrite <- sqrt_Rsqr_abs.
  apply sqrt_le_1_alt.
  apply Rle_trans with (0 + y²)%R. intuition.
  apply Rplus_le_compat_r. auto with R.
Qed.

(** 模小于等于实部和虚部绝对值之和 *)
Lemma Cnorm_le_plus_cre_cim : forall z : C, |z| <= Rabs (Cre z) + Rabs (Cim z).
Proof.
  intros [x y]; unfold Cnorm, Cnorm2; simpl.
  apply Rsqr_incr_0_var.
  - rewrite Rsqr_sqrt; try ra.
    ring_simplify.
    autorewrite with R.
    rewrite <- ?Rsqr_abs.
    rewrite ?xx_Rsqr.
    ring_simplify.
    assert (0 <= 2 * Rabs x * Rabs y); ra.
    assert (0 <= Rabs x); auto with R.
    assert (0 <= Rabs y); auto with R. ra.
  - apply Rle_trans with (Rabs (x + y)); auto with R.
    apply Rabs_triang.
Qed.

(** 该不等式被多处使用，所以预先证明。编号为1x，x从0开始 *)
Lemma R_neq10 : forall x1 x2 y1 y2 : R,
  x1 * x2 + y1 * y2 <= sqrt (x1 * x1 + y1 * y1) * sqrt (x2 * x2 + y2 * y2).
Proof.
  intros.
  destruct (Rcase_abs (x1*x2+y1*y2)).
  + apply Rle_trans with (r2:=0); try lra.
    apply Rmult_le_pos; auto with R.
  + apply Rsqr_incr_0; auto with R.
    autorewrite with R; auto with R.
    unfold Rsqr in *. ring_simplify.
    (* 分别消去最左端、最右端 *)
    rewrite ?Rplus_assoc; apply Rplus_le_compat_l.
    rewrite <- ?Rplus_assoc; apply Rplus_le_compat_r.
    remember (x1 * y2)%R as a.
    remember (x2 * y1)%R as b.
    replace (2 * x1 * x2 * y1 * y2)%R with (2 * a * b)%R by ra.
    replace (x1 ^ 2 * y2 ^ 2)%R with (a * a)%R by ra.
    replace (x2 ^ 2 * y1 ^ 2)%R with (b * b)%R by ra.
    autorewrite with R. auto with R.
Qed.

(** 该不等式被多处使用，所以预先证明。编号为1x，x从0开始 *)
Lemma R_neq11 : forall x1 x2 y1 y2 : R,
  -(x1 * x2 + y1 * y2) <= sqrt (x1 * x1 + y1 * y1) * sqrt (x2 * x2 + y2 * y2).
Proof.
  intros.
  destruct (Rcase_abs (x1*x2+y1*y2)).
  + autorewrite with R.
    rewrite <- sqrt_mult; auto with R.
    apply Rsqr_incr_0; auto with R; try nra.
    rewrite Rsqr_sqrt; try ra.
    ring_simplify.
    (* 分别消去最左端、最右端 *)
    rewrite ?Rplus_assoc; apply Rplus_le_compat_l.
    rewrite <- ?Rplus_assoc; apply Rplus_le_compat_r.
    remember (x1 * y2)%R as a.
    remember (x2 * y1)%R as b.
    replace (2 * x1 * x2 * y1 * y2)%R with (2 * a * b)%R by ra.
    replace (x1 ^ 2 * y2 ^ 2)%R with (a * a)%R by ra.
    replace (x2 ^ 2 * y1 ^ 2)%R with (b * b)%R by ra.
    autorewrite with R. auto with R.
  + apply Rle_trans with (r2:=0); try lra.
    apply Rmult_le_pos; auto with R.
Qed.

(** 和的模小于等于模的和 *)
Lemma Cnorm_add_le_Cadd_norm : forall z1 z2 : C, |z1 + z2| <= |z1| + |z2|.
Proof.
  intros [x1 y1] [x2 y2]. unfold Cnorm,Cnorm2. simpl.
  apply Rsqr_incr_0; auto with R.
  rewrite ?Rsqr_plus,?Rsqr_sqrt; auto with R.
  ring_simplify.
  replace (x1 ^ 2 + 2 * x1 * x2 + x2 ^ 2 + y1 ^ 2 + 2 * y1 * y2 + y2 ^ 2)%R
  with (x1 ^ 2 + x2 ^ 2 + y1 ^ 2 + y2 ^ 2 + 2 * x1 * x2 + 2 * y1 * y2)%R;
  try ring.
  remember (x1 ^ 2 + x2 ^ 2 + y1 ^ 2 + y2 ^ 2)%R.
  rewrite ?Rplus_assoc. apply Rplus_le_compat_l.
  replace (2 * x1 * x2 + 2 * y1 * y2)%R
  with (2 * (x1 * x2 + y1 * y2))%R; try ring.
  rewrite ?Rmult_assoc. apply Rmult_le_compat_l; try lra.
  apply R_neq10.
Qed.

(** 和的模大于等于模的差 *)
Lemma Cnorm_add_ge_Csub_norm : forall z1 z2 : C,
  Rabs (|z1| - |z2|) <= |z1 + z2|.
Proof.
  intros [x1 y1] [x2 y2]. unfold Cnorm,Cnorm2. simpl.
  apply Rsqr_incr_0; auto with R.
  rewrite <- Rsqr_abs.
  rewrite ?Rsqr_minus,?Rsqr_plus,?Rsqr_sqrt; auto with R.
  ring_simplify.
  replace (x1 ^ 2 + 2 * x1 * x2 + y1 ^ 2 + 2 * y1 * y2 + x2 ^ 2 + y2 ^ 2)%R
  with ((x1 ^ 2 + y1 ^ 2 + x2 ^ 2 + y2 ^ 2) + (2 * (x1 * x2 + y1 * y2)))%R;
  try ring.
  remember (x1 ^ 2 + y1 ^ 2 + x2 ^ 2 + y2 ^ 2)%R. unfold Rminus.
  apply Rplus_le_compat_l.
  replace (2 * (x1 * x2 + y1 * y2))%R
  with (- (2 * (- (x1 * x2 + y1 * y2))))%R; try lra.
  apply Ropp_le_contravar.
  rewrite Rmult_assoc. apply Rmult_le_compat_l; try lra.
  apply R_neq11.
Qed.

(** 差的模大于等于模的差的绝对值 *)
Lemma Cnorm_sub_le_Csub_norm : forall z1 z2 : C,
  Rabs (|z1| - |z2|) <= |z1 - z2|.
Proof.
  intros [x1 y1] [x2 y2]. unfold Cnorm,Cnorm2. simpl.
  apply Rsqr_incr_0; auto with R.
  rewrite <- Rsqr_abs.
  rewrite ?Rsqr_minus,?Rsqr_sqrt; auto with R.
  ring_simplify.
  replace (x1 ^ 2 - 2 * x1 * x2 + y1 ^ 2 - 2 * y1 * y2 + x2 ^ 2 + y2 ^ 2)%R
  with (x1 ^ 2 + y1 ^ 2 + x2 ^ 2 + y2 ^ 2 - 2 * x1 * x2 - 2 * y1 * y2)%R;
  try ring.
  remember (x1 ^ 2 + y1 ^ 2 + x2 ^ 2 + y2 ^ 2)%R. unfold Rminus.
  rewrite ?Rplus_assoc. apply Rplus_le_compat_l.
  replace (-(2 * x1 * x2) + - (2 * y1 * y2))%R
  with ((-2) * (x1 * x2 + y1 * y2))%R; try ring.
  replace (- (2 * sqrt (x1 * x1 + y1 * y1) * sqrt (x2 * x2 + y2 * y2)))%R
  with ((-2) * (sqrt (x1 * x1 + y1 * y1) * sqrt (x2 * x2 + y2*y2)))%R; try ring.
  apply Rmult_le_compat_neg_l; try lra.
  apply R_neq10.
Qed.

(** 差的模大于等于模的差 *)
Lemma Cnorm_sub_ge_Csub_norm : forall z1 z2 : C,
  Rabs (|z1| - |z2|) <= |z1 - z2|.
Proof.
  intros [x1 y1] [x2 y2]. unfold Cnorm,Cnorm2. simpl.
  apply Rsqr_incr_0; auto with R.
  rewrite <- Rsqr_abs.
  rewrite ?Rsqr_minus,?Rsqr_plus,?Rsqr_sqrt; auto with R.
  ring_simplify.
  replace (x1 ^ 2 - 2 * x1 * x2 + y1 ^ 2 - 2 * y1 * y2 + x2 ^ 2 + y2 ^ 2)%R
  with ((x1 ^ 2 + y1 ^ 2 + x2 ^ 2 + y2 ^ 2) - (2 * (x1 * x2 + y1 * y2)))%R;
  try ring.
  remember (x1 ^ 2 + y1 ^ 2 + x2 ^ 2 + y2 ^ 2)%R. unfold Rminus.
  apply Rplus_le_compat_l.
  apply Ropp_le_contravar.
  rewrite Rmult_assoc. apply Rmult_le_compat_l; try lra.
  apply R_neq10.
Qed.

(* --------------------------------------------------------------------- *)
(** *** 1.2.3 复数的三角表示 *)

(** 复数三角表示的定义 *)
(* 注意:
   1. Record指定了字段的名称，Inductive不关心字段名称。二者本质上是相同的
   2. 三角表示只定义了非零复数，复数0并未定义。
      若规定模 >0 后，则排除了复数0，所以，复数0从 C 到 Ctrigo 无法转换
      若规定模 >=0，则包含复数0。若模长恰为0，则任意辅角都对应同一个复数。
   3. 所以，复数三角表示的相等，可以用一个等价关系来表达。
 *)
Inductive Ctrigo := mkCtrigo (r θ : R) (H1 : 0 <= r).

(** 复数三角表示相等：要么都是零向量，要么模长和辅角同时相等 *)
Definition Ctrigo_eq (c1 c2 : Ctrigo) : Prop :=
  let (r1,t1,_) := c1 in
  let (r2,t2,_) := c2 in
  if ((r1 =? 0) && (r2 =? 0)) then True
  else (r1 = r2 /\ t1 ∠= t2).

(** 复数三角表示 -> 复数(坐标表示) *)
Definition Ctrigo2C (c : Ctrigo) : C :=
  let '(mkCtrigo r t _) := c in
    (r * cos t) +i (r * sin t).

(** 复数(坐标表示) -> 复数三角表示 *)
(* 注意，这里的定义，与书上的定义不同，书上用CArg，而不是主辐角，所以有无穷多个值 *)
Definition C2Ctrigo (c : C) : Ctrigo :=
  mkCtrigo (|c|) (∠c) (Cnorm_ge0 c).

(** 复数三角表示的模 *)
Lemma Cnorm_trigo (c : Ctrigo) : let (r,t,_) := c in |Ctrigo2C c| = r.
Proof.
  destruct c as [r t]. cbn. unfold Cnorm,Cnorm2.
  replace (r * cos t * (r * cos t) + r * sin t * (r * sin t))%R
  with ((r * r) * ((cos t)² + (sin t)²))%R.
  - rewrite cos2_sin2. autorewrite with R. auto with R.
  - unfold Rsqr. ring.
Qed.

Lemma Rmult_lt_0_reg : forall r1 r2 : R, 0 <= r1 -> r1 * r2 < 0 -> r2 < 0.
Proof. intros. ra. Qed.

Lemma cos_eq0 : forall (k : Z),
    cos (PI / 2 + (IZR k) * PI)%R = 0.
Proof.
  Admitted.

(** CargNorm 以 2π 为周期 *)
Theorem CargNorm_period : forall (t:R) (k:Z),
    CargNorm (t + IZR k * 2 * PI)%R = CargNorm t.
Admitted.

(** 在 [-π,π) 之间的角度，CargNorm 作用后不变 *)
Theorem CargNorm_range_unique : forall (t:R), - PI <= t < PI -> CargNorm t = t.
Admitted.

(** ToDo: 一个发现，Coq中对这些三角函数的周期性普遍都没有证明。至少默认的库中
    我找不到相关引理。*)

(** tan 以 2π 为周期 *)
Theorem tan_period : forall (t:R) (k:Z),
    tan (t + IZR k * 2 * PI)%R = tan t.
Admitted.

(** 复数三角表示时，若模长为证，则其辅角满足如下关系式 *)
Lemma Carg_trigo (c : Ctrigo) : let (r,t,_) := c in
  0 < r -> ∠ (Ctrigo2C c) = CargNorm t.
Proof.
  destruct c as [r t H]; intros.
  tacCarg; subst; ra.
  - assert (sin t < 0); ra.
    assert (cos t = 0); ra.
    assert (forall t, cos t = 0 -> sin t < 0 ->
                 exists k : Z,
                   let T : R := ((IZR k) * 2 * PI)%R in
                   t = (- (PI / 2) + T)%R).
    admit.
    specialize (H3 t H2 H1). destruct H3.
    rewrite H3. rewrite CargNorm_period.
    rewrite CargNorm_range_unique; auto with R.
    assert (PI > 0); auto with R; ra.
  - assert (cos t = 0); ra.
    assert (sin t > 0).
    { assert (sin t <> 0). intro. destruct (cos_sin_0 t); auto. ra. }
    assert (forall t, cos t = 0 -> sin t > 0 ->
                 exists k : Z,
                   let T : R := ((IZR k) * 2 * PI)%R in
                   t = ((PI / 2) + T)%R).
    admit.
    specialize (H3 t H1 H2). destruct H3.
    rewrite H3. rewrite CargNorm_period.
    rewrite CargNorm_range_unique; auto with R.
    assert (PI > 0); auto with R; ra.
  - assert (cos t < 0); ra.
    assert (sin t < 0); ra.
    replace (r * sin t / (r * cos t))%R with (sin t / cos t)%R; try field;ra.
    replace (sin t / cos t)%R with (tan t); auto with R.
    (* 可知，此时 t 在 [-π,π) + T 之间 *)
    assert (forall t, cos t < 0 -> sin t < 0 ->
                 exists k : Z,
                   let T : R := ((IZR k) * 2 * PI)%R in
                   (- PI + T < t < T)%R).
    admit.
    specialize (H3 t H1 H2). destruct H3. simpl in H3.
    (* 然而，这一段中，tan 的行为还要分另种情况 *)
    (* 先使用 tan x 的周期性 *)
    Abort.
  (* 也算展开太多，细节太繁琐了。利用 Carg 的性质也许简洁 *)

(** 例 1.2 *)
Goal Ctrigo_eq
  (C2Ctrigo (1 +i 1))
  (mkCtrigo (sqrt 2) (PI/4) (sqrt_pos 2)).
Proof.
  tacCarg. unfold CArgeq.
  assert (|1 +i 1| <> 0).
  { intro. cbv in H. apply sqrt_eq_0 in H; ra. }
  apply Reqb_neq in H. rewrite H. simpl. split.
  + cbv. f_equal. ring.
  + replace (1 / 1)%R with 1; ra. rewrite atan_1. f_equal.
Qed.

(** 例 1.3 *)
Goal Ctrigo_eq
  (C2Ctrigo ((-1) +i (-3)))
  (mkCtrigo (sqrt 10) (atan 3 - PI) (sqrt_pos 10)).
Proof.
  tacCarg. unfold CArgeq.
  assert (|(-1) +i (-3)| <> 0).
  { intro. cbv in H. apply sqrt_eq_0 in H; ra. }
  apply Reqb_neq in H. rewrite H. simpl. split.
  + cbv. f_equal. ring.
  + replace (-3 / -1)%R with 3; ra.
Qed.

(* 以上，这类题目证明还是很繁琐，因实数构造问题
 这个例子也看出了大量的自动化的需求，比如带有 sqrt, cos, sin 等的运算，
 比如 Rsqr 2 与 sqr 2 的问题（它们混在一起）。
 能将这个证明简化到几步完成，而且还比较通用，也是个不错的课题。 *)

(** 例1.4，已知一个复数的三角表示，求该复数的倒数的三角表示。
这里仅证明，因为实数在Coq中的复杂构造方式，所以手动计算的结果Coq不一定能自动给出 *)
(* Goal forall r t,
  let z := mkCtrigo r t in
  let z1 := Ctrigo2C z in
  let z2 := /z1 in
  let z3 := C2Ctrigo z2 in
    z1 <> 0 -> z3 = mkCtrigo (1/r) (-t).
Proof.
  intros. unfold z3,z2,z1.
  (* 方法一：最笨的方法是，直接展开，按照代数的方法一步步凑 *)
(*   cbn. unfold C2Ctrigo. f_equal. *)
  (* 方法二：按照书上的证明思路，利用数学推导和一些改写引理来做 *)
  rewrite Cinv_eq_conjDivNorm2; auto.
  Search (mkCtrigo).
   2:{ auto.
  let z2 :
    (1/z)   let r  z =  a := 0 in a > 0.
 *)

(* (** |z^n| = |z|^n *)
Lemma Cnorm_pow : forall z n, |z ^ n| = ((|z|) ^ n)%R.
Proof.
intros z n; induction n.
 simpl; apply Cnorm_C1.
 simpl; rewrite Cnorm_Cmult, IHn; reflexivity.
Qed. *)


Set Implicit Arguments.

Require Import Coq.Structures.OrdersEx.
Require Export MSetAux.

Module Type PACKAGE <: OrderedType.
  Parameter t: Set.

  Parameter eq: t -> t -> Prop.
  Parameter lt: t -> t -> Prop.

  Axiom eq_refl: forall x: t, eq x x.
  Axiom eq_sym: forall x y: t, eq x y -> eq y x.
  Axiom eq_trans: forall x y z: t, eq x y -> eq y z -> eq x z.
  Instance eq_equiv : Equivalence eq := Build_Equivalence eq eq_refl eq_sym eq_trans.

  Axiom lt_trans: forall x y z: t, lt x y -> lt y z -> lt x z.
  Axiom lt_not_eq: forall x y: t, lt x y -> ~ eq x y.
  Axiom lt_strorder: StrictOrder lt.
  Axiom lt_compat : Proper (eq==>eq==>iff) lt.

  Parameter compare: t -> t -> comparison.
  Parameter compare_spec : forall s s', CompSpec eq lt s s' (compare s s').

  Parameter eq_dec: forall x y, { eq x y } + { ~ eq x y }.
End PACKAGE.

Declare Module Package: PACKAGE.

Module Conflict := PairOrderedType Package Package.

Declare Module PackageSet : MSetInterface.Sets with Module E := Package.
Export PackageSet.
Declare Module ConflictSet : MSetInterface.Sets with Module E := Conflict.

Axiom conflicts_sym: forall (C: ConflictSet.t) (p q: Package.t),
  ConflictSet.In (p, q) C -> ConflictSet.In (q, p) C.

Axiom conflicts_irrefl: forall (C: ConflictSet.t) (p: Package.t),
  ~ ConflictSet.In (p, p) C.

Module Export PAux := MSetAux.Aux PackageSet.
Export Props.
Export Facts.
Module CAux := Aux ConflictSet.

(* Definition alternative := PackageSet.t. *)

Unset Implicit Arguments.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Categories.Category.Morphisms.
Require Import CommutativeDiagrams.Loader.
Local Open Scope morphism.

Lemma test_concat (C : PreCategory) (a b : C) (m1 m2 m3 : morphism C a b)
      (H12 : 1 o m1 = m2 o 1) (H32 : 1 o m3 o 1 = m2) : m1 = m3.
Proof. diagram solve. Defined.

Lemma test_context (C : PreCategory) (a b c d : C)
      (mab : morphism C a b) (mbc : morphism C b c) (mcd : morphism C c d)
      (mac : morphism C a c) (mad : morphism C a d)
      (Hac : mac o 1 o 1 o 1 = mbc o 1 o mab) (Had : mad o 1 = mcd o mac) :
  1 o mad o 1 = (mcd o 1) o (mbc o (1 o 1 o mab) o 1).
Proof. diagram solve. Defined.

Lemma test_mono (C : PreCategory) (a b c : C)
      (mono : morphism C b c) (m1 m2 : morphism C a b)
      (Hmono : IsMonomorphism mono) (H : mono o m1 = mono o m2) :
  m1 = m2.
Proof. diagram solve. Defined.

Lemma test_epi (C : PreCategory) (a b c : C)
      (epi : morphism C a b) (m1 m2 : morphism C b c)
      (Hepi : IsEpimorphism epi) (H : m1 o epi = m2 o epi) :
  m1 = m2.
Proof. diagram solve. Defined.

Lemma test_id_l (C : PreCategory) (a b c : C)
      (i1 : morphism C b c) (i2 : morphism C c b)
      (m : morphism C a b) (H : i2 o i1 = 1) :
  m = i2 o i1 o m.
Proof. diagram solve. Defined.

Lemma test_id_r (C : PreCategory) (a b c : C)
      (i1 : morphism C a b) (i2 : morphism C b a)
      (m : morphism C b c) (H : i1 o i2 = 1) :
  m = m o i1 o i2.
Proof. diagram solve. Defined.

Lemma test_id (C : PreCategory) (a b c d : C)
      (j1 : morphism C c d) (j2 : morphism C d c) (Hj : j2 o j1 = 1)
      (i1 : morphism C a b) (i2 : morphism C b a) (Hi : i1 o i2 = 1)
      (m : morphism C b c) : m = j2 o j1 o m o i1 o i2.
Proof. diagram solve 6. Defined.

Lemma test_basic_iso_r (C : PreCategory) (a b : C)
      (iso : morphism C a b) (Hiso : IsIsomorphism iso) :
  iso o iso^-1 = 1.
Proof. diagram solve 0. Defined.

Lemma test_basic_iso_l (C : PreCategory) (a b : C)
      (iso : morphism C a b) (Hiso : IsIsomorphism iso) :
  iso^-1 o iso = 1.
Proof. diagram solve 0. Defined.

Lemma test_iso (C : PreCategory) (a b c d : C)
      (iso1 : morphism C a b) (iso2 : morphism C c d)
      (m1 : morphism C a c) (m2 : morphism C b d)
      (Hiso1 : IsIsomorphism iso1) (Hiso2 : IsIsomorphism iso2)
      (H : iso2^-1 o m2 o iso1 = m1) : m2 o iso1 = iso2 o m1.
Proof. diagram solve. Defined.

Lemma test_norm (C : PreCategory) (a b c d : C)
      (iso1 : morphism C a b) (m : morphism C b c) (iso2 : morphism C c d)
      (H1 : IsIsomorphism iso1) (H2 : IsIsomorphism iso2) :
  (iso2^-1 o (iso2 o 1 o 1) o m) o (1 o (1 o iso1) o iso1^-1 o iso1) =
    m o iso1.
Proof. unshelve (diagram norm); reify. reflexivity. Defined.


Require Import Shared.
Require Import LibHeap.
Require Import LibTactics.
Require Import LibReflect.

Module Heap := LibHeap.HeapList.

Lemma write_preserves_indom : forall (X Y : Type) (h : Heap.heap X Y) k k0 v0,
  LibReflect.Comparable X -> Heap.indom h k -> Heap.indom (Heap.write h k0 v0) k
.
Proof.
  intros X Y h k k0 v0 H0 H.
  rewrite Heap.indom_equiv_binds.
  rewrite Heap.indom_equiv_binds in H.
  destruct H as (v&Hv).
  cases (LibReflect.decide (k=k0)). (* LibTactics.cases *)
    fold_bool. (* LibReflect.fold_bool *)
    rew_refl in Eq. (* LibReflect.rew_refl *)
    rewrite Eq.
    exists v0.
    apply Heap.binds_write_eq.

    fold_bool.
    rew_refl in Eq.
    exists v.
    generalize Eq.
    apply Heap.binds_write_neq.
    apply Hv.
Qed.

Lemma binds_write_inv_val_neq : forall X Y (h : Heap.heap X Y) k v k' v',
  Heap.binds (Heap.write h k' v') k v -> v <> v' ->
  Heap.binds h k v
.
Proof.
  intros X Y h k v k' v' IH v_neq_v'.
  apply Heap.binds_write_inv in IH.
  destruct IH as [H|H].
    destruct H as (H_keys,H_values).
    apply v_neq_v' in H_values.
    contradiction.

    destruct H as (H_keys,H_binds).
    apply H_binds.
Qed.


From mathcomp Require Import all_ssreflect seq.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import FinMap.finmap.
Require Import FinMap.ordtype.

Require Import MiniEMTST.OddsAndEnds.
Require Import MiniEMTST.AtomScopes.
Require Import MiniEMTST.Syntax.
Require Import MiniEMTST.Env.
Require Import MiniEMTST.OddsAndEnds.

(* syntax of types *)

(** expression sorts **)

Inductive sort : Set :=
  | boole (* boolean expression *)
  | unite (* unit types *)
.

Fixpoint eq_sort (s s' : sort) : bool :=
  match s, s' with
  | boole, boole => true
  | unite, unite => true
  | _, _ => false
  end.

Lemma eq_sortP : Equality.axiom eq_sort.
Proof.
  move=> x y.
  apply: (iffP idP)=>[|<-].
  by elim x ; elim y.
  by elim x.
Qed.

Canonical sort_eqMixin := EqMixin eq_sortP.
Canonical sort_eqType := Eval hnf in EqType sort sort_eqMixin.

(* process types *)

Inductive tp : Set :=
  | input : sort -> tp -> tp
  | output : sort -> tp -> tp
  | ended : tp
  | bottom : tp
.

Fixpoint dual (T : tp) : tp :=
  match T with
  | input s T => output s (dual T)
  | output s T => input s (dual T)
  | ended => ended
  | bottom => bottom
  end
.

Lemma dual_is_dual t : dual (dual t) = t.
  elim t=>// ; rewrite/dual ; move=>//; rewrite-/dual ;
    do ? (move=> s t0 =>->) ;
    do ? (move=> t0 R' t1 =>->) ;
    rewrite ?R' ;
   easy.
Qed.

Fixpoint eq_tp (T T': tp) : bool :=
  match T, T' with
  | input s T, input s' T' => eq_sort s s' && eq_tp T T'
  | output s T, output s' T' => eq_sort s s' && eq_tp T T'
  | ended, ended => true
  | bottom, bottom => true
  | _, _ => false
  end.

Lemma eq_imp_eq : forall x y, eq_tp x y -> x = y.
Proof.
  move=> x;
  elim x; try (by move=> y; elim y => //);
    move=> s t IH y;
    case: y => //;
    move=> s' t' /andP; fold eq_tp; move=> H; case: H;
    move=> H H0;
    assert (H1: s = s') by (apply/eq_sortP; auto);
    assert (H2: t = t') by ( apply/IH; auto);
    rewrite H1; rewrite H2; reflexivity.
Qed.

(*   apply tp_sort_mutind ; intros; try destruct y  ; try destruct s'; try easy ; *)
(*   inversion H1 ; apply Bool.andb_true_iff in H3 ; destruct H3 ; *)
(*   try(move:H3 ; move/H0=>H3 ; move:H2 ; move/H=>H4 ; by rewrite H3 H4). *)
(* Qed. (* more ssreflect can make this better *) *)

Lemma eq_tp_refl x : eq_tp x x.
Proof.
  elim x ;
    try
      move=>s t H ;
      rewrite/eq_tp=>// ;
      fold eq_tp ;
      rewrite H=>//= ;
      elim s=>//.
Qed.

Lemma eq_tpP : Equality.axiom eq_tp.
Proof.
  move=>x y.
  apply: (iffP idP)=>[|<-].
  apply eq_imp_eq.
  apply eq_tp_refl.
Qed.

Canonical tp_eqMixin := EqMixin eq_tpP.
Canonical tp_eqType := Eval hnf in EqType tp tp_eqMixin.

(* judgements *)

(* environments *)
Definition sort_env_entry := EV_atom_ordType.
Definition sort_env := @env sort_env_entry sort_eqType.

Inductive oft_exp (G : sort_env) : exp -> sort -> Prop :=
| t_tt : def G -> oft_exp G tt boole
| t_ff : def G -> oft_exp G ff boole
| t_unit : def G -> oft_exp G one unite
| t_var : forall x (S : sort),
    binds x S G ->
    oft_exp G (V (EV.Free x)) S
.

Definition tp_env_entry := CH_atom_ordType. (* TODO CLEANUP *)
Definition tp_env := @env tp_env_entry tp_eqType.

Definition completed (D : tp_env) : Prop :=
  def D /\ forall a, a \in dom D -> binds a ended D.

Definition chan_of_entry (c : tp_env_entry) : CH.var := c. (* TODO REMOVE *)

Lemma weaken_completed (D: tp_env):
  forall k T, (completed (add k T D)) -> completed D.
Proof.
  intros.
  unfold completed.
  split.
  {
    destruct H.
    inversion H.
    destruct D; auto.
  }
  {
    destruct H.
    intros.
    assert (a \in dom (add k T D) -> binds a ended (add k T D)).
    { exact (H0 a). }
    assert (a <> k).
    {
      unfold not.
      intros.
      unfold add in H.
      rewrite <- H3 in H.
      rewrite H1 in H.
      auto.
    }
    rewrite in_dom_add in H2.
    rewrite H in H2.
    rewrite H1 in H2.
    simpl in H2.
    move: H2; rewrite orbT=>/(_ is_true_true)-H4.
    apply binds_next in H4 ; auto.
    by apply/eqP.
  }
Qed.

(* compatible environments *)

(* lift dual to option *)
Definition option_dual (d : option tp) : option tp :=
  match d with
  | None => None
  | Some T => Some (dual T)
  end.

Inductive compatible : forall (E1 E2 : tp_env), Prop :=
| compatible_disj E1 E2: disjoint E1 E2 -> compatible E1 E2
| compatible_add E1 E2 k t:
    compatible E1 E2 ->
    compatible (add k t E1) (add k (dual t) E2)
.
Hint Constructors compatible.

Lemma compatible_nil_def : forall els, compatible nil (Def els).
Proof.
  intros.
  apply compatible_disj.
  apply disjoint_nil_def.
Qed.

Lemma compatible_nil : compatible nil nil.
Proof.
  apply compatible_nil_def.
Qed.

Lemma compatibleC E1 E2 : compatible E1 E2 -> compatible E2 E1.
  elim=>//.
  move=> E0 E3.
  rewrite disjointC.
  apply compatible_disj.
  move=> E0 E3 k t D. (* D1 D2. *)
  move/compatible_add.
  move=>H.
  have H':= H k (dual t).
  move:H'.
  by rewrite dual_is_dual.
Qed.

Definition compose (E1 E2 : tp_env) : tp_env :=
  if (E1, E2) is (Def f1, Def f2) then
    let: (f1, f12, f2) := spl f1 f2 in
    Def (fcat f1 (fcat (fmap_map (fun _ => bottom) f12) f2))
  else
    undef_env.

Notation "A 'o' B" := (compose A B) (at level 60, right associativity).  (* : env_scope. *)

Lemma compose_undef D:
  D o undef_env = undef_env.
Proof.
  elim D=>//.
Qed.

Lemma composeC D D': D o D' = D' o D.
Proof.
  elim D=>// ; elim D'=>// f f'.
  (* Disjointness *)
  have: all_disj (spl f f') by apply: disj_spl.
  move=>/andP-[/andP-[di dd] id].
  have dmi :
    disj (diff f' f) (fmap_map (fun _ : tp_eqType => bottom) (intersect f f'))
    by rewrite /disj supp_map -/(disj _ _) disjC.
  have mid :
    disj (fmap_map (fun _ : tp_eqType => bottom) (intersect f f')) (diff f f')
    by rewrite /disj supp_map -/(disj _ _) disjC.
  have dmid :
    disj (fcat (diff f' f)
               (fmap_map (fun _ : tp_eqType => bottom) (intersect f f')))
         (diff f f')
    by rewrite disjC disj_fcat dd Bool.andb_true_l /disj supp_map.
  have eq_supp :
    supp (intersect f' f) == supp (intersect f f')
    by rewrite (supp_intersect f' f).
  (* End disjointness *)
  rewrite /compose/spl.
  rewrite (fmap_const_eq bottom eq_supp).
    by rewrite -fcatA // fcatC // [fcat (diff f' f) _]fcatC.
Qed.

Lemma compose0 D: D o nil = D.
Proof.
  destruct D; auto.
  unfold compose.
  unfold spl.
  destruct nil eqn:H; try inversion H.
  rewrite intersect_nil.
  rewrite diff_nil_d.
  rewrite diff_d_nil.
  rewrite fcats0.
  assert (forall (V1 V2: eqType) (K: ordType),
  forall f: V1 -> V2,
  fmap_map (V1 := V1) (V2 := V2) (K := K) f (finmap.nil _ _) = (finmap.nil _ _)).
  {
    intros.
    rewrite <- supp_nilE.
    rewrite supp_map.
    rewrite supp_nil.
    reflexivity.
  }
  rewrite H0.
  rewrite fcats0.
  reflexivity.
Qed.

(*
Lemma composeAdd D1 D2 k T: (add k T D1) o D2 = (add k T (D1 o D2)).

This does *not* hold, typically if k ∈ D2, then (add k T D1) o D2 is defined,
with k ¬∈ ((add k T D1) o D2) (matching elements are removed), while
add k T (D1 o D2) = undef_env (adding an already existing key results in undef_env).
*)

(* some properties of compatible environments and of defined envirnments *)
Lemma compatible_hd k t t' E1 E2:
  def (add k t E1) -> def (add k t' E2) -> t == dual t'
  -> compatible E1 E2 -> compatible (add k t E1) (add k t' E2).
Proof.
  elim: E1; elim: E2 => // => f f0.
  move=>D1 D2.
  move/eqP=>R. rewrite R.
  move/compatible_add.
  move=>H.
  have H':= H k (dual t'). move:H'.
  by rewrite dual_is_dual.
Qed.

Lemma compatible_swap_left k k' s t E1 E2:
  def (add k t (add k' s E1)) -> def E2 -> (* we may not need/want these*)
  compatible (add k t (add k' s E1)) E2 ->
  compatible (add k' s (add k t E1)) E2.
Proof. by rewrite add_swap. Qed.

(* typing judgment *)

Inductive oft : sort_env -> proc -> tp_env -> Prop :=
| t_send : forall G kt e P D S T,
    oft_exp G e S ->
    oft G P (add kt T D) ->
    oft G (send (chan_of_entry kt) e P) (add kt (output S T) D)

| t_receive : forall (L : seq EV.atom) G kt P D S T,
    (forall x, x \notin L ->
          oft (add x S G) (open_e0 P (V (EV.Free x))) (add kt T D)) -> (* the V should be a coercion *)
    oft G (receive (chan_of_entry kt) P) (add kt (input S T) D)

| t_ife : forall G e P Q D,
    oft_exp G e boole ->
    oft G P D ->
    oft G Q D ->
    oft G (ife e P Q) D

| t_par : forall G P Q D1 D2,
    oft G P D1 ->
    oft G Q D2 ->
    (* def (D1 \:/ D2) -> *)
    compatible D1 D2 ->
    oft G (par P Q) (D1 o D2)

| t_inact : forall G D,
    completed D ->
    def G -> (* we need this to be able to argue that well typed derivations have def G *)
    oft G inact D

| t_nu G P D T (L: seq CH.atom):
    (forall ki,
        ki \notin L ->
        oft G (open_k0 P ki) (add ki T (add ki (dual T)  D))) ->
        (* oft G (open_k0 P ki) (add (ke ki) T (add (ke ki) (dual T)  D))) -> *)
    oft G (nu P) D

(* this is the case when ki is not used, because we don't add it to
    the typing, however we still need to "open" the term,
    because morally it contains a binder. If one where to
    apply t_nu_ch when t_nu_ch' is needed the derivation would
    get stuck because ki is not on the typing.
*)
| t_nu' G P D :
    oft G P D ->
    oft G (nu P) D

| t_bang G P D:
    completed D -> oft G P nil -> oft G (bang P) D
.

(*****************************)

Derive Inversion oft_inv with (forall G P D, oft G P D) Sort Prop.
Derive Inversion oft_inv_par with (forall G P Q D, oft G (par P Q) D) Sort Prop.

Lemma oft_par_inv G P Q D :
  oft G (par P Q) D -> exists D1 D2,
    compatible D1 D2 /\ (* def (D1 o D2) /\ *) (D1 o D2 = D) /\ oft G P D1 /\ oft G Q D2.
Proof.
  elim/oft_inv_par => _ G0 P1 Q0 D1 D2 oftP oftQ Hdef _ _ _ _.
  by exists D1, D2.
Qed.

Lemma oft_send_inv c e P D G :
  oft G (send c e P) D ->
  exists k S T D',
    chan_of_entry k = c /\
    D = add k (output S T) D' /\
    oft_exp G e S /\ oft G P (add k T D').
Proof.
  elim/oft_inv => // _ G0 k' e0 P1 D0 S0 T0 Oe O _ [] Eq<-<-_.
  by exists k', S0, T0, D0; split.
Qed.

(* Lemma oft_receive_inv c P D G : *)
(*   oft G (receive c P) D -> *)
(*   exists k S T D', *)
(*     chan_of_entry k = c /\ *)
(*     D = add k (input S T) D' *)
(*     /\ exists L : seq EV.atom, *)
(*       (forall (x : EV.atom), x \notin L -> *)
(*        oft (add (inr x) S G) (open_e0 P (EV.Free x)) (add k T D')). *)
(* Proof. *)
(*   elim /oft_inv => // _ L G0 k0 P1 D0 S0 T0 O _ [] Eq<-_. *)
(*   exists k0,S0,T0,D0;do ! split =>//. *)
(*   by exists L. *)
(* Qed. *)

Lemma oft_ife_inv G e P Q D :
  oft G (ife e P Q) D ->
  oft G P D /\ oft G Q D.
Proof.
  by elim/oft_inv => // _ G0 e' P1 Q0 D0 _ Hoft1 Hoft2 _ {G0} [] _ <- <-.
Qed.

Lemma oft_exp_lc G E S:
  oft_exp G E S -> lc_exp E.
Proof.
  elim ; try by [].
Qed.

Lemma oft_lc G P D:
  oft G P D -> lc P.
Proof.
  elim; try by [];
  intros.
  {
    by apply: lc_send => //;
    apply oft_exp_lc with (G := G0) (S := S).
  }{
    by apply lc_receive with (L := L).
  }{
    by apply: lc_ife => //;
    apply oft_exp_lc with (G := G0) (S := boole).
  }{
    by apply lc_par.
  }{
    by apply lc_nu with (L := L).
  }{
    by apply: (lc_nu (L:=[::]))=> k k_ninL //; rewrite /open_k0 -opk_lc.
  }{
    by apply: lc_bang.
  }
Qed.

Lemma oft_def G P D:
  oft G P D -> def D.
Proof.
Admitted.

Lemma oft_def_ctx G P D:
  oft G P D -> def G.
Proof.
Admitted.

Lemma oft_exp_def_ctx G E S:
  oft_exp G E S -> def G.
Proof.
  elim ; try by [].
  move=> x S'.
  by apply: binds_def.
Qed.

(* Meta-theory *)

Lemma subst_ch_same c c' : s[ c ~> c ]c c' = c'.
Proof.
  by case: c'=>// ; rewrite /subst_ch=> a ; case: ifP =>// /eqP->.
Qed.

Lemma subst_chan_same c P : s[c ~> c]p P = P.
Admitted.

Lemma subst_exp_proc_open_exp x y e P:
  x != y ->
  lc_exp e ->
  (s[ x ~> e ]pe open_e0 P y) = (open_e0 (s[ x ~> e ]pe P) y).
Proof.
Admitted.

Lemma subst_exp_ope x y n e :
  x \notin fv_exp e ->
  s[ x ~> y ]e open_exp n x e = open_exp n y e.
Proof.
  case: e =>// [][a|m _] /=//; last by case: ifP => ///=; rewrite eq_refl.
  by rewrite in_cons negb_or=>/andP-[/negPf->].
Qed.

Lemma subst_exp_open_e x y P :
  x \notin fev_proc P ->
  s[ x ~> y ]pe open_e0 P x = open_e0 P y.
Admitted.

Lemma subst_chan_openk_var x u n k ch :
  CH.lc u -> s[ x ~> u ]c opk n k ch = opk n k (s[ x ~> u ]c ch).
Proof.
Admitted.

Lemma subst_proc_openk_var x k u P:
  (* x != y -> *) CH.lc u ->
  (s[ x ~> u ]p open_k0 P k) = (open_k0 (s[ x ~> u ]p P) k).
Admitted.

Lemma subst_exp_openk_var x k e P:
  (* x != y -> *) lc_exp e ->
  (s[ x ~> e ]pe open_k0 P k) = (open_k0 (s[ x ~> e ]pe P) k).
Admitted.

Lemma subst_proc_open_e x k u P:
  (s[ x ~> u ]p open_e0 P k) = (open_e0 (s[ x ~> u ]p P) k).
Admitted.

(* Some weakening lemmas *)
Lemma wkn_ctx_oft_exp G E x S S':
  oft_exp G E S -> def (add x S' G) -> oft_exp (add x S' G) E S.
Proof.
  elim ; intros ; constructor ; try assumption.
  apply: binds_add.
  by apply: H.
  apply: def_diff_value.
  by apply H0.
Qed.

Lemma wkn_ctx_oft G P D y S:
  oft G P D -> def (add y S G) -> oft (add y S G) P D.
Proof.
Admitted.

Lemma TypeUniquenessExp G e S S':
  oft_exp G e S -> oft_exp G e S' -> S = S'.
Proof.
  elim=>Hdef H ;  try by inversion H.
  intros.
  inversion H1.
  apply: UniquenessBind ; [ apply: H0 | apply: H3].
Qed.

(* this is somewhat sloppy as in we weaken G to still have x after the
  elim Hp ; introssubstitution *)
Lemma SubstitutionLemmaExp G x S S' e e':
  binds x S' G ->
  oft_exp G e' S' ->
  oft_exp G e S -> oft_exp G (s[ x ~> e']e e) S.
Proof.
  move=>Hbind Hde' Hde.
  move:Hde'.
  elim Hde ; try constructor ; try assumption.
  intros.
  case: (EV.eq_reflect x x0).
  move=>Sub.
  subst.
  simpl.
  rewrite eq_refl.
  have Heq : S' = S0 by apply: UniquenessBind ; [apply: Hbind | apply: H].
  rewrite-Heq.
  assumption.

  case/eqP=>Hdiff=>//=.
  rewrite ifN_eq ; try assumption.
  by constructor.
Qed.

Theorem ExpressionReplacement G P x E S D:
  binds x S G ->
  oft_exp G E S ->
  oft G P D ->
  oft G (s[ x ~> E]pe P) D.
Proof.
Admitted.

Ltac split_notin i H1 H2:=
  move: i; erewrite mem_cat; rewrite negb_or => /andP-[H1 H2].

Ltac inst_notin_cat i :=
  let H1 := fresh i in
  let H2 := fresh i in
  split_notin i H1 H2;
  first [ move: H1 => _; apply: H2; move: H2 => _
        | move: H2 => _; inst_notin_cat H1
        ].

Ltac inst_notin i :=
  first [ apply: i; move: i => _
        | let H1 := fresh i in
          let H2 := fresh i in
          split_notin i H1 H2;
          move: H2 => _;
          inst_notin H1 ].

Lemma subst_nm_oft_exp a a' G e S :
  def (subst_env a a' G) ->
  oft_exp G e S ->
  oft_exp (subst_env a a' G) e S.
Proof.
Admitted.

Lemma completed_means_completed D k T:
  completed D -> look k D = Some T -> T != ended -> False.
  move=>Hcomp Hlook/eqP.
  case Hcomp =>Hfoo Hended.
  move:(look_some_in Hlook)=>/(Hended k).
  rewrite/binds Hlook=>/eqP.
  by case=>->;case.
Qed.

Lemma Weakening G P D1 D2 :
  oft G P D2 -> compatible D1 D2 -> completed D1 -> oft G P (D1 o D2).
Admitted.

(*************************************************************)

Definition subst_k_env k k' (D : tp_env) := subst_env k k' D. (* TODO remove the _env *)

Definition subst_entryk k k' (x : tp_env_entry) := if x == k then k' else x.

Ltac simpl_def :=
  do ! match goal with
       | [ |- context[?k == ?k] ] => rewrite !eq_refl
       | [ |- context[~~ (_ && _)] ] => rewrite !negb_and
       | [ |- context[~~ (_ || _)] ] => rewrite !negb_or
       | [ |- context[~~ (~~ _)] ] => rewrite !negbK
       | [ |- context[_ && false] ] => rewrite !Bool.andb_false_r
       | [ |- context[_ && true ] ] => rewrite !Bool.andb_true_r
       | [ |- context[_ || false] ] => rewrite !Bool.orb_false_r
       | [ |- context[_ || true ] ] => rewrite !Bool.orb_true_r
       end=>/=.

Lemma ChannelReplacement G P c c' D :
  oft G P D ->
  def (subst_env c c' D) ->
  oft G (s[ c ~> chan_of_entry c' ]p P) (subst_env c c' D).
Proof.
  case: (boolP (c' == c)) =>[/eqP->/=|c_neq_c'];
     first by move=> Hd Ho; rewrite subst_chan_same subst_envK.
  elim.
  { (* t_send *)
    move=> G0 kt e P0 D0 S T Oe Op IH Hdef.
    move: (def_addG (oft_def Op)) => def_kt_D0.
    rewrite -subst_addC /= /subst_ch; last by apply: def_kt_D0.
    rewrite -fun_if. apply: t_send =>//.
    rewrite subst_addC; last by apply: def_kt_D0.
    apply: IH; move: Hdef; rewrite !def_subst_dom //.
    by rewrite !in_dom_rem // (dom_diff_eq _ _ T).
  }
  { (* t_receive *)
    move=> L G0 kt P0 D0 S T Op IH Hdef.
    move: (def_addG (oft_def (Op (EV.fresh L) (EV.fresh_not_in L)))) => def_kt_D0.
    rewrite -subst_addC /= /subst_ch; last by apply: def_kt_D0.
    rewrite -fun_if; apply: (t_receive (L:=L))=>//.
    rewrite subst_addC; last by apply: def_kt_D0.
    move=>x x_notin; rewrite -subst_proc_open_e.
    apply: (IH x x_notin); move: Hdef; rewrite !def_subst_dom //.
    by rewrite !in_dom_rem // (dom_diff_eq _ _ T).
  }
  { (* t_ife *)
    move=> G0 e P0 Q D0 Oe O_P IHp O_Q IHq Hdef/=.
    by apply: t_ife => //; [apply: IHp|apply: IHq].
  }
  { (* t_par *)
    admit.
  }
  { (* t_inact *)
  + move=> G0 D0 C0 Df Hdef; apply: t_inact =>//.
    move: C0; rewrite /completed => [][DD0 Bnd]; split=>// x H.
    move: Bnd; rewrite /binds=> Bnd.
    rewrite look_subst //.
    move: H=>/in_dom_subst-/orP-[/andP-[cD0 /orP-[xc'|]]|] //.
    - by rewrite xc' cD0; apply: Bnd.
    - rewrite cD0; move=>/andP[/negPf->].
      case: D0 DD0 Bnd cD0 Hdef => // f _ ; rewrite /rem/dom => Bnd cD0 _.
      rewrite supp_rem !inE /look fnd_rem -/(look _ (Def f))=> /andP-[/negPf->].
      by apply: Bnd.
    - by move=>/andP-[/negPf->]; apply: Bnd.
  }
  { (* t_nu *)
    admit.
  }
  { (* t_nu' *)
    move=> G0 P0 D0 Hoft IH Hdef/=; move: (IH Hdef) => Hoft'.
    by apply: t_nu'.
  }
  { (* t_bang *)
  + move=> G0 P0 D0 C0 Df IH Hdef ; apply: t_bang =>//.
    move: C0; rewrite /completed => [][DD0 Bnd]; split=>// x H.
    move: Bnd; rewrite /binds=> Bnd.
    rewrite look_subst //.
    move: H=>/in_dom_subst-/orP-[/andP-[cD0 /orP-[xc'|]]|] //.
    - by rewrite xc' cD0; apply: Bnd.
    -
      rewrite cD0; move=>/andP[/negPf->].
      case: D0 Df DD0 Bnd cD0 IH Hdef => // f _ ; rewrite /rem/dom => Bnd cD0 _.
      rewrite supp_rem !inE /look fnd_rem -/(look _ (Def f))=>//.
      move=> _ _ /andP -[/negPf->] => HH.
      by rewrite cD0.
    - by move=>/andP-[/negPf->]; apply: Bnd.
    - by apply IH.
  }
(* Qed. *)
Admitted.