(**
  This file contains the syntactic typing judegment,
  as well as type preservation under substitution and
  progress and preservation proofs
*)
Set Implicit Arguments.
Require Import Omega Logic List Classes.Morphisms.
Import List Notations.

From cbpv Require Export base abstractreductionsystems fintype syntax terms semantics.
Import CommaNotation.

(** * Syntactic Typing Judement  *)
Reserved Notation "Gamma ⊢ c : A" (at level 80, c at level 99).
Reserved Notation "Gamma ⊩ v : A" (at level 80, v at level 99).

(** Syntactic typing judgement using DeBrujin indices *)
Definition ctx (n: nat) := fin n -> valtype.

(** ** Value Typing Judgement *)
Inductive value_typing {m: nat} (Gamma: ctx m) : value m -> valtype -> Type :=
| typeVar i : Gamma ⊩ var_value i : Gamma i
| typeUnit: Gamma ⊩ u : one
| typePair v1 v2 A1 A2:
    Gamma ⊩ v1 : A1 -> Gamma ⊩ v2 : A2 -> Gamma ⊩ pair v1 v2 : cross A1 A2
| typeSum A1 A2 (b: bool) v:
    Gamma ⊩ v : (if b then A1 else A2) -> Gamma ⊩ inj b v : Sigma A1 A2
| typeThunk c A:
    Gamma ⊢ c : A -> Gamma ⊩ thunk c : U A
where "Gamma ⊩ v : A" := (value_typing Gamma v A)

(** ** Computation Typing Judgement *)
with computation_typing {m: nat} (Gamma: ctx m) : comp m -> comptype -> Type :=
| typeCone: Gamma ⊢ cu : cone
| typeLambda (c: comp (S m)) A B:
    A .: Gamma ⊢ c : B -> (Gamma ⊢ lambda c : A → B)
| typeLetin c1 c2 A B:
    Gamma ⊢ c1 : F A -> A .: Gamma ⊢ c2 : B -> Gamma ⊢ $ <- c1; c2 : B
| typeRet v A:
    Gamma ⊩ v : A -> Gamma ⊢ ret v : F A
| typeApp c v A B:
    Gamma ⊢ c : A → B -> Gamma ⊩ v : A -> Gamma ⊢ c v : B
| typeTuple c1 c2 B1 B2:
    Gamma ⊢ c1 : B1  -> Gamma ⊢ c2 : B2 -> Gamma ⊢ tuple c1 c2 : Pi B1 B2
| typeProj b c B1 B2:
    Gamma ⊢ c : Pi B1 B2 -> Gamma ⊢ proj b c : (if b then B1 else B2)
| typeForce v A:
    Gamma ⊩ v : U A -> Gamma ⊢ v! : A
| typeCaseZ v A: Gamma ⊩ v : zero -> Gamma ⊢ caseZ v : A
| typeCaseS v c1 c2 A1 A2 C:
    Gamma ⊩ v : Sigma A1 A2 ->
    A1, Gamma ⊢ c1 : C ->
    A2, Gamma ⊢ c2 : C ->
    Gamma ⊢ caseS v c1 c2 : C
| typeCaseP v c A B C:
    Gamma ⊩ v : A * B ->
    B, A, Gamma  ⊢ c : C ->
    Gamma ⊢ caseP v c : C
where "Gamma ⊢ c : A" := (@computation_typing _ Gamma c A).

Scheme value_typing_ind_2 := Minimality for value_typing Sort Prop
  with computation_typing_ind_2  := Minimality for computation_typing Sort Prop.

Scheme value_typing_ind_3 := Minimality for value_typing Sort Type
  with computation_typing_ind_3  := Minimality for computation_typing Sort Type.

Combined Scheme mutind_value_computation_typing from
         value_typing_ind_2, computation_typing_ind_2.

Scheme value_typing_ind_4 := Induction for value_typing Sort Prop
    with computation_typing_ind_4  := Induction for computation_typing Sort Prop.

Combined Scheme mutindt_value_computation_typing from
          value_typing_ind_4, computation_typing_ind_4.

Hint Constructors computation_typing value_typing.

(** Type judgement inversion *)
Ltac invt :=
  match goal with
  | [H: (_ ⊢ cu : _) |- _] => inv H
  | [H: (_ ⊢ lambda _ : _) |- _] => inv H
  | [H: (_ ⊢ _ ! : _) |- _] => inv H
  | [H: (_ ⊢ $ <- _; _ : _) |- _] => inv H
  | [H: (_ ⊢ ret _ : _) |- _] => inv H
  | [H: (_ ⊢ app _ _ : _) |- _] => inv H
  | [H: (_ ⊢ tuple _ _ : _) |- _] => inv H
  | [H: (_ ⊢ proj _ _ : _) |- _] => inv H
  | [H: (_ ⊢ _ ! : _) |- _] => inv H
  | [H: (_ ⊢ proj _ _ : _) |- _] => inv H
  | [H: (_ ⊢ caseZ _ : _) |- _] => inv H
  | [H: (_ ⊢ caseS _ _ _ : _) |- _] => inv H
  | [H: (_ ⊢ caseP _ _ : _) |- _] => inv H
  | [H: (_ ⊩ var_value _ : _) |- _] => inv H
  | [H: (_ ⊩ u : _) |- _] => inv H
  | [H: (_ ⊩ pair _ _  : _) |- _] => inv H
  | [H: (_ ⊩ inj _ _  : _) |- _] => inv H
  | [H: (_ ⊩ <{ _ }>  : _) |- _] => inv H
  | [H: (_ ⊩ _ : zero) |- _] => inv H
  end.

(** Automation friendly version of the variable constructor *)
Lemma typeVar' n (Gamma : ctx n) A i: Gamma i = A -> Gamma ⊩ var_value i : A.
Proof. intros <-; constructor. Qed.

Hint Resolve typeVar'.

(** ** Type Preservation under Substitution *)

(** Type preservation under renaming  *)
Fixpoint value_typepres_renaming n Gamma v A (H: Gamma ⊩ v : A)  m (delta: fin n -> fin m) Delta {struct H}:
  (forall i, Gamma i = Delta (delta i)) -> Delta ⊩ v⟨delta⟩ : A
with comp_typepres_renaming n Gamma c B (H: Gamma ⊢ c : B) m (delta: fin n -> fin m) Delta {struct H}:
  (forall i, Gamma i = Delta (delta i)) -> Delta ⊢ c⟨delta⟩ : B.
Proof.
  all: destruct H; cbn; intros; eauto; econstructor; eauto;
    eapply comp_typepres_renaming; eauto.
  all: auto_case.
Qed.

(** Type preservation under substitution  *)
Fixpoint value_typepres_substitution n (Gamma: ctx n) v A (H: Gamma ⊩ v : A)  m (sigma: fin n -> value m) Delta {struct H}:
  (forall i, Delta ⊩ sigma i : Gamma i) -> Delta ⊩ v[sigma] : A
with comp_typepres_substitution n (Gamma: ctx n) c B (H: Gamma ⊢ c : B) m (sigma: fin n -> value m) Delta {struct H}:
  (forall i, Delta ⊩ sigma i : Gamma i) -> Delta ⊢ c[sigma] : B.
Proof.
    all: destruct H; cbn; intros; eauto; econstructor; eauto.
    all: eapply comp_typepres_substitution; eauto.
    all: auto_case; repeat (eapply value_typepres_renaming); eauto.
Qed.

(** ** Preservation *)
(** Type preservation under beta reduction  *)
Lemma typepres_beta {n: nat} (Gamma: fin n -> valtype) c v A B:
  A .: Gamma ⊢ c : B -> Gamma ⊩ v : A -> Gamma ⊢ c[v..] : B.
Proof.
  intros H1 H2; eapply (comp_typepres_substitution H1). intros []; cbn; eauto.
  apply typeVar. (* don't know why eauto didn't work here *)
Qed.

(** Type preservation under primitive reduction  *)
Lemma primitive_preservation {n} (c c': comp n) Gamma A:
  c ≽ c' -> Gamma ⊢ c : A -> inhab (Gamma ⊢ c' : A).
Proof.
  destruct 1; intros H1; repeat invt; try destruct b; constructor; eauto using typepres_beta.
  eapply comp_typepres_substitution; [eassumption |]; auto_case.
Qed.

(** Type preservation under reduction  *)
Lemma preservation {n: nat} Gamma (c c': comp n) A:
  c > c' -> Gamma ⊢ c : A -> inhab (Gamma ⊢ c' : A).
Proof.
  induction 1 in Gamma, A |-*; [ now apply primitive_preservation | idtac.. ];
    intros; invt; destruct (IHstep _ _ X0); constructor; eauto.
Qed.

Lemma preservation_steps n (Gamma: ctx n)(c c': comp n) A:
    Gamma ⊢ c : A -> c >* c' -> inhab (Gamma ⊢ c' : A).
Proof.
  induction 2; eauto using preservation.
  specialize (preservation H X) as [H1]; eauto.
Qed.

(** ** Progress *)
Lemma progress (e: comp 0) (B: comptype) :
  null ⊢ e : B -> (exists e', e > e') \/ nf e.
Proof with (left; eexists; eauto).
  enough (
      forall n Gamma e B, Gamma ⊢ e : B ->
      (match n return ctx n -> Prop with 0 => fun Gamma => Gamma = null | _ => fun  _ => False end) Gamma ->
      (exists e', e > e') \/ nf e
    ) by eauto.
  induction 1; destruct m; intuition; subst Gamma.
  1, 3, 5: destruct H1...
  1 - 3: inv H1; invt...
  all: inv v0; try (destruct i)...
Qed.


(** * Second-Order Logic *)

Require Import Equations.Equations Equations.Prop.DepElim.
Require Import Lia.
Require Import EqdepFacts.

Require Import VectorLib.
Require Import Decidable.
Require Import Enumerable.
Require Import Util.
Require Import List ListLib.

(** ** Syntax *)

Class funcs_signature :=
  { syms : Type; ar_syms : syms -> nat }.

Coercion syms : funcs_signature >-> Sortclass.

Class preds_signature :=
  { preds : Type; ar_preds : preds -> nat }.

Coercion preds : preds_signature >-> Sortclass.

Section Syntax.

  Context {Σ_funcs : funcs_signature}.

  Unset Elimination Schemes.

  Inductive function : nat -> Type :=
    | var_func : nat -> forall ar, function ar
    | sym : forall f : syms, function (ar_syms f).

  Inductive term : Type :=
    | var_indi : nat -> term
    | func : forall ar, function ar -> vec term ar -> term.

  Set Elimination Schemes.

  Lemma term_ind (p : term -> Prop) :
    (forall n, p (var_indi n))
    -> (forall ar n v (IH : VectorLib.Forall p v), p (func ar (var_func n ar) v))
    -> (forall f v (IH : VectorLib.Forall p v), p (func (ar_syms f) (sym f) v))
    -> forall t, p t.
  Proof.
    intros H1 H2 H3. fix term_ind 1. destruct t.
    - apply H1.
    - destruct f.
      + apply H2. induction v.
        * constructor.
        * constructor. apply term_ind. exact IHv.
      + apply H3. induction v.
        * constructor.
        * constructor. apply term_ind. exact IHv.
  Qed.

  Lemma term_ind' (p : term -> Prop) :
    (forall n, p (var_indi n))
    -> (forall ar f v (IH : VectorLib.Forall p v), p (func ar f v))
    -> forall t, p t.
  Proof.
    intros H1 H2. fix term_ind' 1. destruct t.
    - apply H1.
    - apply H2. clear f. induction v; constructor. apply term_ind'. exact IHv.
  Qed.

  Lemma term_rect (p : term -> Type) :
    (forall n, p (var_indi n))
    -> (forall ar n v (IH : VectorLib.ForallT p v), p (func ar (var_func n ar) v))
    -> (forall f v (IH : VectorLib.ForallT p v), p (func (ar_syms f) (sym f) v))
    -> forall t, p t.
  Proof.
    intros H1 H2 H3. fix term_ind 1. destruct t.
    - apply H1.
    - destruct f.
      + apply H2. induction v.
        * constructor.
        * constructor. apply term_ind. exact IHv.
      + apply H3. induction v.
        * constructor.
        * constructor. apply term_ind. exact IHv.
  Qed.

  Lemma term_rect' (p : term -> Type) :
    (forall n, p (var_indi n))
    -> (forall ar f v (IH : VectorLib.ForallT p v), p (func ar f v))
    -> forall t, p t.
  Proof.
    intros H1 H2. fix term_rect' 1. destruct t.
    - apply H1.
    - apply H2. clear f. induction v; constructor. apply term_rect'. exact IHv.
  Qed.

  Context {Σ_preds : preds_signature}.

  Inductive predicate : nat -> Type :=
    | var_pred : nat -> forall ar, predicate ar
    | pred : forall P : preds, predicate (ar_preds P).

  Class operators := {binop : Type ; quantop : Type}.
  Context {ops : operators}.

  Inductive form : Type :=
    | fal : form
    | atom : forall ar, predicate ar -> vec term ar -> form
    | bin : binop -> form -> form -> form
    | quant_indi : quantop -> form -> form
    | quant_func : quantop -> nat -> form -> form
    | quant_pred : quantop -> nat -> form -> form.

End Syntax.

(** Set implicit arguments. Arities can be left out.  *)
Arguments var_func {_} _ {_}, {_} _ _.
Arguments func {_ _}.
Arguments var_pred {_} _ {_}, {_} _ _.
Arguments atom {_ _ _ _}.

Section FirstorderFragment.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Fixpoint first_order_term (t : term) := match t with
    | var_indi _ => True
    | func (var_func _) _ => False
    | func (sym f) v => VectorLib.Forall first_order_term v
  end.

  Fixpoint first_order phi := match phi with
    | fal => True
    | atom (pred _) v => VectorLib.Forall first_order_term v
    | atom (var_pred _ _) _ => False
    | bin _ phi psi => first_order phi /\ first_order psi
    | quant_indi _ phi => first_order phi
    | quant_func _ _ _ => False
    | quant_pred _ _ _ => False
  end.

  Lemma first_order_term_dec t :
    dec (first_order_term t).
  Proof.
    induction t using term_rect; cbn.
    - now left.
    - now right.
    - now apply VectorLib.Forall_dec.
  Qed.

  Lemma first_order_dec :
    forall phi, dec (first_order phi).
  Proof.
    induction phi; cbn. 2: destruct p. 3: apply VectorLib.Forall_dec, ForallT_general, first_order_term_dec.
    all: firstorder.
  Qed.

