(** * RIS.equiv_stacks : dynamic properties of the binding transducer. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Export transducer.

Section s.
  Context {atom X: Set}{𝐀 : Atom atom} {𝐗 : Alphabet 𝐀 X}.

(** * Static equivalence *)
(** We may define the following relation on stacks. *)
Fixpoint equiv_stacks s1 s2 :=
  match s1 with
  | [] => s2 ✓
  | (a,b)::s1 => (s2 ⊨ a ↦ b) /\ equiv_stacks s1 (s2 ⊖ (a,b))
  end.
Infix " == " := equiv_stacks (at level 80).

(** This relation may easily be translated as a boolean relation. *)
Fixpoint equiv_stacksb s1 s2 :=
  match s1 with
  | [] => prj1 s2 =?= prj2 s2
  | (a,b)::s1 => pairedb s2 a b && equiv_stacksb s1 (s2 ⊖ (a,b))
  end.

(** [equiv_stacksb] reflects [equiv_stacks]. *)
Lemma equiv_stacksb_spec s1 s2: s1 == s2 <-> equiv_stacksb s1 s2 = true.
Proof.
  revert s2;induction s1 as [|(a,b)s1];intros s2;simpl.
  - symmetry;apply eqX_correct.
  - rewrite andb_true_iff,pairedb_spec,IHs1;tauto.
Qed.

(** We will now show that [equiv_stacks] is an equivalence relation. Reflexivity is straightforward. *)
Lemma equiv_stacks_Reflexive s : s == s.
Proof.
  induction s as [|(a,b)s];simpl;[|simpl_beq;split];auto.
  right;exists [],s;repeat split;auto.
Qed.

(** Two equivalent stacks validate the same pairs. *)
Lemma equiv_stacks_paired s1 s2 a b : s1 == s2 -> (s1 ⊨ a ↦ b) <-> (s2 ⊨ a ↦ b).
Proof.
  revert s2 a b;induction s1 as [|(a,b)s1];intros s2 c d;simpl.
  - intro A;rewrite (paired_Accepting _ _ A).
    rewrite paired_Accepting;tauto.
  - intros (h1&IH);pose proof (IHs1 _ c d IH) as Eq.
    rewrite paired_cons,Eq;clear Eq IH IHs1.
    destruct h1 as [(->&A)|(t1&t2&->&A)].
    + rewrite (rmfst_absent A) in *.
      split.
      * intros [E|h];[|tauto].
        inversion E;subst;clear E.
        left;auto.
      * intro h;pose proof h as [(->&A')|(?&?&->&A')].
        -- destruct_eqX a c;auto.
        -- right;split;[|split;[|apply h]];intros ->;destruct A as (a1&a2);[apply a1|apply a2];
             rewrite map_app;simpl;simpl_In;tauto.
    + rewrite rmfst_present;auto.
      repeat rewrite paired_app;rewrite paired_cons.
      split.
      * intros [E|(n1&n2&[(P&I)|(A'&P)])];auto.
        -- inversion E;subst;clear E;auto.
        -- right;split;auto.
      * intros [(P&I)|(A'&[E|(n1&n2&P)])];auto.
        -- right;split;[|split];auto;intros ->;destruct A as (a1&a2);[apply a1|apply a2];
             apply in_map_iff;exists (c,d);simpl;auto.
        -- right;split;auto.
Qed.
(* begin hide *)
Global Instance equiv_stacks_paired_bis :
  Proper (equiv_stacks ==> Logic.eq ==> Logic.eq ==> Logic.iff) paired.
Proof. intros s1 s2 E ? a -> ? b -> ;apply equiv_stacks_paired,E. Qed.
Global Instance equiv_stacks_pairedb :
  Proper (equiv_stacks ==> Logic.eq ==> Logic.eq ==> Logic.eq) pairedb.
Proof.
  intros s1 s2 E ? a -> ? b -> .
  apply eq_true_iff_eq;repeat rewrite <- pairedb_spec;apply equiv_stacks_paired,E.
Qed.
(* end hide *)

(** If two stacks are equivalent, then either both are accepting or none of them are. *)
Lemma equiv_stacks_Accepting s1 s2 : s1 == s2 -> s1 ✓ <-> s2 ✓.
Proof.
  revert s2;induction s1 as [|(a,b)s1];intro s2;simpl;[tauto|].
  intros (h&e);apply IHs1 in e;clear IHs1.
  destruct h as [(->&A)|(?&?&->&A)].
  - rewrite rmfst_absent in e;auto.
    rewrite <-e;clear e;split;[intro e;inversion e|intros ->];reflexivity.
  - rewrite rmfst_present in e;auto.
    repeat rewrite map_app in *;simpl;split.
    + intro E;inversion E as [[h e']];subst.
      rewrite e in e';apply length_app in e' as (->&->);[|solve_length];reflexivity.
    + intro e';apply length_app in e' as (e1&e2);[|solve_length].
      inversion e2 as [[e3 e4]];subst;clear e2.
      f_equal;apply e;congruence.
Qed.

(** Two accepting stacks are always equivalent. *)
Lemma Accepting_equiv_stacks s1 s2 : s1 ✓ -> s2 ✓ -> s1 == s2.
Proof.
  revert s2;induction s1 as [|(a,b)s1];intro s2;simpl;[tauto|].
  intros e0 e2;inversion e0 as [[e0' e1]];subst;clear e0.
  rewrite (paired_Accepting _ _ e2);split;auto.
  apply IHs1;auto.
  apply Accepting_rmfst;auto.
Qed.

(** We may therefore show that [==] is a symmetric relation. *)
Lemma equiv_stacks_Symmetric s1 s2 : s1 == s2 -> s2 == s1.
Proof.
  revert s1;induction s2 as [|(a,b) s2];intros s1;simpl;auto.
  - intro E;rewrite equiv_stacks_Accepting;eauto;reflexivity.
  - intro E;cut (s1 ⊨ a ↦ b ).
    + intro h;split;auto.
      apply IHs2;clear IHs2;revert E.
      revert s2;induction s1 as [|(c,d) s1];intros s2;simpl;
        destruct h as [(->&A)|(t1&t2&E&A)].
      -- intro E;inversion E;subst;auto.
      -- simpl_words.
      -- apply absent_cons in A as (n1&n2&A).
         destruct_eqX (c,d)(a,a);[inversion E;tauto| simpl_beq].
         intros ([(->&A')|(t1&t2&E&A')]&IH);simpl;split.
         ++ apply absent_cons in A' as (_&_&A').
            left;split;auto.
         ++ apply IHs1;auto.
            left;split;auto.
         ++ destruct t1;simpl in *;inversion E;subst;[tauto|].
            apply absent_cons in A' as (_&_&A').
            right;exists t1,t2;split;auto.
         ++ apply IHs1;auto.
            left;split;auto.
      -- destruct_eqX (c,d) (a,b);[tauto|].
         destruct t1;simpl in *;inversion E;subst;[tauto|clear E;simpl_beq].
         apply absent_cons in A as (n1&n2&A).
         intros (P&E);apply paired_cons in P as [F|(_&_&P)];[rewrite F in N;tauto|].
         simpl;split;[tauto|].
         apply IHs1;[|tauto].
         right;exists t1,t2;split;[reflexivity|tauto].
    + eapply equiv_stacks_paired;eauto.
      right;exists [],s2;repeat split;auto.
Qed.

(** The operation [rmfst] is monotonic with respect to [==]. *)
Global Instance equiv_stacks_rmfst :
  Proper (Logic.eq ==> equiv_stacks ==> equiv_stacks) rmfst.
Proof.
  intros x (a,b) -> s1;induction s1 as [|(c,d)s1];intros s2;simpl.
  - intro E;apply Accepting_rmfst;auto.
  - destruct_eqX (a,b)(c,d).
    + inversion E;subst;clear E;intros (p&e);auto.
    + intros (p&e);simpl;split.
      * clear e IHs1 s1;apply rmfst_paired;auto.
      * rewrite rmfst_comm;apply IHs1,e.
Qed.

(** We these facts established we can prove that [==] is transitive. *)
Lemma equiv_stacks_Transitive s1 s2 s3 : s1 == s2 -> s2 == s3 -> s1 == s3.
Proof.
  revert s2 s3;induction s1 as [|(a,b)s1];intros s2 s3;simpl.
  - intros Ok E;rewrite <- equiv_stacks_Accepting;eauto.
  - intros (p&E);destruct s2 as [|(c,d) s2];simpl in *.
    + apply equiv_stacks_Symmetric in E as Ok1;simpl in Ok1.
      intro Ok2;destruct p as [(->&_)|(?&?&F&_)];[|simpl_words].
      rewrite (paired_Accepting _ _ Ok2);split;auto.
      apply Accepting_equiv_stacks;auto.
      apply Accepting_rmfst;auto.
    + apply paired_cons in p.
      revert E;destruct_eqX (a,b)(c,d).
      * clear p;inversion E;subst;clear E.
        intros E1 (p&E2);split;auto.
        eapply IHs1;eauto.
      * destruct p as [F|(n1&n2&p2)];[inversion F;subst;tauto|].
        intros E1 (p'&E2).
        cut (s3 ⊨ a ↦ b ).
        -- intro p3;split;auto.
           eapply IHs1;[eauto|].
           replace ((c, d) :: s2 ⊖ (a, b)) with (((c, d) :: s2) ⊖ (a, b))
             by (simpl;simpl_beq;reflexivity).
           apply equiv_stacks_rmfst;auto.
           simpl;split;auto.
        -- apply paired_rmfst with (a0:=c) (b0:=d);try (intros ->;tauto).
           rewrite <- equiv_stacks_paired;eauto.
Qed.

(** Having proved reflexivity, symmetricity and transitivity, we now know that [==] is indeed an equivalence relation. *)
Global Instance equiv_stacks_equivalence : Equivalence equiv_stacks.
Proof.
  split.
  - intro;apply equiv_stacks_Reflexive.
  - intro;intros;eapply equiv_stacks_Symmetric;eauto.
  - intro;intros;eapply equiv_stacks_Transitive;eauto.
Qed.

(** [cons] is monotonic with respect to [==]. *)
Global Instance equiv_stacks_cons :
  Proper (Logic.eq ==> equiv_stacks ==> equiv_stacks) cons.
Proof.
  intros ? (a,b) -> s1 s2 E.
  simpl;split.
  - right;exists [],s2;repeat split;auto.
  -  simpl_beq;auto.
Qed.

(** If two stacks are equivalent, then their associated [image] functions are extensionally equivalent.  *)
Global Instance equiv_stacks_image :
  Proper (equiv_stacks ==> Logic.eq ==> Logic.eq) image.
Proof.
  intros s1;intros s2 E ? c ->;revert s2 E c;induction s1 as [|(a,b) s1];intros s2 E c;simpl in *.
  - symmetry;apply image_spec,paired_Accepting;auto.
  - destruct E as (p&E).
    rewrite (IHs1 _ E c).
    destruct p as [(->&A)|(t1&t2&->&A)].
    + rewrite rmfst_absent;auto.
      destruct_eqX c a;auto.
      symmetry;apply image_spec;left;auto.
    + rewrite rmfst_present in *;auto.
      destruct_eqX c a;auto.
      * symmetry;apply image_spec;right;exists t1,t2;auto.
      * revert N;clear;intro N;induction t1 as [|(x,y) t1];simpl;auto.
        -- simpl_beq;reflexivity.
        -- destruct_eqX c x;auto.
Qed.

(** It follows that two equivalent stacks yield equivalent permutations for any list. *)
Global Instance equiv_stacks_var_perm :
  Proper (Logic.eq ==> equiv_stacks ==> sequiv) var_perm.
Proof.
  intros ? x -> s1 s2 E;unfold var_perm;revert s1 s2 E;induction x;simpl;auto.
  - intros s1 s2 _; reflexivity.
  - intros s1 s2 E;setoid_rewrite E at 2.
    intro b;repeat rewrite act_cons||rewrite (IHx _ _ E);reflexivity.
Qed.

(** * Definitions *)

Notation " s1 -- α -->> s2 " := (path (fst α) (snd α) s1 s2) (at level 80).
Notation " s1 -- α ---> s2 " := (step s1 (fst α) (snd α) s2) (at level 80).

(** As will be shown later on, the pair of words [w1 s,w2 s] characterises the stack [s]. *)
Definition w1 (s : stack) : word := map close (prj1 s).
Definition w2 (s : stack) : word := map close (prj2 s).
Definition 𝐰 (s : stack) := (w1 s,w2 s).

(** We define bissimilarity of stacks by coinduction, saying that [s1∼s2] holds if for every pair of letters [l1,l2], if [s1] can perform one transition labelled with [l1|l2] to [s3] then [s2] can can follow a transition with the same label to reach [s4] with [s3∼s4], and conversely. *)
Reserved Notation " s1 ∼ s2 " (at level 80).
CoInductive bissimilar : relation stack :=
| prog s1 s2 :
    (forall α, (forall s3, s1 -- α ---> s3 -> exists s4, s2 --α---> s4 /\ s3 ∼ s4)
          /\ (forall s4, s2 --α---> s4 -> exists s3, s1 --α---> s3 /\ s3 ∼ s4))
    -> s1 ∼ s2
where " s1 ∼ s2 " := (bissimilar s1 s2).

(** Similarity is defined analogously. *)
Reserved Notation " s1 ≺ s2 " (at level 80).
CoInductive similar : relation stack :=
| prog2 s1 s2 :
    (forall α, (forall s3, s1 --α---> s3 -> exists s4, s2 --α---> s4 /\ s3 ≺ s4))
    -> s1 ≺ s2
where " s1 ≺ s2 " := (similar s1 s2).

(** We consider here languages to be sets of pairs of words, i.e. predicates over [words*words]. *)
Definition lang := (word * word)%type -> Prop.

(** Two languages are equivalent if they contain the same words. *)
Global Instance eq_sem : SemEquiv lang := fun L M => forall σ, L σ <-> M σ.

(** The language [L] is smaller that the language [M] if every word in [L] belongs to [M]. *)
Global Instance inf_sem : SemSmaller lang := fun L M => forall σ, L σ -> M σ.
(* begin hide *)
Global Instance eq_sem_equivalence : Equivalence (@sequiv _ eq_sem).
Proof. split;intro;intros;firstorder. Qed.
Global Instance inf_sem_preorder : PreOrder (@ssmaller _ inf_sem).
Proof. split;intro;intros;firstorder. Qed.
Global Instance inf_sem_partialorder : PartialOrder (@sequiv _ eq_sem) (@ssmaller _ inf_sem).
Proof. split;intro;intros;firstorder. Qed.
(* end hide *)

(** The semantics of a stack [s] is the set of pairs [u,v] such that there is a path from [s] to some accepting stack labelled with [u,v]. *)
Definition semantics s : lang := fun σ => (exists s', s' ✓ /\ s --σ-->> s').
Notation " ⟦ s ⟧ " := (semantics s).

(** * Lemmas *)
(** ** equiv_stacks *)
(** [fun s => δt s u v] preserves the relation [==]. *)
Global Instance equiv_stacks_δt :
  Proper (equiv_stacks ==> Logic.eq ==> Logic.eq ==> equiv_stacks) δt.
Proof.
  intros s1 s2 E1 ? u -> ? v -> .
  revert s1 s2 v E1;induction u as [|[a|a|x]u];intros s1 s2 [|[b|b|y] v];simpl;auto.
  - intro;apply IHu;rewrite E1;reflexivity.
  - intro E;rewrite E at 1.
    case_paired s2 a b;auto.
    + apply IHu;rewrite E;reflexivity.
    + reflexivity.
  - intro E;case_var s1 x y;case_var s2 x y;try reflexivity.
    + apply IHu,E.
    + exfalso;apply N;rewrite <- E0.
      apply support_eq_action_eq.
      intros a Ia.
      pose proof (var_perm'_Some e Ia) as p1.
      pose proof (var_perm'_Some e0 Ia) as p2.
      rewrite equiv_stacks_paired in p1 by (apply E).
      apply (paired_inj p2 p1);reflexivity.
    + exfalso;apply var_perm'_None in e0 as (a&Ia&h).
      pose proof (var_perm'_Some e Ia) as p1.
      apply (h (p∙a)).
      rewrite equiv_stacks_paired by (symmetry;apply E).
      apply p1.
    + exfalso;apply N;rewrite <- E0.
      apply support_eq_action_eq.
      intros a Ia.
      pose proof (var_perm'_Some e Ia) as p1.
      pose proof (var_perm'_Some e0 Ia) as p2.
      rewrite equiv_stacks_paired in p1 by (apply E).
      apply (paired_inj p1 p2);reflexivity.
    + exfalso;apply var_perm'_None in e as (a&Ia&h).
      pose proof (var_perm'_Some e0 Ia) as p1.
      apply (h (p∙a)).
      rewrite equiv_stacks_paired by (apply E).
      apply p1.
Qed.

(** If [s==s'], then [u,v] is compatible with [s] if and only if [s'] is. *)
Global Instance equiv_stacks_compatible :
  Proper (equiv_stacks ==> Logic.eq ==> Logic.eq ==> Logic.eq) compatible.
Proof.
  intros s1 s2 E1 ? u -> ? v -> .
  revert s1 s2 v E1;induction u as [|[a|a|x]u];intros s1 s2 [|[b|b|y] v];simpl;auto.
  - intro;apply IHu;rewrite E1;reflexivity.
  - intro E;rewrite E at 1.
    case_paired s2 a b;auto.
    apply IHu;rewrite E;reflexivity.
  - intro E;case_var s1 x y;case_var s2 x y;auto.
    + apply IHu,E.
    + exfalso;apply N;rewrite <- E0.
      apply support_eq_action_eq.
      intros a Ia.
      pose proof (var_perm'_Some e Ia) as p1.
      pose proof (var_perm'_Some e0 Ia) as p2.
      rewrite equiv_stacks_paired in p1 by (apply E).
      apply (paired_inj p2 p1);reflexivity.
    + exfalso;apply var_perm'_None in e0 as (a&Ia&h).
      pose proof (var_perm'_Some e Ia) as p1.
      apply (h (p∙a)).
      rewrite equiv_stacks_paired by (symmetry;apply E).
      apply p1.
    + exfalso;apply N;rewrite <- E0.
      apply support_eq_action_eq.
      intros a Ia.
      pose proof (var_perm'_Some e Ia) as p1.
      pose proof (var_perm'_Some e0 Ia) as p2.
      rewrite equiv_stacks_paired in p1 by (apply E).
      apply (paired_inj p1 p2);reflexivity.
    + exfalso;apply var_perm'_None in e as (a&Ia&h).
      pose proof (var_perm'_Some e0 Ia) as p1.
      apply (h (p∙a)).
      rewrite equiv_stacks_paired by (apply E).
      apply p1.
Qed.

(** ** Characteristic words *)
(** The pair [w1 s,w2 s] belongs to the semantics of [s]. *)
Lemma w_path s : ⟦s⟧ (𝐰 s).
Proof.
  induction s as [|(a,b)s].
  - exists [];split;auto.
    apply pathϵ.
  - simpl in *.
    destruct IHs as (s'&Ok&P).
    exists s';split;auto.
    eapply pathl;[|apply P];simpl.
    split.
    + right;exists [],s;repeat split;auto.
    + simpl;simpl_beq;auto.
Qed.

(** If [w1 s1,w2 s1] is in the semantics of [s2], then [s1==s2]. *)
Lemma w_equiv_stacks s1 s2 :
  ⟦s2⟧ (𝐰 s1) -> s1 == s2.
Proof.
  revert s2;induction s1 as [|(a,b)s1];intros s2 (s3&A&E);simpl in *.
  - inversion E;subst;auto.
  - inversion E;subst;destruct H5 as (h&->);split;auto.
    eapply IHs1;exists s3;auto.
Qed.

(** ** Bissimilarity *)
(** Bissimilarity is an equivalence relation. *)
Global Instance bissimilar_equivalence : Equivalence bissimilar.
Proof.
  split.
  - intro s;revert s;cofix ch;intro s;apply prog;intros α;split;intros s' st;exists s';split;auto.
  - intro s;revert s;cofix ch;intros s1 s2 E;inversion E as [? ? h];subst.
    apply prog;intros α;split;intros s' st;apply h in st as (s''&st&E');
      apply ch in E';eauto.
  - intro s;revert s;cofix ch;intros s1 s2 s3 E1 E2;
      inversion E1 as [? ? h1];inversion E2 as [? ? h2];subst;apply prog;intros α;split;
        intros s' st.
    + apply h1 in st as (s4&st&E1');apply h2 in st as (s5&st&E2').
      pose proof (ch _ _ _ E1' E2') as E;eauto.
    + apply h2 in st as (s4&st&E2');apply h1 in st as (s5&st&E1').
      pose proof (ch _ _ _ E1' E2') as E;eauto.
Qed.

(** Although we have defined bissimilarity in terms of transitions, it may be naturally extended to paths. *)
Lemma bissimilar_path s1 s2 σ s3 :
  s1 ∼ s2 -> s1 --σ-->> s3 -> exists s4, s2 --σ-->> s4 /\ s3 ∼ s4.
Proof.
  intros E P;revert s2 E;induction P as [|s1 u v l1 l2 s s3 st P];intros s2 E.
  - exists s2;split;auto.
  - inversion E as [? ? B];clear E;subst.
    apply (B (l1,l2)) in st as (s4&st&E);clear B.
    destruct (IHP _ E) as (s5&P'&E').
    exists s5;split;eauto.
Qed.

(** In fact [s1] is bissimilar to [s2] exactly when for every pair of words [u,v], there is a path labelled with [u|v] from [s1] if and only if there is one from [s2]. *)
Lemma bissimilar_alt s1 s2 :
  s1 ∼ s2 <-> forall σ, (exists s, s1 --σ-->> s) <-> (exists s, s2 --σ-->> s).
Proof.
  split.
  - intros E σ;split;intros (s&P);eapply bissimilar_path in P as (s'&P'&_);try (exists s';apply P');
      rewrite E;reflexivity.
  - revert s1 s2;cofix ch;intros s1 s2 B;apply prog;intros (l1,l2);split;intros s3 P.
    + cut (exists s, s1 ⊣ [l1]|[l2] ⤅ s);[|exists s3;eapply pathl;eauto].
      intro P';apply (B ([l1],[l2])) in P' as (s4&P').
      inversion P' as [|s' ? ? ? ? ? ? st P''];subst;clear P'.
      inversion P'';subst;clear P''.
      exists s4;split;auto.
      apply ch;intros (u,v).
      transitivity (exists s : stack, s1 ⊣ l1::u | l2::v ⤅ s) ;
        [|transitivity (exists s : stack, s2 ⊣ l1::u | l2::v ⤅ s);[apply (B (_,_))|]];
        split;intros(s&P'); exists s;try eapply pathl';eauto;
          inversion P' as [|s' ? ? ? ? ? ? st' P''];subst.
      * rewrite (step_det P st') in *;auto.
      * rewrite (step_det st st') in *;auto.
    + cut (exists s, s2 ⊣ [l1]|[l2] ⤅ s);[|exists s3;eapply pathl;eauto].
      intro P';apply (B(_,_)) in P' as (s4&P').
      inversion P' as [|s' ? ? ? ? ? ? st P''];subst;clear P'.
      inversion P'';subst;clear P''.
      exists s4;split;auto.
      apply ch;intros (u,v).
      transitivity (exists s : stack, s1 ⊣ l1::u | l2::v ⤅ s) ;
        [|transitivity (exists s : stack, s2 ⊣ l1::u | l2::v ⤅ s);[apply (B(_,_))|]];
        split;intros(s&P'); exists s;try eapply pathl';eauto;
          inversion P' as [|s' ? ? ? ? ? ? st' P''];subst.
      * rewrite (step_det st st') in *;auto.
      * rewrite (step_det P st') in *;auto.
Qed.

(** Bissimilar stacks are equivalent with respect to acceptance. *)
Lemma bissimilar_accepting s1 s2 : s1 ∼ s2 -> s1 ✓ -> s2 ✓.
Proof.
  revert s2;induction s1 as [|(a,b)s1];intros s2 B.
  - intros _;induction s2 as [|(a,b) s2];auto.
    inversion B as [? ? h];subst.
    assert (st: (a, b) :: s2 -- (close a,close b)---> s2).
    + split;[|simpl;simpl_beq;auto].
      right;exists [],s2;repeat split;auto.
    + apply h in st as (s'&st&B').
      destruct st as ([(->&_)|(?&?&F&_)]&->).
      * simpl in *;f_equal;auto.
      * simpl_words.
  - simpl;intro E1;inversion E1 as [[E2 E]];subst;clear E1.
    inversion B as [? ? h];subst.
    assert (st: (b, b) :: s1 -- (close b,close b) ---> s1).
    + split;[|simpl;simpl_beq;auto].
      right;exists [],s1;repeat split;auto.
    + apply h in st as (s'&st&B').
      destruct st as ([(_&A)|(t1&t2&->&A)]&->).
      * rewrite rmfst_absent in B';auto.
      * rewrite rmfst_present in B';auto.
        apply IHs1 in B';auto;repeat rewrite map_app in *;simpl.
        apply length_app in B' as (->&->);[|solve_length];auto.
Qed.

(** Static equivalence implies bissimilarity. *)
Lemma equiv_stacks_bissimilar s1 s2 : s1 == s2 -> s1 ∼ s2.
Proof.
  revert s1 s2;cofix ch;intros s1 s2 E;apply prog;intros α;split;intros s3 P.
  - pose proof P as st;apply path_single_letter in P.
    apply δt_compatible_spec in P as (<-&C).
    exists (δt s2 [fst α] [snd α]);split;auto.
    + apply path_single_letter,δt_compatible_spec;split;auto.
      rewrite <- E,C;auto.
    + apply ch;rewrite E;reflexivity.
  - pose proof P as st;apply path_single_letter in P.
    apply δt_compatible_spec in P as (<-&C).
    exists (δt s1 [fst α] [snd α]);split;auto.
    + apply path_single_letter,δt_compatible_spec;split;auto.
      rewrite E,C;auto.
    + apply ch;rewrite E;reflexivity.
Qed.

(** If [s1] and [s2] are bissimilar, then the semantics of [s2] contains [w1 s1,w2 s2]. *)
Lemma bissimilar_w s1 s2 :
  s1 ∼ s2 -> ⟦s2⟧ (𝐰 s1).
Proof.
  intros E;pose proof (w_path s1) as (s0&A&P).
  eapply bissimilar_path in P as (s3&P&E');eauto.
  exists s3;split;auto;apply (bissimilar_accepting E'),A.
Qed.

(** ** Similarity *)
(** Bissimilarity implies similarity. *)
Lemma bissimilar_similar s1 s2 : s1 ∼ s2 -> s1 ≺ s2.
Proof.
  revert s1 s2;cofix ch;intros s1 s2 E;apply prog2;intros α s3 st.
  inversion E as [? ? h];subst.
  apply (h α) in st as (s4&st&E').
  exists s4;split;auto.
Qed.

(** Similarity implies static equivalence. *)
Lemma similar_equiv_stacks s1 s2 : s1 ≺ s2 -> s1 == s2.
Proof.
  revert s2;induction s1 as [|(a,b)s1];intros s2 B;auto.
  - simpl;induction s2 as [|(a,b)s2];auto.
    assert (st : [] -- (close a,close a) ---> [])
      by (split;auto;left;repeat split;auto).
    inversion B as [? ? h];subst;clear B.
    apply h in st as (s1&(st&->)&B);clear h.
    destruct st as [(_&A)|(t1&t2&E&A)].
    + exfalso;rewrite absent_cons in A;tauto.
    + destruct t1 as [|x t1];simpl in *.
      * inversion E;subst;f_equal;auto.
        apply IHs2;revert B;simpl_beq;auto.
      * inversion E;subst;rewrite absent_cons in A;tauto.
  - inversion B as [? ? h];subst;clear B.
    assert (st : (a,b)::s1 -- (close a,close b) ---> s1)
      by (split;simpl;[right;exists [],s1;repeat split|simpl_beq];auto).
    apply h in st as (s3&st&B).
    apply IHs1 in B as ->.
    destruct st as (p&->);simpl;split;reflexivity||auto.
Qed.

(** ** Semantics *)
(** Bissimilarity implies semantic equivalence. *)
Lemma bissimilar_eq_sem s1 s2 : s1 ∼ s2 -> ⟦s1⟧ ≃ ⟦s2⟧.
Proof.
  intros E σ;split; intros (s3&A&P).
  - pose proof (bissimilar_path E P) as (s4&P'&E').
    exists s4;split;auto.
    apply (bissimilar_accepting E');auto.
  - symmetry in E;pose proof (bissimilar_path E P) as (s4&P'&E').
    exists s4;split;auto.
    apply (bissimilar_accepting E');auto.
Qed.

(** Semantic equivalence implies semantic inclusion. *)
Lemma eq_lang_incl_sem s1 s2 : ⟦s1⟧ ≃ ⟦s2⟧ -> ⟦s1⟧ ≲ ⟦s2⟧.
Proof. firstorder. Qed.

(** Semantic inclusion of [s1] in [s2] implies that [w1 s1,w2 s1] is in the semantics of [s2]. *)
Lemma incl_sem_w s1 s2 : ⟦s1⟧ ≲ ⟦s2⟧ -> ⟦s2⟧ (𝐰 s1).
Proof. intro h;apply h;apply w_path. Qed.

End s.


Record t := {x : bool; y : bool; z : bool}.

Goal forall x1 x2 y z,
  {| x := x1; y := y; z := z |} = {| x := x2; y := y; z := z |} -> x1 = x2.
Proof.
intros; congruence. (* was doing stack overflow *)
Qed.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

----
*)

From Coq Require Import ZArith.
From Coq Require Import Sumbool.

(**
  Equality decision functions for
  - Pair_eq_dec: pair types of decidable types A and B.
  - positivie_eq_dec
  - Z_eq_dec
  - ZPair_eq_dec
  *)

Section Pair_eq_dec.
  Variable A : Set.
  Variable B : Set.
  Variable A_eq_dec : forall x y:A, {x=y}+{x<>y}.
  Variable B_eq_dec : forall x y:B, {x=y}+{x<>y}.

  Definition Pair_eq_dec : forall x y:A*B, {x=y}+{x<>y}.
  Proof.
    (*
    intros x y.
    case x; case y.
    intros x1 x2 y1 y2.
    case (A_eq_dec x1 y1); case (B_eq_dec x2 y2); intros.
    left.
    rewrite e. rewrite e0. reflexivity.

    right.
    *)
    decide equality.
  Defined.
End Pair_eq_dec.
Arguments Pair_eq_dec [A B].

Definition positive_eq_dec : forall x y:positive, {x=y}+{x<>y}.
Proof.
  decide equality.
Defined.

Definition Z_eq_dec : forall x y:Z, {x=y}+{x<>y}.
Proof.
  decide equality; apply positive_eq_dec.
Defined.

Definition ZPair_eq_dec : forall x y:Z*Z, {x=y}+{x<>y} := Pair_eq_dec Z_eq_dec Z_eq_dec.
  (*
  decide equality.
  case (Z_eq_dec b z0).
  left; assumption.
  right; assumption.
  case (Z_eq_dec a z).
  left; assumption.
  right; assumption.
  *)

Definition ZPair_eq_bool : forall x y :Z*Z, {b : bool | if b then x = y else x <> y} :=
  fun x y => bool_of_sumbool (ZPair_eq_dec x y).

Definition Z_eqb (x y:Z) : bool :=
  let (b,P) := Z_eq_bool x y in b.

Lemma Z_eqb_spec : forall x y, if Z_eqb x y then x = y else x <> y.
Proof.
  intros x y.
  unfold Z_eqb.
  destruct (Z_eq_bool x y).
  assumption.
Qed.

Definition ZPair_eqb (x y:Z*Z) : bool :=
  let (b,P) := ZPair_eq_bool x y in b.

Lemma ZPair_eqb_spec : forall x y, if ZPair_eqb x y then x = y else x <> y.
Proof.
  intros x y.
  unfold ZPair_eqb.
  destruct (ZPair_eq_bool x y).
  assumption.
Qed.

(* Eval compute in ZPair_eqb (1%Z,1%Z) (1%Z,1%Z). *)


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Infrastructure             *
* Arthur Charguéraud, March 2007                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import List LibLN ML_Core_Definitions.

(* ====================================================================== *)
(** * Additional Definitions used in the Proofs *)

(* ********************************************************************** *)
(** ** Free Variables *)

(** Computing free variables of a type. *)

Fixpoint typ_fv (T : typ) {struct T} : vars :=
  match T with
  | typ_bvar i      => \{}
  | typ_fvar x      => \{x}
  | typ_arrow T1 T2 => (typ_fv T1) \u (typ_fv T2)
  end.

(** Computing free variables of a list of terms. *)

Definition typ_fv_list :=
  List.fold_right (fun t acc => typ_fv t \u acc) \{}.

(** Computing free variables of a type scheme. *)

Definition sch_fv M :=
  typ_fv (sch_type M).

(** Computing free type variables of the values of an environment. *)

Definition env_fv :=
  fv_in_values sch_fv.

(** Computing free variables of a term. *)

Fixpoint trm_fv (t : trm) {struct t} : vars :=
  match t with
  | trm_bvar i    => \{}
  | trm_fvar x    => \{x}
  | trm_abs t1    => (trm_fv t1)
  | trm_let t1 t2 => (trm_fv t1) \u (trm_fv t2)
  | trm_app t1 t2 => (trm_fv t1) \u (trm_fv t2)
  end.

(* ********************************************************************** *)
(** ** Substitution for free names *)

(** Substitution for names for types *)

Fixpoint typ_subst (Z : var) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_bvar i      => typ_bvar i
  | typ_fvar X      => If X = Z then U else (typ_fvar X)
  | typ_arrow T1 T2 => typ_arrow (typ_subst Z U T1) (typ_subst Z U T2)
  end.

(** Iterated substitution for types  *)

Fixpoint typ_substs (Zs : list var) (Us : list typ) (T : typ)
   {struct Zs} : typ :=
  match Zs, Us with
  | Z::Zs', U::Us' => typ_substs Zs' Us' (typ_subst Z U T)
  | _, _ => T
  end.

(** Substitution for names for schemes. *)

Definition sch_subst Z U M :=
  Sch (sch_arity M) (typ_subst Z U (sch_type M)).

(** Iterated substitution for schemes. *)

Definition sch_substs Zs Us M :=
  Sch (sch_arity M) (typ_substs Zs Us (sch_type M)).

(** Substitution for name in a term. *)

Fixpoint trm_subst (z : var) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => trm_bvar i
  | trm_fvar x    => If x = z then u else (trm_fvar x)
  | trm_abs t1    => trm_abs (trm_subst z u t1)
  | trm_let t1 t2 => trm_let (trm_subst z u t1) (trm_subst z u t2)
  | trm_app t1 t2 => trm_app (trm_subst z u t1) (trm_subst z u t2)
  end.

Notation "[ z ~> u ] t" := (trm_subst z u t) (at level 68).

(* ====================================================================== *)
(** * Tactics *)

(* ********************************************************************** *)
(** ** Instanciation of Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : trm => trm_fv x) in
  let E := gather_vars_with (fun x : typ => typ_fv x) in
  let F := gather_vars_with (fun x : list typ => typ_fv_list x) in
  let G := gather_vars_with (fun x : env => env_fv x) in
  let H := gather_vars_with (fun x : sch => sch_fv x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H).

Tactic Notation "pick_fresh" ident(x) :=
  let L := gather_vars in (pick_fresh_gen L x).

Tactic Notation "pick_freshes" constr(n) ident(x) :=
  let L := gather_vars in (pick_freshes_gen L n x).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto*.

(* ********************************************************************** *)
(** ** Automation *)

Hint Constructors type term typing value red.

Lemma typ_def_fresh : typ_fv typ_def = \{}.
Proof.
  auto.
Qed.

Hint Extern 1 (_ \notin typ_fv typ_def) =>
  rewrite typ_def_fresh.

Hint Extern 1 (types _ _) => split; auto.

(* ====================================================================== *)
(** ** Properties of fv *)

Lemma fv_list_map : forall ts1 ts2,
  typ_fv_list (ts1 ++ ts2) = typ_fv_list ts1 \u typ_fv_list ts2.
Proof.
  induction ts1; simpl; intros.
  rewrite* union_empty_l.
  rewrite IHts1. rewrite* union_assoc.
Qed.

(* ====================================================================== *)
(** * Properties of terms *)

(** Substitution on indices is identity on well-formed terms. *)

Lemma trm_open_rec_core :forall t j v i u, i <> j ->
  {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t.
Proof.
  induction t; introv Neq Equ;
  simpl in *; inversion* Equ; f_equal*.
  case_nat*. case_nat*.
Qed.

Lemma trm_open_rec : forall t u,
  term t -> forall k, t = {k ~> u}t.
Proof.
  induction 1; intros; simpl; f_equal*.
  unfolds trm_open. pick_fresh x.
   apply* (@trm_open_rec_core t1 0 (trm_fvar x)).
  unfolds trm_open. pick_fresh x.
   apply* (@trm_open_rec_core t2 0 (trm_fvar x)).
Qed.

(** Substitution for a fresh name is identity. *)

Lemma trm_subst_fresh : forall x t u,
  x \notin trm_fv t ->  [x ~> u] t = t.
Proof.
  intros. induction t; simpls; f_equal*. case_var*.
Qed.

(** Substitution distributes on the open operation. *)

Lemma trm_subst_open : forall x u t1 t2, term u ->
  [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2).
Proof.
  intros. unfold trm_open. generalize 0.
  induction t1; intros; simpl; f_equal*.
  case_nat*. case_var*. apply* trm_open_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma trm_subst_open_var : forall x y u e, y <> x -> term u ->
  ([x ~> u]e) ^ y = [x ~> u] (e ^ y).
Proof.
  introv Neq Wu. rewrite* trm_subst_open.
  simpl. case_var*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma trm_subst_intro : forall x t u,
  x \notin (trm_fv t) -> term u ->
  t ^^ u = [x ~> u](t ^ x).
Proof.
  introv Fr Wu. rewrite* trm_subst_open.
  rewrite* trm_subst_fresh. simpl. case_var*.
Qed.

(** Terms are stable by substitution *)

Lemma trm_subst_term : forall t z u,
  term u -> term t -> term ([z ~> u]t).
Proof.
  induction 2; simpls*.
  case_var*.
  apply_fresh term_abs as y. rewrite* trm_subst_open_var.
  apply_fresh* term_let as y. rewrite* trm_subst_open_var.
Qed.

Hint Resolve trm_subst_term.

(** Conversion from locally closed abstractions and bodies *)

Lemma term_abs_to_body : forall t1,
  term (trm_abs t1) -> term_body t1.
Proof.
  intros. unfold term_body. inversion* H.
Qed.

Lemma body_to_term_abs : forall t1,
  term_body t1 -> term (trm_abs t1).
Proof.
  intros. inversion* H.
Qed.

Lemma term_let_to_body : forall t1 t2,
  term (trm_let t1 t2) -> term_body t2.
Proof.
  intros. unfold term_body. inversion* H.
Qed.

Lemma body_to_term_let : forall t1 t2,
  term_body t2 -> term t1 -> term (trm_let t1 t2).
Proof.
  intros. inversion* H.
Qed.

Hint Resolve body_to_term_abs body_to_term_let.

Hint Extern 1 (term_body ?t) =>
  match goal with
  | H: context [trm_abs t] |- _ =>
    apply term_abs_to_body
  | H: context [trm_let ?t1 t] |- _ =>
    apply (@term_let_to_body t1)
  end.

(** ** Opening a body with a term gives a term *)

Lemma trm_open_term : forall t u,
  term_body t -> term u -> term (t ^^ u).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@trm_subst_intro y).
Qed.

Hint Resolve trm_open_term.

(* ====================================================================== *)
(** * Properties of types *)

(** Open on a type is the identity. *)

Lemma typ_open_type : forall T Us,
  type T -> T = typ_open T Us.
Proof.
  introv W. induction T; simpls; inversions W; f_equal*.
Qed.

(** Substitution for a fresh name is identity. *)

Lemma typ_subst_fresh : forall X U T,
  X \notin typ_fv T ->
  typ_subst X U T = T.
Proof.
  intros. induction T; simpls; f_equal*. case_var*.
Qed.

Lemma typ_subst_fresh_list : forall z u ts,
  z \notin typ_fv_list ts ->
  ts = List.map (typ_subst z u) ts.
Proof.
  induction ts; simpl; intros Fr.
  auto. f_equal. rewrite~ typ_subst_fresh. auto.
Qed.

Lemma typ_subst_fresh_trm_fvars : forall z u xs,
  fresh (\{z}) (length xs) xs ->
  typ_fvars xs = List.map (typ_subst z u) (typ_fvars xs).
Proof.
  intros. apply typ_subst_fresh_list.
  induction xs; simpls. auto. destruct H. auto.
Qed.

Lemma typ_substs_fresh : forall xs us t,
  fresh (typ_fv t) (length xs) xs ->
  typ_substs xs us t = t.
Proof.
  induction xs; simpl; intros us t Fr.
  auto. destruct us. auto.
  inversions Fr. rewrite* typ_subst_fresh.
Qed.

(** Substitution distributes on the open operation. *)

Lemma typ_subst_open : forall X U T1 T2, type U ->
  typ_subst X U (typ_open T1 T2) =
   typ_open (typ_subst X U T1) (List.map (typ_subst X U) T2).
Proof.
  intros. induction T1; intros; simpl; f_equal*.
  apply list_map_nth. apply* typ_subst_fresh.
  case_var*. apply* typ_open_type.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma typ_subst_open_vars : forall X Ys U T,
  fresh \{X} (length Ys) Ys ->
  type U ->
     typ_open_vars (typ_subst X U T) Ys
   = typ_subst X U (typ_open_vars T Ys).
Proof.
  introv Fr Tu. unfold typ_open_vars.
  rewrite* typ_subst_open. f_equal.
  induction Ys; simpls. auto.
  destruct Fr. case_var. f_equal*.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma typ_substs_intro_ind : forall T Xs Us Vs,
  fresh (typ_fv T \u typ_fv_list Vs \u typ_fv_list Us) (length Xs) Xs ->
  types (length Xs) Us ->
  types (length Vs) Vs ->
  typ_open T (Vs ++ Us) = typ_substs Xs Us (typ_open T (Vs ++ (typ_fvars Xs))).
Proof.
  induction Xs; simpl; introv Fr Tu Tv;
   destruct Tu; destruct Us; tryfalse.
  auto.
  inversions H0. lets [Fr1 _]: Fr. simpls.
  rewrite app_last.
  forwards K: (IHXs Us (Vs++t::nil)); clear IHXs.
    rewrite* fv_list_map.
    auto.
    split~. inversions Tv. apply* Forall_app.
  rewrite K. clear K.
  f_equal. rewrite~ typ_subst_open. rewrite~ typ_subst_fresh.
  f_equal. rewrite map_app.
  simpl. case_var; tryfalse*.
  rewrite <- app_last.
  f_equal. apply~ typ_subst_fresh_list.
  f_equal. apply* typ_subst_fresh_trm_fvars.
Qed.

Lemma typ_substs_intro : forall Xs Us T,
  fresh (typ_fv T \u typ_fv_list Us) (length Xs) Xs ->
  types (length Xs) Us ->
  (typ_open T Us) = typ_substs Xs Us (typ_open_vars T Xs).
Proof.
  intros. apply* (@typ_substs_intro_ind T Xs Us nil).
Qed.

(** Types are stable by type substitution *)

Lemma typ_subst_type : forall T Z U,
  type U -> type T -> type (typ_subst Z U T).
Proof.
  induction 2; simpls*. case_var*.
Qed.

Hint Resolve typ_subst_type.

(** Types are stable by iterated type substitution *)

Lemma typ_substs_types : forall Xs Us T,
  types (length Xs) Us ->
  type T ->
  type (typ_substs Xs Us T).
Proof.
  induction Xs; destruct Us; simpl; introv TU TT; auto.
  destruct TU. simpls. inversions H. inversions* H0.
Qed.

(** List of types are stable by type substitution *)

Lemma typ_subst_type_list : forall Z U Ts n,
  type U -> types n Ts ->
  types n (List.map (typ_subst Z U) Ts).
Proof.
  unfold types, list_for_n.
  induction Ts; destruct n; simpl; intros TU [EQ TT].
  auto. auto. inversion EQ.
  inversions TT. forwards*: (IHTs n).
Qed.

(** ** Opening a body with a list of types gives a type *)

Lemma typ_open_types : forall T Us,
  typ_body (length Us) T ->
  types (length Us) Us ->
  type (typ_open T Us).
Proof.
  introv [L K] WT. pick_freshes (length Us) Xs. lets Fr': Fr.
  rewrite (fresh_length Fr) in WT, Fr'.
  rewrite* (@typ_substs_intro Xs). apply* typ_substs_types.
Qed.

(* ====================================================================== *)
(** * Properties of schemes *)

(** Substitution for a fresh name is identity. *)

Lemma sch_subst_fresh : forall X U M,
  X \notin sch_fv M ->
  sch_subst X U M = M.
Proof.
  intros. destruct M as [n T]. unfold sch_subst.
  rewrite* typ_subst_fresh.
Qed.

(** Trivial lemma to unfolding definition of [sch_subst] by rewriting. *)

Lemma sch_subst_fold : forall Z U T n,
  Sch n (typ_subst Z U T) = sch_subst Z U (Sch n T).
Proof.
  auto.
Qed.

(** Distributivity of type substitution on opening of scheme. *)

Lemma sch_subst_open : forall Z U M Us,
   type U ->
    typ_subst Z U (sch_open M Us)
  = sch_open (sch_subst Z U M) (List.map (typ_subst Z U) Us).
Proof.
  unfold sch_open. intros. destruct M. simpl.
  rewrite* <- typ_subst_open.
Qed.

(** Distributivity of type substitution on opening of scheme with variables. *)

Lemma sch_subst_open_vars : forall Z U M Xs,
   fresh (\{Z}) (length Xs) Xs ->
   type U ->
    typ_subst Z U (sch_open_vars M Xs)
  = sch_open_vars (sch_subst Z U M) Xs.
Proof.
  unfold sch_open_vars. intros. destruct M.
  rewrite* <- typ_subst_open_vars.
Qed.

(** Schemes are stable by type substitution. *)

Lemma sch_subst_type : forall Z U M,
  type U -> scheme M -> scheme (sch_subst Z U M).
Proof.
  unfold scheme, sch_subst. intros Z U [n T] TU S.
  simpls. destruct S as [L K]. exists (L \u \{Z}).
  introv Fr. rewrite* typ_subst_open_vars.
Qed.

Hint Resolve sch_subst_type.

(** Scheme arity is preserved by type substitution. *)

Lemma sch_subst_arity : forall X U M,
  sch_arity (sch_subst X U M) = sch_arity M.
Proof.
  auto.
Qed.

(** ** Opening a scheme with a list of types gives a type *)

Lemma sch_open_types : forall M Us,
  scheme M ->
  types (sch_arity M) Us ->
  type (sch_open M Us).
Proof.
  unfold scheme, sch_open. intros [n T] Us WB [Ar TU].
  simpls. subst n. apply* typ_open_types.
Qed.

Hint Resolve sch_open_types.

(* ====================================================================== *)
(** * Properties of judgments *)

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation is restricted to well-formed objects. *)

Lemma typing_regular : forall E e T,
  typing E e T -> ok E /\ term e /\ type T.
Proof.
  splits 3; induction* H.
  (* ok *)
  pick_fresh y. forwards~: (H1 y).
  pick_fresh y. forwards~: (H2 y).
  (* term *)
  apply_fresh* term_let as y.
    pick_freshes (sch_arity M) Xs.
    forwards*: (H0 Xs).
  (* type *)
  pick_fresh y. forwards~: (H1 y).
  pick_fresh y. forwards~: (H2 y).
  inversion* IHtyping1.
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular : forall e,
  value e -> term e.
Proof.
  induction 1; auto*.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Lemma red_regular : forall e e',
  red e e' -> term e /\ term e'.
Proof.
  lets: value_regular. induction 1; jauto.
Qed.

(* ********************************************************************** *)
(** ** Automation *)

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
  | H: typing E _ _ |- _ => apply (proj31 (typing_regular H))
  end.

Hint Extern 1 (term ?t) =>
  match goal with
  | H: typing _ t _ |- _ => apply (proj32 (typing_regular H))
  | H: red t _ |- _ => apply (proj1 (red_regular H))
  | H: red _ t |- _ => apply (proj2 (red_regular H))
  | H: value t |- _ => apply (value_regular H)
  end.

Hint Extern 1 (type ?T) => match goal with
  | H: typing _ _ T |- _ => apply (proj33 (typing_regular H))
  end.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e383m31_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e140m27_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e489m21_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e174m17_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e129m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e190m11_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.interfaces.rationals
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.Classes.theory.rings
               HoTT.Classes.orders.semirings
               HoTT.Classes.orders.rings
               HoTT.Classes.theory.dec_fields
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Export Rlow Opens Functions
               Valuations LowerIntegrals
               D_op OpenFun Riesz1 Giry Cpo
               Interp Flip Random.

Set Implicit Arguments.

(** Random Walk: an example of recursive probabilistic program *)

Definition Fiter  : (nat -> IntPos nat) -> (nat -> IntPos nat)
    := (fun f x => Iif flip (f (S x)) (unit nat x)).

Lemma Fiter_mon : forall a b, Le_fun_IntPos a b ->
                              Le_fun_IntPos (Fiter a) (Fiter b).
Proof.
intros a b Hab.
unfold Fiter.
intros x u.
unfold Iif.
simpl.
intros q Hq.
apply pred_plus_pr in Hq.
apply pred_plus_pr.
revert Hq; apply (Trunc_ind _);
intros (v,(w,(E1,(E2,E3)))).
apply tr;
exists v, w.
repeat split; trivial.
revert E1; apply Rlow_mon.
reflexivity.
intros p Hp.
simpl in *.
unfold pred_multQ in *.
revert Hp; apply Rlow_mon.
reflexivity.
apply Hab.
Defined.

Definition iterflip : nat -> IntPos nat :=
                            Ifix Fiter Fiter_mon.


(* Implements a dependently-typed language *)

(* Drag in our dependencies *)
Require Import Bool.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Vector.
Require Import Fin.
Definition Vec := Vector.t.
Definition F   := Fin.t.

(* Raw terms. Warning: These can be ill-formed! *)
Inductive cT : Type :=
  | cType   : nat -> cT       (* Type with universe index    *)
  | cVar    : nat -> cT       (* de Bruijn index             *)
  | cEmpty  : cT              (* Empty type                  *)
  | cUnit   : cT              (* Trivial type                *)
  | cNull   : cT              (* cUnit introduction          *)
  | cMu     : cT              (* Recursive type combinator   *)
  | cFold   : cT              (* Recursive type introduction *)
  | cUnfold : cT              (* Recursive type elimination  *)
  | cPi     : cT -> cT -> cT  (* Dependent function type     *)
  | cLam    : cT -> cT        (* Dependent function value    *)
  | cSig    : cT -> cT -> cT  (* Dependent pair type         *)
  | cPair   : cT              (* Dependent pair introduction *)
  | cFst    : cT              (* Dependent pair elimination  *)
  | cSnd    : cT              (* Dependent pair elimination  *)
  | cApp    : cT -> cT -> cT  (* Function application        *).

(* Substitute x for 'Var n' in t *)
Fixpoint subst (n   : nat)
               (x t : cT)
                    : cT
      := match t with
             | cVar  m   => if m == n then x else t
             | cSig  i o => cSig  (subst    n  x i)
                                  (subst (S n) x o)
             | cPi   i o => cPi   (subst    n  x i)
                                  (subst (S n) x o)
             | cLam  b   => cLam  (subst (S n) x b)
             | cApp  l r => cApp  (subst (S n) x l)
                                  (subst    n  x r)
             | _         => t
         end.

(* One beta-reduction step (bool indicates progress) *)
Fixpoint cStep (t : cT) : (cT * bool) :=
  match t with
      (* Functions are applied to their arguments *)
      | cApp (cLam f) x => (subst 0 x f, true)
      | cApp cFst (cApp (cApp cPair l) r) => (l, true)
      | cApp cSnd (cApp (cApp cPair l) r) => (r, true)
      | cApp cUnfold (cApp cFold x)       => (x, true)

      (* Beta reduction trickles down the AST *)
      | cSig  x y => let (x', xb) := cStep x in
                     let (y', yb) := cStep y in
                         (cSig x' y', orb xb yb)
      | cPi   i o => let (i', ib) := cStep i in
                     let (o', ob) := cStep o in
                         (cPi i' o', orb ib ob)
      | cLam  b   => let (b', ob) := cStep b in
                         (cLam b', ob)
      | cApp  f x => let (x', xb) := cStep x in
                     let (f', fb) := cStep f in
                         (cApp f' x', orb fb xb)

      (* Everything else is in normal form *)
      | _ => (t, false)
  end.

(* Multiple steps of beta-reduction *)
Fixpoint cSteps (n : nat) (t : cT) : cT
      := match n with
             | 0   => t
             | S m => match cStep t with
             | (t', false) => t'
             | (t', true)  => cSteps m t'
         end end.

(* Asserts that a term normalises in n steps *)
Fixpoint stepCount (n : nat) (t : cT) : Prop :=
  match cStep t with
      | (_, false) => True
      | (t', true) => match n with
                          | 0   => False
                          | S m => stepCount m t'
                      end
  end.

(* Asserts that a term is in normal form *)
Definition normal := stepCount 0.

(* Asserts that two terms are beta-equivalent *)
Definition betaEquiv (a b : cT) : Prop
        := exists c n m, cSteps n a = c /\ cSteps m b = c.

(* Some commonly used typing assertions. Note that these need to be
 * 'instantiated' with a typing predicate to prevent digergence.
 *)

(* anyType' f t asserts that t : cType m, for some m *)
Definition anyType' (f : cT -> cT -> Prop)
                    (t : cT)
                       : Prop
        := exists m, f (cType m) t.

(* lowerType' f n t asserts that t : cType m, for some m < n *)
Definition lowerType' (f : cT -> cT -> Prop)
                      (n : nat)
                      (t : cT)
                         : Prop
        := exists m, f (cType m) t /\ m < n.

(* Asserts that trm : typ. Ill-formed terms or types will result in
 * False, which is unprovable. "a" is a hack to ensure termination.
 *)
Fixpoint cTyped (a len   : nat)
                (ctx     : Vec cT len)
                (typ trm : cT)
                         : Prop :=
  match a with
      (* We've run out of recursion. Give up. *)
      | 0   => False

      (* We can recurse. Instantiate some common idioms: *)
      | S b => (* typedHere x y asserts that y : x *)
               let typedHere          := cTyped b len ctx in

               (* typedWith x y z asserts that z : y, given Var 0 : x *)
               let typedWith (t : cT) := cTyped b (S len)
                                                (cons cT t len ctx) in

               (* anyType t asserts that t : cType m for some m *)
               let anyType            := anyType' typedHere in

               (* lowerType n t asserts that t : cType m for some m < n *)
               let lowerType          := lowerType' typedHere in

  match trm, typ with
        (* cEmpty is always a type *)
      | cEmpty, cType _ => True

        (* cUnit is always a type *)
      | cUnit, cType _ => True

        (* cNull is always a cUnit *)
      | cNull, cUnit => True

        (* Types are stratified to prevent paradoxes *)
      | cType m, cType n => m < n

        (* Dependent pair is a type if its paramters are valid *)
      | cSig i o, cType n =>

        (* i : cType m, where m < n *)
        lowerType n i

        (* o : cPi i (cType m), where m < n *)
        /\ (exists m, typedHere (cPi i (cType m)) o /\ m < n)

        (* Dependent function is a type if its paramters are valid *)
      | cPi i o, cType n =>

        (* i : cType m, where m < n *)
        lowerType n i

        (* o : cPi i (cType m), where m < n *)
        /\ (exists m, typedHere (cPi i (cType m)) o /\ m < n)

        (* Application requires the function and argument to match too *)
      | cApp f x, t =>

        (* t : cType m, for some m *)
        anyType t

        (* Introduce some i and o *)
        /\ (exists i o, (* f : cPi i o *)
                        (typedHere (cPi i o) f)

                        (* x : i *)
                        /\ (typedHere i x)

                        (* i : Type m, for some m *)
                        /\ anyType i

                        (* o x reduces to t *)
                        /\ (betaEquiv t (cApp o x)))

      | cFst,       cPi (cSig l r) o  =>
        betaEquiv l o

      | cSnd,       cPi (cSig l r) o  =>
        betaEquiv r o

      | cLam b,     cPi i o           =>
        inhabited (forall x, typedWith i (cApp o x) (subst 0 x b))

        (* We must have enough context to look up a variable's type and it must be
         * equivalent to t. *)
      | cVar n, t => exists (p : n < len), betaEquiv (nth ctx (of_nat_lt p)) t

      | cPair, cPi l o =>
        exists r,
               betaEquiv o (cPi r (cSig l r))

      | _,           _                =>
        False
  end end.

(* Nothing is typeable without recursion *)
Theorem need_recursion : forall n c t1 t2,
                              ~(cTyped 0 n c t1 t2).
  intros. unfold not. intro. destruct H.
Qed.

(* Allowing more recursion does not decrease what we can prove *)
(*
Theorem more_recursion : forall r n c t1 t2,
                                cTyped    r  n c t1 t2
                             -> cTyped (S r) n c t1 t2.
  intros. induction r. inversion H.
  compute.
*)

(* cTyped isn't inductive so we use shortcuts to ignore invalid typings *)
Theorem types_are_types : forall r n c m t,
                                 cTyped r n c t (cType m) ->
                                 exists l, t = cType (m + (S l)).
  destruct r. intros. intuition.
  simpl. repeat (dependent destruction t; intuition).
  exists (n0 - (S m)).
  assert (n0 = m + S (n0 - S m)).
  omega. rewrite <- H0. auto.
Qed.

(* Variables can have arbitrary types *)
Theorem var0_typed : forall n c ty,
                     exists r,
                            cTyped r (S n) (cons cT ty n c) ty (cVar 0).
  intros. exists 1. simpl. assert (0 < S n). apply (lt_0_Sn n).
  exists H. unfold betaEquiv. exists ty. exists 0. exists 0.
  simpl. auto.
Qed.

Lemma nth_append : forall A l m n (v1 : Vec A l)
                                  (v2 : Vec A m)
                                  (f1 : n < l)
                                  (f2 : n < l + m),
                          nth v1 (of_nat_lt f1)
                        = nth (append v1 v2) (of_nat_lt f2).
  intros. destruct v1. inversion f1.
  dependent induction n. auto. simpl. destruct v1. inversion f1.
  inversion H0.
  apply (IHn).
Qed.

(* Appending a suffix to our context doesn't prevent us typing terms *)
Theorem var_irrelevance : forall r n o c1 c2 ty m,
                                 cTyped r  n              c1     ty (cVar m)
                              -> cTyped r (n + o) (append c1 c2) ty (cVar m).
  intros. destruct r. auto.
  destruct n. simpl. destruct H. inversion x.
  simpl. destruct H. assert (m < S (n + o)). omega.
  exists H0.
  assert (p := nth_append cT (S n) o m c1 c2 x H0).
  rewrite p in H. auto.
Qed.
(*
Theorem context_irrelevance : forall r n o c1 c2 ty tm,
                                     cTyped r n c1 ty tm
                                  -> cTyped r (n + o) (append c1 c2) ty tm.
  intros. destruct r. auto. dependent destruction tm.
  repeat (unfold cTyped; intuition).
  apply (var_irrelevance (S r) n o c1 c2 ty n0 H).
  repeat (unfold cTyped; intuition).
  repeat (unfold cTyped; intuition).
  repeat (unfold cTyped; intuition).
  repeat (unfold cTyped; intuition).
  repeat (unfold cTyped; intuition).
  repeat (unfold cTyped; intuition).
  dependent destruction ty.
*)

(* Everything in 'Type x' is also in 'Type (x + y)' *)
(*
Theorem cumulative : forall x y t n c1 r1,
                     exists r2 c2,
                            (cTyped r1 n c1 (cType  x     ) t) ->
                            (cTyped r2 n c2 (cType (x + y)) t).
  intros. eapply ex_intro. eapply ex_intro. destruct r1. simpl. intuition.
  dependent inversion t.

  simpl. intro. instantiate (2 := 1). simpl.
  apply (lt_plus_trans n0 x y). auto.

  eapply ex_intro. simpl. intro. destruct H. exists x0.
  unfold betaEquiv. destruct H. destruct H. destruct H. exists (cType (x + y)).
  exists x2. exists x3. destruct H.
  assert (cSteps x2 (nth c1 (of_nat_lt x0)) = cSteps x3 (cType x)).
  rewrite H. rewrite H0. auto. intuition.
*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e230m27_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e165m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e191m19_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime621072748687 : prime 621072748687.
Proof.
 apply (Pocklington_refl
         (Pock_certif 621072748687 3 ((7962471137, 1)::(2,1)::nil) 1)
        ((Pock_certif 7962471137 3 ((248827223, 1)::(2,5)::nil) 1) ::
         (Pock_certif 248827223 5 ((601, 1)::(2,1)::nil) 265) ::
         (Proof_certif 601 prime601) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime9012345678901234567890149: prime  9012345678901234567890149.
apply (Pocklington_refl

(SPock_certif
9012345678901234567890149
2
((28519720253228549537, 1)::nil))
(
(Ell_certif
28519720253228549537
5204
((5480345934414089,1)::nil)
10368
0
288
5184)
::
(SPock_certif
5480345934414089
2
((621072748687, 1)::nil))
:: (Proof_certif 621072748687 prime621072748687) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


(********************)
(********************)
(****            ****)
(****   Syntax   ****)
(****            ****)
(********************)
(********************)

Require Import Main.STLC.Name.

Inductive term :=
| eTrue : term
| eFalse : term
| eIf : term -> term -> term -> term
| eVar : name -> term
| eAbs : name -> type -> term -> term
| eApp : term -> term -> term

with type :=
| tBool : type
| tArrow : type -> type -> type.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (1%R / 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Axiom Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (1%R / (pow2 n))%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2; admit.
Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_non_null : forall (n:Z), ~ ((pow2 n) = 0%R).
(* Why3 intros n. *)
intro n.
assert (h:n>=0 \/ n<0) by omega.
destruct h.
ae.
pose (n':=-n).
assert (Hn': n' > 0) by (subst n'; omega).
replace n with (-n') by (subst n'; omega).
rewrite Power_neg_aux; auto with zarith.
unfold Rdiv.
rewrite Rmult_1_l.
apply Rinv_neq_0_compat.
ae.
Admitted.


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2011-04-06

* Translate CPF type into CoLoR type.

*)

Set Implicit Arguments.

Require Import cpf cpf_util Matrix2 cpf2color_vector.

(***********************************************************************)
(** Translate [matrix] of CPF type into CoLor type. *)

Section matrix.

  (* Assuming a dimension of type natural numbers. *)

  Variable dim: nat.

  (** [color_matrix_of_cpf_matrix] define a function convert CPF
     type to CoLoR type, first map a list of column integer to a list
     of result vector of size [dim], then build each vector to each
     column matrix of size [dimxdim], the use the matrix transpose to
     convert rows matrix to columns matrix.

     For example: Given a list of list int name [cols: (1 :: 0 :: nil)
     :: (2 :: 0 :: nil) :: nil, dimension 2].

     Check the lenght of the list [vector_of_list] if it is not equal
     to the size [dim] then return an error [EVector_of_list],
     otherwise return an [Ok e], where [e] is a result vector of size
     [dim]. Finally, return an matrix transpose because matrix in CoLoR
     representated by row matrix where in CPF matrix represented by
     column matrix.

     Result from list [cols], [dimension = 2]

     [M^T = |1 0 |
     |2 0 |] *)

  Definition color_matrix_of_cpf_matrix (cols: list (list coefficient))
    : result (matrix dim dim) :=
    Match map (color_column_of_cpf_column dim) cols With cols ===>
    Match vector_of_list cols dim With M ===>
    Ok (mat_transpose M).

  Definition color_matrix (m : cpf.matrix) : result (matrix dim dim) :=
    match m with
      | Matrix_matrix vs => color_matrix_of_cpf_matrix vs
    end.

  (***********************************************************************)
  (* Domain Arctic natural numbers. *)

  (** [color_matrix_of_cpf_matrix_arcnat] define a function convert
     CPF type to CoLoR type, first map a list of column integer to a
     list of result vector of size [dim], then convert it to
     [ArcticDom] domain, then build each vector to each column
     matrix of size [dimxdim], then use the matrix transpose of
     matrix arctic to get the convert rows matrix to columns matrix.

     For example: Given a list of list int name [cols: (1 ::
     MinusInf :: nil) :: (2 :: MinusInf :: nil) :: nil, dimension
     2].

     Convert to a list of domain [ArcticDom: (Pos 1 :: MinusInf ::
     nil) :: (Pos 2 :: MinusInf :: nil) :: nil].

     Check the lenght of the list [vector_of_list] if it is not equal
     to the size [dim] then return an error [EVector_of_list],
     otherwise return an [Ok e], where [e] is a result vector of size
     [dim]. Finally, return an matrix transpose because matrix in CoLoR
     representated by row matrix where in CPF matrix represented by
     column matrix.

     Result from list [cols], [dimension = 2],

     [M^T = |1 MinusInf |
     |2 MinusInf |] *)

  Definition color_matrix_of_cpf_matrix_arcnat (cols: list (list coefficient)) :
    result (matrix_arcnat dim dim) :=
    Match map (color_column_of_cpf_column_arcnat dim) cols With cols ===>
    Match vector_of_list cols dim With M ===>
    Ok (mat_transpose_arcnat M).

  Definition color_matrix_arcnat (m : cpf.matrix) :
    result (matrix_arcnat dim dim) :=
    match m with
      | Matrix_matrix vs => color_matrix_of_cpf_matrix_arcnat vs
    end.

  (***********************************************************************)
  (* Domain Arctic integer numbers (below zero). *)

  (** [color_matrix_of_cpf_matrix_arcbz] define a function convert
     CPF type to CoLoR type, first map a list of column integer to a
     list of result vector of size [dim], then convert it to
     [ArcticBZDom] domain, then build each vector to each column matrix
     of size [dimxdim], the use the matrix transpose of matrix
     arctic to get the convert rows matrix to columns matrix.

     For example: Given a list of list int name [cols: (1 ::
     MinusInfBZ :: nil) :: (2 :: MinusInfBZ :: nil) :: nil,
     dimension 2].

     Convert to a list of domain [ArcticDom: (Fin 1 :: MinusInfBZ ::
     nil) :: (Fin 2 :: MinusInfBZ :: nil) :: nil].

     Check the lenght of the list [vector_of_list] if it is not equal
     to the size [dim] then return an error [EVector_of_list],
     otherwise return an [Ok e], where [e] is a result vector of size
     [dim]. Finally, return an matrix transpose because matrix in CoLoR
     representated by row matrix where in CPF matrix represented by
     column matrix.

     Result from list [cols], [dimension = 2],
     [M^T = |1 MinusInfBZ |
     |2 MinusInfBZ |] *)

  Definition color_matrix_of_cpf_matrix_arcbz (cols: list (list coefficient)) :
    result (matrix_arcbz dim dim) :=
    Match map (color_column_of_cpf_column_arcbz dim) cols With cols ===>
    Match vector_of_list cols dim With M ===>
    Ok (mat_transpose_arcbz M).

  Definition color_matrix_arcbz (m : cpf.matrix) :
    result (matrix_arcbz dim dim) :=
    match m with
      | Matrix_matrix vs => color_matrix_of_cpf_matrix_arcbz vs
    end.

  (***********************************************************************)
  (* Domain Tropical numbers. *)

  Definition color_matrix_of_cpf_matrix_trop (cols: list (list coefficient)) :
    result (matrix_trop dim dim) :=
    Match map (color_column_of_cpf_column_trop dim) cols With cols ===>
    Match vector_of_list cols dim With M ===>
    Ok (mat_transpose_trop M).

  Definition color_matrix_trop (m : cpf.matrix) :
    result (matrix_trop dim dim) :=
    match m with
      | Matrix_matrix vs => color_matrix_of_cpf_matrix_trop vs
    end.

End matrix.


Goal forall a b c : nat,  a = b -> b = c -> forall d, a+d=c+d.
intros.

(* "compatibility" mode: specializing a global name
   means a kind of generalize *)

specialize eq_trans. intros _.
specialize eq_trans with (1:=H)(2:=H0). intros _.
specialize eq_trans with (x:=a)(y:=b)(z:=c). intros _.
specialize eq_trans with (1:=H)(z:=c). intros _.
specialize eq_trans with nat a b c. intros _.
specialize (@eq_trans nat). intros _.
specialize (@eq_trans _ a b c). intros _.
specialize (eq_trans (x:=a)). intros _.
specialize (eq_trans (x:=a)(y:=b)). intros _.
specialize (eq_trans H H0). intros _.
specialize (eq_trans H0 (z:=b)). intros _.

(* incomplete bindings: y is left quantified and z is instantiated. *)
specialize eq_trans with (x:=a)(z:=c).
intro h.
(* y can be instantiated now *)
specialize h with (y:=b).
(* z was instantiated above so this must fail. *)
Fail specialize h with (z:=c).
clear h.

(* incomplete bindings: 1st dep hyp is instantiated thus A, x and y
   instantiated too. *)
specialize eq_trans with (1:=H).
intro h.
(* 2nd dep hyp can be instantiated now, which instatiates z too. *)
specialize h with (1:=H0).
(* checking that there is no more products in h. *)
match type of h with
| _ = _ => idtac
| _ => fail "specialize test failed: hypothesis h should be an equality at this point"
end.
clear h.

(* local "in place" specialization *)
assert (Eq:=eq_trans).

specialize Eq.
specialize Eq with (1:=H)(2:=H0). Undo.
specialize Eq with (x:=a)(y:=b)(z:=c). Undo.
specialize Eq with (1:=H)(z:=c). Undo.
specialize Eq with nat a b c. Undo.
specialize (Eq nat). Undo.
specialize (Eq _ a b c). Undo.
(* no implicit argument for Eq, hence no (Eq (x:=a)) *)
specialize (Eq _ _ _ _ H H0). Undo.
specialize (Eq _ _ _ b H0). Undo.

(* incomplete binding *)
specialize Eq with (y:=b).
(* A and y have been instantiated so this works *)
specialize (Eq _ _ H H0).
Undo 2.

(* incomplete binding (dependent) *)
specialize Eq with (1:=H).
(* A, x and y have been instantiated so this works *)
specialize (Eq _ H0).
Undo 2.

(* incomplete binding (dependent) *)
specialize Eq with (1:=H) (2:=H0).
(* A, x and y have been instantiated so this works *)
match type of Eq with
| _ = _ => idtac
| _ => fail "specialize test failed: hypothesis Eq should be an equality at this point"
end.
Undo 2.

(*
(** strange behavior to inspect more precisely *)

(* 1) proof aspect : let H:= ... in (fun H => ..) H
    presque ok... *)

(* 2) echoue moins lorsque zero premise de mangé *)
specialize eq_trans with (1:=Eq).  (* mal typé !! *)

(* 3) Seems fixed.*)
specialize eq_trans with _ a b c. intros _.
(* Anomaly: Evar ?88 was not declared. Please report. *)
*)

Abort.

(* Test use of pose proof and assert as a specialize *)

Goal True -> (True -> 0=0) -> False -> 0=0.
intros H0 H H1.
pose proof (H I) as H.
(* Check that the hypothesis is in 2nd position by removing the top one *)
match goal with H:_ |- _ => clear H end.
match goal with H:_ |- _ => exact H end.
Qed.

Goal True -> (True -> 0=0) -> False -> 0=0.
intros H0 H H1.
assert (H:=H I).
(* Check that the hypothesis is in 2nd position by removing the top one *)
match goal with H:_ |- _ => clear H end.
match goal with H:_ |- _ => exact H end.
Qed.

(* Test specialize as *)

Goal (forall x, x=0) -> 1=0.
intros.
specialize (H 1) as ->.
reflexivity.
Qed.

(* A test from corn *)

Goal (forall x y, x=0 -> y=0 -> True) -> True.
intros.
specialize (fun z => H 0 z eq_refl).
exact (H 0 eq_refl).
Qed.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2019, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import ZArith Reals List Psatz.

Require Import Xreal.
Require Import Tree.

Inductive term : Set :=
  | Forward : nat -> term
  | Unary : unary_op -> nat -> term
  | Binary : binary_op -> nat -> nat -> term.

Set Implicit Arguments.

Record operations (A : Type) : Type :=
  { constant : Z -> A
  ; unary : unary_op -> A -> A
  ; binary : binary_op -> A -> A -> A
  ; sign : A -> Xcomparison }.

Unset Implicit Arguments.

Definition eval_generic_body {A} def (ops : operations A) values op :=
  let nth n := nth n values def in
  match op with
  | Forward u => nth u
  | Unary o u => unary ops o (nth u)
  | Binary o u v => binary ops o (nth u) (nth v)
  end :: values.

Definition eval_generic {A} def (ops : operations A) :=
  fold_left (eval_generic_body def ops).

Lemma rev_formula :
  forall A formula terms def (ops : operations A),
  eval_generic def ops formula terms =
  fold_right (fun y x => eval_generic_body def ops x y) terms (rev formula).
Proof.
intros.
pattern formula at 1 ; rewrite <- rev_involutive.
unfold eval_generic, eval_generic_body.
rewrite <- fold_left_rev_right.
rewrite rev_involutive.
apply refl_equal.
Qed.

Theorem eval_inductive_prop :
  forall A B (P : A -> B -> Prop) defA defB (opsA : operations A) (opsB : operations B),
  P defA defB ->
 (forall o a b, P a b -> P (unary opsA o a) (unary opsB o b)) ->
 (forall o a1 a2 b1 b2, P a1 b1 -> P a2 b2 -> P (binary opsA o a1 a2) (binary opsB o b1 b2)) ->
  forall inpA inpB,
 (forall n, P (nth n inpA defA) (nth n inpB defB)) ->
  forall prog,
  forall n, P (nth n (eval_generic defA opsA prog inpA) defA) (nth n (eval_generic defB opsB prog inpB) defB).
Proof.
intros A B P defA defB opsA opsB Hdef Hun Hbin inpA inpB Hinp prog.
do 2 rewrite rev_formula.
induction (rev prog).
exact Hinp.
intros [|n].
2: apply IHl.
destruct a as [n|o n|o n1 n2] ;
  [ idtac | apply Hun | apply Hbin ] ; apply IHl.
Qed.

Definition real_operations :=
  Build_operations IZR
   unary_real binary_real
   (fun x => Xcmp (Xreal x) (Xreal 0)).

Definition eval_real :=
  eval_generic 0%R real_operations.

Scheme Equality for expr.

Inductive splitted_expr : Set :=
  | Sconst
  | Scomposed (lp lc : list expr).

Fixpoint rcons_unique (e : expr) (l : list expr) :=
  match l with
  | cons h t =>
    if expr_beq e h then l else cons h (rcons_unique e t)
  | nil => cons e nil
  end.

Definition cons_unique (e : expr) (l : list expr) :=
  let fix aux (l' : list expr) :=
    match l' with
    | cons h t =>
      if expr_beq e h then l else aux t
    | nil => cons e l
    end in
  aux l.

Fixpoint split_expr (e : expr) (lp lc : list expr) :=
  match e with
  | Evar n => Scomposed lp lc
  | Econst o => Sconst
  | Eunary o e1 =>
    match split_expr e1 lp lc with
    | Sconst => Sconst
    | Scomposed lp lc => Scomposed (cons_unique e lp) lc
    end
  | Ebinary o e1 e2 =>
    match split_expr e2 lp lc with
    | Sconst =>
      match split_expr e1 lp lc with
      | Sconst => Sconst
      | Scomposed lp lc => Scomposed (cons_unique e lp) (rcons_unique e2 lc)
      end
    | Scomposed lp lc =>
      match split_expr e1 lp lc with
      | Sconst => Scomposed (cons_unique e lp) (rcons_unique e1 lc)
      | Scomposed lp lc => Scomposed (cons_unique e lp) lc
      end
    end
  end.

Theorem split_expr_correct :
  forall vars e lp lc,
  (forall n, eval (nth n lc (Econst (Int 0))) vars = eval (nth n lc (Econst (Int 0))) nil) ->
  match split_expr e lp lc with
  | Sconst => eval e vars = eval e nil
  | Scomposed lp' lc' =>
    forall n, eval (nth n lc' (Econst (Int 0))) vars = eval (nth n lc' (Econst (Int 0))) nil
  end.
Proof.
intros vars.
induction e as [n|o|o e1 IHe1|o e1 IHe1 e2 IHe2] ; intros lp lc Hc ; simpl ; try easy.
  specialize (IHe1 lp lc Hc).
  destruct split_expr as [|lp' lc'].
  now apply f_equal.
  apply IHe1.
specialize (IHe2 lp lc Hc).
assert (H: forall e l,
    eval e vars = eval e nil ->
    (forall n, eval (nth n l (Econst (Int 0))) vars = eval (nth n l (Econst (Int 0))) nil) ->
    forall n,
    eval (nth n (rcons_unique e l) (Econst (Int 0))) vars = eval (nth n (rcons_unique e l) (Econst (Int 0))) nil).
  intros e l He Hl.
  induction l as [|h t IH] ; simpl.
    now intros [|[|n]].
  generalize (internal_expr_dec_bl e h).
  destruct expr_beq.
  intros H [|n].
  simpl.
  now rewrite <- H.
  apply Hl.
  intros _ [|n].
  apply (Hl 0%nat).
  apply IH.
  intros n'.
  apply (Hl (S n')).
destruct split_expr as [|lp2 lc2].
  specialize (IHe1 lp lc Hc).
  destruct split_expr as [|lp1 lc1].
  now apply f_equal2.
  now apply H.
specialize (IHe1 lp2 lc2 IHe2).
destruct split_expr as [|lp1 lc1].
  now apply H.
apply IHe1.
Qed.

Fixpoint find_expr_aux (e : expr) (n : nat) (l : list expr) :=
  match l with
  | cons h t => if expr_beq e h then Some n else find_expr_aux e (S n) t
  | nil => None
  end.

Definition find_expr (e : expr) (vars : nat) (lp lc : list expr) :=
  match e with
  | Evar n =>
    if Nat.ltb n vars then Some (List.length lp + n)%nat else None
  | _ =>
    match find_expr_aux e 0%nat lp with
    | Some n => Some n
    | None => find_expr_aux e (length lp + vars)%nat lc
    end
  end.

Theorem find_expr_correct :
  forall e vars lp lc,
  match find_expr e vars lp lc with
  | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Econst (Int 0)) = e
  | None => True
  end.
Proof.
intros e vars lp lc.
assert (H1: forall l n,
    match find_expr_aux e n l with
    | Some k => (n <= k < n + length l)%nat /\ nth (k - n) l (Econst (Int 0)) = e
    | None => True
    end).
  induction l as [|h t IH].
  easy.
  intros n.
  simpl find_expr_aux.
  generalize (internal_expr_dec_bl e h).
  destruct expr_beq.
  intros H.
  split.
  simpl.
  lia.
  rewrite Nat.sub_diag.
  now rewrite H.
  intros _.
  specialize (IH (S n)).
  revert IH.
  destruct find_expr_aux as [k|] ; try easy.
  intros [H1 H2].
  split.
  simpl.
  lia.
  replace (k - n)%nat with (S (k - S n))%nat by lia.
  easy.
unfold find_expr.
set (foo :=
  match find_expr_aux e 0%nat lp with
  | Some n => Some n
  | None => find_expr_aux e (length lp + vars)%nat lc
  end).
assert (H2:
    match foo with
    | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Econst (Int 0)) = e
    | None => True
    end).
  unfold foo.
  clear foo.
  generalize (H1 lp 0%nat).
  destruct find_expr_aux as [n1|].
  rewrite Nat.add_0_l, Nat.sub_0_r.
  intros [H2 H3].
  now rewrite app_nth1.
  intros _.
  specialize (H1 lc (length lp + vars)%nat).
  revert H1.
  destruct find_expr_aux as [n2|] ; try easy.
  intros [H1 H2].
  rewrite -> app_nth2 by lia.
  rewrite app_nth2 ; rewrite map_length, seq_length.
  now rewrite <- Nat.sub_add_distr.
  lia.
destruct e as [n|o|o n1|o n1 n2] ; simpl ; try easy.
destruct (Nat.ltb_spec n vars) as [H|H] ; try easy.
rewrite app_nth2 by apply le_plus_l.
rewrite minus_plus.
rewrite app_nth1.
rewrite nth_indep with (d' := Evar 0).
now rewrite map_nth, seq_nth.
now rewrite map_length, seq_length.
now rewrite map_length, seq_length.
Qed.

Fixpoint decompose (vars : nat) (p : list term) (lp lc : list expr) :=
  match lp with
  | nil => Some p
  | cons h t =>
    match h with
    | Evar n => decompose vars (cons (Forward (length t + n)) p) t lc
    | Econst _ => None
    | Eunary o e1 =>
      match find_expr e1 vars t lc with
      | Some n => decompose vars (cons (Unary o n) p) t lc
      | None => None
      end
    | Ebinary o e1 e2 =>
      match find_expr e1 vars t lc with
      | Some n1 =>
        match find_expr e2 vars t lc with
        | Some n2 => decompose vars (cons (Binary o n1 n2) p) t lc
        | None => None
        end
      | None => None
      end
    end
  end.

Theorem decompose_correct :
  forall vars p lp lc,
  (forall vars n, eval (nth n lc (Econst (Int 0))) vars = eval (nth n lc (Econst (Int 0))) nil) ->
  let lc' := map (fun c => eval c nil) lc in
  match decompose (length vars) p lp lc with
  | None => True
  | Some lp' =>
    eval_real lp' (app vars lc') =
    eval_real p (app (map (fun c => eval c (app vars lc')) lp) (app vars lc'))
  end.
Proof.
intros vars p lp lc Hc lc'.
revert p.
induction lp as [|h t IH].
easy.
intros p.
simpl.
assert (H: forall n e,
    nth n (t ++ map Evar (seq 0 (length vars)) ++ lc) (Econst (Int 0)) = e ->
    nth n (map (fun c : expr => eval c (vars ++ lc')) t ++ vars ++ lc') 0%R = eval e (vars ++ lc')).
  intros n e.
  destruct (Nat.lt_ge_cases n (length t)) as [H1|H1].
  rewrite app_nth1 by apply H1.
  intros H.
  rewrite app_nth1 by now rewrite map_length.
  change 0%R with ((fun c => eval c (vars ++ lc')) (Econst (Int 0))).
  rewrite map_nth.
  now rewrite H.
  rewrite app_nth2 by apply H1.
  rewrite (@app_nth2 _ _ _ _ n) ; rewrite map_length.
  2: exact H1.
  destruct (Nat.lt_ge_cases (n - length t) (length vars)) as [H2|H2].
  rewrite app_nth1 by now rewrite map_length, seq_length.
  rewrite app_nth1 by apply H2.
  rewrite nth_indep with (d' := Evar 0) by now rewrite map_length, seq_length.
  rewrite map_nth, seq_nth, plus_0_l by apply H2.
  intros <-.
  simpl.
  now rewrite app_nth1 by apply H2.
  rewrite app_nth2 ; rewrite map_length, seq_length.
  2: exact H2.
  rewrite app_nth2 by apply H2.
  intros H.
  unfold lc'.
  change 0%R with ((fun c => eval c nil) (Econst (Int 0))).
  rewrite map_nth, H.
  rewrite <- H at 2.
  now rewrite Hc, H.
destruct h as [n|o|o e1|o e1 e2] ; try easy.
- specialize (IH (Forward (length t + n) :: p)).
  destruct decompose ; try easy.
  rewrite IH.
  simpl.
  unfold eval_generic_body.
  rewrite app_nth2 ; rewrite map_length.
  apply (f_equal (fun v => eval_real p (nth v _ _ :: _))).
  lia.
  lia.
- generalize (find_expr_correct e1 (length vars) t lc).
  destruct find_expr as [n1|] ; try easy.
  intros H1.
  specialize (IH (Unary o n1 :: p)).
  destruct decompose ; try easy.
  rewrite IH.
  simpl.
  unfold eval_generic_body.
  apply (f_equal (fun v => eval_real p (unary_real o v :: _))).
  now apply H.
- generalize (find_expr_correct e1 (length vars) t lc).
  destruct find_expr as [n1|] ; try easy.
  intros H1.
  generalize (find_expr_correct e2 (length vars) t lc).
  destruct find_expr as [n2|] ; try easy.
  intros H2.
  specialize (IH (Binary o n1 n2 :: p)).
  destruct decompose ; try easy.
  rewrite IH.
  simpl.
  unfold eval_generic_body.
  apply (f_equal2 (fun v1 v2 => eval_real p (binary_real o v1 v2 :: _))).
  now apply H.
  now apply H.
Qed.

Fixpoint max_arity (e : expr) (n : nat) :=
  match e with
  | Evar k => Nat.ltb k n
  | Econst _ => true
  | Eunary o e1 => max_arity e1 n
  | Ebinary o e1 e2 => if max_arity e1 n then max_arity e2 n else false
  end.

Inductive extracted_expr : Set :=
  | Eabort
  | Eprog (lp : list term) (lc : list expr).

Definition extract (e : expr) (vars : nat) :=
  match split_expr e nil nil with
  | Sconst => Eprog (cons (Forward vars) nil) (cons e nil)
  | Scomposed lp lc =>
    let lp' :=
      match lp with
      | cons h t => if expr_beq e h then lp else e :: lp
      | nil => e :: lp
      end in
    match decompose vars nil lp' lc with
    | Some p => if max_arity e vars then Eprog p lc else Eabort
    | None => Eabort
    end
  end.

Definition eval_real' prog vars consts :=
  nth 0 (eval_real prog (vars ++ map (fun c => eval c nil) consts)) 0%R.

Theorem extract_correct :
  forall e vars,
  match extract e (length vars) with
  | Eabort => True
  | Eprog lp lc => eval_real' lp vars lc = eval e vars
  end.
Proof.
intros e vars.
unfold extract.
generalize (fun v => split_expr_correct v e nil nil).
destruct split_expr as [|lp lc].
  unfold eval_real'.
  simpl.
  intros H.
  rewrite app_nth2 by apply le_refl.
  rewrite Nat.sub_diag.
  apply sym_eq, H.
  now intros [|n].
intros H.
assert (exists lp',
    match lp with
    | cons h t => if expr_beq e h then lp else e :: lp
    | nil => e :: lp
    end = e :: lp') as [lp' ->].
  destruct lp as [|h t].
  now exists nil.
  generalize (internal_expr_dec_bl e h).
  destruct expr_beq.
  intros ->.
  now exists t.
  apply eq_refl.
  intros _.
  now exists (h :: t).
simpl in H.
generalize (decompose_correct vars nil (e :: lp') lc).
destruct decompose as [p|] ; try easy.
case_eq (max_arity e (length vars)).
2: easy.
unfold eval_real'.
intros H' ->.
simpl.
clear -H'.
induction e as [n|o|o e1|o e1 IHe1 e2 IHe2] ; simpl ; try easy.
apply app_nth1.
simpl in H'.
now apply Nat.ltb_lt.
now apply f_equal, IHe1.
simpl in H'.
destruct max_arity ; try easy.
apply f_equal2.
now apply IHe1.
now apply IHe2.
intros v.
apply H.
now intros [|n].
Qed.


(* Finite and infinite sequences *)

From intuitionism Require Import lib set.

(* Infinite sequence *)
Notation "'seq'" := (nat -> nat).

(* Finite sequence *)
(* For technical reasons the head represents the last element. *)
Notation "'fseq'" := (list nat).

(* Infinite constant sequence *)
Definition cseq (c i : nat) := c.

(* The first n elements of α and β coincide. *)
Definition eqn n (α β : seq) := ∀i, i < n -> α i = β i.

(* Apartness relation. *)
Definition seq_apart (α β : seq) := ∃n, α n <> β n.

(* Delete first n elements. *)
Definition del n (α : seq) i := α (n + i).

(* Add n times (α 0) as prefix. *)
Definition fill n (α : seq) i := α (i - n).

(* Overwrite the first n elements of α with β. *)
Definition replace n (α β : seq) i := if i <? n then β i else α i.

(* Add n elements from α as prefix to β. *)
Definition pre n α β := replace n (fill n β) α.

(* Get upper bound of a finite sequence. *)
Definition upb s := fold_right max 0 s.

(* Get first n elements of α. *)
Fixpoint get n (α : seq) : fseq :=
  match n with
  | 0 => []
  | S m => α m :: (get m α)
  end.

(* Check, up to n, how many elements of α and β coincide. *)
Fixpoint compare (n : nat) (α β : seq) :=
  match n with
  | 0 => 0
  | S m => if α 0 =? β 0 then S (compare m (del 1 α) (del 1 β)) else 0
  end.

(* Increasing sequence from n .. n + k *)
Fixpoint iota (n k : nat) : fseq :=
  match k with
  | 0 => []
  | S l => n :: (iota (S n) l)
  end.

(* Alternative notation for iota *)
Definition range n m := iota n (1 + m - n).

(* Apartness set for finite sequences. *)
Definition FSeq := ASet fseq fullset (dec_apart fseq)
  (dec_apart_spec fseq (List.list_eq_dec eq_dec)) (dec_apart_neq fseq)
  (dec_apart_sym fseq).

(* Apartness set of all infinite sequences *)
Section BaireSpace.

Lemma seq_apart_spec α β :
  ~seq_apart α β <-> α = β.
Proof.
unfold seq_apart; split; intros.
- extensionality n. destruct (eq_dec (α n) (β n)); auto.
  exfalso; apply H; exists n; auto.
- intros [n P]; subst; auto.
Qed.

Lemma seq_apart_neq α β : seq_apart α β -> α <> β.
Proof. intros [n H] P; subst; apply H; auto. Qed.

Lemma seq_apart_sym α β : seq_apart α β -> seq_apart β α.
Proof. intros [n H]; exists n; auto. Qed.

Record baire := Baire {
  baire_member : seq -> Prop;
}.

Definition baire_aset (X : baire) :=
  ASet seq (baire_member X) seq_apart
    seq_apart_spec seq_apart_neq seq_apart_sym.

Coercion baire_aset : baire >-> aset.
Definition Seq := Baire fullset.

(* Apartness on the Baire spread is co-transitive. *)
Theorem seq_apart_cotrans (X : baire) (α β : dom X) :
  α # β <-> ∀γ, γ # α \/ γ # β.
Proof.
split.
- intros [n Hn]; intros. destruct (eq_dec (α n) (γ n)).
  right; exists n; lia. left; exists n; lia.
- intros H; destruct (H α). now apply apart_neq in H0. easy.
Qed.

(* Prefix intersection in the baire space. *)
Definition isect_member (X : baire) s α := α ∈ X /\ get (length s) α = s.
Definition isect X s := Baire (isect_member X s).

(* Prefix subtraction in the baire space. *)
Definition subtract_member (X : baire) s α := α ∈ X /\ get (length s) α <> s.
Definition subtract X s := Baire (subtract_member X s).

End BaireSpace.

Notation "c '^ω'" := (cseq c) (at level 10, format "c '^ω'").
Notation "n '..' m" := (range n m) (at level 10, format "n '..' m").
Notation "'⟨' α ';' n '⟩'" := (get n α) (at level 0, format "'⟨' α ';' n '⟩'").
Notation "X '∩' s" := (isect X s) (at level 40).
Notation "X '\' s" := (subtract X s) (at level 40).

(* Facts about the coincedence relation *)
Section Coincedence.

Lemma eqn_refl n α : eqn n α α.
Proof. intros i; auto. Qed.

Lemma eqn_sym n α β : eqn n α β -> eqn n β α.
Proof. intros H i Hi. symmetry; apply H; auto. Qed.

Lemma eqn_trans n α β γ : eqn n α β -> eqn n β γ -> eqn n α γ.
Proof. intros Hαβ Hβγ i Hi. rewrite Hαβ. apply Hβγ. all: lia. Qed.

(* A smaller prefix of a coincedence also coincides. *)
Lemma eqn_add_l m n α β : eqn (m + n) α β -> eqn m α β.
Proof. intros H i Hi; apply H; lia. Qed.

Corollary eqn_le m n α β :
  eqn n α β -> m <= n -> eqn m α β.
Proof.
intros. replace n with (m + (n - m)) in H by lia.
now apply eqn_add_l in H.
Qed.

(* Delete part of a coincedence. *)
Lemma eqn_del m n α β :
  eqn (m + n) α β <-> eqn m α β /\ eqn n (del m α) (del m β).
Proof.
split; unfold del; simpl.
- intros H; split. eapply eqn_add_l; apply H.
  intros i Hi; apply H; lia.
- intros [H1 H2] i Hi. assert(C: i < m \/ i >= m). lia.
  destruct C. apply H1; auto. replace i with (m + (i - m)) by lia.
  apply H2; lia.
Qed.

(* α and β coincide iff their first n elements are the same. *)
Lemma eqn_eq_get n α β :
  eqn n α β <-> ⟨α;n⟩ = ⟨β;n⟩.
Proof.
revert α β; induction n; simpl; intros; split; auto.
- intros _ i Hi; lia.
- intros H; rewrite H; auto. rewrite (proj1 (IHn α β)); auto.
  intros i Hi; apply H; auto.
- intros H i Hi. destruct (eq_dec i n).
  + subst; injection H; auto.
  + apply IHn; try lia. injection H; auto.
Qed.

(* Apartness must occur after any coincedence. *)
Lemma eqn_le_apart α β m n : eqn m α β -> α n <> β n -> m <= n.
Proof. intros Heq Hneq. apply not_gt; intros H. apply Hneq. apply Heq, H. Qed.

(* If there is no coincedence there is apartness. *)
Lemma not_eqn_apart α β n :
  ~eqn n α β -> seq_apart α β.
Proof.
induction n; intros.
- exfalso; now apply H.
- destruct (eq_dec (α n) (β n)).
  + apply IHn; intros Hn; apply H. intros i Hi.
    destruct (eq_dec i n); subst; auto. apply Hn; lia.
  + now exists n.
Qed.

End Coincedence.

(* Facts about delete and fill *)
Section DeleteFill.

(* Delete 0 elements. *)
Lemma del0 α : del 0 α = α.
Proof.
apply functional_extensionality.
intros; unfold del; rewrite add_0_l; auto.
Qed.

(* Fill 0 elements. *)
Lemma fill0 α : fill 0 α = α.
Proof.
apply functional_extensionality.
intros; unfold fill; rewrite sub_0_r; auto.
Qed.

(* Rewrite deletion. *)
Lemma del_access α m n : del m α n = α (m + n).
Proof. auto. Qed.

(* Repeated deletion *)
Lemma del_add_distr n m α :
  del n (del m α) = del (m + n) α.
Proof.
unfold del; apply functional_extensionality.
intros. rewrite add_assoc; auto.
Qed.

End DeleteFill.

(* Facts about sequence comparison *)
Section Compare.

Lemma compare_comm n α β :
  compare n α β = compare n β α.
Proof.
revert α β; induction n; simpl; intros; auto.
rewrite eqb_sym. destruct (β 0 =? α 0); auto.
Qed.

(* Comparison returns at most its input. *)
Lemma compare_le n α β :
  compare n α β <= n.
Proof.
revert α β; induction n; simpl; intros; auto.
destruct (α 0 =? β 0); try lia. apply (succ_le_mono _ n). auto.
Qed.

(* If comparison returns less than its input there is an inequality. *)
Lemma compare_lt n α β :
  compare n α β < n -> α (compare n α β) <> β (compare n α β).
Proof.
revert α β; induction n; simpl; intros. lia.
destruct (α 0 =? β 0) eqn:E; bool_to_Prop; auto.
apply succ_lt_mono in H. apply IHn in H.
rewrite ?del_access, ?add_1_l in H; auto.
Qed.

(* Comparison implies coincedence. *)
Lemma eqn_compare n α β :
  eqn (compare n α β) α β.
Proof.
remember (compare n α β) as k.
revert Heqk; revert n α β. induction k; intros n α β Hk i Hi. lia.
revert Hk. destruct n; simpl. discriminate. intros.
destruct (α 0 =? β 0) eqn:E; bool_to_Prop; try discriminate.
injection Hk; intros. apply IHk in H. destruct (eq_dec i 0); subst; auto.
replace i with (1 + (i - 1)) by lia. apply H; lia.
Qed.

End Compare.

(* Facts about properties of sequence elements *)
Section SeqProp.

Variable P : nat -> Prop.

Lemma pre_prop n α β :
  (∀i, P (α i))
  -> (∀i, P (β i))
  -> (∀i, P (pre n α β i)).
Proof.
intros Hα Hβ i; unfold pre, replace, fill.
destruct (i <? n); auto.
Qed.

End SeqProp.

(* Facts about get *)
Section GetPrefix.

(* Append single element back to deletion. *)
Lemma get_app_S n m α :
  ⟨del (S n) α;m⟩ ++ [α n] = ⟨del n α;S m⟩.
Proof.
induction m; simpl. unfold del; rewrite add_0_r; auto.
rewrite IHm; simpl; unfold del.
replace (S n + m) with (n + S m) by lia; auto.
Qed.

(* Delete and append *)
Lemma get_app_del n m α :
  ⟨α;n + m⟩ = ⟨del n α;m⟩ ++ ⟨α;n⟩.
Proof.
revert α. induction n, m; simpl; intros; auto.
- rewrite del0, app_nil_r; auto.
- rewrite add_0_r; auto.
- apply cons_split.
  + unfold del. replace (n + S m) with (S n + m) by lia. auto.
  + assert(R: ∀x (v w : fseq), v ++ x :: w = (v ++ [x]) ++ w).
    { intros; induction v; simpl; auto. rewrite IHv; auto. }
    rewrite R, get_app_S, <-IHn; auto.
Qed.

(* Equality implies the same length prefix. *)
Lemma get_n_eq n m α β :
  ⟨α;n⟩ = ⟨β;m⟩ -> n = m.
Proof.
revert m; induction n; simpl.
- now destruct m.
- destruct m. now simpl. simpl; intros H.
  injection H; intros. apply IHn in H0. now subst.
Qed.

Corollary get_eq_l n m α β : ⟨α;n⟩ = ⟨β;m⟩ -> ⟨α;n⟩ = ⟨β;n⟩.
Proof. intros; apply get_n_eq in H as R; now subst. Qed.

Corollary get_eq_r n m α β : ⟨α;n⟩ = ⟨β;m⟩ -> ⟨α;m⟩ = ⟨β;m⟩.
Proof. intros; apply get_n_eq in H as R; now subst. Qed.

Corollary get_n_neq n m α β : n <> m -> ⟨α;n⟩ <> ⟨β;m⟩.
Proof. intros H P. apply H. eapply get_n_eq. apply P. Qed.

Lemma get_length α n : length ⟨α;n⟩ = n.
Proof. induction n; simpl; auto. Qed.

End GetPrefix.

(* Facts about prefix *)
Section Prefix.

(* A prefixed sequence coincides with itself. *)
Lemma eqn_pre n m α β :
  eqn n α (pre (n + m) α β).
Proof.
intros i Hi; unfold pre, replace, fill.
replace (i <? n + m) with true by bool_lia; auto.
Qed.

Corollary eqn_pre_n n α β : eqn n α (pre n α β).
Proof. rewrite <-add_0_r at 2. apply eqn_pre. Qed.

(* Prefix zero elements. *)
Lemma pre0 α β :
  pre 0 α β = β.
Proof.
extensionality n. unfold pre, replace, fill.
replace (n <? 0) with false by bool_lia.
rewrite sub_0_r; auto.
Qed.

(* Access sequence after prefix. *)
Lemma pre_l n m α β :
  (pre (n + S m) α β) n = α n.
Proof.
unfold pre, replace, fill.
replace (n <? n + S m) with true by bool_lia; auto.
Qed.

(* Access prefix. *)
Lemma pre_r n m α β :
  (pre n α β) (n + m) = β m.
Proof.
unfold pre, replace, fill.
replace (n + m <? n) with false by bool_lia.
replace (n + m - n) with m by lia.
auto.
Qed.

Corollary pre_l0 n α β : (pre (S n) α β) 0 = α 0.
Proof. rewrite <-(add_0_l (S n)). apply pre_l. Qed.

Corollary pre_r0 n α β : (pre n α β) n = β 0.
Proof. rewrite <-(add_0_r n) at 2. apply pre_r. Qed.

Lemma pre_get_l n m α β :
  ⟨pre (n + m) α β;n⟩ = ⟨α;n⟩.
Proof.
revert m; induction n; simpl; intros; auto.
replace (S (n + m)) with (n + S m) by lia.
rewrite pre_l, IHn; auto.
Qed.

(* Get prefixed elements. *)
Lemma pre_get n m α β :
  ⟨pre n α β;n + m⟩ = ⟨β;m⟩ ++ ⟨α;n⟩.
Proof.
revert n; induction m; simpl; intros.
- rewrite add_0_r. rewrite <-(add_0_r n) at 2. rewrite pre_get_l; auto.
- replace (n + S m) with (S (n + m)) by lia; simpl. rewrite <-IHm.
  rewrite pre_r; auto.
Qed.

End Prefix.

(* Facts about iota and range *)
Section IotaRange.

Lemma iota_cons n k :
  iota n (S k) = n :: iota (S n) k.
Proof. auto. Qed.

Lemma iota_add_app_r n k l :
  iota n (k + l) = iota n k ++ iota (n + k) l.
Proof.
revert n l; induction k; intros; simpl.
- rewrite add_0_r; auto.
- rewrite IHk. replace (S n + k) with (n + S k) by lia; auto.
Qed.

Lemma range_add_app_r n m k :
  n <= m -> n..(m + S k) = n..m ++ (S m)..(m + S k).
Proof.
unfold range; intros H.
replace (1 + (m + S k) - n) with (1 + m - n + S k) by lia.
rewrite iota_add_app_r; apply app_split; auto.
replace (n + (1 + m - n)) with (S m) by lia.
replace (1 + (m + S k) - S m) with (S k) by lia; auto.
Qed.

Lemma in_iota n k x :
  In x (iota n k) <-> n <= x < n + k.
Proof.
revert n; induction k; simpl. lia. split.
- intros [H|H]. subst; lia. apply IHk in H; lia.
- intros H. destruct (eq_dec n x). now left. right. apply IHk; lia.
Qed.

Corollary in_range n m x : In x (range n m) <-> n <= x <= m.
Proof. split; intros. apply in_iota in H; lia. apply in_iota; lia. Qed.

End IotaRange.

(* Facts about upb *)
Section Upb.

Lemma in_upb_le s n :
  In n s -> n <= upb s.
Proof.
induction s; simpl. easy. intros [H|H].
subst; lia. apply IHs in H. lia.
Qed.

Lemma upb_le_map_iota f k l i n :
  k <= i < k + l -> n <= f i -> n <= upb (map f (iota k l)).
Proof.
revert k; induction l; intros; simpl. lia.
apply max_le_iff. destruct (eq_dec k i); subst.
now left. right. apply IHl; auto. lia.
Qed.

End Upb.

(* Facts about intersection *)
Section Intersection.

Variable X : baire.
Variable s : fseq.

Lemma isect_nil α : α ∈ X -> α ∈ X ∩ [].
Proof. easy. Qed.

Lemma isect_cons n α : α ∈ X ∩ (n :: s) -> α ∈ X ∩ s.
Proof. intros [H1 H2]. split; auto. now injection H2. Qed.

Lemma isect_inv α : α ∈ X ∩ s -> α ∈ X.
Proof. now intros [H _]. Qed.

Lemma isect_cons_length α : α ∈ X ∩ s -> α ∈ X ∩ (α (length s) :: s).
Proof. intros [H1 H2]. split; auto. simpl. now rewrite H2. Qed.

End Intersection.


From Coq Require Export
     Vector Fin.
From Coq Require Import
     Program.Equality.

From Coq Require
     List.

From CTree Require Import Core.Utils.

From Equations Require Import Equations.

Import VectorNotations.
Declare Scope fin_vector_scope.

Notation vec n T := (Vector.t T n).
Notation fin := Fin.t.

Equations vector_remove{A n}(v: vec (S n) A)(i: fin (S n)) : vec n A by wf n lt :=
  vector_remove (h :: h' :: ts) (FS (FS j)) := h :: (vector_remove (h' :: ts) (FS j));
  vector_remove (h :: h' :: ts) (FS F1) := h :: ts;
  vector_remove (h :: h' :: ts) F1 := h' :: ts;
  vector_remove (h::nil) F1 := @nil A.
Transparent vector_remove.

Equations vector_replace{A n}(v: vec n A)(i: fin n)(a: A): vec n A by wf n lt :=
  vector_replace [] _ _ := [];
  vector_replace (h :: h' :: ts) (FS (FS j)) a := h :: (vector_replace (h' :: ts) (FS j) a);
  vector_replace (h :: h' :: ts) (FS F1) a := h :: a :: ts;
  vector_replace (h :: h' :: ts) F1 a := a :: h' :: ts;
  vector_replace [h] F1 a := [a].
Transparent vector_replace.

Notation "v '@' i ':=' a" := (vector_replace v i a) (at level 80): fin_vector_scope.
Notation "v '$' i" := (nth v i) (at level 80): fin_vector_scope.
Notation "v '--' i" := (vector_remove v i) (at level 80): fin_vector_scope.

(** Vector utils *)
Equations forallb {A}{m: nat}(f: A -> bool)(a: vec m A): bool :=
  forallb _ [] := true;
  forallb f (h :: ts) := andb (f h) (forallb f ts).
Transparent forallb.

Lemma forall_reflect: forall A (m: nat)(f: A -> bool) (l: vec m A),
    forallb f l = true <-> Forall (fun x => f x = true) l.
Proof.
  intros A m f l.
  split; intros.
  - dependent induction l.
    + econstructor.
    + econstructor; cbn in H; apply andb_prop in H;
        destruct H.
      * exact H.
      * apply IHl; assumption.
  - dependent induction H.
    + reflexivity.
    + cbn;
        apply andb_true_intro; split; assumption.
Defined.

Fixpoint fin_all (n : nat) : list (fin n) :=
  match n as n return list (fin n) with
  | 0 => List.nil
  | S n => List.cons (@F1 n) (List.map (@FS _) (fin_all n))
  end%list.

Theorem fin_all_In : forall {n} (f : fin n),
    List.In f (fin_all n).
Proof.
  induction n; intros.
  inversion f.
  remember (S n). destruct f.
  simpl; firstorder.
  inversion Heqn0. subst.
  simpl. right. apply List.in_map. auto.
Qed.

Theorem fin_case : forall n (f : fin (S n)),
    f = F1 \/ exists f', f = FS f'.
Proof.
  intros. generalize (fin_all_In f). intros.
  destruct H; auto.
  eapply List.in_map_iff in H. right. destruct H.
  exists x. intuition.
Qed.

Lemma vec0 {T}: forall (v:Vector.t T 0), v = [].
  apply (Vector.case0 (fun x => x=[])).
  reflexivity.
Qed.

Fixpoint zip {A B : Type} {n : nat} (a : Vector.t A n) (b : Vector.t B n) : Vector.t (A * B) n :=
  match a in Vector.t _ n return Vector.t B n -> Vector.t (A * B) n  with
  | ha :: ta => fun b => (ha, Vector.hd b) :: zip ta (Vector.tl b)
  | [] => fun _ => []
  end b.

Definition pairwise{A B n}(R: rel A B): rel (vec n A) (vec n B) :=
  fun a b => @Forall (A * B) (fun '(a, b) => R a b) n (zip a b).

Section VInversion.
  Context {A: Type}.
  Lemma inversion_aux : forall n (v: Vector.t A n),
      match n return Vector.t A n -> Prop with
      | 0 => fun v => v = []
      | _ => fun v => exists x y, v = x :: y
      end v.
  Proof.
    intros. destruct v; repeat eexists; trivial.
  Qed.

  Lemma inversion_0 : forall (v:Vector.t A 0), v = [].
  Proof.
    intros. apply (inversion_aux 0).
  Qed.
  Lemma inversion_Sn : forall {n} (v : Vector.t A (S n)),
      exists a b, v = a :: b.
  Proof.
    intros. apply (inversion_aux (S n)).
  Qed.
End VInversion.

(** List utils *)
Fixpoint last{A}(l: list A): option A :=
  match l with
  | List.nil => None
  | List.cons h List.nil => Some h
  | List.cons h ts => last ts
  end.

Fixpoint init{A}(l: list A): list A :=
  match l with
  | List.nil => List.nil
  | List.cons h List.nil => List.nil
  | List.cons h ts => List.cons h (init ts)
  end.