From Undecidability.Shared.Libs.PSL Require Import Base FiniteTypes.
Require Import Lia.
From Complexity.Libs Require Import MorePrelim PSLCompat.

(** * Covering Cards *)
(*
  Covering Cards is a string-based problem.
  We are given an initial string and ask whether this string can be "rewritten" to another string of the same length in exactly t covering steps.
  CC-steps (rewrites) are constrained by a set of covering cards: Each card has constant width w and consists of a premise and a conclusion.
  In order for a CC-step from a string A to a string B to be valid, at each multiple of an offset o in the strings A and B, a card needs to be covering,
  i.e. there needs to exist some card the premise of which matches A at that offset and the conclusion of which matches B at that offset.

  Moreover, we have a final constraint: The final string F which is reaches after t steps should satisfy a substring constraint.
  We are given a set of substrings and one of those strings needs to be a substring of F at an offset which is a muliple of o.

  Abstractly, the offset o can be interpreted in the follocardg way: o subsequent symbols together form an abstract symbol.
  Therefore we impose constraints on the relation between o, w and the length of the strings, namely that o symbols always belong together.
*)

(** a single covering card *)
Inductive CCCard (Sigma : Type):= {
                                prem : list Sigma;
                                conc : list Sigma
                              }.

Inductive CC := {
               Sigma : finType;
               offset : nat;
               width : nat;
               init : list Sigma;  (* the length is encoded implicitly as the length of init*)
               cards : list (CCCard Sigma);
               final : list (list Sigma);
               steps : nat
             }.

(**the cards need to have a size of width *)
Definition CCCard_of_size (X : Type) (card : CCCard X) (k : nat) := |prem card| = k /\ |conc card| = k.

Definition CCCard_of_size_dec (X : Type) width (card : CCCard X) := Nat.eqb (|prem card|) width && Nat.eqb (|conc card|) width.
Lemma CCCard_of_size_dec_correct (X : Type) width (card : CCCard X) : CCCard_of_size_dec width card = true <-> CCCard_of_size card width.
Proof.
  unfold CCCard_of_size, CCCard_of_size_dec. rewrite andb_true_iff. rewrite <- !(reflect_iff _ _ (Nat.eqb_spec _ _ )). easy.
Qed.

(** We impose a number of syntactic constraints; instances not satisfying these constraints do not behave in an intuitive way *)
Definition CC_wellformed (c : CC) :=
  width c > 0
  /\ offset c > 0
  /\ (exists k, k > 0 /\ width c = k * offset c) (*this is in line with the abstract interpretation of seeing offset symbols as one *)
  /\ length (init c) >= width c (*we do not want vacuous coverings *)
  /\ (forall card, card el cards c -> CCCard_of_size card (width c))
  /\ (exists k, length (init c) = k * offset c).

Definition CC_wf_dec (pr : CC) :=
  leb 1 (width pr)
  && leb 1 (offset pr)
  && Nat.eqb (Nat.modulo (width pr) (offset pr)) 0
  && leb (width pr) (|init pr|)
  && forallb (CCCard_of_size_dec (width pr)) (cards pr)
  && Nat.eqb (Nat.modulo (|init pr|) (offset pr)) 0.

Lemma CC_wf_dec_correct (pr : CC) : CC_wf_dec pr = true <-> CC_wellformed pr.
Proof.
  unfold CC_wf_dec, CC_wellformed. rewrite !andb_true_iff, !and_assoc.
  rewrite !leb_iff. rewrite <- !(reflect_iff _ _ (Nat.eqb_spec _ _ )).
  rewrite !forallb_forall.
  setoid_rewrite CCCard_of_size_dec_correct.
  split; intros; repeat match goal with [H : _ /\ _ |- _] => destruct H end;
  repeat match goal with [ |- _ /\ _ ] => split end; try easy.
  - apply Nat.mod_divide in H1 as (k & H1); [ | lia].
    exists k; split; [ | apply H1 ]. destruct k; cbn in *; lia.
  - apply Nat.mod_divide in H4 as (k & H4); [ | lia].  exists k; apply H4.
  - apply Nat.mod_divide; [ lia | ]. destruct H1 as (k & _ & H1). exists k; apply H1.
  - apply Nat.mod_divide; [ lia | ]. apply H4.
Qed.

