(* ** Reduction from PCP to semantic entailment *)

Require Import Undecidability.FOL.Syntax.Facts.
Require Import Undecidability.FOL.Semantics.Tarski.FullFacts.
Require Import Undecidability.FOL.Sets.FST.
Require Import Lia.

From Undecidability.PCP Require Import PCP Util.PCP_facts Reductions.PCPb_iff_dPCPb.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* ** Reduction function *)

Local Definition BSRS := list(card bool).

Fixpoint shift n x :=
  match n with
  | O => x
  | S n => subst_term ↑ (shift n x)
  end.

Definition sing a :=
  a ::: ∅.

Definition upair a b :=
  a ::: (b ::: ∅).

Notation "{ a ; b }" := (upair a b) (at level 31) : syn.
Notation  "'σ' x" := (x ::: x) (at level 32) : syn.

Definition opair a b :=
  {{a; a}; {a; b}}.

Definition pairing f A :=
  ∀ $0 ∈ shift 1 f → ∃ ∃ $1 ∈ shift 3 A ∧ $2 ≡ opair $1 $0.

Definition function' f A :=
  pairing f A ∧ ∀ ∃ $0 ∈ shift 2 A ∧ opair $0 $1 ∈ shift 2 f
                    ∧ ∀ opair $1 $0 ∈ shift 2f → $2 ≡ $0.

Definition function f :=
  ∀ ∀ ∀ opair $2 $1 ∈ shift 3 f → opair $2 $0 ∈ shift 3 f → $1 ≡ $0.

Definition enc_bool (x : bool) :=
  if x then {∅; ∅} else ∅.

Fixpoint prep_string (s : string bool) a :=
  match s with
  | nil => a
  | b::s => opair (enc_bool b) (prep_string s a)
  end.

Definition enc_string (s : string bool) :=
  prep_string s ∅.

Fixpoint enc_stack (B : BSRS) :=
  match B with
  | nil => ∅
  | (s,t)::B => opair (enc_string s) (enc_string t) ::: enc_stack B
  end.

Definition is_rep phi a b :=
  ∀ $0 ∈ shift 1 b ↔ ∃ $0 ∈ shift 2 a ∧ phi.

Definition comb_rel s t :=
  ∃ ∃ $2 ≡ opair $0 $1 ∧ $3 ≡ opair (prep_string s $0) (prep_string t $1).

