(**************************************************************************
* TLC: A library for Coq                                                  *
* Properties of logical connectives and functions                         *
**************************************************************************)

Set Implicit Arguments.
From SLF (* TLC *) Require Import LibTactics.
From SLF (* TLC *) Require Export LibAxioms LibEqual.
Generalizable Variables A B P.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Strong existentials *)

(** Type [sig] is defined in LibLogicCore *)

(** Projections *)

Definition sig_val (A : Type) (P : A->Prop) (e : sig P) : A :=
  match e with exist _ a _ => a end.

Definition sig_proof (A : Type) (P : A->Prop) (e : sig P) : P (sig_val e) :=
  match e with exist _ _ b => b end.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Inhabited types *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Typeclass for describing inhabited types *)

(** The proposition [Inhab A] captures the fact that the type [A] is
    inhabited (i.e., there exists at least one value of type [A]). *)

Class Inhab (A:Type) : Prop :=
  { Inhab_intro : (exists (x:A), True) }.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics taking into account *)

(** Extension to LibTactics' fast introduction tactic [=>>]
    to handle specifically the case of the Inhabited typeclass. *)

Ltac intro_nondeps_aux_special_intro G ::=
  match G with
  | (Inhab _) => idtac
  end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Arbitrary values for inhabited types *)

(** The value [arbitrary] can be used as a dummy value at any place
    where a value of an inhabited type is expected. *)

Definition arbitrary `{Inhab A} : A :=
  sig_val (@indefinite_description A _ Inhab_intro).

(** Extraction of [arbitrary] constants as a runtime error. *)

(* Extract Constant arbitrary => "(raise Not_found)". *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lemmas about inhabited types *)

(** Proving a type to be inhabited *)

Lemma Inhab_of_val : forall (A:Type),
  A ->
  Inhab A.
Proof using. intros A x. constructor. exists x. auto. Qed.

(** Arrows are inhabited if their codomain is inhabited. *)

Instance Inhab_impl : forall A B {I:Inhab B},
  Inhab (A -> B).
Proof using. intros. apply (Inhab_of_val (fun _ => arbitrary)). Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Non-constructive conditionals *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Excluded middle *)

(** Every proposition is either [True] or [False]. *)

Lemma classic : forall (P : Prop),
  P \/ ~ P.
Proof using.
  intros.
  set (B1 := fun b => b = true \/ P).
  set (B2 := fun b => b = false \/ P).
  asserts H1: (ex B1). exists true. left~.
  asserts H2: (ex B2). exists false. left~.
  sets i1: (indefinite_description H1).
  sets i2: (indefinite_description H2).
  destruct (sig_proof i1) as [HA|]; [|auto].
  destruct (sig_proof i2) as [HB|]; [|auto].
  right. intros HP. asserts EB: (B1 = B2).
    apply pred_ext_1. intros b. split; intros _; right; auto.
  subst i1 i2. destruct EB.
  rewrite (proof_irrelevance H2 H1) in HB. congruence.
Qed.

Definition prop_inv := classic.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Strong excluded middle *)

(** From classical logic and indefinite description, we can prove
    the strong (or informative) excluded middle, which allows Coq
    definitions to make a case analysis on the truth value of any
    proposition. *)

Lemma classicT : forall (P : Prop),
  {P} + {~ P}.
Proof using.
  intros. pose (select := fun (b:bool) => if b then P else ~P).
  cuts (M,HP): { b:bool | select b }.
    destruct M. left~. right~.
  apply indefinite_description.
  destruct (prop_inv P). exists~ true. exists~ false.
Qed.

(** Simplification lemmas *)

Lemma classicT_l : forall (P : Prop) (H:P),
   classicT P = left _ H.
Proof using. intros. destruct (classicT P). fequals. false~. Qed.

Lemma classicT_r : forall (P : Prop) (H:~P),
   classicT P = right _ H.
Proof using. intros. destruct (classicT P). false~. fequals. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** If-then-else on propositions *)

(** The expression [If P then v1 else v2] can be used to build
    a conditional that depends on a proposition [P]. *)

Notation "'If' P 'then' v1 'else' v2" :=
  (if (classicT P) then v1 else v2)
  (at level 200, right associativity) : type_scope.

Section Ifthenelse.
Variables A : Type.
Implicit Types P : Prop.
Implicit Types x y : A.

(** Lemmas to simplify If-then-else statement *)

Lemma If_l : forall P x y,
  P ->
  (If P then x else y) = x.
Proof using. intros. case_if*. Qed.

Lemma If_r : forall P x y,
  ~ P ->
  (If P then x else y) = y.
Proof using. intros. case_if*. Qed.

(** A lemma to prove an equality between two If-then-else *)

Lemma If_eq : forall P P' x x' y y',
  (P <-> P') ->
  (P -> x = x') ->
  (~P -> y = y') ->
  (If P then x else y) = (If P' then x' else y').
Proof using. intros. do 2 case_if; autos*. Qed.

(** A simpler version of the above lemma *)

Lemma If_eq_simple : forall P P' x x' y y',
  (P <-> P') ->
  (x = x') ->
  (y = y') ->
  (If P then x else y) = (If P' then x' else y').
Proof using. intros. subst. asserts_rewrite (P = P'). apply~ prop_ext. auto. Qed.

End Ifthenelse.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Consequences *)

(** Propositional extensionality stated using itself *)

Lemma eq_prop_eq_iff : forall P Q,
  (P = Q) = (P <-> Q).
Proof using. intros. extens. iff. subst*. apply~ prop_ext. Qed.

(** Propositional completeness (degeneracy) *)

Lemma prop_degeneracy : forall (P : Prop),
   P = True \/ P = False.
Proof using.
  intros. destruct (prop_inv P).
    left. apply* prop_ext.
    right. apply* prop_ext.
Qed.

(** Independence of general premises *)

Lemma indep_general_premises :
  forall `{Inhab A} (P : A -> Prop) (Q : Prop),
  (Q -> exists x, P x) ->
  (exists x, Q -> P x).
Proof using.
  introv I M. destruct (prop_inv Q).
  destruct* (M H).
  exists arbitrary. auto_false.
Qed.

