From stdpp Require Import prelude.
From Coq Require Import Classical IndefiniteDescription.
From sets Require Import Functions Ensemble.
From AML Require Import Signature Pattern Variables Substitution.
From AML Require Import Structure Valuation PropositionalPatternValuation.

Section sec_pattern_valuation.

Context
  `{signature}
  (s : Structure)
  .

Definition ext_iapp (B C : Ensemble idomain) : Ensemble idomain :=
    fun x => exists b, b ∈ B /\ exists c, c ∈ C /\ x ∈ iapp b c.

Fixpoint pattern_valuation (e : Valuation) (p : Pattern) : Ensemble idomain :=
  match p with
  | PEVar x => {[eval e x]}
  | PSVar X => sval e X
  | POp o => isigma o
  | PApp ϕ ψ => ext_iapp (pattern_valuation e ϕ) (pattern_valuation e ψ)
  | PImpl ϕ ψ => complement (pattern_valuation e ϕ ∖ pattern_valuation e ψ)
  | PEx x ϕ => indexed_union (fun a => pattern_valuation (valuation_eupdate e x a) ϕ)
  | μₚ X ϕ => filtered_intersection (fun B => pattern_valuation (valuation_supdate e X B) ϕ ⊆ B) id
  end.

Lemma pattern_valuation_app e ϕ ψ :
  pattern_valuation e (PApp ϕ ψ)
    =
  ext_iapp (pattern_valuation e ϕ) (pattern_valuation e ψ).
Proof. done. Qed.

Lemma pattern_valuation_ex e x ϕ :
  pattern_valuation e (PEx x ϕ)
    =
  indexed_union (fun a => pattern_valuation (valuation_eupdate e x a) ϕ).
Proof. done. Qed.

Lemma pattern_valuation_mu e X ϕ :
  pattern_valuation e (μₚ X ϕ)
    =
  filtered_intersection  (fun B => pattern_valuation (valuation_supdate e X B) ϕ ⊆ B) id.
Proof. done. Qed.

Lemma pattern_valuation_bot e : pattern_valuation e pBot ≡ ∅.
Proof.
  cbn; intro; rewrite elem_of_filtered_intersection; split;
    [| by intro Hempty; contradict Hempty; apply not_elem_of_empty].
  by intro Hbot; apply Hbot; rewrite fn_update_eq.
Qed.

#[export] Instance propositional_pattern_valuation e :
  PropositionalPatternValuation (pattern_valuation e).
Proof. by constructor; [apply pattern_valuation_bot |]. Qed.

Section set_pattern_valuation.

Context `{Set_ Pattern PatternSet}.

Definition set_pattern_valuation  (e : Valuation) (Gamma : PatternSet) : Ensemble idomain :=
  set_propositional_pattern_valuation s (pattern_valuation e) Gamma.

Lemma elem_of_set_pattern_valuation e Gamma a :
  a ∈ set_pattern_valuation e Gamma
    <->
  forall ϕ, ϕ ∈ Gamma -> a ∈ pattern_valuation e ϕ.
Proof. by apply elem_of_set_propositional_pattern_valuation. Qed.

#[export] Instance set_pattern_valuation_proper e :
  Proper ((≡) ==> (≡)) (set_pattern_valuation e).
Proof. by apply set_propositional_pattern_valuation_proper. Qed.

#[export] Instance set_pattern_valuation_proper_subseteq e :
  Proper ((⊆) --> (⊆)) (set_pattern_valuation e).
Proof. by apply set_propositional_pattern_valuation_proper_subseteq. Qed.

Lemma set_pattern_valuation_empty_top e : set_pattern_valuation e ∅ ≡ top idomain.
Proof. by eapply set_propositional_pattern_valuation_empty_top. Qed.

Lemma set_pattern_valuation_singleton e ϕ :
  set_pattern_valuation e {[ϕ]} ≡ pattern_valuation e ϕ.
Proof. by eapply set_propositional_pattern_valuation_singleton; [typeclasses eauto |]. Qed.

Lemma top_set_pattern_valuation e Gamma :
  set_pattern_valuation e Gamma ≡ top idomain
    <->
  forall ϕ, ϕ ∈ Gamma -> pattern_valuation e ϕ ≡ top idomain.
Proof. by eapply top_set_propositional_pattern_valuation. Qed.

End set_pattern_valuation.

Lemma pattern_valuation_forall_classic e x ϕ :
  pattern_valuation e (pAll x ϕ)
    ≡
  indexed_intersection (fun a => pattern_valuation (valuation_eupdate e x a) ϕ).
Proof.
  unfold pAll; rewrite pattern_valuation_neg_classic by typeclasses eauto.
  rewrite pattern_valuation_ex, complement_indexed_union.
  intro a; rewrite !elem_of_indexed_intersection.
  apply forall_proper; intro a_x; unfold compose.
  by rewrite pattern_valuation_neg_classic, complement_twice_classic by typeclasses eauto.
Qed.

Record FV_equal (e1 e2 : Valuation) (ϕ : Pattern) : Prop :=
{
  fve_evar : forall x, EVarFree x ϕ -> eval e1 x = eval e2 x;
  fve_svar : forall X, SVarFree X ϕ -> sval e1 X ≡ sval e2 X;
}.

Lemma FV_equal_equiv e1 e2 ϕ : e1 ≡ e2 -> FV_equal e1 e2 ϕ.
Proof.
  intros []; split; intros; [apply veqve | apply veqvs].
Qed.

Lemma elem_of_ext_iapp a B C :
  a ∈ ext_iapp B C <-> exists b, b ∈ B /\ exists c, c ∈ C /\ a ∈ iapp b c.
Proof. done. Qed.

Lemma ext_iapp_empty_r : forall B, ext_iapp B ∅ ≡ ∅.
Proof.
  intros B; apply elem_of_equiv_empty.
  intros x (_ & _ & c & Hc & _); contradict Hc; eapply not_elem_of_empty.
Qed.

Lemma ext_iapp_empty_l : forall B, ext_iapp ∅ B ≡ ∅.
Proof.
  intros B; apply elem_of_equiv_empty.
  intros x (c & Hc & _); contradict Hc; eapply not_elem_of_empty.
Qed.

Lemma ext_iapp_union_l C D B :
  ext_iapp (C ∪ D) B ≡ ext_iapp C B ∪ ext_iapp D B.
Proof.
  intro a; rewrite elem_of_union; split.
  - intros (cd & Hcd & b & Hb & Ha); rewrite elem_of_union in Hcd.
    by destruct Hcd as [Hc | Hd]; [left | right]; repeat esplit.
  - intros [(c & Hc & b & Hb & Ha) | (d & Hd & b & Hb & Ha)];
      eexists; rewrite elem_of_union; split; [by left | | by right |];
      by repeat esplit.
Qed.

Lemma ext_iapp_union_r C D B :
  ext_iapp B (C ∪ D) ≡ ext_iapp B C ∪ ext_iapp B D.
Proof.
  intro a; rewrite elem_of_union; split.
  - intros (b & Hb & cd & Hcd & Ha); rewrite elem_of_union in Hcd.
    by destruct Hcd as [Hc | Hd]; [left | right]; repeat esplit.
  - intros [(b & Hb & c & Hc & Ha) | (b & Hb & d & Hd & Ha)];
      eexists; (split; [done |]); eexists; rewrite elem_of_union;
      split; [by left | | by right |];
      by repeat esplit.
Qed.

Lemma ext_iapp_intersection_l C D B :
  ext_iapp (C ∩ D) B ⊆ ext_iapp C B ∩ ext_iapp D B.
Proof.
  intro a; rewrite elem_of_intersection.
  intros (cd & Hcd & b & Hb & Ha); rewrite elem_of_intersection in Hcd.
  by destruct Hcd as [Hc Hd]; repeat esplit.
Qed.

Lemma ext_iapp_intersection_r C D B :
  ext_iapp B (C ∩ D) ⊆ ext_iapp B C ∩ ext_iapp B D.
Proof.
  intro a; rewrite elem_of_intersection.
  intros (b & Hb & cd & Hcd & Ha); rewrite elem_of_intersection in Hcd.
  by destruct Hcd as [Hc Hd]; repeat esplit.
Qed.

Lemma ext_iapp_filtered_union_l `(P : index -> Prop) (A : index -> Ensemble idomain) B :
  ext_iapp (filtered_union P A) B ≡ filtered_union P (fun i => ext_iapp (A i) B).
Proof.
  split.
  - by intros (a & (i & Hi & Ha) & b & Hb & Hx); repeat esplit.
  - by intros (i & Hi & ai & Hai & b & Hb & Hx); repeat esplit.
Qed.

Lemma ext_iapp_indexed_union_l `(A : index -> Ensemble idomain) B :
  ext_iapp (indexed_union A) B ≡ indexed_union (fun i => ext_iapp (A i) B).
Proof. by apply ext_iapp_filtered_union_l. Qed.

Lemma ext_iapp_filtered_union_r `(P : index -> Prop) (A : index -> Ensemble idomain) B :
  ext_iapp B (filtered_union P A) ≡ filtered_union P (fun i => ext_iapp B (A i)).
Proof.
  split.
  - by intros (b & Hb & a & (i & Hi & Ha) & Hx); repeat esplit.
  - by intros (i & b & Hb & Hi & ai & Hai & Hx); repeat esplit.
Qed.
Lemma ext_iapp_indexed_union_r `(A : index -> Ensemble idomain) B :
  ext_iapp B (indexed_union A) ≡ indexed_union (fun i => ext_iapp B (A i)).
Proof. by apply ext_iapp_filtered_union_r. Qed.

Lemma ext_iapp_filtered_intersection_l `(P : index -> Prop) (A : index -> Ensemble idomain) B :
  ext_iapp (filtered_intersection P A) B ⊆ filtered_intersection P (fun i => ext_iapp (A i) B).
Proof.
  intros x (a & Ha & b & Hb & Hx) i Hi.
  by exists a; split; [apply Ha | repeat esplit].
Qed.

Lemma ext_iapp_indexed_intersection_l `(A : index -> Ensemble idomain) B :
  ext_iapp (indexed_intersection A) B ⊆ indexed_intersection (fun i => ext_iapp (A i) B).
Proof. by apply ext_iapp_filtered_intersection_l. Qed.

Lemma ext_iapp_filtered_intersection_r `(P : index -> Prop) (A : index -> Ensemble idomain) B :
  ext_iapp B (filtered_intersection P A) ⊆ filtered_intersection P (fun i => ext_iapp B (A i)).
Proof.
  intros x (b & Hb & a & Ha & Hx) i Hi.
  exists b; split; [done |].
  by exists a; split; [apply Ha |].
Qed.

Lemma ext_iapp_indexed_intersection_r `(A : index -> Ensemble idomain) B :
  ext_iapp B (indexed_intersection A) ⊆ indexed_intersection (fun i => ext_iapp B (A i)).
Proof. by apply ext_iapp_filtered_intersection_r. Qed.

#[export] Instance ext_iapp_Proper_subseteq_l : Proper ((⊆) ==> (≡) ==> (⊆)) ext_iapp.
Proof.
  intros B C Hbc D E Hde.
  intros a (b & Hb & d & Hd & Ha).
  by exists b; split; [apply Hbc | exists d; split; [apply Hde |]].
Qed.

#[export] Instance ext_iapp_Proper_subseteq_r : Proper ((≡) ==> (⊆) ==> (⊆)) ext_iapp.
Proof.
  intros B C Hbc D E Hde.
  intros a (b & Hb & d & Hd & Ha).
  by exists b; split; [apply Hbc | exists d; split; [apply Hde |]].
Qed.

#[export] Instance ext_iapp_Proper_subseteq : Proper ((⊆) ==> (⊆) ==> (⊆)) ext_iapp.
Proof.
  intros B C Hbc D E Hde.
  by transitivity (ext_iapp B E); [rewrite Hde | rewrite Hbc].
Qed.

#[export] Instance ext_iapp_Proper : Proper ((≡) ==> (≡) ==> (≡)) ext_iapp.
Proof.
  intros B C Hbc D E Hde a; rewrite ! elem_of_ext_iapp.
  by setoid_rewrite Hbc; setoid_rewrite Hde.
Qed.

Lemma ext_iapp_complement_l B C D (Hbc : B ⊆ C) :
  ext_iapp (complement C) D ⊆ ext_iapp (complement B) D.
Proof.
  by eapply complement_subseteq_proper in Hbc; cbn in Hbc; rewrite Hbc.
Qed.

Lemma ext_iapp_complement_r B C D (Hbc : B ⊆ C) :
  ext_iapp D (complement C) ⊆ ext_iapp D (complement B).
Proof.
  by eapply complement_subseteq_proper in Hbc; cbn in Hbc; rewrite Hbc.
Qed.

Lemma pattern_valuation_fv ϕ :
  forall e1 e2, FV_equal e1 e2 ϕ ->
    pattern_valuation e1 ϕ ≡ pattern_valuation e2 ϕ.
