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

(* Finite sets library.
 * Authors: Pierre Letouzey and Jean-Christophe Filliâtre
 * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
 *              91405 Orsay, France *)

Require Import Orders PeanoNat POrderedType BinNat BinInt
 RelationPairs EqualitiesFacts.

(** * Examples of Ordered Type structures. *)

(** Ordered Type for [nat], [Positive], [N], [Z] with the usual order. *)

Module Nat_as_OT := PeanoNat.Nat.
Module Positive_as_OT := BinPos.Pos.
Module N_as_OT := BinNat.N.
Module Z_as_OT := BinInt.Z.

(** An OrderedType can now directly be seen as a DecidableType *)

Module OT_as_DT (O:OrderedType) <: DecidableType := O.

(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)

Module Nat_as_DT <: UsualDecidableType := Nat_as_OT.
Module Positive_as_DT <: UsualDecidableType := Positive_as_OT.
Module N_as_DT <: UsualDecidableType := N_as_OT.
Module Z_as_DT <: UsualDecidableType := Z_as_OT.

(** From two ordered types, we can build a new OrderedType
   over their cartesian product, using the lexicographic order. *)

Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
 Include PairDecidableType O1 O2.

 Definition lt :=
   (relation_disjunction (O1.lt @@1) (O1.eq * O2.lt))%signature.

 Instance lt_strorder : StrictOrder lt.
 Proof.
 split.
 (* irreflexive *)
 intros (x1,x2); compute. destruct 1.
 apply (StrictOrder_Irreflexive x1); auto.
 apply (StrictOrder_Irreflexive x2); intuition.
 (* transitive *)
 intros (x1,x2) (y1,y2) (z1,z2). compute. intuition.
 left; etransitivity; eauto.
 left. setoid_replace z1 with y1; auto with relations.
 left; setoid_replace x1 with y1; auto with relations.
 right; split; etransitivity; eauto.
 Qed.

 Instance lt_compat : Proper (eq==>eq==>iff) lt.
 Proof.
 compute.
 intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2).
 rewrite X1,X2,Y1,Y2; intuition.
 Qed.

 Definition compare x y :=
  match O1.compare (fst x) (fst y) with
   | Eq => O2.compare (snd x) (snd y)
   | Lt => Lt
   | Gt => Gt
  end.

 Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
 Proof.
 intros (x1,x2) (y1,y2); unfold compare; simpl.
 destruct (O1.compare_spec x1 y1); try (constructor; compute; auto).
 destruct (O2.compare_spec x2 y2); constructor; compute; auto with relations.
 Qed.

End PairOrderedType.

(** Even if [positive] can be seen as an ordered type with respect to the
  usual order (see above), we can also use a lexicographic order over bits
  (lower bits are considered first). This is more natural when using
  [positive] as indexes for sets or maps (see MSetPositive). *)

Local Open Scope positive.

Module PositiveOrderedTypeBits <: UsualOrderedType.
  Definition t:=positive.
  Include HasUsualEq <+ UsualIsEq.
  Definition eqb := Pos.eqb.
  Definition eqb_eq := Pos.eqb_eq.
  Include HasEqBool2Dec.

  Fixpoint bits_lt (p q:positive) : Prop :=
   match p, q with
   | xH, xI _ => True
   | xH, _ => False
   | xO p, xO q => bits_lt p q
   | xO _, _ => True
   | xI p, xI q => bits_lt p q
   | xI _, _ => False
   end.

  Definition lt:=bits_lt.

  Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
  Proof.
   induction x; simpl; auto.
  Qed.

  Lemma bits_lt_trans :
    forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
  Proof.
   induction x; destruct y,z; simpl; eauto; intuition.
  Qed.

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

  Instance lt_strorder : StrictOrder lt.
  Proof.
   split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
  Qed.

  Fixpoint compare x y :=
    match x, y with
      | x~1, y~1 => compare x y
      | x~1, _ => Gt
      | x~0, y~0 => compare x y
      | x~0, _ => Lt
      | 1, y~1 => Lt
      | 1, 1 => Eq
      | 1, y~0 => Gt
    end.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Proof.
   unfold eq, lt.
   induction x; destruct y; try constructor; simpl; auto.
    destruct (IHx y); subst; auto.
    destruct (IHx y); subst; auto.
  Qed.

End PositiveOrderedTypeBits.


Require Export semantics.

(*retrieve the stamp number from a heap location*)
Definition getStamp (x : location * term * stamp) :=
  match x with
      |(_,_,s) => s
  end.

