Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Lia.
From PLF Require Import Maps.
From PLF Require Smallstep.
From Coq Require Import Lists.List.

Inductive ty : Type :=
  | Ty_Nat   : ty
  | Ty_Unit  : ty
  | Ty_Arrow : ty -> ty -> ty
  | Ty_Ref   : ty -> ty.

Inductive tm  : Type :=
  (* STLC with numbers: *)
  | tm_var    : string -> tm
  | tm_app    : tm -> tm -> tm
  | tm_abs    : string -> ty -> tm -> tm
  | tm_const  : nat -> tm
  | tm_succ    : tm -> tm
  | tm_pred    : tm -> tm
  | tm_mult    : tm -> tm -> tm
  | tm_if0  : tm -> tm -> tm -> tm
  (* Ref new terms: *)
  | tm_unit   : tm
  | tm_ref    : tm -> tm
  | tm_deref  : tm -> tm
  | tm_assign : tm -> tm -> tm
  | tm_loc    : nat -> tm
  (* GC new term: *)
  | tm_free   : tm -> tm
.

Declare Custom Entry stlc.
Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "{ x }" := x (in custom stlc at level 0, x constr).

Notation "'Unit'" :=
  (Ty_Unit) (in custom stlc at level 0).
Notation "'unit'" := tm_unit (in custom stlc at level 0).

