Require Export Db.Spec.

(** ** Simply typed terms. *)
Inductive Ty : Set :=
  | tarr (τ₁ τ₂: Ty)
  | tunit
  | tbool
  | tprod (τ₁ τ₂: Ty)
  | tsum (τ₁ τ₂: Ty).

Notation "A ⊎ B" := (tsum A B) (at level 85, right associativity).
Notation "A × B" := (tprod A B) (at level 85, right associativity).
Notation "A ⇒ B" := (tarr A B) (at level 85, right associativity).

(** ** Typing environments. *)

Inductive Env : Set :=
  | empty
  | evar (Γ : Env) (τ : Ty).

Fixpoint dom (Γ: Env) : Dom :=
  match Γ with
    | empty    => O
    | evar Γ τ => S (dom Γ)
  end.
Notation "Γ ▻ T" := (evar Γ T) (at level 55, left associativity).

Reserved Notation "Γ₁ ▻▻ Γ₂" (at level 55, left associativity).
Fixpoint ecat (Γ₁ Γ₂ : Env) {struct Γ₂} : Env :=
  match Γ₂ with
    | empty  => Γ₁
    | Γ₂ ▻ τ => (Γ₁ ▻▻ Γ₂) ▻ τ
  end
where "Γ₁ ▻▻ Γ₂" := (ecat Γ₁ Γ₂).

Inductive Tm : Set :=
  | var (i: Ix)
  | abs (τ: Ty) (t: Tm)
  | app (t₁ t₂: Tm)
  | unit
  | true
  | false
  | ite (t₁ t₂ t₃: Tm)
  | pair (t₁ t₂: Tm)
  | proj₁ (t: Tm)
  | proj₂ (t: Tm)
  | inl (t: Tm)
  | inr (t: Tm)
  | caseof (t₁ t₂ t₃: Tm)
  | seq (t₁ t₂: Tm)
  | fixt (τ₁ τ₂: Ty) (t: Tm).

Definition Om (τ : Ty) : Tm :=
  app (fixt tunit τ (abs (tarr tunit τ) (var 0))) unit.

Section WellScoping.

  (* Keep this in a section so that the notation for the ws type-class is only
     locally overwritten. *)
  Inductive wsTm (γ: Dom) : Tm → Prop :=
    | WsVar {i}           : γ ∋ i → ⟨ γ ⊢ var i ⟩
    | WsAbs {τ t}         : ⟨ S γ ⊢ t ⟩ → ⟨ γ ⊢ abs τ t ⟩
    | WsApp {t₁ t₂}       : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ app t₁ t₂ ⟩
    | WsUnit              : ⟨ γ ⊢ unit ⟩
    | WsTrue              : ⟨ γ ⊢ true ⟩
    | WsFalse             : ⟨ γ ⊢ false ⟩
    | WsIte {t₁ t₂ t₃}    : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ →
                            ⟨ γ ⊢ t₃ ⟩ → ⟨ γ ⊢ ite t₁ t₂ t₃ ⟩
    | WsProj1 {t}         : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ proj₁ t ⟩
    | WsProj2 {t}         : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ proj₂ t ⟩
    | WsPair {t₁ t₂}      : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ pair t₁ t₂ ⟩
    | WsInj₁ {t}          : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ inl t ⟩
    | WsInj₂ {t}          : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ inr t ⟩
    | WsCaseof {t₁ t₂ t₃} : ⟨ γ ⊢ t₁ ⟩ → ⟨ S γ ⊢ t₂ ⟩ →
                            ⟨ S γ ⊢ t₃ ⟩ → ⟨ γ ⊢ caseof t₁ t₂ t₃ ⟩
    | WsSeq {t₁ t₂}       : ⟨ γ ⊢ t₁ ⟩ → ⟨ γ ⊢ t₂ ⟩ → ⟨ γ ⊢ seq t₁ t₂ ⟩
    | WsFixt {τ₁ τ₂ t}    : ⟨ γ ⊢ t ⟩ → ⟨ γ ⊢ fixt τ₁ τ₂ t ⟩
  where "⟨ γ ⊢ t ⟩" := (wsTm γ t).

End WellScoping.
#[export]
Instance WsTm : Ws Tm := wsTm.

(** ** Program contexts *)

Inductive PCtx : Set :=
  | phole
  | pabs (T: Ty) (C: PCtx)
  | papp₁ (C: PCtx) (t: Tm)
  | papp₂ (t: Tm) (C: PCtx)
  | pite₁ (C: PCtx) (t₂ t₃: Tm)
  | pite₂ (t₁: Tm) (C: PCtx) (t₃: Tm)
  | pite₃ (t₁ t₂: Tm) (C: PCtx)
  | ppair₁ (C: PCtx) (t: Tm)
  | ppair₂ (t: Tm) (C: PCtx)
  | pproj₁ (C: PCtx)
  | pproj₂ (C: PCtx)
  | pinl (C: PCtx)
  | pinr (C: PCtx)
  | pcaseof₁ (C: PCtx) (t₂ t₃: Tm)
  | pcaseof₂ (t₁: Tm) (C: PCtx) (t₃: Tm)
  | pcaseof₃ (t₁ t₂: Tm) (C: PCtx)
  | pseq₁ (C: PCtx) (t: Tm)
  | pseq₂ (t: Tm) (C: PCtx)
  | pfixt (τ₁ τ₂: Ty) (C: PCtx).

Fixpoint pctx_app (t₀: Tm) (C: PCtx) {struct C} : Tm :=
  match C with
    | phole            => t₀
    | pabs T C         => abs T (pctx_app t₀ C)
    | papp₁ C t        => app (pctx_app t₀ C) t
    | papp₂ t C        => app t (pctx_app t₀ C)
    | pite₁ C t₂ t₃    => ite (pctx_app t₀ C) t₂ t₃
    | pite₂ t₁ C t₃    => ite t₁ (pctx_app t₀ C) t₃
    | pite₃ t₁ t₂ C    => ite t₁ t₂ (pctx_app t₀ C)
    | ppair₁ C t       => pair (pctx_app t₀ C) t
    | ppair₂ t C       => pair t (pctx_app t₀ C)
    | pproj₁ C         => proj₁ (pctx_app t₀ C)
    | pproj₂ C         => proj₂ (pctx_app t₀ C)
    | pinl C           => inl (pctx_app t₀ C)
    | pinr C           => inr (pctx_app t₀ C)
    | pcaseof₁ C t₁ t₂ => caseof (pctx_app t₀ C) t₁ t₂
    | pcaseof₂ t₁ C t₂ => caseof t₁ (pctx_app t₀ C) t₂
    | pcaseof₃ t₁ t₂ C => caseof t₁ t₂ (pctx_app t₀ C)
    | pseq₁ C t        => seq (pctx_app t₀ C) t
    | pseq₂ t C        => seq t (pctx_app t₀ C)
    | pfixt τ₁ τ₂ C    => fixt τ₁ τ₂ (pctx_app t₀ C)
  end.

Fixpoint pctx_cat (C₀ C: PCtx) {struct C} : PCtx :=
  match C with
    | phole            => C₀
    | pabs T C         => pabs T (pctx_cat C₀ C)
    | papp₁ C t        => papp₁ (pctx_cat C₀ C) t
    | papp₂ t C        => papp₂ t (pctx_cat C₀ C)
    | pite₁ C t₂ t₃    => pite₁ (pctx_cat C₀ C) t₂ t₃
    | pite₂ t₁ C t₃    => pite₂ t₁ (pctx_cat C₀ C) t₃
    | pite₃ t₁ t₂ C    => pite₃ t₁ t₂ (pctx_cat C₀ C)
    | ppair₁ C t       => ppair₁ (pctx_cat C₀ C) t
    | ppair₂ t C       => ppair₂ t (pctx_cat C₀ C)
    | pproj₁ C         => pproj₁ (pctx_cat C₀ C)
    | pproj₂ C         => pproj₂ (pctx_cat C₀ C)
    | pinl C           => pinl (pctx_cat C₀ C)
    | pinr C           => pinr (pctx_cat C₀ C)
    | pcaseof₁ C t₁ t₂ => pcaseof₁ (pctx_cat C₀ C) t₁ t₂
    | pcaseof₂ t₁ C t₂ => pcaseof₂ t₁ (pctx_cat C₀ C) t₂
    | pcaseof₃ t₁ t₂ C => pcaseof₃ t₁ t₂ (pctx_cat C₀ C)
    | pseq₁ C t        => pseq₁ (pctx_cat C₀ C) t
    | pseq₂ t C        => pseq₂ t (pctx_cat C₀ C)
    | pfixt τ₁ τ₂ C    => pfixt τ₁ τ₂ (pctx_cat C₀ C)
  end.

Section Application.

  Context {Y: Type}.
  Context {vrY: Vr Y}.
  Context {wkY: Wk Y}.
  Context {vrTm: Vr Tm}.
  Context {liftYTm: Lift Y Tm}.

  Fixpoint apTm (ζ: Sub Y) (t: Tm) {struct t} : Tm :=
    match t with
      | var x           => lift (ζ x)
      | abs T t₂        => abs T (apTm (ζ↑) t₂)
      | app t₁ t₂       => app (apTm ζ t₁) (apTm ζ t₂)
      | unit            => unit
      | true            => true
      | false           => false
      | ite t₁ t₂ t₃    => ite (apTm ζ t₁) (apTm ζ t₂) (apTm ζ t₃)
      | pair t₁ t₂      => pair (apTm ζ t₁) (apTm ζ t₂)
      | proj₁ t         => proj₁ (apTm ζ t)
      | proj₂ t         => proj₂ (apTm ζ t)
      | inl t           => inl (apTm ζ t)
      | inr t           => inr (apTm ζ t)
      | caseof t₁ t₂ t₃ => caseof (apTm ζ t₁) (apTm (ζ↑) t₂) (apTm (ζ↑) t₃)
      | seq t₁ t₂       => seq (apTm ζ t₁) (apTm ζ t₂)
      | fixt τ₁ τ₂ t    => fixt τ₁ τ₂ (apTm ζ t)
    end.

  Global Arguments apTm ζ !t.

End Application.

Ltac crushStlcSyntaxMatchH :=
  match goal with
    | [ H: S _ = S _             |- _ ] => apply eq_add_S in H
    | [ H: tarr _ _  = tarr _ _  |- _ ] => inversion H; clear H
    | [ H: tprod _ _ = tprod _ _ |- _ ] => inversion H; clear H
    | [ H: tsum _ _  = tsum _ _  |- _ ] => inversion H; clear H

    | [ H: var _        = var _        |- _ ] => inversion H; clear H
    | [ H: abs _ _      = abs _ _      |- _ ] => inversion H; clear H
    | [ H: app _ _      = app _ _      |- _ ] => inversion H; clear H
    | [ H: pair _ _     = pair _ _     |- _ ] => inversion H; clear H
    | [ H: ite _ _ _    = ite _ _ _    |- _ ] => inversion H; clear H
    | [ H: proj₁ _      = proj₁ _      |- _ ] => inversion H; clear H
    | [ H: proj₂ _      = proj₂ _      |- _ ] => inversion H; clear H
    | [ H: inl _        = inl _        |- _ ] => inversion H; clear H
    | [ H: inr _        = inr _        |- _ ] => inversion H; clear H
    | [ H: caseof _ _ _ = caseof _ _ _ |- _ ] => inversion H; clear H
    | [ H: seq _ _      = seq _ _      |- _ ] => inversion H; clear H
    | [ H: fixt _ _ _   = fixt _ _ _   |- _ ] => inversion H; clear H

    | [ H: inl _       = inr _         |- _ ] => inversion H
    | [ H: inr _       = inl _         |- _ ] => inversion H

    | [ H: unit        = abs _ _       |- _ ] => inversion H
    | [ H: true        = abs _ _       |- _ ] => inversion H
    | [ H: false       = abs _ _       |- _ ] => inversion H
    | [ H: pair _ _    = abs _ _       |- _ ] => inversion H
    | [ H: inl _       = abs _ _       |- _ ] => inversion H
    | [ H: inr _       = abs _ _       |- _ ] => inversion H

    | [ |- S _          = S _          ] => f_equal
    | [ |- var _        = var _        ] => f_equal
    | [ |- abs _ _      = abs _ _      ] => f_equal
    | [ |- app _ _      = app _ _      ] => f_equal
    | [ |- unit         = unit         ] => reflexivity
    | [ |- true         = true         ] => reflexivity
    | [ |- false        = false        ] => reflexivity
    | [ |- ite _ _ _    = ite _ _ _    ] => f_equal
    | [ |- pair _ _     = pair _ _     ] => f_equal
    | [ |- proj₁ _      = proj₁ _      ] => f_equal
    | [ |- proj₂ _      = proj₂ _      ] => f_equal
    | [ |- inl _        = inl _        ] => f_equal
    | [ |- inr _        = inr _        ] => f_equal
    | [ |- caseof _ _ _ = caseof _ _ _ ] => f_equal
    | [ |- seq _ _      = seq _ _      ] => f_equal
    | [ |- fixt _ _ _   = fixt _ _ _   ] => f_equal
    | [ |- _ ▻ _        = _ ▻ _        ] => f_equal
    | [ |- context[apTm ?ξ ?t] ] =>
      change (apTm ξ t) with t[ξ]
  end.


(* The eliminator J *)
Definition J_T (A : Type) (x y :A) (p : x = y) (P : forall (x y :A), x = y -> Type) (c : forall (x : A), P x x eq_refl) : P x y p :=
  match p with
  | eq_refl => c x
  end.

Definition J_P (A : Type) (x y :A) (p : x = y) (P : forall (x y :A), x = y -> Prop) (c : forall (x : A), P x x eq_refl) : P x y p :=
  match p with
  | eq_refl => c x
  end.

(* Function Extensionality *)
Definition fun_ext := forall (A B : Type) (f g : A -> B) (x : A), f x = g x -> f = g.