End FirstorderFragment.

Section FunctionFreeFragment.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Fixpoint funcfreeTerm (t : SOL.term) := match t with
  | var_indi x => True
  | func (var_func _) _ => False
  | func (sym _) v => VectorLib.Forall funcfreeTerm v
  end.

  Fixpoint funcfree (phi : SOL.form) := match phi with
  | atom _ v => VectorLib.Forall funcfreeTerm v
  | fal => True
  | bin _ phi psi => funcfree phi /\ funcfree psi
  | quant_indi _ phi => funcfree phi
  | quant_func _ ar' phi => False
  | quant_pred _ _ phi => funcfree phi
  end.

  Lemma funcfreeTerm_dec t :
    dec (funcfreeTerm t).
  Proof.
    induction t using term_rect; cbn.
    - now left.
    - now right.
    - now apply VectorLib.Forall_dec.
  Qed.

  Lemma funcfree_dec phi :
    dec (funcfree phi).
  Proof.
    induction phi; cbn. 2: apply VectorLib.Forall_dec, ForallT_general, funcfreeTerm_dec.
    all: firstorder.
  Qed.

  Lemma firstorder_funcfree_term t :
    first_order_term t -> funcfreeTerm t.
  Proof.
    now induction t.
  Qed.

  Lemma firstorder_funcfree phi :
    first_order phi -> funcfree phi.
  Proof.
    induction phi; firstorder. now destruct p.
  Qed.

End FunctionFreeFragment.

(** *** Bounds *)

Section Bounded.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Fixpoint bounded_indi_term n (t : term) := match t with
    | var_indi x => n > x
    | func _ v => VectorLib.Forall (bounded_indi_term n) v
  end.

  Fixpoint bounded_func_term ar n (t : term) := match t with
    | var_indi x => True
    | @func _ ar' (var_func x) v => (n > x \/ ar <> ar') /\ VectorLib.Forall (bounded_func_term ar n) v
    | func (sym _) v => VectorLib.Forall (bounded_func_term ar n) v
  end.

  Fixpoint bounded_indi n (phi : form) := match phi with
    | atom _ v => VectorLib.Forall (bounded_indi_term n) v
    | fal => True
    | bin _ phi psi => bounded_indi n phi /\ bounded_indi n psi
    | quant_indi _ phi => bounded_indi (S n) phi
    | quant_func _ _ phi => bounded_indi n phi
    | quant_pred _ _ phi => bounded_indi n phi
  end.

  Fixpoint bounded_func ar n (phi : form) := match phi with
    | atom _ v => VectorLib.Forall (bounded_func_term ar n) v
    | fal => True
    | bin _ phi psi => bounded_func ar n phi /\ bounded_func ar n psi
    | quant_indi _ phi => bounded_func ar n phi
    | quant_func _ ar' phi => (ar = ar' /\ bounded_func ar (S n) phi) \/ (ar <> ar' /\ bounded_func ar n phi)
    | quant_pred _ _ phi => bounded_func ar n phi
  end.

  Fixpoint bounded_pred ar n (phi : form) := match phi with
    | @atom _ _ _ ar' (var_pred x) _ => n > x \/ ar <> ar'
    | atom (pred _) _ => True
    | fal => True
    | bin _ phi psi => bounded_pred ar n phi /\ bounded_pred ar n psi
    | quant_indi _ phi => bounded_pred ar n phi
    | quant_func _ _ phi => bounded_pred ar n phi
    | quant_pred _ ar' phi => (ar = ar' /\ bounded_pred ar (S n) phi) \/ (ar <> ar' /\ bounded_pred ar n phi)
  end.

  Definition closed phi := bounded_indi 0 phi /\ (forall ar, bounded_func ar 0 phi) /\ (forall ar, bounded_pred ar 0 phi).

  Definition bounded_indi_L n A := forall phi, List.In phi A -> bounded_indi n phi.
  Definition bounded_func_L ar n A := forall phi, List.In phi A -> bounded_func ar n phi.
  Definition bounded_pred_L ar n A := forall phi, List.In phi A -> bounded_pred ar n phi.

  Lemma bounded_indi_term_up n m t :
    m >= n -> bounded_indi_term n t -> bounded_indi_term m t.
  Proof.
    intros H1. induction t; intros H2; cbn in *.
    lia. induction v; firstorder. induction v; firstorder.
  Qed.

  Lemma bounded_func_term_up ar n m t :
    m >= n -> bounded_func_term ar n t -> bounded_func_term ar m t.
  Proof.
    intros H1. induction t; intros H2; cbn in *. easy. split. lia.
    eapply Forall_ext_Forall. apply IH. apply H2.
    eapply Forall_ext_Forall. apply IH. apply H2.
  Qed.

  Lemma bounded_indi_up n m phi :
    m >= n -> bounded_indi n phi -> bounded_indi m phi.
  Proof.
    revert m n. induction phi; intros m n' H1 H2; cbn in *. easy.
    eapply Forall_ext. 2: apply H2. intros t; now apply bounded_indi_term_up.
    firstorder. eapply IHphi. 2: apply H2. lia. all: firstorder.
  Qed.

  Lemma bounded_func_up ar n m phi :
    m >= n -> bounded_func ar n phi -> bounded_func ar m phi.
  Proof.
    revert m n. induction phi; intros m n' H1 H2; cbn in *. easy.
    eapply Forall_ext. 2: apply H2. intros t; now apply bounded_func_term_up.
    1,2,4: firstorder. destruct H2 as [H2|H2].
    - left. split. easy. eapply IHphi. 2: apply H2. lia.
    - right. split. easy. eapply IHphi. 2: apply H2. lia.
  Qed.

  Lemma bounded_pred_up ar n m phi :
    m >= n -> bounded_pred ar n phi -> bounded_pred ar m phi.
  Proof.
    revert m n. induction phi; intros m n' H1 H2; cbn in *. easy.
    destruct p. lia. easy. 1-3: firstorder. destruct H2 as [H2|H2].
    - left. split. easy. eapply IHphi. 2: apply H2. lia.
    - right. split. easy. eapply IHphi. 2: apply H2. lia.
  Qed.

  Lemma bounded_indi_term_dec n t :
    dec (bounded_indi_term n t).
  Proof.
    induction t using term_rect; cbn.
    - destruct (Compare_dec.lt_dec n0 n) as [|]. now left. now right.
    - apply VectorLib.Forall_dec, IH.
    - apply VectorLib.Forall_dec, IH.
  Qed.

  Lemma bounded_indi_dec n phi :
    dec (bounded_indi n phi).
  Proof.
    induction phi in n |-*; cbn; trivial.
    - now left.
    - apply VectorLib.Forall_dec, ForallT_general, bounded_indi_term_dec.
    - now apply and_dec.
  Qed.

  Lemma find_bounded_indi_step n (v : vec term n) :
    (ForallT (fun t => { n | bounded_indi_term n t }) v) -> { n | VectorLib.Forall (bounded_indi_term n) v }.
  Proof.
    intros [v' H]%ForallT_translate. induction v; dependent elimination v'; cbn in *.
    - now exists 0.
    - destruct (IHv t) as [h1 H1]. apply H. exists (max h0 h1). split.
      eapply bounded_indi_term_up. 2: apply H. lia. apply Forall_in. intros t' H2.
      eapply Forall_in in H2. eapply bounded_indi_term_up. 2: apply H2. 2: apply H1. lia.
  Qed.

  Lemma find_bounded_func_step n ar (v : vec term n) :
    (ForallT (fun t => { n | bounded_func_term ar n t }) v) -> { n | VectorLib.Forall (bounded_func_term ar n) v }.
  Proof.
    intros [v' H]%ForallT_translate. induction v; dependent elimination v'; cbn in *.
    - now exists 0.
    - destruct (IHv t) as [h1 H1]. apply H. exists (max h0 h1). split.
      eapply bounded_func_term_up. 2: apply H. lia. apply Forall_in. intros t' H2.
      eapply Forall_in in H2. eapply bounded_func_term_up. 2: apply H2. 2: apply H1. lia.
  Qed.

  Lemma find_bounded_indi_term t :
    { n | bounded_indi_term n t }.
  Proof.
    induction t using term_rect'; cbn.
    - exists (S n). lia.
    - apply find_bounded_indi_step, IH.
  Qed.

  Lemma find_bounded_func_term ar t :
    { n | bounded_func_term ar n t }.
  Proof.
    induction t using term_rect; cbn.
    - now exists 0.
    - edestruct find_bounded_func_step as [n' H]. apply IH. exists (max (S n) n').
      split. lia. apply Forall_in. intros t H1. eapply Forall_in in H.
      eapply bounded_func_term_up. 2: apply H. lia. easy.
    - apply find_bounded_func_step, IH.
  Qed.

  Lemma find_bounded_indi phi :
    { n | bounded_indi n phi }.
  Proof.
    induction phi; cbn.
    - now exists 0.
    - apply find_bounded_indi_step, ForallT_general, find_bounded_indi_term.
    - destruct IHphi1 as [n1 IHphi1]. destruct IHphi2 as [n2 IHphi2].
      exists (max n1 n2). split; eapply bounded_indi_up. 2: apply IHphi1. lia.
      2: apply IHphi2. lia.
    - destruct IHphi as [n IHphi]. exists n. eapply bounded_indi_up. 2: apply IHphi. lia.
    - apply IHphi.
    - apply IHphi.
  Qed.

  Lemma find_bounded_func ar phi :
    { n | bounded_func ar n phi }.
  Proof.
    induction phi; cbn.
    - now exists 0.
    - apply find_bounded_func_step, ForallT_general, find_bounded_func_term.
    - destruct IHphi1 as [n1 IHphi1]. destruct IHphi2 as [n2 IHphi2].
      exists (max n1 n2). split; eapply bounded_func_up. 2: apply IHphi1. lia.
      2: apply IHphi2. lia.
    - apply IHphi.
    - destruct IHphi as [n' IHphi]. exists n'. destruct (PeanoNat.Nat.eq_dec ar n) as [->|].
      + left. split. reflexivity. eapply bounded_func_up. 2: apply IHphi. lia.
      + right. now split.
    - apply IHphi.
  Qed.

  Lemma find_bounded_pred ar phi :
    { n | bounded_pred ar n phi }.
  Proof.
    induction phi; cbn.
    - now exists 0.
    - destruct p; cbn. exists (S n); lia. now exists 0.
    - destruct IHphi1 as [n1 IHphi1]. destruct IHphi2 as [n2 IHphi2].
      exists (max n1 n2). split; eapply bounded_pred_up. 2: apply IHphi1. lia.
      2: apply IHphi2. lia.
    - apply IHphi.
    - apply IHphi.
    - destruct IHphi as [n' IHphi]. exists n'. destruct (PeanoNat.Nat.eq_dec ar n) as [->|].
      + left. split. reflexivity. eapply bounded_pred_up. 2: apply IHphi. lia.
      + right. now split.
  Qed.

  Lemma find_bounded_indi_L (A : list SOL.form) :
    { n : nat | bounded_indi_L n A }.
  Proof.
    induction A.
    - exists 0. now intros ? H.
    - destruct IHA as [n IHA]. destruct (find_bounded_indi a) as [n' H]. exists (max n n').
      intros phi [->|]; eapply bounded_indi_up. 2: apply H. lia. 2: apply IHA. lia. easy.
  Qed.

  Lemma find_bounded_func_L ar (A : list SOL.form) :
    { n : nat | bounded_func_L ar n A }.
  Proof.
    induction A.
    - exists 0. now intros ? H.
    - destruct IHA as [n IHA]. destruct (find_bounded_func ar a) as [n' H]. exists (max n n').
      intros phi [->|]; eapply bounded_func_up. 2: apply H. lia. 2: apply IHA. lia. easy.
  Qed.

  Lemma find_bounded_pred_L ar (A : list SOL.form) :
    { n : nat | bounded_pred_L ar n A }.
  Proof.
    induction A.
    - exists 0. now intros ? H.
    - destruct IHA as [n IHA]. destruct (find_bounded_pred ar a) as [n' H]. exists (max n n').
      intros phi [->|]; eapply bounded_pred_up. 2: apply H. lia. 2: apply IHA. lia. easy.
  Qed.

  Lemma funcfree_bounded_func_term t :
    funcfreeTerm t -> forall x ar, bounded_func_term x ar t.
  Proof.
    intros F x ar. induction t; cbn in *; try easy.
    eapply Forall_ext_Forall. apply IH. apply F.
  Qed.

  Lemma funcfree_bounded_func phi :
    funcfree phi -> forall x ar, bounded_func x ar phi.
  Proof.
    intros F. induction phi; intros x ar'; cbn. 1,3-6: firstorder.
    apply Forall_in. intros t H. apply funcfree_bounded_func_term.
    eapply Forall_in in F. apply F. easy.
  Qed.

  Lemma firstorder_bounded_func phi :
    first_order phi -> forall x ar, bounded_func x ar phi.
  Proof.
    intros F. apply funcfree_bounded_func, firstorder_funcfree, F.
  Qed.

  Lemma firstorder_bounded_pred phi :
    first_order phi -> forall x ar, bounded_pred x ar phi.
  Proof.
    induction phi; firstorder. now destruct p.
  Qed.

End Bounded.

Section ArityBounds.

  Context {Σf : funcs_signature}.
  Context {Σp : preds_signature}.
  Context {ops : operators}.

  Fixpoint arity_bounded_p ar (phi : form) := match phi with
    | @atom _ _ _ ar' (var_pred x) _ => ar > ar'
    | atom (pred _) _ => True
    | fal => True
    | bin _ phi psi => arity_bounded_p ar phi /\ arity_bounded_p ar psi
    | quant_indi _ phi => arity_bounded_p ar phi
    | quant_func _ _ phi => arity_bounded_p ar phi
    | quant_pred _ ar' phi => arity_bounded_p ar phi
  end.

  Lemma arity_bounded_p_up ar ar' phi :
    ar' >= ar -> arity_bounded_p ar phi -> arity_bounded_p ar' phi.
  Proof.
    revert ar' ar. induction phi; intros m n' H1 H2; cbn in *. easy.
    destruct p. lia. easy. all: firstorder.
  Qed.

  (* Compute arity bounds *)

  Fixpoint find_arity_bound_p (phi : form) := match phi with
    | @atom _ _ _ ar _ _ => S ar
    | fal => 0
    | bin _ phi psi => max (find_arity_bound_p phi) (find_arity_bound_p psi)
    | quant_indi _ phi => find_arity_bound_p phi
    | quant_func _ ar' phi => find_arity_bound_p phi
    | quant_pred _ _ phi => find_arity_bound_p phi
  end.

  Lemma find_arity_bound_p_correct phi :
    arity_bounded_p (find_arity_bound_p phi) phi.
  Proof.
    induction phi; cbn. easy. destruct p; lia. split; eapply arity_bounded_p_up.
    2: apply IHphi1. 3: apply IHphi2. lia. lia. all: apply IHphi.
  Qed.

  Lemma bounded_pred_arity_bound ar ar' phi :
    arity_bounded_p ar phi -> ar' >= ar -> forall b, bounded_pred ar' b phi.
  Proof.
    intros H1 H2. induction phi; intros b'; cbn.
    - easy.
    - destruct p. right. cbn in H1. lia. easy.
    - split. apply IHphi1, H1. apply IHphi2, H1.
    - apply IHphi, H1.
    - apply IHphi, H1.
    - destruct (PeanoNat.Nat.eq_dec ar' n).
      + left. split. easy. now apply IHphi.
      + right. split. easy. now apply IHphi.
  Qed.

End ArityBounds.

(** *** Discreteness *)

Section EqDec.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {ops : operators}.

  Context `{syms_eq_dec : eq_dec syms}.
  Context `{preds_eq_dec : eq_dec preds}.
  Context `{binop_eq_dec : eq_dec binop}.
  Context `{quantop_eq_dec : eq_dec quantop}.

  Lemma function_eq_dep ar (f1 f2 : function ar) :
    eq_dep _ _ ar f1 ar f2 <-> f1 = f2.
  Proof.
    rewrite <- eq_sigT_iff_eq_dep. split.
    - intros H%inj_pairT2. exact H. lia.
    - now intros ->.
  Qed.

  Lemma predicate_eq_dep ar (P1 P2 : predicate ar) :
    eq_dep _ _ ar P1 ar P2 <-> P1 = P2.
  Proof.
    rewrite <- eq_sigT_iff_eq_dep. split.
    - intros H%inj_pairT2. exact H. lia.
    - now intros ->.
  Qed.

  Lemma dec_function_dep ar1 ar2 (f1 : function ar1) (f2 : function ar2) :
    dec (eq_dep _ _ ar1 f1 ar2 f2).
  Proof.
    destruct f1, f2.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|].
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|].
      left; now apply function_eq_dep.
      right. intros H%eq_sigT_iff_eq_dep%inj_pairT2; try congruence. lia.
      right; intros H%eq_sigT_iff_eq_dep; congruence.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_syms f)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pairT2; try congruence. lia.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_syms f)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pairT2; try congruence. lia.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (syms_eq_dec f f0) as [->|].
      left; now apply function_eq_dep.
      right. now intros [=]%eq_sigT_iff_eq_dep.
  Qed.

  Lemma dec_predicate_dep ar1 ar2 (P1 : predicate ar1) (P2 : predicate ar2) :
    dec (eq_dep _ _ ar1 P1 ar2 P2).
  Proof.
    destruct P1, P2.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|].
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|].
      left; now apply predicate_eq_dep.
      right. intros H%eq_sigT_iff_eq_dep%inj_pairT2; try congruence. lia.
      right; intros H%eq_sigT_iff_eq_dep; congruence.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_preds P)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pairT2; try congruence. lia.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (PeanoNat.Nat.eq_dec ar (ar_preds P)) as [->|].
      right. intros H%eq_sigT_iff_eq_dep%inj_pairT2; try congruence. lia.
      right. intros H%eq_sigT_iff_eq_dep. inversion H.
    - destruct (preds_eq_dec P P0) as [->|].
      left; now apply predicate_eq_dep.
      right. now intros [=]%eq_sigT_iff_eq_dep.
  Qed.

  Instance function_eq_dec ar :
    eq_dec (function ar).
  Proof.
    intros f1 f2. destruct (dec_function_dep _ _ f1 f2).
    - left. now apply function_eq_dep.
    - right. now intros H%function_eq_dep.
  Qed.

  Instance predicate_eq_dec ar :
    eq_dec (predicate ar).
  Proof.
    intros P1 P2. destruct (dec_predicate_dep _ _ P1 P2).
    - left. now apply predicate_eq_dep.
    - right. now intros H%predicate_eq_dep.
  Qed.

  Global Instance term_eq_dec :
    eq_dec term.
  Proof.
    unfold eq_dec. fix IH 1. intros [] []; try (right; congruence).
    - destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. now left. right; congruence.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|]. 2: right; congruence.
      destruct (function_eq_dec ar0 f f0) as [->|].
      + assert ({v = v0} + {v <> v0}) as [->|]. {
          clear f0. induction v; dependent elimination v0. now left.
          destruct (IH h h0) as [->|]. 2: right; congruence.
          destruct (IHv t) as [->|]. now left. right. intros H. apply n.
          enough (Vector.tl (Vector.cons term h0 n0 v) = Vector.tl (Vector.cons term h0 n0 t)) by easy.
          now rewrite H. }
        now left. right. intros H. apply n. inversion H.
        apply inj_pairT2 in H1. exact H1. lia.
      + right. intros H. apply n. inversion H.
        apply inj_pairT2 in H1. exact H1. lia.
  Qed.

  Global Instance form_eq_dec :
    eq_dec form.
  Proof.
    unfold eq_dec. induction x; intros []; try (right; congruence).
    - now left.
    - destruct (PeanoNat.Nat.eq_dec ar ar0) as [->|]. 2: right; congruence.
      destruct (predicate_eq_dec ar0 p p0) as [->|].
      + assert ({v = v0} + {v <> v0}) as [->|]. {
          clear p0. induction v; dependent elimination v0. now left.
          destruct (term_eq_dec h h0) as [->|]. 2: right; congruence.
          destruct (IHv t) as [->|]. now left. right. intros H. apply n.
          enough (Vector.tl (Vector.cons term h0 n0 v) = Vector.tl (Vector.cons term h0 n0 t)) by easy.
          now rewrite H. }
        now left. right. intros H. apply n. inversion H.
        apply inj_pairT2 in H1. exact H1. lia.
      + right. intros H. apply n. inversion H. apply inj_pairT2 in H1. exact H1. lia.
    - destruct (binop_eq_dec b b0) as [->|]. 2: right; congruence.
      destruct (IHx1 f) as [->|]. 2: right; congruence.
      destruct (IHx2 f0) as [->|]. now left. right; congruence.
    - destruct (quantop_eq_dec q q0) as [->|]. 2: right; congruence.
      destruct (IHx f) as [->|]. now left. right; congruence.
    - destruct (quantop_eq_dec q q0) as [->|]. 2: right; congruence.
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. 2: right; congruence.
      destruct (IHx f) as [->|]. now left. right; congruence.
    - destruct (quantop_eq_dec q q0) as [->|]. 2: right; congruence.
      destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. 2: right; congruence.
      destruct (IHx f) as [->|]. now left. right; congruence.
  Qed.

