(** Grothendieck groups of exact categories  *)
Require Export UniMath.Tactics.EnsureStructuredProofs.

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Export UniMath.CategoryTheory.ExactCategories.ExactCategories.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.Free_Monoids_and_Groups.
Import AddNotation.
Local Open Scope addmonoid.

Section setquot.
  Lemma setquot_map_epi {X : Type} {R : eqrel X} {Y : hSet} {h h' : setquot R → Y} :
    h ∘ setquotpr R ~ h' ∘ setquotpr R -> h ~ h'.
  Proof.
    use (surjectionisepitosets _ _ _ (issurjsetquotpr R) (setproperty Y)).
  Defined.
  Lemma setquot_map_recovery {X : Type} (R : eqrel X) (Y : hSet) (h : setquot R → Y) :
    ∏ w, setquotuniv R Y (h ∘ setquotpr R)
                     (λ x x' (r : R x x'), maponpaths h (iscompsetquotpr R x x' r)) w =
         h w.
  Proof.
    exact (setquot_map_epi (λ x, idpath (h (setquotpr R x)))).
  Qed.
  Definition setquot_universal_property (X:Type) (R:eqrel X) (Y:hSet) :
    (setquot R -> Y) ≃ (∑ f : X -> Y, iscomprelfun R f).
  Proof.
    use weq_iso.
    - intros h. exists (h ∘ setquotpr R).
      intros x x' r. simpl. apply maponpaths. apply iscompsetquotpr. exact r.
    - intros f. exact (setquotuniv R Y (pr1 f) (pr2 f)).
    - intros h. apply funextsec. unfold pr1,pr2. intros w. apply setquot_map_recovery.
    - intros f. cbn beta. apply subtypePath.
      * intros f'. apply isapropiscomprelfun.
      * cbn. reflexivity.
  Defined.
  Goal ∏ (X:Type) (R:eqrel X) (Y:hSet) (h : setquot R -> Y),
    pr1 (setquot_universal_property X R Y h) = h ∘ setquotpr R.
  Proof.
    reflexivity.
  Defined.
  Goal ∏ (X:Type) (R:eqrel X) (Y:hSet) (q : ∑ f : X -> Y, iscomprelfun R f),
    invmap (setquot_universal_property X R Y) q = setquotuniv R Y (pr1 q) (pr2 q).
  Proof.
    reflexivity.
  Defined.
End setquot.

(* new stuff *)
Definition K_0_hrel (M:ExactCategory) : hrel (free_abgr (π₀ (ob M)))
  := λ g h, ∃ E : ShortExactSequence M,
      g = free_abgr_unit (component (Ob2 E)) ×
      h = free_abgr_unit (component (Ob1 E)) + free_abgr_unit (component (Ob3 E)).
Definition K_0_related {M:ExactCategory} (E : ShortExactSequence M)
  : K_0_hrel M (free_abgr_unit (component (Ob2 E)))
               (free_abgr_unit (component (Ob1 E)) + free_abgr_unit (component (Ob3 E)))
  := hinhpr ( E ,, idpath _ ,, idpath _).
Definition K_0 (M:ExactCategory) : abgr
  := presented_abgr (π₀ (ob M)) (K_0_hrel M).
Definition K_0_map {M N:ExactCategory} (F:ExactFunctor M N) : monoidfun (K_0 M) (K_0 N).
Proof.
  use (presented_abgrfun (π₀_map (functor_on_objects F))). intros g h.
  use hinhfun. intros [E [e e']]. exists (applyFunctorToShortExactSequence F E).
  now induction (!e), (!e').
Defined.
Definition K_0_class {M:ExactCategory} : ob M -> K_0 M
  := λ A, @presented_abgr_intro (π₀ M) _ (pi0pr _ A).
Lemma K_0_eqn {M:ExactCategory} (E : ShortExactSequence M) :
  K_0_class (Ob2 E) = K_0_class (Ob1 E) + K_0_class (Ob3 E).
Proof.
  apply iscompsetquotpr. apply generated_binopeqrel_intro. apply hinhpr.
  exists E. split; reflexivity.
Defined.
Lemma K_0_map_universal_property {M:ExactCategory} {G:abgr} :
  monoidfun (K_0 M) G
  ≃
  ∑ f : ob M -> G, ∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E).
Proof.
  apply (weqcomp (presented_abgr_universal_property (K_0_hrel M) G)).
  apply (weqtotal2 π₀_universal_property). intros h. apply weqiff.
  + split.
    * intros i E. exact (i _ _ (K_0_related E)).
    * intros k w w' r. apply (squash_to_prop r (setproperty _ _ _)).
      clear r; intros [E [e e']]. induction (!e), (!e'); clear e e'. exact (k E).
  + apply isapropiscomprelfun.
  + apply impred_isaprop; intros E. apply setproperty.
Defined.
Definition K_0_universal_map {M:ExactCategory} {G:abgr} (f : ob M -> G) :
  (∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E)) -> monoidfun (K_0 M) G.
Proof.
  intros c. exact (invmap K_0_map_universal_property (f,,c)).
Defined.
Goal ∏ (M:ExactCategory) (G:abgr) (f : ob M -> G)
      (add : ∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E)) (A:M),
  K_0_universal_map f add (K_0_class A) = f A.
Proof.
  reflexivity.
Qed.
Goal ∏ (M:ExactCategory) (G:abgr) (h : monoidfun (K_0 M) G),
  pr1 (K_0_map_universal_property h) = h ∘ K_0_class.
Proof.
  reflexivity.
Qed.
Goal ∏ (M:ExactCategory) (G:abgr)
     (f : ob M -> G) (add : ∏ E:ShortExactSequence M, f(Ob2 E) = f(Ob1 E) + f(Ob3 E)),
  invmap K_0_map_universal_property (f,,add) = K_0_universal_map f add.
Proof.
  intros.
  apply pathsinv0.              (* omit this and it is slow! *)
  reflexivity.
Qed.


(* coq-robot (c) 2017 AIST and INRIA. License: LGPL-2.1-or-later. *)
From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum rat.
From mathcomp Require Import closed_field polyrcf matrix mxalgebra mxpoly zmodp.
From mathcomp Require Import realalg complex fingroup perm.
From mathcomp.analysis Require Import boolp reals Rstruct classical_sets signed.
From mathcomp.analysis Require Import topology normedtype landau forms derive.
From mathcomp Require Import functions.
Require Import ssr_ext derive_matrix euclidean frame rot skew rigid.

(******************************************************************************)
(* This file is wip. It contains an on-going formalization of                 *)
(* [sciavicco] chap. 3.                                                       *)
(******************************************************************************)

(* contents:
  5. Module BoundVect.
     Module RFrame.
     relative frame
     (NB: to be moved to frame.v)
  6. Section kinematics
     velocity composition rule
  7. Section link_velocity.
  8. Lemma ang_vel_mx_Rz
     example: angular velocity of Rz as a spinor
  9. Section chain. (wip)
  10. Section geometric_jacobian_computation.
      geometric jacobian
  11. Section scara_geometric_jacobian.
      computation of SCARA's geometric jacobian
*)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Local Open Scope ring_scope.
Local Open Scope frame_scope.

Module BoundVect. (* i.e., point of application prescribed *)
Section bound_vector.
Variable T : ringType.
Record t (F : tframe T) := mk { endp : 'rV[T]_3 }.
Definition startp F (v : t F) : 'rV[T]_3 := \o{F}.
End bound_vector.
End BoundVect.
Notation bvec := BoundVect.t.
Coercion boundvectendp T (F : tframe T) (v : bvec F) := BoundVect.endp v.

Definition bvec0 T (F : tframe T) : bvec F := BoundVect.mk _ 0.

Reserved Notation "a \+b b" (at level 39).
Reserved Notation "a \-b b" (at level 39).

Section about_bound_vectors.

Variables (T : ringType) (F : tframe T).

Definition FramedVect_of_Bound (p : bvec F) : fvec F := `[ BoundVect.endp p $ F ].

Definition BoundVect_add (a b : bvec F) : bvec F :=
  BoundVect.mk F (BoundVect.endp a + BoundVect.endp b).

Definition BoundFramed_add (a : bvec F) (b : fvec F) : bvec F :=
  BoundVect.mk F (BoundVect.endp a + FramedVect.v b).

Local Notation "a \+b b" := (BoundFramed_add a b).

Lemma BoundFramed_addA (a : bvec F) (b c : fvec F) :
  a \+b b \+b c = a \+b (b \+f c).
Proof. by rewrite /BoundFramed_add /= addrA. Qed.

Definition BoundVect_sub (F : tframe T) (a b : bvec F) : fvec F :=
  `[ BoundVect.endp a - BoundVect.endp b $ F ].

Local Notation "a \-b b" := (BoundVect_sub a b).

Lemma bv_eq (a b : bvec F) : a = b :> 'rV[T]_3 -> a = b.
Proof. by move: a b => [a] [b] /= ->. Qed.

End about_bound_vectors.

Notation "a \+b b" := (BoundFramed_add a b).
Notation "a \-b b" := (BoundVect_sub a b).

Lemma derive1mx_BoundFramed_add (R : realFieldType) (F : tframe [ringType of R^o])
  (Q : R -> bvec F) (Z : R -> fvec F) t :
  derivable_mx (fun x => BoundVect.endp (Q x)) t 1 ->
  derivable_mx (fun x => FramedVect.v (Z x)) t 1 ->
  derive1mx (fun x => BoundVect.endp (Q x \+b Z x)) t =
  derive1mx (fun x => BoundVect.endp (Q x)) t +
    derive1mx (fun x => FramedVect.v (Z x)) t.
Proof.
move=> H H'.
rewrite (_ : (fun x : R => _) = (fun x : R => BoundVect.endp (Q x) +
  (FramedVect.v (Z x)))); last by rewrite funeqE.
rewrite derive1mxD.
- by [].
- exact: H.
- exact H'.
Qed.

Module RFrame.
Section rframe.
Variable T : ringType.
Record t (F0 : tframe T) := mk {
  o : bvec F0 ;
  i : fvec F0 ;
  j : fvec F0 ;
  k : fvec F0 ;
  F : tframe T ;
  _ : BoundVect.endp o = \o{F} ;
  _ : FramedVect.v i = F~i ;
  _ : FramedVect.v j = F~j ;
  _ : FramedVect.v k = F~k ;
}.
End rframe.
End RFrame.
Notation rframe := RFrame.t.
Coercion tframe_of_rframe R (F : tframe R) (F : rframe F) : tframe R := RFrame.F F.

Lemma RFrame_o T (F0 : tframe T) (F1 : rframe F0) :
  BoundVect.endp (RFrame.o F1) = \o{RFrame.F F1}.
Proof. by destruct F1. Qed.

(* lemmas about relative frames *)

Lemma BoundVect0_fixed (R : realFieldType) T (F : tframe T) (F1 : R -> rframe F) t :
  BoundVect.endp (bvec0 (F1 t)) = BoundVect.endp (bvec0 (F1 0)).
Proof. by []. Qed.

Section derivable_FromTo.

Lemma derivable_mx_FromTo' (R : realFieldType) (F : R -> tframe [ringType of R^o])
  (G' : forall t, rframe (F t)) (G : forall t, rframe (F t)) t :
  derivable_mx F t 1 -> derivable_mx G t 1 -> derivable_mx G' t 1 ->
  derivable_mx (fun x => (G x) _R^ (G' x)) t 1.
Proof.
move=> HF HG HG' a b.
rewrite (_ : (fun x => _) = (fun x => row a (G x) *d row b (G' x))); last first.
  by rewrite funeqE => t'; rewrite !mxE.
evar (f : 'I_3 -> R^o -> R^o).
rewrite (_ : (fun x => _) = \sum_i f i); last first.
  rewrite funeqE => t'; rewrite dotmulE fct_sumE; apply: eq_bigr => /= i _.
  rewrite !mxE /f; reflexivity.
rewrite {}/f.
apply: derivable_sum => i.
apply: derivableM; [exact: HG | exact: HG'].
Qed.

Lemma derivable_mx_FromTo (R : realFieldType) (F : R -> tframe [ringType of R^o])
  (G : forall t, rframe (F t)) t :
  derivable_mx F t 1 -> derivable_mx G t 1 ->
  derivable_mx (fun x => (G x) _R^ (F x)) t 1.
Proof.
move=> HF HG a b.
have @G' : forall t0, rframe (F t0).
  move=> t0.
  exact: (@RFrame.mk _ _ (@BoundVect.mk _ _ \o{F t0}) `[(F t0)~i $ F t0] `[(F t0)~j $ F t0] `[(F t0)~k $ F t0] (F t0)).
apply: (@derivable_mx_FromTo' R F G' G).
by [].
by [].
rewrite {}/G' /=.
exact: HF.
Qed.

Lemma derivable_mx_FromTo_fixed (R : realFieldType)
  (F : tframe [ringType of R^o]) (G : R -> rframe F) t :
  derivable_mx G t 1 -> derivable_mx (fun x => (G x) _R^ F) t 1.
Proof.
move=> H; apply derivable_mx_FromTo; [move=> a b; exact: ex_derive | exact H].
Qed.

Lemma derivable_mx_FromTo_tr (R : realFieldType)
  (F : tframe [ringType of R^o]) (G : R -> rframe F) t :
  derivable_mx (fun x => F _R^ (G x)) t 1 = derivable_mx (fun x => F _R^ (G x)) t 1.
Proof. by rewrite trmx_derivable. Qed.

End derivable_FromTo.

(* the coordinate transformation of a point P1 from frame F1 to frame F
  (eqn 2.33, 3.10) *)
Definition coortrans (R : realType) (F : tframe [ringType of R^o]) (F1 : rframe F)
    (P1 : bvec F1) : bvec F :=
  RFrame.o F1 \+b rmap F (FramedVect_of_Bound P1).

(* motion of P1 w.r.t. the fixed frame F (eqn B.2) *)
Definition motion (R : realType) (F : tframe [ringType of R^o]) (F1 : R -> rframe F)
  (P1 : forall t, bvec (F1 t)) t : bvec F := coortrans (P1 t).

(* [sciavicco] p.351-352  *)
Section kinematics.

Variables (R : realType) (F : tframe [ringType of R^o]). (* fixed frame *)
Variable F1 : R -> rframe F. (* time-varying frame (origin and basis in F) *)
Hypothesis derivable_F1 : forall t, derivable_mx F1 t 1.
Hypothesis derivable_F1o : forall t, derivable_mx (@TFrame.o [ringType of R^o] \o F1) t 1.

Variable P1 : forall t, bvec (F1 t). (* point with coordinates in F1 *)
(* NB: compared with [sciavicco] p.351, P1 not necessarily fixed in F1 *)
Hypothesis derivable_mxP1 : forall t, derivable_mx (fun x => BoundVect.endp (P1 x)) t 1.

Let P : R -> bvec F := motion P1.

Variable Q1 : forall t, bvec (F1 t).
Hypothesis Q1_fixed_in_F1 : forall t, BoundVect.endp (Q1 t) = BoundVect.endp (Q1 0).

Let Q : R -> bvec F := motion Q1.

(* eqn B.3 *)
Lemma eqnB3 t : P t = Q t \+b rmap F (P1 t \-b Q1 t).
Proof.
rewrite /P /Q /motion /coortrans BoundFramed_addA; congr (_ \+b _).
apply fv_eq => /=; rewrite -mulmxDl; congr (_ *m _).
by rewrite addrCA subrr addr0.
Qed.

Lemma derivable_mx_Q t : derivable_mx (fun x => BoundVect.endp (Q x)) t 1.
Proof.
rewrite /Q /=; apply derivable_mxD.
  move=> a b.
  move: (@derivable_F1o t a b).
  rewrite (_ : (fun x => \o{F1 x} a b) =
    (fun x => BoundVect.endp (RFrame.o (F1 x)) a b)) // funeqE => x.
  destruct (F1 x) => /=; by rewrite e.
apply derivable_mxM; last exact: derivable_mx_FromTo.
rewrite (_ : (fun x => _) = (fun _ => BoundVect.endp (Q1 0))); last first.
  rewrite funeqE => x; by rewrite Q1_fixed_in_F1.
move=> a b; exact: ex_derive.
Qed.

Let Rot := fun t => (F1 t) _R^ F.

(* generalization of B.4  *)
Lemma velocity_composition_rule (t : R) :
  derive1mx (fun x => BoundVect.endp (P x)) t =
  derive1mx (fun x => BoundVect.endp (Q x)) t +
  derive1mx P1 t *m Rot t (* rate of change of the coordinates P1 expressed in the frame F *) +
  ang_vel Rot t *v FramedVect.v (P t \-b Q t).
Proof.
rewrite {1}(_ : P = fun t => Q t \+b rmap F (P1 t \-b Q1 t)); last first.
  by rewrite funeqE => t'; rewrite eqnB3.
rewrite (derive1mx_BoundFramed_add (@derivable_mx_Q t)); last first.
  apply derivable_mxM; last exact: derivable_mx_FromTo.
  rewrite (_ : (fun x => _) = (fun x => FramedVect.v (FramedVect_of_Bound (P1 x)) -
    FramedVect.v (FramedVect_of_Bound (Q1 0)))); last first.
    rewrite funeqE => x; by rewrite /= Q1_fixed_in_F1.
  apply: derivable_mxB => /=.
  exact: derivable_mxP1.
  move=> a b; exact: ex_derive.
rewrite -addrA; congr (_ + _).
rewrite [in LHS]/rmap [in LHS]/= derive1mxM; last 2 first.
  rewrite {1}(_ : (fun x  => _) = (fun x  => BoundVect.endp (P1 x) -
    BoundVect.endp (Q1 0))); last first.
    by rewrite funeqE => ?; rewrite Q1_fixed_in_F1.
  apply: derivable_mxB.
    exact: derivable_mxP1.
    move=> a b; exact: ex_derive.
  exact: derivable_mx_FromTo.
rewrite derive1mxB; last 2 first.
  exact: derivable_mxP1.
  rewrite (_ : (fun x => _) = cst (BoundVect.endp (Q1 0))); last first.
    by rewrite funeqE => x; rewrite Q1_fixed_in_F1.
  exact: derivable_mx_cst.
congr (_*m _  + _).
  rewrite [in X in _ + X = _](_ : (fun x => _) = cst (BoundVect.endp (Q1 0))); last first.
    by rewrite funeqE => x; rewrite Q1_fixed_in_F1.
  by rewrite derive1mx_cst subr0.
rewrite -spinE unspinK; last first.
  rewrite ang_vel_mx_is_so; first by [].
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo.
rewrite /ang_vel_mx mulmxA; congr (_ *m _).
rewrite /P /Q /= opprD addrACA subrr add0r mulmxBl -!mulmxA.
by rewrite orthogonal_mul_tr ?FromTo_is_O // !mulmx1.
Qed.

Hypothesis P1_fixed_in_F1 : forall t, BoundVect.endp (P1 t) = BoundVect.endp (P1 0).

(* eqn B.4 *)
Lemma velocity_composition_rule_spec (t : R) :
  derive1mx (fun x => BoundVect.endp (P x)) t =
  derive1mx (fun x => BoundVect.endp (Q x)) t +
  ang_vel Rot t *v (FramedVect.v (P t \-b Q t)).
Proof.
rewrite velocity_composition_rule; congr (_ + _).
suff -> : derive1mx P1 t = 0 by rewrite mul0mx addr0.
apply/matrixP => a b; rewrite !mxE.
rewrite (_ : (fun x => _) = cst (P1 0 a b)); last first.
  rewrite funeqE => x /=; by rewrite /boundvectendp (P1_fixed_in_F1 x).
by rewrite derive1_cst.
Qed.

End kinematics.

(* [sciavicco] p.81-82 *)
Section derivative_of_a_rotation_matrix_contd.

Variables (R : realType) (F : tframe [ringType of R^o]).
Variable F1 : R -> rframe F.
Hypothesis derivable_F1 : forall t, derivable_mx F1 t 1.
Variable p1 : forall t, bvec (F1 t).
Hypothesis derivable_mx_p1 : forall t, derivable_mx (fun x => BoundVect.endp (p1 x)) t 1.
Hypothesis derivable_F1o : forall t, derivable_mx (@TFrame.o [ringType of R^o] \o F1) t 1.

Definition p0 := motion p1.

Lemma eqn312 t :
  derive1mx (fun x => BoundVect.endp (motion p1 x)) t =
  derive1mx (fun x => BoundVect.endp (motion (fun=> bvec0 (F1 x)) t)) t +
  derive1mx p1 t *m (F1 t) _R^ F +
  ang_vel (fun t => (F1 t) _R^ F) t *v (p1 t *m (F1 t) _R^ F).
Proof.
rewrite (@velocity_composition_rule _ F _ derivable_F1 derivable_F1o p1 derivable_mx_p1
  (fun t => bvec0 (F1 t)) (@BoundVect0_fixed _ _ _ F1)).
congr (_ + _ *v _).
by rewrite /= mul0mx addr0 addrAC subrr add0r.
Qed.

End derivative_of_a_rotation_matrix_contd.

Require Import screw.

(* [murray p.54] chapter 2, section 4.2*)
Section rigid_body_velocity.

Section spatial_velocity.

Variables (R : realType) (M : R -> 'M[R^o]_4).
Hypothesis derivableM : forall t, derivable_mx M t 1.
Hypothesis MSE : forall t, M t \in 'SE3[R].

Definition spatial_velocity t : 'M_4 := (M t)^-1 * derive1mx M t.

Definition spatial_lin_vel :=
  let r : R -> 'M[R^o]_3 := @rot_of_hom _ \o M in
  let p : R -> 'rV[R^o]_3:= @trans_of_hom _ \o M in
  fun t => - p t *m (r t)^T *m derive1mx r t + derive1mx p t.

Lemma spatial_velocityE t :
  let r : R -> 'M[R^o]_3 := @rot_of_hom _ \o M in
  spatial_velocity t = block_mx (ang_vel_mx r t) 0 (spatial_lin_vel t) 0.
Proof.
move=> r.
rewrite /spatial_velocity.
transitivity (inv_hom (M t) * derive1mx M t) => //.
  by rewrite inv_homE.
rewrite /inv_hom.
rewrite /hom.
rewrite derive1mx_SE //.
rewrite (_ : rot_of_hom (M t) = r t) // -/r.
rewrite -mulmxE.
rewrite (mulmx_block (r t)^T _ _ _ (derive1mx r t)).
rewrite !(mul0mx,add0r,mul1mx,mulmx0,trmx0,addr0,mulmx1).
by rewrite mulmxE -/(ang_vel_mx r t).
Qed.

Lemma spatial_velocity_in_se3 x : spatial_velocity x \in 'se3[[rcfType of R^o]].
Proof.
rewrite spatial_velocityE. set r := @rot_of_hom _.
rewrite qualifE block_mxKul block_mxKur block_mxKdr 2!eqxx 2!andbT.
rewrite ang_vel_mx_is_so // => t0.
by rewrite rotation_sub // rot_of_hom_is_SO.
exact: derivable_rot_of_hom.
Qed.

Lemma spatial_velocity_is_twist x :
  let r : R -> 'M[R^o]_3 := @rot_of_hom _ \o M in
  spatial_velocity x = wedge \T( spatial_lin_vel x , unspin (ang_vel_mx r x)).
Proof.
move=> r.
rewrite spatial_velocityE.
rewrite /wedge lin_tcoorE ang_tcoorE unspinK //.
rewrite ang_vel_mx_is_so // => t0.
by rewrite rotation_sub // rot_of_hom_is_SO.
exact: derivable_rot_of_hom.
Qed.

End spatial_velocity.

Section body_velocity.

Variables (R : realType) (M : R -> 'M[R^o]_4).
Hypothesis derivableM : forall t, derivable_mx M t 1.
Hypothesis MSE : forall t, M t \in 'SE3[R].

Definition body_velocity t : 'M_4 := derive1mx M t * (M t)^-1.

Definition body_lin_vel :=
  let r : R -> 'M[R^o]_3 := @rot_of_hom _ \o M in
  let p : R -> 'rV[R^o]_3:= @trans_of_hom _ \o M in
  fun t => derive1mx p t *m (r t)^T.

Lemma body_ang_vel_is_so t : body_ang_vel_mx (@rot_of_hom _ \o M) t \is 'so[R]_3.
Proof.
rewrite /body_ang_vel_mx.
have : forall t, (@rot_of_hom [rcfType of R^o] \o M) t \is 'O[[ringType of R]]_3.
  move=> t0; by rewrite rotation_sub // rot_of_hom_is_SO.
move/ang_vel_mx_is_so => /(_ (derivable_rot_of_hom derivableM))/(_ t).
rewrite /ang_vel_mx.
move/(conj_so (((rot_of_hom (T:=[rcfType of R^o]) \o M) t)^T)).
rewrite !mulmxA !trmxK orthogonal_mul_tr ?rotation_sub // ?rot_of_hom_is_SO //.
by rewrite mul1mx.
Qed.

Lemma body_velocityE t : let r : R -> 'M[R^o]_3 := @rot_of_hom _ \o M in
  body_velocity t = block_mx (body_ang_vel_mx r t) 0 (body_lin_vel t) 0.
Proof.
move=> r.
rewrite /body_velocity.
transitivity (derive1mx M t * inv_hom (M t)).
  by rewrite inv_homE.
rewrite /inv_hom.
rewrite /hom.
rewrite derive1mx_SE //.
rewrite (_ : rot_of_hom (M t) = r t) // -/r.
rewrite -mulmxE.
rewrite (mulmx_block (derive1mx r t) _ _ _ (r t)^T).
rewrite !(mul0mx,add0r,mul1mx,mulmx0,trmx0,addr0,mulmx1).
by rewrite -/(body_ang_vel_mx _) -/(body_lin_vel _).
Qed.

Lemma body_velocity_is_se x : body_velocity x \is 'se3[R].
Proof.
rewrite body_velocityE.
rewrite qualifE block_mxKul block_mxKur block_mxKdr 2!eqxx 2!andbT.
by rewrite body_ang_vel_is_so.
Qed.

End body_velocity.

Section spatial_body_adjoint.

Variables (R : realType) (M : R -> 'M[R^o]_4).
Hypothesis derivableM : forall t, derivable_mx M t 1.
Hypothesis MSE : forall t, M t \in 'SE3[R].

Lemma spatial_body_velocity x :
  vee (spatial_velocity M x) = vee (body_velocity M x) *m Adjoint (M x).
Proof.
rewrite -/(SE3_action _ _) action_Adjoint; last by [].
congr vee; rewrite /spatial_velocity -mulmxE -mulmxA; congr (_ * _).
rewrite veeK; last by rewrite body_velocity_is_se.
by rewrite /body_velocity -mulmxA mulVmx ?mulmx1 // SE3_in_unitmx.
Qed.

End spatial_body_adjoint.

End rigid_body_velocity.

(* [sciavicco] p.83 *)
Section link_velocity.

Variables (R : realType) (F : tframe [ringType of R^o]).
Variable F1 : R -> rframe F.
Variable F2 : R -> rframe F.
Let o1 t : bvec F := RFrame.o (F1 t).
Let o2 t : bvec F := RFrame.o (F2 t).

Let r12 : forall t : R, bvec (F1 t) := fun t =>
  BoundVect.mk (F1 t)
    (FramedVect.v (rmap (F1 t) `[ \o{F2 t} - \o{F1 t} $ F ])).

Hypothesis derivable_F1 : forall t, derivable_mx F1 t 1.
Hypothesis derivable_F1o : forall t, derivable_mx (@TFrame.o [ringType of R^o] \o F1) t 1.
Hypothesis derivable_r12 : forall t, derivable_mx (fun x => BoundVect.endp (r12 x)) t 1.
Hypothesis derivable_F2 : forall t, derivable_mx F2 t 1.

Lemma eqn310' t : o2 t = o1 t \+b rmap F (FramedVect_of_Bound (r12 t)).
Proof.
rewrite /o2 /o1 /= /r12 /= /rmap /= /BoundFramed_add /=; apply bv_eq => /=.
rewrite -mulmxA FromTo_comp FromToI mulmx1 /= addrCA RFrame_o /=.
by rewrite subrr addr0 -RFrame_o.
Qed.

Definition w1 := ang_vel (fun t => (F1 t) _R^ F).

Lemma eqn314_helper t : FramedVect.v (rmap F `[r12 t $ F1 t]) = \o{F2 t} - \o{F1 t}.
Proof. by rewrite /= -mulmxA FromTo_comp FromToI mulmx1. Qed.

(* lin. vel. of Link i as a function of
   the translational and rotational velocities of Link i-1 *)
Lemma eqn314 t : derive1mx o2 t = derive1mx o1 t +
  FramedVect.v (rmap F `[derive1mx r12 t $ F1 t])
    (* velocity of the origin of Frame i w.r.t. the origin of Frame i-1 *) +
  w1 t *v (\o{F2 t} - \o{F1 t}).
Proof.
rewrite -eqn314_helper.
move: (@eqn312 _ F _ derivable_F1 _ derivable_r12 derivable_F1o t).
have -> : derive1mx (fun x => BoundVect.endp (motion r12 x)) t = derive1mx o2 t.
  rewrite (_ : (fun x => BoundVect.endp (motion r12 x)) = o2) //.
  rewrite funeqE => t' /=; rewrite -mulmxA FromTo_comp FromToI mulmx1.
  rewrite addrCA RFrame_o subrr addr0.
  by rewrite /o2 -RFrame_o.
move=> ->.
rewrite -!{1}addrA /=; apply: f_equal2; last by [].
rewrite (_ : (fun x => BoundVect.endp (motion (fun _ : R => bvec0 (F1 x)) t)) = o1) //.
rewrite funeqE => t'.
by rewrite /motion /= mul0mx addr0.
Qed.

Definition w2 : R -> 'rV_3 := ang_vel (fun t => (F2 t) _R^ F).
Definition w12 : R -> 'rV_3 := ang_vel (fun t => (F2 t) _R^ (F1 t)).

(* ang. vel. of Link i as a function of the ang. vel. of Link i-1 and of Link i w.r.t. Link i-1 *)
Lemma eqn316 t : w2 t = w1 t + w12 t *m ((F1 t) _R^ F).
Proof.
have : (fun t => (F2 t) _R^ F) = (fun t => ((F2 t) _R^ (F1 t)) *m ((F1 t) _R^ F)).
  by rewrite funeqE => ?; rewrite FromTo_comp.
move/(congr1 (fun x => derive1mx x)).
rewrite funeqE.
move/(_ t).
rewrite derive1mxM; last 2 first.
  move=> t'; exact: derivable_mx_FromTo'.
  move=> t'; exact: derivable_mx_FromTo.
rewrite derive1mx_ang_vel; last 2 first.
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo.
rewrite derive1mx_ang_vel; last 2 first.
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo'.
rewrite derive1mx_ang_vel; last 2 first.
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo.
rewrite ang_vel_mxE; last 2 first.
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo.
rewrite ang_vel_mxE; last 2 first.
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo'.
rewrite ang_vel_mxE; last 2 first.
  move=> t'; by rewrite FromTo_is_O.
  move=> t'; exact: derivable_mx_FromTo.
rewrite mulmxE -[in X in _ = X + _](mulr1 ((F2 t) _R^ (F1 t))).
rewrite -(@orthogonal_tr_mul _ _ (F _R^ (F1 t))) ?FromTo_is_O //.
rewrite -{2}(trmx_FromTo (F1 t) F).
rewrite -!mulrA.
rewrite (mulrA _ _ ((F1 t) _R^ F)).
rewrite (@spin_similarity _ ((F1 t) _R^ F)) ?FromTo_is_SO //.
rewrite mulrA -mulmxE.
rewrite trmx_FromTo.
rewrite FromTo_comp.
rewrite mulmxA.
rewrite FromTo_comp.
rewrite -mulmxDr.
rewrite -spinD.
rewrite -/w2 -/w1 -/w12.
rewrite mulmxE.
move/mulrI.
rewrite FromTo_unit => /(_ isT)/eqP.
rewrite spin_inj => /eqP.
by rewrite addrC.
Qed.

End link_velocity.

From mathcomp Require Import trigo.

Lemma derive1_cos (R : realType) (t : R) : derive1 (cos : _ -> R^o) t = - sin t.
Proof.
rewrite derive1E.
have u := is_derive_cos t.
by have := @derive_val _ _ _ _ _ _ _ u.
Qed.

Lemma derive1_sin (R : realType) (t : R) : derive1 (sin : _ -> R^o) t = cos t.
Proof.
rewrite derive1E.
have u := is_derive_sin t.
by have := @derive_val _ _ _ _ _ _ _ u.
Qed.

Lemma derivable_sin (R : realType) (t : R) : derivable (sin : R^o -> R^o) t 1.
Proof. exact: ex_derive. Qed.

Lemma derivable_cos (R : realType) (t : R) : derivable (cos : R^o -> R^o) t 1.
Proof. exact: ex_derive. Qed.

Lemma derivable_cos_comp  (R : realType) (t : R) (a : R^o -> R^o) :
  derivable a t 1 -> derivable (cos \o a : _ -> R^o) t 1.
Proof. by move=> /derivableP Hs; exact: ex_derive. Qed.

Lemma derivable_sin_comp (R : realType) (t : R) (a : R^o -> R^o) :
  derivable a t 1 -> derivable ((sin : _ -> R^o) \o a) t 1.
Proof. by move=> /derivableP Hs; exact: ex_derive. Qed.

Lemma derive1_cos_comp (R : realType) t (a : R^o -> R^o) : derivable a t 1 ->
  derive1 (cos \o a : _ -> R^o) t = - (derive1 a t) * sin (a t).
Proof.
move=> H; rewrite (derive1_comp H); last exact: derivable_cos.
by rewrite derive1_cos mulrC mulNr mulrN.
Qed.

Lemma derive1mx_RzE (R : realType) (a : R^o -> R^o) t : derivable a t 1 ->
  derive1mx (fun x => Rz (a x) : 'M[R^o]__) t =
  derive1 a t *: col_mx3 (row3 (- sin (a t)) (cos (a t)) 0)
                         (row3 (- cos (a t)) (- sin (a t)) 0)
                         0.
Proof.
move=> Ha.
apply/matrix3P/and9P; split; rewrite !mxE /=.
- rewrite (_ : (fun _ => _) = cos \o a); last by rewrite funeqE => x; rewrite !mxE.
  rewrite (derive1_comp Ha); last exact/derivable_cos.
  by rewrite derive1_cos mulrC.
- rewrite (_ : (fun _ => _) = sin \o a); last by rewrite funeqE => x; rewrite !mxE.
  rewrite (derive1_comp Ha); last exact/derivable_sin.
  by rewrite derive1_sin mulrC.
- rewrite (_ : (fun _ => _) = \0); last by rewrite funeqE => x; rewrite !mxE.
  by rewrite derive1_cst mulr0.
- rewrite (_ : (fun _ => _) = - sin \o a); last by rewrite funeqE => x; rewrite !mxE.
  rewrite (_ : - _ \o _ = - (sin \o a)) // derive1E deriveN; last first.
    apply/derivable1_diffP/differentiable_comp.
    exact/derivable1_diffP.
    exact/derivable1_diffP/derivable_sin.
  rewrite -derive1E (derive1_comp Ha); last exact/derivable_sin.
  by rewrite derive1_sin mulrN mulrC.
- rewrite (_ : (fun _ => _) = cos \o a); last by rewrite funeqE => x; rewrite !mxE.
  rewrite (derive1_comp Ha); last exact/derivable_cos.
  by rewrite derive1_cos mulrN mulNr mulrC.
- rewrite (_ : (fun _ => _) = \0); last by rewrite funeqE => x; rewrite !mxE.
  by rewrite derive1_cst mulr0.
- rewrite (_ : (fun _ => _) = \0); last by rewrite funeqE => x; rewrite !mxE.
  by rewrite derive1_cst mulr0.
- rewrite (_ : (fun _ => _) = \0); last by rewrite funeqE => x; rewrite !mxE.
  by rewrite derive1_cst mulr0.
- rewrite (_ : (fun _ => _) = cst 1); last by rewrite funeqE => x; rewrite !mxE.
  by rewrite derive1_cst mulr0.
Qed.

(* example 3.1 [sciavicco]*)
(* rotational motion of one degree of freedom manipulator *)
Lemma ang_vel_mx_Rz (R : realType) (a : R^o -> R^o) t : derivable a t 1 ->
  ang_vel_mx (@Rz _ \o a) t = \S(row3 0 0 (derive1 a t)).
Proof.
move=> Ha.
rewrite /ang_vel_mx trmx_Rz (derive1mx_RzE Ha) /Rz.
rewrite -!scalerAr -col_mx3_mul.
rewrite mulmx_row3_col3 scale0r addr0.
rewrite mulmx_row3_col3 scale0r addr0.
rewrite e2row mulmx_row3_col3 !(scale0r,scaler0,addr0).
rewrite !row3Z !(cosN,sinN,opprK,mulr0,mulrN,mulNr).
rewrite !row3D mulrC addrC subrr addr0.
rewrite -!expr2 cos2Dsin2 -opprD addrC cos2Dsin2.
by apply/matrix3P; rewrite !spinij !mxE /= !(eqxx,oppr0,mulr0,mulrN1,mulr1).
Qed.

(* see also the end of dh.v *)
Section chain.

Inductive joint (R : rcfType) :=
  Revolute of (R^o -> (*angle*) R) | Prismatic of (R^o -> R).

Definition joint_variable (R : realType) (j : joint [rcfType of R]) : R^o -> R :=
  fun t => match j with Revolute a => a t | Prismatic a => a t end.

Record chain (R : rcfType) n (* number of joints *) := mkChain {
  joint_of_chain : 'I_n -> joint R ;
  frame_of_chain : 'I_n.+1 -> (R^o -> tframe R) }.

End chain.

Section geometric_jacobian_computation.

Variables (n : nat) (R : realType) (c : chain [rcfType of R^o] n).

Definition prev_frame (i : 'I_n) : 'I_n.+1 := widen_ord (leqnSn n) i.
Definition next_frame (i : 'I_n) : 'I_n.+1 := fintype.lift ord0 i.
Lemma next_frameE i : next_frame i = i.+1 :> nat. Proof. by []. Qed.
Definition last_frame : 'I_n.+1 := ord_max.

Section geo_jac_row.
Variable i : 'I_n.
Let j : joint [rcfType of R^o] := joint_of_chain c i.
Let q : R^o -> R^o := joint_variable j.
Let Fim1 := frame_of_chain c (prev_frame i).
(*Let Fi := frame_of_chain c (next_frame i).*)
Let Fmax := frame_of_chain c last_frame.
(* contribution to the angular velocity *)
Definition geo_jac_ang t : 'rV_3 := if j is Revolute _ then (Fim1 t)~k else 0.
(* contribution to the linear velocity *)
Definition geo_jac_lin t : 'rV_3 :=
  if j is Revolute _ then (Fim1 t)~k *v (\o{Fmax t} - \o{Fim1 t}) else (Fim1 t)~k.
End geo_jac_row.

Definition geo_jac t : 'M_(n, 6) :=
  row_mx (\matrix_(i < n) geo_jac_lin i t) (\matrix_(i < n) geo_jac_ang i t).

End geometric_jacobian_computation.

Require Import scara.

Section scara_geometric_jacobian.
Variable R : realType.

Variable theta1 : R -> R.
Variable a1 : R.
Variable theta2 : R -> R.
Variable a2 : R.
Variable d3 : R -> R.
Variable theta4 : R -> R.
Variable d4 : R.
(* direct kinematics equation written in function of the joint variables,
   from scara.v  *)
Let rot t := scara_rot (theta1 t) (theta2 t) (theta4 t).
Let trans t := scara_trans (theta1 t) a1 (theta2 t) a2 (d3 t) d4.
Definition scara_end_effector t : 'M[R]_4 := hom (rot t) (trans t).

Let scara_lin_vel : R -> 'rV[R]_3 :=
  derive1mx (@trans_of_hom [ringType of R^o] \o scara_end_effector).
Let scara_ang_vel : R -> 'rV[R]_3 :=
  ang_vel (@rot_of_hom [ringType of R^o] \o scara_end_effector).

Definition scara_joints : 'I_4 -> joint R :=
  [eta (fun=> Prismatic 0) with
  0 |-> Revolute theta1,
  1 |-> Revolute theta2,
  2%:R |-> Prismatic d3,
  3%:R |-> Revolute theta4].

Definition scara_joint_variables t : 'rV[R^o]_4 :=
  \row_i (joint_variable (scara_joints i) t).

Let scara_joint_velocities : R -> 'rV[R^o]_4 := derive1mx scara_joint_variables.

(* specification of scara frames *)
Variables scara_frames : 'I_5 -> R -> tframe R.
Let Fim1 (i : 'I_4) := scara_frames (prev_frame i).
Let Fi (i : 'I_4) := scara_frames (next_frame i).
Let Fmax := scara_frames ord_max.
Hypothesis Hzvec : forall t i, (Fim1 i t)~k = 'e_2%:R.
Hypothesis o0E : forall t, \o{Fim1 0 t} = 0.
Hypothesis o1E : forall t, \o{Fim1 1 t} =
  a1 * cos (theta1 t) *: 'e_0 + a1 * sin (theta1 t) *: 'e_1.
Hypothesis o2E : forall t, \o{Fim1 2%:R t} = \o{Fim1 1 t} +
  (a2 * cos (theta1 t + theta2 t)) *: 'e_0 +
  (a2 * sin (theta1 t + theta2 t)) *: 'e_1.
Hypothesis o3E : forall t, \o{Fim1 3%:R t} = \o{Fim1 2%:R t} + (d3 t) *: 'e_2.
Hypothesis o4E : forall t, \o{Fmax t} = \o{Fim1 3%:R t} + d4 *: 'e_2.

Lemma scale_realType (K : realType) (k1 : K) (k2 : K^o) : k1 *: k2 = k1 * k2.
Proof. by []. Qed.

Import rv3LieAlgebra.Exports.

Lemma scara_geometric_jacobian t :
  derivable (theta1 : R^o -> R^o) t 1 ->
  derivable (theta2 : R^o -> R^o) t 1 ->
  derivable (d3 : R^o -> R^o) t 1 ->
  derivable (theta4 : R^o -> R^o) t 1 ->
  scara_joint_velocities t *m geo_jac (mkChain scara_joints scara_frames) t =
  row_mx (scara_lin_vel t) (scara_ang_vel t).
Proof.
move=> H1 H2 H3 H4.
rewrite /geo_jac; set a := (X in _ *m @row_mx _ _ 3 3 X _).
rewrite (mul_mx_row _ a) {}/a; congr (@row_mx _ _ 3 3 _ _).
- rewrite /scara_lin_vel (_ : @trans_of_hom [rcfType of R] \o _ = trans); last first.
    rewrite funeqE => x /=; exact: trans_of_hom_hom.
  rewrite /trans /scara_trans derive1mxE [RHS]row3_proj /= ![in RHS]mxE [in RHS]/=.
  transitivity (
      derive1 (theta1 : R^o -> R^o) t *: (Fim1 0 t)~k *v (\o{Fmax t} - \o{Fim1 0 t}) +
      derive1 (theta2 : R^o -> R^o) t *: (Fim1 1 t)~k *v (\o{Fmax t} - \o{Fim1 1 t}) +
      derive1 (d3 : R^o -> R^o) t *: (Fim1 2 t)~k +
      derive1 (theta4 : R^o -> R^o) t *: (Fim1 3%:R t)~k *v (\o{Fmax t} - \o{Fim1 3%:R t})).
    rewrite /scara_joint_velocities /scara_joint_variables derive1mxE /geo_jac_lin /=.
    apply/rowP => i; rewrite 3![in RHS]mxE [in LHS]mxE sum4E;
          (repeat apply: f_equal2).
    - by rewrite 2!mxE /= linearZl_LR [in RHS]mxE.
    - by rewrite 2!mxE /= linearZl_LR [in RHS]mxE.
    - by rewrite 2!mxE [in RHS]mxE.
    - by rewrite 2!mxE /= linearZl_LR [in RHS]mxE.
  rewrite o0E subr0.
  rewrite {1}o4E.
  rewrite linearDr /=.
  rewrite (linearZr_LR _ _ _ 'e_2)
   /= {2}Hzvec (linearZl_LR _ _ _ 'e_2) /= liexx 2!{1}scaler0 addr0.
  rewrite (_ : \o{Fmax t} - \o{Fim1 1 t} =
    (a2 * cos (theta1 t + theta2 t) *: 'e_0 +
    (a1 * sin (theta1 t) + a2 * sin (theta1 t + theta2 t) - a1 * sin (theta1 t)) *: 'e_1 +
    (d3 t + d4) *: 'e_2)); last first.
    rewrite (addrC (a1 * sin _)) addrK.
    rewrite o4E o3E o2E o1E.
    set a := _ *: 'e_0 + _ *: 'e_1.
    rewrite -3!addrA addrC 3!addrA subrK.
    rewrite addrC -[in RHS]addrA; congr (_ + _).
    by rewrite -addrA -scalerDl.
  rewrite linearDr /=.
  rewrite (linearZr_LR _ _ _ 'e_2) /= (linearZl_LR (crossmul_bilinear _) 'e_2)
          {2}(Hzvec t 1) /= liexx 2!{1}scaler0 addr0.
  rewrite (addrC (a1 * sin _)) addrK.
  rewrite (_ : \o{Fmax t} - \o{Fim1 3%:R t} = d4 *: 'e_2%:R); last first.
    by rewrite o4E -addrA addrC subrK.
  rewrite (linearZr_LR _ _ _ 'e_2) /= (linearZl_LR (crossmul_bilinear _) 'e_2)
          {1}(Hzvec t 3%:R) /= liexx 2!scaler0 addr0.
  rewrite o3E.
  rewrite linearDr /= (linearZr_LR _ _ _ 'e_2) (linearZl_LR _ 'e_2)
          {2}(Hzvec t 0) /= liexx 2!scaler0 addr0.
  rewrite {1}o2E {1}o1E.
  rewrite (_ : (fun _ => _) =
                (a2 \*: (cos \o (theta2 + theta1) : R^o -> R^o)) +
                (a1 *: (cos \o theta1 : R^o -> R^o))) //.
  rewrite (_ : (fun _ => _) = (a2 \*: (sin \o (theta2 + theta1) : _ -> R^o)) +
                              (a1 *: (sin \o theta1 : _ -> R^o))) //.
  rewrite row3e2; congr (_ + _ *: _); last first.
  - by rewrite Hzvec.
  - rewrite [in RHS]derive1E [in RHS]deriveD; last 2 first.
      exact: ex_derive.
      exact: H3.
    by rewrite deriveE // diff_cst add0r derive1E.
  - rewrite !linearDr /= !(linearZr_LR (crossmul_bilinear _))
            !(linearZl_LR (crossmul_bilinear _)) /= !Hzvec veckj vecki
            !{1}scalerN.
    rewrite -!addrA addrCA addrC -!addrA (addrCA (- _)) !addrA.
    rewrite -2!addrA [in RHS]addrC; congr (_ + _).
    - rewrite !scalerA -2!scalerDl row3e1; congr (_ *: _).
      rewrite [in RHS]derive1E deriveD; last 2 first.
        apply/derivableZ/derivable_sin_comp/derivableD; [exact H2 | exact H1].
        exact/derivableZ/derivable_sin_comp.
      rewrite deriveZ /=; last first.
        apply/derivable_sin_comp/derivableD; [exact H2 | exact H1].
      rewrite deriveZ /=; last exact/derivable_sin_comp.
      rewrite -[in RHS]derive1E [in RHS]derive1_comp; last 2 first.
      - by apply: derivableD; [exact: H2 | exact: H1].
      - by apply: derivable_sin.
      rewrite derive1_sin.
      rewrite -derive1E [in RHS]derive1_comp; last 2 first.
      - exact: H1.
      - exact: derivable_sin.
      rewrite derive1_sin -addrA addrC; congr (_ + _); last first.
        by rewrite -mulrA.
      rewrite -mulrDr [in RHS]derive1E deriveD; last 2 first.
        exact: H2.
        exact: H1.
      rewrite -mulrA scale_realType; apply: f_equal2; first by [].
      rewrite addrC; apply: f_equal2; first by [].
      by rewrite addrC !derive1E.
    - rewrite !{1}scalerA !addrA -3!{1}scaleNr -2!scalerDl row3e0.
      congr (_ *: _).
      rewrite [in RHS]derive1E deriveD; last 2 first.
        by apply/derivableZ/derivable_cos_comp/derivableD; [exact H2 | exact H1].
        by apply/derivableZ/derivable_cos_comp; exact H1.
      rewrite deriveZ /=; last first.
        by apply/derivable_cos_comp/derivableD.
      rewrite deriveZ /=; last exact/derivable_cos_comp.
      rewrite -derive1E [in RHS]derive1_comp; last 2 first.
      - by apply: derivableD; [exact: H2 | exact: H1].
      - exact: derivable_cos.
      rewrite derive1_cos mulNr scalerN.
      rewrite -derive1E [in RHS]derive1_comp; last 2 first.
      - exact: H1.
      - exact: derivable_cos.
      rewrite derive1_cos mulNr scalerN; congr (_ - _); last first.
        by rewrite -mulrA.
      rewrite -opprD; congr (- _).
      rewrite [in RHS]derive1E deriveD; last 2 first.
        exact: H2.
        exact: H1.
      rewrite -mulrDr -!derive1E.
      rewrite addrC (addrC (_^`() _)).
      by rewrite !scalerAl.
- rewrite /scara_ang_vel (_ : @rot_of_hom [ringType of R^o] \o _ = rot); last first.
    rewrite funeqE => x /=; exact: rot_of_hom_hom.
  rewrite /rot /ang_vel /scara_rot.
  rewrite (_ : (fun _ => _) = (@Rz _ \o (theta1 + theta2 + theta4))); last first.
    by rewrite funeqE.
  rewrite ang_vel_mx_Rz; last first.
    apply derivableD; [apply/derivableD|by []].
    exact: H1.
    exact: H2.
  rewrite [RHS]spinK.
  transitivity (derive1 (theta1 : R^o -> R^o) t *: (Fim1 0 t)~k +
                derive1 (theta2 : R^o -> R^o) t *: (Fim1 1 t)~k +
                derive1 (theta4 : R^o -> R^o) t *: (Fim1 3%:R t)~k).
    rewrite /scara_joint_velocities /scara_joint_variables derive1mxE /geo_jac_ang /=.
    apply/rowP => i; rewrite !mxE sum4E !mxE {1}mulr0 addr0.
    by rewrite -!/(Fim1 _) [Fim1 0 _]lock [Fim1 1 _]lock [Fim1 3%:R _]lock /= -!lock.
  rewrite !Hzvec -2!scalerDl e2row row3Z mulr0 mulr1.
  rewrite [in RHS]derive1E deriveD; [|apply/derivableD|by []]; last 2 first.
    exact: H1.
    exact: H2.
  rewrite deriveD; [| exact: H1| exact H2].
  by rewrite 3!derive1E.
Qed.

End scara_geometric_jacobian.

Section analytical_jacobian.

Variable n' : nat.
Let n := n'.+1.
Variable (R : realType) (p : 'rV[R^o]_n -> 'rV[R^o]_3).
Let Jp := jacobian p.
Variable (phi : 'rV[R^o]_n -> 'rV[R^o]_3).
Let Jphi := jacobian phi.

Lemma dp (q : R^o -> 'rV[R^o]_n) t :
  derive1mx (p \o q) t = derive1mx q t *m Jp (q t). (* 3.56 *)
Proof.
rewrite /Jp /jacobian mul_rV_lin1.
rewrite /derive1mx.
Abort.

End analytical_jacobian.

(*Section tangent_vectors.

Variable R : realType.
Let vector := 'rV[R]_3.
Let point := 'rV[R]_3.
Implicit Types p : point.

(* tangent vector *)
Record tvec p := TVec {tvec_field :> vector}.
Definition vtvec p (v : tvec p) := let: TVec v := v in v.

Local Notation "p .-vec" := (tvec p) (at level 5).
Local Notation "u :@ p" := (TVec p u) (at level 11).

Definition addt (p : point) (u : p.-vec) (v : vector) : p.-vec :=
  TVec p (tvec_field u + v).

Local Notation "p +@ u" := (addt p u) (at level 41).

End tangent_vectors.

Coercion vtvec_field_coercion := vtvec.

Notation "p .-vec" := (tvec p) (at level 5).
Notation "u :@ p" := (TVec p u) (at level 11).
Notation "p +@ u" := (addt p u) (at level 41).*)


Import Require Min.

Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.

Open Scope pred.

Program Definition getsn (n:nat) (stk stk':stack) (Q:pred world) : pred world :=
  fun pr => let (p,r) := pr in
    level p >= n -> exists n', n' < n /\
      exists p', exists r', stepN n' p p' r stk r' stk' /\
        Q (p',r').
Next Obligation.
  hnf. simpl; intros.
  destruct a. destruct a'.
  intro.
  cut (S (level p0) = level p).
  intro. rewrite <- H2 in H0 .
  spec H0. omega.
  destruct H0 as [n' [? ?]].
  exists n'. split; auto.
admit.
admit.
Qed.

Program Definition haltsn (n : nat) (stk : stack) : pred world :=
  fun pr => let (p,r) := pr in
    (level p >= n -> eventually_halts_n n p r stk).
Next Obligation.
  unfold hereditary; intros.
  destruct a as [p r'].
  destruct a' as [p' r''].
  intros.
  unfold prog in *.
  spec H0.
  apply age_level in H; simpl in H; omega.
  hnf in H.
  simpl in H.
  unfold prog_lookup, prog in *.
  remember (age1 p).
  icase o.
  rewrite K.knot_age1 in Heqo.
  remember (K.unsquash p).
  destruct p0.
  icase n0.
  inv H.
  inv Heqo.
  destruct H0 as [px [rx [? ?]]].
  repeat rewrite K.knot_level in *.
  rewrite <- Heqp0 in H.
  rewrite K.unsquash_squash in H1.
  remember (K.unsquash px).
  destruct p0.
  simpl in *.
  destruct n1.
  omegac.
  exists (K.squash (n1, f0)).
  exists rx.
  split.
  repeat rewrite K.knot_level in *.
  repeat rewrite K.unsquash_squash.
  trivial.
  generalize (stepstar_approxprog 1 _ _ (K.squash (n0,f)) (K.squash (n1, f0)) _ _ stk _ _ H0); intro.
  spec H2.
  exists (K.squash (n0,f)). split; try reflexivity.
  hnf. rewrite K.knot_age1.
  rewrite <- Heqp0. trivial.
  spec H2.
  exists (K.squash (n1,f0)). split; try reflexivity.
  hnf. rewrite K.knot_age1.
  rewrite <- Heqp1. trivial.
  spec H2. apply stack_approx_rel_refl.
  destruct H2 as [s2' [? ?]].
  inversion H3. subst s2'.
  trivial.
Qed.

Definition guardsn (n : nat) (P : pred world) (stk : stack) : pred world :=
  P --> haltsn n stk.

Definition termMeas :=
  { R : store -> nat -> Prop |
    forall x y y', R x y -> R x y' -> y = y' }.

Program Definition code (l : label) (c : instruction) : pred prog :=
  fun p =>
    exists i, prog_lookup p l = Some i /\ instr_approx_rel (level p) c i.
Next Obligation.
  unfold hereditary; intros.
  hnf in H.
  unfold prog_lookup, prog in *.
  destruct H0 as [i [? ?]].
  exists (fmap_instr (K.approx (level a')) c).
  split.
  2: red; symmetry; apply collapse_instr_approx_same.
  rewrite K.knot_age1 in H.
  remember (K.unsquash a).
  destruct p.
  icase n.
  inv H.
  rewrite K.knot_level in *.
  rewrite <- Heqp in H1.
  rewrite K.unsquash_squash.
  simpl in *.
  unfold KnotInput.fmap.
  erewrite fmap_eqn.
  2: apply H0.
  red in H1.
  replace n with (min n (S n)) by (apply min_l; auto with arith).
  do 2 rewrite <- collapse_instr_approx.
  rewrite H1.
  trivial.
Qed.

Program Definition evalTM (t : termMeas) (n : nat) : pred world :=
  fun w => let (_, r) := w in
    proj1_sig t r n.
Next Obligation.
  unfold hereditary; intros.
  destruct a. destruct a'.
  hnf in H. simpl in H. unfold prog in *.
  icase (age1 p).
  inv H. trivial.
Qed.

Program Definition embedWP (P : pred world) : pred prog :=
  fun p => forall r, P (p,r).
Next Obligation.
  unfold hereditary; intros.
  rewrite <- (nec_useless P) in H0.
  apply (H0 r (a',r)).
  simpl. rewrite worldNec_unfold. intuition.
Qed.

(* Definition of the hoare relation and rules *)

Definition hoare' (n':nat) (G:pred prog) (R P:pred world) (c:instruction) (Q:pred world) :=
  forall p n k stk,
    G p ->
    (forall r', guardsn n R stk       (p,r')) ->
    (forall r', guardsn n Q (k::stk)  (p,r')) ->
    (forall r,  guardsn (n'+n) P ((c ;; k)::stk) (p,r)).

Definition hoare (G:pred prog) (R P:pred world) (c:instruction) (Q:pred world) :=
  forall p k stk,
    G p -> forall r p', necR p p' -> P (p',r) -> exists n,
      getsn n ((c;;k)::stk) (k::stk) Q (p',r)  \/
      getsn n ((c;;k)::stk) stk R (p',r).

Lemma hoare_seq2 : forall G R P Q S i1 i2,
  hoare G R P i1 Q ->
  hoare G R Q i2 S ->
  hoare G R P (i1 ;; i2) S.
Proof.
  repeat intro.
  spec H p (i2;;k) stk H1.
  spec H r p' H2 H3.
  destruct H as [n1 [?|?]].
  hnf in H.
  destruct (le_lt_dec n1 (level p')).
  spec H. omega.
  destruct H as [n' [? ?]].
  destruct H4 as [p'' [r'' [? ?]]].
  spec H0 p k stk H1.
  spec H0 r'' p''.
  spec H0. admit.
  spec H0; auto.
  destruct H0 as [n2 [?|?]].
  exists (n1+n2). left.
  hnf; intros.
  hnf in H0. spec H0.
admit.
  destruct H0 as [n'' [??]].
  destruct H7 as [p''' [r''' [? ?]]].
  exists (n'+n''). split. omega.
  do 2 econstructor; split. 2: eauto.
admit.
  exists (n1+n2). right.
admit.
  clear H.
  exists n1. left. intro. exfalso; omega.
  exists (n1+1). right.
  repeat intro.
  hnf in  H. spec H. omega.
  destruct H as [n' [? ?]].
  exists (n'+1). split. omega.
admit.
Qed.

(*
Definition funptr' (l:label) (A:Type) (t:termMeas) (P Q: A -> pred world) : pred prog :=
  EX c : instruction, code l c &&
    ALL stk : stack, ALL n : nat, ALL x : A,
      |> ((embedWP (guardsn n (Q x) stk)) -->
           (ALL n' : nat, embedWP (evalTM t n'   -->
                                    guardsn (n+n') (P x) ((c;;instr_assert FF)::stk) ))).
*)

Definition funptr' (l:label) (A:Type) (t:termMeas) (P Q: A -> pred world) : pred prog :=
  EX c : instruction, code l c &&
  ALL stk : stack,  ALL x : A,
      embedWP (P x --> EX n:nat, evalTM t n &&
                 |>getsn n ((c;;instr_assert FF)::stk) stk (Q x)).

Definition funptr l A P Q : pred prog :=
  EX t:termMeas,
      funptr' l A t P Q &&
      ALL x:A, (embedWP (P x --> EX n:nat, evalTM t n)).

(*
Lemma hoare_call : forall G R v Q l A lP lQ a,
  let wp :=
      store_op (fun r => r#v = Some (value_label l)) &&
      prog_op (funptr l A lP lQ) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare G R wp (instr_call v) Q.
Proof.
  repeat intro.
  subst wp.
  destruct H1 as [[[??]?]?].
  hnf in H2. destruct H2 as [? _].
  destruct H2 as [t [? ?]].
  hnf in H2.
  hnf in H2.
  destruct H2 as [i [? ?]].
  spec H6 (k :: stk) a r.
  spec H6 (p',r). spec H6; auto.
  spec H6; auto.
  destruct H6 as [n1 [? ?]].
  exists (1+n1). left.
  intro.
  case_eq (age1 p'); intros.
  spec H7 (p0,r). spec H7.
admit.
  hnf in H7. spec H7.
admit.
  destruct H7 as [n' [? ?]]. exists (1+n'). split. omega.
  destruct H10 as [p'' [r'' [? ?]]].
(*
  case_eq (age1 p''). intros p''' ?.
  exists p'''; exists r''; split.*)
  exists p''. exists r''. split; auto.
  destruct H2 as [i' [? ?]].
  econstructor.
  econstructor; eauto.
  hnf in H1. destruct H1.
  apply H13.
admit.
  spec H4 (p',r''). spec H4; simpl; auto.
  hnf. simpl; auto.
  eapply H4; eauto.
admit.
admit.
Qed.
*)

Definition verify_prog (psi:program assert) (G:pred prog) :=
  forall n, agedfrom (K.squash (n,psi)) && |>G |-- G.

(*
Lemma verify_func_simple : forall psi l (G:pred prog) (A:Type) (P Q:A -> pred world) i
  (REL:A -> A -> Prop),
  well_founded REL ->
  psi#l = Some i ->
  (forall a,
    let Pr' a' := P a' && !!(REL a' a) in
      exists t:termMeas,
        hoare (funptr' l A t Pr' Q && G) (Q a) (P a) i FF) ->

  verify_prog psi G ->
  verify_prog psi (funptr l A P Q  && G).
Proof.
  do 13 intro.
  intros w Hw.
  destruct Hw as [Hw1 Hw2].
  split.
  2: eapply H2; eauto.
  2: split; eauto.
  2: repeat rewrite later_and in Hw2.
  2: destruct Hw2; auto.
  hnf. intro x.
  induction x using (well_founded_induction H).
  destruct (H1 x) as [t' ?].
  hnf in H4.

  hnf; exists i. split.
admit.
  intros stk x r w' ? ?.
  spec H0 x r. simpl in H0. hnf in H0.
  case_eq (age1 w'); intros.
  spec H0 (fst w0).
  generalize (H0 (instr_assert FF)). clear H0; intro.
  spec H0 stk. spec H0.
  clear H0.
  split.
  spec H2 (level w0). spec H2.
admit.
  spec H2 (fst w0). spec H2.
  split; auto.
admit.
admit.
  destruct H2.
  destruct H0 as [? ?].
  destruct H0 as [i' [? ?]].
  exists i'. split; auto.
  intros stk' x' r' w'' ? ?.
  destruct H9. destruct w''; destruct H10. clear H10.
  rewrite later_and in Hw2.
  destruct Hw2.
  rewrite later_and in H10.
  destruct H10.
  spec H13 (fst w0).
  spec H13.
admit.
  spec H13 x r (fst w0, r). spec H13; auto.
  spec H13.
admit.
  destruct H13 as [n1 ?].
  simpl in H13.
  spec H11 n1 H13.
  destruct H11 as [n2 [? ?]].
  spec H7 stk' x' s (p,s).
  spec H7.
admit.
  spec H7; auto.
admit.

  spec H0 r (fst w0). spec H0; auto.
  spec H0. split.
admit.
  repeat rewrite later_and in Hw2.
  destruct Hw2. destruct H6.
  spec H8 (fst w0).
  spec H8.
admit.
  spec H8 x r. spec H8 (fst w0, r). spec H8; auto.
  spec H8.
admit.
  destruct H8 as [n' ?]. simpl in H8.
  exists n'; split; auto. hnf; auto.
  destruct H0 as [n' [?|?]].
admit.

  exists n'. split; auto.

*)

Lemma verify_func_simple : forall psi l (G:pred prog) (A:Type) (P Q:A -> pred world) i (t:termMeas),
  psi#l = Some i ->

  (forall a r,
    let Pr  := P a && EX n:nat, store_op (fun r' => proj1_sig t r' n /\ (r' = r)) in
    let Pr' a' := P a' && store_op (fun r' => forall n, proj1_sig t r n -> exists n', proj1_sig t r' n' /\ n' < n) in
    hoare (funptr' l A t Pr' Q && G) (Q a) Pr i FF) ->

  verify_prog psi G ->
  verify_prog psi (funptr' l A t P Q  &&
                   (ALL a:A, embedWP (P a --> EX x:nat, evalTM t x))
                   && G).
Proof.
  do 12 intro. induction n using (well_founded_induction lt_wf).
  intros w Hw.
  destruct Hw as [Hw1 Hw2].
  split.
  2: eapply H1; eauto.
  2: split; eauto.
  2: repeat rewrite later_and in Hw2.
  2: destruct Hw2; auto.
  split; intros.
  hnf; exists i. split.
admit.
  intros stk x r w' ? ?.
  spec H0 x r. simpl in H0. hnf in H0.
  case_eq (age1 w'); intros.
  spec H0 (fst w0).
  generalize (H0 (instr_assert FF)). clear H0; intro.
  spec H0 stk. spec H0.
  clear H0.
  split.
  spec H2 (level w0). spec H2.
admit.
  spec H2 (fst w0). spec H2.
  split; auto.
admit.
admit.
  destruct H2.
  destruct H0 as [? ?].
  destruct H0 as [i' [? ?]].
  exists i'. split; auto.
  intros stk' x' r' w'' ? ?.
  destruct H9. destruct w''; destruct H10. clear H10.
  rewrite later_and in Hw2.
  destruct Hw2.
  rewrite later_and in H10.
  destruct H10.
  spec H13 (fst w0).
  spec H13.
admit.
  spec H13 x' r (fst w0, r). spec H13; auto.
  spec H13.
admit.
  destruct H13 as [n1 ?].
  simpl in H13.
  spec H11 n1 H13.
  destruct H11 as [n2 [? ?]].
  spec H7 stk' x' s (p,s).
  spec H7.
admit.
  spec H7; auto.
admit.

  spec H0 r (fst w0). spec H0; auto.
  spec H0. split.
admit.
  repeat rewrite later_and in Hw2.
  destruct Hw2. destruct H6.
  spec H8 (fst w0).
  spec H8.
admit.
  spec H8 x r. spec H8 (fst w0, r). spec H8; auto.
  spec H8.
admit.
  destruct H8 as [n' ?]. simpl in H8.
  exists n'; split; auto. hnf; auto.
  destruct H0 as [n' [?|?]].
admit.
  repeat rewrite later_and in Hw2.
  destruct Hw2. destruct H6.
  spec H8 (fst w0).
  spec H8.
admit.
  spec H8 x r. spec H8 (fst w0, r). spec H8; auto.
  spec H8.
admit.
  destruct H8 as [n'' ?].
  exists n''. split; auto.
admit.

Lemma hoare_weaken : forall x x' G G' (R R' P P' Q Q':pred world) i,
  x <= x' ->
  G' |-- G  ->
  prog_op G' && R  |-- R' ->
  prog_op G' && P' |-- P  ->
  prog_op G' && Q  |-- Q' ->
  hoare' x  G  R  P  i Q ->
  hoare' x' G' R' P' i Q'.
Proof.
  intros until i; repeat intro.
  destruct a'.
  spec H4 p n k stk.
  spec H4; auto.
  rewrite worldNec_unfold in H8.
  destruct H8.
  subst s.
  spec H4. repeat intro. eapply H6; eauto.
  apply H1. split; auto. destruct a'. rewrite worldNec_unfold in H10. split; trivial.
  apply pred_nec_hereditary with p; intuition.
  spec H4. repeat intro. eapply H7; eauto.
  apply H3. split; auto. destruct a'. rewrite worldNec_unfold in H10. split; auto.
  apply pred_nec_hereditary with p; intuition.
  spec H4 r (p0, r).
  spec H4. rewrite worldNec_unfold. intuition.
  spec H4; auto.
  apply H2. split; auto. split; auto.
  apply pred_nec_hereditary with p; auto.
  simpl in *.
  intro.
  spec H4. omega.
  destruct H4 as [px [rx [? ?]]].
  exists px. exists rx. split; trivial.
  omega.
Qed.

Lemma hoare_weaken_time : forall x x' G R P i Q,
  x <= x' ->
  hoare' x G R P i Q ->
  hoare' x' G R P i Q.
Proof.
  intros until Q. intro. apply hoare_weaken; hnf; simpl; intuition.
Qed.

Lemma hoare_weaken_pre : forall x G R P P' i Q,
  prog_op G && P' |-- P ->
  hoare' x G R P i Q ->
  hoare' x G R P' i Q .
Proof.
  intros until Q. intro.
  apply hoare_weaken; hnf; simpl; intuition.
Qed.

Lemma hoare_weaken_post : forall x G R P i Q Q',
  prog_op G && Q |-- Q' ->
  hoare' x G R P i Q ->
  hoare' x G R P i Q'.
Proof.
  intros until Q'. intro.
  apply hoare_weaken; hnf; simpl; intuition.
Qed.

Lemma hoare_ex_pre : forall x G R T P i Q,
  (forall z:T, hoare' x G R (P z) i Q) ->
  hoare' x G R (exp P) i Q.
Proof.
  repeat intro.
  destruct H4.
  spec H x0.
  eapply H; eauto.
Qed.

Lemma hoare_ex_pre' : forall x G R T P i Q,
  hoare' x G R (exp P) i Q ->
  (forall z:T, hoare' x G R (P z) i Q).
Proof.
  repeat intro.
  eapply H; eauto.
  exists z. auto.
Qed.

Lemma hoare_fact_pre : forall x G R (X:Prop) P i Q,
  (X -> hoare' x G R P i Q) ->
  hoare' x G R (!!X && P) i Q.
Proof.
  repeat intro.
  destruct H4. hnf in H4.
  spec H H4. eapply H; eauto.
Qed.

Lemma hoare_return : forall G R,
  hoare' 0 G R R instr_return FF.
Proof.
  repeat intro.
  spec H0 r a' H2 H3.
  destruct a'.
  intro.
  destruct H0 as [pz [rz [? ?]]]. omega.
  exists pz. exists rz.
  split. omega.
  econstructor. eapply step_return.
  auto.
Qed.

Lemma hoare_seq : forall x y G R P Q S i1 i2,
  hoare' x G R P i1 Q ->
  hoare' y G R Q i2 S ->
  hoare' (x+y) G R P (i1 ;; i2) S.
Proof.
  intros. hnf; intros.
  assert (guardsn (x+(y+n)) P ((i1;;i2;;k)::stk) (p,r)).
    apply H; auto.
    repeat intro. destruct a'. repeat intro.
    rewrite worldNec_unfold in H4. destruct H4. subst s.
    spec H2 r' (p0, r'). spec H2. rewrite worldNec_unfold. intuition.
    spec H2 H5.
    unfold haltsn in H2. simpl in H2. spec H2. omega.
    destruct H2 as [pz [rz [? ?]]].
    exists pz; exists rz.
    split. omega.
    trivial.
  do 3 intro.
  spec H4 a' H5 H6.
  destruct a'. intro. unfold haltsn in H4. simpl in H4. spec H4. omega.
  destruct H4 as [px [rx [? ?]]].
  exists px. exists rx.
  split. omega.
  econstructor. econstructor.
  auto.
Qed.

Lemma hoare_getlabel : forall l v G R P,
  hoare' 0 G R
    (box (setM v (value_label l)) P)
    (instr_getlabel l v)
    P.
Proof.
  repeat intro.
  spec H1 (r#v <- (value_label l)).
  destruct a'.
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (p0, r#v <- (value_label l)).
  spec H1. rewrite worldNec_unfold. intuition.
  spec H1. apply H3. constructor; auto.
  intro.
  destruct H1 as [pz [rz [? ?]]]. omega.
  exists pz; exists rz.
  split. omega.
  econstructor. econstructor.
  auto.
Qed.

Lemma hoare_call : forall x G R v Q l A t lP lQ a,
  let wp :=
      store_op (fun r => r#v = Some (value_label l)) &&
      evalTM t x &&
      (prog_op (funptr' l A t lP lQ)) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare' (S x) G R wp (instr_call v) Q.
Proof.
  do 23 intro.
  unfold wp in H3.
  destruct H3 as [[[[? ?] ?] ?] ?].
  destruct a'.
  destruct H5 as [[i [? ?]] _].
  intro.
  case_eq (age1 p0); intros.
  2: rewrite (af_level1 age_facts) in H10; omegac.
  spec H8 (k::stk) n a p1.
  spec H8. simpl. apply t_step. trivial.
  spec H8 p1. spec H8. apply rt_refl.
  spec H8.
    intros r'. spec H1 r'.
    repeat intro.
    spec H1 a'.
    spec H1.
    destruct a'.
    rewrite worldNec_unfold in H11. destruct H11. subst s0.
    rewrite worldNec_unfold in H2. destruct H2. subst s.
    rewrite worldNec_unfold. split; trivial.
    apply rt_trans with p0. trivial.
    apply rt_trans with p1. apply rt_step. trivial. trivial.
    spec H1; auto.
    destruct a'.
    spec H7 (p0,s0).
    spec H7. simpl; hnf; auto.
    apply H7; auto.
    repeat rewrite worldNec_unfold in *; intuition.
    apply rt_trans with p1; auto.
    apply rt_step; auto.
  spec H8 x s (p1,s).
  spec H8. simpl; hnf; auto.
  spec H8. apply H4.
  spec H8 (p1,s).
  spec H8. apply rt_refl.
  spec H8. apply pred_nec_hereditary with (p0,s); auto.
  rewrite worldNec_unfold; intuition.

  copy H10.
  apply (af_level2 age_facts) in H10.
  destruct H8 as [pz [rz [? ?]]]. omega.
  exists pz; exists rz.
  split. omega.
  destruct H5 as [ix [? ?]].
  econstructor.
  eapply step_call.
  apply H3.
  apply H5.
  apply H11.
  generalize (stepstar_approxprog 0 p1 pz p1 pz s
      ((i;; instr_assert FF) :: k :: stk) ((ix;; instr_assert FF) :: k :: stk)
      rz nil); intro.
  spec H14 H12.
  spec H14. red. trivial.
  spec H14. red. trivial.
  spec H14.
  constructor.
  rewrite <- H10.
  red. simpl. red in H13. congruence.
  apply stack_approx_rel_refl.
  destruct H14 as [sx [? ?]].
  inversion H15.
  subst sx.
  trivial.
Qed.

Lemma hoare_call2 : forall G R v Q l A t lP lQ a,
  let wp :=
      store_op (fun r => r#v = Some (value_label l)) &&
      (prog_op (funptr' l A t lP lQ)) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare G R wp (instr_call v) Q.
Proof.
  intros.
  hnf. subst wp.

Lemma hoare_call' : forall x G R v Q,
  let wp :=
    EX l:label, EX A:Type, EX t:termMeas,
    EX lP:(A->pred world), EX lQ:(A -> pred world), EX a:A,
      store_op (fun r => r#v = Some (value_label l)) &&
      (evalTM t x) &&
      (prog_op (funptr l A t lP lQ)) &&
      lP a && (closed (lQ a --> Q))
 in
  hoare (S x) G R wp (instr_call v) Q.
Proof.
  intros. subst wp.
  repeat (apply hoare_ex_pre; intro).
  apply hoare_call.
Qed.

Lemma hoare_step_fetch0 : forall v1 v2 x1 x2 G R P,
  hoare 0 G R
    (store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x1) P)
    (instr_fetch_field v1 0 v2)
    P.
Proof.
  repeat intro.
  destruct a'.
  destruct H3.
  destruct H3 as [_ ?].
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (r#v2 <- x1).
  spec H1 (p0,r#v2 <- x1).
  spec H1. repeat rewrite worldNec_unfold; intuition.
  spec H1. apply H4. constructor. auto.
  intro.
  spec H1 H5.
  destruct H1 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. econstructor. eauto.
  auto.
Qed.

Lemma hoare_step_fetch1 : forall v1 v2 x1 x2 G R P,
  hoare 0 G R
    (store_op (fun r => r#v1 = Some (value_cons x1 x2)) && box (setM v2 x2) P)
    (instr_fetch_field v1 1 v2)
    P.
Proof.
  repeat intro.
  destruct a'.
  destruct H3.
  destruct H3 as [_ ?].
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (r#v2 <- x2).
  spec H1 (p0,r#v2 <- x2).
  spec H1. repeat rewrite worldNec_unfold; intuition.
  spec H1. apply H4. constructor. auto.
  intro.
  spec H1 H5.
  destruct H1 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. econstructor. eauto.
  auto.
Qed.

Lemma hoare_cons : forall v1 v2 v3 x1 x2 G R P,
  hoare 0 G R
     (store_op (fun r => r#v1 = Some x1 /\ r#v2 = Some x2) &&
        box (setM v3 (value_cons x1 x2)) P)
     (instr_cons v1 v2 v3)
     P.
Proof.
  repeat intro.
  destruct a'.
  destruct H3.
  destruct H3 as [_ ?].
  rewrite worldNec_unfold in H2. destruct H2. subst s.
  spec H1 (r#v3 <- (value_cons x1 x2)).
  spec H1 (p0, r#v3 <- (value_cons x1 x2)).
  spec H1. repeat rewrite worldNec_unfold; intuition.
  spec H1. apply H4. constructor. auto.
  intro.
  spec H1 H5.
  destruct H1 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  destruct H3.
  econstructor. econstructor; eauto.
  auto.
Qed.

Lemma hoare_if : forall x v s1 s2 P1 P2 G R Q,
  let wp :=
    EX val:value,
      store_op (fun r => r#v = Some val) &&
    (

      ((!!(val = value_label (L 0)) && P1))
      ||
      ((EX x1:value, (EX x2:value,
        !!(val = (value_cons x1 x2)))) && P2)
    )
   in
  hoare x G R P1 s1 Q ->
  hoare x G R P2 s2 Q ->
  hoare x G R wp (instr_if_nil v s1 s2) Q.
Proof.
  do 23 intro.
  hnf in H5.
  destruct a'.
  destruct H5 as [v' [[_ ?] ?]].
  destruct H6 as [[? ?]|[? ?]].

  (* nil case *)
  simpl in H6.
  spec H p n k stk.
  do 3 (spec H; auto).
  rewrite worldNec_unfold in H4. destruct H4. subst s.
  spec H r (p0,r).
  spec H. rewrite worldNec_unfold. intuition.
  spec H H7.
  intro.
  spec H H8.
  destruct H as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. eapply step_if_nil1; eauto.
  subst v'; auto.
  auto.

  (* cons case *)
  destruct H6 as [v1 [v2 ?]]. simpl in H6. subst v'.
  spec H0 p n k stk.
  do 3 (spec H0; auto).
  rewrite worldNec_unfold in H4. destruct H4. subst s.
  spec H0 r (p0,r).
  spec H0. rewrite worldNec_unfold. intuition.
  spec H0 H7.
  intro. spec H0 H6.
  destruct H0 as [pz [rz [? ?]]].
  exists pz; exists rz.
  split; trivial.
  econstructor. eapply step_if_nil2; eauto.
  auto.
Qed.

Lemma hoare_assert : forall G R P (Q:assert),
  prog_op G && P |-- Q ->
  hoare 0 G R P (instr_assert Q) P.
Proof.
  repeat intro.
  spec H2 r a' H3 H4.
  destruct a'.
  intro.
  spec H2 H5.
  destruct H2 as [px [rx [? ?]]].
  exists px. exists rx.
  split. trivial.
  econstructor 2.
  econstructor.
  apply H.
  split; auto.
  rewrite <- (nec_useless G) in H0.
  simpl; split; auto.
  apply H0.
  rewrite worldNec_unfold in H3. intuition.
  auto.
Qed.

(* Verifying function bodies and entire programs *)

Definition verify_prog (psi:program assert) (G:pred prog) :=
  forall n, agedfrom (K.squash (n,psi)) && |>G |-- G.

Lemma verify_complete : forall G psi,
  verify_prog psi G ->
  forall n, G (K.squash (n,psi)).
Proof.
  intros.
  spec H n.
  cut (agedfrom (K.squash (n,psi)) |-- G).
  intros.
  eapply H0.
  hnf; apply rt_refl.
  apply goedel_loeb.
  apply derives_trans with
    (agedfrom (K.squash (n,psi)) && |>G); auto.
  intros a Ha; destruct Ha; split; auto.
Qed.

Record funspec (B:Type) :=
  { fs_A  : B -> Type
  ; fs_t  : B -> termMeas
  ; fs_P  : forall b, fs_A b -> pred world
  ; fs_Q  : forall b, fs_A b -> pred world
  }.

Definition funspec_assumptions B b n (fss:list (label*funspec B) ) : pred prog :=
  ALL l:_, ALL fs:_, !!(In (l,fs) fss) -->
    let P' a := fs_P B fs b a &&
      store_op (fun r => exists n', proj1_sig (fs_t B fs b) r n' /\ n' < n)
    in funptr l (fs_A B fs b) (fs_t B fs b) P' (fs_Q B fs b).

Lemma verify_true :
  forall psi,
    verify_prog psi TT.
Proof.
  repeat intro; hnf; auto.
Qed.

Lemma verify_clique : forall psi G B (fss:list (label * funspec B)),

  (forall l fs,
    In (l,fs) fss ->
    exists i, psi#l = Some i /\
    forall b a n,
    let Pr := fs_P B fs b a && store_op (fun r' => proj1_sig (fs_t B fs b) r' n) in
      hoare n (funspec_assumptions B b n fss && G) (fs_Q B fs b a) Pr i FF) ->

  verify_prog psi G ->

  verify_prog
      psi
      ((ALL b:B, ALL l:_, ALL fs:_,
        !!(In (l,fs) fss) -->
        funptr l (fs_A B fs b) (fs_t B fs b)
        (fs_P B fs b) (fs_Q B fs b)) && G).
Proof.
  repeat intro.
  destruct H1.
  rewrite box_and in H2; destruct H2.
  split. 2: eapply H0; eauto; split; eauto.
  apply verify_complete with _ _ n in H0.
  clear H3.
  simpl in H1.
  clear H2.
  intros b l fs p' ? ?. simpl in H3.
  unfold funptr.
  destruct (H l fs H3) as [i [? ?]].
  exists (fmap_instr (K.approx (level p')) i).
  split.
  exists
    (fmap_instr (K.approx (level p')) (fmap_instr (K.approx n) i)). split.
  apply nec_prog_lookup with (K.squash (n,psi)).
  eapply rt_trans; eauto.
  unfold prog_lookup. rewrite K.unsquash_squash. simpl. unfold KnotInput.fmap.
  erewrite fmap_eqn.
  auto.
  auto.
  hnf.
  f_equal.
  rewrite collapse_instr_approx.
  rewrite min_l; auto.
  replace n with (level (K.squash (n,psi))).
  apply nec_level. apply rt_trans with a; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; auto.

  clear H5.
  intros stk n0 x ? ? ? ? ? n'.
  revert stk n0 x a' a'0 H5 H6 H7.
  revert l fs i H3 H4.
  induction n' using (well_founded_induction lt_wf).

  repeat intro.
  destruct a'1. rewrite worldNec_unfold in H9. destruct H9; subst.
  destruct a'2. rewrite worldNec_unfold in H11. destruct H11; subst.
  simpl in H10.
  destruct (H l fs H4) as [i' [? ?]].
  rewrite H5 in H13; inv H13.
  rename i' into i.
  spec H14 b x n'.
  hnf in H14.
  spec H14 p n0.
  generalize (H14 (instr_assert FF)). clear H14; intro H14.
  spec H14 stk.
  spec H14.
    split.
    hnf; simpl; intros.
    destruct (H b0 b1 H15) as [i' [? ?]].
    exists (fmap_instr (K.approx (level a'1) )i'). split.
    exists (fmap_instr (K.approx (level a'1)) i'). split.
    replace (fmap_instr (K.approx (level a'1)) i')
      with  (fmap_instr (K.approx (level a'1)) (fmap_instr (K.approx n) i')).
    apply nec_prog_lookup with (K.squash (n,psi)).
    apply rt_trans with p; auto.
    apply rt_trans with a'0; auto.
    apply rt_trans with a'; auto.
    apply rt_trans with p'; auto.
    apply rt_trans with a; auto.
    apply Rt_Rft; auto.
    unfold prog_lookup.
    rewrite K.unsquash_squash; simpl.
    unfold KnotInput.fmap.
    eapply fmap_eqn; auto.
    rewrite collapse_instr_approx.
    rewrite min_l; auto.
    replace n with (level (K.squash (n,psi))).
    apply nec_level.
    apply rt_trans with a; auto.
    apply rt_trans with p'; auto.
    apply rt_trans with a'; auto.
    apply Rt_Rft; auto.
    apply rt_trans with a'0; auto.
    apply rt_trans with p; auto.
    rewrite K.knot_level. rewrite K.unsquash_squash.
    simpl; auto.
    hnf. auto.

    intros.
    destruct H24.
    destruct a'5.
    destruct H25.
    destruct H26 as [n'' [? ?]].
    destruct a'4.
    rewrite worldNec_unfold in H21.
    destruct H21.
    subst s1.
    intros.
    rewrite worldNec_unfold in H23.
    destruct H23; subst.
    assert (n'' = b5).
    destruct (fs_t B b1 b); eauto.
    subst b5.
    spec H3 n''.
    spec H3; auto.
    spec H3 b0 b1 i'.
    spec H3; auto.
    spec H3; auto.
    spec H3 b2 b3 b4.
    spec H3 a'1 a'3.
    spec H3.
      simpl.
      apply Rt_Rft_trans with a'; auto.
      apply rt_trans with p; auto.
      apply rt_trans with a'0; auto.
    spec H3.
      apply rt_trans with a'2; auto.
      apply Rt_Rft; auto.
    spec H3; auto.
    simpl in H3.
    spec H3 s (p2,s).
    spec H3.
    rewrite worldNec_unfold; simpl; auto.
    spec H3; auto.
    spec H3 (p1,s).
    spec H3.
    rewrite worldNec_unfold; simpl; auto.
    spec H3; auto.
    spec H3; auto.
    destruct H3 as [? [? [? ?]]].
    destruct (stepstar_approxprog 0 p1 x0 p1 x0 _ _ (((fmap_instr (K.approx (level a'1)) i');;instr_assert FF) :: b2) _ _ H29).
    simpl; auto.
    simpl; auto.
    constructor.
    hnf. simpl. f_equal.
    rewrite collapse_instr_approx.
    rewrite min_l.
    rewrite collapse_instr_approx.
    rewrite min_l.
    auto.
    apply later_level.
    apply Rt_Rft_trans with a'2; auto.
    apply rt_trans with a'3; auto.
    apply rt_trans with p2; auto.

    apply later_level.
    apply Rt_Rft_trans with a'; auto.
    apply rt_trans with a'0; auto.
    apply rt_trans with p; auto.
    apply rt_trans with a'1; auto.
    apply rt_trans with a'2; auto.
    apply Rt_Rft; auto.
    apply rt_trans with a'3; auto.
    apply rt_trans with p2; auto.

    apply stack_approx_rel_refl.
    destruct H30.
    inv H31. hnf; eauto.
    apply pred_nec_hereditary with (K.squash (n,psi)); auto.
    apply rt_trans with a; auto.
    apply rt_trans with p'; auto.
    apply rt_trans with a'; auto.
    apply Rt_Rft; auto.
    apply rt_trans with a'0; auto.

  spec H14.
  intro r'.
  spec H8 r'.
  apply pred_nec_hereditary with (a'0,r'); auto.
  rewrite worldNec_unfold; auto.
  spec H14; repeat intro. inv H15.
  spec H14 s0.
  simpl in H14.
  spec H14 (p0,s0).
  spec H14.
  rewrite worldNec_unfold; auto.
  spec H14; intuition.
  spec H14. omega.
  rewrite plus_comm.
  destruct H14 as [? [? [? ?]]].
  destruct (stepstar_approxprog 0 p0 x0 p0 x0 _ _ (((fmap_instr (K.approx (level p')) i);;instr_assert FF) :: stk) _ _ H15).
  simpl; auto.
  simpl; auto.
  constructor.
  hnf; simpl. f_equal.
  rewrite collapse_instr_approx.
  rewrite min_l.
  auto.
  apply later_level.
  apply Rt_Rft_trans with a'; auto.
  apply rt_trans with a'0; auto.
  apply rt_trans with p; auto.
  apply stack_approx_rel_refl.
  destruct H16.
  inv H17.
  hnf; eauto.
Qed.

Lemma verify_func : forall psi l (G:pred prog) (B:Type) (A:B->Type) (P Q:forall b, A b -> pred world) i (t:B -> termMeas),
  psi#l = Some i ->

  (forall b a n,
    let Pr  := P b a && store_op (fun r' => proj1_sig (t b) r' n) in
    let Pr' a' := P b a' && store_op (fun r' => exists n', proj1_sig (t b) r' n' /\ n' < n) in
    hoare n (funptr l (A b) (t b) Pr' (Q b) && G) (Q b a) Pr i FF) ->

  verify_prog psi G ->
  verify_prog psi
              ((ALL b:_, funptr l (A b) (t b) (P b) (Q b)) && G).
Proof.
  intros.
  generalize (verify_clique psi G B
    ((l,Build_funspec B A t P Q)::nil)); intros.
  spec H2.
    clear H2.
    intros.
    simpl in H2. intuition. inv H3.
    exists i; split; auto.
    simpl. intros.
    spec H0 b a n.
    revert H0.
    Opaque funptr.
    apply hoare_weaken; auto;
      hnf; simpl; intuition.
    spec H2 l0 (Build_funspec B A t P Q) a0.
    spec H2; auto.
  spec H2; auto.
  repeat intro.
  spec H2 n a.
  destruct H3.
  spec H2; split; auto.
    repeat intro.
    spec H4 a' H5.
    destruct H4; split; auto.
    repeat intro.
    simpl in H4.
    spec H4 b.
    simpl in H8. intuition.
    inv H9.
    simpl.
    eapply pred_nec_hereditary; eauto.
    destruct H2.
    intro b.
    spec H2 b.
    spec H2 l (Build_funspec B A t P Q).
    spec H2 a. spec H2; auto.
    simpl in H2. spec H2; auto.
    destruct H2; auto.
Qed.

Lemma verify_func_simple : forall psi l (G:pred prog) (A:Type) (P Q:A -> pred world) i (t:termMeas),
  psi#l = Some i ->

  (forall a n,
    let Pr  := P a && store_op (fun r' => proj1_sig t r' n) in
    let Pr' a' := P a' && store_op (fun r' => exists n', proj1_sig t r' n' /\ n' < n) in
    hoare n (funptr l A t Pr' Q && G) (Q a) Pr i FF) ->

  verify_prog psi G ->
  verify_prog psi (funptr l A t P Q && G).
Proof.
  intros.
  generalize (verify_func psi l G unit (fun _ => A) (fun _ => P) (fun _ => Q) i (fun _ => t) H); intros.
  spec H2. intros. eapply H0; eauto.
  spec H2. intros. eapply H1; eauto.
  repeat intro.
  spec H2 n a.
  rewrite box_and in H3.
  destruct H3.
  destruct H4.
  spec H2. split; auto.
  rewrite box_and. split; auto.
  rewrite box_all. intro. auto.
  destruct H2; split; auto.
  apply H2. exact tt.
Qed.

Lemma end_assert_lemma : forall Q n p p' r r' stk,
    stepN n p p' r (stk++(instr_assert Q ;; instr_return ;; instr_assert FF) :: nil) r' nil ->
    stepstar p p' r stk r' nil /\ proj1_sig Q (p',r').
Proof.
  induction n; simpl; intros; inv H.
  destruct stk; discriminate.
  destruct stk. simpl in H1.
  inv H1.
  inv H2.
  inv H.
  inv H0.
  split; auto.
  constructor.
  inv H.

  simpl in H1.
  inv H1.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; auto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; auto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i1;;i2;;i3)::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i1;;i0)::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:= (i2;;i0)::stk) in H2.
  intuition. econstructor. eapply step_if_nil2; eauto. auto.
  apply IHn with (stk:= (i'0;;instr_assert FF)::i0::stk) in H2.
  intuition. econstructor. econstructor; eauto. auto.
  apply IHn with (stk:=stk) in H2.
  intuition. econstructor. econstructor. auto.
Qed.

(* Fundamental liveness theorem.  A verified function,
   when started in a state satisfying its precondition,
   will halt in a state satisfying its postcondition.
 *)

Lemma verify_totally_correct : forall G A P Q psi l t x,
  verify_prog psi G ->
  G |-- funptr l A t P Q ->
  forall r,
    (forall n, P x (K.squash (n,psi),r)) ->
    forall n c, proj1_sig t r n ->
      psi#l = Some c ->
      exists p', exists r',
        stepstar (K.squash (n,psi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
        Q x (p',r').
Proof.
  intros.
  assert (forall n, G (K.squash (n,psi))).
  apply verify_complete; auto.
  hnf; auto.
  assert (funptr l A t P Q (K.squash (S n,psi))) by auto.
  destruct H5 as [i [? ?]].
  spec H6 ((instr_assert (Q x) ;; instr_return ;; instr_assert FF)::nil).
  spec H6 0 x (K.squash (n,psi)).
  spec H6.
  simpl.
  apply t_step.
  hnf. rewrite K.knot_age1.
  rewrite K.unsquash_squash; simpl.
  f_equal.
  apply K.unsquash_inj.
  repeat rewrite K.unsquash_squash.
  f_equal.
  transitivity (KnotInput.fmap (K.approx n oo K.approx (S n)) psi).
  rewrite <- KnotInput.fmap_comp; auto.
  replace (K.approx n oo K.approx (S n)) with (K.approx n); auto.
  extensionality.
  unfold compose.
  change (K.approx n x0 = (K.approx n oo K.approx (1+n)) x0).
  rewrite <- K.approx_approx1; auto.
  spec H6 (K.squash (n,psi)).
  spec H6.
  apply rt_refl.
  spec H6.
  repeat intro.
  destruct a'.
  simpl.
  intro.
  exists p.
  econstructor.
  split.
  omega.
  econstructor.
  econstructor.
  auto.
  econstructor 2.
  econstructor.
  econstructor.

  spec H6 n r.
  spec H6 (K.squash (n,psi),r).
  spec H6; auto.
  spec H6. auto.
  spec H6 (K.squash (n,psi),r).
  spec H6; auto.
  spec H6. auto.
  hnf in H6.
  spec H6; auto.
  rewrite K.knot_level.
  rewrite K.unsquash_squash; simpl. omega.
  destruct H6 as [pz [rz [? ?]]].
  exists pz; exists rz.
  destruct H5 as [i' [? ?]].
  rewrite K.knot_level in H8.
  rewrite K.unsquash_squash in H8.
  simpl in H8.
  unfold prog_lookup in H5.
  rewrite K.unsquash_squash in H5.
  simpl in H5.
  unfold KnotInput.fmap in H5.
  apply fmap_eqn2 in H5.
  destruct H5 as [? [? ?]].
  unfold prog in *.
  unfold assert, world, prog, KnotInput.other in *.
  rewrite H3 in H5.
  inv H5.
  assert (stepstar (K.squash (n,psi)) pz r
    ((x0;;instr_assert FF) ::
      (instr_assert (Q x) ;; instr_return ;; instr_assert FF) :: nil) rz nil).
  generalize H7; intros.
  eapply stepstar_approxprog in H7.
  2: instantiate (2:=O). 2: simpl; auto.
  2: simpl; auto.
  2: instantiate (1:=
    (x0;; instr_assert FF) ::
    (instr_assert (Q x);; instr_return;;instr_assert FF) :: nil).
  destruct H7 as [? [? ?]].
  inv H9.
  auto.
  constructor.
  rewrite K.knot_level; simpl.
  rewrite K.unsquash_squash.
  simpl.
  hnf.
  hnf in H8.
  simpl; f_equal.
  rewrite collapse_instr_approx in H8.
  rewrite min_l in H8; auto.
  apply stack_approx_rel_refl.
  apply stepstar_stepN in H5.
  destruct H5.
  eapply end_assert_lemma; eauto.
Qed.

(* Weaker corollary: a program with a safe entry point
   will eventually halt.
 *)
Corollary verify_halts : forall t G psi l,
  verify_prog psi G ->
  G |-- funptr l unit t (fun _ => TT) (fun _ => TT) ->
  forall r n c,
    proj1_sig t r n ->
    psi#l = Some c ->
    eventually_halts (K.squash (n,psi)) r
       ((c ;; instr_assert FF)::nil).
Proof.
  intros.
  generalize (verify_totally_correct G unit (fun _ => TT) (fun _ => TT) psi l t tt); intros.
  spec H3; auto.
  spec H3; auto.
  spec H3 r.
  spec H3; auto.
  intros; hnf; auto.
  spec H3 n c H1 H2.
  hnf.
  destruct H3 as [? [? [? ?]]].
  eauto.
Qed.


(** A proof of the fact the [Applicative] functors are the same thing
    as [Monoidal] functors. *)

From CoqMTL Require Export Control.Applicative.
From CoqMTL Require Export Control.Monoidal.

(** We cat define [pure] by mapping a constant function over the default
    computation. *)
Definition pure_Monoidal
  {F : Type -> Type} {inst : Monoidal F} {A : Type} (x : A) : F A :=
    fmap (fun u : unit => x) default.

(** We can define [ap] by pairing f with a and mapping over it with a
    function which applies the first component of the pair to the
    second component. *)
Definition ap_Monoidal
  {F : Type -> Type} {inst : Monoidal F} {A B : Type}
  (f : F (A -> B)) (a : F A) : F B :=
    fmap (fun p => apply (fst p) (snd p)) (pairF f a).

(** The direction [Monoidal] => [Applicative] was very hard for me to
    prove. After unfolding definitions, the easy part is taken care of
    by the tactic [monoidal]. The rest is mostly precisely tailored
    rewrites in the reverse direction. If you gazed at the goals for
    long enough, you could probably have proved this all by yourself,
    but thanks to me you don't need to... *)
#[refine]
#[export]
Instance Monoidal_Applicative
  (F : Type -> Type) (inst : Monoidal F) : Applicative F :=
{
  is_functor := @is_functor F inst;
  pure := @pure_Monoidal F inst;
  ap := @ap_Monoidal F inst
}.
Proof.
  all: unfold pure_Monoidal, ap_Monoidal; intros; monoidal.
    rewrite !par_comp. cbn. unfold apply.
      rewrite <- (pairF_default_l _ (pairF g (pairF f x))).
      rewrite <- ?pairF_assoc, <- ?fmap_comp'. repeat f_equal.
      ext p. destruct p as [[[u g'] f'] x']. cbn. reflexivity.
    rewrite <- fmap_comp'. reflexivity.
    rewrite <- fmap_comp', par_comp. cbn.
      replace (fun p : (A -> B) * unit => id (fst p) x)
      with (@fst (A -> B) unit .> flip apply x).
        monoidal. unfold flip, apply, id, compose. reflexivity.
        ext p. destruct p. cbn. reflexivity.
Defined.

(** We can define [default] by injecting [tt] into the functor. *)
Definition default_Applicative
  {F : Type -> Type} {inst : Applicative F} : F unit := pure tt.

(** We can define [pairF] by applying [pair] injected into the functor. *)
Definition pairF_Applicative
  {F : Type -> Type} {inst : Applicative F} {A B : Type}
  (x : F A) (y : F B) : F (A * B)%type := pair <$> x <*> y.

#[global] Hint Unfold default_Applicative pairF_Applicative : CoqMTL.

(*Hint Remove fmap_pure_ap : CoqMTL.*)

(** The proof is quite easy, nothing to see here.
    Note that [fmap_pure_ap] is not necessary in the big rewrite
    alternative ||, but the tactic [hs] uses it, so it's necessary
    to prove the equivalence. *)
#[refine]
#[export]
Instance Applicative_Monoidal
  (F : Type -> Type) (inst : Applicative F) : Monoidal F :=
{
  is_functor := inst;
  default := default_Applicative;
  pairF := @pairF_Applicative F inst;
}.
Proof.
  all: hs;
  repeat (
    rewrite identity || rewrite homomorphism ||
    (*rewrite fmap_pure_ap ||*) rewrite <- composition ||
    rewrite interchange
  );
  reflexivity.
Defined.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-04-02
- Adam Koprowski, 2007-03-29
- Frederic Blanqui, 2009-05-11

useful definitions and lemmas on natural numbers
*)

Set Implicit Arguments.

From Coq Require Import Min Max Morphisms Psatz Compare Euclid.
From Coq Require Export Arith Omega.

From CoLoR Require Import LogicUtil EqUtil BoolUtil RelUtil.

(***********************************************************************)
(** Declare implicit arguments. *)

Arguments lt_S [n m] _.
Arguments lt_S_n [n m] _.
Arguments lt_n_S [n m] _.
Arguments le_S [n m] _.
Arguments gt_le_S [n m] _.
Arguments le_lt_n_Sm [n m] _.
Arguments lt_le_weak [n m] _.
Arguments le_plus_minus [n m] _.
Arguments le_plus_minus_r [n m] _.
Arguments lt_n_0 [n] _.
Arguments le_lt_trans [n m p] _ _.
Arguments lt_le_trans [n m p] _ _.
Arguments le_lt_or_eq [n m] _.
Arguments lt_n_Sm_le [n m] _.
Arguments lt_trans [n m p] _ _.
Arguments le_trans [n m p] _ _.
Arguments lt_le_weak [n m] _.
Arguments lt_le_S [n m] _.
Arguments lt_not_le [n m] _ _.
Arguments le_lt_eq_dec [n m] _.
Arguments le_S_n [n m] _.
Arguments le_not_lt [n m] _ _.
Arguments eq_add_S [n m] _.
Arguments le_n_S [n m] _.

(***********************************************************************)
(** Tactics. *)

Ltac coq_omega := omega.
Tactic Notation "omega" := intros; omega.
Tactic Notation "lia" := intros; lia.
Tactic Notation "nia" := intros; nia.

Ltac max :=
  match goal with
    | |- context [max ?x ?y] => gen (le_max_l x y); gen (le_max_r x y)
  end; omega.

(***********************************************************************)
(** Properties of ordering relations on nat. *)

Instance le_preorder : PreOrder le.

Proof. split; intro; omega. Qed.

Instance lt_trans : Transitive lt.

Proof. intro; omega. Qed.

Instance ge_preorder : PreOrder ge.

Proof. split; intro; omega. Qed.

Instance gt_trans : Transitive gt.

Proof. intro; omega. Qed.

(***********************************************************************)
(** Boolean function for equality. *)

Fixpoint beq_nat (x y : nat) :=
  match x, y with
    | 0, 0 => true
    | S x', S y' => beq_nat x' y'
    | _, _ => false
  end.

Lemma beq_nat_ok : forall x y, beq_nat x y = true <-> x = y.

Proof.
  induction x; destruct y; simpl; split; intro; try (refl || discr).
  f_equal. fo. fo.
Qed.

Ltac case_beq_nat := case_beq beq_nat beq_nat_ok.

Lemma eq_nat_dec_refl : forall n, eq_nat_dec n n = left (n<>n) (eq_refl n).

Proof.
  intro. gen (eq_nat_dec n n). destruct s.
  rewrite (UIP_refl eq_nat_dec e). refl. cong.
Qed.

(***********************************************************************)
(** Boolean functions for orderings. *)

Fixpoint bgt_nat (x y : nat) :=
  match x, y with
    | 0, _ => false
    | S _, 0 => true
    | S x', S y' => bgt_nat x' y'
  end.

Lemma bgt_nat_ok : forall x y, bgt_nat x y = true <-> x > y.

Proof.
  induction x; destruct y; simpl; split; intro; try omega; try discr. refl.
  rewrite IHx in H. omega. rewrite IHx. omega.
Qed.

Ltac check_gt := rewrite <- bgt_nat_ok; check_eq.

Lemma bgt_nat_ko : forall x y, bgt_nat x y = false <-> x <= y.

Proof.
  induction x; destruct y; simpl; split; intro; try (refl || discr || omega).
  rewrite IHx in H. omega. apply le_S_n in H. rewrite IHx. hyp.
Qed.

Fixpoint bge_nat (x y : nat) :=
  match x, y with
    | 0, 0 => true
    | 0, _ => false
    | S _, 0 => true
    | S x', S y' => bge_nat x' y'
  end.

Lemma bge_nat_ok : forall x y, bge_nat x y = true <-> x >= y.

Proof.
  induction x; destruct y; simpl; split; intro; try (refl || discr || omega).
  rewrite IHx in H. omega. apply le_S_n in H. rewrite IHx. hyp.
Qed.

Ltac check_ge := rewrite <- bge_nat_ok; check_eq.

Definition blt_nat x y := bgt_nat y x.

Lemma blt_nat_ok : forall x y, blt_nat x y = true <-> x < y.

Proof. intros. unfold blt_nat. rewrite bgt_nat_ok. omega. Qed.

Definition bne_nat x y := negb (beq_nat x y).

Lemma bne_nat_ok : forall x y, bne_nat x y = true <-> x <> y.

Proof.
  intros x y. unfold bne_nat. rewrite negb_lr. simpl.
  rewrite (beq_ko beq_nat_ok). refl.
Qed.

(***********************************************************************)
(** Unicity of equality and ordering proofs on nat. *)

Lemma eq_unique : forall (n m : nat) (h1 h2 : n = m), h1 = h2.

Proof. intros. apply UIP. apply eq_nat_dec. Qed.

Scheme le_ind_dep := Induction for le Sort Prop.

Lemma le_unique : forall n m (h1 h2 : n <= m), h1 = h2.

Proof.
intro n.
assert (forall m (h1 : n <= m) p (h2 : n <= p),
           m=p -> eq_dep nat (le n) m h1 p h2).
 intros m h1; elim h1 using le_ind_dep.
  intros p h2; case h2; intros.
   auto.
   subst n. absurd (S m0 <= m0); auto with arith.
 intros m0 l Hrec p h2.
  case h2; intros.
   subst n; absurd (S m0 <= m0); auto with arith.
   assert (m0=m1); auto ; subst m0.
   replace l0 with l; auto.
   apply (@eq_dep_eq _ eq_nat_dec (le n) m1); auto.
 intros; apply (@eq_dep_eq _ eq_nat_dec (le n) m); auto.
Qed.

Lemma lt_unique : forall n m (h1 h2 : n < m), h1 = h2.

Proof. intros n m. unfold lt. intros. apply le_unique. Qed.

Lemma lt_Sn_nS : forall m n (H : m < n), lt_S_n (lt_n_S H) = H.

Proof. intros. apply lt_unique. Qed.

Lemma lt_nS_Sn : forall m n (H : S m < S n), lt_n_S (lt_S_n H) = H.

Proof. intros. apply lt_unique. Qed.

(***********************************************************************)
(** Lemmas on the maximum of two numbers. *)

Arguments max_r [n m] _.
Arguments max_l [n m] _.

From Coq Require Import Compare.

Lemma max_assoc : forall a b c, max a (max b c) = max (max a b) c.

Proof.
intros.
case (le_dec b c); intro H.
 rewrite (max_r H).
 case (le_dec a b); intro H'.
  rewrite (max_r (le_trans H' H)), (max_r H'), (max_r H). refl.
  case (le_dec a c); intro H''; rewrite (max_l H'); refl.
  rewrite (max_l H).
  case (le_dec a b); intro H'.
   rewrite (max_r H').
   apply (sym_equal (max_l H)).
   assert (H'' : c <= max a b). eapply le_trans. apply H. apply le_max_r.
   apply (sym_equal (max_l H'')).
Qed.

Lemma le_max_intro_l x y z : x <= y -> x <= max y z.

Proof. lia. Qed.

Lemma lt_max_intro_l x y z : x < y -> x < max y z.

Proof. lia. Qed.

Lemma le_max_intro_r x y z : x <= z -> x <= max y z.

Proof. lia. Qed.

Lemma lt_max_intro_r x y z : x < z -> x < max y z.

Proof. lia. Qed.

Lemma le_max_elim_l x y z : max x y <= z -> x <= z.

Proof. lia. Qed.

Lemma le_max_elim_r x y z : max x y <= z -> y <= z.

Proof. lia. Qed.

Lemma max_ge_compat x y x' y' : x >= x' -> y >= y' -> max x y >= max x' y'.

Proof. lia. Qed.

Lemma max_gt_compat x y x' y' : x > x' -> y > y' -> max x y > max x' y'.

Proof. lia. Qed.

Lemma min_gt_compat x y x' y' : x > x' -> y > y' -> min x y > min x' y'.

Proof. lia. Qed.

Lemma max_lt x y z : max y z < x <-> y < x /\ z < x.

Proof. lia. Qed.

Lemma gt_max x y z : x > max y z <-> x > y /\ x > z.

Proof. apply max_lt. Qed.

Lemma max_0_r x : max x 0 = x.

Proof. destruct x; refl. Qed.

(***********************************************************************)
(** Lemmas on the minimum of two numbers. *)

Lemma elim_min_l x y z : x <= z -> min x y <= z.

Proof. lia. Qed.

Lemma elim_min_r : forall x y z, y <= z -> min x y <= z.

Proof. lia. Qed.

Lemma lt_min_intro_l x y z : x < z -> min x y < z.

Proof. lia. Qed.

Lemma lt_min_intro_r x y z : y < z -> min x y < z.

Proof. lia. Qed.

Lemma le_min_intro_l x y z : x <= z -> min x y <= z.

Proof. lia. Qed.

Lemma le_min_intro_r x y z : y <= z -> min x y <= z.

Proof. lia. Qed.

Lemma min_ge_compat x y x' y' : x >= x' -> y >= y' -> min x y >= min x' y'.

Proof. lia. Qed.

(***********************************************************************)
(** Decidability of ordering relations on nat. *)

Lemma ge_dec : rel_dec ge.

Proof. intros i j. destruct (le_lt_dec j i); intuition. Defined.

Lemma gt_dec : rel_dec gt.

Proof. intros i j. destruct (le_gt_dec i j); auto with arith. Defined.

Lemma lt_ge_dec x y : {x < y} + {x >= y}.

Proof.
  destruct (lt_eq_lt_dec x y); auto; try destruct s; auto with *.
Defined.

(***********************************************************************)
(** Euclidian division. *)

Lemma mult_is_not_O m n : m * n <> 0 <-> m <> 0 /\ n <> 0.

Proof. nia. Qed.

Lemma mult_lt_r_elim : forall x x' y, x * y < x' * y -> x < x'.

Proof. induction x; induction y; simpl; nia. Qed.

Arguments mult_lt_r_elim [x x' y] _.

Lemma eucl_div_unique b q1 r1 q2 r2 :
  b > r1 -> b > r2 -> q1 * b + r1 = q2 * b + r2 -> q1 = q2 /\ r1 = r2.

Proof.
intros.
assert ((q1-q2)*b=r2-r1). nia.
assert ((q2-q1)*b=r1-r2). (*nia works but is slow*)
rewrite mult_minus_distr_r. clear H2; omega.
(*nia works but is slow*)
destruct (le_gt_dec r1 r2).
(* r1 <= r2 *)
destruct (eq_nat_dec r1 r2).
(* r1 = r2 *)
subst. rewrite minus_diag in *. nia.
(* r1 < r2 *)
assert (r2 - r1 < b). clear -H H0; omega.
rewrite <- H2 in H4. rewrite <- (mult_1_l b) in H4 at -1.
ded (mult_lt_r_elim H4).
assert (q1=q2). clear H H0 H1 H3 H4; omega.
subst q2; clear H2 H3 H4 H5. omega.
(* r1 > r2 *)
assert (r1 - r2 < b). clear -H H0; omega.
rewrite <- H3 in H4. rewrite <- (mult_1_l b) in H4 at -1.
ded (mult_lt_r_elim H4).
assert (q1=q2). clear H H0 H1 H2 H4; omega.
subst q2; clear H2 H3 H4 H5. omega.
Qed.

Arguments eucl_div_unique [b q1 r1 q2 r2] _ _ _.

(***********************************************************************)
(** Iteration of a function. *)

Section iter.

  Variables (A : Type) (a : A) (f : A -> A).

  Fixpoint iter i :=
    match i with
      | 0 => a
      | S i' => f (iter i')
    end.

End iter.

Section iter_prop.

  Variables (A : Type) (f : A -> A).

  Lemma iter_com : forall a i, iter (f a) f i = f (iter a f i).

  Proof. induction i; simpl; intros. refl. rewrite IHi. refl. Qed.

  Lemma red_iter : forall R : relation A,
    (forall x y, R x y -> R (f x) (f y)) ->
    forall i x y, R x y -> R (iter x f i) (iter y f i).

  Proof. induction i; simpl; intros. hyp. apply H. apply IHi. hyp. Qed.

End iter_prop.

(***********************************************************************)
(** Arithmetical lemmas. *)

Lemma le_plus : forall x y, x <= y -> exists k, y = k + x.

Proof.
  induction 1; simpl. ex 0. refl. destruct IHle as [k e]. ex (S k). omega.
Qed.

Lemma le_lt_S : forall i k, i <= k -> i < S k.

Proof. auto with arith. Qed.

Lemma i_lt_n : forall n i j : nat, n = i + S j -> i < n.

Proof. omega. Qed.

Arguments i_lt_n [n i j] _.

Lemma S_neq_O : forall n, S n = O -> False.

Proof. discr. Qed.

Lemma plus_reg_l_inv : forall n1 n2 p2, n2=p2 -> n1+n2=n1+p2.

Proof. omega. Qed.

Lemma plus_reg_r_inv : forall n1 p1 n2, n1=p1 -> n1+n2=p1+n2.

Proof. omega. Qed.

Lemma plus_minus_eq : forall v p, v+p-p=v.

Proof. omega. Qed.

Lemma le_minus_plus : forall v p, p<=v -> v-p+p=v.

Proof. omega. Qed.

Arguments le_minus_plus [v p] _.

Lemma plus_1_S : forall n, n+1 = S n.

Proof. omega. Qed.

Lemma lt_from_le : forall x y, 0 < y -> x <= y-1 -> x < y.

Proof. omega. Qed.

Lemma le_from_lt : forall x y, x < y+1 -> x <= y.

Proof. omega. Qed.

Lemma lt_pm : forall n k x, n < x -> x <= n+k -> x-n-1 < k.

Proof. omega. Qed.

Arguments lt_pm [n k x] _ _.

Lemma le_plus_r : forall k l, k <= k+l.

Proof. omega. Qed.

Lemma misc1 : forall x k, S k = x+2+k-x-1.

Proof. omega. Qed.

Lemma misc2 : forall x k, k = x+2+k-(x+1)-1.

Proof. omega. Qed.

Lemma mult_gt_0 : forall i j, i > 0 -> j > 0 -> i * j > 0.

Proof. nia. Qed.

Lemma mult_lt_compat_lr : forall i j k l,
  i <= j -> j > 0 -> k < l -> i * k < j * l.

Proof. nia. Qed.

Lemma S_add_S : forall n1 n2 n, n1 + S n2 = n -> S n1 + S n2 = S n.

Proof. intros. subst. refl. Qed.

Arguments S_add_S [n1 n2 n] _.

Lemma gt_plus : forall l k, l > k -> exists m, l = (m + 1) + k.

Proof. induction 1. exists 0. omega. destruct IHle. exists (S x). omega. Qed.

Arguments gt_plus [l k] _.

(***********************************************************************)
(** Given a non-null function [F], [Interval_list F i] is the pair
[(S(i),S(i+1)] where S(0)=0 and S(i+1)=S(i)+F(i). *)

Section Interval_list.

  Variables (F : nat -> nat) (HFi : forall i, exists y, F i = S y).

  Fixpoint Interval_list i : nat * nat :=
    match i with
      | 0 => (0, F 0)
      | S i' => let x := snd (Interval_list i') in (x, x + F i)
    end.

  Local Notation F' := Interval_list.

  Lemma int_exPi : forall i, exists j, fst (F' j) <= i /\ i < snd (F' j).

  Proof.
    intros i. induction i. exists 0. simpl. destruct (HFi 0); rewrite H. omega.
    destruct IHi as [k Hk]. assert (HSi : S i <= snd (F' k)). omega.
    destruct (le_lt_or_eq HSi). exists k. intuition.
    exists (S k). simpl. rewrite H. split. omega.
    destruct (HFi (S k)). rewrite H0. omega.
  Qed.

End Interval_list.

(***********************************************************************)
(** Monotone functions on nat. *)

Section mon.

  Variables (A : Type) (ltA : relation A) (ht : transitive ltA) (f : nat->A).

  Lemma monS : (forall x, ltA (f x) (f (S x)))
    -> (forall x y, x < y -> ltA (f x) (f y)).

  Proof.
    intros hf x. cut (forall k, ltA (f x) (f (k+S x))).
    intros hx y xy. assert (y = (y-S x)+S x). omega. rewrite H. apply hx.
    induction k; simpl. apply hf. apply ht with (f (k+S x)). hyp. apply hf.
  Qed.

End mon.

Arguments monS [A ltA] _ [f] _ [x y] _.

(****************************************************************************)
(** Smallest natural number satisfying some satisfiable property. *)

Section smallest.

  Variables (P : nat -> Prop) (P_dec : forall x, {P x}+{~P x}).

  Section smallest_aux.

    Variables (n : nat) (h : P n).

    Fixpoint smallest_aux acc k :=
      match k with
        | 0 => if P_dec k then 0 else acc
        | S k' => smallest_aux (if P_dec k then k else acc) k'
      end.

    Definition smallest := smallest_aux n n.

    Lemma smallest_aux_ok : forall k acc, P acc -> P (smallest_aux acc k).

    Proof.
      induction k; intros acc Pacc; simpl.
      destruct (P_dec 0); hyp.
      destruct (P_dec (S k)); fo.
    Qed.

    Lemma smallest_ok : P smallest.

    Proof. unfold smallest. apply smallest_aux_ok. hyp. Qed.

    Lemma smallest_aux_le_max_args l :
      forall k acc, acc <= l -> k <= l -> smallest_aux acc k <= l.

    Proof.
      induction k; intros acc accl kl; simpl.
      destruct (P_dec 0); omega.
      destruct (P_dec (S k)); apply IHk; omega.
    Qed.

    Lemma smallest_le_arg : smallest <= n.

    Proof. apply smallest_aux_le_max_args; refl. Qed.

    Lemma smallest_aux_plus_exists m :
      forall k acc, exists acc', smallest_aux acc (k + m) = smallest_aux acc' m.

    Proof.
      induction k; intro acc; simpl.
      ex acc. refl.
      set (a := if P_dec (S (k + m)) then S (k + m) else acc).
      destruct (IHk a) as [acc' hacc']. ex acc'. hyp.
    Qed.

    Lemma smallest_aux_plus m : P (S m) ->
      forall k acc acc', smallest_aux acc (k + S m) = smallest_aux acc' (S m).

    Proof.
      intro PSm. induction k; intros acc acc'; simpl.
      destruct (P_dec (S m)). refl. contr. erewrite IHk. refl.
    Qed.

    Lemma smallest_aux_le_exists k l acc :
      k <= l -> exists acc', smallest_aux acc l = smallest_aux acc' k.

    Proof.
      intro kl. destruct (le_plus kl) as [m e]; subst.
      apply smallest_aux_plus_exists.
    Qed.

    Lemma smallest_aux_le k l acc acc' :
      k <= l -> P (S k) -> smallest_aux acc (S l) = smallest_aux acc' (S k).

    Proof.
      intros kl Pk. destruct (le_plus kl) as [m e]; subst.
      assert (e : S (m + k) = m + S k). omega. rewrite e.
      apply smallest_aux_plus. hyp.
    Qed.

  End smallest_aux.

  Lemma smallest_inv_le k l : k <= l -> P k -> smallest l = smallest k.

  Proof.
    unfold smallest. destruct k; simpl.
    (* k=0 *)
    intros _ P0. destruct (P_dec 0). 2: contr. clear p. revert l.
    cut (forall l acc, smallest_aux acc l = 0). fo.
    induction l; intro acc; simpl. destruct (P_dec 0). refl. contr. fo.
    (* k > 0 *)
    destruct l; simpl. omega. intro kl. apply smallest_aux_le. omega.
  Qed.

  Lemma smallest_inv m n : P m -> P n -> smallest m = smallest n.

  Proof.
    intros Pm Pn. destruct (le_dec n m). apply smallest_inv_le; hyp.
    sym. apply smallest_inv_le. omega. hyp.
  Qed.

  Lemma smallest_comp m n : P m -> P n -> smallest m <= n.

  Proof.
    intros Pm Pn. destruct (le_dec m n). rewrite smallest_le_arg. hyp.
    rewrite smallest_inv with (n:=n); auto. apply smallest_le_arg.
  Qed.

End smallest.

Arguments smallest [P] _ _.
Arguments smallest_ok [P] _ [n] _.
Arguments smallest_comp [P] _ [m n] _ _.