(** Small drinker's paradox *)

Lemma small_drinker_paradox : forall `{Inhab A} (P : A -> Prop),
  exists x, (exists x, P x) -> P x.
Proof using.
  intros A I P. destruct (prop_inv (exists x, P x)).
  destruct H. exists x. auto.
  exists arbitrary. auto_false.
Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic for proving tautologies by bruteforce case-analysis *)

(** The tactic [tautop P1 .. PN] helps performing case analysis on
    the propositions/booleans that are given to it as parameters. *)

Ltac tautop_case P :=
  match type of P with
  | Prop => destruct (prop_degeneracy P)
  | bool => destruct P
  end.

Ltac tautop_pre tt :=
  intros;
  repeat rewrite eq_prop_eq_iff in *.

Ltac tautop_post tt :=
  subst;
  try solve [ intuition auto_false ].

Ltac tautop_core args :=
  tautop_pre tt;
  let rec aux Ps :=
    match Ps with
    | nil => idtac
    | cons (boxer ?P) ?Ps' => tautop_case P; aux Ps'
    end in
  aux args;
  tautop_post tt.

Ltac tautop_noargs tt :=
  let rec aux Ps :=
     match goal with
     | |- forall (_:Prop), _ =>
       let P := fresh "P" in intro P; aux (cons (boxer P) Ps)
     | _ => tautop_core Ps
     end
     in
  aux constr:(@nil Boxer).

Tactic Notation "tautop" :=
  tautop_noargs tt.
Tactic Notation "tautop" constr(P1) :=
  tautop_core (>> P1).
Tactic Notation "tautop" constr(P1) constr(P2) :=
  tautop_core (>> P1 P2).
Tactic Notation "tautop" constr(P1) constr(P2) constr(P3) :=
  tautop_core (>> P1 P2 P3).

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties of logical combinators *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Simplification of conjunction and disjunction *)

Section SimplConjDisj.
Implicit Types P Q : Prop.

Lemma and_True_l_eq : forall P,
  (True /\ P) = P.
Proof using. tautop. Qed.

Lemma and_True_r_eq : forall P,
  (P /\ True) = P.
Proof using. tautop. Qed.

Lemma and_False_l_eq : forall P,
  (False /\ P) = False.
Proof using. tautop. Qed.

Lemma and_False_r_eq : forall P,
  (P /\ False) = False.
Proof using. tautop. Qed.

Lemma or_True_l_eq : forall P,
  (True \/ P) = True.
Proof using. tautop. Qed.

Lemma or_True_r_eq : forall P,
  (P \/ True) = True.
Proof using. tautop. Qed.

Lemma or_False_l_eq : forall P,
  (False \/ P) = P.
Proof using. tautop. Qed.

Lemma or_False_r_eq : forall P,
  (P \/ False) = P.
Proof using. tautop. Qed.

End SimplConjDisj.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Distribution of negation on basic operators *)

Section SimplNot.
Implicit Types P Q : Prop.

Lemma not_True_eq :
  (~ True) = False.
Proof using. tautop. Qed.

Lemma not_False_eq :
  (~ False) = True.
Proof using. tautop. Qed.

Lemma not_not_eq : forall P,
  (~ (~ P)) = P.
Proof using. tautop. Qed.

Lemma not_and_eq : forall P Q,
  (~ (P /\ Q)) = (~ P \/ ~ Q).
Proof using. tautop. Qed.

Lemma not_or_eq : forall P Q,
  (~ (P \/ Q)) = (~ P /\ ~ Q).
Proof using. tautop. Qed.

Lemma not_impl_eq : forall P Q,
  (~ (P -> Q)) = (P /\ ~ Q).
Proof using. tautop. Qed.

(* Derived versions *)

Lemma not_or_nots_eq : forall P Q,
  (~ (~ P \/ ~ Q)) = (P /\ Q).
Proof using. tautop. Qed.

Lemma not_and_nots_eq : forall P Q,
  (~ (~ P /\ ~ Q)) = (P \/ Q).
Proof using. tautop. Qed.

End SimplNot.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Double negation and contrapose *)

Section DoubleNeg.
Implicit Types P Q : Prop.

(** Double negation *)

Lemma not_not_inv : forall P,
  ~ ~ P ->
  P.
Proof using. tautop. Qed.

Lemma not_not : forall P,
  P ->
  ~ ~ P.
Proof using. tautop. Qed.

(** Contrapose *)

Lemma contrapose_eq : forall P Q,
  (~ P -> ~ Q) = (Q -> P).
Proof using. tautop. Qed.

Lemma contrapose_inv : forall P Q,
  (~ Q -> ~ P) ->
  (P -> Q).
Proof using. tautop. Qed.

Lemma contrapose : forall P Q,
  (Q -> P) ->
  (~ P -> ~ Q).
Proof using. tautop. Qed.

(** Negation is injective *)

Lemma injective_not : forall P Q,
  (~P) = (~Q) ->
  (P = Q).
Proof using. tautop. Qed.

End DoubleNeg.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Distribution of negation on quantifiers *)

Section SimplNotQuantifiers.
Variables (A : Type).
Implicit Types P : A -> Prop.

(** Three auxiliary facts (private lemmas) *)

Lemma exists_of_not_forall : forall P,
  ~ (forall x, ~ P x) ->
  (exists x, P x).
Proof using. intros. apply* not_not_inv. Qed.

Lemma forall_of_not_exists : forall P,
  ~ (exists x, ~ P x) ->
  (forall x, P x).
Proof using. intros. apply* not_not_inv. Qed.

Lemma not_not_pred_eq : forall A (P:A->Prop),
  P = (fun x => ~ ~ (P x)).
Proof using. intros. extens. intros. rewrite* not_not_eq. Qed.

(** Rewriting rules for quantifiers *)

Lemma not_forall_eq : forall P,
  (~ (forall x, P x)) = (exists x, ~ P x).
Proof using.
  extens. iff.
  { apply exists_of_not_forall. rewrite~ (not_not_pred_eq P) in H. }
  { intros M. destruct~ H as [x Cx]. }
Qed.

Lemma not_exists_eq : forall P,
  (~ (exists x, P x)) = (forall x, ~ P x).
Proof using.
  intros. apply injective_not. rewrite not_forall_eq.
  rewrite not_not_eq. set (P':=P) at 1.
  rewrite~ (not_not_pred_eq P').
Qed.

(* Derived versions, useful when rewriting does not work
   under binders. *)

Lemma not_forall_not_eq : forall P,
  (~ (forall x, ~ P x)) = (exists x, P x).
Proof using.
  intros. rewrite not_forall_eq.
   set (P':=P) at 2. rewrite~ (not_not_pred_eq P').
Qed.

Lemma not_exists_not_eq : forall P,
  (~ (exists x, ~ P x)) = (forall x, P x).
Proof using.
  intros. rewrite not_exists_eq.
  set (P':=P) at 2. rewrite~ (not_not_pred_eq P').
Qed.

End SimplNotQuantifiers.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Propositions equal to [True] or [False] *)

Section EqTrueFalse.
Implicit Types P Q : Prop.

(** Propositions equal to [True] *)

Lemma prop_eq_True_eq : forall P,
  (P = True) = P.
Proof using. tautop. Qed.

Lemma prop_eq_True : forall P,
  P ->
  P = True.
Proof using. tautop. Qed.

Lemma prop_eq_True_inv : forall P,
  P = True ->
  P.
Proof using. tautop. Qed.

(** Propositions equal to [False] *)

Lemma prop_eq_False_eq : forall P,
  (P = False) = ~ P.
Proof using. tautop. Qed.

Lemma prop_eq_False : forall P,
  ~ P ->
  P = False.
Proof using. tautop. Qed.

Lemma prop_eq_False_inv : forall P,
  P = False ->
  ~ P.
Proof using. tautop. Qed.

End EqTrueFalse.

Hint Resolve prop_eq_True prop_eq_False.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Disequal propositions *)

Section NeqProp.
Implicit Types P Q : Prop.

(** Propositions not [True] or not [False] *)

Lemma prop_neq_True_eq : forall P,
  (P <> True) = ~ P.
Proof using. tautop. Qed.

Lemma prop_neq_False_eq : forall P,
  (P <> False) = P.
Proof using. tautop. Qed.

(** Proving two propositions not equal *)

Lemma prop_neq_of_iff_l : forall P Q,
  (P <-> ~ Q) ->
  P <> Q.
Proof using. tautop. Qed.

Lemma prop_neq_of_iff_r : forall P Q,
  (~ P <-> Q) ->
  P <> Q.
Proof using. tautop. Qed.

Lemma prop_neq_inv_iff_l : forall P Q,
  P <> Q ->
  (P <-> ~ Q).
Proof using. tautop. Qed.

Lemma prop_neq_inv_iff_r : forall P Q,
  P <> Q ->
  (~ P <-> Q).
Proof using. tautop. Qed.

(** True is not False *)

Lemma True_neq_False : True <> False.
Proof using. tautop. Qed.

End NeqProp.

Hint Resolve True_neq_False.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Peirce rule and similar *)

Section ClassicOr.
Implicit Types P Q : Prop.

(** Peirce's result: proving a fact by assuming its negation *)

Lemma assume_not : forall P,
  (~ P -> P) ->
  P.
Proof using. tautop. Qed.

(** Proving a disjunction, assuming the negation of the other branch *)

Lemma or_classic_l : forall P Q,
  (~ Q -> P) ->
  P \/ Q.
Proof using. tautop. Qed.

Lemma or_classic_r : forall P Q,
  (~ P -> Q) ->
  P \/ Q.
Proof using. tautop. Qed.

(** Same, but in forward style *)

Lemma or_inv_classic_l : forall P Q,
  P \/ Q ->
  (P \/ (~ P /\ Q)).
Proof using. tautop. Qed.

Lemma or_inv_classic_r : forall P Q,
  P \/ Q ->
  (Q \/ (P /\ ~ Q)).
Proof using. tautop. Qed.

End ClassicOr.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of logical equivalence *)

Section IffProp.
Implicit Types P Q R : Prop.

(** Introduction *)

Lemma iff_eq_and : forall P Q : Prop,
  (P <-> Q) = ((P -> Q) /\ (Q -> P)).
Proof using. tautop. Qed.

Lemma iff_intro : forall P Q : Prop,
  (P -> Q) ->
  (Q -> P) ->
  (P <-> Q).
Proof using. intros. rewrite* iff_eq_and. Qed.

(** Reflexivity: [refl iff] *)

Lemma iff_refl : forall P,
  P <-> P.
Proof using. tautop. Qed.

(** Symmetry: [sym iff] *)

Lemma iff_sym : forall P Q,
  (P <-> Q) ->
  (Q <-> P).
Proof using. tautop. Qed.

(** Transitivity: [trans iff] *)

Lemma iff_trans : forall P Q R,
  (P <-> Q) ->
  (Q <-> R) ->
  (P <-> R).
Proof using. tautop. Qed.

(** First projection *)

Lemma iff_l : forall P Q,
  (P <-> Q) ->
  P ->
  Q.
Proof using. tautop. Qed.

(** Second projection *)

Lemma iff_r : forall P Q,
  (P <-> Q) ->
  Q ->
  P.
Proof using. tautop. Qed.

(** Contrapose of the first projection *)

Lemma iff_not_l : forall P Q,
  (P <-> Q) ->
  ~ P ->
  ~ Q.
Proof using. tautop. Qed.

(** Contrapose of the second projection *)

Lemma iff_not_r : forall P Q,
  (P <-> Q) ->
  ~ Q ->
  ~ P.
Proof using. tautop. Qed.

(** Negation can change side of an equivalence *)

Lemma iff_not_swap_eq : forall P Q,
  ((~ P) <-> Q) = (P <-> (~ Q)).
Proof using. tautop. Qed.

(** Negation can be cancelled on both sides *)

Lemma iff_not_not_eq : forall P Q,
  ((~ P) <-> (~Q)) = (P <-> Q).
Proof using. tautop. Qed.

End IffProp.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic for simplifying expressions *)

(** The tactic [rew_logic] can be used to automatically
    simplify logical expressions. Syntax [rew_logic in H]
    and [rew_logic in *] are also available. *)

(* Remark: [not_impl] needs to have higher priority than [not_forall],
   and samewise for [not_forall_not_eq] and [not_exists_not_eq]. *)
Hint Rewrite
  not_not_eq not_and_eq not_or_eq not_impl_eq not_True_eq not_False_eq
  not_forall_eq not_forall_not_eq
  not_exists_eq not_exists_not_eq not_impl_eq
  prop_eq_True_eq prop_eq_False_eq eq_prop_eq_iff
  and_True_l_eq and_True_r_eq and_False_l_eq and_False_r_eq
  or_True_l_eq or_True_r_eq or_False_l_eq or_False_r_eq
  not_False_eq not_True_eq
  : rew_logic.

Tactic Notation "rew_logic" :=
  autorewrite with rew_logic.
Tactic Notation "rew_logic" "in" hyp(H) :=
  autorewrite with rew_logic in H.
Tactic Notation "rew_logic" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_logic).
  (* autorewrite with rew_logic in *. *)

Tactic Notation "rew_logic" "~" :=
  rew_logic; auto_tilde.
Tactic Notation "rew_logic" "~" "in" hyp(H) :=
  rew_logic in H; auto_tilde.
Tactic Notation "rew_logic" "~" "in" "*" :=
  rew_logic in *; auto_tilde.

Tactic Notation "rew_logic" "*" :=
  rew_logic; auto_star.
Tactic Notation "rew_logic" "*" "in" hyp(H) :=
  rew_logic in H; auto_star.
Tactic Notation "rew_logic" "*" "in" "*" :=
  rew_logic in *; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [tests: P] for classical disjunction on [P]. *)

(** The tactic [tests: P] can be used to tests whether the proposition [P]
    is true or not. If [P] is an equality, it is substituted. Use the
    tactic [tests_nosubst: P] to disable the automated substitution.
    Use the tactic [tests_basic: P] to moreover disable simplification
    of logical expressions.
    To name the resulting hypotheses use [tests I: P], or [tests I1 I2: P]
    to assign different names to both sides.
    (In LibReflect, the tactic is extended so that [P] can be a boolean.) *)

Ltac tests_ssum_base E H1 H2 :=
  destruct E as [H1|H2].

Ltac tests_prop_base E H1 H2 :=
  tests_ssum_base (classicT E) H1 H2.

Ltac tests_dispatch E H1 H2 :=
  match type of E with
  | Prop => tests_prop_base E H1 H2
  | {_}+{_} => tests_ssum_base E H1 H2
  end.

Ltac tests_post H introstac :=
  tryfalse; rew_logic in H; revert H;
  introstac tt; tryfalse.

Ltac tests_post_subst H I :=
  tests_post H ltac:(fun _ => first [ intro_subst_hyp | intros I ]).

Ltac tests_post_nosubst H I :=
  tests_post H ltac:(fun _ => intros I).

Ltac tests_base E I1 I2 tests_post :=
  let H1 := fresh "TEMP" in
  let H2 := fresh "TEMP" in
  tests_dispatch E H1 H2;
    [ tests_post H1 I1
    | tests_post H2 I2 ].

Tactic Notation "tests" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_base E I1 I2 ltac:(tests_post_subst).
Tactic Notation "tests" simple_intropattern(I) ":" constr(E) :=
  tests I I: E.
Tactic Notation "tests" ":" constr(E) :=
  let I := fresh "C" in tests I: E.
Tactic Notation "tests" "~" ":" constr(E) :=
  tests: E; auto_tilde.
Tactic Notation "tests" "*" ":" constr(E) :=
  tests: E; auto_star.

Tactic Notation "tests_nosubst" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_base E I1 I2 ltac:(tests_post_nosubst).
Tactic Notation "tests_nosubst" simple_intropattern(I) ":" constr(E) :=
  tests_nosubst I I: E.
Tactic Notation "tests_nosubst" ":" constr(E) :=
  let I := fresh "C" in tests I: E.
Tactic Notation "tests_nosubst" "~" ":" constr(E) :=
  tests: E; auto_tilde.
Tactic Notation "tests_nosubst" "*" ":" constr(E) :=
  tests: E; auto_star.

Tactic Notation "tests_basic" simple_intropattern(I1) simple_intropattern(I2) ":" constr(E) :=
  tests_dispatch E I1 I2.
Tactic Notation "tests_basic" simple_intropattern(I1) ":" constr(E) :=
  tests_basic I1 I1: E.
Tactic Notation "tests_basic" ":" constr(E) :=
  let C := fresh "C" in tests_basic C: E.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [absurds] *)

(** [absurds] applies to a goal [G] and replaces it with [(~ G) -> False].
    The expression [~ G] is simplified using [rew_logic].

    [absurds ;=> H] introduces [H] as the negation of the goal, and
    leaves [False] is the goal.

    [absurds_nosimpl] is similar, but it does not perform simplifications. *)

Lemma absurds_lemma : forall (G:Prop),
  ((~ G) -> False) ->
  G.
Proof using. intros. applys~ not_not_inv. Qed.

Ltac absurds_nosimpl_core tt :=
  applys absurds_lemma.

Tactic Notation "absurds_nosimpl" :=
  absurds_nosimpl_core tt.

Ltac absurds_post tt :=
  rew_logic.

Ltac absurds_core tt :=
  applys absurds_lemma;
  absurds_post tt.

Tactic Notation "absurds" :=
   absurds_core tt.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Predicate combinators, comparison and compatibility *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition of predicate combinators *)

Definition pred_true {A : Type} :=
  fun (_:A) => True.

Definition pred_false {A : Type} :=
  fun (_:A) => False.

Definition pred_not (A : Type) (P : A -> Prop) :=
  fun x => ~ (P x).

Definition pred_and (A : Type) (P Q : A -> Prop) :=
  fun x => P x /\ Q x.

Definition pred_or (A : Type) (P Q : A -> Prop) :=
  fun x => P x \/ Q x.

Definition pred_impl (A : Type) (P Q : A -> Prop) :=
  fun x => P x -> Q x.

Hint Unfold pred_true pred_false.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of combinators *)

(* --LATER: reformulate using [pred_all] and [pred_and] (?) *)

Lemma pred_conj_forall_distrib : forall A (P Q: A->Prop),
  ((forall x, P x) /\ (forall x, Q x)) = (forall x, P x /\ Q x).
Proof using. intros. apply prop_ext. iff H. autos*. split; intros x; apply* (H x). Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Order on predicates *)

Definition pred_incl (A : Type) (P Q : A -> Prop) :=
  forall x, P x -> Q x.

(* --LATER: create a section here *)

Lemma pred_eq_forall_impl : forall A (P Q : A -> Prop),
  pred_incl P Q = (forall x, P x -> Q x).
Proof using. auto. Qed.

Lemma pred_incl_refl : forall A (P : A -> Prop),
  pred_incl P P.
Proof using. unfolds~ pred_incl. Qed.

Lemma pred_incl_trans : forall A (Q P R : A -> Prop),
  pred_incl P Q ->
  pred_incl Q R ->
  pred_incl P R.
Proof using. unfolds~ pred_incl. Qed.

Lemma pred_incl_antisym : forall A (P Q : A -> Prop),
  pred_incl P Q ->
  pred_incl Q P ->
  P = Q.
Proof using. extens*. Qed.

(** See also [LibRelation] and [LibOrder] for higher-level statements
    of these results *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Existentials *)

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Properties of unique existentials *)

(** [unique_st P x] asserts that [x] is the unique element for which
    [P x] holds. *)

Definition unique_st (A : Type) (P : A -> Prop) (x : A) :=
  P x /\ forall y, P y -> y = x.

Hint Unfold unique_st.

(** [ex_unique P] asserts that there exists a unique element for which
    [P x] holds. *)

Definition ex_unique (A : Type) (P : A -> Prop) :=
  ex (unique_st P).

(** [exists! x, P] is the notation for [ex_unique P]. *)

Notation "'exists' ! x , P" := (ex_unique (fun x => P))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.

Notation "'exists' ! x : A , P" :=
  (ex_unique (fun x:A => P))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.

(** [at_most_one P] asserts that there exists at most one element for
    which [P x] holds. In other words, [P] has 0 or 1 inhabitant. *)

Definition at_most_one (A : Type) (P : A -> Prop) :=
  forall x y, P x -> P y -> x = y.

Section UniqueProp.
Variables (A : Type).
Implicit Types  (P : A -> Prop).

(** [exists! x, P] entails [exists x, P] *)

Lemma ex_of_ex_unique : forall P,
  ex_unique P ->
  ex P.
Proof using. introv (x&H&U). eauto. Qed.

(** [exists! x, P] entails [at_most_one P] *)

Lemma at_most_one_of_ex_unique : forall P,
  ex_unique P ->
  at_most_one P.
Proof using.
  introv (a&H&U) Px Py. applys~ eq_trans a. rewrite~ <- (U y).
Qed.

(** [exists x, P] and [at_most_one P] entail [exists! x, P] *)

Lemma ex_unique_of_ex_at_most_one : forall P,
  ex P ->
  at_most_one P ->
  ex_unique P.
Proof using. introv [x Px] H. exists x. split~. Qed.

End UniqueProp.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Conjunctions *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Changing the order of branches *)

Lemma conj_swap: forall (P Q: Prop),
  P ->
  Q ->
  Q /\ P.
Proof using. autos*. Qed.

Lemma conj_dup_r : forall P Q : Prop,
  Q ->
  (Q -> P) ->
  P /\ Q.
Proof using. autos*. Qed.

Lemma conj_dup_l : forall P Q : Prop,
  P ->
  (P -> Q) ->
  P /\ Q.
Proof using. autos*. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Parallel strengthening of a conjunction *)

Lemma conj_strengthen_2 : forall (Q1 Q2 P1 P2 : Prop),
  (Q1 /\ Q2) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (P1 /\ P2).
Proof using. autos*. Qed.

Lemma conj_strengthen_3 : forall (Q1 Q2 Q3 P1 P2 P3 : Prop),
  (Q1 /\ Q2 /\ Q3) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (Q3 -> P3) ->
  (P1 /\ P2 /\ P3).
Proof using. autos*. Qed.

Lemma conj_strengthen_4 : forall (Q1 Q2 Q3 Q4 P1 P2 P3 P4 : Prop),
  (Q1 /\ Q2 /\ Q3 /\ Q4) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (Q3 -> P3) ->
  (Q4 -> P4) ->
  (P1 /\ P2 /\ P3 /\ P4).
Proof using. autos*. Qed.

Lemma conj_strengthen_5 : forall (Q1 Q2 Q3 Q4 Q5 P1 P2 P3 P4 P5 : Prop),
  (Q1 /\ Q2 /\ Q3 /\ Q4 /\ Q5) ->
  (Q1 -> P1) ->
  (Q2 -> P2) ->
  (Q3 -> P3) ->
  (Q4 -> P4) ->
  (Q5 -> P5) ->
  (P1 /\ P2 /\ P3 /\ P4 /\ P5).
Proof using. autos*. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Projections of lemmas concluding on a conjunction *)

Section ProjLemma.
Variables (A1 : Type).
Variables (A2 : forall (x1 : A1), Type).
Variables (A3 : forall (x1 : A1) (x2 : A2 x1), Type).
Variables (A4 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2), Type).
Variables (A5 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3), Type).
Variables (A6 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4), Type).
Variables (A7 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5), Type).
Variables (A8 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6), Type).
Variables (A9 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7), Type).
Variables (A10 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7) (x9 : A9 x8), Type).
Variables (A11 : forall (x1 : A1) (x2 : A2 x1) (x3 : A3 x2) (x4 : A4 x3) (x5 : A5 x4) (x6 : A6 x5) (x7 : A7 x6) (x8 : A8 x7) (x9 : A9 x8) (x10 : A10 x9), Type).

Ltac prove_forall_conj_inv :=
  intros;
  match goal with H: context [_ /\ _] |- _ =>
    split; intros; apply H end.

Lemma forall_conj_inv_1 : forall (P Q : forall (x1:A1), Prop),
  (forall x1, P x1 /\ Q x1) ->
  (forall x1, P x1) /\
  (forall x1, Q x1).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_2 : forall (P Q : forall (x1:A1) (x2:A2 x1), Prop),
  (forall x1 x2, P x1 x2 /\ Q x1 x2) ->
  (forall x1 x2, P x1 x2) /\
  (forall x1 x2, Q x1 x2).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_3 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2), Prop),
  (forall x1 x2 x3, P x1 x2 x3 /\ Q x1 x2 x3) ->
  (forall x1 x2 x3, P x1 x2 x3) /\
  (forall x1 x2 x3, Q x1 x2 x3).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_4 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3), Prop),
  (forall x1 x2 x3 x4, P x1 x2 x3 x4 /\ Q x1 x2 x3 x4) ->
  (forall x1 x2 x3 x4, P x1 x2 x3 x4) /\
  (forall x1 x2 x3 x4, Q x1 x2 x3 x4).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_5 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4), Prop),
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5 /\ Q x1 x2 x3 x4 x5) ->
  (forall x1 x2 x3 x4 x5, P x1 x2 x3 x4 x5) /\
  (forall x1 x2 x3 x4 x5, Q x1 x2 x3 x4 x5).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_6 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5), Prop),
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6 /\ Q x1 x2 x3 x4 x5 x6) ->
  (forall x1 x2 x3 x4 x5 x6, P x1 x2 x3 x4 x5 x6) /\
  (forall x1 x2 x3 x4 x5 x6, Q x1 x2 x3 x4 x5 x6).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_7 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7, P x1 x2 x3 x4 x5 x6 x7 /\ Q x1 x2 x3 x4 x5 x6 x7) ->
  (forall x1 x2 x3 x4 x5 x6 x7, P x1 x2 x3 x4 x5 x6 x7) /\
  (forall x1 x2 x3 x4 x5 x6 x7, Q x1 x2 x3 x4 x5 x6 x7).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_8 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8, P x1 x2 x3 x4 x5 x6 x7 x8 /\ Q x1 x2 x3 x4 x5 x6 x7 x8) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8, P x1 x2 x3 x4 x5 x6 x7 x8) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8, Q x1 x2 x3 x4 x5 x6 x7 x8).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_9 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, P x1 x2 x3 x4 x5 x6 x7 x8 x9 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, P x1 x2 x3 x4 x5 x6 x7 x8 x9) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9, Q x1 x2 x3 x4 x5 x6 x7 x8 x9).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_10 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8) (x10:A10 x9), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10, Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10).
Proof using. prove_forall_conj_inv. Qed.

Lemma forall_conj_inv_11 : forall (P Q : forall (x1:A1) (x2:A2 x1) (x3:A3 x2)
 (x4:A4 x3) (x5:A5 x4) (x6:A6 x5) (x7:A7 x6) (x8:A8 x7) (x9:A9 x8) (x10:A10 x9) (x11:A11 x10), Prop),
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 /\ Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) ->
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, P x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) /\
  (forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11, Q x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11).
Proof using. prove_forall_conj_inv. Qed.

End ProjLemma.

Arguments forall_conj_inv_1 [A1] [P] [Q].
Arguments forall_conj_inv_2 [A1] [A2] [P] [Q].
Arguments forall_conj_inv_3 [A1] [A2] [A3] [P] [Q].
Arguments forall_conj_inv_4 [A1] [A2] [A3] [A4] [P] [Q].
Arguments forall_conj_inv_5 [A1] [A2] [A3] [A4] [A5] [P] [Q].
Arguments forall_conj_inv_6 [A1] [A2] [A3] [A4] [A5] [A6] [P] [Q].
Arguments forall_conj_inv_7 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [P] [Q].
Arguments forall_conj_inv_8 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [P] [Q].
Arguments forall_conj_inv_9 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [A9] [P] [Q].
Arguments forall_conj_inv_10 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [A9] [A10] [P] [Q].
Arguments forall_conj_inv_11 [A1] [A2] [A3] [A4] [A5] [A6] [A7] [A8] [A9] [A10] [A11] [P] [Q].

(* 2020-03-09 15:04:11 (UTC+01) *)


Require Export GeoCoq.Highschool.midpoint_thales.
Require Export GeoCoq.Highschool.exercises.

Section Circumcenter.

Context `{TE:Tarski_euclidean}.

Definition is_circumcenter G A B C := Cong A G B G /\ Cong B G C G /\ Coplanar G A B C.

Lemma circumcenter_cong : forall G A B C,
 is_circumcenter G A B C ->
 Cong A G B G /\ Cong B G C G /\ Cong C G A G.
Proof.
intros.
unfold is_circumcenter in *.
intuition eCong.
Qed.

Lemma is_circumcenter_perm : forall A B C G,
 is_circumcenter G A B C ->
 is_circumcenter G A B C /\ is_circumcenter G A C B /\
 is_circumcenter G B A C /\ is_circumcenter G B C A /\
 is_circumcenter G C A B /\ is_circumcenter G C B A.
Proof.
unfold is_circumcenter.
intros.
spliter.
repeat split;eauto using cong_transitivity with cong;Cop.
Qed.

Lemma is_circumcenter_cases :
  forall A B C G,
  is_circumcenter G A B C \/
  is_circumcenter G A C B \/
  is_circumcenter G B A C \/
  is_circumcenter G B C A \/
  is_circumcenter G C A B \/
  is_circumcenter G C B A ->
  is_circumcenter G A B C.
Proof.
intros.
decompose [or] H;clear H; first [apply is_circumcenter_perm in H0|apply is_circumcenter_perm in H1];
spliter; assumption.
Qed.

Lemma is_circumcenter_perm_1 : forall A B C G,
 is_circumcenter G A B C -> is_circumcenter G A C B.
Proof.
intros.
apply is_circumcenter_perm in H;intuition.
Qed.

Lemma is_circumcenter_perm_2 : forall A B C G,
 is_circumcenter G A B C -> is_circumcenter G B A C.
Proof.
intros.
apply is_circumcenter_perm in H;intuition.
Qed.

Lemma is_circumcenter_perm_3 : forall A B C G,
 is_circumcenter G A B C -> is_circumcenter G B C A.
Proof.
intros.
apply is_circumcenter_perm in H;intuition.
Qed.

Lemma is_circumcenter_perm_4 : forall A B C G,
 is_circumcenter G A B C -> is_circumcenter G C A B.
Proof.
intros.
apply is_circumcenter_perm in H;intuition.
Qed.

Lemma is_circumcenter_perm_5 : forall A B C G,
 is_circumcenter G A B C -> is_circumcenter G C B A.
Proof.
intros.
apply is_circumcenter_perm in H;intuition.
Qed.

Lemma is_circumcenter_cop : forall A B C G,
 is_circumcenter G A B C -> Coplanar G A B C.
Proof.
unfold is_circumcenter.
intros; spliter; assumption.
Qed.

End Circumcenter.

(* TODO investigate bug Hint Resolve/Section *)
Hint Resolve
     is_circumcenter_perm_1
     is_circumcenter_perm_2
     is_circumcenter_perm_3
     is_circumcenter_perm_4
     is_circumcenter_perm_5 : Circumcenter.

Hint Resolve is_circumcenter_cop : cop.

Section Circumcenter2 .

Context `{TE:Tarski_euclidean}.

(**
#
<article class="geogebraweb" data-param-width="800" data-param-height="600"
data-param-showResetIcon="false" data-param-enableLabelDrags="false" data-param-showMenuBar="false" data-param-showToolBar="false" data-param-showAlgebraInput="false" enableLabelDrags="true" data-param-ggbbase64="UEsDBBQACAAIAPNdNkIAAAAAAAAAAAAAAAAWAAAAZ2VvZ2VicmFfamF2YXNjcmlwdC5qc0srzUsuyczPU0hPT/LP88zLLNHQVKiuBQBQSwcI1je9uRkAAAAXAAAAUEsDBBQACAAIAPNdNkIAAAAAAAAAAAAAAAAMAAAAZ2VvZ2VicmEueG1s1Vrbcts4En3OfAWKD/tk0biDzMqZsl012Ux5LrXObm3tG0VCEmKK5JKULaXy8dsASIm2bMWyk9ijxIYANtDoc7obDSbjn1eLHF3rujFlcRKQEAdIF2mZmWJ2Eizb6SgKfn7303imy5me1AmalvUiaU8CHtJgOw96IVF2sslOAplolbKJHKlIRyMuSTyK40k8SnXMKNOJEngSILRqzNui/D1Z6KZKUn2ZzvUiuSjTpHVrztu2ent8fHNzE/baw7KeHc9mk3DVZAGCnRfNSdB9eQvL3Zp0w5w4xZgc/+e3C7/8yBRNmxSpDpC1amne/fRmfGOKrLxBNyZr5ydBhMGMuTazOZgpbefYClVga6XT1lzrBqYOus7mdlEFTiwp7PM3/hvKN+YEKDPXJtP1SYBDSRgRKoq5YjLilASorI0u2k6WdDqP+9XG10bf+GXtN6eR41gBBaYxk1yfBNMkb8AqU0xrQBQ2VC+h27TrXE+Suu9v90OO4A8ImM/argVmehhOAsGPGJVHCuMjITrzh3oD1JZl7hbFSMToyxdEMcXoyDbENxQaKf0j7Mcw8w31DfeN8DLcT+delHsZ7mU422Nm199rZ28lG1pJwDz7AwwfcbxrZjQwk1gbviBiN+8ahuy2idu+bXjXlb6rXEOwb0j3MLK/HFzyeQaxJxlEBkr9mg/r7AYGSnuVhHH5eJ30OTo3ZnJ5j0oqHjDzIHD3GCqGIQGhYP+6nx2VjD6LzydolPw5kf8EhQr/CIXj4z7PjbvYQ83cyna+0+pFY5MOi13eQQQJCEypIE0IRGJolA1QiohAXECXREjaViFmY5IjhiJk5QhDLruICH5xF68SCVjLDiofuIhxJBgiLidxBJkIubwGOY4ykBACCZhktROrlknEJXRYhDhs0GY0ZdMGg3nQB+UUMYKYnUsUohJJipTNioTbZCkju3dYlCKJkbRTIS1CSvTpEGZEiFlrwMOrsjEbcOc6r3qMHIymqJbtLejSRdZ/bctqQ6GTzsr06uwO1Dpp2sGScBJtzzt/Mt06Dt+M82SicygaLq0XIHSd5DaA3frTsmhR7wHUj83qpJqbtLnUbQuzGvQpuU4uklavfgHppt+gU+1O6bFeprnJTFL8G1zELmEXRP2h7dNSf2rHWHk1aVnW2eW6AcdBq//quoSUZKuUdfc9dr0mTaxbC+weDXtuEX292WWy0pu9oVltI2PQ+dCclfl2qCpN0Z4nVbusXTUF+ay2+zstZrl2ODn2oC5Jrybl6rLLr36tj+sKet0OJrPzMi9rBLFFhQCBrp341snYrW2ksJPBTgL3iJts85zE1Em4duJbJwUU+q11ppLeTIJ7NaZxGcHi5hymT6HWAWyZsyxMe9F3WpNebU21E35fLibgO51z3V6TfKs1x8d33GV8petC594nCiBzWS4b76UbT3szXjb6z6SdnxbZP/UMouvPxCa4Fpb2otstZzo1C5joxzvwEkvsv2CrfjTTs1r3JuaugPXQuqd46KE7w26pX+py8aG4/ghec2er4+PennGT1qay3okmkHGv9Nb/MtMkkK+z4TwwvgErUps7AMjWgnhu6nS5SKH81HWAkmU7L2tXr0I4gm0U/ZoUkJdrSIDgnTYUc70AadQ6H3VuvuHq1FXBlhRUTj5BgtgcB/75FkJ4fK+/Os9O8mqe2Eq5wyNP1rCBIUJuvT+m00a3aHUSjGIIXWjU4OlvZXYXVSDNmQ4ZofLuU2ntPc9bA18qUOYCduAZjqbGKhL24rO2Vx4Gh/Bnf2fyNwQLhI3iW9nPj94hGPzTY/gVNM9eCk3qjWTfG00adppISL8/nOcvBCd3JsI17zujGfdojlgovg2cablYJEWGClfpXeqZHQ+2RUaCbcyjhFhn9dAt2/5B4lfr1tghp+lW6+FPvkLPwOaH+MGPZmeHgC2MLMTxrY/0oNIwjhyoAC+JZHT3yGyhormCCzscRKLnDPsv/zBZpl211mOUWx4/2JzbaJeOd4+jK60rWwf8UXysk6Kxr15un0OHEnXmiTrfIWpyGFGTV0IUD1XkqHGvniwxBEIgJnAd7T/sL0fSuSfpdIek9DCS0ldC0kiFkWdpxENM8fAjHGsiCjmlrzmcbImU64fSHkrofUGV7ecLSjGTbtjIXpSte0Gn+0GHu5YurmGnJZTHaIW7t8dr7PWjz/3ICkAa+bsV6YY+k8HJBMdebVbotJc/7aVOqS0/QyXimMVCKRVTphSMs07FKYeVJRx1ShEWYcppRGyyPhVeo6SEMRIxrigVWMlu4/8rvK2Nv0TYe6yZmnS/C1wARGemcfbecYR0h3q9n3oL94ZZ/Uri9L7gXG/C1yZXKsKI0YGQeob33CHBLKrcpKZ9MgnJDgnTA0iYvhISfImxvr8G6Q44hfm+XPmjgZ/sAD87APjZKwF+5EqIdV9TANRchIKpQTzIHw365ji7g7j2B890B/j3+4G/fRl6/6TLEFS9FnnbTHxz+OXSl9M0fmRIMBEywSTvblEhZfDpwyLy1xyQiTlIfO+rzvuHrjrzw4qz+dPcnmL+bRw/02lZ++tmf7e8GxAkJEpFUkZECqoU3xZxjA7PW0+AgsRFKAUSlMJUSP70YHmhuvv9Q3W3OYxa8/qp5SG9RW337oyE7FYlxXwipBGcRSyOBOMRj6gUf1lud2v0T4dx++nVc8tCiYdVL+mSpoROJEmshCIRll01QRlU18QGN8QuFBxy33X5pal96DiceXJ365DTvyVV2fz9kEOxn/JSRyPx7+/o3tfYg5qd4DBWFMLSR3AEREPy3bz/6HIzCUHiWx6OX6lMdi9EZ4dTcfayVPAuJz6yfoQTL6REEdyV75BLMYnJpnpXnokopKKv3r8rE1PPxO6t6PxwJs5fOihIxwV9HBcyCu0rg8hTKEgooogS0XPh34tHIY8x296vnkfK8fAf1tw/Wnf/Ze3d/wFQSwcIn/9OBqgIAABiJwAAUEsBAhQAFAAIAAgA8102QtY3vbkZAAAAFwAAABYAAAAAAAAAAAAAAAAAAAAAAGdlb2dlYnJhX2phdmFzY3JpcHQuanNQSwECFAAUAAgACADzXTZCn/9OBqgIAABiJwAADAAAAAAAAAAAAAAAAABdAAAAZ2VvZ2VicmEueG1sUEsFBgAAAAACAAIAfgAAAD8JAAAAAA==">

#
**)

Lemma circumcenter_perp : forall A B C A' G,
  A<>B -> B<>C -> A<>C -> G <> A' ->
  is_circumcenter G A B C ->
  Midpoint A' B C ->
  Perp_bisect G A' B C.
Proof.
intros.
apply cong_cop_perp_bisect; try assumption;
unfold Midpoint, is_circumcenter in *;
intuition eCong; Cop.
Qed.

Lemma exists_circumcenter : forall A B C,
  ~ Col A B C -> exists G, is_circumcenter G A B C.
Proof.
intros.
assert (triangle_circumscription_principle).
apply (inter_dec_plus_par_perp_perp_imply_triangle_circumscription).
unfold decidability_of_intersection; apply inter_dec.
unfold perpendicular_transversal_postulate.
intros; apply cop_par_perp__perp with A0 B0; auto.
unfold triangle_circumscription_principle in *.
destruct (H0 A B C H) as [G HG].
exists G.
unfold is_circumcenter.
spliter.
repeat split;eCong; Cop.
Qed.

Lemma circumcenter_perp_all : forall A B C A' B' C' G,
  A<>B -> B<>C -> A<>C -> G <> A' -> G <> B' -> G <> C' ->
  is_circumcenter G A B C ->
  Midpoint A' B C ->
  Midpoint B' A C ->
  Midpoint C' A B ->
  Perp_bisect G A' B C /\ Perp_bisect G B' A C /\ Perp_bisect G C' A B.
Proof.
intros.
split; try apply cong_cop_perp_bisect; try (split; try apply cong_cop_perp_bisect);
try assumption;
unfold is_circumcenter in *;
intuition eCong; Cop.
Qed.

Lemma circumcenter_intersect : forall A B C A' B' C' G,
  A<>B -> B<>C -> A<>C -> G <> A' -> G <> B' -> G <> C' ->
  Midpoint A' B C ->
  Midpoint B' A C ->
  Midpoint C' A B ->
  Perp_bisect G A' B C ->
  Perp_bisect G B' A C ->
  Perp G C' A B.
Proof.
intros.
assert (Cong B G C G).
 apply (perp_bisect_cong2 G A' B C ).
 assumption.
assert (Cong A G B G).
 assert (Cong A G C G).
  apply (perp_bisect_cong2 G B' A C).
  assumption.
 eCong.
apply perp_col1 with C'; Col.
apply perp_right_comm.
apply per_perp; auto.
 apply midpoint_distinct_1 with B; Midpoint.
exists B.
split; Cong.
Qed.

Lemma is_circumcenter_uniqueness :
   forall A B C O O',
  A<>B -> B<>C -> A<>C ->
  is_circumcenter O A B C ->
  is_circumcenter O' A B C ->
  O = O'.
Proof.
intros A B C O O' HAB HBC HAC HIC1 HIC2.
elim (col_dec A B C); intro HABC.

  {
  Name C' the midpoint of A and B.
  assert (HPer1 : Perp_bisect O C' A B).
    {
    apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; Cong; Cop.
    intro; treat_equalities; assert (HFalse := l7_20 O B C); elim HFalse; clear HFalse;
    try intro HFalse; Cong; assert_cols; ColR.
    }
  Name A' the midpoint of B and C.
  assert (HPer2 : Perp_bisect O A' B C).
    {
    apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; Cong; Cop.
    intro; treat_equalities; assert (HFalse := l7_20 O A B); elim HFalse; clear HFalse;
    try intro HFalse; Cong; assert_cols; ColR.

    }
  assert (HPar : Par_strict O A' O C').
    {
    apply par_not_col_strict with C'; Col.

      {
      apply l12_9 with A B; [Cop..| |Cop| |apply perp_bisect_perp; assumption].
        apply col__coplanar; ColR.
      apply perp_col0 with B C; Col; apply perp_sym; apply perp_bisect_perp; Col.
      }

      {
      show_distinct A' C'; try (apply HAC; apply symmetric_point_uniqueness with B A';
      unfold Midpoint in *; spliter; split; Cong; Between).
      intro; assert (HFalse := l7_20 O A B); elim HFalse; clear HFalse; try intro HFalse;
      unfold is_circumcenter in *; spliter; Cong; assert_diffs; assert_cols; try ColR.
      assert (HOC' : O <> C').
        {
        apply perp_bisect_equiv_def in HPer1.
        apply perp_bisect_equiv_def in HPer2.
        unfold Perp_bisect in *; unfold Perp_at in *;
        destruct HPer1 as [I [HOC' Hc1]]; assert_diffs; Col.
        }
      apply HOC'; apply l7_17 with A B; Col.
      }
    }
  assert (HFalse := not_par_strict_id O A' C'); exfalso; apply HFalse; Col.
  }

  {
  Name C' the midpoint of A and B.
  elim (eq_dec_points O C'); intro HOC'; elim (eq_dec_points O' C'); intro HO'C';
  treat_equalities; Col.

    {
    assert (HPer : Per A C B).
      {
      apply midpoint_thales with O; unfold is_circumcenter in *;
      spliter; Col; try split; eCong.
      }
    Name B' the midpoint of A and C.
    assert (HO'B' : O' <> B').
      {
      intro; treat_equalities.
      assert (HPer2 : Per A B C).
        {
        apply midpoint_thales with O'; unfold is_circumcenter in *;
        spliter; Col; try split; eCong.
        }
      assert (HPar : Par_strict A B A C).
        {
        apply par_not_col_strict with C; Col.
        apply l12_9 with B C; [Cop..| |apply perp_right_comm]; apply per_perp; Perp.
        }
      assert (HFalse := not_par_strict_id A B C); exfalso; apply HFalse; Col.
      }
    Name A' the midpoint of B and C.
    assert (HO'A' : O' <> A').
      {
      intro; treat_equalities.
      assert (HPer2 : Per B A C).
        {
        apply midpoint_thales with O'; unfold is_circumcenter in *;
        spliter; Col; try split; eCong.
        }
      assert (HPar : Par_strict B A B C).
        {
        apply par_not_col_strict with C; Col.
        apply l12_9 with A C; [Cop..| |apply perp_right_comm]; apply per_perp; Perp.
        }
      assert (HFalse := not_par_strict_id B A C); exfalso; apply HFalse; Col.
      }
    assert (H : Perp_bisect O' A' B C /\ Perp_bisect O' B' A C /\ Perp_bisect O' O A B).
      {
      apply circumcenter_perp_all; Col.
      }
    destruct H as [HPer3 [HPer4 Hc]]; clear Hc.
    assert (HPer1 : Perp_bisect O A' B C).
      {
      apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; Cong; Cop.
      show_distinct O B; Col.
      intro; treat_equalities; apply HABC; assert_cols; ColR.
      }
    assert (HPer2 : Perp_bisect O B' A C).
      {
      apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
      show_distinct O A; Col.
      intro; treat_equalities; apply HABC; assert_cols; ColR.
      }
    apply l6_21 with O A' B' O'; Col.

      {
      assert (HRect : Rectangle C B' O A').
        {
        apply Per_mid_rectangle with B A; Perp; unfold Midpoint in *; spliter;
        split; Between; Cong.
        }
      destruct HRect as [HPara Hc]; clear Hc.
      apply plg_to_parallelogram in HPara.
      apply plg_permut in HPara.
      intro HOA'B'; apply plg_col_plgf in HPara; Col.
      destruct HPara as [Hc1 [HCol2 Hc2]]; clear Hc1; clear Hc2.
      assert_diffs; assert_cols; apply HABC; ColR.
      }

      {
      apply col_permutation_2; apply cop_perp2__col with B C;
        [|apply perp_bisect_perp;apply perp_bisect_sym_1; auto..].
      apply coplanar_trans_1 with A; Col; Cop.
      }

      {
      apply col_permutation_5; apply cop_perp2__col with A C;
        [|apply perp_bisect_perp;apply perp_bisect_sym_1; auto..].
      apply coplanar_trans_1 with B; Col; Cop.
      }
    }

    {
    assert (HPer : Per A C B).
      {
      apply midpoint_thales with O'; unfold is_circumcenter in *;
      spliter; Col; try split; eCong.
      }
    Name B' the midpoint of A and C.
    assert (HOB' : O <> B').
      {
      intro; treat_equalities.
      assert (HPer2 : Per A B C).
        {
        apply midpoint_thales with O; unfold is_circumcenter in *;
        spliter; Col; try split; eCong.
        }
      assert (HPar : Par_strict A B A C).
        {
        apply par_not_col_strict with C; Col.
        apply l12_9 with B C; [Cop..| |apply perp_right_comm]; apply per_perp; Perp.
        }
      assert (HFalse := not_par_strict_id A B C); exfalso; apply HFalse; Col.
      }
    Name A' the midpoint of B and C.
    assert (HOA' : O <> A').
      {
      intro; treat_equalities.
      assert (HPer2 : Per B A C).
        {
        apply midpoint_thales with O; unfold is_circumcenter in *;
        spliter; Col; try split; eCong.
        }
      assert (HPar : Par_strict B A B C).
        {
        apply par_not_col_strict with C; Col.
        apply l12_9 with A C; [Cop..| |apply perp_right_comm]; apply per_perp; Perp.
        }
      assert (HFalse := not_par_strict_id B A C); exfalso; apply HFalse; Col.
      }
    assert (H : Perp_bisect O A' B C /\ Perp_bisect O B' A C /\ Perp_bisect O O' A B).
      {
      apply circumcenter_perp_all; Col.
      }
    destruct H as [HPer3 [HPer4 Hc]]; clear Hc.
    assert (HPer1 : Perp_bisect O' A' B C).
      {
      apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; Cong; Cop.
      show_distinct O' B; Col.
      intro; treat_equalities; apply HABC; assert_cols; ColR.
      }
    assert (HPer2 : Perp_bisect O' B' A C).
      {
      apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
      show_distinct O' A; Col.
      intro; treat_equalities; apply HABC; assert_cols; ColR.
      }
    apply l6_21 with O' A' B' O; Col.

      {
      assert (HRect : Rectangle C B' O' A').
        {
        apply Per_mid_rectangle with B A; Perp; split; Between; Cong.
        }
      destruct HRect as [HPara Hc]; clear Hc.
      apply plg_to_parallelogram in HPara.
      apply plg_permut in HPara.
      intro HO'A'B'; apply plg_col_plgf in HPara; Col.
      destruct HPara as [Hc1 [HCol2 Hc2]]; clear Hc1; clear Hc2.
      assert_diffs; assert_cols; apply HABC; ColR.
      }

      {
      apply col_permutation_2; apply cop_perp2__col with B C;
        [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
      apply coplanar_trans_1 with A; Cop.
      }

      {
      apply col_permutation_5; apply cop_perp2__col with A C;
        [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
      apply coplanar_trans_1 with B; Col; Cop.
      }
    }

    {
    Name B' the midpoint of A and C.
    elim (eq_dec_points O B'); intro HOB'; elim (eq_dec_points O' B'); intro HO'B';
    treat_equalities; Col.

      {
      assert (HPer : Per A B C).
        {
        apply midpoint_thales with O; unfold is_circumcenter in *;
        spliter; Col; try split; eCong.
        }
      Name A' the midpoint of B and C.
      assert (HO'A' : O' <> A').
        {
        intro; treat_equalities.
        assert (HPer2 : Per B A C).
          {
          apply midpoint_thales with O'; unfold is_circumcenter in *;
          spliter; Col; try split; eCong.
          }
        assert (HPar : Par_strict A C B C).
          {
          apply par_not_col_strict with B; Col.
          apply l12_9 with A B; [Cop..|apply perp_left_comm|apply perp_comm]; apply per_perp; Perp.
          }
        assert (HFalse := not_par_strict_id C A B); exfalso; apply HFalse; Par.
        }
      assert (H : Perp_bisect O' A' B C /\ Perp_bisect O' O A C /\ Perp_bisect O' C' A B).
        {
        apply circumcenter_perp_all; Col.
        }
      destruct H as [HPer3 [Hc HPer4]]; clear Hc.
      assert (HPer1 : Perp_bisect O A' B C).
        {
        apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; Cong; Cop.
        show_distinct O C; Col.
        intro; treat_equalities; apply HABC; assert_cols; ColR.
        }
      assert (HPer2 : Perp_bisect O C' A B).
        {
        apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
        }
      apply l6_21 with O A' C' O'; Col.

        {
        assert (HRect : Rectangle B A' O C').
          {
          apply Per_mid_rectangle with A C; Perp; split; Between; Cong.
          }
        destruct HRect as [HPara Hc]; clear Hc.
        apply plg_to_parallelogram in HPara.
        apply plg_permut in HPara.
        intro HOA'C'; apply plg_col_plgf in HPara; Col.
        destruct HPara as [Hc1 [HCol2 Hc2]]; clear Hc1; clear Hc2.
        assert_diffs; assert_cols; apply HABC; ColR.
        }

        {
        apply col_permutation_2; apply cop_perp2__col with B C;
          [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
        apply coplanar_trans_1 with A; Cop.
        }

        {
        apply col_permutation_5; apply cop_perp2__col with A B;
          [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
        apply coplanar_trans_1 with C; Col; Cop.
        }
      }

      {
      assert (HPer : Per A B C).
        {
        apply midpoint_thales with O'; unfold is_circumcenter in *;
        spliter; Col; try split; eCong.
        }
      Name A' the midpoint of B and C.
      assert (HOA' : O <> A').
        {
        intro; treat_equalities.
        assert (HPer2 : Per B A C).
          {
          apply midpoint_thales with O; unfold is_circumcenter in *;
          spliter; Col; try split; eCong.
          }
        assert (HPar : Par_strict A C B C).
          {
          apply par_not_col_strict with B; Col.
          apply l12_9 with A B; [Cop..|apply perp_left_comm|apply perp_comm]; apply per_perp; Perp.
          }
        assert (HFalse := not_par_strict_id C A B); exfalso; apply HFalse; Par.
        }
      assert (H : Perp_bisect O A' B C /\ Perp_bisect O O' A C /\ Perp_bisect O C' A B).
        {
        apply circumcenter_perp_all; Col.
        }
      destruct H as [HPer3 [Hc HPer4]]; clear Hc.
      assert (HPer1 : Perp_bisect O' A' B C).
        {
        apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; Cong; Cop.
        show_distinct O' C; Col.
        intro; treat_equalities; apply HABC; assert_cols; ColR.
        }
      assert (HPer2 : Perp_bisect O' C' A B).
        {
        apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
        }
      apply l6_21 with O' A' C' O; Col.

        {
        assert (HRect : Rectangle B A' O' C').
          {
          apply Per_mid_rectangle with A C; Perp; split; Between; Cong.
          }
        destruct HRect as [HPara Hc]; clear Hc.
        apply plg_to_parallelogram in HPara.
        apply plg_permut in HPara.
        intro HO'A'C'; apply plg_col_plgf in HPara; Col.
        destruct HPara as [Hc1 [HCol2 Hc2]]; clear Hc1; clear Hc2.
        assert_diffs; assert_cols; apply HABC; ColR.
        }

        {
        apply col_permutation_2; apply cop_perp2__col with B C;
          [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
        apply coplanar_trans_1 with A; Cop.
        }

        {
        apply col_permutation_5; apply cop_perp2__col with A B;
          [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
        apply coplanar_trans_1 with C; Col; Cop.
        }
      }

      {
      Name A' the midpoint of B and C.
      elim (eq_dec_points O A'); intro HOA'; elim (eq_dec_points O' A'); intro HO'A';
      treat_equalities; Col.

        {
        assert (HPer : Per C A B).
          {
          apply midpoint_thales with O; unfold is_circumcenter in *;
          spliter; Col; try split; eCong; Between.
          }
        assert (H : Perp_bisect O' O B C /\ Perp_bisect O' B' A C /\ Perp_bisect O' C' A B).
          {
          apply circumcenter_perp_all; Col.
          }
        destruct H as [Hc [HPer3 HPer4]]; clear Hc.
        assert (HPer1 : Perp_bisect O B' A C).
          {
          apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
          }
        assert (HPer2 : Perp_bisect O C' A B).
          {
          apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
          }
        apply l6_21 with O B' C' O'; Col.

          {
          assert (HRect : Rectangle A B' O C').
            {
            apply Per_mid_rectangle with B C; Perp; split; Between; Cong.
            }
          destruct HRect as [HPara Hc]; clear Hc.
          apply plg_to_parallelogram in HPara.
          apply plg_permut in HPara.
          intro HOB'C'; apply plg_col_plgf in HPara; Col.
          destruct HPara as [Hc1 [HCol2 Hc2]]; clear Hc1; clear Hc2.
          assert_diffs; assert_cols; apply HABC; ColR.
          }

          {
          apply col_permutation_2; apply cop_perp2__col with A C;
            [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
          apply coplanar_trans_1 with B; Col; Cop.
          }

          {
          apply col_permutation_5; apply cop_perp2__col with A B;
            [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
          apply coplanar_trans_1 with C; Col; Cop.
          }
        }

        {
        assert (HPer : Per C A B).
          {
          apply midpoint_thales with O'; unfold is_circumcenter in *;
          spliter; Col; try split; eCong; Between.
          }
        assert (H : Perp_bisect O O' B C /\ Perp_bisect O B' A C /\ Perp_bisect O C' A B).
          {
          apply circumcenter_perp_all; Col.
          }
        destruct H as [Hc [HPer3 HPer4]]; clear Hc.
        assert (HPer1 : Perp_bisect O' B' A C).
          {
          apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
          }
        assert (HPer2 : Perp_bisect O' C' A B).
          {
          apply cong_cop_perp_bisect; unfold is_circumcenter in *; spliter; eCong; Cop.
          }
        apply l6_21 with O' B' C' O; Col.

          {
          assert (HRect : Rectangle A B' O' C').
            {
            apply Per_mid_rectangle with B C; Perp; split; Between; Cong.
            }
          destruct HRect as [HPara Hc]; clear Hc.
          apply plg_to_parallelogram in HPara.
          apply plg_permut in HPara.
          intro HO'B'C'; apply plg_col_plgf in HPara; Col.
          destruct HPara as [Hc1 [HCol2 Hc2]]; clear Hc1; clear Hc2.
          assert_diffs; assert_cols; apply HABC; ColR.
          }

          {
          apply col_permutation_2; apply cop_perp2__col with A C;
            [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
          apply coplanar_trans_1 with B; Col; Cop.
          }

          {
          apply col_permutation_5; apply cop_perp2__col with A B;
            [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
          apply coplanar_trans_1 with C; Col; Cop.
          }
        }

        {
        assert (H : Perp_bisect O A' B C /\ Perp_bisect O B' A C /\ Perp_bisect O C' A B).
          {
          apply circumcenter_perp_all; Col.
          }
        destruct H as [HPer1 [HPer2 Hc]]; clear Hc.
        assert (H : Perp_bisect O' A' B C /\ Perp_bisect O' B' A C /\ Perp_bisect O' C' A B).
          {
          apply circumcenter_perp_all; Col.
          }
        destruct H as [HPer3 [HPer4 Hc]]; clear Hc.
        apply l6_21 with O A' B' O; Col.

          {
          intro HOA'B'; assert (HPar : Par_strict A C C B).
            {
            apply par_not_col_strict with B; Col.
            apply l12_9 with O A'; [| |Cop..| |].
              apply coplanar_perm_4, col_cop__cop with B; Col; Cop.
              apply coplanar_perm_4, col_cop__cop with C; Col; Cop.
              apply perp_col0 with O B'; Col; apply perp_bisect_perp; assumption.
            apply perp_sym; apply perp_right_comm; apply perp_bisect_perp; Col.
            }
          assert (HFalse := not_par_strict_id C A B); apply HFalse; Par.
          }

          {
          apply col_permutation_2; apply cop_perp2__col with B C;
            [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
          apply coplanar_trans_1 with A; Cop.
          }

          {
          apply col_permutation_5; apply cop_perp2__col with A C;
            [|apply perp_bisect_perp, perp_bisect_sym_1; auto..].
          apply coplanar_trans_1 with B; Col; Cop.
          }
        }
      }
    }
  }
Qed.

End Circumcenter2.

Section Circumcenter3.

Context `{TE:Tarski_euclidean}.

Lemma midpoint_thales_reci_circum :
  forall A B C O: Tpoint,
   Per A C B ->
   Midpoint O A B ->
   is_circumcenter O A B C.
Proof.
intros.
assert (T:= midpoint_thales_reci A B C O H H0).
spliter.
split;finish.
Qed.

Lemma circumcenter_per :
 forall A B C O,
 A<>B -> B<>C ->
 Per A B C ->
 is_circumcenter O A B C ->
 Midpoint O A C.
Proof.
intros.

Name O' the midpoint of A and C.
assert (T:= midpoint_thales_reci_circum A C B O' H1 H4).
assert (O=O').
apply is_circumcenter_uniqueness with A B C;finish.
intro.
treat_equalities.
apply l8_8 in H1.
intuition.
auto using is_circumcenter_perm_1.
subst;auto.
Qed.

End Circumcenter3.


Require Import String.

From CoqMTL Require Import Control.

(** * Datat types à la carte *)

(** Based on paper of the same name by Wouter Swierstra. *)

(** ** 1 Introduction *)

(** ** 2 Fixing the expression problem *)

Fail Inductive Expr (F : Type -> Type) : Type :=
    | In : F (Expr F) -> Expr F.

Definition Expr (F : Type -> Type) : Type :=
  forall (X : Type), (F X -> X) -> X.

Inductive Val (E : Type) : Type :=
    | Val' : nat -> Val E.

Arguments Val' {E} _.

Inductive Add (E : Type) : Type :=
    | Add' : E -> E -> Add E.

Arguments Add' {E} _ _.

Inductive Coproduct (F G : Type -> Type) (E : Type) :=
    | Inl : F E -> Coproduct F G E
    | Inr : G E -> Coproduct F G E.

Arguments Inl {F G E} _.
Arguments Inr {F G E} _.

Notation "F :+: G" := (Coproduct F G) (right associativity, at level 42).

Definition addExample : Expr (Val :+: Add) :=
  fun X In =>
    In (Inr (Add' (In (Inl (Val' 118))) (In (Inl (Val' 1219))))).

(** ** 3 Evaluation *)

#[refine]
#[export]
Instance Functor_Val : Functor Val :=
{
    fmap := fun (A B : Type) (f : A -> B) (va : Val A) =>
      match va with Val' a => Val' a end
}.
Proof.
  all: intros; ext x; destruct x; compute; reflexivity.
Defined.

#[refine]
#[export]
Instance Functor_Add : Functor Add :=
{
    fmap := fun (A B : Type) (f : A -> B) (ax : Add A) =>
      match ax with Add' e1 e2 => Add' (f e1) (f e2) end
}.
Proof.
  all: intros; ext x; destruct x; compute; reflexivity.
Defined.

#[refine]
#[export]
Instance Functor_Coproduct
  (F G : Type -> Type) (instF : Functor F) (instG : Functor G)
  : Functor (F :+: G) :=
{
    fmap := fun (A B : Type) (f : A -> B) (x : Coproduct F G A) =>
    match x with
        | Inl e => Inl (fmap f e)
        | Inr e => Inr (fmap f e)
    end
}.
Proof.
  all: intros; ext x; destruct x; hs.
Defined.

Definition foldExpr
  {F : Type -> Type} {inst : Functor F} {A : Type}
  (f : F A -> A) (x : Expr F) : A :=
    x _ f.

Class Eval (F : Type -> Type) (inst : Functor F) : Type :=
{
    evalAlgebra : F nat -> nat
}.

#[export]
Instance Eval_Val : Eval Val Functor_Val :=
{
    evalAlgebra := fun x : Val nat => match x with Val' n => n end
}.

#[export]
Instance Eval_Add : Eval Add Functor_Add :=
{
    evalAlgebra := fun x : Add nat => match x with Add' n m => n + m end
}.

#[export]
Instance Eval_Coproduct
  (F G : Type -> Type) (instF : Functor F) (instG : Functor G)
  (instEF : Eval F instF) (instEG : Eval G instG)
  : Eval (F :+: G) (Functor_Coproduct F G instF instG) :=
{
    evalAlgebra := fun x : (F :+: G) nat =>
    match x with
        | Inl e => evalAlgebra e
        | Inr e => evalAlgebra e
    end
}.

Definition eval
  {F : Type -> Type} {instF : Functor F} {instE : Eval F instF}
  (x : Expr F) : nat := foldExpr evalAlgebra x.

Compute eval addExample.

(** ** 4 Automating injections *)

Class Sub (F G : Type -> Type) : Type :=
{
    inj : forall {A : Type}, F A -> G A
}.

Notation "F :<: G" := (Sub F G) (at level 42).

#[export]
Instance Sub_refl (F : Type -> Type) : Sub F F :=
{
    inj := fun A : Type => @id (F A)
}.

#[export]
Instance Sub_Coproduct (F G : Type -> Type) : Sub F (F :+: G) :=
{
    inj := @Inl F G
}.

#[export]
Instance Sub_Rec
  (F G H : Type -> Type) (inst : Sub F H) : Sub F (G :+: H) :=
{
    inj := fun A : Type => @inj F H inst A .> Inr
}.

Definition inject
  (F G : Type -> Type) (inst : Sub F G) (x : F (Expr G)) : Expr G.
Proof.
  destruct inst as [inj]. unfold Expr in *.
  intros X In.
  apply inj in x. apply In. firstorder.
Abort.

Definition val
  {F : Type -> Type} {inst : Val :<: F} (x : nat) : Expr F :=
    fun X In => In (inj (Val' x)).

Definition add
  {F : Type -> Type} {inst : Add :<: F} (e1 e2 : Expr F) : Expr F :=
    fun X In => In (inj (Add' (e1 _ In) (e2 _ In))).

Eval cbn in
  let x : Expr (Add :+: Val) := add (val 1000) (add (val 330) (val 7))
  in eval x.

(** ** 5 Examples *)

Inductive Mul (E : Type) : Type :=
    | Mul' : E -> E -> Mul E.

Arguments Mul' {E} _ _.

#[refine]
#[export]
Instance Functor_Mul : Functor Mul :=
{
    fmap := fun A B f x => match x with Mul' e1 e2 => Mul' (f e1) (f e2) end
}.
Proof.
  all: intros; ext x; destruct x; hs.
Defined.

#[export]
Instance Eval_Mul : Eval Mul Functor_Mul :=
{
    evalAlgebra := fun '(Mul' x y) => x * y
}.

Definition mul
  {F : Type -> Type} {inst : Mul :<: F} (e1 e2 : Expr F) : Expr F :=
    fun X In => In (inj (Mul' (e1 _ In) (e2 _ In))).

Eval cbn in
  let
    x : Expr (Mul :+: Add :+: Val) :=
      add (val 1000) (mul (val 33) (val 7))
  in eval x.

Open Scope string.

(* Problem! *)
Fail Inductive Render (F : Type -> Type) : Type :=
{
    render : forall {G : Type -> Type} {inst : Render G}, F (Expr G) -> string
}.

Fail Inductive Render (F : Type -> Type) : Type :=
    | C : forall (G : Type -> Type),
            (Render G -> F (Expr G) -> string) -> Render F.

Definition Render : (Type -> Type) -> Type :=
  fun F : Type -> Type =>
    forall Render : (Type -> Type) -> Type,
      ((forall G : Type -> Type, Render G -> F (Expr G) -> string) -> Render F)
      -> Render F.

Class RenderClass (F : Type -> Type) : Type :=
{
    render : Render F;
}.

Definition render_Val : Render Val :=
  fun _ f => f (fun _ _ _ => "42").

#[export]
Instance Render_Val : RenderClass Val :=
{
    render := render_Val
}.

Definition render_Add : Render Add.
Proof.
  red. intros R f.
  apply f. intros G wut x. destruct x as [e1 e2].
Abort.


(*|
###################################
Cannot rewrite goal with assertion?
###################################

:Link: https://stackoverflow.com/q/70490662
|*)

(*|
Question
********

I am not sure I understand why in some cases rewriting ``H`` works,
and in some it doesnt. Here for example:
|*)

Require Import PeanoNat.

Theorem add_assoc2 : forall n m : nat, n + m = m + n.
Proof. intros. rewrite Nat.add_comm. reflexivity. Qed.

Theorem plus_4 : forall n m p q : nat,
    n + (n * p) + m + (m * p) = n + m + (n * p) + (m * p).
Proof.
  intros.
  assert (H : n * p + m = m + n * p).
  { rewrite <- add_assoc2. reflexivity. }
  Fail rewrite H. (* .fails *)

(*| Gives: |*)

  Show. (* .unfold .messages *)

(*| But Coq complains: |*)

  Fail rewrite H. (* .unfold .messages *)
Abort. (* .none *)

(*|
I clearly see one, on the left side. When using induction, rewriting
with ``IHn`` doesn't pose any problem, even if there are some other
terms in front of rewriteable expression.
|*)

(*|
Answer
******

You can "see" a subterm ``n * p + m``, but this is misleading: Coq
doesn't show you the implicit parentheses around all the ``+``
expressions.

Use
|*)

Set Printing Parentheses.

(*|
to make them visible. Your proof state is really:

.. coq:: none
|*)

Theorem plus_4 : forall n m p q : nat,
    n + (n * p) + m + (m * p) = n + m + (n * p) + (m * p).
Proof.
  intros.
  assert (H : n * p + m = m + n * p).
  { rewrite <- add_assoc2. reflexivity. }

(*||*)

  Show. (* .unfold .messages *)

(*|
Coq was right that there is no subterm that matches ``H``'s left hand
side expression ``((n * p) + m)``. You need to rewrite using some
associativity lemmas to shift the parentheses around.

Also, ``add_assoc2`` is not a good name for a lemma ``forall n m :
nat, n + m = m + n``. This is a **commutativity** property, not
associativity.
|*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * An light axiomatization of integers (used in MSetAVL). *)

(** We define a signature for an integer datatype based on [Z].
    The goal is to allow a switch after extraction to ocaml's
    [big_int] or even [int] when finiteness isn't a problem
    (typically : when mesuring the height of an AVL tree).
*)

Require Import BinInt.
Delimit Scope Int_scope with I.
Local Open Scope Int_scope.

(** * A specification of integers *)

Module Type Int.

  Parameter t : Set.
  Bind Scope Int_scope with t.

  Parameter i2z : t -> Z.

  Parameter _0 : t.
  Parameter _1 : t.
  Parameter _2 : t.
  Parameter _3 : t.
  Parameter add : t -> t -> t.
  Parameter opp : t -> t.
  Parameter sub : t -> t -> t.
  Parameter mul : t -> t -> t.
  Parameter max : t -> t -> t.

  Notation "0" := _0 : Int_scope.
  Notation "1" := _1 : Int_scope.
  Notation "2" := _2 : Int_scope.
  Notation "3" := _3 : Int_scope.
  Infix "+" := add : Int_scope.
  Infix "-" := sub : Int_scope.
  Infix "*" := mul : Int_scope.
  Notation "- x" := (opp x) : Int_scope.

  (** For logical relations, we can rely on their counterparts in Z,
      since they don't appear after extraction. Moreover, using tactics
      like omega is easier this way. *)

  Notation "x == y" := (i2z x = i2z y)
    (at level 70, y at next level, no associativity) : Int_scope.
  Notation "x <= y" := (i2z x <= i2z y)%Z : Int_scope.
  Notation "x < y" := (i2z x < i2z y)%Z : Int_scope.
  Notation "x >= y" := (i2z x >= i2z y)%Z : Int_scope.
  Notation "x > y" := (i2z x > i2z y)%Z : Int_scope.
  Notation "x <= y <= z" := (x <= y /\ y <= z) : Int_scope.
  Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope.
  Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
  Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.

  (** Informative comparisons. *)

  Axiom eqb : t -> t -> bool.
  Axiom ltb : t -> t -> bool.
  Axiom leb : t -> t -> bool.

  Infix "=?" := eqb.
  Infix "<?" := ltb.
  Infix "<=?" := leb.

  (** For compatibility, some decidability fonctions (informative). *)

  Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}.
  Axiom ge_lt_dec :  forall x y : t, {x >= y} + {x < y}.
  Axiom eq_dec : forall x y : t, { x == y } + {~ x==y }.

  (** Specifications *)

  (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality
      [==] and the generic [=] are in fact equivalent. We define [==]
      nonetheless since the translation to [Z] for using automatic tactic
      is easier. *)

  Axiom i2z_eq : forall n p : t, n == p -> n = p.

   (** Then, we express the specifications of the above parameters using their
       Z counterparts. *)

  Axiom i2z_0 : i2z _0 = 0%Z.
  Axiom i2z_1 : i2z _1 = 1%Z.
  Axiom i2z_2 : i2z _2 = 2%Z.
  Axiom i2z_3 : i2z _3 = 3%Z.
  Axiom i2z_add : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
  Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z.
  Axiom i2z_sub : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
  Axiom i2z_mul : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
  Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p).
  Axiom i2z_eqb : forall n p, eqb n p = Z.eqb (i2z n) (i2z p).
  Axiom i2z_ltb : forall n p, ltb n p = Z.ltb (i2z n) (i2z p).
  Axiom i2z_leb : forall n p, leb n p = Z.leb (i2z n) (i2z p).

End Int.

(** * Facts and  tactics using [Int] *)

Module MoreInt (Import I:Int).
  Local Notation int := I.t.

  Lemma eqb_eq n p : (n =? p) = true <-> n == p.
  Proof.
   now rewrite i2z_eqb, Z.eqb_eq.
  Qed.

  Lemma eqb_neq n p : (n =? p) = false <-> ~(n == p).
  Proof.
   rewrite <- eqb_eq. destruct (n =? p); intuition.
  Qed.

  Lemma ltb_lt n p : (n <? p) = true <-> n < p.
  Proof.
   now rewrite i2z_ltb, Z.ltb_lt.
  Qed.

  Lemma ltb_nlt n p : (n <? p) = false <-> ~(n < p).
  Proof.
   rewrite <- ltb_lt. destruct (n <? p); intuition.
  Qed.

  Lemma leb_le n p : (n <=? p) = true <-> n <= p.
  Proof.
   now rewrite i2z_leb, Z.leb_le.
  Qed.

  Lemma leb_nle n p : (n <=? p) = false <-> ~(n <= p).
  Proof.
   rewrite <- leb_le. destruct (n <=? p); intuition.
  Qed.

  (** A magic (but costly) tactic that goes from [int] back to the [Z]
      friendly world ... *)

  Hint Rewrite ->
    i2z_0 i2z_1 i2z_2 i2z_3 i2z_add i2z_opp i2z_sub i2z_mul i2z_max
    i2z_eqb i2z_ltb i2z_leb : i2z.

  Ltac i2z := match goal with
    | H : ?a = ?b |- _ =>
      generalize (f_equal i2z H);
	try autorewrite with i2z; clear H; intro H; i2z
    | |- ?a = ?b =>
      apply (i2z_eq a b); try autorewrite with i2z; i2z
    | H : _ |- _ => progress autorewrite with i2z in H; i2z
    | _ => try autorewrite with i2z
  end.

  (** A reflexive version of the [i2z] tactic *)

  (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a
      [i2z] is buried deep inside a subterm, [i2z_refl] may miss it.
      See also the limitation about [Set] or [Type] part below.
      Anyhow, [i2z_refl] is enough for applying [romega]. *)

  Ltac i2z_gen := match goal with
    | |- ?a = ?b => apply (i2z_eq a b); i2z_gen
    | H : ?a = ?b |- _ =>
       generalize (f_equal i2z H); clear H; i2z_gen
    | H : eq (A:=Z) ?a ?b |- _ => revert H; i2z_gen
    | H : Z.lt ?a ?b |- _ => revert H; i2z_gen
    | H : Z.le ?a ?b |- _ => revert H; i2z_gen
    | H : Z.gt ?a ?b |- _ => revert H; i2z_gen
    | H : Z.ge ?a ?b |- _ => revert H; i2z_gen
    | H : _ -> ?X |- _ =>
      (* A [Set] or [Type] part cannot be dealt with easily
         using the [ExprP] datatype. So we forget it, leaving
         a goal that can be weaker than the original. *)
      match type of X with
       | Type => clear H; i2z_gen
       | Prop => revert H; i2z_gen
      end
    | H : _ <-> _ |- _ => revert H; i2z_gen
    | H : _ /\ _ |- _ => revert H; i2z_gen
    | H : _ \/ _ |- _ => revert H; i2z_gen
    | H : ~ _ |- _ => revert H; i2z_gen
    | _ => idtac
   end.

  Inductive ExprI : Set :=
    | EI0 : ExprI
    | EI1 : ExprI
    | EI2 : ExprI
    | EI3 : ExprI
    | EIadd : ExprI -> ExprI -> ExprI
    | EIopp : ExprI -> ExprI
    | EIsub : ExprI -> ExprI -> ExprI
    | EImul : ExprI -> ExprI -> ExprI
    | EImax : ExprI -> ExprI -> ExprI
    | EIraw : int -> ExprI.

  Inductive ExprZ : Set :=
    | EZadd : ExprZ -> ExprZ -> ExprZ
    | EZopp : ExprZ -> ExprZ
    | EZsub : ExprZ -> ExprZ -> ExprZ
    | EZmul : ExprZ -> ExprZ -> ExprZ
    | EZmax : ExprZ -> ExprZ -> ExprZ
    | EZofI : ExprI -> ExprZ
    | EZraw : Z -> ExprZ.

  Inductive ExprP : Type :=
    | EPeq : ExprZ -> ExprZ -> ExprP
    | EPlt : ExprZ -> ExprZ -> ExprP
    | EPle : ExprZ -> ExprZ -> ExprP
    | EPgt : ExprZ -> ExprZ -> ExprP
    | EPge : ExprZ -> ExprZ -> ExprP
    | EPimpl : ExprP -> ExprP -> ExprP
    | EPequiv : ExprP -> ExprP -> ExprP
    | EPand : ExprP -> ExprP -> ExprP
    | EPor : ExprP -> ExprP -> ExprP
    | EPneg : ExprP -> ExprP
    | EPraw : Prop -> ExprP.

  (** [int] to [ExprI] *)

  Ltac i2ei trm :=
    match constr:(trm) with
      | 0 => constr:(EI0)
      | 1 => constr:(EI1)
      | 2 => constr:(EI2)
      | 3 => constr:(EI3)
      | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey)
      | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey)
      | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey)
      | max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey)
      | - ?x => let ex := i2ei x in constr:(EIopp ex)
      | ?x => constr:(EIraw x)
    end

  (** [Z] to [ExprZ] *)

    with z2ez trm :=
    match constr:(trm) with
      | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey)
      | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey)
      | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey)
      | (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
      | (- ?x)%Z =>  let ex := z2ez x in constr:(EZopp ex)
      | i2z ?x => let ex := i2ei x in constr:(EZofI ex)
      | ?x => constr:(EZraw x)
    end.

  (** [Prop] to [ExprP] *)

  Ltac p2ep trm :=
    match constr:(trm) with
      | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey)
      | (?x -> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPimpl ex ey)
      | (?x /\ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPand ex ey)
      | (?x \/ ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPor ex ey)
      | (~ ?x) => let ex := p2ep x in constr:(EPneg ex)
      | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey)
      | (?x < ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey)
      | (?x <= ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)
      | (?x > ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)
      | (?x >= ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey)
      | ?x =>  constr:(EPraw x)
    end.

  (** [ExprI] to [int] *)

  Fixpoint ei2i (e:ExprI) : int :=
    match e with
      | EI0 => 0
      | EI1 => 1
      | EI2 => 2
      | EI3 => 3
      | EIadd e1 e2 => (ei2i e1)+(ei2i e2)
      | EIsub e1 e2 => (ei2i e1)-(ei2i e2)
      | EImul e1 e2 => (ei2i e1)*(ei2i e2)
      | EImax e1 e2 => max (ei2i e1) (ei2i e2)
      | EIopp e => -(ei2i e)
      | EIraw i => i
    end.

  (** [ExprZ] to [Z] *)

  Fixpoint ez2z (e:ExprZ) : Z :=
    match e with
      | EZadd e1 e2 => ((ez2z e1)+(ez2z e2))%Z
      | EZsub e1 e2 => ((ez2z e1)-(ez2z e2))%Z
      | EZmul e1 e2 => ((ez2z e1)*(ez2z e2))%Z
      | EZmax e1 e2 => Z.max (ez2z e1) (ez2z e2)
      | EZopp e => (-(ez2z e))%Z
      | EZofI e => i2z (ei2i e)
      | EZraw z => z
    end.

  (** [ExprP] to [Prop] *)

  Fixpoint ep2p (e:ExprP) : Prop :=
    match e with
      | EPeq e1 e2 => (ez2z e1) = (ez2z e2)
      | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z
      | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z
      | EPgt e1 e2 => ((ez2z e1)>(ez2z e2))%Z
      | EPge e1 e2 => ((ez2z e1)>=(ez2z e2))%Z
      | EPimpl e1 e2 => (ep2p e1) -> (ep2p e2)
      | EPequiv e1 e2 => (ep2p e1) <-> (ep2p e2)
      | EPand e1 e2 => (ep2p e1) /\ (ep2p e2)
      | EPor e1 e2 => (ep2p e1) \/ (ep2p e2)
      | EPneg e => ~ (ep2p e)
      | EPraw p => p
    end.

  (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *)

  Fixpoint norm_ei (e:ExprI) : ExprZ :=
    match e with
      | EI0 => EZraw (0%Z)
      | EI1 => EZraw (1%Z)
      | EI2 => EZraw (2%Z)
      | EI3 => EZraw (3%Z)
      | EIadd e1 e2 => EZadd (norm_ei e1) (norm_ei e2)
      | EIsub e1 e2 => EZsub (norm_ei e1) (norm_ei e2)
      | EImul e1 e2 => EZmul (norm_ei e1) (norm_ei e2)
      | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
      | EIopp e => EZopp (norm_ei e)
      | EIraw i => EZofI (EIraw i)
    end.

  (** [ExprZ] to a simplified [ExprZ] *)

  Fixpoint norm_ez (e:ExprZ) : ExprZ :=
    match e with
      | EZadd e1 e2 => EZadd (norm_ez e1) (norm_ez e2)
      | EZsub e1 e2 => EZsub (norm_ez e1) (norm_ez e2)
      | EZmul e1 e2 => EZmul (norm_ez e1) (norm_ez e2)
      | EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2)
      | EZopp e => EZopp (norm_ez e)
      | EZofI e =>  norm_ei e
      | EZraw z => EZraw z
    end.

  (** [ExprP] to a simplified [ExprP] *)

  Fixpoint norm_ep (e:ExprP) : ExprP :=
    match e with
      | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2)
      | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2)
      | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2)
      | EPgt e1 e2 => EPgt (norm_ez e1) (norm_ez e2)
      | EPge e1 e2 => EPge (norm_ez e1) (norm_ez e2)
      | EPimpl e1 e2 => EPimpl (norm_ep e1) (norm_ep e2)
      | EPequiv e1 e2 => EPequiv (norm_ep e1) (norm_ep e2)
      | EPand e1 e2 => EPand (norm_ep e1) (norm_ep e2)
      | EPor e1 e2 => EPor (norm_ep e1) (norm_ep e2)
      | EPneg e => EPneg (norm_ep e)
      | EPraw p => EPraw p
    end.

  Lemma norm_ei_correct (e:ExprI) : ez2z (norm_ei e) = i2z (ei2i e).
  Proof.
    induction e; simpl; i2z; auto; try congruence.
  Qed.

  Lemma norm_ez_correct (e:ExprZ) : ez2z (norm_ez e) = ez2z e.
  Proof.
    induction e; simpl; i2z; auto; try congruence; apply norm_ei_correct.
  Qed.

  Lemma norm_ep_correct (e:ExprP) : ep2p (norm_ep e) <-> ep2p e.
  Proof.
    induction e; simpl; rewrite ?norm_ez_correct; intuition.
  Qed.

  Lemma norm_ep_correct2 (e:ExprP) : ep2p (norm_ep e) -> ep2p e.
  Proof.
    intros; destruct (norm_ep_correct e); auto.
  Qed.

  Ltac i2z_refl :=
    i2z_gen;
    match goal with |- ?t =>
      let e := p2ep t in
      change (ep2p e); apply norm_ep_correct2; simpl
    end.

  (* i2z_refl can be replaced below by (simpl in *; i2z).
     The reflexive version improves compilation of AVL files by about 15%  *)