(*if location l is present in heap H, then if we extend H with some number of
**locations, all of which have stamp C.  Then either we will get the same
**result when looking up in the extended heap or we will get something that
**has a timestamp of C*)
Theorem lookupExtension : forall H' l v S H C,
                  lookup H l = Some(v, S) ->
                  Forall (fun x : location * term * stamp => getStamp x = C) H' ->
                  lookup (H'++H) l = Some(v, S) \/
                  exists S' v', lookup (H'++H) l = Some(v', S') /\
                           S' = C.
Proof.
  induction H'; intros l v S H C HYP1 HYP2.
  {simpl. auto. }
  {simpl in *. destruct a. destruct p. destruct (eq_nat_dec l l0).
   {right. subst. repeat econstructor. inv HYP2. auto. }
   {inv HYP2. eapply IHH' in HYP1; eauto. }
  }
Qed.

(*we can produce the same replay derivation under an extended heap, if everything
**in the extension has a timestamp greater than the thread being replayed*)
Theorem replayHeapExtension : forall H H' S e0 L e L' e' C,
                      replay H (Some(S,e0),L,e) (Some(S,e0),L',e') -> S < C ->
                      Forall (fun x : location * term * stamp => getStamp x = C) H' ->
                      replay (H'++H) (Some(S,e0),L,e) (Some(S,e0),L',e').
Proof.
  intros. dependent induction H0.
  {constructor. }
  {inv H0.
   {copy H8. eapply lookupExtension with (H':=H') in H0; eauto. inv H0.
    {econstructor. eapply r_readStepValid; eauto. eauto. }
    {invertHyp. econstructor. eapply r_readStepInvalid; eauto. omega. eauto. }
   }
   {copy H8. eapply lookupExtension with (H':=H') in H0; eauto. inv H0.
    {econstructor. eapply r_readStepInvalid; eauto. eauto. }
    {invertHyp. econstructor. eapply r_readStepInvalid; eauto. omega. eauto. }
   }
   {econstructor. eapply r_readInDomainStep; eauto. eauto. }
   {econstructor. eapply r_writeStep; eauto. eauto. }
   {econstructor. eapply r_atomicIdemStep; eauto. eauto. }
   {econstructor. eapply r_betaStep; eauto. eauto. }
  }
Qed.

(*Generalizes the previous theorem to thread pools*)
Theorem poolRewindHeapExtension : forall H H' T C C',
                                    C' >= C -> poolRewind C H T ->
                                    Forall (fun x : location * term * stamp => getStamp x = C) H' ->
                                    poolRewind C' (H'++H) T.
Proof.
  intros. induction H1.
  {constructor. }
  {constructor. rewrite rewindIFFReplay. eapply replayHeapExtension; eauto.
   rewrite <- rewindIFFReplay. auto. omega. }
  {constructor; auto. }
Qed.

(*If the log at the end of a rewind derivation is invalid, then we can rewind
**from the log returned from validate*)
Theorem abortRewind : forall S L H S' e' L' e0 e,
                        validate S L H S' (abort e' L') ->
                        rewind H (Some (S, e0), [], e0) (Some (S, e0), L, e) ->
                        rewind H (Some (S, e0), [], e0) (Some (S, e0), L', e').
Proof.
  intros. dependent induction H1.
  {inv H0. }
  {inv H2; eauto.
   {inv H0; eauto. apply decomposeEq in H10. subst. auto. }
   {inv H0; eauto. eapply decomposeEq in H10. subst. auto. }
   {inv H0. eauto. }
  }
Qed.

Ltac lookupSame :=
  match goal with
      |H:logLookup ?L ?l = ?v, H':logLookup ?L ?l = ?v' |- _ =>
       rewrite H in H'; inv H'
      |A:lookup ?H ?l = ?v, B:lookup ?H ?l = ?v' |- _ =>
       rewrite A in B; inv B
  end.

(*the same rewind derivation can be produced with a newer stamp assuming the
**log is valid*)
Theorem rewindDiffStamp : forall S C H e0 L e L' e' H' S',
                        rewind H (Some(S,e0), L, e) (Some(S,e0), L', e') -> C > S ->
                        validate S L' H S' (commit H') ->
                        rewind H (Some(C,e0), L, e) (Some(C,e0), L', e').
Proof.
  intros. generalize dependent H'. dependent induction H0; intros. constructor.
  inv H1.
  {econstructor. Focus 2. eapply r_readStepValid; eauto. omega.
   eapply IHrewind; eauto. inv H3. eauto. }
  {inv H3. lookupSame. omega. }
  {econstructor. Focus 2. eapply r_readInDomainStep; eauto. eauto. }
  {inv H3. econstructor. Focus 2. eapply r_writeStep; eauto. intros c. inv c.
   eapply IHrewind; eauto. }
  {econstructor. Focus 2. eapply r_atomicIdemStep; eauto. intros c. inv c. eauto. }
  {econstructor. Focus 2. eapply r_betaStep; eauto. intros c. inv c. eauto. }
Qed.

(*rewind can always take place on a newer timestamp*)
Theorem poolRewindWeakening : forall C C' H T,
                                poolRewind C H T -> C' >= C ->
                                poolRewind C' H T.
Proof.
  intros. induction H0.
  {constructor. }
  {constructor; auto. omega. }
  {constructor; auto. }
Qed.

(*if a heap can be validated, then the resulting heap is an extension of the
**input heap*)
Theorem validateHeapExtension : forall S H C H' L,
                                    validate S L H C (commit H')  ->
                                    exists H'', H' = H'' ++ H .
Proof.
  intros. dependent induction H0; eauto; try solve[exists nil; eauto].
  {invertHyp. exists ((l,v,S')::x). simpl. reflexivity. }
Qed.

(*when validating the heap, the extended portion must all have time stamp
**equal to the write version number*)
Theorem validateStampGE : forall H' S L H C,
                            validate S L H C (commit (H'++H)) ->
                            Forall (fun x => getStamp x = C) H'.
Proof.
  intros. dependent induction H0; auto.
  {destruct H'. constructor. apply lengthsEq in x. simpl in *.
   rewrite app_length in x. omega. }
  {copy H0. eapply validateHeapExtension in H0. invertHyp. destruct H'.
   simpl in x. apply lengthsEq in x. simpl in x. rewrite app_length in x. omega.
   constructor. inv x. auto. eapply IHvalidate; eauto. inversion x. auto. }
Qed.

(*version clock and heap increase monotonically under the p_step relation*)
Theorem p_stampHeapMonotonic : forall C H T C' H' T',
             p_step C H T C' H' T' ->
             C' >= C /\ (exists H'', H' = H'' ++ H /\ Forall (fun x => getStamp x = C) H'').
Proof.
  intros. induction H0; try invertHyp; split; eauto; try solve[exists nil; auto]. omega.
  {exists [(l,v,C)]. simpl. split; auto.  }
  {copy H0. apply validateHeapExtension in H0. invertHyp. exists x. split; auto.
   eapply validateStampGE in H2. auto. }
Qed.

(*p_step preserves rewind*)
Theorem p_stepRewind : forall C H T C' H' T',
                       p_step C H T C' H' T' -> poolRewind C H T ->
                       poolRewind C' H' T'.
Proof.
  intros. induction H0; try solve[repeat econstructor].
  {inv H1. inv H0; exfalso; apply H6; auto. inv H0.
   {destruct(lt_dec S' S).
    {constructor; auto. econstructor; eauto. eapply r_readStepValid; eauto. }
    {constructor; auto. econstructor; eauto. eapply r_readStepInvalid; eauto. omega. }
   }
   {constructor. econstructor; eauto. eapply r_readInDomainStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_writeStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_atomicIdemStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_betaStep; eauto. auto. }
  }
  {inv H1. constructor; auto. eapply p_stampHeapMonotonic in H0. invertHyp.
   eapply poolRewindHeapExtension; eauto. }
  {inv H1. constructor; auto.  eapply p_stampHeapMonotonic in H0. invertHyp.
   eapply poolRewindHeapExtension; eauto. }
  {inv H1. constructor; try omega. inv H3.
   {copy H13. eapply abortRewind in H13; eauto. eapply validateValidate in H1.
    invertHyp. eapply rewindDiffStamp; eauto. }
   {apply decomposeEq in H4. subst. eapply rewindDiffStamp; eauto. }
  }
  {inv H1. econstructor; try omega. copy H0. eapply abortRewind in H0; eauto.
   eapply validateValidate in H1; eauto. invertHyp. eapply rewindDiffStamp; eauto. }
Qed.

(*version clock and heap increase monotonically under the f_step relation*)
Theorem f_stampHeapMonotonic : forall C H T C' H' T',
                               f_step C H T C' H' T' ->
                               C' >= C /\ (exists H'', H' = H'' ++ H /\ Forall (fun x => getStamp x = C) H'').
Proof.
  intros. induction H0; try invertHyp; split; eauto; try solve[exists nil; auto]. omega.
  {exists [(l,v,C)]. simpl. split; auto.  }
  {copy H0. apply validateHeapExtension in H0. invertHyp. exists x. split; auto.
   eapply validateStampGE in H2. auto. }
Qed.

(*f_step preserves rewind*)
Theorem f_stepRewind : forall C H T C' H' T',
                       f_step C H T C' H' T' -> poolRewind C H T ->
                       poolRewind C' H' T'.
Proof.
  intros. induction H0; try solve[repeat econstructor].
  {inv H1. inv H0; exfalso; apply H6; auto. inv H0.
   {destruct(lt_dec S' S).
    {constructor; auto. econstructor; eauto. eapply r_readStepValid; eauto. }
    {constructor; auto. econstructor; eauto. eapply r_readStepInvalid; eauto. omega. }
   }
   {constructor. econstructor; eauto. eapply r_readInDomainStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_writeStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_atomicIdemStep; eauto. auto. }
   {econstructor. econstructor; eauto. eapply r_betaStep; eauto. auto. }
  }
  {inv H1. constructor; auto. eapply f_stampHeapMonotonic in H0.
   invertHyp. eapply poolRewindHeapExtension; eauto. }
  {inv H1. constructor; auto. eapply f_stampHeapMonotonic in H0.
   invertHyp. eapply poolRewindHeapExtension; eauto. }
  {constructor. constructor. omega. }
Qed.


Require Export Coq.Arith.PeanoNat CoqRecon.Util.ListLib.

Inductive typ : Set :=
| TBool
| TNat
| TArrow : typ -> typ -> typ
| TVar : nat -> typ.

Declare Scope typ_scope.
Delimit Scope typ_scope with typ.

Coercion TVar : nat >-> typ.
Notation "t1 → t2"
  := (TArrow t1 t2)
       (at level 30, right associativity) : typ_scope.

Open Scope typ_scope.

Fixpoint typ_eq (l r : typ) : bool :=
  match l, r with
  | TBool, TBool | TNat, TNat => true
  | TVar T1, TVar T2 => T1 =? T2
  | l → l', r → r'
    => typ_eq l r && typ_eq l' r'
  | _, _ => false
  end.

Fixpoint tvars (t : typ) : list nat :=
  match t with
  | TBool | TNat => []
  | TVar T => [T]
  | t → t' => tvars t ++ tvars t'
  end.

Fixpoint typ_size (t : typ) : nat :=
  match t with
  | TBool | TNat | TVar _ => 1
  | t → t' => 1 + typ_size t + typ_size t'
  end.

Definition typ_size_vars (t : typ) : nat * nat :=
  (length (uniques (tvars t)), typ_size t).

Definition Ctvars : list (typ * typ) -> list nat :=
  fold_right (fun '(l,r) acc => tvars l ++ tvars r ++ acc) [].

Definition C_size : list (typ * typ) -> nat :=
  fold_right (fun '(l,r) acc => typ_size l + typ_size r + acc) 0.

Definition C_size_vars (C : list (typ * typ)) : nat * nat :=
  (length (uniques (Ctvars C)), C_size C).

Section TypEq.
  Lemma typ_eq_reflexive : forall t, typ_eq t t = true.
  Proof.
    Local Hint Resolve andb_true_intro : core.
    Local Hint Resolve Nat.eqb_refl : core.
    intro t; induction t as [| | t1 IHt1 t2 IHt2 | T];
      simpl; try reflexivity; auto.
  Qed.

  Lemma typ_eq_eq : forall l r,
      typ_eq l r = true -> l = r.
  Proof.
    Hint Rewrite andb_true_iff : core.
    Hint Rewrite Nat.eqb_eq : core.
    intro l; induction l as [| | l IHl l' IHl' | L];
      intros [| | r r' | R] H; simpl in *;
        try discriminate; try reflexivity;
          autorewrite with core in *; f_equal; intuition.
  Qed.

  Local Hint Resolve typ_eq_reflexive : core.
  Local Hint Resolve typ_eq_eq : core.

  Lemma typ_eq_iff : forall l r,
      typ_eq l r = true <-> l = r.
  Proof.
    split; intros; subst; auto.
  Qed.

  Lemma typ_eq_reflects : reflects eq typ_eq.
  Proof.
    unfold reflects.
    intros l r; destruct (typ_eq l r) eqn:Hlr;
      constructor; intuition; subst.
    rewrite typ_eq_reflexive in Hlr.
    discriminate.
  Defined.

  Lemma typ_eq_not_eq : forall l r,
      typ_eq l r = false <-> l <> r.
  Proof.
    intros l r.
    pose proof typ_eq_reflects l r as Hlr; inv Hlr;
      intuition.
  Qed.

  Lemma typ_eq_sym : forall l r,
      typ_eq l r = typ_eq r l.
  Proof.
    intros l r.
    pose proof typ_eq_reflects l r as Hlr; inv Hlr; auto.
    apply not_eq_sym in H0.
    rewrite <- typ_eq_not_eq in H0.
    rewrite H0. reflexivity.
  Qed.
End TypEq.

Section TypSize.
  Lemma typ_size_non_zero : forall t,
    typ_size t > 0.
  Proof.
    intro t; induction t; simpl; lia.
  Qed.
End TypSize.


(* Copied from RamifyCoq project *)

Require Export Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Export Coq.Classes.Equivalence.
Require Coq.Setoids.Setoid.

Definition full_relation {A} : relation A := fun _ _ => True.

Lemma inclusion_full_relation: forall {A} P, inclusion A P full_relation.
Proof.
  intros.
  hnf; intros.
  hnf.
  auto.
Qed.

Lemma same_relation_spec: forall {A} a1 a2, same_relation A a1 a2 <-> pointwise_relation A (pointwise_relation A iff) a1 a2.
Proof.
  intros.
  unfold same_relation, inclusion, pointwise_relation.
  firstorder.
Qed.

Lemma same_relation_Reflexive {A}: Reflexive (same_relation A).
Proof.
  hnf; intros.
  rewrite same_relation_spec.
  unfold pointwise_relation.
  firstorder.
Qed.

Lemma same_relation_Symmetric {A}: Symmetric (same_relation A).
Proof.
  hnf; intros.
  rewrite same_relation_spec in *.
  unfold pointwise_relation in *.
  firstorder.
Qed.

Lemma same_relation_Transitive {A}: Transitive (same_relation A).
Proof.
  hnf; intros.
  rewrite same_relation_spec in H, H0 |- *.
  unfold pointwise_relation in *.
  intros.
  rewrite H, H0.
  tauto.
Qed.

Instance same_relation_Equivalence {A}: Equivalence (same_relation A).
Proof.
  split.
  + apply same_relation_Reflexive.
  + apply same_relation_Symmetric.
  + apply same_relation_Transitive.
Qed.

Instance inclusion_proper {A}: Proper (same_relation A ==> same_relation A ==> iff) (inclusion A).
Proof.
  intros.
  do 2 (hnf; intros ?F ?G ?H).
  unfold inclusion.
  rewrite same_relation_spec in H, H0.
  split; intros HH x y; specialize (HH x y).
  + rewrite (H x y), (H0 x y) in HH.
    auto.
  + rewrite (H x y), (H0 x y).
    auto.
Qed.

Lemma app_same_relation: forall {A: Type} (R1 R2: relation A) (a1 a2: A),
  same_relation A R1 R2 ->
  (R1 a1 a2 <-> R2 a1 a2).
Proof.
  intros.
  rewrite same_relation_spec in H.
  specialize (H a1 a2).
  tauto.
Qed.

Inductive compond_relation {A: Type} (R1 R2: relation A) : relation A :=
  | compond_intro: forall x y z, R1 x y -> R2 y z -> compond_relation R1 R2 x z.

Lemma compond_relation_spec: forall {A} (R1 R2: relation A) x z,
  compond_relation R1 R2 x z ->
  exists y, R1 x y /\ R2 y z.
Proof.
  intros.
  inversion H; subst.
  eauto.
Qed.

Lemma compond_relation_inclusion: forall {A} (R1 R2 R3 R4: relation A),
  inclusion _ R1 R2 ->
  inclusion _ R3 R4 ->
  inclusion _ (compond_relation R1 R3) (compond_relation R2 R4).
Proof.
  intros.
  hnf; intros.
  inversion H1; subst.
  apply compond_intro with y0; auto.
Qed.

Instance compond_relation_proper {A: Type}: Proper (same_relation A ==> same_relation A ==> same_relation A) compond_relation.
Proof.
  do 2 (hnf; intros).
  destruct H, H0.
  split; apply compond_relation_inclusion; auto.
Defined.

Lemma compond_assoc: forall {A: Type} (R1 R2 R3: relation A),
  same_relation _ (compond_relation (compond_relation R1 R2) R3) (compond_relation R1 (compond_relation R2 R3)).
Proof.
  intros.
  split; hnf; intros;
  do 2
  match goal with
  | H : compond_relation _ _ _ _ |- _ => inversion H; subst; clear H
  end;
  do 2 (econstructor; eauto).
Qed.

Lemma compond_eq_right: forall {A: Type} (R: relation A), same_relation _(compond_relation R eq) R.
Proof.
  intros.
  split; hnf; intros.
  + inversion H; subst.
    auto.
  + econstructor; eauto.
Qed.

Lemma compond_eq_left: forall {A: Type} (R: relation A), same_relation _(compond_relation eq R) R.
Proof.
  intros.
  split; hnf; intros.
  + inversion H; subst.
    auto.
  + econstructor; eauto.
Qed.

Lemma relation_conjunction_inclusion: forall {A} (R1 R2 R3 R4: relation A),
  inclusion _ R1 R2 ->
  inclusion _ R3 R4 ->
  inclusion _ (relation_conjunction R1 R3) (relation_conjunction R2 R4).
Proof.
  intros.
  hnf; intros.
  inversion H1; subst.
  split; auto.
Qed.

Instance relation_conjunction_proper {A: Type}: Proper (same_relation A ==> same_relation A ==> same_relation A) relation_conjunction.
Proof.
  do 2 (hnf; intros).
  destruct H, H0.
  split; apply relation_conjunction_inclusion; auto.
Defined.

Lemma relation_conjunction_iff: forall {A} (R R': relation A) x y,
  relation_conjunction R R' x y <-> R x y /\ R' x y.
Proof.
  intros.
  reflexivity.
Qed.

Lemma relation_disjunction_iff: forall {A} (R R': relation A) x y,
  relation_disjunction R R' x y <-> R x y \/ R' x y.
Proof.
  intros.
  reflexivity.
Qed.

Lemma relation_disjunction_inclusion_left: forall {A} (R R': relation A),
  inclusion _ R (relation_disjunction R R').
Proof.
  intros.
  intros ? ? ?.
  rewrite relation_disjunction_iff.
  tauto.
Qed.

Lemma relation_disjunction_inclusion_right: forall {A} (R R': relation A),
  inclusion _ R' (relation_disjunction R R').
Proof.
  intros.
  intros ? ? ?.
  rewrite relation_disjunction_iff.
  tauto.
Qed.

Definition respectful_relation {A B} (f: A -> B) (R: relation B): relation A := fun x y => R (f x) (f y).

Definition fst_relation {A B}: relation A -> relation (A * B) := respectful_relation (@fst A B).

Definition snd_relation {A B}: relation B -> relation (A * B) := respectful_relation (@snd A B).

Instance respectful_relation_proper {A B} (f: A -> B): Proper (same_relation _ ==> same_relation _) (respectful_relation f).
Proof.
  hnf; intros.
  rewrite @same_relation_spec in H |- *.
  intros b1 b2.
  unfold respectful_relation.
  apply H.
Defined.

Lemma respectful_compond_relation: forall {A B} (f: A -> B) R1 R2,
  inclusion _
    (compond_relation (respectful_relation f R1) (respectful_relation f R2))
    (respectful_relation f (compond_relation R1 R2)).
Proof.
  intros.
  intros a1 a2 ?.
  inversion H; subst.
  apply compond_intro with (f y); auto.
Qed.

Definition partial_functional {A: Type} (R: relation A): Prop :=
  forall m n n', R m n -> R m n' -> n = n'.

Class PartialFunctional {A: Type} (R: relation A): Prop :=
  partial_functionality: forall m n n', R m n -> R m n' -> n = n'.

Definition functional {A: Type} (R: relation A): Prop :=
  forall m, exists n, forall n', R m n' <-> n' = n.

Class Functional {A: Type} (R: relation A): Prop :=
  functionality: forall m, exists n, forall n', R m n' <-> n' = n.

Definition serial {A: Type} (R: relation A): Prop :=
  forall m, exists n, R m n.

Class Serial {A: Type} (R: relation A): Prop :=
  seriality: forall m, exists n, R m n.

Lemma function_Functional {A: Type} {f: A -> A}: Functional (fun a => eq (f a)).
Proof.
  hnf; intros.
  exists (f m); intros.
  split; intros; congruence.
Qed.

Lemma SerialPartialFunctional_Functional {A: Type} {R: relation A}: Serial R -> PartialFunctional R -> Functional R.
Proof.
  intros; hnf; intros.
  destruct (seriality m) as [n ?].
  exists n; intros.
  split; intros.
  + eapply partial_functionality; eauto.
  + subst; auto.
Qed.

Instance Functional_PartialFunctional {A: Type} {R: relation A} {_: Functional R}: PartialFunctional R.
Proof.
  intros; hnf; intros.
  destruct (functionality m) as [n0 ?].
  rewrite H2 in H0, H1.
  congruence.
Qed.

Instance Functional_Serial {A: Type} {R: relation A} {_: Functional R}: Serial R.
Proof.
  intros; hnf; intros.
  destruct (functionality m) as [n ?].
  exists n.
  rewrite H0.
  auto.
Qed.

Class Inclusion {A: Type} (R1 R2: relation A) : Prop :=
  including: forall a b, R1 a b -> R2 a b.


(*
(C) Copyright 2010--2014, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

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

Require Import Ass_handling.

Local Open Scope R_scope.

(** * Extensionality of derivable_* *)

Lemma derivable_pt_lim_in_ext: forall f g x D l, f == g ->
  derivable_pt_lim_in D f x l -> derivable_pt_lim_in D g x l.
Proof.
intros f g x D l Heq Hf eps eps_pos ;
 destruct (Hf _ eps_pos) as [alpha [alpha_pos Halpha]] ;
 exists alpha ; split ; [assumption |].
 intros ; erewrite growth_rate_ext ; [eapply Halpha | symmetry] ;
 eassumption.
Qed.

Lemma derivable_pt_lim_in_ext_strong: forall f g x (D : R -> Prop) l,
  D x -> (forall x, D x -> f x = g x) ->
  derivable_pt_lim_in D f x l -> derivable_pt_lim_in D g x l.
Proof.
intros f g x D l Dx Heq Hf eps eps_pos ;
 destruct (Hf _ eps_pos) as [alpha [alpha_pos Halpha]] ;
 exists alpha ; split ; [assumption |].
 intros ; rewrite growth_rate_ext_strong with (g := f) (D := D).
  apply Halpha ; assumption.
   assumption.
   intros ; symmetry ; apply Heq ; assumption.
   destruct H as [[Dy _] _] ; exact Dy.
Qed.

Lemma derivable_pt_in_ext : forall f g D x, f == g ->
  derivable_pt_in D f x -> derivable_pt_in D g x.
Proof.
intros f g D x Heq [l Hl] ; exists l ; eapply derivable_pt_lim_in_ext ; eassumption.
Qed.

Lemma derivable_pt_in_ext_strong : forall f g (D : R -> Prop) x,
  D x -> (forall x, D x -> f x = g x) ->
  derivable_pt_in D f x -> derivable_pt_in D g x.
Proof.
intros f g D x Dx Heq [l Hl] ; exists l ; eapply derivable_pt_lim_in_ext_strong ; eassumption.
Qed.

Lemma derivable_in_ext : forall f g D, f == g ->
  derivable_in D f -> derivable_in D g.
Proof.
intros f g D Heq Hf x Dx ; eapply derivable_pt_in_ext ; [| ass_apply] ; eassumption.
Qed.

Lemma derivable_in_ext_strong : forall f g (D : R -> Prop),
  (forall x, D x -> f x = g x) ->
  derivable_in D f -> derivable_in D g.
Proof.
intros f g D Heq Hf x Dx ; eapply derivable_pt_in_ext_strong ; [| | ass_apply] ; eassumption.
Qed.

(** Link between the stdlib's definition an ours. *)

Lemma derivable_pt_lim_derivable_pt_lim_in: forall f D x l,
  derivable_pt_lim f x l -> derivable_pt_lim_in D f x l.
Proof.
intros f D x l Hl eps eps_pos ; destruct (Hl _ eps_pos) as [delta Hdelta] ;
 exists delta ; split.
  apply delta.
  intros y [[Dy xny] xy_bd] ; simpl ; unfold R_dist, growth_rate ;
   replace (f y) with (f (x + (y - x))) by (f_equal ; ring) ; apply Hdelta.
   intro Hf ; apply xny ; revert Hf ; clear ; intuition.
   apply xy_bd.
Qed.

Lemma derivable_pt_derivable_pt_in: forall f D x,
  derivable_pt f x -> derivable_pt_in D f x.
Proof.
intros f D x [l Hl] ; exists l ;
 apply derivable_pt_lim_derivable_pt_lim_in ;
 assumption.
Qed.

Lemma derivable_derivable_in : forall f D,
  derivable f -> derivable_in D f.
Proof.
intros f D Hf x Dx ; apply derivable_pt_derivable_pt_in, Hf.
Qed.

(** * Unicity of the derivative *)

Lemma derivable_pt_lim_in_uniqueness:
  forall (D : R -> Prop) f x l l', dense D x ->
  derivable_pt_lim_in D f x l -> derivable_pt_lim_in D f x l' ->
  l = l'.
Proof.
intros D f x l l' Dx Hl ; eapply single_limit ; try eassumption ;
 intros eps eps_pos ; destruct (Dx _ eps_pos) as [y [y_h y_bd]] ;
 exists y.
Qed.

Lemma derivable_pt_lim_interval_uniqueness:
  forall (f : R -> R) (lb ub x l l' : R),
  lb < ub -> interval lb ub x ->
  derivable_pt_lim_in (interval lb ub) f x l ->
  derivable_pt_lim_in (interval lb ub) f x l' -> l = l'.
Proof.
intros ; eapply derivable_pt_lim_in_uniqueness ; try eassumption.
 apply dense_interval ; assumption.
Qed.

Lemma derivable_pt_lim_open_interval_uniqueness: forall f lb ub x l l',
  open_interval lb ub x ->
  derivable_pt_lim_in (open_interval lb ub) f x l ->
  derivable_pt_lim_in (open_interval lb ub) f x l' ->
  l = l'.
Proof.
intros ; eapply derivable_pt_lim_in_uniqueness ; try eassumption.
 apply dense_open_interval.
  eapply open_interval_inhabited ; eassumption.
  eapply open_interval_interval ; eassumption.
Qed.

Lemma derivable_pt_lim_Rball_uniqueness: forall c r f x l l', Rball c r x ->
  derivable_pt_lim_in (Rball c r) f x l ->
  derivable_pt_lim_in (Rball c r) f x l' ->
  l = l'.
Proof.
intros ; eapply derivable_pt_lim_in_uniqueness ; try eassumption ;
 apply dense_Rball ; assumption.
Qed.

Lemma derive_pt_in_open_interval_uniqueness :
  forall f x lb ub pr pr', open_interval lb ub x ->
  derive_pt_in (open_interval lb ub) f x pr =
  derive_pt_in (open_interval lb ub) f x pr'.
Proof.
intros f x lb ub [] [] x_in ;
 eapply derivable_pt_lim_open_interval_uniqueness ; eassumption.
Qed.

(** * In specific cases we can come back from the specific case to the one with no limitation. *)

(** open interval *)

Lemma derivable_pt_lim_open_interval_pt_lim :
  forall lb ub f x l, open_interval lb ub x ->
  derivable_pt_lim_in (open_interval lb ub) f x l -> derivable_pt_lim f x l.
Proof.
intros lb ub f x l x_in Hl eps eps_pos ; destruct (Hl _ eps_pos) as [d [d_pos Hd]] ;
 simpl in Hd ; unfold R_dist in Hd.
 pose (delta := Rmin (interval_dist lb ub x) d).
 assert (delta_pos : 0 < delta).
  apply Rmin_pos_lt ; [apply open_interval_dist_pos |] ; assumption.
 exists (mkposreal _ delta_pos) ; intros h h_neq h_bd ;
 specify Hd (x + h) ; unfold growth_rate in * ;
 replace (x + h - x) with h in Hd by ring ; apply Hd ; split.
  split.
   apply open_interval_dist_bound ; [apply open_interval_interval
   | eapply Rlt_le_trans ; [| eapply Rmin_l]] ; eassumption.
   clear -h_neq ; intro Hf ; apply h_neq, Rplus_eq_reg_l with x ;
   rewrite <- Hf ; ring.
  eapply Rlt_le_trans ; [eassumption | eapply Rmin_r].
Qed.

Lemma derivable_open_interval_pt: forall f lb ub,
  derivable_open_interval lb ub f ->
  forall x, open_interval lb ub x -> derivable_pt f x.
Proof.
intros f lb ub H x Dx ; destruct (H x Dx) as [l Hl] ;
 exists l ; eapply derivable_pt_lim_open_interval_pt_lim ;
 eassumption.
Qed.

Lemma derive_open_interval_unfold : forall a b f f_deriv c (c_in : open_interval a b c),
  derive_open_interval a b f f_deriv c =
  derive_pt_in (open_interval a b) f c (f_deriv c c_in).
Proof.
intros a b f f_deriv c c_in ; unfold derive_open_interval ;
 destruct (in_open_interval_dec a b c) as [c_in' | hf].
 + apply derive_pt_in_open_interval_uniqueness ; assumption.
 + contradiction.
Qed.

Lemma derive_open_interval_pt : forall f lb ub x pr pr',
  open_interval lb ub x ->
  derive_pt_in (open_interval lb ub) f x pr = derive_pt f x pr'.
Proof.
intros f lb ub x [l Hl] [l' Hl'] x_in ; simpl ;
 eapply derivable_pt_lim_open_interval_uniqueness.
  eassumption.
  eassumption.
  eapply derivable_pt_lim_derivable_pt_lim_in ; assumption.
Qed.

Lemma derive_open_interval_derive : forall f lb ub x pr pr',
  open_interval lb ub x ->
  derive_open_interval lb ub f pr x = derive f pr' x.
Proof.
intros f lb ub x pr pr' x_in ; unfold derive_open_interval, derive.
 destruct (in_open_interval_dec lb ub x).
  apply derive_open_interval_pt ; assumption.
  contradiction.
Qed.

Lemma derive_open_interval_derive_pt : forall f lb ub x pr pr',
  open_interval lb ub x ->
  derive_open_interval lb ub f pr x = derive_pt f x pr'.
Proof.
intros f lb ub x pr pr' x_in ; unfold derive_open_interval, derive.
 destruct (in_open_interval_dec lb ub x).
  apply derive_open_interval_pt ; assumption.
  contradiction.
Qed.

(** Rball *)

Lemma derivable_pt_lim_Rball_pt_lim: forall f c r x l,
  Rball c r x -> derivable_pt_lim_in (Rball c r) f x l ->
  derivable_pt_lim f x l.
Proof.
intros ; eapply derivable_pt_lim_open_interval_pt_lim.
 eapply included_Rball_open_interval ; eassumption.
 eapply derivable_pt_lim_in_contravariant.
 eapply included_open_interval_Rball2 ; eassumption.
 eassumption.
Qed.

Lemma derivable_Rball_derivable_pt: forall f c r,
  derivable_Rball c r f ->
  forall x, Rball c r x -> derivable_pt f x.
Proof.
intros f lb ub H x Dx ; destruct (H x Dx) as [l Hl] ;
 exists l ; eapply derivable_pt_lim_Rball_pt_lim ;
 eassumption.
Qed.

Lemma derive_Rball_pt : forall f c r x pr pr',
  Rball c r x ->
  derive_pt_in (Rball c r) f x pr = derive_pt f x pr'.
Proof.
intros f lb ub x [l Hl] [l' Hl'] x_in ; simpl ;
 eapply derivable_pt_lim_Rball_uniqueness.
  eassumption.
  eassumption.
  eapply derivable_pt_lim_derivable_pt_lim_in ; assumption.
Qed.

Lemma derive_Rball_derive : forall f c r x pr pr',
  Rball c r x ->
  derive_Rball c r f pr x = derive f pr' x.
Proof.
intros f c r x pr pr' x_in ; unfold derive_Rball, derive.
 destruct (in_Rball_dec c r x).
  apply derive_Rball_pt ; assumption.
  contradiction.
Qed.

(** Proof by restriction to a local open_interval *)

Lemma derivable_open_interval_derivable : forall f,
  (forall lb ub, derivable_open_interval lb ub f) ->
  derivable f.
Proof.
intros f Hf x ; eapply derivable_open_interval_pt, (center_in_open_interval _ 1).
 apply Hf.
 lra.
Qed.

(** * derivable implies continuous *)

Lemma derivable_pt_in_continuity_pt_in : forall f D x,
    derivable_pt_in f D x -> continuity_pt_in f D x.
Proof.
intros D f x [l Hl] Dx eps eps_pos.
 pose (eps' := Rmin eps (eps / (eps + Rabs l))).
 assert (eps'_pos: 0 < eps').
  apply Rmin_pos_lt, Rlt_mult_inv_pos, Rplus_lt_le_0_compat ;
  [| | | apply Rabs_pos] ; assumption.
 destruct (Hl _ eps'_pos) as [alp [alp_pos Halp]] ;
 exists (Rmin alp eps') ; split ; [apply Rmin_pos_lt ; assumption |].
 intros y [Dy y_bd] ; destruct (Req_dec y x) as [Heq | Hneq].
  subst ; rewrite R_dist_eq ; assumption.
  transitivity ((eps + Rabs l) * Rabs (y - x)).
  apply Rle_lt_trans with (Rabs (growth_rate f x y) * Rabs (y - x)).
   right ; simpl ; unfold R_dist, growth_rate ; rewrite <- Rabs_mult ;
   apply Rabs_eq_compat ; field ; apply Rminus_eq_contra ; assumption.
   apply Rle_lt_trans with ((dist R_met (growth_rate f x y) l + Rabs l) * Rabs (y - x)).
   apply Rmult_le_compat_r ; [apply Rabs_pos |].
   apply Rle_trans with (Rabs (growth_rate f x y - l + l)) ;
   [right ; apply Rabs_eq_compat ; ring | apply Rabs_triang].
   apply Rmult_lt_compat_r ; [apply Rabs_pos_lt, Rminus_eq_contra ; assumption |].
   apply Rplus_lt_compat_r, Rlt_le_trans with eps'.
   apply Halp ; repeat split ; [assumption | symmetry ; assumption |].
   apply Rlt_le_trans with (Rmin alp eps'), Rmin_l ; assumption.
   apply Rmin_l.
   apply Rlt_le_trans with ((eps + Rabs l) * eps').
   apply Rmult_lt_compat_l.
    apply Rplus_lt_le_0_compat ; [assumption | apply Rabs_pos].
    apply Rlt_le_trans with (Rmin alp eps') ; [apply y_bd | apply Rmin_r].
   transitivity ((eps + Rabs l) * (eps / (eps + Rabs l))).
   apply Rmult_le_compat_l, Rmin_r ; apply Rplus_le_le_0_compat ;
   [left ; assumption | apply Rabs_pos].
   right ; field ; apply Rgt_not_eq, Rplus_lt_le_0_compat, Rabs_pos ; assumption.
Qed.

Lemma derivable_in_continuity_in : forall f D,
    derivable_in D f -> continuity_in D f.
Proof.
intros f D Hf x Dx ; apply derivable_pt_in_continuity_pt_in.
 apply Hf ; assumption.
 assumption.
Qed.

(** Value of the derivative *)

Lemma derivable_pt_lim_in_derive_pt_Rball: forall c r f x l pr,
  Rball c r x ->
  derivable_pt_lim_in (Rball c r) f x l ->
  derive_pt_in (Rball c r) f x pr = l.
Proof.
intros c r f x l [l' Hl'] x_in Hl ; eapply derivable_pt_lim_Rball_uniqueness ;
 eassumption.
Qed.

Lemma derivable_pt_lim_in_derive_Rball: forall c r f x l pr, Rball c r x ->
  derivable_pt_lim_in (Rball c r) f x l ->
  derive_Rball c r f pr x = l.
Proof.
intros c r f x l pr x_in Hl ; unfold derive_Rball ;
 destruct (in_Rball_dec c r x) as [x_in2 | x_nin].
 eapply derivable_pt_lim_in_derive_pt_Rball ; eassumption.
 contradiction.
Qed.

Lemma derivable_pt_lim_derive_pt_interval: forall f lb ub x l
  (pr : derivable_pt_in (interval lb ub) f x),
  lb < ub -> interval lb ub x ->
  derivable_pt_lim_in (interval lb ub) f x l ->
  derive_pt_in (interval lb ub) f x pr = l.
Proof.
intros f lb ub x l [l' Hl'] x_in Hl ;
 eapply derivable_pt_lim_interval_uniqueness ;
 eassumption.
Qed.

Lemma derivable_pt_lim_derive_pt_open_interval: forall f lb ub x l
  (pr : derivable_pt_in (open_interval lb ub) f x),
  open_interval lb ub x ->
  derivable_pt_lim_in (open_interval lb ub) f x l ->
  derive_pt_in (open_interval lb ub) f x pr = l.
Proof.
intros f lb ub x l [l' Hl'] x_in Hl ;
 eapply derivable_pt_lim_open_interval_uniqueness ;
 eassumption.
Qed.

Lemma derive_pt_derivable_pt_lim_interval: forall f lb ub x l
  (pr : derivable_pt_in (interval lb ub) f x),
  lb < ub -> interval lb ub x ->
  derive_pt_in (interval lb ub) f x pr = l ->
  derivable_pt_lim_in (interval lb ub) f x l.
Proof.
intros f lb ub x l [l' Hl'] Hlt x_in Hl ; subst ; assumption.
Qed.

(** Extensionality of the derive_* definitions *)

Lemma derive_pt_in_ext:
  forall D f g x (prf: derivable_pt_in D f x) (prg: derivable_pt_in D g x),
  dense D x -> D x -> f == g ->
  derive_pt_in D f x prf = derive_pt_in D g x prg.
Proof.
intros D f g x [l1 Hl1] [l2 Hl2] dD x_in Heq ; simpl ;
 eapply derivable_pt_lim_in_uniqueness ; [eassumption | | eassumption].
 eapply derivable_pt_lim_in_ext ; eassumption.
Qed.

Lemma derive_pt_in_ext_strong: forall (D : R -> Prop) f g x
  (prf: derivable_pt_in D f x) (prg: derivable_pt_in D g x),
  dense D x -> D x -> (forall x, D x -> f x = g x) ->
  derive_pt_in D f x prf = derive_pt_in D g x prg.
Proof.
intros D f g x [l1 Hl1] [l2 Hl2] dD x_in Heq ; simpl ;
 eapply derivable_pt_lim_in_uniqueness ; [eassumption | | eassumption].
 eapply derivable_pt_lim_in_ext_strong ; eassumption.
Qed.

Lemma derive_Rball_ext:
  forall c r f g (prf: derivable_Rball c r f) (prg: derivable_Rball c r g),
  f == g ->
  derive_Rball c r f prf == derive_Rball c r g prg.
Proof.
intros c r f g prf prg Heq x ; unfold derive_Rball ;
 destruct (in_Rball_dec c r x) as [HT1 | HF1].
 eapply derive_pt_in_ext ; [apply dense_Rball | |] ; assumption.
 reflexivity.
Qed.

Lemma derive_Rball_ext_strong:
  forall c r f g (prf: derivable_Rball c r f) (prg: derivable_Rball c r g),
  Rball_eq c r f g ->
  derive_Rball c r f prf == derive_Rball c r g prg.
Proof.
intros c r f g prf prg Heq x ; unfold derive_Rball ;
 destruct (in_Rball_dec c r x) as [HT1 | HF1].
 eapply derive_pt_in_ext_strong ; [apply dense_Rball | |] ; assumption.
 reflexivity.
Qed.

Lemma derive_derive_Rball: forall c r f pr pr',
  Rball_eq c r (derive f pr) (derive_Rball c r f pr').
Proof.
intros c r f pr pr' x x_in ; unfold derive_Rball ;
 destruct (in_Rball_dec c r x) as [HT | HF].
 destruct (pr' x HT) as [l Hl] ; simpl ; unfold derive ;
  rewrite derive_pt_eq ; eapply derivable_pt_lim_Rball_pt_lim ;
  eassumption.
 destruct (HF x_in).
Qed.

(** * Compatibility of derivable_*_in with common operations. *)

(** constant functions *)

Lemma derivable_pt_lim_in_const: forall D k x,
  derivable_pt_lim_in D (fun _ => k) x 0.
Proof.
intros D k x eps eps_pos ; exists 1 ; intros ; split.
 lra.
 intros ; simpl ; unfold R_dist, growth_rate, Rminus, Rdiv ;
 rewrite Rplus_opp_r, Rmult_0_l, Rplus_opp_r, Rabs_R0 ;
 assumption.
Qed.

Lemma derivable_pt_in_const : forall D k x,
  derivable_pt_in D (fun _ => k) x.
Proof.
intros ; eexists ; eapply derivable_pt_lim_in_const.
Qed.

Lemma derivable_in_const : forall D k,
  derivable_in D (fun _ => k).
Proof.
intros D k x x_in ; eapply derivable_pt_in_const.
Qed.

Lemma derive_pt_Rball_const : forall k c r x pr,
  Rball c r x ->
  derive_pt_in (Rball c r) (fun _ => k) x pr = 0.
Proof.
intros k c r x pr x_in ;
  eapply derivable_pt_lim_in_derive_pt_Rball ;
 [eexact x_in | eapply derivable_pt_lim_in_const].
Qed.

Lemma derive_Rball_const : forall k c r x pr,
  derive_Rball c r (fun _ => k) pr x = 0.
Proof.
intros k c r x pr ; unfold derive_Rball ;
 destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_const | reflexivity] ; assumption.
Qed.

(** multiplication by a scalar *)

Lemma derivable_pt_lim_in_scal: forall D a f x l,
  derivable_pt_lim_in D f x l ->
  derivable_pt_lim_in D (mult_real_fct a f) x (a * l).
Proof.
intros D a f x l Hf ; destruct (Req_dec a 0).
 subst ; rewrite Rmult_0_l ; eapply derivable_pt_lim_in_ext.
  symmetry ; eapply mult_real_fct_0.
  apply derivable_pt_lim_in_const.
 intros eps eps_pos ; pose (eps' := eps / Rabs a).
 assert (eps'_pos: 0 < eps').
  apply Rlt_mult_inv_pos ; [| apply Rabs_pos_lt] ; assumption.
 destruct (Hf _ eps'_pos) as [alpha [alpha_pos Halpha]].
 exists alpha ; split.
  assumption.
 intros y [[y_in y_neq] y_bd] ;
 rewrite growth_rate_mult_real_fct_compat, R_dist_scal_compat.
 apply Rlt_le_trans with (Rabs a * eps').
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt |
   apply Halpha ; repeat split] ; assumption.
  right ; unfold eps' ; field ; apply Rabs_no_R0 ; assumption.
  split ; [exact I | assumption].
Qed.

Lemma derivable_pt_in_scal: forall D a f x,
  derivable_pt_in D f x ->
  derivable_pt_in D (mult_real_fct a f) x.
Proof.
intros D a f x [l Hl] ; eexists ; eapply derivable_pt_lim_in_scal ; eassumption.
Qed.

Lemma derivable_in_scal: forall D a f,
  derivable_in D f ->
  derivable_in D (mult_real_fct a f).
Proof.
intros D a f Hf x x_in ; specify2 Hf x x_in ;
 apply derivable_pt_in_scal ; assumption.
Qed.

Lemma derive_pt_Rball_scal: forall a f c r x pr pr',
  Rball c r x ->
  derive_pt_in (Rball c r) (mult_real_fct a f) x pr =
  a * derive_pt_in (Rball c r) f x pr'.
Proof.
intros a f c r x [] [] x_in ;
 eapply derivable_pt_lim_in_derive_pt_Rball, derivable_pt_lim_in_scal ;
 eassumption.
Qed.

Lemma derive_Rball_scal: forall a f c r x pr pr',
  derive_Rball c r (mult_real_fct a f) pr x =
  a * derive_Rball c r f pr' x.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_scal ; assumption | symmetry ; apply Rmult_0_r].
Qed.

(** opposite of a function *)

Lemma derivable_pt_lim_in_opp: forall D f x l,
  derivable_pt_lim_in D f x l ->
  derivable_pt_lim_in D (- f)%F x (- l).
Proof.
intros ; eapply limit1_ext.
 intros y Hy ; symmetry ; apply growth_rate_opp_compat ; split ;
  [unfold no_cond ; trivial | apply Hy].
 apply limit_Ropp ; assumption.
Qed.

Lemma derivable_pt_in_opp: forall (D : R -> Prop) f x,
  derivable_pt_in D f x -> derivable_pt_in D (- f)%F x.
Proof.
intros D f x [] ; eexists ; eapply derivable_pt_lim_in_opp ; eassumption.
Qed.

Lemma derivable_in_opp: forall (D : R -> Prop) f,
  derivable_in D f -> derivable_in D (- f)%F.
Proof.
intros D f Hf x x_in ; eapply derivable_pt_in_opp, Hf ;
 eassumption.
Qed.

Lemma derive_pt_Rball_opp: forall f c r x pr pr', Rball c r x ->
  derive_pt_in (Rball c r) (- f)%F x pr = - derive_pt_in (Rball c r) f x pr'.
Proof.
intros f c r x [] [] x_in ;
 eapply derivable_pt_lim_Rball_uniqueness, derivable_pt_lim_in_opp ;
 eassumption.
Qed.

Lemma derive_Rball_opp: forall f c r x pr pr',
  derive_Rball c r (- f)%F pr x = - derive_Rball c r f pr' x.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_opp ; assumption | rewrite Ropp_0 ; reflexivity].
Qed.

(** sum of two functions *)

Lemma derivable_pt_lim_in_plus: forall D f g x l1 l2,
  derivable_pt_lim_in D f x l1 ->
  derivable_pt_lim_in D g x l2 ->
  derivable_pt_lim_in D (f + g)%F x (l1 + l2).
Proof.
intros ; eapply limit1_ext.
 intros y Hy ; symmetry ; apply growth_rate_plus_compat ; split ;
  [unfold no_cond ; trivial | apply Hy].
 apply limit_plus ; assumption.
Qed.

Lemma derivable_pt_in_plus: forall (D : R -> Prop) f g x,
  derivable_pt_in D f x -> derivable_pt_in D g x ->
  derivable_pt_in D (f + g)%F x.
Proof.
intros D f g x [] [] ; eexists ; eapply derivable_pt_lim_in_plus ; eassumption.
Qed.

Lemma derivable_in_plus: forall D f g,
  derivable_in D f -> derivable_in D g ->
  derivable_in D (f + g)%F.
Proof.
intros D f g Hf Hg x x_in ; eapply derivable_pt_in_plus ;
 [eapply Hf | eapply Hg] ; eassumption.
Qed.

Lemma derive_pt_Rball_plus: forall f g c r x prf prg prfg, Rball c r x ->
  derive_pt_in (Rball c r) (f + g)%F x prfg =
  derive_pt_in (Rball c r) f x prf + derive_pt_in (Rball c r) g x prg.
Proof.
intros f g c r x [] [] [] x_in ; eapply derivable_pt_lim_Rball_uniqueness,
 derivable_pt_lim_in_plus ; eassumption.
Qed.

Lemma derive_Rball_plus: forall f g c r x prf prg prfg,
  derive_Rball c r (f + g)%F prfg x =
  derive_Rball c r f prf x + derive_Rball c r g prg x.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_plus ; assumption | rewrite Rplus_0_r ; reflexivity].
Qed.

(** difference of two functions *)

Lemma derivable_pt_lim_in_minus: forall D f g x l1 l2,
  derivable_pt_lim_in D f x l1 -> derivable_pt_lim_in D g x l2 ->
  derivable_pt_lim_in D (f - g)%F x (l1 - l2).
Proof.
intros ; eapply limit1_ext.
 intros y Hy ; symmetry ; apply growth_rate_minus_compat ; split ;
  [unfold no_cond ; trivial | apply Hy].
 apply limit_minus ; assumption.
Qed.

Lemma derivable_pt_in_minus:
  forall (D : R -> Prop) (f g : R -> R) (x : R),
  derivable_pt_in D f x -> derivable_pt_in D g x ->
  derivable_pt_in D (f - g)%F x.
Proof.
intros D f g x [] []; eexists ; eapply derivable_pt_lim_in_minus ; eassumption.
Qed.

Lemma derivable_in_minus: forall D f g,
  derivable_in D f -> derivable_in D g ->
  derivable_in D (f - g)%F.
Proof.
intros D f g Hf Hg x x_in ; eapply derivable_pt_in_minus ;
 [eapply Hf | eapply Hg] ; eassumption.
Qed.

Lemma derive_pt_Rball_minus: forall f g c r x prf prg prfg, Rball c r x ->
  derive_pt_in (Rball c r) (f - g)%F x prfg =
  derive_pt_in (Rball c r) f x prf - derive_pt_in (Rball c r) g x prg.
Proof.
intros f g c r x [] [] [] x_in ; eapply derivable_pt_lim_Rball_uniqueness,
 derivable_pt_lim_in_minus ; eassumption.
Qed.

Lemma derive_Rball_minus: forall f g c r x prf prg prfg,
  derive_Rball c r (f - g)%F prfg x =
  derive_Rball c r f prf x - derive_Rball c r g prg x.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_minus ; assumption | rewrite Rminus_0_r ; reflexivity].
Qed.

(** Product of two functions *)

Lemma derivable_pt_lim_in_mult: forall (D : R -> Prop) f g x l1 l2, D x ->
  derivable_pt_lim_in D f x l1 -> derivable_pt_lim_in D g x l2 ->
  derivable_pt_lim_in D (f * g)%F x (l1 * g x + f x * l2).
Proof.
intros D f g x l1 l2 Dx Hf Hg ; eapply limit1_in_ext.
  intros y [Dy Hneq] ; symmetry ; apply growth_rate_mult_decomp, Hneq.
  apply limit_plus ; apply limit_mul ; [apply Hf | | | apply Hg].
  apply limit_free.
  apply limit1_imp with D.
   intros y [y_in y_neq] ; exact y_in.
   apply derivable_pt_in_continuity_pt_in ; [eexists |] ; eassumption.
Qed.

Lemma derivable_pt_in_mult: forall (D : R -> Prop) f g x, D x ->
  derivable_pt_in D f x -> derivable_pt_in D g x ->
  derivable_pt_in D (f * g)%F x.
Proof.
intros D f g x x_in [] [] ; eexists ; eapply derivable_pt_lim_in_mult ; eassumption.
Qed.

Lemma derivable_in_mult: forall D f g,
  derivable_in D f -> derivable_in D g ->
  derivable_in D (f * g)%F.
Proof.
intros D f g Hf Hg x x_in ; eapply derivable_pt_in_mult ;
 [| eapply Hf | eapply Hg] ; eassumption.
Qed.

Lemma derive_pt_Rball_mult: forall f g c r x prf prg prfg, Rball c r x ->
  derive_pt_in (Rball c r) (f * g)%F x prfg =
  derive_pt_in (Rball c r) f x prf * g x + f x * derive_pt_in (Rball c r) g x prg.
Proof.
intros f g c r x [] [] [] x_in ; eapply derivable_pt_lim_Rball_uniqueness,
 derivable_pt_lim_in_mult ; eassumption.
Qed.

Lemma derive_Rball_mult: forall f g c r x prf prg prfg,
  derive_Rball c r (f * g)%F prfg x =
  derive_Rball c r f prf x * g x + f x * derive_Rball c r g prg x.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_mult ; assumption | ring].
Qed.

(** inverse of a function *)

Lemma derivable_pt_lim_in_inv: forall (D : R -> Prop) f x l,
  D x -> f x <> 0 -> derivable_pt_lim_in D f x l ->
  derivable_pt_lim_in D (/ f)%F x (- l / (f x ^ 2)).
Proof.
intros D f x l Dx Hneq Hf ; assert (f_cont: continuity_pt_in D f x)
 by (eapply derivable_pt_in_continuity_pt_in ; eexists ; eassumption).
 destruct (continuity_not_eq_Rball _ _ _ 0 Dx f_cont Hneq) as [alp [alp_pos Halp]] ;
 eapply limit1_in_ext_strong.
  eassumption.
  intros y y_bd [y_in y_neq] ; symmetry ; eapply growth_rate_inv_decomp ;
   try assumption.
   apply Halp ; assumption.
  replace (- l / f x ^ 2) with (- (l / f x ^ 2)) by (unfold Rdiv ; ring).
 apply limit_Ropp ; unfold Rdiv ; apply limit_mul ; [apply Hf |].
  apply limit_inv ; [| apply pow_nonzero ; assumption].
   apply limit_mul ; [apply limit_free | rewrite Rmult_1_r] ;
   eapply limit1_imp, f_cont.
    intros y [y_in y_neq] ; assumption.
    assumption.
Qed.

Lemma derivable_pt_in_inv: forall (D : R -> Prop) f x,
  D x -> f x <> 0 -> derivable_pt_in D f x ->
  derivable_pt_in D (/ f)%F x.
Proof.
intros D f x Dx Hneq [] ; eexists ; eapply derivable_pt_lim_in_inv ; eassumption.
Qed.

Lemma derivable_in_inv: forall (D : R -> Prop) f,
  (forall x, D x -> f x <> 0) -> derivable_in D f ->
  derivable_in D (/ f)%F.
Proof.
intros D f Hneq Hf x x_in ; apply derivable_pt_in_inv ;
 [| apply Hneq | apply Hf] ; assumption.
Qed.

Lemma derive_pt_Rball_inv: forall f c r x pr pr',
  Rball c r x -> f x <> 0 ->
  derive_pt_in (Rball c r) (/ f)%F x pr =
  (- derive_pt_in (Rball c r) f x pr') / (f x) ^ 2.
Proof.
intros f c r x [] [] x_in fx_neq ; eapply derivable_pt_lim_Rball_uniqueness,
 derivable_pt_lim_in_inv ; eassumption.
Qed.

Lemma derive_Rball_inv: forall f c r x pr pr', f x <> 0 ->
  derive_Rball c r (/ f)%F pr x = (- derive_Rball c r f pr' x) / (f x) ^ 2.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_inv ; assumption | rewrite Ropp_0, Rdiv_0_l ; reflexivity].
Qed.

(** Division of a function by another *)

Lemma derivable_pt_lim_in_div: forall (D : R -> Prop) f g x l1 l2,
  D x -> g x <> 0 ->
  derivable_pt_lim_in D f x l1 -> derivable_pt_lim_in D g x l2 ->
  derivable_pt_lim_in D (f / g)%F x ((l1 * g x - f x * l2) / g x ^ 2).
Proof.
intros D f g x l1 l2 Dx Hneq Hf Hg ; apply derivable_pt_lim_in_ext with (f * / g)%F.
 intro ; reflexivity.
 replace ((l1 * g x - f x * l2) / g x ^ 2) with ((l1 * (/ g)%F x) + f x * (- l2 / g x ^ 2)).
 eapply derivable_pt_lim_in_mult ; try eassumption.
 eapply derivable_pt_lim_in_inv ; try eassumption.
 unfold inv_fct ; field ; assumption.
Qed.

Lemma derivable_pt_in_div: forall (D : R -> Prop) f g x,
  D x -> g x <> 0 ->
  derivable_pt_in D f x -> derivable_pt_in D g x ->
  derivable_pt_in D (f / g)%F x.
Proof.
intros D f g x Dx Hneq [] [] ; eexists ; eapply derivable_pt_lim_in_div ; eassumption.
Qed.

Lemma derivable_in_div: forall (D : R -> Prop) f g,
  (forall x, D x -> g x <> 0) ->
  derivable_in D f -> derivable_in D g ->
  derivable_in D (f / g)%F.
Proof.
intros D f g Hneq Hf Hg x x_in ; apply derivable_pt_in_div ;
 [| apply Hneq | apply Hf | apply Hg] ; assumption.
Qed.

Lemma derive_pt_Rball_div: forall f g c r x prf prg prfg,
  Rball c r x -> g x <> 0 ->
  derive_pt_in (Rball c r) (f / g)%F x prfg =
  (derive_pt_in (Rball c r) f x prf * g x - f x * derive_pt_in (Rball c r) g x prg) / (g x) ^ 2.
Proof.
intros f g c r x [] [] [] x_in gx_neq ; eapply derivable_pt_lim_Rball_uniqueness,
 derivable_pt_lim_in_div ; eassumption.
Qed.

Lemma derive_Rball_div: forall f g c r x prf prg prfg, g x <> 0 ->
  derive_Rball c r (f / g)%F prfg x =
  (derive_Rball c r f prf x * g x - f x * derive_Rball c r g prg x) / (g x) ^ 2.
Proof.
intros ; unfold derive_Rball ; destruct (in_Rball_dec c r x) as [x_in | x_nin] ;
 [apply derive_pt_Rball_div ; assumption
 | rewrite Rmult_0_r, Rmult_0_l, Rminus_0_r, Rdiv_0_l ; reflexivity].
Qed.

(** For more complicated cases we (at the moment) deal only
    with Rball because this is what we need ultimately. *)

(*TODO: prove that stuff in the general case! *)

Lemma derivable_pt_lim_Rball_comp: forall cf rf cg rg f g x l1 l2,
  Rball cf rf x -> Rball cg rg (f x) ->
  derivable_pt_lim_in (Rball cf rf) f x l1 ->
  derivable_pt_lim_in (Rball cg rg) g (f x) l2 ->
  derivable_pt_lim_in (Rball cf rf) (comp g f) x (l1 * l2).
Proof.
intros cf rf cg rg f g x l1 l2 x_in fx_in Hf Hg ; rewrite Rmult_comm.
 apply derivable_pt_lim_derivable_pt_lim_in, derivable_pt_lim_comp ;
 eapply derivable_pt_lim_Rball_pt_lim ; eassumption.
Qed.

Lemma derivable_pt_Rball_comp: forall cf rf cg rg f g x,
  Rball cf rf x -> Rball cg rg (f x) ->
  derivable_pt_in (Rball cf rf) f x ->
  derivable_pt_in (Rball cg rg) g (f x) ->
  derivable_pt_in (Rball cf rf) (comp g f) x.
Proof.
intros cf rf cg rg f g x x_in y_in [] [] ; eexists ;
 eapply derivable_pt_lim_Rball_comp ; eassumption.
Qed.

Lemma derivable_Rball_comp: forall cf rf cg rg f g,
  (forall x, Rball cf rf x -> Rball cg rg (f x)) ->
  derivable_Rball cf rf f -> derivable_Rball cg rg g ->
  derivable_Rball cf rf (comp g f).
Proof.
intros cf rf cg rg f g g_ok Hf Hg x x_in ;
 eapply derivable_pt_Rball_comp ; [| | eapply Hf | eapply Hg] ;
 try eapply g_ok ; eassumption.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

Require Export ZArith.
Require Export Rbase.

Require Import ClassicalEpsilon.

Class WhyType T := {
  why_inhabitant : T ;
  why_decidable_eq : forall x y : T, { x = y } + { x <> y }
}.

Notation int := Z.

Global Instance int_WhyType : WhyType int.
Proof.
split.
exact Z0.
exact Z_eq_dec.
Qed.

Notation real := R.

Global Instance real_WhyType : WhyType real.
Proof.
split.
exact R0.
intros x y.
destruct (total_order_T x y) as [[H|H]|H] ;
  try (left ; exact H) ; right.
now apply Rlt_not_eq.
now apply Rgt_not_eq.
Qed.

Global Instance tuple_WhyType : forall T {T' : WhyType T} U {U' : WhyType U}, WhyType (T * U).
Proof.
intros T WT U WU.
split.
split ; apply why_inhabitant.
intros (x1,x2) (y1,y2).
destruct (why_decidable_eq x1 y1) as [H1|H1].
destruct (why_decidable_eq x2 y2) as [H2|H2].
left.
now apply f_equal2.
right.
now injection.
right.
now injection.
Qed.

Global Instance unit_WhyType : WhyType unit.
Proof.
split.
exact tt.
intros [] [].
now left.
Qed.

Global Instance bool_WhyType : WhyType bool.
Proof.
split.
exact false.
exact Bool.bool_dec.
Qed.

Global Instance func_WhyType : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, WhyType (a -> b).
Proof.
intros.
repeat split.
exact (fun _ => why_inhabitant).
intros x y.
apply excluded_middle_informative.
Qed.


(* ******************************************************************************* *)
(** * Bicategory of graphs
    Benedikt Ahrens, Marco Maggesi
    May 2018
    Revised June 2019
 ********************************************************************************* *)

Require Import UniMath.Foundations.PartB.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Combinatorics.Graph.

(** NB: pregraph is the same as precategory_ob_mor. *)

Require UniMath.CategoryTheory.Core.Univalence.  (* double_transport *)
Require UniMath.CategoryTheory.Core.Functors.    (* functor_data_eq *)

(** Should be moved in Combinatorics/Graph.v,
    but it depends on code from CategoryTheory for now. *)
Definition graph_mor_eq {G H : pregraph} (p q : graph_mor G H)
           (e₀ : ∏ x : vertex G, onvertex p x = onvertex q x)
           (e₁ : ∏ x y (f : edge G x y),
                 UniMath.CategoryTheory.Core.Univalence.double_transport
                   (e₀ x) (e₀ y) (onedge p f) =
                 onedge q f)
  : p = q
  := UniMath.CategoryTheory.Core.Functors.functor_data_eq G H p q e₀ e₁.

Lemma isaprop_has_edgesets (G : pregraph)
  : isaprop (has_edgesets G).
Proof.
  apply UniMath.CategoryTheory.Core.Categories.isaprop_has_homsets.
Qed.

(** ** Precategory of pregraphs. *)

Definition pregraph_precategory_ob_mor : precategory_ob_mor
  := make_precategory_ob_mor pregraph graph_mor.

Definition pregraph_precategory_data : precategory_data
  := make_precategory_data
       pregraph_precategory_ob_mor
       graph_mor_id
       (@graph_mor_comp).

Lemma is_precategory_pregraph : is_precategory pregraph_precategory_data.
Proof.
  apply is_precategory_one_assoc_to_two.
  repeat apply make_dirprod; cbn.
  - exact @graph_mor_id_left.
  - exact @graph_mor_id_right.
  - apply @graph_mor_comp_assoc.
Qed.

Definition pregraph_category : precategory
  := make_precategory
       pregraph_precategory_data
       is_precategory_pregraph.

(** ** Category of graphs. *)

Definition graph_precategory_ob_mor : precategory_ob_mor
  := make_precategory_ob_mor graph graph_mor.

Definition graph_precategory_data : precategory_data
  := make_precategory_data
       graph_precategory_ob_mor
       (λ G : graph, graph_mor_id G)
       (λ G H K : graph, graph_mor_comp).

Lemma is_precategory_graph : is_precategory graph_precategory_data.
Proof.
  apply is_precategory_one_assoc_to_two.
  repeat apply make_dirprod; cbn.
  - exact @graph_mor_id_left.
  - exact @graph_mor_id_right.
  - exact @graph_mor_comp_assoc.
Qed.

Definition graph_precategory : precategory
  := make_precategory
       graph_precategory_data
       is_precategory_graph.

Lemma has_homsets_graph : has_homsets graph_precategory_ob_mor.
Proof.
  intros G H.
  apply isaset_graph_mor.
  - exact (isaset_vertex H).
  - exact (isaset_edge H).
Defined.


(*
Author: Jasper Hugunin
TPPmark 2017
Longest Common Subsequence
*)

(*
Let's aim for efficiency.
Consider an arbitrary type of elements A, whose elements take space size(A),
and for which we can decide equality in time dec(A).
Assume the given strings have lengths n and m, with n <= m.
Let the length of the longest common subsequence be b, then we have b <= n <= m.
Our input then has size ((n + m) * size(A)),
and our output has size (b * size(A)).

We iteratively generate one row of the grid at a time, storing the best
substring of n along with it's length.
Each cell should take O(log b + dec(A)) time, giving
O(n * m * (log b + dec(A))) time,
and (in a strict evaluation model at least)
we have to store one row at a time, with each cell taking O(n + log b) space
and so taking a total of O(n * (n + log b)) space.

We can then extract a string from the final result,
taking O(n) time and O(b * size(A) + n) space.
*)

From Coq Require Import NArith.
From Coq Require Import List.
From Coq Require Import DecidableClass.
From Coq Require Import SetoidDec.
From Coq Require Import SetoidClass.

Import ListNotations.
Close Scope nat_scope.
Open Scope N_scope.

Set Primitive Projections.

Definition length {A} : list A -> N
  := fold_right (fun _ => N.succ) 0.

(* StrictSubseq l1 l2 expresses that l1 is a subsequence of l2 *)
Inductive StrictSubseq {A} : list A -> list A -> Type :=
  | nil_nil_strict_subseq : StrictSubseq nil nil
  | keep_cons_strict_subseq
    : forall a l1 l2, StrictSubseq l1 l2 -> StrictSubseq l1 (a :: l2)
  | cons_cons_strict_subseq
    : forall a l1 l2, StrictSubseq l1 l2 -> StrictSubseq (a :: l1) (a :: l2)
.
Inductive WeakSubseq {A B} (R : A -> B -> Type) : list A -> list B -> Type :=
  | nil_nil_weak_subseq : WeakSubseq R nil nil
  | keep_cons_weak_subseq
    : forall b l1 l2, WeakSubseq R l1 l2 -> WeakSubseq R l1 (b :: l2)
  | cons_cons_weak_subseq
    : forall a b (aRb : R a b) l1 l2,
      WeakSubseq R l1 l2 -> WeakSubseq R (a :: l1) (b :: l2)
.

Definition LongestCommonSubsequence {A B} (R : A -> B -> Type)
  (seq1 : list A) (seq2 : list B) (ans : list A) : Type
  := StrictSubseq ans seq1 * WeakSubseq R ans seq2 *
     (forall ans', StrictSubseq ans' seq1 -> WeakSubseq R ans' seq2 ->
      length ans' <= length ans).

Module Import subseq.
Definition nil_strict_subseq {A} : forall l : list A, StrictSubseq nil l
  := fix nil_subseq l := match l with
     | nil => nil_nil_strict_subseq
     | cons a l' => keep_cons_strict_subseq a nil l' (nil_subseq l')
     end.
Definition nil_weak_subseq {A B} R
  : forall l : list B, WeakSubseq (A:=A) R nil l
  := fix nil_subseq l := match l with
     | nil => nil_nil_weak_subseq R
     | cons a l' => keep_cons_weak_subseq R a nil l' (nil_subseq l')
     end.

Definition strict_to_weak {A} R (Rrefl : forall a : A, R a a)
  : forall {l1 l2}, StrictSubseq l1 l2 -> WeakSubseq R l1 l2
  := fix strict_to_weak {l1 l2} H :=
     match H in StrictSubseq l1 l2 return WeakSubseq R l1 l2
     with
     | nil_nil_strict_subseq => nil_nil_weak_subseq _
     | keep_cons_strict_subseq a l1 l2 IH =>
       keep_cons_weak_subseq _ a l1 l2 (strict_to_weak IH)
     | cons_cons_strict_subseq a l1 l2 IH =>
       cons_cons_weak_subseq _ a a (Rrefl a) l1 l2 (strict_to_weak IH)
     end.
Definition weak_to_weak {A B} R1 R2
  (Rimpl : forall (a : A) (b : B), R1 a b -> R2 a b)
  : forall {l1 l2}, WeakSubseq R1 l1 l2 -> WeakSubseq R2 l1 l2
  := fix weak_to_weak {l1 l2} H :=
     match H in WeakSubseq _ l1 l2 return WeakSubseq R2 l1 l2
     with
     | nil_nil_weak_subseq _ => nil_nil_weak_subseq R2
     | keep_cons_weak_subseq _ b l1 l2 IH =>
       keep_cons_weak_subseq R2 b l1 l2 (weak_to_weak IH)
     | cons_cons_weak_subseq _ a b aR1b l1 l2 IH =>
       cons_cons_weak_subseq R2 a b (Rimpl a b aR1b) l1 l2 (weak_to_weak IH)
     end.
End subseq.

Module Import inner.
Section inner.
(*
We take as the elements of our sequences arbitrary types with a decidable
relation. We produce a strict substring of the first, and a substring up to
the relation of the second.
*)
Context {A B : Type} (R : A -> B -> bool).
Context (seq1 : list A) (seq2 : list B).

Record cell := { cell_len : N; cell_sel : list bool; }.
Definition row := list cell.
Definition row_hd : row -> cell := hd {| cell_len := 0; cell_sel := [] |}.

Definition cell_max : cell -> cell -> cell
  := fun c1 c2 => match cell_len c1 ?= cell_len c2 with
     | Eq | Lt => c2
     | Gt => c1
     end.
Definition pad_cell : cell -> cell
  := fun c => {| cell_len := cell_len c; cell_sel := false :: cell_sel c |}.
Definition inc_cell : cell -> cell
  := fun c =>
     {| cell_len := N.succ (cell_len c); cell_sel := true :: cell_sel c |}.
Definition cell_update (diag : cell) (left : cell) (up : cell) (a : A) (b : B)
  : cell
  := let standard := cell_max (pad_cell left) up in
     if R a b then cell_max standard (inc_cell diag) else standard.

Definition inner_initial_row : list A -> row * list bool
  := fix init seq := match seq with
     | [] => ([], [])
     | a :: seq' =>
       let IH := init seq' in let tail := fst IH in let head_sel := snd IH in
       ({| cell_len := 0; cell_sel := head_sel |} :: tail, false :: head_sel)
     end.
Definition initial_row : row
  := let inner := inner_initial_row seq1 in
     {| cell_len := 0; cell_sel := snd inner |} :: fst inner.

(*
Takes a char from seq2, all of seq1, the previous row, and returns
the tail of the new row, the head of the previous row,
and the head of the new row.
*)
Definition inner_update (char : B) : list A -> row -> row * cell * cell
  := fix update seq1 := fun cur => match seq1 with
     | nil => ([], row_hd cur, {| cell_len := 0; cell_sel := [] |})
     | cons a seq1' =>
       let step := update seq1' (tl cur) in let new_row_ := fst (fst step) in
       let diagc := snd (fst step) in let leftc := snd step in
       let upc := row_hd cur in
       (leftc :: new_row_, upc, cell_update diagc leftc upc a char)
     end.
Definition update_state (char : B) (cur : row) : row
  := let step := inner_update char seq1 cur in snd step :: fst (fst step).

Definition get_substring : list A -> list bool -> list A
  := fix substr seq {struct seq} := fun sel => match seq, sel with
     | [], _ | _, [] => []
     | a :: seq', true :: sel' => a :: substr seq' sel'
     | a :: seq', false :: sel' => substr seq' sel'
     end.

Definition final_cell : cell
  := let final_state := fold_right update_state initial_row seq2 in
     row_hd final_state.
Definition lcs : list A
  := get_substring seq1 (cell_sel final_cell).

Definition get_substring_StrictSubseq
  : forall seq sel, StrictSubseq (get_substring seq sel) seq
  := fix substr_subseq seq sel := match seq, sel with
     | [], _ | _, [] => nil_strict_subseq _
     | a :: seq', true :: sel' =>
       cons_cons_strict_subseq a _ _ (substr_subseq seq' sel')
     | a :: seq', false :: sel' =>
       keep_cons_strict_subseq a _ _ (substr_subseq seq' sel')
     end.
Definition lcs_StrictSubseq_seq1 : StrictSubseq lcs seq1
  := get_substring_StrictSubseq seq1 _.

(*
Define an the induction for the grid.
*)
Section lcs_rect.
Context
  (P : cell -> list A -> list B -> Type)
  (step_nil1 : forall l, P {| cell_len := 0; cell_sel := [] |} [] l)
  (step_nil2
   : forall sel a l,
     P {| cell_len := 0; cell_sel := sel |} l [] ->
     P {| cell_len := 0; cell_sel := false :: sel |} (a :: l) [])
  (step_cell_update
   : forall diag left up a b seq1 seq2,
     P diag seq1 seq2 -> P left seq1 (b :: seq2) -> P up (a :: seq1) seq2 ->
     P (cell_update diag left up a b) (a :: seq1) (b :: seq2))
.

Definition rowP : row -> list A -> list B -> Type
  := let fix rowP' seq1 := fun cur seq2 =>
       match seq1 return Type with
       | nil => unit
       | cons a seq1' => prod
         (P (row_hd (tl cur)) seq1' seq2)
         (rowP' seq1' (tl cur) seq2)
       end in
     fun cur seq1 seq2 => prod
     (P (row_hd cur) seq1 seq2)
     (rowP' seq1 cur seq2).

Definition initial_row_P : rowP initial_row seq1 []
  := let fix initP seq
      : let inner := inner_initial_row seq in
        let init := {| cell_len := 0; cell_sel := snd inner |} :: fst inner in
        rowP init seq []
      := match seq with
         | [] => (step_nil1 _, tt)
         | a :: seq' => let IH := initP seq' in
           (step_nil2 _ a seq' (fst IH), IH)
         end in
     initP seq1.

Definition update_state_P char cur seq2
  : rowP cur seq1 seq2 ->
    rowP (update_state char cur) seq1 (char :: seq2)
  := fun H =>
     let fix inner seq1
      : forall cur, rowP cur seq1 seq2 ->
        let step := inner_update char seq1 cur in
        P (snd (fst step)) seq1 seq2 *
        rowP (snd step :: fst (fst step)) seq1 (char :: seq2)
      := fun cur => match seq1 with
         | nil => fun H => (fst H, (step_nil1 _, tt))
         | cons a seq1' => fun H =>
           let step := inner_update char seq1' (tl cur) in
           let IH
            : _ *
              rowP (snd step :: fst (fst step)) seq1' (char :: seq2)
            := inner seq1' (tl cur) (snd H) in
           (fst H,
            (step_cell_update _ _ _ a char seq1' seq2
             (fst IH) (fst (snd IH)) (fst H),
             (snd IH)))
         end in
     snd (inner seq1 cur H).

Definition final_cell_P : P final_cell seq1 seq2
  := let fix iter seq2
      : rowP (fold_right update_state initial_row seq2) seq1 seq2
      := match seq2 with
         | nil => initial_row_P
         | cons char seq2' => update_state_P char _ _ (iter seq2')
         end in
     fst (iter seq2).
End lcs_rect.

Definition cell_subseq : cell -> list A -> list B -> Type
  := fun c seq1 seq2 => WeakSubseq (fun x y => R x y = true)
     (get_substring seq1 (cell_sel c)) seq2.

Definition cell_max_subseq {c1 c2 seq1 seq2}
  (H1 : cell_subseq c1 seq1 seq2) (H2 : cell_subseq c2 seq1 seq2)
  : cell_subseq (cell_max c1 c2) seq1 seq2
  := match cell_len c1 ?= cell_len c2 as cond
     return cell_subseq (match cond with Gt => _ | _ => _ end) _ _ with
     | Eq | Lt => H2
     | Gt => H1
     end.
Definition pad_cell_subseq {c a seq1 seq2} (H : cell_subseq c seq1 seq2)
  : cell_subseq (pad_cell c) (a :: seq1) seq2
  := H.
Definition inc_cell_subseq {c a seq1 b seq2}
  (aRb : R a b = true) (H : cell_subseq c seq1 seq2)
  : cell_subseq (inc_cell c) (a :: seq1) (b :: seq2)
  := cons_cons_weak_subseq _ _ _ aRb _ _ H.
Definition lift_cell_subseq {c seq1 b seq2}
  : cell_subseq c seq1 seq2 -> cell_subseq c seq1 (b :: seq2)
  := keep_cons_weak_subseq _ _ _ _.
Definition cell_update_subseq diag left up a b seq1 seq2
  (Hdiag : cell_subseq diag seq1 seq2)
  (Hleft : cell_subseq left seq1 (b :: seq2))
  (Hup : cell_subseq up (a :: seq1) seq2)
  : cell_subseq (cell_update diag left up a b) (a :: seq1) (b :: seq2)
  := let Hsides
      : cell_subseq (cell_max (pad_cell left) up) (a :: seq1) (b :: seq2)
      := cell_max_subseq (pad_cell_subseq Hleft) (lift_cell_subseq Hup) in
     (if R a b as cond
      return R a b = cond -> cell_subseq (if cond then _ else _) _ _
      then fun aRb => cell_max_subseq Hsides (inc_cell_subseq aRb Hdiag)
      else fun _ => Hsides)
     eq_refl.

Definition lcs_WeakSubseq_seq2 : WeakSubseq (fun a b => R a b = true) lcs seq2
  := final_cell_P cell_subseq (nil_weak_subseq _) (fun c a l H => H)
     cell_update_subseq.

Definition len_max n seq1 seq2
  := forall ans,
     StrictSubseq ans seq1 ->
     WeakSubseq (fun x y => R x y = true) ans seq2 ->
     length ans <= n.
Definition cell_len_max c seq1 seq2 := len_max (cell_len c) seq1 seq2.

Definition weak_subseq_nil_len_zero {R : A -> B -> Type} l
  (lsub : WeakSubseq R l nil) : length l <= 0
  := match lsub in WeakSubseq _ l nil return length l <= 0
     with nil_nil_weak_subseq _ => N.le_0_l 0 end.
Definition len_max_zero_l_nil {l} : len_max 0 l nil
  := fun ans _ => weak_subseq_nil_len_zero ans.

Definition len_max_zero_nil_l l : len_max 0 nil l
  := fun ans H _ => match H in StrictSubseq ans nil return length ans <= 0
     with nil_nil_strict_subseq => N.le_0_l 0 end.

Definition cell_max_len1 c1 c2 : cell_len c1 <= cell_len (cell_max c1 c2)
  := match cell_len c1 ?= cell_len c2 as cond
     return
       cell_len c1 ?= cell_len c2 = cond ->
       cell_len c1 <= cell_len (match cond with Gt => _ | _ => _ end)
     with
     | Eq | Lt => fun H1 (H2 : _ ?= cell_len c2 = _) =>
       let H := eq_trans (eq_sym H1) H2 in ltac:(discriminate)
     | Gt => fun _ => N.le_refl _
     end eq_refl.
Definition cell_max_len2 c1 c2 : cell_len c2 <= cell_len (cell_max c1 c2)
  := match cell_len c1 ?= cell_len c2 as cond
     return
       cell_len c1 ?= cell_len c2 = cond ->
       cell_len c2 <= cell_len (match cond with Gt => _ | _ => _ end)
     with
     | Eq | Lt => fun _ => N.le_refl _
     | Gt => fun (H : cell_len c1 > cell_len c2) =>
       N.lt_le_incl _ _ (N.gt_lt _ _ H)
     end eq_refl.
Definition cell_update_len_left {diag left up a b}
  : cell_len left <= cell_len (cell_update diag left up a b)
  := let left_leq_sides
      : cell_len left <= cell_len (cell_max (pad_cell left) up)
      := cell_max_len1 (pad_cell left) up in
     if R a b as cond return _ <= cell_len (if cond then _ else _)
     then N.le_trans _ _ _ left_leq_sides (cell_max_len1 _ _)
     else left_leq_sides.
Definition cell_update_len_up {diag left up a b}
  : cell_len up <= cell_len (cell_update diag left up a b)
  := let up_leq_sides
      : cell_len up <= cell_len (cell_max (pad_cell left) up)
      := cell_max_len2 (pad_cell left) up in
     if R a b as cond return _ <= cell_len (if cond then _ else _)
     then N.le_trans _ _ _ up_leq_sides (cell_max_len1 _ _)
     else up_leq_sides.
Definition cell_update_len_diag {diag left up a b} (aRb : R a b = true)
  : N.succ (cell_len diag) <= cell_len (cell_update diag left up a b)
  := match eq_sym aRb in _ = aRb return _ <= cell_len (if aRb then _ else _)
     with eq_refl => cell_max_len2 _ (inc_cell diag) end.

Definition cell_update_len_max diag left up a b seq1 seq2
  : cell_len_max diag seq1 seq2 ->
    cell_len_max left seq1 (b :: seq2) -> cell_len_max up (a :: seq1) seq2 ->
    cell_len_max (cell_update diag left up a b) (a :: seq1) (b :: seq2)
  := fun Hdiag Hleft Hup ans H1 H2 =>
     match H1 in StrictSubseq ans (a :: seq1)
     return
       WeakSubseq _ ans (b :: seq2) ->
       cell_len_max diag seq1 seq2 ->
       cell_len_max left seq1 (b :: seq2) -> cell_len_max up (a :: seq1) seq2 ->
       length ans <= cell_len (cell_update diag left up a b)
     with
     | keep_cons_strict_subseq a ans seq1 IH1 => fun H2 _ Hleft _ =>
       let less_left : length ans <= cell_len left := Hleft ans IH1 H2 in
       N.le_trans _ _ _ less_left cell_update_len_left
     | cons_cons_strict_subseq a ans' seq1 IH1 => fun H2 =>
       match H2 in WeakSubseq _ (a :: ans') (b :: seq2)
       return
         StrictSubseq ans' seq1 ->
         cell_len_max diag seq1 seq2 ->
         cell_len_max left seq1 (b :: seq2) ->
         cell_len_max up (a :: seq1) seq2 ->
         length (a :: ans') <= cell_len (cell_update diag left up a b)
       with
       | keep_cons_weak_subseq _ b (a :: ans') seq2 IH2 => fun IH1 _ _ Hup =>
         let less_up : length (a :: ans') <= cell_len up
          := Hup _ (cons_cons_strict_subseq a ans' seq1 IH1) IH2 in
         N.le_trans _ _ _ less_up cell_update_len_up
       | cons_cons_weak_subseq _ a b aRb ans' seq2 IH2 => fun IH1 Hdiag _ _ =>
         let less_diag : length (a :: ans') <= N.succ (cell_len diag)
          := proj1 (N.succ_le_mono _ _) (Hdiag _ IH1 IH2) in
         N.le_trans _ _ _ less_diag (cell_update_len_diag aRb)
       end IH1
     end H2 Hdiag Hleft Hup.

Definition lcs_len_max : len_max (cell_len final_cell) seq1 seq2
  := final_cell_P cell_len_max
     len_max_zero_nil_l (fun _ _ _ _ => len_max_zero_l_nil)
     cell_update_len_max.

Definition cell_len_correct c seq1
  := cell_len c = length (get_substring seq1 (cell_sel c)).
Definition cell_max_len_correct {c1 c2 seq1}
  (H1 : cell_len_correct c1 seq1) (H2 : cell_len_correct c2 seq1)
  : cell_len_correct (cell_max c1 c2) seq1
  := match cell_len c1 ?= cell_len c2 as cond
     return cell_len_correct (match cond with Gt => _ | _ => _ end) _ with
     | Eq | Lt => H2
     | Gt => H1
     end.
Definition pad_cell_len_correct {c a seq1} (H : cell_len_correct c seq1)
  : cell_len_correct (pad_cell c) (a :: seq1)
  := H.
Definition inc_cell_len_correct {c a seq1} (H : cell_len_correct c seq1)
  : cell_len_correct (inc_cell c) (a :: seq1)
  := f_equal N.succ H.
Definition cell_update_len_correct diag left up a b seq1
  (Hdiag : cell_len_correct diag seq1)
  (Hleft : cell_len_correct left seq1)
  (Hup : cell_len_correct up (a :: seq1))
  : cell_len_correct (cell_update diag left up a b) (a :: seq1)
  := let Hsides : cell_len_correct (cell_max (pad_cell left) up) (a :: seq1)
      := cell_max_len_correct (pad_cell_len_correct Hleft) Hup in
     if R a b as cond
     return cell_len_correct (if cond then _ else _) _
     then cell_max_len_correct Hsides (inc_cell_len_correct Hdiag)
     else Hsides.
Definition lcs_len_correct : cell_len final_cell = length lcs
  := final_cell_P
     (fun c seq1 _ => cell_len_correct c seq1)
     (fun _ => eq_refl) (fun c a l H => H)
     (fun diag left up a b seq1 seq2 =>
      cell_update_len_correct diag left up a b seq1).

Definition lcs_max : len_max (length lcs) seq1 seq2
  := eq_rect _ (fun n => len_max n seq1 seq2) lcs_len_max _ lcs_len_correct.

Definition inner_lcs_LongestCommonSubsequence
  : LongestCommonSubsequence (fun a b => R a b = true) seq1 seq2 lcs
  := (lcs_StrictSubseq_seq1, lcs_WeakSubseq_seq2, lcs_max).

End inner.
End inner.

Definition lcs_LongestCommonSubsequence {A B} (R : A -> B -> bool) s t
  : LongestCommonSubsequence (fun a b => R a b = true) s t (lcs R s t)
  := inner_lcs_LongestCommonSubsequence R s t.

(*
At this point, we have defined a function that computes the longest subsequence
of s that can be matched with a subsequence of t such that R holds between the
two sequences.

If we take R to be an equivalence relation, we can recover the usual version.
*)

Definition UsualLongestCommonSubsequence {A} (Aeq : A -> A -> Type) s t ans
  : Type
  := WeakSubseq Aeq ans s * WeakSubseq Aeq ans t *
     (forall ans', WeakSubseq Aeq ans' s -> WeakSubseq Aeq ans' t ->
      length ans' <= length ans).

Module Import inner_usual.
Section usual_lcs.
Context
  (A : Type)
  {Asetoid : Setoid A}
  {Adec : EqDec Asetoid}.
Context (seq1 seq2 : list A).

Definition usual_lcs : list A
  := lcs (fun a1 a2 => a1 ==b a2) seq1 seq2.
Definition usual_lcs_subseq1
  : WeakSubseq equiv usual_lcs seq1
  := strict_to_weak _ reflexivity (lcs_StrictSubseq_seq1 _ seq1 seq2).
Definition usual_lcs_subseq2
  : WeakSubseq equiv usual_lcs seq2
  := weak_to_weak _ _
     (fun a b => match a == b as cond
      return (if cond then true else false) = true -> a == b
      with left H => fun _ => H | right _ => fun XX => ltac:(discriminate) end)
     (lcs_WeakSubseq_seq2 _ seq1 seq2).

Definition ans'
  : forall ans'_ seq1 : list A, WeakSubseq equiv ans'_ seq1 -> list A
  := fix ans' ans'_ seq1 ans'_sub1 : list A :=
     match ans'_sub1 with
     | nil_nil_weak_subseq _ => nil
     | keep_cons_weak_subseq _ _ _ _ IH => ans' _ _ IH
     | cons_cons_weak_subseq _ _ b _ _ _ IH => b :: ans' _ _ IH
     end.
Definition ans'_length_eq
  : forall ans'_ seq1 ans'_sub1,
    length (ans' ans'_ seq1 ans'_sub1) = length ans'_
  := fix ans'_len ans'_ seq1 ans'_sub1 :=
     match ans'_sub1 with
     | nil_nil_weak_subseq _ => eq_refl
     | keep_cons_weak_subseq _ _ _ _ IH => ans'_len _ _ IH
     | cons_cons_weak_subseq _ _ _ _ _ _ IH => f_equal N.succ (ans'_len _ _ IH)
     end.
Definition equiv_to_eqtrue a1 a2 : a1 == a2 -> a1 ==b a2 = true
  := match a1 == a2 as cond
     return a1 == a2 -> (if cond then true else false) = true
     with
     | left H => fun _ => eq_refl
     | right nH => fun H => False_rect _ (nH H)
     end.
Definition ans'sub1
  : forall ans'_ seq1 ans'_sub1,
    StrictSubseq (ans' ans'_ seq1 ans'_sub1) seq1
  := fix ans'sub1 ans'_ seq1 ans'_sub1 := match ans'_sub1 with
     | nil_nil_weak_subseq _ => nil_nil_strict_subseq
     | keep_cons_weak_subseq _ _ _ _ IH =>
       keep_cons_strict_subseq _ _ _ (ans'sub1 _ _ IH)
     | cons_cons_weak_subseq _ _ _ _ _ _ IH =>
       cons_cons_strict_subseq _ _ _ (ans'sub1 _ _ IH)
     end.
Definition ans'sub2
  : forall ans'_ seq1 ans'_sub1 seq2 (ans'_sub2 : WeakSubseq equiv ans'_ seq2),
    WeakSubseq (fun a1 a2 => a1 ==b a2 = true) (ans' ans'_ seq1 ans'_sub1) seq2
  := fix ans'sub2 ans'_ seq1 ans'_sub1 :=
     match ans'_sub1 in WeakSubseq _ ans'_ seq1
     return
       forall seq2, WeakSubseq equiv ans'_ seq2 ->
       WeakSubseq _ (ans' ans'_ seq1 ans'_sub1) seq2
     with
     | nil_nil_weak_subseq _ => fun seq2 ans'_seq2 => nil_weak_subseq _ _
     | keep_cons_weak_subseq _ _ _ _ IH => ans'sub2 _ _ IH
     | cons_cons_weak_subseq _ a b a_equiv_b l1 l2 IH => fun seq2 ans'_sub2 =>
       let IH' := ans'sub2 _ _ IH in
       (fix inner a l1 seq2 (ans'_sub2 : WeakSubseq _ (a :: l1) seq2)
        : forall l2 IH, a == b ->
          (forall seq, WeakSubseq equiv l1 seq ->
           WeakSubseq _ (ans' l1 l2 IH) seq) ->
          WeakSubseq _ (b :: ans' l1 l2 IH) seq2
        := match ans'_sub2 in WeakSubseq _ (a :: l1) seq2
           return
             forall l2 IH, a == b ->
             (forall seq, WeakSubseq equiv l1 seq ->
              WeakSubseq _ (ans' l1 l2 IH) seq) ->
             WeakSubseq _ (b :: ans' l1 l2 IH) seq2
           with
           | cons_cons_weak_subseq _ _ _ bR _ _ IH => fun l2 IH1 a_equiv_b IH' =>
             cons_cons_weak_subseq _ _ _
             (equiv_to_eqtrue _ _ (transitivity (symmetry a_equiv_b) bR))
             _ _ (IH' _ IH)
           | keep_cons_weak_subseq _ w (a :: l1) seq2' IH =>
             fun l2 IH1 a_equiv_b IH' =>
             keep_cons_weak_subseq _ w (b :: ans' _ _ IH1) seq2'
             (inner _ _ _ IH _ _ a_equiv_b IH')
           end) a l1 seq2 ans'_sub2 l2 IH a_equiv_b IH'
       : WeakSubseq (fun a1 a2 => a1 ==b a2 = true) (b :: ans' l1 l2 IH) seq2
     end.

Definition usual_lcs_max ans'_
  (ans'_sub1 : WeakSubseq equiv ans'_ seq1)
  (ans'_sub2 : WeakSubseq equiv ans'_ seq2)
  : length ans'_ <= length usual_lcs
  := eq_rect _ (fun n => n <= length usual_lcs)
     (lcs_max _ _ _ _ (ans'sub1 _ _ _) (ans'sub2 _ _ _ _ ans'_sub2))
     _ (ans'_length_eq ans'_ seq1 ans'_sub1).

Definition inner_usual_lcs_UsualLongestCommonSubsequence
  : UsualLongestCommonSubsequence (A:=A) equiv seq1 seq2 usual_lcs
  := (usual_lcs_subseq1, usual_lcs_subseq2, usual_lcs_max).

End usual_lcs.
End inner_usual.

Definition usual_lcs_UsualLongestCommonSubsequence
  : forall (A : Type) {Asetoid : Setoid A} {Adec : EqDec Asetoid},
    forall (s t : list A),
    UsualLongestCommonSubsequence (A:=A) equiv s t (usual_lcs A s t)
  := inner_usual_lcs_UsualLongestCommonSubsequence.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable re_ : Universe -> Universe -> Prop.
Variable r_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable e_ : Universe -> Universe -> Prop.
Variable dom_ : Universe -> Prop.

Variable c_ : Universe.
Variable b_ : Universe.
Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ (dom_ b_ /\ (dom_ c_ /\ (re_ a_ b_ /\ re_ a_ c_)))).
Variable goal_ax_2 : (forall X : Universe, ((re_ b_ X /\ re_ c_ X) -> goal_)).
Variable ref_e_3 : (forall X : Universe, (dom_ X -> e_ X X)).
Variable sym_e_4 : (forall X Y : Universe, (e_ X Y -> e_ Y X)).
Variable congl_5 : (forall X Y Z : Universe, ((e_ X Y /\ re_ Y Z) -> re_ X Z)).
Variable e_in_re_6 : (forall X Y : Universe, (e_ X Y -> re_ X Y)).
Variable r_in_re_7 : (forall X Y : Universe, (r_ X Y -> re_ X Y)).
Variable e_or_r_8 : (forall X Y : Universe, (re_ X Y -> (e_ X Y \/ r_ X Y))).
Variable dp_r_9 : (forall X Y Z : Universe, ((r_ X Y /\ r_ X Z) -> (exists U : Universe, (dom_ U /\ (r_ Y U /\ r_ Z U))))).

Theorem goal_to_be_proved_10 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.