(*
(add-to-list 'coq-load-path "~/src/coq/regular/")
*)

Require Import
  ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple finfun div
  path fingraph bigop ssralg ssrnum ssrint intdiv
  dfa_to_re regexp automata.
Import GRing.Theory Num.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma maxn_divr m n d : 0 < d -> maxn (m %/ d) (n %/ d) = maxn m n %/ d.
Proof.
  move => H.
  have BC x y: x < d -> maxn x y %/ d = y %/ d.
    case: (leqP x y); first by move/maxn_idPr => ->.
    by move => H0 H1; rewrite (maxn_idPl (ltnW H0)) !divn_small //;
      apply (leq_ltn_trans (ltnW H0)).
  rewrite {2}(divn_eq m d) {2}(divn_eq n d).
  elim: (m %/ d) (n %/ d).
  - by move => n'; rewrite mul0n add0n max0n BC ?ltn_pmod //
                           divnMDl // divn_small // ltn_pmod.
  - move => n' IH [| m'].
    + by rewrite mul0n add0n maxn0 maxnC BC ?ltn_pmod //
                 divnMDl // divn_small // ltn_pmod.
    + by rewrite maxnSS !mulSn -!addnA -addn_maxr
                 -{1}(mul1n d) divnMDl // add1n -IH.
Qed.

Lemma max_div (I : finType) f d :
  0 < d -> \max_(i : I) f i %/ d = (\max_(i : I) f i) %/ d.
Proof.
  move => H; apply (big_rec2 (fun x y => x = y %/ d)); first by rewrite div0n.
  by move => i x y _ ->; rewrite maxn_divr.
Qed.

Lemma lez_divL d m n : (0 < d -> m <= n * d -> m %/ d <= n)%Z%R.
Proof.
  move => H H0; rewrite -(ler_pmul2r H); apply: (ler_trans _ H0).
  rewrite -[X in (X <= _)%R]addr0 {2}(divz_eq m d) ler_add2l.
  by apply modz_ge0, lt0r_neq0.
Qed.

Definition cons_tuple (A : Type) n (h : A) (t : A ^ n) : A ^ n.+1 :=
  [ffun m =>
   match m with
     | Ordinal 0 Hm => h
     | Ordinal m.+1 Hm =>
       t (@Ordinal n m (eq_ind (m.+1 < n.+1) is_true Hm (m < n) (ltnS _ _)))
   end].

Lemma cons_tuple_const (A : Type) n (x : A) :
  cons_tuple (n := n) x [ffun => x] = [ffun => x].
Proof.
  by apply/ffunP => /= i; rewrite /cons_tuple !ffunE;
    case: i => //; case => // i H; rewrite ffunE.
Qed.