End MoreInt.

(** * An implementation of [Int] *)

(** It's always nice to know that our [Int] interface is realizable :-) *)

Module Z_as_Int <: Int.
  Local Open Scope Z_scope.
  Definition t := Z.
  Definition _0 := 0.
  Definition _1 := 1.
  Definition _2 := 2.
  Definition _3 := 3.
  Definition add := Z.add.
  Definition opp := Z.opp.
  Definition sub := Z.sub.
  Definition mul := Z.mul.
  Definition max := Z.max.
  Definition eqb := Z.eqb.
  Definition ltb := Z.ltb.
  Definition leb := Z.leb.

  Definition eq_dec := Z.eq_dec.
  Definition gt_le_dec i j : {i > j} + { i <= j }.
  Proof.
    generalize (Z.ltb_spec j i).
    destruct (j <? i); [left|right]; inversion H; trivial.
    now apply Z.lt_gt.
  Defined.
  Definition ge_lt_dec i j : {i >= j} + { i < j }.
  Proof.
    generalize (Z.ltb_spec i j).
    destruct (i <? j); [right|left]; inversion H; trivial.
    now apply Z.le_ge.
  Defined.

  Definition i2z : t -> Z := fun n => n.
  Lemma i2z_eq n p : i2z n = i2z p -> n = p. Proof. trivial. Qed.
  Lemma i2z_0 : i2z _0 = 0.  Proof. reflexivity. Qed.
  Lemma i2z_1 : i2z _1 = 1.  Proof. reflexivity. Qed.
  Lemma i2z_2 : i2z _2 = 2.  Proof. reflexivity. Qed.
  Lemma i2z_3 : i2z _3 = 3.  Proof. reflexivity. Qed.
  Lemma i2z_add n p : i2z (n + p) = i2z n + i2z p.
  Proof. reflexivity. Qed.
  Lemma i2z_opp n : i2z (- n) = - i2z n.
  Proof. reflexivity. Qed.
  Lemma i2z_sub n p : i2z (n - p) = i2z n - i2z p.
  Proof. reflexivity. Qed.
  Lemma i2z_mul n p : i2z (n * p) = i2z n * i2z p.
  Proof. reflexivity. Qed.
  Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p).
  Proof. reflexivity. Qed.
  Lemma i2z_eqb n p : eqb n p = Z.eqb (i2z n) (i2z p).
  Proof. reflexivity. Qed.
  Lemma i2z_leb n p : leb n p = Z.leb (i2z n) (i2z p).
  Proof. reflexivity. Qed.
  Lemma i2z_ltb n p : ltb n p = Z.ltb (i2z n) (i2z p).
  Proof. reflexivity. Qed.

  (** Compatibility notations for Coq v8.4 *)
  Notation plus := add (only parsing).
  Notation minus := sub (only parsing).
  Notation mult := mul (only parsing).