Fixpoint eq_trans {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z.
  induction p. assumption.
Defined.
Notation "p ° q" := (eq_trans p q) (at level 60).

(* eq_trans is defined recursively on the left path *)
Lemma eq_trans_refl_l : forall (A : Type) (x y : A)(p : x = y), eq_refl ° p = p.
Proof.
  intros. simpl. reflexivity.
Qed.

Lemma eq_trans_refl_r : forall (A : Type) (x y : A)(p : x = y), p ° eq_refl = p.
Proof.
  intros. subst. simpl. reflexivity.
Qed.

Definition eq_symm {A : Type} {x y : A} (p : x = y) : y = x.
  induction p. reflexivity.
Defined.

Lemma eq_symm_refl : forall (A : Type) (x : A), eq_symm (@eq_refl _ x)  = @eq_refl _ x.
Proof. intros. simpl. reflexivity. Qed.

Lemma eq_symm_involutive : forall (A : Type) (x y : A)(p : x = y), eq_symm (eq_symm p) = p.
Proof.
  intros. apply J_T with (A := A) (x := x) (y := y)(p := p).
  intros. simpl. reflexivity.
Qed.

(* 2: Preliminaries *)
Definition hProp (A : Type) : Prop := forall (x y : A), x = y.
Definition hSet (A : Type) : Prop := forall (x y : A), hProp (x = y).

Lemma hProp_is_hProp : forall (A : Type), hProp (hProp A).
Proof.
  admit.
Admitted.

Lemma hSet_is_hProp : forall (A : Type), hProp (hSet A).
Proof.
  admit.
Admitted.

Definition decidable (A : Type) : Type := A + (A -> False).

Definition discrete (A : Type) : Type := forall (x y : A), decidable (x = y).

Definition constant {A  B : Type}(f : A -> B) : Type :=  forall (x y : A), f x = f y.

Definition collapsible (A : Type) : Type := {f : A -> A & constant f}.

Definition path_collapsible (A : Type) : Type := forall (x y : A), collapsible (x = y).

(* 3 Hedberg's Theorem *)

Lemma hedberg_lemma_1 : forall (A : Type), discrete A -> path_collapsible A.
Proof.
  intros A H_discrete.
  unfold path_collapsible. intros x y.
  pose proof (H_discrete x y) as H_x_y_dec. unfold decidable in H_x_y_dec.
  destruct H_x_y_dec.
  - unfold collapsible.
    exists (fun p => e).
    unfold constant. intros. reflexivity.
  - unfold collapsible.
    exists (fun p => False_rect _ (f p)).
    unfold constant. intros. induction (f x0).
Qed.

Lemma hedberg_lemma_2 : forall (A : Type), path_collapsible A -> hSet A.
Proof.
  intros A H_path_collapsible.
  unfold path_collapsible in *. unfold collapsible in *.
  unfold hSet. unfold hProp.
  intros x y p q.
  assert (H :forall p,  p = ((projT1 (H_path_collapsible x y))p) ° (eq_symm ((projT1 (H_path_collapsible y y)) eq_refl))).
  - intro r. destruct r.
    generalize (projT1 (H_path_collapsible x x) eq_refl).
    intros. pose proof (J_P A x x e).
    apply H with (P := fun x y p => eq_refl = p ° eq_symm p). simpl. reflexivity.
  - rewrite (H p). rewrite (H q).
    pose proof (projT2 (H_path_collapsible x y)). unfold constant in X.
    specialize (X p q). unfold constant. repeat rewrite X. reflexivity.
Qed.

Theorem hedberg : forall (A : Type), discrete A -> hSet A.
Proof.
  intros.
  apply hedberg_lemma_2.
  apply hedberg_lemma_1.
  assumption.
Qed.

Print Assumptions hedberg.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(****************************************************************************)
(*                                                                          *)
(*                         Naive Set Theory in Coq                          *)
(*                                                                          *)
(*                     INRIA                        INRIA                   *)
(*              Rocquencourt                        Sophia-Antipolis        *)
(*                                                                          *)
(*                                 Coq V6.1                                 *)
(*									    *)
(*			         Gilles Kahn 				    *)
(*				 Gerard Huet				    *)
(*									    *)
(*									    *)
(*                                                                          *)
(* Acknowledgments: This work was started in July 1993 by F. Prost. Thanks  *)
(* to the Newton Institute for providing an exceptional work environment    *)
(* in Summer 1995. Several developments by E. Ledinot were an inspiration.  *)
(****************************************************************************)

Require Export Ensembles.
Require Export Relations_1.
Require Export Relations_1_facts.
Require Export Partial_Order.
Require Export Cpo.

Section The_power_set_partial_order.
Variable U : Type.

Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) :=
    Definition_of_Power_set :
      forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X.
Hint Resolve Definition_of_Power_set.

Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X.
intro X; red in |- *.
intros x H'; elim H'.
Qed.
Hint Resolve Empty_set_minimal.

Theorem Power_set_Inhabited :
 forall X:Ensemble U, Inhabited (Ensemble U) (Power_set X).
intro X.
apply Inhabited_intro with (Empty_set U); auto with sets.
Qed.
Hint Resolve Power_set_Inhabited.

Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U).
auto 6 with sets.
Qed.
Hint Resolve Inclusion_is_an_order.

Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U).
elim Inclusion_is_an_order; auto with sets.
Qed.
Hint Resolve Inclusion_is_transitive.

Definition Power_set_PO : Ensemble U -> PO (Ensemble U).
intro A; try assumption.
apply Definition_of_PO with (Power_set A) (Included U); auto with sets.
Defined.
Hint Unfold Power_set_PO.

Theorem Strict_Rel_is_Strict_Included :
 same_relation (Ensemble U) (Strict_Included U)
   (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))).
auto with sets.
Qed.
Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included.

Lemma Strict_inclusion_is_transitive_with_inclusion :
 forall x y z:Ensemble U,
   Strict_Included U x y -> Included U y z -> Strict_Included U x z.
intros x y z H' H'0; try assumption.
elim Strict_Rel_is_Strict_Included.
unfold contains in |- *.
intros H'1 H'2; try assumption.
apply H'1.
apply Strict_Rel_Transitive_with_Rel with (y := y); auto with sets.
Qed.

Lemma Strict_inclusion_is_transitive_with_inclusion_left :
 forall x y z:Ensemble U,
   Included U x y -> Strict_Included U y z -> Strict_Included U x z.
intros x y z H' H'0; try assumption.
elim Strict_Rel_is_Strict_Included.
unfold contains in |- *.
intros H'1 H'2; try assumption.
apply H'1.
apply Strict_Rel_Transitive_with_Rel_left with (y := y); auto with sets.
Qed.

Lemma Strict_inclusion_is_transitive :
 Transitive (Ensemble U) (Strict_Included U).
apply cong_transitive_same_relation with
 (R := Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U)));
 auto with sets.
Qed.

Theorem Empty_set_is_Bottom :
 forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U).
intro A; apply Bottom_definition; simpl in |- *; auto with sets.
Qed.
Hint Resolve Empty_set_is_Bottom.

Theorem Union_minimal :
 forall a b X:Ensemble U,
   Included U a X -> Included U b X -> Included U (Union U a b) X.
intros a b X H' H'0; red in |- *.
intros x H'1; elim H'1; auto with sets.
Qed.
Hint Resolve Union_minimal.

Theorem Intersection_maximal :
 forall a b X:Ensemble U,
   Included U X a -> Included U X b -> Included U X (Intersection U a b).
auto with sets.
Qed.

Theorem Union_increases_l : forall a b:Ensemble U, Included U a (Union U a b).
auto with sets.
Qed.

Theorem Union_increases_r : forall a b:Ensemble U, Included U b (Union U a b).
auto with sets.
Qed.

Theorem Intersection_decreases_l :
 forall a b:Ensemble U, Included U (Intersection U a b) a.
intros a b; red in |- *.
intros x H'; elim H'; auto with sets.
Qed.

Theorem Intersection_decreases_r :
 forall a b:Ensemble U, Included U (Intersection U a b) b.
intros a b; red in |- *.
intros x H'; elim H'; auto with sets.
Qed.
Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l
  Intersection_decreases_r.

Theorem Union_is_Lub :
 forall A a b:Ensemble U,
   Included U a A ->
   Included U b A ->
   Lub (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b) (Union U a b).
intros A a b H' H'0.
apply Lub_definition; simpl in |- *.
apply Upper_Bound_definition; simpl in |- *; auto with sets.
intros y H'1; elim H'1; auto with sets.
intros y H'1; elim H'1; simpl in |- *; auto with sets.
Qed.

Theorem Intersection_is_Glb :
 forall A a b:Ensemble U,
   Included U a A ->
   Included U b A ->
   Glb (Ensemble U) (Power_set_PO A) (Couple (Ensemble U) a b)
     (Intersection U a b).
intros A a b H' H'0.
apply Glb_definition; simpl in |- *.
apply Lower_Bound_definition; simpl in |- *; auto with sets.
apply Definition_of_Power_set.
generalize Inclusion_is_transitive; intro IT; red in IT; apply IT with a;
 auto with sets.
intros y H'1; elim H'1; auto with sets.
intros y H'1; elim H'1; simpl in |- *; auto with sets.
Qed.

End The_power_set_partial_order.

Hint Resolve Empty_set_minimal: sets v62.
Hint Resolve Power_set_Inhabited: sets v62.
Hint Resolve Inclusion_is_an_order: sets v62.
Hint Resolve Inclusion_is_transitive: sets v62.
Hint Resolve Union_minimal: sets v62.
Hint Resolve Union_increases_l: sets v62.
Hint Resolve Union_increases_r: sets v62.
Hint Resolve Intersection_decreases_l: sets v62.
Hint Resolve Intersection_decreases_r: sets v62.
Hint Resolve Empty_set_is_Bottom: sets v62.
Hint Resolve Strict_inclusion_is_transitive: sets v62.


(* coq-robot (c) 2017 AIST and INRIA. License: LGPL-2.1-or-later. *)
From mathcomp Require Import all_ssreflect ssralg ssrint.
From mathcomp Require Import ssrnum rat poly closed_field polyrcf matrix.
From mathcomp Require Import mxalgebra tuple mxpoly zmodp binomial realalg.
From mathcomp Require Import complex finset fingroup perm.
Require Import ssr_ext.

(******************************************************************************)
(*                               Angles                                       *)
(*                                                                            *)
(* NB(2022-02-15): The development in this directory now uses trigonometric   *)
(* from mathcomp-analysis instead of the notation of angle provided by this   *)
(* file.                                                                      *)
(*                                                                            *)
(* This files provides a theory of angles defined using complex numbers and   *)
(* develops the theory of trigonometric functions including trigonometric     *)
(* laws such as the cancellation laws between trigonometric functions and     *)
(* their inverse, Pythagorean identity, double-angle and half-angle formulas, *)
(* law of cosines and of sines, etc.                                          *)
(*                                                                            *)
(*      angle T == type of angles over the rcfType T, i.e., a complex number  *)
(*                 whose modulus is 1                                         *)
(*       angle0 == 0 angle corresponding to the complex number 1              *)
(*        arg x == angle corresponding to the complex number x/|x|            *)
(*           pi == the angle corresponding to the complete number -1          *)
(*                                                                            *)
(* Angles form a ZmodType, so that we can do scalar multiplication of angles: *)
(* half_angle a == the angle corresponding to a/2                             *)
(*       pihalf == pi/2                                                       *)
(*    piquarter == pi/4                                                       *)
(*                                                                            *)
(* Trigonometric functions:                                                   *)
(*       cos a == the real part of the angle a                                *)
(*       sin a == the imaginary part of angle a                               *)
(*       tan a == tangent a                                                   *)
(*      acos x == arccosine, the inverse trigonometric function of cosine     *)
(*      asin x == arcsin x                                                    *)
(*      atan x == arctan x                                                    *)
(*   atan2 x y == the 2-argument arctangent, i.e., the angle between the      *)
(*                positive x axis and the ray to the point (x, y)             *)
(*       cot a == cotangent a                                                 *)
(*                                                                            *)
(******************************************************************************)

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

Local Open Scope ring_scope.
Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Section nthroot.

(* TODO: remove? *)
Lemma rootCD (C : numClosedFieldType) (m n : nat) (x : C) :
  (m * n).-root (x) = m.-root (n.-root x).
Proof.
have [->|m_gt0] := posnP m; first by rewrite mul0n !root0C.
have [->|n_gt0] := posnP n; first by rewrite muln0 root0C rootC0.
have mn_gt0: (m * n > 0)%N by rewrite ?muln_gt0 ?m_gt0.
wlog x_gt0 : x / x >= 0 => [hwlog_x_ge0|]; last first.
  apply: (@pexpIrn _ (m * n)); rewrite // ?qualifE ?rootC_ge0 //.
  by rewrite rootCK // exprM !rootCK.
wlog nx_eq1 : x / `|x| = 1 => [hwlog_nx_eq1|].
  have [->|x_neq0] := eqVneq x 0; first by rewrite !rootC0.
  rewrite -[x](@mulfVK _ `|x|) ?normr_eq0 // rootCMr //.
  rewrite hwlog_nx_eq1 ?normrM ?normfV ?normr_id ?divff ?normr_eq0 //.
  by rewrite hwlog_x_ge0 //; do !rewrite -rootCMr ?rootC_ge0 //.
 have [|m_gt1] := leqP m 1%N.
   by case: m m_gt0 mn_gt0 hwlog_x_ge0 => [|[|m]] // _ _;
     rewrite mul1n root1C.
 have [|n_gt1] := leqP n 1%N.
   by case: n n_gt0 mn_gt0 hwlog_x_ge0 => [|[|n]] // _ _;
     rewrite muln1 root1C.
 have mDn_gt1: (m * n > 1)%N.
   by rewrite -subn_eq0; move: m n {n_gt0 m_gt0} n_gt1 m_gt1
     mn_gt0 hwlog_x_ge0=> [|[|m]] [|[|n]].
apply: eqC_semipolar => //; first 2 last.
- by rewrite mulr_ge0 ?Im_rootC_ge0.
- by rewrite !norm_rootC hwlog_x_ge0.
apply/eqP; rewrite eq_le !rootC_Re_max ?exprM ?rootCK ?Im_rootC_ge0 //.
apply: eqC_semipolar; first 2 last.
- rewrite mulr_ge0 ?Im_rootC_ge0 //. admit.
- by rewrite normrX !norm_rootC hwlog_x_ge0 // rootCK.
apply/eqP; rewrite eq_le rootC_Re_max -?exprM ?rootCK //=; last first.
  admit.
admit.
Abort.

End nthroot.

Section angle_def.

Variable T : rcfType.