Definition is_bunion a b c :=
  a ⊆ c ∧ b ⊆ c ∧ ∀ $0 ∈ c`[↑] → $0 ∈ a`[↑] ∨ $0 ∈ b`[↑].

Fixpoint combinations (B : BSRS) a b :=
  match B with
  | nil => b ≡ ∅
  | (s,t)::B => ∃ ∃ is_bunion $0 $1 (shift 2 b) ∧ combinations B (shift 2 a) $1
                   ∧ is_rep (comb_rel s t) (shift 2 a) $0
  end.

Definition solutions (B : BSRS) f n :=
  opair ∅ (enc_stack B) ∈ f ∧ ∀ ∀ ∀ $2 ∈ shift 3 n → opair $2 $1 ∈ shift 3 f
               → combinations B $1 $0 → opair (σ $2) $0 ∈ shift 3 f.

Definition transitive t :=
  ∀ $0 ∈ shift 1 t → $0 ⊆ shift 1 t.

Definition htransitive t :=
  transitive t ∧ ∀ $0 ∈ shift 1 t → transitive $0.

Definition solvable (B : BSRS) :=
  ∃ ∃ ∃ ∃ htransitive $3 ∧ function $2 ∧ solutions B $2 $3 ∧ opair $3 $0 ∈ $2 ∧ opair $1 $1 ∈ $0.

Lemma bool_bound b n :
  bounded_t n (enc_bool b).
Proof.
  destruct b; repeat solve_bounds.
Qed.

Lemma prep_string_bound s t n :
  bounded_t n t -> bounded_t n (prep_string s t).
Proof.
  intros Ht. induction s; cbn; trivial.
  repeat solve_bounds; trivial.
  all: apply bool_bound.
Qed.

Lemma string_bound s n :
  bounded_t n (enc_string s).
Proof.
  apply prep_string_bound. solve_bounds.
Qed.

Lemma stack_bound B n :
  bounded_t n (enc_stack B).
Proof.
  induction B as [|[s t] B IH]; cbn; repeat solve_bounds; trivial.
  all: apply string_bound.
Qed.

Lemma combinations_bound (B : BSRS) n k l :
  n > 3 + l -> n > 4 + k -> bounded n (combinations B $k $l).
Proof.
  revert n k l. induction B as [|[s t] B IH]; cbn; intros n k l H1 H2; solve_bounds.
  apply IH; lia. all: apply prep_string_bound; solve_bounds.
Qed.

Lemma solvabe_bound B :
  bounded 0 (solvable B).
Proof.
  repeat solve_bounds.
  - apply stack_bound.
  - apply combinations_bound; lia.
Qed.

(* ** ZF-Models *)

Declare Scope sem.
Open Scope sem.

Arguments Vector.nil {_}, _.
Arguments Vector.cons {_} _ {_} _, _ _ _ _.

Notation "x ∈ y" := (@i_atom _ _ _ _ elem (Vector.cons x (Vector.cons y Vector.nil))) (at level 35) : sem.
Notation "x ≡ y" := (@i_atom _ _ _ _ equal (Vector.cons x (Vector.cons y Vector.nil))) (at level 35) : sem.
Notation "x ⊆ y" := (forall z, z ∈ x -> z ∈ y) (at level 34) : sem.

Notation "∅" := (@i_func FST_func_sig ZFSignature.ZF_pred_sig _ _ eset Vector.nil) : sem.
Notation "x ::: y " := (@i_func FST_func_sig _ _ _ adj (Vector.cons x (Vector.cons y Vector.nil))) (at level 31) : sem.

Notation "{ x ; y }" := (x ::: (y ::: ∅)) (at level 31) : sem.
Notation "'σ' x" := (x ::: x) (at level 32) : sem.

(* ** Internal axioms *)

Section FST.

  Context { V : Type }.
  Context { M : interp V }.

  Hypothesis M_FST : forall rho, rho ⊫ FST.
  Hypothesis VIEQ : extensional M.

  Lemma M_ext x y :
    x ⊆ y -> y ⊆ x -> x = y.
  Proof.
    rewrite <- VIEQ. apply (@M_FST (fun _ => ∅) ax_ext). cbn; tauto.
  Qed.

  Lemma M_eset x :
    ~ x ∈ ∅.
  Proof.
    refine (@M_FST (fun _ => ∅) ax_eset _ x). cbn; tauto.
  Qed.

  Lemma M_adj x y z :
    x ∈ y ::: z <-> x = y \/ x ∈ z.
  Proof.
    rewrite <- VIEQ. apply (@M_FST (fun _ => ∅) ax_adj). cbn; tauto.
  Qed.

  Lemma M_pair x y z :
    x ∈ {y; z} <-> x = y \/ x = z.
  Proof.
    rewrite M_adj. rewrite M_adj. intuition. now apply M_eset in H.
  Qed.

  Definition M_is_rep R x y :=
    forall v, v ∈ y <-> exists u, u ∈ x /\ R u v.

  (* ** Basic HF *)

  Definition M_sing x :=
    {x; x}.

  Definition M_opair x y := ({{x; x}; {x; y}}).

  Lemma sing_el x y :
    x ∈ M_sing y <-> x = y.
  Proof.
    split.
    - now intros [H|H] % M_pair.
    - intros ->. apply M_pair. now left.
  Qed.

  Lemma M_pair1 x y :
    x ∈ {x; y}.
  Proof.
    apply M_pair. now left.
  Qed.

  Lemma M_pair2 x y :
    y ∈ {x; y}.
  Proof.
    apply M_pair. now right.
  Qed.

  Lemma sing_pair x y z :
    {x; x} = {y; z} -> x = y /\ x = z.
  Proof.
    intros He. split.
    - assert (H : y ∈ {y; z}) by apply M_pair1.
      rewrite <- He in H. apply M_pair in H. intuition.
    - assert (H : z ∈ {y; z}) by apply M_pair2.
      rewrite <- He in H. apply M_pair in H. intuition.
  Qed.

  Lemma opair_inj1 x x' y y' :
    M_opair x y = M_opair x' y' -> x = x'.
  Proof.
    intros He. assert (H : {x; x} ∈ M_opair x y) by apply M_pair1.
    rewrite He in H. apply M_pair in H as [H|H]; apply (sing_pair H).
  Qed.

  Lemma opair_inj2 x x' y y' :
    M_opair x y = M_opair x' y' -> y = y'.
  Proof.
    intros He. assert (y = x' \/ y = y') as [->| ->]; trivial.
    - assert (H : {x; y} ∈ M_opair x y) by apply M_pair2.
      rewrite He in H. apply M_pair in H as [H|H].
      + symmetry in H. apply sing_pair in H. intuition.
      + assert (H' : y ∈ {x; y}) by apply M_pair2.
        rewrite H in H'. now apply M_pair in H'.
    - assert (x = x') as -> by now apply opair_inj1 in He.
      assert (H : {x'; y'} ∈ M_opair x' y') by apply M_pair2.
      rewrite <- He in H. apply M_pair in H as [H|H]; apply (sing_pair (eq_sym H)).
  Qed.

  Lemma opair_inj x x' y y' :
    M_opair x y = M_opair x' y' -> x = x' /\ y = y'.
  Proof.
    intros H. split.
    - eapply opair_inj1; eassumption.
    - eapply opair_inj2; eassumption.
  Qed.

  Lemma sigma_el x y :
    x ∈ σ y <-> x ∈ y \/ x = y.
  Proof.
    rewrite M_adj. tauto.
  Qed.

  Lemma sigma_eq x :
    x ∈ σ x.
  Proof.
    apply sigma_el. now right.
  Qed.

  Lemma sigma_sub x :
    x ⊆ σ x.
  Proof.
    intros y H. apply sigma_el. now left.
  Qed.

  Lemma pair_com x y :
    {x; y} = {y; x}.
  Proof.
    apply M_ext; intros z [->| ->] % M_pair; apply M_pair; auto.
  Qed.

  (* ** Numerals *)

  Fixpoint numeral n :=
    match n with
    | O => ∅
    | S n => σ (numeral n)
    end.

  Definition trans x :=
    forall y, y ∈ x -> y ⊆ x.

  Lemma numeral_trans n :
    trans (numeral n).
  Proof.
    induction n; cbn.
    - intros x H. now apply M_eset in H.
    - intros x [H| ->] % sigma_el; try apply sigma_sub.
      apply IHn in H. intuition eauto using sigma_sub.
  Qed.

  Lemma numeral_wf n :
    ~ numeral n ∈ numeral n.
  Proof.
    induction n.
    - apply M_eset.
    - intros [H|H] % sigma_el; fold numeral in *.
      + apply IHn. eapply numeral_trans; eauto. apply sigma_eq.
      + assert (numeral n ∈ numeral (S n)) by apply sigma_eq.
        now rewrite H in H0.
  Qed.

  Lemma numeral_lt k l :
    k < l -> numeral k ∈ numeral l.
  Proof.
    induction 1; cbn; apply sigma_el; auto.
  Qed.

  Lemma numeral_inj k l :
    numeral k = numeral l -> k = l.
  Proof.
    intros Hk. assert (k = l \/ k < l \/ l < k) as [H|[H|H]] by lia; trivial.
    all: apply numeral_lt in H; rewrite Hk in H; now apply numeral_wf in H.
  Qed.

  Definition htrans x :=
    trans x /\ forall y, y ∈ x -> trans y.

  Lemma numeral_numeral n x :
    x ∈ numeral n -> exists k, x = numeral k.
  Proof.
    intros H. induction n; cbn in *.
    - now apply M_eset in H.
    - apply sigma_el in H as [H|H].
      + apply IHn, H.
      + exists n. apply H.
  Qed.

  Lemma numeral_htrans n :
    htrans (numeral n).
  Proof.
    split; try apply numeral_trans.
    intros y [k ->] % numeral_numeral. apply numeral_trans.
  Qed.

  Lemma numeral_trans_sub x n :
    (forall x y, (x ∈ y) + (~ x ∈ y)) -> x ⊆ numeral n -> trans x -> sig (fun n => x = numeral n).
  Proof.
    intros d. induction n; cbn.
    - intros H _. exists 0. cbn. apply M_ext; trivial. intros y [] % M_eset.
    - intros Hn Hx. destruct (d (numeral n) x) as [H|H].
      + exists (S n). cbn. apply M_ext; trivial.
        intros y [Hy| ->] % sigma_el; trivial.
        now apply (Hx (numeral n)).
      + apply IHn; trivial. intros y Hy.
        specialize (Hn y Hy). apply sigma_el in Hn as [Hn| ->]; tauto.
  Qed.

  (* ** Encodings *)

  (* Encodings of booleans, strings, cards, and stacks *)

  Definition M_enc_bool (x : bool) :=
    if x then {∅; ∅} else ∅.

  Fixpoint M_prep_string (s : string bool) x :=
    match s with
    | nil => x
    | b::s => M_opair (M_enc_bool b) (M_prep_string s x)
    end.

  Definition M_enc_string (s : string bool) :=
    M_prep_string s ∅.

  Definition M_enc_card s t :=
    M_opair (M_enc_string s) (M_enc_string t).

  Fixpoint M_enc_stack (B : BSRS) :=
    match B with
    | nil => ∅
    | (s,t)::B => M_enc_card s t ::: M_enc_stack B
    end.

  (* Injectivity of encodings *)

  Lemma enc_bool_inj b c :
    M_enc_bool b = M_enc_bool c -> b = c.
  Proof.
    destruct b, c; trivial; cbn.
    - intros H. contradiction (@M_eset ∅).
      pattern ∅ at 2. rewrite <- H. apply M_pair; auto.
    - intros H. contradiction (@M_eset ∅).
      pattern ∅ at 2. rewrite H. apply M_pair; auto.
  Qed.

  Lemma enc_string_inj s t :
    M_enc_string s = M_enc_string t -> s = t.
  Proof.
    induction s in t|-*; destruct t as [|b t]; cbn; trivial.
    - intros H. contradiction (M_eset (x:=M_sing (M_enc_bool b))).
      rewrite H. apply M_pair. now left.
    - intros H. contradiction (M_eset (x:=M_sing (M_enc_bool a))).
      rewrite <- H. apply M_pair. now left.
    - intros [H1 H2] % opair_inj. apply IHs in H2 as ->.
      apply enc_bool_inj in H1 as ->. reflexivity.
  Qed.

  (* Agreement to syntactical encodings under evaluation *)

  Lemma eval_opair rho x y :
    eval rho (opair x y) = M_opair (eval rho x) (eval rho y).
  Proof.
    cbn. reflexivity.
  Qed.

  Lemma eval_enc_bool rho b :
    eval rho (enc_bool b) = M_enc_bool b.
  Proof.
    destruct b; reflexivity.
  Qed.

  Lemma eval_prep_string rho s x :
    eval rho (prep_string s x) = M_prep_string s (eval rho x).
  Proof.
    induction s; trivial. cbn [prep_string].
    now rewrite eval_opair, IHs, eval_enc_bool.
  Qed.

  Lemma eval_enc_string rho s :
    eval rho (enc_string s) = M_enc_string s.
  Proof.
    unfold enc_string. now rewrite eval_prep_string.
  Qed.

  Lemma eval_enc_stack rho B :
    eval rho (enc_stack B) = M_enc_stack B.
  Proof.
    induction B; cbn; trivial. destruct a. cbn. unfold M_enc_card.
    now rewrite <- IHB, <- !eval_enc_string with (rho:=rho), <- eval_opair.
  Qed.

  (* Auxiliary lemmas for stack encodings *)

  Lemma enc_stack_el' x A :
    x ∈ M_enc_stack A -> exists s t, (s, t) el A /\ x = M_enc_card s t.
  Proof.
    induction A as [|[s t] A IH]; cbn.
    - now intros H % M_eset.
    - intros [->|H] % M_adj.
      + exists s, t. intuition.
      + destruct (IH H) as (u&v&H'&->). exists u, v. intuition.
  Qed.

  Lemma enc_stack_el B s t :
    (s, t) el B -> M_enc_card s t ∈ M_enc_stack B.
  Proof.
    induction B as [|[u b] B IH]; cbn; auto.
    intros [[=]|H]; subst; apply M_adj; auto.
  Qed.

  Lemma M_prep_enc s s' :
    M_prep_string s (M_enc_string s') = M_enc_string (s ++ s').
  Proof.
    induction s; cbn; trivial.
    now rewrite IHs.
  Qed.

  (* ** Preservation direction *)

  (*
     We encode the k-step solutions of a PCP instance B as a set-theoretic function M_enc_derivations.
     This function satisfies the conditions expressed in the reduction formula and
     contains a solution whenever B is solvable.
   *)

  Definition append_all A (c : card bool) :=
    map (fun p => (fst c ++ fst p, snd c ++ snd p)) A.

  Definition derivation_step B C :=
    flat_map (append_all C) B.

  Fixpoint derivations B n :=
    match n with
    | O => B
    | S n => derivation_step B (derivations B n)
    end.

  Lemma derivable_derivations B s t :
    derivable B s t -> exists n, (s, t) el derivations B n.
  Proof.
    induction 1.
    - exists 0. apply H.
    - destruct IHderivable as [n Hn]. exists (S n).
      apply in_flat_map. exists (x, y). split; trivial.
      apply in_map_iff. exists (u,v). cbn. split; trivial.
  Qed.

  Fixpoint M_enc_derivations B n :=
    match n with
    | O => M_sing (M_opair ∅ (M_enc_stack B))
    | S n => M_opair (numeral (S n)) (M_enc_stack (derivations B (S n))) ::: M_enc_derivations B n
    end.

  Lemma enc_derivations_base B n :
    M_opair ∅ (M_enc_stack B) ∈ M_enc_derivations B n.
  Proof.
    induction n; cbn.
    - now apply sing_el.
    - apply M_adj. now right.
  Qed.

  Lemma enc_derivations_bound B n k x :
    M_opair k x ∈ M_enc_derivations B n -> k ∈ σ (numeral n).
  Proof.
    induction n; cbn.
    - intros H % sing_el. apply opair_inj in H as [-> _].
      apply sigma_el. now right.
    - intros [H|H] % M_adj.
      + apply opair_inj in H as [-> _]. apply sigma_eq.
      + apply sigma_el. left. apply IHn, H.
  Qed.

  Lemma enc_derivations_fun B n :
    forall k x y, M_opair k x ∈ M_enc_derivations B n -> M_opair k y ∈ M_enc_derivations B n -> x = y.
  Proof.
    induction n; cbn -[derivations]; intros k x y.
    - intros H1 % sing_el H2 % sing_el.
      rewrite <- H2 in H1. now apply opair_inj in H1.
    - intros [H1|H1] % M_adj [H2|H2] % M_adj.
      + rewrite <- H2 in H1. now apply opair_inj in H1.
      + exfalso. apply enc_derivations_bound in H2.
        destruct (opair_inj H1) as [-> _]. now apply (@numeral_wf (S n)).
      + exfalso. apply enc_derivations_bound in H1.
        destruct (opair_inj H2) as [-> _]. now apply (@numeral_wf (S n)).
      + now apply (IHn k x y).
  Qed.

  Lemma enc_derivations_el B n k x :
    M_opair k x ∈ M_enc_derivations B n -> exists l, k = numeral l /\ x = M_enc_stack (derivations B l).
  Proof.
    induction n; cbn.
    - intros H % sing_el. exists 0. apply (opair_inj H).
    - intros [H|H] % M_adj.
      + exists (S n). apply (opair_inj H).
      + apply IHn, H.
  Qed.

  Lemma enc_derivations_step B n l :
    numeral l ∈ numeral n
    -> M_opair (σ (numeral l)) (M_enc_stack (derivations B (S l))) ∈ M_enc_derivations B n.
  Proof.
    induction n; cbn -[derivations].
    - now intros H % M_eset.
    - intros [H|H] % M_adj; apply M_adj.
      + left. now apply numeral_inj in H as ->.
      + right. apply IHn, H.
  Qed.

  Definition M_is_bunion a b c :=
    a ⊆ c /\ b ⊆ c /\ forall d, d ∈ c -> d ∈ a \/ d ∈ b.

  Lemma M_enc_stack_app A B :
    M_is_bunion (M_enc_stack A) (M_enc_stack B) (M_enc_stack (A ++ B)).
  Proof.
    induction A as [|[s t] A IH]; cbn.
    - repeat split; auto. intros x [] % M_eset.
    - repeat split.
      + intros x [->|H] % M_adj; apply M_adj; auto. right. now apply IH in H.
      + intros x H. apply M_adj. right. now apply IH in H.
      + intros x [->|H] % M_adj; rewrite M_adj; auto. apply IH in H. tauto.
  Qed.

  Lemma M_bunion_unique a b c c' :
    M_is_bunion a b c -> M_is_bunion a b c' -> c = c'.
  Proof.
    intros H1 H2. apply M_ext; firstorder.
  Qed.

  Lemma enc_stack_combinations B rho C x X Y :
    rho ⊨ combinations B X Y -> eval rho X = M_enc_stack C -> eval rho Y = x -> x = M_enc_stack (derivation_step B C).
  Proof.
    induction B as [|[s t] B IH] in rho,C,x,X,Y |-*.
    - cbn. rewrite VIEQ. now intros -> _ <-.
    - intros [x1[x2[[H1 H2]H3]]] R1 R2; fold sat in *.
      assert (M_is_bunion x2 x1 x).
      { rewrite <- R2. cbn in H1. destruct H1 as [[H1 H1'] H1'']. repeat split; intros y.
        - specialize (H1 y). rewrite !eval_comp in H1. apply H1.
        - specialize (H1' y). rewrite !eval_comp in H1'. apply H1'.
        - specialize (H1'' y). rewrite !eval_comp in H1''. apply H1''. } clear H1.
      cbn. fold (derivation_step B C).
      enough (x1 = M_enc_stack (derivation_step B C)) as E1.
      + enough (x2 = M_enc_stack (append_all C (s, t))) as E2.
        { eapply M_bunion_unique; try apply H. rewrite E1, E2. apply M_enc_stack_app. }
        apply M_ext; intros u Hu.
        * apply H3 in Hu as [v [Hv[a [b Ha]]]].
          cbn in Hv. erewrite !eval_comp, eval_ext, R1 in Hv; trivial.
          apply enc_stack_el' in Hv as (s'&t'&Hst&Hv).
          enough (u = M_enc_card (s++s') (t++t')) as ->.
          { apply enc_stack_el. apply in_map_iff. now exists (s', t'). }
          cbn in Ha. rewrite !VIEQ in Ha. destruct Ha as [D1 D2].
          rewrite D1 in Hv. unfold M_enc_card in Hv. apply opair_inj in Hv as [-> ->].
          rewrite D2; unfold M_enc_card, M_opair; repeat f_equal.
          all: rewrite eval_prep_string; cbn. all: apply M_prep_enc.
        * apply enc_stack_el' in Hu as (s'&t'&Hst&->).
          unfold append_all in H. eapply in_map_iff in Hst as [[a b][Ha Hb]].
          cbn in H. apply H3. exists (M_enc_card a b). split.
          { cbn. erewrite !eval_comp, eval_ext, R1; trivial. now apply enc_stack_el. }
          exists (M_enc_string b), (M_enc_string a). split.
          -- cbn. apply VIEQ. reflexivity.
          -- cbn. apply VIEQ. rewrite !eval_prep_string. cbn.
             rewrite !M_prep_enc. injection Ha. intros -> ->. reflexivity.
      + eapply IH; eauto. unfold shift. now erewrite !eval_comp, eval_ext, R1.
  Qed.

  Lemma enc_derivations_solutions B n rho a b :
    (a .: b .: M_enc_derivations B n .: numeral n .: rho) ⊨ solutions B $2 $3.
  Proof.
    cbn. split.
    - rewrite eval_enc_stack. apply enc_derivations_base.
    - intros k x x' H1 H2 H3.
      destruct (enc_derivations_el H2) as [l[-> ->]].
      specialize (enc_derivations_step B H1).
      replace (M_enc_stack (derivations B (S l))) with x'; trivial.
      apply (enc_stack_combinations H3); trivial.
  Qed.

  Lemma derivations_enc_derivations B n :
    M_opair (numeral n) (M_enc_stack (derivations B n)) ∈ M_enc_derivations B n.
  Proof.
    induction n; cbn -[derivations].
    - now apply sing_el.
    - apply M_adj. now left.
  Qed.

  Lemma derivations_el B n s t :
    (s, t) el derivations B n -> M_enc_card s t ∈ M_enc_stack (derivations B n).
  Proof.
    apply enc_stack_el.
  Qed.

  Theorem PCP_FST1 B s :
    derivable B s s -> forall rho, rho ⊨ solvable B.
  Proof.
    intros H rho. destruct (derivable_derivations H) as [n Hn]. unfold solvable.
    exists (numeral n), (M_enc_derivations B n), (M_enc_string s), (M_enc_stack (derivations B n)).
    split; [split; [split; [split |] |] |].
    - apply numeral_htrans.
    - unfold function'. intros k x y H1 H2. apply VIEQ. apply (enc_derivations_fun H1 H2).
    - apply enc_derivations_solutions.
    - cbn. apply derivations_enc_derivations.
    - now apply enc_stack_el.
  Qed.

  (* ** Reflection direction *)

  (*
    Conversely, we show how to reconstruct a solution of a PCP instance B from a model
    (1) satisfying the reduction formula defined above and
    (2) containing only the standard natural numers.
    The latter seems necessary to exclude non-standard solutions the model might contain.
   *)

  Definition M_comb_rel s t :=
    fun u v => exists u1 u2, u = M_opair u1 u2 /\ v = M_opair (M_prep_string s u1) (M_prep_string t u2).

  Fixpoint M_combinations B x y :=
    match B with
    | nil => y = ∅
    | (s,t)::B => exists y1 y2, M_is_bunion y2 y1 y /\ M_combinations B x y1
                          /\ M_is_rep (M_comb_rel s t) x y2
    end.

  Lemma M_combinations_spec B rho x y a b :
    M_combinations B x y -> eval rho a = x -> eval rho b = y -> rho ⊨ combinations B a b.
  Proof.
    induction B in y,a,b,rho|-*; cbn.
    - rewrite VIEQ. now intros -> _ ->.
    - destruct a0 as [s t]. intros (y1&y2&H1&H2&H3) Ha Hb. exists y1, y2. split. split. 3: split.
      + cbn. repeat split; intros d; rewrite !eval_comp; unfold funcomp; cbn.
        all: change (eval (fun x => rho x) b) with (eval rho b); rewrite Hb; apply H1.
      + eapply (IHB _ y1); trivial. erewrite !eval_comp. unfold funcomp. cbn.
        change (eval (fun x => rho x) a) with (eval rho a). now rewrite Ha.
      + intros (u & Hu & c & d' & H) % H3. exists u. split.
        * cbn. erewrite !eval_comp. erewrite eval_ext, Ha; trivial.
        * exists d', c. cbn. rewrite !VIEQ, !eval_prep_string. apply H.
      + intros (u & Hu & c & d' & H). apply H3. exists u. split.
        * cbn in Hu. erewrite !eval_comp in Hu. rewrite <- Ha. apply Hu.
        * exists d', c. cbn in H. rewrite !VIEQ, !eval_prep_string in H. apply H.
  Qed.

  Definition M_solutions B f n :=
    M_opair ∅ (M_enc_stack B) ∈ f /\ forall k x y, k ∈ n -> M_opair k x ∈ f -> M_combinations B x y -> M_opair (σ k) y ∈ f.

  Lemma comb_rel_rep C s t :
    M_is_rep (M_comb_rel s t) (M_enc_stack C) (M_enc_stack (append_all C (s, t))).
  Proof.
    intros y. split.
    - intros (u&v&H&->) % enc_stack_el'.
      unfold append_all in H. apply in_map_iff in H as [[a b][H1 H2]]. cbn in H1.
      exists (M_enc_card a b). split; try now apply enc_stack_el.
      exists (M_enc_string a), (M_enc_string b). split; trivial.
      assert (u = s++a) as -> by congruence. assert (v = t++b) as -> by congruence.
      now rewrite !M_prep_enc.
    - intros (u&H&a&b&->&->). apply enc_stack_el' in H as [u[v[H1 H2]]].
      apply opair_inj in H2 as [-> ->]. rewrite !M_prep_enc. apply enc_stack_el.
      apply in_map_iff. now exists (u, v).
  Qed.

  Lemma M_combinations_step B C :
    M_combinations B (M_enc_stack C) (M_enc_stack (derivation_step B C)).
  Proof.
    induction B as [|[s t] B IH]; cbn; trivial.
    exists (M_enc_stack (derivation_step B C)), (M_enc_stack (append_all C (s, t))).
    split; try apply M_enc_stack_app. split; trivial.
    apply comb_rel_rep.
  Qed.

  Lemma solutions_derivations B f n k :
    M_solutions B f (numeral n) -> k <= n -> M_opair (numeral k) (M_enc_stack (derivations B k)) ∈ f.
  Proof.
    intros H Hk; induction k; cbn.
    - apply H.
    - assert (Hk' : k <= n) by lia. specialize (IHk Hk').
      destruct H as [_ H]. eapply H in IHk; eauto.
      + now apply numeral_lt.
      + apply M_combinations_step.
  Qed.

  Lemma derivations_derivable B n s t :
    (s, t) el derivations B n -> derivable B s t.
  Proof.
    induction n in s,t|-*; cbn.
    - now constructor.
    - unfold derivation_step. intros [[u v][H1 H2]] % in_flat_map.
      unfold append_all in H2. apply in_map_iff in H2 as [[a b][H2 H3]]. cbn in H2.
      assert (s = u++a) as -> by congruence. assert (t = v++b) as -> by congruence.
      constructor 2; trivial. apply IHn, H3.
  Qed.

  Definition M_function f :=
    forall x y y', M_opair x y ∈ f -> M_opair x y' ∈ f -> y = y'.

  Definition standard :=
    forall x, htrans x -> exists n, x ≡ numeral n.

  Lemma M_solutions_el B f k X p :
    standard -> htrans k -> M_function f -> M_solutions B f k -> M_opair k X ∈ f
    -> p ∈ X -> exists u v, p = M_enc_card u v /\ derivable B u v.
  Proof.
    intros HS HO Hf Hk HX Hp. destruct (HS k HO) as [n -> % VIEQ].
    pose proof (H := solutions_derivations Hk (le_n n)).
    rewrite (Hf _ _ _ HX H) in Hp. apply enc_stack_el' in Hp as (s&t&H'&->).
    exists s, t. split; trivial. eapply derivations_derivable; eauto.
  Qed.

  Theorem PCP_FST2 B rho :
    standard -> rho ⊨ solvable B -> exists s, derivable B s s.
  Proof.
    intros VIN (n & f & s & X & [[[[H1 H2] H3] H4] H5]).
    assert (H1' : htrans n) by apply H1. clear H1.
    assert (H4' : M_opair n X ∈ f) by apply H4. clear H4.
    assert (H5' : M_opair s s ∈ X) by apply H5. clear H5.
    assert (H2' : M_function f).
    { intros x y y' H H'. apply VIEQ. eapply H2. apply H. apply H'. } clear H2.
    assert (H3' : M_opair ∅ (M_enc_stack B) ∈ f).
    { erewrite <- eval_enc_stack. apply H3. } destruct H3 as [_ H3].
    assert (H3'' : forall k x y, k ∈ n -> M_opair k x ∈ f -> M_combinations B x y -> M_opair (σ k) y ∈ f).
    { intros k x y Hn Hk Hy. apply (H3 k x y); auto. fold sat. eapply M_combinations_spec; eauto. } clear H3.
    destruct (@M_solutions_el B f n X (M_opair s s)) as (u&v&H1&H2); trivial.
    now split. exists u. apply opair_inj in H1 as [H ->]. apply enc_string_inj in H as ->. apply H2.
  Qed.

End FST.

(* ** Reduction Theorem *)

Arguments standard {_} _.

Theorem PCP_FST B :
  (exists V (M : interp V), extensional M /\ standard M /\ forall rho, rho ⊫ FST)
  -> PCPb B <-> entailment_FST (solvable B).
Proof.
  intros HZF. rewrite PCPb_iff_dPCPb. split; intros H.
  - clear HZF. destruct H as [s H]. intros M HM rho H1 H2. eapply PCP_FST1; eauto.
  - destruct HZF as (M & H1 & H2 & H3 & H4).
    specialize (H M H1 (fun _ => @i_func _ _ _ _ eset Vector.nil) H2 H4).
    apply PCP_FST2 in H as [s Hs]; trivial. now exists s.
Qed.


Require Export Functor.Sum NaturalTransformation.Core.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section sum_functor_nt.
  Definition sum_Functor_Functorial
             C C' D F G F' G'
             (T : @NaturalTransformation C D F G)
             (T' : @NaturalTransformation C' D F' G')
  : NaturalTransformation (F + F') (G + G').
  Proof.
    refine (Build_NaturalTransformation
              (F + F') (G + G')
              (fun x => match x with
                          | inl c => T c
                          | inr c' => T' c'
                        end)
              _).
    abstract (
        repeat (intros [] || intro); simpl;
        auto with natural_transformation
      ).
  Defined.
End sum_functor_nt.

Notation "T + U" := (sum_Functor_Functorial T U) : natural_transformation_scope.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Prelude ssreflect ssrbool ssrfun eqtype ssrnat fintype finset fingroup.
Require morphism quotient action gfunctor gproduct commutator gseries nilpotent.
Require PFsection14.

(******************************************************************************)
(* This file contains a minimal, self-contained reformulation of the Odd      *)
(* Order theorem, using only the bare Coq logic, and avoiding any use of      *)
(* extra-logical features such as notation, coercion or implicit arguments.   *)
(* This stripped theorem would hardly be usable, however; it just provides    *)
(* evidence for the sceptics.                                                 *)
(******************************************************************************)

(* Equivalence and equality *)

Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P).

Inductive equal T (x : T) : T -> Type := Equal : equal T x x.

(* Arithmetic *)

Inductive natural := Zero | Add_1_to (n : natural).

Fixpoint add (m n : natural) : natural :=
  match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end.

Definition double (n : natural) : natural := add n n.

Inductive odd (n : natural) :=
  Odd (half : natural)
    (n_odd : equal natural n (Add_1_to (double half))).

Inductive less_than (m n : natural) :=
  LessThan (diff : natural)
    (m_lt_n : equal natural n (Add_1_to (add m diff))).

(* Finite subsets *)

Definition injective_in T R (D : T -> Type) (f : T -> R) :=
  forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y.

Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) :=
  InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)).

Inductive finite_of_order T (D : T -> Type) (n : natural) :=
  FiniteOfOrder (rank : T -> natural)
    (rank_injective : injective_in T natural D rank)
    (rank_onto :
       forall i, equivalent (less_than i n) (in_image T natural D rank i)).

(* Elementary group theory *)

Inductive group_axioms T (mul : T -> T -> T) (one : T) (inv : T -> T) :=
  GroupAxioms
    (associativity : forall x y z, equal T (mul x (mul y z)) (mul (mul x y) z))
    (left_identity : forall x,     equal T (mul one x) x)
    (left_inverse  : forall x,     equal T (mul (inv x) x) one).

Inductive group T mul one inv (G : T -> Type) :=
  Group
    (G_closed_under_mul : forall x y, G x -> G y -> G (mul x y))
    (one_in_G           : G one)
    (G_closed_under_inv : forall x, G x -> G (inv x)).

Inductive subgroup T mul one inv (H G : T -> Type) :=
  Subgroup
    (H_group    : group T mul one inv H)
    (H_subset_G : forall x, H x -> G x).

Inductive normal_subgroup T mul one inv (H G : T -> Type) :=
  NormalSubgroup
    (H_subgroup_G     : subgroup T mul one inv H G)
    (H_is_G_invariant : forall x y, H x -> G y -> H (mul (inv y) (mul x y))).

Inductive commute_mod T mul (x y : T) (H : T -> Type) :=
  CommuteMod (z : T)
    (z_in_H    : H z)
    (xy_eq_zyx : equal T (mul x y) (mul z (mul y x))).

Inductive abelian_factor T mul one inv (G H : T -> Type) :=
  AbelianFactor
    (G_group        : group T mul one inv G)
    (H_normal_in_G  : normal_subgroup T mul one inv H G)
    (G_on_H_abelian : forall x y, G x -> G y -> commute_mod T mul x y H).

Inductive solvable_group T mul one inv (G : T -> Type) :=
| TrivialGroupSolvable
   (G_trivial : forall x, equivalent (G x) (equal T x one))
| AbelianExtensionSolvable (H : T -> Type)
   (H_solvable     : solvable_group T mul one inv H)
   (G_on_H_abelian : abelian_factor T mul one inv G H).

(* begin hide *)
Module InternalSkepticOddOrderProof.

Local Notation Aeq := (equal _).
Local Notation Aadd := add.
Local Notation Adouble := double.
Local Notation Aodd := odd.
Local Notation Alt := less_than.
Local Notation Agroup := group.
Local Notation Asubgroup := subgroup.
Local Notation Anormal := normal_subgroup.
Local Notation Aabel_quo := abelian_factor.
Local Notation Asol := solvable_group.

Import Prelude ssreflect ssrbool ssrfun eqtype ssrnat fintype finset fingroup.
Import morphism quotient action gfunctor gproduct commutator gseries nilpotent.
Import GroupScope.

Lemma main T mul one inv G nn :
    group_axioms T mul one inv -> Agroup T mul one inv G ->
    finite_of_order T G nn -> Aodd nn ->
  Asol T mul one inv G.
Proof.
pose fix natN n := if n is n1.+1 then Add_1_to (natN n1) else Zero.
pose fix Nnat mm := if mm is Add_1_to mm1 then (Nnat mm1).+1 else 0.
have natN_K: cancel natN Nnat by elim=> //= n ->.
have NnatK: cancel Nnat natN by elim=> //= mm ->.
have AaddE nn1 nn2: Nnat (Aadd nn1 nn2) = Nnat nn1 + Nnat nn2.
  by elim: nn1 nn2 => //= nn1 IHnn nn2; rewrite IHnn addnS.
have AltE m n: Alt (natN m) (natN n) -> m < n.
  by rewrite -{2}[n]natN_K => [[dd ->]]; rewrite /= ltnS AaddE natN_K leq_addr.
have AltI m n: m < n -> Alt (natN m) (natN n).
  move/subnKC <-; exists (natN (n - m.+1)).
  by rewrite -[Add_1_to _]NnatK /= AaddE !natN_K.
have AoddE n: Aodd (natN n) -> odd n.
  by rewrite -{2}[n]natN_K => [[hh ->]]; rewrite /= AaddE addnn odd_double.
case=> mulA mul1T mulVT [mulG oneG invG] [rG inj_rG im_rG] odd_nn.
pose n := Nnat nn; have{odd_nn} odd_n: odd n by rewrite AoddE ?NnatK.
have{rG inj_rG im_rG} [gT o_gT [f [g Gf [fK gK]] [fM f1 fV]]]:
  {gT : finGroupType & #|gT| = n & {f : gT -> T
    & {g : _ & forall a, G (f a) & cancel f g /\ forall x, G x -> f (g x) = x}
      & [/\ {morph f : a b / a * b >-> mul a b}, f 1 = one
          & {morph f : a / a^-1 >-> inv a}]}}.
- pose gT := 'I_n.-1.+1; pose g x : gT := inord (Nnat (rG x)).
  have ub_rG x: G x -> Nnat (rG x) < n.
    move=> Gx; rewrite AltE ?NnatK //.
    by have [_] := im_rG (rG x); apply; exists x.
  have Dn: n.-1.+1 = n := ltn_predK (ub_rG one oneG).
  have fP a: {x : T & G x * (g x = a)}%type.
    have a_lt_n: Alt (natN a) nn by rewrite -(canLR NnatK Dn); apply: AltI.
    have [/(_ a_lt_n)[x Gx rGx] _] := im_rG (natN a).
    by exists x; split; rewrite // /g -rGx natN_K inord_val.
  pose f a := tag (fP a); have Gf a: G (f a) by rewrite /f; case: (fP) => x [].
  have fK: cancel f g by rewrite /f => a; case: (fP a) => x [].
  have Ng x & G x: natN (g x) = rG x by rewrite inordK ?Dn ?ub_rG ?NnatK.
  have{Ng} gK x: G x -> f (g x) = x.
    by move=> Gx; rewrite (inj_rG (f (g x)) x) // -!Ng ?fK.
  pose m a b := g (mul (f a) (f b)).
  pose o := g one; pose v a := g (inv (f a)).
  have fM: {morph f: a b / m a b >-> mul a b} by move=> a b; apply/gK/mulG.
  have f1: f o = one by apply: gK.
  have fV: {morph f: a / v a >-> inv a} by move=> a; apply/gK/invG.
  have mA: associative m by move=> a b c; apply: canLR fK _; rewrite !fM mulA.
  have m1: left_id o m by move=> a; apply: canLR fK _; rewrite f1 mul1T.
  have mV: left_inverse o v m.
    by move=> a; apply: canLR fK _; rewrite fV f1 mulVT.
  pose bT := BaseFinGroupType _ (FinGroup.Mixin mA m1 mV).
  exists (@FinGroupType bT mV); first by rewrite card_ord Dn.
  by exists f; first exists g.
pose im (H : {group gT}) x := (G x * (g x \in H))%type.
have imG H : Agroup T mul one inv (im H).
  split=> [x y [Gx Hx] [Gy Hy] | | x [Gx Hx]]; first 1 last.
  - by split; rewrite // -(canRL fK f1).
  - by split; [auto | rewrite -(gK x Gx) -fV fK groupV].
  by split; [auto | rewrite -(gK x Gx) -(gK y Gy) -fM fK groupM].
pose G0 := [set: gT]%G.
have sGG0 x: G x -> im G0 x by split; rewrite ?inE.
have mulVV1 x: mul (inv (inv x)) one = x by rewrite -(mulVT x) mulA mulVT mul1T.
have{mulVV1} mulT1 x: mul x one = x by rewrite -[x]mulVV1 -mulA mul1T.
pose comm x y := mul (mul x y) (inv (mul y x)).
suffices solH: Asol T mul one inv (im G0).
  right with (im G0) => //; split=> // [|x y Gx Gy].
    by split=> // [|x y [Gx _] Gy]; [split=> // x [] | apply: sGG0; auto].
  by exists (comm x y); [rewrite /comm; auto | rewrite -mulA mulVT -mulA mulT1].
have solG0: solvable G0 by rewrite PFsection14.Feit_Thompson ?cardsT ?o_gT.
elim: _.+1 {-2}G0 (ltnSn #|G0|) => // m IHm H; rewrite ltnS => leHm.
have [-> | ntH] := eqVneq H 1%G.
  left=> // x; split=> [[Gx /set1P] | ->].
    by rewrite -f1 => <-; rewrite gK.
  by split; rewrite // -f1 fK.
have ltH'H: H^`(1) \proper H := sol_der1_proper solG0 (subsetT H) ntH.
right with (im H^`(1)%G); first exact: IHm (leq_trans (proper_card _) leHm).
have /andP[/subsetP sH'H /subsetP nH'H]: H^`(1) <| H := der_normal 1 H.
split=> // [|x y [Gx Hx] [Gy Hy]].
  split=> // [|x y [Gx H'x] [Gy Hy]]; first by split=> // x [Gx /sH'H].
  split; first by [auto]; rewrite -(gK x Gx) -(gK y Gy) -!(fM, fV) !fK.
  by rewrite memJ_norm ?nH'H.
exists (comm x y); last by rewrite -mulA mulVT -mulA mulT1.
rewrite /comm; split; first by [auto]; rewrite -(gK x Gx) -(gK y Gy).
by rewrite -!(fM, fV) fK -[g x * g y]invgK !invMg -mulgA mem_commg ?groupV.
Qed.

End InternalSkepticOddOrderProof.
(* end hide *)

(* The Odd Order theorem *)

Theorem stripped_Odd_Order T mul one inv (G : T -> Type) (n : natural) :
    group_axioms T mul one inv -> group T mul one inv G ->
    finite_of_order T G n -> odd n ->
  solvable_group T mul one inv G.
Proof. exact (InternalSkepticOddOrderProof.main T mul one inv G n). Qed.


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 double (double_arg0 : natural) : natural
           := match double_arg0 with
              | Zero => Zero
              | Succ n => Succ (Succ (double n))
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
   induction l1.
   - intros. simpl. f_equal. apply IHl1.
   - intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (append x x)) (double (len x)).
