(* TLC in Coq
 *
 * Module: tlc.semantics.term
 * Purpose: Contains the semantics for term forms.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.path.
Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrfun.
Require Import mathcomp.ssreflect.ssrnat.
Require Import tlc.semantics.constructor.
Require Import tlc.semantics.error.
Require Import tlc.semantics.pattern.
Require Import tlc.syntax.all_syntax.
Require Import tlc.utility.monad.
Require Import tlc.utility.option.
Require Import tlc.utility.partial_map.
Require Import tlc.utility.result.
Require Import tlc.utility.seq.

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

Fixpoint push_term_params_rec t k :=
  let fix push_match_params_rec cs k :=
    match cs with
    | [::] => [::]
    | (p, t) :: cs =>
      (p, push_term_params_rec t k) :: push_match_params_rec cs k
    end in
  match t with
  | TParameter (P i j) =>
    if i >= k then TParameter (P i.+1 j) else TParameter (P i j)
  | TVariable x => TVariable x
  | TConstructor c => TConstructor c
  | TFunction f => TFunction f
  | TUnknown u => TUnknown u
  | TApplication f a =>
    TApplication
      (push_term_params_rec f k)
      (push_term_params_rec a k)
  | TMatch cs => TMatch (push_match_params_rec cs k.+1)
  end.

Definition push_term_params t := push_term_params_rec t 0.

Definition argument_map := partial_map [eqType of parameter] (option term).

(* Push a argument map to the next binding level when entering a binder *)
Definition push_argument_map (am : argument_map) :=
  map (fun '(P i j, t) => (P i.+1 j, t)) am.

(* Pop a argument map to the previous binding level when exiting a binder
 * Bindings initially at level 0 will be removed and returned separately.
 *)
Definition pop_argument_map (am : argument_map) :=
  (map (fun '(P i j, t) => (P i.-1 j, t))
    (filter (fun '(P i _, _) => i > 0) am),
  map (fun '(P _ j, t) => (j, t))
    (filter (fun '(P i _, _) => i == 0) am)).

(* Get the set of binders appearing in an argument map *)
Definition argument_map_binders (am : argument_map) :=
  undup (map (fun '(P i _, _) => i) am).

(* Get the number of binders appearing in an argument map *)
Definition count_argument_map_binders am :=
  if omax (argument_map_binders am) is Some k then k.+1 else 0.

Fixpoint group_argument_map_by_binder_rec am k :=
  let '(am, usm) := pop_argument_map am in
  if k is k.+1 then rcons (group_argument_map_by_binder_rec am k) usm
  else [:: usm].

Definition group_argument_map_by_binder am :=
  if count_argument_map_binders am is k.+1 then
    group_argument_map_by_binder_rec am k
  else [::].

Definition flatten_argument_map_binder (usm : seq (nat * option term)) :=
  (* Ensure all bindings are mapped *)
  let js := map fst usm in
  let j_count := if omax js is Some j then j.+1 else 0 in
  if set_eq js (iota 0 j_count) && uniq js then
    usm <- foldr
      (fun '(j, t) z =>
        if z is Some z then
          if t is Some t then Some ((j, t) :: z)
          else None
        else None)
      (Some [::])
      usm;
    pure (map snd (sort (fun '(j1, _) '(j2, _) => j1 <= j2) usm))
  else None.

(* Flatten an argument map into a sequence of arguments ordered from
 * outermost to innermost
 *)
Definition flatten_argument_map (am : argument_map) :=
  (* Ensure all binders are mapped *)
  if set_eq (argument_map_binders am) (iota 0 (count_argument_map_binders am)) then
    foldr
      (fun usm z =>
        z <- z;
        us <- flatten_argument_map_binder usm;
        pure (us :: z))
      (Some [::])
      (group_argument_map_by_binder am)
  else None.

(* Unify two terms within an argument map
 * If the two terms are equal when substituting according to the map,
 * an updated map is returned.
 *)
Fixpoint unify_term_with t' t am :=
  let fix unify_cases_with cs' cs am :=
    match cs', cs with
    | [::], [::] => pure am
    | (p', t') :: cs', (p, t) :: cs =>
      if p' == p then
        am <- unify_term_with t' t (push_argument_map am);
        unify_cases_with cs' cs (pop_argument_map am).1
      else None
    | _, _ => None
    end
  in
  match t', t with
  | TParameter x', t =>
    if am {@ x'} is Some ot' then
      if ot' is Some t' then
        if t' == t then pure am else None
      else pure am {= x' := Some t}
    else if t' == t then pure am else None
  | TVariable x', TVariable x => if x' == x then pure am else None
  | TConstructor c', TConstructor c => if c' == c then pure am else None
  | TFunction f', TFunction f => if f' == f then pure am else None
  | TUnknown u', TUnknown u => if u' == u then pure am else None
  | TApplication f' a', TApplication f a =>
    am <- unify_term_with f' f am;
    unify_term_with a' a am
  | TMatch cs', TMatch cs => unify_cases_with cs' cs am
  | _, _ => None
  end.

(* Determine whether a term is a value
 * Values are constructors that are fully applied with value arguments.
 *)
Fixpoint is_value_rec t :=
  match t with
  | TParameter _ => None
  | TVariable _ => None
  | TConstructor c => Some (constructor_arity c)
  | TFunction _ => None
  | TUnknown _ => None
  | TApplication f a =>
    kf <- is_value_rec f;
    ka <- is_value_rec a;
    match kf, ka with
    | kf'.+1, 0 => Some kf'
    | _, _ => None
    end
  | TMatch _ => None
  end.
Definition is_value t := is_value_rec t == Some 0.

(* Derive the constructor and arguments of a value term
 * Returns Some (c, [x1, .., xn]) if the term t is of the form
 * (TConstructor c) ' x1 ' .. ' xn.
 *)
Fixpoint term_construction t :=
  match t with
  | TParameter _ => None
  | TVariable _ => None
  | TConstructor c => Some (c, [::])
  | TFunction _ => None
  | TUnknown _ => None
  | TApplication f x =>
    match term_construction f with
    | Some (c, xs) => Some (c, rcons xs x)
    | None => None
    end
  | TMatch _ => None
  end.

(* Every value term has a constructor *)
Lemma value_construction t :
  is_value t ->
  term_construction t <> None.
Proof.
Admitted.

(* Open a term t at depth k with bindings us *)
Fixpoint open_term_at k us t :=
  match t with
  | TParameter (P i j) =>
    if i == k then
      if onth us j is Some u then pure u
      else Failure (k, P i j)
    else if i > k then pure (TParameter (P i.-1 j))
    else pure t
  | TVariable _ => pure t
  | TConstructor _ => pure t
  | TFunction _ => pure t
  | TUnknown _ => pure t
  | TApplication f a =>
    f <- open_term_at k us f;
    a <- open_term_at k us a;
    pure (TApplication f a)
  | TMatch cs =>
    TMatch <$>
      (flatten_results ((fun '(p, b) =>
        match open_term_at k.+1 us b with
        | Success b => Success (p, b)
        | Failure e => Failure e
        end) <$> cs))
  end.
Definition open_term := open_term_at 0.

(* Determine whether a term is locally closed
 * A term is locally closed if every parameter reference is well-formed.
 *)
Fixpoint term_lc_in ks t :=
  match t with
  | TParameter (P i j) => if onth ks i is Some k then j < k else false
  | TVariable _ => true
  | TConstructor _ => true
  | TFunction _ => true
  | TUnknown _ => true
  | TApplication f a =>
    term_lc_in ks f && term_lc_in ks a
  | TMatch cs =>
    all (fun '(p, b) => term_lc_in (pattern_arity p :: ks) b) cs
  end.
Definition term_lc := term_lc_in [::].

(* Any term that is closed at depth ks is closed at depth k :: ks *)
Lemma term_lc_in_cons k ks t :
  term_lc_in ks t ->
  term_lc_in (k :: ks) t.
Proof.
Admitted.

(* Any term that is closed at depth ks is closed at depth ks' ++ ks *)
Lemma term_lc_in_concat ks' ks t :
  term_lc_in ks t ->
  term_lc_in (ks' ++ ks) t.
Proof.
  elim: ks' => [| k ks' IH] //=.
  by move=> H; specialize (IH H); apply term_lc_in_cons.
Qed.

(* Opening a closed term at a depth above its closure depth has no effect *)
Lemma open_lc_term_at k ks us t :
  k >= size ks ->
  term_lc_in ks t ->
  open_term_at k us t = Success t.
Proof.
Admitted.

(* Compute the set of flexible variables appearing in a term *)
Fixpoint term_flexibles t :=
  match t with
  | TParameter _ => [::]
  | TVariable (VF x) => [:: x]
  | TVariable (VR _) => [::]
  | TConstructor _ => [::]
  | TFunction _ => [::]
  | TUnknown _ => [::]
  | TApplication f a => term_flexibles f ++ term_flexibles a
  | TMatch cs => foldr cat [::] ((fun '(_, b) => term_flexibles b) <$> cs)
  end.

(* Compute the set of rigid variables appearing in a term *)
Fixpoint term_rigids t :=
  match t with
  | TParameter _ => [::]
  | TVariable (VF _) => [::]
  | TVariable (VR x) => [:: x]
  | TConstructor _ => [::]
  | TFunction _ => [::]
  | TUnknown _ => [::]
  | TApplication f a => term_rigids f ++ term_rigids a
  | TMatch cs => foldr cat [::] ((fun '(_, b) => term_rigids b) <$> cs)
  end.

(* Compute the set of variables appearing in a term *)
Definition term_vars t :=
  map VF (term_flexibles t) ++ map VR (term_rigids t).

(* Determine whether a term is globally closed
 * A term is globally closed if it contains no rigid variables.
 *)
Definition term_gc_in xs t := subset (term_rigids t) xs.
Definition term_gc := term_gc_in [::].

(* Determine whether a term is closed
 * A term is closed if it is locally and globally closed.
 *)
Definition term_closed_in ks xs t := term_lc_in ks t && term_gc_in xs t.
Definition term_closed t := term_lc t && term_gc t.

(* A closed term is locally closed *)
Lemma closed_term_lc ks xs t :
  term_closed_in ks xs t ->
  term_lc_in ks t.
Proof.
  by move/andP => [??].
Qed.

(* A closed term is globally closed *)
Lemma closed_term_gc ks xs t :
  term_closed_in ks xs t ->
  term_gc_in xs t.
Proof.
  by move/andP => [??].
Qed.

(* Well-formed opening will not fail *)
Lemma open_closed_term_at ks xs k us t :
  term_closed_in ks xs t ->
  onth ks k = Some (size us) ->
  exists t', open_term_at k us t = Success t'.
Proof.
Admitted.

(* Determine whether a term is rigid
 * A term is rigid if it contains no flexible variables.
 *)
Fixpoint term_rigid t :=
  match t with
  | TParameter _ => true
  | TVariable (VR _) => true
  | TVariable (VF _) => false
  | TConstructor _ => true
  | TFunction _ => true
  | TUnknown _ => true
  | TApplication f a => term_rigid f && term_rigid a
  | TMatch cs => all (fun '(p, b) => term_rigid b) cs
  end.

(* Replace all instances of term x with term u within t *)
Fixpoint replace_term (x u t : term) :=
  if x == t then u else
  match t with
  | TParameter _ => t
  | TVariable _ => t
  | TConstructor _ => t
  | TFunction _ => t
  | TUnknown _ => t
  | TApplication f a =>
    TApplication (replace_term x u f) (replace_term x u a)
  | TMatch cs =>
    TMatch ((fun '(p, b) => (p, replace_term x u b)) <$> cs)
  end.

(* Replace all instances of variable x with term u within t *)
Definition replace_term_var x u t := replace_term (TVariable x) u t.

(* Replacing a flexible variable inside of a rigid term has no effect *)
Lemma replace_rigid_term_flexible_var (x : flexible) u t :
  term_rigid t ->
  replace_term x u t = t.
Proof.
Admitted.

(* Replacing a rigid variable inside of a globally-closed term has no effect *)
Lemma replace_gc_term_rigid_var (x : rigid) u t :
  term_gc t ->
  replace_term x u t = t.
Proof.
Admitted.

(* Determine whether a replacement within a term is compatible *)
Definition term_replace_compatible x u :=
  match x with
  | VR x => term_rigid u
  | VF x => true
  end.

(* Determine whether a replacement within a term is admissible *)
Definition term_replace_admissible x u :=
  term_replace_compatible x u && term_lc u.

(* Determine whether a term is known
 * A term is local if it does not contain any unknowns.
 *)
Fixpoint term_known t :=
  match t with
  | TParameter _ => true
  | TVariable _ => true
  | TConstructor _ => true
  | TFunction _ => true
  | TUnknown _ => false
  | TApplication f a => term_known f && term_known a
  | TMatch cs => all (fun '(p, b) => term_known b) cs
  end.

(* Determine whether all patterns in a term are well-formed *)
Fixpoint patterns_wf t :=
  match t with
  | TParameter _ => true
  | TVariable _ => true
  | TConstructor _ => true
  | TFunction _ => true
  | TUnknown _ => true
  | TApplication f a => patterns_wf f && patterns_wf a
  | TMatch cs => all (fun '(p, b) => pattern_wf p && patterns_wf b) cs
  end.

(* Determine whether a term is computable
 * This is a weaker form of type checking.  It checks whether a term is locally
 * and globally closed, rigid, known, and contains only well-formed patterns.
 *)
Definition term_computable t :=
  [&& term_closed t
    , term_rigid t
    , term_known t
    & patterns_wf t
    ].

(* A computable term is closed *)
Lemma computable_term_closed t :
  term_computable t ->
  term_closed t.
Proof.
  by move/andP => [??].
Qed.

(* A computable term is rigid *)
Lemma computable_term_rigid t :
  term_computable t ->
  term_rigid t.
Proof.
  by move/andP => [_]; move/andP => [? _].
Qed.

(* A computable term has no rigids *)
Lemma computable_term_rigids t :
  term_computable t ->
  term_rigids t = [::].
Proof.
  by move=> Hc; move/andP: (computable_term_closed Hc) => [_ ?];
    exact: subsets0.
Qed.

(* Reduce the application of an argument to a match.
 * If no match can be made between the patterns and the argument, EMatch will
 * be returned with an explanation for each matching failure.  If a match is
 * found, the case body will be opened using the bindings produced by the match.
 * If an error is encountered during opening, EOpenTerm will be returned to
 * explain what bindings were produced and which parameter was out of bounds.
 *)
Fixpoint reduce_match cs a :=
  match cs with
  | [::] => Failure (EEmptyMatch a)
  | (p, b) :: cs =>
    match match_pattern p a with
    | Success us =>
      match open_term us b with
      | Success t => Success t
      | Failure (k, x) => Failure (EOpenTerm b us k x)
      end
    | Failure pe =>
      match reduce_match cs a with
      | Success t => Success t
      | Failure e => Failure (EMatch p pe a e)
      end
    end
  end.

(* Reduce a term as far as possible given some amount of recursion fuel
 * This algorithm uses the fuel pattern to prove termination.
 *)
Fixpoint reduce_term_rec fuel t :=
  if fuel is fuel.+1 then
  match t with
  | TParameter _ => pure t
  | TVariable _ => pure t
  | TConstructor _ => pure t
  | TFunction _ => pure t
  | TUnknown _ => pure t
  | TApplication f a =>
    f' <- reduce_term_rec fuel f;
    a' <- reduce_term_rec fuel a;
    let t' := TApplication f' a' in
    match t' with
    | TApplication (TMatch cs) _ =>
      (* Do not fail pattern matching failed on a non-value *)
      match reduce_match cs a' with
      | Success b => reduce_term_rec fuel b
      | Failure e => if is_value a' then Failure e else pure t'
      end
    (* Boolean equality *)
    | TApplication (TApplication FEqual x1) x2 =>
      (* Only reduce this if the equality can be determined
       * Equality can be determined if the terms are syntactically equal or if
       * both terms are values.
       *)
      if x1 == x2 then pure TTrue
      else if is_value x1 && is_value x2 then pure TFalse
      else pure t'
    (* Naturals *)
    | TApplication (TApplication FAdd x1) x2 =>
      match nat_of_term x1, nat_of_term x2 with
      | Some x1', Some x2' => pure (term_of_nat (x1' + x2'))
      | Some x1', None => pure {-t term_of_nat x1' + x2 -}
      | None, Some x2' => pure {-t x1 + term_of_nat x2' -}
      | None, None => pure t
      end
    (* Lists *)
    | TApplication (TApplication FMap f) xs =>
      match xs with
      | CNil => pure xs
      | TApplication (TApplication CCons x) xs' =>
        reduce_term_rec fuel {-t (f ' x) :: (FMap ' f ' xs') -}
      | _ => pure t
      end
    | TApplication (TApplication FCount y) xs =>
      match xs with
      | CNil => pure TZero
      | TApplication (TApplication CCons x) xs' =>
        reduce_term_rec fuel {-t
          if: x == y then: CSucc ' (FCount ' y ' xs')
          else: FCount ' y ' xs'
        -}
      | _ => pure t'
      end
    | TApplication (TApplication FConcat xs1) xs2 =>
      match xs1 with
      | CNil => pure xs2
      | TApplication (TApplication CCons x) xs1 =>
        reduce_term_rec fuel {-t
          x :: (xs1 ++ xs2)
        -}
      | _ => pure t'
      end
    | TApplication (TApplication FSetUnion xs) ys =>
      match xs with
      | CNil => pure ys
      | TApplication (TApplication CCons x) xs' =>
        reduce_term_rec fuel {-t
          if: x \in ys then: xs' :|: ys
          else: x :: (xs' :|: ys)
        -}
      | _ => pure t'
      end
    | _ => pure t'
    end
  | TMatch _ => pure t
  end
  else Failure (EFuel t).

(* Reduce a term with a default amount of recursion fuel *)
Definition reduce_term_fuel := 4999.
Definition reduce_term := reduce_term_rec reduce_term_fuel.
Notation "[[t t ]]" := (reduce_term t) (at level 0, no associativity).


(* 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 angles_vecteurs.
Set Implicit Arguments.
Unset Strict Implicit.
(* Le plan est orienté et on utilise le cercle trigonométrique*)

Definition repere_orthonormal_direct (O I J : PO) :=
  image_angle pisurdeux = cons_AV (vec O I) (vec O J) /\
  scalaire (vec O I) (vec O I) = 1 /\ scalaire (vec O J) (vec O J) = 1.
Parameter cos : R -> R.
Parameter sin : R -> R.
Parameter Cos : AV -> R.
Parameter Sin : AV -> R.
(* cosinus et sinus d'un angle (ou d'un réel) sont obtenus par projections
   du point image du cercle trigonométrique sur les axes de coordonnées*)

Axiom
  def_cos :
    forall (A B C : PO) (x : R),
    distance A B = 1 ->
    distance A C = 1 ->
    image_angle x = cons_AV (vec A B) (vec A C) ->
    cos x = scalaire (vec A B) (vec A C).

Axiom
  def_sin :
    forall (A B C D : PO) (x : R),
    distance A B = 1 ->
    distance A C = 1 ->
    image_angle x = cons_AV (vec A B) (vec A C) ->
    repere_orthonormal_direct A B D -> sin x = scalaire (vec A C) (vec A D).

Axiom
  def_Cos :
    forall A B C : PO,
    distance A B = 1 ->
    distance A C = 1 ->
    Cos (cons_AV (vec A B) (vec A C)) = scalaire (vec A B) (vec A C).

Axiom
  def_Sin :
    forall A B C D : PO,
    distance A B = 1 ->
    distance A C = 1 ->
    repere_orthonormal_direct A B D ->
    Sin (cons_AV (vec A B) (vec A C)) = scalaire (vec A C) (vec A D).

Lemma ROND_RON :
 forall O I J : PO,
 repere_orthonormal_direct O I J -> repere_orthonormal O I J.
unfold repere_orthonormal_direct, repere_orthonormal in |- *; intros.
elim H; intros H0 H1; try clear H; try exact H1.
split; [ auto with geo | try assumption ].
Qed.
Hint Resolve ROND_RON: geo.

Definition repere_orthonormal_indirect (O I J : PO) :=
  image_angle pisurdeux = cons_AV (vec O J) (vec O I) /\
  scalaire (vec O I) (vec O I) = 1 /\ scalaire (vec O J) (vec O J) = 1.

Lemma ROND_RONI :
 forall O I J : PO,
 repere_orthonormal_direct O I J -> repere_orthonormal_indirect O J I.
unfold repere_orthonormal_indirect, repere_orthonormal_direct in |- *.
intros O I J H; try assumption.
elim H; intros H0 H1; try clear H; try exact H1.
elim H1; intros H H2; try clear H1; try exact H2.
split; [ auto | split; [ auto | try assumption ] ].
Qed.

Lemma ROND_new :
 forall O I J K : PO,
 repere_orthonormal_direct O I J ->
 vec O K = mult_PP (-1) (vec O I) -> repere_orthonormal_direct O J K.
unfold repere_orthonormal_indirect, repere_orthonormal_direct in |- *.
intros O I J K H H0; try assumption.
elim H; intros H1 H2; elim H2; intros H3 H4; try clear H2 H; try exact H4.
cut (scalaire (vec O K) (vec O K) = 1); intros.
split; [ auto | split; [ auto | try assumption ] ].
replace pisurdeux with (- pisurdeux + pi).
cut (image_angle (- pisurdeux) = cons_AV (vec O J) (vec O I)); intros.
cut (image_angle pi = cons_AV (vec O I) (vec O K)); intros.
rewrite add_mes_compatible.
rewrite H5; rewrite H2; rewrite Chasles; auto with geo.
replace (vec O K) with (vec I O).
rewrite <- angle_plat; auto with geo.
rewrite H0.
unfold vec in |- *; RingPP.
apply mes_oppx; auto with geo.
unfold pi in |- *; ring.
rewrite H0.
Simplscal; rewrite H3; ring.
Qed.

Lemma existence_ROND_AB :
 forall A B : PO,
 distance A B = 1 -> exists C : PO, repere_orthonormal_direct A B C.
intros.
elim
 existence_representant_angle
  with (A := A) (B := B) (C := A) (x := pisurdeux);
 [ intros C H0; elim H0; intros H1 H2; try clear H0; try exact H2 | auto ].
exists C; unfold repere_orthonormal_direct in |- *.
split; [ try assumption | idtac ].
split; auto with geo.
Qed.

Lemma cos_deux_mes :
 forall x y : R, image_angle x = image_angle y -> cos x = cos y.
intros.
elim existence_AB_unitaire; intros A H1; elim H1; intros B H0; try clear H1.
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H1; elim H1; intros; try clear H1 | auto ].
rewrite (def_cos (A:=A) (B:=B) (C:=C) (x:=x)); auto.
rewrite (def_cos (A:=A) (B:=B) (C:=C) (x:=y)); auto.
rewrite <- H3; auto.
Qed.

Lemma cos_paire : forall x : R, cos (- x) = cos x.
intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
rewrite (def_cos (A:=A) (B:=B) (C:=C) (x:=x)); auto.
cut (image_angle (- x) = cons_AV (vec A C) (vec A B)); intros.
rewrite (def_cos (A:=A) (B:=C) (C:=B) (x:=- x)); auto.
rewrite scalaire_sym; auto.
apply mes_oppx; auto with geo.
Qed.

Lemma cos_periodique : forall x : R, cos (x + deuxpi) = cos x.
intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
rewrite (def_cos (A:=A) (B:=B) (C:=C) (x:=x)); auto.
cut (image_angle (x + deuxpi) = cons_AV (vec A B) (vec A C)); intros.
rewrite (def_cos (A:=A) (B:=B) (C:=C) (x:=x + deuxpi)); auto.
apply mesure_mod_deuxpi; auto with geo.
Qed.

Lemma sin_deux_mes :
 forall x y : R, image_angle x = image_angle y -> sin x = sin y.
intros.
elim existence_AB_unitaire; intros A H1; elim H1; clear H1; intros B H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H10 | auto ].
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H1; elim H1; intros; try clear H1 | auto ].
rewrite (def_sin (A:=A) (B:=B) (C:=C) (D:=D) (x:=x)); auto.
rewrite (def_sin (A:=A) (B:=B) (C:=C) (D:=D) (x:=y)); auto.
rewrite <- H3; auto.
Qed.

Lemma sin_periodique : forall x : R, sin (x + deuxpi) = sin x.
intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H10 | auto ].
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
rewrite (def_sin (A:=A) (B:=B) (C:=C) (D:=D) (x:=x)); auto.
cut (image_angle (x + deuxpi) = cons_AV (vec A B) (vec A C)); intros.
rewrite (def_sin (A:=A) (B:=B) (C:=C) (D:=D) (x:=x + deuxpi)); auto.
apply mesure_mod_deuxpi; auto with geo.
Qed.

Lemma sin_cos_pisurdeux_moins_x : forall x : R, sin x = cos (pisurdeux + - x).
intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
elim existence_ROND_AB with (A := A) (B := B);
 [ intros D H; try exact H | auto ].
rewrite (def_sin (A:=A) (B:=B) (C:=C) (D:=D) (x:=x)); auto.
cut (image_angle (- x) = cons_AV (vec A C) (vec A B)); intros.
replace (pisurdeux + - x) with (- x + pisurdeux); try ring.
elim H; intros.
elim H5; intros H6 H7; try clear H5; try exact H7.
rewrite (def_cos (A:=A) (B:=C) (C:=D) (x:=- x + pisurdeux)); auto with geo.
rewrite add_mes_compatible.
rewrite H3; rewrite H4; rewrite Chasles; auto with geo.
apply mes_oppx; auto with geo.
Qed.

Lemma cos_sin_pisurdeux_moins_x : forall x : R, cos x = sin (pisurdeux + - x).
intros.
rewrite sin_cos_pisurdeux_moins_x.
replace (pisurdeux + - (pisurdeux + - x)) with x; try ring.
Qed.

Lemma cos_zero : cos 0 = 1.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
rewrite (def_cos (A:=A) (B:=B) (C:=B) (x:=0)); auto with geo.
rewrite <- angle_nul; auto with geo.
Qed.

Lemma sin_zero : sin 0 = 0.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H | auto ].
elim H; intros.
rewrite (def_sin (A:=A) (B:=B) (C:=B) (D:=D) (x:=0)); auto with geo.
rewrite <- angle_nul; auto with geo.
Qed.

Lemma cos_pisurdeux : cos pisurdeux = 0.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H | auto ].
elim H; intros.
elim H2; intros H3 H4; try clear H2; try exact H4.
rewrite (def_cos (A:=A) (B:=B) (C:=D) (x:=pisurdeux)); auto with geo.
Qed.

Lemma sin_pisurdeux : sin pisurdeux = 1.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H | auto ].
elim H; intros.
elim H2; intros H3 H4; try clear H2; try exact H4.
rewrite (def_sin (A:=A) (B:=B) (C:=D) (D:=D) (x:=pisurdeux)); auto with geo.
Qed.

Lemma cos_pi : cos pi = -1.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim
 existence_representant_mult_vecteur
  with (A := A) (B := A) (C := B) (k := -1); intros D H1.
cut (scalaire (vec A D) (vec A D) = 1); intros.
rewrite (def_cos (A:=A) (B:=B) (C:=D) (x:=pi)); auto with geo.
rewrite H1.
Simplscal; rewrite carre_scalaire_distance; rewrite H0; ring.
replace (vec A D) with (vec B A).
rewrite <- angle_plat; auto with geo.
rewrite H1.
Ringvec.
rewrite H1.
Simplscal; rewrite carre_scalaire_distance; rewrite H0; ring.
Qed.

Lemma sin_pi : sin pi = 0.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H | auto ].
elim H; intros.
elim H2; intros H4 H5; try clear H2; try exact H4.
elim
 existence_representant_mult_vecteur
  with (A := A) (B := A) (C := B) (k := -1); intros E H3.
rewrite (def_sin (A:=A) (B:=B) (C:=E) (D:=D) (x:=pi)); auto.
rewrite H3.
cut (scalaire (vec A B) (vec A D) = 0); auto with geo; intros.
Simplscal; rewrite H2; ring.
cut (scalaire (vec A E) (vec A E) = 1); auto with geo; intros.
rewrite H3.
Simplscal; rewrite H4; ring.
replace (vec A E) with (vec B A).
rewrite <- angle_plat; auto with geo.
rewrite H3.
Ringvec.
Qed.

Lemma coordonnees_cos_sin :
 forall (x : R) (O I J M : PO),
 repere_orthonormal_direct O I J ->
 image_angle x = cons_AV (vec O I) (vec O M) ->
 distance O M = 1 ->
 vec O M = add_PP (mult_PP (cos x) (vec O I)) (mult_PP (sin x) (vec O J))
 :>PP.
intros.
elim H; intros.
elim H3; intros H4 H5; try clear H3; try exact H5.
rewrite (def_sin (A:=O) (B:=I) (C:=M) (D:=J) (x:=x)); auto with geo.
rewrite (def_cos (A:=O) (B:=I) (C:=M) (x:=x)); auto with geo.
pattern (vec O M) at 1 in |- *.
rewrite (coordonnees_scalaire_base (O:=O) (I:=I) (J:=J) M); auto with geo.
rewrite scalaire_sym; auto.
Qed.

Lemma calcul_cos_sin :
 forall (x a b : R) (O I J M : PO),
 repere_orthonormal_direct O I J ->
 image_angle x = cons_AV (vec O I) (vec O M) ->
 distance O M = 1 ->
 vec O M = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J)) :>PP ->
 a = cos x /\ b = sin x.
intros.
apply unicite_coordonnees with (2 := H2); auto with geo.
apply coordonnees_cos_sin; auto.
Qed.

Lemma trigo_Pythagore : forall x : R, Rsqr (cos x) + Rsqr (sin x) = 1.
unfold Rsqr in |- *; intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := x);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
elim existence_ROND_AB with (A := A) (B := B); [ intros D H | auto ].
elim H; intros.
cut
 (vec A C = add_PP (mult_PP (cos x) (vec A B)) (mult_PP (sin x) (vec A D)));
 intros.
replace 1 with (scalaire (vec A C) (vec A C)); auto with geo.
rewrite H5.
Simplscal.
elim H4; intros H6 H7; try clear H4; try exact H7.
rewrite H7; rewrite H6.
rewrite (pisurdeux_scalaire_nul (A:=A) (B:=B) (C:=D)); auto.
rewrite scalaire_sym.
rewrite (pisurdeux_scalaire_nul (A:=A) (B:=B) (C:=D)); auto.
ring.
apply coordonnees_cos_sin; auto.
Qed.

Lemma pisurdeux_plus_x :
 forall x : R, cos (pisurdeux + x) = - sin x /\ sin (pisurdeux + x) = cos x.
intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H10 | auto ].
elim
 existence_representant_angle
  with (A := A) (B := B) (C := A) (x := pisurdeux + x);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
elim H10; intros.
elim H3; intros H6 H7; try clear H3; try exact H7.
elim
 existence_representant_mult_vecteur
  with (A := A) (B := A) (C := B) (k := -1); intros E H4.
cut (image_angle x = cons_AV (vec A D) (vec A C)); intros.
generalize
 (coordonnees_cos_sin (x:=pisurdeux + x) (O:=A) (I:=B) (J:=D) (M:=C));
 intros.
generalize (coordonnees_cos_sin (x:=x) (O:=A) (I:=D) (J:=E) (M:=C)); intros.
cut
 (vec A C = add_PP (mult_PP (- sin x) (vec A B)) (mult_PP (cos x) (vec A D)));
 intros.
apply unicite_coordonnees with (3 := H9); auto with geo.
rewrite H8; auto.
rewrite H4.
unfold vec in |- *; RingPP.
apply ROND_new with B; auto.
replace x with (- pisurdeux + (pisurdeux + x)); try ring.
replace (cons_AV (vec A D) (vec A C)) with
 (plus (cons_AV (vec A D) (vec A B)) (cons_AV (vec A B) (vec A C))).
replace (cons_AV (vec A D) (vec A B)) with (image_angle (- pisurdeux)).
rewrite <- H2.
apply add_mes_compatible.
apply mes_oppx; auto with geo.
apply Chasles; auto with geo.
Qed.

Lemma sin_impaire : forall x : R, sin (- x) = - sin x.
intros.
elim pisurdeux_plus_x with (x := - x); intros H H0;
 try clear pisurdeux_plus_x; try exact H.
replace (sin (- x)) with (-1 * - sin (- x)).
rewrite <- H.
replace (- x + pisurdeux) with (pisurdeux + - x).
rewrite <- sin_cos_pisurdeux_moins_x.
ring.
ring.
ring.
Qed.

Lemma pi_moins_x :
 forall x : R, cos (pi + - x) = - cos x /\ sin (pi + - x) = sin x.
intros.
unfold pi in |- *.
replace (pisurdeux + pisurdeux + - x) with (pisurdeux + (pisurdeux + - x)).
elim pisurdeux_plus_x with (x := pisurdeux + - x); intros H H0;
 try clear pisurdeux_plus_x; try exact H0.
rewrite H0; rewrite H.
split; [ try assumption | idtac ].
rewrite cos_sin_pisurdeux_moins_x; auto.
rewrite sin_cos_pisurdeux_moins_x; auto.
ring.
Qed.

Lemma pi_plus_x :
 forall x : R, cos (pi + x) = - cos x /\ sin (pi + x) = - sin x.
intros.
elim pi_moins_x with (x := - x); intros H H0; try clear pi_moins_x;
 try exact H0.
replace (pi + x) with (pi + - - x).
rewrite H0; rewrite H.
split; [ try assumption | idtac ].
rewrite cos_paire; auto.
rewrite sin_impaire; auto.
ring.
Qed.

Theorem cos_diff :
 forall a b : R, cos (a + - b) = cos a * cos b + sin a * sin b.
intros.
elim existence_AB_unitaire; intros A H; elim H; intros B H0; try clear H;
 try exact H0.
elim existence_ROND_AB with (A := A) (B := B); [ intros D H10 | auto ].
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := a);
 [ intros C H; elim H; intros H1 H2; try clear H; try exact H2 | auto ].
elim existence_representant_angle with (A := A) (B := B) (C := A) (x := b);
 [ intros E H; elim H; intros H3 H4; try clear H; try exact H4 | auto ].
generalize (coordonnees_cos_sin (x:=a) (O:=A) (I:=B) (J:=D) (M:=C)); intros H.
generalize (coordonnees_cos_sin (x:=b) (O:=A) (I:=B) (J:=D) (M:=E)); intros.
replace (cos a * cos b + sin a * sin b) with (scalaire (vec A C) (vec A E)).
cut (image_angle (a + - b) = cons_AV (vec A E) (vec A C)); intros.
rewrite (def_cos (A:=A) (B:=E) (C:=C) (x:=a + - b)); auto.
rewrite scalaire_sym; auto.
replace (cons_AV (vec A E) (vec A C)) with
 (plus (cons_AV (vec A E) (vec A B)) (cons_AV (vec A B) (vec A C))).
replace (cons_AV (vec A E) (vec A B)) with (image_angle (- b)).
rewrite <- H2.
replace (a + - b) with (- b + a).
apply add_mes_compatible.
ring.
apply mes_oppx; auto with geo.
apply Chasles; auto with geo.
rewrite H5; auto.
rewrite H; auto.
Simplscal.
elim H10; intros.
elim H7; intros H8 H9; try clear H7; try exact H9.
cut (scalaire (vec A B) (vec A D) = 0); auto with geo; intros.
rewrite H9; rewrite H8; rewrite H7.
rewrite scalaire_sym; rewrite H7.
ring.
Qed.

Lemma cos_som :
 forall a b : R, cos (a + b) = cos a * cos b + - (sin a * sin b).
intros.
replace (a + b) with (a + - - b).
rewrite (cos_diff a (- b)).
rewrite cos_paire.
rewrite sin_impaire.
ring.
ring.
Qed.

Lemma sin_som : forall a b : R, sin (a + b) = sin a * cos b + sin b * cos a.
intros.
replace (sin (a + b)) with (cos (pisurdeux + - (a + b))).
replace (pisurdeux + - (a + b)) with (pisurdeux + - a + - b).
rewrite cos_diff.
rewrite <- sin_cos_pisurdeux_moins_x.
rewrite <- cos_sin_pisurdeux_moins_x.
ring.
ring.
rewrite <- sin_cos_pisurdeux_moins_x; auto.
Qed.

Lemma sin_diff :
 forall a b : R, sin (a + - b) = sin a * cos b + - (sin b * cos a).
intros.
rewrite sin_som.
rewrite cos_paire.
rewrite sin_impaire.
ring.
Qed.

Lemma duplication_cos : forall a : R, cos (2 * a) = 2 * Rsqr (cos a) + -1.
intros.
repeat rewrite double.
rewrite cos_som.
rewrite <- (trigo_Pythagore a).
unfold Rsqr; ring.
Qed.

Lemma duplication_cos2 : forall a : R, cos (2 * a) = 1 + - (2 * Rsqr (sin a)).
intros.
repeat rewrite double.
rewrite cos_som.
rewrite <- (trigo_Pythagore a).
unfold Rsqr; ring.
Qed.

Lemma duplication_sin : forall a : R, sin (2 * a) = 2 * (sin a * cos a).
intros.
repeat rewrite double.
rewrite sin_som; auto.
Qed.

Lemma coordonnees_polaires_cartesiennes :
 forall (x y a r : R) (O I J M : PO),
 repere_orthonormal_direct O I J ->
 O <> M ->
 r = distance O M ->
 image_angle a = cons_AV (vec O I) (vec O M) ->
 vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)) :>PP ->
 x = r * cos a /\ y = r * sin a.
intros.
apply unicite_coordonnees with (2 := H3); auto with geo.
elim existence_representant_unitaire with (A := O) (B := M);
 [ intros C H4; try clear existence_unitaire; try exact H4 | auto ].
rewrite (distance_vecteur (A:=O) (B:=M)); auto.
rewrite <- H4.
rewrite (coordonnees_cos_sin (x:=a) (O:=O) (I:=I) (J:=J) (M:=C)); auto.
rewrite <- H1.
unfold vec in |- *; RingPP.
rewrite H2.
rewrite H4.
inversion H.
elim H6; intros H7 H8; try clear H6; try exact H7.
rewrite angles_representants_unitaires; auto with geo.
replace (representant_unitaire (vec O I)) with (vec O I); auto with geo.
elim def_representant_unitaire2 with (A := O) (B := M) (C := C);
 [ intros; elim H6; intros H7 H8; try clear H6 def_representant_unitaire2;
    auto with geo
 | auto
 | auto ].
Qed.

Lemma trivial_cos_Cos :
 forall (A B C : PO) (x : R),
 distance A B = 1 ->
 distance A C = 1 ->
 image_angle x = cons_AV (vec A B) (vec A C) ->
 cos x = Cos (cons_AV (vec A B) (vec A C)).
intros.
rewrite (def_cos (A:=A) (B:=B) (C:=C) (x:=x)); auto.
rewrite (def_Cos (A:=A) (B:=B) (C:=C)); auto.
Qed.

Lemma egalite_cos_Cos :
 forall (A B C : PO) (x : R),
 A <> B ->
 A <> C ->
 image_angle x = cons_AV (vec A B) (vec A C) ->
 cos x = Cos (cons_AV (vec A B) (vec A C)).
intros.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H2; try clear existence_representant_unitaire; try exact H2
 | auto ].
elim existence_representant_unitaire with (A := A) (B := C);
 [ intros C' H3; try clear existence_representant_unitaire; try exact H3
 | auto ].
rewrite (trivial_cos_Cos (A:=A) (B:=B') (C:=C') (x:=x)); auto.
rewrite H2; rewrite H3; auto.
rewrite angles_representants_unitaires; auto.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B'); auto;
 intros.
elim H5; auto with geo.
elim def_representant_unitaire2 with (A := A) (B := C) (C := C'); auto;
 intros.
elim H5; auto with geo.
rewrite H2; rewrite H3; rewrite H1; rewrite angles_representants_unitaires;
 auto with geo.
Qed.

Lemma trivial_sin_Sin :
 forall (A B C D : PO) (x : R),
 distance A B = 1 ->
 distance A C = 1 ->
 image_angle x = cons_AV (vec A B) (vec A C) ->
 repere_orthonormal_direct A B D -> sin x = Sin (cons_AV (vec A B) (vec A C)).
intros.
rewrite (def_sin (A:=A) (B:=B) (C:=C) (D:=D) (x:=x)); auto.
rewrite (def_Sin (A:=A) (B:=B) (C:=C) (D:=D)); auto.
Qed.

Lemma egalite_sin_Sin :
 forall (A B C : PO) (x : R),
 A <> B ->
 A <> C ->
 image_angle x = cons_AV (vec A B) (vec A C) ->
 sin x = Sin (cons_AV (vec A B) (vec A C)).
intros.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros B' H2; try clear existence_representant_unitaire; try exact H2
 | auto ].
elim existence_ROND_AB with (A := A) (B := B'); [ intros D H10 | auto ].
elim existence_representant_unitaire with (A := A) (B := C);
 [ intros C' H3; try clear existence_representant_unitaire; try exact H3
 | auto ].
rewrite (trivial_sin_Sin (A:=A) (B:=B') (C:=C') (D:=D) (x:=x)); auto.
rewrite H2; rewrite H3; auto.
rewrite angles_representants_unitaires; auto.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B'); auto;
 intros.
elim H5; auto with geo.
elim def_representant_unitaire2 with (A := A) (B := C) (C := C'); auto;
 intros.
elim H5; auto with geo.
rewrite H2; rewrite H3; rewrite H1; rewrite angles_representants_unitaires;
 auto.
elim def_representant_unitaire2 with (A := A) (B := B) (C := B');
 auto with geo; intros.
elim H4; auto with geo.
Qed.

Lemma coordonnees_Cos_Sin :
 forall O I J M : PO,
 repere_orthonormal_direct O I J ->
 distance O M = 1 ->
 vec O M =
 add_PP (mult_PP (Cos (cons_AV (vec O I) (vec O M))) (vec O I))
   (mult_PP (Sin (cons_AV (vec O I) (vec O M))) (vec O J)) :>PP.
intros.
elim H; intros.
elim H2; intros H4 H5; try clear H2.
mesure O I O M.
rewrite H2.
rewrite <- (trivial_sin_Sin (A:=O) (B:=I) (C:=M) (D:=J) (x:=x));
 auto with geo.
rewrite <- (trivial_cos_Cos (A:=O) (B:=I) (C:=M) (x:=x)); auto with geo.
apply coordonnees_cos_sin; auto.
Qed.

Lemma calcul_Cos_Sin :
 forall (a b : R) (O I J M : PO),
 repere_orthonormal_direct O I J ->
 distance O M = 1 ->
 vec O M = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J)) :>PP ->
 a = Cos (cons_AV (vec O I) (vec O M)) /\
 b = Sin (cons_AV (vec O I) (vec O M)).
intros.
elim H; intros.
elim H3; intros H4 H5; try clear H3.
mesure O I O M.
rewrite H3.
rewrite <- (trivial_sin_Sin (A:=O) (B:=I) (C:=M) (D:=J) (x:=x));
 auto with geo.
rewrite <- (trivial_cos_Cos (A:=O) (B:=I) (C:=M) (x:=x)); auto with geo.
apply (calcul_cos_sin (x:=x) (a:=a) (b:=b) (O:=O) (I:=I) (J:=J) (M:=M)); auto.
Qed.

Axiom
  egalite_angle_trigo :
    forall x y : R,
    sin x = sin y -> cos x = cos y -> image_angle x = image_angle y.
Hint Resolve egalite_angle_trigo: geo.


(** * LogRel.AutoSubst.Extra: extra content to better handle the boilerplate generated by AutoSubst. *)

(** This is the only file in the AutoSubst submodule that is not automatically generated. *)
From smpl Require Import Smpl.
From LogRel.AutoSubst Require Import core unscoped Ast.
From LogRel Require Import Utils BasicAst.

(* Export UnscopedNotations.
#[global] Open Scope subst_scope. *)

Declare Scope asubst_scope.
Delimit Scope asubst_scope with asub.

Arguments funcomp {X Y Z}%type_scope (g f)%function_scope.

Notation "f >> g" := (funcomp g f) (at level 50) : function_scope.

Notation "s .: sigma" := (scons s sigma) (at level 55, sigma at next level, right associativity) : asubst_scope.

Notation "s ⟨ xi1 ⟩" := (ren1 xi1 s) (at level 7, left associativity, format "s ⟨ xi1 ⟩") : asubst_scope.
(* Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : function_scope. *)

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : asubst_scope.

Notation "s [ t ]⇑" := (subst_term (scons t (shift >> tRel)) s) (at level 7, left associativity, format "s '/' [ t ]⇑") : asubst_scope.

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : asubst_scope.

Notation "↑" := (shift) : asubst_scope.

#[global] Open Scope asubst_scope.

Notation U := (tSort set).
Notation "'eta_expand' f" := (tApp f⟨↑⟩ (tRel 0)) (at level 40, only parsing).

#[global] Instance Ren1_subst {Y Z : Type} `{Ren1 (nat -> nat) Y Z} :
  (Ren1 (nat -> nat) (nat -> Y) (nat -> Z)) :=
  fun ρ σ i => (σ i)⟨ρ⟩.

Ltac fold_autosubst :=
    fold ren_term ;
    fold subst_term.

Smpl Add fold_autosubst : refold.

Ltac change_autosubst :=
    change ren_term with (@ren1 _ _ _ Ren_term) in * ;
    change subst_term with (@subst1 _ _ _ Subst_term) in *;
    change (fun i => (?σ i)⟨?ρ⟩) with (@ren1 _ _ _ Ren1_subst ρ σ) in *.

Smpl Add 50 change_autosubst : refold.

Arguments ren1 {_ _ _}%type_scope {Ren1} _ !_/.
(* Ideally, we'd like Ren_term to not be there, and ren_term to be directly the Ren1 instance… *)
Arguments Ren_term _ _ /.
Arguments Ren1_subst {_ _ _} _ _/.

Notation arr A B := (tProd A B⟨↑⟩).
Notation comp A f g := (tLambda A (tApp f⟨↑⟩ (tApp g⟨↑⟩ (tRel 0)))).
Notation idterm A  := (tLambda A (tRel 0)).

Lemma arr_ren1 {A B} : forall ρ, (arr A B)⟨ρ⟩ = arr A⟨ρ⟩ B⟨ρ⟩.
Proof.
  now asimpl.
Qed.

Definition elimSuccHypTy P :=
  tProd tNat (arr P P[tSucc (tRel 0)]⇑).


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import ZArith.
Require Import Coq.Arith.Max.
Require Import List.
Set Implicit Arguments.

(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v)
   -- this is harmless and spares a lot of Empty.
   This means smaller proof-terms.
   BTW, by dropping the  polymorphism, I get small (yet noticeable) speed-up.
*)

Section MakeVarMap.
  Variable A : Type.
  Variable default : A.

  Inductive t  : Type :=
  | Empty : t
  | Leaf : A -> t
  | Node : t  -> A -> t  -> t .

  Fixpoint find   (vm : t ) (p:positive) {struct vm} : A :=
    match vm with
      | Empty => default
      | Leaf i => i
      | Node l e r => match p with
                        | xH => e
                        | xO p => find l p
                        | xI p => find r p
                      end
    end.

 (* an off_map (a map with offset) offers the same functionalites  as /plugins/setoid_ring/BinList.v - it is used in EnvRing.v *)
(*
  Definition off_map  :=  (option positive *t )%type.

  Definition jump  (j:positive) (l:off_map ) :=
    let (o,m) := l in
      match o with
        | None => (Some j,m)
        | Some j0 => (Some (j+j0)%positive,m)
      end.

  Definition nth  (n:positive) (l: off_map ) :=
    let (o,m) := l in
      let idx  := match o with
                    | None => n
                    | Some i => i + n
                  end%positive in
      find  idx m.

  Definition hd  (l:off_map) := nth  xH l.

  Definition tail (l:off_map ) := jump xH l.

  Lemma psucc : forall p,  (match p with
                              | xI y' => xO (Psucc y')
                              | xO y' => xI y'
                              | 1%positive => 2%positive
                            end) = (p+1)%positive.
  Proof.
    destruct p.
    auto with zarith.
    rewrite xI_succ_xO.
    auto with zarith.
    reflexivity.
  Qed.

  Lemma jump_Pplus : forall i j l,
    (jump (i + j) l) = (jump i (jump j l)).
  Proof.
    unfold jump.
    destruct l.
    destruct o.
    rewrite Pplus_assoc.
    reflexivity.
    reflexivity.
  Qed.

  Lemma jump_simpl : forall p l,
    jump p l =
    match p with
      | xH => tail l
      | xO p => jump p (jump p l)
      | xI p  => jump p (jump p (tail l))
    end.
  Proof.
    destruct p ; unfold tail ; intros ;  repeat rewrite <- jump_Pplus.
    (* xI p = p + p + 1 *)
    rewrite xI_succ_xO.
    rewrite Pplus_diag.
    rewrite <- Pplus_one_succ_r.
    reflexivity.
    (* xO p = p + p *)
    rewrite Pplus_diag.
    reflexivity.
    reflexivity.
  Qed.

  Ltac jump_s :=
    repeat
      match goal with
        | |- context [jump xH ?e] => rewrite (jump_simpl xH)
        | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
        | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
      end.

  Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
  Proof.
    unfold tail.
    intros.
    repeat rewrite <- jump_Pplus.
    rewrite Pplus_comm.
    reflexivity.
  Qed.

  Lemma jump_Psucc : forall j l,
    (jump (Psucc j) l) = (jump 1 (jump j l)).
  Proof.
    intros.
    rewrite <- jump_Pplus.
    rewrite Pplus_one_succ_r.
    rewrite Pplus_comm.
    reflexivity.
  Qed.

  Lemma jump_Pdouble_minus_one : forall i l,
    (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
  Proof.
    unfold tail.
    intros.
    repeat rewrite <- jump_Pplus.
    rewrite <- Pplus_one_succ_r.
    rewrite Psucc_o_double_minus_one_eq_xO.
    rewrite Pplus_diag.
    reflexivity.
  Qed.

  Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l.
  Proof.
    intros.
    jump_s.
    repeat rewrite <- jump_Pplus.
    reflexivity.
  Qed.

  Lemma nth_spec : forall p l,
    nth p l =
    match p with
      | xH => hd  l
      | xO p => nth p (jump p l)
      | xI p => nth p (jump p (tail l))
    end.
  Proof.
    unfold nth.
    destruct l.
    destruct o.
    simpl.
    rewrite psucc.
    destruct p.
    replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive.
    reflexivity.
    rewrite xI_succ_xO.
    rewrite Pplus_one_succ_r.
    rewrite <- Pplus_diag.
    rewrite Pplus_comm.
    symmetry.
    rewrite (Pplus_comm p0).
    rewrite <- Pplus_assoc.
    rewrite (Pplus_comm 1)%positive.
    rewrite <- Pplus_assoc.
    reflexivity.
  (**)
    replace ((p0 + xO p))%positive with (p + p0 + p)%positive.
    reflexivity.
    rewrite <- Pplus_diag.
    rewrite <- Pplus_assoc.
    rewrite Pplus_comm.
    rewrite Pplus_assoc.
    reflexivity.
    reflexivity.
    simpl.
    destruct p.
    rewrite xI_succ_xO.
    rewrite Pplus_one_succ_r.
    rewrite <- Pplus_diag.
    symmetry.
    rewrite Pplus_comm.
    rewrite Pplus_assoc.
    reflexivity.
    rewrite Pplus_diag.
    reflexivity.
    reflexivity.
  Qed.

  Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l).
  Proof.
    destruct l.
    unfold tail.
    unfold hd.
    unfold jump.
    unfold nth.
    destruct o.
    symmetry.
    rewrite Pplus_comm.
    rewrite <- Pplus_assoc.
    rewrite (Pplus_comm p0).
    reflexivity.
    rewrite Pplus_comm.
    reflexivity.
  Qed.

  Lemma nth_Pdouble_minus_one :
    forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
  Proof.
    destruct l.
    unfold tail.
    unfold nth, jump.
    destruct o.
    rewrite ((Pplus_comm p)).
    rewrite <- (Pplus_assoc p0).
    rewrite Pplus_diag.
    rewrite <- Psucc_o_double_minus_one_eq_xO.
    rewrite Pplus_one_succ_r.
    rewrite (Pplus_comm (Pdouble_minus_one p)).
    rewrite Pplus_assoc.
    rewrite (Pplus_comm p0).
    reflexivity.
    rewrite <- Pplus_one_succ_l.
    rewrite Psucc_o_double_minus_one_eq_xO.
    rewrite Pplus_diag.
    reflexivity.
  Qed.

*)

End MakeVarMap.


(* Wish #2154 by E. van der Weegen *)

(* auto was not using f_equal-style lemmas with metavariables occuring
   only in the type of an evar of the concl, but not directly in the
   concl itself *)

Parameters
  (F: Prop -> Prop)
  (G: forall T, (T -> Prop) -> Type)
  (L: forall A (P: A -> Prop), G A P -> forall x, F (P x))
  (Q: unit -> Prop).

Hint Resolve L.

Goal G unit Q -> F (Q tt).
  intro.
  auto.
Qed.

(* Test implicit arguments in "using" clause *)

Goal forall n:nat, nat * nat.
auto using (pair O).
Undo.
eauto using (pair O).
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.

From Freak Require Import Language.
From Freak Require Import Maps.
From Freak Require Import Semantics.
From Freak Require Import Opt.

Module Tests.

Definition rnat x := <{ return x }>.
Definition rtrue := <{ return true }>.
Definition x : string := "x".
Definition y : string := "y".
Definition s : string := "s".
Definition s' : string := "s'".
Definition f : string := "f".
Definition p : string := "p".
Definition k : string := "k".
Definition k' : string := "k'".
Definition Const : string := "Const".
Definition Put : string := "Put".
Definition coalgPutGet : string := "_coalg_Put_Get".
Definition Get : string := "Get".
Hint Unfold rnat : core.

(* Test lambda calculus *)

Example eval_nat: rnat 42 -->* rnat 42.
Proof. normalize. Qed.

Example eval_app:
  <{ (\s -> return s) 42 }> -->* rnat 42.
Proof. normalize. Qed.

Example eval_let_lambda_forget :
  <{ let f <- return (\s -> return s) in return 42 }> -->*
  rnat 42.
Proof. normalize. Qed.

Example eval_let_lambda :
  <{ let f <- return (\s -> return s) in (f 42) }> -->*
  rnat 42.
Proof. normalize. Qed.

Example if_true :
  <{ if true then return 1 else return 2 }> -->* rnat 1.
Proof. normalize. Qed.

Example if_false :
  <{ if false then return 1 else return 2 }> -->* rnat 2.
Proof. normalize. Qed.

Example var_capture :
  <{
    let x <- return 1 in
    let x <- return 2 in
    return x
  }> -->* rnat 2.
Proof. normalize. Qed.

Example static_scope :
  <{
    let y <- return 1 in
    let f <- return (\x -> return y) in
    let y <- return 2 in f 3
  }> -->* rnat 1.
Proof. normalize. Qed.

(* Test handlers *)

Example trivial_handler :
  <{ handle return 1 with ( |r #return x -> return x ) }>
  -->* rnat 1.
Proof. normalize. Qed.

Example handler_return_overrite :
  <{ handle return 1 with ( |r #return x -> return 2 ) }>
  -->* rnat 2.
Proof. normalize. Qed.

Example const_handler :
  <{ handle
        (do y <- Const @ 1 in return y)
    with (
        |o # Const , p , k |-> k 42 ;
        |r #return x -> return x ) }>
  -->* rnat 42.
Proof.
    eapply multi_step.
    - eapply step_handle_op. simpl. auto. auto.
    - normalize.
Qed.

Definition state_handler : handler := <{
    |o # Put , s' , k |-> return (\s ->
         let k' <- k true in k' s'
    );
    |o # Get , s' , k |-> return (\s ->
         let k' <- k s in k' s
    );
    |r #return x -> return (\s -> return x)
  }>.

Example state_handler_get_initial :
  <{ let f <- handle
        do x <- Get @ true in
        return x
    with state_handler
    in f 1
  }>
  -->* rnat 1.
Proof.
    unfold state_handler.
    eapply multi_step.
    - apply step_let. eapply step_handle_op. simpl. auto. auto.
    - normalize.
Qed.

Example state_handler_put :
  <{ let f <- handle
        do y <- Put @ 2 in return y
    with state_handler
    in f 1
  }>
  -->* rtrue.
Proof.
    unfold state_handler.
    eapply multi_step.
    - apply step_let. eapply step_handle_op. simpl. auto. auto.
    - simpl. normalize.
Qed.

Example state_handler_put_get :
  <{ let f <- handle
        do y <- Put @ 2 in
        do x <- Get @ true in
        return x
    with state_handler
    in f 1
  }>
  -->* rnat 2.
Proof.
    unfold state_handler.
    eapply multi_step.
    - apply step_let.  eapply step_handle_op. simpl. auto. auto.
    - simpl.
      eapply multi_step. auto. simpl.
      eapply multi_step. auto. simpl.
      eapply multi_step. auto. simpl.
      eapply multi_step.
      apply step_let. apply step_handle_op. simpl. auto. auto.
      simpl. normalize.
Qed.

(* Test Opt *)

Example opt_st_example :
  opt_st <{
    let f <- handle
        do y <- Put @ 2 in
        do x <- Get @ true in
        return x
      with state_handler
    in f 1
  }> = <{
    let f <- handle
        return (\s ->
          let coalgPutGet <- return s in
          let coalgPutGet <- return 2 in
          let y <- return true in
          let x <- return coalgPutGet in
          return x
        )
      with identity_handler
    in f 1
  }>.
Proof. auto. Qed.

End Tests.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, Collège de France and Inria Paris            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  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 file is also distributed under the terms of the               *)
(*  INRIA Non-Commercial License Agreement.                            *)
(*                                                                     *)
(* *********************************************************************)

(** Platform-specific built-in functions *)

Require Import String Coqlib.
Require Import AST Integers Floats Values.
Require Import Builtins0.

Inductive platform_builtin : Type :=
  | BI_fmin
  | BI_fmax.

Local Open Scope string_scope.

Definition platform_builtin_table : list (string * platform_builtin) :=
     ("__builtin_fmin", BI_fmin)
  :: ("__builtin_fmax", BI_fmax)
  :: nil.

Definition platform_builtin_sig (b: platform_builtin) : signature :=
  match b with
  | BI_fmin | BI_fmax =>
      mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default
  end.

Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
  match b with
  | BI_fmin =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Eq | Some Lt => f1
                      | Some Gt | None => f2
                      end)
  | BI_fmax =>
      mkbuiltin_n2t Tfloat Tfloat Tfloat
        (fun f1 f2 => match Float.compare f1 f2 with
                      | Some Eq | Some Gt => f1
                      | Some Lt | None => f2
                      end)
  end.


(* TLC in Coq
 *
 * Module: tlc.component.perfect_link_3
 * Purpose: Contains the local specification of the perfect link PL_3 property.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrnat.
Require Import tlc.component.component.
Require Import tlc.component.perfect_link.
Require Import tlc.logic.all_logic.
Require Import tlc.semantics.all_semantics.
Require Import tlc.syntax.all_syntax.
Require Import tlc.utility.all_utility.

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

(* No forge
 * If a node n delivers a message m with sender n', then m was previously sent
 * to n by node n'.
 *)
Theorem PL_3 Delta : Context Delta [::] ||- perfect_link, {-A
  forall: forall: forall: (* n, n', m *)
  $$2 \in UCorrect /\ $$1 \in UCorrect ->
  on $$2, event[]<- CPLDeliver ' $$1 ' $$0 <~
  on $$1, event[]-> CPLSend ' $$2 ' $$0
 -}.
Proof.
  dforall n; dforall n'; dforall m; dif; dsplitp.

  (* By OI' *)
  dhave {-A
    on n, event[]<- CPLDeliver ' n' ' m <~
    on n, CPLDeliver ' n' ' m \in Fois /\ self-event
  -}.
  {
    duse DPOI'; dforallp n; dforallp {-t CPLDeliver ' n' ' m -}.
    eapply DSCut; first (by repeat dclear; apply DTL123 with
      (A := {-A self-event /\ on n, CPLDeliver ' n' ' m \in Fois -}));
      dtsubstposp.
    eapply DSCut; first (by repeat dclear; apply DTAndComm with
      (A1 := {-A self-event -})
      (A2 := {-A on n, CPLDeliver ' n' ' m \in Fois -}));
      dtsubstp_l.
    by eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n -})
      (A2 := {-A CPLDeliver ' n' ' m \in Fois -})
      (A3 := {-A self-event -}));
      dtsubstp_l.
  }

  (* By InvL *)
  dhave {-A
    on n, CPLDeliver ' n' ' m \in Fois /\ self-event =>>
    exists: (* c *) on n, event[0]<- CSLDeliver ' n' ' ($$0, m)
  -}.
  {
    repeat dclear.
    eapply DSCut; first by apply DPInvL with
      (A := {-A
        on n, CPLDeliver ' n' ' m \in Fois ->
        exists: (* c *) on n, event[0]<- CSLDeliver ' n' ' ($$0, m)
      -});
      [by dautoclosed | by repeat constructor].

    (* request *)
    difp.
    {
      dforall e; dif; dsplitp; dswap; dsimplp.
      dcase {-t ? e -}; dexistsp e_m; dexistsp e_n'; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dtinjectionp; repeat dsplitp; do 2 dclear.

      dif; dsplitp; dclear; dswap.
      by dtgenp; dtsubstep_l; dpmembernilp.
    }

    (* indication *)
    difp.
    {
      dforall i; dforall e; dif; dsplitp; dswap; dsimplp.
      dcase {-t (? i, ? e) -}; dexistsp e_m; dexistsp e_c; dexistsp e_n.
      dtinjectionp; dsplitp; do 2 (dtgenp; dswap).
      dxchg 1 2; dtsubstep_l; dsimplp.
      dswap; dxchg 1 3; dtsubstep_l; dautoeq; dswap; dclear.
      dswap; dtsubstep_l.
      dswap; dxchg 1 2; dtsubstep_l; dsimplp; dswap; dclear.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t FCount ' (? e_n, ? e_c) ' ? s_r == 0 -}; dorp; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp;
        dtinjectionp; repeat dsplitp;
        do 2 dclear; dtgenp;
        dif; dsplitp.
      - dexists e_c; dsplit; first (by dassumption); dclear.
        dswap; dtsubstep_l; dswap; dclear.
        by dpmembersingletonp; dtinjectionp; repeat (dsplitp; dswap);
        repeat (dtgenp; dtsubste_l; dautoeq; dclear).
      - by dclear; dswap; dtsubstep_l; dpmembernilp.
    }

    (* periodic *)
    difp.
    {
      dif; dsplitp; dswap; dsimplp.
      dtinjectionp; repeat dsplitp; do 2 dclear.
      dif; dsplitp; dclear.
      by dswap; dtgenp; dtsubstep_l; dpmembernilp.
    }

    dtmergeentailsifp.
    eapply DSCut; first (by repeat dclear; apply DTAndComm with
      (A1 := {-A self-event -})
      (A2 := {-A on n, CPLDeliver ' n' ' m \in Fois -}));
      dtsubstp_l.
    by eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n -})
      (A2 := {-A CPLDeliver ' n' ' m \in Fois -})
      (A3 := {-A self-event -}));
      dtsubstp_l.
  }

  (* By lemma 99 on (1) and (2) *)
  (* NOTE: Rewriting is easier. *)
  dtsubstposp.

  (* By rule OR' *)
  dhave {-A
    forall: (* c *)
    on n', event[0]-> CSLSend ' n ' ($$0, m) <~
    on n', (0, CSLSend ' n ' ($$0, m)) \in Fors /\ self-event
  -}.
  {
    dforall c.
    duse DPOR'; dforallp n'; dforallp {-t 0 -}; dforallp {-t CSLSend ' n ' (c, m) -}.
    eapply DSCut; first (by repeat dclear; apply DTL123 with
      (A := {-A self-event /\ on n', (0, CSLSend ' n ' (c, m)) \in Fors -}));
      dtsubstposp.
    eapply DSCut; first (by repeat dclear; apply DTAndComm with
      (A1 := {-A self-event -})
      (A2 := {-A on n', (0, CSLSend ' n ' (c, m)) \in Fors -}));
      dtsubstp_l.
    by eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n' -})
      (A2 := {-A (0, CSLSend ' n ' (c, m)) \in Fors -})
      (A3 := {-A self-event -}));
      dtsubstp_l.
  }

  (* By rule InvL *)
  dhave {-A
    forall: (* c *)
    on n', (0, CSLSend ' n ' ($$0, m)) \in Fors /\ self-event =>>
    on n', event[]-> CPLSend ' n ' m
  -}.
  {
    repeat dclear.
    dforall c.
    eapply DSCut; first by apply DPInvL with
      (A := {-A
        on n', (0, CSLSend ' n ' (c, m)) \in Fors ->
        on n', event[]-> CPLSend ' n ' m
      -});
      [by dautoclosed | by repeat constructor].

    (* request *)
    difp.
    {
      dforall e; dif; dsplitp; dswap; dsimplp.
      dcase {-t ? e -}; dexistsp e_m; dexistsp e_n'; dtgenp;
        dtsubstep_l; dsimplp;
        dswap; dxchg 1 2; dtsubstep_l; dswap; dclear; dswap.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dtinjectionp; repeat dsplitp; dclear; dswap; dclear.

      dif; dsplitp; dsplit; first (by dassumption); dclear.
      dswap; dtgenp; dtsubstep_l; dswap; dclear.
      by dpmembersingletonp; dtinjectionp; repeat (dsplitp; dswap);
      do 2 (dtgenp; dtsubste_l; dautoeq; dclear; dclear).
    }

    (* indication *)
    difp.
    {
      dforall i; dforall e; dif; dsplitp; dswap; dsimplp.
      dcase {-t (? i, ? e) -}; dexistsp e_m; dexistsp e_c; dexistsp e_n; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t ? Fs ' ? Fn -}; dexistsp s_r; dexistsp s_c; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp.
      dcase {-t FCount ' (? e_n, ? e_c) ' ? s_r == 0 -}; dorp; dtgenp;
        dtsubstep_l; dswap; dclear; dsimplp;
        dtinjectionp; repeat dsplitp;
        dclear; dswap; dclear; dtgenp; dtsubste_l; dclear;
        dif; dsplitp; dclear;
        by dpmembernilp.
    }

    (* periodic *)
    difp.
    {
      dif; dsplitp; dswap; dsimplp.
      dtinjectionp; repeat dsplitp; dclear; dswap; dclear.
      dif; dsplitp; dclear.
      by dswap; dtgenp; dtsubstep_l; dpmembernilp.
    }

    dtmergeentailsifp.
    eapply DSCut; first (by repeat dclear; apply DTAndComm with
      (A1 := {-A self-event -})
      (A2 := {-A on n', (0, CSLSend ' n ' (c, m)) \in Fors -}));
      dtsubstp_l.
    by eapply DSCut; first (by repeat dclear; apply DTAndAssoc with
      (A1 := {-A Fn = n' -})
      (A2 := {-A (0, CSLSend ' n ' (c, m)) \in Fors -})
      (A3 := {-A self-event -}));
      dtsubstp_l.
  }

  (* By lemma 99 on (1) and (2) *)
  (* NOTE: Rewriting is easier. *)
  dtsubstposp.

  (* By lemma 88 on (3), SL_2', and (6) *)
  duse PL_SL_2.
  dxchg 1 2; dtsubstposp.
  dswap; dtsubstposp.
  eapply DSCut; first (by repeat dclear; apply DTL83_1 with
    (A := {-A on n', event[]-> CPLSend ' n ' m -}));
    dtsubstp_r.
  eapply DSCut; first (by repeat dclear; apply DTL127_3 with
    (A := {-A on n', event[]-> CPLSend ' n ' m -}));
    dtsubstp_r.
  eapply DSCut; first (by repeat dclear; apply DTL83_1 with
    (A := {-A exists: on n', event[]-> CPLSend ' n ' m -}));
    dtsubstp_r.
  by eapply DSCut; first (by repeat dclear; apply DTExistsConstant with
    (A := {-A on n', event[]-> CPLSend ' n ' m -}); first by dautoclosed);
    dtsubstp_r.
Qed.