End Z_as_Int.


From Coq Require Import List Lia.
From WiSE Require Import equalities.
Import ListNotations.

(** * A library to manipulate infinite streams *)

CoInductive stream (A : Type) : Type :=
  | scons (x : A) (xs : stream A) : stream A.
Arguments scons { _ }.

Definition force {A} (s : stream A) : stream A :=
  match s with
  | scons x xs => scons x xs
  end.

Lemma force_id:
  forall A (s : stream A), force s = s.
Proof.
  intros. now destruct s.
Qed.

Ltac force :=
  rewrite <- force_id; simpl force.

(** Get the nth element of a stream *)
Fixpoint get {A} (n : nat) (s : stream A) : A :=
  match n, s with
  | 0, scons x _ => x
  | S n, scons _ xs => get n xs
  end.

Fixpoint shift {A} (n : nat) (s : stream A) : stream A :=
  match n, s with
  | 0, _ => s
  | S n, scons _ xs => shift n xs
  end.

Lemma get_shift:
  forall A (s : stream A) n m, get n (shift m s) = get (n + m) s.
Proof.
  intros *.
  induction m in s |-*.
  - now replace (n + 0) with n by lia.
  - simpl. destruct s. rewrite IHm.
    now replace (n + S m) with (S (n + m)) by lia.
