(* Copyright 2020 Frédéric Besson <frederic.besson@inria.fr> *)

Require Import Bool ZifyClasses ZifyUint63 ZArith Lia.
Require Import Cdcl.PatriciaR.

Require Uint63.

Section S.
  Import Uint63.
  Definition zero := 0%uint63.
  Definition one :=  1%uint63.
End S.

Definition int_of_nat (n:nat) := Uint63.of_Z (Z.of_nat n).

#[export] Program Instance Op_int_of_nat : UnOp int_of_nat :=
    {| TUOp := fun x => x mod 9223372036854775808%Z ; TUOpInj := _ |}%Z.
Next Obligation.
  unfold int_of_nat.
  rewrite Uint63.of_Z_spec.
  reflexivity.
Qed.
Add Zify UnOp Op_int_of_nat.

Lemma int_of_nat_inj : forall n n',
    n < 63 -> n' < 63 ->
    int_of_nat n = int_of_nat n' -> n = n'.
Proof.
  intros.
  unfold int_of_nat in *.
  lia.
Qed.

Definition testbit (i:Uint63.int) (n:nat) :=
  if 63 <=? n then false else Uint63.bit i (int_of_nat n).

Lemma zero_spec: forall n, testbit zero n = false.
Proof.
  intros. unfold testbit,zero.
  rewrite Uint63.bit_0.
  destruct (63 <=?n); auto.
Qed.

Lemma eqb_spec : forall k1 k2, Uint63.eqb k1 k2 = true <-> k1 = k2.
Proof.
  split ; intros.
  apply Uint63.eqb_correct; auto.
  apply Uint63.eqb_complete; auto.
Qed.