(** We now give a semantics to CC instances *)
Section fixX.
  Variable (X : Type).
  Variable (offset : nat).
  Variable (width : nat).
  Variable (cards : list (CCCard X)).

  Context (G0 : width > 0).

  Local Set Default Proof Using "Type".

  (** The final constraint*)
  (** This is defined in terms of the offset: there must exist an element of a list of strings final which is a substring of the the string s at a multiple of offset *)
  Definition satFinal l (final : list (list X)) s :=
    exists subs k, subs el final /\ k * offset <= l /\  prefix subs (skipn (k * offset) s).

  (** rewrites inside a string *)
  Definition coversHead (X : Type) (card : CCCard X) a b := prefix (prem card) a /\ prefix (conc card) b.

  Definition coversAt (card : CCCard X) (i : nat) a b := coversHead card (skipn i a) (skipn i b).
  Lemma coversAt_head card a b : coversHead card a b <-> coversAt card 0 a b.
  Proof.
    clear G0. unfold coversAt.
    rewrite <- firstn_skipn with (n:= 0) (l:= a) at 1.
    rewrite <- firstn_skipn with (n:= 0) (l:= b) at 1.
    repeat rewrite firstn_O; now cbn.
  Qed.

  Lemma coversAt_step (card : CCCard X) a b u v (i:nat) : length u = offset -> length v = offset -> coversAt card i a b <-> coversAt card (i + offset) (u ++ a) (v ++ b).
  Proof.
    clear G0. intros. unfold coversAt.
    rewrite Nat.add_comm. now repeat rewrite skipn_add.
  Qed.

  (** ** Validity of a rewrite *)
  (** We use an inductive definition; the main motivation behind this definition is to only have a coversHead premise in one case as this leads to fewer cases in proofs.
      The drawback of this definition is that it allows vacuous rewrites (using only the first two constructors); but if the two strings have a length of at least width, this is not a problem. *)
  Inductive valid: list X -> list X -> Prop :=
  | validB: valid [] []
  | validSA a b u v :
      valid a b
      -> length a < width - offset
      -> length u = offset
      -> length v = offset
      -> valid (u++ a) (v++ b)
  | validS a b u v card:
      valid a b
      -> length u = offset
      -> length v = offset
      -> card el cards
      -> coversHead card (u ++ a) (v ++ b)
      -> valid (u ++ a) (v ++ b).

  Lemma valid_length_inv a b : valid a b -> length a = length b.
  Proof.
    clear G0. induction 1; cbn. reflexivity.
    all: repeat rewrite app_length; firstorder; nia.
  Qed.

  (** We can make a step to any string if the length is less than width *)
  Lemma valid_vacuous (a b : list X) m: |a| = |b| -> |a| < width -> |a| = m * offset -> valid a b.
  Proof.
    clear G0.
    revert a b. induction m as [ | m IHm]; intros.
    - cbn in H1. destruct a; [ | cbn in H1; congruence]. destruct b; [ | cbn in H; congruence ].  constructor.
    - cbn in H1. assert (offset <= |a|) by lia. apply list_length_split1 in H2 as (s1 & s2 & H3 & H4 & H5).
      assert (offset <= |b|) as H2 by lia. apply list_length_split1 in H2 as (s3 & s4 & H6 & H7 & H8).
      rewrite H5, H8. constructor 2. 2-4: lia.
      subst. apply IHm; rewrite !app_length in *; lia.
  Qed.

  Lemma valid_multiple_of_offset a b : valid a b -> exists k, |a| = k * offset.
  Proof.
    clear G0.
    induction 1 as [ | a b u v ? IH ? ? ? | a b u v card ? IH ? ? ? ?].
    exists 0; now cbn.
    all: setoid_rewrite app_length; destruct IH as (k & ->); exists (S k); nia.
  Qed.

  (** A more direct characterisation which does not allow vacuous rewrites, making some proofs simpler. *)
  (** Its drawback is that it uses coversHead in two cases, which makes many proofs more complicated *)
  Inductive validDirect: list X -> list X -> Prop :=
  | validDirectB a b card :
    |a| = |b|
    -> |a| = width
    -> card el cards
    -> coversHead card a b
    -> validDirect a b
  | validDirectS a b u v card:
      validDirect a b
      -> length u = offset
      -> length v = offset
      -> card el cards
      -> coversHead card (u ++ a) (v ++ b)
      -> validDirect (u ++ a) (v ++ b).
  Hint Constructors validDirect : core.

  Variable (A0 : exists k, k > 0 /\ width = k * offset).
  Variable (A1 : offset > 0).
  Lemma validDirect_valid a b : validDirect a b <-> valid a b /\ |a| >= width.
  Proof using G0 A1 A0.
    split.
    - induction 1 as [a b card H H0 H1 H2 | a b u v card H IH H0 H1 H2 H3].
      + split; [ | lia].
        assert (offset <= width) as H3 by (destruct A0 as (? & ? & ?); nia).
        rewrite <- H0 in H3. assert (offset <= |b|) as H4 by lia.
        apply list_length_split1 in H3 as (a1 & a2 & H3 & _ & ->).
        apply list_length_split1 in H4 as (b1 & b2 & H4 & _ & ->).
        econstructor; [ | lia | lia | apply H1| apply H2].
        rewrite !app_length in *.
        destruct A0 as (k & _ & ->).
        eapply valid_vacuous; try lia. rewrite H3 in H0. assert (|a2| = (k-1) * offset) as H6 by nia. apply H6.
      + destruct IH as (IH & H4). split; [ | rewrite app_length; lia].
        econstructor 3; [ apply IH | apply H0 | apply H1 | apply H2 | apply H3].
    - intros (H1 & H2).
      induction H1 as [ | a b u v H IH H0 H1 H3 | a b u v card H IH H0 H1 H3 H4];
          cbn in H2; [ lia | rewrite app_length in H2; lia| ].
      destruct (le_lt_dec width (|a|)).
      + apply IH in l. eauto.
      + clear IH. assert (|u++a| = width).
        { apply valid_multiple_of_offset in H as (ak & H). destruct A0 as (k & A2 & ->).
          rewrite app_length in *. enough (k = S ak) by nia. nia.
        }
        econstructor 1; eauto. apply valid_length_inv in H. now rewrite !app_length.
  Qed.

  (** We can give an explicit characterisation which better captures the original intuition: a rewrite carddow has to hold at every multiple of offset. *)
  Definition validExplicit a b := length a = length b
    /\ (exists k, length a = k * offset)
    /\ forall i, 0 <= i < length a + 1 - width /\ (exists j, i = j * offset)
           -> exists card, card el cards /\ coversAt card i a b.

  Lemma valid_iff a b :
    valid a b <-> validExplicit a b.
  Proof using G0.
    unfold validExplicit. clear A0 A1. split.
    - induction 1.
      + split; [now cbn |split; [now exists 0 | ] ]. intros. cbn [length] in H. lia.
      + specialize (valid_length_inv H) as H'. split; [ repeat rewrite app_length; now rewrite H', H1, H2 | ].
        destruct IHvalid as (IH1 & IH2 & IH3).
        split.
        1: { destruct IH2 as (k & IH2). exists (S k). rewrite app_length; lia. }
        rewrite app_length; intros. lia.
      + destruct IHvalid as (IH1 & IH2 & IH3). split; [repeat rewrite app_length; firstorder;nia | ].
        split.
        1: { destruct IH2 as (k & IH2). exists (S k). rewrite app_length; lia. }
        rewrite app_length. intros i (iH1 & (j & iH2)). destruct j.
        * exists card. split; [assumption | ]. rewrite Nat.mul_0_l in iH2. rewrite iH2 in *. now rewrite <- coversAt_head.
        * cbn in iH2. assert (0 <= i - offset < (|a|) + 1 - width) by lia.
          assert (exists j, i - offset = j * offset) by (exists j; lia).
          specialize (IH3 (i -offset) (conj H4 H5)) as (card' & F1 & F2).
          exists card'; split; [assumption | ]. rewrite (@coversAt_step card' a b u v (i -offset) H0 H1) in F2. rewrite Nat.sub_add in F2; [assumption | lia].
    - intros (H1 & (k & H2) & H3). revert a b H1 H2 H3. induction k; intros.
      + rewrite Nat.mul_0_l in H2; rewrite H2 in *. inv_list. constructor.
      + cbn in H2. rewrite H2 in H1; symmetry in H1.
        apply length_app_decompose in H2 as (u & a' & -> & H2 & H4).
        apply length_app_decompose in H1 as (v & b' & -> & H1 & H5).
        destruct (le_lt_dec (width - offset) (length a')).
        * (*have to find a carddow to apply*)
          rewrite app_length in H3.
          assert (0 <= 0 < (|u|) + (|a'|) + 1 - width) by lia.
          assert (exists j, 0 = j * offset) as H' by (exists 0; lia).
          destruct (H3 0 (conj H H')) as (card & F1 & F2%coversAt_head).
          eapply (@validS a' b' u v card). 2-5: assumption.
          apply IHk; [lia | apply H4 | ].
          intros i (H0 & (j & H6)). assert (0 <= i + (|u|) < (|u|) + (|a'|) + 1 - width) by lia.
          assert (exists j, i + (|u|) = j * offset) by (exists (S j); lia).
          destruct (H3 (i + (|u|)) (conj H7 H8)) as (card' & F3 & F4).
          exists card'; split; [assumption | ].
          rewrite H2 in F4. now apply (proj2 (@coversAt_step card' a' b' u v (i ) H2 H1)) in F4.
        * (* the rewrite is vacuously valid *)
          constructor.
          2-4: assumption.
          apply IHk; [congruence | assumption | ].
          intros i (F1 & (j & F2)). rewrite app_length in H3.
          assert (0 <= i + (|u|) < (|u|) + (|a'|) + 1 - width) by lia.
          assert (exists j, i + (|u|) = j * offset) by (exists (S j); lia).
          destruct (H3 (i + (|u|)) (conj H H0)) as (card & H6 & H7).
          exists card; split; [assumption | ].
          rewrite H2 in H7. now apply (proj2 (@coversAt_step card a' b' u v i H2 H1)) in H7.
  Qed.

  (** In order to reason about a sequence of rewrites, we use relational powers *)
  Lemma relpower_valid_length_inv k a b : relpower valid k a b -> length a = length b.
  Proof.
    induction 1 as [ | ? ? ? ? ? ? IH]; [ auto | rewrite <- IH; now apply valid_length_inv].
  Qed.
End fixX.

(** We can now define the language of valid CC instances *)
Definition CCLang (C : CC) :=
  CC_wellformed C
  /\ exists (sf : list (Sigma C)),
    relpower (valid (offset C) (width C) (cards C)) (steps C) (init C) sf
    /\ satFinal (offset C) (|init C|) (final C) sf.

Section fixValid.
  (** We consider syntactically equivalent instances: equivalent instances are obtained by reordering the cards and final substrings *)
  Variable (X : Type).
  Variable (offset width l : nat).

  Hint Constructors valid : core.
  Lemma valid_cards_monotonous (a b : list X) (w1 w2 : list (CCCard X)) :
    w1 <<= w2 -> valid offset width w1 a b -> valid offset width w2 a b.
  Proof.
    intros. induction H0; eauto.
  Qed.

  Lemma valid_cards_equivalent (a b : list X) (w1 w2 : list (CCCard X)) :
    w1 === w2 -> valid offset width w1 a b <-> valid offset width w2 a b.
  Proof.
    intros [H1 H2]; split; now apply valid_cards_monotonous.
  Qed.

  Lemma satFinal_final_monotonous (f1 f2 : list (list X)) s:
    f1 <<= f2 -> satFinal offset l f1 s -> satFinal offset l f2 s.
  Proof.
    intros. destruct H0 as (subs & k & H1 & H2 & H3).
    exists subs, k. apply H in H1. easy.
  Qed.

  Lemma satFinal_final_equivalent (f1 f2 : list (list X)) s:
    f1 === f2 -> satFinal offset l f1 s <-> satFinal offset l f2 s.
  Proof.
    intros [H1 H2]; split; now apply satFinal_final_monotonous.
  Qed.
End fixValid.

Section fixInstance.
  (** Results specific to CC instances *)
  Variable (c : CC).
  Context (wf : CC_wellformed c).

  Definition isRule r := r el cards c.
  Lemma isRule_length r : isRule r -> length (prem r) = width c /\ length (conc r) = width c.
  Proof.
    intros. destruct wf as (_ & _ & _ & _ & H1 & _). specialize (H1 r H ) as (H1 & H2). tauto.
  Qed.

  Lemma coversHead_length_inv card a b : coversHead card a b -> isRule card -> length a >= width c /\ length b >= width c.
  Proof.
    intros. unfold coversHead, prefix in *. destruct H as ((b1 & ->) & (b2 & ->)). split.
    - rewrite app_length. rewrite (proj1 (isRule_length H0)). lia.
    - rewrite app_length, (proj2 (isRule_length H0)). lia.
  Qed.
End fixInstance.


(** * Incompleteness and Undecidability *)

Require Import SOL.
Require Import FullSyntax.
Require Import Subst.
Require Import Tarski.
Require Import PA.
Require Import Vector List.
Import VectorNotations.
Require Import VectorLib.
Require Import Decidable Enumerable.
Require Import Util.

Require Import Equations.Equations Equations.Prop.DepElim.
Require Import Equations.Equations.
Derive Signature for Vector.t.
Require Import Lia.

Import ListNotations.

Inductive polynomial : Set :=
  | number : nat -> polynomial
  | variable : nat -> polynomial
  | add : polynomial -> polynomial -> polynomial
  | mul : polynomial -> polynomial -> polynomial.

Fixpoint eval_polynomial alpha p :=
  match p with
  | number n => n
  | variable x => alpha x
  | add p q => eval_polynomial alpha p + eval_polynomial alpha q
  | mul p q => eval_polynomial alpha p * eval_polynomial alpha q
  end.

Definition H10 equation := exists alpha, eval_polynomial alpha (fst equation) = eval_polynomial alpha (snd equation).

(** Polynomials have equality deciders and are enumerable *)

Lemma polynomial_eq_dec :
  Decidable.eq_dec polynomial.
Proof.
  intros p. induction p; intros []; try (right; congruence).
  - destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. now left. right; congruence.
  - destruct (PeanoNat.Nat.eq_dec n n0) as [->|]. now left. right; congruence.
  - destruct (IHp1 p) as [->|]. 2: right; congruence.
    destruct (IHp2 p0) as [->|]. now left. right; congruence.
  - destruct (IHp1 p) as [->|]. 2: right; congruence.
    destruct (IHp2 p0) as [->|]. now left. right; congruence.
Qed.

Unset Equations With Funext.

Equations? E_polynomial (n : nat) : option polynomial by wf n lt :=
{
    E_polynomial 0 := Some (number 0) ;
    E_polynomial (S n) := match pi1 (S n) with
      | 0 => Some (number (pi2 (S n)))
      | 1 => Some (variable (pi2 (S n)))
      | 2 => match E_polynomial (pi1 (pi2 (S n))), E_polynomial (pi2 (pi2 (S n))) with
              | Some p, Some q => Some (add p q)
              | _, _ => None
            end
      | 3 => match E_polynomial (pi1 (pi2 (S n))), E_polynomial (pi2 (pi2 (S n))) with
              | Some p, Some q => Some (mul p q)
              | _, _ => None
            end
      | _ => None
    end
}.
Proof.
  all: try apply pi1_pi2_le. all: apply pi2_pi2_le.
Qed.
Next Obligation.
  unfold E_polynomial. Init.unfold_recursor.
  - destruct x. reflexivity. now repeat rewrite H0.
  - destruct n. reflexivity. now repeat rewrite H0.
Defined.

Lemma polynomial_enumerable__T :
  enumerable__T polynomial.
Proof.
  exists E_polynomial. intros p. induction p.
  - exists (embed (0, n)). destruct n.
    + rewrite embed_zero. now funelim (E_polynomial 0).
    + funelim (E_polynomial (embed (0, S n))). now pose (embed_not_zero_r 0 n).
      now rewrite eqargs, pi1_correct, pi2_correct.
  - exists (embed (1, n)).
    funelim (E_polynomial (embed (1, n))). now pose (embed_not_zero_l 0 n).
    now rewrite eqargs, pi1_correct, pi2_correct.
  - destruct IHp1 as [n1 H1], IHp2 as [n2 H2]. exists (embed (2, embed (n1, n2))).
    funelim (E_polynomial (embed (2, embed (n1, n2)))). now pose (embed_not_zero_l 1 (embed (n1, n2))).
    now rewrite eqargs, pi1_correct, pi2_correct, pi1_correct, H3, pi2_correct, H4.
  - destruct IHp1 as [n1 H1], IHp2 as [n2 H2]. exists (embed (3, (embed (n1, n2)))).
    funelim (E_polynomial (embed (3, (embed (n1, n2))))). now pose (embed_not_zero_l 2 (embed (n1, n2))).
    now rewrite eqargs, pi1_correct, pi2_correct, pi1_correct, H3, pi2_correct, H4.
Qed.

(** ** Definition of Reduction Function *)

Section Reduction.

  (** Encode diophantine equations as (first-order) formulas *)

  Fixpoint encode_number n := match n with
    | 0 => zero
    | S n => σ (encode_number n)
  end.

  Fixpoint encode_polynomial p := match p with
    | number n => encode_number n
    | variable x => $x
    | add p q => encode_polynomial p ⊕ encode_polynomial q
    | mul p q => encode_polynomial p ⊗ encode_polynomial q
  end.

  Lemma find_largest_variable p :
    { n | bounded_indi_term n (encode_polynomial p) }.
  Proof.
    induction p; cbn.
    - exists 0. now induction n.
    - exists (S n). lia.
    - destruct IHp1 as [n], IHp2 as [m]. destruct (Arith.Compare_dec.le_lt_dec n m).
      + exists m. repeat split. 2: easy.
        now apply (bounded_indi_term_up n m).
      + exists n. repeat split. easy.
        apply (bounded_indi_term_up m n). lia. easy.
    - destruct IHp1 as [n], IHp2 as [m]. destruct (Arith.Compare_dec.le_lt_dec n m).
      + exists m. repeat split. 2: easy.
        now apply (bounded_indi_term_up n m).
      + exists n. repeat split. easy.
        apply (bounded_indi_term_up m n). lia. easy.
  Qed.

  Fixpoint exists_n n phi := match n with
    | 0 => phi
    | S n => ∃i exists_n n phi
  end.

  Definition encode_problem equation := match equation with
    | (p, q) => exists_n (max (proj1_sig (find_largest_variable p)) (proj1_sig (find_largest_variable q))) (encode_polynomial p == encode_polynomial q)
  end.

  (** Encoding is closed *)

  Lemma exists_n_switch n phi :
    ∃i exists_n n phi = exists_n n (∃i phi).
  Proof.
    induction n. easy. cbn. now rewrite IHn.
  Qed.

  Lemma exists_n_bounded n phi :
    bounded_indi 0 (exists_n n phi) <-> bounded_indi n phi.
  Proof.
    induction n in phi |- *.
    - easy.
    - cbn [exists_n]. rewrite exists_n_switch. apply IHn.
  Qed.

  Lemma encoding_closed e :
    bounded_indi 0 (encode_problem e).
  Proof.
    destruct e as [p q]; cbn.
    destruct (find_largest_variable p) as [n H1].
    destruct (find_largest_variable q) as [m H2].
    apply exists_n_bounded. cbn.
    destruct (Arith.Compare_dec.le_lt_dec n m).
    - assert (max n m = m) as -> by lia. repeat split. 2: easy.
      now apply (bounded_indi_term_up n m).
    - assert (max n m = n) as -> by lia. repeat split. easy.
      apply (bounded_indi_term_up m n). lia. easy.
  Qed.

  (** Encoding is first-order *)

  Lemma polynomial_first_order p :
    first_order_term (encode_polynomial p).
  Proof.
    induction p; try easy. now induction n.
  Qed.

  Lemma exists_n_first_order n phi :
    first_order phi -> first_order (exists_n n phi).
  Proof.
    now induction n.
  Qed.

  Lemma encoding_first_order e :
    first_order (encode_problem e).
  Proof.
    destruct e as [p q]; cbn.
    destruct (find_largest_variable p) as [n H1].
    destruct (find_largest_variable q) as [m H2].
    apply exists_n_first_order.
    repeat split; apply polynomial_first_order.
  Qed.

  (** Encoding is satisfiable iff the diophantine equation has
      a solution. *)

  Lemma eval_encoding alpha rho p :
    eval (M_domain Standard_PA_Model) ⟨alpha, get_func rho, get_pred rho⟩ (encode_polynomial p) = eval_polynomial alpha p.
  Proof.
    induction p; cbn.
    - induction n. reflexivity. cbn. now repeat f_equal.
    - reflexivity.
    - now repeat f_equal.
    - now repeat f_equal.
  Qed.

  Lemma sat_encoding alpha rho p q :
    sat (M_interp Standard_PA_Model) ⟨alpha, get_func rho, get_pred rho⟩ (encode_polynomial p == encode_polynomial q)
    <-> eval_polynomial alpha p = eval_polynomial alpha q.
  Proof.
    split.
    - intros H%eq_sem. now repeat rewrite eval_encoding in H.
    - intros. apply eq_sem. now repeat rewrite eval_encoding.
  Qed.

  Section Model.
    Variable M : Model_of PA.

    Lemma exists_n_sat phi n :
      first_order phi -> bounded_indi n phi -> M ⊨ exists_n n phi <-> exists rho, (M, rho) ⊨ phi.
    Proof.
      intros FO B. split.
      - enough (forall rho, (M, rho) ⊨ (exists_n n phi) -> exists sigma, (M, sigma) ⊨ phi) as X.
        { intros H. apply (X (empty_PA_env _)), H. }
        revert phi FO B. induction n; intros phi FO B rho H.
        + now exists rho.
        + cbn [exists_n] in H. rewrite exists_n_switch in H.
          destruct (IHn (∃i phi) FO B rho H) as [sigma [x H1]]. eexists. apply H1.
      - intros [rho H]. revert rho phi FO B H. induction n; intros rho phi FO B H sigma.
        + eapply sat_ext_closed_FO; try easy. apply H.
        + cbn [exists_n]. rewrite exists_n_switch.
          apply (IHn ⟨fun n => get_indi rho (S n), get_func rho, get_pred rho⟩).
          apply FO. apply B. cbn. exists (get_indi rho 0).
          eapply sat_ext. 2: apply H. split. now induction n0. easy.
    Qed.

    Lemma exists_n_sat_1 rho phi n :
      (M, rho) ⊨ phi -> first_order phi -> bounded_indi n phi -> forall sigma, (M, sigma) ⊨ (exists_n n phi).
    Proof.
      intros. apply exists_n_sat; eauto.
    Qed.

    Lemma exists_n_sat_2 rho phi n :
      (M, rho) ⊨ (exists_n n phi) -> first_order phi -> bounded_indi n phi -> exists sigma, (M, sigma) ⊨ phi.
    Proof.
      intros. eapply exists_n_sat; eauto. intros sigma. eapply sat_ext_closed_FO.
      now apply exists_n_first_order. now apply exists_n_bounded. eassumption.
    Qed.
  End Model.

  (** ** Undecidability *)

  Lemma H10_to_PA_standard_model_sat e :
    H10 e <-> Standard_PA_Model ⊨ encode_problem e.
  Proof.
    split.
    - destruct e as [p q]; cbn; intros [alpha H]; hnf.
      eapply (exists_n_sat_1 Standard_PA_Model).
      + now apply (sat_encoding alpha (empty_PA_env _)).
      + repeat split; apply polynomial_first_order.
      + apply exists_n_bounded. apply (encoding_closed (p, q)).
    - destruct e as [p q]; unfold H10; cbn. intros H.
      specialize (H (empty_PA_env Standard_PA_Model)).
      apply (exists_n_sat_2 Standard_PA_Model) in H.
      + destruct H as [sigma H]. exists (get_indi sigma).
        apply (sat_encoding _ sigma). eapply sat_ext.
        2: apply H. easy.
      + repeat split; apply polynomial_first_order.
      + apply exists_n_bounded. apply (encoding_closed (p, q)).
  Qed.

  Lemma solution_from_PA_model (M : Model_of PA) e :
    M ⊨ encode_problem e -> H10 e.
  Proof.
    intros H. eapply H10_to_PA_standard_model_sat, PA_models_agree_FO with (rho := empty_PA_env _).
    apply encoding_first_order. apply encoding_closed. apply H.
  Qed.

  Theorem H10_to_PA_model_sat e (M : Model_of PA) :
    H10 e <-> M ⊨ encode_problem e.
  Proof.
    split.
    - intros H. eapply PA_models_agree_FO with (rho := empty_PA_env _).
      apply encoding_first_order. apply encoding_closed.
      now apply H10_to_PA_standard_model_sat.
    - intros H. eapply H10_to_PA_standard_model_sat, PA_models_agree_FO with (rho := empty_PA_env _).
      apply encoding_first_order. apply encoding_closed. apply H.
  Qed.

  Theorem H10_to_PA_validity e :
    H10 e <-> PA ⊨ encode_problem e.
  Proof.
    split.
    - intros H M. now apply H10_to_PA_model_sat.
    - intros H. eapply H10_to_PA_model_sat, (H Standard_PA_Model).
  Qed.

  Theorem H10_to_PA_satisfiability e :
    H10 e <-> exists (M : Model_of PA) rho, (M, rho) ⊨ (encode_problem e).
  Proof.
    split.
    - intros H. exists Standard_PA_Model, (empty_PA_env _).
      now apply H10_to_PA_standard_model_sat.
    - intros [M [rho H]]. apply H10_to_PA_model_sat with (M := M). intros rho'.
      eapply sat_ext_closed_FO. apply encoding_first_order. apply encoding_closed. apply H.
  Qed.

  Theorem H10_to_validity Σf Σp e :
    H10 e <-> forall M : @Model Σf Σp, M ⊨ (∀f(0) ∀f(1) ∀f(2) ∀f(2) ∀p(2) (embed_form 0 0 0 0 (PA_form --> encode_problem e))).
  Proof.
    split.
    - intros H M. apply PA_model_valid_iff_model_valid. intros M_PA.
      now apply H10_to_PA_model_sat.
    - intros H. now apply H10_to_PA_standard_model_sat, PA_model_valid_iff_model_valid.
  Qed.

  Theorem H10_to_satisfiability Σf Σp e :
    H10 e <-> exists (M : @Model Σf Σp) rho, (M, rho) ⊨ (∃f(0) ∃f(1) ∃f(2) ∃f(2) ∃p(2) (embed_form 0 0 0 0 (PA_form ∧ encode_problem e))).
  Proof.
    split.
    - intros H. apply PA_model_sat_iff_model_sat. exists Standard_PA_Model, (empty_PA_env _).
      now apply H10_to_PA_standard_model_sat.
    - intros [M [rho H]]. edestruct PA_model_sat_iff_model_sat as [_ H1].
      destruct H1 as [M_PA [rho' H1]]. exists M, rho. apply H.
      apply H10_to_PA_model_sat with (M := M_PA). intros rho''. eapply sat_ext_closed_FO.
      apply encoding_first_order. apply encoding_closed. apply H1.
  Qed.

  Theorem H10_to_validity_funcfree e :
    H10 e <-> forall M : Model, M ⊨ (PA_form --> encode_problem e).
  Proof.
    split.
    - intros H M rho HPA. assert (forall phi, PA phi -> forall rho, (M, rho) ⊨ phi) as M_correct.
      { intros phi H1 rho'. repeat destruct H1 as [<-|H1]; try apply HPA. easy. }
      pose (M_PA := {| M_model := M ; M_correct := M_correct |}).
      now apply H10_to_PA_model_sat with (M := M_PA).
    - intros H. apply H10_to_PA_standard_model_sat. intros rho. apply H. cbn.
      repeat split; intros; try congruence. induction d; auto.
  Qed.

  Theorem H10_to_satisfiability_funcfree e :
    H10 e <-> exists (M : Model) rho, (M, rho) ⊨ (PA_form ∧ encode_problem e).
  Proof.
    split.
    - intros H. exists Standard_PA_Model, (empty_PA_env _). split.
      + cbn. repeat split; intros; try congruence. induction d; auto.
      + now apply H10_to_PA_model_sat.
    - intros [M [rho [HPA H]]]. assert (forall phi, PA phi -> forall rho, (M, rho) ⊨ phi) as M_correct.
      { intros phi H1 rho'. repeat destruct H1 as [<-|H1]; try apply HPA. easy. }
      pose (M_PA := {| M_model := M ; M_correct := M_correct |}).
      eapply H10_to_PA_model_sat with (M := M_PA). intros rho'.
      eapply sat_ext_closed_FO. apply encoding_first_order. apply encoding_closed.
      apply H.
  Qed.

  (** Undecidability for funcfree fragment *)

  Lemma PA_env_p_exists (M : Model_p) :
    inhabited (env_p (M_p_domain M)).
  Proof.
    destruct (@i_f_p PA_funcs_signature PA_preds_signature (M_p_domain M) _ Zero) as [Z [HF HT]].
    destruct (HT ([])) as [z _].
    assert (forall ar, func_p (M_p_domain M) ar) as F.
    { intros ar. exists (fun _ d => d = z). split.
      now intros v y y' -> ->. intros v. now exists z. }
    econstructor. exact ⟨⟨ fun _ => z, fun _ ar => F ar, fun _ _ _ => True ⟩⟩.
  Qed.

  Section Model.
    Variable M : Model_p_of PA.

    Lemma exists_n_sat_p phi n :
      first_order phi -> bounded_indi n phi -> M ⊨p exists_n n phi <-> exists rho, (M, rho) ⊨p phi.
    Proof.
      intros FO B. split.
      - enough (forall rho, (M, rho) ⊨p (exists_n n phi) -> exists sigma, (M, sigma) ⊨p phi) as X.
        { intros H. destruct (PA_env_p_exists M) as [rho]. apply (X rho), H. }
        revert phi FO B. induction n; intros phi FO B rho H.
        + now exists rho.
        + cbn [exists_n] in H. rewrite exists_n_switch in H.
          destruct (IHn (∃i phi) FO B rho H) as [sigma [x H1]]. eexists. apply H1.
      - intros [rho H]. revert rho phi FO B H. induction n; intros rho phi FO B H sigma.
        + eapply sat_p_ext_closed_FO; try easy. apply H.
        + cbn [exists_n]. rewrite exists_n_switch.
          apply (IHn ⟨⟨fun n => get_indi_p rho (S n), get_func_p rho, get_pred_p rho⟩⟩).
          apply FO. apply B. cbn. exists (get_indi_p rho 0).
          eapply sat_p_ext. 2: apply H. split. now induction n0. easy.
    Qed.

    Lemma exists_n_sat_p_1 rho phi n :
      (M, rho) ⊨p phi -> first_order phi -> bounded_indi n phi -> forall sigma, (M, sigma) ⊨p (exists_n n phi).
    Proof.
      intros. apply exists_n_sat_p; eauto.
    Qed.

    Lemma exists_n_sat_p_2 rho phi n :
      (M, rho) ⊨p (exists_n n phi) -> first_order phi -> bounded_indi n phi -> exists sigma, (M, sigma) ⊨p phi.
    Proof.
      intros. eapply exists_n_sat_p; eauto. intros sigma. eapply sat_p_ext_closed_FO.
      now apply exists_n_first_order. now apply exists_n_bounded. eassumption.
    Qed.
  End Model.

  Lemma eval_p_encoding alpha rho p :
    eval_p (M_p_domain Standard_PA_Model_p) ⟨⟨alpha, get_func_p rho, get_pred_p rho⟩⟩ (encode_polynomial p) (eval_polynomial alpha p).
  Proof.
    induction p; cbn.
    - induction n; cbn. now exists []. now exists [n].
    - reflexivity.
    - now exists [eval_polynomial alpha p1 ; eval_polynomial alpha p2].
    - now exists [eval_polynomial alpha p1 ; eval_polynomial alpha p2].
  Qed.

  Lemma sat_p_encoding alpha rho p q :
    sat_p (M_p_interp Standard_PA_Model_p) ⟨⟨alpha, get_func_p rho, get_pred_p rho⟩⟩ (encode_polynomial p == encode_polynomial q)
    <-> eval_polynomial alpha p = eval_polynomial alpha q.
  Proof.
    split.
    - intros [v H]. repeat depelim v. cbn in H. destruct H as [[H1 [H2 _]] H].
      assert (h = eval_polynomial alpha p) as ->. { eapply eval_p_functional. apply H1. apply eval_p_encoding. }
      assert (h0 = eval_polynomial alpha q) as ->. { eapply eval_p_functional. apply H2. apply eval_p_encoding. }
      exact H.
    - intros H. exists [eval_polynomial alpha p ; eval_polynomial alpha q].
      repeat split; cbn; trivial; apply eval_p_encoding.
  Qed.

  Lemma H10_to_PA_standard_model_p_sat e :
    H10 e <-> Standard_PA_Model_p ⊨p encode_problem e.
  Proof.
    destruct (PA_env_p_exists Standard_PA_Model_p) as [rho]. split.
    - destruct e as [p q]; cbn; intros [alpha H]; hnf.
      eapply (exists_n_sat_p_1 Standard_PA_Model_p).
      + now apply (sat_p_encoding alpha rho).
      + repeat split; apply polynomial_first_order.
      + apply exists_n_bounded. apply (encoding_closed (p, q)).
    - destruct e as [p q]; unfold H10; cbn. intros H.
      specialize (H rho).
      apply (exists_n_sat_p_2 Standard_PA_Model_p) in H.
      + destruct H as [sigma H]. exists (get_indi_p sigma).
        apply (sat_p_encoding _ sigma). eapply sat_p_ext.
        2: apply H. easy.
      + repeat split; apply polynomial_first_order.
      + apply exists_n_bounded. apply (encoding_closed (p, q)).
  Qed.

  (** ** Not enumerable *)

  Definition bi_enumerable {X} (P : X -> Prop) := enumerable P /\ enumerable (fun x => ~ P x).

  Lemma bi_enumerable_ext X (P Q : X -> Prop) :
    (forall x, P x <-> Q x) -> bi_enumerable P -> bi_enumerable Q.
  Proof.
    intros H [H1 H2]. split.
    - eapply enumerable_ext. apply H. apply H1.
    - eapply enumerable_ext. intros x. assert (forall P Q, (P <-> Q) -> (~P <-> ~Q)) as H3 by tauto.
      apply H3, H. apply H2.
  Qed.

  Lemma polynomial_pair_enumerable :
    Decidable.eq_dec (polynomial * polynomial).
  Proof.
    intros [p q] [p' q'].
    destruct (polynomial_eq_dec p p') as [->|]. 2: right; congruence.
    destruct (polynomial_eq_dec q q') as [->|]. now left. right; congruence.
  Qed.

  Lemma PA_sat_neg phi :
    first_order phi -> bounded_indi 0 phi -> PA ⊨ (¬ phi) <-> ~ PA ⊨ phi.
  Proof.
    intros FO B. split.
    - intros H1 H2. apply (H1 Standard_PA_Model (empty_PA_env _)). apply H2.
    - intros H1 M rho H2. apply H1. hnf. eapply PA_models_agree_FO; try easy. apply H2.
  Qed.

  Lemma PA_validity_not_enumerable :
    enumerable (fun phi => PA ⊨ phi) -> bi_enumerable H10.
  Proof.
    intros H. eapply bi_enumerable_ext. intros e. symmetry. apply H10_to_PA_validity. split.
    - eapply enumerable_comp with (f := encode_problem) in H.
      + apply H.
      + apply enumerable__T_pair; apply polynomial_enumerable__T.
      + apply form_eq_dec.
    - eapply enumerable_comp with (f := fun x => ¬ encode_problem x) in H.
      + eapply enumerable_ext in H. apply H. cbn. intros e.
        setoid_rewrite PA_sat_neg. reflexivity. apply encoding_first_order.
        apply encoding_closed.
      + apply enumerable__T_pair; apply polynomial_enumerable__T.
      + apply form_eq_dec.
  Qed.

  Corollary PA_validity_not_enumerable' :
    MP -> enumerable (fun phi => PA ⊨ phi) -> decidable H10.
  Proof.
    intros mp H. apply Post. easy. apply polynomial_pair_enumerable.
    all: now apply PA_validity_not_enumerable.
  Qed.

  Lemma PA_satisfiability_not_enumerable :
    enumerable (fun phi => exists (M : Model_of PA) rho, (M, rho) ⊨ phi) -> bi_enumerable H10.
  Proof.
    intros H. eapply bi_enumerable_ext. intros e. symmetry. apply H10_to_PA_satisfiability. split.
    - eapply enumerable_comp with (f := encode_problem) in H.
      + apply H.
      + apply enumerable__T_pair; apply polynomial_enumerable__T.
      + apply form_eq_dec.
    - eapply enumerable_comp with (f := fun x => ¬ encode_problem x) in H.
      + eapply enumerable_ext in H. apply H. cbn. intros e. split.
        * intros [M1 [rho1 H1]] [M2 [rho2 H2]]. apply H1.
          eapply PA_models_agree_FO. 3: apply H2. apply encoding_first_order.
          apply encoding_closed.
        * intros H1. exists Standard_PA_Model, (empty_PA_env _). intros H2.
          apply H1. eexists. eexists. apply H2.
      + apply enumerable__T_pair; apply polynomial_enumerable__T.
      + apply form_eq_dec.
  Qed.

  Corollary PA_satisfiability_not_enumerable' :
    MP -> enumerable (fun phi => exists (M : Model_of PA) rho, (M, rho) ⊨ phi) -> decidable H10.
  Proof.
    intros mp H. apply Post. easy. apply polynomial_pair_enumerable.
    all: now apply PA_satisfiability_not_enumerable.
  Qed.

  Section Signature.

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

    Context `{eq_dec_Σf : Decidable.eq_dec Σf}.
    Context `{eq_dec_Σp : Decidable.eq_dec Σp}.

    Lemma validity_not_enumerable :
      enumerable (fun phi => forall M : Model, M ⊨ phi) -> bi_enumerable H10.
    Proof.
      intros H. apply PA_validity_not_enumerable; trivial.
      apply enumerable_comp with (f := fun phi => (∀f (0) (∀f (1) (∀f (2) (∀f (2) (∀p (2) embed_form 0 0 0 0 (PA_form --> phi))))))) in H.
      eapply enumerable_ext. 2: apply H.
      - symmetry. apply PA_model_valid_iff_model_valid.
      - apply PA_form_enumerable.
      - apply form_eq_dec.
    Qed.

    Corollary validity_not_enumerable' :
      MP -> enumerable (fun phi => forall M : Model, M ⊨ phi) -> decidable H10.
    Proof.
      intros mp H. apply Post. easy. apply polynomial_pair_enumerable.
      all: now apply validity_not_enumerable.
    Qed.

    Lemma satisfiability_not_enumerable :
      enumerable (fun phi => exists (M : Model) rho, (M, rho) ⊨ phi) -> bi_enumerable H10.
    Proof.
      intros H. apply PA_satisfiability_not_enumerable; trivial.
      apply enumerable_comp with (f := fun phi => (∃f (0) (∃f (1) (∃f (2) (∃f (2) (∃p (2) embed_form 0 0 0 0 (PA_form ∧ phi))))))) in H.
      eapply enumerable_ext. 2: apply H.
      - symmetry. apply PA_model_sat_iff_model_sat.
      - apply PA_form_enumerable.
      - apply form_eq_dec.
    Qed.

    Lemma satisfiability_not_enumerable' :
      MP -> enumerable (fun phi => exists (M : Model) rho, (M, rho) ⊨ phi) -> decidable H10.
    Proof.
      intros mp H. apply Post. easy. apply polynomial_pair_enumerable.
      all: now apply satisfiability_not_enumerable.
    Qed.

  End Signature.

  Lemma standard_model_validity_not_enumerable :
    enumerable (fun phi => first_order phi /\ bounded_indi 0 phi /\ Standard_Model ⊨ phi) -> bi_enumerable H10.
  Proof.
    intros H. eapply bi_enumerable_ext. intros e. symmetry.
    apply H10_to_PA_standard_model_sat. split.
    - eapply enumerable_comp with (f := encode_problem) in H.
      + eapply enumerable_ext in H. apply H. cbn. intros x. split.
        easy. intros H1. repeat split; trivial. apply encoding_first_order.
        apply encoding_closed.
      + apply enumerable__T_pair; apply polynomial_enumerable__T.
      + apply form_eq_dec.
    - eapply enumerable_comp with (f := fun x => ¬ encode_problem x) in H.
      + eapply enumerable_ext in H. apply H. cbn. intros x. split.
        intros [_ [_ H1]] H2. apply H1 with (rho := empty_PA_env _), H2.
        intros H1. repeat split; trivial. apply encoding_first_order.
        apply encoding_closed. intros rho H2. apply H1. intros rho'.
        eapply sat_ext_closed_FO. apply encoding_first_order.
        apply encoding_closed. apply H2.
      + apply enumerable__T_pair; apply polynomial_enumerable__T.
      + apply form_eq_dec.
  Qed.

  Corollary standard_model_validity_not_enumerable' :
    MP -> enumerable (fun phi => first_order phi /\ bounded_indi 0 phi /\ Standard_Model ⊨ phi) -> decidable H10.
  Proof.
    intros mp H. apply Post. easy. apply polynomial_pair_enumerable.
    all: now apply standard_model_validity_not_enumerable.
  Qed.

End Reduction.

(** ** Incompleteness *)

(* Incompleteness in PA signature*)
Section IncompletenessPA.

  Variable prv : list (@form Σf Σp full_operators) -> @form Σf Σp full_operators -> Prop.
  Notation "T ⊢ phi" := (prv T phi) (at level 20).

  Hypothesis sound : forall A phi, A ⊢ phi -> valid A phi.
  Hypothesis complete : forall A phi, valid A phi -> A ⊢ phi.
  Hypothesis prv_enumerable : forall A, enumerable (fun phi => A ⊢ phi).

  Lemma PA_valid_to_model phi :
    PA ⊨ phi <-> valid PA_L phi.
  Proof.
    split.
    - intros H D I rho H1. pose (M := {| M_domain := D ; M_interp := I |}).
      assert (forall psi, PA psi -> M ⊨ psi) as H2. {
        intros psi H2 rho'. repeat destruct H2 as [<-|H2]. apply (H1 ax_eq_refl). 2: apply (H1 ax_eq_symm). 3: apply (H1 ax_zero_succ). 4: apply (H1 ax_succ_inj). 5: apply (H1 ax_add_zero). 6: apply (H1 ax_add_rec). 7: apply (H1 ax_mul_zero). 8: apply (H1 ax_mul_rec). 9: apply (H1 ax_ind). 10: easy. all: clear; firstorder.
      } apply (H {| M_model := M ; M_correct := H2 |}).
    - intros H M rho. apply H. intros psi H1. repeat destruct H1 as [<-|H1]; try easy; apply (M_correct M); clear; firstorder.
  Qed.

  Lemma validity_enumerable_PA :
    enumerable (fun phi => PA ⊨ phi).
  Proof.
    eapply enumerable_ext. 2: apply (prv_enumerable PA_L). intros phi. setoid_rewrite PA_valid_to_model.
    split. apply sound. apply complete.
  Qed.

  Theorem Incompleteness_PA :
    bi_enumerable H10.
  Proof.
   apply PA_validity_not_enumerable, validity_enumerable_PA.
  Qed.

  Theorem Incompleteness_PA' :
    MP -> decidable H10.
  Proof.
    intros mp. now apply PA_validity_not_enumerable', validity_enumerable_PA.
  Qed.

End IncompletenessPA.

Section Incompleteness.

  (** Suppose we have a sound and complete deduction system *)

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

  Variable prv : list (@form Σf Σp full_operators) -> @form Σf Σp full_operators -> Prop.
  Notation "T ⊢ phi" := (prv T phi) (at level 20).

  Hypothesis sound : forall A phi, A ⊢ phi -> valid A phi.
  Hypothesis complete : forall A phi, valid A phi -> A ⊢ phi.
  Hypothesis prv_enumerable : forall A, enumerable (fun phi => A ⊢ phi).

  Lemma valid_to_model phi :
    (forall M : Model, M ⊨ phi) <-> valid ([]) phi.
  Proof.
    split.
    - intros H D I rho H1. apply (H {| M_domain := D ; M_interp := I |}).
    - intros H M rho. apply H. now intros psi H1.
  Qed.

  Context `{eq_dec_Σf : Decidable.eq_dec Σf}.
  Context `{eq_dec_Σp : Decidable.eq_dec Σp}.

  Lemma validity_enumerable :
    enumerable (fun phi => forall M : Model, M ⊨ phi).
  Proof.
    eapply enumerable_ext. 2: apply (prv_enumerable ([])). intros phi. setoid_rewrite valid_to_model.
    split. apply sound. apply complete.
  Qed.

  Theorem Incompleteness :
    bi_enumerable H10.
  Proof.
    apply validity_not_enumerable, validity_enumerable.
  Qed.

  Theorem Incompleteness' :
    MP -> decidable H10.
  Proof.
    intros MP. now apply validity_not_enumerable', validity_enumerable.
  Qed.

End Incompleteness.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import NPeano.

Import ListNotations.
(*-------------------Representation-Binaire-------------------------------------*)
(*ou reecrire fonction mod2 pour rendre que true ou false*)
(*Fixpoint nat_to_bool (n:nat) : bool :=
  match (n mod 2) with
  |0 => false
  |1 => true
  |(S p) => false (*theoreme pour prouver que ce cas narrive jamais*)
  end.*)
SearchAbout div.
SearchAbout pow S.

Definition brem (n:nat) : bool :=
  if (beq_nat ((n/2)*2) n)
  then false
  else true.

(*
n: nat a encoder
SearchAbout()
k: encoder sur k bits
TODO: fonction decode : (list bool) -> nat
*)
Fixpoint encode (n:nat)(k:nat):(list bool):=
  match k with
  |0 => []
  |(S p) => (encode (n/2) p)++(brem n)::[]
  end.

Compute (encode 5 4).

(*-------------------Representation-Instructions--------------------------------*)
(*TODO:
-displacement: inter_code_car, eval_inter_code_car, instruction, decode_ins_icc
 *)

(*Representation dun code intermediaire qui va generer du binaire*)
Inductive inter_code_car : Type :=
|hexcar : nat -> inter_code_car (*generates 4-bit binary word*)
|constant: nat -> inter_code_car (*generates 4-bytes binary code*)
(*|displacement: nat -> inter_code_car*) (*generates 4-bytes binary code/ negative representation*)
.

(*evaluation of a inter_code_car*)
Fixpoint eval_inter_code_car (icc : inter_code_car) : (list bool) :=
  match icc with
  |(hexcar n) => (encode n 4)
  |(constant n) => (encode n 32)
  end.

(*hexadecimal is a list of inter_code_cars*)
(*Inductive type for register*)
(*1 register represented by 4 bits*)
Inductive reg: Type :=
|EAX: reg
|ECX: reg
|EDX: reg
|EBX: reg
|ESP: reg
|EBP: reg
|ESI: reg
|EDI: reg
|F : reg.

(*decode register*)
Fixpoint decode_reg (r : reg) : (list bool) :=
  match r with
  |EAX => (encode 0 4)
  |ECX => (encode 1 4)
  |EDX => (encode 2 4)
  |EBX => (encode 3 4)
  |ESP => (encode 4 4)
  |EBP => (encode 5 4)
  |ESI => (encode 6 4)
  |EDI => (encode 7 4)
  |F => (encode 15 4)
  end.

(*Operators represented by 1 byte*)
Inductive operator : Type :=
|ADD : operator
|SUB : operator
|AND : operator
|XOR : operator
.

(*decode operator to binary*)
Fixpoint decode_op (op: operator) : (list bool) :=
  match op with
  |ADD => (encode 6 4)++(encode 0 4)
  |SUB => (encode 6 4)++(encode 1 4)
  |AND => (encode 6 4)++(encode 2 4)
  |XOR => (encode 6 4)++(encode 3 4)
  end.

(*1 instruction represented by a maximum of 6 bytes*)
Inductive instruction: Type :=
|halt : instruction
|nop : instruction
|rrmovl : reg -> reg -> instruction
|irmovl : nat -> reg -> instruction
(*|rmmovl : reg -> constant -> reg -> instruction
|mrmovl : constant -> reg -> reg -> instruction*)
|opl : operator -> reg -> reg -> instruction
.

Fixpoint decode_ins (i : instruction) : (list bool) :=
  match i with
  |halt => (encode 0 4)++(encode 0 4)
  |nop => (encode 1 4)++(encode 0 4)
  |(rrmovl ra rb) => (encode 2 4)++(encode 0 4)++(decode_reg ra)++(decode_reg rb)
  |(irmovl n rb) => (encode 3 4)++(encode 0 4)++(encode 15 4)++(decode_reg rb)++(encode n 32)
  |(opl op ra rb) => (encode 6 4)++(decode_op op)++(decode_reg ra)++(decode_reg rb)
  end.

Compute (decode_ins halt).
Compute (decode_ins nop).
Compute (decode_ins (rrmovl EAX ECX)).
Compute (decode_ins (irmovl 15 EBX)).

(* ********************************************************************** *)
(*                              DECODE                                    *)
(* ********************************************************************** *)

Fixpoint decode (l : list bool) : (nat):=
  match l with
  | [] => 0
  | e::rest => match e with
         | false => decode rest
         | true => (decode rest) + (pow 2 ((length rest)))
         end
  end.

Compute (decode [false; true; true]).
Compute (decode [false;false;false;false;     false;true;false;true]).
(*SearchAbout not.
Lemma brem_S:forall n:nat, brem (S n)=negb ( brem n).
  intros.
  destruct n. reflexivity.
  SearchAbout plus S.
  simpl.
simpl.
Lemma eq_div_brem:forall n, n / 2 * 2 + (if brem n then 1 else 0) = n.
  induction n. reflexivity.
  Opaque div.
  simpl.

  SearchAbout   div .
intros n. *)

Lemma decode_concat: forall
    (l:list bool) (l':list bool), decode (l++l') = (decode l) * pow 2 (length l') + decode l'.

  intros.
      induction l. simpl. reflexivity. case a. simpl.
      rewrite IHl. rewrite app_length.
      rewrite Nat.pow_add_r.
      rewrite mult_plus_distr_r. omega.
      simpl.
      rewrite IHl.
      reflexivity.
Qed.

Lemma eq_encode_decod: forall k (n:nat), ((pow 2 k)>n)->(decode (encode n k))=n.
Proof.
  intros k.
  induction k.
  - intros.
    simpl  in H.
    inversion H.
    + reflexivity.
    + inversion H1.
  - intros.
    Opaque div.
    simpl encode.
    rewrite decode_concat with (l:=encode (n/2) k) (l':=[brem n]).

      rewrite IHk.
      Focus 2.
      { unfold gt.
        apply Nat.mul_lt_mono_pos_l with (p:=2).
        - omega.
        - apply le_lt_trans with (m:=n).
          + apply Nat.mul_div_le.
            omega.
          + assumption.
      }
      Unfocus.
      simpl.
      assert ((if brem n then 1 else 0) = n mod 2).
      { destruct (brem n) eqn:heq.

        - admit.
        - admit. }
      rewrite H0.
      rewrite (div_mod n 2) at 3;omega.
Qed.

(*

Lemma brem_mod: forall (n:nat),(brem n)=true->(( n mod 2)=1).
  induction n.
  simpl.
  unfold brem.
  rewrite Nat.div_0_l.
  simpl.*)

(*

        induction n. simpl.
       rewrite Nat.div_0_l. reflexivity.
       omega. simpl. rewrite <-Nat.add_1_l. SearchAbout plus div.
       assert(forall a b:nat,(a+b)/2=a/2+b/2).
       {
         induction a. simpl. reflexivity.  rewrite <-Nat.add_1_l.
         SearchAbout plus.
         rewrite plus_comm with (n:=1) (m:=a).
         intros b.
         rewrite <-plus_assoc with (n:=a) (m:=1) (p:=b).
         replace b with 0. simpl.  rewrite Nat.div_0_l.
         trivial. omega.  induction b. reflexivity.
         rewrite<- IHb.
          admit.
       }

       unfold brem.
       rewrite H1 with (a:=1) (b:=n).

       rewrite Nat.div_small with(a:=1)(b:=2). simpl.
       assert( 2 * (n / 2)<=n).
        {
          apply  Nat.mul_div_le with (b:=2)(a:=n). omega.
        }
        SearchAbout S .
        assert(n<S n). apply gt_Sn_n.

        SearchAbout (_<_).

        rewrite mult_comm with (n:=n/2) (m:=2).
        SearchAbout (_->_).
        assert( 2 * (n / 2)<S n).
        {
        apply le_lt_trans with (m:=n) (p:=S n) (n:=2*(n/2)).
        apply H2. apply H3.
        }
        apply Nat.lt_neq in H4. SearchAbout beq_nat.
         rewrite<- Nat.eqb_neq  with (x:=(2*(n/2))) (y:=(S n)) in H4.
         rewrite H4.

        }

        rewrite le_lt_trans with (m:=n) (p:=S n) (n:=2*(n/2)).
        admit.
      simpl in H.
      replace (2 ^ k + (2 ^ k + 0)) with (2 * (2 ^ k)) in H.
      SearchAbout lt div.
      assert (2 * 2 ^ k > 2* (n/2)).
      { assert( 2 * (n / 2)<=n).
        {
          apply  Nat.mul_div_le with (b:=2)(a:=n). omega.
        }
        SearchAbout (_>_).

        apply gt_le_trans with (n:=(2*2^k)) (m:=n) (p:=2*(n/2)).
        apply H.
        apply H1.
      }
      SearchAbout mult lt .
      apply Nat.mul_lt_mono_pos_l with (p:=2).
      apply lt_0_Sn.
      apply H1.
      omega.
Qed.

   SearchAbout lt.
      simpl.
      simpl
      * reflexivity.
      * admit.

    (*    n / 2 * 2 + (if brem n then 1 else 0) = n * a rpouver comm lemma*)

  induction n.
  - induction k; simpl.
    + auto.
    + assert (forall l l', decode (l++l') = (decode l) * pow 2 (length l') + decode l').
      { admit. }
      rewrite H0 .
      rewrite IHk.
      * reflexivity.
      * admit.
  - simpl.
    simpl  in H.
    inversion H.
    + reflexivity.
    + inversion H1.
  - Opaque div.
    simpl encode.
(*

 Lemma eq_length: forall (n:nat) (k:nat),-> (length(encode n k))= k.

Lemma eq_decod_encode: forall (l:list bool),(encode(decode l) (length l))=l.

*)
  (*  SearchAbout mult.
      replace (decode l * 2 ^ length l'+decode l'+ 2 ^ length (l ++ l'))
      with
      (decode l * 2 ^ length l'+ 2 ^ length (l ++ l')+decode l').

      replace
        (decode l * 2 ^ length l'+ 2 ^ length (l ++ l'))
        with
     ( (decode l + 2 ^ length l) * 2 ^ length l').
      reflexivity.
       replace
        (decode l * 2 ^ length l'+ 2 ^ length (l ++ l'))
        with
     ( (decode l + 2 ^ length l) * 2 ^ length l').
       reflexivity.
        replace
        (decode l * 2 ^ length l'+ 2 ^ length (l ++ l'))
        with
     ( (decode l + 2 ^ length l) * 2 ^ length l').
       reflexivity.*)


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
(*                                                                     *)
(*  Definition of the multplicative group                              *)
(*                                                                     *)
(***********************************************************************)
(***********************************************************************)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat.
Require Import fintype finset groups morphisms normal div gprod.

(* Require Import seq paths connect zp bigops group_perm automorphism  *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Section Euler.

Definition fp_mul p := {x : 'I_p | coprime p x}.
Canonical Structure fp_mul_subType p := Eval hnf in [subType of fp_mul p].
Canonical Structure fp_mul_eqType p := Eval hnf in [eqType of fp_mul p].
Canonical Structure fp_mul_finType p := Eval hnf in [finType of fp_mul p].
Canonical Structure fp_mul_subFinType p :=
  Eval hnf in [subFinType of fp_mul p].

Variable n : pos_nat.

Lemma to_zp_proof : forall i, i %% n < n.
Proof. by move=> i; rewrite ltn_mod. Qed.

Definition to_zp i := Ordinal (to_zp_proof i).

Lemma fp_mul_unit_proof : coprime n (to_zp 1).
Proof.
case: (ltngtP n 1) => [|lt1n | n1]; first by rewrite ltnNge (valP n).
  by rewrite /= modn_small // /coprime gcdn1.
by rewrite {1}n1 /coprime gcd1n.
Qed.

Definition fp_mul_unit : fp_mul n := Sub (to_zp 1) fp_mul_unit_proof.

Lemma inv_fp_mul_proof : forall x : fp_mul n,
  coprime n (to_zp (egcdn (val x) n).1).
Proof.
case=> x; rewrite /= /coprime gcdn_modr.
case: (posnP x) => [->|x_pos conx]; first by case: n; do 2?case.
case: egcdnP => //= kx kp; rewrite -(gauss_gcdl _ conx) => -> _.
by rewrite gcdn_addl_mul -(gcdnC n) (eqnP conx) gcdn1.
Qed.

Definition inv_fp_mul x : fp_mul n := Sub (to_zp _) (inv_fp_mul_proof x).

Lemma mul_fp_mul_proof : forall x y : fp_mul n,
  coprime n (to_zp (val x * val y)).
Proof.
case=> [x conx] [y cony]; rewrite /= /coprime gcdn_modr [_ == 1]coprime_mulr.
exact/andP.
Qed.

Definition mul_fp_mul x y : fp_mul n := Sub (to_zp _) (mul_fp_mul_proof x y).

Lemma unit_fp_mul : left_unit fp_mul_unit mul_fp_mul.
Proof.
by move=> x; do 2!apply: val_inj; rewrite /= modn_mulml mul1n modn_small.
Qed.

Lemma invP_fp_mul : left_inverse fp_mul_unit inv_fp_mul mul_fp_mul.
Proof.
case=> x conx; do 2!apply: val_inj; rewrite /= modn_mulml.
case: (posnP x) conx => [->|x_pos conx]; first by case: n; do 2?case.
by case: egcdnP => // _ kp -> _; rewrite gcdnC (eqnP conx) modn_addl_mul.
Qed.

Lemma mulP_fp_mul : associative mul_fp_mul.
Proof.
by move=> x y z; do 2!apply: val_inj; rewrite /= modn_mulmr modn_mulml mulnA.
Qed.

Canonical Structure fp_mul_baseFinGroupType := Eval hnf in
  [baseFinGroupType of fp_mul n by mulP_fp_mul, unit_fp_mul & invP_fp_mul].

Canonical Structure fp_mul_finGroupType := FinGroupType invP_fp_mul.

End Euler.

Section EulerUnit.

(* the unit for the multiplicative group *)

Lemma ltnSSn : forall n, 1 < n.+2.
Proof. by []. Qed.

Definition zp1 (n:pos_nat) : ordinal_finType n.
case; case; first by case/negP; rewrite ltn0.
case; first by exists (Ordinal (ltnSn 0)).
move=> n i; by exists (Ordinal (ltnSSn n)).
Defined.

Lemma zp11 : forall (n:nat) (H: 0 < n.+2),
  (zp1 (PosNat H)) = (Ordinal (ltnSSn n)).
Proof.  by case=> [|n] H; apply: val_inj=> //=. Qed.

Lemma zp10 : forall (H : 0 < 1), (zp1 (PosNat H)) = (Ordinal H).
Proof. trivial. Qed.

Lemma coprime_zp1 : forall n: pos_nat, coprime n (zp1 n).
Proof.
case; case; first by case/negP; rewrite ltn0.
case=> [|n] H; first by rewrite zp10.
by rewrite zp11; apply coprimen1.
Qed.

End EulerUnit.

Section Chinese.

Variables m n : pos_nat.

Lemma coprime_modn_mull : forall p,
    coprime (m * n) p = coprime m (p %% m) && coprime n (p %% n).
Proof.
move=> p; rewrite /coprime (gcdnC m) (gcdnC n); move: (gcdnE m p) (gcdnE n p).
rewrite !eqn0Ngt (valP m) (valP n) /= => <- <-; exact: coprime_mull.
Qed.

Lemma coprime_fp_mul_proof : forall p,
  coprime (m * n) p ->
  coprime m (to_zp m p) && coprime n (to_zp n p).
Proof. by move=> p; rewrite coprime_modn_mull. Qed.

Definition rho : fp_mul (m * n) ->  (fp_mul m) * (fp_mul n):=
  fun x => let Hcop := (andP (coprime_fp_mul_proof (valP x))) in
    (Sub (to_zp m _) (proj1 Hcop), Sub (to_zp n _) (proj2 Hcop)).

Lemma rho_morph : {morph rho : x y / x * y}%g.
Proof.
move=> x y; apply/eqP; rewrite eq_sym; do 3!rewrite /eqd /=.
rewrite !modn_mul2m !eqn_mod_dvd ?leq_mod //.
rewrite {1 3}(divn_eq (sval x * sval y) (m * n)) !addnK.
by rewrite !mulnA {1}mulnAC !dvdn_mull.
Qed.

Canonical Structure rho_morphism := @Morphism _ _ setT rho (in2W rho_morph).

Hypothesis Hcop : coprime m n.

Lemma rho_inj : ('injm rho)%g.
Proof.
apply/injmP=> x y _ _; case=> Hm Hn; do 2!apply: val_inj => /=.
move: (modn_small (valP (sval x))) (modn_small (valP (sval y))) => /= <- <-.
by apply/eqP; rewrite chinese_remainder // Hm Hn !eqxx.
Qed.

Lemma rho_isom : isom setT setT rho.
Proof.
apply/isomP; split; first exact: rho_inj.
apply/setP=> [[x1 x2]]; rewrite !inE /=.
have Hi : chinese m n (sval x1) (sval x2) %% (m * n) < m * n.
  by rewrite ltn_mod pos_natP.
have Hc: coprime (m * n) (Ordinal Hi).
  move: (gcdnE (m * n) (chinese m n (sval x1) (sval x2))).
  rewrite eqn0Ngt pos_natP /coprime /= [gcdn (_ %% _ ) _ ]gcdnC=> <-.
  move: (coprime_modn_mull (chinese m n (sval x1) (sval x2))).
  rewrite /coprime=> ->.
  rewrite chinese_modl ?(valP n) // chinese_modr ?(valP m) //.
  rewrite (modn_small (valP (sval x1))) (modn_small (valP (sval x2))) /=.
  by move: (svalP x1) (svalP x2); rewrite /coprime=> ->->.
pose c : fp_mul (m * n) := Sub (Ordinal _) Hc.
apply/imsetP; exists c; rewrite ?inE //=; apply/eqP; do 3!rewrite /eqd /=.
set e := chinese _ _ _ _; pose e' i j := modn_addl_mul (e %/ (m * n) * i) j _.
rewrite -(e' m n) -{e'}(e' n m) -!mulnA (mulnC n) -divn_eq.
by rewrite chinese_modl ?chinese_modr ?modn_small ?eqxx.
Qed.

End Chinese.


Theorem Modus_toolens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P.
unfold not.
Proof.
  intros.
  apply H.
  intros.
  destruct H.
  apply H1.
  apply H0.
Qed.


Inductive BS : Type :=
| L : BS
| R : BS
| l : BS -> BS
| r : BS -> BS.
(* | eqL : L   = l L
| eqM : l R = r L
| eqR : R   = r R *)

Inductive D : Type :=
| middle : D
| left   : D -> D
| right  : D -> D.

Inductive BS' : Type :=
| L' : BS'
| R' : BS'
| η  : D -> BS'.