From stdpp Require Export countable vector.
From stdpp Require Import options.

Class Finite A `{EqDecision A} := {
  enum : list A;
  (* [NoDup] makes it easy to define the cardinality of the type. *)
  NoDup_enum : NoDup enum;
  elem_of_enum x : x ∈ enum
}.
Hint Mode Finite ! - : typeclass_instances.
Arguments enum : clear implicits.
Arguments enum _ {_ _} : assert.
Arguments NoDup_enum : clear implicits.
Arguments NoDup_enum _ {_ _} : assert.
Definition card A `{Finite A} := length (enum A).

Program Definition finite_countable `{Finite A} : Countable A := {|
  encode := λ x,
    Pos.of_nat $ S $ default 0 $ fst <$> list_find (x =.) (enum A);
  decode := λ p, enum A !! pred (Pos.to_nat p)
|}.
Arguments Pos.of_nat : simpl never.
Next Obligation.
  intros ?? [xs Hxs HA] x; unfold encode, decode; simpl.
  destruct (list_find_elem_of (x =.) xs x) as [[i y] Hi]; auto.
  rewrite Nat2Pos.id by done; simpl; rewrite Hi; simpl.
  destruct (list_find_Some (x =.) xs i y); naive_solver.
Qed.
Hint Immediate finite_countable : typeclass_instances.

Definition find `{Finite A} P `{∀ x, Decision (P x)} : option A :=
  list_find P (enum A) ≫= decode_nat ∘ fst.

Lemma encode_lt_card `{finA: Finite A} (x : A) : encode_nat x < card A.
Proof.
  destruct finA as [xs Hxs HA]; unfold encode_nat, encode, card; simpl.
  rewrite Nat2Pos.id by done; simpl.
  destruct (list_find _ xs) as [[i y]|] eqn:HE; simpl.
  - apply list_find_Some in HE as (?&?&?); eauto using lookup_lt_Some.
  - destruct xs; simpl; [|lia].
    exfalso; eapply not_elem_of_nil, (HA x).
Qed.
Lemma encode_decode A `{finA: Finite A} i :
  i < card A → ∃ x : A, decode_nat i = Some x ∧ encode_nat x = i.
Proof.
  destruct finA as [xs Hxs HA].
  unfold encode_nat, decode_nat, encode, decode, card; simpl.
  intros Hi. apply lookup_lt_is_Some in Hi. destruct Hi as [x Hx].
  exists x. rewrite !Nat2Pos.id by done; simpl.
  destruct (list_find_elem_of (x =.) xs x) as [[j y] Hj]; auto.
  split; [done|]; rewrite Hj; simpl.
  apply list_find_Some in Hj as (?&->&?). eauto using NoDup_lookup.
Qed.
Lemma find_Some `{finA: Finite A} P `{∀ x, Decision (P x)} (x : A) :
  find P = Some x → P x.
Proof.
  destruct finA as [xs Hxs HA]; unfold find, decode_nat, decode; simpl.
  intros Hx. destruct (list_find _ _) as [[i y]|] eqn:Hi; simplify_eq/=.
  rewrite !Nat2Pos.id in Hx by done.
  destruct (list_find_Some P xs i y); naive_solver.
Qed.
Lemma find_is_Some `{finA: Finite A} P `{∀ x, Decision (P x)} (x : A) :
  P x → ∃ y, find P = Some y ∧ P y.
Proof.
  destruct finA as [xs Hxs HA]; unfold find, decode; simpl.
  intros Hx. destruct (list_find_elem_of P xs x) as [[i y] Hi]; auto.
  rewrite Hi; simpl. rewrite !Nat2Pos.id by done. simpl.
  apply list_find_Some in Hi; naive_solver.
Qed.

Definition encode_fin `{Finite A} (x : A) : fin (card A) :=
  Fin.of_nat_lt (encode_lt_card x).