End EqDec.

(** *** Enumerability *)

Import ListNotations.

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Variable L_Funcs : nat -> list syms.
  Hypothesis enum_Funcs : list_enumerator__T L_Funcs syms.

  Variable L_Preds : nat -> list preds.
  Hypothesis enum_Preds : list_enumerator__T L_Preds preds.

  Variable L_binop : nat -> list binop.
  Hypothesis enum_binop : list_enumerator__T L_binop binop.

  Variable L_quantop : nat -> list quantop.
  Hypothesis enum_quantop : list_enumerator__T L_quantop quantop.

  Fixpoint vecs_from {X} (A : list X) (n : nat) : list (vec X n) :=
    match n with
    | 0 => [Vector.nil X]
    | S n => [ Vector.cons X x _ v | (x, v) ∈ (A × vecs_from A n) ]
    end.

  Fixpoint L_nat n : list nat := match n with
    | 0 => [0]
    | S n => S n :: L_nat n
  end.

  Fixpoint L_term n : list term := match n with
    | 0 => []
    | S n => L_term n ++ var_indi n ::
                   concat [[ func (@var_func _ x ar) v | v ∈ vecs_from (L_term n) ar ] | (x, ar) ∈ (L_nat n × L_nat n) ]
                ++ concat [[ func (@sym _ f) v | v ∈ vecs_from (L_term n) (ar_syms f) ] | f ∈ L_T n]
  end.

  Fixpoint L_form n : list form := match n with
    | 0 => [fal]
    | S n => L_form n
                ++ concat [[ atom (var_pred x ar) v | v ∈ vecs_from (L_term n) ar ] | (x, ar) ∈ (L_nat n × L_nat n) ]
                ++ concat [[ atom (pred P) v | v ∈ vecs_from (L_term n) (ar_preds P) ] | P ∈ L_T n]
                ++ concat ([ [ bin op phi psi | (phi, psi) ∈ (L_form n × L_form n) ] | op ∈ L_T n])
                ++ concat ([ [ quant_indi op phi | phi ∈ L_form n ] | op ∈ L_T n])
                ++ concat ([ [ quant_func op ar phi | phi ∈ L_form n ] | (op, ar) ∈ (L_T n × L_nat n)])
                ++ concat ([ [ quant_pred op ar phi | phi ∈ L_form n ] | (op, ar) ∈ (L_T n × L_nat n)])
  end.

  Lemma L_nat_correct n m :
    m <= n -> m el L_nat n.
  Proof.
    induction n.
    - intros H. left. lia.
    - intros H. cbn. assert (m = S n \/ m <= n) as [] by lia; firstorder.
  Qed.

  Lemma vecs_from_correct X (A : list X) (n : nat) (v : vec X n) :
    VectorLib.Forall (fun x => x el A) v <-> v el vecs_from A n.
  Proof.
    induction n; cbn.
    - split.
      + intros. left. now dependent elimination v.
      + now intros [<-|[]].
    - split.
      + intros. dependent elimination v. in_collect (h, t); destruct (IHn t).
        apply H. apply H0. apply H.
      + intros Hv. apply in_map_iff in Hv as ([h v'] & <- & (? & ? & [= <- <-] & ? & ?) % list_prod_in).
        split. easy. destruct (IHn v'). now apply H2.
  Qed.

  Lemma vec_forall_cml X (L : nat -> list X) n (v : vec X n) :
    cumulative L -> (VectorLib.Forall (fun x => exists m, x el L m) v) -> exists m, v el vecs_from (L m) n.
  Proof.
    intros HL Hv. induction v; cbn.
    - exists 0. now left.
    - destruct IHv as [m H], Hv as [[m' H'] Hv]. easy.
      exists (m + m'). in_collect (h, v).
      apply (cum_ge' (n:=m')); intuition lia.
      apply vecs_from_correct. rewrite <- vecs_from_correct in H.
      eapply Forall_ext. 2: apply H. cbn.
      intros x Hx. apply (cum_ge' (n:=m)). all: eauto. lia.
  Qed.

  Lemma L_term_cml :
    cumulative L_term.
  Proof.
    intros ?; cbn; eauto.
  Qed.

  Lemma enum_term :
    list_enumerator__T L_term term.
  Proof with eapply cum_ge'; eauto; lia.
    intros t. induction t.
    - exists (S n); cbn. auto.
    - apply vec_forall_cml in IH as [m H]. 2: exact L_term_cml.
      exists (S (m + n + ar)); cbn. in_app 3. eapply in_concat_iff. eexists. split.
      2: in_collect (n, ar). 2,3: apply L_nat_correct; lia.
      in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
      2: apply H. cbn. intros...
    - apply vec_forall_cml in IH as [m H]. 2: exact L_term_cml.
      destruct (el_T f) as [m' H']. exists (S (m + m')); cbn.
      in_app 4. eapply in_concat_iff. eexists. split. 2: in_collect f...
      in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
      2: apply H. cbn. intros...
  Qed.

  Lemma enum_form :
    list_enumerator__T L_form form.
  Proof with eapply cum_ge'; eauto; lia.
    intros phi. induction phi.
    - exists 0. now left.
    - destruct (vec_forall_cml term L_term _ v) as [m H]; eauto.
      + clear p. induction v. easy. split. apply enum_term. apply IHv.
      + destruct p; cbn.
        * exists (S (m + n + ar)); cbn. in_app 2. eapply in_concat_iff.
          eexists. split. 2: in_collect (n, ar). 2,3: apply L_nat_correct; lia.
          in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
          2: apply H. cbn. intros...
        * destruct (el_T P) as [m']. exists (S (m + m')); cbn. in_app 3.
          eapply in_concat_iff. eexists. split. 2: in_collect P...
          in_collect v. rewrite <- vecs_from_correct in H |-*. eapply Forall_ext.
          2: apply H. cbn. intros...
    - destruct (el_T b) as [m], IHphi1 as [m1], IHphi2 as [m2].
      exists (1 + m + m1 + m2); cbn. in_app 4. apply in_concat. eexists. split.
      in_collect b... in_collect (phi1, phi2)...
    - destruct (el_T q) as [m], IHphi as [m']. exists (S (m + m')); cbn. in_app 5.
      apply in_concat. eexists. split. in_collect q... in_collect phi...
    - destruct (el_T q) as [m], IHphi as [m']. exists (S (m + m' + n)); cbn.
      in_app 6. apply in_concat. eexists. split. in_collect (q, n).
      eapply cum_ge'; eauto; lia. apply L_nat_correct; lia. in_collect phi...
    - destruct (el_T q) as [m], IHphi as [m']. exists (S (m + m' + n)); cbn.
      in_app 7. apply in_concat. eexists. split. in_collect (q, n).
      eapply cum_ge'; eauto; lia. apply L_nat_correct; lia. in_collect phi...
  Qed.

End Enumerability.

Section Enumerability'.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_pred : preds_signature}.
  Context {ops : operators}.

  Hypothesis enumerable_funcs : enumerable__T syms.
  Hypothesis enumerable_preds : enumerable__T preds.
  Hypothesis enumerable_binop : enumerable__T binop.
  Hypothesis enumerable_quantop : enumerable__T quantop.

  Lemma form_enumerable :
    enumerable__T form.
  Proof.
    apply enum_enumT.
    apply enum_enumT in enumerable_funcs as [Lf HLf].
    apply enum_enumT in enumerable_preds as [Lp HLp].
    apply enum_enumT in enumerable_binop as [Lb HLb].
    apply enum_enumT in enumerable_quantop as [Lq HLq].
    exists (L_form Lf HLf Lp HLp Lb HLb Lq HLq). apply enum_form.
  Qed.

  Lemma form_enumerable_firstorder :
    enumerable (fun phi => first_order phi).
  Proof.
    apply enumerable_decidable. apply form_enumerable. apply decidable_if, first_order_dec.
  Qed.

  Lemma form_enumerable_funcfree :
    enumerable (fun phi => funcfree phi).
  Proof.
    apply enumerable_decidable. apply form_enumerable. apply decidable_if, funcfree_dec.
  Qed.

End Enumerability'.

Notation "$ x" := (var_indi x) (at level 5, format "$ '/' x").
Notation "i$ x" := (var_indi x) (at level 5, format "i$ '/' x").
Notation "f$ x" := (func (var_func x)) (at level 5, format "f$ '/' x").
Notation "p$ x" := (atom (var_pred x)) (at level 5, format "p$ '/' x").


Set Implicit Arguments.

Require Import List.

Section Filter.

Variable A : Type.

Lemma In_filter_In :
  forall (f : A -> bool) x l l',
    filter f l = l' ->
    In x l' -> In x l.
Proof.
  intros. subst.
  eapply filter_In.
  instantiate (1 := f).
  assumption.
Qed.

End Filter.


(* 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.analysis Require Import functions.
Require Import ssr_ext euclidean rigid skew.

(******************************************************************************)
(*                  Derivatives of time-varying matrices                      *)
(*                                                                            *)
(*    derive1mx M(t) == the derivative matrix of M(t)                         *)
(*      ang_vel_mx M == angular velocity matrix of M(t) 　　　　　　　　　　　　  *)
(*                                                                            *)
(******************************************************************************)

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

Local Open Scope ring_scope.

(* NB: PR to analysis in progress *)
Lemma derive1_cst (R : numFieldType) (V : normedModType R) (k : V) t :
  (cst k)^`() t = 0.
Proof. by rewrite derive1E derive_val. Qed.

(* TODO: see coord_continuous in normedtype.v *)
Lemma coord_continuous (R : numDomainType) (K : normedModType R) m n i j :
  continuous (fun M : 'M[K]_(m, n) => M i j).
Proof.
move=> /= M s /= /nbhs_normP => -[e e0 es].
by apply/nbhs_ballP; exists e => //= N MN; exact/es/MN.
Qed.

Lemma mx_lin1N (R : ringType) n (M : 'M[R]_n) :
  mx_lin1 (- M) = -1 \*: mx_lin1 M :> ( _ -> _).
Proof. by rewrite funeqE => v /=; rewrite scaleN1r mulmxN. Qed.

Lemma mxE_funeqE (R : realFieldType) (V W : normedModType R)
    n m (f : V -> 'I_n -> 'I_m -> W) i j :
  (fun x => (\matrix_(i < n, j < m) (f x i j)) i j) =
  (fun x => f x i j).
Proof. by rewrite funeqE => ?; rewrite mxE. Qed.

Section derive_mx.

Variable (R : realFieldType) (V W : normedModType R).

Definition derivable_mx m n (M : R -> 'M[W]_(m, n)) t v :=
  forall i j, derivable (fun x : R^o => (M x) i j) t v.

Definition derive1mx m n (M : R -> 'M[W]_(m, n)) := fun t =>
  \matrix_(i < m, j < n) (derive1 (fun x => M x i j) t : W).

Lemma derive1mxE m n t (f : 'I_m -> 'I_n -> R -> W) :
  derive1mx (fun x => \matrix_(i, j) f i j x) t =
  \matrix_(i, j) (derive1 (f i j) t : W).
Proof.
rewrite /derive1mx; apply/matrixP => ? ?; rewrite !mxE; congr (derive1 _ t).
rewrite funeqE => ?; by rewrite mxE.
Qed.

Variables m n : nat.
Implicit Types M N : R -> 'M[W]_(m, n).

Lemma derivable_mxD M N t : derivable_mx M t 1 -> derivable_mx N t 1 ->
  derivable_mx (fun x => M x + N x) t 1.
Proof.
move=> Hf Hg a b. evar (f1 : R -> W). evar (f2 : R -> W).
rewrite (_ : (fun x => _) = f1 + f2); last first.
  rewrite funeqE => x; rewrite -[RHS]/(f1 x + f2 x) mxE /f1 /f2; reflexivity.
rewrite {}/f1 {}/f2; exact: derivableD.
Qed.

Lemma derivable_mxN M t : derivable_mx M t 1 ->
  derivable_mx (fun x => - M x) t 1.
Proof.
move=> HM a b.
rewrite (_ : (fun x => _) = (fun x => - (M x a b))); first exact: derivableN.
by rewrite funeqE => ?; rewrite mxE.
Qed.

Lemma derivable_mxB M N t : derivable_mx M t 1 -> derivable_mx N t 1 ->
  derivable_mx (fun x => M x - N x) t 1.
Proof. move=> Hf Hg; apply derivable_mxD => //; exact: derivable_mxN. Qed.

Lemma trmx_derivable M t v :
  derivable_mx M t v = derivable_mx (fun x => (M x)^T) t v.
Proof.
rewrite propeqE; split => [H j i|H i j].
by rewrite (_ : (fun _ => _) = (fun x => M x i j)) // funeqE => z; rewrite mxE.
by rewrite (_ : (fun _ => _) = (fun x => (M x)^T j i)) // funeqE => z; rewrite mxE.
Qed.

Lemma derivable_mx_row M t i :
  derivable_mx M t 1 -> derivable_mx (row i \o M) t 1.
Proof.
move=> H a b.
by rewrite (_ : (fun _ => _) = (fun x => (M x) i b)) // funeqE => z; rewrite mxE.
Qed.

Lemma derivable_mx_col M t i :
  derivable_mx M t 1 -> derivable_mx (trmx \o col i \o M) t 1.
Proof.
move=> H a b.
by rewrite (_ : (fun _ => _) = (fun x => (M x) b i)) // funeqE => z; rewrite 2!mxE.
Qed.

Lemma derivable_mx_cst (P : 'M[W]_(m, n)) t : derivable_mx (cst P) t 1.
Proof. move=> a b; by rewrite (_ : (fun x : R => _) = cst (P a b)). Qed.

Lemma derive1mx_cst (P : 'M[W]_(m, n)) : derive1mx (cst P) = cst 0.
Proof.
rewrite /derive1mx funeqE => t; apply/matrixP => i j; rewrite !mxE.
by rewrite (_ : (fun x : R => _) = (cst (P i j))) // derive1_cst.
Qed.

Lemma derive1mx_tr M t : derive1mx (trmx \o M) t = (derive1mx M t)^T.
Proof.
apply/matrixP => i j; rewrite !mxE.
by rewrite (_ : (fun _ => _) = (fun t => M t j i)) // funeqE => ?; rewrite mxE.
Qed.

Lemma derive1mxD M N t : derivable_mx M t 1 -> derivable_mx N t 1 ->
  derive1mx (M + N) t = derive1mx M t + derive1mx N t.
Proof.
move=> Hf Hg; apply/matrixP => a b; rewrite /derive1mx !mxE.
rewrite (_ : (fun _ => _) = (fun x => M x a b) \+ fun x => N x a b); last first.
  by rewrite funeqE => ?; rewrite mxE.
by rewrite derive1E deriveD 2?{1}derive1E.
Qed.

Lemma derive1mxN M t : derivable_mx M t 1 -> derive1mx (- M) t = - derive1mx M t.
Proof.
move=> Hf; apply/matrixP => a b.
rewrite !mxE [in RHS]derive1E -deriveN; last by [].
by rewrite -derive1E; f_equal; rewrite funeqE => x; rewrite mxE.
Qed.

Lemma derive1mxB M N t : derivable_mx M t 1 -> derivable_mx N t 1 ->
  derive1mx (M - N) t = derive1mx M t - derive1mx N t.
Proof.
by move=> Hf Hg; rewrite derive1mxD ?derive1mxN; last by exact: derivable_mxN.
Qed.

End derive_mx.

Section derive_mx_R.

Variables (R : realFieldType) (m n k : nat).

Lemma derivable_mxM (f : R -> 'M[R^o]_(m, k)) (g : R -> 'M[R^o]_(k, n)) t :
  derivable_mx f t 1 -> derivable_mx g t 1 -> derivable_mx (fun x => f x *m g x) t 1.
Proof.
move=> Hf Hg a b. evar (f1 : 'I_k -> R^o -> R^o).
rewrite (_ : (fun x => _) = (\sum_i f1 i)); last first.
  rewrite funeqE => t'; rewrite mxE fct_sumE; apply: eq_bigr => k0 _.
  rewrite /f1; reflexivity.
rewrite {}/f1; apply: derivable_sum => k0.
evar (f1 : R^o -> R). evar (f2 : R -> R).
rewrite (_ : (fun t' => _) = f1 * f2); last first.
  rewrite funeqE => t'; rewrite -[RHS]/(f1 t' * f2 t') /f1 /f2; reflexivity.
rewrite {}/f1 {}/f2; exact: derivableM.
Qed.

End derive_mx_R.

Section derive_mx_SE.

Variables (R : rcfType) (M : R -> 'M[R^o]_4).

Lemma derivable_rot_of_hom : (forall t, derivable_mx M t 1) ->
  forall x, derivable_mx (@rot_of_hom _ \o M) x 1.
Proof.
move=> H x i j.
rewrite (_ : (fun _ => _) = (fun y => (M y) (lshift 1 i) (lshift 1 j))); last first.
  rewrite funeqE => y; by rewrite !mxE.
exact: H.
Qed.

Lemma derive1mx_SE : (forall t, M t \in 'SE3[R]) ->
  forall t, derive1mx M t = block_mx
    (derive1mx (@rot_of_hom [rcfType of R^o] \o M) t) 0
    (derive1mx (@trans_of_hom [rcfType of R^o] \o M) t) 0.
Proof.
move=> MSE t.
rewrite block_mxEh.
rewrite {1}(_ : M = (fun x => hom (rot_of_hom (M x)) (trans_of_hom (M x)))); last first.
  rewrite funeqE => x; by rewrite -(SE3E (MSE x)).
apply/matrixP => i j.
rewrite 2!mxE; case: splitP => [j0 jj0|j0 jj0].
  rewrite (_ : j = lshift 1 j0); last exact/val_inj.
  rewrite mxE; case: splitP => [i1 ii1|i1 ii1].
    rewrite (_ : i = lshift 1 i1); last exact/val_inj.
    rewrite mxE; congr (derive1 _ t); rewrite funeqE => x.
    by rewrite /hom (block_mxEul _ _ _ _ i1 j0).
  rewrite (_ : i = rshift 3 i1); last exact/val_inj.
  rewrite mxE; congr (derive1 _ t); rewrite funeqE => x.
  by rewrite /hom (block_mxEdl (rot_of_hom (M x))).
rewrite (_ : j = rshift 3 j0) ?mxE; last exact/val_inj.
rewrite (ord1 j0).
case: (@splitP 3 1 i) => [i0 ii0|i0 ii0].
  rewrite (_ : i = lshift 1 i0); last exact/val_inj.
  rewrite (_ : (fun _ => _) = (fun=> 0)) ?derive1_cst ?mxE //.
  rewrite funeqE => x; by rewrite /hom (block_mxEur (rot_of_hom (M x))) mxE.
rewrite (_ : i = rshift 3 i0); last exact/val_inj.
rewrite (_ : (fun _ => _) = (fun=> 1)) ?derive1_cst // (ord1 i0) ?mxE //.
by rewrite funeqE => x; rewrite /hom (block_mxEdr (rot_of_hom (M x))) mxE.
Qed.

End derive_mx_SE.

Section row_belast.

(* TODO: move? *)
Definition row_belast {R : ringType} n (v : 'rV[R]_n.+1) : 'rV[R]_n :=
  \row_(i < n) (v ``_ (widen_ord (leqnSn n) i)).

(* TODO: move? *)
Lemma row_belast_last (R : ringType) n (r : 'rV[R]_n.+1) H :
  r = castmx (erefl, H) (row_mx (row_belast r) (r ``_ ord_max)%:M).
Proof.
apply/rowP => i; rewrite castmxE mxE.
case: fintype.splitP => /= [j Hj|[] [] //= ? ni]; rewrite mxE /=.
  congr (_ ``_ _); exact: val_inj.
rewrite mulr1n; congr (_ ``_ _); apply val_inj; by rewrite /= ni addn0.
Qed.

Lemma derivable_row_belast (R : realFieldType) n (u : R -> 'rV[R^o]_n.+1) (t : R) (v : R):
  derivable_mx u t v -> derivable_mx (fun x => row_belast (u x)) t v.
Proof.
move=> H i j; move: (H ord0 (widen_ord (leqnSn n) j)) => {H}.
set f := fun _ => _. set g := fun _ => _.
by rewrite (_ : f = g) // funeqE => x; rewrite /f /g mxE.
Qed.

Lemma dotmul_belast {R : realFieldType} n (u : 'rV[R]_n.+1) (v1 : 'rV[R]_n) v2 H :
  u *d castmx (erefl 1%nat, H) (row_mx v1 v2) =
    u *d castmx (erefl 1%nat, H) (row_mx v1 0%:M) +
    u *d castmx (erefl 1%nat, H) (row_mx 0 v2).
Proof.
rewrite -dotmulDr; congr dotmul; apply/matrixP => i j; rewrite !(castmxE,mxE) /=.
case: fintype.splitP => [k /= jk|[] [] // ? /= jn]; by rewrite !(mxE,addr0,add0r,mul0rn).
Qed.

Lemma derive1mx_dotmul_belast (R : realFieldType) n (u v : R^o -> 'rV[R^o]_n.+1) t :
  let u' x := row_belast (u x) in let v' x := row_belast (v x) in
  u' t *d derive1mx v' t + (u t)``_ord_max *: derive (fun x => (v x)``_ord_max) t 1 =
  u t *d derive1mx v t.
Proof.
move=> u' v'.
rewrite (row_belast_last (derive1mx v t)) ?addn1 // => ?.
rewrite dotmul_belast; congr (_ + _).
  rewrite 2!dotmulE [in RHS]big_ord_recr /=.
  rewrite castmxE mxE /=; case: fintype.splitP => [j /= /eqP/negPn|j _].
    by rewrite (gtn_eqF (ltn_ord j)).
  rewrite !mxE (_ : _ == _); last by apply/eqP/val_inj => /=; move: j => [[] ?].
  rewrite mulr0 addr0; apply/eq_bigr => i _; rewrite castmxE !mxE; congr (_ * _).
  case: fintype.splitP => [k /= ik|[] [] //= ?]; rewrite !mxE.
    f_equal.
    rewrite funeqE => x; rewrite /v' !mxE; congr ((v _) _ _); by apply/val_inj.
  rewrite addn0 => /eqP/negPn; by rewrite (ltn_eqF (ltn_ord i)).
apply/esym.
rewrite dotmulE big_ord_recr /= (eq_bigr (fun=> 0)); last first.
  move=> i _.
  rewrite !castmxE !mxE; case: fintype.splitP => [j /= ij| [] [] //= ?].
    by rewrite mxE mulr0.
  rewrite addn0 => /eqP/negPn; by rewrite (ltn_eqF (ltn_ord i)).
rewrite sumr_const mul0rn add0r castmxE /=; congr (_ * _); rewrite !mxE.
case: fintype.splitP => [j /= /eqP/negPn | [] [] //= ? Hn].
  by rewrite (gtn_eqF (ltn_ord j)).
by rewrite mxE derive1E (_ : _ == _).
Qed.

End row_belast.

(* TODO: could be derived from more generic lemmas about bilinearity in derive.v? *)
Section product_rules.

Lemma derive1mx_dotmul (R : realFieldType) n (u v : R^o -> 'rV[R^o]_n) (t : R^o) :
  derivable_mx u t 1 -> derivable_mx v t 1 ->
  derive1 (fun x => u x *d v x : R^o) t =
  derive1mx u t *d v t + u t *d derive1mx v t.
Proof.
move=> U V.
evar (f : R -> R); rewrite (_ : (fun x : R => u x *d v x : R^o) = f); last first.
  rewrite funeqE => x /=; exact: dotmulE.
rewrite derive1E {}/f.
set f := fun i : 'I__ => fun x => ((u x) ``_ i * (v x) ``_ i).
rewrite (_ : (fun _ : R => _) = \sum_(k < _) f k); last first.
  by rewrite funeqE => x; rewrite /f /= fct_sumE.
rewrite derive_sum; last by move=> ?; exact: derivableM (U _ _) (V _ _).
rewrite {}/f.
elim: n u v => [|n IH] u v in U V *.
  rewrite big_ord0 (_ : v t = 0) ?dotmulv0 ?add0r; last by apply/rowP => [[]].
  rewrite (_ : u t = 0) ?dotmul0v //; by apply/rowP => [[]].
rewrite [LHS]big_ord_recr /=.
set u' := fun x => row_belast (u x). set v' := fun x => row_belast (v x).
transitivity (derive1mx u' t *d v' t + u' t *d derive1mx v' t +
    derive (fun x => (u x)``_ord_max * (v x)``_ord_max) t 1).
  rewrite -(IH _ _ (derivable_row_belast U) (derivable_row_belast V)).
  apply: f_equal2; last by [].
  apply eq_bigr => i _; congr (derive _ t 1).
  by rewrite funeqE => x; rewrite !mxE.
rewrite (deriveM (U _ _) (V _ _)) /= -!addrA addrC addrA.
rewrite -(addrA (_ + _)) [in RHS]addrC derive1mx_dotmul_belast; congr (_ + _).
by rewrite [in RHS]dotmulC -derive1mx_dotmul_belast addrC dotmulC.
Qed.

Lemma derive1mxM (R : realFieldType) n m p (M : R -> 'M[R^o]_(n, m))
  (N : R^o -> 'M[R^o]_(m, p)) (t : R^o) :
  derivable_mx M t 1 -> derivable_mx N t 1 ->
  derive1mx (fun t => M t *m N t) t =
    derive1mx M t *m N t + M t *m (derive1mx N t).
Proof.
move=> HM HN; apply/matrixP => i j; rewrite ![in LHS]mxE.
rewrite (_ : (fun x => _) = fun x => \sum_k (M x) i k * (N x) k j); last first.
  by rewrite funeqE => x; rewrite !mxE.
rewrite (_ : (fun x => _) =
    fun x => (row i (M x)) *d (col j (N x))^T); last first.
  rewrite funeqE => z; rewrite dotmulE; apply eq_bigr => k _.
  by rewrite 3!mxE.
rewrite (derive1mx_dotmul (derivable_mx_row HM) (derivable_mx_col HN)).
by rewrite [in RHS]mxE; congr (_  + _); rewrite [in RHS]mxE dotmulE;
   apply/eq_bigr => /= k _; rewrite !mxE; apply: f_equal2;
   try by congr (@derive1 _ [normedModType R of R^o] _ t);
          rewrite funeqE => z; rewrite !mxE.
Qed.

Lemma derive1mx_crossmul (R : realFieldType) (u v : R -> 'rV[R^o]_3) t :
  derivable_mx u t 1 -> derivable_mx v t 1 ->
  derive1mx (fun x => (u x *v v x) : 'rV[R^o]_3) t =
  derive1mx u t *v v t + u t *v derive1mx v t.
Proof.
move=> U V.
evar (f : R -> 'rV[R]_3); rewrite (_ : (fun x : R => _) = f); last first.
  rewrite funeqE => x; exact: crossmulE.
rewrite {}/f {1}/derive1mx; apply/rowP => i; rewrite mxE derive1E.
rewrite (mxE_funeqE (fun x : R^o => _)) /= mxE 2!crossmulE !{1}[in RHS]mxE /=.
case: ifPn => [/eqP _|/ifnot0P/orP[]/eqP -> /=];
  rewrite ?derive1E (deriveD (derivableM (U _ _) (V _ _))
    (derivableN (derivableM (U _ _) (V _ _))));
  rewrite (deriveN (derivableM (U _ _) (V _ _))) 2!(deriveM (U _ _) (V _ _));
  rewrite addrCA -!addrA; congr (_ + (_ + _)); by [ rewrite mulrC |
  rewrite opprD addrC; congr (_ + _); rewrite mulrC ].
Qed.

End product_rules.

Section cross_product_matrix.
Import rv3LieAlgebra.Exports.

Lemma differential_cross_product (R : realFieldType) (v : 'rV[R^o]_3) y :
  'd (crossmul v) y = mx_lin1 \S( v ) :> (_ -> _).
Proof.
rewrite (_ : crossmul v = (fun x => x *m \S( v ))); last first.
  by rewrite funeqE => ?; rewrite -spinE.
rewrite (_ : mulmx^~ \S(v) = mulmxr_linear 1 \S(v)); last by rewrite funeqE.
rewrite diff_lin //= => x.
suff : differentiable (mulmxr \S(v)) (x : 'rV[R^o]_3).
  by move/differentiable_continuous.
rewrite (_ : mulmxr \S(v) = (fun z => \sum_i z``_i *: row i \S(v))); last first.
  rewrite funeqE => z; by rewrite -mulmx_sum_row.
set f := fun (i : 'I_3) (z : 'rV_3) => z``_i *: row i \S(v) : 'rV_3.
rewrite (_ : (fun _ => _) = \sum_i f i); last by rewrite funeqE => ?; by rewrite fct_sumE.
apply: differentiable_sum => i.
exact/differentiableZl/differentiable_coord.
Qed.

Lemma differential_cross_product2 (R : realFieldType) (v y : 'rV[R^o]_3) :
  'd (fun x : 'rV[R^o]_3 => x *v v) y = -1 \*: mx_lin1 \S( v ) :> (_ -> _).
Proof.
transitivity ('d (crossmul (- v)) y); last first.
  by rewrite differential_cross_product spinN mx_lin1N.
congr diff.
by rewrite funeqE => /= u; rewrite lieC linearNl.
Qed.

End cross_product_matrix.

(* [sciavicco] p.80-81 *)
Section derivative_of_a_rotation_matrix.

Variables (R : realFieldType) (M : R -> 'M[R^o]_3).

Definition ang_vel_mx t : 'M_3 := (M t)^T * derive1mx M t.

Definition body_ang_vel_mx t : 'M_3 := derive1mx M t *m (M t)^T.

(* angular velocity (a free vector) *)
Definition ang_vel t := unspin (ang_vel_mx t).

Hypothesis MO : forall t, M t \is 'O[ [ringType of R] ]_3.
Hypothesis derivable_M : forall t, derivable_mx M t 1.

Lemma ang_vel_mx_is_so t : ang_vel_mx t \is 'so[ [ringType of R] ]_3.
Proof.
have : (fun t => (M t)^T * M t) = cst 1.
  rewrite funeqE => x; by rewrite -orthogonal_inv // mulVr // orthogonal_unit.
move/(congr1 (fun f => derive1mx f t)); rewrite derive1mx_cst -[cst 0 _]/(0).
rewrite derive1mxM // -?trmx_derivable // derive1mx_tr.
move=> /eqP; rewrite addr_eq0 => /eqP H.
by rewrite antiE /ang_vel_mx trmx_mul trmxK H opprK.
Qed.

Lemma ang_vel_mxE t : ang_vel_mx t = \S( ang_vel t).
Proof. by rewrite /ang_vel unspinK // ang_vel_mx_is_so. Qed.

(* [sciavicco] eqn 3.7 *)
Lemma derive1mx_ang_vel t : derive1mx M t = M t * ang_vel_mx t.
Proof.
move: (ang_vel_mx_is_so t); rewrite antiE -subr_eq0 opprK => /eqP.
rewrite {1 2}/ang_vel_mx trmx_mul trmxK => /(congr1 (fun x => (M t) * x)).
rewrite mulr0 mulrDr !mulrA -{1}(orthogonal_inv (MO t)).
rewrite divrr ?orthogonal_unit // mul1r.
move=> /eqP; rewrite addr_eq0 => /eqP {1}->.
rewrite -mulrA -mulrN -mulrA; congr (_ * _).
move: (ang_vel_mx_is_so t); rewrite antiE -/(ang_vel_mx t) => /eqP ->.
by rewrite /ang_vel_mx trmx_mul trmxK mulmxE.
Qed.

Lemma derive1mx_rot (p' : 'rV[R^o]_3 (* constant vector *)) :
  let p := fun t => p' *m M t in
  forall t, derive1mx p t = ang_vel t *v p t.
Proof.
move=> p t; rewrite /p derive1mxM; last first.
  exact: derivable_M.
  rewrite /derivable_mx => i j; exact: ex_derive.
rewrite derive1mx_cst mul0mx add0r derive1mx_ang_vel mulmxA.
by rewrite -{1}(unspinK (ang_vel_mx_is_so t)) spinE.
Qed.

End derivative_of_a_rotation_matrix.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Subst.

Unset Standard Proposition Elimination Names.

(** Here, we follow exactly Joachimski manuscript *)

Module Joachimski.

Inductive substitution : Set :=
  Dot : term -> substitution -> substitution
| Up : nat -> substitution.

Fixpoint sublift (theta : substitution) : nat -> substitution := fun n =>
  match theta with
  | Dot r theta =>  Dot (lift 0 n r) (sublift theta n)
  | Up m => Up (m+n)
  end.

Notation " th ||\ n " := (sublift th n) (at level 60, no associativity).

Lemma subliftId : forall theta, theta||\0 = theta.
Proof.
induction theta; simpl; auto with arith.
rewrite lift_null; f_equal; auto.
Qed.

Fixpoint sub' (k : nat) : substitution -> term := fun theta =>
 match k,theta with
  | S k, Dot r theta => sub' k theta
  | 0, Dot r theta => r
  | k, Up n => Var (k+n)
  end.

Fixpoint sub (r : term) : substitution -> term := fun theta =>
  match r with
  | Var k => sub' k theta
  | App r s => App (sub r theta) (sub s theta)
  | Abs rho r => Abs rho (sub r (Dot (Var 0) (sublift theta 1)))
  end.

Notation " r {[ th ]} " := (sub r th) (at level 60, no associativity).

Fixpoint comp'  (n : nat) : substitution -> substitution := fun theta =>
  match n,theta with
  | 0,_ => theta
  | S n, Dot r theta => comp' n theta
  | S n, Up m => Up (S n + m)
  end.

Fixpoint comp (theta theta': substitution) {struct theta} : substitution :=
  match theta with
  | Dot r theta => Dot (sub r theta') (comp theta theta')
  | Up n => comp' n theta'
  end.

Notation " th 'o' th' " := (comp th th') (at level 61, left associativity).

Lemma Comp'Eq : forall n m, comp' m (Up n) = Up (m+n).
induction m; simpl; auto with arith.
Qed.

Lemma Sub'Eq : forall n m, sub' m (Up n) = Var (n+m).
induction m; simpl; auto with arith; tomega.
Qed.

Hint Rewrite Sub'Eq Comp'Eq : db.
Ltac ar := autorewrite with db.

Lemma SubliftTwice :
  forall theta n m, (theta ||\ n) ||\ m = theta ||\ n+m.
Proof.
induction theta; simpl; intros.
rewrite lift_lift; f_equal; auto.
tomega.
Qed.

(** To encode the notation (Vect(s).theta),
    a list of term pushed before theta *)

Fixpoint PushList (l : list term) : substitution -> substitution :=
 fun theta =>
  match l with
   | nil => theta
   | r :: l => Dot r (PushList l theta)
  end.

Infix "++" := PushList.

(** 0...(n-1).theta *)

Fixpoint Spare(n : nat) : substitution -> substitution :=
 fun theta =>
  match n with
  | 0 => theta
  | S m => Spare m (Dot (Var m) theta)
  end.

Infix "!!" := Spare (at level 60, no associativity).

(** The initial form of Spare is really bad for reasoning. *)
(** So we prove an equivalence with a special form of PushList. *)

(** Begin Spare/PushList **)

Lemma SparePushList_aux : forall n m theta, m<=n ->
  (map Var (seq 0 n)) ++ theta =
  Spare m (map Var (seq m (n-m)) ++ theta).
Proof.
induction m; intros; simp; auto.
rewrite IHm; simpl; try omega.
replace (n-m) with (S (n- (S m))); simpl; auto; omega.
Qed.

Lemma SparePushList :
 forall n theta, n !! theta = map Var (seq 0 n) ++ theta.
Proof.
 intros; rewrite (SparePushList_aux n n); simpl_arith; auto.
Qed.

Lemma SubPushList1 : forall n l theta, n < length l ->
  Var n {[l++theta]} = nth n l (Var 0).
Proof.
induction n; destruct l; intros; try (inversion H; fail); auto.
simpl in *; rewrite IHn; auto with arith.
Qed.

Lemma SubPushList2 : forall n l theta, length l <= n ->
  Var n {[l++theta]} = Var (n - length l) {[theta]}.
Proof.
induction n; destruct l; intros; auto.
inversion H.
simpl in *; apply IHn; auto with arith.
Qed.

Lemma SubliftPushList : forall n l theta,
 (l++theta) ||\ n = (map (fun r => r |\ [0,n]) l) ++ (theta ||\ n).
Proof.
induction l; simpl; auto.
intros; rewrite IHl; auto.
Qed.

Lemma UpPushList : forall l theta, (Up (length l))o(l++theta) = theta.
Proof.
induction l; simpl; auto.
Qed.

(** End Spare/PushList **)

(** Prop (2) *)
Lemma LiftSubst : forall r m n, r |\ [m,n] = r {[ m !! (Up (n+m)) ]}.
Proof.
induction r; intros.
rewrite SparePushList.
simpl lift.
break.
  rewrite SubPushList2; simp; auto; ar; tomega.
  rewrite SubPushList1; simp; auto; rewrite seq_nth; auto.
(* App *)
simpl; rewrite IHr1; rewrite IHr2; auto.
(* Abs *)
rewrite SparePushList; simpl.
rewrite IHr; do 2 f_equal.
rewrite SparePushList; simpl; f_equal.
rewrite SubliftPushList; simpl.
map_map_S; simpl_arith; auto.
Qed.

(** (3) *)
Lemma CompUp : forall theta n, theta o Up n = theta ||\ n.
Proof.
induction theta; simpl; intros.
rewrite IHtheta.
rewrite LiftSubst.
simp; auto.
ar; auto.
Qed.

(** Added: an auxiliary result used in (4) *)
Lemma LiftSublift : forall k n m theta,
 (Var k {[theta ||\ m]}) |\ [m,n] = Var k {[theta ||\ m+n]}.
Proof.
induction k.
destruct theta; simpl; intros.
exact (lift_lift2 t 0 m n).
simp; tomega.
destruct theta; simpl in *; auto; intros; simp; tomega.
Qed.

(** Corrected (4) : the initial (4), with (theta) instead of (theta||\m), is false *)
Lemma LiftSpare : forall r m theta n,
  (r {[ m !! (theta ||\ m)]}) |\ [m,n] = r {[ m !! (theta ||\ m+n)]}.
Proof.
induction r; intros.
(* Var n *)
case (le_lt_dec m n); intros; do 2 (rewrite SparePushList; auto).
(* m <= n *)
do 2 (rewrite SubPushList2; simpl_list; auto).
apply LiftSublift.
(* n < m *)
do 2 (rewrite SubPushList1; simpl_list; auto).
rewrite seq_nth; simp; tomega.
(* App *)
simpl; rewrite IHr1; rewrite IHr2; auto.
(* Abs *)
simpl.
do 2 (rewrite SparePushList; rewrite SubliftPushList).
f_equal.
map_map_S.
do 2 rewrite SubliftTwice.
generalize (IHr (S m) theta n).
do 2 rewrite SparePushList.
simp; auto.
Qed.

(** The degenerate (4) with m=0, enough to prove what follows. *)
Lemma LiftSpare2 : forall r theta n,
  (r {[theta]}) |\ [0,n] = r {[ theta ||\ n]}.
Proof.
intros.
rewrite <- (subliftId theta).
rewrite SubliftTwice.
exact (LiftSpare r 0 theta n).
Qed.

(** (5) *)
Lemma CompSublift : forall theta theta' n,
  theta o (theta' ||\ n) = (theta o theta') ||\ n.
Proof.
induction theta.
simpl; intros.
rewrite LiftSpare2.
rewrite IHtheta; auto.
simpl.
induction n; destruct theta'; simpl; auto; intros; tomega.
Qed.

(** (6) *)
Lemma SubLiftSpare : forall r m l theta,
  (r |\ [m, length l]) {[ m  !! (l++theta) ]} = r {[ m !! theta ]}.
Proof.
induction r; simpl; intros.
simp;
  match goal with|-sub'?n?s=sub'?n'?s'=>change(n{[s]}=n'{[s']})end;
  do 2 (rewrite SparePushList; auto).
(* m <= n *)
do 3 (rewrite SubPushList2; [idtac | simpl_list; omega]); simpl_list.
do 2 (f_equal; auto); omega.
(* n < m *)
do 2 (rewrite SubPushList1; simpl_list; auto).
(* App *)
rewrite IHr1; rewrite IHr2; trivial.
(* Abs *)
do 2 rewrite SparePushList; do 3 rewrite SubliftPushList.
map_map_S.
set (l' := map (fun r0 => r0 |\  [0, 1]) l).
replace (length l) with (length l').
generalize (IHr (S m) l' (theta ||\1)).
do 2 rewrite SparePushList.
simpl; congruence.
unfold l'; simp; auto.
Qed.

(** (6') *)
Lemma SubLiftComp : forall theta theta' l,
  (theta ||\ length l)o(l++theta') = theta o theta'.
Proof.
induction theta; simpl; intros.
change  (l++theta') with (0 !! (l++theta')).
rewrite SubLiftSpare; simpl.
rewrite IHtheta; auto.
induction l; simpl; simpl_arith; auto.
Qed.

(** (7) *)
Lemma SubSub : forall r theta theta',
 r{[theta]}{[theta']} = r{[theta o theta']}.
Proof.
induction r; simpl.
intro theta.
generalize n; clear n.
induction theta; simpl.
destruct n; auto; intros.
apply (IHtheta n theta').
intros m theta'.
generalize n m; clear n m.
induction theta'; simpl; ar; auto.
destruct n; auto; simpl; intros.
ar; auto.
simpl in *; rewrite <- IHtheta'; ar; auto.
intros; rewrite  Comp'Eq; do 2 (ar; simpl); tomega.
(* App *)
intros; rewrite IHr1; rewrite IHr2; trivial.
(* Abs *)
intros; rewrite IHr; simpl.
rewrite <- CompSublift ; simpl; auto.
rewrite <- SubLiftComp with (l:=[0]::nil) (theta:=theta); auto.
Qed.

(** (7') *)
Lemma CompAssoc : forall theta theta' theta'',
  (theta o theta') o theta'' = theta o (theta' o theta'').
Proof.
induction theta; intros.
simpl; rewrite SubSub.
rewrite IHtheta; trivial.
generalize n; clear n.
induction theta'; intros.
destruct n; simpl in *; auto.
generalize n n0; clear n n0.
induction theta''; intros.
destruct n; simpl; ar; simp; auto.
simpl in *; rewrite <- IHtheta''; ar; auto.
intros; do 2 (simpl; ar); tomega.
Qed.

End Joachimski.

Module Isom.
 Import Joachimski.

Fixpoint sub_2_1 (s:substitution) : Subst.substitution := match s with
  | Dot r s => let s' := sub_2_1 s in (r::s')#s'.(shift)
  | Up n => nil#n
 end.

Definition sub_1_2 (s:Subst.substitution) : substitution :=
 fold_right Dot (Up s.(shift)) s.

Lemma substitution_isom1 : forall s, sub_2_1 (sub_1_2 s) = s.
Proof.
induction s as [l s]; unfold sub_1_2.
induction l; auto; simpl in*; rewrite IHl; auto.
Qed.

Lemma substitution_isom2 : forall s, sub_1_2 (sub_2_1 s) = s.
Proof.
unfold sub_1_2.
induction s; auto; simpl; rewrite IHs; auto.
Qed.

Lemma sublift_isom : forall th n, sub_2_1 (th ||\ n) =
  (map (lift 0 n) (sub_2_1 th))#((sub_2_1 th).(shift)+n).
Proof.
induction th; simpl; auto.
intros; rewrite IHth; simpl; auto.
Qed.

Lemma sub_isom1 : forall r s, sub r s = Subst.sub r (sub_2_1 s).
Proof.
induction r; simpl.
 induction n; destruct s; simpl; auto.
 intros; rewrite IHr1; rewrite IHr2; auto.
 intros; rewrite IHr; auto.
 simpl.
 rewrite sublift_isom; simpl.
 simpl_arith.
 unfold Subst.sublift.
 rewrite map_ext with (f:=up 0) (g:=lift 0 1); auto.
 intros; apply lift_up.
Qed.

Lemma sub_isom2 : forall r s, Subst.sub r s = sub r (sub_1_2 s).
Proof.
intros.
pattern s at 1; rewrite <- (substitution_isom1 s).
rewrite sub_isom1; auto.
Qed.

End Isom.

Import Joachimski.
Import Isom.
Import Subst.

Lemma Sub_Sub : forall r (s:term) rs,
 sub (sub r s) rs = sub r (((sub s rs)::rs)#rs.(shift)).
Proof.
intros.
repeat rewrite sub_isom2.
unfold Isom.sub_1_2; simpl.
set (theta := fold_right Dot (Up (shift rs)) rs);
 clearbody theta; clear rs.
rewrite SubSub.
simpl; auto.
Qed.

Lemma Sub_Sub_Ad_Hoc : forall (r s:term) (rs:substitution),
  sub (sub r (sublift rs)) s =
  sub r ((s::rs)#rs.(shift)).
Proof.
intros.
repeat rewrite sub_isom2.
assert (sub_1_2 (sublift rs) = Dot [0] (sub_1_2 rs ||\ 1)).
unfold sub_1_2, sublift; simpl.
destruct rs; simpl.
induction support; simpl; simpl_arith; auto.
rewrite lift_up.
injection IHsupport; clear IHsupport; intros.
rewrite H; auto.
rewrite H; clear H.
unfold sub_1_2; simpl.
set (theta := (fold_right Dot (Up (shift rs)) rs)); clearbody theta; clear rs.
rewrite SubSub; simpl.
replace (Dot s (Up 0)) with ((s::nil) ++ Up 0); auto.
replace 1 with (length (s::nil)); auto.
rewrite SubLiftComp.
rewrite CompUp.
rewrite subliftId; auto.
Qed.

Definition above k r := forall n, k <= n -> occurs n r = false.

Lemma above_sub : forall r (rs:substitution) l d,
 above (length rs) r ->
 sub r ((rs++l)#d) = sub r rs.
Proof.
unfold above; induction r; simpl; intros.
destruct (le_lt_dec (length rs) n).
generalize (H n l0); destruct (eq_nat_dec n n); intuition; try discriminate.
rewrite app_nth1; auto.
apply nth_indep; auto.
rewrite IHr1.
rewrite IHr2; auto.
intros; destruct (orb_false_elim _ _ (H n H0)); auto.
intros; destruct (orb_false_elim _ _ (H n H0)); auto.
unfold sublift; simpl; rewrite map_app; simpl.
rewrite app_comm_cons.
f_equal.
apply (IHr (([0] :: map (up 0) rs) # S (shift rs))).
simp; intros; rewrite (S_pred n) with 0; intuition.
Qed.

Lemma sub_sub_swap0 : forall r k, above (S k) r ->
   sub_swap0 (sub r [k]) k = r.
Proof.
unfold sub_swap0; intros.
rewrite Sub_Sub; simp.
rewrite app_nth2; simp; auto.
rewrite app_comm_cons.
replace ([0] :: map (up 0) (map Var (seq 0 k))) with (support (id (S k))).
rewrite above_sub.
apply sub_id.
unfold id; simp; auto.
rewrite <- (sublift_id k); auto.
Qed.

Lemma down_sub2 : forall r l k,
 occurs 0 r = false ->
 let rs := ((id l)++[k]::nil)#l in
 down 0 (sub r (sublift rs)) = sub (down 0 r) rs.
(* begin hide *)
Proof.
intros.
rewrite (down_sub _ _ dterm H).
unfold id; simpl.
replace ((dterm::nil)#0) with (sub1 dterm); auto.
rewrite Sub_Sub.
rewrite <- Sub_Sub_Ad_Hoc.
rewrite (down_sub (sub r (sublift rs)) 0 (sub dterm rs)); auto.
unfold rs, sublift; simpl.
rewrite map_app; simpl.
rewrite app_comm_cons.
replace ([0] :: map (up 0) (map Var (seq 0 l))) with (support (id (S l))).
rewrite <- sub_occurs2; auto with arith.
rewrite <- (sublift_id l); auto.
Qed.
(* end hide *)


Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface FMapPositive FMapFacts ProofIrrelevance EqdepFacts.

Require Import sflib.

Set Implicit Arguments.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.

Module UsualPositiveMap' <: S with Module E:=PositiveOrderedTypeBits.

  Module E:=PositiveOrderedTypeBits.
  Module ME:=KeyOrderedType E.

  Definition key := positive : Type.

  Module Raw := PositiveMap.

  Inductive inhabited A: forall (m : Raw.t A), Prop :=
  | inhabited_Some
      l o r
      (L: wf l)
      (R: wf r):
      inhabited (Raw.Node l (Some o) r)
  | inhabited_l
      l r
      (L: inhabited l)
      (R: wf r):
      inhabited (Raw.Node l None r)
  | inhabited_r
      l r
      (L: wf l)
      (R: inhabited r):
      inhabited (Raw.Node l None r)

  with wf A: forall (m : Raw.t A), Prop :=
  | wf_Leaf:
      wf (Raw.Leaf _)
  | wf_inhabited
      m (INHABITED: inhabited m):
      wf m
  .

  Lemma wf_l A l o r (WF: @wf A (Raw.Node l o r)):
    wf l.
  Proof.
    inversion WF. subst. clear WF.
    inversion INHABITED; subst; auto.
    constructor. auto.
  Qed.

  Lemma wf_r A l o r (WF: @wf A (Raw.Node l o r)):
    wf r.
  Proof.
    inversion WF. subst. clear WF.
    inversion INHABITED; subst; auto.
    constructor. auto.
  Qed.

  Lemma inhabited_inv A m (INH: @inhabited A m):
    exists i a, Raw.find i m = Some a.
  Proof.
    revert INH.
    induction m; intros;
      inversion INH; subst; clear INH.
    - exists xH, o0. auto.
    - destruct (IHm1 L) as [i' [a' IH]].
      exists (xO i'), a'. auto.
    - destruct (IHm2 R) as [i' [a' IH]].
      exists (xI i'), a'. auto.
  Qed.

  Definition t A := {tr:Raw.t A | wf tr}.

  Section A.
  Variable A:Type.

  Ltac tac :=
    repeat
      (try match goal with
           | [|- wf (Raw.Leaf _)] => constructor
           | [|- wf (Raw.Node _ _ _)] => constructor
           | [|- inhabited (Raw.Node _ (Some _) _)] => constructor 1
           | [|- inhabited (Raw.Node ?x None (Raw.Leaf _))] => constructor 2
           | [|- inhabited (Raw.Node (Raw.Leaf _) None ?x)] => constructor 3
           | [H: inhabited ?x |- inhabited (Raw.Node ?x None _)] => constructor 2
           | [H: inhabited ?x |- inhabited (Raw.Node _ None ?x)] => constructor 3

           | [x: t A |- _] =>
             let m := fresh "m" in
             let WF := fresh "WF" in
             destruct x as [m WF]; clear x
           | [WF: wf (Raw.Node _ _ _) |- _] =>
             inversion WF; clear WF
           | [INHABITED: inhabited (Raw.Node _ _ _) |- _] =>
             inversion INHABITED; clear INHABITED
           | [INHABITED: inhabited ?m |- wf ?m] =>
             constructor; auto
           | [H: inhabited (Raw.Leaf _) |- _] => inversion H
           | [H: (Raw.Leaf _) <> ?x |- _] =>
             destruct x; [congruence|clear H]
           | [H: ?x <> (Raw.Leaf _) |- _] =>
             destruct x; [congruence|clear H]
           end;
       ss; subst; auto).

  Program Definition empty : t A := Raw.empty A.
  Next Obligation. constructor. Qed.

  Definition is_empty (m : t A) : bool := Raw.is_empty (proj1_sig m).

  Definition find (i : key) (m : t A) := Raw.find i (proj1_sig m).

  Definition mem (i : key) (m : t A) := Raw.mem i (proj1_sig m).

  Lemma add_proper i v (m:Raw.t A) (WF: wf m):
    inhabited (Raw.add i v m).
  Proof.
    revert v m WF.
    induction i; destruct m; intros; tac;
      try (constructor; tac; fail).
    - constructor 3; tac. apply IHi. tac.
    - constructor 2; tac. apply IHi. tac.
  Qed.
  Definition add (i : key) (v : A) (m : t A) : t A :=
    exist
      _
      (Raw.add i v (proj1_sig m))
      (wf_inhabited (add_proper i v (proj2_sig m))).

  Lemma remove_proper i (m:Raw.t A) (WF: wf m):
    wf (Raw.remove i m).
  Proof.
    revert m WF.
    induction i; destruct m; intros; tac.
    - destruct m1; tac.
    - destruct m1; tac.
    - destruct m1; tac; try (apply IHi; tac; fail).
      specialize (IHi m2 (wf_inhabited R)).
      destruct (Raw.remove i m2); tac.
    - destruct m2; tac; try (apply IHi; tac; fail).
      specialize (IHi m1 (wf_inhabited L)).
      destruct (Raw.remove i m1); tac.
    - destruct m2; tac.
    - destruct m1, m2; tac.
    - destruct m1, m2; tac.
    - destruct m1, m2; tac.
  Qed.
  Definition remove (i : key) (m : t A) : t A :=
    exist
      _
      (Raw.remove i (proj1_sig m))
      (remove_proper i (proj2_sig m)).

  (** [elements] *)

  Definition elements (m : t A) := Raw.elements (proj1_sig m).

  (** [cardinal] *)

  Definition cardinal (m : t A) := Raw.cardinal (proj1_sig m).

  Section CompcertSpec.

  Theorem gempty:
    forall (i: key), find i empty = None.
  Proof.
    apply Raw.gempty.
  Qed.

  Theorem gss:
    forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x.
  Proof.
    intros. apply Raw.gss.
  Qed.

  Theorem gso:
    forall (i j: key) (x: A) (m: t A),
    i <> j -> find i (add j x m) = find i m.
  Proof.
    intros. apply Raw.gso. tac.
  Qed.

  Theorem grs:
    forall (i: key) (m: t A), find i (remove i m) = None.
  Proof.
    intros. apply Raw.grs.
  Qed.

  Theorem gro:
    forall (i j: key) (m: t A),
    i <> j -> find i (remove j m) = find i m.
  Proof.
    intros. apply Raw.gro. tac.
  Qed.

  Theorem elements_correct:
    forall (m: t A) (i: key) (v: A),
    find i m = Some v -> List.In (i, v) (elements m).
  Proof.
    intros. apply Raw.elements_correct. tac.
  Qed.

  Theorem elements_complete:
    forall (m: t A) (i: key) (v: A),
    List.In (i, v) (elements m) -> find i m = Some v.
  Proof.
    intros. apply Raw.elements_complete. tac.
  Qed.

  Lemma cardinal_1 :
   forall (m: t A), cardinal m = length (elements m).
  Proof.
    intros. apply Raw.cardinal_1.
  Qed.

  End CompcertSpec.

  Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v.

  Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m.

  Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.

  Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').

  Definition eq_key_elt (p p':key*A) :=
          E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').

  Global Instance eqk_equiv : Equivalence eq_key := _.
  Global Instance eqke_equiv : Equivalence eq_key_elt := _.
  Global Instance ltk_strorder : StrictOrder lt_key := _.

  Lemma mem_find :
    forall m x, mem x m = match find x m with None => false | _ => true end.
  Proof.
    intros. apply Raw.mem_find.
  Qed.

  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
  Proof.
    intros. apply Raw.Empty_alt.
  Qed.

  Section FMapSpec.

  Lemma mem_1 : forall m x, In x m -> mem x m = true.
  Proof.
  unfold In, MapsTo; intros m x; rewrite mem_find.
  destruct 1 as (e0,H0); rewrite H0; auto.
  Qed.

  Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof.
  unfold In, MapsTo; intros m x; rewrite mem_find.
  destruct (find x m).
  exists a; auto.
  intros; discriminate.
  Qed.

  Variable  m m' m'' : t A.
  Variable x y z : key.
  Variable e e' : A.

  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros; rewrite <- H; auto. Qed.

  Lemma find_1 : MapsTo x e m -> find x m = Some e.
  Proof. unfold MapsTo; auto. Qed.

  Lemma find_2 : find x m = Some e -> MapsTo x e m.
  Proof. red; auto. Qed.

  Lemma empty_1 : Empty empty.
  Proof.
  rewrite Empty_alt; apply gempty.
  Qed.

  Lemma is_empty_1 : Empty m -> is_empty m = true.
  Proof.
    intros. apply Raw.is_empty_1. auto.
  Qed.

  Lemma is_empty_2 : is_empty m = true -> Empty m.
  Proof.
    intros. apply Raw.is_empty_2. auto.
  Qed.

  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
  Proof.
    intros. apply Raw.add_1. auto.
  Qed.

  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof.
    intros. apply Raw.add_2; auto.
  Qed.

  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
    unfold add. intros. eapply Raw.add_3; eauto.
  Qed.

  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
  Proof.
    unfold remove. intros. eapply Raw.remove_1; eauto.
  Qed.

  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
    unfold remove. intros. eapply Raw.remove_2; eauto.
  Qed.

  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
    unfold remove. intros. eapply Raw.remove_3; eauto.
  Qed.

  Lemma elements_1 :
     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
    unfold elements. intros. eapply Raw.elements_1; eauto.
  Qed.

  Lemma elements_2 :
     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
    unfold elements. intros. eapply Raw.elements_2; eauto.
  Qed.

  Lemma elements_3 : sort lt_key (elements m).
  Proof.
    unfold elements. intros. eapply Raw.elements_3; eauto.
  Qed.

  Lemma elements_3w : NoDupA eq_key (elements m).
  Proof.
    unfold elements. intros. eapply Raw.elements_3w; eauto.
  Qed.

  End FMapSpec.

  (** [map] and [mapi] *)

  Variable B : Type.

  Section Mapi.

    Variable f : key -> A -> B.

    Lemma xmapi_proper (m:Raw.t A) i:
      (wf m -> wf (Raw.xmapi f m i)) /\
      (inhabited m -> inhabited (Raw.xmapi f m i)).
    Proof.
      revert i.
      induction m; constructor; intros; tac;
        try (apply IHm1; tac; fail);
        try (apply IHm2; tac; fail).
      - constructor 2; try apply IHm1; try apply IHm2; tac.
      - constructor 3; try apply IHm1; try apply IHm2; tac.
      - constructor 2; try apply IHm1; try apply IHm2; tac.
      - constructor 3; try apply IHm1; try apply IHm2; tac.
    Qed.
    Program Definition xmapi (m : t A) (i : key) : t B :=
      exist
        _
        (Raw.xmapi f (proj1_sig m) i)
        (proj1 (xmapi_proper (proj1_sig m) i) (proj2_sig m)).

    Definition mapi m := xmapi m xH.

  End Mapi.

  Definition map (f : A -> B) m := mapi (fun _ => f) m.

  End A.

  Lemma xgmapi:
      forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A),
      find i (xmapi f m j) = option_map (f (append j i)) (find i m).
  Proof.
    unfold find, xmapi. s. intros. apply Raw.xgmapi.
  Qed.

  Theorem gmapi:
    forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A),
    find i (mapi f m) = option_map (f i) (find i m).
  Proof.
  intros.
  unfold mapi.
  replace (f i) with (f (append xH i)).
  apply xgmapi.
  rewrite append_neutral_l; auto.
  Qed.

  Lemma mapi_1 :
    forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
    MapsTo x e m ->
    exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof.
  intros.
  exists x.
  split; [red; auto|].
  apply find_2.
  generalize (find_1 H); clear H; intros.
  rewrite gmapi.
  rewrite H.
  s; auto.
  Qed.

  Lemma mapi_2 :
    forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'),
    In x (mapi f m) -> In x m.
  Proof.
  intros.
  apply mem_2.
  rewrite mem_find.
  destruct H as (v,H).
  generalize (find_1 H); clear H; intros.
  rewrite gmapi in H.
  destruct (find x m); auto.
  ss; discriminate.
  Qed.

  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
    MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof.
  intros; unfold map.
  destruct (mapi_1 (fun _ => f) H); intuition.
  Qed.

  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
    In x (map f m) -> In x m.
  Proof.
  intros; unfold map in *; eapply mapi_2; eauto.
  Qed.

  Fixpoint normalize A (m:Raw.t A): Raw.t A :=
    match m with
    | Raw.Leaf _ => Raw.Leaf _
    | Raw.Node l o r =>
      match normalize l, o, normalize r with
      | Raw.Leaf _, None, Raw.Leaf _ => Raw.Leaf _
      | l, _, r => Raw.Node l o r
      end
    end.

  Lemma normalize_wf A (m:Raw.t A):
    wf (normalize m).
  Proof.
    induction m; s.
    { constructor. }
    destruct (normalize m1), o, (normalize m2);
      try (repeat (constructor; auto); fail).
    - constructor. constructor 3; auto.
      inversion IHm2. auto.
    - constructor. constructor 2; auto.
      inversion IHm1. auto.
    - constructor. constructor 2; auto.
      inversion IHm1. auto.
  Qed.

  Lemma normalize_correct A (m:Raw.t A) i:
    Raw.find i (normalize m) = Raw.find i m.
  Proof.
    revert m.
    induction i; destruct m; intros; s; auto;
      destruct
        (normalize m1) eqn:M1,
        o,
        (normalize m2) eqn:M2;
      try (rewrite <- M1, IHi; auto; fail);
      try (rewrite <- M2, IHi; auto; fail);
      auto.
    - rewrite <- IHi, M2. rewrite Raw.gleaf. auto.
    - rewrite <- IHi, M1. rewrite Raw.gleaf. auto.
  Qed.

  Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'')
             (m:t elt) (m':t elt'): t elt'' :=
    exist
      _
      (normalize (Raw.map2 f (proj1_sig m) (proj1_sig m')))
      (normalize_wf _).

  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x m \/ In x m' ->
    find x (map2 f m m') = f (find x m) (find x m').
  Proof.
    unfold find, map2. s. intros.
    rewrite normalize_correct.
    apply Raw.map2_1. auto.
  Qed.

  Lemma  map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x (map2 f m m') -> In x m \/ In x m'.
  Proof.
    unfold map2. intros.
    apply mem_1 in H. unfold mem in *. ss.
    rewrite Raw.mem_find, normalize_correct, <- Raw.mem_find in *.
    apply Raw.mem_2 in H.
    eapply Raw.map2_2; eauto.
  Qed.

  Section Fold.

    Variables A B : Type.
    Variable f : key -> A -> B -> B.

    Definition fold (m:t A) i := Raw.fold f (proj1_sig m) i.

  End Fold.

  Lemma fold_1 :
    forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B),
    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof.
    unfold fold, elements. intros.
    apply Raw.fold_1.
  Qed.

  Definition equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
    Raw.equal cmp (proj1_sig m1) (proj1_sig m2).

  Definition Equal (A:Type)(m m':t A) :=
    forall y, find y m = find y m'.
  Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).

  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
    Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
    intros. apply Raw.equal_1. auto.
  Qed.

  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
    equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
    intros. apply Raw.equal_2. auto.
  Qed.

  Lemma eq_leibniz
        A (m m':t A)
        (EQUAL: Equal m m'):
    m = m'.
  Proof.
    destruct m as [m WF], m' as [m' WF'].
    revert WF m' WF' EQUAL.
    induction m; destruct m'; intros;
      apply subset_eq_compat; auto.
    - inversion WF'. subst.
      apply inhabited_inv in INHABITED.
      destruct INHABITED as [i [a INHABITED]].
      specialize (EQUAL i). unfold find in *. ss.
      rewrite Raw.gleaf, INHABITED in EQUAL. congruence.
    - inversion WF. subst.
      apply inhabited_inv in INHABITED.
      destruct INHABITED as [i [a INHABITED]].
      specialize (EQUAL i). unfold find in *. ss.
      rewrite Raw.gleaf, INHABITED in EQUAL. congruence.
    - f_equal.
      + eapply eq_sig_fst. apply IHm1.
        intro i. specialize (EQUAL (xO i)). auto.
      + specialize (EQUAL xH). auto.
      + eapply eq_sig_fst. apply IHm2.
        intro i. specialize (EQUAL (xI i)). auto.
  Unshelve.
  { s. eapply wf_l. eauto. }
  { s. eapply wf_l. eauto. }
  { s. eapply wf_r. eauto. }
  { s. eapply wf_r. eauto. }
  Qed.

  Definition singleton A (key:positive) (value:A): t A :=
    add key value (empty _).

  Lemma singleton_eq A key (value:A):
    find key (singleton key value) = Some value.
  Proof.
    unfold singleton. rewrite gss. auto.
  Qed.

  Lemma singleton_neq A k1 k2 (value:A) (NEQ: k1 <> k2):
    find k1 (singleton k2 value) = None.
  Proof.
    unfold singleton. rewrite gso; auto. apply gempty.
  Qed.

  Lemma singleton_find_inv A key key' (value value':A)
        (FIND:find key (singleton key' value') = Some value):
    key = key' /\ value = value'.
  Proof.
    unfold singleton in *.
    destruct (Pos.eq_dec key key').
    - subst. rewrite gss in *. inv FIND. auto.
    - rewrite gso, gempty in *; auto. inv FIND.
  Qed.

  Lemma singleton_add A key (value1 value2:A):
    add key value1 (singleton key value2) =
    singleton key value1.
  Proof.
    apply eq_leibniz. ii. unfold singleton.
    destruct (Pos.eq_dec y key).
    - subst. rewrite ? gss. auto.
    - rewrite ? gso; auto.
  Qed.
End UsualPositiveMap'.

(** Here come some additional facts about this implementation.
  Most are facts that cannot be derivable from the general interface. *)

Module UsualPositiveMap <: S with Module E:=PositiveOrderedTypeBits.
  Include UsualPositiveMap'.

  Module Facts := FMapFacts.Facts (UsualPositiveMap').
  Module Properties := FMapFacts.Properties (UsualPositiveMap').

  Lemma map_add A B (f:A -> B) i v m:
    map f (add i v m) = add i (f v) (map f m).
  Proof.
    apply eq_leibniz. intro.
    rewrite ? Facts.map_o, ? Properties.F.add_o.
    destruct (Properties.F.eq_dec i y); auto.
    rewrite Facts.map_o. auto.
  Qed.

  Lemma map_remove A B (f:A -> B) i m:
    map f (remove i m) = remove i (map f m).
  Proof.
    apply eq_leibniz. intro.
    rewrite ? Facts.map_o, ? Properties.F.remove_o.
    destruct (Properties.F.eq_dec i y); auto.
    rewrite Facts.map_o. auto.
  Qed.

  (* Derivable from the Map interface *)
  Theorem gsspec:
    forall (A:Type)(i j: key) (x: A) (m: t A),
    find i (add j x m) = if E.eq_dec i j then Some x else find i m.
  Proof.
    intros.
    destruct (E.eq_dec i j) as [ ->|]; [ apply gss | apply gso; auto ].
  Qed.

  Theorem grspec:
    forall (A:Type)(i j: key) (m: t A),
    find i (remove j m) = if E.eq_dec i j then None else find i m.
  Proof.
    intros.
    destruct (E.eq_dec i j) as [ ->|]; [ apply grs | apply gro; auto ].
  Qed.

  (* Not derivable from the Map interface *)
  Theorem gsident:
    forall (A:Type)(i: key) (m: t A) (v: A),
    find i m = Some v -> add i v m = m.
  Proof.
    intros. destruct m as [m WF].
    apply subset_eq_compat.
    apply PositiveMapAdditionalFacts.gsident.
    auto.
  Qed.

  Lemma add_add V k1 k2 (v1 v2:V) m
        (KEY: k1 <> k2):
    add k1 v1 (add k2 v2 m) = add k2 v2 (add k1 v1 m).
  Proof.
    apply eq_leibniz. ii.
    rewrite ? Facts.add_o.
    destruct (E.eq_dec k1 y), (E.eq_dec k2 y); auto.
    congruence.
  Qed.

  Lemma add_add_eq V k (v1 v2:V) m:
    add k v1 (add k v2 m) = add k v1 m.
  Proof.
    apply eq_leibniz. ii.
    rewrite ? Facts.add_o.
    destruct (E.eq_dec k y); auto.
  Qed.
End UsualPositiveMap.


From cap_machine Require Import rules_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.
From cap_machine.rules Require Import rules_LoadU.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ, MonRef: MonRefG (leibnizO _) CapR_rtc Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Lemma isU_nonO p p' :
    PermFlows p p' → isU p = true → p' ≠ O.
  Proof.
    intros Hfl' Hra. destruct p'; auto. destruct p; inversion Hfl'. inversion Hra.
  Qed.

  (* TODO: replace all the 1's by general z's in this file *)

  Lemma wb_implies_verify_access p g:
    ∀ b e a a',
      (a' + 1)%a = Some a ->
      withinBounds ((p, g), b, e, a') = true ->
      (if Addr_le_dec b a'
       then if Addr_lt_dec a' a then if Addr_le_dec a e then Some a' else None else None
       else None) = Some a'.
  Proof.
    intros b e a a' Hincr Hwb.
    apply withinBounds_le_addr in Hwb as [Hle Hlt].
    destruct (Addr_le_dec b a');[|contradiction].
    destruct (Addr_lt_dec a' a);[|solve_addr].
    destruct (Addr_le_dec a e);[|solve_addr].
    auto.
  Qed.

  (* load from the top *)
  Lemma wp_loadU_success E r1 r2 pc_p pc_g pc_b pc_e pc_a w w' w'' p g b e a a' pc_a'
        pc_p' p' :
    decodeInstrW w = LoadU r1 r2 (inl (-1)%Z) →
    PermFlows pc_p pc_p' →
    PermFlows p p' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    isU p = true -> withinBounds ((p, g), b, e, a) = true →
    (pc_a + 1)%a = Some pc_a' →
    (a + 1)%a = Some a' ->

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
          ∗ ▷ pc_a ↦ₐ[pc_p'] w
          ∗ ▷ r1 ↦ᵣ w''
          ∗ ▷ r2 ↦ᵣ inr ((p,g),b,e,a')
          ∗ ▷ a ↦ₐ[p'] w' }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
             ∗ r1 ↦ᵣ w'
             ∗ pc_a ↦ₐ[pc_p'] w
             ∗ r2 ↦ᵣ inr ((p,g),b,e,a')
             ∗ a ↦ₐ[p'] w' }}}.
  Proof.
    iIntros (Hinstr Hfl Hfl' Hvpc HU Hwb Hpca' Hincr φ)
            "(>HPC & >Hi & >Hr1 & >Hr2 & >Ha) Hφ".
    pose proof (correctPC_nonO _ _ _ _ _ _ Hfl Hvpc) as Hpc_p'.
    pose proof (isU_nonO _ _ Hfl' HU) as Hp'.
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%) ]".
    iDestruct (memMap_resource_2ne_apply with "Hi Ha") as "[Hmem %]"; auto.
    iApply (wp_loadU with "[$Hmap $Hmem]");[|apply Hpc_p'|apply Hvpc|..];simplify_map_eq; eauto.
    { by rewrite !dom_insert; set_solver+. }
    { rewrite HU. simplify_map_eq.
      assert ((a' + -1)%a = Some a) as ->;[solve_addr|].
      erewrite wb_implies_verify_access;eauto.
        by simplify_map_eq. }
    iNext. iIntros (regs' retv) "(#Hspec & Hmem & Hmap)".
    iDestruct "Hspec" as %Hspec.

    destruct Hspec as [ | * Hfail ].
     { (* Success *)
       iApply "Hφ".
       simplify_map_eq.
       assert ((a0 + -1)%a = Some a) as Heq;[solve_addr|]. rewrite Heq in H9.
       erewrite  wb_implies_verify_access in H9;eauto. simplify_eq.
       simplify_map_eq.
       iDestruct (memMap_resource_2ne with "Hmem") as "[Hpc_a Ha]";auto.
       incrementPC_inv.
       simplify_map_eq.
       rewrite (insert_commute _ _ PC) // insert_insert insert_insert.
       iDestruct (regs_of_map_3 with "[$Hmap]") as "[HPC [Hr1 Hr2] ]"; eauto. iFrame. }
     { (* Failure (contradiction) *)
       destruct Hfail; try incrementPC_inv; simplify_map_eq; eauto.
       all: try congruence.
       assert ((a0 + -1)%a = Some a) as Heq;[solve_addr|]. rewrite Heq in e4.
       erewrite  wb_implies_verify_access in e4;eauto. simplify_eq.
       Unshelve. all:auto.
     }
  Qed.

  (* load into PC from reg *)
  Lemma wp_loadU_success_reg_to_PC E r1 r2 pc_p pc_g pc_b pc_e pc_a w p g b e a a1 p' g' b' e' a' a'' pc_p' p'':
    decodeInstrW w = LoadU PC r1 (inr r2)  →
    PermFlows pc_p pc_p' →
    PermFlows p p'' →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    isU p = true -> withinBounds ((p, g), b, e, a) = true →
    (a' + 1)%a = Some a'' →
    (a + 1)%a = Some a1 ->

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
          ∗ ▷ pc_a ↦ₐ[pc_p'] w
          ∗ ▷ r1 ↦ᵣ inr ((p,g),b,e,a1)
          ∗ ▷ r2 ↦ᵣ inl (-1)%Z
          ∗ ▷ a ↦ₐ[p''] inr ((p',g'),b',e',a') }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((p',g'),b',e',a'')
             ∗ pc_a ↦ₐ[pc_p'] w
             ∗ r1 ↦ᵣ inr ((p,g),b,e,a1)
             ∗ r2 ↦ᵣ inl (-1)%Z
             ∗ a ↦ₐ[p''] inr ((p',g'),b',e',a') }}}.
  Proof.
    iIntros (Hinstr Hfl Hfl' Hvpc HU Hwb Hpca' Hincr φ)
            "(>HPC & >Hi & >Hr1 & >Hr2 & >Ha) Hφ".
    pose proof (correctPC_nonO _ _ _ _ _ _ Hfl Hvpc) as Hpc_p'.
    pose proof (isU_nonO _ _ Hfl' HU) as Hp'.
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%) ]".
    iDestruct (memMap_resource_2ne_apply with "Hi Ha") as "[Hmem %]"; auto.
    iApply (wp_loadU with "[$Hmap $Hmem]");[apply Hinstr |apply Hpc_p'|apply Hvpc|..];simplify_map_eq; eauto.
    { by rewrite !dom_insert; set_solver+. }
    { rewrite HU. simplify_map_eq.
      assert ((a1 + -1)%a = Some a) as ->;[solve_addr|].
      erewrite wb_implies_verify_access;eauto.
        by simplify_map_eq. }
    iNext. iIntros (regs' retv) "(#Hspec & Hmem & Hmap)".
    iDestruct "Hspec" as %Hspec.

    destruct Hspec as [ | * Hfail ].
     { (* Success *)
       iApply "Hφ".
       simplify_map_eq.
       assert ((a0 + -1)%a = Some a) as Heq;[solve_addr|]. rewrite Heq in H9.
       erewrite  wb_implies_verify_access in H9;eauto. simplify_eq.
       simplify_map_eq.
       iDestruct (memMap_resource_2ne with "Hmem") as "[Hpc_a Ha]";auto.
       incrementPC_inv.
       simplify_map_eq.
       rewrite insert_insert insert_insert.
       iDestruct (regs_of_map_3 with "[$Hmap]") as "[HPC [Hr1 Hr2] ]"; eauto. iFrame. }
     { (* Failure (contradiction) *)
       destruct Hfail; simplify_map_eq; first congruence.
       all: assert ((a0 + -1)%a = Some a) as Heq;[solve_addr|]; rewrite Heq in e4;
       erewrite  wb_implies_verify_access in e4;eauto.
       * by exfalso.
       * simplify_map_eq. eapply (incrementPC_None_inv _ _ _ _ a') in e6; last by simplify_map_eq. congruence.
       Unshelve. all:auto.
     }
  Qed.

End cap_lang_rules.