Proof.
induction x.
   - simpl. rewrite <- IHx. f_equal. lfind. Admitted.


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

(*i $Id: Diaconescu.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
   in topoi [Diaconescu75]. Lacas and Werner adapted the proof to show
   that the axiom of choice in equivalence classes entails
   Excluded-Middle in Type Theory [LacasWerner99].

   Three variants of Diaconescu's result in type theory are shown below.

   A. A proof that the relational form of the Axiom of Choice +
      Extensionality for Predicates entails Excluded-Middle (by Hugo
      Herbelin)

   B. A proof that the relational form of the Axiom of Choice + Proof
      Irrelevance entails Excluded-Middle for Equality Statements (by
      Benjamin Werner)

   C. A proof that extensional Hilbert epsilon's description operator
      entails excluded-middle (taken from Bell [Bell93])

   See also [Carlström] for a discussion of the connection between the
   Extensional Axiom of Choice and Excluded-Middle

   [Diaconescu75] Radu Diaconescu, Axiom of Choice and Complementation,
   in Proceedings of AMS, vol 51, pp 176-178, 1975.

   [LacasWerner99] Samuel Lacas, Benjamin Werner, Which Choices imply
   the excluded middle?, preprint, 1999.

   [Bell93] John L. Bell, Hilbert's epsilon operator and classical
   logic, Journal of Philosophical Logic, 22: 1-18, 1993

   [Carlström04] Jesper Carlström, EM + Ext_ + AC_int <-> AC_ext,
   Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
*)