Qed.

Lemma shift_eq:
  forall A n (x : A) xs, shift (S n) (scons x xs) = shift n xs.
Proof.
  auto.
Qed.

(** Peek the first [n] elements of a stream *)
Fixpoint peek {A} (n : nat) (s : stream A) : list A :=
  match n, s with
  | 0, _ => []
  | S n, scons x xs => x::peek n xs
  end.

(** Apply a function to a stream elementwise *)
CoFixpoint map {A B} (f : A -> B) (s : stream A) : stream B :=
  match s with
  | scons x xs => scons (f x) (map f xs)
  end.

Lemma map_eq:
  forall A B (f : A -> B) x xs, map f (scons x xs) = scons (f x) (map f xs).
Proof.
  intros. now rewrite <- force_id at 1.
Qed.

(** Filter out some element of a stream *)
CoFixpoint filter {A} (f : A -> bool) (s : stream A) : stream (option A) :=
  match s with
  | scons x xs =>
    if f x then scons None (filter f xs)
    else scons (Some x) (filter f xs)
  end.

(** Correctness of [filter] *)
Lemma get_filter :
  forall A (f : A -> bool) (s : stream A) n,
    if f (get n s) then
      get n (filter f s) = None
    else
      get n (filter f s) = Some (get n s).
Proof.
  intros A f s n.
  induction n in s |-*.
  - simpl. now destruct s, (f x).
  - destruct s; simpl.
    destruct (f (get n s)) eqn:Heq.
    + specialize (IHn s). rewrite Heq in IHn.
      now destruct (f x).
    + specialize (IHn s). rewrite Heq in IHn.
      now destruct (f x).
