(**

Author: Perry Alexander and Alessandro Coglio

This file contains a Coq model of "perfect" crypto adapted from a PVS
model [6] developed by Alessandro Coglio.

By perfect crypto we mean functions that provide absolute instead of
high-probability guarantees for cryptographic properties.  Specifically:

- Keys cannot be guessed.  Encryption and decrytption, signing and
  verifying signatures only works if the appropriate key is known.
- Hashes are collision-free, injective functions

The model incudes:

- Structured data that includes explicit uses of crypto functions
- Analysis functions for structured data (decryption)
- Synthesis functions for structured data (encryption)

This approach is used in the inductive approach to verifying cryptographic
protocols [1] as well as in the model checking of cryptographic progocols
[2].  The analysis and synthesis functions on structured data correspond
to the Dolev-Yao attacker model [3].  The inductive approach to verifying
cryptographic protocols [1] was originally developed for the Isabelle/HOL
theorem prover.  This Coq theory is similar to [4] and derived from a PVS
model [6].

References:

[1] Lawrence Paulson,
    "The Inductive Approach to Verifying Cryptographic Protocols",
    Journal of Computer Security, 6 (1998), pages 85-128.

[2] David Basin, Cas Cremers, Catherine Meadows,
    "Model Checking Security Protocols",
    Chapter 24 of Handbook of Model Checking (Springer), to appear.

[3] Danny Dolev, Andrew Yao,
    "On the Security of Public Key Protocols",
    IEEE Transactions on Information Theory, Vol. IT-29, No. 2, 1983.

[4] Lawrence Paulson,
    "HOL/Auth/Message" theory in the Isabelle 2013-2 library
    (http://isabelle.in.tum.de).

[5] Veronique Cortier, Stephanie Delaune, Pascal Lafourcade,
    "A Survey of Algebraic Properties Used in Cryptographic Protocols",
     Journal of Computer Security, 14-1 (2006), pages 1-43.

[6] PVS model here

*)

Require Import Arith.
Require Import Relations.
Require Export List.
Require Export Lists.ListTactics.

Create HintDb crypto.

Inductive key: Set :=
| symmetric : nat -> key
| private : nat -> key
| public : nat -> key.

Theorem key_decidable (k0 k1: key):
  { k0 = k1 }+{ k0 <> k1 }.
Proof.
  destruct k0 as [n0 | n0 | n0], k1 as [n1 | n1 | n1];
    try (right; discriminate);
    case (Nat.eq_dec n0 n1);
    try (intros ->; left; reflexivity);
    intros Hneq; right; injection;
    contradiction.
Qed.

Definition eqb_key (k0 k1: key): bool :=
  match k0, k1 with
  | symmetric n0, symmetric n1 => Nat.eqb n0 n1
  | private n0, private n1 => Nat.eqb n0 n1
  | public n0, public n1 => Nat.eqb n0 n1
  | _, _ => false
  end.

Theorem key_eqb_eq (k0 k1: key):
  eqb_key k0 k1 = true <-> k0 = k1.
Proof.
  split; [intros Hb | intros <-].
  { destruct k0 as [n0 | n0 | n0],
      k1 as [n1 | n1 | n1];
      simpl in Hb; try (discriminate Hb);
      rewrite Nat.eqb_eq in Hb;
      subst; reflexivity. }
  { destruct k0 as [n0 | n0 | n0]; simpl;
      rewrite Nat.eqb_eq;
      reflexivity. }
Qed.

Definition kinverse (k: key): key :=
  match k with
    | symmetric _ => k
    | private k' => (public k')
    | public k' => (private k')
  end.

  Lemma kinverse_inverse (k: key):
  kinverse (kinverse k) = k.
Proof.
  destruct k as [n | n | n];
    cbv;
    reflexivity.
Qed.

#[global]
Hint Resolve kinverse_inverse: crypto.

Lemma kinverse_injective (k1 k2: key):
  kinverse k1 = kinverse k2 ->
  k1 = k2.
Proof.
  intros Hinv.
  rewrite <- kinverse_inverse.
  rewrite <- Hinv.
  rewrite kinverse_inverse.
  reflexivity.
Qed.

#[global]
Hint Resolve kinverse_injective: crypto.

Lemma kinverse_surjective (k1: key):
  exists (k2: key), kinverse k2 = k1.
Proof.
  exists (kinverse k1).
  apply kinverse_inverse.
Qed.

#[global]
Hint Resolve kinverse_surjective: crypto.

Lemma kinverse_bijective :
  (forall (k1 k2: key),
    kinverse k1 = kinverse k2 ->
    k1 = k2)
  /\ (forall (k1: key),
    exists (k2: key), kinverse k2 = k1).
Proof.
  split;
    [ apply kinverse_injective
    | apply kinverse_surjective].
Qed.

Inductive data (T: Type): Type :=
| value : T -> data T
| kval : key -> data T
| kapply : key -> data T -> data T
| hash : data T -> data T
| pair : data T -> data T -> data T.

Arguments value {T} _.
Arguments kval {T} _.
Arguments kapply {T} _ _.
Arguments hash {T} _.
Arguments pair {T} _ _.

Definition sign {T: Type}(d: data T)(k: key): data T :=
  pair d (kapply k (hash d)).

Definition check {T: Type}(d: data T)(k: key): Prop :=
  match d with
  | pair d' s' =>
    match s' with
    | kapply k' s'' =>
      k = kinverse k' /\ s'' = hash d'
    | _ => False
    end
  | _ => False
  end.

(** Verify signature checking and signing *)

Theorem sig_check {T: Type}(d: data T)(k1 k2: key):
  k1 = kinverse k2 ->
  check (sign (value d) k1) k2.
Proof.
  intros H.
  subst.
  firstorder.
  auto with crypto.
Qed.

Theorem sign_only {T: Type}(d0: data T)(k0: key):
  check d0 k0 ->
  exists (d1: data T)(k1: key),
    sign d1 k1 = d0 /\ k0 = kinverse k1.
Proof.
  destruct d0 as [t0 | k0' | k0' d0' | d0' | d0_0 d0_1];
    unfold check; try contradiction.
  destruct d0_1 as [t0 | k0' | k0' d0_1' | d0_1' | d0_1_0 d0_1_1];
    unfold check; try contradiction.
  intros [-> ->].
  exists d0_0; exists k0'.
  split; trivial.
Qed.

(** I would prefer using sets here, but will use lists to take advantage
  of structured mechanisms for traversal *)

(** [recoverable0] takes a data element [d] and appends a list of new data
  that is recoverable from [d] to [d]. *)

Fixpoint recoverable0 {T: Type}(d: data T): list (data T) :=
  cons d (match d with
    | kapply _ d => recoverable0 d
    | pair d1 d2 => app (recoverable0 d1) (recoverable0 d2)
    | _ => nil
    end).

(** [recoverable] takes a list of data [dset] and walks the list with
  [recoverable0] to create a list of all data recoverable from the list
  of data.  This is effectively a fold of [recoverable0] over the input
  [dset] *)

Fixpoint recoverable {T: Type}(dset: list (data T)): list (data T) :=
  match dset with
  | nil => nil
  | cons h t => app (recoverable0 h) (recoverable t)
  end.

(** This is dorky *)

Theorem recoverable_from_single {T: Type}(d: data T)(dset: list (data T)):
  In d (recoverable dset) ->
  exists (d0: data T), In d (recoverable0 d0).
Proof.
  intros.
  exists d.
  destruct d;
    simpl;
    tauto.
Qed.

(* Hint Resolve app_nil_r. *)

Theorem recoverable_single {T: Type}(d: data T):
  recoverable (cons d nil) = recoverable0 d.
Proof.
  intros.
  simpl.
  apply app_nil_r.
Qed.

(* Theorem recoverable_subterm: forall d dset, In d (recoverable dset) -> exists d0 *)
Lemma recoverable0_self {T: Type}(d: data T):
  In d (recoverable0 d).
Proof.
  destruct d; simpl;
  left; reflexivity.
Qed.

Lemma recoverable0_kapply {T: Type}(k: key)(d0 d1: data T):
  In (kapply k d0) (recoverable0 d1) ->
  In d0 (recoverable0 d1).
Proof.
  generalize dependent d0.
  induction d1; simpl;
    intros d0 [H | H];
    try contradiction;
    try (inversion H; fail).
  { inversion H; subst; clear H.
    right.
    apply recoverable0_self. }
  { right. apply IHd1; apply H. }
  { right. apply in_app_or in H.
    inversion_clear H as [H1 | H2];
    apply in_or_app.
    { apply IHd1_1 in H1.
      left; trivial. }
    { apply IHd1_2 in H2.
      right; trivial. } }
Qed.

Lemma recoverable0_pair {T: Type}(d0 d1 d2: data T):
  In (pair d0 d1) (recoverable0 d2) ->
  In d0 (recoverable0 d2) /\ In d1 (recoverable0 d2).
Proof.
  induction d2; simpl;
    intros [H | H0];
    try contradiction;
    try (inversion H; fail).
  { split; right;
      apply IHd2 in H0;
      inversion_clear H0;
      trivial. }
  { inversion H; subst; clear H.
    split; right; apply in_or_app.
    { left; apply recoverable0_self. }
    { right; apply recoverable0_self. } }
  { apply in_app_or in H0.
    inversion_clear H0.
    { apply IHd2_1 in H.
      inversion_clear H.
      split; right; apply in_or_app;
        left; trivial. }
    { apply IHd2_2 in H.
      inversion_clear H.
      split; right; apply in_or_app;
        right; trivial. } }
Qed.

Theorem in_recoverable0_transitive {T: Type}(d0 d1 d2: data T):
  In d0 (recoverable0 d1) ->
  In d1 (recoverable0 d2) ->
  In d0 (recoverable0 d2).
Proof.
  generalize dependent d2;
  generalize dependent d0;
  generalize dependent d1.
  induction d1;
  simpl;
  try (intros d0 d2 [<- | H] H0; trivial; contradiction).
  { intros d0 d2 [<- | H0] H1; trivial.
    (* In (kapply k d1) (recoverable0 d2) *)
    apply recoverable0_kapply in H1.
    apply IHd1; trivial. }
  { intros d0 d2 [<- | H0] H1; trivial.
    apply recoverable0_pair in H1.
    inversion_clear H1.
    apply in_app_or in H0.
    inversion_clear H0.
    { apply IHd1_1; trivial. }
    { apply IHd1_2; trivial. } }
Qed.

Theorem in_recoverable0_in_recoverable {T: Type}(d0 d1: data T)(ds: list (data T)):
  In d0 (recoverable0 d1) ->
  In d1 ds ->
  In d0 (recoverable ds).
Proof.
  induction ds; simpl;
    try contradiction.
  intros Hd0d1 [-> | Hd1];
    apply in_or_app;
    [left | right; apply IHds];
    trivial.
Qed.

Theorem recoverable_increasing {T: Type}(ds: list (data T)):
  forall (d: data T),
    In d ds ->
    In d (recoverable ds).
Proof.
  induction ds; simpl;
    intros d H;
    try contradiction.
  inversion_clear H.
  { subst.
    destruct d; simpl;
      left; reflexivity. }
  { apply IHds in H0.
    apply in_or_app.
    right; trivial. }
Qed.