Program Definition decode_fin `{Finite A} (i : fin (card A)) : A :=
  match Some_dec (decode_nat i) return _ with
  | inleft (x ↾ _) => x | inright _ => _
  end.
Next Obligation.
  intros A ?? i ?; exfalso.
  destruct (encode_decode A i); naive_solver auto using fin_to_nat_lt.
Qed.
Lemma decode_encode_fin `{Finite A} (x : A) : decode_fin (encode_fin x) = x.
Proof.
  unfold decode_fin, encode_fin. destruct (Some_dec _) as [[x' Hx]|Hx].
  { by rewrite fin_to_nat_to_fin, decode_encode_nat in Hx; simplify_eq. }
  exfalso; by rewrite ->fin_to_nat_to_fin, decode_encode_nat in Hx.
Qed.

Lemma fin_choice {n} {B : fin n → Type} (P : ∀ i, B i → Prop) :
  (∀ i, ∃ y, P i y) → ∃ f, ∀ i, P i (f i).
Proof.
  induction n as [|n IH]; intros Hex.
  { exists (fin_0_inv _); intros i; inv_fin i. }
  destruct (IH _ _ (λ i, Hex (FS i))) as [f Hf], (Hex 0%fin) as [y Hy].
  exists (fin_S_inv _ y f); intros i; by inv_fin i.
Qed.
Lemma finite_choice `{Finite A} {B : A → Type} (P : ∀ x, B x → Prop) :
  (∀ x, ∃ y, P x y) → ∃ f, ∀ x, P x (f x).
Proof.
  intros Hex. destruct (fin_choice _ (λ i, Hex (decode_fin i))) as [f ?].
  exists (λ x, eq_rect _ _ (f(encode_fin x)) _ (decode_encode_fin x)); intros x.
  destruct (decode_encode_fin x); simpl; auto.
Qed.

Lemma card_0_inv P `{finA: Finite A} : card A = 0 → A → P.
Proof.
  intros ? x. destruct finA as [[|??] ??]; simplify_eq.
  by destruct (not_elem_of_nil x).
Qed.
Lemma finite_inhabited A `{finA: Finite A} : 0 < card A → Inhabited A.
Proof.
  unfold card; intros. destruct finA as [[|x ?] ??]; simpl in *; [exfalso;lia|].
  constructor; exact x.
Qed.
Lemma finite_inj_submseteq `{finA: Finite A} `{finB: Finite B} (f: A → B)
  `{!Inj (=) (=) f} : f <$> enum A ⊆+ enum B.
Proof.
  intros. destruct finA, finB. apply NoDup_submseteq; auto using NoDup_fmap_2.
Qed.
Lemma finite_inj_Permutation `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A = card B → f <$> enum A ≡ₚ enum B.
Proof.
  intros. apply submseteq_Permutation_length_eq.
  - by rewrite fmap_length.
  - by apply finite_inj_submseteq.
Qed.
Lemma finite_inj_surj `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A = card B → Surj (=) f.
Proof.
  intros HAB y. destruct (elem_of_list_fmap_2 f (enum A) y) as (x&?&?); eauto.
  rewrite finite_inj_Permutation; auto using elem_of_enum.
Qed.

Lemma finite_surj A `{Finite A} B `{Finite B} :
  0 < card A ≤ card B → ∃ g : B → A, Surj (=) g.
Proof.
  intros [??]. destruct (finite_inhabited A) as [x']; auto with lia.
  exists (λ y : B, default x' (decode_nat (encode_nat y))).
  intros x. destruct (encode_decode B (encode_nat x)) as (y&Hy1&Hy2).
  { pose proof (encode_lt_card x); lia. }
  exists y. by rewrite Hy2, decode_encode_nat.
Qed.
Lemma finite_inj A `{Finite A} B `{Finite B} :
  card A ≤ card B ↔ ∃ f : A → B, Inj (=) (=) f.
Proof.
  split.
  - intros. destruct (decide (card A = 0)) as [HA|?].
    { exists (card_0_inv B HA). intros y. apply (card_0_inv _ HA y). }
    destruct (finite_surj A B) as (g&?); auto with lia.
    destruct (surj_cancel g) as (f&?). exists f. apply cancel_inj.
  - intros [f ?]. unfold card. rewrite <-(fmap_length f).
    by apply submseteq_length, (finite_inj_submseteq f).
Qed.
Lemma finite_bijective A `{Finite A} B `{Finite B} :
  card A = card B ↔ ∃ f : A → B, Inj (=) (=) f ∧ Surj (=) f.
Proof.
  split.
  - intros; destruct (proj1 (finite_inj A B)) as [f ?]; auto with lia.
    exists f; split; [done|]. by apply finite_inj_surj.
  - intros (f&?&?). apply (anti_symm (≤)); apply finite_inj.
    + by exists f.
    + destruct (surj_cancel f) as (g&?). exists g. apply cancel_inj.
Qed.
Lemma inj_card `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} : card A ≤ card B.
Proof. apply finite_inj. eauto. Qed.
Lemma surj_card `{Finite A} `{Finite B} (f : A → B)
  `{!Surj (=) f} : card B ≤ card A.
Proof.
  destruct (surj_cancel f) as (g&?).
  apply inj_card with g, cancel_inj.
Qed.
Lemma bijective_card `{Finite A} `{Finite B} (f : A → B)
  `{!Inj (=) (=) f} `{!Surj (=) f} : card A = card B.
Proof. apply finite_bijective. eauto. Qed.

(** Decidability of quantification over finite types *)
Section forall_exists.
  Context `{Finite A} (P : A → Prop).

  Lemma Forall_finite : Forall P (enum A) ↔ (∀ x, P x).
  Proof. rewrite Forall_forall. intuition auto using elem_of_enum. Qed.
  Lemma Exists_finite : Exists P (enum A) ↔ (∃ x, P x).
  Proof. rewrite Exists_exists. naive_solver eauto using elem_of_enum. Qed.

  Context `{∀ x, Decision (P x)}.

  Global Instance forall_dec: Decision (∀ x, P x).
  Proof using Type*.
   refine (cast_if (decide (Forall P (enum A))));
    abstract by rewrite <-Forall_finite.
  Defined.
  Global Instance exists_dec: Decision (∃ x, P x).
  Proof using Type*.
   refine (cast_if (decide (Exists P (enum A))));
    abstract by rewrite <-Exists_finite.
  Defined.
End forall_exists.

(** Instances *)
Section enc_finite.
  Context `{EqDecision A}.
  Context (to_nat : A → nat) (of_nat : nat → A) (c : nat).
  Context (of_to_nat : ∀ x, of_nat (to_nat x) = x).
  Context (to_nat_c : ∀ x, to_nat x < c).
  Context (to_of_nat : ∀ i, i < c → to_nat (of_nat i) = i).

  Program Instance enc_finite : Finite A := {| enum := of_nat <$> seq 0 c |}.
  Next Obligation.
    apply NoDup_alt. intros i j x. rewrite !list_lookup_fmap. intros Hi Hj.
    destruct (seq _ _ !! i) as [i'|] eqn:Hi',
      (seq _ _ !! j) as [j'|] eqn:Hj'; simplify_eq/=.
    apply lookup_seq in Hi' as  [-> ?]. apply lookup_seq in Hj' as [-> ?].
    rewrite <-(to_of_nat i), <-(to_of_nat j) by done. by f_equal.
  Qed.
  Next Obligation.
    intros x. rewrite elem_of_list_fmap. exists (to_nat x).
    split; auto. by apply elem_of_list_lookup_2 with (to_nat x), lookup_seq.
  Qed.
  Lemma enc_finite_card : card A = c.
  Proof. unfold card. simpl. by rewrite fmap_length, seq_length. Qed.
End enc_finite.

Section bijective_finite.
  Context `{Finite A, EqDecision B} (f : A → B) (g : B → A).
  Context `{!Inj (=) (=) f, !Cancel (=) f g}.

  Program Instance bijective_finite: Finite B := {| enum := f <$> enum A |}.
  Next Obligation. apply (NoDup_fmap_2 _), NoDup_enum. Qed.
  Next Obligation.
    intros y. rewrite elem_of_list_fmap. eauto using elem_of_enum.
  Qed.
End bijective_finite.

Program Instance option_finite `{Finite A} : Finite (option A) :=
  {| enum := None :: (Some <$> enum A) |}.
Next Obligation.
  constructor.
  - rewrite elem_of_list_fmap. by intros (?&?&?).
  - apply (NoDup_fmap_2 _); auto using NoDup_enum.
Qed.
Next Obligation.
  intros ??? [x|]; [right|left]; auto.
  apply elem_of_list_fmap. eauto using elem_of_enum.
Qed.
Lemma option_cardinality `{Finite A} : card (option A) = S (card A).
Proof. unfold card. simpl. by rewrite fmap_length. Qed.

Program Instance Empty_set_finite : Finite Empty_set := {| enum := [] |}.
Next Obligation. by apply NoDup_nil. Qed.
Next Obligation. intros []. Qed.
Lemma Empty_set_card : card Empty_set = 0.
Proof. done. Qed.

Program Instance unit_finite : Finite () := {| enum := [tt] |}.
Next Obligation. apply NoDup_singleton. Qed.
Next Obligation. intros []. by apply elem_of_list_singleton. Qed.
Lemma unit_card : card unit = 1.
Proof. done. Qed.

Program Instance bool_finite : Finite bool := {| enum := [true; false] |}.
Next Obligation.
  constructor; [ by rewrite elem_of_list_singleton | apply NoDup_singleton ].
Qed.
Next Obligation. intros [|]; [ left | right; left ]. Qed.
Lemma bool_card : card bool = 2.
Proof. done. Qed.

Program Instance sum_finite `{Finite A, Finite B} : Finite (A + B)%type :=
  {| enum := (inl <$> enum A) ++ (inr <$> enum B) |}.
Next Obligation.
  intros. apply NoDup_app; split_and?.
  - apply (NoDup_fmap_2 _). by apply NoDup_enum.
  - intro. rewrite !elem_of_list_fmap. intros (?&?&?) (?&?&?); congruence.
  - apply (NoDup_fmap_2 _). by apply NoDup_enum.
Qed.
Next Obligation.
  intros ?????? [x|y]; rewrite elem_of_app, !elem_of_list_fmap;
    [left|right]; (eexists; split; [done|apply elem_of_enum]).
Qed.
Lemma sum_card `{Finite A, Finite B} : card (A + B) = card A + card B.
Proof. unfold card. simpl. by rewrite app_length, !fmap_length. Qed.

Program Instance prod_finite `{Finite A, Finite B} : Finite (A * B)%type :=
  {| enum := foldr (λ x, (pair x <$> enum B ++.)) [] (enum A) |}.
Next Obligation.
  intros A ?????. induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl.
  { constructor. }
  apply NoDup_app; split_and?.
  - by apply (NoDup_fmap_2 _), NoDup_enum.
  - intros [? y]. rewrite elem_of_list_fmap. intros (?&?&?); simplify_eq.
    clear IH. induction Hxs as [|x' xs ?? IH]; simpl.
    { rewrite elem_of_nil. tauto. }
    rewrite elem_of_app, elem_of_list_fmap.
    intros [(?&?&?)|?]; simplify_eq.
    + destruct Hx. by left.
    + destruct IH; [ | by auto ]. by intro; destruct Hx; right.
  - done.
Qed.
Next Obligation.
  intros ?????? [x y]. induction (elem_of_enum x); simpl.
  - rewrite elem_of_app, !elem_of_list_fmap. eauto using elem_of_enum.
  - rewrite elem_of_app; eauto.
Qed.
Lemma prod_card `{Finite A} `{Finite B} : card (A * B) = card A * card B.
Proof.
  unfold card; simpl. induction (enum A); simpl; auto.
  rewrite app_length, fmap_length. auto.
Qed.

Definition list_enum {A} (l : list A) : ∀ n, list { l : list A | length l = n } :=
  fix go n :=
  match n with
  | 0 => [[]↾eq_refl]
  | S n => foldr (λ x, (sig_map (x ::.) (λ _ H, f_equal S H) <$> (go n) ++.)) [] l
  end.

Program Instance list_finite `{Finite A} n : Finite { l : list A | length l = n } :=
  {| enum := list_enum (enum A) n |}.
Next Obligation.
  intros A ?? n. induction n as [|n IH]; simpl; [apply NoDup_singleton |].
  revert IH. generalize (list_enum (enum A) n). intros l Hl.
  induction (NoDup_enum A) as [|x xs Hx Hxs IH]; simpl; auto; [constructor |].
  apply NoDup_app; split_and?.
  - by apply (NoDup_fmap_2 _).
  - intros [k1 Hk1]. clear Hxs IH. rewrite elem_of_list_fmap.
    intros ([k2 Hk2]&?&?) Hxk2; simplify_eq/=. destruct Hx. revert Hxk2.
    induction xs as [|x' xs IH]; simpl in *; [by rewrite elem_of_nil |].
    rewrite elem_of_app, elem_of_list_fmap, elem_of_cons.
    intros [([??]&?&?)|?]; simplify_eq/=; auto.
  - apply IH.
Qed.
Next Obligation.
  intros A ?? n [l Hl]. revert l Hl.
  induction n as [|n IH]; intros [|x l] Hl; simpl; simplify_eq.
  { apply elem_of_list_singleton. by apply (sig_eq_pi _). }
  revert IH. generalize (list_enum (enum A) n). intros k Hk.
  induction (elem_of_enum x) as [x xs|x xs]; simpl in *.
  - rewrite elem_of_app, elem_of_list_fmap. left. injection Hl. intros Hl'.
    eexists (l↾Hl'). split; [|done]. by apply (sig_eq_pi _).
  - rewrite elem_of_app. eauto.
Qed.

Lemma list_card `{Finite A} n : card { l : list A | length l = n } = card A ^ n.
Proof.
  unfold card; simpl. induction n as [|n IH]; simpl; auto.
  rewrite <-IH. clear IH. generalize (list_enum (enum A) n).
  induction (enum A) as [|x xs IH]; intros l; simpl; auto.
  by rewrite app_length, fmap_length, IH.
Qed.

Fixpoint fin_enum (n : nat) : list (fin n) :=
  match n with 0 => [] | S n => 0%fin :: (FS <$> fin_enum n) end.
Program Instance fin_finite n : Finite (fin n) := {| enum := fin_enum n |}.
Next Obligation.
  intros n. induction n; simpl; constructor.
  - rewrite elem_of_list_fmap. by intros (?&?&?).
  - by apply (NoDup_fmap _).
Qed.
Next Obligation.
  intros n i. induction i as [|n i IH]; simpl;
    rewrite elem_of_cons, ?elem_of_list_fmap; eauto.
Qed.
Lemma fin_card n : card (fin n) = n.
Proof. unfold card; simpl. induction n; simpl; rewrite ?fmap_length; auto. Qed.

Section sig_finite.
  Context {A} (P : A → Prop) `{∀ x, Decision (P x)}.

  Fixpoint list_filter_sig (l : list A) : list (sig P) :=
    match l with
    | [] => []
    | x :: l => match decide (P x) with
              | left H => x ↾ H :: list_filter_sig l
              | _ => list_filter_sig l
              end
    end.
  Lemma list_filter_sig_filter (l : list A) :
    proj1_sig <$> list_filter_sig l = filter P l.
  Proof.
    induction l as [| a l IH]; [done |].
    simpl; rewrite filter_cons.
    destruct (decide _); csimpl; by rewrite IH.
  Qed.

  Context `{Finite A} `{∀ x, ProofIrrel (P x)}.

  Global Program Instance sig_finite : Finite (sig P) :=
    {| enum := list_filter_sig (enum A) |}.
  Next Obligation.
    eapply NoDup_fmap_1. rewrite list_filter_sig_filter.
    apply NoDup_filter, NoDup_enum.
  Qed.
  Next Obligation.
    intros p. apply (elem_of_list_fmap_2_inj proj1_sig).
    rewrite list_filter_sig_filter, elem_of_list_filter.
    split; [by destruct p | apply elem_of_enum].
  Qed.
  Lemma sig_card : card (sig P) = length (filter P (enum A)).
  Proof. by rewrite <-list_filter_sig_filter, fmap_length. Qed.
End sig_finite.


From Coq Require Import Lists.List.
From Coq Require Import Relations.Relations.
From Coq Require Import Sorting.Sorting.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Lia.
From AAC_tactics Require Import AAC.

Parameter var : Set. (* TODO https://github.com/coq-community/aac-tactics/issues/85 ? *)

Axiom var_eq_dec : forall x y : var, {x = y} + {x <> y}.

Inductive φ :=
| φ_pos : var -> φ
| φ_neg : var -> φ
| φ_one : φ
| φ_bot : φ
| φ_top : φ
| φ_nul : φ
| φ_tns : φ -> φ -> φ
| φ_par : φ -> φ -> φ
| φ_wth : φ -> φ -> φ
| φ_pls : φ -> φ -> φ
| φ_bng : φ -> φ
| φ_whn : φ -> φ.

Fixpoint dual_φ (A : φ) :=
match A with
| φ_pos x => φ_neg x
| φ_neg x => φ_pos x
| φ_one => φ_bot
| φ_bot => φ_one
| φ_top => φ_nul
| φ_nul => φ_top
| φ_tns A B => φ_par (dual_φ A) (dual_φ B)
| φ_par A B => φ_tns (dual_φ A) (dual_φ B)
| φ_wth A B => φ_pls (dual_φ A) (dual_φ B)
| φ_pls A B => φ_wth (dual_φ A) (dual_φ B)
| φ_bng A => φ_whn (dual_φ A)
| φ_whn A => φ_bng (dual_φ A)
end.

Notation "P °" := (dual_φ P) (at level 1, left associativity, format "P °").

Notation "1" := (φ_one).
Notation "⊥" := (φ_bot).
Notation "⊤" := (φ_top).
Notation "0" := (φ_nul).

Notation "A ⊗ B" := (φ_tns A B) (at level 40).
Notation "A ⅋ B" := (φ_par A B) (at level 40).
Notation "A ⊕ B" := (φ_pls A B) (at level 50).
Notation "A & B" := (φ_wth A B) (at level 50).
Notation "! A" := (φ_bng A) (at level 10, format "!  A").
Notation "? A" := (φ_whn A) (at level 10, format "?  A").

Definition φ_eq_dec : forall A B : φ, {A = B} + {A <> B}.
Proof.
intros A B; decide equality; apply var_eq_dec.
Defined.

Definition sequent := list φ.

(* Definition permutation (Γ Δ : sequent) := forall (P : φ),
  count_occ φ_eq_dec Γ P = count_occ φ_eq_dec Δ P. *)

Definition permutation (Γ Δ : sequent) := Sorting.Permutation.Permutation Γ Δ.

Inductive derivation : sequent -> Prop :=
| drv_axm : forall A,
  derivation (A :: A° :: nil)
| drv_cut : forall Γ Δ A,
  derivation (A :: Γ) -> derivation (A° :: Δ) -> derivation (Γ ++ Δ)
| drv_prm : forall Γ Δ,
  permutation Γ Δ -> derivation Γ -> derivation Δ
| drv_one :
  derivation (1 :: nil)
| drv_bot : forall Γ,
  derivation Γ -> derivation (⊥ :: Γ)
| drv_top : forall Γ,
  derivation (⊤ :: Γ)
| drv_tns : forall Γ Δ A B,
  derivation (A :: Γ) -> derivation (B :: Δ) -> derivation (A ⊗ B :: Γ ++ Δ)
| drv_par : forall Γ A B,
  derivation (A :: B :: Γ) -> derivation (A ⅋ B :: Γ)
| drv_wth : forall Γ A B,
  derivation (A :: Γ) -> derivation (B :: Γ) -> derivation (A & B :: Γ)
| drv_pls_1 : forall Γ A B,
  derivation (A :: Γ) -> derivation (A ⊕ B :: Γ)
| drv_pls_2 : forall Γ A B,
  derivation (B :: Γ) -> derivation (A ⊕ B :: Γ)
| drv_drl : forall Γ A,
  derivation (A :: Γ) -> derivation (? A :: Γ)
| drv_wkn : forall Γ A,
  derivation Γ -> derivation (? A :: Γ)
| drv_ctr : forall Γ A,
  derivation (? A :: ? A :: Γ) -> derivation (? A :: Γ)
| drv_bng : forall Γ A,
  derivation (A :: List.map φ_whn Γ) -> derivation (! A :: List.map φ_whn Γ)
.

Ltac cauto := auto with typeclass_instances.

Section Permutation.

Import Sorting.Permutation.

(* Lemma permutation_nil : forall Γ, permutation nil Γ -> Γ = nil.
Proof.
intros Γ; induction Γ as [|A Γ]; [reflexivity|].
unfold permutation; intros Hperm; specialize (Hperm A); simpl in Hperm.
destruct φ_eq_dec; now intuition.
Qed.

Lemma permutation_cons : forall Γ Δ A, permutation (A :: Γ) Δ ->
  { Δs | Δ = (fst Δs) ++ A :: (snd Δs) /\ permutation Γ ((fst Δs) ++ (snd Δs)) }.
Proof.
intros Γ; induction Γ as [|B Γ]; intros Δ A Hperm.
  exists (nil, nil); simpl; split; [|unfold permutation; now auto].
  destruct Δ as [|B Δ].
    specialize (Hperm A); simpl in Hperm; destruct φ_eq_dec; exfalso; congruence.
    destruct (φ_eq_dec A B) as [Heq|Hdf]; subst; [f_equal|exfalso].
      admit.
      specialize (Hperm B).
      rewrite (@count_occ_cons_neq _ _ _ A B) in Hperm; [|congruence].
      now simpl in Hperm; destruct φ_eq_dec; congruence.
SearchAbout list.
Locate Permutation.
Print Sorting.Permutation. *)

Lemma permutation_ind : forall (P : sequent -> sequent -> Prop),
  (P nil nil) ->
  (forall Γ Δ1 Δ2 A, permutation Γ (Δ1 ++ Δ2) ->
    P Γ (Δ1 ++ Δ2) -> P (A :: Γ) (Δ1 ++ A :: Δ2)) ->
  forall Γ Δ, permutation Γ Δ -> P Γ Δ.
Proof.
intros P Hnil Hcons; induction Γ as [|A Γ]; intros Δ Hperm.
  apply Sorting.Permutation.Permutation_nil in Hperm; subst; apply Hnil.
  assert (HIn : In A Δ) by (apply (@Permutation_in _ (A :: Γ)); simpl; tauto).
  apply in_split in HIn; destruct HIn as [Δ1 [Δ2 HΔ]]; rewrite HΔ in *.
  assert (Hperm' : permutation Γ (Δ1 ++ Δ2)) by (eapply Permutation_cons_app_inv; eassumption).
  now apply Hcons; [|apply IHΓ]; assumption.
Qed.

End Permutation.

Section Phase_semantics.

Class Monoid := {
  M : Set; (* TODO https://github.com/coq-community/aac-tactics/issues/85 ? *)
  M_eq : M -> M -> Prop;
  Equivalence_M_eq :> Equivalence M_eq;
  M_op : M -> M -> M;
  M_nul : M;
  Associative_M_op :> Associative M_eq M_op;
  Commutative_M_op :> Commutative M_eq M_op;
  Unit_M_op :> Unit M_eq M_op M_nul;
  Proper_M_op :> Proper (M_eq ==> M_eq ==> M_eq) M_op
}.

Coercion M : Monoid >-> Sortclass.

Notation "x · y" := (M_op x y) (at level 40).

Section Definitions.

Context {M : Monoid}.

Ltac mreplace s t :=
  let H := fresh "H" in
  assert (H : M_eq s t); [|rewrite H; clear H].

Class fact := {
  fact_set : M -> Prop;
  fact_compat :> Proper (M_eq ==> iff) fact_set
}.

Coercion fact_set : fact >-> Funclass.

Definition fact_eq (X Y : fact) := forall x, X x <-> Y x.

Global Instance Equivalence_fact_eq : Equivalence fact_eq.
Proof.
split; unfold fact_eq.
  intros X x; now auto.
  intros X Y x; now auto.
  intros X Y Z H1 H2 x; now firstorder.
Qed.

Class assignation := assignation_fun : var -> fact.
Context {assign : assignation}.

Class pole := pole_set : fact.
Typeclasses Transparent pole.

Context {pole : pole}.

Global Instance Proper_fact_set : Proper (fact_eq ==> M_eq ==> iff) (@fact_set).
Proof.
intros X Y HXY x y Hxy; simpl.
split; intros H; apply HXY; first [rewrite Hxy|rewrite <- Hxy]; assumption.
Qed.

Global Program Instance orth (X : fact) : fact :=
  { fact_set := (fun x => forall y, X y -> pole (x · y)) }.
Next Obligation.
apply proper_sym_impl_iff; [cauto|].
intros x y H HR z Hz.
mreplace (y · z) (x · z); [rewrite H; reflexivity|now eauto].
Qed.

Notation "X ⌝" := (orth X) (at level 1, left associativity, format "X ⌝").

Lemma orth_closed : forall X, fact_eq X⌝⌝⌝ X⌝.
Proof.
intros X x; split; unfold orth; simpl.
  intros Hx y Hy; apply Hx; intros z Hz.
  mreplace (y · z) (z · y); [aac_reflexivity|].
  now apply Hz; assumption.
  intros Hx y Hy.
  mreplace (x · y) (y · x); [aac_reflexivity|].
  apply Hy; now intuition.
Qed.

Lemma orth_incl : forall (X : fact) x, X x -> X⌝⌝ x.
Proof.
intros X x Hx; unfold orth; simpl; intros y Hy.
mreplace (x · y) (y · x); [aac_reflexivity|].
now apply Hy; assumption.
Qed.

Global Instance Proper_orth : Proper (fact_eq ==> fact_eq) orth.
Proof.
intros X Y Heq x; split; unfold orth; simpl; intros H; firstorder.
Qed.

(* Program Instance fact_dsj (X Y : fact) : fact :=
  { fact_set := fun x => X x \/ Y x }.
Next Obligation.
apply proper_sym_impl_iff; [now cauto|].
intros x y Heq H; rewrite <- Heq; intuition.
Qed. *)

Inductive fact_prd_set (X Y : fact) (z : M) : Prop :=
| fact_prd_set_intro :
  forall x y, X x -> Y y -> M_eq z (x · y) -> fact_prd_set X Y z.

Global Program Instance fact_prd (X Y : fact) : fact :=
  { fact_set := fact_prd_set X Y }.
Next Obligation.
apply proper_sym_impl_iff; [now cauto|].
intros x y Heq [z w Hz Hw H]; exists z w; solve [auto|rewrite <- Heq; assumption].
Qed.

Notation "X ⊙ Y" := (fact_prd X Y) (at level 40).

Global Instance Proper_fact_prd : Proper (fact_eq ==> fact_eq ==> fact_eq) fact_prd.
Proof.
intros X1 X2 HeqX Y1 Y2 HeqY z; split; intros [x y Hx Hy H]; exists x y;
  first [apply HeqX|apply HeqY|idtac]; assumption.
Qed.

Global Program Instance fact_dsj (X Y : fact) : fact :=
  { fact_set := fun x => X x \/ Y x }.
Next Obligation.
apply proper_sym_impl_iff; [now cauto|].
intros x y Heq H; rewrite <- Heq; now intuition.
Qed.

Notation "X ∪ Y" := (fact_dsj X Y) (at level 50).

Global Instance Proper_fact_dsj : Proper (fact_eq ==> fact_eq ==> fact_eq) fact_dsj.
Proof.
intros X1 X2 HeqX Y1 Y2 HeqY x; split; intros [Hl|Hr]; simpl; solve [
  left; apply HeqX; assumption|
  right; apply HeqY; assumption].
Qed.

Global Program Instance fact_one : fact := { fact_set := fun x => M_eq x M_nul }.
Next Obligation.
apply proper_sym_impl_iff; [now cauto|].
intros x y Heq H; rewrite <- Heq; now auto.
Qed.

Global Program Instance fact_nul : fact := { fact_set := fun x => False }.
Next Obligation.
apply proper_sym_impl_iff; [now cauto|].
intros x y Heq; intuition.
Qed.

Record fact_bng_set (X : fact) (x : M) : Prop := {
  fact_bng_fct : X x;
  fact_bng_one : fact_one⌝⌝ x;
  fact_bng_dup : M_eq (x · x) x
}.

Global Program Instance fact_bng (X : fact) : fact :=
  { fact_set := fact_bng_set X }.
Next Obligation.
apply proper_sym_impl_iff; [now cauto|].
intros x y Heq [Hx H1 Hd]; split; rewrite <- Heq; assumption.
Qed.

Global Instance Proper_fact_bng : Proper (fact_eq ==> fact_eq) fact_bng.
Proof.
intros X1 X2 HeqX x; split; intros [Hx H1 Hd]; split;
first [rewrite HeqX|rewrite <- HeqX|idtac]; assumption.
Qed.

Fixpoint eval_φ A : fact :=
match A with
| φ_pos x => (assign x)⌝⌝
| φ_neg x => (assign x)⌝
| 1 => fact_one⌝⌝
| ⊥ => fact_one⌝
| ⊤ => fact_nul⌝
| 0 => fact_nul⌝⌝
| A ⊗ B => (fact_prd (eval_φ A) (eval_φ B))⌝⌝
| A ⅋ B => (fact_prd (eval_φ A)⌝ (eval_φ B)⌝)⌝
| A & B => (fact_dsj (eval_φ A)⌝ (eval_φ B)⌝)⌝
| A ⊕ B => (fact_dsj (eval_φ A) (eval_φ B))⌝⌝
| ! A => (fact_bng (eval_φ A))⌝⌝
| ? A => (fact_bng (eval_φ A)⌝)⌝
end.

Fixpoint sequent_to_φ Γ :=
match Γ with
| nil => ⊥
| A :: Γ => A ⅋ (sequent_to_φ Γ)
end.

Lemma fact_prd_comm : forall X Y, fact_eq (fact_prd X Y) (fact_prd Y X).
Proof.
intros X Y z; split; intros [x y Hx Hy H]; exists y x;
solve [assumption|rewrite Commutative_M_op; assumption].
Qed.

Lemma fact_prd_assoc : forall X Y Z, fact_eq (fact_prd X (fact_prd Y Z)) (fact_prd (fact_prd X Y) Z).
Proof.
intros X Y Z w; split.
  intros [x ? Hx [y z Hy Hz H'] H].
  exists (x · y) z; [exists x y| |]; first [assumption|reflexivity|idtac].
  rewrite H, H'; aac_reflexivity.
  intros [? z [x y Hx Hy H] Hz H'].
  exists x (y · z); [|exists y z|]; first [assumption|reflexivity|idtac].
  rewrite H', H; aac_reflexivity.
Qed.

Lemma fact_prd_closed_l : forall X Y, fact_eq Y⌝⌝ Y ->
  fact_eq (fact_prd X⌝⌝ Y)⌝ (fact_prd X Y)⌝.
Proof.
intros X Y Heq w; split; intros H; simpl in *.
  intros z [x y Hx Hy Hz].
  now apply H; exists x y; [apply orth_incl| |]; assumption.
  intros z [x y Hx Hy Hz]; rewrite Hz.
  mreplace (w · (x · y)) (x · (w · y)); [aac_reflexivity|].
  apply Hx; clear x Hx Hz; intros x Hx.
  mreplace ((w · y) · x) (w · (x · y)); [aac_reflexivity|].
  apply H; exists x y; solve [assumption|reflexivity].
Qed.

Lemma fact_prd_closed_r : forall X Y, fact_eq X⌝⌝ X ->
  fact_eq (fact_prd X Y⌝⌝)⌝ (fact_prd X Y)⌝.
Proof.
intros X Y Hrw.
rewrite fact_prd_comm.
rewrite fact_prd_closed_l; [|assumption].
rewrite fact_prd_comm; reflexivity.
Qed.

(* Lemma fact_prd_dual : forall X, fact_eq (fact_prd X X⌝) pole.
Proof.
intros X z; split; intros H.
  destruct H as [x y Hx Hy Hz]; rewrite Hz.
  rewrite Commutative_M_op; apply Hy; assumption.
*)

End Definitions.

(* Redefinition of notations because Coq does not accept Global Notation... *)

Notation "X ⌝" := (orth X) (at level 1, left associativity, format "X ⌝").
Notation "X ⊙ Y" := (fact_prd X Y) (at level 40).
Notation "X ∪ Y" := (fact_dsj X Y) (at level 50).

Section Soundness.

Typeclasses Transparent pole.

Context {M : Monoid}.
Context {assign : assignation}.
Context {pole : pole}.

Ltac mreplace s t :=
  let H := fresh "H" in
  assert (H : M_eq s t); [|rewrite H; clear H].

Lemma eval_φ_dual_aux : forall A, fact_eq (eval_φ A°) (eval_φ A)⌝ /\ fact_eq (eval_φ A)⌝⌝ (eval_φ A).
Proof.
intros A; induction A; simpl; split;
  first [reflexivity|symmetry; apply orth_closed|now apply orth_closed|idtac].
  destruct IHA1 as [IHA1_l IHA1_r]; destruct IHA2 as [IHA2_l IHA2_r];
  rewrite orth_closed, IHA1_l, IHA2_l, IHA1_r, IHA2_r; reflexivity.
  destruct IHA1 as [IHA1_l IHA1_r]; destruct IHA2 as [IHA2_l IHA2_r];
  rewrite IHA1_l, IHA2_l; reflexivity.
  destruct IHA1 as [IHA1_l IHA1_r]; destruct IHA2 as [IHA2_l IHA2_r];
  rewrite IHA1_l, IHA2_l; reflexivity.
  destruct IHA1 as [IHA1_l IHA1_r]; destruct IHA2 as [IHA2_l IHA2_r];
  rewrite orth_closed, IHA1_l, IHA2_l, IHA1_r, IHA2_r; reflexivity.
  destruct IHA as [IHA_l IHA_r];
  rewrite orth_closed, IHA_l, IHA_r; reflexivity.
  destruct IHA as [IHA_l IHA_r];
  rewrite IHA_l; reflexivity.
Qed.

Lemma eval_φ_dual_compat : forall A, fact_eq (eval_φ A°) (eval_φ A)⌝.
Proof.
apply eval_φ_dual_aux.
Qed.

Lemma eval_φ_dual_closed : forall A, fact_eq (eval_φ A)⌝⌝ (eval_φ A).
Proof.
apply eval_φ_dual_aux.
Qed.

Notation "[[ Γ ]]" := (eval_φ (sequent_to_φ Γ)) (format "[[ Γ ]]").

(* Definition eval_sequent Γ : fact := eval_φ (sequent_to_φ Γ). *)

Lemma eval_sequent_app_compat : forall Γ Δ,
  fact_eq [[Γ ++ Δ]] (fact_prd [[Γ]]⌝ [[Δ]]⌝)⌝.
Proof.
intros Γ; induction Γ as [|A Γ]; intros Δ; simpl.
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  set (X := eval_φ (sequent_to_φ Δ)).
  assert (HX : fact_eq X⌝⌝ X) by (apply eval_φ_dual_closed); clearbody X.
  intros x; split; intros Hx.
    intros ? [u xc Hu Hxc H]; rewrite H, Hu; clear H Hu.
    mreplace (x · (M_nul · xc)) (xc · x); [aac_reflexivity|].
    now apply Hxc; assumption.
    now rewrite <- HX; intros xc Hxc; apply Hx; exists M_nul xc; simpl; solve [aac_reflexivity|assumption].
  rewrite IHΓ.
  rewrite fact_prd_closed_r; [|now apply orth_closed].
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  rewrite fact_prd_assoc; reflexivity.
Qed.

Lemma eval_sequent_permutation_compat : forall Γ Δ,
  permutation Γ Δ -> fact_eq [[Γ]] [[Δ]].
Proof.
apply permutation_ind; simpl.
  reflexivity.
  intros Γ Δ1 Δ2 A Hperm IH; rewrite IH.
  do 2 rewrite eval_sequent_app_compat; simpl.
  repeat (rewrite fact_prd_closed_r; [|now apply orth_closed]).
  rewrite <- fact_prd_comm with (Y := (eval_φ A)⌝).
  rewrite <- fact_prd_assoc.
  rewrite fact_prd_comm with (Y := (eval_φ A)⌝).
  now reflexivity.
Qed.

Ltac simpl_sequent :=
  simpl sequent_to_φ in *; unfold eval_φ in *; simpl eval_φ in *; fold eval_φ in *.

Lemma eval_φ_sound_axm : forall A, [[A :: A° :: nil]] M_nul.
Proof.
intros A; simpl_sequent.
rewrite eval_φ_dual_compat.
rewrite fact_prd_closed_r with (Y := fact_one); [|now apply orth_closed].
rewrite fact_prd_closed_r; [|now apply orth_closed].
rewrite fact_prd_assoc, eval_φ_dual_closed.
intros ? [z k Hz Hk H]; rewrite H; clear H; simpl in Hk; rewrite Hk; clear k Hk.
mreplace (M_nul · (z · M_nul)) z; [aac_reflexivity|].
destruct Hz as [xc x Hxc Hx H]; rewrite H; clear H.
now apply Hxc; assumption.
Qed.

Lemma eval_φ_sound_cut : forall Γ Δ A,
  [[A :: Γ]] M_nul -> [[A° :: Δ]] M_nul -> [[Γ ++ Δ]] M_nul.
Proof.
intros Γ Δ A IHHΓ1 IHHΓ2; simpl_sequent.
rewrite eval_sequent_app_compat.
intros p [x y Hx Hy H]; rewrite H; clear p H.
mreplace (M_nul · (x · y)) (y · x); [aac_reflexivity|].
rewrite <- orth_closed in Hy; apply Hy.
intros yc Hyc.
mreplace (x · yc) (M_nul · (x · yc)); [aac_reflexivity|].
apply IHHΓ2; exists x yc; first [reflexivity|assumption|idtac].
rewrite eval_φ_dual_compat; intros xc Hxc.
mreplace (x · xc) (M_nul · (xc · x)); [aac_reflexivity|].
now apply IHHΓ1; exists xc x; solve [reflexivity|assumption].
Qed.

Lemma eval_φ_sound_prm : forall Γ Δ,
  [[Γ]] M_nul -> permutation Γ Δ -> [[Δ]] M_nul.
Proof.
intros Γ Δ IHHΓ Hperm.
now rewrite <- (eval_sequent_permutation_compat Γ Δ); assumption.
Qed.

Lemma eval_φ_sound_one : [[1 :: nil]] M_nul.
Proof.
simpl_sequent.
rewrite fact_prd_closed_l; [|now apply orth_closed].
rewrite fact_prd_closed_r; [|now apply orth_closed].
intros z [x y Hx Hy H]; rewrite H; clear H.
mreplace (M_nul · (x · y)) (x · y); [aac_reflexivity|].
now apply Hx; assumption.
Qed.

Lemma eval_φ_sound_tns : forall Γ Δ A B,
  [[A :: Γ]] M_nul -> [[B :: Δ]] M_nul -> [[A ⊗ B :: Γ ++ Δ]] M_nul.
Proof.
intros Γ Δ A B IHHΓ1 IHHΓ2; simpl_sequent.
rewrite fact_prd_closed_l; [|now apply orth_closed].
rewrite eval_sequent_app_compat.
rewrite fact_prd_closed_r; [|now apply orth_closed].
intros z [x y Hx Hy H]; rewrite H; clear z H.
destruct Hy as [u v Hu Hv H]; rewrite H; clear y H.
mreplace (M_nul · (x · (u · v))) (x · (u · v)); [aac_reflexivity|].
apply Hx; exists u v; first [reflexivity|rewrite <- eval_φ_dual_closed].
  clear x Hx; intros x Hx.
  mreplace (u · x) (M_nul · (x · u)); [aac_reflexivity|].
  now apply IHHΓ1; exists x u; solve [assumption|reflexivity].
  clear x Hx; intros y Hy.
  mreplace (v · y) (M_nul · (y · v)); [aac_reflexivity|].
  now apply IHHΓ2; exists y v; solve [assumption|reflexivity].
Qed.

Lemma eval_φ_sound_bng : forall Γ A, [[A :: map φ_whn Γ]] M_nul -> [[! A :: map φ_whn Γ]] M_nul.
Proof.
intros Γ A HΓ; simpl_sequent.
rewrite fact_prd_closed_l; [|now apply orth_closed].
intros w [x y Hx Hy H]; rewrite H; clear w H.
mreplace (M_nul · (x · y)) (y · (M_nul · x)); [aac_reflexivity|].
apply Hy; clear y Hy; revert A x Hx HΓ.
induction Γ as [|B Γ]; intros A x Hx HΓ; simpl_sequent.
  intros z Hz; rewrite Hz; clear z Hz.
  mreplace ((M_nul · x) · M_nul) (x · M_nul); [aac_reflexivity|].
  apply Hx; split; [|apply orth_incl; simpl; reflexivity|aac_reflexivity].
  rewrite <- eval_φ_dual_closed; intros z Hz; apply HΓ.
  now exists z M_nul; [assumption|apply orth_incl; simpl; reflexivity|aac_reflexivity].

  rewrite fact_prd_closed_l in HΓ; [|now apply orth_closed].
  rewrite fact_prd_closed_r in HΓ; [|now apply orth_closed].
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [u v Hu Hv H]; rewrite H; clear w H.
  mreplace ((M_nul · x) · (u · v)) (v · (M_nul · (x · u))); [aac_reflexivity|].
  rewrite fact_prd_assoc in HΓ.
  apply Hv; apply (IHΓ (A ⅋ ? B)); unfold eval_φ in *; fold eval_φ in *;
  (rewrite fact_prd_closed_r; [|now apply orth_closed]).
    clear v Γ IHΓ HΓ Hv; intros z [Hz Hz1 Hzd]; destruct Hu as [Hu Hu1 Hud].
    mreplace ((x · u) · z) (x · (z · u)); [aac_reflexivity|].
    apply Hx; split.
      rewrite <- eval_φ_dual_closed; intros k Hk.
      mreplace ((z · u) · k) (z · (k · u)); [aac_reflexivity|].
      now apply Hz; exists k u; [assumption|split; assumption|aac_reflexivity].
      intros k Hk.
      mreplace ((z · u) · k) (z · (k · u)); [aac_reflexivity|].
      apply Hz1; intros c Hc; rewrite Hc; clear c Hc.
      mreplace ((k · u) · M_nul) (u · k); [aac_reflexivity|].
      now apply Hu1; assumption.
      mreplace ((z · u) · (z · u)) ((z · z) · (u · u)); [aac_reflexivity|].
      now rewrite Hzd, Hud; reflexivity.
    rewrite fact_prd_closed_l; [|now apply orth_closed].
    now assumption.
Qed.

Theorem eval_φ_sound : forall Γ, derivation Γ -> [[Γ]] M_nul.
Proof.
intros Γ HΓ; induction HΓ; simpl_sequent.
  (* axiom *)
  now apply eval_φ_sound_axm.
  (* cut *)
  now apply (eval_φ_sound_cut _ _ A); assumption.
  (* permutation *)
  now apply (eval_φ_sound_prm Γ Δ); assumption.
  (* 1 *)
  now apply eval_φ_sound_one.
  (* ⊥ *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros z [x y Hx Hy H]; rewrite H, Hx; clear H Hx.
  mreplace (M_nul · (M_nul · y)) (y · M_nul); [aac_reflexivity|].
  now apply Hy; assumption.
  (* ⊤ *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  now intros z [x y Hx Hy H]; rewrite H; clear H; now inversion Hx.
  (* ⊗ *)
  now apply eval_φ_sound_tns; assumption.
  (* ⅋ *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  rewrite fact_prd_closed_r in IHHΓ; [|now apply orth_closed].
  now rewrite <- fact_prd_assoc; assumption.
  (* & *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [z x Hz Hx H]; rewrite H; clear w H; destruct Hz as [Hz|Hz].
    apply IHHΓ1; exists z x; solve [assumption|reflexivity].
    apply IHHΓ2; exists z x; solve [assumption|reflexivity].
  (* ⊕_1 *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [z x Hz Hx H]; rewrite H; clear w H; apply IHHΓ.
  exists z x; [|assumption|reflexivity].
  now intros u Hu; apply Hz; simpl; tauto.
  (* ⊕_2 *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [z x Hz Hx H]; rewrite H; clear w H; apply IHHΓ.
  exists z x; [|assumption|reflexivity].
  now intros u Hu; apply Hz; simpl; tauto.
  (* dereliction *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [x y Hx Hy H]; rewrite H; clear w H; apply IHHΓ.
  exists x y; [|assumption|reflexivity].
  now destruct Hx as [Hx _ _]; assumption.
  (* weakening *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [x y Hx Hy H]; rewrite H; clear w H; destruct Hx as [_ Hx _].
  mreplace (M_nul · (x · y)) (x · (M_nul · y)); [aac_reflexivity|].
  apply Hx; intros z Hz; rewrite Hz; clear z Hz.
  mreplace ((M_nul ·y) · M_nul) (y · M_nul); [aac_reflexivity|].
  now apply Hy; assumption.
  (* contraction *)
  rewrite fact_prd_closed_l; [|now apply orth_closed].
  intros w [x y Hx Hy H]; rewrite H; clear w H.
  assert (Hd := fact_bng_dup _ _ Hx); rewrite <- Hd; apply IHHΓ.
  exists x (x · y); [apply orth_incl; assumption|apply orth_incl|aac_reflexivity].
  now exists x y; [apply orth_incl; assumption|assumption|aac_reflexivity].
  (* promotion *)
  apply eval_φ_sound_bng; assumption.
Qed.

End Soundness.

(* Section Witness.

(* We need a formula A such that neither A nor A° is provable. *)

Existing Instance eq_equivalence.

Program Let XOR_Monoid : Monoid := {|
  M := bool;
  M_eq := @eq bool;
  M_op := xorb;
  M_nul := false
|}.
Next Obligation.
intros x y z; symmetry; apply Bool.xorb_assoc.
Qed.
Next Obligation.
intros x y; apply Bool.xorb_comm.
Qed.
Next Obligation.
split.
  apply Bool.xorb_false_r.
  apply Bool.xorb_false_l.
Qed.
Next Obligation.
repeat intro; congruence.
Qed.

Program Let T : @fact XOR_Monoid := {| fact_set := fun x => x = true |}.
Program Let T_pole : pole := T.

Program Let α : assignation := fun (_ : var) => T.

Lemma no_derivation_one_par_one : ~ derivation (1 ⅋ 1 :: nil).
Proof.
intros Hd; apply (@eval_φ_sound XOR_Monoid α T_pole) in Hd.
specialize (Hd false); unfold eval_φ in Hd; fold eval_φ in Hd; discriminate Hd.
repeat rewrite orth_closed.
exists false false; try reflexivity; apply orth_incl; [|reflexivity].
exists true true; first [reflexivity|simpl]; intros ? ?; subst; reflexivity.
Qed.

Program Let O_pole : pole := fact_nul.

Lemma no_derivation_bot_tns_bot : ~ derivation (⊥ ⊗ ⊥ :: nil).
Proof.
intros Hd; apply (@eval_φ_sound XOR_Monoid α O_pole) in Hd.
specialize (Hd false); unfold eval_φ in Hd; fold eval_φ in Hd; elim Hd.
repeat rewrite orth_closed.
exists false false; [|apply orth_incl; reflexivity|reflexivity].
intros b [x y Hx Hy H]; rewrite H; clear b H.
elim (Hx false); reflexivity.
Qed.

End Witness. *)

Section Completeness.

Inductive syntactic_rel : sequent -> sequent -> Prop :=
| synrel_prm : forall Γ Δ, permutation Γ Δ -> syntactic_rel Γ Δ
| synrel_ctr : forall Γ A, syntactic_rel (? A :: ? A :: Γ) (? A :: Γ).

Definition syntactic_eq := clos_refl_sym_trans _ syntactic_rel.

Instance Reflexive_syntactic_eq : Reflexive syntactic_eq.
Proof.
intros Γ; apply rst_refl.
Qed.

Instance Symmetric_syntactic_eq : Symmetric syntactic_eq.
Proof.
intros Γ Δ H; apply rst_sym; assumption.
Qed.

Instance Transitive_syntactic_eq : Transitive syntactic_eq.
Proof.
intros Γ Δ Ξ Hl Hr; eapply rst_trans; eassumption.
Qed.

Program Instance Equivalence_syntactic_eq : Equivalence syntactic_eq.

Lemma permutation_syntactic_eq_incl : forall Γ Δ, permutation Γ Δ -> syntactic_eq Γ Δ.
Proof.
intros Γ Δ H.
apply rst_step; apply synrel_prm; assumption.
Qed.

Lemma Proper_syntactic_eq_permutation : Proper (permutation ==> permutation ==> iff) syntactic_eq.
Proof.
intros Γ1 Γ2 HΓ Δ1 Δ2 HΔ.
apply permutation_syntactic_eq_incl in HΓ.
apply permutation_syntactic_eq_incl in HΔ.
split; intros; rewrite HΓ, HΔ in *; tauto.
Qed.

Instance Proper_syntactic_eq_app : Proper (syntactic_eq ==> syntactic_eq ==> syntactic_eq) (@app φ).
Proof.
intros Γ1 Γ2 HΓ Δ1 Δ2 HΔ; revert Δ1 Δ2 HΔ.
apply clos_rst_rst1n in HΓ.
induction HΓ as [Γ|Γ1 Γ2 Γ3]; intros Δ1 Δ2 HΔ.
  apply clos_rst_rst1n in HΔ.
  induction HΔ as [Δ|Δ1 Δ2 Δ3].
    now reflexivity.
    transitivity (Γ ++ Δ2); [|assumption].
    refine (let P := _ in or_ind (P Γ Δ1 Δ2) (_ (P Γ Δ2 Δ1)) H); now intuition.
    Unshelve. 2:{
    clear; intros Γ Δ1 Δ2 HΔ; induction HΔ as [Δ1 Δ2|Δ].
      now apply rst_step, synrel_prm, Permutation.Permutation_app_head.
      transitivity (? A :: ? A :: Δ ++ Γ).
        now apply rst_step, synrel_prm, Permutation.Permutation_app_comm.
      transitivity (? A :: Δ ++ Γ).
        now apply rst_step, synrel_ctr.
        now apply rst_step, synrel_prm; apply (Permutation.Permutation_app_comm (? A :: Δ) Γ). }
  transitivity (Γ2 ++ Δ1); [clear - H|apply IHHΓ; eassumption].
  refine (let P := _ in or_ind (P Γ1 Γ2 Δ1) (_ (P Γ2 Γ1 Δ1)) H); now intuition.
  Unshelve.
  clear; intros Γ1 Γ2 Δ HΓ; induction HΓ as [Γ1 Γ2|Γ].
    now apply rst_step, synrel_prm, Permutation.Permutation_app_tail.
    now simpl; apply rst_step, synrel_ctr.
Qed.

Program Instance Syntactic_Monoid : Monoid := {
  M := sequent;
  M_op := @app _;
  M_eq := syntactic_eq;
  M_nul := nil
}.
Next Obligation.
intros Γ Δ Ξ; rewrite app_assoc; reflexivity.
Qed.
Next Obligation.
intros Γ Δ; apply permutation_syntactic_eq_incl.
apply Permutation.Permutation_app_comm; apply Permutation.Permutation_refl.
Qed.
Next Obligation.
split; intros Γ.
  rewrite app_nil_l; reflexivity.
  rewrite app_nil_r; reflexivity.
Qed.

Instance Proper_syntactic_eq_derivation : Proper (syntactic_eq ==> iff) derivation.
Proof.
apply proper_sym_impl_iff; [change (Symmetric (@M_eq Syntactic_Monoid)); cauto|].
intros Γ Δ Heq HΓ; apply clos_rst_rst1n in Heq.
induction Heq as [Γ|Γ Δ Ξ]; [assumption|apply IHHeq].
clear - H HΓ; destruct H as [H|H]; induction H as [Γ Δ|Γ].
  now eapply drv_prm; eassumption.
  now apply drv_ctr; assumption.
  now eapply drv_prm; [apply Permutation.Permutation_sym|]; eassumption.
  now apply drv_wkn; assumption.
Qed.

Program Instance provable_pole : fact := {
  fact_set := fun Γ => derivation Γ
}.
Next Obligation.
apply Proper_syntactic_eq_derivation.
Qed.

Program Let pole : pole := provable_pole.
Existing Instance pole.

Program Let fact_cst (v : var) : fact := {| fact_set := fun Γ => syntactic_eq Γ (φ_pos v :: nil) |}.
Next Obligation.
apply proper_sym_impl_iff; [change (Symmetric (@M_eq Syntactic_Monoid)); cauto|].
intros Γ1 Γ2 HΓ Hrw; rewrite <- Hrw; symmetry; assumption.
Qed.

Program Let α : assignation := fun v : var => (fact_cst v)⌝.
Existing Instances α.

Lemma syntactic_eq_cons_app : forall A Γ, syntactic_eq (A :: Γ) (Γ ++ A :: nil).
Proof.
intros A Γ; apply rst_step, synrel_prm.
replace (A :: Γ) with ((A :: nil) ++ Γ) by reflexivity.
now apply Permutation.Permutation_app_comm.
Qed.

Lemma syntactic_eq_idempotent : forall Γ,
  syntactic_eq (Γ · Γ) Γ -> {Δ | Γ = map φ_whn Δ}.
Proof.
intros Γ Heq.
assert (Hc : {Δ | Γ = map φ_whn Δ} + {exists A, In A Γ /\ forall B, A <> ? B}).
  clear; induction Γ as [|A Γ].
    left; exists nil; reflexivity.
    destruct IHΓ as [[Δ HΔ]|H]; [|now right; destruct H as [B HB]; exists B; intuition].
    assert (Heq : {B | A = ? B} + {forall B, A <> ? B}).
      now destruct A; intuition (eauto||congruence).
    destruct Heq as [[B HB]|Hr].
      now left; exists (B :: Δ); simpl; congruence.
      now right; exists A; intuition.
destruct Hc as [?|Hc]; [assumption|exfalso].
assert (Hcount :
  forall Γ Δ A, syntactic_eq Γ Δ -> (forall B, A <> ? B) ->
  count_occ φ_eq_dec Γ A = count_occ φ_eq_dec Δ A).
  clear; intros Γ Δ A Heq HA.
  apply clos_rst_rst1n in Heq; induction Heq as [Γ|Γ1 Γ2 Γ3].
    reflexivity.
    etransitivity; [|eassumption].
    refine (let P := _ in or_ind (P Γ1 Γ2) (_ (P Γ2 Γ1)) H); now intuition.
    Unshelve. 2:{
    clear - HA; intros Γ1 Γ2 Hr; induction Hr.
      now induction H; simpl; repeat destruct φ_eq_dec; congruence.
      unfold count_occ.
      destruct (φ_eq_dec); [exfalso; intuition congruence|reflexivity]. }
destruct Hc as [A [Hi HA]].
assert (H := Hcount _ _ A Heq HA); clear - H Hi.
assert (Hrw : forall Γ Δ, count_occ φ_eq_dec (Γ ++ Δ) A = count_occ φ_eq_dec Γ A + count_occ φ_eq_dec Δ A).
  clear; intros Γ Δ; induction Γ as [|B Γ].
    reflexivity.
    simpl; destruct φ_eq_dec; rewrite IHΓ; lia.
simpl in H; rewrite Hrw in H.
apply -> (count_occ_In φ_eq_dec) in Hi; lia.
Qed.

Lemma eval_φ_complete : forall A Γ, (eval_φ A) Γ -> derivation (A :: Γ).
Proof.
induction A; intros Γ HΓ;
  unfold eval_φ in *; fold eval_φ in *; simpl; rewrite syntactic_eq_cons_app.
  (* positive variable *)
  apply HΓ; clear Γ HΓ; intros Γ HΓ; simpl; simpl in HΓ.
  now rewrite syntactic_eq_cons_app; apply HΓ; reflexivity.
  (* negative variable *)
  apply HΓ; clear Γ HΓ; intros Γ HΓ; simpl in *.
  replace (φ_neg v :: Γ) with ((φ_neg v :: nil) ++ Γ) by reflexivity.
  now rewrite HΓ; simpl; apply drv_axm.
  (* 1 *)
  now apply HΓ; clear Γ HΓ; intros Γ HΓ; rewrite HΓ; constructor.
  (* ⊥ *)
  now rewrite <- syntactic_eq_cons_app; constructor; rewrite <- app_nil_r; apply HΓ; simpl; reflexivity.
  (* ⊤ *)
  now rewrite <- syntactic_eq_cons_app; constructor.
  (* 0 *)
  now rewrite syntactic_eq_cons_app; apply HΓ; intros Δ HΔ; contradiction.
  (* ⊗ *)
  apply HΓ; clear Γ HΓ; intros Ξ [Γ Δ HΓ HΔ H]; rewrite H; clear Ξ H.
  now simpl; constructor; intuition.
  (* ⅋ *)
  rewrite <- syntactic_eq_cons_app; constructor.
  assert (Hrw : syntactic_eq (A1 :: A2 :: Γ) (Γ ++ A1 :: A2 :: nil)); [|rewrite Hrw; clear Hrw].
    now apply rst_step, synrel_prm, (Permutation.Permutation_app_comm (A1 :: A2 :: nil) Γ).
  apply HΓ; clear Γ HΓ; exists (A1 :: nil) (A2 :: nil); [intros Γ HΓ|intros Γ HΓ|reflexivity].
    now simpl; apply IHA1; assumption.
    now simpl; apply IHA2; assumption.
  (* & *)
  rewrite <- syntactic_eq_cons_app.
  now constructor; rewrite syntactic_eq_cons_app; apply HΓ; [left|right]; assumption.
  (* ⊕ *)
  apply HΓ; clear Γ HΓ.
  intros Γ [HΓ|HΓ]; simpl; [apply drv_pls_1|apply drv_pls_2]; intuition.
  (* ! *)
  apply HΓ; clear Γ HΓ; intros Γ [HΓ HΓ1 HΓd]; simpl.
  apply syntactic_eq_idempotent in HΓd; destruct HΓd as [Γ' Hrw]; rewrite Hrw.
  now constructor; apply IHA; rewrite <- Hrw; assumption.
  (* ? *)
  apply HΓ; clear Γ HΓ; split.
    now intros Γ HΓ; simpl; apply drv_drl; intuition.
    now intros Γ HΓ; simpl; apply drv_wkn; rewrite <- app_nil_r; apply HΓ; simpl; reflexivity.
    now simpl; apply rst_step, synrel_ctr.
Qed.

End Completeness.

End Phase_semantics.


(*
Copyright © 2007-2008 Russell O’Connor

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

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

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Export Coq.QArith.QArith.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.algebra.COrdFields.
Require Import CoRN.tactics.Qauto.
Require Import CoRN.tactics.CornTac.

Set Implicit Arguments.

Local Open Scope Q_scope.

(**
* [OpenUnit]
Open unit represents rational number in (0,1).
*)

Record OpenUnit:={OpenUnitasQ:> Q;
OpenUnitprf:0<OpenUnitasQ/\OpenUnitasQ<1}.

Delimit Scope ou_scope with ou.
Bind Scope ou_scope with OpenUnit.

(** This notation allows one to easily write closed expressions for
[OpenUnit] (e.g. [ou (1#2)]).  The typechecker verifies that the close
term is inside (0,1) by computation. *)
Notation "'ou' x":=(@Build_OpenUnit x (conj (refl_equal Lt) (refl_equal Lt))) (at level 60, no associativity) : ou_scope.

(** Basic propertirs about [a:OpenUnit] and its dual value [1-a]. *)
Lemma OpenUnit_0_lt : forall (a:OpenUnit), 0 < a.
Proof.
 intros [a [H0 H1]]; assumption.
Qed.

Lemma OpenUnit_lt_1 : forall (a:OpenUnit), a < 1.
Proof.
 intros [a [H0 H1]]; assumption.
Qed.

Lemma OpenUnit_0_lt_Dual : forall (a:OpenUnit), 0 < 1-a.
Proof.
 intros [a [H0 H1]].
 simpl.
 rewrite -> Qlt_minus_iff in H1;assumption.
Qed.

Lemma OpenUnit_Dual_lt_1 : forall (a:OpenUnit), 1-a < 1.
Proof.
 intros [a [H0 H1]].
 simpl.
 rewrite -> Qlt_minus_iff.
 replace RHS with a by simpl; ring.
 assumption.
Qed.
(* begin hide *)
#[global]
Hint Resolve OpenUnit_0_lt OpenUnit_lt_1 OpenUnit_0_lt_Dual OpenUnit_Dual_lt_1 : ouarith.
(* end hide *)
(** Multiplication *)
Definition OpenUnitMult (a b:OpenUnit):OpenUnit.
Proof.
 exists (a * b).
 abstract(destruct a as [a [Ha0 Ha1]]; destruct b as [b [Hb0 Hb1]]; split; simpl;
   [apply: mult_resp_pos; assumption |change (1:Q) with (1*1);
     apply: mult_resp_less_both;auto with *]).
Defined.

Notation "x * y":=(OpenUnitMult x y) : ou_scope.

(** Division *)
Definition OpenUnitDiv (a b:OpenUnit):(a<b)->OpenUnit.
Proof.
 intros p.
 exists (a/b).
 abstract (destruct a as [a [Ha0 Ha1]]; destruct b as [b [Hb0 Hb1]]; split; simpl;[
   apply Qlt_shift_div_l; auto; ring_simplify;  auto|
     apply Qlt_shift_div_r; auto; ring_simplify;  auto]).
Defined.

(** The dual of a is 1-a *)
Definition OpenUnitDual (a:OpenUnit):OpenUnit.
Proof.
 exists (1-a).
 abstract (destruct a as [a [Ha0 Ha1]]; simpl; split; rewrite  -> Qlt_minus_iff in *;[
   (replace RHS with (1+-a) by simpl; ring); auto| (replace RHS with (a+-0) by simpl; ring); auto]).
Defined.

(** The dual of multipliation: 1 - (1-a)*(1-b) or a + b - a*b *)
Definition OpenUnitDualMult (a b:OpenUnit):OpenUnit.
Proof.
 exists (a + b - a * b).
 abstract ( split;
   [(replace RHS with (OpenUnitDual ((OpenUnitDual a)*(OpenUnitDual b)):Q) by simpl; ring);
     auto with *
       |(replace LHS with (OpenUnitDual ((OpenUnitDual a)*(OpenUnitDual b)):Q) by simpl; ring);
         auto with *]).
Defined.

(** The dual of division: 1 - (1-b)/(1-a) or (b-a)/(1-a) *)
Definition OpenUnitDualDiv (b a:OpenUnit):(a<b)->OpenUnit.
Proof.
 intros p.
 exists ((b-a)/(1-a)).
 abstract ( assert (X:OpenUnitDual b < OpenUnitDual a); [rewrite -> Qlt_minus_iff in *; simpl;
   (replace RHS with (b + - a) by simpl; ring); assumption |split;
     [(replace RHS with (OpenUnitDual (OpenUnitDiv _ _ X):Q) by simpl; field; auto with * );
       auto with *
         |(replace LHS with (OpenUnitDual (OpenUnitDiv _ _ X):Q) by simpl; field; auto with * );
           auto with *]]).
Defined.

(**
*** Equality
*)
Definition ou_eq (x y:OpenUnit) := Qeq x y.
Lemma ou_eq_refl : forall x, ou_eq x x.
Proof.
 intros; apply Qeq_refl.
Qed.

Lemma ou_eq_sym : forall x y, ou_eq x y -> ou_eq y x.
Proof.
 intros; apply Qeq_sym; auto.
Qed.

Lemma ou_eq_trans : forall x y z, ou_eq x y -> ou_eq y z -> ou_eq x z.
Proof.
 intros; apply (Qeq_trans x y); auto.
Qed.

Add Relation OpenUnit ou_eq
 reflexivity proved by ou_eq_refl
 symmetry proved by ou_eq_sym
 transitivity proved by ou_eq_trans
 as ou_st.

(** One cheif use of OpenUnit is to make strict affine combinations. *)
Definition affineCombo (o:OpenUnit) (a b:Q) := o*a + (1-o)*b.

Add Morphism affineCombo with signature ou_eq ==> Qeq ==> Qeq ==> Qeq as affineCombo_wd.
Proof.
 intros x1 x2 Hx y1 y2 Hy z1 z2 Hz.
 unfold affineCombo.
 unfold ou_eq in Hx.
 rewrite -> Hx, Hy, Hz; reflexivity.
Qed.

(** Properties of an affine combination. *)
Lemma affineCombo_gt : forall o a b (H:a < b), a < affineCombo o a b.
Proof.
 intros o a b H.
 unfold affineCombo.
 rewrite -> Qlt_minus_iff in *.
 replace RHS with ((1-o)*(b-a)) by simpl; ring.
 apply: mult_resp_pos; simpl; auto with *.
Qed.

Lemma affineCombo_lt : forall o a b (H:a < b), affineCombo o a b < b.
Proof.
 intros o a b H.
 unfold affineCombo.
 rewrite -> Qlt_minus_iff in *.
 replace RHS with (o*(b-a)) by simpl; ring.
 apply: mult_resp_pos; simpl; auto with *.
Qed.
(* begin hide *)
#[global]
Hint Resolve affineCombo_lt affineCombo_gt : ouarith.
(* end hide *)

Lemma affineAffine_l : forall a b o1 o2,
(affineCombo o1 a (affineCombo o2 a b)==affineCombo (OpenUnitDualMult o1 o2) a b)%Q.
Proof.
 intros a b o1 o2.
 unfold affineCombo.
 simpl.
 ring.
Qed.

Lemma affineAffine_r : forall a b o1 o2,
(affineCombo o1 (affineCombo o2 a b) b==affineCombo (o1*o2) a b)%Q.
Proof.
 intros a b o1 o2.
 unfold affineCombo.
 simpl.
 ring.
Qed.


(* Make [omega] work for [N] *)

Require Import Coq.Arith.Arith Coq.omega.Omega Coq.NArith.NArith.
Require Export Bedrock.Coq__8_4__8_5__Compat.

Global Set Asymmetric Patterns.
Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
  intuition.
  apply nat_of_N_eq in H0; tauto.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
  unfold Nlt; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
  unfold Nlt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
  unfold Nge; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
  unfold Nge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import SeqProp.
Require Import PartSum.
Require Import Max.
Open Local Scope R_scope.

(**********)
(** * Formalization of alternated series *)
Definition tg_alt (Un:nat -> R) (i:nat) : R := (-1) ^ i * Un i.
Definition positivity_seq (Un:nat -> R) : Prop := forall n:nat, 0 <= Un n.

Lemma CV_ALT_step0 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_growing (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof.
  intros; unfold Un_growing in |- *; intro.
  cut ((2 * S n)%nat = S (S (2 * n))).
  intro; rewrite H0.
  do 4 rewrite tech5; repeat rewrite Rplus_assoc; apply Rplus_le_compat_l.
  pattern (tg_alt Un (S (2 * n))) at 1 in |- *; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
    rewrite Rmult_1_l.
  apply Rplus_le_reg_l with (Un (S (2 * S n))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * S n)) + (Un (2 * S n)%nat + -1 * Un (S (2 * S n)))) with
      (Un (2 * S n)%nat); [ idtac | ring ].
  apply H.
  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

Lemma CV_ALT_step1 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_decreasing (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)).
Proof.
  intros; unfold Un_decreasing in |- *; intro.
  cut ((2 * S n)%nat = S (S (2 * n))).
  intro; rewrite H0; do 2 rewrite tech5; repeat rewrite Rplus_assoc.
  pattern (sum_f_R0 (tg_alt Un) (2 * n)) at 2 in |- *; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt in |- *; rewrite <- H0; rewrite pow_1_odd; rewrite pow_1_even;
    rewrite Rmult_1_l.
  apply Rplus_le_reg_l with (Un (S (2 * n))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * n)) + (-1 * Un (S (2 * n)) + Un (2 * S n)%nat)) with
      (Un (2 * S n)%nat); [ idtac | ring ].
  rewrite H0; apply H.
  cut (forall n:nat, S n = (n + 1)%nat); [ intro | intro; ring ].
  rewrite (H0 n); rewrite (H0 (S (2 * n))); rewrite (H0 (2 * n)%nat); ring.
Qed.

(**********)
Lemma CV_ALT_step2 :
  forall (Un:nat -> R) (N:nat),
    Un_decreasing Un ->
    positivity_seq Un ->
    sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
  replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ].
  apply Rplus_le_reg_l with (Un 1%nat); rewrite Rplus_0_r.
  replace (Un 1%nat + (-1 * Un 1%nat + Un 2%nat)) with (Un 2%nat);
    [ apply H | ring ].
  cut (S (2 * S N) = S (S (S (2 * N)))).
  intro; rewrite H1; do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))).
  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N))) at 2 in |- *;
    rewrite <- Rplus_0_r.
  rewrite Rplus_assoc; apply Rplus_le_compat_l.
  unfold tg_alt in |- *; rewrite <- H1.
  rewrite pow_1_odd.
  cut (S (S (2 * S N)) = (2 * S (S N))%nat).
  intro; rewrite H2; rewrite pow_1_even; rewrite Rmult_1_l; rewrite <- H2.
  apply Rplus_le_reg_l with (Un (S (2 * S N))).
  rewrite Rplus_0_r;
    replace (Un (S (2 * S N)) + (-1 * Un (S (2 * S N)) + Un (S (S (2 * S N)))))
      with (Un (S (S (2 * S N)))); [ idtac | ring ].
  apply H.
  ring.
  apply HrecN.
  ring.
Qed.

(** A more general inequality *)
Lemma CV_ALT_step3 :
  forall (Un:nat -> R) (N:nat),
    Un_decreasing Un ->
    positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r.
  apply Rplus_le_reg_l with (Un 1%nat).
  rewrite Rplus_0_r; replace (Un 1%nat + -1 * Un 1%nat) with 0;
    [ apply H0 | ring ].
  assert (H1 := even_odd_cor N).
  elim H1; intros.
  elim H2; intro.
  rewrite H3; apply CV_ALT_step2; assumption.
  rewrite H3; rewrite tech5.
  apply Rle_trans with (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))).
  pattern (sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * x))) at 2 in |- *;
    rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  unfold tg_alt in |- *; simpl in |- *.
  replace (x + (x + 0))%nat with (2 * x)%nat; [ idtac | ring ].
  rewrite pow_1_even.
  replace (-1 * (-1 * (-1 * 1)) * Un (S (S (S (2 * x))))) with
    (- Un (S (S (S (2 * x))))); [ idtac | ring ].
  apply Rplus_le_reg_l with (Un (S (S (S (2 * x))))).
  rewrite Rplus_0_r; rewrite Rplus_opp_r.
  apply H0.
  apply CV_ALT_step2; assumption.
Qed.

  (**********)
Lemma CV_ALT_step4 :
  forall Un:nat -> R,
    Un_decreasing Un ->
    positivity_seq Un ->
    has_ub (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))).
Proof.
  intros; unfold has_ub in |- *; unfold bound in |- *.
  exists (Un 0%nat).
  unfold is_upper_bound in |- *; intros; elim H1; intros.
  rewrite H2; rewrite decomp_sum.
  replace (tg_alt Un 0) with (Un 0%nat).
  pattern (Un 0%nat) at 2 in |- *; rewrite <- Rplus_0_r.
  apply Rplus_le_compat_l.
  apply CV_ALT_step3; assumption.
  unfold tg_alt in |- *; simpl in |- *; ring.
  apply lt_O_Sn.
Qed.

(** This lemma gives an interesting result about alternated series *)
Lemma CV_ALT :
  forall Un:nat -> R,
    Un_decreasing Un ->
    positivity_seq Un ->
    Un_cv Un 0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof.
  intros.
  assert (H2 := CV_ALT_step0 _ H).
  assert (H3 := CV_ALT_step4 _ H H0).
  assert (X := growing_cv _ H2 H3).
  elim X; intros.
  exists x.
  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
    unfold R_dist in H1; unfold Un_cv in p; unfold R_dist in p.
  intros; cut (0 < eps / 2);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
	[ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H1 (eps / 2) H5); intros N2 H6.
  elim (p (eps / 2) H5); intros N1 H7.
  set (N := max (S (2 * N1)) N2).
  exists N; intros.
  assert (H9 := even_odd_cor n).
  elim H9; intros P H10.
  cut (N1 <= P)%nat.
  intro; elim H10; intro.
  replace (sum_f_R0 (tg_alt Un) n - x) with
    (sum_f_R0 (tg_alt Un) (S n) - x + - tg_alt Un (S n)).
  apply Rle_lt_trans with
    (Rabs (sum_f_R0 (tg_alt Un) (S n) - x) + Rabs (- tg_alt Un (S n))).
  apply Rabs_triang.
  rewrite (double_var eps); apply Rplus_lt_compat.
  rewrite H12; apply H7; assumption.
  rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult;
    rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6;
      rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n)));
	apply H6.
  unfold ge in |- *; apply le_trans with n.
  apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ].
  apply le_n_Sn.
  rewrite tech5; ring.
  rewrite H12; apply Rlt_trans with (eps / 2).
  apply H7; assumption.
  unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym;
    [ rewrite Rmult_1_r | discrR ].
  rewrite double.
  pattern eps at 1 in |- *; rewrite <- (Rplus_0_r eps); apply Rplus_lt_compat_l;
    assumption.
  elim H10; intro; apply le_double.
  rewrite <- H11; apply le_trans with N.
  unfold N in |- *; apply le_trans with (S (2 * N1));
    [ apply le_n_Sn | apply le_max_l ].
  assumption.
  apply lt_n_Sm_le.
  rewrite <- H11.
  apply lt_le_trans with N.
  unfold N in |- *; apply lt_le_trans with (S (2 * N1)).
  apply lt_n_Sn.
  apply le_max_l.
  assumption.
Qed.

(*************************************************)
(** *       Convergence of alternated series     *)
Theorem alternated_series :
  forall Un:nat -> R,
    Un_decreasing Un ->
    Un_cv Un 0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l }.
Proof.
  intros; apply CV_ALT.
  assumption.
  unfold positivity_seq in |- *; apply decreasing_ineq; assumption.
  assumption.
Qed.

Theorem alternated_series_ineq :
  forall (Un:nat -> R) (l:R) (N:nat),
    Un_decreasing Un ->
    Un_cv Un 0 ->
    Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) N) l ->
    sum_f_R0 (tg_alt Un) (S (2 * N)) <= l <= sum_f_R0 (tg_alt Un) (2 * N).
Proof.
  intros.
  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N)) l).
  cut (Un_cv (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N))) l).
  intros; split.
  apply (growing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (S (2 * N)))).
  apply CV_ALT_step0; assumption.
  assumption.
  apply (decreasing_ineq (fun N:nat => sum_f_R0 (tg_alt Un) (2 * N))).
  apply CV_ALT_step1; assumption.
  assumption.
  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
    unfold R_dist in H1; intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  apply H3.
  unfold ge in |- *; apply le_trans with (2 * n)%nat.
  apply le_trans with n.
  assumption.
  assert (H5 := mult_O_le n 2).
  elim H5; intro.
  cut (0%nat <> 2%nat);
    [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
  assumption.
  apply le_n_Sn.
  unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1;
    unfold R_dist in H1; intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  apply H3.
  unfold ge in |- *; apply le_trans with n.
  assumption.
  assert (H5 := mult_O_le n 2).
  elim H5; intro.
  cut (0%nat <> 2%nat);
    [ intro; elim H7; symmetry  in |- *; assumption | discriminate ].
  assumption.
Qed.

(***************************************)
(** * Application : construction of PI *)
(***************************************)

Definition PI_tg (n:nat) := / INR (2 * n + 1).

Lemma PI_tg_pos : forall n:nat, 0 <= PI_tg n.
Proof.
  intro; unfold PI_tg in |- *; left; apply Rinv_0_lt_compat; apply lt_INR_0;
    replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
Qed.

Lemma PI_tg_decreasing : Un_decreasing PI_tg.
Proof.
  unfold PI_tg, Un_decreasing in |- *; intro.
  apply Rmult_le_reg_l with (INR (2 * n + 1)).
  apply lt_INR_0.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (2 * S n + 1)).
  apply lt_INR_0.
  replace (2 * S n + 1)%nat with (S (2 * S n)); [ apply lt_O_Sn | ring ].
  rewrite (Rmult_comm (INR (2 * S n + 1))); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply le_INR.
  replace (2 * S n + 1)%nat with (S (S (2 * n + 1))).
  apply le_trans with (S (2 * n + 1)); apply le_n_Sn.
  ring.
  apply not_O_INR; discriminate.
  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
    [ discriminate | ring ].
Qed.

Lemma PI_tg_cv : Un_cv PI_tg 0.
Proof.
  unfold Un_cv in |- *; unfold R_dist in |- *; intros.
  cut (0 < 2 * eps);
    [ intro | apply Rmult_lt_0_compat; [ prove_sup0 | assumption ] ].
  assert (H1 := archimed (/ (2 * eps))).
  cut (0 <= up (/ (2 * eps)))%Z.
  intro; assert (H3 := IZN (up (/ (2 * eps))) H2).
  elim H3; intros N H4.
  cut (0 < N)%nat.
  intro; exists N; intros.
  cut (0 < n)%nat.
  intro; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
    rewrite Rabs_right.
  unfold PI_tg in |- *; apply Rlt_trans with (/ INR (2 * n)).
  apply Rmult_lt_reg_l with (INR (2 * n)).
  apply lt_INR_0.
  replace (2 * n)%nat with (n + n)%nat; [ idtac | ring ].
  apply lt_le_trans with n.
  assumption.
  apply le_plus_l.
  rewrite <- Rinv_r_sym.
  apply Rmult_lt_reg_l with (INR (2 * n + 1)).
  apply lt_INR_0.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_O_Sn | ring ].
  rewrite (Rmult_comm (INR (2 * n + 1))).
  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply lt_INR.
  replace (2 * n + 1)%nat with (S (2 * n)); [ apply lt_n_Sn | ring ].
  apply not_O_INR; replace (2 * n + 1)%nat with (S (2 * n));
    [ discriminate | ring ].
  replace n with (S (pred n)).
  apply not_O_INR; discriminate.
  symmetry  in |- *; apply S_pred with 0%nat.
  assumption.
  apply Rle_lt_trans with (/ INR (2 * N)).
  apply Rmult_le_reg_l with (INR (2 * N)).
  rewrite mult_INR; apply Rmult_lt_0_compat;
    [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (INR (2 * n)).
  rewrite mult_INR; apply Rmult_lt_0_compat;
    [ simpl in |- *; prove_sup0 | apply lt_INR_0; assumption ].
  rewrite (Rmult_comm (INR (2 * n))); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  do 2 rewrite Rmult_1_r; apply le_INR.
  apply (fun m n p:nat => mult_le_compat_l p n m); assumption.
  replace n with (S (pred n)).
  apply not_O_INR; discriminate.
  symmetry  in |- *; apply S_pred with 0%nat.
  assumption.
  replace N with (S (pred N)).
  apply not_O_INR; discriminate.
  symmetry  in |- *; apply S_pred with 0%nat.
  assumption.
  rewrite mult_INR.
  rewrite Rinv_mult_distr.
  replace (INR 2) with 2; [ idtac | reflexivity ].
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ idtac | discrR ].
  rewrite Rmult_1_l; apply Rmult_lt_reg_l with (INR N).
  apply lt_INR_0; assumption.
  rewrite <- Rinv_r_sym.
  apply Rmult_lt_reg_l with (/ (2 * eps)).
  apply Rinv_0_lt_compat; assumption.
  rewrite Rmult_1_r;
    replace (/ (2 * eps) * (INR N * (2 * eps))) with
      (INR N * (2 * eps * / (2 * eps))); [ idtac | ring ].
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; replace (INR N) with (IZR (Z_of_nat N)).
  rewrite <- H4.
  elim H1; intros; assumption.
  symmetry  in |- *; apply INR_IZR_INZ.
  apply prod_neq_R0;
    [ discrR | red in |- *; intro; rewrite H8 in H; elim (Rlt_irrefl _ H) ].
  apply not_O_INR.
  red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
  replace (INR 2) with 2; [ discrR | reflexivity ].
  apply not_O_INR.
  red in |- *; intro; rewrite H8 in H5; elim (lt_irrefl _ H5).
  apply Rle_ge; apply PI_tg_pos.
  apply lt_le_trans with N; assumption.
  elim H1; intros H5 _.
  assert (H6 := lt_eq_lt_dec 0 N).
  elim H6; intro.
  elim a; intro.
  assumption.
  rewrite <- b in H4.
  rewrite H4 in H5.
  simpl in H5.
  cut (0 < / (2 * eps)); [ intro | apply Rinv_0_lt_compat; assumption ].
  elim (Rlt_irrefl _ (Rlt_trans _ _ _ H7 H5)).
  elim (lt_n_O _ b).
  apply le_IZR.
  simpl in |- *.
  left; apply Rlt_trans with (/ (2 * eps)).
  apply Rinv_0_lt_compat; assumption.
  elim H1; intros; assumption.
Qed.

Lemma exist_PI :
  { l:R | Un_cv (fun N:nat => sum_f_R0 (tg_alt PI_tg) N) l }.
Proof.
  apply alternated_series.
  apply PI_tg_decreasing.
  apply PI_tg_cv.
Qed.

(** Now, PI is defined *)
Definition PI : R := 4 * (let (a,_) := exist_PI in a).

(** We can get an approximation of PI with the following inequality *)
Lemma PI_ineq :
  forall N:nat,
    sum_f_R0 (tg_alt PI_tg) (S (2 * N)) <= PI / 4 <=
    sum_f_R0 (tg_alt PI_tg) (2 * N).
Proof.
  intro; apply alternated_series_ineq.
  apply PI_tg_decreasing.
  apply PI_tg_cv.
  unfold PI in |- *; case exist_PI; intro.
  replace (4 * x / 4) with x.
  trivial.
  unfold Rdiv in |- *; rewrite (Rmult_comm 4); rewrite Rmult_assoc;
    rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r; reflexivity | discrR ].
Qed.

Lemma PI_RGT_0 : 0 < PI.
Proof.
  assert (H := PI_ineq 0).
  apply Rmult_lt_reg_l with (/ 4).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite Rmult_0_r; rewrite Rmult_comm.
  elim H; clear H; intros H _.
  unfold Rdiv in H;
    apply Rlt_le_trans with (sum_f_R0 (tg_alt PI_tg) (S (2 * 0))).
  simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_l;
    rewrite Rmult_1_r; apply Rplus_lt_reg_r with (PI_tg 1).
  rewrite Rplus_0_r;
    replace (PI_tg 1 + (PI_tg 0 + -1 * PI_tg 1)) with (PI_tg 0);
      [ unfold PI_tg in |- * | ring ].
  simpl in |- *; apply Rinv_lt_contravar.
  rewrite Rmult_1_l; replace (2 + 1) with 3; [ prove_sup0 | ring ].
  rewrite Rplus_comm; pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_lt_compat_l; prove_sup0.
  assumption.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
From Coq Require Import Lists.List.

Require Import Utils.

Module TotalMap.
  Definition t (A B : Type) `{EqDec A eq} := A -> B.

  Section ops.
    Context {A B : Type}.
    Context `{EqDec A eq}.

    Definition empty (v : B) : t A B :=
      fun _ => v.

    Definition update (m : t A B) (x : A) (v : B) :=
      fun x' => if x ==b x' then v else m x'.
  End ops.

  Module Notations.
    Notation "'_' '!->' v" := (TotalMap.empty v)
      (at level 100, right associativity).

    Notation "x '!->' v ';' m" := (TotalMap.update m x v)
      (at level 100, v at next level, right associativity).
  End Notations.

  Import Notations.

  Section lemmas.
    Context (A B : Type).
    Context `{EqDec A eq}.
    Implicit Types m : t A B.

    Lemma apply_empty (x : A) (v : B) :
        (_ !-> v) x = v.
    Proof using. unfold empty. reflexivity. Qed.

    Lemma update_eq m x v :
        (x !-> v ; m) x = v.
    Proof using.
      unfold update.
      now rewrite equiv_decb_true.
    Qed.

    Theorem update_neq m x1 x2 v
      (Hneq : x1 <> x2) :
        (x1 !-> v ; m) x2 = m x2.
    Proof using.
      unfold update.
      now rewrite equiv_decb_false.
    Qed.

    Lemma update_shadow m x v1 v2 :
        (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
    Proof using.
      extensionality x'. unfold update.
      now destruct (x ==b x').
    Qed.

    Theorem update_same m x :
      (x !-> m x ; m) = m.
    Proof using.
      extensionality x'. unfold update.
      destruct (equiv_decbP x x') as [Heq | Hneq].
      { now rewrite Heq. }
      reflexivity.
    Qed.

    Theorem update_permute m v1 v2 x1 x2
      (Hneq : x2 <> x1) :
        (x1 !-> v1 ; x2 !-> v2 ; m) = (x2 !-> v2 ; x1 !-> v1 ; m).
    Proof using.
      extensionality x'. unfold update.
      destruct (equiv_decbP x1 x'), (equiv_decbP x2 x').
      all: try reflexivity.
      congruence.
    Qed.
  End lemmas.
End TotalMap.

Module PartialMap.
  Definition t (A B : Type) `{EqDec A eq} := TotalMap.t A (option B).

  Import TotalMap.Notations.

  Section ops.
    Context {A B : Type}.
    Context `{EqDec A eq}.

    Definition empty : t A B :=
      (_ !-> None).

    Definition update (m : t A B) (x : A) (v : B) :=
      (x !-> Some v ; m).
  End ops.

  Module Notations.
    Notation "x '|->' v ';' m" := (update m x v)
      (at level 100, v at next level, right associativity).

    Notation "x '|->' v" := (update empty x v)
      (at level 100).
  End Notations.

  Import Notations.

  Section lemmas.
    Context (A B : Type).
    Context `{EqDec A eq}.
    Implicit Types m : t A B.

    Lemma apply_empty (x : A) :
        (empty : t A B) x = None.
    Proof using.
      unfold empty.
      now rewrite TotalMap.apply_empty.
    Qed.

    Lemma update_eq m x v :
        (x |-> v ; m) x = Some v.
    Proof using.
      unfold update.
      now rewrite TotalMap.update_eq.
    Qed.

    Theorem update_neq m x1 x2 v
      (Hneq : x2 <> x1) :
        (x2 |-> v ; m) x1 = m x1.
    Proof using.
      unfold update.
      now rewrite TotalMap.update_neq.
    Qed.

    Lemma update_shadow m x v1 v2 :
      (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
    Proof using.
      unfold update.
      now rewrite TotalMap.update_shadow.
    Qed.

    Theorem update_same m x v
      (Heq : m x = Some v) :
        (x |-> v ; m) = m.
    Proof using.
      unfold update. rewrite <- Heq.
      apply TotalMap.update_same.
    Qed.

    Theorem update_permute m x1 x2 v1 v2
      (Hneq : x2 <> x1) :
        (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
    Proof using.
      unfold update.
      now apply TotalMap.update_permute.
    Qed.

    Lemma add_none m x v
      (Hnone : m x = None) :
        m = (x !-> None; x !-> Some v; m).
    Proof using.
      extensionality x'.
      unfold TotalMap.update.
      destruct (equiv_decbP x x') as [Heq | Hneq].
      { now rewrite <- Heq. }
      reflexivity.
    Qed.
  End lemmas.

  Section join.
    Context {A B : Type}.
    Context `{EqDec A eq}.

    Definition in_dom (x : A) (m : t A B) :=
      exists v, m x = Some v.

    Definition disjoint (m1 m2 : t A B) : Prop :=
      forall k, m1 k = None \/ m2 k = None.

    Definition join (m1 m2 : t A B) : t A B :=
      fun k =>
        match m1 k with
        | Some val => Some val
        | None     => m2 k
        end.
  End join.

  Section join_lemmas.
    Context (A B : Type).
    Context `{EqDec A eq}.

    Lemma not_in_dom_iff (m : t A B) (x : A) :
      ~ in_dom x m <-> m x = None.
    Proof using.
      unfold in_dom.
      destruct (m x).
      all: split; ins.
      { exfalso; eauto. }
      intro; desf.
    Qed.

    Lemma disjoint_iff (m1 m2 : t A B) :
      disjoint m1 m2 <-> (forall k, ~ in_dom k m1 \/ ~ in_dom k m2).
    Proof using.
      unfold disjoint.
      setoid_rewrite not_in_dom_iff.
      reflexivity.
    Qed.

    Lemma join_comm (m1 m2 : t A B) (Hdisj : disjoint m1 m2) :
      (join m1 m2) = (join m2 m1).
    Proof using.
      extensionality k.
      unfold join.
      destruct Hdisj with k; desf.
    Qed.

    Lemma join_assoc (m1 m2 m3 : t A B) :
      join m1 (join m2 m3) = join (join m1 m2) m3.
    Proof using.
      extensionality k.
      unfold join.
      desf.
    Qed.

    Lemma join_empty_r (m : t A B) :
      join m empty = m.
    Proof using.
      extensionality k.
      unfold join, empty, TotalMap.empty.
      desf.
    Qed.

    Lemma join_empty_l (m : t A B) :
      join empty m = m.
    Proof using.
      extensionality k.
      unfold join, empty, TotalMap.empty.
      desf.
    Qed.

    Lemma empty_disjoint_l (m : t A B) :
      disjoint empty m.
    Proof using.
      unfold join, empty, TotalMap.empty.
      intros k. now left.
    Qed.

    Lemma empty_disjoint_r (m : t A B) :
      disjoint m empty.
    Proof using.
      unfold disjoint, empty, TotalMap.empty.
      intros k. now right.
    Qed.

    Lemma disjoint_symm (m1 m2 : t A B)
      (Hdisj : disjoint m1 m2) :
        disjoint m2 m1.
    Proof using.
      unfold disjoint in *.
      intros k.
      destruct Hdisj with k; auto.
    Qed.

    Lemma disjoint_symm_iff (m1 m2 : t A B) :
      disjoint m1 m2 <-> disjoint m2 m1.
    Proof using.
      split; apply disjoint_symm.
    Qed.
  End join_lemmas.
End PartialMap.


Set Implicit Arguments.

Require Import
        Discrete.DiscreteType
        Finite.FinType
        Tactics.Tactics.

Import ListNotations.

(** xs is a vector (list) indexed by A's elements *)

Definition Card_X_eq A B (xs : list B) := |xs| = Cardinality A.

Definition vector (A : finType) (B : Type) := subtype (@Card_X_eq A B).
Notation "A --> B" := (vector A B) (at level 55, right associativity).

(** image of a vector *)

Definition image (A : finType) (B : Type) (f : A --> B) := proj1_sig  f.

Instance vector_eq_dec (X: finType) (Y: discType) : eq_dec (X --> Y).
Proof.
  crush.
Qed.

Canonical Structure DiscVect (A : finType)(B: discType) := DiscType (A --> B).

Fixpoint images (B : Type) (xs : list B) (n: nat): list (list B) :=
  match n with
  | 0 => [[]]
  | S n' => concat (map (fun x => map (cons x) (images xs n')) xs)
  end.

Lemma images_not_nil (A : Type) x (xs : list A) : forall n, images (x :: xs) n <> nil.
Proof.
  intro n. induction n as [| n'].
  -
    crush.
  -
    cbn. intro H. pose proof (app_eq_nil _ _ H) as [E1 E2]. clear H.
    pose proof (map_eq_nil _ _ E1).  auto.
Qed.

Lemma not_In_map_cons (A : discType) (y x : A) (xs : list A) (ys : list (list A))
  : y <> x -> (x :: xs) el (map (cons y) ys) -> False.
Proof.
  intros neq E. rewrite In_map_iff in E. destruct E as [C [E _]]. congruence.
Qed.

Definition mC A xs := (fun x : A => map (cons x) xs).
Definition mmC A xs (ys : list A) := map (mC xs) ys.

Lemma disjoint_map_cons (A : discType) (xs : list (list A)) (x y : A )
  : x <> y -> disjoint (map (cons x) xs) (map (cons y) xs).
Proof.
  intro N ; induction xs as [| x' xs].
  -
    cbn. auto.
  -
    cbn. unfold disjoint. intros [B [H1 H2]]. destruct H1, H2 ; try solve [crush].
    +
      subst B.
      eapply not_In_map_cons with (A := A)(y := y)(x := x)(xs := x')(ys := xs) ; auto.
    +
      subst B.
      eapply not_In_map_cons ; eauto.
    +
      apply IHxs. now exists B.
Qed.

Lemma disjoint_in
      (A : discType) x xs
      (ys : list (list A))
      (E : ys <> nil) zs
      (H: ~ x el xs)
  : zs el map (mC ys) xs -> disjoint (map (cons x) ys) zs.
Proof.
  destruct ys ; try congruence.
  intro H'. induction xs as [| x' xs].
  -
    contradiction H'.
  -
    pose proof (neg_or H) as [G G']. destruct H' as [H' | H'].
    +
      subst zs. apply disjoint_map_cons; congruence.
    +
      apply IHxs ; auto.
Qed.

Lemma disjoint_in_map_map_cons
      (A : discType) (xs : list A)
      (ys zs zs' : list (list A))
      (H : zs <> zs')
      (E : zs el (mmC ys xs))
      (E': zs' el (mmC ys xs))
      (N : ys <> nil)
      (D : dup_free xs):
  disjoint zs zs'.
Proof.
  induction D.
  -
    contradiction E.
  -
    destruct ys ; try congruence ; clear N.
    destruct E, E'; try congruence.
    +
      subst zs.
      eapply disjoint_in ; now eauto.
    +
      subst zs'.
      apply disjoint_symm.
      eapply disjoint_in ; now eauto.
    +
      now apply IHD.
Qed.

Lemma dup_free_concat_map_cons (A : discType) (xs : list A) (ys : list (list A))
  : dup_free xs ->
    dup_free ys ->
    ys <> nil ->
    dup_free (concat (map (fun x => map (cons x) ys) xs)).
Proof.
  intros D D' N.
  apply dup_free_concat ; try split.
  -
    intros C E. induction D.
    +
      contradiction E.
    +
      destruct E ; auto. subst C.
      apply dup_free_map ; auto.
      congruence.
  -
    intros B' B'' E E' H.
    eapply disjoint_in_map_map_cons; eauto.
  -
    apply dup_free_map ; auto.
    intros x y _ _ E.
    destruct ys.
    +
      congruence.
    +
      cbn in E. now inverts E.
Qed.

Lemma images_dup_free
      (A : discType)
      (xs : list A)
      (n : nat)
  : dup_free xs -> dup_free (images xs n).
Proof.
  induction n as [| n].
  -
    now repeat constructor.
  -
    cbn.
    intro D.
    destruct xs.
    +
      constructor.
    +
      apply dup_free_concat_map_cons ; auto.
      apply images_not_nil.
Qed.

Lemma in_concat_cons (A : discType)(xs zs : list A) (ys : list (list A)) y
  : y el xs /\ zs el ys -> (y :: zs) el (concat (map (fun x => map (cons x) ys) xs)).
Proof.
  intros [E E']. induction xs as [| x xs].
  -
    contradiction E.
  -
    cbn. destruct E as [E | E].
    +
      subst x.
      apply In_app_iff.
      left.
      apply In_map_iff.
      now exists zs.
    +
      apply In_app_iff. crush.
Qed.

Lemma in_images (A : discType) (xs ys : list A)
  : (forall x, x el ys -> x el xs) -> ys el images xs (|ys|).
Proof.
 intros E. induction ys as [| y ys].
 -
   cbn.
   now left.
 -
   cbn. apply in_concat_cons. crush.
Qed.

Lemma dup_free_elem (A : finType) : dup_free (elem A).
Proof.
  destruct A as [X [A AI]]. assert (forall x, count A x <= 1) as H'.
  {
    intro x. specialize (AI x). omega.
  }
  now apply count_lt_dup_free.
Qed.

Lemma vector_enum_sound (A : finType) (B : finType) f
  : |f| = Cardinality A -> count (images (elem B) (Cardinality A)) f = 1.
Proof.
  intros H.
  apply dup_free_count.
  -
    apply images_dup_free. apply dup_free_elem.
  -
    rewrite <- H.
    now apply in_images.
Qed.

Lemma images_inner_length (A : discType) (n: nat) :
  forall (xs : list A) ys, ys el (images xs n) -> | ys | = n.
Proof.
  induction n ; intros xs ys ; cbn.
  -
    intros H.
    destruct H ; try tauto.
    now subst ys.
  -
    pattern xs at 1. generalize xs at 2. induction xs as [| x xs] ; cbn.
    +  tauto.
    + intros C E.
      rewrite In_app_iff in E.
      destruct E as [H|H].
      *
        rewrite In_map_iff in H.
        destruct H as [D [H G]]. simpl in *.
        specialize (IHn C D G). subst ys. cbn. omega.
      *
        now apply (IHxs C).
Qed.

Definition extensional_power
           (A B : finType)
           (xs : list (list B))
           (P : xs <<= images (elem B) (Cardinality A))
  : list (A --> B).
Proof.
  revert xs P.
  refine (fix extPow xs P :=  _). destruct xs.
  -  exact nil.
  - apply cons.
    + exists l. specialize (P l (or_introl eq_refl)). unfold pure. dec; auto.
      contradiction ( n (images_inner_length P)).
    +
      eapply extPow. intros ys E. apply P. exact (or_intror E).
Defined.

Lemma vector_extensionality
      (A : finType)
      (B : Type)
      (F G : A --> B) : (image F = image G) -> F = G.
Proof.
  apply subtype_extensionality.
Qed.

Lemma count_vector_extensionality A B xs P f
  : count (@extensional_power A B xs P) f = count xs (image f).
Proof.
  induction xs as [| x xs].
  -
    reflexivity.
  -
    simpl.
    dec ; rename x into X ; decide (image f = X).
    +
      now rewrite IHxs.
    +
      contradict n.
      now subst f.
    +
      contradict n.
      now apply vector_extensionality.
    +
      apply IHxs.
Qed.

Instance finTypeC_vector (A B : finType) :
  FinTypeC (DiscVect A B).
Proof.
  apply (@Fin_TypeC _ (@extensional_power _ _
                                          (images (elem B) (Cardinality A))
                                          (fun x => fun y => y))).
  intro f.
  rewrite count_vector_extensionality.
  apply vector_enum_sound.
  destruct f as [xs p]. cbn. now impurify p.
Defined.

Canonical Structure FinType_vector (A B : finType) := FinType (DiscVect A B).

Notation "B ^ A" := (FinType_vector A B).

Fixpoint  get_position
          {A : discType}
          (xs : list A) x
  := match xs with
     | [] => 0
     | x' :: xs' => if decision (x = x') then 0
                   else 1 + get_position xs' x
     end.

Definition index {A : finType} (x : A) :=
  get_position (elem A) x.

Notation "# x" := (index x) (at level 65).

Fixpoint get_at (A : Type) (xs : list A)(n: nat) (v : A) : A :=
 match n with
 | 0 =>  match xs with
       | [] => v
       | y :: _ => y
       end
 | (S n') => match xs with
              | []  => v
              | _ :: xs' => get_at xs' n' v
              end
 end.

(** application of finite functions *)

Definition apply_vect (A : finType) (B : Type) (f : A --> B) : A -> B.
Proof.
  refine (fun x : A => _).
  destruct (elem A) eqn: E.
  -
    exfalso.
    pose proof (element_In x).
    now rewrite E in H.
  -
    destruct f as [image p].
    destruct image.
    +
      exfalso.
      unfold Card_X_eq, Cardinality in p.
      rewrite E in p.
      unfolds in p. simpl in *. crush.
    +
      exact (get_at (b :: image0) (# x) b).
Defined.

Coercion apply_vect: vector >-> Funclass.

Definition get_image {A : finType} {B : Type} (f : A -> B) :=
  map f (elem A).

Lemma get_image_in (A B : finType)(f : A -> B)(x : A)
  : (f x) el (get_image f).
Proof.
  unfold get_image. now apply In_map.
Qed.

Lemma get_image_length (A B: finType)(f : A -> B)
  :  |get_image f| = Cardinality A.
Proof.
  apply map_length.
Qed.

Definition vectorise {A B : finType}(f : A -> B) : A --> B :=
  exist (pure (@Card_X_eq A B)) (get_image f) (purify (get_image_length f)).

Lemma get_image_correct (A B : finType)(f : A -> B)
  : get_image f = image (vectorise f).
Proof.
  reflexivity.
Qed.

Lemma help_apply (A B : discType)(xs : list A) (f: A -> B) x y (C: count xs x > 0)
  : get_at (map f xs) (get_position xs x) y = f x.
Proof.
  induction xs as [| x' xs] ; repeat (crush ; dec).
Qed.

Lemma apply_vectorise_inverse (A B : finType)(f : A -> B) (x : A)
  : (vectorise f) x = f x.
Proof.
 destruct A as [X [A ok]]. destruct A.
 -
   discriminate (ok x).
 -
   cbn  in  *. specialize (ok x). dec.
   +
     congruence.
   +
     apply help_apply.
     omega.
Qed.

Lemma count_number_app
      (A : discType)
      (x : A)
      (xs ys : list A)
      (ok : count (xs ++ x :: ys) x = 1)
  : get_position (xs ++ x :: ys) x = | xs |.
Proof.
  induction xs as [| x' xs].
  -
    cbn.
    now deq x.
  -
    cbn in *.
    dec.
    +
      inverts* ok.
      rewrite count_app in *.
      simpl in *. dec ; crush.
    +
      auto.
Qed.

Lemma get_at_correct (A : discType) (xs ys : list A) y y':
get_at (ys ++ y :: xs) (|ys|) y' = y.
Proof.
  induction ys ; cbn.
  -
    reflexivity.
  -
    cbn in *.
    apply IHys.
Qed.

Lemma right_result
      (A B : finType)
      (x : A)
      (xs xs' : list A)
      (y : B)
      (ys ys' : list B)
      (H : pure (@Card_X_eq A B) (ys' ++ y :: ys))
      (H' : | xs' | = | ys'|)
      (G : elem A = xs' ++ x :: xs)
  : ((exist _ _ H) : A --> B) x = y.
Proof.
  destruct A as [X [C ok]].
  unfold apply_vect.
  cbn in *. subst C.
  destruct xs' ; destruct ys' ; cbn in * ; impurify H ; unfold Card_X_eq in H ;
    cbn in H.
  -
    now deq x.
  -
    rewrite app_length in H.
    inverts H.
    omega.
  -
    rewrite app_length in H.
    cbn in H.
    omega.
  -
    specialize (ok x).
    dec.
    +
      subst d.
      inverts ok.
      rewrite count_app in H1.
      repeat (crush ; dec).
    +
      rewrite count_number_app ; auto.
      inverts H'.
      rewrite H1.
      eapply get_at_correct.
Qed.

Lemma vectorise_apply_inverse'
      (A B : finType)
      (xs xs' : list A)
      (ys ys' ys'' : list B)
      (H : pure (@Card_X_eq A B) ys'')
      (H' : |ys'| = | xs' |)
      (H'' : |ys| = | xs |)
      (E : ys' ++ ys = ys'') (G : elem A = xs' ++ xs)
  : map ((exist _ _ H) : A --> B) xs = ys.
Proof.
    revert ys ys' xs' H' H'' E G. induction xs ; intros A1 A' B' H' H'' E G.
    -
      cbn.
      symmetry.
      now rewrite <- length_zero_iff_nil.
    -
      cbn.
      destruct A1 ; try (discriminate H''). f_equal.
      +
        subst ys''. simpl in *.
        apply right_result with (xs := xs)(xs' := B')(ys := A1).
        *
          symmetry in H' ; eexact H'.
        *
          exact G.
      +
        apply (IHxs A1 (A' ++ [d]) (B' ++ [a])).
        *
          repeat rewrite app_length.
          cbn.
          omega.
        *
          now inverts H''.
        *
          now rewrite app_assoc_reverse.
        *
          rewrite G.
          replace (a :: xs) with ([a] ++ xs) by auto.
          now rewrite app_assoc.
Qed.

Lemma vectorise_apply_inverse
      (A B : finType)
      (f : A --> B)
  : vectorise f = f.
Proof.
  apply vector_extensionality. cbn. destruct f as [X p].
  eapply vectorise_apply_inverse'; eauto using app_nil_l ;
  now impurify p.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq path.
From mathcomp Require Import finmap choice eqtype order zify.
From eventstruct Require Import utils order wftype ident.

Open Scope ident_scope.

Lemma ecnode_prop_eq {E : identType} (x y : E) :
  x = y <-> encode x = encode y.
Proof. by split=> [-> //|/encode_inj->]. Qed.

Ltac encode_indets :=
  multimatch goal with
  | E : identType |- context [@eq_op ?E ?x ?y ] =>
    lazymatch type of x with
    | nat => fail
    | _ => rewrite -[x == y](inj_eq encode_inj)
    end
  | E : identType |- (@eq ?E ?x _) =>
    lazymatch type of x with
    | nat => fail
    | _ => try apply/encode_inj
    end
  | E : identType |- context [@eq ?E ?x ?y] =>
    lazymatch type of x with
    | nat => fail
    | _ => rewrite [x = y]ecnode_prop_eq
    end
  | E : identType, e := _ |- _ =>
    lazymatch type of e with
    | ?E => rewrite ?/e
    end
  end.

Lemma le_identE {E : identType} (e1 e2 : E) :
  e1 <=^i e2 = (encode e1 <= encode e2).
Proof. by []. Qed.

Lemma lt_identE {E : identType} (e1 e2 : E) :
  e1 <^i e2 = (encode e1 < encode e2).
Proof. by []. Qed.

Open Scope type_scope.

Definition identE {E : identType} :=
  (@encode0 E, @encode1 E, @encode_fresh E, @encode_iter E,
   @in_nfresh E, @le_identE E, @lt_identE E).

Ltac push_ident_context := (
  match goal with
  | H : context [ encode \i0 ] |- _ => move: H; try clear H
  | H : context [ encode \i1 ] |- _ => move: H; try clear H
  | H : context [ encode (fresh _) ] |- _ => move: H; try clear H
  | H : context [ encode (iter _ fresh _) ] |- _ => move: H; try clear H
  | H : context [ _ \in nfresh _ _ ] |- _ => move: H; try clear H
  | H : context [ _ <=^i _ ] |- _ => move: H; try clear H
  | H : context [ _ <^i _ ] |- _ => move: H; try clear H
  | E : identType, H : context [@eq_op ?E ?x _] |- _ => move: H; try clear H
  | E : identType, H : context [@eq ?E ?x _] |- _ => move: H; try clear H
  end).

Ltac encodify := (repeat progress push_ident_context); (repeat progress encode_indets); rewrite ?identE //=.

Ltac ilia  := encodify; lia.