Qed.

Lemma get_map :
  forall n A B (f : A -> B) (s : stream A),
      get n (map f s) = f (get n s).
Proof.
  induction n.
  - now destruct s.
  - destruct s. simpl in *. now rewrite IHn.
Qed.

(** ** Predicates Over Streams *)

Module LTL.
  Lemma shift_shift:
    forall A m n (str : stream A), shift n (shift m str) = shift (n + m) str.
  Proof.
    induction m; auto.
    - intros. now replace (n + 0) with n by lia.
    - intros n str. replace (n + S m) with (S (n + m)) by lia.
      destruct str. rewrite shift_eq.
      now rewrite IHm.
  Qed.
  Definition t {A} : Type := (stream A -> Prop).
  Definition now {A} (P : A -> Prop) : t :=
    fun (s : stream A) => P (get 0 s).
  Definition globally {A} (P : t) : t :=
    fun (s : stream A) => forall n, P (shift n s).
  Definition eventually {A} (P : t) : t :=
    fun (s : stream A) => exists n, P (shift n s).
  Definition imp {A} (P Q : t) : t :=
    fun (s : stream A) => P s -> Q s.
  Definition or {A} (P Q : t) : t :=
    fun (s : stream A) => P s \/ Q s.
  Definition and {A} (P Q : t) : t :=
    fun (s : stream A) => P s /\ Q s.
  Definition not {A} (P : t) : t :=
    fun (s : stream A) => ~P s.
  Definition next {A} (P : t) : t :=
    fun (s : stream A) => P (shift 1 s).

  Notation "□ P" := (globally P) (at level 80).
  Notation "◊ P" := (eventually P) (at level 80).
  Notation "◯ P" := (next P) (at level 80).
  Notation "P → Q" := (imp P Q) (at level 80).
  Notation "¬ Q" := (not Q) (at level 80).
  Notation "P ∨ Q" := (or P Q) (at level 80).
  Notation "P ∧ Q" := (and P Q) (at level 80).
  Notation "! P" := (now P) (at level 80).
  Notation "!! p" := (! (fun x => x = p)) (at level 80).
  Check (_ → (□ ◯ _)).

  Theorem globally_map:
    forall A B (f : A -> B) (P : B -> Prop) str,
      (□ (now (fun x => P (f x)))) str ->
      (□ (now P)) (map f str).
  Proof.
    intros * H n.
    specialize (H n).
    unfold now in *. rewrite get_shift in *.
    simpl in *.
    now rewrite get_map.
  Qed.

  Definition model {A} (s : stream A) (f : @t A) : Prop :=
    f s.
  Notation "α ⊨ φ" := (model α φ) (at level 80).
