(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import ZArith.
Require Import List.
Require Import Bool.
Require Import Psatz.
Require Import Setoid Morphisms.
Require Import Permutation.

Require Import Linalg.
Require Import Loop.
Require Import PolyLoop.
Require Import Misc.
Require Import Semantics.
Require Import Instr.
Require Import VplInterface.
Require Import Result.
Require Import Heuristics.

Require Import Vpl.Impure.
Require Import ImpureAlarmConfig.

Open Scope Z_scope.
Open Scope list_scope.

(** * Creating expressions that evaluate to a given linear function *)

Fixpoint make_linear_expr (n : nat) (l : list Z) :=
  match n, l with
  | O, _ | _, nil => Constant 0
  | S n, x :: l => make_sum (make_mult x (Var n)) (make_linear_expr n l)
  end.

Theorem make_linear_expr_correct_aux :
  forall n l env, (length env >= n)%nat -> eval_expr env (make_linear_expr n l) = dot_product l (rev (firstn n env)).
Proof.
  induction n.
  - intros l env Hel. destruct env; destruct l; simpl in *; auto; lia.
  - intros l env Hel.
    destruct l as [|x l]; simpl in Hel; destruct (rev (firstn (S n) env)) as [|y ev] eqn:Hrev; auto; simpl; auto.
    + destruct env as [|e env]; simpl in *; [lia | destruct (rev (firstn n env)); simpl in *; congruence].
    + rewrite firstn_nth_app with (d := 0) in Hrev by auto. rewrite rev_unit in Hrev.
      injection Hrev as Hnth Hrev. rewrite make_sum_correct, make_mult_correct, IHn by lia; simpl. congruence.
Qed.

Theorem make_linear_expr_correct :
  forall n l env, length env = n -> eval_expr env (make_linear_expr n l) = dot_product l (rev env).
Proof.
  intros. rewrite make_linear_expr_correct_aux by lia. f_equal. f_equal. apply firstn_all2. lia.
Qed.

Definition make_affine_expr (n : nat) (e : (list Z * Z)%type) := make_sum (make_linear_expr n (fst e)) (Constant (snd e)).

Theorem make_affine_expr_correct :
  forall n e env, length env = n -> eval_expr env (make_affine_expr n e) = dot_product (fst e) (rev env) + snd e.
Proof.
  intros. unfold make_affine_expr. rewrite make_sum_correct, make_linear_expr_correct; auto.
Qed.

(** * Creating upper and lower bounds for a given variable in a constraint *)

Definition make_lower_bound n c :=
  make_div (make_sum (Constant ((- nth n (fst c) 0) - 1)) (make_affine_expr n (fst c, -(snd c)))) (-(nth n (fst c) 0)).

Lemma make_lower_bound_correct :
  forall n c env x, length env = n -> nth n (fst c) 0 < 0 -> (eval_expr env (make_lower_bound n c) <= x <-> satisfies_constraint (rev env ++ x :: nil) c = true).
Proof.
  intros n c env x Hlen Hneg.
  unfold satisfies_constraint. simpl.
  reflect. unfold make_lower_bound; rewrite make_div_correct, make_sum_correct, make_affine_expr_correct by auto. simpl.
  rewrite dot_product_app_left, dot_product_resize_right, dot_product_commutative.
  rewrite rev_length, Hlen.
  replace (dot_product (x :: nil) (skipn n (fst c))) with (x * nth n (fst c) 0) at 1;
    [| transitivity (x * nth 0 (skipn n (fst c)) 0);
       [ rewrite nth_skipn; f_equal; f_equal; lia
       | destruct (skipn n (fst c)) as [|z l]; [|destruct l]; simpl; lia
       ]
    ].
  rewrite div_le_iff by lia. nia.
Qed.

Definition make_upper_bound n c :=
  make_div (make_sum (Constant (nth n (fst c) 0)) (make_affine_expr n (mult_vector (-1) (fst c), snd c))) (nth n (fst c) 0).

Lemma make_upper_bound_correct :
  forall n c env x, length env = n -> 0 < nth n (fst c) 0 -> (x < eval_expr env (make_upper_bound n c) <-> satisfies_constraint (rev env ++ x :: nil) c = true).
Proof.
  intros n c env x Hlen Hpos.
  unfold satisfies_constraint. simpl.
  reflect. unfold make_upper_bound; rewrite make_div_correct, make_sum_correct, make_affine_expr_correct by auto. simpl.
  rewrite dot_product_mult_left.
  rewrite dot_product_app_left, dot_product_resize_right, dot_product_commutative.
  rewrite rev_length, Hlen.
  replace (dot_product (x :: nil) (skipn n (fst c))) with (x * nth n (fst c) 0) at 1;
    [| transitivity (x * nth 0 (skipn n (fst c)) 0);
       [ rewrite nth_skipn; f_equal; f_equal; lia
       | destruct (skipn n (fst c)) as [|z l]; [|destruct l]; simpl; lia
       ]
    ].
  rewrite div_gt_iff by lia. nia.
Qed.

Opaque make_lower_bound make_upper_bound.

(** * Finding the upper and lower bounds for a given variable of a polyhedron *)

Fixpoint find_lower_bound_aux (e : option expr) (n : nat) (p : polyhedron) :=
  match p with
  | nil => match e with Some e => Ok e | None => Err "No lower bound found" end
  | c :: p => if nth n (fst c) 0 <? 0 then
               find_lower_bound_aux (Some (match e with Some e => make_max e (make_lower_bound n c) | None => make_lower_bound n c end)) n p
             else
               find_lower_bound_aux e n p
  end.

Lemma find_lower_bound_aux_correct :
  forall n pol env x e lb, find_lower_bound_aux e n pol = Ok lb -> length env = n ->
                      eval_expr env lb <= x <->
                      ((match e with Some e => eval_expr env e <= x | None => True end) /\
                       forall c, In c pol -> nth n (fst c) 0 < 0 -> satisfies_constraint (rev env ++ x :: nil) c = true).
Proof.
  intros n pol. induction pol.
  - intros env x e lb Hlb Hlength. simpl in *.
    destruct e; simpl in *; [|congruence].
    injection Hlb as Hlb; rewrite Hlb.
    split; intros H; tauto.
  - intros env x e lb Hlb Hlen. simpl in *.
    destruct (nth n (fst a) 0 <? 0) eqn:Hcmp.
    + reflect. rewrite IHpol; eauto; simpl.
      destruct e; simpl; [rewrite make_max_correct, Z.max_lub_iff|]; rewrite make_lower_bound_correct by auto; split.
      * intros [[H1 H2] H3]. split; auto. intros c [Hce|Hcin] Hcnth; [congruence|auto].
      * intros [H1 H2]. split; [split|]; auto.
      * intros [H1 H2]. split; auto. intros c [Hce|Hcin] Hcnth; [congruence|auto].
      * intros [H1 H2]. split; auto.
    + reflect. rewrite IHpol; eauto; simpl. f_equiv. split.
      * intros H c [Hce|Hcin] Hcnth; auto; rewrite Hce in *; lia.
      * intros H c Hcin Hcnth; auto.
Qed.

Fixpoint find_upper_bound_aux (e : option expr) (n : nat) (p : polyhedron) :=
  match p with
  | nil => match e with Some e => Ok e | None => Err "No upper bound found" end
  | c :: p => if 0 <? nth n (fst c) 0 then
               find_upper_bound_aux (Some (match e with Some e => make_min e (make_upper_bound n c) | None => make_upper_bound n c end)) n p
             else
               find_upper_bound_aux e n p
  end.

Lemma find_upper_bound_aux_correct :
  forall n pol env x e ub, find_upper_bound_aux e n pol = Ok ub -> length env = n ->
                      x < eval_expr env ub <->
                      ((match e with Some e => x < eval_expr env e | None => True end) /\
                       forall c, In c pol -> 0 < nth n (fst c) 0 -> satisfies_constraint (rev env ++ x :: nil) c = true).
Proof.
  intros n pol. induction pol.
  - intros env x e ub Hub Hlength. simpl in *.
    destruct e; simpl in *; [|congruence].
    injection Hub as Hub; rewrite Hub.
    split; intros H; tauto.
  - intros env x e lb Hub Hlen. simpl in *.
    destruct (0 <? nth n (fst a) 0) eqn:Hcmp.
    + reflect. rewrite IHpol; eauto; simpl.
      destruct e; simpl; [rewrite make_min_correct, Z.min_glb_lt_iff|]; rewrite make_upper_bound_correct by auto; split.
      * intros [[H1 H2] H3]. split; auto. intros c [Hce|Hcin] Hcnth; [congruence|auto].
      * intros [H1 H2]. split; [split|]; auto.
      * intros [H1 H2]. split; auto. intros c [Hce|Hcin] Hcnth; [congruence|auto].
      * intros [H1 H2]. split; auto.
    + reflect. rewrite IHpol; eauto; simpl. f_equiv. split.
      * intros H c [Hce|Hcin] Hcnth; auto; rewrite Hce in *; lia.
      * intros H c Hcin Hcnth; auto.
Qed.

Definition find_lower_bound := find_lower_bound_aux None.
Definition find_upper_bound := find_upper_bound_aux None.

Theorem find_lower_bound_correct :
  forall n pol env x lb, find_lower_bound n pol = Ok lb -> length env = n ->
                    eval_expr env lb <= x <-> (forall c, In c pol -> nth n (fst c) 0 < 0 -> satisfies_constraint (rev env ++ x :: nil) c = true).
Proof.
  intros n pol env x lb Hlb Hlen.
  rewrite find_lower_bound_aux_correct by eauto. simpl. tauto.
Qed.

Theorem find_upper_bound_correct :
  forall n pol env x ub, find_upper_bound n pol = Ok ub -> length env = n ->
                    x < eval_expr env ub <-> (forall c, In c pol -> 0 < nth n (fst c) 0 -> satisfies_constraint (rev env ++ x :: nil) c = true).

Proof.
  intros n pol env x ub Hub Hlen.
  rewrite find_upper_bound_aux_correct by eauto. simpl. tauto.
Qed.

Theorem find_bounds_correct :
  forall n pol env x lb ub, find_lower_bound n pol = Ok lb -> find_upper_bound n pol = Ok ub -> length env = n ->
                       eval_expr env lb <= x < eval_expr env ub <-> (forall c, In c pol -> nth n (fst c) 0 <> 0 -> satisfies_constraint (rev env ++ x :: nil) c = true).
Proof.
  intros n pol env x lb ub Hlb Hub Hlen.
  rewrite find_lower_bound_correct; eauto.
  rewrite find_upper_bound_correct; eauto.
  split.
  - intros [H1 H2] c Hin Hnotzero. destruct (nth n (fst c) 0 <=? 0) eqn:Hcmp; reflect; [apply H1 | apply H2]; auto; lia.
  - intros H; split; intros c Hin Hcmp; apply H; auto; lia.
Qed.

Definition solve_eq n c :=
  (make_div (make_affine_expr n (mult_vector (-1) (fst c), snd c)) (nth n (fst c) 0),
   make_eq (make_mod (make_affine_expr n (mult_vector (-1) (fst c), snd c)) (nth n (fst c) 0)) (Constant 0)).

Lemma solve_eq_correct :
  forall n c env x, length env = n -> nth n (fst c) 0 <> 0 ->
               (eval_expr env (fst (solve_eq n c)) = x /\ eval_test env (snd (solve_eq n c)) = true) <->
                dot_product (rev env ++ x :: nil) (fst c) = snd c.
Proof.
  intros n c env x Hlen Hnz. simpl.
  rewrite make_div_correct, make_eq_correct, make_mod_correct, !make_affine_expr_correct by auto. simpl.
  rewrite !dot_product_mult_left, dot_product_app_left, dot_product_resize_right, dot_product_commutative.
  rewrite rev_length, Hlen.
  replace (dot_product (x :: nil) (skipn n (fst c))) with (x * nth n (fst c) 0) at 1;
    [| transitivity (x * nth 0 (skipn n (fst c)) 0);
       [ rewrite nth_skipn; f_equal; f_equal; lia
       | destruct (skipn n (fst c)) as [|z l]; [|destruct l]; simpl; lia
       ]
    ].
  reflect. split.
  - intros [Hdiv Hmod]. rewrite <- Z.div_exact in Hmod by auto. nia.
  - intros H. rewrite <- H, Z.add_assoc, Z.add_opp_diag_l, Z.add_0_l. split.
    + apply Z.div_mul; auto.
    + apply Z.mod_mul; auto.
Qed.

Definition make_affine_test n c := make_le (make_linear_expr n (fst c)) (Constant (snd c)).

Lemma make_affine_test_correct :
  forall env n c, length env = n -> eval_test env (make_affine_test n c) = satisfies_constraint (rev env) c.
Proof.
  intros. simpl in *. unfold make_affine_test. rewrite make_le_correct, make_linear_expr_correct; auto.
  rewrite dot_product_commutative. reflexivity.
Qed.

Definition make_poly_test n poly :=
  and_all (map (make_affine_test n) poly).

Lemma make_poly_test_correct :
  forall n poly env, length env = n ->
                eval_test env (make_poly_test n poly) = in_poly (rev env) poly.
Proof.
  intros n poly env Hlen.
  unfold make_poly_test. rewrite and_all_correct. unfold in_poly.
  rewrite forallb_map. apply forallb_ext. intros c. apply make_affine_test_correct. auto.
Qed.

Definition scan_dimension (n : nat) (inner : stmt) (p : polyhedron) : imp stmt :=
  match find_eq n p with
  | Some c =>
    let '(result, test) := solve_eq n c in
    let cstrs := map (fun c1 => make_affine_test n (make_constraint_with_eq n c c1)) (filter (fun c => negb (nth n (fst c) 0 =? 0)) p) in
    let cstrs1 := map (make_affine_test n) (filter (fun c => nth n (fst c) 0 =? 0) p) in
    pure (make_guard (make_and test (and_all (cstrs ++ cstrs1))) (make_let result inner))
  | None =>
    BIND lb <- res_to_alarm (Constant 0) (find_lower_bound n p) -;
    BIND ub <- res_to_alarm (Constant 0) (find_upper_bound n p) -;
    let cstrs := filter (fun c => nth n (fst c) 0 =? 0) p in
    pure (make_guard (make_poly_test n cstrs) (Loop lb ub inner))
  end.

Lemma dot_product_nth_zero_eval :
  forall env n u x, nth n u 0 = 0 -> length env = n -> dot_product (env ++ x :: nil) u = dot_product env u.
Proof.
  intros env n u x H1 H2.
  rewrite <- dot_product_assign_left_zero with (k := n) (s := 0) by auto.
  rewrite assign_app_ge by lia. rewrite H2, Nat.sub_diag.
  unfold assign. simpl.
  f_equiv. rewrite <- app_nil_r. f_equiv.
Qed.

Lemma satisfies_constraint_nth_zero_eq :
  forall env n c x, nth n (fst c) 0 = 0 -> length env = n -> satisfies_constraint (env ++ x :: nil) c = satisfies_constraint env c.
Proof.
  intros. unfold satisfies_constraint.
  erewrite dot_product_nth_zero_eval; eauto.
Qed.

Lemma scan_dimension_sem :
  forall n inner pol,
    WHEN st <- scan_dimension n inner pol THEN
         forall env mem1 mem2,
           length env = n ->
           exists lb ub,
             (loop_semantics st env mem1 mem2 <-> iter_semantics (fun x => loop_semantics inner (x :: env)) (Zrange lb ub) mem1 mem2) /\
             (forall x, in_poly (rev (x :: env)) pol = true <-> lb <= x < ub).
Proof.
  intros n inner pol st Hst env mem1 mem2 Henvlen.
  unfold scan_dimension in Hst.
  destruct (find_eq n pol) as [c|] eqn:Hfindeq.
  - destruct (solve_eq n c) as [result test] eqn:Hsolve. apply mayReturn_pure in Hst; rewrite <- Hst.
    match goal with [ Hst : make_guard ?T _ = _ |- _ ] => set (test1 := T) end.
    assert (Hcnth : 0 < nth n (fst c) 0) by (eapply find_eq_nth; eauto).
    destruct (eval_test env test1) eqn:Htest1.
    + exists (eval_expr env result). exists (eval_expr env (Sum result (Constant 1))). split.
      * split.
        -- intros Hsem. rewrite make_guard_correct, Htest1 in Hsem. unfold make_let in Hsem. inversion_clear Hsem. auto.
        -- intros Hsem. rewrite make_guard_correct, Htest1. unfold make_let. constructor; auto.
      * intros x. simpl.
        unfold test1 in Htest1. rewrite make_and_correct in Htest1; reflect.
        rewrite and_all_correct in Htest1. destruct Htest1 as [Htest Hcstr].
        rewrite forallb_app, andb_true_iff in Hcstr. destruct Hcstr as [Hcstr1 Hcstr2].
        transitivity (eval_expr env (fst (solve_eq n c)) = x /\ eval_test env (snd (solve_eq n c)) = true); [|rewrite Hsolve; simpl; intuition lia].
        rewrite solve_eq_correct by (auto || lia).
        split.
        -- intros H. unfold in_poly in H. rewrite forallb_forall in H.
           eapply find_eq_correct_1; eauto.
        -- intros H. unfold in_poly; rewrite forallb_forall. intros c1 Hc1in.
           rewrite forallb_map, forallb_forall in Hcstr1, Hcstr2. specialize (Hcstr1 c1). specialize (Hcstr2 c1).
           rewrite filter_In, make_affine_test_correct in Hcstr1, Hcstr2 by auto.
           destruct (nth n (fst c1) 0 =? 0) eqn:Hc1nth; reflect.
           ++ erewrite satisfies_constraint_nth_zero_eq; rewrite ?rev_length; eauto.
           ++ rewrite <- make_constraint_with_eq_correct_1 with (n := n) (c1 := c) by (auto || lia).
              erewrite satisfies_constraint_nth_zero_eq; rewrite ?rev_length; eauto.
              apply make_constraint_with_eq_nth; lia.
    + exists 0. exists 0. split.
      * split.
        -- intros Hsem. rewrite make_guard_correct, Htest1 in Hsem; rewrite Hsem. constructor; lia.
        -- intros Hsem. rewrite make_guard_correct, Htest1. inversion_clear Hsem. reflexivity.
      * split; [|lia]. intros H. exfalso.
        enough (eval_test env test1 = true) by congruence.
        unfold test1. rewrite make_and_correct, and_all_correct, forallb_app, !forallb_map. reflect.
        unfold in_poly in H. rewrite forallb_forall in H.
        assert (Heq : dot_product (rev (x :: env)) (fst c) = snd c) by (eapply find_eq_correct_1; eauto). simpl in Heq.
        split; [|split].
        -- rewrite <- solve_eq_correct in Heq; [|exact Henvlen|lia]. rewrite Hsolve in Heq; simpl in Heq; tauto.
        -- rewrite forallb_forall. intros c1 Hc1in. rewrite filter_In in Hc1in. reflect.
           rewrite make_affine_test_correct by auto. destruct Hc1in as [Hc1in Hc1n]. specialize (H c1 Hc1in).
           rewrite <- make_constraint_with_eq_correct_1 with (n := n) (c1 := c) in H by (auto || lia).
           simpl in H; erewrite satisfies_constraint_nth_zero_eq in H; rewrite ?rev_length; eauto.
           apply make_constraint_with_eq_nth; lia.
        -- rewrite forallb_forall. intros c1 Hc1in. rewrite filter_In in Hc1in. reflect.
           rewrite make_affine_test_correct by auto. destruct Hc1in as [Hc1in Hc1n]. specialize (H c1 Hc1in).
           simpl in H; erewrite satisfies_constraint_nth_zero_eq in H; rewrite ?rev_length; eauto.
  - bind_imp_destruct Hst lb Hlb. apply res_to_alarm_correct in Hlb.
    bind_imp_destruct Hst ub Hub. apply res_to_alarm_correct in Hub.
    apply mayReturn_pure in Hst. rewrite <- Hst.
    match goal with [ Hst : make_guard ?T _ = _ |- _ ] => set (test1 := T) end.
    destruct (eval_test env test1) eqn:Htest1.
    + exists (eval_expr env lb). exists (eval_expr env ub).
      rewrite make_guard_correct, Htest1.
      split.
      * split.
        -- intros Hsem; inversion_clear Hsem; auto.
        -- intros Hsem; constructor; auto.
      * intros x. rewrite find_bounds_correct; [|exact Hlb|exact Hub|exact Henvlen].
        unfold test1 in Htest1. rewrite make_poly_test_correct in Htest1 by auto.
        unfold in_poly in *. rewrite forallb_forall. rewrite forallb_forall in Htest1.
        split.
        -- intros H c Hc Hcnth; apply H; auto.
        -- intros H c Hc. destruct (nth n (fst c) 0 =? 0) eqn:Hcnth; reflect.
           ++ simpl; erewrite satisfies_constraint_nth_zero_eq; rewrite ?rev_length; [|eauto|eauto].
              apply Htest1. rewrite filter_In; reflect; auto.
           ++ apply H; auto.
    + exists 0. exists 0. rewrite make_guard_correct, Htest1. split.
      * split.
        -- intros H; rewrite H. econstructor; lia.
        -- intros H; inversion_clear H; reflexivity.
      * unfold test1 in Htest1. intros x. split; [|lia].
        intros H; unfold in_poly in H; rewrite forallb_forall in H.
        exfalso; eapply eq_true_false_abs; [|exact Htest1].
        rewrite make_poly_test_correct by auto. unfold in_poly; rewrite forallb_forall.
        intros c Hc; rewrite filter_In in Hc; destruct Hc as [Hcin Hcnth].
        specialize (H c Hcin). reflect. simpl in H.
        erewrite satisfies_constraint_nth_zero_eq in H; rewrite ?rev_length; eauto.
Qed.

Fixpoint polyloop_to_loop n pstmt : imp stmt :=
  match pstmt with
  | PSkip => pure (Seq nil)
  | PSeq s1 s2 =>
    BIND u1 <- polyloop_to_loop n s1 -;
    BIND u2 <- polyloop_to_loop n s2 -;
    pure (Seq (u1 :: u2 :: nil))
  | PInstr i es =>
    pure (Instr i (map (fun e => make_div (make_affine_expr n (snd e)) (Zpos (fst e))) es))
  | PLoop pol inner =>
    BIND inner1 <- polyloop_to_loop (S n) inner -;
    scan_dimension n inner1 pol
  | PGuard pol inner =>
    BIND inner1 <- polyloop_to_loop n inner -;
    pure (make_guard (make_poly_test n pol) inner1)
  end.

Lemma polyloop_to_loop_correct :
  forall pstmt n env mem1 mem2,
    WHEN st <- polyloop_to_loop n pstmt THEN
    loop_semantics st env mem1 mem2 ->
    length env = n ->
    poly_loop_semantics pstmt env mem1 mem2.
Proof.
  induction pstmt; intros n env mem1 mem2 st Hst Hsem Henv; simpl in *.
  - bind_imp_destruct Hst inner Hinner.
    generalize (scan_dimension_sem _ _ _ _ Hst _ mem1 mem2 Henv).
    intros [lb [ub [H1 H2]]].
    econstructor; [exact H2|]. rewrite H1 in Hsem.
    eapply iter_semantics_map; [|exact Hsem].
    intros x mem3 mem4 Hx Hsem2. simpl in Hsem2. eapply IHpstmt; simpl; eauto.
  - apply mayReturn_pure in Hst. rewrite <- Hst in *.
    inversion_clear Hsem. constructor.
    rewrite map_map in H.
    unfold eval_affine_expr. erewrite map_ext; [exact H|].
    intros [k a]; simpl. rewrite make_div_correct, make_affine_expr_correct by auto. reflexivity.
  - apply mayReturn_pure in Hst. rewrite <- Hst in *.
    inversion_clear Hsem. econstructor; auto.
  - bind_imp_destruct Hst u1 Hu1. bind_imp_destruct Hst u2 Hu2.
    apply mayReturn_pure in Hst; rewrite <- Hst in *.
    inversion_clear Hsem; inversion_clear H0. replace mem2 with mem4 by (inversion_clear H2; auto).
    econstructor; [eapply IHpstmt1|eapply IHpstmt2]; eauto.
  - bind_imp_destruct Hst inner Hinner. apply mayReturn_pure in Hst; rewrite <- Hst in *.
    rewrite make_guard_correct in Hsem.
    rewrite make_poly_test_correct in Hsem by auto.
    destruct (in_poly (rev env) p) eqn:Htest.
    + apply PLGuardTrue; [|auto]. eapply IHpstmt; eauto.
    + rewrite Hsem; apply PLGuardFalse; auto.
Qed.


(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION                                                        *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import useless.
Require Import inaccessible.
Require Import unitrules.
Require Import emptyrules.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INITIAL THEOREMS                                     *)
(* --------------------------------------------------------------------- *)

Section Simplification.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation term_lift':= ((terminal_lift non_terminal') terminal).