(**********************************************************************)
(** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)

Section PredExt_RelChoice_imp_EM.

(** The axiom of extensionality for predicates *)

Definition PredicateExtensionality :=
  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.

(** From predicate extensionality we get propositional extensionality
   hence proof-irrelevance *)

Require Import ClassicalFacts.

Variable pred_extensionality : PredicateExtensionality.

Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
Proof.
  intros A B H.
  change ((fun _ => A) true = (fun _ => B) true) in |- *.
  rewrite
   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
    reflexivity.
    intros _; exact H.
Qed.

Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
Proof.
  apply (ext_prop_dep_proof_irrel_cic prop_ext).
Qed.

(** From proof-irrelevance and relational choice, we get guarded
   relational choice *)

Require Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Lemma guarded_rel_choice : GuardedRelationalChoice.
Proof.
 apply
  (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
Qed.

(** The form of choice we need: there is a functional relation which chooses
    an element in any non empty subset of bool *)

Require Import Bool.

Lemma AC_bool_subset_to_bool :
  exists R : (bool -> Prop) -> bool -> Prop,
   (forall P:bool -> Prop,
      (exists b : bool, P b) ->
       exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
Proof.
  destruct (guarded_rel_choice _ _
   (fun Q:bool -> Prop =>  exists y : _, Q y)
   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
    exact (fun _ H => H).
  exists R; intros P HP.
  destruct (HR P HP) as (y,(Hy,Huni)).
  exists y; firstorder.
Qed.

(** The proof of the excluded middle *)
(** Remark: P could have been in Set or Type *)

Theorem pred_ext_and_rel_choice_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
intro P.

(** first we exhibit the choice functional relation R *)
destruct AC_bool_subset_to_bool as [R H].

set (class_of_true := fun b => b = true \/ P).
set (class_of_false := fun b => b = false \/ P).

(** the actual "decision": is (R class_of_true) = true or false? *)
destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
exists true; left; reflexivity.
destruct H0.

(** the actual "decision": is (R class_of_false) = true or false? *)
destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
exists false; left; reflexivity.
destruct H1.

(** case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
right.
intro HP.
assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
intro b; split.
unfold class_of_false in |- *; right; assumption.
unfold class_of_true in |- *; right; assumption.
assert (Heq : class_of_true = class_of_false).
apply pred_extensionality with (1 := Hequiv).
apply diff_true_false.
rewrite <- H0.
rewrite <- H1.
rewrite <- H0''. reflexivity.
rewrite Heq.
assumption.

(** cases where P is true *)
left; assumption.
left; assumption.

Qed.

End PredExt_RelChoice_imp_EM.

(**********************************************************************)
(** * B. Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)

(** This is an adaptation of Diaconescu's paradox exploiting that
    proof-irrelevance is some form of extensionality *)

Section ProofIrrel_RelChoice_imp_EqEM.

Variable rel_choice : RelationalChoice.

Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.

(** Let [a1] and [a2] be two elements in some type [A] *)

Variable A :Type.
Variables a1 a2 : A.

(** We build the subset [A'] of [A] made of [a1] and [a2] *)

Definition A' := sigT (fun x => x=a1 \/ x=a2).

Definition a1':A'.
exists a1 ; auto.
Defined.

Definition a2':A'.
exists a2 ; auto.
Defined.

(** By proof-irrelevance, projection is a retraction *)

Lemma projT1_injective : a1=a2 -> a1'=a2'.
Proof.
  intro Heq ; unfold a1', a2', A'.
  rewrite Heq.
  replace (or_introl (a2=a2) (refl_equal a2))
     with (or_intror (a2=a2) (refl_equal a2)).
  reflexivity.
  apply proof_irrelevance.
Qed.

(** But from the actual proofs of being in [A'], we can assert in the
    proof-irrelevant world the existence of relevant boolean witnesses *)

Lemma decide : forall x:A', exists y:bool ,
  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
Proof.
  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
Qed.

(** Thanks to the axiom of choice, the boolean witnesses move from the
    propositional world to the relevant world *)

Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
Proof.
  destruct
    (rel_choice A' bool
       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
    as (R,(HRsub,HR)).
    apply decide.
  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2.
    rewrite (projT1_injective H) in Ha1'b1.
    assert (false = true) by auto using Huni2.
    discriminate.
  left; assumption.
Qed.

(** An alternative more concise proof can be done by directly using
    the guarded relational choice *)

Declare Implicit Tactic auto.

Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
Proof.
  assert (decide: forall x:A, x=a1 \/ x=a2 ->
                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
  assert (guarded_rel_choice :=
          rel_choice_and_proof_irrel_imp_guarded_rel_choice
	  rel_choice
	  proof_irrelevance).
  destruct
    (guarded_rel_choice A bool
      (fun x => x=a1 \/ x=a2)
      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
      as (R,(HRsub,HR)).
      apply decide.
  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2; subst a1.
    assert (false = true) by auto using Huni2, Ha1b1.
    discriminate.
  left; assumption.
Qed.

End ProofIrrel_RelChoice_imp_EqEM.

(**********************************************************************)
(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)

(** Proof sketch from Bell [Bell93] (with thanks to P. Castéran) *)

Notation Local inhabited A := A (only parsing).

Section ExtensionalEpsilon_imp_EM.

Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.

Hypothesis epsilon_spec :
  forall (A:Type) (i:inhabited A) (P:A->Prop),
  (exists x, P x) -> P (epsilon A i P).

Hypothesis epsilon_extensionality :
  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.

Notation Local eps := (epsilon bool true) (only parsing).

Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
  intro P.
  pose (B := fun y => y=false \/ P).
  pose (C := fun y => y=true  \/ P).
  assert (B (eps B)) as [Hfalse|HP]
    by (apply epsilon_spec; exists false; left; reflexivity).
  assert (C (eps C)) as [Htrue|HP]
    by (apply epsilon_spec; exists true; left; reflexivity).
    right; intro HP.
    assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
    rewrite epsilon_extensionality with (1:=H) in Hfalse.
    rewrite Htrue in Hfalse.
    discriminate.
  auto.
  auto.
Qed.

End ExtensionalEpsilon_imp_EM.


Require Import maps.
Set Implicit Arguments.
Set Contextual Implicit.

Inductive MapRep (Key Elt : Type) : Type :=
   rEmpty : MapRep Key Elt
 | rItem : Key -> Elt -> MapRep Key Elt
 | rJoin : MapRep Key Elt -> MapRep Key Elt -> MapRep Key Elt
 | rLeaf : Map Key Elt -> MapRep Key Elt
 .

Function join {Key Elt} (m1 m2 : Map Key Elt) : Map Key Elt :=
  match m1, m2 with
    | mapEmpty, _ => m2
    | _, mapEmpty => m1
    | _, _ => m1 :* m2
  end.
Lemma join_sem : forall {K E} (m1 m2 : Map K E), m1 :* m2 ~= join m1 m2.
Proof.
intros. functional induction (join m1 m2).
apply equivUnitL.
apply equivUnit.
apply equivRefl.
Qed.

Fixpoint unrep {K E} (r : MapRep K E) : Map K E :=
  match r with
    | rEmpty => mapEmpty
    | rItem k v => k |-> v
    | rJoin l r => unrep l :* unrep r
    | rLeaf m => m
  end.
Fixpoint simplRep {K E} (r : MapRep K E) : Map K E :=
  match r with
    | rEmpty => mapEmpty
    | rItem k v => k |-> v
    | rJoin l r => join (simplRep l) (simplRep r)
    | rLeaf m => m
  end.

Lemma simplValid {K E} (r : MapRep K E) : unrep r ~= simplRep r.
induction r;try reflexivity.
simpl. rewrite <- join_sem. apply equivJoin;assumption.
Qed.

Inductive MapZipper (Key Elt : Type) : Type :=
   Here : MapZipper Key Elt
 | Left : forall {r : Map Key Elt}, MapZipper Key Elt -> MapZipper Key Elt
 | Right : forall {l : Map Key Elt}, MapZipper Key Elt -> MapZipper Key Elt
 .

Fixpoint plug {K E} (z : MapZipper K E) (m : Map K E) : Map K E :=
  match z with
    | Here => m
    | Left r z' => plug z' m :* r
    | Right l z' => l :* plug z' m
  end.

Fixpoint plug' {K E} (z : MapZipper K E) : Map K E :=
  match z with
    | Here => mapEmpty
    | Left r Here => r
    | Left r z' => plug' z' :* r
    | Right l Here => l
    | Right l z' => l :* plug' z'
  end.

Lemma plug'_plug : forall {K E} (z : MapZipper K E), plug' z ~= plug z mapEmpty.
intros. induction z;simpl;
[reflexivity|..];rewrite <- IHz; clear IHz;
(destruct z;[simpl;rewrite ?equivUnit,?equivUnitL|..];reflexivity).
Qed.

Lemma plug_plug' : forall {K E} m (z : MapZipper K E), plug z m ~= m :* plug' z.
induction z;simpl;
[rewrite equivUnit;reflexivity|..];
rewrite IHz;clear IHz.

rewrite equivAssoc. destruct z;[simpl;rewrite equivUnitL|..];reflexivity.
destruct z;rewrite equivComAssoc;[simpl;rewrite equivUnit|..];reflexivity.
Qed.

Lemma same_item {K E} k v m' (z : MapZipper K E):
   plug' z ~= m' -> plug z (k |-> v) ~= k |-> v :* m'.
intros. rewrite <- H. apply plug_plug'.
Qed.

Lemma equiv_item {K E} k v v' m' (z : MapZipper K E):
   v = v' -> plug' z ~= m' -> plug z (k |-> v) ~= k |-> v' :* m'.
intros. subst. rewrite <- H0. apply plug_plug'.
Qed.

Lemma item_test : forall (k1 k2 : nat) (v1 v2 : nat) (m1 : Map nat nat),
    exists m1',
    exists v2',
    k1 |-> v1 :* m1 :* k2 |-> v2 ~= k2 |-> v2' :* k1 |-> v1 :* m1'.
intros. eexists. eexists.
refine (equiv_item (Right (Right Here)) (eq_refl _) _);unfold plug'.
refine (equiv_item (Left Here) (eq_refl _) _);unfold plug'.
reflexivity.
Qed.

Ltac find k m s :=
  match m with
    | @mapItem ?K ?E k _ => let t := constr:(@Here K E) in s t
    | ?l :* ?r =>
         find k l ltac:(fun m => let m' := constr:(Left (r:=r)  m) in s m')
      || find k r ltac:(fun m => let m' := constr:(Right (l:=l) m) in s m')
  end.
Ltac items :=
  match goal with
  |[|- ?m ~= ?k |-> _ :* _] =>
    find k m ltac:(fun t => (apply (same_item t) || apply (equiv_item t));
                             [..|unfold plug';instantiate;items])
  |_ => idtac
  end.

Lemma item_tac_test : forall (k1 k2 k3 : nat) (v1 v2 : nat) (m1 : Map nat nat),
    exists v1', exists v2', exists v3',
    k3 |-> v1 :* k1 |-> v1 :* k2 |-> v1 ~= k2 |-> v2' :* k1 |-> v1' :* k3 |-> v3'.
intros; repeat eexists.
items. apply equivRefl.
Qed.
Print item_tac_test.


Require Import ZF.Axioms.

Notation "??" := (ltac:(assumption)) (only parsing).

Local Lemma and_map_l (B C A : Prop) : (A -> B) -> A /\ C -> B /\ C. Proof. intuition. Qed.
Local Lemma and_map_r (C B A : Prop) : (A -> B) -> C /\ A -> C /\ B. Proof. intuition. Qed.
Local Lemma or_map_l (B C A : Prop) : (A -> B) -> A \/ C -> B \/ C. Proof. intuition. Qed.
Local Lemma or_map_r (C B A : Prop) : (A -> B) -> C \/ A -> C \/ B. Proof. intuition. Qed.
Local Lemma forall_map A (P Q : A -> Prop) : (forall a, P a -> Q a) -> (forall a, P a) -> (forall a, Q a). Proof. intuition. Qed.

Local Lemma nothing_ft e : e in nothing <-> False.
Proof. intuition. apply set_nothing. exists e. auto. Qed.

Local Lemma union_ft e x : e in union x <-> exists y, e in y /\ y in x.
Proof.
  split.
  + apply set_specif.
  + intros [y []].
    apply set_specif.
    split.
    - apply (set_union _ y); auto.
    - exists y; auto.
Qed.

Local Lemma pairing_ft e x y : e in {x, y} <-> e = x \/ e = y.
Proof.
  split; intros p.
  + apply set_specif in p. intuition.
  + apply set_specif.
    intuition; subst;
    apply set_pairing.
Qed.

Local Lemma singleton_ft e x : e in {x,} <-> e = x. Proof. pose (pairing_ft e x x). intuition. Qed.

Local Lemma cup_ft e x y : e in cup x y <-> e in x \/ e in y.
Proof.
  split; intros p.
  + apply union_ft in p as [? [? p]].
    apply pairing_ft in p.
    intuition; subst; auto.
  + apply union_ft.
    destruct p;
    exists x + exists y; intuition; apply pairing_ft; progress intuition.
Qed.

Local Lemma power_ft e x : e in power x <-> e sub x.
Proof.
  split; intros p.
  + apply (set_specif (c_power x) (fun z => z sub x)). auto.
  + apply set_specif.
    split; auto.
    apply set_power. auto.
Qed.

Local Lemma dep_repl_ft e x (F : forall y, y in x -> set) : e in dep_repl x F <-> exists y, exists p, e = F y p.
Proof.
  split; intros p.
  + apply set_repl in p as [y [q i]].
    exists y. exists q.
    set (s := classic (y in x)) in i. destruct s; try contradiction.
    erewrite (prop_ext q). eauto.
  + destruct p as [y [q i]].
    apply set_repl.
    exists y. split; auto.
    set (s := classic (y in x)). destruct s; try contradiction.
    erewrite (prop_ext q) in i. eauto.
Qed.

Ltac inclusion_goal := lazymatch goal with
  | |- _ <-> _ => unfold iff; inclusion_goal
  | |- _ sub _ => unfold subset
  | |- not _ => unfold not; inclusion_goal
  | |- ?p -> ?q => let v := fresh in intros v; inclusion_goal + inclusion_hyp v; revert v
  | |- forall v, ?p => let v := fresh v in intros v; inclusion_goal; revert v
  | |- ?p /\ ?q => (eapply (and_map_l p q); [ let v := fresh in intros v; inclusion_goal; exact v | ])
                || (eapply (and_map_r p q); [ let v := fresh in intros v; inclusion_goal; exact v | ])
  | |- ?p \/ ?q => (eapply (or_map_l p q); [ let v := fresh in intros v; inclusion_goal; exact v | ])
                || (eapply (or_map_r p q); [ let v := fresh in intros v; inclusion_goal; exact v | ])
  | |- exists v, ?p => let A := fresh in let Q := fresh in
                       evar (A : Type); evar (Q : A -> Prop);
                       cut (exists v, Q v);
                       [ let v := fresh in let w := fresh in intros [w v]; exists w; inclusion_goal; exact v | ];
                       subst A Q; cbn
  | |- ?e in c_specif ?x ?P => apply (set_specif x P e)
  | |- ?e in nothing => apply (nothing_ft e)
  | |- ?e in {?x, ?y} => apply (pairing_ft e x y)
  | |- ?e in union ?x => apply (union_ft e x)
  | |- ?e in c_repl ?x ?F => apply (set_repl x F e)
  | |- ?e in dep_repl ?x ?F => apply (dep_repl_ft e x F)
  | |- ?e in {?x,} => apply (singleton_ft e x)
  | |- ?e in cup ?x ?y => apply (cup_ft e x y)
  | |- ?e in cap ?x ?y => apply (set_specif x (fun z => z in y) e)
  | |- ?e in power ?x => apply (power_ft e x)
  end
with inclusion_hyp H := lazymatch type of H with
  | _ <-> _ => unfold iff in H; inclusion_hyp H
  | _ sub _ => unfold subset in H
  | not _ => unfold not in H; inclusion_hyp H
  | ?p -> ?q => let r := fresh in let H' := fresh in evar (r : Prop);
                ( assert (H' : p -> r);
                  [ let v := fresh in intros v; let v' := fresh in pose (v' := H v); inclusion_hyp v'; exact v' | ]
                ) || ( assert (H' : r -> q);
                  [ let v := fresh in intros v; refine (H _); inclusion_goal; exact v | ]
                );
                clear H; rename H' into H; subst r
  | forall v, ?p => let A := fresh in let Q := fresh in
                    evar (A : Type); evar (Q : A -> Prop);
                    cut (forall v, Q v);
                    [ | let v := fresh in intros v; specialize H with v; inclusion_hyp H; exact H ];
                    clear H; intros H; subst A Q; cbn in H
  | ?p /\ ?q => (eapply (and_map_l _ q p) in H; [ | let v := fresh in intros v; inclusion_hyp v; exact v ])
             || (eapply (and_map_r p _ q) in H; [ | let v := fresh in intros v; inclusion_hyp v; exact v ])
  | ?p \/ ?q => (eapply (or_map_l _ q p) in H; [ | let v := fresh in intros v; inclusion_hyp v; exact v ])
             || (eapply (or_map_r p _ q) in H; [ | let v := fresh in intros v; inclusion_hyp v; exact v ])
  | exists v, ?p => let A := fresh in let P := fresh in
                    evar (A : Type); evar (P : A -> Prop);
                    cut (exists v, P v);
                    [ | let v := fresh in let w := fresh in destruct H as [w v]; exists w; inclusion_hyp v; exact v ];
                    clear H; intros H; subst A P; cbn in H
  | ?e in c_specif ?x ?P => apply (set_specif x P e) in H
  | ?e in nothing => apply (nothing_ft e) in H
  | ?e in {?x, ?y} => apply (pairing_ft e x y) in H
  | ?e in union ?x => apply (union_ft e x) in H
  | ?e in c_repl ?x ?F => apply (set_repl x F e) in H
  | ?e in dep_repl ?x ?F => apply (dep_repl_ft e x F) in H
  | ?e in {?x,} => apply (singleton_ft e x) in H
  | ?e in cup ?x ?y => apply (cup_ft e x y) in H
  | ?e in cap ?x ?y => apply (set_specif x (fun z => z in y) e) in H
  | ?e in power ?x => apply (power_ft e x) in H
  end.

Ltac inclusion := inclusion_goal + match goal with H : _ |- _ => inclusion_hyp H end.
Global Ltac unsettle := repeat inclusion.

Global Ltac ext H := lazymatch type of H with
  | ?x = ?y => let H' := fresh in assert (H' : forall z, z in x <-> z in y);
               [ intros ?; split; intros ?; [ rewrite <- H | rewrite H ]; assumption | ];
               clear H; rename H' into H
  end.


(* -------------------------------------------------------------------- *)
(* A very classical axiomatization of real numbers: a discrete real     *)
(* archimedean field with a least upper bound operator.                 *)
(* -------------------------------------------------------------------- *)

From mathcomp Require Import all_ssreflect all_algebra bigenough.
(* ------- *) Require Import boolp Setoid.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import GRing.Theory Num.Theory BigEnough.

(* -------------------------------------------------------------------- *)
Delimit Scope real_scope with real.

Local Open Scope real_scope.
Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Module Real.
Section Mixin.

Variable (R : archiFieldType).

(* Real set non-emptyness. *)
Definition nonempty (E : pred R) :=
  exists x : R, x \in E.

(* Real upper bound set. *)
Definition ub (E : pred R) : pred R :=
  [pred z | `[forall y, (y \in E) ==> (y <= z)]].

(* Real down set (i.e., generated order ideal) *)
(* i.e. down E := { x | exists y, y \in E /\ x <= y} *)
Definition down (E : pred R) : pred R :=
  [pred x | `[exists y, (y \in E) && (x <= y)]].

(* Real set supremum existence condition. *)
Definition has_ub  (E : pred R) := nonempty (ub E).
Definition has_sup (E : pred R) := nonempty E /\ has_ub E.

Record mixin_of : Type := Mixin {
  sup : pred R -> R;
   _  :
    forall E : pred (Num.ArchimedeanField.sort R),
      has_sup E -> sup E \in ub E;
   _  :
    forall (E : pred (Num.ArchimedeanField.sort R)) (eps : R),
      has_sup E -> 0 < eps -> exists2 e : R, E e & (sup E - eps) < e;
   _  :
    forall E : pred (Num.ArchimedeanField.sort R),
      ~ has_sup E -> sup E = 0
}.

End Mixin.

Definition EtaMixin R sup sup_upper_bound sup_adherent :=
  let _ := @Mixin R sup sup_upper_bound sup_adherent in
  @Mixin (Num.ArchimedeanField.Pack (Num.ArchimedeanField.class R) R)
         sup sup_upper_bound sup_adherent.
Section ClassDef.

Record class_of (R : Type) : Type := Class {
  base : Num.ArchimedeanField.class_of R;
  mixin : mixin_of (Num.ArchimedeanField.Pack base R)
}.

Local Coercion base : class_of >-> Num.ArchimedeanField.class_of.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack T c T.
Let xT := let: Pack T _ _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack b0 (m0 : mixin_of (@Num.ArchimedeanField.Pack T b0 T)) :=
  fun bT b & phant_id (Num.ArchimedeanField.class bT) b =>
  fun    m & phant_id m0 m => Pack (@Class T b m) T.

Definition eqType := @Equality.Pack cT xclass xT.
Definition choiceType := @Choice.Pack cT xclass xT.
Definition zmodType := @GRing.Zmodule.Pack cT xclass xT.
Definition ringType := @GRing.Ring.Pack cT xclass xT.
Definition comRingType := @GRing.ComRing.Pack cT xclass xT.
Definition unitRingType := @GRing.UnitRing.Pack cT xclass xT.
Definition comUnitRingType := @GRing.ComUnitRing.Pack cT xclass xT.
Definition idomainType := @GRing.IntegralDomain.Pack cT xclass xT.
Definition numDomainType := @Num.NumDomain.Pack cT xclass xT.
Definition fieldType := @GRing.Field.Pack cT xclass xT.
Definition join_numDomainType := @Num.NumDomain.Pack fieldType xclass xT.
Definition realDomainType := @Num.RealDomain.Pack cT xclass xT.
Definition numFieldType := @Num.NumField.Pack cT xclass xT.
Definition join_realDomainType := @Num.RealDomain.Pack numFieldType xclass xT.
Definition realFieldType := @Num.RealField.Pack cT xclass xT.
Definition archimedeanFieldType := @Num.ArchimedeanField.Pack cT xclass xT.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Num.ArchimedeanField.class_of.
Coercion mixin : class_of >-> mixin_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> GRing.Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> GRing.Ring.type.
Canonical ringType.
Coercion comRingType : type >-> GRing.ComRing.type.
Canonical comRingType.
Coercion unitRingType : type >-> GRing.UnitRing.type.
Canonical unitRingType.
Coercion comUnitRingType : type >-> GRing.ComUnitRing.type.
Canonical comUnitRingType.
Coercion idomainType : type >-> GRing.IntegralDomain.type.
Canonical idomainType.
Coercion numDomainType : type >-> Num.NumDomain.type.
Canonical numDomainType.
Canonical join_numDomainType.
Coercion realDomainType : type >-> Num.RealDomain.type.
Canonical realDomainType.
Coercion fieldType : type >-> GRing.Field.type.
Canonical fieldType.
Coercion numFieldType : type >-> Num.NumField.type.
Canonical numFieldType.
Coercion realFieldType : type >-> Num.RealField.type.
Canonical realFieldType.
Coercion archimedeanFieldType : type >-> Num.ArchimedeanField.type.
Canonical archimedeanFieldType.

Notation realType := type.
Notation RealType T m := (@pack T _ m _ _ id _ id).
Notation RealMixin := EtaMixin.
Notation "[ 'ringType' 'of' T 'for' cT ]" := (@clone T cT _ idfun)
  (at level 0, format "[ 'ringType'  'of'  T  'for'  cT ]") : form_scope.
Notation "[ 'ringType' 'of' T ]" := (@clone T _ _ id)
  (at level 0, format "[ 'ringType'  'of'  T ]") : form_scope.

End Exports.
End Real.

Export Real.Exports.

(* -------------------------------------------------------------------- *)
Definition sup {R : realType} := Real.sup (Real.class R).

Definition nonempty {R : realType} := @Real.nonempty R.
Definition ub       {R : realType} := @Real.ub R.
Definition down     {R : realType} := @Real.down R.
Definition has_ub   {R : realType} := @Real.has_ub R.
Definition has_sup  {R : realType} := @Real.has_sup R.

(* -------------------------------------------------------------------- *)
Section BaseReflect.
Context {R : realType}.

Implicit Types E : pred R.
Implicit Types x : R.

Lemma nonemptyP E : nonempty E <-> exists x, x \in E.
Proof. by []. Qed.

Lemma ubP E x : reflect (forall y, y \in E -> y <= x) (x \in ub E).
Proof. by apply: (iffP (forallbP _))=> h y; apply/implyP/h. Qed.

Lemma downP E x : reflect (exists2 y, y \in E & x <= y) (x \in down E).
Proof.
apply: (iffP (existsbP _))=> [[y /andP[]]|[y]].
  by exists y. by exists y; apply/andP; split.
Qed.

Lemma has_ubP {E} : has_ub E <-> nonempty (ub E).
Proof. by []. Qed.

Lemma has_supP {E} : has_sup E <-> (nonempty E /\ nonempty (ub E)).
Proof. by []. Qed.
End BaseReflect.

(* -------------------------------------------------------------------- *)
Lemma sup_upper_bound {R : realType} (E : pred R):
  has_sup E -> (forall x, x \in E -> x <= sup E).
Proof. by move=> supE; apply/ubP; case: R E supE=> ? [? []]. Qed.

Lemma sup_adherent {R : realType} (E : pred R) (eps : R) :
  has_sup E -> 0 < eps -> exists2 e : R, e \in E & (sup E - eps) < e.
Proof. by case: R E eps=> ? [? []]. Qed.

Lemma sup_out {R : realType} (E : pred R) : ~ has_sup E -> sup E = 0.
Proof. by case: R E => ? [? []]. Qed.

(* -------------------------------------------------------------------- *)
Section IsInt.
Context {R : realType}.

Definition Rint := [qualify a x : R | `[exists z, x == z%:~R]].
Fact Rint_key : pred_key Rint. Proof. by []. Qed.
Canonical Rint_keyed := KeyedQualifier Rint_key.

Lemma Rint_def x : (x \is a Rint) = (`[exists z, x == z%:~R]).
Proof. by []. Qed.

Lemma RintP x : reflect (exists z, x = z%:~R) (x \in Rint).
Proof. exact/(iffP (existsPP (fun x => eqP (y := x%:~R)))). Qed.

Lemma RintC z : z%:~R \is a Rint.
Proof. by apply/RintP; exists z. Qed.

Lemma Rint0 : 0 \is a Rint.
Proof. by rewrite -[0](mulr0z 1) RintC. Qed.

Lemma Rint1 : 1 \is a Rint.
Proof. by rewrite -[1]mulr1z RintC. Qed.

Hint Resolve Rint0 Rint1 RintC.

Lemma Rint_subring_closed : subring_closed Rint.
Proof.
split=> // _ _ /RintP[x ->] /RintP[y ->]; apply/RintP.
by exists (x - y); rewrite rmorphB. by exists (x * y); rewrite rmorphM.
Qed.

Canonical Rint_opprPred := OpprPred Rint_subring_closed.
Canonical Rint_addrPred := AddrPred Rint_subring_closed.
Canonical Rint_mulrPred := MulrPred Rint_subring_closed.
Canonical Rint_zmodPred := ZmodPred Rint_subring_closed.
Canonical Rint_semiringPred := SemiringPred Rint_subring_closed.
Canonical Rint_smulrPred := SmulrPred Rint_subring_closed.
Canonical Rint_subringPred := SubringPred Rint_subring_closed.

Lemma Rint_ler_addr1 (x y : R) : x \is a Rint -> y \is a Rint ->
  (x + 1 <= y) = (x < y).
Proof.
move=> /RintP[xi ->] /RintP[yi ->]; rewrite -{2}[1]mulr1z.
by rewrite -intrD !(ltr_int, ler_int) lez_addr1.
Qed.

Lemma Rint_ltr_addr1 (x y : R) : x \is a Rint -> y \is a Rint ->
  (x < y + 1) = (x <= y).
move=> /RintP[xi ->] /RintP[yi ->]; rewrite -{3}[1]mulr1z.
by rewrite -intrD !(ltr_int, ler_int) ltz_addr1.
Qed.

End IsInt.

(* -------------------------------------------------------------------- *)
Section ToInt.
Context {R : realType}.

Implicit Types x y : R.

Definition Rtoint (x : R) : int :=
  if insub x : {? x | x \is a Rint} is Some Px then
    xchooseb (tagged Px)
  else 0.

Lemma RtointK (x : R): x \is a Rint -> (Rtoint x)%:~R = x.
Proof.
move=> Ix; rewrite /Rtoint insubT /= [RHS](eqP (xchoosebP Ix)).
by congr _%:~R; apply/eq_xchoose.
Qed.

Lemma Rtointz (z : int): Rtoint z%:~R = z.
Proof. by apply/eqP; rewrite -(@eqr_int R) RtointK ?rpred_int. Qed.

Lemma Rtointn (n : nat): Rtoint n%:R = n%:~R.
Proof. by rewrite -{1}mulrz_nat Rtointz. Qed.

Lemma inj_Rtoint : {in Rint &, injective Rtoint}.
Proof. by move=> x y Ix Iy /= /(congr1 (@intmul R 1)); rewrite !RtointK. Qed.
End ToInt.

(* -------------------------------------------------------------------- *)
Section RealDerivedOps.
Variable R : realType.

Implicit Types x y : R.

Definition floor_set x := [pred y | (y \is a Rint) && (y <= x)].

Definition floor x : R := sup (floor_set x).

Definition ifloor x : int := Rtoint (floor x).

Definition range1 (x : R) := [pred y | x <= y < x + 1].
End RealDerivedOps.

(*-------------------------------------------------------------------- *)
Section RealLemmas.

Variables (R : realType).

Implicit Types E : pred R.
Implicit Types x : R.

Lemma sup_ub {E} : has_ub E -> sup E \in ub E.
Proof.
move=> ubE; apply/ubP=> x x_in_E; apply/sup_upper_bound=> //.
by apply/has_supP; split; first by exists x.
Qed.

Lemma sup_total {E} x : has_sup E -> (x \in down E) || (sup E <= x).
Proof.
move=> has_supE; rewrite orbC; case: (lerP (sup E) x)=> hx //=.
have /(sup_adherent has_supE) : 0 < sup E - x by rewrite subr_gt0.
case=> e Ee hlte; apply/downP; exists e => //; move: hlte.
by rewrite opprB addrCA subrr addr0 => /ltrW.
Qed.

Lemma sup_le_ub {E} x : nonempty E -> x \in ub E -> sup E <= x.
Proof.
move=> hasE /ubP leEx; set y := sup E; pose z := (x + y) / 2%:R.
have Dz: 2%:R * z = x + y.
  by rewrite mulrCA divff ?mulr1 // pnatr_eq0.
have ubE: has_sup E by split; last by exists x; apply/ubP.
have /orP [/downP [t Et lezt] | leyz] := sup_total z ubE.
  rewrite -(ler_add2l x) -Dz -mulr2n -[X in _<=X]mulr_natl.
  rewrite ler_pmul2l ?ltr0Sn //; exact/(ler_trans lezt)/leEx.
rewrite -(ler_add2r y) -Dz -mulr2n -[X in X<=_]mulr_natl.
by rewrite ler_pmul2l ?ltr0Sn.
Qed.

Lemma nonemptybP {E} :
  `[< nonempty E >] = `[< exists x : R, x \in E >].
Proof. by apply: (asbool_equiv_eq (nonemptyP _)). Qed.

Lemma nonemptyPn {E} :
  ~ nonempty E <-> (forall x, x \notin E).
Proof.
by apply: asbool_eq_equiv; rewrite asbool_neg nonemptybP asbool_forallNb.
Qed.

Lemma has_ubPn {E} :
  ~ has_ub E <-> (forall x, exists2 y, y \in E & x < y).
Proof. split; last first.
+ move=> h /has_ubP [x /ubP] hle; case/(_ x): h => y /hle.
  by rewrite lerNgt => /negbTE ->.
move/asboolPn; rewrite (asbool_equiv_eq has_ubP).
move/asboolPn/nonemptyPn=> h x; have /ubP {h} := h x.
case/asboolPn/existsp_asboolPn=> y /asboolPn /imply_asboolPn.
by case=> [yE /negP]; rewrite -ltrNge => ltx; exists y.
Qed.

Lemma has_supPn {E} : nonempty E ->
  ~ has_sup E <-> (forall x, exists2 y, y \in E & x < y).
Proof.
move=> nzE; split=> [/asboolPn|]; rewrite ?(asbool_equiv_eq has_supP).
  by rewrite asbool_and (asboolT nzE) /= => /asboolP/has_ubPn.
by move/has_ubPn=> h /has_supP [_].
Qed.

End RealLemmas.

(* -------------------------------------------------------------------- *)
Section FloorTheory.
Variable R : realType.

Implicit Types x y : R.

Lemma has_sup_floor_set x: has_sup (floor_set x).
Proof.
split; [exists (- (Num.bound (-x))%:~R) | exists (Num.bound x)%:~R].
  rewrite inE rpredN rpred_int /= ler_oppl.
  case: (ger0P (-x)) => [/archi_boundP/ltrW//|].
  by move/ltrW/ler_trans; apply; rewrite ler0z.
apply/ubP=> y /andP[_] /ler_trans; apply.
case: (ger0P x)=> [/archi_boundP/ltrW|] //.
by move/ltrW/ler_trans; apply; rewrite ler0z.
Qed.

Lemma sup_in_floor_set x : sup (floor_set x) \in floor_set x.
Proof.
have /sup_adherent /(_ ltr01) [y Fy] := has_sup_floor_set x.
have /sup_upper_bound /(_ _ Fy) := has_sup_floor_set x.
rewrite ler_eqVlt=> /orP[/eqP<-//| lt_yFx].
rewrite ltr_subl_addr -ltr_subl_addl => lt1_FxBy.
pose e := sup (floor_set x) - y; have := has_sup_floor_set x.
move/sup_adherent=> -/(_ e) []; first by rewrite subr_gt0.
move=> z Fz; rewrite /e opprB addrCA subrr addr0 => lt_yz.
have /sup_upper_bound /(_ _ Fz) := has_sup_floor_set x.
rewrite -(ler_add2r (-y)) => /ler_lt_trans /(_ lt1_FxBy).
case/andP: Fy Fz lt_yz=> /RintP[yi -> _].
case/andP=> /RintP[zi -> _]; rewrite -rmorphB /= ltrz1 ltr_int.
rewrite ltr_neqAle => /andP[ne_yz le_yz].
rewrite -[_-_]gez0_abs ?subr_ge0 // ltz_nat ltnS leqn0.
by rewrite absz_eq0 subr_eq0 eq_sym (negbTE ne_yz).
Qed.

Lemma isint_floor x: floor x \is a Rint.
Proof. by case/andP: (sup_in_floor_set x). Qed.

Lemma floorE x : floor x = (ifloor x)%:~R.
Proof. by rewrite /ifloor RtointK ?isint_floor. Qed.

Lemma mem_rg1_floor (x : R) : x \in range1 (floor x).
Proof.
rewrite inE; have /andP[_ ->] /= := sup_in_floor_set x.
case: (boolP (floor x + 1 \in floor_set x)); last first.
  by rewrite inE negb_and -ltrNge rpredD // ?(Rint1, isint_floor).
by move/sup_upper_bound=> -/(_ (has_sup_floor_set x)); rewrite ger_addl ler10.
Qed.

Lemma floor_ler (x : R) : floor x <= x.
Proof. by case/andP: (mem_rg1_floor x). Qed.

Lemma floorS_gtr (x : R) : x < floor x + 1.
Proof. by case/andP: (mem_rg1_floor x). Qed.

Lemma range1z_inj (x : R) (m1 m2 : int) :
  x \in range1 m1%:~R -> x \in range1 m2%:~R -> m1 = m2.
Proof.
move=> /andP[m1x x_m1] /andP[m2x x_m2].
wlog suffices: m1 m2 m1x {x_m1 m2x} x_m2 / (m1 <= m2)%R.
  by move=> ih; apply/eqP; rewrite eqr_le !ih.
rewrite -(ler_add2r 1) lez_addr1 -(@ltr_int R) intrD.
by apply/(ler_lt_trans m1x).
Qed.

Lemma range1rr (x : R) : x \in range1 x.
Proof. by rewrite inE lerr /= ltr_addl ltr01. Qed.

Lemma range1zP (m : int) (x : R) :
  reflect (floor x = m%:~R) (x \in range1 m%:~R).
Proof.
apply: (iffP idP)=> [h|<-]; [apply/eqP | by apply/mem_rg1_floor].
rewrite floorE eqr_int; apply/eqP/(@range1z_inj x) => //.
by rewrite -floorE mem_rg1_floor.
Qed.

Lemma floor_natz (x : int) : floor x%:~R = x%:~R :> R.
Proof. by apply/range1zP/range1rr. Qed.

Lemma floor0 : floor 0 = 0 :> R.
Proof. by rewrite -{1}(mulr0z 1) floor_natz. Qed.

Lemma floor1 : floor 1 = 1 :> R.
Proof. by rewrite -{1}(mulr1z 1) floor_natz. Qed.

Lemma ler_floor (x y : R) : x <= y -> floor x <= floor y.
Proof.
move=> le_xy; case: lerP=> //=; rewrite -Rint_ler_addr1 ?isint_floor //.
move/(ltr_le_trans (floorS_gtr y))/ltr_le_trans/(_ (floor_ler x)).
by rewrite ltrNge le_xy.
Qed.

Lemma floor_ge0 (x : R) : (0 <= floor x) = (0 <= x).
Proof.
apply/idP/idP; last by move/ler_floor; rewrite floor0.
by move/ler_trans=> -/(_ _ (floor_ler x)).
Qed.

Lemma ifloor_ge0 (x : R) : (0 <= ifloor x) = (0 <= x).
Proof. by rewrite -(@ler_int R) -floorE floor_ge0. Qed.
End FloorTheory.

(* -------------------------------------------------------------------- *)
Section Sup.
Context {R : realType}.

Lemma eq_ub (S1 S2 : pred R) : S2 =i S1 -> ub S2 =i ub S1.
Proof.
move=> eq_12 x; apply/ubP/ubP=> h y yS; apply/h;
  by rewrite (eq_12, =^~ eq_12).
Qed.

Lemma eq_has_sup (S1 S2 : pred R) :
  S2 =i S1 -> has_sup S2 -> has_sup S1.
Proof.
move=> eq_12 /has_supP[[x xS2] [u uS2]]; apply/has_supP; split.
  by exists x; rewrite -eq_12. by exists u; rewrite (@eq_ub S2).
Qed.

Lemma eq_has_supb (S1 S2 : pred R) :
  S2 =i S1 -> `[< has_sup S2 >] = `[< has_sup S1 >].
Proof. by move=> eq_12; apply/asboolP/asboolP; apply/eq_has_sup. Qed.

Lemma eq_sup (S1 S2 : pred R) : S2 =i S1 -> sup S2 = sup S1.
Proof.
wlog: S1 S2 / (sup S1 <= sup S2) => [wlog|le_S1S2] eq_12.
  by case: (lerP (sup S1) (sup S2)) => [|/ltrW] /wlog ->.
move: le_S1S2; rewrite ler_eqVlt => /orP[/eqP->//|lt_S1S2].
case/boolP: `[< has_sup S2 >] => [/asboolP|] h2; last first.
  by rewrite !sup_out // => /asboolPn; rewrite -?(eq_has_supb eq_12).
pose x : R := sup S2 - sup S1; have gt0_x: 0 < x by rewrite subr_gt0.
have [e eS2] := sup_adherent h2 gt0_x; rewrite subKr => lt_S1e.
have /(eq_has_sup eq_12) h1 := h2; have := eS2; rewrite eq_12.
by move/sup_upper_bound=> -/(_ h1); rewrite lerNgt lt_S1e.
Qed.

Lemma sup1 (c : R) : sup (pred1 c) = c.
Proof.
have hs: has_sup (pred1 c); first (apply/has_supP; split; exists c).
  by rewrite inE eqxx. by apply/ubP => y; rewrite inE => /eqP->.
apply/eqP; rewrite eqr_le sup_upper_bound ?inE // andbT.
apply/sup_le_ub; first by exists c; rewrite inE eqxx.
by apply/ubP=> y; rewrite inE => /eqP ->.
Qed.
End Sup.

(* -------------------------------------------------------------------- *)
Section ExtendedReals.
Variable (R : realType).

Inductive er := ERFin of R | ERPInf | ERNInf.

Coercion real_of_er (x : er) :=
  if x is ERFin v then v else 0.
End ExtendedReals.

Notation "\+inf" := (@ERPInf _).
Notation "\-inf" := (@ERNInf _).
Notation "x %:E" := (@ERFin _ x) (at level 2, format "x %:E").

Notation "{ 'ereal' R }" := (er R) (format "{ 'ereal'  R }").

Bind    Scope ereal_scope with er.
Delimit Scope ereal_scope with E.

(* -------------------------------------------------------------------- *)
Section ERealCode.
Variable (R : realType).

Definition code (x : {ereal R}) :=
  match x with
  | x%:E  => GenTree.Node 0 [:: GenTree.Leaf x]
  | \+inf => GenTree.Node 1 [::]
  | \-inf => GenTree.Node 2 [::]
  end.

Definition decode (x : GenTree.tree R) : option {ereal R} :=
  match x with
  | GenTree.Node 0 [:: GenTree.Leaf x] => Some x%:E
  | GenTree.Node 1 [::] => Some \+inf
  | GenTree.Node 2 [::] => Some \-inf
  | _ => None
  end.

Lemma codeK : pcancel code decode.
Proof. by case. Qed.

Definition ereal_eqMixin := PcanEqMixin codeK.
Canonical  ereal_eqType  := EqType {ereal R} ereal_eqMixin.
Definition ereal_choiceMixin := PcanChoiceMixin codeK.
Canonical  ereal_choiceType  := ChoiceType {ereal R} ereal_choiceMixin.
End ERealCode.

Lemma eqe {R : realType} (x1 x2 : R) :
  (x1%:E == x2%:E) = (x1 == x2).
Proof. by apply/eqP/eqP=> [[]|->]. Qed.

(* -------------------------------------------------------------------- *)
Section ERealOrder.
Context {R : realType}.

Definition lee (x1 x2 : {ereal R}) :=
  match x1, x2 with
  | \-inf, _ | _, \+inf => true
  | \+inf, _ | _, \-inf => false

  | x1%:E, x2%:E => (x1 <= x2)
  end.

Definition lte (x1 x2 : {ereal R}) :=
  match x1, x2 with
  | \-inf, \-inf | \+inf, \+inf => false
  | \-inf, _     | _    , \+inf => true
  | \+inf, _     | _    , \-inf => false

  | x1%:E, x2%:E => (x1 < x2)
  end.
End ERealOrder.

Notation "x <= y" := (lee x y) : ereal_scope.
Notation "x < y"  := (lte x y) : ereal_scope.

(* -------------------------------------------------------------------- *)
Section ERealOrderTheory.
Context {R : realType}.

Local Open Scope ereal_scope.

Implicit Types x y z : {ereal R}.

Local Tactic Notation "elift" constr(lm) ":" ident(x) :=
  by case: x => [?||]; first by rewrite ?eqe; apply: lm.

Local Tactic Notation "elift" constr(lm) ":" ident(x) ident(y) :=
  by case: x y => [?||] [?||]; first by rewrite ?eqe; apply: lm.

Lemma leee x : x <= x.
Proof. by elift lerr: x. Qed.

Lemma lteW x y : x < y -> x <= y.
Proof. by elift ltrW: x y. Qed.

Lemma leeNgt x y : (x <= y) = ~~ (y < x).
Proof. by elift lerNgt: x y. Qed.

Lemma lteNgt x y : (x < y) = ~~ (y <= x).
Proof. by elift ltrNge: x y. Qed.

Lemma lee_eqVlt x y : (x <= y) = ((x == y) || (x < y)).
Proof. by elift ler_eqVlt: x y. Qed.

Lemma lte_neqAle x y : (x < y) = ((x != y) && (x <= y)).
Proof. by elift ltr_neqAle: x y. Qed.

Lemma lee_fin (x y : R) : (x%:E <= y%:E)%E = (x <= y)%R.
Proof. by []. Qed.

Lemma lte_fin (x y : R) : (x%:E < y%:E)%E = (x < y)%R.
Proof. by []. Qed.
End ERealOrderTheory.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Problem(s):
    Semi-unification
*)

Require Import List.

From Undecidability.SemiU Require Import SemiU_prelim.

(* inequality: s ≤ t *)
Definition inequality : Set := (term * term).

(* φ solves s ≤ t, if there is ψ such that ψ (φ (s)) = φ (s) *)
Definition solution (φ : valuation) : inequality -> Prop :=
  fun '(s, t) => exists (ψ : valuation), substitute ψ (substitute φ s) = substitute φ t.

(* is there a substitution φ that solves all inequalities? *)
Definition SemiU (p: list inequality) :=
  exists (φ: valuation), forall (c: inequality), In c p -> solution φ c.


Require Import ZArith.
Require Import ASN1FP.Types.BitContainer ASN1FP.Types.Bitstring.

(** * container tuples *)

(* nbs - normal bitstring (i.e. not a special value) *)
Inductive BER_nbs :=
| short_nbs
    (id co : cont8)
    (t s : cont1) (bb ff ee : cont2)
    (e : container (8 * (c2n ee + 1))) (m : container (8*((c2n co) - (c2n ee) - 2)))
    (VS1 : c2z id = real_id_b) (VS2 : c2z t = 1) (VS3 : c2z ee <= 2) (VS4 : 1 <= c2z m)
    (VS5 : c2z co <= 127)
| long_nbs
    (id co : cont8)
    (t s : cont1) (bb ff ee : cont2)
    (eo : cont8)
    (e : container (8*(c2n eo))) (m : container (8 * ((c2n co) - (c2n eo) - 2)))
    (VL1 : c2z id = real_id_b) (VL2 : c2z t = 1) (VL3 : c2z ee = 3) (VL4 : 1 <= c2z m)
    (VL5 : c2z co <= 127).

Inductive BER_bs_aux :=
| special_aux (val : BER_special) : BER_bs_aux
| normal_aux (b : BER_nbs) : BER_bs_aux.


(**
  Ciro Iván García López
  Tesis de Maestría
  Session Type Systems Verification
  Unam - 2021

  This file contains the definitions for the processes.
*)
From Coq Require Import Lists.List.
Import ListNotations.
From Coq Require Import Lia.

From Tmcod Require Import Defs_Process.
From Tmcod Require Import Defs_Tactics.
From Tmcod Require Import Facts_Names.
From Tmcod Require Import Facts_Process.

(**
*)
Lemma List_Sk_char :
forall (k : nat)(L : list nat),
(length L) = S k ->
(exists (x : nat)(L0 : list nat), L = x :: L0 /\ (length L0) = k).
Proof.
  intros.
  destruct L.
  + simpl in H.
    lia.
  + exists n.
    exists L.
    auto.
Qed.
#[global]
Hint Resolve List_Sk_char : Piull.

(**
*)
Ltac ListEasyInduction k L H HL IHk:=
  induction k; intros;
  try rewrite length_zero_iff_nil in H;
    try rewrite H;
   try specialize (List_Sk_char k L H) as HL;
    try destruct HL as [x0 [ L0 [HL HT]]];
    try rewrite HL;
    try simpl;
    try rewrite IHk; Piauto.

(**
*)
Lemma MOpen_Name_FName :
forall (k x : nat)( L : list nat),
(length L) = k ->
MOpen_Name_Rec k L (FName x) = FName x.
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Name_FName : Piull.

(**
*)
Lemma MOpen_Name_BName_Gt :
forall (k i : nat)(L : list nat),
(length L) = k -> k <= i ->
MOpen_Name_Rec k L (BName i) = (BName i).
Proof.
  intro.
  induction k; intros.
  + rewrite length_zero_iff_nil in H.
    rewrite H.
    auto.
  + specialize (List_Sk_char k L H) as HL.
    destruct HL as [x0 [ L0 [HL HT]]].
    rewrite HL.
    simpl.
    rewrite IHk; try lia.
    rewrite Open_Name_BName_Gt; auto.
Qed.
#[global]
Hint Resolve MOpen_Name_BName_Gt : Piull.

(**
*)
Lemma MOpen_Name_Result :
forall (k : nat)(L : list nat)(x : Name),
(length L) = k -> lca_name k x ->
exists (x0 : nat), ( MOpen_Name_Rec k L x) = FName x0.
Proof.
  induction k; intros.
  + apply Lca_Zero_Lc_Name in H0.
    apply length_zero_iff_nil in H.
    rewrite H.
    simpl.
    inversions H0.
    exists x0.
    auto.
  + inversions H0.
    - rewrite MOpen_Name_FName;
       try exists x0; auto.
    - specialize (List_Sk_char k L H) as HL.
      destruct HL as [x [ L0 [HL HT]]].
      rewrite HL.
      simpl.
      assert (HA : k = i \/ i < k). { lia. }
      destruct HA.
      * assert ( HB: k <= i ). { lia. }
        rewrite MOpen_Name_BName_Gt; auto.
        rewrite Open_Name_BName_Eq; auto.
        exists x; auto.
      * assert (Hk : lca_name k ((BName i)) ).
        constructor; auto.
        specialize (IHk L0 (BName i) HT Hk).
        destruct IHk.
        rewrite H3.
        simpl.
        exists x0.
        auto.
Qed.
#[global]
Hint Resolve MOpen_Name_Result : Piull.

(**
*)
Lemma MOpen_Name_Rec_lc :
forall (k : nat)(L : list nat)(x : Name),
(length L) = k -> lca_name k x ->
lc_name ( MOpen_Name_Rec k L x).
Proof.
  intros.
  specialize (MOpen_Name_Result k L x H H0) as HA.
  destruct HA as [x0 HA].
  rewrite HA.
  constructor.
Qed.
#[global]
Hint Resolve MOpen_Name_Rec_lc : Piull.

(**
*)
Lemma M2Open_MOpen :
forall (k x : nat)(L : list nat)(P : Process),
(length L) = k ->
({0 ~> x} M2Open_Rec k L P) = MOpen_Rec (S k) (L ++ (x :: nil)) P.
Proof.
  induction k.
  + intros.
    rewrite length_zero_iff_nil in H.
    rewrite H.
    auto.
  + intros.
    specialize (List_Sk_char k L H) as HL.
    destruct HL as [x0 [ L0 [HL HT]]].
    rewrite HL.
    simpl.
    rewrite <- IHk; auto.
    rewrite Exchange_Open; auto.
Qed.
#[global]
Hint Resolve M2Open_MOpen : Piull.

(**
*)
Lemma MOpen_Pzero :
forall (k : nat)(L : list nat),
(length L) = k -> MOpen_Rec k L (θ) = θ.
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Pzero : Piull.

(**
*)
Lemma MOpen_Fuse :
forall (k : nat)(L : list nat)(x y : Name),
(length L) = k ->
MOpen_Rec k L ([x ←→ y]) = [(MOpen_Name_Rec k L x) ←→ (MOpen_Name_Rec k L y)].
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Fuse : Piull.

(**
*)
Lemma MOpen_Parallel :
forall (k : nat)(L : list nat)( P Q : Process),
(length L) = k ->
MOpen_Rec k L (P ↓ Q) = (MOpen_Rec k L P) ↓ (MOpen_Rec k L Q).
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Parallel : Piull.

(**
*)
Lemma MOpen_Chan_output :
forall (k : nat)(L : list nat)( x y : Name)(P : Process),
(length L) = k ->
MOpen_Rec k L (x « y »· P) = (MOpen_Name_Rec k L x) « (MOpen_Name_Rec k L y) »· (MOpen_Rec k L P).
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_output : Piull.

(**
*)
Lemma MOpen_Chan_zero :
forall (k : nat)(L : list nat)(x : Name),
(length L) = k ->
MOpen_Rec k L (x ·θ) = (MOpen_Name_Rec k L x) ·θ.
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_zero : Piull.

(**
*)
Lemma MOpen_Chan_close :
forall (k : nat)(L : list nat)(x : Name)(P : Process),
(length L) = k ->
MOpen_Rec k L (x ()·P) = (MOpen_Name_Rec k L x) ()·(MOpen_Rec k L P).
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_close : Piull.

(**
*)
Lemma MOpen_Chan_res :
forall (k : nat)(L : list nat)(P : Process),
(length L) = k ->
MOpen_Rec k L (ν P) = (ν M2Open_Rec k L P).
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_res : Piull.

(**
*)
Lemma MOpen_Chan_input :
forall (k : nat)(L : list nat)(x : Name)(P : Process),
(length L) = k ->
MOpen_Rec k L (x · P) = (MOpen_Name_Rec k L x) · (M2Open_Rec k L P).
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_input : Piull.

(**
*)
Lemma MOpen_Chan_replicate :
forall (k : nat)(L : list nat)(x : Name)(P : Process),
(length L) = k ->
MOpen_Rec k L (x !· P) = (MOpen_Name_Rec k L x) !· (M2Open_Rec k L P).
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_replicate : Piull.

(**
*)
Theorem Lca_Lc_Process_MOpen :
forall (P : Process)(k : nat)(L : list nat),
(length L) = k ->
lca k P -> lc (MOpen_Rec k L P).
Proof.
  induction P; intros; inversions H0.
  + rewrite MOpen_Pzero; constructor.
  + rewrite MOpen_Fuse; auto.
    constructor;
    apply MOpen_Name_Rec_lc; auto.
  + rewrite MOpen_Parallel; constructor; auto.
  + rewrite MOpen_Chan_output; auto.
    constructor;
    try apply MOpen_Name_Rec_lc; auto.
  + rewrite MOpen_Chan_zero; auto.
    constructor;
    try apply MOpen_Name_Rec_lc; auto.
  + rewrite MOpen_Chan_close; auto.
    constructor;
    try apply MOpen_Name_Rec_lc; auto.
  + rewrite MOpen_Chan_res; auto.
    constructor.
    intros.
    rewrite M2Open_MOpen; auto.
    apply IHP; auto.
    rewrite app_length; simpl; lia.
  + rewrite MOpen_Chan_input; auto.
    inversions H0.
    constructor;
    try apply MOpen_Name_Rec_lc; auto.
    intros.
    rewrite M2Open_MOpen; auto.
    apply IHP; auto.
    rewrite app_length; simpl; lia.
  + rewrite MOpen_Chan_replicate; auto.
    inversions H0.
    constructor;
    try apply MOpen_Name_Rec_lc; auto.
    intros.
    rewrite M2Open_MOpen; auto.
    apply IHP; auto.
    rewrite app_length; simpl; lia.
Qed.
#[global]
Hint Resolve Lca_Lc_Process_MOpen : Piull.

(**
*)
Lemma MOpen_Chan_zero_FName_NoMOpenName :
forall (k x : nat)( L : list nat),
(length L) = k ->
MOpen_Rec k L (FName x ·θ) = FName x ·θ.
Proof.
  ListEasyInduction k L H HL IHk.
Qed.
#[global]
Hint Resolve MOpen_Chan_zero_FName_NoMOpenName : Piull.

(*
Lemma MOpen_Chan_zero_BName_Eq_NoMOpenName :
forall (k i : nat)(L : list nat),
(length L) = k -> k <= i ->
MOpen_Rec k L (BName i ·θ) = (BName i ·θ).
Proof.
  induction k; intros.
  + rewrite length_zero_iff_nil in H.
    rewrite H.
    auto.
  + specialize (List_Sk_char k L H) as HL.
    destruct HL as [x0 [ L0 [HL HT]]].
    rewrite HL.
    simpl.
    rewrite IHk; auto.
    simpl.
    admit.
    lia.
Admitted.

(*
*)
Lemma MOpen_Chan_zero_NoMOpenName :
forall (k : nat)(L : list nat)(x : Name),
(length L) = k -> lca k (x·θ) ->
exists (y : nat), MOpen_Rec k L (x ·θ) = (FName y)·θ.
Proof.
  induction k.
  + intros.
    inversions H0.
    apply Lca_Zero_Lc_Name in H3.
    inversions H3.
    exists x0.
    rewrite length_zero_iff_nil in H.
    rewrite H.
    auto.
  + intros.
    inversions H0.
    inversions H3.
    - exists x0.
      rewrite MOpen_Chan_zero_FName_NoMOpenName; auto.
    - specialize (List_Sk_char k L H) as HL.
      destruct HL as [x [ L0 [HL HT]]].
      rewrite HL.
      simpl.
      assert (HA : k = i \/ i < k). { lia. }
      destruct HA.
      * assert ( HB: k <= i ). { lia. }
        specialize (MOpen_Chan_zero_BName_Eq k i L0 HT HB) as HC.
        rewrite HC.
        simpl.
        admit.
      * assert (Hk : lca k ((BName i) ·θ) ).
        constructor; constructor; auto.
        specialize (IHk L0 (BName i) HT Hk).
        destruct IHk.
        rewrite H4;
        simpl.
        exists x0.
        auto.
Admitted.

 *)