Proof.
  induction ϕ; cbn; intros e1 e2 [].
  - by rewrite fve_evar0; [| constructor].
  - by rewrite fve_svar0; [| constructor].
  - rewrite IHϕ1, IHϕ2; [done |..]; split; intros.
    + by apply fve_evar0, ef_impl_right.
    + by apply fve_svar0, sf_impl_right.
    + by apply fve_evar0, ef_impl_left.
    + by apply fve_svar0, sf_impl_left.
  - intro b; rewrite !elem_of_indexed_union.
    cut (forall i : idomain, pattern_valuation (valuation_eupdate e1 e i) ϕ
      ≡ pattern_valuation (valuation_eupdate e2 e i) ϕ);
      [by intro Hrew; setoid_rewrite Hrew |].
    intro a; rewrite IHϕ; [done |].
    split; intros x Hx.
    + cbn; unfold fn_update; case_decide; [done |].
      by apply fve_evar0; constructor.
    + by apply fve_svar0; constructor.
  - intro a; rewrite !elem_of_filtered_intersection.
    apply forall_proper; intro A.
    rewrite IHϕ; [done |].
    split; intros x Hx.
    + by apply fve_evar0; constructor.
    + cbn; unfold fn_update; case_decide; [done |].
      by apply fve_svar0; constructor.
  - intro a; rewrite !elem_of_ext_iapp.
    setoid_rewrite (IHϕ1 e1 e2); [setoid_rewrite (IHϕ2 e1 e2) |]; [done |..];
      split; intros.
    + by apply fve_evar0, ef_app_right.
    + by apply fve_svar0, sf_app_right.
    + by apply fve_evar0, ef_app_left.
    + by apply fve_svar0, sf_app_left.
  - done.
Qed.

Lemma pattern_valuation_eupdate_not_free e x a ϕ :
  ~ EVarFree x ϕ ->
  pattern_valuation (valuation_eupdate e x a) ϕ
    ≡
  pattern_valuation e ϕ.
Proof.
  intro Hx.
  apply pattern_valuation_fv; split; [cbn | done].
  by intros; unfold fn_update; case_decide; subst.
Qed.

Lemma pattern_valuation_supdate_not_free e x a ϕ :
  ~ SVarFree x ϕ ->
  pattern_valuation (valuation_supdate e x a) ϕ
    ≡
  pattern_valuation e ϕ.
Proof.
  intro Hx.
  apply pattern_valuation_fv; split; [done | cbn].
  by intros; unfold fn_update; case_decide; subst.
Qed.

Lemma ClosedPattern_FV_equal (ϕ : Pattern) (e1 e2 : Valuation) :
  ClosedPattern ϕ -> FV_equal e1 e2 ϕ.
Proof. intros []; split; intros x Hx; contradict Hx; done. Qed.

Lemma pattern_valuation_closed_pattern e1 e2 ϕ :
  ClosedPattern ϕ -> pattern_valuation e1 ϕ ≡ pattern_valuation e2 ϕ.
Proof. by intro; apply pattern_valuation_fv, ClosedPattern_FV_equal. Qed.

Instance pattern_valuation_proper : Proper ((≡) ==> (=) ==> (≡)) pattern_valuation.
Proof.
  intros e1 e2 [] _ϕ ϕ ->.
  induction ϕ.
  - by cbn; rewrite veqve.
  - by cbn; rewrite veqvs.
  - by cbn; rewrite IHϕ1, IHϕ2.
  - cbn; intro a; rewrite! elem_of_indexed_union.
    apply exist_proper; intro b.
    by apply pattern_valuation_fv, FV_equal_equiv, valuation_eupdate_proper; [split |..].
  - cbn; intro a; rewrite! elem_of_filtered_intersection.
    apply forall_proper; intro A.
    cut (pattern_valuation (valuation_supdate e1 s0 A) ϕ ≡ pattern_valuation (valuation_supdate e2 s0 A) ϕ);
      [by intros -> |].
    by apply pattern_valuation_fv, FV_equal_equiv, valuation_supdate_proper; [split |..].
  - by cbn; rewrite IHϕ1, IHϕ2.
  - done.
Qed.

Definition evaluates_to_singleton (e : Valuation) (ϕ : Pattern) : Prop :=
  exists a, pattern_valuation e ϕ ≡ {[a]}.

Class always_evaluates_to_singleton (ϕ : Pattern) : Prop :=
{
  aes : forall (e : Valuation), evaluates_to_singleton e ϕ
}.

#[export] Instance always_evaluates_to_singleton_evar x :
  always_evaluates_to_singleton (PEVar x).
Proof. by constructor; intros; eexists. Qed.