Notation "'Natural'" := Ty_Nat (in custom stlc at level 0).
Notation "'succ' x" := (tm_succ x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "'pred' x" := (tm_pred x) (in custom stlc at level 0,
                                     x custom stlc at level 0).
Notation "x * y" := (tm_mult x y) (in custom stlc at level 1,
                                      left associativity).
Notation "'if0' x 'then' y 'else' z" :=
  (tm_if0 x y z) (in custom stlc at level 89,
                    x custom stlc at level 99,
                    y custom stlc at level 99,
                    z custom stlc at level 99,
                    left associativity).
Coercion tm_const : nat >-> tm.

Notation "'Ref' t" :=
  (Ty_Ref t) (in custom stlc at level 4).
Notation "'loc' x" := (tm_loc x) (in custom stlc at level 2).
Notation "'ref' x" := (tm_ref x) (in custom stlc at level 2).
Notation "'!' x " := (tm_deref x) (in custom stlc at level 2).
Notation " e1 ':=' e2 " := (tm_assign e1 e2) (in custom stlc at level 21).
Notation "'free' x" := (tm_free x) (in custom stlc at level 2).

Print Scopes.

Definition store := list (option tm).

Inductive store_lookup : nat -> store -> tm -> Prop :=
  | SL_found : forall r t, store_lookup 0 ((Some t) :: r) t
  | SL_next n r t (H: store_lookup n r t) : forall x, store_lookup (S n) (x :: r) t.

Inductive store_assign : store -> nat -> tm -> store -> Prop :=
  | SA_here : forall x r t, store_assign ((Some x) :: r) 0 t ((Some t)::r)
  | SA_next s n t s' x (H : store_assign s n t s') :
      store_assign (x::s) (S n) t (x::s')
.

Inductive store_assign_new : store -> nat -> tm -> store -> Prop :=
  | SAN_here : forall r t, store_assign_new (None :: r) 0 t ((Some t)::r)
  | SAN_next s n t s' x (H : store_assign_new s n t s') :
      store_assign_new (x::s) (S n) t (x::s')
.

Inductive store_free : store -> nat -> store -> Prop :=
  | SF_here : forall x r, store_free (Some x :: r) 0 (None::r)
  | SF_next s n s' x (H : store_free s n s') :
      store_free (x::s) (S n) (x::s')
.

Inductive first_empty_cell : store -> nat -> Prop :=
  | FEC_found : forall r, first_empty_cell (None :: r) 0
  | FEC_next s n (H: first_empty_cell s n) :
      forall x, first_empty_cell ((Some x) :: s) (S n)
.

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value <{\x:T2, t1}>
  | v_nat : forall n : nat ,
      value <{ n }>
  | v_unit :
      value <{ unit }>
  | v_loc : forall l,
         value <{ loc l }>.

Hint Constructors value : core.

(** Extending substitution to handle the new syntax of terms is
    straightforward.  *)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  (* pure STLC *)
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> =>
      <{([x:=s] t1) ([x:=s] t2)}>
  (* numbers *)
  | tm_const _ =>
      t
  | <{succ t1}> =>
      <{succ [x := s] t1}>
  | <{pred t1}> =>
      <{pred [x := s] t1}>
  | <{t1 * t2}> =>
      <{ ([x := s] t1) * ([x := s] t2)}>
  | <{if0 t1 then t2 else t3}> =>
      <{if0 [x := s] t1 then [x := s] t2 else [x := s] t3}>
  (* unit *)
  | <{ unit }> =>
    <{ unit }>
  (* references *)
  | <{ ref t1 }> =>
      <{ ref ([x:=s] t1) }>
  | <{ !t1 }> =>
      <{ !([x:=s] t1) }>
  | <{ t1 := t2 }> =>
    <{ ([x:=s] t1) := ([x:=s] t2) }>
  | <{ loc _ }> =>
      t
  | <{ free t }> =>
    <{ free [x:=s]t }>
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

Reserved Notation "t / st --> t' / st'"
  (at level 40, st at level 39, t' at level 39).

Inductive step : tm * store -> tm * store -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2 st,
         value v2 ->
         <{ (\x : T2, t1) v2 }> / st --> <{ [x := v2] t1 }> / st
  | ST_App1 : forall t1 t1' t2 st st',
         t1 / st --> t1' / st' ->
         <{ t1 t2 }> / st --> <{ t1' t2 }> / st'
  | ST_App2 : forall v1 t2 t2' st st',
         value v1 ->
         t2 / st --> t2' / st' ->
         <{ v1 t2 }> / st --> <{ v1 t2' }> / st'
  (* numbers *)
  | ST_SuccNatural : forall (n : nat) st,
         <{ succ n }> / st --> tm_const (S n) / st
  | ST_Succ : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ succ t1 }> / st --> <{ succ t1' }> / st'
  | ST_PredNatural : forall (n : nat) st,
         <{ pred n }> / st --> tm_const (n - 1) / st
  | ST_Pred : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ pred t1 }> / st --> <{ pred t1' }> / st'
  | ST_MultNaturals : forall (n1 n2 : nat) st,
      <{ n1 * n2 }> / st -->  tm_const (n1 * n2) / st
  | ST_Mult1 : forall t1 t2 t1' st st',
         t1 / st --> t1' / st' ->
         <{ t1 * t2 }> / st --> <{ t1' * t2 }> / st'
  | ST_Mult2 : forall v1 t2 t2' st st',
         value v1 ->
         t2 / st --> t2' / st' ->
         <{ v1 * t2 }> / st --> <{ v1 * t2' }> / st'
  | ST_If0 : forall t1 t1' t2 t3 st st',
         t1 / st --> t1' / st' ->
         <{ if0 t1 then t2 else t3 }> / st --> <{ if0 t1' then t2 else t3 }> / st'
  | ST_If0_Zero : forall t2 t3 st,
         <{ if0 0 then t2 else t3 }> / st --> t2 / st
  | ST_If0_Nonzero : forall n t2 t3 st,
         <{ if0 {S n} then t2 else t3 }> / st --> t3 / st
  (* references *)
  | ST_RefValue : forall v st st' n,
         value v ->
         first_empty_cell st n ->
         store_assign_new st n v st' ->
         <{ ref v }> / st --> <{ loc n }> / st'
  | ST_Ref : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ ref t1 }> /  st --> <{ ref t1' }> /  st'
  | ST_DerefLoc : forall st n t,
         store_lookup n st t ->
         <{ !(loc n) }> / st --> <{ t }> / st
  | ST_Deref : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ ! t1 }> / st --> <{ ! t1' }> / st'
  | ST_Assign : forall v l st st',
         value v ->
         store_assign st l v st' ->
         <{ (loc l) := v }> / st --> <{ unit }> / st'
  | ST_Assign1 : forall t1 t1' t2 st st',
         t1 / st --> t1' / st' ->
         <{ t1 := t2 }> / st --> <{ t1' := t2 }> / st'
  | ST_Assign2 : forall v1 t2 t2' st st',
         value v1 ->
         t2 / st --> t2' / st' ->
         <{ v1 := t2 }> / st --> <{ v1 := t2' }> / st'
  | ST_Free : forall st st' n,
      store_free st n st' ->
      <{free (loc n)}> / st --> <{unit}> / st'
  | ST_Free1 : forall t1 t1' st st',
         t1 / st --> t1' / st' ->
         <{ free t1 }> / st --> <{ free t1' }> / st'
where "t / st --> t' / st'" := (step (t,st) (t',st')).

Definition multi_step := Smallstep.multi step.

Notation "t / st -->* t' / st'" :=
  (multi_step (t, st) (t', st'))
       (at level 40, st at level 39, t' at level 39).

Lemma can_assign_empty_cell : forall st n t,
       first_empty_cell st n ->
       exists st', store_assign_new st n t st'.
Proof.
  intros.
  generalize dependent st.
  induction n.
  - intros.
    inversion H; subst; clear H.
    eexists. constructor.

  - intros.
    inversion H; subst; clear H.
    apply IHn in H2. destruct H2.
    eexists. constructor. eauto.
Qed.

Lemma assign_new_free_inv : forall st n t st',
       store_assign_new st n t st' ->
       store_free st' n st.
Proof.
  intros.
  generalize dependent st.
  generalize dependent st'.
  induction n.
  - intros. inversion H; subst. constructor.

  - intros. inversion H; subst; clear H.
    apply IHn in H2. constructor. auto.
Qed.

Lemma free_ref_noop : forall st t n,
       (* I could have proved it for arbitrary t, but
          it would require proving progress first. Therefore I will be assuming
          t is a value.
        *)
       value t ->
       (* ensure that st has an empty space *)
       first_empty_cell st n ->
       <{free (ref t)}> / st -->* <{unit}> / st.
Proof.
  intros.
  assert (first_empty_cell st n) by auto.
  apply can_assign_empty_cell with (t:=t) in H1. destruct H1.
  rename x into st'.
  assert (store_free st' n st) by eauto using assign_new_free_inv.

  eapply Smallstep.multi_step.
  eapply ST_Free1.
  apply ST_RefValue; eauto.

  eapply Smallstep.multi_step.
  eapply ST_Free; eauto.

  eapply Smallstep.multi_refl.
Qed.


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

Require Export contact.
Require Export reflexion_plane.
Require Export similitudes_directes.
Set Implicit Arguments.
Unset Strict Implicit.
Hint Resolve translation_trivial rec_translation_vecteur: geo.

Lemma translation_isometrie :
 forall A A' B B' C C' : PO,
 B' = translation A A' B ->
 C' = translation A A' C -> distance B' C' = distance B C.
intros.
apply Rsqr_inj; auto with real geo.
unfold Rsqr in |- *.
repeat rewrite <- carre_scalaire_distance.
rewrite <-
 (translation_bipoint (I:=A) (J:=A') (A:=B) (A':=B') (B:=C) (B':=C'))
 ; auto.
Qed.

Lemma translation_conserve_orthogonalite :
 forall I J A A' B B' M M' : PO,
 A' = translation I J A ->
 B' = translation I J B ->
 M' = translation I J M ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=A) (A':=A') (B:=M) (B':=M'))
 ; auto.
rewrite <-
 (translation_bipoint (I:=I) (J:=J) (A:=A) (A':=A') (B:=B) (B':=B'))
 ; auto.
Qed.

Lemma translation_conserve_contact_cercle_droite :
 forall I J A A' B B' M M' O O' : PO,
 A' = translation I J A ->
 B' = translation I J B ->
 M' = translation I J M ->
 O' = translation I J O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite
 (translation_isometrie (A:=I) (A':=J) (B:=O) (B':=O') (C:=A) (C':=A'))
 ; auto.
rewrite
 (translation_isometrie (A:=I) (A':=J) (B:=O) (B':=O') (C:=B) (C':=B'))
 ; auto.
apply
 (translation_conserve_orthogonalite (I:=I) (J:=J) (A:=B) (A':=B') (B:=M)
    (B':=M') (M:=O) (M':=O')); auto.
Qed.

Lemma translation_conserve_contact_cercle_cercle :
 forall I J A A' B B' K K' O O' : PO,
 O <> A ->
 K <> B ->
 A' = translation I J A ->
 B' = translation I J B ->
 K' = translation I J K ->
 O' = translation I J O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H6; elim H6;
    [ intros M H7; elim H7;
       [ intros H8 H9; elim H9;
          [ intros H10 H11; try clear H9 H7 H6; try exact H10 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_representant_vecteur with (A := T) (B := I) (C := J);
 [ intros T' H6; try clear existence_representant_vecteur; try exact H6 ].
elim existence_representant_vecteur with (A := M) (B := I) (C := J);
 [ intros M' H7; try clear existence_representant_vecteur; try exact H7 ].
assert (distance O' A' = distance O A).
rewrite <-
 (translation_isometrie (A:=I) (A':=J) (B:=O) (B':=O') (C:=A) (C':=A'))
 ; auto with geo.
assert (distance K' B' = distance K B).
rewrite <-
 (translation_isometrie (A:=I) (A':=J) (B:=K) (B':=K') (C:=B) (C':=B'))
 ; auto with geo.
assert (O' <> A').
apply (isometrie_distinct (A:=O) (B:=A) (A':=O') (B':=A')); auto.
assert (K' <> B').
apply (isometrie_distinct (A:=K) (B:=B) (A':=K') (B':=B')); auto.
assert (distance T' M' = distance T M).
rewrite <-
 (translation_isometrie (A:=I) (A':=J) (B:=T) (B':=T') (C:=M) (C':=M'))
 ; auto with geo.
assert (T' <> M').
apply (isometrie_distinct (A:=T) (B:=M) (A':=T') (B':=M')); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply translation_conserve_contact_cercle_droite with (1 := H1) (5 := H10);
 auto with geo.
apply translation_conserve_contact_cercle_droite with (1 := H2) (5 := H11);
 auto with geo.
Qed.

Lemma homothetie_conserve_orthogonalite :
 forall (k : R) (I A A' B B' M M' : PO),
 k <> 0 :>R ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO ->
 M' = homothetie k I M :>PO ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
generalize (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'));
 intros.
generalize (homothetie_bipoint (k:=k) (I:=I) (A:=A) (B:=M) (A':=A') (B':=M'));
 intros.
assert (orthogonal (vec A B) (vec A' M')).
apply ortho_sym; rewrite H5; auto with geo.
rewrite H4; auto with geo.
Qed.

Lemma homothetie_conserve_contact_cercle_droite :
 forall (k : R) (I A A' B B' M M' O O' : PO),
 k <> 0 :>R ->
 A' = homothetie k I A :>PO ->
 B' = homothetie k I B :>PO ->
 M' = homothetie k I M :>PO ->
 O' = homothetie k I O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite (distance_homothetie (k:=k) (I:=I) (A:=O) (A':=O') (B:=A) (B':=A'));
 auto.
rewrite (distance_homothetie (k:=k) (I:=I) (A:=O) (A':=O') (B:=B) (B':=B'));
 auto.
rewrite H5; auto.
apply
 (homothetie_conserve_orthogonalite (k:=k) (I:=I) (A:=B) (A':=B') (B:=M)
    (B':=M') (M:=O) (M':=O')); auto.
Qed.

Lemma produit_distance_distinct :
 forall (A B C D : PO) (k : R),
 k <> 0 -> A <> B -> distance C D = k * distance A B -> C <> D.
intros.
contrapose H0.
assert (distance A B = 0); auto with geo.
replace (distance A B) with (/ k * distance C D).
rewrite H2.
replace (distance D D) with 0.
ring.
symmetry  in |- *; auto with geo.
rewrite H1.
field; auto.
Qed.

Lemma homothetie_conserve_contact_cercle_cercle :
 forall (k : R) (I J A A' B B' K K' O O' : PO),
 O <> A ->
 K <> B ->
 k <> 0 ->
 A' = homothetie k I A ->
 B' = homothetie k I B ->
 K' = homothetie k I K ->
 O' = homothetie k I O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H7; elim H7;
    [ intros M H8; elim H8;
       [ intros H9 H10; elim H10;
          [ intros H11 H12; try clear H10 H8 H7; try exact H11 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_homothetique with (k := k) (I := I) (A := T); [ intros T' H7 ].
elim existence_homothetique with (k := k) (I := I) (A := M); [ intros M' H8 ].
assert (O' <> A').
apply image_homothetie_distincts with (3 := H5) (4 := H2); auto.
assert (K' <> B').
apply image_homothetie_distincts with (3 := H4) (4 := H3); auto.
assert (T' <> M').
apply image_homothetie_distincts with (3 := H7) (4 := H8); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply homothetie_conserve_contact_cercle_droite with (2 := H2) (6 := H11);
 auto with geo.
apply homothetie_conserve_contact_cercle_droite with (2 := H3) (6 := H12);
 auto with geo.
Qed.

Lemma reflexion_conserve_orthogonalite :
 forall I J A A' B B' M M' : PO,
 I <> J ->
 A' = reflexion I J A :>PO ->
 B' = reflexion I J B :>PO ->
 M' = reflexion I J M :>PO ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
assert (distance A' B' = distance A B).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=A) (M':=A') (N:=B) (N':=B'))
 ; auto with geo.
assert (distance A' M' = distance A M).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=A) (M':=A') (N:=M) (N':=M'))
 ; auto with geo.
discrimine A B.
assert (distance A' B' = 0).
rewrite H4; rewrite H6; auto with geo.
assert (A' = B'); auto with geo.
rewrite H8.
VReplace (vec B' B') zero; auto with geo.
discrimine A M.
assert (distance A' M' = 0).
rewrite H5; rewrite H7; auto with geo.
assert (A' = M'); auto with geo.
rewrite H9.
VReplace (vec M' M') zero; auto with geo.
assert (~ alignes A B M); auto with geo.
assert (B <> M); auto with geo.
apply non_alignes_distincts2 with A; auto.
assert (cons_AV (vec A' B') (vec A' M') = opp (cons_AV (vec A B) (vec A M))).
apply reflexion_anti_deplacement with (A := I) (B := J); auto.
assert (double_AV (cons_AV (vec A M) (vec A B)) = image_angle pi).
apply orthogonal_angles; auto with geo.
apply angles_orthogonal.
apply (isometrie_distinct (A:=A) (B:=B) (A':=A') (B':=B')); auto.
apply (isometrie_distinct (A:=A) (B:=M) (A':=A') (B':=M')); auto.
rewrite H10.
rewrite def_opp; auto.
Qed.

Lemma reflexion_conserve_contact_cercle_droite :
 forall I J A A' B B' M M' O O' : PO,
 I <> J ->
 A' = reflexion I J A ->
 B' = reflexion I J B ->
 M' = reflexion I J M ->
 O' = reflexion I J O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=O) (M':=O') (N:=A) (N':=A'))
 ; auto.
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=O) (M':=O') (N:=B) (N':=B'))
 ; auto.
apply
 (reflexion_conserve_orthogonalite (I:=I) (J:=J) (A:=B) (A':=B') (B:=M)
    (B':=M') (M:=O) (M':=O')); auto.
Qed.

Lemma reflexion_conserve_contact_cercle_cercle :
 forall I J A A' B B' K K' O O' : PO,
 I <> J ->
 O <> A ->
 K <> B ->
 A' = reflexion I J A ->
 B' = reflexion I J B ->
 K' = reflexion I J K ->
 O' = reflexion I J O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H7; elim H7;
    [ intros M H8; elim H8;
       [ intros H9 H10; elim H10;
          [ intros H11 H12; try clear H10 H8 H7; try exact H11 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_reflexion_AB with (A := I) (B := J) (M := T);
 [ intros T' H7; try clear existence_reflexion_AB; try exact H7 | auto ].
elim existence_reflexion_AB with (A := I) (B := J) (M := M);
 [ intros M' H8; try clear existence_reflexion_AB; try exact H7 | auto ].
assert (distance O' A' = distance O A).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=O) (M':=O') (N:=A) (N':=A'))
 ; auto.
assert (O' <> A').
apply (isometrie_distinct (A:=O) (B:=A) (A':=O') (B':=A')); auto.
assert (distance K' B' = distance K B).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=K) (M':=K') (N:=B) (N':=B'))
 ; auto.
assert (K' <> B').
apply (isometrie_distinct (A:=K) (B:=B) (A':=K') (B':=B')); auto.
assert (distance T' M' = distance T M).
rewrite <-
 (reflexion_isometrie (A:=I) (B:=J) (M:=T) (M':=T') (N:=M) (N':=M'))
 ; auto.
assert (T' <> M').
apply (isometrie_distinct (A:=T) (B:=M) (A':=T') (B':=M')); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply reflexion_conserve_contact_cercle_droite with (2 := H2) (6 := H11);
 auto with geo.
apply reflexion_conserve_contact_cercle_droite with (2 := H3) (6 := H12);
 auto with geo.
Qed.

Lemma rotation_conserve_orthogonalite :
 forall (I A B M A' B' M' : PO) (a : R),
 A' = rotation I a A ->
 B' = rotation I a B ->
 M' = rotation I a M ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
assert (distance A' B' = distance A B).
rewrite <- (rotation_isometrie (I:=I) (A:=A) (B:=B) (A':=A') (B':=B') (a:=a));
 auto with geo.
assert (distance A' M' = distance A M).
rewrite <- (rotation_isometrie (I:=I) (A:=A) (B:=M) (A':=A') (B':=M') (a:=a));
 auto with geo.
discrimine A B.
assert (distance A' B' = 0).
rewrite H3; rewrite H5; auto with geo.
assert (A' = B'); auto with geo.
rewrite H7.
VReplace (vec B' B') zero; auto with geo.
discrimine A M.
assert (distance A' M' = 0).
rewrite H4; rewrite H6; auto with geo.
assert (A' = M'); auto with geo.
rewrite H8.
VReplace (vec M' M') zero; auto with geo.
assert (cons_AV (vec A B) (vec A M) = cons_AV (vec A' B') (vec A' M')).
apply rotation_conserve_angle with (a := a) (I := I); auto.
assert (double_AV (cons_AV (vec A B) (vec A M)) = image_angle pi).
apply orthogonal_angles; auto with geo.
apply angles_orthogonal.
apply (isometrie_distinct (A:=A) (B:=B) (A':=A') (B':=B')); auto.
apply (isometrie_distinct (A:=A) (B:=M) (A':=A') (B':=M')); auto.
rewrite <- H7; auto.
Qed.

Lemma rotation_conserve_contact_cercle_droite :
 forall (I A A' B B' M M' O O' : PO) (a : R),
 A' = rotation I a A ->
 B' = rotation I a B ->
 M' = rotation I a M ->
 O' = rotation I a O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite (rotation_isometrie (I:=I) (A:=O) (B:=A) (A':=O') (B':=A') (a:=a));
 auto.
rewrite (rotation_isometrie (I:=I) (A:=O) (B:=B) (A':=O') (B':=B') (a:=a));
 auto.
apply
 (rotation_conserve_orthogonalite (I:=I) (A:=B) (B:=M) (M:=O) (A':=B')
    (B':=M') (M':=O') (a:=a)); auto.
Qed.

Lemma rotation_conserve_contact_cercle_cercle :
 forall (I A A' B B' K K' O O' : PO) (a : R),
 O <> A ->
 K <> B ->
 A' = rotation I a A ->
 B' = rotation I a B ->
 K' = rotation I a K ->
 O' = rotation I a O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H6; elim H6;
    [ intros M H7; elim H7;
       [ intros H8 H9; elim H9;
          [ intros H10 H11; try clear H9 H7 H6; try exact H10 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_rotation_Ia with (I := I) (M := T) (a := a);
 [ intros T' H6; try clear existence_rotation_Ia; try exact H6 ].
elim existence_rotation_Ia with (I := I) (M := M) (a := a);
 [ intros M' H7; try clear existence_rotation_Ia; try exact H7 ].
assert (O' <> A').
apply (image_bipoint_distinct (I:=I) (A:=O) (B:=A) (A':=O') (B':=A') (a:=a));
 auto.
assert (K' <> B').
apply (image_bipoint_distinct (I:=I) (A:=K) (B:=B) (A':=K') (B':=B') (a:=a));
 auto.
assert (T' <> M').
apply (image_bipoint_distinct (I:=I) (A:=T) (B:=M) (A':=T') (B':=M') (a:=a));
 auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply rotation_conserve_contact_cercle_droite with (1 := H1) (5 := H10);
 auto with geo.
apply rotation_conserve_contact_cercle_droite with (1 := H2) (5 := H11);
 auto with geo.
Qed.

Lemma similitude_conserve_orthogonalite :
 forall (I A B M A' B' M' : PO) (k a : R),
 k > 0 ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 M' = similitude I k a M ->
 orthogonal (vec A B) (vec A M) -> orthogonal (vec A' B') (vec A' M').
intros.
assert (distance A' B' = k * distance A B).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=A) (B:=B) (A':=A') (B':=B'))
 ; auto with geo.
assert (distance A' M' = k * distance A M).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=A) (B:=M) (A':=A') (B':=M'))
 ; auto with geo.
discrimine A B.
assert (distance A' B' = 0).
rewrite H4; rewrite H6.
replace (distance B B) with 0.
ring.
symmetry  in |- *; auto with geo.
assert (A' = B'); auto with geo.
rewrite H8.
VReplace (vec B' B') zero; auto with geo.
discrimine A M.
assert (distance A' M' = 0).
rewrite H5; rewrite H7.
replace (distance M M) with 0.
ring.
symmetry  in |- *; auto with geo.
assert (A' = M'); auto with geo.
rewrite H9.
VReplace (vec M' M') zero; auto with geo.
assert (cons_AV (vec A B) (vec A M) = cons_AV (vec A' B') (vec A' M')).
apply similitude_conserve_angle with (a := a) (k := k) (I := I); auto.
assert (double_AV (cons_AV (vec A B) (vec A M)) = image_angle pi).
apply orthogonal_angles; auto with geo.
assert (k <> 0); auto with real.
apply angles_orthogonal.
apply produit_distance_distinct with (3 := H4); auto.
apply produit_distance_distinct with (3 := H5); auto.
rewrite <- H8; auto.
Qed.

Lemma similitude_conserve_contact_cercle_droite :
 forall (I A B M A' B' M' O O' : PO) (k a : R),
 k > 0 ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 M' = similitude I k a M ->
 O' = similitude I k a O ->
 tangente_cercle O A B M -> tangente_cercle O' A' B' M'.
icercle.
rewrite
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=O) (B:=A) (A':=O') (B':=A'))
 ; auto.
rewrite
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=O) (B:=B) (A':=O') (B':=B'))
 ; auto.
rewrite H5; auto.
apply
 (similitude_conserve_orthogonalite (I:=I) (A:=B) (B:=M) (M:=O) (A':=B')
    (B':=M') (M':=O') (k:=k) (a:=a)); auto.
Qed.

Lemma similitude_conserve_contact_cercle_cercle :
 forall (I A A' B B' K K' O O' : PO) (k a : R),
 k > 0 ->
 O <> A ->
 K <> B ->
 A' = similitude I k a A ->
 B' = similitude I k a B ->
 K' = similitude I k a K ->
 O' = similitude I k a O ->
 cercles_tangents O A K B -> cercles_tangents O' A' K' B'.
intros.
elim
 cercles_tangents_tangente_commune with (O := O) (A := A) (O' := K) (A' := B);
 [ intros T H7; elim H7;
    [ intros M H8; elim H8;
       [ intros H9 H10; elim H10;
          [ intros H11 H12;
             try clear H10 H8 H7 cercles_tangents_tangente_commune;
             try exact H11 ] ] ]
 | auto
 | auto
 | auto ].
elim existence_similitude_Ika with (I := I) (M := T) (k := k) (a := a);
 [ intros T' H13; try clear existence_similitude_Ika; try exact H13 | auto ].
elim existence_similitude_Ika with (I := I) (M := M) (k := k) (a := a);
 [ intros M' H14; try clear existence_similitude_Ika; try exact H14 | auto ].
assert (distance O' A' = k * distance O A).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=O) (B:=A) (A':=O') (B':=A'))
 ; auto with geo.
assert (distance K' B' = k * distance K B).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=K) (B:=B) (A':=K') (B':=B'))
 ; auto with geo.
assert (distance T' M' = k * distance T M).
rewrite <-
 (distance_similitude (k:=k) (a:=a) (I:=I) (A:=T) (B:=M) (A':=T') (B':=M'))
 ; auto with geo.
assert (k <> 0); auto with real.
assert (O' <> A').
apply produit_distance_distinct with (3 := H15); auto.
assert (K' <> B').
apply produit_distance_distinct with (3 := H16); auto.
assert (T' <> M').
apply produit_distance_distinct with (3 := H17); auto.
apply tangente_commune_cercles_tangents with (B := T') (M := M'); auto.
apply similitude_conserve_contact_cercle_droite with (2 := H2) (6 := H11);
 auto with geo.
apply similitude_conserve_contact_cercle_droite with (2 := H3) (6 := H12);
 auto with geo.
Qed.


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

Require Export metrique_triangle.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter rotation : PO -> R -> PO -> PO.

Axiom
  rotation_def :
    forall (I A B : PO) (a : R),
    I <> A ->
    B = rotation I a A ->
    distance I A = distance I B /\
    image_angle a = cons_AV (vec I A) (vec I B).

Axiom rotation_def_centre : forall (I : PO) (a : R), I = rotation I a I.

Axiom
  rotation_def2 :
    forall (I A B : PO) (a : R),
    I <> A ->
    distance I A = distance I B ->
    image_angle a = cons_AV (vec I A) (vec I B) -> B = rotation I a A.

Lemma rotation_angle_nul : forall I A : PO, A = rotation I 0 A.
intros.
elim (classic (I = A)); intros.
rewrite <- H.
apply rotation_def_centre.
apply rotation_def2; auto.
apply angle_nul; auto.
Qed.

Lemma image_distinct_centre :
 forall (I A B : PO) (a : R),
 I <> A :>PO -> B = rotation I a A :>PO -> I <> B :>PO.
intros; red in |- *; intros.
apply H.
elim rotation_def with (I := I) (A := A) (B := B) (a := a);
 [ unfold distance in |- *; intros | auto | auto ].
rewrite <- H1 in H2.
apply distance_nulle.
rewrite <- (def_sqrt (scalaire (vec I A) (vec I A))); auto with geo.
rewrite H2.
replace (scalaire (vec I I) (vec I I)) with 0.
rewrite sqrt_0; ring.
replace (vec I I) with (mult_PP 0 (vec I B)).
Simplscal.
Ringvec.
Qed.

Lemma rotation_inverse :
 forall (I A B : PO) (a : R),
 B = rotation I a A :>PO -> A = rotation I (- a) B :>PO.
intros.
elim (classic (I = A)); intros.
rewrite <- H0.
rewrite <- H0 in H.
rewrite H; rewrite <- rotation_def_centre; auto.
apply rotation_def_centre.
elim rotation_def with (I := I) (A := A) (B := B) (a := a);
 [ try clear rotation_def; intros | auto | auto ].
apply rotation_def2; auto.
apply image_distinct_centre with (2 := H); auto.
rewrite <- (mes_oppx (A:=I) (B:=A) (C:=I) (D:=B) (x:=a)); auto.
apply image_distinct_centre with (2 := H); auto.
Qed.

Lemma composee_rotations_meme_centre :
 forall (I A B C : PO) (a b : R),
 B = rotation I a A -> C = rotation I b B -> C = rotation I (a + b) A.
intros.
elim (classic (I = A)); intros.
rewrite H0.
rewrite H.
rewrite <- H1.
repeat rewrite <- rotation_def_centre; auto.
generalize (image_distinct_centre (I:=I) (A:=A) (B:=B) (a:=a)); intros H5.
generalize (image_distinct_centre (I:=I) (A:=B) (B:=C) (a:=b)); intros.
elim rotation_def with (I := I) (A := A) (B := B) (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := B) (B := C) (a := b);
 [ try clear rotation_def; intros | auto | auto ].
apply rotation_def2; auto.
rewrite H3; auto.
rewrite add_mes_compatible.
rewrite H7; rewrite H4; rewrite Chasles; auto.
Qed.

Theorem rotation_isometrie :
 forall (I A B A' B' : PO) (a : R),
 A' = rotation I a A -> B' = rotation I a B -> distance A' B' = distance A B.
intros I A B A' B' a H H0; try assumption.
apply distance_carre; auto.
elim (classic (I = A)); intros.
rewrite <- H1 in H.
rewrite <- H1; rewrite H; repeat rewrite <- rotation_def_centre; auto.
elim (classic (I = B)); intros.
rewrite <- H2 in H0.
rewrite H0; rewrite <- H2; repeat rewrite <- rotation_def_centre; auto.
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
rewrite H3; auto.
elim (classic (I = B)); intros.
rewrite <- H2 in H0.
rewrite H0; rewrite <- H2; repeat rewrite <- rotation_def_centre; auto.
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
rewrite (distance_sym A I); auto.
rewrite H3; rewrite distance_sym; auto.
generalize (image_distinct_centre (I:=I) (A:=A) (B:=A') (a:=a)); intros H11.
generalize (image_distinct_centre (I:=I) (A:=B) (B:=B') (a:=a)); intros H12.
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
mesure I A I B.
rewrite (Al_Kashi (A:=I) (B:=A) (C:=B) (a:=x)); auto.
rewrite (Al_Kashi (A:=I) (B:=A') (C:=B') (a:=x)); auto.
rewrite H5; rewrite H3; auto.
rewrite H7.
replace (cons_AV (vec I A') (vec I B')) with
 (plus (cons_AV (vec I A') (vec I A))
    (plus (cons_AV (vec I A) (vec I B)) (cons_AV (vec I B) (vec I B')))).
rewrite <- (mes_oppx (A:=I) (B:=A) (C:=I) (D:=A') (x:=a)); auto.
rewrite <- H7; rewrite <- H4.
rewrite <- add_mes_compatible; rewrite <- add_mes_compatible.
replace (- a + (x + a)) with x; try ring; auto.
rewrite Chasles; auto.
rewrite Chasles; auto.
Qed.

Lemma rotation_IAB :
 forall (I A B A' B' : PO) (a : R),
 I <> A ->
 I <> B ->
 A' = rotation I a A ->
 B' = rotation I a B ->
 cons_AV (vec I A) (vec I B) = cons_AV (vec I A') (vec I B') :>AV.
intros.
generalize (isometrie_distinct (A:=I) (B:=B) (A':=I) (B':=B')); intros.
generalize (isometrie_distinct (A:=I) (B:=A) (A':=I) (B':=A')); intros.
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
replace (cons_AV (vec I A') (vec I B')) with
 (plus (cons_AV (vec I A') (vec I A))
    (plus (cons_AV (vec I A) (vec I B)) (cons_AV (vec I B) (vec I B')))).
rewrite <- H6.
rewrite <- (mes_oppx (A:=I) (B:=A) (C:=I) (D:=A') (x:=a)); auto.
mesure I A I B.
replace (- a + (x + a)) with x; try ring; auto.
rewrite Chasles; auto.
rewrite Chasles; auto.
Qed.

Lemma image_bipoint_distinct :
 forall (I A B A' B' : PO) (a : R),
 A <> B :>PO -> A' = rotation I a A -> B' = rotation I a B -> A' <> B' :>PO.
intros.
generalize (rotation_isometrie (I:=I) (A:=A) (B:=B) (A':=A') (B':=B') (a:=a));
 intros H7.
apply (isometrie_distinct (A:=A) (B:=B)); auto.
symmetry  in |- *; auto.
Qed.

Theorem rotation_conserve_angle :
 forall (I A B C A' B' C' : PO) (a : R),
 A <> B :>PO ->
 A <> C :>PO ->
 A' = rotation I a A ->
 B' = rotation I a B ->
 C' = rotation I a C ->
 cons_AV (vec A B) (vec A C) = cons_AV (vec A' B') (vec A' C') :>AV.
intros.
generalize
 (image_bipoint_distinct (I:=I) (A:=A) (B:=C) (A':=A') (B':=C') (a:=a));
 intros.
generalize
 (image_bipoint_distinct (I:=I) (A:=A) (B:=B) (A':=A') (B':=B') (a:=a));
 intros H11.
elim (classic (I = A)); intros.
rewrite <- H5 in H1; rewrite <- H5 in H; rewrite <- H5 in H0.
rewrite H1; repeat rewrite <- rotation_def_centre; rewrite <- H5; auto.
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := C) (B := C') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
generalize (isometrie_distinct (A:=I) (B:=B) (A':=I) (B':=B')); intros H30.
generalize (isometrie_distinct (A:=I) (B:=C) (A':=I) (B':=C')); intros H31.
apply rotation_IAB with a; auto.
elim (classic (I = B)); intros.
rewrite <- H6 in H2; rewrite <- H6 in H.
rewrite H2; repeat rewrite <- rotation_def_centre; rewrite <- H6; auto.
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim (classic (I = C)); intros.
rewrite <- H9 in H3; rewrite <- H9 in H0.
rewrite H3; repeat rewrite <- rotation_def_centre; rewrite <- H9; auto.
rewrite <- angle_nul; auto.
rewrite <- angle_nul; auto.
apply dist_non_nulle; rewrite distance_sym; rewrite <- H7; auto with geo.
elim rotation_def with (I := I) (A := C) (B := C') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
generalize (isometrie_distinct (A:=I) (B:=C) (A':=I) (B':=C')); intros H31.
elim
 cas_egalite_triangle
  with (A := I) (B := A) (C := C) (A' := I) (B' := A') (C' := C');
 (auto with geo; intros).
elim H14; intros H15 H16; try clear H14; try exact H16.
mesure A C A I.
rewrite <- (mes_oppx (A:=A) (B:=C) (C:=A) (D:=I) (x:=x)); auto.
rewrite <- (mes_oppx (A:=A') (B:=C') (C:=A') (D:=I) (x:=x)); auto.
apply dist_non_nulle; rewrite distance_sym; rewrite <- H7; auto with geo.
rewrite H14; rewrite H15; auto.
generalize (isometrie_distinct (A:=I) (B:=A) (A':=I) (B':=A')); intros H30.
apply rotation_IAB with a; auto.
generalize (isometrie_distinct (A:=I) (B:=A) (A':=I) (B':=A')); intros H30.
generalize (isometrie_distinct (A:=I) (B:=B) (A':=I) (B':=B')); intros H31.
elim (classic (I = C)); intros.
rewrite <- H7 in H3.
rewrite H3; repeat rewrite <- rotation_def_centre; rewrite <- H7; auto.
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim
 cas_egalite_triangle
  with (A := I) (B := A) (C := B) (A' := I) (B' := A') (C' := B');
 (auto; intros).
elim H14; intros H15 H16; try clear H14; try exact H15.
apply rotation_IAB with a; auto.
generalize (isometrie_distinct (A:=I) (B:=C) (A':=I) (B':=C')); intros H32.
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := C) (B := C') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim
 cas_egalite_triangle
  with (A := I) (B := A) (C := B) (A' := I) (B' := A') (C' := B');
 (auto; intros).
elim
 cas_egalite_triangle
  with (A := I) (B := A) (C := C) (A' := I) (B' := A') (C' := C');
 (auto; intros).
elim H18; intros H19 H20; try clear H18; try exact H20.
elim H16; intros H18 H21; try clear H16; try exact H21.
replace (cons_AV (vec A B) (vec A C)) with
 (plus (cons_AV (vec A B) (vec A I)) (cons_AV (vec A I) (vec A C))).
mesure A C A I.
rewrite <- (mes_oppx (A:=A) (B:=C) (C:=A) (D:=I) (x:=x)); auto with geo.
rewrite (mes_oppx (A:=A') (B:=C') (C:=A') (D:=I) (x:=x)); auto with geo.
rewrite H18; rewrite Chasles; auto with geo.
apply dist_non_nulle; rewrite distance_sym; rewrite <- H8; auto with geo.
apply dist_non_nulle; rewrite distance_sym; rewrite <- H8; auto with geo.
rewrite H16; rewrite H19; auto.
rewrite Chasles; auto.
apply rotation_IAB with a; auto.
apply rotation_IAB with a; auto.
Qed.

Theorem rotation_image_bipoint :
 forall (I A B C A' B' C' : PO) (a : R),
 A <> B :>PO ->
 A' = rotation I a A ->
 B' = rotation I a B ->
 distance A' B' = distance A B /\
 image_angle a = cons_AV (vec A B) (vec A' B') :>AV.
intros.
generalize
 (image_bipoint_distinct (I:=I) (A:=A) (B:=B) (A':=A') (B':=B') (a:=a));
 intros H11.
split; [ try assumption | idtac ].
apply rotation_isometrie with (1 := H0); auto.
elim (classic (I = A)); intros.
rewrite <- H2; rewrite <- H2 in H0; rewrite <- H2 in H.
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
rewrite H0; repeat rewrite <- rotation_def_centre; auto.
elim (classic (I = B)); intros.
rewrite <- H3; rewrite <- H3 in H1; rewrite <- H3 in H.
generalize (isometrie_distinct (A:=I) (B:=A) (A':=I) (B':=A')); intros H30.
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
rewrite H1; repeat rewrite <- rotation_def_centre; auto.
rewrite angle_oppu_oppv; auto.
elim rotation_def with (I := I) (A := B) (B := B') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
elim rotation_def with (I := I) (A := A) (B := A') (a := a);
 [ try clear rotation_def; intros | auto | auto ].
generalize (isometrie_distinct (A:=I) (B:=A) (A':=I) (B':=A')); intros H30.
generalize (isometrie_distinct (A:=I) (B:=B) (A':=I) (B':=B')); intros.
elim
 cas_egalite_triangle
  with (A := I) (B := A) (C := B) (A' := I) (B' := A') (C' := B');
 (auto; intros).
elim H10; intros H12 H13; try clear H10; try exact H13.
replace (cons_AV (vec A B) (vec A' B')) with
 (plus (cons_AV (vec A B) (vec A I))
    (plus (cons_AV (vec A I) (vec A' I)) (cons_AV (vec A' I) (vec A' B')))).
mesure A B A I.
rewrite <- (mes_oppx (A:=A') (B:=B') (C:=A') (D:=I) (x:=x)).
rewrite angle_oppu_oppv; auto.
rewrite <- H7.
rewrite <- add_mes_compatible; rewrite <- add_mes_compatible.
replace (x + (a + - x)) with a; try ring; auto.
apply H11; auto.
apply dist_non_nulle; rewrite distance_sym; rewrite <- H6; auto with geo.
rewrite H10; rewrite H12; auto.
rewrite Chasles; auto.
rewrite Chasles; auto.
apply dist_non_nulle; rewrite distance_sym; rewrite <- H6; auto with geo.
apply rotation_IAB with a; auto.
Qed.

Lemma existence_rotation_Ia :
 forall (I M : PO) (a : R), exists M' : PO, M' = rotation I a M.
intros.
elim (classic (M = I)); intros.
exists I.
rewrite H; rewrite <- rotation_def_centre; auto.
elim existence_representant_unitaire with (A := I) (B := M);
 [ intros; try clear existence_representant_unitaire | auto ].
cut (I <> x); intros.
generalize (existence_representant_angle (A:=I) (B:=x) I a); intros.
elim H2;
 [ intros C H3; elim H3; intros H4 H5; try clear H3 H2; try exact H5
 | idtac ].
cut (I <> C); intros.
generalize (distance_vecteur (A:=I) (B:=M)); intros.
elim
 existence_representant_mult_vecteur
  with (A := I) (B := I) (C := C) (k := distance I M);
 intros D H6; try clear existence_representant_mult_vecteur;
 try exact H6.
cut (I <> D); intros.
exists D.
apply rotation_def2; auto.
apply resolution; auto with geo.
repeat rewrite <- carre_scalaire_distance.
rewrite H6; rewrite H3; auto.
rewrite <- H0.
Simplscal.
elim def_representant_unitaire2 with (A := I) (B := M) (C := x);
 [ intros; elim H9; intros H22 H23; rewrite H22; try discrR | auto | auto ].
rewrite carre_scalaire_distance.
rewrite H4.
ring.
rewrite angles_representants_unitaires; auto.
replace (representant_unitaire (vec I D)) with (vec I C).
rewrite <- H0; auto.
apply def_representant_unitaire; auto with geo.
cut (distance I M <> 0); intros; auto with geo.
apply colineaire_alignes with (/ distance I M); auto.
rewrite H6.
Fieldvec (distance I M).
rewrite H6.
replace (scalaire (mult_PP (distance I M) (vec I C)) (vec I C)) with
 (distance I M * scalaire (vec I C) (vec I C)).
apply Rmult_pos; auto with geo.
Simplscal.
apply distinct_produit_vecteur with (3 := H6); auto with geo.
auto with geo.
elim def_representant_unitaire2 with (A := I) (B := M) (C := x);
 [ intros; elim H4; intros H22 H23; try discrR | auto | auto ].
auto with geo.
apply distance_non_nulle.
elim def_representant_unitaire2 with (A := I) (B := M) (C := x);
 [ intros; elim H2; intros H22 H23; rewrite H22; try discrR | auto | auto ].
Qed.

Lemma deux_mes_angle_rotation :
 forall (I M : PO) (a b : R),
 image_angle a = image_angle b -> rotation I a M = rotation I b M.
intros.
elim (classic (I = M)); intros.
rewrite <- H0; repeat rewrite <- rotation_def_centre; auto.
elim (existence_rotation_Ia I M a); intros.
rewrite <- H1.
generalize (rotation_def (I:=I) (A:=M) (B:=x) (a:=a)); intros.
elim H2; auto; intros.
apply rotation_def2; auto.
rewrite <- H4; rewrite <- H; auto.
Qed.


From TLA Require Import prelude.
From TLA.examples.mutex Require Import nodup automation safety liveness.

Section example.

Implicit Types (σ: State) (s: Config) (t: Tid) (tp: gmap Tid pc.t).
Implicit Types (l: bool) (q: list Tid).

Lemma waiters_monotonic_next s s' :
  next s s' →
  wait_set s'.(tp) ⊆ wait_set s.(tp).
Proof.
  destruct s as [σ tp]. destruct s' as [σ' tp'].
  simpl.
  intros Hnext.
  destruct Hnext as [ [t'' Hstep] | Heq ]; [ | by stm ].
  destruct Hstep as [pc [Hlookup [ρ' [Hstep Heq]]]]; stm_simp.
  destruct_step; stm.
Qed.

Lemma waiters_monotonic W :
  spec ⊢
  ⌜λ s, wait_set s.(tp) = W⌝ ~~>
  □⌜λ s, wait_set s.(tp) ⊆ W⌝.
Proof.
  rewrite -leads_to_impl_internal.
  rewrite /spec. tla_clear ⌜init⌝. tla_clear fair.
  apply always_induction_impl_pred.
  - eauto.
  - intros s s' Hwait_set.
    intros Hsubset%waiters_monotonic_next.
    set_solver.
Qed.

Hint Resolve list_elem_of_head : core.

Lemma __queue_gets_popped_locked W t ts :
  spec ⊢
  ⌜λ s, wait_set s.(tp) = W ∧
        s.(state).(queue) = t :: ts ∧
        s.(state).(lock) = true⌝ ~~>
  ⌜λ s, wait_set s.(tp) ⊆ W ∧
       (∃ ts', s.(state).(queue) = ts ++ ts') ∧
        s.(tp) !! t = Some pc.kernel_wait ∧
        t ∉ s.(state).(queue)⌝.
Proof.
  leads_to_trans (∃ t', ⌜λ s,
        wait_set s.(tp) = W ∧
        (∃ ts', s.(state).(queue) = t :: ts ++ ts' ∧
                t ∉ ts ++ ts') ∧
        s.(tp) !! t = Some pc.kernel_wait ∧
        s.(state).(lock) = true ∧
        lock_held s t'⌝)%L.
  - apply (leads_to_assume _ all_invs_ok).
    lt_unfold.
    intros [[HW [Hq Hl]] Hinv].
    destruct Hinv as [_ Hlocked Hnodup Hwaiting _];
      autounfold with inv in *.
    destruct s as [[l q] ?]; simpl in *; subst.
    destruct Hlocked as [t' ?]; eauto.
    exists t'; intuition eauto.
    { exists nil; rewrite app_nil_r. split; first by eauto.
      apply NoDup_cons_inv in Hnodup; intuition auto. }
  - apply leads_to_exist_intro => t'.
    unfold lock_held.

(*|
This "detour" is actually really interesting: you might think that simple transitivity is enough, because if t' has the lock, it will release the lock, then signal to t (transitivity is needed because this is two steps from thread t'). However, this is _not_ the case. It is possible for t' to release the lock, and then for some other thread to happen to do a CAS, acquire the lock, unlock it, and then send the signal to t; the original t' will now signal some other thread. This is unusual because t' is trying to signal something to t but some unrelated thread swoops in and does it instead, many steps later.
|*)
    apply (leads_to_detour ⌜λ s,
      wait_set s.(tp) ⊆ W ∧
      ((∃ ts' : list Tid, s.(state).(queue) = t :: ts ++ ts') ∧
      s.(tp) !! t = Some pc.kernel_wait ∧
       s.(tp) !! t' = Some pc.unlock_wake)⌝).

    { tla_simp.
      apply (mutex_wf1 t'); cbn.
      - intro t''; intros.
        (* extract the invariants we want to use *)
        destruct Hinv as [Hexclusion _ Hnodup _ _];
          destruct Hinv' as [_ _ Hnodup' _ _];
          autounfold with inv in *; simpl in *.
        destruct Hexclusion as [_ Hsafe].
        stm_simp.

        destruct_step; stm_simp; eauto 8.
        + left; intuition eauto.
          eexists (_ ++ [t'']).
          rewrite !app_assoc; split; first by eauto.
          rewrite NoDup_cons_inv in Hnodup Hnodup'.
          rewrite elem_of_app elem_of_list_singleton; intuition subst.
          rewrite NoDup_cons_inv NoDup_app1 in Hnodup'.
          set_solver+ Hnodup'.
        + assert (t'' ≠ t) by set_solver.
          stm.
        + assert (t' = t''); subst.
          { apply Hsafe; eauto. }
          right; stm.
      - stm.
      - stm.
        eexists; split; first by eauto.
        intuition congruence. }

    { apply (mutex_wf1 t'); cbn.
      - intro t''; intros.
        destruct Hinv as [_ _  Hnodup _ _];
          autounfold with inv in *; simpl in *.
        stm_simp.

        destruct_step; stm_simp;
          try solve [ eauto 6 ].
        + left; intuition eauto.
          eexists (_ ++ [t'']).
          rewrite !app_assoc; split; eauto.
        + assert (t'' ≠ t) by set_solver.
          stm.
        + right. eexists; intuition eauto.
          apply NoDup_head_not_in in Hnodup; auto.
      - intros.
        stm.
        destruct Hinv as [_ _ Hnodup _ _];
          autounfold with inv in *; simpl in *.
        apply NoDup_head_not_in in Hnodup; auto.
      - intros.
        stm.
        eexists; split; first by eauto.
        intuition congruence. }
Qed.

Lemma __futex_wait_progress t W :
  spec ⊢
  ⌜λ s, wait_set s.(tp) = W ∧
        s.(tp) !! t = Some pc.futex_wait⌝ ~~>
  ⌜λ s, wait_set s.(tp) ⊂ W ∨
        wait_set s.(tp) = W ∧
        s.(tp) !! t = Some pc.kernel_wait ∧
        s.(state).(lock) = true⌝.
Proof.
  apply (leads_to_detour
           ⌜λ s, wait_set s.(tp) = W ∧
                 s.(state).(lock) = false ∧
                 s.(tp) !! t = Some pc.lock_cas⌝).
  { tla_simp.
    apply (mutex_wf1 t); simpl; intros.
    - destruct_step; stm.
    - stm.
      destruct l0; stm.
    - naive_solver. }
  lt_apply lock_cas_unlocked_progress.
Qed.

Lemma __queue_gets_popped W t ts :
  spec ⊢
  ⌜λ s, wait_set s.(tp) = W ∧
        s.(state).(queue) = t :: ts⌝ ~~>
  ⌜λ s, wait_set s.(tp) ⊂ W ∨
        (wait_set s.(tp) ⊆ W ∧
        s.(tp) !! t = Some pc.kernel_wait ∧
        t ∉ s.(state).(queue))⌝.
Proof.
  apply leads_to_if_lock.
  - lt_apply queue_gets_popped_unlocked.
  - lt_apply __queue_gets_popped_locked.
Qed.

Definition no_wake_threads tp :=
  ∀ t pc, tp !! t = Some pc → pc ≠ pc.unlock_wake.

(** This is never used, but it's an interesting observation. I was hoping to use
it to avoid decreasing a lexicographic tuple, but this strategy doesn't really
work: after waiting for the wake threads to go away, threads may have
re-arranged and the original kernel_wait threads may now be in lock_cas, for
example. *)
Lemma __eventually_no_wake_threads W :
  spec ⊢
  ⌜λ s, wait_set s.(tp) = W⌝ ~~>
  ⌜λ s, wait_set s.(tp) ⊂ W ∨
        s.(state).(lock) = false ∨
        wait_set s.(tp) = W ∧
        s.(state).(lock) = true ∧
        no_wake_threads s.(tp)⌝.
Proof.
  set (h S s := wait_set s.(tp) ⊂ W ∨
                s.(state).(lock) = false ∨
                wait_set s.(tp) = W ∧
                signal_set s.(tp) = S ∧
                s.(state).(lock) = true
      ).
  lt_apply (lattice_leads_to_ex gset_subset_wf h ∅).
  - lt_auto.
    rewrite /h. destruct s.(state).(lock); eauto. naive_solver.
  - intros S Hnotempty.
    rewrite /h.
    assert (∃ t, t ∈ S) as [t Hel].
    { apply set_choose_L in Hnotempty; naive_solver. }
    leads_to_trans (⌜λ s, wait_set s.(tp) ⊂ W ∨
                     s.(state).(lock) = false ∨
                    ∃ U', U' ⊂ S ∧
                            wait_set s.(tp) = W ∧
                            signal_set s.(tp) = U' ∧
                            s.(state).(lock) = true⌝).
    2: { lt_auto naive_solver. }
    leads_to_trans (⌜λ s, wait_set s.(tp) ⊂ W⌝ ∨
                    ⌜λ s, s.(state).(lock) = false⌝ ∨
                    ⌜λ s, wait_set s.(tp) = W ∧
                          signal_set s.(tp) = S ∧
                          s.(state).(lock) = true⌝
                   )%L.
    { lt_auto naive_solver. }
    lt_split; first by lt_auto.
    lt_split; first by lt_auto.
    apply (mutex_wf1 t); simpl; intros.
    + destruct_step; stm.
      * assert (t' ∈ signal_set tp) by eauto.
        assert (t' ∉ wait_set tp) by eauto.
        right; right; right.
        eexists; intuition eauto.
    + stm_simp.
      apply elem_signal_set in Hel.
      stm_simp.
      right; right.
      eexists; intuition eauto.
    + stm_simp.
      apply elem_signal_set in Hel.
      naive_solver.
  - rewrite /h /no_wake_threads.
    lt_auto.
    intros [| [|]]; eauto.
    right; right.
    intuition eauto.
    subst.
    assert (t ∈ signal_set s.(tp)) by eauto.
    set_solver.

    Unshelve.
    all: exact inhabitant.
Qed.

End example.


From iris.heap_lang Require Export lang.
From stdpp Require Import gmap.

(* This file contains some metatheory about the heap_lang language,
  which is not needed for verifying programs. *)

(* Closed expressions and values. *)
Fixpoint is_closed_expr (X : list string) (e : expr) : bool :=
  match e with
  | Val v => is_closed_val v
  | Var x => bool_decide (x ∈ X)
  | Rec f x e => is_closed_expr (f :b: x :b: X) e
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Fork e | Alloc e | Load e =>
     is_closed_expr X e
  | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | Store e1 e2 | FAA e1 e2
  | ResolveProph e1 e2 =>
     is_closed_expr X e1 && is_closed_expr X e2
  | If e0 e1 e2 | Case e0 e1 e2 | CAS e0 e1 e2 =>
     is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
  | NewProph => true
  end
with is_closed_val (v : val) : bool :=
  match v with
  | LitV _ => true
  | RecV f x e => is_closed_expr (f :b: x :b: []) e
  | PairV v1 v2 => is_closed_val v1 && is_closed_val v2
  | InjLV v | InjRV v => is_closed_val v
  end.

Lemma is_closed_weaken X Y e : is_closed_expr X e → X ⊆ Y → is_closed_expr Y e.
Proof. revert X Y; induction e; naive_solver (eauto; set_solver). Qed.

Lemma is_closed_weaken_nil X e : is_closed_expr [] e → is_closed_expr X e.
Proof. intros. by apply is_closed_weaken with [], list_subseteq_nil. Qed.

Lemma is_closed_subst X e x v :
  is_closed_val v → is_closed_expr (x :: X) e → is_closed_expr X (subst x v e).
Proof.
  intros Hv. revert X.
  induction e=> X /= ?; destruct_and?; split_and?; simplify_option_eq;
    try match goal with
    | H : ¬(_ ∧ _) |- _ => apply not_and_l in H as [?%dec_stable|?%dec_stable]
    end; eauto using is_closed_weaken with set_solver.
Qed.
Lemma is_closed_subst' X e x v :
  is_closed_val v → is_closed_expr (x :b: X) e → is_closed_expr X (subst' x v e).
Proof. destruct x; eauto using is_closed_subst. Qed.

(* Substitution *)
Lemma subst_is_closed X e x es : is_closed_expr X e → x ∉ X → subst x es e = e.
Proof.
  revert X. induction e=> X /=; rewrite ?bool_decide_spec ?andb_True=> ??;
    repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
Qed.

Lemma subst_is_closed_nil e x v : is_closed_expr [] e → subst x v e = e.
Proof. intros. apply subst_is_closed with []; set_solver. Qed.

Lemma subst_subst e x v v' :
  subst x v (subst x v' e) = subst x v' e.
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst' e x v v' :
  subst' x v (subst' x v' e) = subst' x v' e.
Proof. destruct x; simpl; auto using subst_subst. Qed.

Lemma subst_subst_ne e x y v v' :
  x ≠ y → subst x v (subst y v' e) = subst y v' (subst x v e).
Proof.
  intros. induction e; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using eq_sym, subst_is_closed_nil with f_equal.
Qed.
Lemma subst_subst_ne' e x y v v' :
  x ≠ y → subst' x v (subst' y v' e) = subst' y v' (subst' x v e).
Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.

Lemma subst_rec' f y e x v :
  x = f ∨ x = y ∨ x = BAnon →
  subst' x v (Rec f y e) = Rec f y e.
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.
Lemma subst_rec_ne' f y e x v :
  (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
  subst' x v (Rec f y e) = Rec f y (subst' x v e).
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed.

(* The stepping relation preserves closedness *)
Lemma head_step_is_closed e1 σ1 obs e2 σ2 es :
  is_closed_expr [] e1 →
  map_Forall (λ _ v, is_closed_val v) σ1.(heap) →
  head_step e1 σ1 obs e2 σ2 es →

  is_closed_expr [] e2 ∧ Forall (is_closed_expr []) es ∧
  map_Forall (λ _ v, is_closed_val v) σ2.(heap).
Proof.
  intros Cl1 Clσ1 STEP.
  destruct STEP; simpl in *; split_and!;
    try apply map_Forall_insert_2; try by naive_solver.
  - subst. repeat apply is_closed_subst'; naive_solver.
  - unfold un_op_eval in *. repeat case_match; naive_solver.
  - unfold bin_op_eval, bin_op_eval_bool in *. repeat case_match; naive_solver.
Qed.