End LTL.

(** The current value satisfies [P] *)
Definition now {A} (s : stream A) (P : A -> Prop) : Prop :=
  P (get 0 s).

(** Globally, [P] holds for all values of the stream *)
Definition globally {A} (s : stream A) (P : A -> Prop) : Prop :=
  forall n, P (get n s).

(** Eventually, a [P] value will be enumerated *)
Definition eventually {A} (s : stream A) (P : A -> Prop) : Prop :=
  exists n, P (get n s).

(** [P] holds untill [Q] holds *)
Definition untill {A} (s : stream A) (P Q : A -> Prop) :=
  exists n, Q (get n s) /\ forall m, 0 <= m <= n -> P (get n s).

(** ** Examples *)

(** Type of enumerators over a type [A] *)
Definition enum A : Type := nat -> A.

(** Extensional equality of streams *)
Definition stream_equ {A} (s1 s2 : stream A) :=
  forall n, get n s1 = get n s2.

(** Extensional equality of enumerators *)
Definition enum_equ {A} (f1 f2 : enum A) :=
  forall n, f1 n = f2 n.

(** Instances of [Eq] *)
Instance stream_Eq {A} : @Eq (stream A) := EQ _ stream_equ.
Instance fun_Eq {A} : @Eq (enum A) := EQ _ enum_equ.