Definition singleton_value
  (ϕ : Pattern) `{!always_evaluates_to_singleton ϕ}
  (e : Valuation) : { a : idomain | pattern_valuation e ϕ ≡ {[a]} }.
Proof.
  destruct always_evaluates_to_singleton0.
  specialize (aes0 e).
  by apply constructive_indefinite_description in aes0.
Qed.

Lemma pattern_valuation_evar_sub0_not_free e x delta ϕ c :
  ~ EVarFree x ϕ ->
  pattern_valuation e (evar_sub0 x delta ϕ)
    ≡
  pattern_valuation (valuation_eupdate e x c) ϕ.
Proof.
  intro; erewrite evar_sub0_not_free by done.
  apply pattern_valuation_fv; split; [| done].
  intros y Hy; cbn; unfold fn_update.
  by case_decide; subst.
Qed.

Lemma pattern_valuation_evar_sub0 e x delta ϕ
  `{!always_evaluates_to_singleton delta} :
  EFreeFor x delta ϕ ->
  pattern_valuation e (evar_sub0 x delta ϕ)
    ≡
  pattern_valuation (valuation_eupdate e x (` (singleton_value delta e))) ϕ.
Proof.
  remember (proj1_sig _) as c.
  intros Hfree_for.
  destruct (classic (EVarFree x ϕ)) as [Hfree |];
    [| by apply pattern_valuation_evar_sub0_not_free].
  revert e c Heqc; induction ϕ; try (by inversion Hfree); intros ? c Hc.
  - by inversion Hfree; subst; cbn; unfold fn_update;
      rewrite !decide_True by done; destruct singleton_value.
  - rewrite pattern_valuation_impl_alt_classic by typeclasses eauto.
    apply EFreeForImpl in Hfree_for as [Hfree_for1 Hfree_for2].
    destruct (classic (EVarFree x ϕ1)); [destruct (classic (EVarFree x ϕ2)) |].
    + rewrite <- IHϕ1, <- IHϕ2 by done.
      apply pattern_valuation_impl_alt_classic; typeclasses eauto.
    + rewrite <- IHϕ1, <- pattern_valuation_evar_sub0_not_free
        with (ϕ := ϕ2) (delta := delta) by done.
      apply pattern_valuation_impl_alt_classic; typeclasses eauto.
    + inversion Hfree; [done | subst].
      rewrite <- IHϕ2, <- pattern_valuation_evar_sub0_not_free
        with (ϕ := ϕ1) (delta := delta) by done.
      apply pattern_valuation_impl_alt_classic; typeclasses eauto.
  - apply EFreeForEx in Hfree_for as [Hfree_for1 Hx].
    inversion Hfree; subst y ϕ0.
    cbn; rewrite decide_False by done; cbn.
    intro a; rewrite !elem_of_indexed_union.
    setoid_rewrite IHϕ; [| done..].
    apply exist_proper; intro b.
    rewrite valuation_eupdate_comm by done.
    subst; destruct (singleton_value delta e0) as [c Hc].
    destruct (singleton_value delta (valuation_eupdate e0 e b)) as [d Hd]; cbn.
    rewrite pattern_valuation_fv, Hc in Hd;
      [by apply singleton_equiv_inj in Hd; subst |].
    split; cbn; [| done]; intros; unfold fn_update.
    case_decide; [| done].
    by subst; exfalso; apply Hx.
  - apply EFreeForMu in Hfree_for as [Hfree_for1 Hx].
    inversion Hfree; subst; cbn.
    intro a; rewrite !elem_of_filtered_intersection.
    setoid_rewrite IHϕ; [| done..].
    setoid_rewrite valuation_esupdate_comm.
    apply forall_proper; intro A.
    destruct (singleton_value delta e) as [c Hc].
    destruct (singleton_value delta (valuation_supdate e s0 A)) as [d Hd]; cbn.
    rewrite pattern_valuation_fv, Hc in Hd;
      [by apply singleton_equiv_inj in Hd; subst |].
    split; cbn; [done |]; intros; unfold fn_update.
    case_decide; [| done].
    by subst; exfalso; apply Hx.
  - cbn.
    apply EFreeForApp in Hfree_for as [Hfree_for1 Hfree_for2].
    destruct (classic (EVarFree x ϕ1)); [destruct (classic (EVarFree x ϕ2)) |].
    + by rewrite <- IHϕ1, <- IHϕ2.
    + by rewrite <- IHϕ1, <- pattern_valuation_evar_sub0_not_free
        with (ϕ := ϕ2) (delta := delta).
    + inversion Hfree; [done | subst].
      by rewrite <- IHϕ2, <- pattern_valuation_evar_sub0_not_free
        with (ϕ := ϕ1) (delta := delta).
Qed.

Lemma pattern_valuation_evar_sub0_evar e x y ϕ :
  EFreeFor x (PEVar y) ϕ ->
  pattern_valuation e (evar_sub0 x (PEVar y) ϕ)
    ≡
  pattern_valuation (valuation_eupdate e x (eval e y)) ϕ.
Proof.
  intro Hfree_for.
  unshelve rewrite pattern_valuation_evar_sub0 by done;
    [typeclasses eauto |].
  destruct (singleton_value (PEVar y) e); cbn in *.
  by apply singleton_equiv_inj in e0 as <-.
Qed.

Lemma pattern_valuation_svar_sub0_not_free e x delta ϕ c :
  ~ SVarFree x ϕ ->
  pattern_valuation e (svar_sub0 x delta ϕ)
    ≡
  pattern_valuation (valuation_supdate e x c) ϕ.
Proof.
  intro; erewrite svar_sub0_not_free by done.
  apply pattern_valuation_fv; split; [done |].
  intros y Hy; cbn; unfold fn_update.
  by case_decide; subst.
Qed.

Lemma pattern_valuation_svar_sub0 e x delta ϕ :
  SFreeFor x delta ϕ ->
  pattern_valuation e (svar_sub0 x delta ϕ)
    ≡
  pattern_valuation (valuation_supdate e x (pattern_valuation e delta)) ϕ.
Proof.
  intros Hfree_for.
  destruct (classic (SVarFree x ϕ)) as [Hfree |];
    [| by apply pattern_valuation_svar_sub0_not_free].
  revert e; induction ϕ; try (by inversion Hfree); intros ?.
  - by inversion Hfree; subst; cbn; unfold fn_update;
      rewrite !decide_True by done.
  - rewrite pattern_valuation_impl_alt_classic by typeclasses eauto.
    apply SFreeForImpl in Hfree_for as [Hfree_for1 Hfree_for2].
    destruct (classic (SVarFree x ϕ1)); [destruct (classic (SVarFree x ϕ2)) |].
    + rewrite <- IHϕ1, <- IHϕ2 by done.
      apply pattern_valuation_impl_alt_classic; typeclasses eauto.
    + rewrite <- IHϕ1, <- pattern_valuation_svar_sub0_not_free
        with (ϕ := ϕ2) (delta := delta) by done.
      apply pattern_valuation_impl_alt_classic; typeclasses eauto.
    + inversion Hfree; [done | subst].
      rewrite <- IHϕ2, <- pattern_valuation_svar_sub0_not_free
        with (ϕ := ϕ1) (delta := delta) by done.
      apply pattern_valuation_impl_alt_classic; typeclasses eauto.
  - apply SFreeForEx in Hfree_for as [Hfree_for1 Hx].
    inversion Hfree; subst X ϕ0.
    cbn.
    intro a; rewrite !elem_of_indexed_union.
    setoid_rewrite IHϕ; [| done..].
    apply exist_proper; intro b.
    rewrite valuation_esupdate_comm by done.
    apply pattern_valuation_proper; [| done].
    apply valuation_eupdate_proper; [| done..].
    apply valuation_supdate_proper; [done..|].
    apply pattern_valuation_eupdate_not_free.
    by intro; apply Hx.
  - apply SFreeForMu in Hfree_for as [Hfree_for1 Hx].
    inversion Hfree; subst; cbn; rewrite decide_False by done; cbn.
    intro a; rewrite !elem_of_filtered_intersection.
    setoid_rewrite IHϕ; [| done..].
    apply forall_proper; intro A.
    rewrite valuation_supdate_comm by done.
    cut
      (pattern_valuation
        (valuation_supdate
          (valuation_supdate e x
            (pattern_valuation (valuation_supdate e s0 A) delta)) s0 A) ϕ
        ≡
      pattern_valuation
        (valuation_supdate (valuation_supdate e x (pattern_valuation e delta))
          s0 A) ϕ);
      [by intros -> |].
    apply pattern_valuation_proper; [| done].
    apply valuation_supdate_proper; [| done..].
    apply valuation_supdate_proper; [done.. |].
    apply pattern_valuation_supdate_not_free.
    by intro; apply Hx.
  - cbn.
    apply SFreeForApp in Hfree_for as [Hfree_for1 Hfree_for2].
    destruct (classic (SVarFree x ϕ1)); [destruct (classic (SVarFree x ϕ2)) |].
    + by rewrite <- IHϕ1, <- IHϕ2.
    + by rewrite <- IHϕ1, <- pattern_valuation_svar_sub0_not_free
        with (ϕ := ϕ2) (delta := delta).
    + inversion Hfree; [done | subst].
      by rewrite <- IHϕ2, <- pattern_valuation_svar_sub0_not_free
        with (ϕ := ϕ1) (delta := delta).
Qed.

Lemma pattern_valuation_svar_sub0_svar e x y ϕ :
  SFreeFor x (PSVar y) ϕ ->
  pattern_valuation e (svar_sub0 x (PSVar y) ϕ)
    ≡
  pattern_valuation (valuation_supdate e x (sval e y)) ϕ.
Proof.
  by intro Hfree_for; rewrite pattern_valuation_svar_sub0.
Qed.

Lemma pattern_valuation_nu_classic e X ϕ :
  pattern_valuation e (νₚ X ϕ)
    ≡
  filtered_union (fun B => B ⊆ pattern_valuation (valuation_supdate e X B) ϕ) id.
Proof.
  unfold νₚ.
  rewrite pattern_valuation_neg_classic, pattern_valuation_mu by typeclasses eauto.
  rewrite complement_filtered_intersection_classic.
  assert (Hfree_for : SFreeFor X (pNeg (PSVar X)) ϕ).
  {
    by apply SFreeFor_x_theta_if_no_free_vars; cbn; set_solver.
  }
  intro x; rewrite !elem_of_filtered_union.
  split; intros (A & HA & Hx).
  - rewrite pattern_valuation_neg_classic in HA by typeclasses eauto.
    rewrite pattern_valuation_svar_sub0, valuation_supdate_twice in HA by done.
    apply complement_subseteq_proper in HA; rewrite complement_twice_classic in HA.
    exists (complement A); split; [| done].
    etransitivity; [done |].
    apply set_equiv_subseteq, pattern_valuation_proper; [| done].
    apply valuation_supdate_proper; [done.. |].
    rewrite pattern_valuation_neg_classic by typeclasses eauto.
    by cbn; rewrite fn_update_eq.
  - exists (complement A); split; [| by cbn; rewrite complement_twice_classic].
    apply complement_subseteq_proper in HA.
    etransitivity; [| done].
    apply set_equiv_subseteq.
    rewrite pattern_valuation_neg_classic by typeclasses eauto.
    rewrite pattern_valuation_svar_sub0, valuation_supdate_twice by done.
    apply complement_equiv_proper, pattern_valuation_proper; [| done].
    apply valuation_supdate_proper; [done.. |].
    rewrite pattern_valuation_neg_classic by typeclasses eauto.
    by cbn; rewrite fn_update_eq, complement_twice_classic.
Qed.

Lemma pattern_valuation_positive_negative_proper e X ϕ A B :
  A ⊆ B ->
  (OccursPositively X ϕ ->
  pattern_valuation (valuation_supdate e X A) ϕ
    ⊆
  pattern_valuation (valuation_supdate e X B) ϕ)
  /\
  (OccursNegatively X ϕ ->
  pattern_valuation (valuation_supdate e X B) ϕ
    ⊆
  pattern_valuation (valuation_supdate e X A) ϕ).
Proof.
  intros Hincl; revert e; induction ϕ; try done; intro; split.
  - by cbn; unfold fn_update; case_decide.
  - by inversion 1; cbn; unfold fn_update; rewrite !decide_False.
  - inversion 1 as [| | | | | | | ? ? Hϕ1 Hϕ2]; subst.
    specialize (IHϕ1 e) as [_ IHϕ1].
    specialize (IHϕ2 e) as [IHϕ2 _].
    specialize (IHϕ1 Hϕ1). specialize (IHϕ2 Hϕ2).
    rewrite !pattern_valuation_impl_alt_classic by typeclasses eauto.
    intro a; rewrite !elem_of_union, !elem_of_complement.
    by set_solver.
  - inversion 1 as [| | | | | | | ? ? Hϕ1 Hϕ2]; subst.
    specialize (IHϕ1 e) as [IHϕ1 _].
    specialize (IHϕ2 e) as [_ IHϕ2].
    specialize (IHϕ1 Hϕ1). specialize (IHϕ2 Hϕ2).
    rewrite !pattern_valuation_impl_alt_classic by typeclasses eauto.
    intro a; rewrite !elem_of_union, !elem_of_complement.
    by set_solver.
  - inversion 1; subst; cbn.
    intro a; rewrite !elem_of_indexed_union.
    intros [b Hb]; exists b.
    rewrite <- valuation_esupdate_comm in Hb |- *.
    by apply IHϕ.
  - inversion 1; subst; cbn.
    intro a; rewrite !elem_of_indexed_union.
    intros [b Hb]; exists b.
    rewrite <- valuation_esupdate_comm in Hb |- *.
    by apply IHϕ.
  - inversion 1; subst; cbn; intro a; rewrite !elem_of_filtered_intersection;
      intros HA C HC; apply HA; [by rewrite valuation_supdate_twice in HC |- * |].
    rewrite valuation_supdate_comm in HC |- * by done.
    etransitivity; [| done].
    by apply IHϕ.
  - inversion 1; subst; cbn; intro a; rewrite !elem_of_filtered_intersection;
      intros HA C HC; apply HA; [by rewrite valuation_supdate_twice in HC |- * |].
    rewrite valuation_supdate_comm in HC |- * by done.
    etransitivity; [| done].
    by apply IHϕ.
  - inversion 1 as [| | | ? ? Hϕ1 Hϕ2 | | | |]; subst.
    specialize (IHϕ1 e) as [IHϕ1 _].
    specialize (IHϕ2 e) as [IHϕ2 _].
    specialize (IHϕ1 Hϕ1). specialize (IHϕ2 Hϕ2).
    by cbn; rewrite IHϕ1, IHϕ2.
  - inversion 1 as [| | | ? ? Hϕ1 Hϕ2 | | | |]; subst.
    specialize (IHϕ1 e) as [_ IHϕ1].
    specialize (IHϕ2 e) as [_ IHϕ2].
    specialize (IHϕ1 Hϕ1). specialize (IHϕ2 Hϕ2).
    by cbn; rewrite IHϕ1, IHϕ2.
Qed.

Definition pattern_valuation_fn e ϕ x a :=
  pattern_valuation (valuation_eupdate e x a) ϕ.

Definition pattern_valuation_functor e ϕ X A :=
  pattern_valuation (valuation_supdate e X A) ϕ.

Lemma pattern_valuation_functor_and e ϕ ψ X A :
  pattern_valuation_functor e (ϕ ∧ₚ ψ) X A
    ≡
  pattern_valuation_functor e ϕ X A
    ∩
  pattern_valuation_functor e ψ X A.
Proof.
  unfold pattern_valuation_functor.
  by apply pattern_valuation_and_classic; typeclasses eauto.
Qed.

Lemma pattern_valuation_functor_or e ϕ ψ X A :
  pattern_valuation_functor e (ϕ ∨ₚ ψ) X A
    ≡
  pattern_valuation_functor e ϕ X A
    ∪
  pattern_valuation_functor e ψ X A.
Proof.
  unfold pattern_valuation_functor.
  by apply pattern_valuation_or_classic; typeclasses eauto.
Qed.

Lemma pattern_valuation_functor_free e ϕ X A :
  X ∉ FSV ϕ ->
  pattern_valuation_functor e ϕ X A
    ≡
  pattern_valuation e ϕ.
Proof.
  intros HX; apply pattern_valuation_fv.
  split; intros; [done |].
  rewrite <- SVarFree_FSV in HX.
  cbn; unfold fn_update.
  by case_decide; [subst |].
Qed.

Lemma pattern_valuation_functor_neg e ϕ X A :
  pattern_valuation_functor e (¬ₚ ϕ) X A
    ≡
  complement (pattern_valuation_functor e ϕ X A).
Proof.
  unfold pattern_valuation_functor.
  by apply pattern_valuation_neg_classic; typeclasses eauto.
Qed.

Lemma pattern_valuation_functor_top e X A :
  pattern_valuation_functor e pTop X A ≡ top idomain.
Proof.
  by rewrite pattern_valuation_functor_free, pattern_valuation_top;
    [| typeclasses eauto | cbn; set_solver].
Qed.

Lemma pattern_valuation_functor_app e ϕ ψ X A :
  pattern_valuation_functor e (PApp ϕ ψ) X A
    ≡
  ext_iapp
    (pattern_valuation_functor e ϕ X A)
    (pattern_valuation_functor e ψ X A).
Proof. done. Qed.

Lemma pattern_valuation_positive_proper e ϕ X :
  OccursPositively X ϕ ->
  Proper ((⊆) ==> (⊆)) (pattern_valuation_functor e ϕ X).
Proof.
  by intros Hpos A B Hincl; revert Hpos; apply pattern_valuation_positive_negative_proper.
Qed.

Lemma pattern_valuation_negative_proper e ϕ X :
  OccursNegatively X ϕ ->
  Proper ((⊆) --> (⊆)) (pattern_valuation_functor e ϕ X).
Proof.
  by intros Hneg A B Hincl; revert Hneg; apply pattern_valuation_positive_negative_proper.
Qed.

Lemma pattern_valuation_mu_unroll ϕ X e :
  OccursPositively X ϕ ->
  pattern_valuation e (μₚ X ϕ) ≡
  pattern_valuation (valuation_supdate e X (pattern_valuation e (μₚ X ϕ))) ϕ.
Proof.
  intros Hocc.
  pose proof (pattern_valuation_positive_proper e ϕ X Hocc).
  symmetry; apply (knaster_tarsky_lfp_fix (pattern_valuation_functor e ϕ X)).
Qed.

Lemma pattern_valuation_mu_lfp ϕ X e B :
  OccursPositively X ϕ ->
  pattern_valuation (valuation_supdate e X B) ϕ ≡ B ->
  pattern_valuation e (μₚ X ϕ) ⊆ B.
Proof.
  intros Hocc Hfix.
  pose proof (pattern_valuation_positive_proper e ϕ X Hocc).
  by apply (knaster_tarsky_lfp_least (pattern_valuation_functor e ϕ X)).
Qed.

Lemma pattern_valuation_nu_unroll ϕ X e :
  OccursPositively X ϕ ->
  pattern_valuation e (νₚ X ϕ) ≡
  pattern_valuation (valuation_supdate e X (pattern_valuation e (νₚ X ϕ))) ϕ.
Proof.
  intros Hocc.
  pose proof (pattern_valuation_positive_proper e ϕ X Hocc).
  rewrite pattern_valuation_nu_classic at 1.
  specialize (knaster_tarsky_gfp_fix (pattern_valuation_functor e ϕ X)) as Hgfp.
  unfold fixpoint, gfp, pattern_valuation_functor, post_fixpoint in Hgfp; cbn in Hgfp.
  rewrite <- Hgfp.
  apply pattern_valuation_proper; [| done].
  apply valuation_supdate_proper; [done.. |].
  by rewrite pattern_valuation_nu_classic.
Qed.

Lemma pattern_valuation_nu_gfp ϕ X e B :
  OccursPositively X ϕ ->
  pattern_valuation (valuation_supdate e X B) ϕ ≡ B ->
  B ⊆ pattern_valuation e (νₚ X ϕ).
Proof.
  intros Hocc Hfix.
  pose proof (pattern_valuation_positive_proper e ϕ X Hocc).
  rewrite pattern_valuation_nu_classic.
  by apply (knaster_tarsky_gfp_greatest (pattern_valuation_functor e ϕ X)).
Qed.

Lemma pattern_valuation_context_hole e ϕ :
  pattern_valuation e (csubst Hole ϕ) = pattern_valuation e ϕ.
Proof. done. Qed.

Lemma pattern_valuation_context_l e c ϕ ψ :
  pattern_valuation e (csubst (LApp c ψ) ϕ)
   =
  ext_iapp (pattern_valuation e (csubst c ϕ)) (pattern_valuation e ψ).
Proof. done. Qed.

Lemma pattern_valuation_context_r e c ϕ ψ :
  pattern_valuation e (csubst (RApp ψ c) ϕ)
   =
  ext_iapp (pattern_valuation e ψ) (pattern_valuation e (csubst c ϕ)).
Proof. done. Qed.

End sec_pattern_valuation.


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

- Sebastien Hinderer, 2004-04-20
- Frederic Blanqui, 2005-02-24

polynomials with multiple variables and integer coefficients
*)

Set Implicit Arguments.

Require Import VecUtil LogicUtil List ZArith OrdSemiRing2 Arith.

(***********************************************************************)
(** monomials with n variables *)

Notation monom := (vector nat).

Lemma monom_eq_dec : forall n (m1 m2 : monom n), {m1 = m2} + {~m1 = m2}.

Proof.
intros. eapply eq_vec_dec. apply eq_nat_dec.
Defined.

(* monomial 1 *)
(*
Notation mone := (Vconst 0).

(* monomial x_i^k *)

Fixpoint mxi n : forall i, i < n -> nat -> monom n :=
  match n as n return forall i, i < n -> nat -> monom n with
    | O => fun i h _ => False_rec (monom O) (lt_n_O h)
    | S n' => fun i =>
      match i as i return lt i (S n') -> nat -> monom (S n') with
        | O => fun _ k => Vcons k (mone n')
	| S _ => fun h k => Vcons O (mxi (lt_S_n h) k)
      end
  end.

(* monomial multiplication *)

Definition mmult n (m1 m2 : monom n) := Vmap2 plus m1 m2. *)

(***********************************************************************)
(** polynomials on a Semi-ring *)

Section S.

  Context {R: Ring}.

  Import SR_Notations.

  Add Ring R : r_th.

  (* polynomials with n variables *)

  Definition poly n := list (s_typ * monom n).

  Delimit Scope poly_scope with poly.
  Bind Scope poly_scope    with poly.

  (***********************************************************************)
  (** coefficient of monomial m in polynomial p *)

  Fixpoint coef n (m : monom n) (p : poly n) {struct p} : s_typ :=
    match p with
      | nil => 0
      | cons (c,m') p' =>
        match monom_eq_dec m m' with
	  | left _ => c + coef m p'
	  | right _ => coef m p'
        end
    end.

  (***********************************************************************)
  (** simple polynomials *)

  Notation mone := (Vconst O).

  (* monomial x_i^1 *)

  Fixpoint mxi n : forall i, i < n -> monom n :=
    match n as n return forall i, i < n -> monom n with
      | O => fun i h => False_rec (monom O) (lt_n_O h)
      | S n' => fun i =>
                  match i as i return lt i (S n') -> monom (S n') with
                    | O => fun _ => Vcons (S O) (mone n')
	            | S _ => fun h => Vcons O (mxi (lt_S_n h))
                  end
    end.

  (* polynomial x_i for i<n *)

  Definition pxi n i (h : i < n) := (1, mxi h) :: nil.

  (* null polynomial *)

  Definition pzero n : poly n := nil.

  (* constant polynomial *)

  Definition pconst n (c : s_typ) : poly n := (c, mone n) :: nil.

  (***********************************************************************)
  (** multiplication by a constant *)

  Definition cpmult c n (p : poly n) := map (fun cm => (c * fst cm, snd cm)) p.

  (***********************************************************************)
  (** opposite *)

  Definition popp (n: nat) (p: poly n) := map (fun cm => (- fst cm, snd cm)) p.

  Notation "'-' p" := (popp p) (at level 35, right associativity) : poly_scope.

  (***********************************************************************)
  (** addition *)

  Fixpoint mpadd n (c : s_typ) (m : monom n) (p : poly n) {struct p} : poly n :=
    match p with
      | nil => (c,m) :: nil
      | cons (c',m') p' =>
        match monom_eq_dec m m' with
	  | left _ => (c+c',m) :: p'
	  | right _ => (c',m') :: mpadd c m p'
        end
    end.

  Fixpoint padd n (p1 p2 : poly n) {struct p1} : poly n :=
    match p1 with
      | nil => p2
      | cons (c,m) p' => mpadd c m (padd p' p2)
    end.

  Infix "+" := padd : poly_scope.

  (***********************************************************************)
  (** substraction *)

  Open Local Scope poly_scope.

  Definition pminus (n: nat) (p1 p2: poly n)  :=  p1  + (- p2).

  Infix "-" := pminus : poly_scope.

  (***********************************************************************)
  (** multiplication *)

  Definition mmult n (m1 m2 : monom n) := Vmap2 plus m1 m2.

  Definition mpmult n c (m : monom n) (p : poly n) :=
    map (fun cm => (c * fst cm, mmult m (snd cm))) p.

  Fixpoint pmult n (p1 p2 : poly n) {struct p1} : poly n :=
    match p1 with
      | nil => nil
      | cons (c,m) p' => mpmult c m p2 + pmult p' p2
    end.

  Infix "*" := pmult : poly_scope.

  (***********************************************************************)
  (** power *)

  Fixpoint ppower n (p : poly n) (k : nat) {struct k} : poly n :=
    match k with
      | O => pconst n 1
      | S k' => p * ppower p k'
    end.

  Infix "^" := ppower : poly_scope.

  (***********************************************************************)
  (** composition *)

  Fixpoint mcomp n : monom n -> forall k, vector (poly k) n -> poly k :=
    match n as n return monom n -> forall k, vector (poly k) n -> poly k with
      | O => fun _ k _ => pconst k 1
      | S _ => fun m _ ps => Vhead ps ^ Vhead m * mcomp (Vtail m) (Vtail ps)
    end.

  Fixpoint pcomp n (p : poly n) k (ps : vector (poly k) n) {struct p} : poly k :=
    match p with
      | nil => nil
      | cons (c,m) p' => cpmult c (mcomp m ps) + pcomp p' ps
    end.

  Close Local Scope poly_scope.

  (***********************************************************************)
  (** evaluation *)

  Notation vec := (vector s_typ).

  Fixpoint meval n : monom n -> vec n -> s_typ :=
    match n as n return monom n -> vec n -> s_typ with
      | O => fun _ _ => 1
      | S _ => fun m v => power _ (Vhead v) (Vhead m) * meval (Vtail m) (Vtail v)
    end.

  Fixpoint peval n (p : poly n) (v : vec n) {struct p} : s_typ :=
    match p with
      | nil => 0
      | cons (c,m) p' => c * meval m v + peval p' v
    end.

  Lemma meval_app : forall n1 (m1 : monom n1) (v1 : vec n1)
                           n2 (m2 : monom n2) (v2 : vec n2),
    meval (Vapp m1 m2) (Vapp v1 v2) == meval m1 v1 * meval m2 v2.

  Proof.
    induction m1. intros. VOtac. simpl. ring.
    intros. VSntac v1. simpl. rewrite IHm1. ring.
  Qed.

  Lemma meval_one : forall n (v : vec n), meval (mone n) v == 1.

  Proof.
    intros n v. induction v; simpl. refl. rewrite IHv. ring.
  Qed.

  Lemma meval_xi : forall n i (H: i<n) (v: vec n),
    meval (mxi H) v == Vnth v H.

  Proof.
  induction n. intros. absurd(lt i 0). omega. hyp.
  intro. destruct i; intros; VSntac v. simpl.
  rewrite meval_one. ring. simpl. rewrite IHn. ring.
  Qed.

  Lemma peval_const : forall n c (v : vec n), peval (pconst n c) v == c.

  Proof.
    intros. simpl. rewrite meval_one. ring.
  Qed.

  Lemma peval_app : forall n (p1 p2 : poly n) (v : vec n),
    peval (p1 ++ p2) v == peval p1 v + peval p2 v.

  Proof.
    intros. elim p1. simpl. auto. ring.
    intros (c, m). intros. simpl. rewrite H. ring.
  Qed.

  Lemma peval_opp : forall n (p : poly n) (v : vec n),
    peval (- p) v == - peval p v.

  Proof.
    intros. elim p. simpl. ring.
    intros (c, m). intros. simpl. rewrite H. ring.
  Qed.

  Lemma peval_mpadd : forall n c (m : monom n) (p : poly n) (v : vec n),
    peval (mpadd c m p) v == c * meval m v + peval p v.

  Proof.
    intros. elim p. simpl. ring.
    intros (c', m'). intros. simpl.
    case (monom_eq_dec m m'); simpl; intro. subst m'. ring.
    rewrite H. ring.
  Qed.

  Lemma peval_add : forall n (p1 p2 : poly n) (v : vec n),
    peval (p1 + p2) v == peval p1 v + peval p2 v.

  Proof. intros. elim p1. simpl. ring. auto.
    intros (c, m). intros. simpl. rewrite peval_mpadd. rewrite H. ring.
  Qed.

  Lemma peval_minus : forall n (p1 p2 : poly n) (v : vec n),
    peval (p1 - p2) v == peval p1 v - peval p2 v.

  Proof.
    intros. unfold pminus. rewrite peval_add. rewrite peval_opp. ring.
  Qed.

  Lemma meval_mult : forall n (m1 m2 : monom n) (v : vec n),
    meval (mmult m1 m2) v == meval m1 v * meval m2 v.

  Proof.
    induction n; intros. VOtac. simpl. ring. VSntac m1. VSntac m2.
    simpl. unfold mmult in IHn. rewrite IHn. rewrite power_add. ring.
  Qed.

  Lemma peval_mpmult : forall n c (m : monom n) (p : poly n) (v : vec n),
    peval (mpmult c m p) v == c * meval m v * peval p v.

  Proof.
    induction p; intros; simpl. ring. destruct a. simpl. rewrite IHp.
    rewrite meval_mult. ring.
  Qed.

  Lemma peval_mult : forall n (p1 p2 : poly n) (v : vec n),
    peval (p1 * p2) v == peval p1 v * peval p2 v.

  Proof.
    induction p1; intros; simpl. ring. destruct a. simpl. rewrite peval_add.
    rewrite peval_mpmult. rewrite IHp1. ring.
  Qed.

  Lemma peval_power : forall n (p : poly n) (k : nat) (v : vec n),
    peval (ppower p k) v == power _ (peval p v) k.

  Proof.
    induction k; intros; simpl. rewrite meval_one. ring.
    rewrite peval_mult. rewrite IHk. ring.
  Qed.

  Lemma peval_mcomp : forall n k (m: monom n) (ps: vector (poly k) n)
    (v: vec k), peval (mcomp m ps) v == meval m (Vmap (fun p => peval p v) ps).

  Proof.
    induction n; intros. VOtac. simpl. rewrite meval_one. ring.
    VSntac m. VSntac ps. simpl. rewrite peval_mult. rewrite peval_power.
    rewrite IHn. refl.
  Qed.

  Lemma peval_cpmult : forall n c (p : poly n) (v : vec n),
    peval (cpmult c p) v == c * peval p v.

  Proof.
    induction p; intros; simpl. ring. destruct a. simpl. rewrite IHp. ring.
  Qed.

  Lemma peval_comp : forall n k (p: poly n) (ps: vector (poly k) n) (v: vec k),
    peval (pcomp p ps) v == peval p (Vmap (fun p => peval p v) ps).

  Proof.
    induction p; intros; simpl. ring. destruct a. rewrite peval_add.
    rewrite peval_cpmult. rewrite IHp. rewrite peval_mcomp. ring.
  Qed.

End S.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.
Fixpoint eqb (n m: natural) : bool :=
match n, m with
   | Zero, Zero => true
   | Zero, Succ _ => false
   | Succ _, Zero => false
   | Succ n', Succ m' => eqb n' m'
end.
Fixpoint count  (count_arg1 : lst) (count_arg0 : natural) : natural
           := match  count_arg1, count_arg0 with
              | Nil, x => Zero
              | Cons y z, x => if eqb x y then Succ (count z x) else count z x
              end.

Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
           := match insort_arg1, insort_arg0 with
              | Nil, i => Cons i Nil
              | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
              end.

Fixpoint sort (sort_arg0 : lst) : lst
           := match sort_arg0 with
              | Nil => Nil
              | Cons x y => insort (sort y) x
              end.

Lemma Nat_beq_refl : forall (n : natural), eqb n n = true.
Proof.
   intros.
   induction n.
   - assumption.
   - reflexivity.

Qed.

Lemma Nat_beq_eq : forall (x y : natural), eqb x y = true -> x = y.
Proof.
   intros.
   generalize dependent y.
   induction x.
   - intros. destruct y.
   + simpl in H. apply IHx in H. rewrite H. reflexivity.
   + discriminate.
   - intros. destruct y.
   + discriminate.
   + reflexivity.
Qed.

Lemma less_not_refl : forall (n : natural), less n n = false.
Proof.
   intros.
   induction n.
   - simpl. assumption.
   - reflexivity.

Qed.

Theorem theorem0 : forall (x : natural) (y : lst), eq (count (insort y x) x) (Succ (count y x)).
Proof.
   intros.
  induction y.
  - simpl. destruct (eqb x n) eqn:?.
    + destruct (less x n) eqn:?.
lfind.  rewrite Heqb in Heqb0.  rewrite less_not_refl in Heqb0.  discriminate.
Admitted.


Theorem Modus_tollens : forall P Q : Prop, ~Q /\ (P-> Q) -> ~P.
Proof.
intros.
intro.
apply H.
apply H.
apply H0.
Qed.


Require Import Coq.Bool.Bool.

Inductive digit : Type :=
  | digit_0 : digit
  | digit_1 : digit
  | digit_2 : digit
  | digit_3 : digit
  | digit_4 : digit
  | digit_5 : digit
  | digit_6 : digit
  | digit_7 : digit
  | digit_8 : digit
  | digit_9 : digit.

Example sample_digit : digit.
  apply digit_0.
Qed.

Inductive code : Type :=
  | code_intro : digit -> digit -> digit -> code.

Inductive position : Type :=
  | position_0 : position
  | position_1 : position
  | position_2 : position.

Inductive has_digit : code -> digit -> position -> Prop :=
  | has_digit_0 :
    forall d0 d1 d2,
      has_digit (code_intro d0 d1 d2) d0 position_0
  | has_digit_1 :
    forall d0 d1 d2,
      has_digit (code_intro d0 d1 d2) d1 position_1
  | has_digit_2 :
    forall d0 d1 d2,
      has_digit (code_intro d0 d1 d2) d2 position_2.

Inductive match_at_position : code -> code -> position -> Prop :=
  | match_at_position_intro :
    forall d pos c0 c1,
      has_digit c0 d pos -> has_digit c1 d pos -> match_at_position c0 c1 pos.

Inductive wrong_position : code -> code -> position -> Prop :=
  | wrong_position_intro :
    forall d pos0 pos1 c0 c1,
      has_digit c0 d pos0 ->
        has_digit c1 d pos1 ->
          ~(has_digit c1 d pos0) -> wrong_position c0 c1 pos0.

Inductive invalid_digit_at_position : code -> code -> position -> Prop :=
  | invalid_digit_at_position_intro :
    forall d pos0 c0 c1,
      has_digit c0 d pos0 ->
        (forall pos1, ~(has_digit c1 d pos1)) ->
          invalid_digit_at_position c0 c1 pos0.

Inductive three_different_positions : position -> position -> position -> Prop :=
  | three_different_positions_intro :
    forall p0 p1 p2,
      p0 <> p1 -> p0 <> p2 -> p1 <> p2 -> three_different_positions p0 p1 p2.

Definition code_682 :=
  code_intro digit_6 digit_8 digit_2.

Definition code_614 :=
  code_intro digit_6 digit_1 digit_4.

Definition code_206 :=
  code_intro digit_2 digit_0 digit_6.

Definition code_738 :=
  code_intro digit_7 digit_3 digit_8.

Definition code_870 :=
  code_intro digit_8 digit_7 digit_0.

Inductive condition_0 : code -> Prop :=
  | condition_0_intro :
    forall c p0 p1 p2,
      three_different_positions p0 p1 p2 ->
        match_at_position code_682 c p0 ->
          invalid_digit_at_position code_682 c p1 ->
            invalid_digit_at_position code_682 c p2 ->
              condition_0 c.

Inductive condition_1 : code -> Prop :=
  | condition_1_intro :
    forall c p0 p1 p2,
      three_different_positions p0 p1 p2 ->
        wrong_position code_614 c p0 ->
          invalid_digit_at_position code_614 c p1 ->
            invalid_digit_at_position code_614 c p2 ->
              condition_1 c.

Inductive condition_2 : code -> Prop :=
  | condition_2_intro :
    forall c p0 p1 p2,
      three_different_positions p0 p1 p2 ->
        wrong_position code_206 c p0 ->
          wrong_position code_206 c p1 ->
            invalid_digit_at_position code_206 c p2 ->
              condition_2 c.

Inductive condition_3 : code -> Prop :=
  | condition_3_intro :
    forall c,
      (forall pos, invalid_digit_at_position code_738 c pos) ->
        condition_3 c.

Inductive condition_4 : code -> Prop :=
  | condition_4_intro :
    forall c p0 p1 p2,
      three_different_positions p0 p1 p2 ->
        wrong_position code_870 c p0 ->
          invalid_digit_at_position code_870 c p1 ->
            invalid_digit_at_position code_870 c p2 ->
              condition_4 c.

Inductive valid_code (c : code) : Prop :=
  | valid_code_intro :
    condition_0 c ->
      condition_1 c ->
        condition_2 c ->
          condition_3 c ->
            condition_4 c ->
              valid_code c.

Section Pure_theorems.

  Theorem same_digit_at_pos :
    forall c d0 d1 p,
      has_digit c d0 p ->
        has_digit c d1 p ->
          d0 = d1.
  Proof.
    intros.
    destruct c.
    destruct p;
      inversion H; subst;
      inversion H0; subst;
      reflexivity.
  Qed.

  Theorem three_different_as_all_pos (pr : position -> Prop) :
    forall p0 p1 p2,
      three_different_positions p0 p1 p2 ->
        pr p0 -> pr p1 -> pr p2 ->
          forall p, pr p.
  Proof.
    intros.
    destruct p;
      destruct p0;
      destruct p1;
      destruct p2;
      try auto;
      try (
        inversion H;
        exfalso;
        auto).
  Defined.

  Theorem always_one_of_three :
    forall p p0 p1 p2,
      three_different_positions p0 p1 p2 ->
        p = p0 \/ p = p1 \/ p = p2.
  Proof.
    intros.
    inversion H; subst.
    destruct p, p0;
      try (left; reflexivity);
      right;
      destruct p1;
      try (left; reflexivity);
      right;
      destruct p2;
      try reflexivity;
      try (exfalso; auto).
  Qed.

  Theorem code_012_condition_0 :
    condition_0 (code_intro digit_0 digit_1 digit_2).
  Proof.
    apply condition_0_intro with position_2 position_0 position_1.
    - apply three_different_positions_intro;
      intro H;
      inversion H.
    - apply match_at_position_intro with digit_2.
      apply has_digit_2.
      apply has_digit_2.
    - apply invalid_digit_at_position_intro with digit_6.
      * apply has_digit_0.
      * intros pos1.
        destruct pos1;
          intro Hinv;
          inversion Hinv.
    - apply invalid_digit_at_position_intro with digit_8.
      * apply has_digit_1.
      * intros pos1.
        destruct pos1;
          intro Hinv;
          inversion Hinv.
  Qed.

  Theorem code_012_condition_1 :
    ~(condition_1 (code_intro digit_0 digit_1 digit_2)).
  Proof.
    intro H.
    inversion H; subst.
    destruct p0.
    - inversion H1; subst.
      inversion H4; subst.
      inversion H5.
    - inversion H1; subst.
      inversion H4; subst.
      apply H6.
      apply has_digit_1.
    - inversion H1; subst.
      inversion H4; subst.
      inversion H5.
  Qed.

  Theorem code_012_is_not_valid :
    ~(valid_code (code_intro digit_0 digit_1 digit_2)).
  Proof.
    intro.
    destruct H as [H0 H1 H2 H3 H4].
    apply code_012_condition_1.
    auto.
  Qed.

  Theorem invalid_8 :
    forall c,
      valid_code c ->
        forall pos, ~(has_digit c digit_8 pos).
  Proof.
    intros c H.
    inversion H.
    inversion H3; subst.
    intros pos.
    pose (H5 position_2) as H6.
    inversion H6; subst.
    inversion H7; subst.
    apply H8.
  Qed.

  Theorem wrong_position_0_at_2 :
    forall c,
      valid_code c ->
        has_digit c digit_0 position_0 \/ has_digit c digit_0 position_1.
  Proof.
    intros.
    inversion H.
    inversion H3; subst.
    inversion H4; subst.
    assert (p0 <> position_0).
    { intros Hinv.
      subst.
      inversion H7; subst.
      inversion H10; subst.
      apply (invalid_8 c H pos1).
      apply H11. }
    assert (p0 <> position_1).
    { intros Hinv.
      subst.
      inversion H7; subst.
      inversion H11; subst.
      pose (H5 position_0) as H5_position_0.
      inversion H5_position_0; subst.
      inversion H14; subst.
      apply (H15 pos1).
      auto. }
    assert (p0 = position_2).
    { destruct p0.
      - exfalso.
        apply H10.
        reflexivity.
      - exfalso.
        apply H11.
        reflexivity.
      - reflexivity. }
    subst.
    inversion H7; subst.
    inversion H12; subst.
    destruct pos1.
    - left.
      auto.
    - right.
      auto.
    - exfalso.
      apply H14.
      auto.
  Qed.

  Theorem not_0_at_1 :
    forall c,
      valid_code c ->
        ~(has_digit c digit_0 position_1).
  Proof.
    intros c H Hinv.
    inversion H.
    inversion H2; subst.
    assert (position_1 = p0 \/ position_1 = p1 \/ position_1 = p2) as Hchoice.
    { apply always_one_of_three.
      auto. }
    destruct Hchoice as [Hc | [Hc | Hc]].
    - subst.
      inversion H6; subst.
      inversion H9; subst.
      auto.
    - subst.
      inversion H7; subst.
      inversion H9; subst.
      auto.
    - subst.
      inversion H8; subst.
      inversion H9; subst.
      apply (H10 position_1).
      auto.
  Qed.

  Theorem correct_position_0_at_0 :
    forall c,
      valid_code c ->
        has_digit c digit_0 position_0.
  Proof.
    intros c H.
    pose (wrong_position_0_at_2 c H) as H1.
    destruct H1.
    - auto.
    - exfalso.
      apply (not_0_at_1 c); auto.
  Qed.

  Theorem correct_position_2_at_2 :
    forall c,
      valid_code c ->
        has_digit c digit_2 position_2.
  Proof.
    intros c H.
    inversion H.
    inversion H0; subst.
    destruct p0.
    - inversion H6; subst.
      inversion H9; subst.
      assert (digit_6 = digit_0).
      { apply same_digit_at_pos with c position_0; auto.
        apply correct_position_0_at_0; auto. }
      inversion H11.
    - inversion H6; subst.
      inversion H9; subst.
      exfalso.
      apply invalid_8 with c position_1; auto.
    - inversion H6; subst.
      inversion H9; subst.
      auto.
  Qed.

  Theorem invalid_6 :
    forall c,
      valid_code c ->
        forall pos, ~(has_digit c digit_6 pos).
  Proof.
    intros c H.
    inversion H.
    inversion H2; subst.
    destruct p2.
    - inversion H8; subst.
      inversion H9; subst.
      exfalso.
      apply (H10 position_2).
      apply correct_position_2_at_2.
      auto.
    - inversion H8; subst.
      inversion H9; subst.
      exfalso.
      apply (H10 position_0).
      apply correct_position_0_at_0.
      auto.
    - inversion H8; subst.
      inversion H9; subst.
      apply H10.
  Qed.

  Theorem correct_position_4_at_1 :
    forall c,
      valid_code c ->
        has_digit c digit_4 position_1.
  Proof.
    intros c H.
    inversion H.
    inversion H1; subst.
    destruct p0.
    - exfalso.
      inversion H6; subst.
      inversion H9; subst.
      apply invalid_6 with c pos1; auto.
    - inversion H6; subst.
      inversion H9; subst.
      destruct pos1.
      * assert (digit_1 = digit_0).
        { apply same_digit_at_pos with c position_0.
          - auto.
          - apply correct_position_0_at_0.
            auto. }
        inversion H12.
      * exfalso.
        auto.
      * assert (digit_1 = digit_2).
        { apply same_digit_at_pos with c position_2.
          - auto.
          - apply correct_position_2_at_2.
            auto. }
        inversion H12.
    - inversion H6; subst.
      inversion H9; subst.
      destruct pos1.
      * assert (digit_4 = digit_0).
        { apply same_digit_at_pos with c position_0.
          - auto.
          - apply correct_position_0_at_0.
            auto. }
        inversion H12.
      * auto.
      * assert (digit_4 = digit_2).
        { apply same_digit_at_pos with c position_2.
          - auto.
          - apply correct_position_2_at_2.
            auto. }
        inversion H12.
  Qed.

  Definition code_042 :=
    code_intro digit_0 digit_4 digit_2.

  Theorem only_valid_code_is_042 :
    forall c,
      valid_code c -> c = code_042.
  Proof.
    intros c H.
    assert (has_digit c digit_0 position_0) as Hd0.
    { apply correct_position_0_at_0; auto. }
    assert (has_digit c digit_4 position_1) as Hd1.
    { apply correct_position_4_at_1; auto. }
    assert (has_digit c digit_2 position_2) as Hd2.
    { apply correct_position_2_at_2; auto. }
    destruct c.
    inversion Hd0; subst.
    inversion Hd1; subst.
    inversion Hd2; subst.
    reflexivity.
  Qed.

  Theorem code_042_is_valid :
    valid_code code_042.
  Proof.
    apply valid_code_intro.
    - apply condition_0_intro with position_2 position_0 position_1.
      + apply three_different_positions_intro;
        intro H;
        inversion H.
      + apply match_at_position_intro with digit_2.
        * apply has_digit_2.
        * apply has_digit_2.
      + apply invalid_digit_at_position_intro with digit_6.
        * apply has_digit_0.
        * intros p H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_8.
        * apply has_digit_1.
        * intros p H.
          inversion H.
    - apply condition_1_intro with position_2 position_0 position_1.
      + apply three_different_positions_intro;
        intro H;
        inversion H.
      + apply wrong_position_intro with digit_4 position_1.
        * apply has_digit_2.
        * apply has_digit_1.
        * intro H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_6.
        * apply has_digit_0.
        * intros pos1 H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_1.
        * apply has_digit_1.
        * intros pos1 H.
          inversion H.
    - apply condition_2_intro with position_0 position_1 position_2.
      + apply three_different_positions_intro;
        intro H;
        inversion H.
      + apply wrong_position_intro with digit_2 position_2.
        * apply has_digit_0.
        * apply has_digit_2.
        * intros H.
          inversion H.
      + apply wrong_position_intro with digit_0 position_0.
        * apply has_digit_1.
        * apply has_digit_0.
        * intro H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_6.
        * apply has_digit_2.
        * intros pos1 H.
          inversion H.
    - apply condition_3_intro.
      intros.
      destruct pos.
      + apply invalid_digit_at_position_intro with digit_7.
        * apply has_digit_0.
        * intros pos1 H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_3.
        * apply has_digit_1.
        * intros pos1 H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_8.
        * apply has_digit_2.
        * intros pos1 H.
          inversion H.
    - apply condition_4_intro with position_2 position_0 position_1.
      + apply three_different_positions_intro;
        intro H;
        inversion H.
      + apply wrong_position_intro with digit_0 position_0.
        * apply has_digit_2.
        * apply has_digit_0.
        * intros H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_8.
        * apply has_digit_0.
        * intros pos1 H.
          inversion H.
      + apply invalid_digit_at_position_intro with digit_7.
        * apply has_digit_1.
        * intros pos1 H.
          inversion H.
  Qed.

End Pure_theorems.

Section With_functions.

  Definition get_digit_at_pos (c : code) (p : position) :=
    match c with
    | code_intro d0 d1 d2 => match p with
      | position_0 => d0
      | position_1 => d1
      | position_2 => d2
      end
    end.

  Theorem get_digit_at_pos_correct :
    forall c d p,
      get_digit_at_pos c p = d <-> has_digit c d p.
  Proof.
    intros.
    destruct c.
    split.
    + intro H.
      destruct p; simpl in H; subst.
      - apply has_digit_0.
      - apply has_digit_1.
      - apply has_digit_2.
    + intro H.
      destruct p;
        simpl;
        inversion H;
        reflexivity.
  Qed.

  Definition digit_eq_bool (d0 d1 : digit) : bool :=
    match d0, d1 with
    | digit_0, digit_0 => true
    | digit_1, digit_1 => true
    | digit_2, digit_2 => true
    | digit_3, digit_3 => true
    | digit_4, digit_4 => true
    | digit_5, digit_5 => true
    | digit_6, digit_6 => true
    | digit_7, digit_7 => true
    | digit_8, digit_8 => true
    | digit_9, digit_9 => true
    | _, _ => false
    end.

  Theorem digit_eq_bool_correct :
    forall d0 d1,
      d0 = d1 <-> digit_eq_bool d0 d1 = true.
  Proof.
    split.
    - intro H.
      subst.
      destruct d1;
        reflexivity.
    - intro H.
      destruct d0, d1;
        try reflexivity;
        try inversion H.
  Qed.

  Definition match_at_position_bool (c0 c1 : code) (p : position) : bool :=
    digit_eq_bool (get_digit_at_pos c0 p) (get_digit_at_pos c1 p).

  Theorem match_at_position_bool_correct :
    forall c0 c1 p,
      match_at_position c0 c1 p <-> match_at_position_bool c0 c1 p = true.
  Proof.
    intros c0 c1 p.
    unfold match_at_position_bool.
    split.
    - intro H.
      apply digit_eq_bool_correct.
      inversion H; subst.
      apply get_digit_at_pos_correct in H0.
      apply get_digit_at_pos_correct in H1.
      subst.
      auto.
    - intro H.
      apply digit_eq_bool_correct in H.
      apply match_at_position_intro with (get_digit_at_pos c0 p).
      + apply get_digit_at_pos_correct.
        reflexivity.
      + apply get_digit_at_pos_correct.
        rewrite H.
        reflexivity.
  Qed.

  Definition invalid_digit_at_position_bool (c0 c1 : code) (p : position) : bool :=
    negb (digit_eq_bool (get_digit_at_pos c0 p) (get_digit_at_pos c1 position_0))
    && negb (digit_eq_bool (get_digit_at_pos c0 p) (get_digit_at_pos c1 position_1))
    && negb (digit_eq_bool (get_digit_at_pos c0 p) (get_digit_at_pos c1 position_2)).

  Theorem invalid_digit_at_position_bool_correct :
    forall c0 c1 p,
      invalid_digit_at_position c0 c1 p <-> invalid_digit_at_position_bool c0 c1 p = true.
  Proof.
    intros.
    split.
    - intro H.
      inversion H; subst.
      unfold invalid_digit_at_position_bool.
      apply get_digit_at_pos_correct in H0.
      subst.
      assert (forall pp, digit_eq_bool (get_digit_at_pos c0 p) (get_digit_at_pos c1 pp) = false) as Hpb.
      { intro pp.
        apply not_true_is_false.
        intro Hinv.
        apply H1 with pp.
        apply digit_eq_bool_correct in Hinv.
        apply get_digit_at_pos_correct.
        rewrite <- Hinv.
        reflexivity. }
      rewrite (Hpb position_0).
      rewrite (Hpb position_1).
      rewrite (Hpb position_2).
      reflexivity.
    - intro H.
      apply invalid_digit_at_position_intro with (get_digit_at_pos c0 p).
      + apply get_digit_at_pos_correct.
        reflexivity.
      + intros pos1.
        intro Hinv.
        apply get_digit_at_pos_correct in Hinv.
        unfold invalid_digit_at_position_bool in H.
        rewrite <- Hinv in H.
        apply andb_true_iff in H.
        destruct H.
        apply andb_true_iff in H.
        destruct H.
        apply negb_true_iff in H.
        apply negb_true_iff in H0.
        apply negb_true_iff in H1.
        apply not_true_iff_false in H.
        apply not_true_iff_false in H0.
        apply not_true_iff_false in H1.
        destruct pos1.
        * apply H.
          apply digit_eq_bool_correct.
          reflexivity.
        * apply H1.
          apply digit_eq_bool_correct.
          reflexivity.
        * apply H0.
          apply digit_eq_bool_correct.
          reflexivity.
Qed.

End With_functions.


Require Import Bool.
Require Import ZArith.
Require Import OrderedType.
Require Import OrderedTypeEx.
Require Import MapInterface.

(** File adapted from FMapPositive.v in the standard lib *)

Set Implicit Arguments.
Generalizable All Variables.

Local Open Scope positive_scope.

(** * An implementation of [FMapInterface.S] for positive keys. *)

(** This file is an adaptation to the [FMap] framework of a work by
  Xavier Leroy and Sandrine Blazy (used for building certified compilers).
  Keys are of type [positive], and maps are binary trees: the sequence
  of binary digits of a positive number corresponds to a path in such a tree.
  This is quite similar to the [IntMap] library, except that no path compression
  is implemented, and that the current file is simple enough to be
  self-contained. *)

(** Even if [positive] can be seen as an ordered type with respect to the
  usual order (see [OrderedTypeEx]), we use here a lexicographic order
  over bits, which is more natural here (lower bits are considered first). *)
(** The corresponding instance is already defined in OrderedTypeEx,
   as [positive_l2r_OrderedType]. *)

(** Other positive stuff *)

Fixpoint append (i j : positive) {struct i} : positive :=
    match i with
      | xH => j
      | xI ii => xI (append ii j)
      | xO ii => xO (append ii j)
    end.

Lemma append_assoc_0 :
  forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
Proof.
 induction i; intros; destruct j; simpl;
 try rewrite (IHi (xI j));
 try rewrite (IHi (xO j));
 try rewrite <- (IHi xH);
 auto.
Qed.

Lemma append_assoc_1 :
  forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
Proof.
 induction i; intros; destruct j; simpl;
 try rewrite (IHi (xI j));
 try rewrite (IHi (xO j));
 try rewrite <- (IHi xH);
 auto.
Qed.

Lemma append_neutral_r : forall (i : positive), append i xH = i.
Proof.
 induction i; simpl; congruence.
Qed.

Lemma append_neutral_l : forall (i : positive), append xH i = i.
Proof.
 simpl; auto.
Qed.

(** The module of maps over positive keys *)
Module PositiveMap.
  Module E.
    Definition eq (x y : positive) := @_eq positive
      (@SOT_as_OT positive _ positive_l2r_OrderedType) x y.
    Definition lt (x y : positive) := @_lt positive
      (@SOT_as_OT positive _ positive_l2r_OrderedType) x y.
  End E.
  Hint Unfold E.eq E.lt.
  Module ME := KeyOrderedType.
  Definition key := positive.

  Inductive tree (A : Type) :=
    | Leaf : tree A
    | Node : tree A -> option A -> tree A -> tree A.

  Definition t := tree.

  Section A.
  Variable A:Type.

  Arguments Leaf {A}.

  Definition empty : t A := Leaf.

  Fixpoint is_empty (m : t A) {struct m} : bool :=
   match m with
    | Leaf => true
    | Node l None r => (is_empty l) && (is_empty r)
    | _ => false
   end.

  Fixpoint find (i : positive) (m : t A) {struct i} : option A :=
    match m with
    | Leaf => None
    | Node l o r =>
        match i with
        | xH => o
        | xO ii => find ii l
        | xI ii => find ii r
        end
    end.

  Fixpoint mem (i : positive) (m : t A) {struct i} : bool :=
    match m with
    | Leaf => false
    | Node l o r =>
        match i with
        | xH => match o with None => false | _ => true end
        | xO ii => mem ii l
        | xI ii => mem ii r
        end
    end.

  Fixpoint add (i : positive) (v : A) (m : t A) {struct i} : t A :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf (Some v) Leaf
        | xO ii => Node (add ii v Leaf) None Leaf
        | xI ii => Node Leaf None (add ii v Leaf)
        end
    | Node l o r =>
        match i with
        | xH => Node l (Some v) r
        | xO ii => Node (add ii v l) o r
        | xI ii => Node l o (add ii v r)
        end
    end.

  Fixpoint insert (i : positive) (v : A) (f : A -> A) (m : t A) : t A :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf (Some v) Leaf
        | xO ii => Node (insert ii v f Leaf) None Leaf
        | xI ii => Node Leaf None (insert ii v f Leaf)
        end
    | Node l o r =>
        match i with
        | xH =>
          Node l (match o with None => Some v | Some v' => Some (f v') end) r
        | xO ii => Node (insert ii v f l) o r
        | xI ii => Node l o (insert ii v f r)
        end
    end.

  Fixpoint adjust (i : positive) (f : A -> A) (m : t A) : t A :=
    match m with
    | Leaf =>
        match i with
        | xH => m
        | xO ii => Node (adjust ii f Leaf) None Leaf
        | xI ii => Node Leaf None (adjust ii f Leaf)
        end
    | Node l o r =>
        match i with
        | xH =>
          Node l (match o with None => None | Some v => Some (f v) end) r
        | xO ii => Node (adjust ii f l) o r
        | xI ii => Node l o (adjust ii f r)
        end
    end.

  Fixpoint remove (i : positive) (m : t A) {struct i} : t A :=
    match i with
    | xH =>
        match m with
        | Leaf => Leaf
        | Node Leaf o Leaf => Leaf
        | Node l o r => Node l None r
        end
    | xO ii =>
        match m with
        | Leaf => Leaf
        | Node l None Leaf =>
            match remove ii l with
            | Leaf => Leaf
            | mm => Node mm None Leaf
            end
        | Node l o r => Node (remove ii l) o r
        end
    | xI ii =>
        match m with
        | Leaf => Leaf
        | Node Leaf None r =>
            match remove ii r with
            | Leaf => Leaf
            | mm => Node Leaf None mm
            end
        | Node l o r => Node l o (remove ii r)
        end
    end.

  (** [elements] *)

    Fixpoint xelements (m : t A) (i : positive) {struct m}
             : list (positive * A) :=
      match m with
      | Leaf => nil
      | Node l None r =>
          (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
      | Node l (Some x) r =>
          (xelements l (append i (xO xH)))
          ++ ((i, x) :: xelements r (append i (xI xH)))
      end.

  (* Note: function [xelements] above is inefficient.  We should apply
     deforestation to it, but that makes the proofs even harder. *)

  Definition elements (m : t A) := xelements m xH.

  (** [cardinal] *)

  Fixpoint cardinal (m : t A) : nat :=
    match m with
      | Leaf => 0%nat
      | Node l None r => (cardinal l + cardinal r)%nat
      | Node l (Some _) r => S (cardinal l + cardinal r)
    end.

  Section CompcertSpec.

  Theorem gempty:
    forall (i: positive), find i empty = None.
  Proof.
    destruct i; simpl; auto.
  Qed.

  Theorem gss:
    forall (i: positive) (x: A) (m: t A), find i (add i x m) = Some x.
  Proof.
    induction i; destruct m; simpl; auto.
  Qed.

  Lemma gleaf : forall (i : positive), find i (Leaf : t A) = None.
  Proof. exact gempty. Qed.

  Theorem gso:
    forall (i j: positive) (x: A) (m: t A),
    i <> j -> find i (add j x m) = find i m.
  Proof.
    induction i; intros; destruct j; destruct m; simpl;
       try rewrite <- (gleaf i); auto; try apply IHi; congruence.
  Qed.

  Theorem gis:
    forall (i: positive) (x x' : A) (f : A -> A) (m : t A),
      find i m = Some x' ->
      find i (insert i x f m) = Some (f x').
  Proof.
    induction i; destruct m; simpl; auto; try (intro; discriminate).
    intro R; rewrite R; reflexivity.
  Qed.

  Theorem gin:
    forall (i: positive) (x : A) (f : A -> A) (m : t A),
      find i m = None ->
      find i (insert i x f m) = Some x.
  Proof.
    induction i; destruct m; simpl; auto; try (intro; discriminate);
      try (rewrite <- (gleaf i) at 1; auto).
    intro R; rewrite R; reflexivity.
  Qed.

  Theorem gio:
    forall (i j: positive) (x : A) (f : A -> A) (m : t A),
      i <> j -> find i (insert j x f m) = find i m.
  Proof.
    induction i; intros; destruct j; destruct m; simpl;
      try rewrite <- (gleaf i); auto; try apply IHi; congruence.
  Qed.

  Theorem gas:
    forall (i: positive) (x' : A) (f : A -> A) (m : t A),
      find i m = Some x' -> find i (adjust i f m) = Some (f x').
  Proof.
    induction i; destruct m; simpl; auto; try (intro; discriminate).
    intro R; rewrite R; reflexivity.
  Qed.

  Theorem gan:
    forall (i: positive) (f : A -> A) (m : t A),
      find i m = None -> find i (adjust i f m) = None.
  Proof.
    induction i; destruct m; simpl; auto; try (intro; discriminate);
      try (rewrite <- (gleaf i) at 1; auto).
    intro R; rewrite R; reflexivity.
  Qed.

  Theorem gao:
    forall (i j: positive) (f : A -> A) (m : t A),
      i <> j -> find i (adjust j f m) = find i m.
  Proof.
    induction i; intros; destruct j; destruct m; simpl;
      try rewrite <- (gleaf i); auto; try apply IHi; congruence.
  Qed.

  Lemma rleaf : forall (i : positive), remove i (Leaf : t A) = Leaf.
  Proof. destruct i; simpl; auto. Qed.

  Theorem grs:
    forall (i: positive) (m: t A), find i (remove i m) = None.
  Proof.
    induction i; destruct m.
     simpl; auto.
     destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto.
      rewrite (rleaf i); auto.
      cut (find i (remove i (Node ll oo rr)) = None).
        destruct (remove i (Node ll oo rr)); auto; apply IHi.
        apply IHi.
     simpl; auto.
     destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto.
      rewrite (rleaf i); auto.
      cut (find i (remove i (Node ll oo rr)) = None).
        destruct (remove i (Node ll oo rr)); auto; apply IHi.
        apply IHi.
     simpl; auto.
     destruct m1; destruct m2; simpl; auto.
  Qed.

  Theorem gro:
    forall (i j: positive) (m: t A),
    i <> j -> find i (remove j m) = find i m.
  Proof.
    induction i; intros; destruct j; destruct m;
        try rewrite (rleaf (xI j));
        try rewrite (rleaf (xO j));
        try rewrite (rleaf 1); auto;
        destruct m1; destruct o; destruct m2;
        simpl;
        try apply IHi; try congruence;
        try rewrite (rleaf j); auto;
        try rewrite (gleaf i); auto.
     cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2));
        [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto
        | apply IHi; congruence ].
     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
        auto.
     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
        auto.
     cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2));
        [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto
        | apply IHi; congruence ].
     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
        auto.
     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
        auto.
  Qed.

  Lemma xelements_correct:
      forall (m: t A) (i j : positive) (v: A),
      find i m = Some v -> List.In (append j i, v) (xelements m j).
    Proof.
      induction m; intros.
       rewrite (gleaf i) in H; congruence.
       destruct o; destruct i; simpl; simpl in H.
        rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
          apply IHm2; auto.
        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
        rewrite append_neutral_r; apply in_or_app; injection H;
          intro EQ; rewrite EQ; right; apply in_eq.
        rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
        congruence.
    Qed.

  Theorem elements_correct:
    forall (m: t A) (i: positive) (v: A),
    find i m = Some v -> List.In (i, v) (elements m).
  Proof.
    intros m i v H.
    exact (xelements_correct m i xH H).
  Qed.

  Fixpoint xfind (i j : positive) (m : t A) {struct j} : option A :=
      match i, j with
      | _, xH => find i m
      | xO ii, xO jj => xfind ii jj m
      | xI ii, xI jj => xfind ii jj m
      | _, _ => None
      end.

  Lemma xfind_left :
    forall (j i : positive) (m1 m2 : t A) (o : option A) (v : A),
      xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
  Proof.
    induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
    destruct i; congruence.
  Qed.

    Lemma xelements_ii :
      forall (m: t A) (i j : positive) (v: A),
      List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
         apply in_or_app.
        left; apply IHm1; auto.
        right; destruct (in_inv H0).
         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
         apply in_cons; apply IHm2; auto.
        left; apply IHm1; auto.
        right; apply IHm2; auto.
    Qed.

    Lemma xelements_io :
      forall (m: t A) (i j : positive) (v: A),
      ~List.In (xI i, v) (xelements m (xO j)).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        apply (IHm1 _ _ _ H0).
        destruct (in_inv H0).
         congruence.
         apply (IHm2 _ _ _ H1).
        apply (IHm1 _ _ _ H0).
        apply (IHm2 _ _ _ H0).
    Qed.

    Lemma xelements_oo :
      forall (m: t A) (i j : positive) (v: A),
      List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
         apply in_or_app.
        left; apply IHm1; auto.
        right; destruct (in_inv H0).
         injection H1; intros Eq1 Eq2; rewrite Eq1; rewrite Eq2; apply in_eq.
         apply in_cons; apply IHm2; auto.
        left; apply IHm1; auto.
        right; apply IHm2; auto.
    Qed.

    Lemma xelements_oi :
      forall (m: t A) (i j : positive) (v: A),
      ~List.In (xO i, v) (xelements m (xI j)).
    Proof.
      induction m.
       simpl; auto.
       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        apply (IHm1 _ _ _ H0).
        destruct (in_inv H0).
         congruence.
         apply (IHm2 _ _ _ H1).
        apply (IHm1 _ _ _ H0).
        apply (IHm2 _ _ _ H0).
    Qed.

    Lemma xelements_ih :
      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
      List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
    Proof.
      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
        destruct (in_inv H0).
         congruence.
         apply xelements_ii; auto.
        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
        apply xelements_ii; auto.
    Qed.

    Lemma xelements_oh :
      forall (m1 m2: t A) (o: option A) (i : positive) (v: A),
      List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
    Proof.
      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
        apply xelements_oo; auto.
        destruct (in_inv H0).
         congruence.
         absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
        apply xelements_oo; auto.
        absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
    Qed.

    Lemma xelements_hi :
      forall (m: t A) (i : positive) (v: A),
      ~List.In (xH, v) (xelements m (xI i)).
    Proof.
      induction m; intros.
       simpl; auto.
       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        generalize H0; apply IHm1; auto.
        destruct (in_inv H0).
         congruence.
         generalize H1; apply IHm2; auto.
        generalize H0; apply IHm1; auto.
        generalize H0; apply IHm2; auto.
    Qed.

    Lemma xelements_ho :
      forall (m: t A) (i : positive) (v: A),
      ~List.In (xH, v) (xelements m (xO i)).
    Proof.
      induction m; intros.
       simpl; auto.
       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
        generalize H0; apply IHm1; auto.
        destruct (in_inv H0).
         congruence.
         generalize H1; apply IHm2; auto.
        generalize H0; apply IHm1; auto.
        generalize H0; apply IHm2; auto.
    Qed.

    Lemma find_xfind_h :
      forall (m: t A) (i: positive), find i m = xfind i xH m.
    Proof.
      destruct i; simpl; auto.
    Qed.

    Lemma xelements_complete:
      forall (i j : positive) (m: t A) (v: A),
      List.In (i, v) (xelements m j) -> xfind i j m = Some v.
    Proof.
      induction i; simpl; intros; destruct j; simpl.
       apply IHi; apply xelements_ii; auto.
       absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io.
       destruct m.
        simpl in H; tauto.
        rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H).
       absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi.
       apply IHi; apply xelements_oo; auto.
       destruct m.
        simpl in H; tauto.
        rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H).
       absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi.
       absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho.
       destruct m.
        simpl in H; tauto.
        destruct o; simpl in H; destruct (in_app_or _ _ _ H).
         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
         destruct (in_inv H0).
          congruence.
          absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
         absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
    Qed.

  Theorem elements_complete:
    forall (m: t A) (i: positive) (v: A),
    List.In (i, v) (elements m) -> find i m = Some v.
  Proof.
    intros m i v H.
    unfold elements in H.
    rewrite find_xfind_h.
    exact (xelements_complete i xH m v H).
  Qed.

  Lemma cardinal_1 :
   forall (m: t A), cardinal m = length (elements m).
  Proof.
   unfold elements.
   intros m; set (p:=1); clearbody p; revert m p.
   induction m; simpl; auto; intros.
   rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto.
   destruct o; rewrite app_length; simpl; omega.
  Qed.

  End CompcertSpec.

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

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

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

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

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

  Definition lt_key (p p':positive*A) :=
    @ME.ltk positive (@SOT_as_OT _ _ positive_l2r_OrderedType) _ p p'.

  Lemma mem_find :
    forall m x, mem x m = match find x m with None => false | _ => true end.
  Proof.
  induction m; destruct x; simpl; auto.
  Qed.

  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
  Proof.
  unfold Empty, MapsTo.
  intuition.
  generalize (H a).
  destruct (find a m); intuition.
  elim (H0 a0); auto.
  rewrite H in H0; discriminate.
  Qed.

  Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r.
  Proof.
  intros l o r.
  split.
  rewrite Empty_alt.
  split.
  destruct o; auto.
  generalize (H 1); simpl; auto.
  split; rewrite Empty_alt; intros.
  generalize (H (xO a)); auto.
  generalize (H (xI a)); auto.
  intros (H,(H0,H1)).
  subst.
  rewrite Empty_alt; intros.
  destruct a; auto.
  simpl; generalize H1; rewrite Empty_alt; auto.
  simpl; generalize H0; rewrite Empty_alt; auto.
  Qed.

  Section FMapSpec.

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

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

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

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

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

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

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

  Lemma is_empty_1 : Empty m -> is_empty m = true.
  Proof.
  induction m; simpl; auto.
  rewrite Empty_Node.
  intros (H,(H0,H1)).
  subst; simpl.
  rewrite IHt0_1; simpl; auto.
  Qed.

  Lemma is_empty_2 : is_empty m = true -> Empty m.
  Proof.
  induction m; simpl; auto.
  rewrite Empty_alt.
  intros _; exact gempty.
  rewrite Empty_Node.
  destruct o.
  intros; discriminate.
  intro H; destruct (andb_prop _ _ H); intuition.
  Qed.

  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
  Proof.
  unfold MapsTo.
  intro H; rewrite H; clear H.
  apply gss.
  Qed.

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

  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
  unfold MapsTo.
  intro H; rewrite gso; auto.
  Qed.

  Lemma insert_1 : forall d f, E.eq x y -> MapsTo y e m ->
    MapsTo y (f e) (insert x d f m).
  Proof.
    unfold MapsTo; intros d f H; rewrite H; clear H; apply gis.
  Qed.

  Lemma insert_2 : forall d f, E.eq x y -> ~ In y m ->
    MapsTo y d (insert x d f m).
  Proof.
    unfold MapsTo.
    intros d f H abs; rewrite H, gin; auto.
    case_eq (find y m); auto; intros; contradiction abs; exists a; auto.
  Qed.

  Lemma insert_3 : forall d f, ~ E.eq x y -> MapsTo y e m ->
    MapsTo y e (insert x d f m).
  Proof.
    unfold MapsTo.
    intros; rewrite gio; auto.
  Qed.

  Lemma insert_4 : forall d f, ~ E.eq x y -> MapsTo y e (insert x d f m) ->
    MapsTo y e m.
  Proof.
    unfold MapsTo.
    intros d f H; rewrite gio; auto.
  Qed.

  Lemma adjust_1 : forall f, E.eq x y -> MapsTo y e m ->
    MapsTo y (f e) (adjust x f m).
  Proof.
    unfold MapsTo; intros f H; rewrite H; clear H; apply gas.
  Qed.

  Lemma adjust_2 : forall f, ~ E.eq x y -> MapsTo y e m ->
    MapsTo y e (adjust x f m).
  Proof.
    unfold MapsTo.
    intros; rewrite gao; auto.
  Qed.

  Lemma adjust_3 : forall f, ~ E.eq x y -> MapsTo y e (adjust x f m) ->
    MapsTo y e m.
  Proof.
    unfold MapsTo.
    intros f H; rewrite gao; auto.
  Qed.

  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
  Proof.
  intros; intro.
  generalize (mem_1 H0).
  rewrite mem_find.
  rewrite H.
  rewrite grs.
  intros; discriminate.
  Qed.

  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
  unfold MapsTo.
  intro H; rewrite gro; auto.
  Qed.

  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
  unfold MapsTo.
  destruct (eq_dec x y).
  rewrite H in *.
  rewrite grs; intros; discriminate.
  rewrite gro; auto.
  Qed.

  Lemma elements_1 :
     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof.
  unfold MapsTo.
  rewrite InA_alt.
  intro H.
  exists (x,e).
  split.
  red; simpl; unfold E.eq; auto.
  apply elements_correct; auto.
  Qed.

  Lemma elements_2 :
     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof.
  unfold MapsTo.
  rewrite InA_alt.
  intros ((e0,a),(H,H0)).
  red in H; simpl in H; destruct H; compute in H; subst.
  apply elements_complete; auto.
  Qed.

  Notation bits_lt := Plt_l2r.
  Notation bits_lt_trans := Plt_l2r_trans.
  Lemma xelements_bits_lt_1 : forall p p0 q m v,
     List.In (p0,v) (xelements m (append p (xO q))) -> bits_lt p0 p.
  Proof.
  intros.
  generalize (xelements_complete _ _ _ _ H); clear H; intros.
  revert p0 q m v H.
  induction p; destruct p0; simpl; intros; eauto; try discriminate.
  Qed.

  Lemma xelements_bits_lt_2 : forall p p0 q m v,
     List.In (p0,v) (xelements m (append p (xI q))) -> bits_lt p p0.
  Proof.
  intros.
  generalize (xelements_complete _ _ _ _ H); clear H; intros.
  revert p0 q m v H.
  induction p; destruct p0; simpl; intros; eauto; try discriminate.
  Qed.

  Lemma xelements_sort : forall p, sort lt_key (xelements m p).
  Proof.
  induction m.
  simpl; auto.
  destruct o; simpl; intros.
  (* Some *)
  apply (SortA_app (eqA:=eq_key_elt)); auto.
  apply KeyOrderedType.eqke_Equiv.
  constructor; repeat intro; unfold lt_key, ME.ltk in *; try solve [order].
  apply In_InfA; intros.
  destruct y0.
  red; red; simpl.
  eapply xelements_bits_lt_2; eauto.
  intros x0 y0.
  do 2 rewrite InA_alt.
  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
  red; red; simpl.
  destruct H0.
  injection H0; clear H0; intros _ H0; subst.
  eapply xelements_bits_lt_1; eauto.
  apply bits_lt_trans with p.
  eapply xelements_bits_lt_1; eauto.
  eapply xelements_bits_lt_2; eauto.
  (* None *)
  apply (SortA_app (eqA:=eq_key_elt)); auto.
  apply KeyOrderedType.eqke_Equiv.
  intros x0 y0.
  do 2 rewrite InA_alt.
  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
  red; red; simpl.
  apply bits_lt_trans with p.
  eapply xelements_bits_lt_1; eauto.
  eapply xelements_bits_lt_2; eauto.
  Qed.

  Lemma elements_3 : sort lt_key (elements m).
  Proof.
  unfold elements.
  apply xelements_sort; auto.
  Qed.

  Lemma elements_3w : NoDupA eq_key (elements m).
  Proof.
    apply ME.Sort_NoDupA; apply elements_3; auto.
  Qed.

  End FMapSpec.

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

  Variable B : Type.

  Section Mapi.

    Variable f : positive -> A -> B.

    Fixpoint xmapi (m : t A) (i : positive) {struct m} : t B :=
       match m with
        | Leaf => @Leaf B
        | Node l o r => Node (xmapi l (append i (xO xH)))
                             (option_map (f i) o)
                             (xmapi r (append i (xI xH)))
       end.

    Definition mapi m := xmapi m xH.

  End Mapi.

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

  End A.

  Lemma xgmapi:
      forall (A B: Type) (f: positive -> A -> B) (i j : positive) (m: t A),
      find i (xmapi f m j) = option_map (f (append j i)) (find i m).
  Proof.
  induction i; intros; destruct m; simpl; auto.
  rewrite (append_assoc_1 j i); apply IHi.
  rewrite (append_assoc_0 j i); apply IHi.
  rewrite (append_neutral_r j); auto.
  Qed.

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

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

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

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

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

  Section map2.
  Variable A B C : Type.
  Variable f : option A -> option B -> option C.

  Arguments Leaf {A}.

  Fixpoint xmap2_l (m : t A) {struct m} : t C :=
      match m with
      | Leaf => Leaf
      | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
      end.

  Lemma xgmap2_l : forall (i : positive) (m : t A),
          f None None = None -> find i (xmap2_l m) = f (find i m) None.
    Proof.
      induction i; intros; destruct m; simpl; auto.
    Qed.

  Fixpoint xmap2_r (m : t B) {struct m} : t C :=
      match m with
      | Leaf => Leaf
      | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
      end.

  Lemma xgmap2_r : forall (i : positive) (m : t B),
          f None None = None -> find i (xmap2_r m) = f None (find i m).
    Proof.
      induction i; intros; destruct m; simpl; auto.
    Qed.

  Fixpoint _map2 (m1 : t A)(m2 : t B) {struct m1} : t C :=
    match m1 with
    | Leaf => xmap2_r m2
    | Node l1 o1 r1 =>
        match m2 with
        | Leaf => xmap2_l m1
        | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2)
        end
    end.

    Lemma gmap2: forall (i: positive)(m1:t A)(m2: t B),
      f None None = None ->
      find i (_map2 m1 m2) = f (find i m1) (find i m2).
    Proof.
      induction i; intros; destruct m1; destruct m2; simpl; auto;
      try apply xgmap2_r; try apply xgmap2_l; auto.
    Qed.

  End map2.

  Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') :=
   _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).

  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x m \/ In x m' ->
    find x (map2 f m m') = f (find x m) (find x m').
  Proof.
  intros.
  unfold map2.
  rewrite gmap2; auto.
  generalize (@mem_1 _ m x) (@mem_1 _ m' x).
  do 2 rewrite mem_find.
  destruct (find x m); simpl; auto.
  destruct (find x m'); simpl; auto.
  intros.
  destruct H; intuition; try discriminate.
  Qed.

  Lemma  map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x (map2 f m m') -> In x m \/ In x m'.
  Proof.
  intros.
  generalize (mem_1 H); clear H; intros.
  rewrite mem_find in H.
  unfold map2 in H.
  rewrite gmap2 in H; auto.
  generalize (@mem_2 _ m x) (@mem_2 _ m' x).
  do 2 rewrite mem_find.
  destruct (find x m); simpl in *; auto.
  destruct (find x m'); simpl in *; auto.
  Qed.

  Section Fold.

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

    Fixpoint xfoldi (m : t A) (v : B) (i : positive) :=
      match m with
        | Leaf => v
        | Node l (Some x) r =>
          xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3)
        | Node l None r =>
          xfoldi r (xfoldi l v (append i 2)) (append i 3)
      end.

    Lemma xfoldi_1 :
      forall m v i,
      xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v.
    Proof.
      set (F := fun a p => f (fst p) (snd p) a).
      induction m; intros; simpl; auto.
      destruct o.
      rewrite fold_left_app; simpl.
      rewrite <- IHm1.
      rewrite <- IHm2.
      unfold F; simpl; reflexivity.
      rewrite fold_left_app; simpl.
      rewrite <- IHm1.
      rewrite <- IHm2.
      reflexivity.
    Qed.

    Definition fold m i := xfoldi m i 1.

  End Fold.

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

  Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool :=
    match m1, m2 with
      | Leaf, _ => is_empty m2
      | _, Leaf => is_empty m1
      | Node l1 o1 r1, Node l2 o2 r2 =>
           (match o1, o2 with
             | None, None => true
             | Some v1, Some v2 => cmp v1 v2
             | _, _ => false
            end)
           && equal cmp l1 l2 && equal cmp r1 r2
     end.

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

  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
    Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
  induction m.
  (* m = Leaf *)
  destruct 1.
  simpl.
  apply is_empty_1.
  red; red; intros.
  assert (In a (Leaf A)).
  rewrite H.
  exists e; auto.
  destruct H2; red in H2.
  destruct a; simpl in *; discriminate.
  (* m = Node *)
  destruct m'.
  (* m' = Leaf *)
  destruct 1.
  simpl.
  destruct o.
  assert (In xH (Leaf A)).
  rewrite <- H.
  exists a; red; auto.
  destruct H1; red in H1; simpl in H1; discriminate.
  apply andb_true_intro; split; apply is_empty_1; red; red; intros.
  assert (In (xO a) (Leaf A)).
  rewrite <- H.
  exists e; auto.
  destruct H2; red in H2; simpl in H2; discriminate.
  assert (In (xI a) (Leaf A)).
  rewrite <- H.
  exists e; auto.
  destruct H2; red in H2; simpl in H2; discriminate.
  (* m' = Node *)
  destruct 1.
  assert (Equivb cmp m1 m'1).
    split.
    intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
    intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto.
  assert (Equivb cmp m2 m'2).
    split.
    intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
    intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto.
  simpl.
  destruct o; destruct o0; simpl.
  repeat (apply andb_true_intro; split); auto.
  apply (H0 xH); red; auto.
  generalize (H xH); unfold In, MapsTo; simpl; intuition.
  destruct H4; try discriminate; eauto.
  generalize (H xH); unfold In, MapsTo; simpl; intuition.
  destruct H5; try discriminate; eauto.
  apply andb_true_intro; split; auto.
  Qed.

  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
    equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
  induction m.
  (* m = Leaf *)
  simpl.
  split; intros.
  split.
  destruct 1; red in H0; destruct k; discriminate.
  destruct 1; elim (is_empty_2 H H0).
  red in H0; destruct k; discriminate.
  (* m = Node *)
  destruct m'.
  (* m' = Leaf *)
  simpl.
  destruct o; intros; try discriminate.
  destruct (andb_prop _ _ H); clear H.
  split; intros.
  split; unfold In, MapsTo; destruct 1.
  destruct k; simpl in *; try discriminate.
  destruct (is_empty_2 H1 (find_2 _ _ H)).
  destruct (is_empty_2 H0 (find_2 _ _ H)).
  destruct k; simpl in *; discriminate.
  unfold In, MapsTo; destruct k; simpl in *; discriminate.
  (* m' = Node *)
  destruct o; destruct o0; simpl; intros; try discriminate.
  destruct (andb_prop _ _ H); clear H.
  destruct (andb_prop _ _ H0); clear H0.
  destruct (IHm1 _ _ H2); clear H2 IHm1.
  destruct (IHm2 _ _ H1); clear H1 IHm2.
  split; intros.
  destruct k; unfold In, MapsTo in *; simpl; auto.
  split; eauto.
  destruct k; unfold In, MapsTo in *; simpl in *.
  eapply H4; eauto.
  eapply H3; eauto.
  congruence.
  destruct (andb_prop _ _ H); clear H.
  destruct (IHm1 _ _ H0); clear H0 IHm1.
  destruct (IHm2 _ _ H1); clear H1 IHm2.
  split; intros.
  destruct k; unfold In, MapsTo in *; simpl; auto.
  split; eauto.
  destruct k; unfold In, MapsTo in *; simpl in *.
  eapply H3; eauto.
  eapply H2; eauto.
  try discriminate.
  Qed.

  Section MapAsOT.
    Context `{Helt : OrderedType elt}.

    Inductive t_eq : t elt -> t elt -> Prop :=
    | t_eq_Leaf : t_eq (Leaf _) (Leaf _)
    | t_eq_Node :
      forall l l' o o' r r', t_eq l l' -> o === o' -> t_eq r r' ->
        t_eq (Node l o r) (Node l' o' r').
    Property t_eq_refl : forall x, t_eq x x.
    Proof. Tactics.minductive_refl. Qed.
    Property t_eq_sym : forall x y, t_eq x y -> t_eq y x.
    Proof. Tactics.minductive_sym. Qed.
    Property t_eq_trans : forall x y z, t_eq x y -> t_eq y z -> t_eq x z.
    Proof. Tactics.minductive_trans. Qed.

    Inductive t_lt : t elt -> t elt -> Prop :=
    | t_lt_Leaf_Node : forall l o r, t_lt (Leaf _) (Node l o r)
    | t_lt_Node_Node_1 :
      forall l l' o o' r r', o <<< o' -> t_lt (Node l o r) (Node l' o' r')
    | t_lt_Node_Node_2 :
      forall l l' o o' r r', t_lt l l' -> o === o' ->
        t_lt (Node l o r) (Node l' o' r')
    | t_lt_Node_Node_3 :
      forall l l' o o' r r', t_eq l l' -> o === o' -> t_lt r r' ->
        t_lt (Node l o r) (Node l' o' r').
    Property t_lt_irrefl : forall x y, t_lt x y -> ~t_eq x y.
    Proof. Tactics.minductive_irrefl. Qed.
    Property t_eq_lt : forall x x' y, t_eq x x' -> t_lt x y -> t_lt x' y.
    Proof. Tactics.rinductive_eq_lt t_eq_sym t_eq_trans. Qed.
    Property t_eq_gt : forall x x' y, t_eq x x' -> t_lt y x -> t_lt y x'.
    Proof. Tactics.rinductive_eq_gt t_eq_trans. Qed.
    Property t_lt_trans : forall x y z, t_lt x y -> t_lt y z -> t_lt x z.
    Proof.
      Tactics.rinductive_lexico_trans t_eq_sym t_eq_trans t_eq_gt t_eq_lt.
    Qed.

    Fixpoint t_cmp (m m' : t elt) : comparison :=
      match m, m' with
        | Leaf, Leaf => Eq
        | Leaf, Node _ _ _ => Lt
        | Node _ _ _, Leaf => Gt
        | Node l o r, Node l' o' r' =>
          match o =?= o' with
            | Eq =>
              match t_cmp l l' with
                | Eq => t_cmp r r'
                | Lt => Lt
                | Gt => Gt
              end
            | Lt => Lt
            | Gt => Gt
          end
      end.
    Property t_cmp_spec : forall x y, compare_spec t_eq t_lt x y (t_cmp x y).
    Proof.
      induction x; destruct y; try (tconstructor (constructor)).
      simpl; destruct (compare_dec o o0); try (constructor; tconstructor (auto)).
      destruct (IHx1 y1); try constructor.
      tconstructor (assumption).
      destruct (IHx2 y2); try constructor;
        tconstructor (solve [auto using t_eq_sym]).
      tconstructor (solve [auto using t_eq_sym]).
    Qed.

    Program Instance Map_OrderedType : OrderedType (t elt) := {
      _eq := t_eq;
      OT_Equivalence := @Build_Equivalence _ _ t_eq_refl t_eq_sym t_eq_trans;
      _lt := t_lt;
      OT_StrictOrder := @Build_StrictOrder _ _ _ _ t_lt_trans t_lt_irrefl;
      _cmp := t_cmp;
      _compare_spec := t_cmp_spec
    }.
  End MapAsOT.

End PositiveMap.

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

Module PositiveMapAdditionalFacts.
  Import PositiveMap.

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

   (* Not derivable from the Map interface *)
  Theorem gsident:
    forall (A:Type)(i: positive) (m: t A) (v: A),
    find i m = Some v -> add i v m = m.
  Proof.
    induction i; intros; destruct m; simpl; simpl in H; try congruence.
     rewrite (IHi m2 v H); congruence.
     rewrite (IHi m1 v H); congruence.
  Qed.

  Lemma xmap2_lr :
      forall (A B : Type)(f g: option A -> option A -> option B)(m : t A),
      (forall (i j : option A), f i j = g j i) ->
      xmap2_l f m = xmap2_r g m.
    Proof.
      induction m; intros; simpl; auto.
      rewrite IHm1; auto.
      rewrite IHm2; auto.
      rewrite H; auto.
    Qed.

  Theorem map2_commut:
    forall (A B: Type) (f g: option A -> option A -> option B),
    (forall (i j: option A), f i j = g j i) ->
    forall (m1 m2: t A),
    _map2 f m1 m2 = _map2 g m2 m1.
  Proof.
    intros A B f g Eq1.
    assert (Eq2: forall (i j: option A), g i j = f j i).
      intros; auto.
    induction m1; intros; destruct m2; simpl;
      try rewrite Eq1;
      repeat rewrite (xmap2_lr f g);
      repeat rewrite (xmap2_lr g f);
      auto.
     rewrite IHm1_1.
     rewrite IHm1_2.
     auto.
  Qed.

End PositiveMapAdditionalFacts.


Theorem forward_huge : (forall A B C : Prop, A -> (A->B) -> (A->B->C) -> C).

Proof.
  intros A B C.
  intros pA AimpsB AimpsBimpsC.
  pose (pB := AimpsB pA).
  pose (pC := AimpsBimpsC pA pB).
  exact pC.
Show Proof.
Qed.