Theorem no_useless_symbols:
forall g: cfg terminal non_terminal,
non_empty g ->
exists g': cfg terminal non_terminal,
g_equiv g' g /\
has_no_useless_symbols g'.
Proof.
intros g.
exists (g_use g).
apply g_use_correct.
exact H.
Qed.

Theorem no_inaccessible_symbols:
forall g: cfg terminal non_terminal,
exists g': cfg terminal non_terminal,
g_equiv g' g /\
has_no_inaccessible_symbols g'.
Proof.
intros g.
exists (g_acc g).
apply g_acc_correct.
Qed.

Theorem no_unit_rules:
forall g: cfg terminal non_terminal,
exists g': cfg terminal non_terminal,
g_equiv g' g /\
has_no_unit_rules g'.
Proof.
intros g.
exists (g_unit g).
apply g_unit_correct.
Qed.

Theorem no_empty_rules:
forall g: cfg non_terminal terminal,
exists g': cfg (non_terminal' non_terminal) terminal,
g_equiv g' g /\
(generates_empty g -> has_one_empty_rule g') /\
(~ generates_empty g -> has_no_empty_rules g') /\
start_symbol_not_in_rhs g'.
Proof.
intros g.
exists (g_emp' g).
apply g_emp'_correct.
Qed.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACCESSIBLE AND USELESS SYMBOLS                     *)
(* --------------------------------------------------------------------- *)

Lemma g_acc_preserves_use:
forall g: cfg _ _,
forall s: non_terminal + terminal,
useful g s ->
accessible g s ->
useful (g_acc g) s.
Proof.
intros g s H1 H2.
destruct s.
- unfold useful in H1.
  unfold useful.
  destruct H1 as [s H3].
  exists s.
  apply derives_sflist in H3.
  destruct H3 as [l [H4 [H5 H6]]].
  assert (H7: length l >= 2 \/ length l < 2) by omega.
  destruct H7 as [H7 | H7].
  + assert (H7':=H7).
    apply sflist_rules with (g:=g) in H7.
    destruct H7 as [H7 _].
    specialize (H7 H4).
    apply derives_sflist.
    exists l.
    split.
    * {
      apply sflist_rules.
      - exact H7'.
      - intros i H8.
        specialize (H7 i H8).
        destruct H7 as [left [right [s0 [s' [H10 [H11 H12]]]]]].
        exists left, right, s0, s'.
        split.
        + exact H10.
        + split.
          * exact H11.
          * simpl.
            {
            apply Lift_acc.
            - exact H12.
            - unfold accessible in H2.
              destruct H2 as [s2 [s3 H13]].
              assert (H20: derives g [inl n] (s0 ++ inl left :: s')).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H4.
                apply sflist_app_r in H4.
                exists (firstn (S i) l).
                split.
                - exact H4.
                - split.
                  + rewrite hd_first.
                    * exact H5.
                    * omega.
                  + rewrite <- H10.
                    apply last_first_nth.
                    omega.
                }
              assert (H21: derives g [inl (start_symbol g)] (s2++s0++inl left::s'++s3)).
                {
                replace (s2 ++ inl n :: s3) with (s2 ++ [inl n] ++ s3) in H13.
                - apply derives_subs with (g:=g) (s1:=[inl (start_symbol g)]) (s2:=s2) (s3:=[inl n]) (s3':=(s0 ++ inl left :: s')) (s4:=s3) in H13.
                  + rewrite <- app_assoc in H13.
                    exact H13.
                  + exact H20.
                - simpl.
                  reflexivity.
                }
              exists (s2++s0), (s'++s3).
              rewrite <- app_assoc.
              exact H21.
            }
      }
    * {
      split.
      - exact H5.
      - exact H6.
      }
  + destruct l as [| s0 l].
    * simpl in H5.
      inversion H5.
    * {
      replace (s0::l) with ([s0]++l) in H7.
      - rewrite app_length in H7.
        simpl in H7.
        assert (H8: length l = 0) by omega.
        apply length_zero in H8.
        subst.
        simpl in H5.
        rewrite H5 in H6.
        simpl in H6.
        destruct s.
        + simpl in H6.
          inversion H6.
        + replace (t::s) with ([t]++s) in H6.
          * rewrite map_app in H6.
            inversion H6.
          * simpl.
            reflexivity.
      - simpl.
        reflexivity.
      }
- simpl.
  auto.
Qed.

Lemma acc_appears:
forall g: cfg _ terminal,
forall n: non_terminal,
useful g (inl (start_symbol g)) ->
accessible g (inl n) ->
appears g (inl n).
Proof.
intros g n H10 H.
unfold accessible in H.
destruct H as [s1 [s2 H2]].
apply exists_rule' in H2.
destruct H2 as [H2 | H2].
- destruct H2 as [H2 [_ _]].
  inversion H2.
  apply (useful_exists).
  exact H10.
- destruct H2 as [left [right [H3 H4]]].
  exists left, right.
  split.
  + exact H3.
  + right.
    exact H4.
Qed.

Lemma in_g_use_acc_is_use:
forall g: cfg non_terminal terminal,
forall n: non_terminal,
useful g (inl (start_symbol g)) ->
accessible (g_use g) (inl n) ->
useful (g_use g) (inl n).
Proof.
intros g n H99 H.
unfold accessible in H.
unfold useful.
destruct H as [s1 [s2 H2]].
apply exists_rule' in H2.
destruct H2 as [H2 | H2].
- apply useful_g_use.
  simpl in H2.
  destruct H2 as [H2 [_ _]].
  rewrite H2.
  apply acc_appears.
  + simpl.
    apply useful_g_g_use.
    exact H99.
  + unfold accessible.
    exists [], [].
    constructor.
- destruct H2 as [left [right [H3 H4]]].
  simpl in H3.
  inversion H3.
  subst.
  specialize (H1 (inl n) H4).
  unfold useful in H1.
  destruct H1 as [s0 H7].
  exists s0.
  apply derives_sflist in H7.
  destruct H7 as [l [H10 [H11 H12]]].
  apply derives_sflist.
  exists l.
  split.
  + assert (H6: length l >= 2 \/ length l < 2) by omega.
    destruct H6 as [H6 | H6].
    * assert (H6':=H6).
      apply sflist_rules with (g:=g) in H6.
      destruct H6 as [H6 _].
      specialize (H6 H10).
      {
      apply sflist_rules.
      - exact H6'.
      - intros i H7.
        specialize (H6 i H7).
        destruct H6 as [left0 [right0 [s3 [s' [H20 [H21 H22]]]]]].
        exists left0, right0, s3, s'.
        split.
        + exact H20.
        + split.
          * exact H21.
          * simpl.
            {
            apply Lift_use.
            - exact H22.
            - assert (H30: derives g (s3 ++ inl left0 :: s') (map term_lift s0)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn i l) in H10.
                apply sflist_app_l in H10.
                exists (skipn i l).
                split.
                + exact H10.
                + split.
                  * rewrite hd_skip.
                    exact H20.
                  * {
                    rewrite last_skip.
                    - exact H12.
                    - omega.
                    }
                }
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H31 [H32 H33]]]].
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [_ [s2'0 [_ [_ H34]]]].
              rewrite <- H34 in H33.
              replace (inl left0 :: s') with ([inl left0] ++ s') in H33.
              + apply derives_split in H33.
                destruct H33 as [s1'0 [s2'1 [H35 [H36 _]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'1 [_ [_ [H37 _]]]].
                rewrite <- H37 in H36.
                unfold useful.
                exists s1'1.
                exact H36.
              + simpl.
                reflexivity.
            - assert (H30: derives g (s3 ++ right0 ++ s') (map term_lift s0)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H10.
                apply sflist_app_l in H10.
                exists (skipn (S i) l).
                split.
                + exact H10.
                + split.
                  * rewrite hd_skip.
                    exact H21.
                  * {
                    rewrite last_skip.
                    - exact H12.
                    - omega.
                    }
                }
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H31 [H32 H33]]]].
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [_ [s2'0 [_ [_ H34]]]].
              rewrite <- H34 in H33.
              apply derives_split in H33.
              destruct H33 as [s1'0 [s2'1 [H35 [H36 _]]]].
              symmetry in H35.
              apply map_expand in H35.
              destruct H35 as [s1'1 [_ [_ [H37 _]]]].
              rewrite <- H37 in H36.
              intros s4 H40.
              destruct s4.
              + unfold useful.
                apply in_split in H40.
                destruct H40 as [l1 [l2 H41]].
                rewrite H41 in H36.
                apply derives_nt_sentence in H36.
                destruct H36 as [s'0 H42].
                exists s'0.
                exact H42.
              + simpl.
                auto.
            }
      }
    * apply lt2_sflist.
      exact H6.
  + split.
    * exact H11.
    * exact H12.
Qed.

End Simplification.

Section Simplification_2.

Variables non_terminal terminal: Type.

Lemma no_useless_no_inaccessible_symbols_v1:
forall g: cfg non_terminal terminal,
non_empty g ->
g_equiv (g_acc (g_use g)) g /\
has_no_inaccessible_symbols (g_acc (g_use g)) /\
has_no_useless_symbols (g_acc (g_use g)).
Proof.
intros g H'.
split.
- assert (H1: g_equiv (g_use g) g).
    {
    apply g_equiv_use.
    exact H'.
    }
  assert (H2: g_equiv (g_acc (g_use g)) (g_use g)).
    {
    apply g_equiv_acc.
    }
  apply g_equiv_trans with (g2:= g_use g).
  split.
  + exact H2.
  + exact H1.
- split.
  + intros s H.
    destruct s.
    * inversion H.
      destruct H0 as [right [H1 H2]].
      {
      destruct H2 as [H2 | H2].
      - subst.
        simpl in H1.
        inversion H1.
        subst.
        apply accessible_g_g_acc.
        exact H2.
      - simpl in H1.
        inversion H1.
        subst.
        apply accessible_g_g_acc.
        apply acc_step with (s:=inl n) (right:=right) in H3.
        + exact H3.
        + exact H0.
        + exact H2.
      }
    * inversion H.
      destruct H0 as [right [H1 H2]].
      inversion H1.
      subst.
      apply accessible_g_g_acc.
      simpl in H1.
      inversion H1.
      subst.
      {
      apply acc_step with (s:=inr t) (right:=right) in H3.
      - exact H3.
      - exact H0.
      - exact H2.
      }
  + intros s H.
    inversion H.
    destruct H0 as [right [H1 H2]].
    destruct H2 as [H2 | H2].
    * simpl in H1.
      inversion H1.
      subst.
      assert (H4:= H3).
      {
      apply in_g_use_acc_is_use in H3.
      - apply g_acc_preserves_use.
        + exact H3.
        + exact H4.
      - exact H'.
      }
    * inversion H1.
      subst.
      {
      apply acc_step with (s:=inl s) (right:=right) in H3.
      - assert (H4:=H3).
        apply in_g_use_acc_is_use in H3.
        + apply g_acc_preserves_use.
          * exact H3.
          * exact H4.
        + exact H'.
      - exact H0.
      - exact H2.
      }
Qed.

Lemma no_useless_no_inaccessible_symbols_v2:
forall g: cfg non_terminal terminal,
non_empty g ->
exists g': cfg non_terminal terminal,
g_equiv g' g /\
has_no_inaccessible_symbols g' /\
has_no_useless_symbols g'.
Proof.
intros g H'.
exists (g_acc (g_use g)).
apply no_useless_no_inaccessible_symbols_v1.
exact H'.
Qed.

End Simplification_2.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - EMPTY AND UNIT RULES                                 *)
(* --------------------------------------------------------------------- *)

Section Simplification_3.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).

Lemma New_ss_not_in_unit_v1:
forall g: cfg non_terminal terminal,
forall n: non_terminal' non_terminal,
~ unit (g_emp' g) n (start_symbol (g_emp' g)).
Proof.
intros g n H.
remember (start_symbol (g_emp' g)) as w.
induction H.
- rewrite Heqw in H.
  apply New_ss_not_in_right_g_emp'_v2 in H.
  simpl in H.
  unfold New_ss_not_in_sf in H.
  simpl in H.
  apply H.
  left.
  reflexivity.
- apply IHunit2.
  exact Heqw.
Qed.

Lemma New_ss_not_in_unit_v2:
forall g: cfg non_terminal terminal,
forall n1 n2: non_terminal' non_terminal,
unit (g_emp' g) n1 n2 -> n2 <> (start_symbol (g_emp' g)).
Proof.
intros g n1 n2 H1.
assert (H2: n2 = start_symbol (g_emp' g) \/ n2 <> start_symbol (g_emp' g)).
  {
  destruct n2.
  - right.
    simpl.
    discriminate.
  - left.
    simpl.
    reflexivity.
  }
destruct H2 as [H2 | H2].
- rewrite H2 in H1.
  apply New_ss_not_in_unit_v1 in H1.
  contradiction.
- exact H2.
Qed.

Lemma g_unit_preserves_one_empty_rule:
forall g: cfg (non_terminal' non_terminal) terminal,
(forall n1 n2: non_terminal' non_terminal, unit g n1 n2 -> n2 <> (start_symbol g)) ->
has_one_empty_rule g ->
has_one_empty_rule (g_unit g).
Proof.
intros g H0 H1.
unfold has_one_empty_rule.
intros left right H2.
inversion H2.
- subst.
  specialize (H1 left right H3).
  destruct H1 as [H1 | H1].
  + left.
    simpl.
    exact H1.
  + right.
    exact H1.
- clear H2.
  subst.
  simpl.
  specialize (H1 b right H3).
  destruct H1 as [H1 | H1].
  + specialize (H0 left b H).
    destruct H1 as [H1 _].
    contradiction.
  + right.
    exact H1.
Qed.

Lemma g_unit_preserves_no_empty_rules:
forall g: cfg non_terminal terminal,
has_no_empty_rules g ->
has_no_empty_rules (g_unit g).
Proof.
unfold has_no_empty_rules.
intros g H1.
intros left right H2.
inversion H2.
- subst.
  apply H1 with (left:= left).
  exact H0.
- subst.
  apply H1 with (left:= b).
  exact H0.
Qed.

End Simplification_3.

Section Simplification_4.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Lemma no_empty_no_unit_rules_v1:
forall g: cfg non_terminal terminal,
g_equiv (g_unit (g_emp' g)) g /\
(generates_empty g -> has_one_empty_rule (g_unit (g_emp' g))) /\
(~ generates_empty g -> has_no_empty_rules (g_unit (g_emp' g))) /\
has_no_unit_rules (g_unit (g_emp' g)).
Proof.
intros g.
split.
- assert (H1: g_equiv (g_unit (g_emp' g)) (g_emp' g)).
    {
    apply g_unit_correct.
    }
  assert (H2: g_equiv (g_emp' g) g).
    {
    apply g_emp'_correct.
    }
  apply g_equiv_trans with (g2:= (g_emp' g)).
  split.
  + exact H1.
  + exact H2.
- split.
  + intros H1.
    assert (H2: has_one_empty_rule (g_emp' g)).
      {
      apply g_emp'_has_one_empty_rule.
      exact H1.
      }
    apply g_unit_preserves_one_empty_rule.
    * apply New_ss_not_in_unit_v2.
    * exact H2.
  + split.
    * intros H1.
      assert (H2: has_no_empty_rules (g_emp' g)).
        {
        apply g_emp'_has_no_empty_rules.
        exact H1.
        }
      apply g_unit_preserves_no_empty_rules.
      exact H2.
    * apply g_unit_has_no_unit_rules.
Qed.

Lemma no_empty_no_unit_rules_v2:
forall g: cfg non_terminal terminal,
g_equiv_without_empty (g_unit (g_emp g)) g /\
has_no_empty_rules (g_unit (g_emp g)) /\
has_no_unit_rules (g_unit (g_emp g)).
Proof.
intros g.
split.
- assert (H1: g_equiv (g_unit (g_emp g)) (g_emp g)).
    {
    apply g_unit_correct.
    }
  assert (H2: g_equiv_without_empty (g_emp g) g).
    {
    apply g_emp_correct.
    }
  apply g_equiv_without_empty_trans with (g2:= (g_emp g)).
  split.
  + apply remove_empty in H1.
    exact H1.
  + exact H2.
- split.
  + assert (H2: has_no_empty_rules (g_emp g)).
      {
      apply g_emp_has_no_empty_rules.
      }
    apply g_unit_preserves_no_empty_rules.
    exact H2.
  + apply g_unit_has_no_unit_rules.
Qed.

Lemma no_empty_no_unit_rules_v3:
forall g: cfg non_terminal terminal,
exists g': cfg  (non_terminal' non_terminal) terminal,
g_equiv g' g /\
(generates_empty g -> has_one_empty_rule g') /\
(~ generates_empty g -> has_no_empty_rules g') /\
has_no_unit_rules g'.
Proof.
intros g.
exists (g_unit (g_emp' g)).
apply no_empty_no_unit_rules_v1.
Qed.

End Simplification_4.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - FINAL THEOREM                                        *)
(* --------------------------------------------------------------------- *)

Section Simplification_5.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Lemma g_acc_g_use_preserves_rules:
forall g: cfg non_terminal terminal,
forall left: _,
forall right: _,
rules (g_acc (g_use g)) left right -> rules g left right.
Proof.
intros g left right H.
inversion H.
clear H.
subst.
inversion H0.
clear H0.
subst.
exact H.
Qed.

Lemma g_acc_g_use_preserves_empty_rule:
forall g: cfg (non_terminal' non_terminal) terminal,
rules g (start_symbol g) [] ->
rules (g_acc (g_use g)) (start_symbol (g_acc (g_use g))) [].
Proof.
intros g H.
simpl.
apply Lift_acc.
- apply Lift_use.
  + exact H.
  + unfold useful.
    exists [].
    apply derives_start.
    simpl.
    exact H.
  + intros s H1.
    simpl in H1.
    contradiction.
- exists [], [].
  simpl.
  apply derives_refl.
Qed.

Lemma g_emp_preserves_non_empty:
forall g: cfg non_terminal terminal,
(exists s: sentence, produces g s /\ s <> []) ->
non_empty (g_emp g).
Proof.
intros g H0.
unfold non_empty.
unfold produces in H0.
unfold generates in H0.
unfold useful.
destruct H0 as [s [H0 H1]].
assert (H3: g_equiv_without_empty (g_emp g) g).
  {
  apply g_emp_correct.
  }
unfold g_equiv_without_empty in H3.
specialize (H3 s H1).
destruct H3 as [_ H3].
specialize (H3 H0).
exists s.
exact H3.
Qed.

Lemma g_emp'_preserves_non_empty:
forall g: cfg non_terminal terminal,
non_empty g ->
non_empty (g_emp' g).
Proof.
unfold non_empty.
intros g H0.
unfold useful in H0.
destruct H0 as [s H0].
assert (H1: g_equiv (g_emp' g) g).
  {
  apply g_emp'_correct.
  }
unfold g_equiv in H1.
specialize (H1 s).
destruct H1 as [_ H1].
specialize (H1 H0).
unfold useful.
exists s.
exact H1.
Qed.

Lemma g_unit_preserves_non_empty:
forall g: cfg non_terminal terminal,
non_empty g ->
non_empty (g_unit g).
Proof.
unfold non_empty.
intros g H0.
simpl.
unfold useful in H0.
destruct H0 as [s H0].
exists s.
assert (H2: g_equiv (g_unit g) g).
  {
  apply g_unit_correct.
  }
unfold g_equiv in H2.
specialize (H2 s).
destruct H2 as [_ H2].
unfold produces in H2.
unfold generates in H2.
apply H2.
exact H0.
Qed.

Lemma g_unit_preserves_start:
forall g: cfg (non_terminal' non_terminal) terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_unit g).
Proof.
intros g H1 left right H2 H3.
unfold start_symbol_not_in_rhs in H1.
inversion H2.
- subst.
  specialize (H1 left right H0).
  apply H1.
  simpl in H3.
  exact H3.
- specialize (H1 b right H0).
  apply H1.
  simpl in H3.
  exact H3.
Qed.

Lemma g_use_preserves_start:
forall g: cfg (non_terminal' non_terminal) terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_use g).
Proof.
intros g H1 left right H2 H3.
unfold start_symbol_not_in_rhs in H1.
inversion H2.
subst.
specialize (H1 left right H).
apply H1.
simpl in H3.
exact H3.
Qed.

Lemma g_acc_preserves_start:
forall g: cfg (non_terminal' non_terminal) terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_acc g).
Proof.
intros g H1 left right H2 H3.
unfold start_symbol_not_in_rhs in H1.
inversion H2.
subst.
specialize (H1 left right H).
apply H1.
simpl in H3.
exact H3.
Qed.

End Simplification_5.

Section Simplification_6.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Theorem g_simpl_exists_v1:
forall g: cfg non_terminal terminal,
 non_empty g ->
 exists g': cfg (non_terminal' non_terminal) terminal,
 g_equiv g' g /\
 has_no_inaccessible_symbols g' /\
 has_no_useless_symbols g' /\
(generates_empty g -> has_one_empty_rule g') /\
(~ generates_empty g -> has_no_empty_rules g') /\
 has_no_unit_rules g' /\
 start_symbol_not_in_rhs g'.
Proof.
intros g H.
exists (g_acc (g_use (g_unit (g_emp' g)))).
split.
- assert (H3: g_equiv (g_acc (g_use (g_unit (g_emp' g)))) (g_unit (g_emp' g))).
    {
    apply no_useless_no_inaccessible_symbols_v1.
    apply g_emp'_preserves_non_empty in H.
    apply g_unit_preserves_non_empty in H.
    exact H.
    }
  apply g_equiv_trans with (g2:= (g_unit (g_emp' g))).
  split.
  + exact H3.
  + apply no_empty_no_unit_rules_v1.
- split.
  + apply g_acc_has_no_inaccessible_symbols.
  + split.
    * apply no_useless_no_inaccessible_symbols_v1.
      {
      apply g_emp'_preserves_non_empty in H.
      apply g_unit_preserves_non_empty in H.
      exact H.
      }
    * {
      split.
      - intros H1'.
        assert (H2': has_one_empty_rule (g_unit (g_emp' g))).
          {
          apply no_empty_no_unit_rules_v1.
          exact H1'.
          }
        unfold has_one_empty_rule.
        remember (g_unit (g_emp' g)) as g'.
        intros left right HH.
        simpl in HH.
        inversion HH.
        clear HH.
        subst.
        simpl.
        simpl in H0.
        inversion H0.
        clear H0.
        subst.
        specialize (H2' left right H2).
        destruct H2' as [H2' | H2'].
        + simpl in H2'.
          left.
          exact H2'.
        + right.
          exact H2'.
      - split.
        + intros H1'.
          unfold has_no_empty_rules.
          intros left right H2'.
          apply g_acc_g_use_preserves_rules in H2'.
          apply g_emp'_has_no_empty_rules in H1'.
          apply g_unit_preserves_no_empty_rules in H1'.
          unfold has_no_empty_rules in H1'.
          specialize (H1' left right H2').
          exact H1'.
        + split.
          * unfold has_no_unit_rules.
            intros left n right H1'.
            apply g_acc_g_use_preserves_rules in H1'.
            {
            inversion H1'.
            clear H1'.
            - subst.
              specialize (H0 n).
              exact H0.
            - subst.
              specialize (H2 n).
              exact H2.
            }
          * assert (H1: start_symbol_not_in_rhs (g_emp' g)).
              {
              apply start_symbol_not_in_rhs_g_emp'.
              }
            apply g_unit_preserves_start in H1.
            apply g_use_preserves_start in H1.
            apply g_acc_preserves_start in H1.
            exact H1.
      }
Qed.

Theorem g_simpl_exists_v2:
forall g: cfg non_terminal terminal,
(exists s: sentence, produces g s /\ s <> [] ) ->
 exists g': cfg (non_terminal' non_terminal) terminal,
 g_equiv_without_empty g' g /\
 has_no_inaccessible_symbols g' /\
 has_no_useless_symbols g' /\
 has_no_empty_rules g' /\
 has_no_unit_rules g' /\
 start_symbol_not_in_rhs g'.
Proof.
intros g H.
exists (g_acc (g_use (g_unit (g_emp g)))).
split.
- assert (H3: g_equiv (g_acc (g_use (g_unit (g_emp g)))) (g_unit (g_emp g))).
    {
    apply no_useless_no_inaccessible_symbols_v1.
    apply g_emp_preserves_non_empty in H.
    apply g_unit_preserves_non_empty in H.
    exact H.
    }
  apply g_equiv_without_empty_trans with (g2:= (g_unit (g_emp g))).
  split.
  + apply remove_empty in H3.
    exact H3.
  + apply no_empty_no_unit_rules_v2.
- split.
  + apply g_acc_has_no_inaccessible_symbols.
  + split.
    * apply no_useless_no_inaccessible_symbols_v1.
      {
      apply g_emp_preserves_non_empty in H.
      apply g_unit_preserves_non_empty in H.
      exact H.
      }
    * {
      split.
      - unfold has_no_empty_rules.
        intros left right H2'.
        apply g_acc_g_use_preserves_rules in H2'.
        apply g_unit_preserves_no_empty_rules in H2'.
        exact H2'.
        apply g_emp_has_no_empty_rules.
      - split.
        + unfold has_no_unit_rules.
          intros left n right H1'.
          apply g_acc_g_use_preserves_rules in H1'.
          inversion H1'.
          clear H1'.
          * subst.
            specialize (H0 n).
            exact H0.
          * subst.
            specialize (H2 n).
            exact H2.
        + assert (H1: start_symbol_not_in_rhs (g_emp g)).
            {
            apply start_symbol_not_in_rhs_g_emp.
            }
          apply g_unit_preserves_start in H1.
          apply g_use_preserves_start in H1.
          apply g_acc_preserves_start in H1.
          exact H1.
      }
Qed.

End Simplification_6.


(*
  Reduction from:
    Uniform Diophantine Constraint Solvability (H10UC_SAT)
  to:
    Uniform Diophantine Pair Constraint Solvability (H10UPC_SAT)
*)

Require Import List Lia Cantor.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Require Import Undecidability.DiophantineConstraints.H10C.

Set Default Goal Selector "!".

(* Uniform Diophantine pairs constraints are of shape:
    (x, y) # (1 + x + y, (y²+y)/2)
   Uniform Diophantine constraints are of shape:
    1 + x + y * y = z

  Idea: We represent 1+x+y²=z as such:
  (where a, b, c, t1, t2 are new variables):
  y(y+1)/2 = a
  a+a+1 = b ( = y(y+1) + 1 = y²+y+1)
  c+y+1 = b (-> c = y²)
  x+c+1 = z (-> z = 1+x+y²)

  This yields these constraints
  (a,a) # (b,t1)
  (c,y) # (b,a)
  (c,x) # (z,t2)

  We use the following renaming scheme:
  <x,0> = x                          (used for x,y,z)
  <x,1> = (x²+x)/2                   (used for a (with y), t2 (with x))
  <x,2> = x²+x+1                     (used for b (with y))
  <x,3> = x²                         (used for c (with y))
  <x,4> = (k²+k)/2 where k=(x²+x)/2  (used for t1 (with y))
*)

Module Argument.

Definition c2_full (x: nat) : { y:nat | y + y = x * S x}.
Proof.
  elim: x; first by exists 0.
  move=> x [y Hy]. exists (y+x+1). nia.
Qed.

#[local] Notation c2 x := (sval (c2_full x)).
#[local] Notation c2_spec x := (svalP (c2_full x)).

(* fresh variable space *)
Notation var x t := (Cantor.to_nat (x, t)).
Opaque Cantor.to_nat Cantor.of_nat.

Section Reduction.
(* The instance of h10uc (which we are reducing from) *)
Context (ucs: list h10uc).

Definition h10uc_to_h10upcs (c : h10uc) : list h10upc :=
  let '(x, y, z) := c in
  let '(a, b, c, t1, t2) := (var y 1, var y 2, var y 3, var y 4, var x 1) in
  let '(x, y, z) := (var x 0, var y 0, var z 0) in
    [((a, a), (b, t1)); ((c, y), (b, a)); ((c, x), (z, t2))].

Definition upcs := flat_map h10uc_to_h10upcs ucs.

Section Transport.
(* The solution to cs *)
Context (φ: nat -> nat).
(* Proof that φ solves ucs *)
Context (Hφ : forall c, In c ucs -> h10uc_sem φ c).

Definition φ' (xn: nat) : nat :=
  match Cantor.of_nat xn with
  | (x, 0) => φ x
  | (x, 1) => c2 (φ x)
  | (x, 2) => φ x * φ x + φ x + 1
  | (x, 3) => φ x * φ x
  | (x, 4) => c2 (c2 (φ x))
  | _ => 0
  end.

Lemma transport : forall c, In c upcs -> h10upc_sem φ' c.
Proof using Hφ.
  apply /Forall_forall /Forall_flat_map.
  move: Hφ => /Forall_forall.
  apply: Forall_impl => - [[x y] z] /= ?.
  constructor; [|constructor; [|constructor]]; last done.
  all: rewrite /φ' /= ?Cantor.cancel_of_to ?(c2_spec _); lia.
Qed.

End Transport.

Section InverseTransport.
(* The solution to f(cs) (f is the reduction function) *)
Context (φ': nat -> nat).
(* Proof that φ' solves upcs *)
Context (Hφ' : forall c, In c upcs -> h10upc_sem φ' c).

Definition φ (n:nat) : nat := φ' (var n 0).

Lemma inverse_transport : forall c, In c ucs -> h10uc_sem φ c.
Proof using Hφ'.
  apply /Forall_forall.
  move: Hφ' => /Forall_forall /Forall_flat_map.
  apply: Forall_impl => - [[x y] z] /=.
  move=> /Forall_cons_iff [+] /Forall_cons_iff [+] /Forall_cons_iff [+ _].
  rewrite /φ /=. nia.
Qed.

End InverseTransport.
End Reduction.
End Argument.

Require Import Undecidability.Synthetic.Definitions.

(** Square Diophantine Constraint Solvability many-one reduces to Uniform Diophantine Constraint Solvability *)
Theorem reduction : H10UC_SAT ⪯ H10UPC_SAT.
Proof.
  exists Argument.upcs. split.
  - intros [φ Hφ]. exists (Argument.φ' φ). now apply Argument.transport.
  - intros [φ' Hφ']. exists (Argument.φ φ'). now apply Argument.inverse_transport.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* ** FRACTRAN reduces to Diophantine logic *)

Require Import List.

Require Import Undecidability.Synthetic.Definitions.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.Shared.Libs.DLW
   Require Import utils_tac pos vec.

From Undecidability.FRACTRAN
  Require Import FRACTRAN MM_FRACTRAN FRACTRAN_sss.

From Undecidability.H10.Fractran Require Import fractran_dio.
From Undecidability.H10.Dio      Require Import dio_elem dio_single dio_logic.

Set Implicit Arguments.

(* A diophantine logic satisfiability question is given
    a diophantine logic formula f and a valuation for the
    parameters. Is the formula valid ? *)

Definition DIO_LOGIC_PROBLEM :=
  (dio_formula * (nat -> nat))%type.

Definition DIO_LOGIC_SAT (p : DIO_LOGIC_PROBLEM) :=
  let (f,ν) := p in df_pred f ν.

Theorem FRACTRAN_HALTING_DIO_LOGIC_SAT : Halt_FRACTRAN ⪯ DIO_LOGIC_SAT.
Proof.
  apply reduces_dependent; exists.
  intros (l & x).
  destruct FRACTRAN_HALTING_on_diophantine
    with (ll := l) (x := fun _ : nat -> nat => x) as (f & Hf); simpl.
  + dio_rel_auto.
  + exists (f, fun _ => x).
    setoid_rewrite eval_iff.
   unfold DIO_LOGIC_SAT; rewrite Hf; tauto.
Qed.

(* An elementary diophantine problem is a list of elementary diophantine
    constraints and a valuation for the parameters. The question is whether
    there exists a valuation for the variables that satisfies all the constraints
    simultaneously *)

Definition DIO_ELEM_PROBLEM :=
  (list dio_constraint * (nat -> nat))%type.

Definition DIO_ELEM_SAT (p : DIO_ELEM_PROBLEM) :=
  let (l,v) := p in exists φ, Forall (dc_eval φ v) l.

Theorem DIO_LOGIC_ELEM_SAT : DIO_LOGIC_SAT ⪯  DIO_ELEM_SAT.
Proof.
  apply reduces_dependent; exists.
  intros (A,v).
  destruct (dio_formula_elem A) as (l & _ & _ & Hl).
  exists (l,v); apply Hl.
Qed.

Definition DIO_SINGLE_PROBLEM :=
  (dio_single nat nat * (nat -> nat))%type.

Definition DIO_SINGLE_SAT (p : DIO_SINGLE_PROBLEM) :=
  let (E,φ) := p in dio_single_pred E φ.

Theorem DIO_ELEM_SINGLE_SAT : DIO_ELEM_SAT ⪯ DIO_SINGLE_SAT.
Proof.
  apply reduces_dependent; exists.
  intros (l,v).
  destruct (dio_elem_equation l) as (E & _ & HE).
  exists (E,v).
  unfold DIO_ELEM_SAT, DIO_SINGLE_SAT.
  rewrite <- HE; tauto.
Qed.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Logic.MinimunLogic.DeepEmbedded.MinimunLanguage.

Local Open Scope logic_base.
Local Open Scope syntax.

Section MinimunLogic.

Context (Var: Type).

Instance L: Language := MinimunLanguage.L Var.
Instance minL: MinimunLanguage L := MinimunLanguage.minL Var.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z)).

Instance G: ProofTheory L := Build_AxiomaticProofTheory provable.

Instance AX: NormalAxiomatization L G := Build_AxiomaticProofTheory_AX provable.

Instance minAX: MinimunAxiomatization L G.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance SC: NormalSequentCalculus L G := Axiomatization2SequentCalculus_SC.

Instance bSC: BasicSequentCalculus L G := Axiomatization2SequentCalculus_bSC.

Instance fwSC: FiniteWitnessedSequentCalculus L G := Axiomatization2SequentCalculus_fwSC.

Instance minSC: MinimunSequentCalculus L G := Axiomatization2SequentCalculus_minSC.

End MinimunLogic.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


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

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

Print Assumptions square.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import vec.

From Undecidability.MuRec.Util
  Require Import recalg ra_univ ra_univ_andrej.

Set Implicit Arguments.

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

(* We build a universal µ-recusive algorithm of size 8708

      ra_univ : recalg 1

    which is just a particular µ-recursive algorithm. It is
    universal w.r.t. elementary Diophantine constraints
    as established in Reductions/H10C_RA_UNIV.v

    Basically, its termination predicate RA_UNIV_HALT
    can simulate the solvability of any list of elementary
    Diophantine constraints, making it undecidable *)

(* Check ra_size ra_univ. *)
(* Eval compute in ra_size ra_univ. *)
(* Check ra_size ra_univ_ad. *)
(* Eval compute in ra_size ra_univ_ad. *)

Definition RA_UNIV_PROBLEM := nat.
Definition RA_UNIV_HALT (n : RA_UNIV_PROBLEM) : Prop := ex (⟦ra_univ⟧ (n##vec_nil)).
Definition RA_UNIV_AD_HALT (n : RA_UNIV_PROBLEM) : Prop := ex (⟦ra_univ_ad⟧ (n##vec_nil)).


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

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

Print Assumptions square.


Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.orders.rings.

Section contents.
Context `{Ring R} `{Apart R} `{!TrivialApart R} `{!FullPseudoSemiRingOrder Rle Rlt} `{∀ x y, Decision (x = y)} `{a : !Abs R}.

Add Ring R : (rings.stdlib_ring_theory R).

Global Instance abs_proper: Setoid_Morphism abs | 0.
Proof.
  split; try apply _. intros x y E.
  unfold abs, abs_sig. destruct (a x) as [z1 [Ez1 Fz1]]. destruct (a y) as [z2 [Ez2 Fz2]].
  simpl.
  rewrite <-E in Ez2, Fz2.
  destruct (total (≤) 0 x).
   now rewrite Ez1, Ez2.
  now rewrite Fz1, Fz2.
Qed.

Lemma abs_nonneg (x : R) : 0 ≤ x → abs x = x.
Proof.
  intros E. unfold abs, abs_sig. destruct (a x) as [z1 [Ez1 Fz1]]. auto.
Qed.

Lemma abs_nonpos (x : R) : x ≤ 0 → abs x = -x.
Proof.
  intros E. unfold abs, abs_sig. destruct (a x) as [z1 [Ez1 Fz1]]. auto.
Qed.

Lemma abs_nonneg_plus (x y : R) :
  0 ≤ x → 0 ≤ y → abs (x + y) = abs x + abs y.
Proof.
  intros Ex Ey.
  rewrite ?abs_nonneg; try easy.
  now apply nonneg_plus_compat.
Qed.

Lemma abs_nonpos_plus (x y : R) :
  x ≤ 0 → y ≤ 0 → abs (x + y) = abs x + abs y.
Proof.
  intros Ex Ey.
  rewrite ?abs_nonpos; trivial.
   ring.
  now apply nonpos_plus_compat.
Qed.

Lemma abs_0 : abs 0 = 0.
Proof.
  now rewrite abs_nonneg.
Qed.

Lemma abs_mult (x y : R) : abs (x * y) = abs x * abs y.
Proof with try ring; auto.
  destruct (total (≤) 0 x) as [Ex|Ex]; destruct (total (≤) 0 y) as [Ey|Ey].
     rewrite ?abs_nonneg...
     apply nonneg_mult_compat...
    rewrite (abs_nonneg x), (abs_nonpos y), (abs_nonpos (x * y))...
    apply nonneg_nonpos_mult...
   rewrite (abs_nonpos x), (abs_nonneg y), (abs_nonpos (x * y))...
   apply nonpos_nonneg_mult...
  rewrite (abs_nonpos x), (abs_nonpos y), (abs_nonneg (x * y))...
  apply nonpos_mult...
Qed.

Lemma abs_1 : abs 1 = 1.
Proof.
  rewrite abs_nonneg.
   reflexivity.
  apply le_0_1.
Qed.

Lemma abs_negate (x : R) : abs (-x) = abs x.
Proof with trivial.
  destruct (total (≤) 0 x).
   rewrite (abs_nonneg x), abs_nonpos...
    apply rings.negate_involutive.
   apply flip_nonneg_negate...
  rewrite (abs_nonneg (-x)), abs_nonpos...
   reflexivity.
  apply flip_nonpos_negate...
Qed.
End contents.

#[global]
Program Instance default_abs `{Ring R} `{!SemiRingOrder Rle} `{∀ x y, Decision (x ≤ y)} : Abs R | 20
  := λ x, if decide_rel (≤) 0 x then x else (-x).
Next Obligation.
  split; intros E; try reflexivity.
  setoid_replace x with 0 by now apply (antisymmetry (≤)).
  now rewrite rings.negate_0.
Qed.
Next Obligation. intuition. Qed.

Section order_preserving.
  Context `{Ring A} `{oA : Le A} `{!SemiRingOrder oA} `{!TotalRelation oA} `{!Abs A}
    `{Ring B} `{oB : Le B} `{!SemiRingOrder oB} `{!TotalRelation oB} `{!Abs B}
    {f : A → B} `{!OrderPreserving f} `{!SemiRing_Morphism f}.

  Lemma preserves_abs x : f (abs x) = abs (f x).
  Proof.
    destruct (total (≤) 0 x).
     rewrite ?abs_nonneg; try easy.
     now apply semirings.preserves_nonneg.
    rewrite ?abs_nonpos; try easy.
     apply rings.preserves_negate.
    now apply preserves_nonpos.
  Qed.
End order_preserving.