Record angle := Angle {
  expi : T[i];
  _ : `| expi | == 1 }.

Fact angle0_subproof : `| 1 / `| 1 | | == 1 :> T[i].
Proof. by rewrite normr1 divr1 normr1. Qed.

Definition angle0 := Angle angle0_subproof.

Canonical angle_subType := [subType for expi].

Lemma normr_expi a : `|expi a| = 1.
Proof. by case: a => x /= /eqP. Qed.

Lemma expi_eq0 a : (expi a == 0) = false.
Proof. case: a => /= a /eqP Ha; apply/negbTE; by rewrite -normr_gt0 Ha. Qed.

Lemma expi_inj : injective expi.
Proof. move=> [a a1] [b b1] /= ab; by apply/val_inj. Qed.

Lemma expi_is_unit a : expi a \is a GRing.unit.
Proof. by rewrite unitfE -normr_eq0 normr_expi oner_eq0. Qed.

Definition arg (x : T[i]) : angle :=
  insubd angle0 (x / `| x |).

Lemma argZ x (k : T) : 0 < k -> arg (k %:C%C * x) = arg x.
Proof.
move=> k0; rewrite /arg; congr (insubd _ _).
rewrite normrM gtr0_norm; last by rewrite ltcR.
rewrite -mulf_div divff ?mul1r //.
by rewrite lt0r_neq0 // ltcR.
Qed.

Lemma argZ_neg x (k : T) : k < 0 -> arg (k %:C%C * x) = arg (- x).
Proof.
move=> k0; rewrite /arg; congr (insubd _ _).
rewrite normrM ltr0_norm; last by rewrite ltcR.
rewrite -mulf_div invrN mulrN divff ?mul1r; last by rewrite ltr0_neq0 // ltcR.
by rewrite mulNr mul1r normrN mulNr.
Qed.

Lemma expiK : cancel expi arg.
Proof.
move=> a; apply/val_inj=> /=.
by rewrite insubdK ?normr_expi ?divr1 // -topredE /= normr_expi.
Qed.

Lemma expi_arg x : x != 0 -> expi (arg x) = x / `|x|.
Proof.
move=> Nx_neq0; rewrite insubdK //.
by rewrite -topredE /= normrM normfV normr_id divff // normr_eq0.
Qed.

Lemma expi_conjc (a : T[i]) : a != 0 -> (expi (arg a))^-1 = expi (arg a^*).
Proof.
case: a => a b a0 /=; rewrite expi_arg // expi_arg //; last first.
  apply: contra a0 => a0; by rewrite -conjc_eq0.
rewrite invc_norm (_ : `| _ | = 1); last first.
  by rewrite normrM normrV ?unitfE ?normr_eq0 // normr_id divrr // unitfE normr_eq0.
rewrite exprnN exp1rz mul1r. simpc. by rewrite /= sqrrN.
Qed.

Lemma mul_norm_arg x : x = `|x| * expi (arg x).
Proof.
have [x0|x_neq0] := boolP (x == 0); first by rewrite (eqP x0) normr0 mul0r.
by rewrite expi_arg // mulrC mulfVK // normr_eq0.
Qed.

Lemma argK x : `|x| = 1 -> expi (arg x) = x.
Proof. by move=> Nx1; rewrite expi_arg ?Nx1 ?divr1 // -normr_gt0 Nx1. Qed.

Lemma arg_Re k : 0 < k -> arg k%:C%C = arg 1.
Proof. by move=> k_gt0; rewrite -[(k%:C)%C]mulr1 argZ. Qed.

Lemma arg_Re_neg k : k < 0 -> arg k%:C%C = arg (- 1).
Proof. by move=> k_gt0; rewrite -[(k%:C)%C]mulr1 argZ_neg. Qed.

Definition add_angle a b := arg (expi a * expi b).
Definition opp_angle a := arg (expi a)^-1.

Lemma add_angleA : associative add_angle.
Proof.
by move=> ???; rewrite /add_angle argK ?mulrA ?argK // ?normrM 2!normr_expi mulr1.
Qed.

Lemma add_angleC : commutative add_angle.
Proof. move=> a b; by rewrite /add_angle mulrC. Qed.

Lemma add_0angle x : add_angle (arg 1) x = x.
Proof. by rewrite /add_angle argK ?normr1 ?mul1r ?expiK. Qed.

Lemma add_Nangle x : add_angle (opp_angle x) x = arg 1.
Proof.
rewrite /add_angle /opp_angle argK; first by rewrite mulVr // expi_is_unit.
by rewrite normrV ?expi_is_unit // normr_expi invr1.
Qed.

Definition angle_eqMixin := [eqMixin of angle by <:].
Canonical angle_eqType := EqType angle angle_eqMixin.
Definition angle_choiceMixin := [choiceMixin of angle by <:].
Canonical angle_choiceType := ChoiceType angle angle_choiceMixin.
Definition angle_ZmodMixin := ZmodMixin add_angleA add_angleC add_0angle add_Nangle.
Canonical angle_ZmodType := ZmodType angle angle_ZmodMixin.

Lemma arg1 : arg 1 = 0.
Proof. apply val_inj => /=; by rewrite argK // normr1. Qed.

Lemma expiD a b : expi (a + b) = expi a * expi b.
Proof.
move: a b => [a a1] [b b1] /=.
by rewrite /add_angle /= argK // normrM  (eqP a1) (eqP b1) mulr1.
Qed.

Definition pi := arg (-1).

Lemma expipi : expi pi = -1. Proof. by rewrite argK ?normrN1. Qed.

Lemma argN1 : arg (- 1) = pi.
Proof. apply val_inj => /=; by rewrite argK // ?normrN1. Qed.

Lemma expi2pi : expi (pi + pi) = 1.
Proof. by rewrite /pi expiD argK // ?normrN1 // mulrNN mulr1. Qed.

Lemma pi2 : pi *+ 2 = 0.
Proof. apply expi_inj => //; by rewrite expi2pi -arg1 argK // normr1. Qed.

End angle_def.

Arguments expi {T} _.
Arguments angle0 {T}.
Arguments pi {T}.

Section angle_basic_prop.

Variable T : rcfType.
Implicit Types a b : angle T.

Lemma add_angleE a b : a + b = add_angle a b.
Proof. done. Qed.

Lemma opp_angleE a : - a = opp_angle a.
Proof. done. Qed.

Lemma argc (z : T[i]) : z != 0 -> arg z^* = - arg z.
Proof.
case: z => a b z0 /=; by rewrite {2}/arg opp_angleE /opp_angle expi_conjc //= expiK.
Qed.

Definition cos a := complex.Re (expi a).

Lemma cos0 : cos 0 = 1.
Proof. by rewrite /cos -arg1 argK // ger0_norm // ler01. Qed.

Lemma cospi : cos pi = -1.
Proof. by rewrite /cos /pi argK //= normrN normr1. Qed.

Lemma cos_max a : `| cos a | <= 1.
Proof.
rewrite -lecR (le_trans (normc_ge_Re _)) //; by case: a => ? /= /eqP ->.
Qed.

Lemma cosN a : cos (- a) = cos a.
Proof.
case: a => -[a b] ab; rewrite opp_angleE /cos /opp_angle /=.
rewrite invc_norm (eqP ab) expr1n invr1 mul1r expi_arg; last first.
  by rewrite conjc_eq0 -normr_eq0 (eqP ab) oner_eq0.
by rewrite normcJ (eqP ab) divr1.
Qed.

Definition sin a := complex.Im (expi a).

Lemma sin0 : sin 0 = 0.
Proof. by rewrite /sin -arg1 argK // normr1. Qed.

Lemma sinpi : sin pi = 0.
Proof. by rewrite /sin /pi argK /= ?oppr0 // normrN normr1. Qed.

Lemma sinN a : sin (- a) = - sin a.
Proof.
case: a => -[a b] ab; rewrite opp_angleE /sin /opp_angle /=.
rewrite invc_norm (eqP ab) expr1n invr1 mul1r expi_arg; last first.
  by rewrite conjc_eq0 -normr_eq0 (eqP ab) oner_eq0.
by rewrite normcJ (eqP ab) divr1.
Qed.

Lemma eq_angle a b : (a == b) = ((cos a == cos b) && (sin a == sin b)).
Proof.
case: a b => [[a b] ab] [[c d] cd].
rewrite /cos /= /sin /=.
apply/idP/idP; first by case/eqP => -> ->; rewrite 2!eqxx.
case/andP => /eqP ac /eqP bd.
apply/eqP/val_inj => /=; by rewrite ac bd.
Qed.

Lemma sqrD1_cossin (x y : T) :
  x ^+ 2 + y ^+ 2 = 1 -> {a | x = cos a /\ y = sin a}.
Proof.
move=> v1.
have {}v1 : (`| x +i* y | = 1)%C by rewrite normc_def /= v1 sqrtr1.
exists (arg (x +i* y)%C).
rewrite /cos /sin expi_arg //; last by rewrite -normr_eq0 v1 oner_neq0.
by rewrite v1 divr1.
Qed.

(* relation expi<->cos/sin *)

Lemma expi_cos_sin a : expi a = (cos a +i* sin a)%C.
Proof. by case: a => -[a0 a1] Ha; rewrite /cos /sin. Qed.

Lemma expi0 : expi 0 = 1 :> T[i].
Proof. by rewrite expi_cos_sin cos0 sin0. Qed.

Lemma expi_expr k a : expi a ^+ k = expi (a *+ k).
Proof.
elim: k => [|k ih]; by
  [rewrite expr0 mulr0n expi0 | rewrite exprS ih mulrS expiD].
Qed.

Lemma moivre n a : ((cos a +i* sin a) ^+n = cos (a *+ n) +i* sin (a *+ n))%C.
Proof.
rewrite -!expi_cos_sin.
elim: n => [|n ih]; by [rewrite expr0 mulr0n expi0 | rewrite expi_expr].
Qed.

Lemma pi_neq0 : pi != 0 :> angle T.
Proof.
apply/eqP => /(congr1 expi).
rewrite argK ?expi0; last by rewrite normrN normr1.
by move/eqP; rewrite eq_sym -subr_eq0 opprK (_ : 1 + 1 = 2%:R) // pnatr_eq0.
Qed.

Lemma expii : expi (arg 'i) = 'i :> T[i].
Proof. by rewrite argK // normc_def /= expr0n expr1n add0r sqrtr1. Qed.

Lemma expiNi : expi (- arg 'i) = -'i :> T[i].
Proof.
rewrite expi_cos_sin sinN cosN /cos /sin expi_arg; last first.
  by rewrite -normr_eq0 normci oner_neq0.
rewrite normci divr1 /=; apply/eqP; by rewrite eq_complex /= oppr0 2!eqxx.
Qed.

Lemma expiNpi : expi (- pi) = - 1 :> T[i].
Proof.
rewrite /pi.
rewrite expi_cos_sin cosN sinN cospi sinpi.
by apply/eqP; rewrite eq_complex /= !eqxx.
Qed.

Lemma piNpi : pi = - pi :> angle T.
Proof. by apply expi_inj; rewrite expiNpi expipi. Qed.

Lemma arg0_inv (x : T[i]) y : y != 0 -> `|x| = y -> arg x = 0 -> x = y.
Proof.
move=> y0; case: x => x1 x2 norma H.
rewrite -(mulr1 y) -expi0 -H expi_arg; last by rewrite -normr_eq0 norma.
by rewrite norma mulrCA divrr // mulr1.
Qed.

Lemma argpi_inv (x : T[i]) y : y != 0 -> `|x| = y -> arg x = pi -> x = - y.
Proof.
move=> y0; case: x => x1 x2 norma H.
rewrite -(mulrN1 y) -expipi -H expi_arg; last by rewrite -normr_eq0 norma.
by rewrite norma mulrCA divrr // mulr1.
Qed.

(* standard trigonometric relations *)

Lemma cos2Dsin2 a : (cos a) ^+ 2 + (sin a) ^+ 2 = 1.
Proof.
move: (add_Re2_Im2 (expi a)).
by rewrite normr_expi expr1n => /(congr1 (@complex.Re T)) => /= <-.
Qed.

Lemma sin2cos2 a : sin a ^+ 2 = 1 - cos a ^+ 2.
Proof. move/eqP: (cos2Dsin2 a); by rewrite eq_sym addrC -subr_eq => /eqP. Qed.

Lemma cos2sin2 a : cos a ^+ 2 = 1 - sin a ^+ 2.
Proof. move/eqP: (cos2Dsin2 a); by rewrite eq_sym -subr_eq => /eqP. Qed.

Lemma sinD a b : sin (a + b) = sin a * cos b + cos a * sin b.
Proof. by rewrite {1}/sin expiD 2!expi_cos_sin /= addrC. Qed.

Lemma sinDpi a : sin (a + pi) = - sin a.
Proof. by rewrite sinD ?(cosN, sinN) cospi mulrN1 sinpi ?oppr0 mulr0 addr0. Qed.

Lemma sin_mulr2n a : sin (a *+ 2) = (cos a * sin a) *+ 2.
Proof. by rewrite mulr2n sinD mulrC -mulr2n. Qed.

Lemma cosD a b : cos (a + b) = cos a * cos b - sin a * sin b.
Proof. by rewrite {1}/cos expiD 2!expi_cos_sin /= addrC. Qed.

Lemma cosDpi a : cos (a + pi) = - cos a.
Proof. by rewrite cosD ?(cosN, sinN) cospi mulrN1 sinpi ?oppr0 mulr0 subr0. Qed.

Lemma cosB a b : cos (a - b) = cos a * cos b + sin a * sin b.
Proof. by rewrite cosD cosN sinN mulrN opprK. Qed.

Lemma sinB a b : sin (a - b) = sin a * cos b - cos a * sin b.
Proof. by rewrite sinD cosN sinN mulrN. Qed.

Lemma abs_sin a : `| sin a | = Num.sqrt (1 - cos a ^+ 2).
Proof.
apply/eqP; rewrite -(@eqr_expn2 _ 2) //; last by rewrite sqrtr_ge0.
rewrite -normrX ger0_norm; last by rewrite sqr_ge0.
rewrite sqr_sqrtr; last first.
  by rewrite lter_sub_addr add0r -sqr_normr exprn_ilte1 // cos_max.
by rewrite -subr_eq opprK addrC cos2Dsin2.
Qed.

(* valeurs remarquables de cos/sin *)

Lemma norm_cos_eq1 a : (`|cos a| == 1) = (sin a == 0).
Proof.
by rewrite -sqrf_eq0 -sqrp_eq1 // sqr_normr sin2cos2 subr_eq0 eq_sym.
Qed.

Lemma norm_sin_eq1 a : (`|sin a| == 1) = (cos a == 0).
Proof.
by rewrite -sqrf_eq0 -sqrp_eq1 // sqr_normr cos2sin2 subr_eq0 eq_sym.
Qed.

Lemma cos1sin0 a : `|cos a| = 1 -> sin a = 0.
Proof. by move/eqP; rewrite norm_cos_eq1 => /eqP. Qed.

Lemma sin1cos0 a : `|sin a| = 1 -> cos a = 0.
Proof. by move/eqP; rewrite norm_sin_eq1 => /eqP. Qed.

Lemma sin0cos1 a : sin a = 0 -> `|cos a| = 1.
Proof. by move/eqP; rewrite -norm_cos_eq1 => /eqP. Qed.

Lemma cos0sin1 a : cos a = 0 -> `|sin a| = 1.
Proof. by move/eqP; rewrite -norm_sin_eq1 => /eqP. Qed.

Lemma cos_eq1 a : (cos a == 1) = (a == 0).
Proof.
apply/eqP/eqP=> [cosa|->]; last by rewrite cos0.
by rewrite -[a]expiK expi_cos_sin cosa cos1sin0 ?arg1 ?cosa ?normr1.
Qed.

Lemma cos1_angle0 a : cos a = 1 -> a = 0.
Proof. by move/eqP; rewrite cos_eq1 => /eqP. Qed.

Lemma cos_eqN1 a : (cos a == -1) = (a == pi).
Proof.
apply/eqP/eqP=> [cosa|->]; last by rewrite cospi.
rewrite -[a]expiK expi_cos_sin cosa cos1sin0 ?complexr0 ?rmorphN ?argN1 //.
by rewrite cosa normrN1.
Qed.

Lemma cosN1_angle0 a : cos a = -1 -> a = pi.
Proof. by move/eqP; rewrite cos_eqN1 => /eqP. Qed.

Lemma sin_eq0 a : (sin a == 0) = (a == 0) || (a == pi).
Proof. by rewrite -sqrf_eq0 sin2cos2 subr_eq0 eq_sym sqrf_eq1 cos_eq1 cos_eqN1. Qed.

Lemma sin0_inv a : sin a = 0 -> {a = 0} + { a = pi }.
Proof. by move/eqP; rewrite sin_eq0; case: eqP => /= ?/eqP?; [left|right]. Qed.

Definition tan a := sin a / cos a.

Lemma tan0 : tan 0 = 0 :> T.
Proof. by rewrite /tan sin0 cos0 mul0r. Qed.

Lemma tanpi : tan pi = 0.
Proof. by rewrite /tan sinpi mul0r. Qed.

Lemma tanN x : tan (- x) = - tan x :> T.
Proof. by rewrite /tan sinN cosN mulNr. Qed.

Lemma cos2_tan2 x : cos x != 0 -> 1 / (cos x) ^+ 2 = 1 + (tan x) ^+ 2.
Proof.
move=> cosx; rewrite /tan exprMn sin2cos2 mulrBl -exprMn divrr ?unitfE //.
by rewrite expr1n addrCA subrr addr0 div1r mul1r exprVn.
Qed.

Definition pihalf : angle T := arg 'i.

Lemma expi_pihalf : expi pihalf = 'i.
Proof. by rewrite /pihalf argK // normc_def /= expr0n expr1n add0r sqrtr1. Qed.

Lemma expi_Npihalf : expi (- pihalf) = - 'i.
Proof. by rewrite /pihalf expiNi. Qed.

Lemma sin_pihalf : sin pihalf = 1.
Proof.
have i1 : `|'i| = 1 :> T[i] by rewrite normc_def /= expr0n add0r expr1n sqrtr1.
rewrite /sin /pihalf expi_arg //.
by rewrite i1 divr1.
by rewrite -normr_eq0 i1 oner_neq0.
Qed.

Lemma cos_pihalf : cos pihalf = 0.
Proof.
have i1 : `|'i| = 1 :> T[i] by rewrite normc_def /= expr0n add0r expr1n sqrtr1.
rewrite /cos /pihalf expi_arg //.
by rewrite i1 divr1.
by rewrite -normr_eq0 i1 oner_neq0.
Qed.

Lemma tan_pihalf : tan pihalf = 0.
Proof. by rewrite /tan sin_pihalf cos_pihalf invr0 mulr0. Qed.

Lemma cosDpihalf a : cos (a + pihalf) = - sin a.
Proof. by rewrite cosD cos_pihalf mulr0 add0r sin_pihalf mulr1. Qed.

Lemma cosBpihalf a : cos (a - pihalf) = sin a.
Proof. by rewrite cosB cos_pihalf sin_pihalf mulr0 add0r mulr1. Qed.

Lemma sinDpihalf a : sin (a + pihalf) = cos a.
Proof. by rewrite sinD cos_pihalf mulr0 add0r sin_pihalf mulr1. Qed.

Lemma sinBpihalf a : sin (a - pihalf) = - cos a.
Proof. by rewrite sinB cos_pihalf sin_pihalf mulr0 add0r mulr1. Qed.

Lemma cos0_inv a : cos a = 0 -> {a = pihalf} + {a = - pihalf}.
Proof.
case: a => -[a b] ni; rewrite /cos /= => a0.
have [b1|b1] : {b = 1} + {b = - 1}.
  move: ni.
  rewrite a0 normc_def /= expr0n add0r sqrtr_sqr eq_complex /= eqxx andbT.
  case: (lerP 0 b) => b0.
  - rewrite ger0_norm // => /eqP ->; by left.
  - rewrite ltr0_norm // eqr_oppLR => /eqP ->; by right.
- left; apply val_inj => /=;
  by rewrite /pihalf argK // ?a0 ?b1 // normc_def /= expr0n add0r expr1n sqrtr1.
- right; apply val_inj => /=.
  by apply/eqP; rewrite /pihalf a0 b1 expiNi eq_complex /= oppr0 2!eqxx.
Qed.

Definition piquarter : angle T := arg (Num.sqrt (2%:R^-1) +i* Num.sqrt (2%:R^-1))%C.

Lemma expi_piquarter :
  expi piquarter = (Num.sqrt (2%:R^-1) +i* Num.sqrt (2%:R^-1))%C.
Proof.
rewrite /piquarter argK // normc_def /= sqr_sqrtr ?invr_ge0 ?ler0n //.
by rewrite -div1r -mulr2n -mulrnAl divrr ?unitfE ?pnatr_eq0 // sqrtr1.
Qed.

(*
sin(t) = ( exp(it) - exp(-it) )/2i
cos(t) = ( exp(it) + exp(-it) )/2
*)

Definition acos (x : T) : angle T := arg (x +i* Num.sqrt (1 - x ^+ 2))%C.

Lemma acos1 : acos 1 = 0.
Proof. by rewrite /acos expr1n subrr sqrtr0 complexr0 arg1. Qed.

Lemma acosN1 : acos (- 1) = pi.
Proof.
rewrite /acos sqrrN expr1n subrr sqrtr0 complexr0 (_ : ((_)%:C)%C = -1) //.
apply/eqP; by rewrite eq_complex /= oppr0 eqxx eqxx.
Qed.

Definition asin (x : T) : angle T := arg (Num.sqrt (1 - x ^+ 2) +i* x)%C.

Lemma asinN x : asin (- x) = - asin x.
Proof.
rewrite /asin sqrrN -argc //= eq_complex /= negb_and.
case/boolP : (x == 0) => [/eqP ->|]; last by rewrite orbT.
by rewrite expr0n /= subr0 sqrtr1 oner_neq0.
Qed.

Definition atan (x : T) : angle T :=
  if x == 0 then 0 else arg ((x^-1 +i* 1)%C *~ sgz x).

Lemma atan0 : atan 0 = 0.
Proof. by rewrite /atan eqxx. Qed.

Lemma atan1 : atan 1 = piquarter.
Proof.
rewrite /atan oner_eq0 invr1 sgz1 mulr1z.
rewrite -(@argZ _ _ (Num.sqrt 2%:R^-1)) ?sqrtr_gt0 ?invr_gt0 ?ltr0Sn //.
by rewrite -complexZ1 mulr1.
Qed.

Lemma atanN x : atan (- x) = - atan x.
Proof.
rewrite /atan eqr_oppLR oppr0.
case: ifPn => [|x0]; first by rewrite oppr0.
rewrite -argc.
  congr arg; apply/eqP.
  rewrite sgzN mulrNz /= eq_complex /=.
  move: x0; rewrite neq_lt => /orP [] x0.
    by rewrite ltr0_sgz // 2!mulrN1z opprK /= invrN opprK 2!eqxx.
  by rewrite gtr0_sgz // 2!mulr1z /= invrN opprK 2!eqxx.
move: x0; rewrite neq_lt => /orP [] x0.
  rewrite ltr0_sgz // -?oppr_gt0 ?opprK // mulrN1z eq_complex /= negb_and orbC.
  by rewrite eqr_oppLR oppr0 oner_neq0.
by rewrite gtr0_sgz ?oppr_gt0 // mulr1z eq_complex /= negb_and oner_neq0 orbC.
Qed.

Definition atan2 x y :=
  if y > 0 then atan (x / y) else
  if y < 0 then
     (if x >= 0 then atan (x / y) + pi else
        (* x < 0 *) atan (x / y) - pi) else
  (* y == 0 *)
     (if x > 0 then pihalf else
      if x < 0 then - pihalf else
        0) (* undefined *).

Lemma atan200 : atan2 0 0 = 0.
Proof. by rewrite /atan2 ltxx. Qed.

Lemma atan2_11 : atan2 1 1 = piquarter.
Proof. by rewrite /atan2 ltr01 invr1 mulr1 atan1. Qed.

Lemma atan2N (x y : T) : atan2 (- x) y = - atan2 x y.
Proof.
rewrite /atan2; have [y0|y0]:= ltP 0 y; first by rewrite mulNr atanN.
rewrite lt_neqAle y0 andbT; have [y0'|y0'] /= := boolP (y == 0).
  by rewrite oppr_gt0 oppr_lt0; case: ltrgt0P => x0; rewrite ?opprK ?oppr0.
by rewrite oppr_ge0; case: ltrgt0P => x0;
   rewrite mulNr atanN opprD ?opprK // {1}piNpi.
Qed.

(* cancellation laws *)

(* The following lemmas are true in specific domains only, such as
]-pi/2, pi/2[ = [pred a | cos a > 0]
]0, pi[ = [pred a | sin a > 0]
[-pi/2, pi/2[ = [pred a | cos a > 0]
[0, pi] = [pred a | sin a >= 0]
[0, pi[ = [pred a | sin a >= 0 && a != pi]
*)

Definition Opi_closed := [pred a | 0 <= sin a].
Definition piO_closed := [pred a | sin a < 0].

Lemma angle_in a : a \in Opi_closed \/ a \in piO_closed.
Proof. rewrite 2!inE; case: (lerP 0 (sin a)); by auto. Qed.

(* ]-pi/2, pi/2[ *)
Definition Npi2pi2_open : pred (angle T) := [pred a | cos a > 0].
Definition Npi2pi2_closed : pred (angle T) := [pred a | cos a >= 0].
Lemma Npi2pi2_openP a : (a \in Npi2pi2_open) = (0 < cos a).
Proof. by rewrite inE. Qed.

Lemma acosK (r : T) : -1 <= r <= 1 -> cos (acos r) = r.
Proof.
move=> rdom; rewrite /acos /cos argK // normc_def /= sqr_sqrtr; last first.
  by rewrite subr_ge0 -ler_sqrt // ?ltr01 // sqrtr1 sqrtr_sqr ler_norml.
by rewrite addrC subrK sqrtr1.
Qed.

Lemma tanK a : a \in Npi2pi2_open -> atan (tan a) = a.
Proof.
rewrite inE => adoml; rewrite /atan /tan mulf_eq0.
have [|saNZ] /= := boolP (sin a == 0).
  rewrite sin_eq0 => /orP[] /eqP aE //.
  by rewrite aE cospi // -subr_lt0 opprK add0r (ltr_nat _ 1 0) in adoml.
rewrite invr_eq0.
move: (adoml); rewrite lt0r => /andP[/negPf-> _].
have -> : ((sin a / cos a)^-1 +i* 1 = (sin a)^-1%:C * (cos a +i* sin a))%C.
  by rewrite invf_div -complexZ mulVf // mulrC.
rewrite sgzM; case: (sgzP (sin a)) saNZ => //= saP _.
  by rewrite mul1r gtr0_sgz ?invr_gt0 // argZ ?invr_gt0 // -expi_cos_sin expiK.
rewrite mulN1r gtr0_sgz ?invr_gt0 // mulrN1z -!mulrN.
by rewrite argZ_neg ?invr_lt0 // opprK -expi_cos_sin expiK.
Qed.

Lemma tanDpi a : tan (a + pi) = tan a.
Proof. by rewrite /tan sinDpi cosDpi mulNr invrN mulrN opprK. Qed.

Lemma tanK_closed a : a \notin Npi2pi2_closed -> atan (tan a) = a + pi.
Proof.
rewrite inE => adoml.
rewrite -{1}[a]addr0 -pi2 mulr2n addrA tanDpi tanK // inE cosDpi.
by rewrite oppr_cp0 ltNge.
Qed.

Lemma cosK a : a \in Opi_closed -> acos (cos a) = a.
Proof.
rewrite inE => adoml; rewrite /acos /cos /= expi_cos_sin /= -sin2cos2.
by rewrite sqrtr_sqr /= ger0_norm // -expi_cos_sin expiK.
Qed.

Lemma cosKN a : a \in piO_closed -> acos (cos a) = - a.
Proof.
rewrite inE => adoml; rewrite /acos /cos /= expi_cos_sin /= -sin2cos2.
rewrite sqrtr_sqr /= ltr0_norm //.
move: (expi_cos_sin (- a)); rewrite cosN sinN => <-; by rewrite expiK.
Qed.

Lemma sinK (x : angle T) : 0 <= cos x (* TODO: define Npi2pi2_closed? *) ->
  asin (sin x) = x.
Proof.
case: x => /= -[x y] x1 cosx1; apply/val_inj/eqP => /=.
rewrite eq_complex /asin /sin argK /= ?eqxx ?andbT; last first.
  rewrite {cosx1}.
  rewrite normc_def /= sqr_sqrtr ?subrK ?sqrtr1 // subr_ge0.
  move: x1; rewrite normc_def eq_complex eqxx andbT /=.
  move/eqP/(congr1 (fun x => x^+2)); rewrite expr1n.
  rewrite sqr_sqrtr ?addr_ge0 // ?sqr_ge0 // => <-.
  by rewrite ler_addr // sqr_ge0.
rewrite /cos /= in cosx1.
move : x1; rewrite normc_def /= eq_complex /= eqxx andbT.
move/eqP/(congr1 (fun x => x^+2)); rewrite expr1n.
rewrite  sqr_sqrtr // ?addr_ge0 // ?sqr_ge0 // => <-.
by rewrite addrK sqrtr_sqr ger0_norm.
Qed.

Lemma asinK r : -1 <= r <= 1 -> sin (asin r) = r.
Proof.
move=> rdom; rewrite /sin /asin argK // normc_def /= sqr_sqrtr; last first.
  by rewrite subr_ge0 -ler_sqrt // ?ltr01 // sqrtr1 sqrtr_sqr ler_norml.
by rewrite subrK sqrtr1.
Qed.

Lemma atan_in x : atan x \in Npi2pi2_open.
Proof.
case/boolP : (x == 0) => [/eqP ->|x0].
  by rewrite atan0 inE cos0 ltr01.
rewrite Npi2pi2_openP /atan (negbTE x0) /cos => [:myRe0].
rewrite expi_arg.
  rewrite normc_def => [:myltr0].
  rewrite Re_scale.
    rewrite divr_gt0 //.
      abstract: myRe0.
      move/lt_total : x0 => /orP [] x0; last by rewrite gtr0_sgz //= invr_gt0.
      by rewrite ltr0_sgz //= ltr_oppr oppr0 invr_lt0.
    abstract: myltr0.
    rewrite -ltcR -normc_def normr_gt0 eq_complex /= negb_and.
    move/lt_total : x0 => /orP [] x0; last by rewrite gtr0_sgz //= invr_eq0 gt_eqF.
    by rewrite ltr0_sgz //= eqr_oppLR oppr0 invr_eq0 lt_eqF.
  by rewrite gt_eqF.
by rewrite eq_complex /= negb_and gt_eqF.
Qed.

Lemma atanKpos x : 0 < x -> tan (atan x) = x.
Proof.
move=> x0; rewrite /atan gt_eqF // gtr0_sgz // mulr1z /tan /sin /cos.
rewrite expi_arg /=; last by rewrite eq_complex /= negb_and oner_neq0 orbT.
rewrite mul0r oppr0 mulr0 add0r mulr0 subr0 expr0n addr0 expr1n.
rewrite sqr_sqrtr; last by rewrite addr_ge0 // ?ler01 // sqr_ge0.
set y := Num.sqrt _ / _; move=> [:yunit].
rewrite mul1r invrM; last 2 first.
  by rewrite unitrV unitfE gt_eqF.
  abstract: yunit.
  rewrite unitfE /y mulf_eq0 negb_or sqrtr_eq0 -ltNge invr_eq0.
  move=> [:x2D1]; apply/andP; split.
    abstract: x2D1.
    by rewrite addr_gt0 // ?ltr01 // exprn_even_gt0 //= invr_eq0 gt_eqF.
  by rewrite gt_eqF.
by rewrite mulrA divrr // invrK mul1r.
Qed.

Lemma atanKneg x : x < 0 -> tan (atan x) = x.
Proof.
rewrite -oppr_gt0 => x0; rewrite /atan lt_eqF -?oppr_gt0 //.
move/eqP: (atanKpos x0); rewrite -eqr_oppLR => /eqP H.
by rewrite -{3}H {H} atanN tanN opprK /atan lt_eqF // -oppr_gt0.
Qed.

Lemma atanK x : tan (atan x) = x.
Proof.
case: (lerP 0 x); last by apply atanKneg.
rewrite le_eqVlt => /orP [/eqP <-|]; by [rewrite atan0 tan0 | apply atanKpos].
Qed.

Lemma sqr_sin_atan (x : T) : (sin (atan x)) ^+ 2 = x ^+ 2 / (1 + x ^+ 2).
Proof.
case/boolP : (x == 0) => [/eqP ->|x0].
  by rewrite atan0 sin0 expr0n /= mul0r.
rewrite sin2cos2.
apply/eqP; rewrite -eqr_opp opprB subr_eq; apply/eqP.
rewrite -mulNr.
have /divrr H : 1 + x ^+ 2 \in GRing.unit.
  by rewrite unitfE gt_eqF // -(addr0 0) ltr_le_add // ?ltr01 // sqr_ge0.
rewrite -{2}H {H} addrC mulNr -mulrBl -invf_div -[LHS]invrK; congr (_ ^-1).
rewrite -exprVn -div1r expr_div_n expr1n cos2_tan2.
  by rewrite atanK addrK divr1.
by rewrite gt_eqF // -Npi2pi2_openP atan_in.
Qed.

Lemma sin_atan_ltr0 (x : T) : x < 0 -> sin (atan x) < 0.
Proof.
move=> x0.
rewrite /sin /atan lt_eqF // ltr0_sgz // mulrN1z /= expi_arg //=.
  rewrite expr0n addr0 mul0r oppr0 mulr0 add0r.
  rewrite sqr_sqrtr; last by rewrite addr_ge0 // sqr_ge0.
  rewrite pmulr_llt0; first by rewrite oppr_lt0 ltr01.
  rewrite (sqrrN 1) expr1n divr_gt0 //.
    rewrite sqrtr_gt0 addr_gt0 // ?ltr01 //.
    by rewrite exprn_gt0 // oppr_gt0 invr_lt0.
  by rewrite addr_gt0 // ?ltr01 // exprn_gt0 // oppr_gt0 invr_lt0.
by rewrite eq_complex /= negb_and /= orbC eqr_oppLR oppr0 oner_eq0.
Qed.

Lemma sin_atan_gtr0 (x : T) : 0 < x -> 0 < sin (atan x).
Proof.
move=> x0.
by rewrite -(opprK (sin _)) -sinN -atanN -oppr_lt0 opprK sin_atan_ltr0 // oppr_lt0.
Qed.

Lemma sin_atan (x : T) : sin (atan x) = x / Num.sqrt (1 + x ^+ 2).
Proof.
apply/eqP.
case/boolP : (x == 0) => [/eqP ->|].
  by rewrite atan0 sin0 mul0r.
move/lt_total => /orP [] x0.
  rewrite -eqr_opp -(@eqr_expn2 _ 2) //; last 2 first.
    move/sin_atan_ltr0 : x0; by rewrite oppr_ge0 => /ltW.
    by rewrite -mulNr divr_ge0 // ?sqrtr_ge0 // oppr_ge0 ltW.
  by rewrite 2!sqrrN sqr_sin_atan exprMn exprVn sqr_sqrtr // addr_ge0 // ?ler01 // sqr_ge0.
rewrite -(@eqr_expn2 _ 2) //; last 2 first.
  by rewrite ltW // sin_atan_gtr0.
  by rewrite mulr_ge0 // ?invr_ge0 ?sqrtr_ge0 // ltW.
by rewrite sqr_sin_atan exprMn exprVn sqr_sqrtr // addr_ge0 // ?ler01 // sqr_ge0.
Qed.

Lemma sin_acos x : `|x| <= 1 -> sin (acos x) = Num.sqrt (1 - x ^+ 2).
Proof.
move=> Nx_le1; rewrite /sin /acos argK //; simpc; rewrite sqr_sqrtr.
  by rewrite addrC addrNK sqrtr1.
by rewrite subr_ge0 -[_ ^+ _]real_normK ?num_real // exprn_ile1.
Qed.

Lemma cos_asin (x : T) : `| x | < 1 -> cos (asin x) = Num.sqrt (1 - x ^+ 2).
Proof.
move=> x1.
rewrite /asin /cos argK // normc_def /= sqr_sqrtr ?subr_ge0 ?subrK ?sqrtr1 //.
by rewrite -sqr_normr expr_le1 // ltW.
Qed.

Lemma cos_atan x : cos (atan x) = 1 / Num.sqrt (1 + x ^+ 2).
Proof.
move: (atan_in x); rewrite Npi2pi2_openP lt_neqAle => /andP [H1 H2].
move: (H1); rewrite eq_sym; move/cos2_tan2.
rewrite atanK => <-.
rewrite sqrtrM ?ler01 // sqrtr1 2!mul1r.
rewrite -exprVn sqrtr_sqr ger0_norm; by [rewrite invrK | rewrite invr_ge0].
Qed.

End angle_basic_prop.

Section half_angle.

Variable T : rcfType.

Definition half_anglec (x : T[i]) :=
  (if 0 <= complex.Im x then
    Num.sqrt ((1 + complex.Re x) / 2%:R) +i* Num.sqrt ((1 - complex.Re x) / 2%:R)
  else
    - Num.sqrt ((1 + complex.Re x) / 2%:R) +i* Num.sqrt ((1 - complex.Re x) / 2%:R))%C.

Lemma Re_half_anglec (x : T[i]) : `|x| = 1 -> 0 <= 1 + complex.Re x.
Proof.
move=> x1; rewrite -ler_subl_addr add0r.
suff : `| complex.Re x |%:C%C <= `|x|; last by rewrite normc_ge_Re.
rewrite x1 -lecR; apply: le_trans; by rewrite lecR ler_normr lexx orbT.
Qed.

Lemma Im_half_anglec (x : T[i]) : `|x| = 1 -> complex.Re x <= 1.
Proof.
move=> x1; suff : `| complex.Re x |%:C%C <= `|x|; last by rewrite normc_ge_Re.
rewrite x1 -lecR; apply: le_trans; by rewrite lecR ler_normr lexx.
Qed.

Lemma norm_half_anglec (x : T[i]) : `|x| = 1 -> `|half_anglec x| == 1.
Proof.
move=> x1.
rewrite /half_anglec.
case: ifP => a0.
  rewrite normc_def /= sqr_sqrtr; last first.
    by rewrite divr_ge0 // ?ler0n // Re_half_anglec.
  rewrite sqr_sqrtr; last first.
    by rewrite divr_ge0 // ?ler0n // subr_ge0 Im_half_anglec.
  by rewrite mulrC (mulrC (1 - complex.Re x)) -mulrDr addrCA addrK -mulr2n mulVr ?pnatf_unit // sqrtr1.
rewrite normc_def /= sqr_sqrtr; last first.
  by rewrite divr_ge0 // ?ler0n // subr_ge0 Im_half_anglec.
rewrite sqrrN sqr_sqrtr; last first.
  by rewrite divr_ge0 // ?ler0n // Re_half_anglec.
by rewrite mulrC (mulrC (1 - complex.Re x)) -mulrDr addrCA addrK -mulr2n mulVr ?pnatf_unit // sqrtr1.
Qed.

Definition half_angle (x : angle T) := Angle (norm_half_anglec (normr_expi x)).

Lemma half_angle0 : half_angle 0 = 0.
Proof.
apply val_inj => /=; rewrite /half_anglec; case: ifPn => /=; rewrite expi0 /=.
2: by rewrite lexx.
move=> _; rewrite subrr mul0r sqrtr0 divrr ?unitfE // ?complexr0 ?sqrtr1 //.
by rewrite (_ : 1 + 1 = 2%:R) // pnatr_eq0.
Qed.

Lemma half_anglepi : half_angle pi = pihalf T.
Proof.
apply val_inj => /=; rewrite /half_anglec; case: ifPn => /=; rewrite expipi /= oppr0.
2: by rewrite lexx.
move=> _; rewrite subrr mul0r sqrtr0 opprK expi_pihalf.
rewrite (_ : 1 + 1 = 2%:R) // ?pnatr_eq0 divrr ?unitfE ?pnatr_eq0 //.
by rewrite sqrtr1.
Qed.

Lemma sin_half_angle_ge0 a : 0 <= sin (half_angle a).
Proof.
case: a => -[a b] /= ab.
rewrite /sin /= /half_anglec /=; case: ifPn => b0 /=; by rewrite sqrtr_ge0.
Qed.

Lemma halfP a : half_angle a + half_angle a = a.
Proof.
apply/eqP.
rewrite eq_angle; apply/andP; split.
  rewrite /cos /= add_angleE /add_angle /half_angle /= argK; last first.
    by rewrite normrM (eqP (norm_half_anglec (normr_expi _))) mulr1.
  rewrite /half_anglec. simpc. rewrite /=.
  move=> [:tmp].
  case: ifP => a0 /=.
    abstract: tmp.
    rewrite -2!expr2 sqr_sqrtr; last first.
      by rewrite divr_ge0 // ?Re_half_anglec // ?normr_expi // ler0n.
    rewrite sqr_sqrtr; last first.
      by rewrite divr_ge0 // ?ler0n // subr_ge0 Im_half_anglec // normr_expi.
    rewrite mulrC (mulrC (_ - _)) -mulrBr opprB addrC addrA subrK -mulr2n.
    by rewrite -(mulr_natl (complex.Re _)) mulrA mulVr ?pnatf_unit // mul1r eqxx.
  rewrite mulNr mulrN opprK; exact: tmp.
rewrite /sin /= add_angleE /add_angle /half_angle /= argK; last first.
  by rewrite normrM (eqP (norm_half_anglec (normr_expi _))) mulr1.
rewrite /half_anglec. simpc. rewrite /=.
case: ifPn => a0 /=.
  rewrite mulrC -mulr2n -mulr_natl sqrtrM; last by rewrite subr_ge0 Im_half_anglec // normr_expi.
  rewrite mulrAC sqrtrM; last by rewrite Re_half_anglec // normr_expi.
  rewrite -!mulrA -sqrtrM; last by rewrite invr_ge0 ler0n.
  rewrite -expr2 sqrtr_sqr !mulrA mulrC normrV ?unitfE ?pnatr_eq0 //.
  rewrite normr_nat !mulrA mulVr ?mul1r ?unitfE ?pnatr_eq0 //.
  rewrite -sqrtrM; last by rewrite subr_ge0 Im_half_anglec // normr_expi.
  rewrite -subr_sqr expr1n.
  rewrite -(@eqr_expn2 _ 2%N) //; last by rewrite sqrtr_ge0.
  by rewrite -sin2cos2 sqr_sqrtr // sqr_ge0.
rewrite mulrN mulNr -opprB opprK eqr_oppLR.
rewrite mulrC -mulr2n -mulr_natl sqrtrM; last by rewrite Re_half_anglec // normr_expi.
rewrite mulrAC sqrtrM; last by rewrite subr_ge0 Im_half_anglec // normr_expi.
rewrite -!mulrA -sqrtrM; last by rewrite invr_ge0 ler0n.
rewrite -expr2 sqrtr_sqr !mulrA mulrC normrV ?unitfE ?pnatr_eq0 //.
rewrite normr_nat !mulrA mulVr ?mul1r ?unitfE ?pnatr_eq0 //.
rewrite -sqrtrM; last by rewrite Re_half_anglec // normr_expi.
rewrite mulrC -subr_sqr expr1n.
rewrite -(@eqr_expn2 _ 2%N) //; last 2 first.
  by rewrite sqrtr_ge0.
  by rewrite ltW // oppr_gt0 ltNge.
by rewrite -sin2cos2 sqrrN sqr_sqrtr // sqr_ge0.
Qed.

Lemma pihalf_is_half : pihalf _ = half_angle pi.
Proof.
rewrite /half_angle; apply val_inj => /=.
rewrite /half_anglec expipi /= oppr0 lexx subrr mul0r sqrtr0 opprK.
by rewrite -(@natrD _ 1 1) divrr ?unitfE ?pnatr_eq0 // sqrtr1 expi_pihalf.
Qed.

Lemma pi_pihalf : pi = pihalf T *+ 2.
Proof. by rewrite -[LHS]halfP pihalf_is_half -mulr2n. Qed.

Lemma piquarter_is_half : piquarter _ = half_angle (pihalf _).
Proof.
rewrite /half_angle; apply val_inj => /=.
by rewrite /half_anglec expi_pihalf /= ler01 addr0 subr0 div1r expi_piquarter.
Qed.

Lemma pi_piquarter : pi = piquarter T *+ 4.
Proof.
rewrite (mulrnA _ 2 2) -[LHS]halfP -mulr2n; congr (_ *+ 2).
by rewrite piquarter_is_half mulr2n halfP pihalf_is_half.
Qed.

Lemma sin_half_angle a : `| sin (half_angle a) | = Num.sqrt ((1 - cos a) / 2%:R).
Proof.
move: (cosD (half_angle a) (half_angle a)).
rewrite halfP -2!expr2 cos2sin2 -addrA -opprD -mulr2n => /eqP.
rewrite eq_sym subr_eq addrC -subr_eq eq_sym => /eqP/(congr1 (fun x => x / 2%:R)).
rewrite -mulr_natl mulrC mulrA mulVr ?unitfE ?pnatr_eq0 // mul1r.
by move/(congr1 Num.sqrt); rewrite sqrtr_sqr.
Qed.

Lemma cos_half_angle a : `| cos (half_angle a) | = Num.sqrt ((1 + cos a) / 2%:R).
Proof.
move: (cosD (half_angle a) (half_angle a)).
rewrite halfP -2!expr2 sin2cos2 opprB addrA -mulr2n => /eqP.
rewrite eq_sym subr_eq addrC => /eqP/(congr1 (fun x => x / 2%:R)).
rewrite -mulr_natl mulrC mulrA mulVr ?unitfE ?pnatr_eq0 // mul1r.
by move/(congr1 Num.sqrt); rewrite sqrtr_sqr.
Qed.

Lemma tan_half_angle a : tan (half_angle a) = (1 - cos a) / sin a.
Proof.
rewrite /tan.
move: (sin_half_angle a) => H1.
move: (cos_half_angle a) => H2.
have H3 : cos a <= 1 by move: (@ler_norml _ (cos a) 1); rewrite cos_max => /esym/andP[].
have H4 : -1 <= cos a by move: (@ler_norml _ (cos a) 1); rewrite cos_max => /esym/andP[].
move: (sin_half_angle_ge0 a) => sa0.
move: H1; rewrite ger0_norm // => ->.
rewrite sqrtrM; last by rewrite subr_ge0.
case: (lerP 0 (cos (half_angle a))) => ca0.
  move: H2; rewrite ger0_norm // => ->.
  rewrite sqrtrM; last by rewrite -ler_sub_addl add0r.
  rewrite -mulf_div divrr ?unitfE ?sqrtr_eq0 -?ltNge ?invr_gt0 ?ltr0Sn // mulr1.
  case/boolP : (cos a == 1) => [/eqP ca1|ca1]; first by rewrite ca1 subrr sqrtr0 2!mul0r.
  rewrite -[LHS]mulr1 -{3}(@divrr _ (Num.sqrt (1 - cos a))); last first.
    by rewrite unitfE sqrtr_eq0 -ltNge subr_gt0 lt_neqAle ca1.
  rewrite mulf_div -sqrtrM; last by rewrite subr_ge0.
  rewrite -expr2 -sqrtrM; last by rewrite -ler_sub_addl add0r.
  rewrite (mulrC (1 + cos a)) -subr_sqr expr1n.
  rewrite sqrtr_sqr -sin2cos2 sqrtr_sqr.
  rewrite ger0_norm; last by rewrite subr_ge0.
  rewrite ger0_norm // -(halfP a) sinD mulrC -mulr2n -mulr_natl.
  by rewrite mulr_ge0 // ?ler0n // mulr_ge0.
move: (cos_half_angle a).
rewrite ltr0_norm // => /eqP.
rewrite eqr_oppLR => /eqP ->.
rewrite invrN mulrN sqrtrM; last by rewrite -ler_sub_addl add0r.
rewrite -mulf_div divrr ?unitfE ?sqrtr_eq0 -?ltNge ?invr_gt0 ?ltr0Sn // mulr1.
case/boolP : (cos a == 1) => [/eqP ca1|ca1]; first by rewrite ca1 subrr sqrtr0 2!mul0r oppr0.
rewrite -[LHS]mulr1 -{3}(@divrr _ (Num.sqrt (1 - cos a))); last first.
  by rewrite unitfE sqrtr_eq0 -ltNge subr_gt0 lt_neqAle ca1.
rewrite mulNr mulf_div -sqrtrM; last by rewrite subr_ge0.
rewrite -expr2 -sqrtrM; last by rewrite -ler_sub_addl add0r.
rewrite (mulrC (1 + cos a)) -subr_sqr expr1n.
rewrite sqrtr_sqr -sin2cos2 sqrtr_sqr.
rewrite ger0_norm; last by rewrite subr_ge0.
rewrite ler0_norm //; last first.
  by rewrite -(halfP a) sinD mulrC -mulr2n -mulr_natl pmulr_rle0 ?ltr0n // nmulr_rle0.
by rewrite invrN mulrN opprK.
Qed.

Lemma tan_half_angle' a : tan (half_angle a) = sin a / (1 + cos a).
Proof.
case/boolP : (cos a == 1) => [/eqP /cos1_angle0 ->|ca1].
  by rewrite sin0 mul0r /tan half_angle0 sin0 mul0r.
case/boolP : (a == pi) => [/eqP|] api.
  by rewrite api sinpi mul0r half_anglepi tan_pihalf.
rewrite -[RHS]mulr1 -{2}(@divrr _ (1 - cos a)); last by rewrite unitfE subr_eq0 eq_sym.
rewrite mulf_div (mulrC (1 + cos a)) -subr_sqr expr1n -sin2cos2 expr2.
rewrite -mulf_div divrr ?mul1r ?tan_half_angle //.
rewrite unitfE.
apply: contra ca1 => /eqP/sin0_inv[->|/eqP]; first by rewrite cos0.
by rewrite (negbTE api).
Qed.

End half_angle.

Lemma atan2_N1N1 (T : rcfType) : atan2 (- 1) (- 1) = - piquarter T *+ 3.
Proof.
rewrite /atan2 ltr0N1 ltrN10 ler0N1 divrr; last first.
  by rewrite unitfE eqr_oppLR oppr0 oner_neq0.
rewrite atan1 pi_piquarter -opprB -{2}(mulr1n (piquarter T)).
by rewrite -mulrnBr // mulNrn.
Qed.

Section properties_of_atan2.

Variables (T : rcfType).

Lemma sqrtr_sqrN2 (x : T) : x != 0 -> Num.sqrt (x ^- 2) = `|x|^-1.
Proof.
move=> x0.
apply (@mulrI _ `|x|); first by rewrite unitfE normr_eq0.
rewrite -{1}(sqrtr_sqr x) -sqrtrM ?sqr_ge0 // divrr; last by rewrite unitfE normr_eq0.
by rewrite divrr ?sqrtr1 // unitfE sqrf_eq0.
Qed.

Lemma sqrtr_1sqr2 (x y : T) : Num.sqrt (x ^+ 2 + y ^+ 2) = 1 -> x != 0 ->
  Num.sqrt (1 + (y / x) ^+ 2) = `|x|^-1.
Proof.
move=> u1 k0.
rewrite exprMn exprVn -(@divrr _ (x ^+ 2)) ?unitfE ?sqrf_eq0 //.
by rewrite -mulrDl sqrtrM ?u1 ?mul1r ?sqrtr_sqrN2 // addr_ge0// sqr_ge0.
Qed.

Lemma N1x2_gt0 (x : T) : `| x | < 1 -> 0 < 1 - x ^+ 2.
Proof. move=> x1; by rewrite subr_gt0 -sqr_normr expr_lt1. Qed.

Definition yarc (x : T) := Num.sqrt (1 - x ^+ 2).

Lemma yarc0 : yarc 0 = 1.
Proof. by rewrite /yarc expr0n subr0 sqrtr1. Qed.

Lemma yarc1 x : `| x | = 1 -> yarc x = 0.
Proof. by move/eqP; rewrite -sqr_norm_eq1 /yarc => /eqP ->; rewrite subrr sqrtr0. Qed.

Lemma yarc_neq0 (x : T) : `| x | < 1 -> yarc x != 0.
Proof. by move=> x1; rewrite sqrtr_eq0 -ltNge N1x2_gt0. Qed.

Lemma yarc_gt0 (x : T) : `| x | < 1 -> 0 < yarc x.
Proof. by move=> x1; rewrite lt_neqAle sqrtr_ge0 andbT eq_sym yarc_neq0. Qed.

Lemma sqr_yarc (x : T) : `| x | < 1 -> (yarc x) ^+ 2 = 1 - x ^+ 2.
Proof. move=> x1; by rewrite /yarc sqr_sqrtr // ltW // N1x2_gt0. Qed.

Lemma yarc_sin (x : angle T) : yarc (sin x) = `| cos x |.
Proof. by rewrite /yarc -cos2sin2 sqrtr_sqr. Qed.

Lemma inv_yarc (x : T) : `| x | < 1 -> (yarc x)^-1 = Num.sqrt (1 - x ^+ 2)^-1.
Proof.
move=> x1.
apply (@mulrI _ (yarc x)); first by rewrite unitfE yarc_neq0.
rewrite divrr; last by rewrite unitfE yarc_neq0.
rewrite -sqrtrM; last by rewrite ltW // N1x2_gt0.
by rewrite divrr ?sqrtr1 // unitfE gt_eqF // N1x2_gt0.
Qed.

Lemma inv_yarc_gt0 (x : T) : `| x | < 1 -> 0 < (yarc x)^-1.
Proof. move=> x1; by rewrite inv_yarc // sqrtr_gt0 invr_gt0 N1x2_gt0. Qed.

Lemma atan2_x_gt0E (x y : T) : y > 0 -> atan2 x y = atan (x / y).
Proof. move=> y0; by rewrite /atan2 y0. Qed.

Lemma atan2_ge0_lt0E (x y : T) : x >= 0 -> y < 0 -> atan2 x y = atan (x / y) + pi.
Proof. move=> x0 y0; by rewrite /atan2 x0 y0 ltNge ltW. Qed.

Lemma atan2_lt0_lt0E (x y : T) : x < 0 -> y < 0 -> atan2 x y = atan (x / y) - pi.
Proof. move=> x0 y0; by rewrite /atan2 x0 y0 ltNge ltW //= leNgt x0. Qed.

Lemma atan2_gt0_0E (x : T) : x > 0 -> atan2 x 0 = pihalf _.
Proof. by move=> x0; rewrite /atan2 x0 ltxx. Qed.

Lemma atan2_lt0_0E (x : T) : x < 0 -> atan2 x 0 = - pihalf _.
Proof. move=> x0; by rewrite /atan2 ltxx ltNge ltW //= x0. Qed.

Lemma cos_atan2 (x y : T) : y != 0 -> cos (atan2 x y) = y / Num.sqrt (y ^+ 2 + x ^+ 2).
Proof.
rewrite neq_lt => /orP[] y0.
  move=> [:H].
  case: (lerP 0 x) => x0.
    rewrite atan2_ge0_lt0E // cosDpi ?eqxx // cos_atan mul1r expr_div_n.
    abstract: H.
    rewrite -{1}(@divrr _ (y ^+ 2)); last by rewrite unitfE sqrf_eq0 lt_eqF.
    rewrite -mulrDl sqrtrM; last by rewrite addr_ge0 // sqr_ge0.
    rewrite sqrtr_sqrN2 ?lt_eqF // ltr0_norm // invrM; last 2 first.
      by rewrite unitfE sqrtr_eq0 -ltNge ltr_paddr // ?sqr_ge0 // exprn_even_gt0 // orbC lt_eqF.
      by rewrite unitfE invr_eq0 eqr_oppLR oppr0 lt_eqF.
    by rewrite !invrN invrK mulNr opprK.
  rewrite atan2_lt0_lt0E // -piNpi cosDpi ?eqxx ?orbT // cos_atan mul1r expr_div_n.
  exact: H.
rewrite {1}atan2_x_gt0E // cos_atan mul1r.
rewrite -{1}(@divrr _ (y ^+ 2)); last by rewrite unitfE sqrf_eq0 gt_eqF.
rewrite expr_div_n -mulrDl sqrtrM; last by rewrite addr_ge0 // sqr_ge0.
rewrite sqrtr_sqrN2 ?gt_eqF // gtr0_norm // invrM ?invrK //.
by rewrite unitfE sqrtr_eq0 -ltNge ltr_paddr // ?sqr_ge0 // exprn_gt0.
by rewrite unitfE invr_neq0 // gt_eqF.
Qed.

Lemma cos_atan2_xyarc (x : T) : `| x | < 1 -> cos (atan2 (- x) (yarc x)) = yarc x.
Proof.
move=> x1; by rewrite cos_atan2 ?yarc_neq0 // sqr_yarc // sqrrN subrK sqrtr1 divr1.
Qed.

Lemma cos_atan2_yarcx (x : T) : `| x | < 1 -> cos (atan2 (yarc x) x) = x.
Proof.
move=> x1.
have [/eqP x0|x0] := boolP (x == 0).
  rewrite x0 yarc0.
  by rewrite /atan2 ltxx ltr01 cos_pihalf.
rewrite cos_atan2 //.
by rewrite sqr_yarc // addrCA subrr addr0 sqrtr1 divr1.
Qed.

Lemma sin_atan2 (x y : T) : y != 0 -> sin (atan2 x y) = x / Num.sqrt (y ^+ 2 + x ^+ 2).
Proof.
rewrite neq_lt => /orP[] y0.
  move=> [:H].
  case: (lerP 0 x) => x0.
    rewrite atan2_ge0_lt0E // sinDpi ?eqxx // sin_atan expr_div_n.
    abstract: H.
    rewrite -{1}(@divrr _ (y ^+ 2)); last by rewrite unitfE sqrf_eq0 lt_eqF.
    rewrite -mulrDl sqrtrM; last by rewrite addr_ge0 // sqr_ge0.
    rewrite sqrtr_sqrN2 ?lt_eqF // ltr0_norm // invrM; last 2 first.
      by rewrite unitfE sqrtr_eq0 -ltNge ltr_paddr // ?sqr_ge0 // exprn_even_gt0 // orbC lt_eqF.
      by rewrite unitfE invr_eq0 eqr_oppLR oppr0 lt_eqF.
    rewrite !invrN invrK mulNr mulrN opprK -mulrA (mulrA _^-1) mulVr ?mul1r //.
    by rewrite unitfE lt_eqF.
  rewrite atan2_lt0_lt0E // -piNpi sinDpi ?eqxx ?orbT // sin_atan expr_div_n.
  exact: H.
rewrite {1}atan2_x_gt0E // sin_atan.
rewrite -{1}(@divrr _ (y ^+ 2)); last by rewrite unitfE sqrf_eq0 gt_eqF.
rewrite expr_div_n -mulrDl sqrtrM; last by rewrite addr_ge0 // sqr_ge0.
rewrite sqrtr_sqrN2 ?gt_eqF // gtr0_norm // invrM; last 2 first.
  by rewrite unitfE sqrtr_eq0 -ltNge ltr_paddr // ?sqr_ge0 // exprn_gt0.
  by rewrite unitfE invr_neq0 // gt_eqF.
rewrite invrK -(mulrA x) (mulrA _^-1) mulVr ?mul1r //.
by rewrite unitfE gt_eqF.
Qed.

Lemma sin_atan20x (x : T) : sin (atan2 0 x) = 0.
Proof.
have [/eqP ->|x0] := boolP (x == 0); first by rewrite atan200 sin0.
by rewrite sin_atan2 // mul0r.
Qed.

Lemma sin_atan2_0 (x : T) : sin (atan2 x 0) = Num.sg x.
Proof.
rewrite /atan2 ltxx; case: ifPn => [x0|]; first by rewrite sin_pihalf gtr0_sg.
rewrite -leNgt le_eqVlt => /orP[/eqP ->| x0]; first by rewrite ltxx sin0 sgr0.
by rewrite x0 sinN sin_pihalf ltr0_sg.
Qed.

Lemma sin_atan2_xyarc (x : T) : `| x | < 1 -> sin (atan2 x (yarc x)) = x.
Proof.
move=> x1; by rewrite sin_atan2 ?yarc_neq0 // sqr_yarc // subrK sqrtr1 divr1.
Qed.

Lemma sin_atan2_yarcx (x : T) : `| x | < 1 -> sin (atan2 (yarc x) x) = yarc x.
Proof.
move=> x1.
have [/eqP x0|x0] := boolP (x == 0).
  rewrite x0 yarc0.
  by rewrite /atan2 ltxx ltr01 sin_pihalf.
rewrite sin_atan2 //.
by rewrite sqr_yarc // addrCA subrr addr0 sqrtr1 divr1.
Qed.

Lemma cos_atan2_0 (x : T) : cos (atan2 x 0) = (x == 0)%:R.
Proof.
rewrite /atan2 ltxx; case: ifPn => [x0|]; first by rewrite cos_pihalf gt_eqF.
rewrite -leNgt le_eqVlt => /orP[/eqP ->| x0]; first by rewrite ltxx cos0 eqxx.
by rewrite x0 cosN cos_pihalf lt_eqF.
Qed.

End properties_of_atan2.

Section derived_trigonometric_functions.

Variable T : rcfType.
Implicit Types a : angle T.

Definition cot a := (tan a)^-1.

Lemma cot_pihalf : cot (pihalf T) = 0.
Proof. by rewrite /cot tan_pihalf invr0. Qed.

Lemma cot_half_angle a : cot (half_angle a) = sin a / (1 - cos a).
Proof. by rewrite /cot tan_half_angle invf_div. Qed.

Lemma cot_half_angle' a : cot (half_angle a) = (1 + cos a) / sin a.
Proof. by rewrite /cot tan_half_angle' invf_div. Qed.

Definition sec a := (cos a)^-1.

Lemma secpi : sec pi = -1.
Proof. by rewrite /sec cospi invrN invr1. Qed.

End derived_trigonometric_functions.


Require Import List.
Import ListNotations.
Require Import Coq.Lists.ListSet.
Require Import Arith.
Require Import Omega.
Require Import Unify.

Inductive goal : Set :=
| Fail     : goal
| Cut      : goal                     (* for SLD semantics only, in others is treated as 'success' *)
| Unify    : term -> term -> goal
| Disunify : term -> term -> goal
| Disj     : goal -> goal -> goal
| Conj     : goal -> goal -> goal
| Fresh    : (name -> goal) -> goal
| Invoke   : name -> term -> goal.

(* rel is a body of a relational symbol *)
Definition rel : Set := term -> goal.

Inductive is_fv_of_goal (n : name) : goal -> Prop :=
| fvUnifyL : forall t1 t2 (IN_FV : In n (fv_term t1)),
                          is_fv_of_goal n (Unify t1 t2)
| fvUnifyR : forall t1 t2 (IN_FV : In n (fv_term t2)),
                          is_fv_of_goal n (Unify t1 t2)
| fvDisunifyL : forall t1 t2 (IN_FV : In n (fv_term t1)),
                             is_fv_of_goal n (Disunify t1 t2)
| fvDisunifyR : forall t1 t2 (IN_FV : In n (fv_term t2)),
                             is_fv_of_goal n (Disunify t1 t2)
| fvDisjL  : forall g1 g2 (IS_FV : is_fv_of_goal n g1),
                          is_fv_of_goal n (Disj g1 g2)
| fvDisjR  : forall g1 g2 (IS_FV : is_fv_of_goal n g2),
                          is_fv_of_goal n (Disj g1 g2)
| fvConjL  : forall g1 g2 (IS_FV : is_fv_of_goal n g1),
                          is_fv_of_goal n (Conj g1 g2)
| fvConjR  : forall g1 g2 (IS_FV : is_fv_of_goal n g2),
                          is_fv_of_goal n (Conj g1 g2)
| fvFresh  : forall fg n' (NEQ : n' <> n)
                          (IS_FV : is_fv_of_goal n (fg n')),
                          is_fv_of_goal n (Fresh fg)
| fvInvoke : forall r arg (IN_FV : In n (fv_term arg)),
                          is_fv_of_goal n (Invoke r arg).

Hint Constructors is_fv_of_goal.

Definition closed_goal_in_context (c : list name) (g : goal) : Prop :=
  forall n, is_fv_of_goal n g -> In n c.

Definition closed_goal : goal -> Prop := closed_goal_in_context [].

Definition closed_rel (r : rel) : Prop :=
  forall (arg : term), closed_goal_in_context (fv_term arg) (r arg).

(* Some checks *)
Module SmokeTest.

  Definition g0 : goal := Fresh (fun x => Unify (Var x) (Cst 2)).
  Definition g1 : goal := Fresh (fun x => Fresh (fun y => Unify (Var x) (Var y))).

  Lemma g0_closed : closed_goal g0.
  Proof.
    red. red. intros. inversion H. inversion IS_FV.
    { simpl in IN_FV. destruct IN_FV; contradiction. }
    { inversion IN_FV. }
  Qed.

  Lemma g1_closed : closed_goal g1.
  Proof.
    red. red. intros. inversion H. inversion IS_FV.
    inversion IS_FV0; inversion IN_FV; contradiction.
  Qed.

  Definition r0 : rel := (fun t => Fresh (fun x => Fresh (fun y =>
      Conj (Unify t (Con 0 (Var x) (Var y))) (Unify (Var x) (Var y))))).
  Definition r1 : rel := (fun t => Fresh (fun x => Unify (Var 0) t)).

  Lemma r0_closed : closed_rel r0.
  Proof.
    red. red. intros. inversion H. inversion IS_FV.
    inversion IS_FV0.
    { inversion IS_FV; auto. inversion IS_FV2; inversion IS_FV3.
      { auto. }
      { simpl in IN_FV. destruct (name_eq_dec n'1 n').
        { inversion IN_FV; contradiction. }
        { inversion IN_FV; try contradiction. inversion H0; contradiction. } }
      { inversion IN_FV; contradiction. }
      { inversion IN_FV; contradiction. } }
    { inversion IS_FV1; inversion IN_FV; contradiction. }
  Qed.

  Lemma r1_non_closed : ~ closed_rel r1.
  Proof.
    intro C. red in C. red in C.
    specialize (C (Cst 0) 0). apply C.
    unfold r1. apply fvFresh with 1.
    { omega. }
    { constructor. left. auto. }
  Qed.

End SmokeTest.

(* Weak version of a variable renaming *)
Inductive renaming (old_x : name) (new_x : name) : goal -> goal -> Prop :=
| rFail : renaming old_x new_x Fail Fail
| rCut  : renaming old_x new_x Cut Cut
| rUnify : forall t1 t2, renaming old_x new_x (Unify t1 t2)
                                              (Unify (apply_subst [(old_x, Var new_x)] t1)
                                                     (apply_subst [(old_x, Var new_x)] t2))
| rDisunify : forall t1 t2, renaming old_x new_x (Disunify t1 t2)
                                                 (Disunify (apply_subst [(old_x, Var new_x)] t1)
                                                           (apply_subst [(old_x, Var new_x)] t2))
| rDisj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1)
                               (R_G2 : renaming old_x new_x g2 rg2),
                               renaming old_x new_x (Disj g1 g2) (Disj rg1 rg2)
| rConj : forall g1 g2 rg1 rg2 (R_G1 : renaming old_x new_x g1 rg1)
                               (R_G2 : renaming old_x new_x g2 rg2),
                               renaming old_x new_x (Conj g1 g2) (Conj rg1 rg2)
| rFreshNFV : forall fg (OLD_X_NOT_FV : ~ is_fv_of_goal old_x (Fresh fg)),
                        renaming old_x new_x (Fresh fg) (Fresh fg)
| rFreshFV : forall fg rfg (OLD_X_FV : is_fv_of_goal old_x (Fresh fg))
                           (R_FG : forall y (Y_NOT_FV : ~ is_fv_of_goal y (Fresh fg)),
                                            renaming old_x new_x (fg y) (rfg y)),
                           renaming old_x new_x (Fresh fg) (Fresh rfg)
| rInvoke : forall r arg, renaming old_x new_x (Invoke r arg)
                                               (Invoke r (apply_subst [(old_x, Var new_x)] arg)).

Hint Constructors renaming.

Definition consistent_binding (b : name -> goal) : Prop :=
  forall x y, (~ is_fv_of_goal x (Fresh b)) -> renaming x y (b x) (b y).

Inductive consistent_goal : goal -> Prop :=
| cgFail   : consistent_goal Fail
| cgCut    : consistent_goal Cut
| cgUnify  : forall t1 t2, consistent_goal (Unify t1 t2)
| cgDisunify  : forall t1 t2, consistent_goal (Disunify t1 t2)
| cgDisj   : forall g1 g2 (CG_G1 : consistent_goal g1)
                          (CG_G2 : consistent_goal g2),
                          consistent_goal (Disj g1 g2)
| cgConj   : forall g1 g2 (CG_G1 : consistent_goal g1)
                          (CG_G2 : consistent_goal g2),
                          consistent_goal (Conj g1 g2)
| cgFresh  : forall fg (CB_FG : consistent_binding fg)
                       (CG_BODY : forall n, consistent_goal (fg n)),
                       consistent_goal (Fresh fg)
| cgInvoke : forall r arg, consistent_goal (Invoke r arg).

Hint Constructors consistent_goal.

Definition consistent_function (f : term -> goal) : Prop :=
  forall a1 a2 t, renaming a1 a2 (f t) (f (apply_subst [(a1, Var a2)] t)).

Definition consistent_rel (r : rel) : Prop :=
  forall (arg : term), consistent_goal (r arg) /\ consistent_function r.

Definition def : Set := {r : rel | closed_rel r /\ consistent_rel r}.

Definition spec : Set := name -> def.

Variable Prog : spec.


(* Definition of category of representations of a signature.
Not using displayed categories par flemme de définir les morphismes de signatures

 *)
(*

A signature is just a family of arities.
In the end, we would like to prove that any presentable signature is representable.
That is: let (O, (α_o, Θ^(n))_o) be a presentable signature (α_o is presentable
in the old sense and n is a natural number). Then there is an initial representation.

The plan is:
1) show that the category of representation of this signature
  is equivalent to the category of representation of the following raw signature
  (O, (α_o × Θ^n,Θ))
2) show that the category of representations of a signature (O, (β_o, Θ)) is
  equivalent to the category of representation of ∐ β_o
3) show that the the epis |Σ_o| -> β_o gather into an epi ∐ |Σ_o| → ∐ β_o
4) use the representability result for presentable half-arities.

Step 2) implies show that the category of half-arities have
arbitrary coproducts

This looks like quite a load of work. I wonder if it is really needed to formalize
all these steps, or just the first one, even for a signature with a single arity.
What do you think ?

*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Categories.
Require Import UniMath.CategoryTheory.functor_categories.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

Require Import Modules.Signatures.aritiesalt.
Require Import Modules.Signatures.FullSignatures.

Definition signature C := ∑ (O : hSet), O -> FullArity C.

Definition base_of_sig {C} (S : signature C) : hSet := pr1 S.
Local Notation O := base_of_sig.

Definition ar_of_sig {C} {S : signature C} : O S -> FullArity C := pr2 S.
Local Notation α := ar_of_sig.

(** A representation of a signature is a representation of each of its component *)
Definition rep_sig {C} (S : signature C) :=
  ∑ R : Monad C, ∏ (o : O S), LModule_Mor R (dom (α o) R) (codom (α o) R).

Coercion Monad_from_rep_sig {C} {S : signature C} (X : rep_sig S) : Monad C := pr1 X.

Definition rep_sig_τ {C} {S : signature C} {X : rep_sig S} : ∏ (o : O S), _ := pr2 X.

Definition rep_ar_from_sig {C} {S : signature C} (X : rep_sig S) (o : O S) :
  rep_ar _ (α o) := (Monad_from_rep_sig X) ,, rep_sig_τ o.

(* Definition of a morphism of representations of a signature, using the existing
definitino about arities *)
Definition rep_a_sig_mor {C} {S : signature C } (M N : rep_sig S) :=
  ∑ g:Monad_Mor M N, ∏ (o : O S) , rep_ar_mor_law C (rep_ar_from_sig M o)
                                                  (rep_ar_from_sig N o) (identity _) g.

Coercion monad_morphism_from_rep_a_sig_mor {C} {S : signature C } {M N : rep_sig S}
         (X : rep_a_sig_mor M N) : Monad_Mor M N := pr1 X.

Definition rep_a_sig_mor_ax  {C} {S : signature C } {M N : rep_sig S}
           (X : rep_a_sig_mor M N) := pr2 X.

Definition rep_ar_mor_from_sig {C} {S : signature C } {M N : rep_sig S}
         (X : rep_a_sig_mor M N) (o : O S) : rep_ar_mor_mor C (rep_ar_from_sig M o)
                                                            (rep_ar_from_sig N o)
                                                            (identity _) :=

  (X : Monad_Mor _ _),, rep_a_sig_mor_ax X o.

Lemma isaset_rep_a_sig_mor {C} {S : signature C } (M : rep_sig S) (N : rep_sig S)  :
  isaset (rep_a_sig_mor  M N ).
Proof.
  intros.
  apply isaset_total2 .
  - apply has_homsets_Monad.
  - intros.
    apply isasetaprop.
    apply impred_isaprop.
    intros ?.
    apply isaprop_rep_ar_mor_law.
Qed.

Lemma rep_sig_mor_mor_equiv {C} (S : signature C) (A B:rep_sig S)
       (f g :rep_a_sig_mor A B) :
  (∏ c, ((f : Monad_Mor _ _):nat_trans _ _) c = (g : Monad_Mor _ _) c) -> f = g.
Proof.
  intros.
  use (invmap (subtypeInjectivity _ _ _ _  )).
  - intros ?.
    apply impred_isaprop.
    intros ?.
    apply isaprop_rep_ar_mor_law.
  - use (invmap (Monad_Mor_equiv _ _  _  )).
     +  apply homset_property.
     +  apply nat_trans_eq.
        apply homset_property.
        assumption.
Qed.

Definition rep_sig_ob_mor {C} (S : signature C) : precategory_ob_mor :=
  precategory_ob_mor_pair (rep_sig S) (rep_a_sig_mor (S := S)).

Open Scope cat.

Definition rep_sig_id  {C} {S : signature C}  (R : rep_sig S) :
  rep_a_sig_mor R R.
Proof.
  exists (Monad_identity _).
  intro o.
  apply rep_id_law.
Defined.

Lemma rep_sig_comp_law  {C} {S : signature C}  {X Y Z : rep_sig S}
           (f : rep_a_sig_mor X Y) (g : rep_a_sig_mor Y Z) :
  ∏ o : O S, rep_ar_mor_law C (rep_ar_from_sig X o) (rep_ar_from_sig Z o)
                            (identity (α o)) (compose (C:=category_Monad C) (f : Monad_Mor _ _) (g : Monad_Mor _ _)).
Proof.
  intro o.
  assert (h := rep_comp_law _ _ _ _ (identity (α o)) (identity (α o))
                            (rep_ar_from_sig X o)
                            (rep_ar_from_sig Y o)
                            (rep_ar_from_sig Z o)
                            (rep_ar_mor_from_sig f o)
                            (rep_ar_mor_from_sig g o)
         ).
  rewrite id_left in h.
  exact h.
Qed.

Definition rep_sig_comp  {C} {S : signature C}  {X Y Z : rep_sig S}
           (f : rep_a_sig_mor X Y) (g : rep_a_sig_mor Y Z) :
  rep_a_sig_mor X Z :=
  (compose (C:=category_Monad C) (f : Monad_Mor _ _) (g : Monad_Mor _ _))
    ,, ( rep_sig_comp_law f g).

Definition rep_sig_precat_data {C} (S: signature C) : precategory_data :=
  precategory_data_pair (rep_sig_ob_mor S) rep_sig_id (λ a b c : rep_sig_ob_mor S, rep_sig_comp).

Lemma rep_sig_is_precat {C} (S : signature C)  : is_precategory
                                                   (rep_sig_precat_data S).
Proof.
  use make_is_precategory_one_assoc.
  - intros a b f.
(*  We don't need the pointwise version actually but who cares *)
    apply rep_sig_mor_mor_equiv.
    intro c.
    apply id_left.
  - intros a b f.
    apply rep_sig_mor_mor_equiv.
    intro c.
    apply id_right.
  - intros.
    apply rep_sig_mor_mor_equiv.
    intros ?.
    apply assoc.
Qed.

Definition precategory_rep_sig {C} (S : signature C) :=
  make_precategory _ (rep_sig_is_precat S).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_betweennotequal_1 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_inequalitysymmetric_2 : (forall A B : Universe, (A <> B -> B <> A)).
Variable defcollinear_3 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_4 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_5 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_6 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_7 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_8 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_9 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_10 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable lemma_collinear4_11 : (forall A B C D : Universe, ((col_ A B C /\ (col_ A B D /\ A <> B)) -> col_ B C D)).
Variable lemma_ray4_1_12 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_13 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_14 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable axiom_betweennesssymmetry_15 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defsupplement_16 : (forall A B C D F : Universe, (supp_ A B C D F -> (out_ B C D /\ betS_ A B F))).
Variable defsupplement2_17 : (forall A B C D F : Universe, ((out_ B C D /\ betS_ A B F) -> supp_ A B C D F)).
Variable lemma_ABCequalsCBA_18 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_supplements_19 : (forall A B C D F Xa Xb Xc Xd Xf : Universe, ((congA_ A B C Xa Xb Xc /\ (supp_ A B C D F /\ supp_ Xa Xb Xc Xd Xf)) -> congA_ D B F Xd Xb Xf)).
Variable lemma_equalanglestransitive_20 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_equalanglessymmetric_21 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).

Theorem proposition_15_22 : (forall A B C D E : Universe, ((betS_ A E B /\ (betS_ C E D /\ ~(col_ A E C))) -> (congA_ A E C D E B /\ congA_ C E B A E D))).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* An exercise to prove the security of the (academic version of) Dual_EC_DRBG.  Taken from http://eprint.iacr.org/2007/048. *)

Set Implicit Arguments.

Require Import FCF.
Require Import DiffieHellman.
Require Import RndNat.

Local Open Scope list_scope.
Local Open Scope group_scope.

(*
Section DLP.

  Context`{FCG : FiniteCyclicGroup}.
  Hypothesis group_eqd : EqDec GroupElement.

  Variable A : GroupElement -> Comp nat.

  Definition DLP_G :=
    x <-$ RndNat order;
    x' <-$ A (g ^ x);
    ret (eqb x x').

  Definition DLP_Advantage := Pr[DLP_G].

End DLP.
*)

(*
Section PRG.

  Variable D B : Set.
  Variable RndD : Comp D.
  Variable RndB : Comp B.
  Variable f : D -> (D * B).

  Variable A : (D * B) -> Comp bool.

  Definition PRG_G1 :=
    r <-$ RndD;
    g <-$ (A (f r));
    ret g.

  Definition PRG_G2 :=
    r <-$ RndD;
    b <-$ RndB;
    g <-$ (A (r, b));
    ret g.

  Definition PRG_Advantage := | (Pr[PRG_G1]) - (Pr[PRG_G2]) |.
End PRG.
*)

Section Dual_EC_DRBG.

  Context`{FCG : FiniteCyclicGroup}.
  Hypothesis eqd_GroupElement : EqDec GroupElement.

  Definition P := g.
  Variable x : GroupElement -> nat.
  Variable from_x : nat -> GroupElement.

  Definition DRBG(P Q : GroupElement)(t : nat) : (GroupElement * GroupElement ) :=
    let s :=  x (P ^ t) in
        (P ^ s, Q ^ t).

  Variable A : (GroupElement * GroupElement * GroupElement) -> Comp bool.

  Definition DRBG_GA Q :=
    seed <-$ RndNat order;
    [s1, v1] <-2 DRBG P Q seed;
    b <-$ A (Q, s1, v1);
    ret b.

  Definition DRBG_GB Q :=
    x2 <-$ RndNat order;
    x3 <-$ RndNat order;
    b <-$ A (Q, (P^x2), (P^x3));
    ret b.

  Definition DRBG_P (f : GroupElement -> Comp bool) :=
    x <-$ RndNat order;
    Q <- P ^ x;
    f Q.

  Definition G2 Q :=
    seed <-$ RndNat order;
    [s1, v1] <-2 (seed, Q ^ seed);
    b <-$ A (Q, (P ^ s1), v1);
    ret b.

  Definition xLogAdvantage := | Pr[DRBG_P DRBG_GA] - Pr[DRBG_P G2] |.

  Definition DRBG_Advantage := | Pr[DRBG_P DRBG_GA] - Pr[DRBG_P DRBG_GB] |.

  Theorem DRBG_P_DH : | Pr[DRBG_P G2] - Pr[DRBG_P DRBG_GB] | == @DDH_Advantage _ groupOp ident inverse _ g order A.

    unfold DDH_Advantage.
    unfold DRBG_P, DRBG_GB, G2, DDH0, DDH1.
    unfold P.
    eapply ratDistance_eqRat_compat.
    comp_skip.
    comp_skip.
    rewrite groupExp_mult.
    reflexivity.

    reflexivity.

  Qed.

  Theorem DRBG_P_secure :  | Pr[DRBG_P DRBG_GA] - Pr[DRBG_P DRBG_GB] | <= xLogAdvantage + @DDH_Advantage _ groupOp ident inverse _ g order A.

    eapply leRat_trans.
    eapply ratTriangleInequality.
    eapply ratAdd_leRat_compat.
    eapply eqRat_impl_leRat.
    eapply eqRat_refl.
    eapply eqRat_impl_leRat.
    eapply DRBG_P_DH.

  Qed.

  Section DRBG_S.

    Variable Q : GroupElement.

    Definition DRBG_S (f : GroupElement -> Comp bool) :=
      f Q.

    Theorem DRBG_S_DH : | Pr[DRBG_S G2] - Pr[DRBG_S DRBG_GB] | == @DDH_Advantage _ groupOp ident inverse _ g order A.

      unfold DDH_Advantage.
      unfold DRBG_S, DRBG_GB, G2, DDH0, DDH1.
      unfold P.
      eapply ratDistance_eqRat_compat.
      comp_irr_r.
      comp_skip.
      rewrite <- groupExp_mult.

    (* Now we are stuck: nothing leads to Q = G^x *)

    Abort.

  End DRBG_S.

End Dual_EC_DRBG.

Section Dual_EC_DRBG_V.

  Context`{FCG : FiniteCyclicGroup}.
  Hypothesis eqd_GroupElement : EqDec GroupElement.

  Variable x : GroupElement -> nat.
  Variable from_x : nat -> GroupElement.

  Variable Q : GroupElement.
  Variable z : nat.
  Hypothesis Q_eq_g_z : Q = g ^ z.

  Definition B (e: (GroupElement * GroupElement * GroupElement)) :=
    [a, b, c] <-3 e;
    g_seed <- c ^ modNatAddInverse z order;
    ret (eqb b (g ^ (x g_seed))).

  Theorem GA_always_true :
    Pr[(@DRBG_GA _ groupOp ident inverse _ g order x B Q)] == 1.

    unfold DRBG_GA, DRBG, P.
    subst.
    comp_irr_l.

  Abort.
    (*
    Not quite right.  We need to assume something about what the x function leaks about the point.
    In ECC, x leaks the x coordinate of the point.

    comp_simp.
    comp_irr_l.
    subst.
    unfold P.
    rewrite evalDist_ret_1.
    intuition.
    eapply eqb_leibniz.
    f_equal.
    f_equal.
    repeat rewrite groupExp_mult.
    rewrite mult_comm.
    rewrite <- mult_assoc.
    rewrite <- groupExp_mult.

    SearchAbout modNatAddInverse.

    SearchAbout groupExp modNat.
    SearchAbout eqb true.
    SearchAbout evalDist Ret.
    eapply evalDist_ret_1.

  Qed.

  Theorem foo :
    | Pr[(@DRBG_GA _ groupOp ident inverse _ g order x B Q)] -
      Pr[(@DRBG_GB _ groupOp ident inverse _ g order B Q)] | == 1.

    unfold DRBG_GA, DRBG_GB, DRBG.
    subst.
    unfold P.

    unfold B.
    comp_simp.

    SearchAbout ratDistance Bind.

    assert (((g ^ z) ^ seed) ^ modNatAddInverse z order = g^seed).
    rewrite <- groupExp_mult.

    SearchAbout modNatAddInverse.

    SearchAbout FiniteCyclicGroup.

    SearchAbout ratDistance eqRat.

  Qed.
  *)

End Dual_EC_DRBG_V.


Require Import Rupicola.Lib.Api. Import bedrock2.WeakestPrecondition.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Bedrock.Field.Interface.Compilation2.
Local Open Scope Z_scope.

Section Gallina.
  Local Open Scope F_scope.

  Definition ladderstep_gallina (m : positive) (a24 : F m)
             (X1 X2 Z2 X3 Z3: F m) : \<< F m, F m, F m, F m \>> :=
    let/n A := stack (X2+Z2) in
    let/n X2 := (X2-Z2) in
    let/n Z2 := (X3+Z3) in
    let/n Z3 := (X3-Z3) in
    let/n Z3 := (Z3*A) in
    let/n Z2 := (Z2*X2) in
    let/n A := (A^2) in
    let/n X2 := (X2^2) in
    let/n E := stack (A-X2) in
    let/n X3 := (Z3+Z2) in
    let/n X3 := X3^2 in
    let/n Z3 := (Z3-Z2) in
    let/n Z3 := Z3^2 in
    let/n Z3 := X1*Z3 in
    let/n X2 := A*X2 in
    let/n Z2 := a24*E in
    let/n Z2:= (A+Z2) in
    let/n Z2 := E*Z2 in
    \<X2, Z2, X3, Z3\>.
End Gallina.

Section __.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.
  Context {field_parameters : FieldParameters}
          {field_representaton : FieldRepresentation}
          {field_representation_ok : FieldRepresentation_ok}.
  Hint Resolve relax_bounds : compiler.
  Existing Instance felem_alloc.

  Instance spec_of_ladderstep : spec_of "ladderstep" :=
    fnspec! "ladderstep"
          (pX1 pX2 pZ2 pX3 pZ3 : word)
          / (X1 X2 Z2 X3 Z3 : F M_pos) R,
    { requires tr mem :=
        (FElem (Some tight_bounds) pX1 X1
         * FElem (Some tight_bounds) pX2 X2
         * FElem (Some tight_bounds) pZ2 Z2
         * FElem (Some tight_bounds) pX3 X3
         * FElem (Some tight_bounds) pZ3 Z3 * R)%sep mem;
      ensures tr' mem' :=
        tr = tr'
        /\ exists X4 Z4 X5 Z5 (* output values *)
                  : F M_pos,
                  (ladderstep_gallina M_pos a24 X1 X2 Z2 X3 Z3
           = \<X4, Z4, X5, Z5\>)
          /\ (FElem (Some tight_bounds) pX1 X1
              * FElem (Some tight_bounds) pX2 X4
              * FElem (Some tight_bounds) pZ2 Z4
              * FElem (Some tight_bounds) pX3 X5
              * FElem (Some tight_bounds) pZ3 Z5 * R)%sep mem'}.

  Lemma compile_ladderstep {tr m l functions}
        (x1 x2 z2 x3 z3 : F M_pos) :
    let v := ladderstep_gallina M_pos a24 x1 x2 z2 x3 z3 in
    forall P (pred: P v -> predicate) (k: nlet_eq_k P v) k_impl
           Rout
           X1_ptr X1_var X2_ptr X2_var Z2_ptr Z2_var
           X3_ptr X3_var Z3_ptr Z3_var,

      spec_of_ladderstep functions ->

      (FElem (Some tight_bounds) X1_ptr x1
       * FElem (Some tight_bounds) X2_ptr x2 * FElem (Some tight_bounds) Z2_ptr z2
       * FElem (Some tight_bounds) X3_ptr x3 * FElem (Some tight_bounds) Z3_ptr z3 * Rout)%sep m ->

      map.get l X1_var = Some X1_ptr ->
      map.get l X2_var = Some X2_ptr ->
      map.get l Z2_var = Some Z2_ptr ->
      map.get l X3_var = Some X3_ptr ->
      map.get l Z3_var = Some Z3_ptr ->

      (let v := v in
       forall (* output values *) m',
       let '\<X4, Z4, X5, Z5\> := ladderstep_gallina M_pos a24 x1 x2 z2 x3 z3 in
         (FElem (Some tight_bounds) X1_ptr x1
          * FElem (Some tight_bounds) X2_ptr X4
          * FElem (Some tight_bounds) Z2_ptr Z4
          * FElem (Some tight_bounds) X3_ptr X5
          * FElem (Some tight_bounds) Z3_ptr Z5 * Rout)%sep m' ->
         (<{ Trace := tr;
             Memory := m';
             Locals := l;
             Functions := functions }>
          k_impl
          <{ pred (k v eq_refl) }>)) ->

      <{ Trace := tr;
         Memory := m;
         Locals := l;
         Functions := functions }>
      cmd.seq
        (cmd.call [] "ladderstep"
                  [ expr.var X1_var; expr.var X2_var;
                  expr.var Z2_var; expr.var X3_var;
                  expr.var Z3_var])
        k_impl
      <{ pred (nlet_eq
                 [X2_var; Z2_var; X3_var; Z3_var]
                 v k) }>.
  Proof using env_ok ext_spec_ok locals_ok mem_ok word_ok.
    repeat straightline'.
    handle_call.
    apply H6.
    rewrite H9.
    ecancel_assumption.
  Qed.

  Local Ltac ecancel_assumption ::=  ecancel_assumption_impl.

  Derive ladderstep_body SuchThat
         (defn! "ladderstep" ("X1", "X2", "Z2", "X3", "Z3")
              { ladderstep_body },
           implements ladderstep_gallina
                      using [mul;add;sub;square;scmula24])
         As ladderstep_correct.
  Proof. compile. Qed.

End __.

#[global]
Existing Instance spec_of_ladderstep.

#[global]
Hint Extern 8 (WeakestPrecondition.cmd _ _ _ _ _ (_ (nlet_eq _ (ladderstep_gallina _ _ _ _ _ _ _) _))) =>
       simple eapply compile_ladderstep; shelve : compiler.

Import Syntax.
Local Unset Printing Coercions.
Local Set Printing Depth 70.
(* Set the printing width so that arguments are printed on 1 line.
   Otherwise the build breaks.
*)
Local Set Printing Width 140.
Redirect "Crypto.Bedrock.Group.ScalarMult.LadderStep.ladderstep_body" Print ladderstep_body.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal8.

Set Printing Depth 1000.
Definition lfind_eval  z n x:=
drop x (Cons n z).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Succ (Succ (Succ Zero))) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ (Succ (Succ Zero))))) (Zero).

Compute lfind_eval  (Nil) (Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero) (Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ Zero))) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)))) (Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil))) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero Nil))) (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil)) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero) (Zero).

Compute lfind_eval  (Nil) (Zero) (Succ Zero).

Compute lfind_eval  (Nil) (Zero) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero Nil) (Zero) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ (Succ Zero))))) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil)) (Succ (Succ Zero)) (Zero).

Compute lfind_eval  (Nil) (Zero) (Zero).