(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Characterization and properties of deterministic semantics *)

Require Import Classical.
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Behaviors.

(** This file uses classical logic (the axiom of excluded middle), as
  well as the following extensionality property over infinite
  sequences of events.  All these axioms are sound in a set-theoretic
  model of Coq's logic. *)

Axiom traceinf_extensionality:
  forall T T', traceinf_sim T T' -> T = T'.

(** * Deterministic worlds *)

(** One source of possible nondeterminism is that our semantics leave
  unspecified the results of system calls.
  Different results to e.g. a "read" operation can of
  course lead to different behaviors for the program.
  We address this issue by modeling a notion of deterministic
  external world that uniquely determines the results of external calls. *)

(** An external world is a function that, given the name of an
  external call and its arguments, returns either [None], meaning
  that this external call gets stuck, or [Some(r,w)], meaning
  that this external call succeeds, has result [r], and changes
  the world to [w]. *)

Inductive world: Type :=
  World (io: ident -> list eventval -> option (eventval * world))
        (vload: memory_chunk -> ident -> int -> option (eventval * world))
        (vstore: memory_chunk -> ident -> int -> eventval -> option world).

Definition nextworld_io (w: world) (evname: ident) (evargs: list eventval) :
                     option (eventval * world) :=
  match w with World io vl vs => io evname evargs end.

Definition nextworld_vload (w: world) (chunk: memory_chunk) (id: ident) (ofs: int) :
                     option (eventval * world) :=
  match w with World io vl vs => vl chunk id ofs end.

Definition nextworld_vstore (w: world) (chunk: memory_chunk) (id: ident) (ofs: int) (v: eventval):
                     option world :=
  match w with World io vl vs => vs chunk id ofs v end.

(** A trace is possible in a given world if all events correspond
  to non-stuck external calls according to the given world.
  Two predicates are defined, for finite and infinite traces respectively:
- [possible_trace w t w'], where [w] is the initial state of the
  world, [t] the finite trace of interest, and [w'] the state of the
  world after performing trace [t].
- [possible_traceinf w T], where [w] is the initial state of the
  world and [T] the infinite trace of interest.
*)

Inductive possible_event: world -> event -> world -> Prop :=
  | possible_event_syscall: forall w1 evname evargs evres w2,
      nextworld_io w1 evname evargs = Some (evres, w2) ->
      possible_event w1 (Event_syscall evname evargs evres) w2
  | possible_event_vload: forall w1 chunk id ofs evres w2,
      nextworld_vload w1 chunk id ofs = Some (evres, w2) ->
      possible_event w1 (Event_vload chunk id ofs evres) w2
  | possible_event_vstore: forall w1 chunk id ofs evarg w2,
      nextworld_vstore w1 chunk id ofs evarg = Some w2 ->
      possible_event w1 (Event_vstore chunk id ofs evarg) w2
  | possible_event_annot: forall w1 id args,
      possible_event w1 (Event_annot id args) w1.

Inductive possible_trace: world -> trace -> world -> Prop :=
  | possible_trace_nil: forall w,
      possible_trace w E0 w
  | possible_trace_cons: forall w1 ev w2 t w3,
      possible_event w1 ev w2 -> possible_trace w2 t w3 ->
      possible_trace w1 (ev :: t) w3.

Lemma possible_trace_app:
  forall t2 w2 w0 t1 w1,
  possible_trace w0 t1 w1 -> possible_trace w1 t2 w2 ->
  possible_trace w0 (t1 ** t2) w2.
Proof.
  induction 1; simpl; intros.
  auto.
  econstructor; eauto.
Qed.

Lemma possible_trace_app_inv:
  forall t2 w2 t1 w0,
  possible_trace w0 (t1 ** t2) w2 ->
  exists w1, possible_trace w0 t1 w1 /\ possible_trace w1 t2 w2.
Proof.
  induction t1; simpl; intros.
  exists w0; split. constructor. auto.
  inv H. exploit IHt1; eauto. intros [w1 [A B]].
  exists w1; split. econstructor; eauto. auto.
Qed.

Lemma match_possible_traces:
  forall (F V: Type) (ge: Genv.t F V) t1 t2 w0 w1 w2,
  match_traces ge t1 t2 -> possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 ->
  t1 = t2 /\ w1 = w2.
Proof.
  intros. inv H; inv H1; inv H0.
  auto.
  inv H7; inv H6. inv H9; inv H10. split; congruence.
  inv H7; inv H6. inv H9; inv H10. split; congruence.
  inv H4; inv H3. inv H6; inv H7. split; congruence.
  inv H4; inv H3. inv H7; inv H6. auto.
Qed.

CoInductive possible_traceinf: world -> traceinf -> Prop :=
  | possible_traceinf_cons: forall w1 ev w2 T,
      possible_event w1 ev w2 ->
      possible_traceinf w2 T ->
      possible_traceinf w1 (Econsinf ev T).

Lemma possible_traceinf_app:
  forall t2 w0 t1 w1,
  possible_trace w0 t1 w1 -> possible_traceinf w1 t2 ->
  possible_traceinf w0 (t1 *** t2).
Proof.
  induction 1; simpl; intros.
  auto.
  econstructor; eauto.
Qed.

Lemma possible_traceinf_app_inv:
  forall t2 t1 w0,
  possible_traceinf w0 (t1 *** t2) ->
  exists w1, possible_trace w0 t1 w1 /\ possible_traceinf w1 t2.
Proof.
  induction t1; simpl; intros.
  exists w0; split. constructor. auto.
  inv H. exploit IHt1; eauto. intros [w1 [A B]].
  exists w1; split. econstructor; eauto. auto.
Qed.

Ltac possibleTraceInv :=
  match goal with
  | [H: possible_trace _ E0 _ |- _] =>
      inversion H; clear H; subst; possibleTraceInv
  | [H: possible_trace _ (_ ** _) _ |- _] =>
      let P1 := fresh "P" in
      let w := fresh "w" in
      let P2 := fresh "P" in
      elim (possible_trace_app_inv _ _ _ _ H); clear H;
      intros w [P1 P2];
      possibleTraceInv
  | [H: possible_traceinf _ (_ *** _) |- _] =>
      let P1 := fresh "P" in
      let w := fresh "w" in
      let P2 := fresh "P" in
      elim (possible_traceinf_app_inv _ _ _ H); clear H;
      intros w [P1 P2];
      possibleTraceInv
  | [H: exists w, possible_trace _ _ w |- _] =>
      let P := fresh "P" in let w := fresh "w" in
      destruct H as [w P]; possibleTraceInv
  | _ => idtac
  end.

Definition possible_behavior (w: world) (b: program_behavior) : Prop :=
  match b with
  | Terminates t r => exists w', possible_trace w t w'
  | Diverges t => exists w', possible_trace w t w'
  | Reacts T => possible_traceinf w T
  | Goes_wrong t => exists w', possible_trace w t w'
  end.

CoInductive possible_traceinf': world -> traceinf -> Prop :=
  | possible_traceinf'_app: forall w1 t w2 T,
      possible_trace w1 t w2 -> t <> E0 ->
      possible_traceinf' w2 T ->
      possible_traceinf' w1 (t *** T).

Lemma possible_traceinf'_traceinf:
  forall w T, possible_traceinf' w T -> possible_traceinf w T.
Proof.
  cofix COINDHYP; intros. inv H. inv H0. congruence.
  simpl. econstructor. eauto. apply COINDHYP.
  inv H3. simpl. auto. econstructor; eauto. econstructor; eauto. unfold E0; congruence.
Qed.

(** * Definition and properties of deterministic semantics *)

Record sem_deterministic (L: semantics) := mk_deterministic {
  det_step: forall s0 t1 s1 t2 s2,
    Step L s0 t1 s1 -> Step L s0 t2 s2 -> s1 = s2 /\ t1 = t2;
  det_initial_state: forall s1 s2,
    initial_state L s1 -> initial_state L s2 -> s1 = s2;
  det_final_state: forall s r1 r2,
    final_state L s r1 -> final_state L s r2 -> r1 = r2;
  det_final_nostep: forall s r,
    final_state L s r -> Nostep L s
}.

Section DETERM_SEM.

Variable L: semantics.
Hypothesis DET: sem_deterministic L.

Ltac use_step_deterministic :=
  match goal with
  | [ S1: Step L _ ?t1 _, S2: Step L _ ?t2 _ |- _ ] =>
    destruct (det_step L DET _ _ _ _ _ S1 S2) as [EQ1 EQ2]; subst
  end.

(** Determinism for finite transition sequences. *)

Lemma star_step_diamond:
  forall s0 t1 s1, Star L s0 t1 s1 ->
  forall t2 s2, Star L s0 t2 s2 ->
  exists t,
     (Star L s1 t s2 /\ t2 = t1 ** t)
  \/ (Star L s2 t s1 /\ t1 = t2 ** t).
Proof.
  induction 1; intros.
  exists t2; auto.
  inv H2. exists (t1 ** t2); right.
    split. econstructor; eauto. auto.
  use_step_deterministic.
  exploit IHstar. eexact H4. intros [t A]. exists t.
  destruct A. left; intuition. traceEq. right; intuition. traceEq.
Qed.

Ltac use_star_step_diamond :=
  match goal with
  | [ S1: Star L _ ?t1 _, S2: Star L _ ?t2 _ |- _ ] =>
    let t := fresh "t" in let P := fresh "P" in let EQ := fresh "EQ" in
    destruct (star_step_diamond _ _ _ S1 _ _ S2)
    as [t [ [P EQ] | [P EQ] ]]; subst
 end.

Ltac use_nostep :=
  match goal with
  | [ S: Step L ?s _ _, NO: Nostep L ?s |- _ ] => elim (NO _ _ S)
  end.

Lemma star_step_triangle:
  forall s0 t1 s1 t2 s2,
  Star L s0 t1 s1 ->
  Star L s0 t2 s2 ->
  Nostep L s2 ->
  exists t,
  Star L s1 t s2 /\ t2 = t1 ** t.
Proof.
  intros. use_star_step_diamond.
  exists t; auto.
  inv P. exists E0. split. constructor. traceEq.
  use_nostep.
Qed.

Ltac use_star_step_triangle :=
  match goal with
  | [ S1: Star L _ ?t1 _, S2: Star L _ ?t2 ?s2, NO: Nostep L ?s2 |- _ ] =>
    let t := fresh "t" in let P := fresh "P" in let EQ := fresh "EQ" in
    destruct (star_step_triangle _ _ _ _ _ S1 S2 NO)
    as [t [P EQ]]; subst
  end.

Lemma steps_deterministic:
  forall s0 t1 s1 t2 s2,
  Star L s0 t1 s1 -> Star L s0 t2 s2 ->
  Nostep L s1 -> Nostep L s2 ->
  t1 = t2 /\ s1 = s2.
Proof.
  intros. use_star_step_triangle. inv P.
  split; auto; traceEq. use_nostep.
Qed.

Lemma terminates_not_goes_wrong:
  forall s t1 s1 r t2 s2,
  Star L s t1 s1 -> final_state L s1 r ->
  Star L s t2 s2 -> Nostep L s2 ->
  (forall r, ~final_state L s2 r) -> False.
Proof.
  intros.
  assert (t1 = t2 /\ s1 = s2).
    eapply steps_deterministic; eauto. eapply det_final_nostep; eauto.
  destruct H4; subst. elim (H3 _ H0).
Qed.

(** Determinism for infinite transition sequences. *)

Lemma star_final_not_forever_silent:
  forall s t s', Star L s t s' ->
  Nostep L s' ->
  Forever_silent L s -> False.
Proof.
  induction 1; intros.
  inv H0. use_nostep.
  inv H3. use_step_deterministic. eauto.
Qed.

Lemma star2_final_not_forever_silent:
  forall s t1 s1 t2 s2,
  Star L s t1 s1 -> Nostep L s1 ->
  Star L s t2 s2 -> Forever_silent L s2 ->
  False.
Proof.
  intros. use_star_step_triangle.
  eapply star_final_not_forever_silent. eexact P. eauto. auto.
Qed.

Lemma star_final_not_forever_reactive:
  forall s t s', Star L s t s' ->
  forall T, Nostep L s' -> Forever_reactive L s T -> False.
Proof.
  induction 1; intros.
  inv H0. inv H1. congruence. use_nostep.
  inv H3. inv H4. congruence.
  use_step_deterministic.
  eapply IHstar with (T := t4 *** T0). eauto.
  eapply star_forever_reactive; eauto.
Qed.

Lemma star_forever_silent_inv:
  forall s t s', Star L s t s' ->
  Forever_silent L s ->
  t = E0 /\ Forever_silent L s'.
Proof.
  induction 1; intros.
  auto.
  subst. inv H2. use_step_deterministic. eauto.
Qed.

Lemma forever_silent_reactive_exclusive:
  forall s T,
  Forever_silent L s -> Forever_reactive L s T -> False.
Proof.
  intros. inv H0. exploit star_forever_silent_inv; eauto.
  intros [A B]. contradiction.
Qed.

Lemma forever_reactive_inv2:
  forall s t1 s1, Star L s t1 s1 ->
  forall t2 s2 T1 T2,
  Star L s t2 s2 ->
  t1 <> E0 -> t2 <> E0 ->
  Forever_reactive L s1 T1 ->
  Forever_reactive L s2 T2 ->
  exists s', exists t, exists T1', exists T2',
  t <> E0 /\
  Forever_reactive L s' T1' /\
  Forever_reactive L s' T2' /\
  t1 *** T1 = t *** T1' /\
  t2 *** T2 = t *** T2'.
Proof.
  induction 1; intros.
  congruence.
  inv H2. congruence. use_step_deterministic.
  destruct t3.
  (* inductive case *)
  simpl in *. eapply IHstar; eauto.
  (* base case *)
  exists s5; exists (e :: t3);
  exists (t2 *** T1); exists (t4 *** T2).
  split. unfold E0; congruence.
  split. eapply star_forever_reactive; eauto.
  split. eapply star_forever_reactive; eauto.
  split; traceEq.
Qed.

Lemma forever_reactive_determ':
  forall s T1 T2,
  Forever_reactive L s T1 ->
  Forever_reactive L s T2 ->
  traceinf_sim' T1 T2.
Proof.
  cofix COINDHYP; intros.
  inv H. inv H0.
  destruct (forever_reactive_inv2 _ _ _ H t s2 T0 T)
  as [s' [t' [T1' [T2' [A [B [C [D E]]]]]]]]; auto.
  rewrite D; rewrite E. constructor. auto.
  eapply COINDHYP; eauto.
Qed.

Lemma forever_reactive_determ:
  forall s T1 T2,
  Forever_reactive L s T1 ->
  Forever_reactive L s T2 ->
  traceinf_sim T1 T2.
Proof.
  intros. apply traceinf_sim'_sim. eapply forever_reactive_determ'; eauto.
Qed.

Lemma star_forever_reactive_inv:
  forall s t s', Star L s t s' ->
  forall T, Forever_reactive L s T ->
  exists T', Forever_reactive L s' T' /\ T = t *** T'.
Proof.
  induction 1; intros.
  exists T; auto.
  inv H2. inv H3. congruence.
  use_step_deterministic.
  exploit IHstar. eapply star_forever_reactive. 2: eauto. eauto.
  intros [T' [A B]]. exists T'; intuition. traceEq. congruence.
Qed.

Lemma forever_silent_reactive_exclusive2:
  forall s t s' T,
  Star L s t s' -> Forever_silent L s' ->
  Forever_reactive L s T ->
  False.
Proof.
  intros. exploit star_forever_reactive_inv; eauto.
  intros [T' [A B]]. subst T.
  eapply forever_silent_reactive_exclusive; eauto.
Qed.

(** Determinism for program executions *)

Lemma state_behaves_deterministic:
  forall s beh1 beh2,
  state_behaves L s beh1 -> state_behaves L s beh2 -> beh1 = beh2.
Proof.
  generalize (det_final_nostep L DET); intro dfns.
  intros until beh2; intros BEH1 BEH2.
  inv BEH1; inv BEH2.
(* terminates, terminates *)
  assert (t = t0 /\ s' = s'0). eapply steps_deterministic; eauto.
  destruct H3. f_equal; auto. subst. eapply det_final_state; eauto.
(* terminates, diverges *)
  byContradiction. eapply star2_final_not_forever_silent with (s1 := s') (s2 := s'0); eauto.
(* terminates, reacts *)
  byContradiction. eapply star_final_not_forever_reactive; eauto.
(* terminates, goes_wrong *)
  byContradiction. eapply terminates_not_goes_wrong with (s1 := s') (s2 := s'0); eauto.
(* diverges, terminates *)
  byContradiction. eapply star2_final_not_forever_silent with (s2 := s') (s1 := s'0); eauto.
(* diverges, diverges *)
  f_equal. use_star_step_diamond.
  exploit star_forever_silent_inv. eexact P. eauto.
  intros [A B]. subst; traceEq.
  exploit star_forever_silent_inv. eexact P. eauto.
  intros [A B]. subst; traceEq.
(* diverges, reacts *)
  byContradiction. eapply forever_silent_reactive_exclusive2; eauto.
(* diverges, goes wrong *)
  byContradiction. eapply star2_final_not_forever_silent with (s1 := s'0) (s2 := s'); eauto.
(* reacts, terminates *)
  byContradiction. eapply star_final_not_forever_reactive; eauto.
(* reacts, diverges *)
  byContradiction. eapply forever_silent_reactive_exclusive2; eauto.
(* reacts, reacts *)
  f_equal. apply traceinf_extensionality.
  eapply forever_reactive_determ; eauto.
(* reacts, goes wrong *)
  byContradiction. eapply star_final_not_forever_reactive; eauto.
(* goes wrong, terminate *)
  byContradiction. eapply terminates_not_goes_wrong with (s1 := s'0) (s2 := s'); eauto.
(* goes wrong, diverges *)
  byContradiction. eapply star2_final_not_forever_silent with (s1 := s') (s2 := s'0); eauto.
(* goes wrong, reacts *)
  byContradiction. eapply star_final_not_forever_reactive; eauto.
(* goes wrong, goes wrong *)
  assert (t = t0 /\ s' = s'0). eapply steps_deterministic; eauto.
  destruct H5. congruence.
Qed.

Theorem program_behaves_deterministic:
  forall beh1 beh2,
  program_behaves L beh1 -> program_behaves L beh2 ->
  beh1 = beh2.
Proof.
  intros until beh2; intros BEH1 BEH2. inv BEH1; inv BEH2.
(* both initial states defined *)
  assert (s = s0) by (eapply det_initial_state; eauto). subst s0.
  eapply state_behaves_deterministic; eauto.
(* one initial state defined, the other undefined *)
  elim (H1 _ H).
  elim (H _ H0).
(* both initial states undefined *)
  auto.
Qed.

End DETERM_SEM.

(** * Integrating an external world in a semantics. *)

(** Given a transition semantics, we can build another semantics that
  integrates an external world in its state and allows only world-possible
  transitions. *)

Section WORLD_SEM.

Variable L: semantics.
Variable initial_world: world.

Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
Local Open Scope pair_scope.

Definition world_sem : semantics := @Semantics
  (state L * world)%type
  (funtype L)
  (vartype L)
  (fun ge s t s' => step L ge s#1 t s'#1 /\ possible_trace s#2 t s'#2)
  (fun s => initial_state L s#1 /\ s#2 = initial_world)
  (fun s r => final_state L s#1 r)
  (globalenv L).

(** If the original semantics is determinate, the world-aware semantics is deterministic. *)

Hypothesis D: determinate L.

Theorem world_sem_deterministic: sem_deterministic world_sem.
Proof.
  constructor; simpl; intros.
(* steps *)
  destruct H; destruct H0.
  exploit (sd_determ D). eexact H. eexact H0. intros [A B].
  exploit match_possible_traces; eauto. intros [EQ1 EQ2]. subst t2.
  split; auto.
  rewrite (surjective_pairing s1). rewrite (surjective_pairing s2). intuition congruence.
(* initial states *)
  destruct H; destruct H0.
  rewrite (surjective_pairing s1). rewrite (surjective_pairing s2). decEq.
  eapply (sd_initial_determ D); eauto.
  congruence.
(* final states *)
  eapply (sd_final_determ D); eauto.
(* final no step *)
  red; simpl; intros. red; intros [A B]. exploit (sd_final_nostep D); eauto.
Qed.

(*** To be updated. *)
(***********
Variable genv: Type.
Variable state: Type.
Variable step: genv -> state -> trace -> state -> Prop.
Variable initial_state: state -> Prop.
Variable final_state: state -> int -> Prop.
Variable initial_world: world.

Definition wstate : Type := (state * world)%type.

Definition wstep (ge: genv) (S: wstate) (t: trace) (S': wstate) :=
  step ge S#1 t S'#1 /\ possible_trace S#2 t S'#2.

Definition winitial_state (S: wstate) :=
  initial_state S#1 /\ S#2 = initial_world.

Definition wfinal_state (S: wstate) (r: int) :=
  final_state S#1 r.

Definition wprogram_behaves (ge: genv) (beh: program_behavior) :=
  program_behaves wstep winitial_state wfinal_state ge beh.

(** We now relate sequences of transitions and behaviors between the two semantics. *)

Section TRANSITIONS.

Variable ge: genv.

Lemma inject_star:
  forall S t S', star step ge S t S' ->
  forall w w', possible_trace w t w' ->
  star wstep ge (S, w) t (S', w').
Proof.
  induction 1; intros; subst; possibleTraceInv.
  constructor.
  apply star_step with t1 (s2,w0) t2. split; auto. auto. auto.
Qed.

Lemma project_star:
  forall S t S', star wstep ge S t S' -> star step ge S#1 t S'#1.
Proof.
  induction 1. constructor. destruct H. econstructor; eauto.
Qed.

Lemma project_star_trace:
  forall S t S', star wstep ge S t S' -> possible_trace S#2 t S'#2.
Proof.
  induction 1. constructor. subst t. destruct H. eapply possible_trace_app. eauto. eauto.
Qed.

Lemma inject_forever_silent:
  forall S w, forever_silent step ge S -> forever_silent wstep ge (S, w).
Proof.
  cofix COINDHYP; intros. inv H.
  apply forever_silent_intro with (s2,w).
  split. auto. constructor. apply COINDHYP; auto.
Qed.

Lemma project_forever_silent:
  forall S, forever_silent wstep ge S -> forever_silent step ge S#1.
Proof.
  cofix COINDHYP; intros. inv H. destruct H0.
  apply forever_silent_intro with (s2#1). auto. apply COINDHYP; auto.
Qed.

Lemma inject_forever_reactive:
  forall S T w, forever_reactive step ge S T -> possible_traceinf w T ->
  forever_reactive wstep ge (S, w) T.
Proof.
  cofix COINDHYP; intros. inv H. possibleTraceInv.
  apply forever_reactive_intro with (s2,w0).
  apply inject_star; auto. auto. apply COINDHYP; auto.
Qed.

Lemma project_forever_reactive:
  forall S T, forever_reactive wstep ge S T -> forever_reactive step ge S#1 T.
Proof.
  cofix COINDHYP; intros. inv H.
  apply forever_reactive_intro with (s2#1).
  apply project_star; auto. auto. apply COINDHYP; auto.
Qed.

Lemma project_forever_reactive_trace:
  forall S T, forever_reactive wstep ge S T -> possible_traceinf S#2 T.
Proof.
  intros. apply possible_traceinf'_traceinf. revert S T H.
  cofix COINDHYP; intros. inv H. econstructor.
  apply project_star_trace. eauto. auto. apply COINDHYP; auto.
Qed.

Lemma inject_behaviors:
  forall beh,
  program_behaves step initial_state final_state ge beh ->
  possible_behavior initial_world beh ->
  wprogram_behaves ge beh.
Proof.
  intros. inv H; simpl in H0.
(* terminates *)
  destruct H0 as [w' A]. econstructor.
    instantiate (1 := (s, initial_world)). red; eauto.
    apply inject_star; eauto.
    red; auto.
(* diverges silently *)
  destruct H0 as [w' A]. econstructor.
    instantiate (1 := (s, initial_world)). red; eauto.
    apply inject_star; eauto. apply inject_forever_silent; auto.
(* diverges reactively *)
  econstructor.
    instantiate (1 := (s, initial_world)). red; eauto.
    apply inject_forever_reactive; auto.
(* goes wrong *)
  destruct H0 as [w' A]. red in H3.
  econstructor.
    instantiate (1 := (s, initial_world)). red; eauto.
    apply inject_star; eauto.
    red. intros. red; intros [C D]. elim (H3 t0 s'0#1); auto.
    unfold wfinal_state; simpl. auto.
(* goes initially wrong *)
  apply program_goes_initially_wrong. intros; red; intros. destruct H.
  elim (H1 s#1); auto.
Qed.

Lemma project_behaviors_trace:
  forall beh,
  wprogram_behaves ge beh ->
  possible_behavior initial_world beh.
Proof.
  intros. inv H; simpl.
  destruct H0. rewrite <- H0. exists (s'#2); apply project_star_trace; auto.
  destruct H0. rewrite <- H0. exists (s'#2); apply project_star_trace; auto.
  destruct H0. rewrite <- H0. apply project_forever_reactive_trace; auto.
  destruct H0. rewrite <- H0. exists (s'#2); apply project_star_trace; auto.
  exists initial_world; constructor.
Qed.

Lemma project_behaviors:
  forall beh,
  wprogram_behaves ge beh ->
  program_behaves step initial_state final_state ge beh
  \/ exists S, exists t, exists S', exists w', exists S'', exists t',
     beh = Goes_wrong t /\
     initial_state S /\ star step ge S t S' /\ possible_trace initial_world t w' /\
     step ge S' t' S'' /\ forall w'', ~(possible_trace w' t' w'').
Proof.
  intros. inv H.
(* terminates *)
  destruct H0.
  left. econstructor; eauto. apply project_star; auto.
(* diverges silently *)
  destruct H0.
  left. econstructor; eauto. apply project_star; eauto. apply project_forever_silent; auto.
(* diverges reactively *)
  destruct H0.
  left. econstructor; eauto. apply project_forever_reactive; auto.
(* goes wrong *)
  destruct H0.
  red in H2.
  destruct (classic (forall t s'', ~step ge s'#1 t s'')).
  left. econstructor; eauto. apply project_star; eauto.
  destruct (not_all_ex_not _ _ H4) as [t' A]. clear H4.
  destruct (not_all_ex_not _ _ A) as [s'' B]. clear A.
  assert (C: step ge s'#1 t' s''). apply NNPP; auto. clear B.
  right. do 6 econstructor. split. eauto. split. eauto.
  split. apply project_star; eauto.
  split. rewrite <- H0. apply project_star_trace; eauto.
  split. eauto.
  intros; red; intros. elim (H2 t' (s'',w'')). split; auto.
(* goes initially wrong *)
  left. apply program_goes_initially_wrong. intros; red; intros.
  elim (H0 (s, initial_world)). split; auto.
Qed.

End TRANSITIONS.

Section INTERNAL_DET_TO_DET.

(** We assume given a transition semantics that is internally
  deterministic: the only source of non-determinism is the return
  value of system calls.   Under this assumption, the world-aware semantics
  is deterministic. *)

Hypothesis step_internal_deterministic:
  forall ge s t1 s1 t2 s2,
  step ge s t1 s1 -> step ge s t2 s2 -> matching_traces t1 t2 -> s1 = s2 /\ t1 = t2.

Hypothesis initial_state_determ:
  forall s1 s2, initial_state s1 -> initial_state s2 -> s1 = s2.

Hypothesis final_state_determ:
  forall st r1 r2, final_state st r1 -> final_state st r2 -> r1 = r2.

Hypothesis final_state_nostep:
  forall ge st r, final_state st r -> nostep step ge st.

Remark matching_possible_traces:
  forall w0 t1 w1, possible_trace w0 t1 w1 ->
  forall t2 w2, possible_trace w0 t2 w2 ->
  matching_traces t1 t2.
Proof.
  induction 1; intros.
  destruct t2; simpl; auto.
  destruct t2; simpl. destruct ev; auto. inv H1.
  inv H; inv H5; auto; intros.
  destruct H2. subst. rewrite H in H1; inv H1. split; eauto.
  destruct H2. destruct H3. subst. rewrite H in H1; inv H1. split; eauto.
  destruct H2. destruct H3. destruct H4. subst. rewrite H in H1; inv H1. eauto.
Qed.

Lemma wstep_deterministic:
  forall ge S0 t1 S1 t2 S2,
  wstep ge S0 t1 S1 -> wstep ge S0 t2 S2 -> S1 = S2 /\ t1 = t2.
Proof.
  intros. destruct H; destruct H0.
  exploit step_internal_deterministic. eexact H. eexact H0.
  eapply matching_possible_traces; eauto.
  intros [A B]. split. apply injective_projections. auto.
  subst t2. eapply possible_trace_final_world; eauto.
  auto.
Qed.

Lemma winitial_state_determ:
  forall s1 s2, winitial_state s1 -> winitial_state s2 -> s1 = s2.
Proof.
  intros. destruct H; destruct H0. apply injective_projections. eauto. congruence.
Qed.

Lemma wfinal_state_determ:
  forall st r1 r2, wfinal_state st r1 -> wfinal_state st r2 -> r1 = r2.
Proof.
  unfold wfinal_state. eauto.
Qed.

Lemma wfinal_state_nostep:
  forall ge st r, wfinal_state st r -> nostep wstep ge st.
Proof.
  unfold wfinal_state. intros; red; intros; red; intros [A B].
  eapply final_state_nostep; eauto.
Qed.

Theorem program_behaves_world_deterministic:
  forall ge beh1 beh2,
  program_behaves step initial_state final_state ge beh1 -> possible_behavior initial_world beh1 ->
  program_behaves step initial_state final_state ge beh2 -> possible_behavior initial_world beh2 ->
  beh1 = beh2.
Proof.
  intros.
  apply program_behaves_deterministic with
    (step := wstep) (initial_state := winitial_state) (final_state := wfinal_state) (ge := ge).
  exact wstep_deterministic.
  exact winitial_state_determ.
  exact wfinal_state_determ.
  exact wfinal_state_nostep.
  apply inject_behaviors; auto.
  apply inject_behaviors; auto.
Qed.

End INTERNAL_DET_TO_DET.

***********)

End WORLD_SEM.


Require Import Rpos.
Require Import RL.hr.term.
Require Import RL.hr.semantic.
Require Import RL.hr.hseq.
Require Import RL.hr.hr.
Require Import RL.hr.tech_lemmas.

Require Import CMorphisms.
Require Import Lra.

Require Import RL.OLlibs.List_more.
Require Import RL.OLlibs.List_Type.
Require Import RL.OLlibs.Permutation_Type.
Require Import RL.OLlibs.Permutation_Type_more.
Require Import RL.OLlibs.Permutation_Type_solve.

(** Proof of Lemma 4.35 *)
Lemma hrr_mul_vec : forall L (pi : HR_T (map (fun x => snd x) L)),
    HR_T (map (fun x => seq_mul_vec (fst x) (snd x)) L).
Proof.
  intros L pi.
  remember (map (fun x => snd x) L) as G.
  revert L HeqG; induction pi; intros L HeqG.
  - destruct L; [ | destruct L]; try now inversion HeqG.
    destruct p as [r T]; destruct T; try now inversion HeqG.
    simpl; rewrite seq_mul_vec_nil_r; apply hrr_INIT.
  - destruct L; try now inversion HeqG.
    simpl in HeqG; inversion HeqG.
    apply hrr_W.
    apply IHpi.
    apply H1.
  - destruct L; simpl in HeqG; inversion HeqG; subst.
    simpl.
    apply hrr_C.
    apply (IHpi (p :: p :: L) eq_refl).
  - destruct L; [ | destruct L]; try destruct p as [r1 T1']; try destruct p0 as [r2 T2']; inversion HeqG; subst.
    destruct r1 ; [ | destruct r2].
    + simpl.
      eapply (hrr_ex_hseq _ ((seq_mul_vec r2 T2' :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) ++ (nil :: nil)) _ _ (hrr_W_gen _ _ _ (hrr_INIT _))).
      Unshelve.
      Permutation_Type_solve.
    + simpl.
      eapply (hrr_ex_hseq _ ((seq_mul_vec (r :: r1) T1' :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L) ++ (nil :: nil)) _ _ (hrr_W_gen _ _ _ (hrr_INIT _))).
      Unshelve.
      Permutation_Type_solve.
    + assert (r0 :: r2 <> nil) as Hnnilr2 by now auto.
      assert (r :: r1 <> nil) as Hnnilr1 by now auto.
      assert (Permutation_Type (seq_mul_vec (vec_mul_vec (r :: r1) (r0 :: r2)) (T1' ++ T2')) ((seq_mul_vec (r0 :: r2) (seq_mul r T1' ++ seq_mul_vec r1 T1') ++ seq_mul_vec (r :: r1) (seq_mul r0 T2' ++ seq_mul_vec r2 T2')))) as Hperm'.
      { etransitivity; [ symmetry; apply seq_mul_vec_twice | ].
        etransitivity ; [ apply seq_mul_vec_perm_r; apply (seq_mul_vec_app_r _ _ (r0 :: r2)) | ].
        etransitivity ; [ apply seq_mul_vec_app_r | ].
        etransitivity ; [ apply Permutation_Type_app ; [ apply seq_mul_vec_twice_comm | reflexivity ] | ].
        Permutation_Type_solve. }
      unfold HR_T; change hr_frag_T with (hr_frag_add_T hr_frag_T).
      simpl.
      apply hrr_T_vec with (r0 :: r2); try apply Hnnilr2.
      eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      change hr_frag_T with (hr_frag_add_T hr_frag_T).
      apply hrr_T_vec with (r :: r1); try apply Hnnilr1.
      eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
      apply hrr_S.
      eapply hrr_ex_seq; [ apply Hperm' | ].
      apply (IHpi ((vec_mul_vec (r :: r1) (r0 :: r2) , T1' ++ T2') :: L) eq_refl).
  - inversion f.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    apply hrr_T with r; try assumption.
    rewrite seq_mul_seq_mul_vec.
    apply (IHpi ((r1, seq_mul r T1) :: L) eq_refl).
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    apply hrr_ex_seq with (vec (vec_mul_vec r1 s) (RS_covar n) ++ vec (vec_mul_vec r1 r) (RS_var n) ++ seq_mul_vec r1 T).
    { etransitivity ; [ | symmetry ; apply seq_mul_vec_app_r].
      etransitivity ; [ | symmetry; apply Permutation_Type_app; try apply seq_mul_vec_app_r; reflexivity ].
      apply Permutation_Type_app ; [ | apply Permutation_Type_app]; try rewrite seq_mul_vec_vec_mul_vec; reflexivity. }
    apply hrr_ID.
    { rewrite ? sum_vec_vec_mul_vec.
      nra. }
    apply (IHpi ((r1, T) :: L) eq_refl).
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_Z.
    apply (IHpi ((r1, T) :: L) eq_refl).
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_plus.
    rewrite <- ? seq_mul_vec_vec_mul_vec.
    apply hrr_ex_seq with (seq_mul_vec r1 (vec r A ++ vec r B ++ T)).
    { etransitivity ; [apply seq_mul_vec_app_r | ].
      apply Permutation_Type_app; try apply seq_mul_vec_app_r; reflexivity. }
    apply (IHpi ((r1, vec r A ++ vec r B ++ T) :: L) eq_refl).
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_mul.
    rewrite <- vec_mul_vec_mul_vec_comm.
    rewrite <- ? seq_mul_vec_vec_mul_vec.
    eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ].
    apply (IHpi ((r1, vec (mul_vec r0 r) A ++ T) :: L) eq_refl).
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_max.
    rewrite <- ? seq_mul_vec_vec_mul_vec.
    eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_swap | ].
    apply (IHpi ((r1, vec r B ++ T) :: (r1, vec r A ++ T) :: L) eq_refl).
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ symmetry; apply seq_mul_vec_app_r | ].
    rewrite seq_mul_vec_vec_mul_vec.
    apply hrr_min;
      rewrite <- ? seq_mul_vec_vec_mul_vec;
      (eapply hrr_ex_seq ; [ apply seq_mul_vec_app_r | ]);
      [ apply (IHpi1 ((r1, vec r A ++ T) :: L) eq_refl)
      | apply (IHpi2 ((r1, vec r B ++ T) :: L) eq_refl) ].
  - destruct L; try destruct p0 as [r1 T1']; inversion HeqG; subst.
    simpl.
    eapply hrr_ex_seq ; [ apply seq_mul_vec_perm_r; apply p | ].
    apply (IHpi ((r1 , T1) :: L) eq_refl).
  - subst.
    destruct (Permutation_Type_map_inv _ _ p) as [L' Heq Hperm].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_map ; symmetry; apply Hperm | ]; apply (IHpi L' Heq).
  - inversion f.
Qed.

Lemma hrr_M_gen : forall L H D (pi : HR_T (map (fun x => snd x) L)),
    HR_T (D :: H) ->
    HR_T (map (fun x => snd x ++ seq_mul_vec (fst x) D) L ++ H).
Proof.
  intros L H D pi pi2.
  remember (map (fun x => snd x) L) as G.
  revert L HeqG.
  induction pi; intros L HeqG.
  - destruct L; try (destruct p as [r1 T1]; destruct T1); inversion HeqG; simpl.
    destruct L; inversion H1; simpl.
    assert {L & prod
                  (H = map (fun x => snd x) L)
                  (H = map (fun x => seq_mul_vec (fst x) (snd x)) L)} as [L [Heq1 Heq2]].
    { clear; induction H.
      - split with nil; split; reflexivity.
      - destruct IHlist as [L [H1 H2]].
        split with (((One :: nil), a) :: L).
        simpl; split ; [ rewrite H1; reflexivity |  rewrite H2].
        rewrite app_nil_r; rewrite seq_mul_One.
        reflexivity. }
    rewrite Heq2.
    change (seq_mul_vec r1 D :: map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) L)
      with
        (map (fun x : list Rpos * sequent => seq_mul_vec (fst x) (snd x)) ((r1 , D) :: L)).
    apply hrr_mul_vec.
    simpl; rewrite <- Heq1.
    apply pi2.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_W; apply (IHpi L eq_refl) .
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_C; apply (IHpi ((r1, T1) :: (r1, T1) :: L) eq_refl) .
  - destruct L; [ | destruct L]; try destruct p as [r1 T1']; try destruct p0 as [r2 T2']; inversion HeqG; subst; simpl.
    apply hrr_S.
    apply hrr_ex_seq with ((T1' ++ T2') ++ seq_mul_vec (r1 ++ r2) D).
    { rewrite seq_mul_vec_app_l.
      Permutation_Type_solve. }
    apply (IHpi ((r1 ++ r2, T1' ++ T2') :: L) eq_refl) .
  - inversion f.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_T with r; auto.
    apply hrr_ex_seq with (seq_mul r T1 ++ seq_mul_vec (mul_vec r r1) D) ; [ rewrite seq_mul_app; rewrite seq_mul_seq_mul_vec_2; reflexivity | ].
    apply (IHpi ((mul_vec r r1, seq_mul r T1) :: L) eq_refl) .
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_ex_seq with (vec s (RS_covar n) ++ vec r (RS_var n) ++ T ++ seq_mul_vec r1 D) ; [ rewrite <- ? app_assoc; reflexivity | apply hrr_ID; try assumption].
    apply (IHpi ((r1, T) :: L) eq_refl) .
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
     apply hrr_ex_seq with (vec r RS_zero ++ T ++ seq_mul_vec r1 D) ; [ rewrite <- ? app_assoc; reflexivity | apply hrr_Z; apply (IHpi ((r1, T) :: L) eq_refl)] .
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_ex_seq with (vec r (A +S B) ++ T ++ seq_mul_vec r1 D) ; [ rewrite <- ? app_assoc; reflexivity | apply hrr_plus].
    eapply hrr_ex_seq ; [ | apply (IHpi ((r1, vec r A ++ vec r B ++ T) :: L) eq_refl)].
    Permutation_Type_solve.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_ex_seq with (vec r (r0 *S A) ++ T ++ seq_mul_vec r1 D) ; [ rewrite <- ? app_assoc; reflexivity | apply hrr_mul].
    eapply hrr_ex_seq ; [ | apply (IHpi ((r1, vec (mul_vec r0 r) A ++ T) :: L) eq_refl)].
    Permutation_Type_solve.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_ex_seq with (vec r (A \/S B) ++ T ++ seq_mul_vec r1 D) ; [ rewrite <- ? app_assoc; reflexivity | ].
    apply hrr_max.
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    apply hrr_ex_seq with ((vec r A ++ T) ++ seq_mul_vec r1 D) ; [ Permutation_Type_solve | ].
    eapply hrr_ex_hseq; [ apply Permutation_Type_swap | ].
    eapply hrr_ex_seq; [ | apply (IHpi ((r1, vec r B ++ T) :: (r1, vec r A ++ T) :: L) eq_refl)].
    Permutation_Type_solve.
  - destruct L; try destruct p as [r1 T1]; inversion HeqG; subst; simpl.
    apply hrr_ex_seq with (vec r (A /\S B) ++ T ++ seq_mul_vec r1 D) ; [ Permutation_Type_solve |].
    apply hrr_min; eapply hrr_ex_hseq ; [ | apply (IHpi1 ((r1, vec r A ++ T) :: L) eq_refl) | | apply (IHpi2 ((r1, vec r B ++ T) :: L) eq_refl)]; Permutation_Type_solve.
  - destruct L; try destruct p0 as [r1 T1']; inversion HeqG; subst; simpl.
    eapply hrr_ex_seq ; [ apply Permutation_Type_app ; [ apply p | reflexivity] | ].
    apply (IHpi ((r1, T1) :: L) eq_refl).
  - subst.
    destruct (Permutation_Type_map_inv  _ _ p) as [L' Heq Hperm].
    eapply hrr_ex_hseq ; [ apply Permutation_Type_app ; [ apply Permutation_Type_map ; symmetry; apply Hperm | reflexivity ] | ].
    apply (IHpi L' Heq).
  - inversion f.
Qed.

Lemma hrr_M_elim : forall G,
    HR_T_M G ->
    HR_T G.
Proof.
  intros G pi; induction pi; try now constructor.
  - assert {L & prod
                  (G = map (fun x => snd x) L)
                  (G = map (fun x => snd x ++ seq_mul_vec (fst x) T2) L)} as [L [Heq1 Heq2]].
    { clear; induction G.
      - split with nil; split; reflexivity.
      - destruct IHG as [L [H1 H2]].
        split with ((nil, a) :: L).
        simpl; split ; [ rewrite H1; reflexivity |  rewrite H2].
        rewrite app_nil_r; reflexivity. }
    apply hrr_ex_hseq with (G ++ ((T1 ++ T2) :: nil)); [ Permutation_Type_solve | ].
    apply hrr_C_gen.
    apply hrr_ex_hseq with (((T1 ++ T2) :: G) ++ G); [ Permutation_Type_solve | ].
    pattern G at 1; rewrite Heq2.
    replace ((T1 ++ T2)
               :: map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) T2) L)
      with (map (fun x : list Rpos * list (Rpos * term) => snd x ++ seq_mul_vec (fst x) T2) ((One :: nil , T1) :: L)) by (simpl; rewrite app_nil_r; now rewrite seq_mul_One).
    apply hrr_M_gen; try assumption.
    simpl.
    rewrite <- Heq1; apply IHpi1.
  - now apply hrr_T with r.
  - now apply hrr_ex_seq with T1.
  - now apply hrr_ex_hseq with G.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^213 - 3
Base: 42.6
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 42 + 3/5;
    bitwidth := 64;
    s := 2^213;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj6eqsynthconj5 : forall  (lv0 : natural), (@eq natural (lv0) (plus Zero lv0)).
Admitted.
QuickChick conj6eqsynthconj5.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^389 - 21
Base: 24 + 5/16
***)

Definition curve : CurveParameters :=
  {|
    sz := 16%nat;
    base := 24 + 5/16;
    bitwidth := 32;
    s := 2^389;
    c := [(1, 21)];
    carry_chains := Some [seq 0 (pred 16); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(* This file formalises the lemmas from subsection 5.1, plus a few
   trivial properties of (sim U) left implicit in the paper text. *)

Require Import beta.
Require Import cases.

Section Sim.

Variable U : term -> Prop.

Lemma lem_U_morphism : meaningless U -> forall x y, U x -> x == y -> U y.
Proof.
  intros.
  assert (inf_beta x y) by (pose_inf_beta; ycrush).
  sauto.
Qed.

Lemma lem_sim_morphism : meaningless U -> morphism (sim U).
Proof.
  intro Hm.
  unfold morphism.
  coinduction CH.
  - clear CH; pose lem_U_morphism; ycrush.
  - destruct x'0, y'0; try solve [ clear CH; sauto ].
    intros.
    apply par_clos_app.
    + apply CH with (x := x0) (y := x'); clear CH; pose_term_eq; ycrush.
    + apply CH with (x := y0) (y := y'); clear CH; pose_term_eq; ycrush.
Qed.

Lemma lem_par_bot_to_sim :
  U bot -> forall x y, par_bot U x y -> sim U x y.
Proof.
  intro; coinduction using ssolve.
Qed.

Lemma lem_sim_refl_0 : reflexive term (sim U).
Proof.
  coinduction on 0.
Qed.

Lemma lem_sim_refl :
  (forall x y, U x -> x == y -> U y) -> forall x y, x == y -> sim U x y.
Proof.
  intro; coinduction.
Qed.

Lemma lem_sim_sym : symmetric term (sim U).
Proof.
  coinduction.
Qed.

(* Lemma 5.4 *)
Lemma lem_sim_trans : meaningless U -> transitive term (sim U).
Proof.
  unfold meaningless.
  intro H; simp_hyps.
  coinduction CH using auto.
  - csolve CH.
  - cintro; [ pose lem_sim_sym; clear CH; constructor; sintuition; eauto |
              constructor 4; eapply CH; eauto ].
  - cintro; [ pose lem_sim_sym; clear CH; constructor; sintuition; eauto |
              constructor 5; eapply CH; eauto ].
Qed.

Lemma lem_sim_subset (R : term -> Prop) : (forall x, U x -> R x) -> forall x y, sim U x y -> sim R x y.
Proof.
  intro H; coinduction.
Qed.

Lemma lem_sim_shift_closed : meaningless U -> shift_closed (sim U).
Proof.
  unfold shift_closed.
  intro H.
  coinduction.
Qed.

(* Lemma 5.1 *)
Lemma lem_sim_subst : meaningless U ->
                      forall n t t' s s', sim U t t' -> sim U s s' -> sim U (t [n := s]) (t' [n := s']).
Proof.
  intro H.
  pose lem_sim_shift_closed; coinduction.
Qed.

CoFixpoint F_sim_to_par_bot (t s : term) (p : sim U t s) : term.
destruct (lem_par_clos_cases t s p).
- exact bot.
- exact bot.
- exact (var n).
- exact (app (F_sim_to_par_bot x x' p0) (F_sim_to_par_bot y y' p1)).
- exact (abs (F_sim_to_par_bot x y p0)).
Defined.

(* Lemma 5.5 *)
Lemma lem_sim_to_par_bot : forall t s, sim U t s -> exists r, par_bot U t r /\ par_bot U s r.
Proof.
  enough (exists f, forall t s (p : sim U t s), par_bot U t (f t s p) /\ par_bot U s (f t s p)) by ycrush.
  exists F_sim_to_par_bot.
  split; revert t s p.
  - cofix CH.
    intros t s p.
    peek (F_sim_to_par_bot t s p).
    destruct (lem_par_clos_cases t s p).
    + clear CH; destruct x; sauto; constructor; constructor; pose_term_eq; ycrush.
    + clear CH; solve [ constructor ].
    + clear CH; solve [ constructor ].
    + apply par_clos_app; apply CH.
    + apply par_clos_abs; apply CH.
  - cofix CH.
    intros t s p.
    peek (F_sim_to_par_bot t s p).
    destruct (lem_par_clos_cases t s p).
    + clear CH; destruct y; sauto; constructor; constructor; pose_term_eq; ycrush.
    + clear CH; solve [ constructor ].
    + clear CH; solve [ constructor ].
    + apply par_clos_app; apply CH.
    + apply par_clos_abs; apply CH.
Qed.

(* Lemma 5.2 *)
Lemma lem_step_beta_preserves_sim : meaningless U ->
  forall t t' s, step_beta t s -> sim U t t' -> exists s', step_beta_eq t' s' /\ sim U s s'.
Proof.
  intros Hm t t' s H; revert t'.
  induction H.
  - inversion_clear H.
    intros t' H.
    inversion H; subst; clear H; try yelles 1.
    + exists t'; split.
      * pose_term_eq; ycrush.
      * assert (inf_beta x y) by
            (rewrite H0; rewrite H1; pose lem_red_beta_redex; pose_inf_beta; ycrush).
        ycrush.
    + inversion H0; subst; yisolve; fold term_eq in *.
      inversion H2; subst; try yelles 1.
      * assert (U (abs t1)) by (pose lem_U_morphism; pose_term_eq; ycrush).
        assert (U (app (abs t1) t2)) by ycrush.
        exists (app x' y'); split.
        ** pose_term_eq; ycrush.
        ** assert (sim U (app x0 y0) (app x' y')) by ycrush.
           assert (sim U (app (abs t1) t2) (app x' y')) by
               (pose lem_sim_morphism; pose_term_eq; ycrush).
           assert (inf_beta (app (abs t1) t2) y) by
            (rewrite H1; pose lem_red_beta_redex; pose_inf_beta; ycrush).
           ycrush.
      * inversion H6; subst; yisolve; fold term_eq in *.
        exists (y1 [0 := y']).
        split.
        ** pose lem_step_beta_redex; ycrush.
        ** assert (sim U (x [0 := y0]) (y1 [0 := y'])) by
              (pose lem_sim_subst; ycrush).
           assert (y == x [0 := y0]) by
               (rewrite H7; rewrite H8; assumption).
           pose lem_sim_morphism; pose_term_eq; ycrush.
  - intros t' H1.
    inversion H1; subst.
    + exists t'; split.
      * pose_term_eq; ycrush.
      * assert (inf_beta (app x y) (app x' y')) by
            (rewrite H0; pose lem_red_beta_redex; pose_inf_beta; ycrush).
        ycrush.
    + generalize (IHcomp_clos x'0 H4); intro HH; destruct HH as [s' [HH1 HH2]].
      exists (app s' y'0).
      split.
      * destruct HH1.
        ** left; constructor 2; ycrush.
        ** right; pose_term_eq; ycrush.
      * constructor 4; pose lem_sim_morphism; pose_term_eq; unfold morphism, sim in *; ycrush.
  - intros t' H1.
    inversion H1; subst.
    + exists t'; split.
      * pose_term_eq; ycrush.
      * assert (inf_beta (app x y) (app x' y')) by
            (rewrite H0; pose lem_red_beta_redex; pose_inf_beta; ycrush).
        ycrush.
    + generalize (IHcomp_clos y'0 H6); intro HH; destruct HH as [s' [HH1 HH2]].
      exists (app x'0 s').
      split.
      * destruct HH1.
        ** left; constructor 3; ycrush.
        ** right; pose_term_eq; ycrush.
      * constructor 4; pose lem_sim_morphism; pose_term_eq; unfold morphism, sim in *; ycrush.
  - intros t' H1.
    inversion H1; subst.
    + exists t'; split.
      * pose_term_eq; ycrush.
      * assert (inf_beta (abs x) (abs y)) by
            (pose lem_red_beta_redex; pose_inf_beta; ycrush).
        ycrush.
    + generalize (IHcomp_clos y0 H2); intro HH; destruct HH as [s' [HH1 HH2]].
      exists (abs s').
      split.
      * destruct HH1.
        ** left; constructor 4; ycrush.
        ** right; pose_term_eq; ycrush.
      * constructor 5; pose lem_sim_morphism; pose_term_eq; unfold morphism, sim in *; ycrush.
Qed.

Lemma lem_red_beta_preserves_sim : meaningless U ->
  forall t t' s, red_beta t s -> sim U t t' -> exists s', red_beta t' s' /\ sim U s s'.
Proof.
  intros Hm t t' s H; revert t'.
  induction H.
  - pose lem_sim_morphism; pose_term_eq; ycrush.
  - intros.
    generalize (lem_step_beta_preserves_sim Hm x t' y H H1); intro HH; destruct HH as [s [HH1 HH2]].
    generalize (IHstar s HH2); intro Hs; destruct Hs as [s0 [Hs1 Hs2]].
    exists s0.
    destruct HH1; pose_red_beta; pose_term_eq; ycrush.
Qed.

Lemma lem_red_beta_preserves_sim_choice :
  meaningless U ->
  forall t t' s, red_beta t s -> sim U t t' -> { s' | red_beta t' s' /\ sim U s s' }.
Proof.
  intros.
  apply constructive_indefinite_description.
  eapply lem_red_beta_preserves_sim; eauto.
Qed.

Lemma lem_inf_beta_preserves_sim_cases :
  meaningless U ->
  forall t t' s, inf_beta t s -> sim U t t' ->
                 red_beta t s \/
                 (exists u, red_beta t' u /\ sim U s u) \/
                 (exists s1 s2 t1 t2 u1 u2, s = app s1 s2 /\ red_beta t (app t1 t2) /\
                                            inf_beta t1 s1 /\ inf_beta t2 s2 /\
                                            sim U t1 u1 /\ sim U t2 u2 /\ red_beta t' (app u1 u2)) \/
                 (exists s0 t0 u0, s = abs s0 /\ red_beta t (abs t0) /\ inf_beta t0 s0 /\
                                   sim U t0 u0 /\ red_beta t' (abs u0)).
Proof.
  intros.
  inversion H0; subst; yisolve.
  - assert (HH: exists u, sim U (app x y) u /\ red_beta t' u) by
        Reconstr.rcrush (@beta.lem_step_beta_to_red_beta, @beta.lem_red_beta_refl, @Sim.lem_red_beta_preserves_sim, @beta.lem_red_beta_step) (@beta.step_beta_eq).
    destruct HH as [u [HH1 HH2]].
    inversion HH1; subst.
    + right; left.
      exists u.
      assert (inf_beta (app x y) (app x' y')) by
          Reconstr.reasy (@beta.lem_inf_beta_app) (@defs.inf_beta, @defs.red_beta).
      assert (U (app x' y')) by ycrush.
      ycrush.
    + right; right; left.
      exists x', y', x, y, x'0, y'0.
      ycrush.
  - assert (HH: exists u, sim U (abs x) u /\ red_beta t' u) by
        Reconstr.rcrush (@beta.lem_step_beta_to_red_beta, @beta.lem_red_beta_refl, @Sim.lem_red_beta_preserves_sim, @beta.lem_red_beta_step) (@beta.step_beta_eq).
    destruct HH as [u [HH1 HH2]].
    inversion HH1; subst.
    + right; left.
      exists u.
      assert (inf_beta (abs x) (abs x')) by
          Reconstr.reasy (@beta.lem_inf_beta_abs) (@defs.inf_beta, @defs.red_beta).
      assert (U (abs x')) by ycrush.
      ycrush.
    + right; right; right.
      exists x', x, y.
      ycrush.
Qed.

Inductive ctr (t t' s : term) : Set :=
| ctr_red : red_beta t s -> ctr t t' s
| ctr_u : forall u, red_beta t' u -> sim U s u -> ctr t t' s
| ctr_app : forall s1 s2 t1 t2 u1 u2, s = app s1 s2 -> red_beta t (app t1 t2) ->
                                      inf_beta t1 s1 -> inf_beta t2 s2 ->
                                      sim U t1 u1 -> sim U t2 u2 -> red_beta t' (app u1 u2) ->
                                      ctr t t' s
| ctr_abs : forall s0 t0 u0, s = abs s0 -> red_beta t (abs t0) -> inf_beta t0 s0 ->
                             sim U t0 u0 -> red_beta t' (abs u0) -> ctr t t' s.

Lemma lem_inf_beta_preserves_sim_cases_choice :
  meaningless U ->
  forall t t' s, inf_beta t s -> sim U t t' -> ctr t t' s.
Proof.
  intros Hm t t' s H1 H2.
  enough ({ c : ctr t t' s | True }) by ycrush.
  enough (exists c : ctr t t' s, True) by (apply constructive_indefinite_description; assumption).
  generalize (lem_inf_beta_preserves_sim_cases Hm t t' s H1 H2).
  ycrush.
Qed.

CoFixpoint F_inf_beta_preserves_sim (t t' s : term) (pu : meaningless U)
           (p1 : inf_beta t s) (p2 : sim U t t') : term.
destruct (lem_inf_beta_preserves_sim_cases_choice pu t t' s p1 p2).
- exact (proj1_sig (lem_red_beta_preserves_sim_choice pu t t' s r p2)).
- exact u.
- exact (app (F_inf_beta_preserves_sim t1 u1 s1 pu i s0) (F_inf_beta_preserves_sim t2 u2 s2 pu i0 s3)).
- exact (abs (F_inf_beta_preserves_sim t0 u0 s0 pu i s1)).
Defined.

(* Lemma 5.3 *)
Lemma lem_inf_beta_preserves_sim : meaningless U ->
  forall t t' s, inf_beta t s -> sim U t t' -> exists s', inf_beta t' s' /\ sim U s s'.
Proof.
  intro Hm.
  enough (exists f, forall t t' s (p1 : inf_beta t s) (p2 : sim U t t'),
               inf_beta t' (f t t' s Hm p1 p2) /\ sim U s (f t t' s Hm p1 p2)) by ycrush.
  exists F_inf_beta_preserves_sim.
  split.
  - revert t t' s p1 p2.
    cofix CH.
    intros.
    peek (F_inf_beta_preserves_sim t t' s Hm p1 p2).
    destruct (lem_inf_beta_preserves_sim_cases_choice Hm t t' s p1 p2).
    + clear CH; destruct (lem_red_beta_preserves_sim_choice Hm t t' _ r p2); pose_inf_beta; ycrush.
    + clear CH; pose_inf_beta; ycrush.
    + apply inf_clos_app with (x := u1) (y := u2).
      * assumption.
      * apply CH.
      * apply CH.
    + apply inf_clos_abs with (x := u0).
      * assumption.
      * apply CH.
  - revert t t' s p1 p2.
    cofix CH.
    intros.
    peek (F_inf_beta_preserves_sim t t' s Hm p1 p2).
    destruct (lem_inf_beta_preserves_sim_cases_choice Hm t t' s p1 p2).
    + clear CH; destruct (lem_red_beta_preserves_sim_choice Hm t t' _ r p2); ycrush.
    + clear CH; ycrush.
    + rewrite e.
      apply par_clos_app.
      * apply CH.
      * apply CH.
    + rewrite e.
      apply par_clos_abs.
      apply CH.
Qed.

End Sim.

Ltac pose_sim := pose proof lem_par_bot_to_sim; pose proof lem_sim_refl_0;
                 pose proof lem_sim_refl; pose proof lem_sim_sym; pose proof lem_sim_trans;
                 pose lem_sim_subst; pose lem_sim_to_par_bot;
                 autounfold with shints in *.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rtrigo.
Require Import SeqSeries.
Require Export Ranalysis1.
Require Export Ranalysis2.
Require Export Ranalysis3.
Require Export Rtopology.
Require Export MVT.
Require Export PSeries_reg.
Require Export Exp_prop.
Require Export Rtrigo_reg.
Require Export Rsqrt_def.
Require Export R_sqrt.
Require Export Rtrigo_calc.
Require Export Rgeom.
Require Export RList.
Require Export Sqrt_reg.
Require Export Ranalysis4.
Require Export Rpower.
Open Local Scope R_scope.

Axiom AppVar : R.

(**********)
Ltac intro_hyp_glob trm :=
  match constr:trm with
    | (?X1 + ?X2)%F =>
      match goal with
        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
        | _ => idtac
      end
    | (?X1 - ?X2)%F =>
      match goal with
        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
        | _ => idtac
      end
    | (?X1 * ?X2)%F =>
      match goal with
        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
        | _ => idtac
      end
    | (?X1 / ?X2)%F =>
      let aux := constr:X2 in
        match goal with
          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
            intro_hyp_glob X1; intro_hyp_glob X2
          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
            intro_hyp_glob X1; intro_hyp_glob X2
          |  |- (derivable _) =>
            cut (forall x0:R, aux x0 <> 0);
              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
          |  |- (continuity _) =>
            cut (forall x0:R, aux x0 <> 0);
              [ intro; intro_hyp_glob X1; intro_hyp_glob X2 | try assumption ]
          | _ => idtac
        end
    | (comp ?X1 ?X2) =>
      match goal with
        |  |- (derivable _) => intro_hyp_glob X1; intro_hyp_glob X2
        |  |- (continuity _) => intro_hyp_glob X1; intro_hyp_glob X2
        | _ => idtac
      end
    | (- ?X1)%F =>
      match goal with
        |  |- (derivable _) => intro_hyp_glob X1
        |  |- (continuity _) => intro_hyp_glob X1
        | _ => idtac
      end
    | (/ ?X1)%F =>
      let aux := constr:X1 in
        match goal with
          | _:(forall x0:R, aux x0 <> 0) |- (derivable _) =>
            intro_hyp_glob X1
          | _:(forall x0:R, aux x0 <> 0) |- (continuity _) =>
            intro_hyp_glob X1
          |  |- (derivable _) =>
            cut (forall x0:R, aux x0 <> 0);
              [ intro; intro_hyp_glob X1 | try assumption ]
          |  |- (continuity _) =>
            cut (forall x0:R, aux x0 <> 0);
              [ intro; intro_hyp_glob X1 | try assumption ]
          | _ => idtac
        end
    | cos => idtac
    | sin => idtac
    | cosh => idtac
    | sinh => idtac
    | exp => idtac
    | Rsqr => idtac
    | sqrt => idtac
    | id => idtac
    | (fct_cte _) => idtac
    | (pow_fct _) => idtac
    | Rabs => idtac
    | ?X1 =>
      let p := constr:X1 in
        match goal with
          | _:(derivable p) |- _ => idtac
          |  |- (derivable p) => idtac
          |  |- (derivable _) =>
            cut (True -> derivable p);
              [ intro HYPPD; cut (derivable p);
                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
                | idtac ]
          | _:(continuity p) |- _ => idtac
          |  |- (continuity p) => idtac
          |  |- (continuity _) =>
            cut (True -> continuity p);
              [ intro HYPPD; cut (continuity p);
                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
                | idtac ]
          | _ => idtac
        end
  end.

(**********)
Ltac intro_hyp_pt trm pt :=
  match constr:trm with
    | (?X1 + ?X2)%F =>
      match goal with
        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        |  |- (derive_pt _ _ _ = _) =>
          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        | _ => idtac
      end
    | (?X1 - ?X2)%F =>
      match goal with
        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        |  |- (derive_pt _ _ _ = _) =>
          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        | _ => idtac
      end
    | (?X1 * ?X2)%F =>
      match goal with
        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        |  |- (derive_pt _ _ _ = _) =>
          intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
        | _ => idtac
      end
    | (?X1 / ?X2)%F =>
      let aux := constr:X2 in
        match goal with
          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
            intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
            generalize (id pt); intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt
          |  |- (derivable_pt _ _) =>
            cut (aux pt <> 0);
              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
          |  |- (continuity_pt _ _) =>
            cut (aux pt <> 0);
              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
          |  |- (derive_pt _ _ _ = _) =>
            cut (aux pt <> 0);
              [ intro; intro_hyp_pt X1 pt; intro_hyp_pt X2 pt | try assumption ]
          | _ => idtac
        end
    | (comp ?X1 ?X2) =>
      match goal with
        |  |- (derivable_pt _ _) =>
          let pt_f1 := eval cbv beta in (X2 pt) in
            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
        |  |- (continuity_pt _ _) =>
          let pt_f1 := eval cbv beta in (X2 pt) in
            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
        |  |- (derive_pt _ _ _ = _) =>
          let pt_f1 := eval cbv beta in (X2 pt) in
            (intro_hyp_pt X1 pt_f1; intro_hyp_pt X2 pt)
        | _ => idtac
      end
    | (- ?X1)%F =>
      match goal with
        |  |- (derivable_pt _ _) => intro_hyp_pt X1 pt
        |  |- (continuity_pt _ _) => intro_hyp_pt X1 pt
        |  |- (derive_pt _ _ _ = _) => intro_hyp_pt X1 pt
        | _ => idtac
      end
    | (/ ?X1)%F =>
      let aux := constr:X1 in
        match goal with
          | _:(aux pt <> 0) |- (derivable_pt _ _) =>
            intro_hyp_pt X1 pt
          | _:(aux pt <> 0) |- (continuity_pt _ _) =>
            intro_hyp_pt X1 pt
          | _:(aux pt <> 0) |- (derive_pt _ _ _ = _) =>
            intro_hyp_pt X1 pt
          | id:(forall x0:R, aux x0 <> 0) |- (derivable_pt _ _) =>
            generalize (id pt); intro; intro_hyp_pt X1 pt
          | id:(forall x0:R, aux x0 <> 0) |- (continuity_pt _ _) =>
            generalize (id pt); intro; intro_hyp_pt X1 pt
          | id:(forall x0:R, aux x0 <> 0) |- (derive_pt _ _ _ = _) =>
            generalize (id pt); intro; intro_hyp_pt X1 pt
          |  |- (derivable_pt _ _) =>
            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
          |  |- (continuity_pt _ _) =>
            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
          |  |- (derive_pt _ _ _ = _) =>
            cut (aux pt <> 0); [ intro; intro_hyp_pt X1 pt | try assumption ]
          | _ => idtac
        end
    | cos => idtac
    | sin => idtac
    | cosh => idtac
    | sinh => idtac
    | exp => idtac
    | Rsqr => idtac
    | id => idtac
    | (fct_cte _) => idtac
    | (pow_fct _) => idtac
    | sqrt =>
      match goal with
        |  |- (derivable_pt _ _) => cut (0 < pt); [ intro | try assumption ]
        |  |- (continuity_pt _ _) =>
          cut (0 <= pt); [ intro | try assumption ]
        |  |- (derive_pt _ _ _ = _) =>
          cut (0 < pt); [ intro | try assumption ]
        | _ => idtac
      end
    | Rabs =>
      match goal with
        |  |- (derivable_pt _ _) =>
          cut (pt <> 0); [ intro | try assumption ]
        | _ => idtac
      end
    | ?X1 =>
      let p := constr:X1 in
        match goal with
          | _:(derivable_pt p pt) |- _ => idtac
          |  |- (derivable_pt p pt) => idtac
          |  |- (derivable_pt _ _) =>
            cut (True -> derivable_pt p pt);
              [ intro HYPPD; cut (derivable_pt p pt);
                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
                | idtac ]
          | _:(continuity_pt p pt) |- _ => idtac
          |  |- (continuity_pt p pt) => idtac
          |  |- (continuity_pt _ _) =>
            cut (True -> continuity_pt p pt);
              [ intro HYPPD; cut (continuity_pt p pt);
                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
                | idtac ]
          |  |- (derive_pt _ _ _ = _) =>
            cut (True -> derivable_pt p pt);
              [ intro HYPPD; cut (derivable_pt p pt);
                [ intro; clear HYPPD | apply HYPPD; clear HYPPD; trivial ]
                | idtac ]
          | _ => idtac
        end
  end.

(**********)
Ltac is_diff_pt :=
  match goal with
    |  |- (derivable_pt Rsqr _) =>

  (* fonctions de base *)
      apply derivable_pt_Rsqr
    |  |- (derivable_pt id ?X1) => apply (derivable_pt_id X1)
    |  |- (derivable_pt (fct_cte _) _) => apply derivable_pt_const
    |  |- (derivable_pt sin _) => apply derivable_pt_sin
    |  |- (derivable_pt cos _) => apply derivable_pt_cos
    |  |- (derivable_pt sinh _) => apply derivable_pt_sinh
    |  |- (derivable_pt cosh _) => apply derivable_pt_cosh
    |  |- (derivable_pt exp _) => apply derivable_pt_exp
    |  |- (derivable_pt (pow_fct _) _) =>
      unfold pow_fct in |- *; apply derivable_pt_pow
    |  |- (derivable_pt sqrt ?X1) =>
      apply (derivable_pt_sqrt X1);
        assumption ||
          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
            comp, id, fct_cte, pow_fct in |- *
    |  |- (derivable_pt Rabs ?X1) =>
      apply (Rderivable_pt_abs X1);
        assumption ||
          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
            comp, id, fct_cte, pow_fct in |- *
        (* regles de differentiabilite *)
        (* PLUS *)
    |  |- (derivable_pt (?X1 + ?X2) ?X3) =>
      apply (derivable_pt_plus X1 X2 X3); is_diff_pt
       (* MOINS *)
    |  |- (derivable_pt (?X1 - ?X2) ?X3) =>
      apply (derivable_pt_minus X1 X2 X3); is_diff_pt
       (* OPPOSE *)
    |  |- (derivable_pt (- ?X1) ?X2) =>
      apply (derivable_pt_opp X1 X2);
        is_diff_pt
       (* MULTIPLICATION PAR UN SCALAIRE *)
    |  |- (derivable_pt (mult_real_fct ?X1 ?X2) ?X3) =>
      apply (derivable_pt_scal X2 X1 X3); is_diff_pt
       (* MULTIPLICATION *)
    |  |- (derivable_pt (?X1 * ?X2) ?X3) =>
      apply (derivable_pt_mult X1 X2 X3); is_diff_pt
       (* DIVISION *)
    |  |- (derivable_pt (?X1 / ?X2) ?X3) =>
      apply (derivable_pt_div X1 X2 X3);
        [ is_diff_pt
          | is_diff_pt
          | try
            assumption ||
              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                comp, pow_fct, id, fct_cte in |- * ]
    |  |- (derivable_pt (/ ?X1) ?X2) =>

       (* INVERSION *)
      apply (derivable_pt_inv X1 X2);
        [ assumption ||
          unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
            comp, pow_fct, id, fct_cte in |- *
          | is_diff_pt ]
    |  |- (derivable_pt (comp ?X1 ?X2) ?X3) =>

       (* COMPOSITION *)
      apply (derivable_pt_comp X2 X1 X3); is_diff_pt
    | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) =>
      assumption
    | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) =>
      cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ]
    |  |- (True -> derivable_pt _ _) =>
      intro HypTruE; clear HypTruE; is_diff_pt
    | _ =>
      try
        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
          fct_cte, comp, pow_fct in |- *
  end.

(**********)
Ltac is_diff_glob :=
  match goal with
    |  |- (derivable Rsqr) =>
  (* fonctions de base *)
      apply derivable_Rsqr
    |  |- (derivable id) => apply derivable_id
    |  |- (derivable (fct_cte _)) => apply derivable_const
    |  |- (derivable sin) => apply derivable_sin
    |  |- (derivable cos) => apply derivable_cos
    |  |- (derivable cosh) => apply derivable_cosh
    |  |- (derivable sinh) => apply derivable_sinh
    |  |- (derivable exp) => apply derivable_exp
    |  |- (derivable (pow_fct _)) =>
      unfold pow_fct in |- *;
        apply derivable_pow
        (* regles de differentiabilite *)
        (* PLUS *)
    |  |- (derivable (?X1 + ?X2)) =>
      apply (derivable_plus X1 X2); is_diff_glob
       (* MOINS *)
    |  |- (derivable (?X1 - ?X2)) =>
      apply (derivable_minus X1 X2); is_diff_glob
       (* OPPOSE *)
    |  |- (derivable (- ?X1)) =>
      apply (derivable_opp X1);
        is_diff_glob
       (* MULTIPLICATION PAR UN SCALAIRE *)
    |  |- (derivable (mult_real_fct ?X1 ?X2)) =>
      apply (derivable_scal X2 X1); is_diff_glob
       (* MULTIPLICATION *)
    |  |- (derivable (?X1 * ?X2)) =>
      apply (derivable_mult X1 X2); is_diff_glob
       (* DIVISION *)
    |  |- (derivable (?X1 / ?X2)) =>
      apply (derivable_div X1 X2);
        [ is_diff_glob
          | is_diff_glob
          | try
            assumption ||
              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                id, fct_cte, comp, pow_fct in |- * ]
    |  |- (derivable (/ ?X1)) =>

       (* INVERSION *)
      apply (derivable_inv X1);
        [ try
          assumption ||
            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
              id, fct_cte, comp, pow_fct in |- *
          | is_diff_glob ]
    |  |- (derivable (comp sqrt _)) =>

       (* COMPOSITION *)
      unfold derivable in |- *; intro; try is_diff_pt
    |  |- (derivable (comp Rabs _)) =>
      unfold derivable in |- *; intro; try is_diff_pt
    |  |- (derivable (comp ?X1 ?X2)) =>
      apply (derivable_comp X2 X1); is_diff_glob
    | _:(derivable ?X1) |- (derivable ?X1) => assumption
    |  |- (True -> derivable _) =>
      intro HypTruE; clear HypTruE; is_diff_glob
    | _ =>
      try
        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
          fct_cte, comp, pow_fct in |- *
  end.

(**********)
Ltac is_cont_pt :=
  match goal with
    |  |- (continuity_pt Rsqr _) =>

       (* fonctions de base *)
      apply derivable_continuous_pt; apply derivable_pt_Rsqr
    |  |- (continuity_pt id ?X1) =>
      apply derivable_continuous_pt; apply (derivable_pt_id X1)
    |  |- (continuity_pt (fct_cte _) _) =>
      apply derivable_continuous_pt; apply derivable_pt_const
    |  |- (continuity_pt sin _) =>
      apply derivable_continuous_pt; apply derivable_pt_sin
    |  |- (continuity_pt cos _) =>
      apply derivable_continuous_pt; apply derivable_pt_cos
    |  |- (continuity_pt sinh _) =>
      apply derivable_continuous_pt; apply derivable_pt_sinh
    |  |- (continuity_pt cosh _) =>
      apply derivable_continuous_pt; apply derivable_pt_cosh
    |  |- (continuity_pt exp _) =>
      apply derivable_continuous_pt; apply derivable_pt_exp
    |  |- (continuity_pt (pow_fct _) _) =>
      unfold pow_fct in |- *; apply derivable_continuous_pt;
        apply derivable_pt_pow
    |  |- (continuity_pt sqrt ?X1) =>
      apply continuity_pt_sqrt;
        assumption ||
          unfold plus_fct, minus_fct, opp_fct, mult_fct, div_fct, inv_fct,
            comp, id, fct_cte, pow_fct in |- *
    |  |- (continuity_pt Rabs ?X1) =>
      apply (Rcontinuity_abs X1)
       (* regles de differentiabilite *)
       (* PLUS *)
    |  |- (continuity_pt (?X1 + ?X2) ?X3) =>
      apply (continuity_pt_plus X1 X2 X3); is_cont_pt
       (* MOINS *)
    |  |- (continuity_pt (?X1 - ?X2) ?X3) =>
      apply (continuity_pt_minus X1 X2 X3); is_cont_pt
       (* OPPOSE *)
    |  |- (continuity_pt (- ?X1) ?X2) =>
      apply (continuity_pt_opp X1 X2);
        is_cont_pt
       (* MULTIPLICATION PAR UN SCALAIRE *)
    |  |- (continuity_pt (mult_real_fct ?X1 ?X2) ?X3) =>
      apply (continuity_pt_scal X2 X1 X3); is_cont_pt
       (* MULTIPLICATION *)
    |  |- (continuity_pt (?X1 * ?X2) ?X3) =>
      apply (continuity_pt_mult X1 X2 X3); is_cont_pt
       (* DIVISION *)
    |  |- (continuity_pt (?X1 / ?X2) ?X3) =>
      apply (continuity_pt_div X1 X2 X3);
        [ is_cont_pt
          | is_cont_pt
          | try
            assumption ||
              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                comp, id, fct_cte, pow_fct in |- * ]
    |  |- (continuity_pt (/ ?X1) ?X2) =>

       (* INVERSION *)
      apply (continuity_pt_inv X1 X2);
        [ is_cont_pt
          | assumption ||
            unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
              comp, id, fct_cte, pow_fct in |- * ]
    |  |- (continuity_pt (comp ?X1 ?X2) ?X3) =>

       (* COMPOSITION *)
      apply (continuity_pt_comp X2 X1 X3); is_cont_pt
    | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
      assumption
    | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) =>
      cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ]
    | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) =>
      apply derivable_continuous_pt; assumption
    | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) =>
      cut (continuity X1);
        [ intro HypDDPT; apply HypDDPT
          | apply derivable_continuous; assumption ]
    |  |- (True -> continuity_pt _ _) =>
      intro HypTruE; clear HypTruE; is_cont_pt
    | _ =>
      try
        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
          fct_cte, comp, pow_fct in |- *
  end.

(**********)
Ltac is_cont_glob :=
  match goal with
    |  |- (continuity Rsqr) =>

       (* fonctions de base *)
      apply derivable_continuous; apply derivable_Rsqr
    |  |- (continuity id) => apply derivable_continuous; apply derivable_id
    |  |- (continuity (fct_cte _)) =>
      apply derivable_continuous; apply derivable_const
    |  |- (continuity sin) => apply derivable_continuous; apply derivable_sin
    |  |- (continuity cos) => apply derivable_continuous; apply derivable_cos
    |  |- (continuity exp) => apply derivable_continuous; apply derivable_exp
    |  |- (continuity (pow_fct _)) =>
      unfold pow_fct in |- *; apply derivable_continuous; apply derivable_pow
    |  |- (continuity sinh) =>
      apply derivable_continuous; apply derivable_sinh
    |  |- (continuity cosh) =>
      apply derivable_continuous; apply derivable_cosh
    |  |- (continuity Rabs) =>
      apply Rcontinuity_abs
       (* regles de continuite *)
       (* PLUS *)
    |  |- (continuity (?X1 + ?X2)) =>
      apply (continuity_plus X1 X2);
        try is_cont_glob || assumption
            (* MOINS *)
    |  |- (continuity (?X1 - ?X2)) =>
      apply (continuity_minus X1 X2);
        try is_cont_glob || assumption
            (* OPPOSE *)
    |  |- (continuity (- ?X1)) =>
      apply (continuity_opp X1); try is_cont_glob || assumption
                                      (* INVERSE *)
    |  |- (continuity (/ ?X1)) =>
      apply (continuity_inv X1);
        try is_cont_glob || assumption
            (* MULTIPLICATION PAR UN SCALAIRE *)
    |  |- (continuity (mult_real_fct ?X1 ?X2)) =>
      apply (continuity_scal X2 X1);
        try is_cont_glob || assumption
            (* MULTIPLICATION *)
    |  |- (continuity (?X1 * ?X2)) =>
      apply (continuity_mult X1 X2);
        try is_cont_glob || assumption
            (* DIVISION *)
    |  |- (continuity (?X1 / ?X2)) =>
      apply (continuity_div X1 X2);
        [ try is_cont_glob || assumption
          | try is_cont_glob || assumption
          | try
            assumption ||
              unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct,
                id, fct_cte, pow_fct in |- * ]
    |  |- (continuity (comp sqrt _)) =>

       (* COMPOSITION *)
      unfold continuity_pt in |- *; intro; try is_cont_pt
    |  |- (continuity (comp ?X1 ?X2)) =>
      apply (continuity_comp X2 X1); try is_cont_glob || assumption
    | _:(continuity ?X1) |- (continuity ?X1) => assumption
    |  |- (True -> continuity _) =>
      intro HypTruE; clear HypTruE; is_cont_glob
    | _:(derivable ?X1) |- (continuity ?X1) =>
      apply derivable_continuous; assumption
    | _ =>
      try
        unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id,
          fct_cte, comp, pow_fct in |- *
  end.

(**********)
Ltac rew_term trm :=
  match constr:trm with
    | (?X1 + ?X2) =>
      let p1 := rew_term X1 with p2 := rew_term X2 in
        match constr:p1 with
          | (fct_cte ?X3) =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(fct_cte (X3 + X4))
              | _ => constr:(p1 + p2)%F
            end
          | _ => constr:(p1 + p2)%F
        end
    | (?X1 - ?X2) =>
      let p1 := rew_term X1 with p2 := rew_term X2 in
        match constr:p1 with
          | (fct_cte ?X3) =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(fct_cte (X3 - X4))
              | _ => constr:(p1 - p2)%F
            end
          | _ => constr:(p1 - p2)%F
        end
    | (?X1 / ?X2) =>
      let p1 := rew_term X1 with p2 := rew_term X2 in
        match constr:p1 with
          | (fct_cte ?X3) =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
              | _ => constr:(p1 / p2)%F
            end
          | _ =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
              | _ => constr:(p1 / p2)%F
            end
        end
    | (?X1 * / ?X2) =>
      let p1 := rew_term X1 with p2 := rew_term X2 in
        match constr:p1 with
          | (fct_cte ?X3) =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(fct_cte (X3 / X4))
              | _ => constr:(p1 / p2)%F
            end
          | _ =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(p1 * fct_cte (/ X4))%F
              | _ => constr:(p1 / p2)%F
            end
        end
    | (?X1 * ?X2) =>
      let p1 := rew_term X1 with p2 := rew_term X2 in
        match constr:p1 with
          | (fct_cte ?X3) =>
            match constr:p2 with
              | (fct_cte ?X4) => constr:(fct_cte (X3 * X4))
              | _ => constr:(p1 * p2)%F
            end
          | _ => constr:(p1 * p2)%F
        end
    | (- ?X1) =>
      let p := rew_term X1 in
        match constr:p with
          | (fct_cte ?X2) => constr:(fct_cte (- X2))
          | _ => constr:(- p)%F
        end
    | (/ ?X1) =>
      let p := rew_term X1 in
        match constr:p with
          | (fct_cte ?X2) => constr:(fct_cte (/ X2))
          | _ => constr:(/ p)%F
        end
    | (?X1 AppVar) => constr:X1
    | (?X1 ?X2) =>
      let p := rew_term X2 in
        match constr:p with
          | (fct_cte ?X3) => constr:(fct_cte (X1 X3))
          | _ => constr:(comp X1 p)
        end
    | AppVar => constr:id
    | (AppVar ^ ?X1) => constr:(pow_fct X1)
    | (?X1 ^ ?X2) =>
      let p := rew_term X1 in
        match constr:p with
          | (fct_cte ?X3) => constr:(fct_cte (pow_fct X2 X3))
          | _ => constr:(comp (pow_fct X2) p)
        end
    | ?X1 => constr:(fct_cte X1)
  end.

(**********)
Ltac deriv_proof trm pt :=
  match constr:trm with
    | (?X1 + ?X2)%F =>
      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
        constr:(derivable_pt_plus X1 X2 pt p1 p2)
    | (?X1 - ?X2)%F =>
      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
        constr:(derivable_pt_minus X1 X2 pt p1 p2)
    | (?X1 * ?X2)%F =>
      let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
        constr:(derivable_pt_mult X1 X2 pt p1 p2)
    | (?X1 / ?X2)%F =>
      match goal with
        | id:(?X2 pt <> 0) |- _ =>
          let p1 := deriv_proof X1 pt with p2 := deriv_proof X2 pt in
            constr:(derivable_pt_div X1 X2 pt p1 p2 id)
        | _ => constr:False
      end
    | (/ ?X1)%F =>
      match goal with
        | id:(?X1 pt <> 0) |- _ =>
          let p1 := deriv_proof X1 pt in
            constr:(derivable_pt_inv X1 pt p1 id)
        | _ => constr:False
      end
    | (comp ?X1 ?X2) =>
      let pt_f1 := eval cbv beta in (X2 pt) in
        let p1 := deriv_proof X1 pt_f1 with p2 := deriv_proof X2 pt in
          constr:(derivable_pt_comp X2 X1 pt p2 p1)
    | (- ?X1)%F =>
      let p1 := deriv_proof X1 pt in
        constr:(derivable_pt_opp X1 pt p1)
    | sin => constr:(derivable_pt_sin pt)
    | cos => constr:(derivable_pt_cos pt)
    | sinh => constr:(derivable_pt_sinh pt)
    | cosh => constr:(derivable_pt_cosh pt)
    | exp => constr:(derivable_pt_exp pt)
    | id => constr:(derivable_pt_id pt)
    | Rsqr => constr:(derivable_pt_Rsqr pt)
    | sqrt =>
      match goal with
        | id:(0 < pt) |- _ => constr:(derivable_pt_sqrt pt id)
        | _ => constr:False
      end
    | (fct_cte ?X1) => constr:(derivable_pt_const X1 pt)
    | ?X1 =>
      let aux := constr:X1 in
        match goal with
          | id:(derivable_pt aux pt) |- _ => constr:id
          | id:(derivable aux) |- _ => constr:(id pt)
          | _ => constr:False
        end
  end.

(**********)
Ltac simplify_derive trm pt :=
  match constr:trm with
    | (?X1 + ?X2)%F =>
      try rewrite derive_pt_plus; simplify_derive X1 pt;
        simplify_derive X2 pt
    | (?X1 - ?X2)%F =>
      try rewrite derive_pt_minus; simplify_derive X1 pt;
        simplify_derive X2 pt
    | (?X1 * ?X2)%F =>
      try rewrite derive_pt_mult; simplify_derive X1 pt;
        simplify_derive X2 pt
    | (?X1 / ?X2)%F =>
      try rewrite derive_pt_div; simplify_derive X1 pt; simplify_derive X2 pt
    | (comp ?X1 ?X2) =>
      let pt_f1 := eval cbv beta in (X2 pt) in
        (try rewrite derive_pt_comp; simplify_derive X1 pt_f1;
          simplify_derive X2 pt)
    | (- ?X1)%F => try rewrite derive_pt_opp; simplify_derive X1 pt
    | (/ ?X1)%F =>
      try rewrite derive_pt_inv; simplify_derive X1 pt
    | (fct_cte ?X1) => try rewrite derive_pt_const
    | id => try rewrite derive_pt_id
    | sin => try rewrite derive_pt_sin
    | cos => try rewrite derive_pt_cos
    | sinh => try rewrite derive_pt_sinh
    | cosh => try rewrite derive_pt_cosh
    | exp => try rewrite derive_pt_exp
    | Rsqr => try rewrite derive_pt_Rsqr
    | sqrt => try rewrite derive_pt_sqrt
    | ?X1 =>
      let aux := constr:X1 in
        match goal with
          | id:(derive_pt aux pt ?X2 = _),H:(derivable aux) |- _ =>
            try replace (derive_pt aux pt (H pt)) with (derive_pt aux pt X2);
              [ rewrite id | apply pr_nu ]
          | id:(derive_pt aux pt ?X2 = _),H:(derivable_pt aux pt) |- _ =>
            try replace (derive_pt aux pt H) with (derive_pt aux pt X2);
              [ rewrite id | apply pr_nu ]
          | _ => idtac
        end
    | _ => idtac
  end.

(**********)
Ltac reg :=
  match goal with
    |  |- (derivable_pt ?X1 ?X2) =>
      let trm := eval cbv beta in (X1 AppVar) in
        let aux := rew_term trm in
          (intro_hyp_pt aux X2;
            try (change (derivable_pt aux X2) in |- *; is_diff_pt) || is_diff_pt)
    |  |- (derivable ?X1) =>
      let trm := eval cbv beta in (X1 AppVar) in
        let aux := rew_term trm in
          (intro_hyp_glob aux;
            try (change (derivable aux) in |- *; is_diff_glob) || is_diff_glob)
    |  |- (continuity ?X1) =>
      let trm := eval cbv beta in (X1 AppVar) in
        let aux := rew_term trm in
          (intro_hyp_glob aux;
            try (change (continuity aux) in |- *; is_cont_glob) || is_cont_glob)
    |  |- (continuity_pt ?X1 ?X2) =>
      let trm := eval cbv beta in (X1 AppVar) in
        let aux := rew_term trm in
          (intro_hyp_pt aux X2;
            try (change (continuity_pt aux X2) in |- *; is_cont_pt) || is_cont_pt)
    |  |- (derive_pt ?X1 ?X2 ?X3 = ?X4) =>
      let trm := eval cbv beta in (X1 AppVar) in
      let aux := rew_term trm in
      intro_hyp_pt aux X2;
      (let aux2 := deriv_proof aux X2 in
       try
         (replace (derive_pt X1 X2 X3) with (derive_pt aux X2 aux2);
           [ simplify_derive aux X2;
             try unfold plus_fct, minus_fct, mult_fct, div_fct, id, fct_cte,
                        inv_fct, opp_fct in |- *; ring || ring_simplify
           | try apply pr_nu ]) || is_diff_pt)
  end.


Require Import Coq.Structures.Orders.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.Strings.Ascii Coq.Strings.String.
Require Import Coq.Arith.Arith.
Require Import Coq.NArith.NArith.
Require Export Crypto.Util.FixCoqMistakes.

(** This should disappear whenever we bump the minimum version to a version where https://github.com/coq/coq/pull/14096 has been merged *)

Module Ascii_as_OT <: UsualOrderedType.
  Definition t := ascii.
  Include HasUsualEq <+ UsualIsEq.
  Definition eqb := Ascii.eqb.
  Definition eqb_eq := Ascii.eqb_eq.
  Include HasEqBool2Dec.

  Definition compare (a b : ascii) := N_as_OT.compare (N_of_ascii a) (N_of_ascii b).
  Definition lt (a b : ascii) := N_as_OT.lt (N_of_ascii a) (N_of_ascii b).

#[global]
  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
    intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
  Qed.

#[global]
  Instance lt_strorder : StrictOrder lt.
  Proof.
    split; unfold lt; [ intro | intros ??? ]; eapply N_as_OT.lt_strorder.
  Qed.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
    intros x y; unfold eq, lt, compare.
    destruct (N_as_OT.compare_spec (N_of_ascii x) (N_of_ascii y)) as [H|H|H]; constructor; try assumption.
    now rewrite <- (ascii_N_embedding x), <- (ascii_N_embedding y), H.
  Qed.
End Ascii_as_OT.

(** [String] is an ordered type with respect to the usual lexical order. *)

Module String_as_OT <: UsualOrderedType.
  Definition t := string.
  Include HasUsualEq <+ UsualIsEq.
  Definition eqb := String.eqb.
  Definition eqb_eq := String.eqb_eq.
  Include HasEqBool2Dec.

  Fixpoint compare (a b : string)
    := match a, b with
       | EmptyString, EmptyString => Eq
       | EmptyString, _ => Lt
       | String _ _, EmptyString => Gt
       | String a_head a_tail, String b_head b_tail =>
         match Ascii_as_OT.compare a_head b_head with
         | Lt => Lt
         | Gt => Gt
         | Eq => compare a_tail b_tail
         end
       end.

  Definition lt (a b : string) := compare a b = Lt.

#[global]
  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
    intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
  Qed.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
    unfold eq, lt.
    induction x as [|x xs IHxs], y as [|y ys]; cbn [compare]; try constructor; cbn [compare]; try reflexivity.
    specialize (IHxs ys).
    destruct (Ascii_as_OT.compare x y) eqn:H; [ destruct IHxs; constructor | constructor | constructor ]; cbn [compare].
    all: destruct (Ascii_as_OT.compare_spec y x), (Ascii_as_OT.compare_spec x y); cbv [Ascii_as_OT.eq] in *; try congruence; subst.
    all: exfalso; eapply irreflexivity; (idtac + etransitivity); eassumption.
  Qed.

#[global]
  Instance lt_strorder : StrictOrder lt.
  Proof.
    split; unfold lt; [ intro x | intros x y z ]; unfold complement.
    { induction x as [|x xs IHxs]; cbn [compare]; [ congruence | ].
      destruct (Ascii_as_OT.compare x x) eqn:H; try congruence.
      exfalso; eapply irreflexivity; eassumption. }
    { revert x y z.
      induction x as [|x xs IHxs], y as [|y ys], z as [|z zs]; cbn [compare]; try congruence.
      specialize (IHxs ys zs).
      destruct (Ascii_as_OT.compare x y) eqn:Hxy, (Ascii_as_OT.compare y z) eqn:Hyz, (Ascii_as_OT.compare x z) eqn:Hxz;
        try intuition (congruence || eauto).
      all: destruct (Ascii_as_OT.compare_spec x y), (Ascii_as_OT.compare_spec y z), (Ascii_as_OT.compare_spec x z);
        try discriminate.
      all: unfold Ascii_as_OT.eq in *; subst.
      all: exfalso; eapply irreflexivity; (idtac + etransitivity); (idtac + etransitivity); eassumption. }
  Qed.
End String_as_OT.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^322 - 2^161 - 1
Base: 46
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 46;
    bitwidth := 64;
    s := 2^322;
    c := [(1, 1); (2^161, 1)];
    carry_chains := Some [[2; 6]; [3; 0; 4; 1; 5; 2; 6]; [3; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From mathcomp
Require Import all_ssreflect.

From chip
Require Import extra connect acyclic closure check change hierarchical hierarchical_sub.

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

Section HierarchicalSubPt.

Variable (A_top : eqType) (A_bot : eqType).

Variable (U' : finType) (V' : finType).

Variable (f'_top : U' -> A_top) (f'_bot : V' -> A_bot).

Variable (P_top : pred U') (P_bot : pred V').

Local Notation U := (sig_finType P_top).

Local Notation V := (sig_finType P_bot).

Variable (g_top : rel U) (g_bot : rel V).

Local Notation g_top_rev := [rel x y | g_top y x].

Local Notation g_bot_rev := [rel x y | g_bot y x].

Variable (f_top : U -> A_top) (f_bot : V -> A_bot).

Variable (checkable : pred V').

Variable (R : eqType).

Variable (check : V' -> R).

Variables (p : U -> {set V}) (p' : U' -> {set V'}).

Hypothesis p_neq : forall (u u' : U), u <> u' -> p u <> p u'.

Hypothesis p_partition : partition (\bigcup_( u | u \in U ) [set p u]) [set: V].

Hypothesis p'_partition : partition (\bigcup_( u | u \in U' ) [set p' u]) [set: V'].

Hypothesis g_bot_top : forall (v v' : V) (u u' : U),
 u <> u' -> g_bot v v' -> v \in p u -> v' \in p u' -> g_top u u'.

Hypothesis f_top_bot : forall (u : U),
 f_top u = f'_top (val u) -> forall (v : V), v \in p u -> f_bot v = f'_bot (val v).

Hypothesis f_top_partition : forall (u : U),
 f_top u = f'_top (val u) -> [set val v | v in p u] = p' (val u).

Local Notation V_sub := ((sig_finType P_V_sub) : finType).

Local Notation g_bot_sub := ([rel x y : V_sub | g_bot (val x) (val y)] : rel V_sub).

Definition pfreshV' := \bigcup_(u | u \in freshV' P_top) (p' u) :|: \bigcup_(u | u \in modifiedV f'_top f_top) (p' (val u)).

Definition freshV'_sub : {set V'} := [set v in pfreshV' | ~~ P_bot v].

Definition impactedV'_sub_pt := impactedVV'_sub f'_top f'_bot g_top g_bot f_top f_bot p :|: freshV'_sub.

Lemma pfreshV'_in_freshV' : forall v,
  v \in freshV' P_bot ->
  v \in pfreshV'.
Proof.
move => v; rewrite in_set => Hv.
apply/setUP.
have Hp := p'_partition.
move/andP: Hp => [Hc Hp].
move/andP: Hp => [Htr H0].
move: Hc.
rewrite /cover.
move/eqP => Hc.
have Hvv: v \in \bigcup_(B in \bigcup_(u in U') [set p' u]) B by rewrite Hc.
move/bigcupP: Hvv => [vs Hvv] Hvs.
move/bigcupP: Hvv => [u Hu] Huvs.
move: Huvs Hvs.
rewrite inE.
move/eqP =>-> Hv'.
have H_sp := (insubP [subType of U] u).
destruct H_sp; last by left; apply/bigcupP; exists u => //; rewrite inE.
right; apply/bigcupP; exists u0; last by rewrite e.
rewrite inE.
apply/negP.
move/eqP/f_top_partition => Hf.
move: Hf Hv'.
rewrite e =><-.
move/imsetP => [x Hx] Hpx.
move: Hv.
rewrite Hpx => Hv.
case/negP: Hv.
exact: valP.
Qed.

Lemma freshV'_sub_eq :
  freshV'_sub = freshV' P_bot.
Proof.
apply/setP => x.
apply/idP/idP.
- rewrite inE.
  move/andP => [Hp Hpb].
  by rewrite inE.
- rewrite inE => Hf.
  rewrite inE.
  apply/andP; split => //.
  apply/pfreshV'_in_freshV'.
  by rewrite inE.
Qed.

Lemma impactedV'_sub_pt_eq :
  impactedV'_sub_pt = impactedV' f'_bot f_bot g_bot.
Proof.
rewrite /impactedV'_sub_pt.
rewrite impactedVV'_sub_eq //.
by rewrite freshV'_sub_eq.
Qed.

Definition checkable_impactedV'_sub_pt :=
 [set v in impactedV'_sub_pt | checkable v].

Definition checkable_impacted_fresh_sub_pt : seq V' :=
 enum checkable_impactedV'_sub_pt.

Definition check_impactedV'_sub_pt_cert :=
 [seq (v, check v) | v <- checkable_impacted_fresh_sub_pt].

End HierarchicalSubPt.


Add LoadPath "../from_compcert".
Require Import Libs.
Require Import Errors.
Require Import Polyhedra.
Require Import Loops.
Require Import Memory.
Require Import ArithClasses.
Require Import Permutation.
Require Import Sorted.
Require Import Instructions.
Require Import Bounds.
Require Import BoxedPolyhedra.
Require Import Psatz.
Require Import PolyBase.
Require Import PLang.
Require Import TimeStamp.
Require Import ExtractPoly.
Require Import Do_notation.
Require Import PermutInstrs.
Require Import Tilling.
Require Import SimpleLanguage.
Open Scope string_scope.
(*Set Implicit Arguments.*)
Open Scope Z_scope.

Module Validator (Import M:BASEMEM(ZNum))
  (I:INSTRS(ZNum) with Definition Value := M.Value).
  Module Mem := MEMORY(ZNum)(M).
  Import Mem.

  Module Per := Permut(M)(I).
  Import Per.
  Import Til.
  Import EP.
  Import P. Import T. Import L.

  Definition optimize
    (blackbox: Poly_Program ->
      res ((list (list (positive * nat))) * list (list (list Z))))
    (prog:Program) : res Poly_Program :=
    do{;
      unopt_pprog <- extract_program prog;;
      tilling_info, new_schedule <- blackbox unopt_pprog;;
      tilled_pprog <- res_of_option (mk_tilled_poly_prog unopt_pprog tilling_info)
        "The tilling failed";
      change_schedule tilled_pprog new_schedule
      }.

  Theorem preservation: forall lprog pprog blackbox,
    optimize blackbox lprog = OK pprog ->
    forall args,
      forall mem1 mem2,
        program_semantics lprog args mem1 mem2 ->
        (exists mem2', poly_program_semantics pprog args mem1 mem2') /\
        (forall mem2', poly_program_semantics pprog args mem1 mem2' -> mem2 ≡ mem2').
  Proof.
    intros.
    unfold optimize in H. prog_dos.
    destruct _XY_ as (tilling_info, new_schedule).
    prog_dos.
    pose proof (extract_program_correct _ _ Heq_do args mem1 mem2 X).
    clear Heq_do X.
    rewrite (mk_tilled_poly_prog_ok _ _ _ Heq_do1) in H0.
    eapply change_schedule_OK; eauto.
  Qed.

End Validator.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e194m33_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 lv0)).
Admitted.
QuickChick conj3synthconj4.