(** Converting enumerators into streams *)
CoFixpoint func_to_stream {A} (n : nat) (f : nat -> A) : stream A :=
  scons (f n) (func_to_stream (S n) f).

(** Applying [func_to_stream] gives an equivalent [stream] *)
Lemma func_to_stream_correct {A} :
  forall n (f : nat -> A) m,
    get m (func_to_stream n f) = f (n + m).
Proof.
  intros.
  induction m in n |-*.
  - now replace (n + 0) with n by lia.
  - simpl get. rewrite IHm.
    now replace (n + S m) with (S n + m) by lia.
Qed.

(** [stream A] and [enum A] are isomorphic *)
Theorem stream_func_iso {A}:
  stream A ≃ (enum A).
Proof.
  exists (fun x n => get n x), (func_to_stream 0).
  split.
  - intros x n.
    now rewrite func_to_stream_correct.
  - intros f n.
    now rewrite func_to_stream_correct.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.Morphisms_Prop.
Require Import VCF.LiftConstructors.
Require Import VCF.PairConstructors.
Require Import VCF.KnasterTarski.

Class Union_Domain (A: Type) {CL_A: CL_Domain A} : Type := {
  Domain_union: A -> A -> A;
  Domain_empty: A;
  Domain_union_mono: Proper (Domain_R ==> Domain_R ==> Domain_R) Domain_union
}.

Class Concat_Domain (A: Type) {CL_A: CL_Domain A} : Type := {
  Domain_concat: A -> A -> A;
  Domain_concat_mono: forall a, Proper (Domain_R ==> Domain_R) (Domain_concat a)
}.

Existing Instances Domain_union_mono Domain_concat_mono.

Lemma lift_union_proper {X A R} {union: A -> A -> A} {Pr: Proper (R ==> R ==> R) union}:
  Proper (lift_rel2 R ==> lift_rel2 R ==> lift_rel2 R) (@lift_fun2 X A union).
Proof.
  hnf; intros; hnf; intros.
  intros a; unfold lift_fun2.
  apply Pr; auto.
Qed.

Lemma pair_union_proper
        {A B AB: Type}
        (projA: AB -> A)
        (projB: AB -> B)
        {RA: A -> A -> Prop}
        {RB: B -> B -> Prop}
        (RAB: AB -> AB -> Prop)
        {unionA: A -> A -> A}
        {unionB: B -> B -> B}
        (unionAB: AB -> AB -> AB)
        (PrA: Proper (RA ==> RA ==> RA) unionA)
        (PrB: Proper (RB ==> RB ==> RB) unionB):
  (forall c1 c2, RAB c1 c2 <-> RA (projA c1) (projA c2) /\ RB (projB c1) (projB c2)) ->
  (forall c1 c2, projA (unionAB c1 c2) = unionA (projA c1) (projA c2) /\
                 projB (unionAB c1 c2) = unionB (projB c1) (projB c2)) ->
  (forall c1 c2, projA c1 = projA c2 -> projB c1 = projB c2 -> c1 = c2) ->
  Proper (RAB ==> RAB ==> RAB) unionAB.
Proof.
  intros HR Hunion Hproj.
  unfold Proper, respectful.
  intros.
  rewrite HR in H, H0 |- *.
  rewrite !(proj1 (Hunion _ _)), !(proj2 (Hunion _ _)).
  split; [apply PrA | apply PrB]; tauto.
Qed.

Lemma prod_pair_union_proper
        {A B: Type}
        {RA: A -> A -> Prop}
        {RB: B -> B -> Prop}
        {unionA: A -> A -> A}
        {unionB: B -> B -> B}
        (PrA: Proper (RA ==> RA ==> RA) unionA)
        (PrB: Proper (RB ==> RB ==> RB) unionB):
  Proper (pair_rel2 RA RB ==> pair_rel2 RA RB ==> pair_rel2 RA RB) (pair_fun2 unionA unionB).
Proof.
  apply (pair_union_proper fst snd _ _ PrA PrB).
  + intros; reflexivity.
  + intros [? ?] [? ?]; simpl; intros; subst; split; reflexivity.
  + intros [? ?] [? ?]; simpl; intros; subst; reflexivity.
Qed.

Instance Lift_Union_Domain {A B} {CL_B: CL_Domain B} {Union_B: Union_Domain B}: Union_Domain (A -> B) :=
  Build_Union_Domain (A -> B) (Lift_CL_Domain A B) (lift_fun2 Domain_union) (lift_fun0 Domain_empty) (lift_union_proper).

Instance Pair_Union_Domain {A B}
         {CL_A: CL_Domain A} {CL_B: CL_Domain B}
         {Union_A: Union_Domain A} {Union_B: Union_Domain B}: Union_Domain (A * B) :=
  Build_Union_Domain
    (A * B) (Pair_CL_Domain _ _)
    (pair_fun2 Domain_union Domain_union)
    (pair_fun0 Domain_empty Domain_empty)
    (prod_pair_union_proper _ _).


Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.seq.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*======================================================================================
  We define a type of "casts".
  - Mathematically, this consists of a partial function [downcast] and a left inverse
    [upcast], together with the defining property [castinv].
  - For our purposes, [upcast] corresponds to *decoding*, and is not necessarily
    injective (values may have more than one code), and [downcast] corresponds to
    *encoding*, which may fail, and is not unique (it just *picks* some code).
  ======================================================================================*)
Structure CAST t u := MakeCast
{ upcast: t -> u;
  downcast: u -> option t;
  castinv : forall x y, downcast x = Some y -> upcast y = x
}.
Implicit Arguments MakeCast [t u].

Coercion upcast : CAST >-> Funclass.

Definition castIsTotal t u (c: CAST t u) := forall x, isSome (downcast c x).

(* Identity cast and composition of casts *)
Definition idCast t : CAST t t.
apply: MakeCast (fun x => x) (fun x => Some x) _.
by move => ? ? [->].
Defined.

Definition composeCast t u v (c: CAST t u) (d: CAST u v) : CAST t v.
Proof.
apply: MakeCast (fun x => upcast d (upcast c x))
                (fun x => if downcast d x is Some x' then downcast c x' else None) _.
move => x y.
case E: (downcast d x) => [x' |] //= E'. by rewrite (castinv E') (castinv E).
Defined.

(* Constructor casts *)
Definition unNil t : CAST unit (seq t).
apply: MakeCast (fun _ => nil) (fun x => if x is nil then Some tt else None) _. elim => //.
Defined.

Definition unCons t : CAST (t * seq t) (seq t).
apply: MakeCast (fun p => (p.1) :: (p.2)) (fun x => if x is x::xs' then Some (x,xs') else None) _.
elim => //. move => x xs H. move => [x' xs']. by move => [-> ->].
Defined.

Definition unInl t u : CAST t (t+u).
apply: MakeCast (fun x => inl x) (fun x => if x is inl y then Some y else None) _.
elim => x y => //. by move => [->]. Defined.

Definition unInr t u : CAST u (t+u).
apply: MakeCast (fun x => inr x) (fun x => if x is inr y then Some y else None) _.
elim => x y => //. by move => [->]. Defined.

Definition unConst (t: eqType) (x:t) : CAST unit t.
apply: MakeCast (fun _ => x) (fun x' => if x == x' then Some tt else None) _.
move => x1 x2. case E: (_==_) => //. by rewrite (eqP E).
Defined.

(* Projection casts *)
Definition fstCast t u (y:u) : CAST (t*u) t.
apply: MakeCast (fun x => x.1) (fun x => Some (x,y)) _. by move => x0 [x y'] [<-]. Defined.

Definition sndCast t u (x:t) : CAST (t*u) u.
apply: MakeCast (fun x => x.2) (fun y => Some (x,y)) _. by move => x0 [x' y] [<-]. Defined.

Definition unitCast t : CAST t unit.
apply: MakeCast (fun _ => tt) (fun _ => None) _. by move => []. Defined.

(* Isomorphisms as casts *)
Definition unitRcast t : CAST t (t*unit).
apply: MakeCast (fun x => (x,tt)) (fun x => Some x.1) _.
by move => [x []] x' [->].
Defined.

Definition unitLcast t : CAST t (unit*t).
apply: MakeCast (fun x => (tt,x)) (fun x => Some x.2) _.
by move => [[] x] x' [->].
Defined.

Definition fstUnitCast t : CAST (t*unit) t.
apply: MakeCast (fun x => x.1) (fun x => Some (x,tt)) _.
by move => x [y []] [->]. Defined.

Definition sndUnitCast t : CAST (unit*t) t.
apply: MakeCast (fun x => x.2) (fun x => Some (tt,x)) _.
by move => x [[] y] [->]. Defined.

Definition existTcast T U : CAST {_:T & U} (T*U).
apply: MakeCast (fun (p: {_:T & U}) => (projT1 p, projT2 p))
                (fun x => Some (existT (fun _ => U) x.1 x.2)) _.
by move => [y z] [y' z'] [->]  ->.
Defined.

Definition sumCast F : CAST (F false + F true) {x:bool & F x}.
apply: (MakeCast (fun (p: F false + F true) =>
                 match p with inl x => existT _ false x | inr x => existT _ true x end)
                (fun (p: {x:bool & F x}) =>
                 Some (match p with
                 | existT false x => inl x
                 | existT true x => inr x end)) _).
elim => [x y]. elim => [a | b] => H; destruct x; congruence. Defined.

Definition pairAssocCast t1 t2 t3 : CAST (t1*(t2*t3)) ((t1*t2)*t3).
apply: MakeCast (fun (x: t1*(t2*t3)) => ((x.1,x.2.1),x.2.2))
                (fun (x: (t1*t2)*t3) => Some (x.1.1, (x.1.2, x.2))) _.
move => [[x1 x2] x3] [y1 [y2 y3]]. by move => [-> -> -> ].
Defined.

Definition pairAssocCastOp t1 t2 t3 : CAST ((t1*t2)*t3) (t1*(t2*t3)).
apply: MakeCast (fun (x: (t1*t2)*t3) => (x.1.1, (x.1.2, x.2)))
                (fun (x: t1*(t2*t3)) => Some ((x.1,x.2.1),x.2.2))
                _.
move => [x1 [x2 x3]] [[y1 y2] y3]. by move => [-> -> -> ].
Defined.

Definition swapPairCast t u : CAST (t*u) (u*t).
apply: MakeCast (fun (x:t*u) => (x.2,x.1)) (fun (x:u*t) => Some (x.2,x.1)) _.
by move => [x1 x2] [y1 y2] [-> ->].
Defined.

(* Congruences *)
Definition pairOfCasts t t' u u' (c: CAST t t') (d: CAST u u') : CAST (t*u) (t'*u').
apply: MakeCast (fun x => (upcast c x.1,upcast d x.2))
                (fun x => match downcast c x.1, downcast d x.2 with
                            Some y, Some z => Some (y,z) | _, _ => None end) _.
move => [x1 x2] [y1 y2]/=.
case E: (downcast c x1) => [y1' |]//.
case E': (downcast d x2) => [y2' |]//. move => [<- <-].
by rewrite (castinv E) (castinv E').
Defined.

Definition sumOfCasts t t' u u' (c: CAST t t') (d: CAST u u') : CAST (t+u) (t'+u').
apply: MakeCast (fun x => match x with inl y => inl (c y) | inr z => inr (d z) end)
                (fun x => match x with
                 | inl y => if downcast c y is Some z then Some (inl z) else None
                 | inr y => if downcast d y is Some z then Some (inr z) else None end) _.
elim => [y | y]. elim => [z | z].
case E: (downcast c y) => [x |]//. move => [<-]. by rewrite (castinv E).
case E: (downcast c y) => [x |]//.
elim => [z | z].
case E: (downcast d y) => [x |]//.
case E: (downcast d y) => [x |]//. move => [<-]. by rewrite (castinv E).
Defined.