Theorem in_recoverable_singleton {T: Type}(d: data T)(ds: list (data T)):
  In d (recoverable ds) ->
  exists (d': data T), In d' ds /\ In d (recoverable (d'::nil)).
Proof.
  induction ds; simpl;
    try contradiction.
  simpl in IHds; intros H.
  apply in_app_or in H.
  inversion_clear H.
  { exists a.
    split; [left; reflexivity |].
    rewrite app_nil_r.
    trivial. }
  { apply IHds in H0.
    inversion_clear H0.
    inversion_clear H.
    exists x.
    split; [right |];
      trivial. }
Qed.

Theorem in_recoverable_union {T: Type}(ds0 ds1: list (data T)):
  forall (d: data T),
    In d (recoverable (ds0 ++ ds1)) <->
    In d (recoverable ds0) \/ In d (recoverable ds1).
Proof.
  intros d; split.
  { intros Happ.
    apply in_recoverable_singleton in Happ.
    inversion_clear Happ;
      simpl in H; rewrite app_nil_r in H.
    inversion_clear H as (H0 & H1).
    apply in_app_or in H0.
    inversion_clear H0 as [H | H];
      [left | right];
      apply in_recoverable0_in_recoverable with x;
      trivial. }
  { generalize dependent ds1;
      generalize dependent d;
      induction ds0;
      simpl.
    { intros d ds1 [Hcontra | Hdds1];
        try contradiction;
        trivial. }
    { intros d ds1 [Hdads0 | Hdds1];
      apply in_or_app.
      { apply in_app_or in Hdads0.
        inversion_clear Hdads0;
          try (left; trivial; fail).
        right; apply IHds0.
        left; trivial. }
      { right; apply IHds0.
        right; trivial. } } }
Qed.

Lemma recoverable0_recoverable {T: Type}(d: data T):
  recoverable (d::nil) = recoverable0 d.
Proof.
  simpl.
  apply app_nil_r.
Qed.

Lemma in_recoverable_recoverable0 {T: Type}(d: data T):
  forall (d0: data T),
    In d0 (recoverable (recoverable0 d)) ->
    In d0 (recoverable0 d).
Proof.
  induction d; simpl; intros;
  try (inversion_clear H; try contradiction;
      left; trivial; fail).
  { inversion_clear H as [<- | Hin];
      [left; reflexivity | right].
    apply in_app_or in Hin.
    inversion_clear Hin as [H | H]; trivial.
    apply IHd; trivial. }
  { inversion_clear H as [<- | Hin];
      [left; reflexivity | right].
    apply in_app_or in Hin.
    inversion_clear Hin as [H | H]; trivial.
    rewrite in_recoverable_union in H.
    apply in_or_app;
    inversion_clear H as [H0 | H0];
      [ left; apply IHd1 | right; apply IHd2 ];
      trivial. }
Qed.

Theorem in_recoverable_idempotent {T: Type}(ds: list (data T)):
  forall (d: data T),
    In d (recoverable (recoverable ds)) <->
    In d (recoverable ds).
Proof.
  induction ds; simpl.
  { intros; split; contradiction. }
  { intros d; split; intros H.
    { apply in_or_app.
      rewrite in_recoverable_union in H.
      inversion_clear H as [H0 | H0].
      { apply in_recoverable_recoverable0 in H0.
          left; trivial. }
      { right; rewrite <- IHds; trivial. } }
    { apply in_app_or in H.
      rewrite in_recoverable_union.
      inversion_clear H as [H0 | H0].
      { left.
        apply recoverable_increasing; trivial. }
      { right; rewrite IHds; trivial. } } }
Qed.

(* Inductive analyzable {T: Type}: list (data T) -> list (data T) -> Prop :=
| analyzable_inj:
  forall (d: data T)(ds an: list (data T)),
    In d ds -> In d an ->
    analyzable ds an
| analyzable_fst:
  forall (d0 d1: data T)(an: list (data T)),
    In (pair d0 d1) an -> In d0 an ->
    forall (ds: list (data T)), analyzable ds an
| analyzable_snd:
  forall (d0 d1: data T)(an: list (data T)),
    In (pair d0 d1) an -> In d1 an ->
    forall (ds: list (data T)), analyzable ds an
| analyzable_decrypt:
  forall (k: key)(d: data T)(an: list (data T)),
    In (kapply k d) an /\ In (kval (kinverse k)) an ->
    In d an ->
    forall (ds: list (data T)), analyzable ds an. *)


(************************************************************************)
(*  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        *)
(************************************************************************)
(** Reformulation of the Wf module using subsets where possible, providing
   the support for [Program]'s treatment of well-founded definitions. *)

Require Import Coq.Init.Wf.
Require Import Coq.Program.Utils.
Require Import ProofIrrelevance.

Open Local Scope program_scope.

Section Well_founded.
  Variable A : Type.
  Variable R : A -> A -> Prop.
  Hypothesis Rwf : well_founded R.

  Variable P : A -> Type.

  Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.

  Fixpoint Fix_F_sub (x : A) (r : Acc R x) : P x :=
    F_sub x (fun y: { y : A | R y x}  => Fix_F_sub (proj1_sig y)
      (Acc_inv r (proj2_sig y))).

  Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).

  (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *)
  (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *)

  Hypothesis
    F_ext :
    forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
      (forall (y : A | R y x), f y = g y) -> F_sub x f = F_sub x g.

  Lemma Fix_F_eq :
    forall (x:A) (r:Acc R x),
      F_sub x (fun (y:A|R y x) => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r.
  Proof.
    destruct r using Acc_inv_dep; auto.
  Qed.

  Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s.
  Proof.
    intro x; induction (Rwf x); intros.
    rewrite (proof_irrelevance (Acc R x) r s) ; auto.
  Qed.

  Lemma Fix_eq : forall x:A, Fix_sub x = F_sub x (fun (y:A|R y x) => Fix_sub (proj1_sig y)).
  Proof.
    intro x; unfold Fix_sub in |- *.
    rewrite <- (Fix_F_eq ).
    apply F_ext; intros.
    apply Fix_F_inv.
  Qed.

  Lemma fix_sub_eq :
    forall x : A,
      Fix_sub x =
      let f_sub := F_sub in
        f_sub x (fun (y : A | R y x) => Fix_sub (`y)).
    exact Fix_eq.
  Qed.

End Well_founded.

Extraction Inline Fix_F_sub Fix_sub.

Set Implicit Arguments.

(** Reasoning about well-founded fixpoints on measures. *)

Section Measure_well_founded.

  (* Measure relations are well-founded if the underlying relation is well-founded. *)

  Variables T M: Type.
  Variable R: M -> M -> Prop.
  Hypothesis wf: well_founded R.
  Variable m: T -> M.

  Definition MR (x y: T): Prop := R (m x) (m y).

  Lemma measure_wf: well_founded MR.
  Proof with auto.
    unfold well_founded.
    cut (forall a: M, (fun mm: M => forall a0: T, m a0 = mm -> Acc MR a0) a).
      intros.
      apply (H (m a))...
    apply (@well_founded_ind M R wf (fun mm => forall a, m a = mm -> Acc MR a)).
    intros.
    apply Acc_intro.
    intros.
    unfold MR in H1.
    rewrite H0 in H1.
    apply (H (m y))...
  Defined.

End Measure_well_founded.

Hint Resolve measure_wf.

Section Fix_rects.

  Variable A: Type.
  Variable P: A -> Type.
  Variable R : A -> A -> Prop.
  Variable Rwf : well_founded R.
  Variable f: forall (x : A), (forall y: { y: A | R y x }, P (proj1_sig y)) -> P x.

  Lemma F_unfold x r:
    Fix_F_sub A R P f x r =
    f (fun y => Fix_F_sub A R P f (proj1_sig y) (Acc_inv r (proj2_sig y))).
  Proof. intros. case r; auto. Qed.

  (* Fix_F_sub_rect lets one prove a property of
  functions defined using Fix_F_sub by showing
  that property to be invariant over single application of the
  function body (f in our case). *)

  Lemma Fix_F_sub_rect
    (Q: forall x, P x -> Type)
    (inv: forall x: A,
     (forall (y: A) (H: R y x) (a: Acc R y),
        Q y (Fix_F_sub A R P f y a)) ->
        forall (a: Acc R x),
          Q x (f (fun y: {y: A | R y x} =>
            Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y)))))
    : forall x a, Q _ (Fix_F_sub A R P f x a).
  Proof with auto.
    set (R' := fun (x: A) => forall a, Q _ (Fix_F_sub A R P f x a)).
    cut (forall x, R' x)...
    apply (well_founded_induction_type Rwf).
    subst R'.
    simpl.
    intros.
    rewrite F_unfold...
  Qed.

  (* Let's call f's second parameter its "lowers" function, since it
  provides it access to results for inputs with a lower measure.

  In preparation of lemma similar to Fix_F_sub_rect, but
  for Fix_sub, we first
  need an extra hypothesis stating that the function body has the
  same result for different "lowers" functions (g and h below) as long
  as those produce the same results for lower inputs, regardless
  of the lt proofs. *)

  Hypothesis equiv_lowers:
    forall x0 (g h: forall x: {y: A | R y x0}, P (proj1_sig x)),
    (forall x p p', g (exist (fun y: A => R y x0) x p) = h (exist _ x p')) ->
      f g = f h.

  (* From equiv_lowers, it follows that
   [Fix_F_sub A R P f x] applications do not not
  depend on the Acc proofs. *)

  Lemma eq_Fix_F_sub x (a a': Acc R x):
    Fix_F_sub A R P f x a =
    Fix_F_sub A R P f x a'.
  Proof.
    revert a'.
    pattern x, (Fix_F_sub A R P f x a).
    apply Fix_F_sub_rect.
    intros.
    rewrite F_unfold.
    apply equiv_lowers.
    intros.
    apply H.
    assumption.
  Qed.

  (* Finally, Fix_F_rect lets one prove a property of
  functions defined using Fix_F_sub by showing that
  property to be invariant over single application of the function
  body (f). *)

  Lemma Fix_sub_rect
    (Q: forall x, P x -> Type)
    (inv: forall
      (x: A)
      (H: forall (y: A), R y x -> Q y (Fix_sub A R Rwf P f y))
      (a: Acc R x),
        Q x (f (fun y: {y: A | R y x} => Fix_sub A R Rwf P f (proj1_sig y))))
    : forall x, Q _ (Fix_sub A R Rwf P f x).
  Proof with auto.
    unfold Fix_sub.
    intros.
    apply Fix_F_sub_rect.
    intros.
    assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))...
    set (inv x0 X0 a). clearbody q.
    rewrite <- (equiv_lowers (fun y: {y: A | R y x0} =>
      Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y)))
    (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))...
    intros.
    apply eq_Fix_F_sub.
  Qed.

End Fix_rects.

(** Tactic to fold a definition based on [Fix_measure_sub]. *)

Ltac fold_sub f :=
  match goal with
    | [ |- ?T ] =>
      match T with
        appcontext C [ @Fix_sub _ _ _ _ _ ?arg ] =>
        let app := context C [ f arg ] in
          change app
      end
  end.

(** This module provides the fixpoint equation provided one assumes
   functional extensionality. *)

Module WfExtensionality.

  Require Import FunctionalExtensionality.

  (** The two following lemmas allow to unfold a well-founded fixpoint definition without
     restriction using the functional extensionality axiom. *)

  (** For a function defined with Program using a well-founded order. *)

  Program Lemma fix_sub_eq_ext :
    forall (A : Type) (R : A -> A -> Prop) (Rwf : well_founded R)
      (P : A -> Type)
      (F_sub : forall x : A, (forall (y : A | R y x), P y) -> P x),
      forall x : A,
        Fix_sub A R Rwf P F_sub x =
          F_sub x (fun (y : A | R y x) => Fix_sub A R Rwf P F_sub y).
  Proof.
    intros ; apply Fix_eq ; auto.
    intros.
    assert(f = g).
    extensionality y ; apply H.
    rewrite H0 ; auto.
  Qed.

  (** Tactic to unfold once a definition based on [Fix_sub]. *)

  Ltac unfold_sub f fargs :=
    set (call:=fargs) ; unfold f in call ; unfold call ; clear call ;
      rewrite fix_sub_eq_ext ; repeat fold_sub f ; simpl proj1_sig.

End WfExtensionality.


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

Set Printing Depth 1000.
Definition lfind_eval  l2:=
append (rev l2) Nil.

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

Compute lfind_eval  (Cons (Succ Zero) Nil).

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

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

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

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

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

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

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

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

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).


(*Require Import Coq.Program.Basics.*)
Require Import Lib.AML.
Require Import Categories.Essentials.Notations.
Require Import Categories.Category.Main.

Record SignatureMorphism{from to : Signature} : Type :=
  { evarsMorphism : evars from -> evars to;
    svarsMorphism : svars from -> svars to;
    symbolsMorphism : symbols from -> symbols to;
  }.

Definition SignatureMorphism_id{sig:Signature} : @SignatureMorphism sig sig :=
  {| evarsMorphism := fun x => x;
     svarsMorphism := fun x => x;
     symbolsMorphism := fun x => x;
  |}.

Definition SignatureMorphism_compose{A B C : Signature}(g: @SignatureMorphism B C)(f: @SignatureMorphism A B) :=
  {| evarsMorphism := fun x : evars A => evarsMorphism g (evarsMorphism f x);
     svarsMorphism := fun x : svars A => svarsMorphism g (svarsMorphism f x);
     symbolsMorphism := fun x => symbolsMorphism g (symbolsMorphism f x);
  |}.

Lemma SignatureMorphism_compose_assoc :
  forall (A B C D : Signature)
         (f: @SignatureMorphism A B)
         (g: @SignatureMorphism B C)
         (h: @SignatureMorphism C D),
    SignatureMorphism_compose h (SignatureMorphism_compose g f)
    = SignatureMorphism_compose (SignatureMorphism_compose h g) f.
Proof.
  intros. unfold SignatureMorphism_compose. f_equal.
Qed.

Lemma SignatureMorphism_compose_id_left :
  forall (A B : Signature) (f : @SignatureMorphism A B),
    SignatureMorphism_compose SignatureMorphism_id f = f.
Proof.
  intros.  auto.
Qed.

Lemma SignatureMorphism_compose_id_right :
  forall (A B : Signature) (f : @SignatureMorphism A B),
    SignatureMorphism_compose f SignatureMorphism_id = f.
Proof.
  intros. auto.
Qed.

Definition Signature_Cat : Category :=
  {| Obj := Signature;
     Hom := fun A B => @SignatureMorphism A B;
     compose := fun _ _ _ f g => SignatureMorphism_compose g f;
     assoc := SignatureMorphism_compose_assoc;
     assoc_sym := fun A B C D f g h => eq_sym (SignatureMorphism_compose_assoc A B C D f g h);
     id := @SignatureMorphism_id;
     id_unit_left := SignatureMorphism_compose_id_left;
     id_unit_right := SignatureMorphism_compose_id_right;
  |}.


Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
Require Import Eqdep ClassicalFacts.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*****************************)
(* Axioms and extensionality *)
(*****************************)

(* extensionality is needed for domains *)
Axiom pext : forall p1 p2 : Prop, (p1 <-> p2) -> p1 = p2.
Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

Lemma proof_irrelevance (P : Prop) (p1 p2 : P) : p1 = p2.
Proof. by apply: ext_prop_dep_proof_irrel_cic; apply: pext. Qed.

Lemma eta A (B : A -> Type) (f : forall x, B x) : f = [eta f].
Proof. by apply: fext. Qed.

Lemma ext A (B : A -> Type) (f1 f2 : forall x, B x) :
        f1 = f2 -> forall x, f1 x = f2 x.
Proof. by move=>->. Qed.

(*******************)
(* Setoid renaming *)
(*******************)

(* Setoid library takes up some important arrow notations *)
(* used by ssreflect and elsewhere; so we must rename *)
Ltac add_morphism_tactic := SetoidTactics.add_morphism_tactic.
Notation " R ===> R' " := (@Morphisms.respectful _ _ R R')
  (right associativity, at level 55) : signature_scope.

(***********)
(* Prelude *)
(***********)

(* often used notation definitions and lemmas that are *)
(* not included in the other libraries *)

Definition inj_pair2 := @inj_pair2.
Implicit Arguments inj_pair2 [U P p x y].
Prenex Implicits inj_pair2.

Lemma inj_sval A P : injective (@sval A P).
Proof.
move=>[x Hx][y Hy] /= H; move: Hx Hy; rewrite H=>*.
congr exist; apply: proof_irrelevance.
Qed.

Lemma svalE A (P : A -> Prop) x H : sval (exist P x H) = x.
Proof. by []. Qed.

(* rewrite rule for propositional symmetry *)
Lemma sym A (x y : A) : x = y <-> y = x.
Proof. by []. Qed.

(* selecting a list element *)
(* should really be in seq.v *)

Section HasSelect.
Variables (A : eqType) (p : pred A).

CoInductive has_spec (s : seq A) : bool -> Type :=
| has_true x of x \in s & p x : has_spec s true
| has_false of (all (predC p) s) : has_spec s false.

Lemma hasPx : forall s, has_spec s (has p s).
Proof.
elim=>[|x s IH] /=; first by apply: has_false.
rewrite orbC; case: IH=>/=.
- by move=>k H1; apply: has_true; rewrite inE H1 orbT.
case E: (p x)=>H; last by apply: has_false; rewrite /= E H.
by apply: has_true E; rewrite inE eq_refl.
Qed.

End HasSelect.

(****************)
(* Type dynamic *)
(****************)

(* putting it in a module, to get a path name for typ and val *)
Module Dyn.
Record dynamic : Type := dyn {typ : Type; val : typ}.
End Dyn.

Notation dynamic := Dyn.dynamic.
Notation dyn := Dyn.dyn.

Lemma dyn_inj A (x y : A) : dyn x = dyn y -> x = y.
Proof. move=>[H]; apply: inj_pairT2 H. Qed.

Lemma dyn_eta d : d = dyn (Dyn.val d).
Proof. by case:d. Qed.

Lemma dyn_injT A1 A2 (x1 : A1) (x2 : A2) : dyn x1 = dyn x2 -> A1 = A2.
Proof. by case. Qed.

Prenex Implicits dyn_inj dyn_injT.

(* is dyneq really needed? *)
(*
Module DynEq.
Record dynamic_eq : Type := dyneq {typ : eqType; val : typ}.
End DynEq.

Notation dynamic_eq := DynEq.dynamic_eq.
Notation dyneq := DynEq.dyneq.

Lemma dyneq_inj (A : eqType) (x y : A) : dyneq x = dyneq y -> x = y.
Proof. case=>H; apply: inj_pairT2 H. Qed.

Lemma dyneq_eta d : d = dyneq (DynEq.val d).
Proof. by case:d. Qed.

Lemma dyneq_injT (A1 A2 : eqType) (x1 : A1) (x2 : A2) : dyneq x1 = dyneq x2 -> A1 = A2.
Proof. by case. Qed.
*)

(***********************)
(* John Major equality *)
(***********************)

Section Coercions.
Variable (T : Type -> Type).

Definition coerce A B (x : T A) : A = B -> T B := [eta eq_rect A [eta T] x B].

Lemma eqc A (x : T A) (pf : A = A) : coerce x pf = x.
Proof. by move:pf; apply: Streicher_K. Qed.

Definition jmeq A B (x : T A) (y : T B) := forall pf, coerce x pf = y.

Lemma jmE A (x y : T A) : jmeq x y <-> x = y.
Proof.
by split=>[|-> ?]; [move/(_ (erefl _))=><-|]; rewrite eqc.
Qed.

Lemma jmeq_refl A (x : T A) : jmeq x x.
Proof. by move=>pf; rewrite eqc. Qed.

End Coercions.

Hint Resolve jmeq_refl.
Implicit Arguments jmeq [A B].
Notation "a =jm b" := (jmeq id a b) (at level 50).

(* some additional elimination principles *)

Lemma contV B (P : B -> B -> Prop) :
        (forall x x', x =jm x' -> P x x') <-> forall x, P x x.
Proof.
split; first by move=>H x; exact: (H x x (jmeq_refl _)).
by move=>H x x'; move/jmE=>->.
Qed.

Lemma contVT B (P : B -> B -> Prop) :
        (forall x x', B = B -> x =jm x' -> P x x') <-> forall x, P x x.
Proof.
split; first by move=>H x; exact: (H x x (erefl _) (jmeq_refl _)).
by move=>H x x' _; move/jmE=>->.
Qed.

(* john major on pairs *)

Section Coercions2.
Variable (T : Type -> Type -> Type).

Definition coerce2 A1 A2 B1 B2 (x : T A1 A2) :
             (A1, A2) = (B1, B2) -> T B1 B2.
Proof. by move=> [<- <-]; exact: x. Defined.

Lemma eqc2 A1 A2 (x : T A1 A2) (pf : (A1, A2) = (A1, A2)) :
        coerce2 x pf = x.
Proof. by move:pf; apply: Streicher_K. Qed.

Definition jmeq2 A1 A2 B1 B2 (x : T A1 B1) (y : T A2 B2) :=
             forall pf, coerce2 x pf = y.

Lemma jm2E A B (x y : T A B) : jmeq2 x y <-> x = y.
Proof.
by move=>*; split=>[|-> ?]; [move/(_ (erefl _))=><-|]; rewrite eqc2.
Qed.

Lemma refl_jmeq2 A B (x : T A B) : jmeq2 x x.
Proof. by move=>pf; rewrite eqc2. Qed.

End Coercions2.

Hint Resolve refl_jmeq2.
Implicit Arguments jmeq2 [A1 A2 B1 B2].

(***************************)
(* operations on functions *)
(***************************)

Lemma compA A B C D (h : A -> B) (g : B -> C) (f : C -> D) :
        (f \o g) \o h = f \o (g \o h).
Proof. by []. Qed.

Lemma compf1 A B (f : A -> B) : f = f \o id.
Proof. by apply: fext. Qed.

Lemma comp1f A B (f : A -> B) : f = id \o f.
Proof. by apply: fext. Qed.

Definition fprod A1 A2 B1 B2 (f1 : A1 -> B1) (f2 : A2 -> B2) :=
  fun (x : A1 * A2) => (f1 x.1, f2 x.2).

Notation "f1 \* f2" := (fprod f1 f2) (at level 45).

(* reordering functions *)
Section Reorder.
Variables (A B C : Type).

Definition swap (x : A * B) :=
  let: (x1, x2) := x in (x2, x1).
Definition rCA (x : A * (B * C)) :=
  let: (x1, (x2, x3)) := x in (x2, (x1, x3)).
Definition rAC (x : (A * B) * C) :=
  let: ((x1, x2), x3) := x in ((x1, x3), x2).
Definition rA (x : A * (B * C)) :=
  let: (x1, (x2, x3)) := x in ((x1, x2), x3).
Definition iA (x : (A * B) * C) :=
  let: ((x1, x2), x3) := x in (x1, (x2, x3)).
Definition pL (x : A * B) :=
  let: (x1, x2) := x in x1.
Definition pR (x : A * B) :=
  let: (x1, x2) := x in x2.
End Reorder.

Prenex Implicits swap rCA rAC rA iA pL pR.

(*
Definition Id A : simpl_fun A A := [fun x => x].

Implicit Arguments Id [A].
Prenex Implicits Id.
*)

(* idempotency lemmas *)
Lemma swapI A B : swap \o swap = @id (A * B).
Proof. by apply: fext; case. Qed.

Lemma rCAI A B C : rCA \o (@rCA A B C) = id.
Proof. by apply: fext; case=>a [b c]. Qed.

Lemma rACI A B C : rAC \o (@rAC A B C) = id.
Proof. by apply: fext; case=>[[a]] b c. Qed.

Lemma riA A B C : rA \o (@iA A B C) = id.
Proof. by apply: fext; case=>[[]]. Qed.

Lemma irA A B C : iA \o (@rA A B C) = id.
Proof. by apply: fext; case=>a []. Qed.

Lemma swap_prod A1 B1 A2 B2 (f1 : A1 -> B1) (f2 : A2 -> B2) :
        swap \o f1 \* f2 = f2 \* f1 \o swap.
Proof. by apply: fext; case. Qed.

Lemma swap_rCA A B C : swap \o (@rCA A B C) = rAC \o rA.
Proof. by apply: fext; case=>x []. Qed.

Lemma swap_rAC A B C : swap \o (@rAC A B C) = rCA \o iA.
Proof. by apply: fext; case=>[[]]. Qed.

(*
Lemma swapCAAC A B C : rCA \o swap \o (@rAC A B C) = (@iA A B C).
*)

(* rewrite equality/john major equality, forward/backwards *)
Ltac rfe1 x1 := let H := fresh "H" in move=>H; move:H x1=>-> x1.
Ltac rfe2 x1 x2 := let H := fresh "H" in move=>H; move:H x1 x2=>-> x1 x2.
Ltac rfjm := move/jmE=>->.
Ltac rfejm1 x1 := rfe1 x1; rfjm.
Ltac rfejm2 x1 x2 := rfe2 x1 x2; rfjm.
Ltac rfp := move/inj_pair2=>->.
Ltac rfep1 x1 := rfe1 x1; rfp.
Ltac rfep2 x1 x2 := rfe1 x2; rfp.

Ltac rbe1 x1 := let H := fresh "H" in move=>H; move:H x1=><- x1.
Ltac rbe2 x1 x2 := let H := fresh "H" in move=>H; move:H x1 x2=><- x1 x2.
Ltac rbjm := move/jmE=><-.
Ltac rbejm1 x1 := rbe1 x1; rbjm.
Ltac rbejm2 x1 x2 := rbe2 x1 x2; rbjm.
Ltac rbp := move/inj_pair2=><-.
Ltac rbep1 x1 := rbe1 x1; rbp.
Ltac rbep2 x1 x2 := rbe1 x2; rbp.

(************************)
(* extension to ssrbool *)
(************************)

Reserved Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" (at level 0, format
  "'[hv' [ /\ '['  P1 , '/'  P2 , '/'  P3 , '/'  P4 , '/'  P5 ']' '/ '  &  P6 ] ']'").

Reserved Notation "[ \/ P1 , P2 , P3 , P4 & P5 ]" (at level 0, format
  "'[hv' [ \/ '['  P1 , '/'  P2 , '/'  P3 , '/'  P4 ']' '/ '  &  P5 ] ']'").
Reserved Notation "[ \/ P1 , P2 , P3 , P4 , P5 & P6 ]" (at level 0, format
  "'[hv' [ \/ '['  P1 , '/'  P2 , '/'  P3 , '/'  P4 , '/'  P5 ']' '/ '  &  P6 ] ']'").

Inductive and6 (P1 P2 P3 P4 P5 P6 : Prop) : Prop :=
  And6 of P1 & P2 & P3 & P4 & P5 & P6.

Inductive or5 (P1 P2 P3 P4 P5 : Prop) : Prop :=
  Or51 of P1 | Or52 of P2 | Or53 of P3 | Or54 of P4 | Or55 of P5.
Inductive or6 (P1 P2 P3 P4 P5 P6 : Prop) : Prop :=
  Or61 of P1 | Or62 of P2 | Or63 of P3 | Or64 of P4 | Or65 of P5 | Or66 of P6.

Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" := (and6 P1 P2 P3 P4 P5 P6) : type_scope.
Notation "[ \/ P1 , P2 , P3 , P4 | P5 ]" := (or5 P1 P2 P3 P4 P5) : type_scope.
Notation "[ \/ P1 , P2 , P3 , P4 , P5 | P6 ]" := (or6 P1 P2 P3 P4 P5 P6) : type_scope.

Section ReflectConnectives.

Variable b1 b2 b3 b4 b5 b6 : bool.
Lemma and6P : reflect [/\ b1, b2, b3, b4, b5 & b6] [&& b1, b2, b3, b4, b5 & b6].
Proof.
by case b1; case b2; case b3; case b4; case b5; case b6; constructor; try by case.
Qed.

Lemma or5P : reflect [\/ b1, b2, b3, b4 | b5] [|| b1, b2, b3, b4 | b5].
Proof.
case b1; first by constructor; constructor 1.
case b2; first by constructor; constructor 2.
case b3; first by constructor; constructor 3.
case b4; first by constructor; constructor 4.
case b5; first by constructor; constructor 5.
by constructor; case.
Qed.

Lemma or6P : reflect [\/ b1, b2, b3, b4, b5 | b6] [|| b1, b2, b3, b4, b5 | b6].
Proof.
case b1; first by constructor; constructor 1.
case b2; first by constructor; constructor 2.
case b3; first by constructor; constructor 3.
case b4; first by constructor; constructor 4.
case b5; first by constructor; constructor 5.
case b6; first by constructor; constructor 6.
by constructor; case.
Qed.

End ReflectConnectives.

Implicit Arguments and6P [b1 b2 b3 b4 b5 b6].
Implicit Arguments or5P [b1 b2 b3 b4 b5].
Implicit Arguments or6P [b1 b2 b3 b4 b5 b6].
Prenex Implicits and6P or5P or6P.


Require Import Rbase Ranalysis.
Require Import Rinterval Rfunctions Rfunction_def.
Require Import Ranalysis_def Ranalysis_def_simpl Rfunction_facts.
Require Import MyRIneq MyR_dist Lra.

Require Import Tactics.

Local Open Scope R_scope.

(** * Extensionality of continuity_pt_in *)

Lemma continuity_pt_in_ext : forall D (f g : R -> R) x,
  (f == g)%F -> continuity_pt_in D f x -> continuity_pt_in D g x.
Proof.
intros D f g x Heq Hf Dx ; eapply limit1_in_ext.
 intros ; apply Heq.
 rewrite <- (Heq x) ; apply Hf ; assumption.
Qed.

Lemma continuity_pt_in_ext_strong : forall (D : R -> Prop) (f g : R -> R) x,
  (forall x, D x -> f x = g x)%F ->
  continuity_pt_in D f x -> continuity_pt_in D g x.
Proof.
intros D f g x Heq Hf Dx ; eapply limit1_in_ext.
 eexact Heq.
 rewrite <- (Heq x) ; [apply Hf |] ; assumption.
Qed.

Lemma continuity_in_ext : forall D (f g : R -> R),
  (f == g)%F -> continuity_in D f -> continuity_in D g.
Proof.
intros D f g Heq Hf x ; eapply continuity_pt_in_ext, Hf ; eassumption.
Qed.

Lemma continuity_in_ext_strong : forall (D : R -> Prop) f g,
  (forall x, D x -> f x = g x)%F ->
  continuity_in D f -> continuity_in D g.
Proof.
intros D f g Heq Hf x ; eapply continuity_pt_in_ext_strong, Hf ; eassumption.
Qed.

(** * How to relate the different notions of continuity. *)

Lemma continuity_pt_continuity_pt_in: forall f (D : R -> Prop) x,
  continuity_pt f x -> continuity_pt_in D f x.
Proof.
intros f D x Hf Dx eps eps_pos ;
 destruct (Hf _ eps_pos) as [alp [alp_pos Halp]] ;
 exists alp ; split ; [assumption | intros y [Dy y_bd]].
 destruct (Req_dec x y) as [Heq | Hneq].
 subst ; rewrite R_dist_eq ; assumption.
 apply Halp ; repeat split ; assumption.
Qed.

Lemma continuity_continuity_in: forall D f,
  continuity f -> continuity_in D f.
Proof.
intros D f f_cont x x_in ; apply continuity_pt_continuity_pt_in ;
 [apply f_cont |] ; assumption.
Qed.

Lemma continuity_interval_continuity_pt: forall f lb ub x, lb < ub ->
  continuity_interval lb ub f -> open_interval lb ub x ->
  continuity_pt f x.
Proof.
intros f lb ub x lb_lt_ub Hf x_in eps eps_pos ;
 assert (x_in' := open_interval_interval _ _ _ x_in) ;
 destruct (Hf _ x_in' _ eps_pos) as [alpha [alpha_pos Halpha]].
 exists (Rmin alpha (interval_dist lb ub x)) ; split.
  apply Rmin_pos_lt, open_interval_dist_pos ; assumption.
  intros y [[_ x_neq_y] y_bd] ; apply Halpha ; split.
   replace y with (x + (y -x)) by ring ; apply interval_dist_bound.
    assumption.
    left ; eapply Rlt_le_trans ; [eassumption | apply Rmin_r].
    eapply Rlt_le_trans ; [eassumption | apply Rmin_l].
Qed.

Lemma continuity_open_interval_continuity : forall f,
  (forall lb ub, continuity_open_interval lb ub f) ->
  continuity f.
Proof.
intros f Hf x eps eps_pos ;
 destruct (Hf _ _ _ (center_in_open_interval x 1 Rlt_0_1) _ eps_pos) as [delta [delta_pos Hdelta]] ;
 exists (Rmin delta 1) ; split.
  apply Rmin_pos_lt ; lra.
  simpl ; intros y [[_ y_neq] y_b] ; apply Hdelta ; split.
   rewrite <- Rball_rewrite ; eapply Rlt_le_trans ; [eassumption | apply Rmin_r].
   eapply Rlt_le_trans ; [eassumption | apply Rmin_l].
Qed.

(** * Simple compatibility results on continuity_in *)

Lemma continuity_in_const : forall D c, continuity_in D (fun _ => c).
Proof.
intros ; exists 1 ; split ; [lra |] ;
 intros ; rewrite R_dist_eq ; assumption.
Qed.

Lemma continuity_in_opp : forall D f,
  continuity_in D f -> continuity_in D (- f)%F.
Proof.
intros D f Hf x x_in ; apply limit_Ropp ; eapply_assumption ; assumption.
Qed.

Lemma continuity_pt_in_opp_rev : forall f D x,
  continuity_pt_in D (- f)%F x -> continuity_pt_in D f x.
Proof.
intros f D x Hf x_in ; apply limit1_in_ext with (- - f)%F.
 intros y y_in ; apply Ropp_involutive.
 rewrite <- (Ropp_involutive (f x)) ;
 apply limit_Ropp, Hf ; assumption.
Qed.

Lemma continuity_in_plus : forall D f g,
  continuity_in D f -> continuity_in D g ->
  continuity_in D (f + g)%F.
Proof.
intros f g a b Hf Hg x x_in ; apply limit_plus ; eapply_assumption ;
 assumption.
Qed.

Lemma continuity_in_minus : forall D f g,
  continuity_in D f -> continuity_in D g ->
  continuity_in D (f - g)%F.
Proof.
intros f g a b Hf Hg x x_in ; apply limit_minus ; eapply_assumption ;
 assumption.
Qed.

Lemma continuity_in_mult : forall D f g,
  continuity_in D f -> continuity_in D g ->
  continuity_in D (f * g)%F.
Proof.
intros f g a b Hf Hg x x_in ; apply limit_mul ; eapply_assumption ;
 assumption.
Qed.

(** Special case: (open) interval *)

Lemma continuity_open_interval_Ropp_compat : forall f lb ub,
  continuity_open_interval lb ub f ->
  continuity_open_interval (- ub) (- lb) (fun x => f (- x)).
Proof.
intros f lb ub Hf b b_in eps eps_pos.
 assert (mb_in : open_interval lb ub (- b)).
  destruct b_in ; split ; lra.
 destruct (Hf _ mb_in _ eps_pos) as [alpha [alpha_pos Halpha]] ;
 exists alpha ; split ; [assumption | intros x [x_in x_bd]].
 apply Halpha ; split ; simpl.
  destruct x_in ; split ; lra.
  rewrite R_dist_opp_compat ; assumption.
Qed.

Lemma continuity_open_interval_Ropp_compat_rev : forall f lb ub,
  continuity_open_interval (- ub) (- lb) (fun x => f (- x)) ->
  continuity_open_interval lb ub f.
Proof.
intros f lb ub Hf ; pose (F := fun x => f (- x)) ;
 apply continuity_in_ext with (fun x => F (- x)).
 intro x ; unfold F ; f_equal ; apply Ropp_involutive.
  rewrite <- (Ropp_involutive lb), <- (Ropp_involutive ub) ;
  apply continuity_open_interval_Ropp_compat, Hf.
Qed.

Lemma continuity_interval_Ropp_compat : forall f lb ub,
  continuity_interval lb ub f ->
  continuity_interval (- ub) (- lb) (fun x => f (- x)).
Proof.
intros f lb ub Hf b b_in eps eps_pos.
 assert (mb_in : interval lb ub (- b)).
  destruct b_in ; split ; lra.
 destruct (Hf _ mb_in _ eps_pos) as [alpha [alpha_pos Halpha]] ;
 exists alpha ; split ; [assumption | intros x [x_in x_bd]].
 apply Halpha ; split ; simpl.
  destruct x_in ; split ; lra.
  rewrite R_dist_opp_compat ; assumption.
Qed.

Lemma continuity_interval_Ropp_compat_rev : forall f lb ub,
  continuity_interval (- ub) (- lb) (fun x => f (- x)) ->
  continuity_interval lb ub f.
Proof.
intros f lb ub Hf ; pose (F := fun x => f (- x)) ;
 apply continuity_in_ext with (fun x => F (- x)).
 intro x ; unfold F ; f_equal ; apply Ropp_involutive.
  rewrite <- (Ropp_involutive lb), <- (Ropp_involutive ub) ;
  apply continuity_interval_Ropp_compat, Hf.
Qed.

(** If f x <> y and f continue then there is a ball B around x such that y is not in f B. *)

(* TODO: move this *)

Lemma continuity_not_eq_Rball : forall f (D : R -> Prop) x y,
  D x -> continuity_pt_in D f x -> f x <> y ->
  exists alp, 0 < alp /\ forall a, D a -> Rball x alp a -> f a <> y.
Proof.
intros f D x y Dx f_cont Hneq ; pose (eps := R_dist (f x) y / 2).
 assert (eps_pos: 0 < eps).
  unfold eps, Rdiv ; apply Rlt_mult_inv_pos.
   apply Rabs_pos_lt ; intro Hf ; apply Hneq, Rminus_diag_uniq ; assumption.
   lra.
 destruct (f_cont Dx eps eps_pos) as [alp [alp_pos Halp]] ; exists alp ; split.
  assumption.
  intros a Da a_in ; apply Rminus_not_eq, Rabs_pos_lt_contravar.
  transitivity (Rabs (f x - y) - eps).
   apply Rlt_le_trans with eps ; [assumption | right ; unfold eps, R_dist ; field].
   apply Rlt_minus_swap ; apply Rle_lt_trans with (dist R_met (f x - y) (f a - y)) ;
   [apply Rabs_triang_inv | rewrite R_dist_sym, R_dist_minus_compat].
 apply Halp ; split ; [| unfold R_dist] ; assumption.
Qed.


Require Import Omega.
Require Import Lia.
Require Import ssreflect.
Require Import ssrfun.
Require Import Coq.ssr.ssrbool.

Notation "a :: b" := (cons a b).
Notation "[]" := (nil).

(* Cette partie a été intéressante car elle nous a fait manipuler les concepts de
base et les définitions.

Toutes les questions sauf la tout dernière (en fait sauf le dernier item de la dernière question),
ont été relativbemetn faciles, si ce n'est gourmandes en lemmes intermédiaires dans
tous les sens (pour montrer quelques banalités spécifiques utiles dans certaines preuves).

Le dernier item de la dernière question (sur l'inversion sous certaines hypothèses
d'une substitution parallèle) m'a posé énormément de fil à retordre, sûrement à cause de
notre définition de la substitution parallèle que je me suis donné! *)

(* Question 1 *)

(* Définition des termes de De Bruijn. On a ajouté un terme `Protect` pour nosu aider
dans la définition de la substitution parallèle. L'idée est qu'une substitution parallèle
est un enchaînement de substitutions simples (donc avec les termes successifs de
la liste. Mais lorsqu'on effectue une substitution simple, on place le terme substitué
dans un terme `Protect` qui garantie qu'il ne sera pas modifié par la suite de la
substitution parallèle. Cf la définition de la substitution parallèle.)

Cela implique que beaucoup de nos lemmes et théorèmes comportent une hypothèse
supplémentaire par rapport au sujet, qui est que le terme en question doit être `safe`,
i.e. ne pas contenir de sous-terme protégés. En effet, les sous-termes protégés
ne doivent apparaître que dans les résultats intermédiaires de substitution. *)

Inductive DeBruijn :=
    | Var : nat -> DeBruijn
    | Lambda : DeBruijn -> DeBruijn
    | Application : DeBruijn -> DeBruijn -> DeBruijn
    | Protect : DeBruijn -> DeBruijn.

Check Application (Lambda (Var 0)) (Lambda (Var 0)).

(* Cette fonction déprotège un terme. Utile après une substitution.*)

Fixpoint deprotect (t: DeBruijn) :=
    match t with
    | Var n => Var n
    | Lambda tp => Lambda (deprotect tp)
    | Application tp1 tp2 => Application (deprotect tp1) (deprotect tp2)
    | Protect tp => deprotect tp
    end
.

(* Basically "detects" if a terms contains a protected subterm *)
Fixpoint protected (t: DeBruijn) : Prop :=
    match t with
    | Var n => False
    | Lambda tp => protected tp
    | Application tp1 tp2 => (protected tp1) \/ (protected tp2)
    | Protect tp => True
    end
.

Fixpoint contains_geq_n (t: DeBruijn) (n: nat) : Prop :=
    match t with
    | Var n0 => n0 >= n
    | Lambda t => contains_geq_n t (n + 1)
    | Application tp1 tp2 => (contains_geq_n tp1 n) \/ (contains_geq_n tp2 n)
    | Protect tp => contains_geq_n tp n
    end
.

(* Est-ce qu'un terme contient une variable >= n protégée. *)
Fixpoint protected_n (t: DeBruijn) (n: nat) : Prop :=
    match t with
    | Var n0 => False
    | Lambda tp => protected_n tp n
    | Application tp1 tp2 => (protected_n tp1 n) \/ (protected_n tp2 n)
    | Protect tp => contains_geq_n tp n
    end
.

(* This is a safe term, without any protected subterm *)
Notation "S( t )" := (~(protected t)).

(* Toutes les variables >= n ne sont pas protégées *)
Notation "S[ n ]( t )" := (~(protected_n t n)).

(* De Morgan *)
Lemma destruct_false_or : forall (P Q: Prop),
    ~(P \/ Q) <-> ~P /\ ~Q.
Proof.
    intuition.
Qed.

(* Lemme utile. Un terme déprotége l'est effectivement. *)
Lemma deprotect_correction : forall (t: DeBruijn),
    S(deprotect t).
Proof.
    intro t.
    induction t.
    simpl. auto.
    simpl. exact IHt.
    simpl. apply <- destruct_false_or. split. exact IHt1. exact IHt2.
    simpl. exact IHt.
Qed.

Lemma lambda_equal : forall (t u: DeBruijn),
    Lambda t = Lambda u -> t = u.
Proof.
    intros t u.
    case. trivial.
Qed.

(* Si t n'a pas de sous-terme protégé, déprotéger t correspond à l'identité *)
Theorem safe_deprotect : forall (t: DeBruijn),
    S(t) -> deprotect(t) = t.
Proof.
    induction t.
    simpl. reflexivity.
    simpl. assert (deprotect t =  t -> Lambda (deprotect t) = Lambda t).
    intro H. rewrite H. reflexivity. intro H0. apply H. apply IHt. exact H0.
    simpl. intro H. apply destruct_false_or in H. destruct H.
    assert (deprotect t1 = t1). apply IHt1. exact H.
    assert (deprotect t2 = t2). apply IHt2. exact H0.
    rewrite H1. rewrite H2. reflexivity.
    simpl. contradiction.
Qed.

(* deprotect est involutive. Utile *)
Lemma deprotect_involutive : forall (t: DeBruijn),
    deprotect (deprotect t) = deprotect t.
Proof.
    move => t.
    assert (S(deprotect t)). apply deprotect_correction.
    apply (safe_deprotect (deprotect t) H).
Qed.

(* Question 2 *)

(* Fonction auxiliaire *)
Fixpoint max_var_smaller_n_depth (t: DeBruijn) (n depth: nat) : Prop :=
    match t with
    | Var v => v < n + depth
    | Lambda tp => max_var_smaller_n_depth tp n (depth + 1)
    | Application tp0 tp1 => (max_var_smaller_n_depth tp0 n depth) /\ (max_var_smaller_n_depth tp1 n depth)
    | Protect tp => max_var_smaller_n_depth tp n depth
    end.

(* Ce qui est demandé dans la question *)
Definition max_var_smaller_n (t: DeBruijn) (n: nat) : Prop :=
    max_var_smaller_n_depth t n 0.

(* Premier élément d'une suite de propriétés d'hérédité sur le C[.](.) *)
Lemma heredite_0: forall (t: DeBruijn), forall (n d: nat),
    (max_var_smaller_n_depth t n d) -> (max_var_smaller_n_depth t (n+1) d).
Proof.
    move => t.
    induction t.
    simpl. lia.
    simpl. intros n d.
    apply IHt.
    intros n d.
    simpl.
    case. intro H1. intro H2.
    split.
    apply IHt1. apply H1.
    apply IHt2. apply H2.
    simpl. intros n d H.
    apply IHt. exact H.
Qed.

Notation "C[ n ]( t )" := (max_var_smaller_n t n).

Lemma C_deprotect_aux : forall (t: DeBruijn), forall (n d: nat),
    max_var_smaller_n_depth t n d = max_var_smaller_n_depth (deprotect t) n d.
Proof.
    move => t n.
    induction t.
    move => d.
    simpl. reflexivity.
    move => d.
    simpl. rewrite (IHt (d + 1)). reflexivity.
    move => d.
    simpl. rewrite IHt1. rewrite IHt2. reflexivity.
    simpl. exact IHt.
Qed.

(* Le prédicat se fiche de la présence de termes protégés *)
Lemma C_deprotect : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> C[n](deprotect t).
Proof.
    move => t n Cn.
    unfold max_var_smaller_n.
    unfold max_var_smaller_n in Cn.
    rewrite <- (C_deprotect_aux t n 0). exact Cn.
Qed.

(* Écrit avant d'avoir découvert qu'il est plu simple d'utiliser lia directement.
 Laissé pour la postérité *)
Lemma inutile_0 : forall (n: nat),
    n + 0 = n.
Proof.
    intro n.
    lia.
Qed.

(* De même *)
Lemma inutile_1 : forall (n: nat),
    S n = n + 1.
Proof.
    intro n.
    lia.
Qed.

(* ... Pareil *)
Lemma inutile_2 : forall (n: nat), forall (m: nat), forall (p: nat),
    n + m + p = n + (m + p).
Proof.
    intros n m p.
    lia.
Qed.

Lemma heredite_1 : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> C[n + 1](t).
Proof.
    intros t n H.
    apply heredite_0. exact H.
Qed.

Lemma heredite_2 : forall (t: DeBruijn), forall (n: nat), forall (m: nat),
    C[n](t) -> C[n + m](t).
Proof.
    intros t n m H.
    induction m.
    simpl. rewrite -> inutile_0. exact H.
    rewrite inutile_1. rewrite <- inutile_2.
    apply heredite_1 with (t := t) (n := n + m). exact IHm.
Qed.

(* Lemme utile *)
Lemma heredite_3 : forall (t: DeBruijn), forall (n: nat), forall (m: nat),
    n <= m -> C[n](t) -> C[m](t).
Proof.
    intros t n m H H0.
    assert (n + (m - n) = m). lia.
    rewrite <- H1.
    apply heredite_2.
    exact H0.
Qed.

Definition closed (T: DeBruijn) :=
    C[0](T).

Notation "C( t )" := (closed t).

(* Équivalence des notions (en fait on n'a montré que le sens direct car
c'est le seul utile) *)
Theorem closed_universal : forall (t: DeBruijn),
    C(t) -> forall (n: nat), C[n](t).
Proof.
    intros t H n.
    induction n.
    exact H.
    assert (n+1 = S n).
    lia.
    rewrite <- H0.
    apply heredite_1 with (t := t) (n := n).
    exact IHn.
Qed.

(* Question 3 *)
(* Fonction de substitution.
À l'origine, on avait uen définition différente (qui nous semblait plus
intuitive, mais nous étions bloqués plus loin en 1.4) *)
Fixpoint substitution (t: DeBruijn) (index: nat) (u: DeBruijn) : DeBruijn :=
    match t with
    | Var n => if n =? index then (Protect u) else (Var n)
    | Lambda tp => Lambda (substitution tp (index + 1) u)
    | Application tp0 tp1 => Application (substitution tp0 index u) (substitution tp1 index u)
    | Protect tp => Protect tp
    end
.

Notation "t [ y <- u ]" := (deprotect (substitution t y u)) (at level 0).

(* Surprisingly very useful. *)
Lemma aux_0 : forall (n n0: nat),
    C[n](Var n0) <-> n > n0.
Proof.
    intros n n0.
    split. intro H.
    induction n.
    unfold max_var_smaller_n in H.
    unfold max_var_smaller_n_depth in H.
    simpl in H. exact H.
    unfold max_var_smaller_n in H.
    unfold max_var_smaller_n_depth in H.
    unfold max_var_smaller_n in IHn.
    unfold max_var_smaller_n_depth in IHn.
    simpl in H. lia.
    intro H.
    unfold max_var_smaller_n.
    unfold max_var_smaller_n_depth. lia.
Qed.

(* Lemme un peu stupide *)
Lemma aux_0_0 : forall (n n0: nat),
    n > n0 -> (Nat.eqb n0 n) = false.
Proof.
    intros n n0 H.
    destruct (PeanoNat.Nat.eqb_neq n0 n).
    apply H1.
    lia.
Qed.

Lemma aux_0_1 : forall (n n0: nat), forall (u: DeBruijn),
    C[n](Var n0) -> (if n0 =? n then u else Var n0) = Var n0.
Proof.
    intros n n0 u H.
    rewrite aux_0_0. apply aux_0. exact H.
    reflexivity.
Qed.

(* Laissé pour des raisons historiques. N'avons-nous pas tous un jour
du prendre en main un langage inconnu et commencé par écrire la fonction la
plus inutile possible? *)
Lemma aux_1_0 : forall (t u: DeBruijn),
    u = t -> Lambda u = Lambda t.
Proof.
    intros t u H.
    rewrite H. reflexivity.
Qed.

(* Cf le lemme juste au-dessus *)
Lemma aux_1_1 : forall (t1 t2 u1 u2: DeBruijn),
    t1 = u1 -> t2 = u2 -> Application t1 t2 = Application u1 u2.
Proof.
    intros t1 t2 u1 u2 H H0.
    rewrite H. rewrite H0. reflexivity.
Qed.

(* Aha enfin un lemme utile. Il a été très utile pour démontrer des trucs techniques
dans des hérédités. *)
Lemma aux_2_0 : forall (t: DeBruijn), forall (n d: nat),
    max_var_smaller_n_depth t n (d + 1) <-> max_var_smaller_n_depth t (n + 1) d.
Proof.
    move => t n d.
    split.
    revert d.
    induction t.
    simpl.
    lia.
    simpl.
    move => d.
    apply IHt with (d := d + 1).
    simpl. case. case.
    simpl. split.
    apply IHt1 with (d := 0). simpl. exact a.
    apply IHt2 with (d := 0). simpl. exact b.
    split.
    destruct H.
    apply IHt1 with (d := S n0). exact H.
    destruct H.
    apply IHt2 with (d := S n0). exact H0.
    simpl. exact IHt.

    revert d.
    induction t.
    move => d.
    simpl. lia.
    move => d.
    simpl. exact (IHt (d + 1)).
    move => d.
    simpl. move => H.
    destruct H.
    split.
    exact (IHt1 d H).
    exact (IHt2 d H0).
    move => d.
    simpl. exact (IHt d).
Qed.

(* Un peu la même chose mais en variant le terme au lieu de d *)
Lemma aux_2_1 : forall (t: DeBruijn), forall (n d: nat),
    max_var_smaller_n_depth (Lambda t) n d <-> max_var_smaller_n_depth t (n + 1) d.
Proof.
    split.
    intros H.
    induction t.
    simpl. simpl in H.
    lia.
    simpl in H.
    simpl. apply -> aux_2_0. exact H.
    simpl. split.
    destruct H.
    apply aux_2_0. exact H.
    destruct H.
    apply aux_2_0. exact H0.
    simpl. apply IHt. simpl in H. simpl. exact H.

    move => H.
    induction t.
    simpl. unfold max_var_smaller_n_depth in H.
    lia.
    simpl. simpl in H. apply <- (aux_2_0 t n (d + 1)). exact H.
    simpl. destruct H.
    split.
    exact (IHt1 H).
    exact (IHt2 H0).
    simpl. simpl in H. simpl in IHt.
    exact (IHt H).
Qed.

(* A montré son utilité *)
Lemma aux_2_2 : forall (t: DeBruijn), forall (n: nat),
    C[n](Lambda t) -> C[n + 1](t).
Proof.
    intros t n H.
    simpl. apply aux_2_1. exact H.
Qed.

(*Nous n'avions plus de place dans la section `lemmes stupides` donc on l'a mis là *)
Lemma aux_3 : forall (t1 t2: DeBruijn), forall (n: nat),
    C[n](Application t1 t2) -> C[n](t1) /\ C[n](t2).
Proof.
    intros t1 t2 n H.
    unfold max_var_smaller_n in H. unfold max_var_smaller_n_depth in H.
    fold max_var_smaller_n_depth in H. trivial.
Qed.

(* ... *)
Lemma protect_aux_0 : forall (t: DeBruijn), forall (u: DeBruijn),
    t = u -> deprotect t = deprotect u.
Proof.
    intros t u H.
    rewrite H. reflexivity.
Qed.

(* Un des théorèmes intéressant de la partie. On, a du l'adapter
pour accomoder la potentielle protection des sous-termes *)
Theorem substitution_aux : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> forall (u: DeBruijn), t[n <- u] = deprotect t.
Proof.
    intro t.
    induction t.
    simpl. intros n0 H u.
    assert (forall (n: nat), deprotect (Var n) = Var n).
    simpl. reflexivity. rewrite <- H0. apply protect_aux_0.
    apply aux_0_1. exact H.
    simpl. intros n H u. apply aux_1_0.
    apply IHt with (n := n + 1). apply aux_2_2 with (t := t) (n := n). exact H.
    intros n H u.
    simpl. apply aux_3 in H.
    destruct H.
    rewrite IHt1. exact H.
    rewrite IHt2. exact H0.
    reflexivity.
    intros n H u. simpl. reflexivity.
Qed.

Theorem substitution_thm_general : forall (t: DeBruijn),
    closed t -> forall (u: DeBruijn), forall (n: nat), t[n <- u] = deprotect t.
Proof.
    intros t H u n.
    apply substitution_aux.
    apply closed_universal.
    trivial.
Qed.

Theorem substitution_thm : forall (t: DeBruijn),
    C(t) -> S(t) -> forall (u: DeBruijn), forall (n: nat), t[n <- u] = t.
Proof.
    intros t C S.
    assert (deprotect t = t).
    apply safe_deprotect. exact S.
    pattern (t) at 2. rewrite <- H.
    apply substitution_thm_general.
    exact C.
Qed.

Theorem raw_substitution_aux : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> forall (u: DeBruijn), substitution t n u = t.
Proof.
    intro t.
    induction t.
    simpl. intros n0 H u.
    simpl. apply aux_0_1. exact H.

    move => n H u. simpl. apply aux_1_0. simpl.
    assert (C[n + 1](t)). apply aux_2_2. exact H.
    apply (IHt (n + 1) H0 u).

    move => n H u. simpl. apply aux_3 in H.
    destruct H.
    rewrite (IHt1 n H u).
    rewrite (IHt2 n H0 u).
    reflexivity.

    move => n C u.
    simpl. reflexivity.
Qed.

Theorem raw_substitution_thm_general : forall (t: DeBruijn),
    closed t -> forall (u: DeBruijn), forall (n: nat), substitution t n u = t.
Proof.
    intros t H u n.
    apply raw_substitution_aux.
    apply closed_universal.
    trivial.
Qed.

Lemma partial_safeness_passes : forall (t: DeBruijn), forall (n: nat),
    S[n](t) <-> S[n](Lambda t)
.
Proof.
    induction t.
    move => n0.
    simpl. intuition.
    move => n.
    apply (IHt n).
    move => n.
    simpl. intuition.
    intuition.
Qed.

Lemma contains_geq_n_heredite_1 : forall (t: DeBruijn), forall (n: nat),
    ~ (contains_geq_n t n) -> ~ (contains_geq_n t (n + 1))
.
Proof.
    induction t.
    move => n0.
    simpl. lia.
    move => n.
    simpl. exact (IHt (n + 1)).
    simpl.
    move => n H.
    apply destruct_false_or.
    apply destruct_false_or in H. destruct H.
    split. apply (IHt1 n H).
    apply (IHt2 n H0).
    simpl. trivial.
Qed.

(* Propriété peu intéressante *)
Lemma partial_safeness_heredite_1 : forall (t: DeBruijn), forall (n: nat),
    S[n](t) -> S[n + 1](t)
.
Proof.
    induction t.
    move => n0.
    simpl. intuition.
    move => n.
    simpl. apply (IHt n).
    move => n.
    simpl. intro.
    apply destruct_false_or. apply destruct_false_or in H.
    destruct H.
    split. exact (IHt1 n H).
    exact (IHt2 n H0).
    move => n.
    simpl. exact (contains_geq_n_heredite_1 t n).
Qed.

(* Simple décomposition *)
Lemma partial_safeness_application : forall (tp1 tp2: DeBruijn), forall (n: nat),
    S[n](Application tp1 tp2) -> (S[n](tp1)) /\ (S[n](tp2))
.
Proof.
    move => tp1 tp2 n H.
    simpl in H. apply destruct_false_or in H.
    destruct H.
    split.
    exact H. exact H0.
Qed.

Lemma not_contains_geq_n_Cn : forall (t: DeBruijn), forall (n: nat),
    ~ (contains_geq_n t n) -> C[n](t)
.
Proof.
    induction t.
    move => n0.
    simpl. unfold max_var_smaller_n. simpl. lia.
    move => n.
    simpl. move => H. unfold max_var_smaller_n. simpl. unfold max_var_smaller_n in IHt.
    assert (max_var_smaller_n_depth t (n + 1) 0).
    apply (IHt (n + 1) H).
    apply <- (aux_2_0 t n 0). exact H0.
    simpl. move => n H.
    apply destruct_false_or in H.
    unfold max_var_smaller_n.
    destruct H.
    split.
    exact (IHt1 n H).
    exact (IHt2 n H0).
    move => n.
    simpl.
    unfold max_var_smaller_n. simpl. exact (IHt n).
Qed.

Lemma not_contains_geq_n_Cn_reversed : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> ~ (contains_geq_n t n)
.
Proof.
    induction t.
    move => n0 H.
    simpl.
    assert (n0 > n). apply aux_0. exact H.
    lia.
    move => n H.
    simpl.
    assert (C[n + 1](t)). apply aux_2_1. exact H.
    exact (IHt (n + 1) H0).
    move => n C.
    destruct C.
    apply destruct_false_or.
    split. 1-2:fold contains_geq_n.
    exact (IHt1 n H).
    exact (IHt2 n H0).
    simpl.
    trivial.
Qed.

Lemma not_contains_Cn : forall (t: DeBruijn), forall (n: nat),
    C[n](t) <-> ~ (contains_geq_n t n)
.
Proof.
    move => t n.
    split.
    move => C.
    apply not_contains_geq_n_Cn_reversed. exact C.
    move => S.
    apply not_contains_geq_n_Cn. exact S.
Qed.

(* Ceci montre une équivalence entre deux notions *)
Lemma partial_safety_protect_C : forall (t: DeBruijn), (forall (n: nat),
    S[n](Protect t) <-> C[n](t))
.
Proof.
    split.
    move => Sn.
    induction t.
    unfold max_var_smaller_n. simpl.
    unfold protected_n in Sn.
    unfold contains_geq_n in Sn. lia.
    simpl in Sn.
    assert (~(contains_geq_n (Lambda t) n)).
    simpl. exact Sn.
    apply not_contains_geq_n_Cn. exact H.
    simpl. simpl in Sn. apply destruct_false_or in Sn. destruct Sn.
    split.
    apply (IHt1 H).
    apply (IHt2 H0).
    unfold max_var_smaller_n. simpl. simpl in IHt.
    simpl in Sn. exact (IHt Sn).

    move => C.
    unfold protected_n.
    apply not_contains_Cn. exact C.
Qed.

(* Le seul `admit` entre 1.1 et 5.3 inclus. On n'a pas trouvé comment éviter ce genre de choses*)
Lemma stupid_0 : forall (n n0: nat),
    (n =? n0) = true <-> n = n0.
Proof.
    intros n n0.
    admit.
Admitted.

Lemma partial__protect_identity_aux : forall (t: DeBruijn), forall (n: nat), forall (u: DeBruijn),
    C[n](t) -> (deprotect t)[n <- u] = deprotect t
.
Proof.
    induction t.
    revert n.
    simpl.
    move => n n0 u Cn0.
    case_eq (n =? n0).
    move => H.
    assert (n < n0). apply aux_0.
    exact Cn0.
    assert (n = n0). apply stupid_0. exact H.
    assert (~(n = n0)). lia. contradiction.
    move => H. simpl. reflexivity.
    move => n u Cn.
    simpl. apply aux_1_0.
    apply (IHt (n + 1) u).
    apply aux_2_1. exact Cn.
    move => n u Cn.
    destruct Cn.
    simpl. apply aux_1_1.
    exact (IHt1 n u H).
    exact (IHt2 n u H0).
    simpl. assumption.
Qed.

(* Principale théorème lié à la substitution simple *)
Theorem partial_protect_identity : forall (t: DeBruijn),
    forall (n: nat), forall (u: DeBruijn),
    S[n](t) -> t[n <- u] = (deprotect t)[n <- u]
.
Proof.
    induction t.
    move => n0 u Sn0.
    simpl. reflexivity.
    move => n u Sn.
    simpl. assert (S[n](t)). apply partial_safeness_passes. exact Sn.
    apply aux_1_0. rewrite (IHt (n + 1) u).
    exact (partial_safeness_heredite_1 t n H).
    reflexivity.
    move => n u.
    move => Sn.
    simpl. assert (S[n](t1) /\ S[n](t2)). apply partial_safeness_application. exact Sn.
    apply aux_1_1.
    destruct H.
    exact (IHt1 n u H).
    destruct H.
    exact (IHt2 n u H0).
    move => n u Sn.
    simpl. assert (C[n](t)). apply partial_safety_protect_C.
    exact Sn.
    assert (deprotect t = (deprotect t) [n <- u] <-> (deprotect t)[n <- u] = (deprotect t)).
    intuition. apply H0. apply partial__protect_identity_aux.
    exact H.
Qed.

(* Question 4 *)

(* Définition de la substitution multiple.
On remarque que c'est simplement une itération de la susbtitution simple.
Cela correspond bien à la définition car les termes substitués restent protégés
pour la suite de la substitution parallèle. Ainsi on est sûrs de ne pas les modifier.

Je voulais vraiment  avec une substitution multiple définie par induction sur
la lsite de termes, donc comem un enchaînement de substitutions simples. Cela
m'a obligé à procéder à l'ajout du terme Protect dans la définition (et donc à
refaire netièrement la partie 1 pour intégrer ce terme dans les preuves).

Finalement, même si on a une définition de la substitution parallèle un peu plus
intuitive, la preuve de 1.4.3 a été absolument infernale et on se retrouve bloqués
à 5.4, probablement à cause de la complication de la définition des lambda-termes.
Ce n'était donc pas, avec un peu de recul, une si bonne idée! *)
Fixpoint substitution_multiple_aux (t: DeBruijn) (offset: nat) (u: list DeBruijn) : DeBruijn :=
    match u with
    | [] => t
    | hd :: tl =>
    substitution (substitution_multiple_aux t (offset + 1) tl) (offset) hd
    end
.

Definition substitution_multiple (t: DeBruijn) (base: nat) (u: list DeBruijn) :=
    substitution_multiple_aux t base u.

Notation "t [ n <-- l ]" := (deprotect (substitution_multiple t n l)) (at level 0).

(* Première propriété de 1.4.
Rendue triviale par notre définition de la substitution parallèle *)
Theorem substitution_multiple_nil : forall (t: DeBruijn), forall (n: nat),
    S(t) -> t[n <-- []] = t.
Proof.
    intros t n H.
    unfold substitution_multiple.
    unfold substitution_multiple_aux.
    apply safe_deprotect. exact H.
Qed.

(* C'est juste l'explicitation de la façon dont fonctionne une itération de susbtitution multiple*)
Lemma substitution_multiple_one_step : forall (t: DeBruijn), forall (n: nat),
    forall (u: DeBruijn), forall (terms: list DeBruijn),
    S(t) -> substitution_multiple t n (u :: terms) =
        substitution (substitution_multiple t (n + 1) terms) n u.
Proof.
    intros t n u terms H .
    induction terms.
    unfold substitution_multiple.
    unfold substitution_multiple_aux.
    reflexivity.
    reflexivity.
Qed.

(* Un peu la même chose que pour la substitution simple.
Si t ne contient pas de variable libre >= n, en substituant de façon multiple
avec un indice m >= n, on ne fait rien *)
Theorem substitution_multiple_C_0 : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> S(t) -> forall (u: list DeBruijn), forall (m: nat),
    m >= n -> substitution_multiple t m u = t.
Proof.
    move => t n C S.
    induction u.
    unfold substitution_multiple.
    move => m cmp.
    unfold substitution_multiple_aux. reflexivity.

    move => m cmp.
    rewrite (substitution_multiple_one_step t m a u S).

    assert (m + 1 >= n). lia.
    rewrite (IHu (m + 1) H).

    apply raw_substitution_aux. apply (heredite_3 t n m). lia. exact C.
Qed.

(* Théorème 2 de 1.4. Cela n'a encore pas été très difficile.
Le pire arrive... *)
Theorem substitution_multiple_C_thm : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> S(t) -> forall (u: list DeBruijn), t[n <-- u] = t.
Proof.
    move => t n C S u.
    assert (n >= n). lia.
    rewrite (substitution_multiple_C_0 t n C S u n H).
    apply safe_deprotect. exact S.
Qed.

(* C'est une définition de `forall k >= 1, C[i](u_k)*)
Fixpoint C_multiple (u: list DeBruijn) (n: nat) : Prop :=
    match u with
    | [] => True
    | hd :: tl => (C[n](hd)) /\ (C_multiple tl n)
    end
.

(* Petite notation sympathique *)
Notation "Cm[ n ]( u )" := (C_multiple (List.tl u) n).

(* J'ai besoin de dire que ce lemme n'est là que pour des raisons historiques? :) *)
Lemma sub_preserves_equality : forall (t: DeBruijn), forall (u: DeBruijn),
    forall (n: nat), forall (v: DeBruijn),
    t = u -> t[n <- v] = u[n <- v].
Proof.
    move => t u n v E.
    rewrite E.
    reflexivity.
Qed.

(* Début d'une trèèèèèès longue série de lemmes stupides manipulant des listes,
des propritéts sur des lsites, etc.
(Je n'ai découvert que plus tard l'existence d'une library `List`
dans la stdlib de Coq qui fournit déjà tous ces lemmes...)*)
Lemma cm_add : forall (u: list DeBruijn), forall (n: nat), forall (a: DeBruijn),
    Cm[n](a::u) -> C_multiple u n.
Proof.
    move => u n a Cm.
    unfold C_multiple in Cm.
    unfold C_multiple.
    trivial.
Qed.

(* Suite *)
Lemma cm_completion : forall(u : list DeBruijn), forall(a: DeBruijn), forall (n: nat),
    Cm[n](u) -> C[n](List.hd (Var 0) u) -> Cm[n](a :: u).
Proof.
    move => u a n Cm C.
    induction u.
    trivial.
    simpl.
    split.
    simpl in C. exact C.
    apply (cm_add u n a0).
    exact Cm.
Qed.

(* Suite *)
Lemma list_prop_completion : forall (t: list DeBruijn), forall (a: DeBruijn),
    forall (f: DeBruijn -> Prop),
    (List.Forall f t) -> f a -> (List.Forall f (a :: t)).
Proof.
    move => t a f.
    intuition.
Qed.

(* Suite *)
Lemma cm_conversion : forall (u: list DeBruijn), forall(n: nat),
    C_multiple u n -> Cm[n](u).
Proof.
    move => u n.
    induction u.^
    simpl. trivial.
    simpl. intuition.
Qed.

(* Suite *)
Lemma cm_truc : forall (u: list DeBruijn), forall (a: DeBruijn), forall (b: DeBruijn),
    forall (n: nat),
    Cm[n](a :: b :: u) -> C[n](b).
Proof.
    intros u a b n H.
    unfold C_multiple in H. simpl in H.
    destruct H.
    exact H.
Qed.

(* ........ Suite! *)
Lemma cm_truc_2 : forall (u: list DeBruijn), forall (a: DeBruijn), forall (b: DeBruijn),
    forall (n: nat),
    Cm[n](a :: b :: u) -> Cm[n](u).
Proof.
    intros u a  b n H.
    unfold C_multiple in H. simpl in H.
    destruct H. apply (cm_conversion u n).
    fold C_multiple in H0.
    exact H0.
Qed.

(* Suite *)
Lemma cm_truc_3 : forall (u: list DeBruijn), forall (a: DeBruijn), forall (n: nat),
    Cm[n](a :: u) -> Cm[n](u).
Proof.
    induction u.
    simpl. intuition.
    move => a0 n.
    simpl. intuition.
Qed.

(* Suite *)
Lemma cm_truc_4 : forall(u : DeBruijn), forall (a: DeBruijn), forall (terms: list DeBruijn),
    forall (n: nat),
    Cm[n](u :: a :: terms) -> Cm[n](u :: terms).
Proof.
    intros u a terms n H.
    assert (C_multiple (a :: terms) n). intuition.
    assert (Cm[n](a :: terms)). apply cm_conversion. exact H0.
    assert (C_multiple terms n). intuition.
    intuition.
Qed.

(* etiuS *)
Lemma cm_meaning : forall (u: list DeBruijn), forall (n: nat),
    Cm[n](u) -> List.Forall (fun x => C[n](x)) (List.tl u).
Proof.
    move => u n Cm.
    induction u. simpl.
    intuition.

    simpl.
    induction u. intuition.
    apply (list_prop_completion u a0 (max_var_smaller_n^~ n)).
    assert (Cm[n](u)). apply (cm_truc_2 u a a0 n). exact Cm.
    assert C[n](a0). apply (cm_truc u a a0 n). exact Cm.
    assert (Cm[n](a0::u)). apply (cm_truc_3 (a0::u) a n). exact Cm.
    apply IHu. exact H1. apply (cm_truc u a a0). exact Cm.
Qed.

(* Aha enfin quelque chose de différent et d'un peu moins boilerplate!
Moui un peu boilerplaater quand même *)
Lemma heredite_var : forall (n: nat), forall (n0: nat),
    C[n](Var n0) -> C[n + 1](Var (n0 + 1)).
Proof.
    move => n n0.
    unfold max_var_smaller_n.
    simpl. lia.
Qed.

(* Oui, nous sommes sérieux. *)
Lemma stupid_1 : forall(n0: nat),
    (0 <=? n0) = false -> False.
Proof.
    simpl. intuition.
Qed.

(* Ceci est peut-être en double *)
Lemma heredite_correct_variable_aux : forall (t: DeBruijn), forall (n: nat),
    forall (d: nat), forall (dp: nat),
    max_var_smaller_n_depth t n d ->
        max_var_smaller_n_depth t (n + 1) d.
Proof.
    induction t.
    simpl.
    move => n0 d dp.
    move => cond.((substitution_multiple (tau_code i) 1 (tau_environment_aux e))
    case_eq (dp <=? n).
    move => Cond.
    simpl. lia.
    move => Cond.
    simpl. lia.

    move => n d dp.
    unfold max_var_smaller_n. simpl.
    unfold max_var_smaller_n in IHt.
    exact (IHt n (d + 1) (dp + 1)).

    move => n d dp.
    unfold max_var_smaller_n. simpl.
    split.
    apply (IHt1 n d dp).
    destruct H.
    exact H.

    apply (IHt2 n d dp).
    destruct H.
    exact H0.

    move => n d dp.
    unfold max_var_smaller_n. simpl.
    exact (IHt n d dp).
Qed.

Lemma heredite_correct_variable : forall (t: DeBruijn), forall (n: nat),
    C[n](t) -> C[n + 1]( t).
Proof.
    move => t n Cn.
    apply (heredite_correct_variable_aux t n). intuition.
    exact Cn.
Qed.

(* Ceci est intéressant, on s'approche enfin du but! *)
Lemma substitution_multiple_commut : forall (t: DeBruijn), forall (n: nat), forall (u1 u2: DeBruijn),
    S(t) -> C[n](u2) -> t[n <-- u1 :: u2 :: []] = t[n+1 <- u2][n <- u1].
Proof.
    simpl.
    induction t.
    revert n.
    simpl.
    move => n0 n u1 u2 S C2.
    case_eq (n0 =? n + 1).
    move => egalite.
    apply stupid_0 in egalite.
    simpl. assert (S(deprotect u2)). apply deprotect_correction.
    assert (C[n](deprotect u2)). apply (C_deprotect u2 n). exact C2.
    assert ((deprotect u2)[n <- u1] = deprotect (deprotect u2)).
    apply (substitution_aux (deprotect u2) n H0 u1).
    rewrite -> deprotect_involutive in H1.
    intuition.
    simpl. intro H. reflexivity.
    move => n u1 u2 S C. assert (S(t)). intuition.
    assert (C[n + 1](u2)). apply (heredite_1 u2 n C). simpl.
    apply aux_1_0.
    assert (C[n + 1](u2)). apply (heredite_correct_variable u2 n C).
    rewrite (IHt (n + 1) u1 u2 H H1). reflexivity.
    move => n u1 u2 S C2.
    simpl. apply aux_1_1.
    assert (S(t1)). unfold protected in S. intuition.
    apply (IHt1 n u1 u2 H C2).
    assert (S(t2)). unfold protected in S. intuition.
    apply (IHt2 n u1 u2 H C2).
    move => n u1 u2 S C2.
    simpl. contradiction S. simpl. trivial.
Qed.

(* Pendant à un théorème similaire sur C[n](t) *)
Lemma protected_protected_n : forall (t: DeBruijn),
    S(t) -> forall (n: nat), S[n](t)
.
Proof.
    induction t.
    move => S n0.
    unfold protected_n.
    intuition.
    simpl.
    assumption.
    simpl.
    move => H. apply destruct_false_or in H. destruct H.
    move => n.
    apply destruct_false_or. split.
    exact (IHt1 H n).
    exact (IHt2 H0 n).
    simpl. intuition.
Qed.

Lemma Sn_heredite_substitution : forall (t: DeBruijn), forall (a: DeBruijn), forall (n: nat),
    S[n](t) -> C[n](a) -> (forall (m: nat), S[n](substitution t m a))
.
Proof.
    induction t.
    move => a n0 Sn0 Cn0 m.
    simpl. case_eq (n =? m).
    move => H. apply stupid_0 in H.
    simpl.
    apply partial_safety_protect_C. exact Cn0.
    move => H. exact Sn0.
    move => a n Sn Cn m.
    simpl.
    exact (IHt a n Sn Cn (m + 1)).
    move => a n Sn Cn m.
    simpl.
    apply destruct_false_or.
    simpl in Sn. apply destruct_false_or in Sn.
    destruct Sn.
    split.
    exact (IHt1 a n H Cn m).
    exact (IHt2 a n H0 Cn m).
    move => a n Sn Cn m.
    simpl. simpl in Sn. exact Sn.
Qed.

(* Paraît très obscur mais en  fait c'est très utile pour démontrer la dernière
propriété de la partie 1 *)
Lemma petit_lemme_final : forall (t: DeBruijn),  forall (terms: list DeBruijn),
    S(t) -> (forall (n: nat), C_multiple terms n ->
    (forall (m: nat), S[n](substitution_multiple t m terms)))
.
Proof.
    induction terms.
    move => S n H m. apply (protected_protected_n t S n).
    simpl. move => S n H m.
    destruct H. apply (Sn_heredite_substitution
        (substitution_multiple t (m + 1) terms) a
    ). exact (IHterms S n H0 (m + 1)). exact H.
Qed.

(* Finally, le théorème sur l'inversion d'une substitution parallèle!
Il m'a donné énormément de fil à retordre mais on l'a enfin, après beaucoup de lemmes
intermédiaires testés, prouvés en fait faux, etc.*)
Theorem substitution_multiple_C_2 : forall (t: DeBruijn), forall (n: nat), forall (u: DeBruijn),
    forall (terms: list DeBruijn),
    S(t) -> Cm[n](u :: terms) -> t[n <-- u :: terms] =
        (t[n+1 <--terms])[n <- u].
Proof.
    induction terms.
    revert n.
    move => n S Cm.
    simpl. rewrite (safe_deprotect t S). reflexivity.

    assert (forall (t0: DeBruijn), S(t0) -> C[n](a) -> t0[n <-- u :: a :: []] = (t0[n + 1 <-- a :: []])[n <- u]).
    intros t0 H H0. apply substitution_multiple_commut. exact H. exact H0.
    move => S Cm.
    assert (Cm[n](u :: terms)). apply (cm_truc_4 u a terms n Cm).
    apply partial_protect_identity.
    assert (C_multiple (a :: terms) n). apply (cm_add (a:: terms) n u Cm).
    apply (petit_lemme_final t (a::terms) S n H1).
Qed.


(************************************************************************)
(*  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        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Export ZLt.

Module ZAddOrderProp (Import Z : ZAxiomsMiniSig').
Include ZOrderProp Z.

(** Theorems that are either not valid on N or have different proofs
    on N and Z *)

Theorem add_neg_neg : forall n m, n < 0 -> m < 0 -> n + m < 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_lt_mono.
Qed.

Theorem add_neg_nonpos : forall n m, n < 0 -> m <= 0 -> n + m < 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_lt_le_mono.
Qed.

Theorem add_nonpos_neg : forall n m, n <= 0 -> m < 0 -> n + m < 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_le_lt_mono.
Qed.

Theorem add_nonpos_nonpos : forall n m, n <= 0 -> m <= 0 -> n + m <= 0.
Proof.
intros. rewrite <- (add_0_l 0). now apply add_le_mono.
Qed.

(** Sub and order *)

Theorem lt_0_sub : forall n m, 0 < m - n <-> n < m.
Proof.
intros n m. now rewrite (add_lt_mono_r _ _ n), add_0_l, sub_simpl_r.
Qed.

Notation sub_pos := lt_0_sub (only parsing).

Theorem le_0_sub : forall n m, 0 <= m - n <-> n <= m.
Proof.
intros n m. now rewrite (add_le_mono_r _ _ n), add_0_l, sub_simpl_r.
Qed.

Notation sub_nonneg := le_0_sub (only parsing).

Theorem lt_sub_0 : forall n m, n - m < 0 <-> n < m.
Proof.
intros n m. now rewrite (add_lt_mono_r _ _ m), add_0_l, sub_simpl_r.
Qed.

Notation sub_neg := lt_sub_0 (only parsing).

Theorem le_sub_0 : forall n m, n - m <= 0 <-> n <= m.
Proof.
intros n m. now rewrite (add_le_mono_r _ _ m), add_0_l, sub_simpl_r.
Qed.

Notation sub_nonpos := le_sub_0 (only parsing).

Theorem opp_lt_mono : forall n m, n < m <-> - m < - n.
Proof.
intros n m. now rewrite <- lt_0_sub, <- add_opp_l, <- sub_opp_r, lt_0_sub.
Qed.

Theorem opp_le_mono : forall n m, n <= m <-> - m <= - n.
Proof.
intros n m. now rewrite <- le_0_sub, <- add_opp_l, <- sub_opp_r, le_0_sub.
Qed.

Theorem opp_pos_neg : forall n, 0 < - n <-> n < 0.
Proof.
intro n; now rewrite (opp_lt_mono n 0), opp_0.
Qed.

Theorem opp_neg_pos : forall n, - n < 0 <-> 0 < n.
Proof.
intro n. now rewrite (opp_lt_mono 0 n), opp_0.
Qed.

Theorem opp_nonneg_nonpos : forall n, 0 <= - n <-> n <= 0.
Proof.
intro n; now rewrite (opp_le_mono n 0), opp_0.
Qed.

Theorem opp_nonpos_nonneg : forall n, - n <= 0 <-> 0 <= n.
Proof.
intro n. now rewrite (opp_le_mono 0 n), opp_0.
Qed.

Theorem lt_m1_0 : -1 < 0.
Proof.
apply opp_neg_pos, lt_0_1.
Qed.

Theorem sub_lt_mono_l : forall n m p, n < m <-> p - m < p - n.
Proof.
intros. now rewrite <- 2 add_opp_r, <- add_lt_mono_l, opp_lt_mono.
Qed.

Theorem sub_lt_mono_r : forall n m p, n < m <-> n - p < m - p.
Proof.
intros. now rewrite <- 2 add_opp_r, add_lt_mono_r.
Qed.

Theorem sub_lt_mono : forall n m p q, n < m -> q < p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply lt_trans with (m - p);
[now apply sub_lt_mono_r | now apply sub_lt_mono_l].
Qed.

Theorem sub_le_mono_l : forall n m p, n <= m <-> p - m <= p - n.
Proof.
intros. now rewrite <- 2 add_opp_r, <- add_le_mono_l, opp_le_mono.
Qed.

Theorem sub_le_mono_r : forall n m p, n <= m <-> n - p <= m - p.
Proof.
intros. now rewrite <- 2 add_opp_r, add_le_mono_r.
Qed.

Theorem sub_le_mono : forall n m p q, n <= m -> q <= p -> n - p <= m - q.
Proof.
intros n m p q H1 H2.
apply le_trans with (m - p);
[now apply sub_le_mono_r | now apply sub_le_mono_l].
Qed.

Theorem sub_lt_le_mono : forall n m p q, n < m -> q <= p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply lt_le_trans with (m - p);
[now apply sub_lt_mono_r | now apply sub_le_mono_l].
Qed.

Theorem sub_le_lt_mono : forall n m p q, n <= m -> q < p -> n - p < m - q.
Proof.
intros n m p q H1 H2.
apply le_lt_trans with (m - p);
[now apply sub_le_mono_r | now apply sub_lt_mono_l].
Qed.

Theorem le_lt_sub_lt : forall n m p q, n <= m -> p - n < q - m -> p < q.
Proof.
intros n m p q H1 H2. apply (le_lt_add_lt (- m) (- n));
[now apply -> opp_le_mono | now rewrite 2 add_opp_r].
Qed.

Theorem lt_le_sub_lt : forall n m p q, n < m -> p - n <= q - m -> p < q.
Proof.
intros n m p q H1 H2. apply (lt_le_add_lt (- m) (- n));
[now apply -> opp_lt_mono | now rewrite 2 add_opp_r].
Qed.

Theorem le_le_sub_lt : forall n m p q, n <= m -> p - n <= q - m -> p <= q.
Proof.
intros n m p q H1 H2. apply (le_le_add_le (- m) (- n));
[now apply -> opp_le_mono | now rewrite 2 add_opp_r].
Qed.

Theorem lt_add_lt_sub_r : forall n m p, n + p < m <-> n < m - p.
Proof.
intros n m p. now rewrite (sub_lt_mono_r _ _ p), add_simpl_r.
Qed.

Theorem le_add_le_sub_r : forall n m p, n + p <= m <-> n <= m - p.
Proof.
intros n m p. now rewrite (sub_le_mono_r _ _ p), add_simpl_r.
Qed.

Theorem lt_add_lt_sub_l : forall n m p, n + p < m <-> p < m - n.
Proof.
intros n m p. rewrite add_comm; apply lt_add_lt_sub_r.
Qed.

Theorem le_add_le_sub_l : forall n m p, n + p <= m <-> p <= m - n.
Proof.
intros n m p. rewrite add_comm; apply le_add_le_sub_r.
Qed.

Theorem lt_sub_lt_add_r : forall n m p, n - p < m <-> n < m + p.
Proof.
intros n m p. now rewrite (add_lt_mono_r _ _ p), sub_simpl_r.
Qed.

Theorem le_sub_le_add_r : forall n m p, n - p <= m <-> n <= m + p.
Proof.
intros n m p. now rewrite (add_le_mono_r _ _ p), sub_simpl_r.
Qed.

Theorem lt_sub_lt_add_l : forall n m p, n - m < p <-> n < m + p.
Proof.
intros n m p. rewrite add_comm; apply lt_sub_lt_add_r.
Qed.

Theorem le_sub_le_add_l : forall n m p, n - m <= p <-> n <= m + p.
Proof.
intros n m p. rewrite add_comm; apply le_sub_le_add_r.
Qed.

Theorem lt_sub_lt_add : forall n m p q, n - m < p - q <-> n + q < m + p.
Proof.
intros n m p q. now rewrite lt_sub_lt_add_l, add_sub_assoc, <- lt_add_lt_sub_r.
Qed.

Theorem le_sub_le_add : forall n m p q, n - m <= p - q <-> n + q <= m + p.
Proof.
intros n m p q. now rewrite le_sub_le_add_l, add_sub_assoc, <- le_add_le_sub_r.
Qed.

Theorem lt_sub_pos : forall n m, 0 < m <-> n - m < n.
Proof.
intros n m. now rewrite (sub_lt_mono_l _ _ n), sub_0_r.
Qed.

Theorem le_sub_nonneg : forall n m, 0 <= m <-> n - m <= n.
Proof.
intros n m. now rewrite (sub_le_mono_l _ _ n), sub_0_r.
Qed.

Theorem sub_lt_cases : forall n m p q, n - m < p - q -> n < m \/ q < p.
Proof.
intros. now apply add_lt_cases, lt_sub_lt_add.
Qed.

Theorem sub_le_cases : forall n m p q, n - m <= p - q -> n <= m \/ q <= p.
Proof.
intros. now apply add_le_cases, le_sub_le_add.
Qed.

Theorem sub_neg_cases : forall n m, n - m < 0 -> n < 0 \/ 0 < m.
Proof.
intros.
rewrite <- (opp_neg_pos m). apply add_neg_cases. now rewrite add_opp_r.
Qed.

Theorem sub_pos_cases : forall n m, 0 < n - m -> 0 < n \/ m < 0.
Proof.
intros.
rewrite <- (opp_pos_neg m). apply add_pos_cases. now rewrite add_opp_r.
Qed.

Theorem sub_nonpos_cases : forall n m, n - m <= 0 -> n <= 0 \/ 0 <= m.
Proof.
intros.
rewrite <- (opp_nonpos_nonneg m). apply add_nonpos_cases. now rewrite add_opp_r.
Qed.

Theorem sub_nonneg_cases : forall n m, 0 <= n - m -> 0 <= n \/ m <= 0.
Proof.
intros.
rewrite <- (opp_nonneg_nonpos m). apply add_nonneg_cases. now rewrite add_opp_r.
Qed.

Section PosNeg.

Variable P : Z.t -> Prop.
Hypothesis P_wd : Proper (eq ==> iff) P.

Theorem zero_pos_neg :
  P 0 -> (forall n, 0 < n -> P n /\ P (- n)) -> forall n, P n.
Proof.
intros H1 H2 n. destruct (lt_trichotomy n 0) as [H3 | [H3 | H3]].
apply opp_pos_neg, H2 in H3. destruct H3 as [_ H3].
now rewrite opp_involutive in H3.
now rewrite H3.
apply H2 in H3; now destruct H3.
Qed.

End PosNeg.

Ltac zero_pos_neg n := induction_maker n ltac:(apply zero_pos_neg).

End ZAddOrderProp.


(**************************************************************************)
(**   Mechanised Framework for Local Interactions & Distributed Algorithms
      T. Balabonski, P. Courtieu, R. Pelle, L. Rieg, X. Urbain

      PACTOLE project

      This file is distributed under the terms of the CeCILL-C licence.
                                                                          *)
(**************************************************************************)

Require Import Utf8.
Require Import SetoidDec.
Require Import Rbase Rbasic_fun.
Require Import Psatz.
Require Import Pactole.Util.Coqlib.
Require Import Pactole.Util.Bijection.
Require Import Pactole.Core.Configuration.
Require Import Pactole.Spaces.Graph.
Set Implicit Arguments.

(****************************)
(** *  Graph Isomorphisms  **)
(****************************)

Section Isomorphism.
Context {V E : Type}.
Context {G : Graph V E}.

Record isomorphism := {
  iso_V :> bijection V;
  iso_E : bijection E;
  iso_T : bijection R;
  iso_morphism : forall e, iso_V (src e) == src (iso_E e)
                        /\ iso_V (tgt e) == tgt (iso_E e);
  iso_threshold : forall e, iso_T (threshold e) = threshold (iso_E e);
  iso_incr : forall a b, (a < b)%R -> (iso_T a < iso_T b)%R;
  iso_bound_T : forall r, (0 < iso_T r < 1)%R <-> (0 < r < 1)%R }.

Global Instance isomorphism_Setoid : Setoid isomorphism.
simple refine {| equiv := fun iso1 iso2 => iso1.(iso_V) == iso2.(iso_V)
                                        /\ iso1.(iso_E) == iso2.(iso_E)
                                        /\ iso1.(iso_T) == iso2.(iso_T) |}; autoclass.
Proof. split.
+ intro f. now repeat split.
+ intros f g Hfg; destruct Hfg as [HV [HE HT]]. repeat split; intro; now symmetry.
+ intros f g h Hfg Hgh. destruct Hfg as [? [? ?]], Hgh as [? [? ?]].
  repeat split; intro; etransitivity; eauto.
Defined.

Instance iso_V_compat : Proper (equiv ==> equiv) iso_V.
Proof using . intros ? ? Heq ?. now apply Heq. Qed.

Instance iso_E_compat : Proper (equiv ==> equiv) iso_E.
Proof using . intros ? ? Heq ?. now apply Heq. Qed.

Instance iso_T_compat : Proper (equiv ==> equiv) iso_T.
Proof using . intros ? ? Heq ?. now apply Heq. Qed.

Definition id : isomorphism.
refine {| iso_V := @id V _;
          iso_E := @id E _;
          iso_T := @id R _ |}.
Proof.
+ now intros.
+ now intros.
+ now intros.
+ now intros.
Defined.

Definition comp (f g : isomorphism) : isomorphism.
refine {|
    iso_V := compose f.(iso_V) g.(iso_V);
    iso_E := compose f.(iso_E) g.(iso_E);
    iso_T := compose f.(iso_T) g.(iso_T) |}.
Proof.
+ intro. simpl.
  split; now rewrite <- 2 (proj1 (iso_morphism _ _)) || rewrite <- 2 (proj2 (iso_morphism _ _)).
+ intro. simpl. now rewrite 2 iso_threshold.
+ intros. simpl. now do 2 apply iso_incr.
+ intro. simpl. now rewrite 2 iso_bound_T.
Defined.

Global Instance IsoComposition : Composition isomorphism.
refine {| compose := comp |}.
Proof. intros f1 f2 Hf g1 g2 Hg. repeat split; intro; simpl; now rewrite Hf, Hg. Defined.

(* Global Instance compose_compat : Proper (equiv ==> equiv ==> equiv) compose.
Proof. intros f1 f2 Hf g1 g2 Hg. repeat split; intro; simpl; now rewrite Hf, Hg. Qed. *)

Lemma compose_assoc : forall f g h, f ∘ (g ∘ h) == (f ∘ g) ∘ h.
Proof using . intros f g h; repeat split; simpl; reflexivity. Qed.

Set Printing Implicit.

Definition inv (iso : isomorphism) : isomorphism.
  refine {| iso_V := inverse iso.(iso_V);
            iso_E := inverse iso.(iso_E);
            iso_T := inverse iso.(iso_T)
         |}.
Proof.
+ intro. simpl. rewrite <- 2 Inversion, (proj1 (iso_morphism _ _)), (proj2 (iso_morphism _ _)).
  split; apply src_compat || apply tgt_compat; now rewrite Inversion.
+ intro. simpl. change eq with (@equiv R _). rewrite <- Inversion, iso_threshold.
  apply threshold_compat. now rewrite Inversion.
+ intros a b Hab.
  simpl.
  assert (Hincr := iso_incr iso).
  assert (forall x y, @retraction R _ (iso_T iso) x < @retraction R _ (iso_T iso) y -> x < y)%R.
  { intros.
    specialize (Hincr (@retraction R _ (iso_T iso) x) (@retraction R _ (iso_T iso) y) H).
    now do 2 rewrite section_retraction in Hincr. }
  assert (Hnondecr:
    (forall x y,  x <= y -> @retraction R _ (iso_T iso) x <= @retraction R _ (iso_T iso) y)%R).
  { intros x y Hle. apply Rnot_lt_le. apply Rle_not_lt in Hle. intuition. }
  destruct (Hnondecr a b) as [| Heq]; auto; intuition; [].
  apply (f_equal (iso_T iso)) in Heq. rewrite 2 section_retraction in Heq. lra.
+ intro. simpl.
  assert (Hbound := iso_bound_T iso). specialize (Hbound (@retraction R _ (iso_T iso) r)).
  now rewrite section_retraction in Hbound.
Defined.

Global Instance IsoInverse : Inverse isomorphism.
refine {| inverse := inv |}.
Proof.
intros f g [? [? ?]].
repeat split; intro; simpl; change eq with (@equiv R _); f_equiv; auto.
Defined.

(* Global Instance inverse_compat : Proper (equiv ==> equiv) inverse.
Proof.
intros f g [? [? ?]].
repeat split; intro; simpl; change eq with (@equiv R _); f_equiv; auto.
Qed. *)

Lemma compose_inverse_l : forall iso : isomorphism, iso ⁻¹ ∘ iso == id.
Proof using . intro. repeat split; intro; simpl; try now rewrite retraction_section; autoclass. Qed.

Lemma compose_inverse_r : forall iso : isomorphism, iso ∘ (iso ⁻¹) == id.
Proof using . intro. repeat split; intro; simpl; try now rewrite section_retraction; autoclass. Qed.

Lemma inverse_compose : forall f g : isomorphism, (f ∘ g) ⁻¹ == (g ⁻¹) ∘ (f ⁻¹).
Proof using . intros f g; repeat split; intro; simpl; reflexivity. Qed.

Lemma injective : forall iso : isomorphism, Preliminary.injective equiv equiv iso.
Proof using .
intros f x y Heq. transitivity (id x); try reflexivity; [].
rewrite <- (compose_inverse_l f). simpl. rewrite Heq.
now apply compose_inverse_l.
Qed.

End Isomorphism.

Arguments isomorphism {V} {E} G.

Lemma find_edge_iso_Some `{G : Graph} : forall (iso : isomorphism G) src tgt e,
  @find_edge _ _ G (iso src) (iso tgt) == Some (iso.(iso_E) e)
  <-> @find_edge _ _ G src tgt == Some e.
Proof using .
intros iso src tgt e.
assert (strong_and : forall T U V W (A B : T -> U -> V -> W -> Prop),
          (forall x y z t, B x y z t) ->
          ((forall x y z t, B x y z t) -> (forall x y z t, A x y z t)) ->
          forall x y z t, A x y z t /\ B x y z t) by intuition.
revert iso src tgt e. apply strong_and.
+ intros iso src tgt e. rewrite 2 find_edge_Some. intro Hfind.
  rewrite (proj1 Hfind), (proj2 Hfind). apply iso_morphism.
+ intros Hstep iso src tgt e H.
  specialize (Hstep (inverse iso) (iso src) (iso tgt) (iso_E iso e) H).
  simpl in Hstep. now rewrite 3 Bijection.retraction_section in Hstep.
Qed.

Lemma find_edge_iso_None `{G : Graph} : forall (iso : isomorphism G) src tgt,
  @find_edge _ _ G (iso src) (iso tgt) == None <-> @find_edge _ _ G src tgt == None.
Proof using .
intros iso src tgt. destruct (find_edge src tgt) eqn:Hcase.
+ apply (eq_subrelation (R := equiv)) in Hcase; autoclass; [].
  rewrite <- find_edge_iso_Some in Hcase. rewrite Hcase. tauto.
+ intuition; []. destruct (find_edge (iso src) (iso tgt)) eqn:Hcase'; try reflexivity; [].
  exfalso. apply (eq_subrelation (R := equiv)) in Hcase'; autoclass; [].
  rewrite <- (find_edge_iso_Some (inverse iso)) in Hcase'. cbn -[equiv] in Hcase'.
  rewrite 2 Bijection.retraction_section in Hcase'. rewrite Hcase in Hcase'. tauto.
Qed.


Set Implicit Arguments.

(*

Stream used here is a set of infinite states that can be understood as a list.
Co-Inductive definitions are used to create termination proofs for the infinitely long streams.

This Section gives practical definitions of properties of Stream.

*)

Section Stream.
  Variable A : Type.

  CoInductive Stream : Type :=
  | Cons : A -> Stream -> Stream.

  Definition head (l : Stream) : A :=
    match l with
    | Cons x _ => x
    end.

  Definition tail (l : Stream) : Stream :=
    match l with
    | Cons _ l' => l'
    end.

  Definition frob (l : Stream) : Stream :=
    match l with
    | Cons x l' => Cons x l'
    end.

  Theorem frob_id :
    forall (l : Stream),
      l = frob l.
  Proof.
    intros; destruct l; auto.
  Qed.

  Fixpoint nth_tail (n : nat) (l : Stream) : Stream :=
    match n with
    | 0 => l
    | S n => nth_tail n (tail l)
    end.

End Stream.


Require Export Iron.Language.Simple.Base.

(********************************************************************)
(* Types *)
Inductive ty  : Type :=
 | TCon  : nat -> ty           (* data type constructor *)
 | TFun  : ty  -> ty -> ty.    (* function type constructor *)
Hint Constructors ty.

(* Type Environments *)
Definition tyenv := list ty.

(********************************************************************)
(* Value Expressions *)
Inductive exp : Type :=
 | XVar  : nat -> exp          (* deBruijn index *)
 | XLam  : ty  -> exp -> exp   (* function abstraction *)
 | XApp  : exp -> exp -> exp.  (* function application *)
Hint Constructors exp.

(* Weak normal forms.
   Expressions in weak normal form cannot be reduced further by
   call-by-value evaluation.

   Note that c.b.v does not reduce under lambdas, which makes
   the result of an evaluation a *weak* normal form (instead of
   a strong normal form).

   It's not *weak head* normal form because we use strict function
   application, so the function arguments are reduced to wnf before
   substituting. *)
Inductive wnfX : exp -> Prop :=
 | Wnf_XVar
   : forall i
   , wnfX (XVar i)

 | Wnf_XLam
   : forall t1 x2
   , wnfX (XLam t1 x2).
Hint Constructors wnfX.

(* Well formed expressions are closed under the given environment. *)
Fixpoint wfX (te: tyenv) (xx: exp) : Prop :=
 match xx with
 | XVar i     => exists t, get i te = Some t
 | XLam t x   => wfX (te :> t) x
 | XApp x1 x2 => wfX te x1 /\ wfX te x2
 end.

(* Closed expressions are well formed under an empty environment. *)
Definition closedX (xx: exp) : Prop
 := wfX nil xx.
Hint Unfold closedX.

(* Values are closed expressions that cannot be reduced further. *)
Definition value (x : exp)
 := wnfX x /\ closedX x.
Hint Unfold value.

(********************************************************************)
(* Lifting of references into the environment.
   When we push new elements on the environment stack, we need
   to lift referenes to existing elements across the new ones.

   For example given:
             t1, t0 |- 0 1 (\. 0 1 2) :: t3

   Pushing two more elements gives:
     t1, t0, ta, tb |- 2 3 (\. 0 3 4) :: t3
 *)
Fixpoint
 liftX  (d:  nat) (* current binding depth in expression *)
        (xx: exp) (* expression containing referenes to lift *)
        : exp
 := match xx with
    |  XVar ix
    => if le_gt_dec d ix
        (* Index is referencing the env, so lift it across the new elem *)
        then XVar (S ix)

        (* Index is locally bound in the expression itself, and
           not the environment, so we don't need to change it. *)
        else xx

    (* Increase the current depth as we move across a lambda,
       if we find locally bound indices that reference this lambda
       then we don't need to lift them. *)
    |  XLam t1 x1
    => XLam t1 (liftX (S d) x1)

    |  XApp x1 x2
    => XApp   (liftX d x1) (liftX d x2)
    end.

(*******************************************************************)
(* Substitute for the outermost binder in an expression. *)
Fixpoint
 substX (d:  nat) (* current binding depth in expression *)
        (u:  exp) (* new expression to substitute *)
        (xx: exp) (* expression to substitute into *)
        : exp
 := match xx with
    | XVar ix
    => match Nat.compare ix d with
       (* Index matches the one we are substituting for. *)
       | Eq  => u

       (* Index was free in the original expression.
          As we've removed the outermost binder, also decrease this
          index by one. *)
       | Gt  => XVar (ix - 1)

       (* Index was bound in the original expression. *)
       | Lt  => XVar ix
       end

    (* Increase the depth as we move across a lambda.
       Any free references in the exp being substitued also need
       to be lifted across the lambda as we enter it. *)
    |  XLam t1 x2
    => XLam t1 (substX (S d) (liftX 0 u) x2)

    |  XApp x1 x2
    => XApp (substX d u x1) (substX d u x2)
 end.