Lemma cons_tuple_map (A B : Type) (f : A -> B) n (h : A) (t : 'I_n -> A) :
  [ffun i => f ((cons_tuple h [ffun i => t i]) i)] =
  cons_tuple (f h) [ffun i => f (t i)].
Proof.
  by apply/ffunP => /= i; rewrite /cons_tuple !ffunE;
    case: i => //; case => // i H; rewrite !ffunE.
Qed.

(* extensions for fintype *)

Section Range.
Variable (i k : int).

Inductive range : predArgType := Range j of ((i <= j) && (j <= k))%R.

Coercion int_of_range r := let: (Range j _) := r in j.

Canonical range_subType := [subType for int_of_range].
Definition range_eqMixin := Eval hnf in [eqMixin of range by <:].
Canonical range_eqType := Eval hnf in EqType range range_eqMixin.
Definition range_choiceMixin := [choiceMixin of range by <:].
Canonical range_choiceType := Eval hnf in ChoiceType range range_choiceMixin.
Definition range_countMixin := [countMixin of range by <:].
Canonical range_countType := Eval hnf in CountType range range_countMixin.
Canonical range_subCountType := [subCountType of range].

Lemma lb_range (r : range) : (i <= r)%R.
Proof. by case: r => /= j /andP []. Qed.

Lemma ub_range (r : range) : (r <= k)%R.
Proof. by case: r => /= j /andP []. Qed.

Lemma range_inj : injective int_of_range.
Proof. exact: val_inj. Qed.

Definition range_enum : seq range :=
  pmap insub
    (map Negz (match i with Negz i' => iota 0 i'.+1 | _ => [::] end) ++
     map Posz (match k with Posz k' => iota 0 k'.+1 | _ => [::] end)).

Lemma range_enum_uniq : uniq range_enum.
Proof.
  rewrite pmap_sub_uniq // cat_uniq !map_inj_in_uniq;
    first (case: i => i'; case: k => k'; rewrite ?iota_uniq // andTb andbT).
  - by rewrite -all_predC /=; elim: map.
  - rewrite -all_predC all_map.
    elim: (iota 0 k'.+1) => //= n ns ->; rewrite andbT.
    by rewrite !inE /=; elim: iota.
  - by move => /= x y _ _ [].
  - by move => /= x y _ _ [].
Qed.

Lemma mem_range_enum r : r \in range_enum.
Proof.
  rewrite -(mem_map range_inj) /= /range_enum.
  case: r => /= j /andP [H H0]; rewrite pmap_filter;
    last by move => j'; case: insubP.
  rewrite mem_filter mem_cat; apply/andP; split;
    first by case: insubP => //; rewrite H H0.
  apply/orP; case: j H H0 => j' H H0; [right | left];
    (rewrite mem_map; last by move => ? ? []).
  - by case: k H0 => // k' H0; rewrite (mem_iota 0 k'.+1).
  - by case: i H => // i' H; rewrite (mem_iota 0 i'.+1) leq0n ltnS.
Qed.

Definition range_finMixin :=
  Eval hnf in UniqFinMixin range_enum_uniq mem_range_enum.
Canonical range_finType := Eval hnf in FinType range range_finMixin.
Canonical range_subFinType := Eval hnf in [subFinType of range].

End Range.

(* term and formula of Presburger arithmetic *)

Inductive term (v : nat) :=
  | t_const   of nat
  | t_var     of 'I_v
  | t_add     of term v & term v
  | t_mulc    of nat & term v.

Inductive formula (v : nat) :=
  | f_all     of formula v.+1
  | f_exists  of formula v.+1
  | f_neg     of formula v
  | f_and     of formula v & formula v
  | f_or      of formula v & formula v
  | f_leq     of term v & term v
  | f_lt      of term v & term v.

(* normal form of Prethburger formula *)

Inductive nformula (v : nat) :=
  | nf_exists of nformula v.+1
  | nf_neg    of nformula v
  | nf_and    of nformula v & nformula v
  | nf_or     of nformula v & nformula v
  | nf_atomic of int ^ v & int.

(* interpretation of Presburger arithmetic  *)

Fixpoint term_val fvs (t : term fvs) (assign : nat ^ fvs) : nat :=
  match t with
    | t_const n => n
    | t_var v => assign v
    | t_add t t' => term_val t assign + term_val t' assign
    | t_mulc n t => n * term_val t assign
  end.

Fixpoint interpret_formula fvs (f : formula fvs) : nat ^ fvs -> Prop :=
  match f with
    | f_all f =>
      fun assign => forall n : nat, interpret_formula f (cons_tuple n assign)
    | f_exists f =>
      fun assign => exists n : nat, interpret_formula f (cons_tuple n assign)
    | f_neg f => fun assign => ~ interpret_formula f assign
    | f_and f f' =>
      fun assign => interpret_formula f assign /\ interpret_formula f' assign
    | f_or f f' =>
      fun assign => interpret_formula f assign \/ interpret_formula f' assign
    | f_leq t t' => fun assign => term_val t assign <= term_val t' assign
    | f_lt t t' => fun assign => term_val t assign < term_val t' assign
  end.

Fixpoint interpret_nformula fvs (f : nformula fvs) : nat ^ fvs -> Prop :=
  match f with
    | nf_exists f =>
      fun assign => exists n : nat, interpret_nformula f (cons_tuple n assign)
    | nf_neg f => fun assign => ~ interpret_nformula f assign
    | nf_and f f' =>
      fun assign => interpret_nformula f assign /\ interpret_nformula f' assign
    | nf_or f f' =>
      fun assign => interpret_nformula f assign \/ interpret_nformula f' assign
    | nf_atomic t n => fun assign => (\sum_(m < fvs) t m * assign m <= n)%R
  end.

(* normal form computation *)

Fixpoint normal_t fvs (t : term fvs) : int ^ fvs * int :=
  (* a_1 x_1 + ... + a_n x_n + m *)
  match t with
    | t_const n => ([ffun => 0%R], (n : int))
    | t_var v => ([ffun v' => (v == v' : int)], 0%R)
    | t_add t t' =>
      let: (cs, n) := normal_t t in
      let: (cs', m) := normal_t t' in
      ([ffun var => cs var + cs' var], n + m)%R
    | t_mulc c t =>
      let: (cs, n) := normal_t t in
      ([ffun var => (c : int) * cs var], (c : int) * n)%R
  end.

Fixpoint normal_f fvs (f : formula fvs) : nformula fvs :=
  match f with
    | f_all f => nf_neg (nf_exists (nf_neg (normal_f f)))
    | f_exists f => nf_exists (normal_f f)
    | f_neg f => nf_neg (normal_f f)
    | f_and f f' => nf_and (normal_f f) (normal_f f')
    | f_or f f' => nf_or (normal_f f) (normal_f f')
    | f_leq t t' =>
      let: (cs, n) := normal_t t in
      let: (cs', m) := normal_t t' in
      nf_atomic [ffun var => cs var - cs' var]%R (m - n)%R
    | f_lt t t' =>
      let: (cs, n) := normal_t t in
      let: (cs', m) := normal_t t' in
      nf_atomic [ffun var => cs var - cs' var]%R (m - n - 1)%R
  end.

(* correctness proof of normal form computation *)

Lemma nt_correct fvs (t : term fvs) assign :
  (term_val t assign : int) =
  (let (c, n) := normal_t t in \sum_(m < fvs) c m * assign m + n)%R.
Proof.
  elim: t assign => /=.
  - move => n assign; rewrite -{1}(add0r (n : int)); f_equal.
    apply big_ind => //.
    + by move => x y <- <-.
    + by move => ? _; rewrite ffunE mul0r.
  - move => v assign; rewrite addr0.
    rewrite (bigID (eq_op^~ v)) /= -{1}(addr0 (assign v : int)); f_equal.
    + by rewrite big_pred1_eq ffunE eqxx mul1r.
    + apply big_ind => //.
      * by move => x y <- <-.
      * by move => ? /negPf; rewrite ffunE eq_sym => -> /=; rewrite mul0r.
  - move => t; case_eq (normal_t t) => cs n _ IHt.
    move => t'; case_eq (normal_t t') => cs' m _ IHt' i.
    rewrite PoszD IHt IHt' !addrA (addrAC _ n); do 2 f_equal.
    by rewrite -big_split /=; apply eq_big => // var _; rewrite ffunE mulrDl.
  - move => c t; case_eq (normal_t t) => cs n H IH i.
    rewrite PoszM IH mulrDr big_distrr /=.
    by f_equal; apply eq_big => // var _; rewrite ffunE mulrA.
Qed.

Lemma nf_correct fvs (f : formula fvs) assign :
  (forall fvs (f : nformula fvs) assign,
    let P := interpret_nformula f assign in ~ ~ P -> P) ->
  (interpret_formula f assign <-> interpret_nformula (normal_f f) assign).
Proof.
  have Hbigop fvs' (a : nat ^ fvs') (cs cs' : int ^ fvs') :
      (\sum_(m0 < fvs') cs' m0 * a m0 - \sum_(m0 < fvs') cs m0 * a m0)%R
    = (\sum_(m0 < fvs') [ffun var => cs' var - cs var] m0 * a m0)%R.
    rewrite (@big_morph _ _ -%R%R 0%R _ 0%R _ (@opprD _))
            ?oppr0 // -big_split /=.
    set x := BigOp.bigop _ _ _; set y := BigOp.bigop _ _ _.
    suff ->: x = y by []; rewrite {}/x {}/y.
    by apply eq_big => // var _; rewrite ffunE mulrDl mulNr.
  move => dne; move: fvs f assign; refine (formula_ind _ _ _ _ _ _ _) => /=.
  - move => fvs f IH assign; split => H.
    + by case => a; apply; apply IH, H.
    + by move => a; apply IH, dne => H0; apply H; exists a.
  - by move => fvs f IH assign; split; case => a H; exists a; apply IH.
  - by move => fvs f IH assign; split => H H0; apply H, IH.
  - by move => fvs f IHf f' IHf' assign; split;
      case => H H0; (split; [apply IHf | apply IHf']).
  - by move => fvs f IHf f' IHf' assign; split;
      (case => H; [left; apply IHf | right; apply IHf']).
  - move => fvs t t' assign; rewrite -lez_nat !nt_correct.
    case_eq (normal_t t); case_eq (normal_t t') => /= cs n _ cs' m _.
    by rewrite -ler_subr_addr -addrA addrC -ler_subl_addr Hbigop.
  - move => fvs t t' assign; rewrite -ltz_nat !nt_correct.
    case_eq (normal_t t); case_eq (normal_t t') => /= cs n _ cs' m _.
    by rewrite ler_sub_addr lez_addr1 -ltr_subr_addr -addrA addrC -ltr_subl_addr
               Hbigop.
Qed.

(* automata construction *)

Section word_assign_conversion.
Variable (fvs : nat).

Fixpoint word_of_assign' (n : nat) (assign : nat ^ fvs) : seq (bool ^ fvs) :=
  match n with
    | 0 => [::]
    | n.+1 =>
      if assign == [ffun => 0]
        then [::]
        else [ffun i => odd (assign i)] ::
             word_of_assign' n [ffun i => assign i %/ 2]
  end.

Definition word_of_assign (assign : nat ^ fvs) : seq (bool ^ fvs) :=
  word_of_assign' (\max_(i < fvs) assign i) assign.

Fixpoint assign_of_word (w : seq (bool ^ fvs)) : nat ^ fvs :=
  match w with
    | [::] => [ffun => 0]
    | ch :: w => [ffun i => ch i + assign_of_word w i * 2]
  end.

Lemma max_div2_ffunE (assign : nat ^ fvs) :
  \max_i [ffun i' => assign i' %/ 2] i = (\max_i assign i) %/ 2.
Proof. by rewrite -max_div //; apply eq_bigr => /= i _; rewrite ffunE. Qed.

Lemma word_of_assign'_eq n m (assign : nat ^ fvs) :
  \max_(i < fvs) assign i <= n -> \max_(i < fvs) assign i <= m ->
  word_of_assign' n assign = word_of_assign' m assign.
Proof.
  elim: n m assign => //=.
  - move => [] //= m assign; case: ifP => // H0 /bigmax_leqP /= H _; move: H0.
    have -> //: assign == [ffun => 0] by
      apply/eqP/ffunP => i; rewrite ffunE; apply/eqP; rewrite -leqn0; apply H.
  - move => n IH [| m] assign; do !case: ifP => //=.
    + move => H0 _ /bigmax_leqP => H; move: H0.
      have -> //: assign == [ffun => 0] by
        apply/eqP/ffunP => i; rewrite ffunE; apply/eqP; rewrite -leqn0; apply H.
    + by move => H _ H0 H1; f_equal; apply IH; rewrite max_div2_ffunE;
        [move: H0 | move: H1]; case: (\max_i _) => // x;
        rewrite ltnS; apply leq_trans; case: x => // x;
        rewrite -add2n -{1}(mul1n 2) divnMDl // add1n ltn_divLR //;
        apply leq_pmulr.
Qed.

Lemma word_of_assign_step assign :
  word_of_assign assign =
  if assign == [ffun => 0] then [::]
    else [ffun i => odd (assign i)] :: word_of_assign [ffun i => assign i %/ 2].
Proof.
  rewrite /word_of_assign; case: ifP.
  - move/eqP => ->.
    have/bigmax_leqP: forall i : 'I_fvs, true -> [ffun => 0] i <= 0 by
      move => i _; rewrite ffunE.
    by case: (\max_i _).
  - rewrite max_div2_ffunE.
    case: {2 3 4}(\max_(i < fvs) assign i) (erefl (\max_(i < fvs) assign i)).
    + move/eq_leq/bigmax_leqP => /= H0.
      suff/ffunP -> : assign =1 [ffun => 0] by rewrite eqxx.
      by move => /= i; apply/eqP; rewrite ffunE -leqn0; apply H0.
    + move => /= n H0 ->; f_equal.
      apply word_of_assign'_eq; rewrite max_div2_ffunE // H0 //.
      by case: n {H0} => // n; rewrite
        -add2n -(mul1n 2) divnMDl // add1n ltn_divLR //; apply leq_pmulr.
Qed.

Lemma cancel_woa_aow : cancel word_of_assign assign_of_word.
Proof.
  rewrite /cancel /word_of_assign => assign.
  set n := (\max_(i < fvs) assign i).
  move: {2 3}n (leqnn n); rewrite {}/n => n; elim: n assign => //=.
  - by move => assign H; apply/ffunP => /= i; rewrite ffunE; apply/eqP;
      move: H; apply contraTT; rewrite (bigID (eq_op^~ i)) /= big_pred1_eq;
      case: (assign i) => // n _; case: (BigOp.bigop _ _ _) => // m;
      rewrite maxnSS.
  - move => n IHn assign H; case: ifP => //=; first by move/eqP.
    move => H0; apply/ffunP => /= i.
    rewrite IHn; first by rewrite !ffunE -modn2 addnC -divn_eq.
    rewrite max_div2_ffunE => {i IHn H0}.
    move: H; apply contraTT; rewrite -!ltnNge leq_divRL // => H.
    by apply: (leq_trans _ H); rewrite mulSn !ltnS muln2 -addnn leq_addr.
Qed.

Lemma assign_of_word_cat (w1 w2 : seq (bool ^ fvs)) :
  assign_of_word (w1 ++ w2) =
  [ffun i => assign_of_word w1 i + 2 ^ (size w1) * assign_of_word w2 i].
Proof.
  apply/ffunP => i; rewrite ffunE.
  elim: w1 => //=.
  - by rewrite ffunE add0n expn0 mul1n.
  - by move => ch w1 IH;
      rewrite !ffunE IH mulnDl addnA mulnAC (mulnC (_ ^ _)) expnS.
Qed.

Lemma assign_of_word_nseq0 n :
  assign_of_word (nseq n [ffun => false]) = [ffun => 0].
Proof. by elim: n => //= n ->; apply/ffunP => i; rewrite !ffunE. Qed.

End word_assign_conversion.

Section word_cons.
Variable (fvs : nat).

Fixpoint word_cons a (w : seq (bool ^ fvs)) : seq (bool ^ fvs.+1) :=
  match w with
    | [::] => word_of_assign (cons_tuple a [ffun => 0])
    | ch :: w' =>
      cons_tuple (odd a) ch :: word_cons (a %/ 2) w'
  end.

Lemma word_cons_correctness a w :
  cons_tuple a (assign_of_word w) = assign_of_word (word_cons a w).
Proof.
  elim: w a => //=; first by move => a; rewrite cancel_woa_aow.
  move => ch w IH a; apply/ffunP => /= i.
  rewrite ffunE -IH /cons_tuple !ffunE; case: i; case => /=.
  - by rewrite -modn2 addnC -divn_eq.
  - by move => i H; rewrite ffunE.
Qed.

End word_cons.

Section dfa_of_atomic_formula.
Variable (fvs : nat).
Variable (cs : int ^ fvs) (n : int).

Definition state_lb : int := Num.min n (- \sum_(i : 'I_fvs | 0 <= cs i) cs i)%R.
Definition state_ub : int := Num.max n (- \sum_(i : 'I_fvs | cs i <= 0) cs i)%R.

Lemma afdfa_s_proof : (state_lb <= n <= state_ub)%R.
Proof. by rewrite /state_lb /state_ub ler_minl ler_maxr lerr. Qed.

Lemma afdfa_trans_proof (q : range state_lb state_ub) (ch : bool ^ fvs) :
  (state_lb <=
   ((int_of_range q - \sum_(i : 'I_fvs | ch i) cs i) %/ 2)%Z <=
   state_ub)%R.
Proof.
  case: q => /= q /andP [].
  rewrite /state_lb /state_ub !lez_divRL // => H H0.
  by apply/andP; split;
    [case: minrP H {H0} => H H0 |
     case: maxrP H0 {H} => H H0; apply lez_divL => //];
  rewrite mulz2 ler_add //; [apply (ler_trans H) | | apply: (ler_trans _ H) |];
  rewrite ler_opp2 big_mkcond [X in (_ <= X)%R]big_mkcond /=;
  apply (big_ind2 (fun (x y : int) => (x <= y)%R) (lerr 0) (@ler_add _)) => i _;
  do 2 case: ifP => //; [| | move => _ | move => _] => /negbT;
    rewrite -ltrNge ltr_def => /andP [].
Qed.

Definition dfa_of_af : dfa [finType of bool ^ fvs] :=
  {| dfa_state      := [finType of range state_lb state_ub];
     dfa_s          := Range afdfa_s_proof;
     dfa_fin q      := (0 <= q)%R;
     dfa_trans q ch := Range (afdfa_trans_proof q ch)
  |}.

Lemma afdfa_equiv w :
  w \in dfa_lang dfa_of_af =
  (\sum_(m < fvs) cs m * (assign_of_word w) m <= n)%R.
Proof.
  rewrite delta_accept unfold_in /=.
  elim: w n afdfa_s_proof => /= [| ch w IH] n' H.
  - have -> //: (\sum_(m < fvs) cs m * [ffun => 0%N] m = 0)%R.
    by apply big_rec => //= i x _ ->; rewrite ffunE mulr0.
  - rewrite delta_cons /= {}IH lez_divRL // ler_subr_addr.
    set x := (_ + _)%R; set y := (\sum_m _)%R;
      have -> // : x = y; rewrite {}/x {}/y.
    rewrite (big_morph (fun x : int => (x * 2)%R) (id1 := 0%R) (op1 := +%R))
            /= ?mul0r //; last by move => /= x y; rewrite mulrDl.
    rewrite (big_mkcond ch) -big_split /=.
    by apply eq_bigr => i _; rewrite ffunE PoszD PoszM mulrDr mulrA addrC;
      case: (ch i); rewrite ?mulr1 ?mulr0.
Qed.

End dfa_of_atomic_formula.

Section nfa_of_exists.
Variable (fvs : nat).
Variable (P : nat ^ fvs.+1 -> Prop) (A : dfa [finType of bool ^ fvs.+1]).
Hypothesis (H_PA : forall w, reflect (P (assign_of_word w)) (w \in dfa_lang A)).

Definition nfa_of_exists : nfa [finType of bool ^ fvs] :=
  let nfa_trans' q ch q' :=
    [exists b : bool, dfa_trans A q (cons_tuple b ch) == q']
  in
  {| nfa_state         := A;
     nfa_s             := dfa_s A;
     nfa_fin q         :=
       [exists (q' | q' \in dfa_fin A),
        connect (nfa_trans' ^~ [ffun => false]) q q'];
     nfa_trans q ch q' := nfa_trans' q ch q'
  |}.

Lemma exists_nfaP w :
  reflect (exists a, P (cons_tuple a (assign_of_word w)))
          (w \in nfa_lang nfa_of_exists).
Proof.
  rewrite /nfa_lang unfold_in /=.
  apply: (iffP idP).
  - move => H.
    suff: exists a n,
      delta (dfa_s A) (word_cons a w ++ nseq n [ffun => false]) \in dfa_fin A.
      move => [a [n]]; rewrite -delta_accept => /H_PA.
      have ->: assign_of_word (word_cons a w ++ nseq n [ffun=> false]) =
               assign_of_word (word_cons a w) by
        apply/ffunP => /= i;
          rewrite assign_of_word_cat assign_of_word_nseq0 !ffunE muln0 addn0.
      by move => H0; exists a; rewrite word_cons_correctness.
    elim: w (dfa_s A) H.
    + move => /= s; rewrite unfold_in =>
        /existsP [q] /andP [H] /connectP [qs H0 H1]; subst q.
      elim: qs s H0 H.
      * move => /= s _ H; exists 0.
        rewrite cons_tuple_const /word_of_assign.
        case: (eq_bigmax [ffun _ : 'I_fvs.+1 => 0]); first by rewrite card_ord.
        by move => /= i ->; exists 0 => /=; rewrite cats0 ffunE /=.
      * move => /= q' qs IH q /andP [] /existsP [] /= b /eqP H;
          subst q' => /IH H /H {IH H} [a] [n H]; exists (a * 2 + b).
        rewrite word_of_assign_step; case: ifP => /=.
        - move/eqP/ffunP/(_ (Ordinal (ltn0Sn fvs))); rewrite !ffunE addnC;
            case: b H => //= H; rewrite add0n => /(f_equal (divn^~2)) /=;
            rewrite mulnK // div0n => H0; subst a; exists n.+1; move: H;
            rewrite !cons_tuple_const /= delta_cons /word_of_assign.
          have -> //: \max_(i < fvs.+1) [ffun=> 0] i = 0 by
            apply/eqP; rewrite -leqn0;
              apply/bigmax_leqP => /= i _; rewrite ffunE.
        - by move => H0; exists n;
            rewrite cons_tuple_map (cons_tuple_map (divn^~2)) odd_add odd_mul
                    andbF oddb divnMDl // div0n divn_small ?addn0 //; case b.
    + by move => /= ch w IH s /existsP [] q /andP [] /existsP [] /= b /eqP H;
        subst q => /IH [] a [n H]; exists (a * 2 + b) => /=; exists n;
        rewrite delta_cons odd_add odd_mul /= andbF /= divnMDl //
                divn_small ?addn0 ?oddb //; case b.
  - case => a; rewrite word_cons_correctness => /H_PA /=.
    rewrite delta_accept /=.
    elim: w a (dfa_s A) => //=.
    + move => a s H0; rewrite unfold_in;
        apply/existsP; eexists; apply/andP; split; first exact: H0;
        apply/connectP; eexists; last reflexivity.
      rewrite /word_of_assign.
      move: (\max_i _) => n; elim: n a s {H0} => //= n IH a s.
      case: ifP => //= _.
      rewrite cons_tuple_map (cons_tuple_map (divn^~2)) /= IH andbT.
      by apply/existsP; exists (odd a).
    + move => ch w IH a s.
      rewrite delta_cons => /IH H0.
      apply/existsP; eexists; apply/andP; split; last exact: H0.
      by apply/existsP; exists (odd a).
Qed.

End nfa_of_exists.

Fixpoint dfa_of_nformula fvs (f : nformula fvs) : dfa [finType of bool ^ fvs] :=
  match f with
    | nf_exists f' => nfa_to_dfa (nfa_of_exists (dfa_of_nformula f'))
    | nf_neg f' => dfa_compl (dfa_of_nformula f')
    | nf_and f1 f2 => dfa_op andb (dfa_of_nformula f1) (dfa_of_nformula f2)
    | nf_or f1 f2 => dfa_op orb (dfa_of_nformula f1) (dfa_of_nformula f2)
    | nf_atomic t n => dfa_of_af t n
  end.

Lemma dfa_of_nformula_correct fvs (f : nformula fvs) w :
  reflect (interpret_nformula f (assign_of_word w))
          (w \in dfa_lang (dfa_of_nformula f)).
Proof.
  move: fvs f w; refine (nformula_rect _ _ _ _ _) => /=.
  - move => fvs f IH w; rewrite -nfa_to_dfa_correct; apply exists_nfaP, IH.
  - by move => fvs f IH w; rewrite dfa_compl_correct; apply: (iffP idP) => /IH.
  - move => fvs f1 IHf1 f2 IHf2 w; rewrite dfa_op_correct;
      apply: (iffP andP); case => /IHf1 H /IHf2 H0; tauto.
  - move => fvs f1 IHf1 f2 IHf2 w; rewrite dfa_op_correct;
      apply: (iffP orP); (case; [move/IHf1 | move/IHf2]); tauto.
  - move => fvs t n w; rewrite afdfa_equiv; apply idP.
Qed.

Lemma presburger_arithmetic_dec fvs (f : formula fvs) assign :
  reflect (interpret_formula f assign)
          (word_of_assign assign \in dfa_lang (dfa_of_nformula (normal_f f))).
Proof.
  have dec_dne P : decidable P -> ~ ~ P -> P by case.
  apply (iffP (dfa_of_nformula_correct _ _)); rewrite cancel_woa_aow;
    apply nf_correct => fvs' f'  assign' /=;
    apply dec_dne,
          decP with (word_of_assign assign' \in dfa_lang (dfa_of_nformula f'));
    rewrite -{1}(cancel_woa_aow assign'); apply dfa_of_nformula_correct.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable tS_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable par_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable pG_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable meet_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_3_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable defparallelogram_1 : (forall A B C D : Universe, (pG_ A B C D -> (par_ A B C D /\ par_ A D B C))).
Variable defparallelogram2_2 : (forall A B C D : Universe, ((par_ A B C D /\ par_ A D B C) -> pG_ A B C D)).
Variable lemma_parallelflip_3 : (forall A B C D : Universe, (par_ A B C D -> (par_ B A C D /\ (par_ A B D C /\ par_ B A D C)))).
Variable lemma_diagonalsmeet_4 : (forall A B C D : Universe, (exists X : Universe, (pG_ A B C D -> (betS_ A X C /\ betS_ B X D)))).
Variable axiom_betweennesssymmetry_5 : (forall A B C : Universe, (betS_ A B C -> betS_ C B A)).
Variable defcollinear_6 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_7 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_8 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_9 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_10 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_11 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_12 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_collinearorder_13 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defparallel_14 : (forall A B C D : Universe, (exists U V Su Sv X : Universe, (par_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V))))))))))))).
Variable defparallel2_15 : (forall A B C D U V Su Sv X : Universe, ((A <> B /\ (C <> D /\ (col_ A B U /\ (col_ A B V /\ (U <> V /\ (col_ C D Su /\ (col_ C D Sv /\ (Su <> Sv /\ (~(meet_ A B C D) /\ (betS_ U X Sv /\ betS_ Su X V)))))))))) -> par_ A B C D)).
Variable defmeet_16 : (forall A B C D : Universe, (exists X : Universe, (meet_ A B C D -> (A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X)))))).
Variable defmeet2_17 : (forall A B C D X : Universe, ((A <> B /\ (C <> D /\ (col_ A B X /\ col_ C D X))) -> meet_ A B C D)).
Variable defoppositeside_18 : (forall P A B Q : Universe, (exists X : Universe, (tS_ P A B Q -> (betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P)))))).
Variable defoppositeside2_19 : (forall P A B Q X : Universe, ((betS_ P X Q /\ (col_ A B X /\ ~(col_ A B P))) -> tS_ P A B Q)).
Variable proposition_29B_20 : (forall A D G H : Universe, ((par_ A G H D /\ tS_ A G H D) -> congA_ A G H G H D)).
Variable lemma_ABCequalsCBA_21 : (forall A B C : Universe, (~(col_ A B C) -> congA_ A B C C B A)).
Variable lemma_equalanglestransitive_22 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).
Variable lemma_NCorder_23 : (forall A B C : Universe, (~(col_ A B C) -> (~(col_ B A C) /\ (~(col_ B C A) /\ (~(col_ C A B) /\ (~(col_ A C B) /\ ~(col_ C B A))))))).
Variable deftriangle_24 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_25 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).
Variable lemma_equalanglesNC_26 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable cn_equalityreverse_27 : (forall A B : Universe, cong_ A B B A).
Variable proposition_26A_28 : (forall A B C D E F : Universe, ((triangle_ A B C /\ (triangle_ D E F /\ (congA_ A B C D E F /\ (congA_ B C A E F D /\ cong_ B C E F)))) -> (cong_ A B D E /\ (cong_ A C D F /\ congA_ B A C E D F)))).
Variable lemma_congruenceflip_29 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable deftrianglecongruence_30 : (forall A B C Ca Cb Cc : Universe, (cong_3_ A B C Ca Cb Cc -> (cong_ A B Ca Cb /\ (cong_ B C Cb Cc /\ (cong_ A C Ca Cc /\ triangle_ A B C))))).
Variable deftrianglecongruence2_31 : (forall A B C Ca Cb Cc : Universe, ((cong_ A B Ca Cb /\ (cong_ B C Cb Cc /\ (cong_ A C Ca Cc /\ triangle_ A B C))) -> cong_3_ A B C Ca Cb Cc)).
Variable lemma_equalanglesflip_32 : (forall A B C D E F : Universe, (congA_ A B C D E F -> congA_ C B A F E D)).
Variable lemma_angledistinct_33 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> (A <> B /\ (B <> C /\ (A <> C /\ (Xa <> Xb /\ (Xb <> Xc /\ Xa <> Xc))))))).
Variable lemma_inequalitysymmetric_34 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_ray4_1_35 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_36 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_37 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_congruencesymmetric_38 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable defequalangles_39 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_40 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).

Theorem proposition_34_41 : (forall A B C D : Universe, (pG_ A C D B -> (cong_ A B C D /\ (cong_ A C B D /\ (congA_ C A B B D C /\ (congA_ A B D D C A /\ cong_3_ C A B B D C)))))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import List.
Import List.ListNotations.
Require Import Omega.

(* maps different pos constructors to different nats *)
Definition pos_constr_test (p : positive) : nat :=
  match p with
  | xH => O
  | xI _ => S O
  | xO _ => S (S O)
  end.

(* same thing, using eliminators *)
Definition pos_constr_test_elim (p : positive) : nat :=
  @positive_rect (fun _ => nat)
                 (fun _ _ => S O)
                 (fun _ _ => S (S O))
                 (O) p.

Lemma pos_constr_test_same :
  forall p,
    pos_constr_test p = pos_constr_test_elim p.
Proof.
  intros. destruct p; simpl; reflexivity.
Qed.

Definition pos_constr_0 := xH.
Definition pos_constr_1 := xI xH.
Definition pos_constr_2 := xO xH.

Require Pretty CompilationUnit.
Require Import SourceLang.
Require OeufPlugin.OeufPlugin.

Definition pos_constr_test_ty : type :=
  ltac:(type_reflect (positive -> nat)).

Definition pos_constr_ty : type :=
  ltac:(type_reflect (positive)).

Definition pos_constr_0_reflect {l} : expr l pos_constr_ty :=
  ltac:(let x := eval unfold pos_constr_0 in pos_constr_0 in reflect x).

Definition pos_constr_1_reflect {l} : expr l pos_constr_ty :=
  ltac:(let x := eval unfold pos_constr_1 in pos_constr_1 in reflect x).

Definition pos_constr_2_reflect {l} : expr l pos_constr_ty :=
  ltac:(let x := eval unfold pos_constr_2 in pos_constr_2 in reflect x).

Definition pos_constr_test_reflect {l} : expr l pos_constr_test_ty :=
  ltac:(let x := eval unfold pos_constr_test_elim in pos_constr_test_elim in reflect x).

Import HList.
Require Import String.

Oeuf Eval lazy Then Write To File "threecon.oeuf"
     (Pretty.compilation_unit.pretty 75
       (CompilationUnit.CompilationUnit _ (hcons (@pos_constr_test_reflect [])
                                          (hcons (@pos_constr_0_reflect [])
                                          (hcons (@pos_constr_1_reflect [])
                                          (hcons (@pos_constr_2_reflect []) hnil))))
                                        ["pos_constr_test"; "pos_constr_0"; "pos_constr_1"; "pos_constr_2"]%list%string)).


Require Import BaseLists.

(** *** Filter *)

Section Filter.
  Variable X : Type.
  Implicit Types (x y: X) (A B C: list X) (p q: X -> bool).

  Fixpoint filter p A : list X :=
    match A with
    | nil => nil
    | x::A' => if p x then x :: filter p A' else filter p A'
    end.

  Lemma in_filter_iff x p A :
    x el filter p A <-> x el A /\ p x.
  Proof.
    induction A as [|y A]; cbn.
    - tauto.
    - destruct (p y) eqn:E; cbn;
        rewrite IHA; intuition; subst; auto.
      destruct (p x); auto.
  Qed.

  Lemma filter_incl p A :
    filter p A <<= A.
  Proof.
    intros x D. apply in_filter_iff in D. apply D.
  Qed.

  Lemma filter_mono p A B :
    A <<= B -> filter p A <<= filter p B.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_id p A :
    (forall x, x el A -> p x) -> filter p A = A.
  Proof.
    intros D.
    induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:E.
      + f_equal; auto.
      + exfalso. apply bool_Prop_false in E. auto.
  Qed.

  Lemma filter_app p A B :
    filter p (A ++ B) = filter p A ++ filter p B.
  Proof.
    induction A as [|y A]; cbn.
    - reflexivity.
    - rewrite IHA. destruct (p y); reflexivity.
  Qed.

  Lemma filter_fst p x A :
    p x -> filter p (x::A) = x::filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_fst' p x A :
    ~ p x -> filter p (x::A) = filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_pq_mono p q A :
    (forall x, x el A -> p x -> q x) -> filter p A <<= filter q A.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_pq_eq p q A :
    (forall x, x el A -> p x = q x) -> filter p A = filter q A.
  Proof.
    intros C; induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:D, (q x) eqn:E.
      + f_equal. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + auto.
  Qed.

  Lemma filter_and p q A :
    filter p (filter q A) = filter (fun x => p x && q x) A.
  Proof.
    induction A as [|x A]; cbn. reflexivity.
    destruct (p x) eqn:E, (q x); cbn;
      try rewrite E; now rewrite IHA.
  Qed.

  Lemma filter_comm p q A :
    filter p (filter q A) = filter q (filter p A).
  Proof.
    rewrite !filter_and. apply filter_pq_eq.
    intros x _. now destruct (p x), (q x).
  Qed.

End Filter.


From Undecidability.Shared.Libs.PSL Require Export BaseLists Dupfree.
Require Import Arith.

Definition elAt := nth_error.
Notation "A '.[' i  ']'" := (elAt A i) (no associativity, at level 50).

Section Fix_X.

  Variable X : eqType.

  Fixpoint pos (s : X) (A : list X) :=
    match A with
    | nil => None
    | a :: A => if Dec (s = a) then Some 0 else match pos s A with None => None | Some n => Some (S n) end
    end.

  Lemma el_pos s A : s el A -> exists m, pos s A = Some m.
  Proof.
    revert s; induction A; simpl; intros s H.
    - contradiction.
    - decide (s = a) as [D | D]; eauto;
        destruct H; try congruence.
      destruct (IHA s H) as [n Hn]; eexists; now rewrite Hn.
  Qed.

  Lemma pos_elAt s A i : pos s A = Some i -> A .[i] = Some s.
  Proof.
    revert i s. induction A; intros i s.
    - destruct i; inversion 1.
    - simpl. decide (s = a).
      + inversion 1; subst; reflexivity.
      + destruct i; destruct (pos s A) eqn:B; inversion 1; subst; eauto.
  Qed.

  Lemma elAt_app (A : list X) i B s : A .[i] = Some s -> (A ++ B).[i] = Some s.
  Proof.
    revert s B i. induction A; intros s B i H; destruct i; simpl; intuition; inv H.
  Qed.

  Lemma elAt_el  A (s : X) m : A .[ m ] = Some s -> s el A.
  Proof.
    revert A. induction m; intros []; inversion 1; eauto.
  Qed.

  Lemma el_elAt (s : X) A : s el A -> exists m, A .[ m ] = Some s.
  Proof.
    intros H; destruct (el_pos H);  eexists; eauto using pos_elAt.
  Qed.

  Lemma dupfree_elAt (A : list X) n m s : dupfree A -> A.[n] = Some s -> A.[m] = Some s -> n = m.
  Proof with try tauto.
    intros H; revert n m; induction A; simpl; intros n m H1 H2.
    - destruct n; inv H1.
    - destruct n, m; inv H...
      + inv H1. simpl in H2. eapply elAt_el in H2...
      + inv H2. simpl in H1. eapply elAt_el in H1...
      + inv H1. inv H2. rewrite IHA with n m...
  Qed.

  Lemma nth_error_none A n l : nth_error l n = @None A -> length l <= n.
  Proof. revert n;
           induction l; intros n.
         - simpl; lia.
         - simpl. intros. destruct n. inv H. inv H. assert (| l | <= n). eauto. lia.
  Qed.

  Lemma pos_None (x : X) l l' : pos x l = None-> pos x l' = None -> pos x (l ++ l') = None.
  Proof.
    revert x l'; induction l; simpl; intros; eauto.
    have (x = a).
    destruct (pos x l) eqn:E; try congruence.
    rewrite IHl; eauto.
  Qed.

  Lemma pos_first_S (x : X)  l l' i  : pos x l = Some i -> pos x (l ++ l') = Some i.
  Proof.
    revert x i; induction l; intros; simpl in *.
    - inv H.
    - decide (x = a); eauto.
      destruct (pos x l) eqn:E.
      + eapply IHl in E. now rewrite E.
      + inv H.
  Qed.

  Lemma pos_second_S x l l' i : pos x l = None ->
                                pos x l' = Some i ->
                                pos x (l ++ l') = Some ( i + |l| ).
  Proof.
    revert i l'; induction l; simpl; intros.
    - rewrite plus_comm. eauto.
    - destruct _; subst; try congruence.
      destruct (pos x l) eqn:EE. congruence.
      erewrite IHl; eauto.
  Qed.

  Lemma pos_length (e : X) n E : pos e E = Some n -> n < |E|.
  Proof.
    revert e n; induction E; simpl; intros.
    - inv H.
    - decide (e = a).
      + inv H. simpl. lia.
      + destruct (pos e E) eqn:EE.
        * inv H. assert (n1 < |E|) by eauto.  lia.
        * inv H.
  Qed.

  Fixpoint replace (xs : list X) (y y' : X) :=
    match xs with
    | nil => nil
    | x :: xs' => (if Dec (x = y) then y' else x) :: replace xs' y y'
    end.

  Lemma replace_same xs x : replace xs x x = xs.
  Proof.
    revert x; induction xs; intros; simpl; [ | destruct _; subst ]; congruence.
  Qed.

  Lemma replace_diff xs x y : x <> y -> ~ x el replace xs x y.
  Proof.
    revert x y; induction xs; intros; simpl; try destruct _; firstorder.
  Qed.

  Lemma replace_pos xs x y y' : x <> y -> x <> y' -> pos x xs = pos x (replace xs y y').
  Proof.
    induction xs; intros; simpl.
    - reflexivity.
    - repeat destruct Dec; try congruence; try lia; subst.
      + rewrite IHxs; eauto. + rewrite IHxs; eauto.
  Qed.

End Fix_X.

Arguments replace {_} _ _ _.

(* Fixpoint  getPosition {E: eqType} (A: list E) x := match A with *)
(*                                                    | nil => 0 *)
(*                                                    | cons x' A' => if Dec (x=x') then 0 else 1 + getPosition A' x end. *)

(* Lemma getPosition_correct {E: eqType} (x:E) A: if Dec (x el A) then forall z, (nth (getPosition A x) A z) = x else getPosition A x = |A |. *)
(* Proof. *)
(*   induction A;cbn. *)
(*   -dec;tauto. *)
(*   -dec;intuition; congruence. *)
(* Qed. *)