Lemma testbit_spec: forall k1 k2, (forall n, testbit k1 n = testbit k2 n) -> k1 = k2.
  Proof.
    intros.
    unfold testbit in *.
    apply Uint63.bit_ext;auto ; intros.
    specialize (H (Z.to_nat (Uint63.to_Z n))).
    destruct (63 <=? Z.to_nat (Uint63.to_Z n)) eqn:EQ.
    -  assert (Uint63.leb Uint63.digits n = true).
       { unfold Uint63.digits. lia. }
       rewrite Uint63.bit_M by assumption.
       rewrite Uint63.bit_M by assumption.
       reflexivity.
    -
      assert ( int_of_nat (Z.to_nat (Uint63.to_Z n)) = n)
        by (unfold int_of_nat ; lia).
    congruence.
  Qed.

  Definition interp:= (fun i => (Uint63.sub i one)).

  Definition is_mask := (fun (m: Uint63.int) (n: nat) => forall p, testbit m p = true <-> n = p).

  Import Uint63.

  Section NatUP.
    Variable P : nat -> bool.

    Fixpoint forall_n  (n:nat) : bool :=
      match n with
    | O => P O
    | S n' => P n && forall_n n'
      end.

    Lemma forall_n_correct : forall n, forall_n n = true -> forall p, p <= n -> P p = true.
    Proof.
      induction n ; simpl.
      - intros. assert (p = 0) by lia.
        congruence.
      - intros.
        rewrite andb_true_iff in H.
        destruct H.
        specialize (IHn H1 p).
        assert (p = S n \/ p <= n) by lia.
        destruct H2 ; subst; auto.
    Qed.

  End NatUP.

  Section NatUP2.
    Variable P : nat -> nat -> bool.

    Fixpoint forall_2n (n:nat) (m:nat) :=
      match n with
      | O => forall_n (P O) m
      | S n' => forall_n (P n) m && forall_2n n' m
      end.

    Lemma forall_2n_correct : forall n m, forall_2n n m = true -> forall p q, p <= n -> q <= m -> P p q = true.
    Proof.
      induction n ; simpl.
      - intros. assert (p = 0) by lia.
        subst.
        eapply forall_n_correct in H ; eauto.
      - intros.
        rewrite andb_true_iff in H.
        destruct H.
        specialize (IHn _ H2 p q).
        assert (p = S n \/ p <= n) by lia.
        destruct H3 ; subst; auto.
        eapply forall_n_correct; eauto.
    Qed.

  End NatUP2.

  Lemma bool_and : forall (b: bool) (P: bool -> Prop),
      (b = true -> P true) /\
      (b = false -> P false) -> P b.
  Proof.
    intros.
    destruct b;
    tauto.
  Qed.

  Ltac elim_if :=
    match goal with
    | |- context[match ?e with
                 | true => _
                 | false => _
                 end] => apply (bool_and e)
    end.

  Lemma mask_small :
    forall m n
           (BOUND : n < 63)
           (BITN : is_mask m n),
      m = Uint63.lsl one (int_of_nat n).
  Proof.
    unfold one.
    intros.
    apply testbit_spec.
    intros.
    destruct (testbit m n0) eqn:TEST.
    - assert (n = n0).
      { apply BITN;auto. }
      subst. clear BITN.
      unfold testbit in *.
      revert TEST.
      rewrite Uint63.bit_lsl.
      rewrite bit_1.
      repeat elim_if.
      lia.
    - assert (n <> n0).
      { specialize (BITN n0).
        intuition congruence. }
      unfold testbit.
      rewrite Uint63.bit_lsl.
      rewrite bit_1.
      repeat elim_if ; intuition try lia.
  Qed.

  Lemma mask_big :
    forall m n
           (BOUND : n >= 63)
           (BITN : is_mask m n),
      False.
  Proof.
    unfold is_mask.
    intros.
    generalize (BITN n).
    generalize (BITN (n+1)).
    intros.
    unfold testbit in *.
    replace (63 <=? n +1) with true in * by lia.
    replace ( 63 <=? n) with true in * by lia.
    intuition lia.
  Qed.

  Definition mask_spec : forall m n, is_mask m n ->
                                     if 63 <=? n then
                                       False
                                     else
                                       m = Uint63.lsl one (int_of_nat n).
  Proof.
    intros.
    destruct (63 <=? n) eqn:EQ.
    eapply mask_big with (n:= n) ; eauto.
    lia.
    eapply mask_small with (n:= n) ; eauto.
    lia.
  Qed.

  Lemma eqb_iff : forall b1 b2,
      Bool.eqb b1 b2 = true <-> (b1 = true <-> b2 = true).
  Proof.
    intros.
    destruct b1,b2; intuition congruence.
  Qed.

  Lemma interp_spec: forall m n, is_mask m n -> forall p, testbit (interp m) p = true <-> (p < n)%nat.
  Proof.
    intros.
    apply mask_spec in H.
    destruct (63 <=? n) eqn:N; [tauto|].
    subst.
    unfold testbit.
    destruct (63 <=?p) eqn:EQ.
    - lia.
    -
      assert (NS : n <= 62) by lia.
      assert (NP : p <= 62) by lia.
      rewrite <- Nat.ltb_lt.
        apply eqb_iff.
        set (Q:= fun n p =>  Bool.eqb (bit (interp (one << int_of_nat n)) (int_of_nat p)) (p <? n)).
        change (Q n p = true).
        eapply (forall_2n_correct _ 62 62);auto.
  Qed.

  Lemma land_spec: forall n k1 k2, testbit (Uint63.land k1 k2) n = testbit k1 n && testbit k2 n.
  Proof.
    intros.
    unfold testbit.
    rewrite Uint63.land_spec.
    destruct (63 <=? n) eqn:T; reflexivity.
  Qed.

  Lemma lxor_spec: forall n k1 k2, testbit (Uint63.lxor k1 k2) n = xorb (testbit k1 n) (testbit k2 n).
  Proof.
    intros.
    unfold testbit.
    rewrite Uint63.lxor_spec.
    destruct (63 <=? n) eqn:T; reflexivity.
  Qed.

  Ltac unfold_wB :=
    let f := fresh "w" in
    set (f := wB) in *;
    compute in f ;
    unfold f in *; clear f.

  Definition  ones (n:int) := ((1 << n) - 1)%uint63.

  Lemma power2_mod : forall n m,
      (0 <= n -> 0 <= m ->
      ((2 ^ n) mod (2 ^ m) =  if Z.ltb n m then 2^n else  0))%Z.
  Proof.
    intros.
    destruct (n <?m)%Z eqn:T.
    - apply Z.mod_small; auto.
      split.
      apply Z.pow_nonneg. lia.
      apply Z.pow_lt_mono_r; lia.
    - assert ((2 ^ n) = 0 + 2^(n-m) * 2^m)%Z.
      rewrite <- Z.pow_add_r.
      simpl. f_equal. lia.
      lia. lia.
      rewrite H1.
      rewrite Z_mod_plus_full.
      apply Z.mod_0_l.
      generalize (Z.pow_pos_nonneg 2 m).
      lia.
  Qed.

  Lemma bit_ones : forall n p,
                          (*(SMALL: (n < Uint63.digits = true)%uint63),*)
      bit (ones n) p = if (ltb p n && (ltb p  63))%uint63 then true else false.
  Proof.
    unfold ones,one.
    intros.
    rewrite bitE.
    rewrite sub_spec.
    rewrite lsl_spec.
    replace (((φ (1)%uint63 * 2 ^ φ (n)%uint63)))%Z with
        (2 ^ (to_Z n))%Z by lia.
    unfold wB.
    rewrite power2_mod by (unfold size ; lia).
    destruct ((φ (n)%uint63 <? Z.of_nat size)%Z) eqn:T.
    - unfold size in *.
      rewrite Z.mod_small.
      replace ( 2 ^ φ (n)%uint63 - φ (1)%uint63)%Z
        with (Z.pred (2 ^ φ (n)%uint63))%Z by lia.
      rewrite <- Z.ones_equiv.
      rewrite Z.testbit_ones_nonneg by lia.
      destruct ((p <? n) && (p <? 63))%uint63 eqn:LT.
      lia. lia.
      assert (BOUND : (0 < 2 ^ to_Z n < wB)%Z).
      { unfold wB.
        split.
        apply Z.pow_pos_nonneg; lia.
        apply Z.pow_lt_mono_r.
        lia. unfold size. lia.
        unfold digits, size in *.
        lia.
      }
      lia.
    -
      assert (1 < 2 ^ Z.of_nat size)%Z.
      {
        apply Z.pow_gt_1.
        lia.
        lia.
      }
      rewrite Z_mod_nz_opp_full; rewrite Z.mod_small ; try lia.
      replace ( 2 ^ Z.of_nat size - φ (1)%uint63)%Z
        with (Z.pred (2 ^ Z.of_nat size))%Z by lia.
      rewrite <- Z.ones_equiv.
      rewrite Z.testbit_ones_nonneg by lia.
      destruct ((p <? n)%uint63 && (p <? 63)%uint63) eqn:T2.
      lia.
      lia.
  Qed.

  Definition split_m (i: int) (m: int) :=
    ( (i land ((ones digits) << m)) lor ((i land (ones m))))%uint63.

  Lemma split_all : forall i m,
      i = split_m i m.
  Proof.
    intros.
    unfold split_m.
    apply bit_ext.
    intros.
    rewrite lor_spec.
    rewrite Uint63.land_spec.
    rewrite bit_lsl.
    rewrite Uint63.land_spec.
    rewrite! bit_ones.
    generalize (bit_M i n).
    destruct ((n <? m)%uint63 || (digits ≤? n)%uint63) eqn:T1.
    destruct ((n <? m)%uint63 && (n <? 63)%uint63) eqn:T2.
    - unfold digits in *.
      destruct (bit i n); try lia.
    - unfold digits in *.
      destruct (bit i n); try lia.
    - destruct ((n - m <? digits)%uint63 && (n - m <? 63)%uint63) eqn:T2.
      destruct ((n <? m)%uint63 && (n <? 63)%uint63) eqn:T3.
      unfold digits in *.
      destruct (bit i n); try lia.
      unfold digits in *.
      destruct (bit i n); try lia.
      destruct ((n <? m)%uint63 && (n <? 63)%uint63) eqn:T3.
      unfold digits in *.
      destruct (bit i n); try lia.
      unfold digits in *.
      destruct (bit i n); try lia.
  Qed.

  Definition is_set (k:int) (m:nat) :=
      (forall p, (p < m)%nat -> testbit k p = false) /\
      testbit k m = true.

  Definition is_set_int (k:int) (m:int) :=
      (forall p, (p <? m = true)%uint63 -> bit k p = false) /\
      bit k m = true.

  Ltac split_and :=
    match goal with
      | |- ?A /\ ?B => split ; intros; split_and
      | _ => idtac
    end.

  Definition nat_of_int (i:int) := Z.to_nat (to_Z i).

  Lemma is_set_small : forall k m, is_set k m -> m < 63.
  Proof.
    intros.
    unfold is_set in *.
    destruct H.
    unfold testbit in *.
    destruct (63 <=? m) eqn:EQ ; lia.
  Qed.

  Lemma is_set_eq :
    forall k m, is_set k  m ->
                exists n, n = int_of_nat m /\
                          (n <? digits = true)%uint63 /\
                          is_set_int k n.
  Proof.
    intros.
    assert (SM := is_set_small _ _ H).
    unfold is_set, is_set_int in *.
    destruct H.
    exists (int_of_nat m).
    split_and; intros.
    - reflexivity.
    - unfold digits ; lia.
    - unfold testbit in H.
      rewrite <- H with (p := nat_of_int p).
      replace (63 <=? nat_of_int p) with false by (unfold nat_of_int in* ; lia).
      f_equal. unfold nat_of_int ; lia.
      unfold nat_of_int ; lia.
    - unfold testbit in H0.
      rewrite <- H0.
      destruct (63 <=? m) ; congruence.
  Qed.

  Lemma is_set_decomp : forall k m,
      is_set k m ->
      (k = ((k >> (int_of_nat m + 1)) << (int_of_nat m + 1))  lor (1 << int_of_nat m))%uint63.
  Proof.
    intros.
    apply is_set_eq in H.
    destruct H as (n & EQ & LT & SET).
    unfold is_set_int in SET.
    destruct SET as [F T].
    rewrite <- EQ.
    clear EQ.
    apply bit_ext.
    intros.
    rewrite lor_spec.
    rewrite ! bit_lsl.
    rewrite ! bit_lsr.
    assert (n0 = n \/ n0 <? n = true \/ (Uint63.ltb n n0  && Uint63.ltb n0 digits) = true \/ (Uint63.leb digits n0) = true)%uint63 by lia.
    destruct H as [H | [H | [H |H]]].
    + subst.
      rewrite T.
      repeat elim_if.
      rewrite bit_1.
        lia.
    + rewrite F by auto.
      repeat elim_if.
      rewrite bit_1.
      lia.
    + rewrite andb_true_iff in H.
      destruct H.
      replace (n0 <? n + 1)%uint63 with false by lia.
      simpl.
      replace (digits <=? n0)%uint63 with false by lia.
      replace ((n0 - (n + 1) ≤? n + 1 + (n0 - (n + 1)))%uint63) with true by lia.
      replace ((n + 1 + (n0 - (n + 1))))%uint63 with n0 by lia.
      elim_if.
      rewrite bit_1.
      destruct (bit k n0); lia.
    + rewrite bit_M; auto.
      repeat elim_if.
      rewrite! bit_1.
      lia.
  Qed.

  Lemma sub_pow2 : forall x k m,
      (0 <= k < m)%Z ->
      (0<= x < 2^m)%Z  ->
      (x - x mod 2 ^ (k+1) + 2^k < 2^ m )%Z.
  Proof.
    intros.
    assert (2 ^(k +1) = 2 * 2^k)%Z.
    {
      rewrite Z.pow_add_r; lia.
    }
    rewrite H1.
    clear H1.
    assert (exists n, Z.of_nat n = m).
    {
      exists (Z.to_nat m).
      lia.
    }
    destruct H1 as (m' & EQ).
    subst.
    revert x k H0 H.
    induction m'.
    - intros.
      change (2^ Z.of_nat 0)%Z with 1%Z in *.
      assert (x = 0)%Z by lia.
      subst. lia.
    - intros.
      replace (Z.of_nat (S m'))%Z with (1 + Z.of_nat m')%Z  in * by lia.
      assert (DB : (0 <= x / 2 < 2^ Z.of_nat m')%Z).
      {
        rewrite Z.pow_add_r in H0 by lia.
        lia.
      }
      assert (k = 0 \/ 0<= k-1 < Z.of_nat m')%Z by lia.
      destruct H1.
      +  subst.
         change (2 * 2^0)%Z with 2%Z.
         rewrite Z.pow_add_r in * by lia.
         lia.
      +
        specialize (IHm' (x / 2)%Z _ DB H1).
        rewrite Z.pow_add_r by lia.
        assert (2 * 2^ (k-1) = 2 ^k)%Z.
        {
          change 2%Z with (2^1)%Z at 1.
          rewrite <- Z.pow_add_r by lia.
          f_equal. lia.
        }
        rewrite H2 in IHm'.
        assert (2^0 <= 2 ^ k)%Z.
        {
          apply Z.pow_le_mono_r; lia.
        }
        assert (2 * (x / 2 - (x / 2) mod 2 ^ k + 2 ^ (k - 1)) + 1 < 2 * 2 ^ Z.of_nat m')%Z by lia.
        eapply Z.le_lt_trans ; eauto.
        ring_simplify.
        rewrite H2.
        cut (x - x mod (2 * 2 ^ k) <=
                2 * (x / 2) - 2 * ((x / 2) mod 2 ^ k) + 1)%Z.
        lia.
        clear - H3.
        zify.
        rewrite H5 by lia.
        rewrite H10 by lia.
        assert (q1 = q0) by nia.
        lia.
  Qed.

  Lemma to_Z_branch_bit : forall k m
      (SMALL : (m <? 63 = true)%uint63),
      to_Z
        ((k >> (m + 1)) << (m + 1) + 1 << m)%uint63 =

      ((to_Z k  / 2^ (to_Z m + 1)) * 2^ (to_Z m + 1) + 2^ (to_Z m))%Z.
  Proof.
    intros.
    rewrite add_spec.
    rewrite! lsl_spec.
    rewrite lsr_spec.
    rewrite add_spec.
    change (to_Z m + to_Z 1%uint63)%Z with (to_Z m + 1)%Z.
    assert (B1 : (0 <= φ (1)%uint63 * 2 ^ φ (m)%uint63 < wB)%Z).
    {
      replace (φ (1)%uint63 * 2 ^ φ (m)%uint63)%Z with (2 ^ to_Z m)%Z by lia.
      split.
      apply Z.pow_nonneg.
      lia.
      apply Z.pow_lt_mono_r.
      lia.
      lia.
      lia.
    }
    assert (B2 : (2^1 <= 2 ^ ((φ (m)%uint63 + 1)))%Z).
    {
      apply Z.pow_le_mono_r.
      lia.
      lia.
    }
    assert (B3 :  (0 <=  φ (k)%uint63 / 2 ^ ((φ (m)%uint63 + 1)))%Z).
    {
      nia.
    }
    assert (B4 :  (0 <=
   φ (k)%uint63 / 2 ^ ((φ (m)%uint63 + 1) mod wB) * 2 ^ ((φ (m)%uint63 + 1) mod wB) <
   wB)%Z).
    {
      change (Z.of_nat size) with 63%Z in *.
      rewrite Z.mod_small by lia.
      split.
      apply Z.mul_nonneg_nonneg ; nia.
      nia.
    }
    rewrite! Z.mod_small; auto.
    - lia.
    - unfold wB.
      change (Z.of_nat size) with 63%Z.
      lia.
    - rewrite Z.mod_small;auto.
      rewrite Z.mod_small;auto.
      rewrite Z.mod_small;auto.
      split.
      lia.
      clear B4.
      unfold wB in *.
      change (Z.of_nat size) with 63%Z.
      assert (φ (k)%uint63 / 2 ^ (φ (m)%uint63 + 1) * 2 ^ (φ (m)%uint63 + 1) =
              to_Z k - to_Z k mod 2 ^ (φ (m)%uint63 + 1))%Z.
      nia.
      rewrite H.
      change (to_Z 1%uint63) with 1%Z.
      rewrite Z.mul_1_l.
      apply sub_pow2.
      lia.
      lia.
      unfold wB.
      change (Z.of_nat size) with 63%Z.
      lia.
  Qed.

  Lemma testbit_0 : forall a n,
      (0 <= n)%Z ->
      Z.testbit a n = ((a / 2 ^ n) mod 2 =? 1)%Z.
  Proof.
    intros.
    generalize  (Z.testbit_true a n H).
    destruct (Z.testbit a n); intuition.
    - rewrite H0. reflexivity.
    - assert ((a / 2 ^ n) mod 2 = 0 \/ a / 2 ^ n mod 2 = 1)%Z.
      clear. lia.
      destruct H0.
      rewrite H0. reflexivity.
      intuition congruence.
  Qed.

  Definition not_int (x : int) := (- x - 1)%uint63.

  Lemma bit_not_int : forall x n
      (SN : (n <? digits = true)%uint63),
      bit (not_int x) n = negb (bit x n).
  Proof.
    unfold not_int.
    intros.
    rewrite! bitE.
    unfold Uint63.opp.
    rewrite sub_spec.
    assert (x = 0 \/ x <> 0)%uint63 by lia.
    destruct H.
    - subst.
      change (to_Z (0 - 0)%uint63) with 0%Z.
      rewrite Z.bits_0. simpl.
      change ( - to_Z 1%uint63 mod wB)%Z with (wB - 1)%Z.
      assert (nat_of_int n <= 62).
      { unfold nat_of_int, digits in * ; lia. }
      replace (to_Z n) with (Z.of_nat (nat_of_int n)) by
          (unfold nat_of_int in * ; lia).
      set (P := fun n =>   Z.testbit (wB - 1) (Z.of_nat n)).
      change (P (nat_of_int n) = true).
      eapply (forall_n_correct _ 62); auto.
    -
      rewrite sub_spec.
      rewrite Z.sub_0_l.
      unfold digits in SN.
      rewrite Z.mod_opp_l_nz.
      rewrite (Z.mod_small  (to_Z x)%Z).
      rewrite Z.mod_small.
      rewrite <- (Z.opp_involutive  (wB - φ (x)%uint63 - φ (1)%uint63)).
      rewrite Z.bits_opp.
      f_equal.
      replace ((Z.pred (- (wB - φ (x)%uint63 - φ (1)%uint63))))%Z with
          (to_Z x + (-1) * wB)%Z by lia.
      rewrite! testbit_0 by lia.
      replace (-1 * wB)%Z with ((2 * (-1 * 2^(62 - to_Z n))) * 2^(to_Z n))%Z.
      rewrite Z_div_plus.
      rewrite Z.mul_comm.
      rewrite Z_mod_plus_full.
      reflexivity.
      apply pow2_pos.
      lia.
      unfold wB.
      change (Z.of_nat size) with 63%Z.
      replace 63%Z with (1 + (62 - to_Z n) + to_Z n)%Z by lia.
      rewrite! Z.pow_add_r.
      all: try (change wB with (2^63)%Z ; lia).
  Qed.

  Lemma opp_spec : forall x, (- x = not_int x + 1)%uint63.
  Proof.
    unfold not_int.
    intros. lia.
  Qed.

  Lemma bit_ext' : forall a b,
      (forall n, n <? digits = true -> bit a n = bit b n)%uint63 ->
      a = b.
  Proof.
    intros.
    apply bit_ext.
    intros.
    assert (digits <=? n = true \/ n <? digits = true)%uint63 by lia.
    destruct H0.
    - rewrite! bit_M by auto.
      reflexivity.
    - apply H ; auto.
  Qed.

  Lemma not_int_lor : forall a b,
      (not_int (a lor b) = (not_int a) land (not_int b))%uint63.
  Proof.
    intros.
    apply bit_ext'; intros.
    rewrite Uint63.land_spec.
    rewrite! bit_not_int by auto.
    rewrite Uint63.lor_spec.
    apply negb_orb.
  Qed.

  Definition bit_excl (x y: int) :=
    (forall n : int, bit x n = true -> bit y n = true -> False).

  Lemma lsl_1_spec : forall n,
      (n <? digits = true)%uint63 ->
      (φ (1 << n)%uint63 = 2 ^ to_Z n)%Z.
  Proof.
    intros.
    rewrite lsl_spec.
    rewrite Z.mod_small.
    lia.
    replace (φ (1)%uint63 * 2 ^ φ (n)%uint63)%Z with
        (2^ to_Z n)%Z by lia.
    split.
    apply Z.pow_nonneg. lia.
    unfold wB.
    unfold size.
    apply  Z.pow_lt_mono_r. lia.
    lia.
    unfold digits in *; lia.
  Qed.

  Lemma bit_pred_1_lsl : forall n i ,
      (n <? digits = true)%uint63 ->
      (bit (1 << n - 1) i)%uint63 =  (to_Z i <? to_Z n)%Z.
  Proof.
    intros.
    rewrite bitE.
    rewrite sub_spec.
    rewrite Z.mod_small.
    rewrite lsl_1_spec by auto.
    replace (2 ^ φ (n)%uint63 - φ (1)%uint63)%Z with
          (Z.pred (2 ^ (to_Z n)))%Z by lia.
    rewrite <- Z.ones_equiv.
    apply Z.testbit_ones_nonneg.
    lia.
    lia.
    rewrite lsl_1_spec by auto.
    assert (2^0 <= 2 ^ to_Z n)%Z.
    { apply Z.pow_le_mono_r ; lia. }
    unfold wB, size. change (Z.of_nat 63) with 63%Z.
    assert (2^ to_Z n < 2 ^ 63)%Z.
    {
      apply Z.pow_lt_mono_r. lia.  lia.
      lia.
    }
    lia.
  Qed.

  Lemma not_int_lsl : forall k m,
      (m <? digits = true)%uint63 ->
      (not_int ((k >> (m+1)) << (m+1) lor (1 << m)) =
         (((not_int k) >> (m+1) << (m+1)) lor (1 << m - 1)))%uint63.
  Proof.
    intros.
    apply bit_ext'; intros.
    rewrite! bit_not_int by auto.
    rewrite! Uint63.lor_spec.
    rewrite bit_pred_1_lsl by auto.
    rewrite bit_lsl.
    rewrite! bit_lsr.
    rewrite! bit_lsl.
    rewrite bit_lsr.
    rewrite bit_not_int.
    replace ((m + 1 + (n - (m + 1))))%uint63 with n by lia.
    rewrite bit_1.
    repeat elim_if.
    intuition try lia.
    destruct (bit k n); lia.
    zify.
    lia.
  Qed.

  Lemma bit_add_or :
    forall x y : int,
      (forall n : int, bit x n = true -> bit y n = true -> False) ->
      (x + y)%uint63 = (x lor y)%uint63.
  Proof.
    intros.
    now apply Uint63.bit_add_or.
  Qed.

  Lemma opp_mask : forall k m,
      (m <? digits = true)%uint63 ->
      (- ((k >> (m + 1)) << ( m + 1) lor 1 <<  m)
      =
      (((not_int k) >> (m+1)) << (m+1)) lor ((1 << m)))%uint63.
  Proof.
    intros.
    rewrite opp_spec.
    rewrite! not_int_lsl by auto.
    repeat rewrite <- bit_add_or.
    zify.
    lia.
    - intros.
      rewrite bit_lsl in H1.
      rewrite bit_1 in H1.
      rewrite bit_lsl in H0.
      rewrite bit_lsr in H0.
      revert H0 H1.
      repeat elim_if.
      intuition try lia.
    - intros.
      rewrite bit_pred_1_lsl in H1 by lia.
      rewrite bit_lsl in H0.
      revert H0 H1.
      elim_if; intuition try lia.
  Qed.

  Lemma LPO : forall (k:Uint63.int), k <> zero -> exists p, testbit k p = true.
  Proof.
    intros.
    unfold zero in *.
    assert (LPO: (exists p, ((p <? int_of_nat size) = true) /\ (bit k p = true))%uint63).
    {
      case (to_Z_bounded k).
      unfold wB.
      assert (0 < size <= 63).
      {
        unfold size. lia.
      }
      revert k H.
      induction size; try lia.
      intros.
      assert (n = 0 \/ 0 < n) by lia.
      destruct H3.
      - subst.
        assert (k = one).
        {
          change (2 ^Z.of_nat 1)%Z with 2%Z in H2.
          unfold one. lia.
        }
        subst.
        exists 0%uint63.
        split. unfold int_of_nat.  lia.
        apply bit_1.
      -
        assert ((k >> 1) = 0 \/ (k  >> 1) <> 0)%uint63 by lia.
        destruct H4.
        + exists 0%uint63.
          unfold int_of_nat.
          split.
          lia.
          destruct (bit k 0) eqn:B0;auto.
          rewrite (bit_split k) in H.
          rewrite B0 in H.
          rewrite H4 in H.
          compute in  H.
          lia.
        +
          assert (exists p : int, (p <? int_of_nat n)%uint63 = true /\ bit (k >> 1) p = true).
          {
            apply IHn ; auto.
            lia.
            lia.
            rewrite lsr_spec.
            replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z in H2 by lia.
            rewrite Z.pow_add_r  in H2 by lia.
            lia.
          }
          destruct H5.
          exists (x+1)%uint63.
          split.
          unfold int_of_nat in *.
          lia.
          destruct H5.
          rewrite bit_lsr in H6.
          destruct ((x ≤? 1 + x)%uint63) eqn:EQ ; try lia.
          rewrite <- H6.
          f_equal. lia.
    }
    destruct LPO.
    exists (Z.to_nat (to_Z x)).
    unfold testbit.
    destruct (63 <=? Z.to_nat (to_Z x)) eqn:LE.
    unfold int_of_nat,size in H0.
    lia.
    destruct H0.
    rewrite <- H1.
    f_equal.
    unfold int_of_nat; lia.
  Qed.

  Definition lowest_bit (x: int) :=  (x land (opp x))%uint63.

  Fixpoint find_lowest (n: nat) (k: int) (p: nat) :=
    match p with
    | O => n
    | S q => if testbit k (n - p)%nat then (n - p)%nat else find_lowest n k q
    end.

  Lemma find_lowest_spec:
    forall n p k,
      testbit k n = true ->
      (forall q, ((n - p)%nat <= q < find_lowest n k p)%nat -> testbit k q = false) /\ testbit k (find_lowest n k p) = true.
  Proof.
    induction p; intros.
    - simpl. split; auto. intros; lia.
    - apply IHp in H. destruct H as [HA HB].
      simpl. case_eq (testbit k (n - S p)%nat); intros.
      + split; intros; auto; lia.
      + split; intros; auto.
        destruct (Nat.eq_dec (n - S p)%nat q).
        * subst q. auto.
        * apply HA; lia.
  Qed.

  Lemma lopp_spec_low:
    forall k m,
      (forall p, (p < m)%nat -> testbit k p = false) ->
      testbit k m = true ->
      forall p, (p < m)%nat -> testbit (Uint63.opp k) p = false.
  Proof.
    intros.
    assert (IS : is_set k m).
    { unfold is_set ; auto. }
    assert (MSMALL := is_set_small k m IS).
    apply is_set_decomp in IS.
    rewrite IS.
    rewrite opp_mask by (unfold digits; lia).
    unfold testbit.
    replace (int_of_nat (Init.Nat.min p 62)) with (int_of_nat p) by lia.
    rewrite Uint63.lor_spec.
    rewrite bit_lsl.
    rewrite bit_lsl.
    rewrite bit_1.
    repeat elim_if ; lia.
  Qed.

  Lemma lopp_spec_eq: forall k m,
      (forall p, (p < m)%nat -> testbit k p = false) ->
      testbit k m = true ->
      testbit (Uint63.opp k) m = true.
  Proof.
    intros.
    assert (IS : is_set k m).
    { unfold is_set ; auto. }
    assert (MSMALL := is_set_small k m IS).
    apply is_set_decomp in IS.
    rewrite IS.
    rewrite opp_mask by (unfold digits; lia).
    unfold testbit.
    replace (int_of_nat (Init.Nat.min m 62)) with (int_of_nat m) by lia.
    rewrite Uint63.lor_spec.
    rewrite bit_lsl.
    rewrite bit_lsl.
    rewrite bit_1.
    unfold digits.
    repeat elim_if ; lia.
  Qed.

  Definition digits := Some 63%nat.

  Lemma testbit_M : forall k n, le_o digits n -> testbit k n = false.
  Proof.
    simpl.
    intros. unfold testbit.
    replace (63 <=? n)%nat with true by lia.
    reflexivity.
  Qed.

  Lemma lopp_spec_high: forall k m, (forall p, (p < m)%nat -> testbit k p = false) -> testbit k m = true ->
                                    forall p, (p > m)%nat -> ~ le_o digits p ->  testbit (Uint63.opp k) p = negb (testbit k p).
  Proof.
    intros.
    assert (IS : is_set k m).
    { unfold is_set ; auto. }
    assert (MSMALL := is_set_small k m IS).
    apply is_set_decomp in IS.
    rewrite IS. clear IS.
    simpl in H2.
    rewrite opp_mask by (unfold Uint63.digits; lia).
    unfold testbit.
    replace (63 <=?p)%nat with false by lia.
    rewrite! Uint63.lor_spec.
    rewrite bit_lsl.
    rewrite! bit_lsl.
    rewrite bit_1.
    rewrite! bit_lsr.
    unfold Uint63.digits.
    repeat elim_if ; intuition try lia.
    + rewrite bit_not_int by (unfold Uint63.digits ; lia).
    destruct (bit k (int_of_nat m + 1 + (int_of_nat p - (int_of_nat m + 1)))).
    lia.
    lia.
  Qed.

  Lemma ltb_spec: forall m1 n1 m2 n2, is_mask m1 n1 -> is_mask m2 n2 -> (Uint63.ltb m1 m2 = true <-> (n1 < n2)%nat).
  Proof.
    intros.
    apply mask_spec in H.
    apply mask_spec in H0.
    destruct (63 <=? n1)%nat eqn:N1; [tauto|].
    destruct (63 <=? n2)%nat eqn:N2; [tauto|].
    subst.
    assert (NS : (n1 <= 62)%nat) by lia.
    assert (NP : (n2 <= 62)%nat) by lia.
    rewrite <- Nat.ltb_lt.
    apply eqb_iff.
    set (Q:= fun n1 n2=>   Bool.eqb (one << int_of_nat n1 <? one << int_of_nat n2)%uint63 (n1 <? n2)%nat).
    change (Q n1 n2 = true).
    eapply (forall_2n_correct _ 62 62);auto.
  Qed.

#[export] Instance KInt : Keys_Base.Key  Uint63.int :=
    {|
      Keys_Base.eqb:= Uint63.eqb;
      Keys_Base.testbit:= testbit;
      Keys_Base.interp:= (fun i => (Uint63.sub i one));
      Keys_Base.land:= Uint63.land;
      Keys_Base.lxor:= Uint63.lxor;
      Keys_Base.lopp:= Uint63.opp;
      Keys_Base.ltb:= Uint63.ltb;
      Keys_Base.digits := digits;
      Keys_Base.testbit_M := testbit_M;
      Keys_Base.zero_spec:= zero_spec;
      Keys_Base.eqb_spec := KeyInt.eqb_spec;
      Keys_Base.testbit_spec:= testbit_spec;
      Keys_Base.interp_spec:= interp_spec;
      Keys_Base.land_spec:= land_spec;
      Keys_Base.lxor_spec:= lxor_spec;
      Keys_Base.lopp_spec_low:= lopp_spec_low;
      Keys_Base.lopp_spec_eq:= lopp_spec_eq;
      Keys_Base.lopp_spec_high:= lopp_spec_high;
      Keys_Base.ltb_spec:= ltb_spec;
      Keys_Base.LPO := LPO;
  |}.


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

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

Print Assumptions mul.


Require DTS_Def.
Require Import Program.
Require Import Words.

(** Um zu zeigen, dass [Lang_delta] und [Lang_Conf] die gleichen Sprachen beschreiben,
 werden zunaechst noch ein paar Lemmata ueber Gleichheit benoetigt.*)

Module DTS_eq_Lang  (DTS : DTS_Def.DTS_Par).
Import DTS.

Module DTS_Prop := DTS_Def.DTS_Fun DTS.
Import DTS_Prop.

Lemma eq_Q_eq_delta_hat : forall (w : @Word Sigma)(p q : Q)
      (d : forall q p : Q, (p = q) ), delta_hat q w = delta_hat p w.
Proof.
  intros w q p d.
  induction w.
  - simpl.
    apply d.
  - simpl.
    rewrite IHw.
    reflexivity.
Qed.

Lemma delta_hat_eps (q : Q) (w : @Word Sigma) :
      delta_hat q eps = q.
Proof.
  simpl.
  reflexivity.
Defined.

Lemma eq_Q_eq_delta_hat_left : forall (w : @Word Sigma)(p q : Q),
      q = p -> delta_hat q w = delta_hat p w.
Proof.
  intros w p q H.
  induction w.
  - simpl.
    assumption.
  - simpl.
    rewrite IHw.
    reflexivity.
Defined.

Lemma eq_Q_eq_delta_hat_right : forall (p q : Q),
      (forall (w : @Word Sigma),
      delta_hat q w = delta_hat p w) -> q = p.
Proof.
  intros p q H.
  pose (H eps).
  simpl in e.
  exact e.
Defined.

(**  [Lang_delta] und [Lang_Conf] beschreiben die gleichen Sprachen.*)

(** Um zu zeigen, dass [Lang_delta] und [Lang_Conf]  aequivalent zueinander sind, muss sowohl
[Lang_delta] w -> [Lang_Conf] w als auch [Lang_Conf] w -> [Lang_delta] w gezeigt werden. Dazu
sind eine Reihe von Lemmata notwendig.*)

(** Lemmata fuer [Lang_delta_Lang_Conf]*)
Lemma delta_hat_Conf_reverse (w : @Word Sigma) : forall (q : Q),
      Conf_rel (q, (word_reverse w)) (delta_hat q (word_reverse w), eps).
Proof.
  induction w.
  - intro q.
    simpl.
    apply refl.
  - intro q.
    simpl.
    rewrite (delta_hat_Lemma q a (word_reverse w)).
    pose (IHw (delta q a)) as step2.
    exact (step _ _ _ (one_step q a (word_reverse w)) step2).
Qed.

Lemma delta_hat_Conf (w : @Word Sigma) : forall (q : Q),
      Conf_rel (q, w)  (delta_hat q w, eps).
Proof.
  rewrite <- (word_reverse_involutiv w).
  exact (delta_hat_Conf_reverse (word_reverse w)).
Qed.

(** Hinrichtung der Aequivalenz: *)
Lemma Lang_delta_Lang_Conf {w: @Word Sigma} :
      Lang_delta w -> Lang_Conf w.
Proof.
  intro LDw.
  unfold Lang_Conf.
  unfold Lang_delta in LDw.
  exists (delta_hat q0 w).
  split.
  - exact LDw.
  - exact (delta_hat_Conf w q0).
Qed.

(** Lemmata fuer [Lang_Conf_Lang_delta].*)
(** Die vollstaendige Abarbeitung eines umgedrehten Wortes.*)
Lemma Conf_delta_hat_reverse (w : @Word Sigma) : forall (q p : Q),
      Conf_rel (q, word_reverse w) (p, eps) ->
      delta_hat q (word_reverse w)= p.
Proof.
  induction w.
  - simpl.
    intros q p rel.
    dependent destruction rel.
    + reflexivity.
    + dependent destruction c.
       induction w.
      * dependent induction x.
      * dependent induction x.
  - simpl.
    intros q p rel.
    rewrite delta_hat_Lemma.
    dependent destruction rel.
    + rewrite <- (word_reverse_snoc w a) in x.
       apply (f_equal word_reverse) in x.
       rewrite (word_reverse_involutiv (snoc w a)) in x.
       simpl in x.
       dependent destruction x.
    + dependent induction c.
       rewrite <- (word_reverse_involutiv w0) in x.
       rewrite <- (word_reverse_snoc (word_reverse w0) a0) in x.
       rewrite <- (word_reverse_snoc w a) in x.
       apply (word_reverse_injective) in x.
       injection x.
       intros a0Eqa revw0Eqw.
       rewrite a0Eqa in rel.
       apply (f_equal word_reverse) in revw0Eqw.
       rewrite (word_reverse_involutiv w0) in revw0Eqw.
       rewrite revw0Eqw in rel.
       exact (IHw (delta q a) p rel).
Defined.

Lemma Conf_delta_hat (w : @Word Sigma) : forall (q p : Q),
      Conf_rel (q, w) (p, eps) -> delta_hat q w = p.
Proof.
  rewrite <- (word_reverse_involutiv w).
  exact (Conf_delta_hat_reverse (word_reverse w)).
Qed.

(** Rueckrichtung der Aequivalenz: *)
Lemma Lang_Conf_Lang_delta {w: @Word Sigma} :
      Lang_Conf w -> Lang_delta w.
Proof.
  intro LCw.
  unfold Lang_delta.
  unfold Lang_Conf in LCw.
  destruct LCw as [p [pacc rel]].
  rewrite (Conf_delta_hat w q0 p rel).
  exact pacc.
Defined.

End DTS_eq_Lang.


From Undecidability.L Require Import Prelim.MoreBase L.
Require Import Lia.

(* ** Encoding Terms as Programs *)

Inductive Tok := varT (n :nat) | appT | lamT | retT.
Notation Pro := (list Tok) (only parsing).

Instance Tok_eq_dec : eq_dec Tok.
Proof.
repeat intro. hnf. repeat decide equality.
Qed.

Fixpoint compile (s: L.term) : Pro :=
  match s with
    var x => [varT x]
  | app s t => compile s ++ compile t ++ [appT]
  | lam s => lamT :: compile s ++ [retT]
  end.

Inductive reprP : Pro -> term -> Prop :=
  reprPC s : reprP (compile s) (lam s).

Lemma reprP_elim P s': reprP P s' -> exists s, P = compile s /\ s' = lam s.
Proof. inversion 1. eauto. Qed.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List NArith.

Require Import OrderedSet FiniteSet.

Set Implicit Arguments.

Open Scope N_scope.

Section FilterSpec.

Hypothesis A containerA containerA': Type.
Hypothesis OA : Oeset.Rcd A.
Hypothesis contentA : containerA -> list A.
Hypothesis contentA' : containerA' -> list A.

Notation nb_occA a b := (Oeset.nb_occ OA a (contentA b)).
Notation nb_occA' a b := (Oeset.nb_occ OA a (contentA' b)).

Definition is_a_filter_op_strong (fltr : (A -> bool) -> containerA -> containerA') :=
  forall (f : A -> bool) (s : containerA),
  forall t, nb_occA' t (fltr f s) = (nb_occA t s) * (if f t then 1 else 0).

Definition is_a_filter_op (f : A -> bool) (fltr : containerA -> containerA') :=
  forall (s : containerA),
  forall t, nb_occA' t (fltr s) = (nb_occA t s) * (if f t then 1 else 0).

Lemma is_a_filter_op_strong_is_a_filter_op :
  forall fltr, is_a_filter_op_strong fltr <-> (forall f, is_a_filter_op f (fltr f)).
Proof.
intro fltr; unfold is_a_filter_op_strong, is_a_filter_op; split.
- intros H f; apply (H f).
- intros H; apply H.
Qed.

End FilterSpec.

Section MapSpec.

Hypothesis A B containerA containerB: Type.
Hypothesis OA : Oeset.Rcd A.
Hypothesis OB : Oeset.Rcd B.
Hypothesis contentA : containerA -> list A.
Hypothesis contentB : containerB -> list B.

Notation nb_occA a b := (Oeset.nb_occ OA a (contentA b)).
Notation nb_occB a b := (Oeset.nb_occ OB a (contentB b)).

Definition is_a_map_op_strong (mp : (A -> B) -> containerA -> containerB) :=
  forall (f : A -> B) (s : containerA),
  forall t, nb_occB t (mp f s) = Oeset.nb_occ OB t (map f (contentA s)).

Definition is_a_map_op (f : A -> B) (mp : containerA -> containerB) :=
  forall (s : containerA),
  forall t, nb_occB t (mp s) = Oeset.nb_occ OB t (map f (contentA s)).

Lemma is_a_map_op_strong_is_a_map_op :
  forall mp, is_a_map_op_strong mp <-> (forall f, is_a_map_op f (mp f)).
Proof.
intro mp; unfold is_a_map_op_strong, is_a_map_op; split.
- intros H f; apply (H f).
- intros H; apply H.
Qed.

End MapSpec.

Section JoinSpec.
Hypotheses A1 A2 A containerA1 containerA2 containerA: Type.
Hypothesis OA1 : Oeset.Rcd A1.
Hypothesis OA2 : Oeset.Rcd A2.
Hypothesis OA : Oeset.Rcd A.
Hypothesis contentA1 : containerA1 -> list A1.
Hypothesis contentA2 : containerA2 -> list A2.
Hypothesis contentA : containerA -> list A.
Notation nb_occA1 a b := (Oeset.nb_occ OA1 a (contentA1 b)).
Notation nb_occA2 a b := (Oeset.nb_occ OA2 a (contentA2 b)).
Notation nb_occA a b := (Oeset.nb_occ OA a (contentA b)).

Hypothesis Att : Type.
Hypothesis OAtt : Oset.Rcd Att.
Hypothesis FAtt : Fset.Rcd OAtt.

Notation setAtt := (Fset.set FAtt).

Hypothesis sup1 : A1 -> setAtt.
Hypothesis sup2 : A2 -> setAtt.
Hypothesis sup : A -> setAtt.
Hypothesis proj1_ : A -> A1.
Hypothesis proj2_ : A -> A2.

Definition is_a_join_op sa1 sa2 j :=
    forall (s1 : containerA1) (s2 : containerA2),
      (forall t1, 0 < nb_occA1 t1 s1 -> sup1 t1 =S= sa1) ->
      (forall t2, 0 < nb_occA2 t2 s2 -> sup2 t2 =S= sa2) ->

      ((forall t, 0 < nb_occA t (j s1 s2) -> sup t =S= (sa1 unionS sa2)) /\
       (forall t, sup t =S= (sa1 unionS sa2) ->
                  nb_occA t (j s1 s2) = nb_occA1 (proj1_ t) s1 * nb_occA2 (proj2_ t) s2)).

Definition is_a_join_op_alt sa1 sa2 j :=
    forall (s1 : containerA1) (s2 : containerA2),
      (forall t1, 0 < nb_occA1 t1 s1 -> sup1 t1 =S= sa1) ->
      (forall t2, 0 < nb_occA2 t2 s2 -> sup2 t2 =S= sa2) ->
      forall t, nb_occA t (j s1 s2) = nb_occA1 (proj1_ t) s1 * nb_occA2 (proj2_ t) s2 *
                                      (if sup t =S?= (sa1 unionS sa2) then 1 else 0).

Lemma is_a_join_op_is_a_join_op_alt :
  forall sa1 sa2 j, is_a_join_op sa1 sa2 j <-> is_a_join_op_alt sa1 sa2 j.
Proof.
  intros sa1 sa2 j;
    unfold is_a_join_op, is_a_join_op_alt; split;
    intros H s1 s2 H1 H2;
    assert (H' := H _ _ H1 H2).
  - intro t.
    case_eq (sup t =S?= (sa1 unionS sa2)); intro Ht.
    + rewrite (proj2 H' _ Ht), N.mul_1_r; apply refl_equal.
    + rewrite N.mul_0_r; apply Oeset.not_mem_nb_occ.
      case_eq (Oeset.mem_bool OA t (contentA (j s1 s2))); intro Kt; [ | apply refl_equal].
      generalize (proj1 H' t); rewrite Ht; intro Abs; apply sym_eq; apply Abs.
      rewrite <- Oeset.nb_occ_diff_0_pos.
      apply Oeset.mem_nb_occ; apply Kt.
  - split.
    + intros t Ht.
      case_eq (sup t =S?= (sa1 unionS sa2)); intro Kt; [apply refl_equal | ].
      assert (Ht' := H' t).
      rewrite Kt, N.mul_0_r in Ht'.
      rewrite Ht' in Ht; discriminate Ht.
    + intros t Ht; rewrite H', Ht, N.mul_1_r; apply refl_equal.
Qed.

End JoinSpec.

Section FilterJoinSpec.

Hypotheses A1 A2 A containerA1 containerA2 containerA : Type.
Hypothesis OA1 : Oeset.Rcd A1.
Hypothesis OA2 : Oeset.Rcd A2.
Hypothesis OA : Oeset.Rcd A.
Hypothesis contentA1 : containerA1 -> list A1.
Hypothesis contentA2 : containerA2 -> list A2.
Hypothesis contentA : containerA -> list A.
Notation nb_occA1 a b := (Oeset.nb_occ OA1 a (contentA1 b)).
Notation nb_occA2 a b := (Oeset.nb_occ OA2 a (contentA2 b)).
Notation nb_occA a b := (Oeset.nb_occ OA a (contentA b)).

Hypothesis Att : Type.
Hypothesis OAtt : Oset.Rcd Att.
Hypothesis FAtt : Fset.Rcd OAtt.

Notation setAtt := (Fset.set FAtt).

Hypothesis sort1 : containerA1 -> setAtt.
Hypothesis sort2 : containerA2 -> setAtt.
Hypothesis sup1 : A1 -> setAtt.
Hypothesis sup2 : A2 -> setAtt.
Hypothesis sup : A -> setAtt.
Hypothesis proj1_ : A -> A1.
Hypothesis proj2_ : A -> A2.

Definition is_a_filter_join_op (f : A -> bool) sa1 sa2 j :=
    forall (s1 : containerA1) (s2 : containerA2),
      (forall t1, 0 < nb_occA1 t1 s1 -> sup1 t1 =S= sa1) ->
      (forall t2, 0 < nb_occA2 t2 s2 -> sup2 t2 =S= sa2) ->

      ((forall t, 0 < nb_occA t (j s1 s2) -> sup t =S= (sa1 unionS sa2)) /\
       (forall t, sup t =S= (sa1 unionS sa2) ->
                  nb_occA t (j s1 s2) =
                  nb_occA1 (proj1_ t) s1 * nb_occA2 (proj2_ t) s2 * (if f t then 1 else 0))).

End FilterJoinSpec.

Section GroupSpec.

Hypothesis A B containerA containerA': Type.
Hypothesis OA : Oeset.Rcd A.
Hypothesis contentA : containerA -> list A.
Hypothesis contentA' : containerA' -> list A.
Notation nb_occA a b := (Oeset.nb_occ OA a (contentA b)).
Notation nb_occA' a b := (Oeset.nb_occ OA a (contentA' b)).

Hypothesis Att : Type.
Hypothesis OAtt : Oset.Rcd Att.
Hypothesis FAtt : Fset.Rcd OAtt.

Notation setAtt := (Fset.set FAtt).

Definition is_a_grouping_op_strong (G : Type) (mk_g : G -> containerA' -> list B) grp :=
  forall (g : G) (f : B -> bool) (build : B -> A) (s : containerA') t,
    nb_occA t (grp g f build s) = Oeset.nb_occ OA t (map build (filter f (mk_g g s))).

Definition is_a_grouping_op
   (G : Type) (mk_g : G -> containerA' -> list B) (g : G) (f : B -> bool) (build : B -> A) grp :=
  forall (s : containerA') t,
    nb_occA t (grp s) = Oeset.nb_occ OA t (map build (filter f (mk_g g s))).

Lemma is_a_grouping_op_strong_is_a_grouping_op :
  forall (G : Type) (mk_g : G -> containerA' -> list B) grp,
    is_a_grouping_op_strong mk_g grp <->
    (forall g f build, is_a_grouping_op mk_g g f build (grp g f build)).
Proof.
  intros G mk_g grp; unfold is_a_grouping_op, is_a_grouping_op_strong; split.
- intros H g f build; apply (H g f build).
- intros H g f build; apply H.
Qed.

End GroupSpec.


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

(*
  Reduction from:
    Uniform Diophantine Constraint Solvability (H10UC_SAT)
  via:
    Finite Multiset Term Constraint Solvability (FMsetTC_SAT)
  to:
    Finite Multiset Constraint Solvability (FMsetC_SAT)
*)

Require Import Arith Lia List.
Require Cantor.
Import ListNotations.

Require Import Undecidability.SetConstraints.FMsetC.
From Undecidability.SetConstraints.Util Require Facts mset_eq_utils mset_poly_utils.

Require Undecidability.DiophantineConstraints.H10C.
Require Import Undecidability.Synthetic.Definitions.
Require Import Undecidability.Synthetic.ReducibilityFacts.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Local Notation "A ≡ B" := (mset_eq A B) (at level 65).

(* reduction from H10UC_SAT to FMsetTC_SAT *)
Module H10UC_FMsetTC.

(* terms *)
Inductive mset_term : Set :=
  | mset_term_zero : mset_term
  | mset_term_var : nat -> mset_term
  | mset_term_plus : mset_term -> mset_term -> mset_term
  | mset_term_h : mset_term -> mset_term.

Definition constraint : Set := mset_term * mset_term.

(* evaluate an mset wrt. a valuation φ *)
Fixpoint mset_sem (φ : nat -> list nat) (A : mset_term) : list nat :=
  match A with
    | mset_term_zero => [0]
    | mset_term_var x => φ x
    | mset_term_plus A B => (mset_sem φ A) ++ (mset_sem φ B)
    | mset_term_h A => map S (mset_sem φ A)
  end.

(* does the valuation φ that satisfy all contraints *)
Definition mset_sat (φ : nat -> list nat) (l : list constraint) :=
  Forall (fun '(A, B) => (mset_sem φ A) ≡ (mset_sem φ B)) l.

(* is there a valuation φ that satisfies all contraints *)
Definition FMsetTC_SAT (l: list constraint) :=
  exists (φ : nat -> list nat), mset_sat φ l.

Import Facts mset_eq_utils mset_poly_utils.

Module Argument.

Local Notation "t ⊍ u" := (mset_term_plus t u) (at level 40).
Local Notation "'h' t" := (mset_term_h t) (at level 38).
Local Notation "•0" := mset_term_zero.

Coercion mset_term_var : nat >-> mset_term.

(* nat constraints are only satisfied by multisets containing only zeroes *)
Lemma nat_spec {n A B C} :
  (map S B) ++ A ≡ [n] ++ B ++ B ++ B ++ B ->
  (map S (map S C)) ++ A ≡ [2*n] ++ C ++ C ++ C ++ C ->
  Forall (fun a => 0 = a) A.
Proof.
  move=> /(eval_eq (p := 4)) + /(eval_eq (p := 2)).
  rewrite ? eval_norm ? eval_map Nat.pow_mul_r.
  move=> /= ? ?.
  have : eval 2 A = eval 4 A by lia.
  apply /eval_nat_spec. by lia.
Qed.

Fixpoint tower m n :=
  match n with
  | 0 => []
  | S n => (tower m n) ++ (tower m n) ++ (tower m n) ++ (tower m n) ++ [m*n]
  end.

Lemma nat_sat {m n} :
  (map (fun i => m + i) (tower m n)) ++ (repeat 0 (4^n)) ≡ [m*n] ++ (tower m n) ++ (tower m n) ++ (tower m n) ++ (tower m n).
Proof.
  elim: n; first by (have -> : m * 0 = 0 by lia).
  move=> n IH /=. rewrite ?map_app ?repeat_app /= app_nil_r.
  pose L := (map (fun i => m + i) (tower m n)) ++ (repeat 0 (4^n)).
  pose R := [m*n] ++ (tower m n) ++ (tower m n) ++ (tower m n) ++ (tower m n).
  have -> : m + m * n = m * (S n) by nia.
  under (eq_lr (A' := (m * S n) :: (L ++ L ++ L ++ L)) (B' := (m * S n) :: (R ++ R ++ R ++ R)));
    [by eq_trivial | by eq_trivial |].
  apply /eq_cons_iff.
  by do 3 (apply /eq_appI; first done).
Qed.

(* forces instance to be a sequence *)
(* first constraint of encode bound *)
(* type 1 constraint *)
Lemma seq_spec2 {d A B} : A ++ B ≡ [0] ++ (map (fun i => (S d) + i) A) ->
  exists n, A ≡ map (fun i => (S d) * i) (seq 0 n) /\ B = [(S d) * n].
Proof.
  suff : forall k, A ++ B ≡ [(1+d) * k] ++ (map (fun i => (1 + d) + i) A) ->
    A ≡ map (fun i => (1+d) * i) (seq k (length A)) /\ B = [(1+d) * (k + length A)].
  {
    have ->: [0] = [(1+d) * 0] by (f_equal; lia).
    move=> H /H => [[? ->]]. by exists (length A).
  }
  move=> k. elim /(measure_rect (@length nat)) : A k => A IH k H.
  move: (H) => /eq_length. rewrite ?app_length map_length /= => HAB.
  have [b Hb] : exists b, B = [b].
  { move: (B) HAB => [|? [|? ?]] /=; [ by lia | by eexists | by lia ]. }
  subst B.
  move: (H) => /eq_in_iff /(_ ((1 + d) * k)) /iffRL /(_ ltac:(by left)) /in_app_iff [|].
  - move /(@in_split nat) => [A1 [A2 ?]]. subst A.
    have := IH (A1 ++ A2). apply: unnest.
    { rewrite ?app_length /=. by lia. }
    move=> /(_ (1+k)). apply: unnest.
    { move: H. rewrite ?map_app /=.
      move=> + c => /(_ c). rewrite ?(count_occ_app, count_occ_cons).
      have -> : S (k + d * S k) = S (d + (k + d * k)) by lia.
      by lia. }
    move=> {IH} [IH ->]. constructor.
    + have ->: length (A1 ++ (1 + d) * k :: A2) = 1 + length (A1 ++ A2).
      { rewrite ?app_length /=. by lia. }
      apply: (eq_trans eq_app_comm). apply /eq_cons_iff. by apply: (eq_trans eq_app_comm).
    + f_equal. rewrite ?app_length /=. by lia.
  - case; last done. move=> ?. subst b.
    move: H => /(eq_trans eq_app_comm) /eq_app_iff /eq_symm /eq_mapE.
    apply: unnest; first by lia. move=> ?. subst A.
    constructor=> /=; first done.
    f_equal. by lia.
Qed.

(* type 1 constraint satisfied by any sequence *)
Lemma seq_sat2 {d n} :
  let A n := map (fun i => (S d) * i) (seq 0 n) in
  (A n) ++ [(S d) * n] ≡ [0] ++ (map (fun i => (S d) + i) (A n)).
Proof.
  move=> A. elim: n.
  { apply /eq_eq. cbn. f_equal. by nia. }
  move=> n IH.
  rewrite /A seq_last ? map_app -/(A n) /plus -/plus.
  rewrite /(map _ [n]) /(map _ [S d * n]).
  have -> : S (d + S d * n) = S d * S n by lia.
  under map_ext => i do rewrite -/(plus (S d) i).
  rewrite -/(mset_eq _ _).
  apply /(eq_lr
    (A' := S d * S n :: (A n ++ [S d * n]))
    (B' := S d * S n :: ([0] ++ map [eta Init.Nat.add (S d)] (A n))));
    [by eq_trivial | by eq_trivial | ].
  by apply /eq_cons_iff.
Qed.

Lemma seq_sat1 {n} :
  (seq 0 n) ++ [n] ≡ [0] ++ (map S (seq 0 n)).
Proof.
  have -> : S = (fun i => (S 0) + i) by done.
  have -> : seq 0 n = map (fun i => (S 0) * i) (seq 0 n).
  { elim: n; first done.
    move=> n IH. rewrite seq_last map_app - IH /=.
    by rewrite Nat.add_0_r. }
  have -> : [n] = [1*n] by f_equal; lia.
  by apply: seq_sat2.
Qed.

Lemma unify_spec {A m n} : A ++ (map (fun i => 2 * i) (seq 0 m)) ≡ (seq 0 n) ++ map S A ->
  n = m.
Proof.
  move /eq_length. rewrite ?app_length ?map_length ?seq_length. by lia.
Qed.

Definition unify_sat n :
  {A | A ++ (map (fun i => 2*i) (seq 0 n)) ≡ (seq 0 n) ++ map S A}.
Proof.
  elim: n; first by exists [].
  set f := (fun i => 2*i). move=> n [A HA]. exists (A ++ seq n n).
  rewrite ?seq_last ?map_app /=.
  apply /(eq_lr
    (A' := (A ++ map f (seq 0 n)) ++  (seq n n ++ [f n]))
    (B' := (seq 0 n ++ map S A) ++ ([n] ++ map S (seq n n))));
    [by eq_trivial | by eq_trivial |].
  apply: eq_appI; first done.
  rewrite /f. have ->: 2 * n = n + n by lia.
  apply: eq_eq. by rewrite seq_shift -seq_last.
Qed.

(* embed nat^3 into nat to provide fresh variables *)
Definition embed '(x, y, z) := Cantor.to_nat (Cantor.to_nat (x, y), z).
Definition unembed n := let (xy, z) := Cantor.of_nat n in
  (Cantor.of_nat xy, z).

Lemma embed_unembed {xyz} : unembed (embed xyz) = xyz.
Proof.
  case: xyz. case. move=> >.
  by rewrite /embed /unembed ?Cantor.cancel_of_to.
Qed.

Opaque embed unembed.

Definition encode_bound (x: nat): list constraint :=
  let X n := embed (x, n, 0) in
    [
      ((X 1) ⊍ (X 2), •0 ⊍ (h (X 1))); (* X 1 = [0..n-1], X 2 = [n] *)
      ((X 3) ⊍ (X 4), •0 ⊍ (h (h (X 3)))); (* X 3 = [0,2,..2*(m-1)], X 4 = [2*m] *)
      ((X 5) ⊍ (X 3), (X 1) ⊍ (h (X 5))); (* n = m *)
      ((h (X 6)) ⊍ (X 0), (X 2) ⊍ ((X 6) ⊍ ((X 6) ⊍ ((X 6) ⊍ (X 6)))));
      ((h (h (X 7))) ⊍ (X 0), (X 4) ⊍ ((X 7) ⊍ ((X 7) ⊍ ((X 7) ⊍ (X 7))))) (* X 0 = [0..0] of length 2^n *)
    ].

Definition encode_bound_spec {φ x} : mset_sat φ (encode_bound x) ->
  Forall (fun a => 0 = a) (φ (embed (x, 0, 0))).
Proof.
  rewrite /encode_bound /mset_sat ? Forall_norm /mset_sem.
  have -> (A) : map S (map S A) = map (fun i => (S 1) + i) A by rewrite map_map.
  have -> : map S = map [eta Nat.add 1] by done.

  move=> [/seq_spec2 [n [/eq_length Hn ->]]].
  move=> [/seq_spec2 [m [/eq_length Hm ->]]].
  move=> [/eq_length]. rewrite ? app_length Hn Hm ? map_length ? seq_length => ?.
  have ? : n = m by lia. subst m. clear.
  have -> : [eta Nat.add 1] = S by done.
  have -> : 1 * n = n by lia.
  move=> [H1 H2]. by apply: nat_spec.
Qed.

(* [0] ++ [0,1] ++ [0,1,2] ++ ...*)
Definition pyramid n := flat_map (seq 0) (seq 0 n).

(* from a H10UC valuation φ construct a valuation for FMsetC *)
Definition construct_valuation (φ: nat -> nat) (n: nat): list nat :=
  match unembed n with
  | (x, 0, 0) => repeat 0 (4^(φ x))
  | (x, 1, 0) => seq 0 (φ x)
  | (x, 2, 0) => [(φ x)]
  | (x, 3, 0) => map (fun i => 2*i) (seq 0 (φ x))
  | (x, 4, 0) => [2*(φ x)]
  | (x, 5, 0) => proj1_sig (unify_sat (φ x))
  | (x, 6, 0) => tower 1 (φ x)
  | (x, 7, 0) => tower 2 (φ x)
  | (x, 0, 1) => repeat 0 (φ x)
  | (x, 1, 1) => repeat 0 (length (pyramid (φ x)))
  | (x, 2, 1) => repeat 0 (4^(φ x) - (φ x))
  | (x, 3, 1) => repeat 0 (4^(φ x) - (length (pyramid (φ x))))
  | (x, 4, 1) => seq 0 (φ x)
  | (x, 5, 1) => [(φ x)]
  | (x, 6, 1) => pyramid (φ x)
  | (x, 7, 1) => flat_map pyramid (seq 0 (φ x))
  | _ => []
  end.

Lemma encode_bound_sat {φ x} :
  mset_sat (construct_valuation φ) (encode_bound x).
Proof.
  rewrite /encode_bound /mset_sat ? Forall_norm /mset_sem.
  rewrite /construct_valuation ? embed_unembed.
  pose A d n := map (fun i => (S d) * i) (seq 0 n).
  constructor; first by apply: seq_sat1.
  constructor.
  { have -> (X) : map S (map S X) = map (fun i => 2+i) X by rewrite map_map.
    by apply: seq_sat2. }
  constructor; first by apply: proj2_sig (unify_sat _).
  constructor.
  { have -> (n): [n] = [1*n] by f_equal; lia.
    by apply: nat_sat. }
  rewrite map_map. by apply: nat_sat.
Qed.

(* each n : nat is represented by a multiset containing n zeroes *)
Definition encode_nat (x: nat) : list constraint :=
  let X n := embed (x, n, 1) in
    [
      (X 0 ⊍ X 2, mset_term_var (embed (x, 0, 0))); (* X 0 = [0..0] *)
      (X 1 ⊍ X 3, mset_term_var (embed (x, 0, 0))); (* X 1 = [0..0] *)
      (X 4 ⊍ X 5, •0 ⊍ (h (X 4))); (* X 4 = [0..m-1], X 5 = [m]*)
      (X 4 ⊍ X 6, X 0 ⊍ (h (X 6))); (* m = length (X 0), length (X 6) ~ m * m *)
      (X 6 ⊍ X 7, X 1 ⊍ (h (X 7))) (* length X 1 ~ m * m *)
    ].

(* auxiliary lemma for square_spec *)
Lemma square_spec_aux {n m A C} : C ++ (n :: A) ≡ (repeat 0 (S m)) ++ (map S A) ->
  exists A', A ≡ (seq 0 n) ++ A' /\ C ++ A' ≡ (repeat 0 m) ++ (map S A').
Proof.
  elim: n A.
  { move=> A.
    move /(eq_lr (A' := 0 :: (C ++ A)) (B' := 0 :: ((repeat 0 m) ++ map S A))).
    move /(_ ltac:(by eq_trivial) ltac:(by eq_trivial)) /eq_cons_iff=> ?.
    exists A. by constructor. }
  move=> n IH A /copy [/eq_in_iff /(_ (S n)) /iffLR].
  apply: unnest.
  { apply /in_app_iff. right. by left. }
  move /in_app_iff. case; first by move /(@repeat_spec _ _ _ _).
  move /in_map_iff=> [n' [+ +]] => [[->]].
  move /(@in_split _ _) => [A1 [A2 ?]]. subst A.

  move /(eq_lr (A' := S n :: (C ++ (n :: (A1 ++ A2)))) (B' := S n :: ((repeat 0 (S m)) ++ map S (A1 ++ A2)))).
  move /(_ ltac:(by eq_trivial)). apply: unnest.
  { rewrite ? map_app map_cons. by eq_trivial. }
  move /eq_cons_iff => /IH [A' [? ?]].
  exists A'. constructor; last done.
  rewrite seq_last /=.
  apply /(eq_lr (A' := n :: (A1 ++ A2)) (B' := n :: (seq 0 n ++ A')));
    [by eq_trivial | by eq_trivial | ].
  by apply /eq_cons_iff.
Qed.

(* forces B to be a n zeroes and A to be of length in proportion to n squared *)
Lemma square_spec {n A} : (seq 0 n) ++ A ≡ (repeat 0 n) ++ (map S A) ->
  length A + length A + n = n * n.
Proof.
  elim: n A.
  { move=> A /eq_symm /eq_mapE ->; [by lia | done]. }
  move=> n IH A. rewrite seq_last /(plus 0 _).
  move /(eq_lr _ eq_refl (A' := seq 0 n ++ (n :: A))) => /(_ ltac:(by eq_trivial)).
  move /square_spec_aux => [A' [/eq_length + /IH]].
  rewrite app_length seq_length. by lia.
Qed.

(* if encode bound is satisfied, then there is a square relationship on length of solutions *)
Lemma encode_nat_spec {φ x} : mset_sat φ (encode_bound x) -> mset_sat φ (encode_nat x) ->
  length (φ (embed (x, 1, 1))) + length (φ (embed (x, 1, 1))) + length (φ (embed (x, 0, 1))) =
    length (φ (embed (x, 0, 1))) * length (φ (embed (x, 0, 1))).
Proof.
  move /encode_bound_spec. rewrite /mset_sat /encode_nat ?Forall_norm /mset_sem.
  pose X n := φ (embed (x, n, 1)). rewrite -?/(X _).
  move=> H [/eq_Forall_iff /(_ [eta eq 0]) /iffRL /(_ H)].
  rewrite Forall_norm=> [[HX0 _]].
  move=> [/eq_Forall_iff /(_ [eta eq 0]) /iffRL /(_ H)].
  rewrite Forall_norm=> [[? _]].
  have -> : map S (X 4) = map [eta Init.Nat.add 1] (X 4) by done.
  move=> [/seq_spec2 [n]].
  have -> : map [eta Init.Nat.mul 1] (seq 0 n) = map id (seq 0 n).
  { under map_ext => i do have -> : 1*i = i by lia. done. }
  rewrite map_id => [[Hn _]].
  move=> [/eq_symm /eq_trans] => /(_ ((seq 0 n) ++ X 6)).
  apply: unnest; first by apply: eq_appI.
  move=> HX6. have HlX0 : length (X 0) = n.
  { move: HX6 => /eq_length. rewrite ? app_length map_length seq_length. by lia. }
  move: HX6 => /eq_symm. have -> := Forall_repeat HX0. rewrite HlX0.
  move /square_spec => ? /eq_length. rewrite ?app_length map_length repeat_length.
  by lia.
Qed.

Lemma pyramid_shuffle {n} : seq 0 n ++ pyramid n ≡ repeat 0 n ++ map S (pyramid n).
Proof.
  elim: n; first done.
  move=> n IH.
  rewrite /pyramid seq_last /plus flat_map_concat_map map_app concat_app.
  rewrite -flat_map_concat_map -/(pyramid _) ? map_app /= ? app_nil_r seq_shift.
  apply /(eq_lr
    (A' := (seq 0 n ++ [n]) ++ (seq 0 n ++ pyramid n))
    (B' := (0 :: seq 1 n) ++ (repeat 0 n ++ map S (pyramid n))));
    [ by eq_trivial | by eq_trivial | ].
  rewrite -seq_last -/(seq _ (S n)).
  by apply /eq_app_iff.
Qed.

Lemma pyramid_length n : n + length (pyramid n) <= 4 ^ n.
Proof.
  elim: n; first by (move=> /=; lia).
  move=> n IH.
  rewrite /pyramid seq_last /plus -/plus flat_map_concat_map map_app concat_app app_length.
  rewrite -flat_map_concat_map -/(pyramid _).
  rewrite /map /concat app_length seq_length /=.
  have := Nat.pow_gt_lin_r 4 n ltac:(lia).
  by lia.
Qed.

Lemma encode_nat_sat_aux {n} :
  pyramid n ++ flat_map pyramid (seq 0 n) ≡ repeat 0 (length (pyramid n)) ++ (map S (flat_map pyramid (seq 0 n))).
Proof.
  elim: n; first done.
  move=> n IH.
  rewrite /pyramid ? seq_last /plus ? (flat_map_concat_map, map_app, concat_app, app_length).
  rewrite -?flat_map_concat_map -/pyramid -/(pyramid _) ?repeat_app seq_length /= ?app_nil_r.
  apply /(eq_lr
    (A' := (pyramid n ++ flat_map pyramid (seq 0 n)) ++ (seq 0 n ++ pyramid n))
    (B' := (repeat 0 (length (pyramid n)) ++ map S (flat_map pyramid (seq 0 n))) ++ (repeat 0 n ++ map S (pyramid n))));
    [by eq_trivial | by eq_trivial |].
  apply: eq_appI; first done.
  by apply: pyramid_shuffle.
Qed.

Lemma encode_nat_sat {φ x} :
  mset_sat (construct_valuation φ) (encode_nat x).
Proof.
  rewrite /encode_nat /mset_sat ?Forall_norm /mset_sem  /construct_valuation ?embed_unembed.
  rewrite -?repeat_app.
  constructor.
  { apply: eq_eq. f_equal. have := pyramid_length (φ x). by lia. }
  constructor.
  { apply: eq_eq. f_equal. have := pyramid_length (φ x). by lia. }
  constructor; first by apply: seq_sat1.
  constructor; first by apply: pyramid_shuffle.
  by apply: encode_nat_sat_aux.
Qed.

(* represent constraints of shape 1 + x + y * y = z *)
Definition encode_constraint x y z :=
  encode_bound x ++ encode_bound y ++ encode_bound z ++
  encode_nat x ++ encode_nat y ++ encode_nat z ++
  let x := embed (x, 0, 1) in
  let yy := embed (y, 1, 1) in
  let y := embed (y, 0, 1) in
  let z := embed (z, 0, 1) in
  [ (•0 ⊍ x ⊍ yy ⊍ yy ⊍ y, mset_term_var z) ].

(* if mset constraint has a solution, then uniform diophantine constraint is satisfied *)
Lemma encode_constraint_spec {φ x y z} :
  mset_sat φ (encode_constraint x y z) ->
  1 + length (φ (embed (x, 0, 1))) + length(φ (embed (y, 0, 1))) * length(φ (embed (y, 0, 1))) = length(φ (embed (z, 0, 1))).
Proof.
  rewrite /encode_constraint /mset_sat ?Forall_app -?/(mset_sat _ _).
  move=> [Hx [Hy [Hz]]].
  move=> [/(encode_nat_spec Hx) ? [/(encode_nat_spec Hy) ? [/(encode_nat_spec Hz) ?]]].
  rewrite /mset_sat Forall_norm /mset_sem.
  move /eq_length. rewrite ? app_length /=. by lia.
Qed.

(* if uniform diophantine constraint is satisfied, then mset constraint has a solution *)
Lemma encode_constraint_sat {φ x y z} :
  1 + (φ x) + (φ y) * (φ y) = (φ z) -> mset_sat (construct_valuation φ) (encode_constraint x y z).
Proof.
  move=> Hxyz.
  rewrite /encode_constraint /mset_sat ?Forall_app -?/(mset_sat _ _).
  do 3 (constructor; first by apply: encode_bound_sat).
  do 3 (constructor; first by apply: encode_nat_sat).
  constructor; last done.
  rewrite /mset_sem /construct_valuation ? embed_unembed.
  have ->: [0] = repeat 0 1 by done.
  rewrite -?repeat_app. apply: eq_eq. f_equal. move: Hxyz=> <-. clear.
  elim: (φ y); clear; first by (move=> /=; lia).
  move=> φy IH.
  rewrite /pyramid seq_last /(plus 0 _) flat_map_concat_map map_app concat_app.
  rewrite -flat_map_concat_map -/(pyramid _) /= ?app_length seq_length /=. by lia.
Qed.

(* encode a single H10UC constraint as a list of FMsetC constraints *)
Definition encode_h10uc '(x, y, z) := encode_constraint x y z.

End Argument.

Import H10C.

(* many-one reduction from H10UC to FMsetC *)
Theorem reduction : H10UC_SAT ⪯ FMsetTC_SAT.
Proof.
  exists (fun h10ucs => flat_map Argument.encode_h10uc h10ucs).
  move=> h10ucs. constructor.
  - move=> [φ Hφ].
    exists (Argument.construct_valuation φ).
    elim: h10ucs Hφ; first by constructor.
    move=> [[x y] z] h10cs IH.
    move /Forall_forall. rewrite Forall_cons_iff. move=> [Hxyz /Forall_forall /IH].
    move=> {}IH. apply /Forall_app. constructor; last done.
    by apply: Argument.encode_constraint_sat.
  - move=> [φ] Hφ.
    pose ψ := (fun x => length (φ (Argument.embed (x, 0, 1)))).
    exists ψ. rewrite -Forall_forall.
    elim: h10ucs Hφ; first done.
    move=> [[x y] z] h10ucs IH.
    rewrite /flat_map -/(flat_map _) /mset_sat Forall_app /(Argument.encode_h10uc _).
    move=> [/Argument.encode_constraint_spec Hxyz /IH ?].
    by constructor.
Qed.

End H10UC_FMsetTC.

(* reduction from FMsetTC_SAT to FMsetC_SAT *)
Module FMsetTC_FMsetC.

Import Facts mset_eq_utils mset_poly_utils.
Import H10UC_FMsetTC.

Module Argument.

Opaque Cantor.to_nat Cantor.of_nat.
Fixpoint term_to_nat (t: mset_term) : nat :=
  match t with
  | mset_term_zero => 1 + Cantor.to_nat (0, 0)
  | mset_term_var x => 1 + Cantor.to_nat (0, 1+x)
  | mset_term_plus t u => 1 + Cantor.to_nat (1 + term_to_nat t, 1 + term_to_nat u)
  | mset_term_h t => 1 + Cantor.to_nat (1 + term_to_nat t, 0)
  end.

Fixpoint nat_to_term' (k: nat) (n: nat) : mset_term :=
  match k with
  | 0 => mset_term_zero
  | S k =>
    match n with
    | 0 => mset_term_zero
    | S n =>
      match Cantor.of_nat n with
      | (0, 0) => mset_term_zero
      | (0, S x) => mset_term_var x
      | (S nt, 0) => mset_term_h (nat_to_term' k nt)
      | (S nt, S nu) => mset_term_plus (nat_to_term' k nt) (nat_to_term' k nu)
      end
    end
  end.

Definition nat_to_term (n: nat) : mset_term := nat_to_term' (1+n) n.

Lemma nat_term_cancel {t} : nat_to_term (term_to_nat t) = t.
Proof.
  rewrite /nat_to_term.
  move Hk: (k in nat_to_term' k _) => k.
  have : term_to_nat t < k by lia.
  elim: t k {Hk}.
  - move=> [|k]; [by lia | done].
  - move=> x [|k]; first by lia.
    by rewrite /= Cantor.cancel_of_to.
  - move=> nt IHt nu IHu [|k]; first by lia.
    rewrite /= Cantor.cancel_of_to => ?.
    have ? := Cantor.to_nat_non_decreasing (S (term_to_nat nt)) (S (term_to_nat nu)).
    rewrite IHt; first by lia. by rewrite IHu; first by lia.
  - move=> nt IH [|k]; first by lia.
    rewrite /= Cantor.cancel_of_to => ?.
    have ? := Cantor.to_nat_non_decreasing (S (term_to_nat nt)) 0.
    by rewrite IH; first by lia.
Qed.

(* decompose mset_term into elementary constraints *)
Fixpoint term_to_msetcs (t: mset_term) : list msetc :=
  match t with
  | mset_term_zero => [msetc_zero (term_to_nat t)]
  | mset_term_var x => []
  | mset_term_plus u v =>
      [msetc_sum (term_to_nat t) (term_to_nat u) (term_to_nat v)] ++
      (term_to_msetcs u) ++ (term_to_msetcs v)
  | mset_term_h u =>
      [msetc_h (term_to_nat t) (term_to_nat u)] ++ (term_to_msetcs u)
  end.

Definition encode_eq (t u: mset_term) :=
  [(msetc_sum 0 0 0);
  (msetc_sum (term_to_nat t) 0 (term_to_nat u))].

(* encode FMsetC_PROBLEM as LPolyNC_PROBLEM *)
Definition encode_problem (msetcs : list constraint) : list msetc :=
  flat_map (fun '(t, u) => (encode_eq t u) ++ term_to_msetcs t ++ term_to_msetcs u) msetcs.

Lemma term_to_nat_pos {t} : term_to_nat t = S (Nat.pred (term_to_nat t)).
Proof. case: t; by move=> *.  Qed.

Lemma completeness {l} : FMsetTC_SAT l -> FMsetC_SAT (encode_problem l).
Proof.
  move=> [φ] Hφ.
  pose ψ x := if x is 0 then [] else mset_sem φ (nat_to_term x).
  have Hψ (A) : Forall (msetc_sem ψ) (term_to_msetcs A).
  {
    elim: A.
    - by rewrite /term_to_msetcs ? Forall_norm /ψ.
    - by rewrite /term_to_msetcs.
    - move=> A IHA B IHB.
      rewrite /term_to_msetcs -/term_to_msetcs ? Forall_norm.
      constructor; last by constructor.
      rewrite /ψ /msetc_sem ? nat_term_cancel.
      by rewrite ? term_to_nat_pos.
    - move=> A IH.
      rewrite /term_to_msetcs -/term_to_msetcs ? Forall_norm.
      constructor; last done.
      rewrite /ψ /msetc_sem ? nat_term_cancel.
      by rewrite ? term_to_nat_pos.
  }
  exists ψ.
  rewrite - Forall_forall /encode_problem Forall_flat_map.
  apply: Forall_impl; last eassumption.
  move=> [A B]. rewrite ? Forall_norm.
  move=> HφAB. constructor; last by constructor.
  constructor; first done.
  rewrite /ψ /msetc_sem.
  rewrite (@term_to_nat_pos A) (@term_to_nat_pos B).
  by rewrite - ? term_to_nat_pos ? nat_term_cancel.
Qed.

Lemma soundness {l} : FMsetC_SAT (encode_problem l) -> FMsetTC_SAT l.
Proof.
  move=> [ψ]. rewrite -Forall_forall Forall_flat_map => Hψ.
  pose φ x := ψ (term_to_nat (mset_term_var x)).
  exists φ.
  apply: Forall_impl; last by eassumption.
  move=> [t u]. rewrite ? Forall_norm => [[+ [+]]].
  rewrite /msetc_sem -/(msetc_sem _). move=> [/eq_app_nil_nilP /copy [Hψ0 ->]].
  rewrite /app => Hψtu.

  have Hφ (s) : Forall (msetc_sem ψ) (term_to_msetcs s) -> mset_sem φ s ≡ (ψ (term_to_nat s)).
  {
    clear. elim: s.
    - rewrite /term_to_msetcs ? Forall_norm /msetc_sem /φ /mset_sem.
      by apply /eq_symm.
    - by move=> x _.
    - move=> t IHt u IHu.
      rewrite /term_to_msetcs -/term_to_msetcs ? Forall_norm.
      move=> [+ [/IHt {}IHt /IHu {}IHu]].
      rewrite /msetc_sem /φ /mset_sem -/mset_sem -/φ.
      move /eq_symm. apply /eq_trans.
      by apply: eq_appI.
    - move=> t IH.
      rewrite /term_to_msetcs -/term_to_msetcs ? Forall_norm.
      move=> [+ /IH {}IH].
      rewrite /msetc_sem /φ /mset_sem -/mset_sem -/φ.
      move /eq_symm. apply /eq_trans.
      by apply: eq_mapI.
  }
  move=> /Hφ Ht /Hφ Hu.
  under eq_lr; by eassumption.
Qed.

End Argument.

(* many-one reduction from FMsetTC to FMsetC *)
Theorem reduction : FMsetTC_SAT ⪯ FMsetC_SAT.
Proof.
  exists Argument.encode_problem.
  move=> cs. constructor.
  - exact Argument.completeness.
  - exact Argument.soundness.
Qed.

End FMsetTC_FMsetC.

Import H10C.

Theorem reduction : H10UC_SAT ⪯ FMsetC_SAT.
Proof.
  eapply reduces_transitive.
  - exact H10UC_FMsetTC.reduction.
  - exact FMsetTC_FMsetC.reduction.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.

Section original_euclid_original_spp.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma original_euclid__original_spp : euclid_s_parallel_postulate -> alternative_strong_parallel_postulate.
Proof.
  intros oe A B C D P Q R Hos HSuma HNBet.
  assert(HA' := symmetric_point_construction A B).
  destruct HA' as [A'].
  assert(HD' := symmetric_point_construction D C).
  destruct HD' as [D'].
  assert (Hdiff := HSuma).
  apply suma_distincts in Hdiff.
  spliter.
  assert_diffs.
  elim(lea_total B C D C B A'); auto.
  { intro.
    assert(HY := oe A B C D P Q R).
    destruct HY as [Y []]; auto.
      apply (sams_chara _ _ _ _ _ _ A'); Between.
    assert_cols.
    exists Y; auto.
  }

  intro.
  assert(SAMS D' C B C B A') by (apply (sams_chara _ _ _ _ _ _ D); Between).
  assert(HSuma' := ex_suma A' B C B C D').
  destruct HSuma' as [P' [Q' [R' HSuma']]]; auto.
  assert(Hdiff := HSuma').
  apply suma_distincts in Hdiff.
  spliter.
  assert(HY := oe A' B C D' P' Q' R').
  destruct HY as [Y []]; SumA.
  3: exists Y; split; ColR.
  { assert(HNCol1 : ~ Col B C A) by (apply (one_side_not_col123 _ _ _ D); auto).
    assert(HNCol2 : ~ Col B C D) by (apply (one_side_not_col123 _ _ _ A); Side).
    exists D.
    split.
    apply l9_2; apply (l9_8_2 _ _ A); auto.
    - repeat split; Col.
      intro; apply HNCol1; ColR.
      exists B; Col; Between.
    - repeat split; Col.
      intro; apply HNCol2; ColR.
      exists C.
      split; Col; Between.
  }
  intro.
  apply HNBet.
  apply (bet_conga__bet P' Q' R'); auto.
  apply (suma2__conga A B C B C D); auto.
  apply suma_sym.
  apply (conga3_suma__suma A' B C B C D' P' Q' R'); auto.
  3: apply conga_refl; auto.
  - assert(HNCol : ~ Col B C D) by (apply (one_side_not_col123 _ _ _ A); Side).
    assert(TS C B D D').
    { repeat split; Col.
      intro; apply HNCol; ColR.
      exists C; Col; Between.
    }
    apply (sams2_suma2__conga123 _ _ _ _ _ _ B C D' P' Q' R'); auto.
      SumA.
    { apply sams_left_comm.
      repeat split; Col.
        right; intro; assert_cols; Col.
      exists D'.
      split; CongA; split.
        apply l9_9; auto.
      split; Cop.
      intro Hts; destruct Hts as [_ []]; assert_cols; Col.
    }
    apply suma_left_comm.
    exists D'.
    split; CongA; split.
      apply l9_9; auto.
    split; Cop.
    apply conga_line; Between.

  - assert(HNCol : ~ Col B C A) by (apply (one_side_not_col123 _ _ _ D); auto).
    assert(TS B C A A').
    { repeat split; Col.
      intro; apply HNCol; ColR.
      exists B; Col; Between.
    }
    apply (sams2_suma2__conga456 A' B C _ _ _ _ _ _ P' Q' R'); auto.
      SumA.
    { apply sams_left_comm.
      apply sams_sym.
      repeat split; Col.
        right; intro; assert_cols; Col.
      exists A'.
      split; CongA; split.
        apply l9_9; auto.
      split; Cop.
      intro Hts; destruct Hts as [_ []]; assert_cols; Col.
    }
    apply suma_sym.
    exists A'.
    split; CongA; split.
      apply l9_9; auto.
    split; Cop.
    apply conga_line; Between.
Qed.

End original_euclid_original_spp.