(************************************************************************)
(* Copyright 2006 Milad Niqui                                           *)
(* This file is distributed under the terms of the                      *)
(* GNU Lesser General Public License Version 2.1                        *)
(* A copy of the license can be found at                                *)
(*                  <http://www.gnu.org/licenses>                       *)
(************************************************************************)

Require Import digits.
Require Import ub.
Require Import rep.
Require Import Rseries.
Require Import Rdefinitions.
Require Import RIneq.
Require Import Rcomplete.
From QArithSternBrocot Require Import R_addenda.
Require Import Fourier_solvable_ineqs.

(** This file deals with the correctness of the representation predicate [rep]. *)

Lemma lb_Cauchy:forall alpha, Rseries.Cauchy_crit (lb alpha).
Proof.
 intros alpha.
 intros eps H_eps_pos.
 set (N:=Zabs_nat (up (2 / eps))).
 exists N.
 intros m n Hn Hm.
 unfold Rfunctions.R_dist.
 apply Raxioms.Rlt_trans with (Qminus (ub alpha N)(lb alpha N)).
 set (u_N:=ub alpha N); set (l_N:=lb alpha N); set (l_n:=lb alpha n);set (l_m:=lb alpha m).

  apply Rbasic_fun.Rabs_def1.

   repeat rewrite <- Q_to_Rminus; apply Q_to_Rlt.
   apply Qlt_Zero_Qminus.
   stepr (Qplus (Qminus u_N l_m)(Qminus l_n l_N)); try ring.
   apply Qlt_le_reg_pos.
    apply Qlt_Qminus_Zero; subst u_N l_m; apply lb_lt_ub.
    apply Qle_Qminus_Zero; subst l_N l_n; apply lb_nondecreasing; auto.

   apply RIneq.Ropp_lt_cancel; rewrite RIneq.Ropp_involutive; rewrite RIneq.Ropp_minus_distr.
   repeat rewrite <- Q_to_Rminus; apply Q_to_Rlt.
   apply Qlt_Zero_Qminus.
   stepr (Qplus(Qminus u_N l_n)(Qminus l_m l_N)); try ring.
   apply Qlt_le_reg_pos.
    apply Qlt_Qminus_Zero; subst u_N l_n; apply lb_lt_ub.
    apply Qle_Qminus_Zero; subst l_N l_m; apply lb_nondecreasing; auto.

   apply RIneq.Rle_lt_trans with (Qdiv (Z_to_Q (Z_of_nat 2)) (Qplus (Z_to_Q (Z_of_nat N)) (Z_to_Q (Z_of_nat 1)))).

    apply Q_to_Rle; apply thesis_5_7_9.

    (* TP: 0 < IZR N +1 *)
    assert (H_N_plus_one_pos:(0 < Rdefinitions.IZR N +1)%R);
    [ apply RIneq.Rle_lt_trans with (Rdefinitions.IZR N); rewrite <- INR_IZR_INZ; auto with real| ].
    (* TP: IZR N +1 <> 0 *)
    assert (H_N_plus_one_nonzero:(Rdefinitions.IZR N +1<>0)%R); auto with real.

    elim (Raxioms.archimed (2/eps)); intros H_N _.
    rewrite <- (Z_of_nat_Zabs_nat_pos (up(2/eps))) in H_N.
    rewrite Q_to_Rdiv.
    rewrite Q_to_Rplus.
    repeat rewrite Z_to_Q_to_R_IZR.
    assert (2/eps-1<(Rdefinitions.IZR N))%R.

     apply Raxioms.Rlt_trans with (2/eps)%R; auto.
      apply RIneq.Rminus_lt.
      stepl (Ropp (Rdefinitions.IZR 1%nat)).
      simpl.
      apply RIneq.Ropp_lt_gt_0_contravar.
      apply Fourier_util.Rlt_zero_1.
      simpl; ring.

     simpl.
     apply Rmult_lt_reg_l with ((Rdefinitions.IZR N + 1)*(Rinv eps))%R.
     apply Fourier_util.Rlt_mult_inv_pos; auto.

      stepl (2/eps)%R.
       stepr (Rdefinitions.IZR N+1)%R.
        apply Rplus_lt_reg_r with (Ropp 1).
	stepl (2/eps -1)%R; try ring.
	stepr (Rdefinitions.IZR N)%R; auto; try ring.
       field; auto with real.
      field; auto with real.

    natq_S N; natq_zero; apply Z_to_Q_not_eq; apply inj_neq; discriminate.

    apply le_O_IZR.
    apply RIneq.Rlt_le.
    apply Raxioms.Rlt_trans with (2 / eps)%R; auto;
    unfold Rdiv; apply Fourier_util.Rlt_mult_inv_pos; auto; apply DiscrR.Rlt_R0_R2.
Qed.

(** This is the real number in #[#-1,+1#]# represented by [alpha] *)
Definition real_value alpha := (proj1_sig (Rcomplete.R_complete (lb alpha) (lb_Cauchy alpha))).

Lemma rep_lb: forall (k:nat) alpha r, rep alpha r -> ((lb alpha k)<=r)%R.
Proof.
 induction k.
  (* 0 *)
  intros alpha r H_rep.
  simpl; rewrite Q_to_R_Qneg_One.
  elim (rep_inv_interval _ _ H_rep); trivial.
  (* S k *)
  intros [[ | | ] alpha] r H_rep; rewrite lb_S_n; unfold hd,tl; set (l':=(lb alpha k)).
   (* L *)
   (* TP: Zero <= l'+ 1 *)
   assert (H_l'_one_nonneg: Zero <= l'+1);
   [ stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low|].
   (* TP: Zero < l'+3 *)
   assert (H_l'_three_pos: Zero < l'+3);
   [ apply Qle_lt_trans with (l'+1); auto; apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_l'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_l'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_L; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Q_to_Rplus; rewrite Q_to_Rminus;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_L_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_L_inv _ _ H_rep)); clear IHk; fold l'; intro IHk;
   apply rep_lb_auxiliary_L; auto; stepr (l'+(2+1))%R; auto; ring.
   (* R *)
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1);
   [stepr (1-l'); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_up|].
   (* TP: Zero < -l'+3 *)
   assert (H_min_l'_three_pos: Zero < -l'+3);
   [ apply Qle_lt_trans with ((-l')+1); auto;
     apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_min_l'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_min_l'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero; rewrite Q_to_Ropp;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_R; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   repeat rewrite Q_to_Rplus; rewrite Q_to_Ropp;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_R_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_R_inv _ _ H_rep)); clear IHk; fold l'; intro IHk;
   apply rep_lb_auxiliary_R; auto; stepr (-l'+(2+1))%R; auto; ring.
   (* M *)
   rewrite as_Moebius_Q_M; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_M_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_M_inv _ _ H_rep)); clear IHk; fold l'; intro IHk;
   apply rep_lb_auxiliary_M; auto.
Qed.

Lemma rep_ub: forall (k:nat) alpha r, rep alpha r -> (r<=(ub alpha k))%R.
Proof.
 induction k.
  (* 0 *)
  intros alpha r H_rep;
  unfold ub; rewrite Z_to_Q_to_R_IZR; simpl;
  elim (rep_inv_interval _ _ H_rep); trivial.
  (* S k *)
  intros [[ | | ] alpha] r H_rep; rewrite ub_S_n; unfold hd,tl; set (u':=(ub alpha k)).
   (* L *)
   (* TP: Zero <= u'+ 1 *)
   assert (H_u'_one_nonneg: Zero <= u'+1);
   [ stepr (u'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst u'; apply ub_is_in_base_interval_low|].
   (* TP: Zero < u'+3 *)
   assert (H_u'_three_pos: Zero < u'+3);
   [ apply Qle_lt_trans with (u'+1); auto; apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_u'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_u'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_L; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Q_to_Rplus; rewrite Q_to_Rminus;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_L_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_L_inv _ _ H_rep)); clear IHk; fold u'; intro IHk;
   apply rep_ub_auxiliary_L; auto; stepr (u'+(2+1))%R; auto; ring.
   (* R *)
   (* TP: Zero <= -u'+ 1 *)
   assert (H_min_u'_one_nonneg: Zero <= -u'+1);
   [stepr (1-u'); try ring; apply Qle_Qminus_Zero; subst u'; apply ub_is_in_base_interval_up|].
   (* TP: Zero < -u'+3 *)
   assert (H_min_u'_three_pos: Zero < -u'+3);
   [ apply Qle_lt_trans with ((-u')+1); auto;apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|].

   generalize (Q_to_Rle _ _ H_min_u'_one_nonneg);
   generalize (Q_to_Rlt _ _ H_min_u'_three_pos);
   do 2 rewrite Q_to_Rplus; rewrite Q_to_R_Zero; rewrite Q_to_Ropp;
   do 2 rewrite Z_to_Q_to_R_IZR; intros H1 H2; simpl in H1,H2.

   rewrite as_Moebius_Q_R; trivial; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   repeat rewrite Q_to_Rplus; rewrite Q_to_Ropp;
   repeat rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_R_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_R_inv _ _ H_rep)); clear IHk; fold u'; intro IHk;
   apply rep_ub_auxiliary_R; auto; stepr (-u'+(2+1))%R; auto; ring.
   (* M *)
   rewrite as_Moebius_Q_M; natZ_numerals;
   rewrite Q_to_Rdiv; auto;
   rewrite Z_to_Q_to_R_IZR; simpl;
   elim (rep_M_inv_interval _ _ H_rep); intros Hr1 Hr2;
   generalize (IHk _ _ (rep_M_inv _ _ H_rep)); clear IHk; fold u'; intro IHk;
   apply rep_ub_auxiliary_M; auto.
Qed.

Lemma rep_interval : forall (k:nat) alpha r1 r2, rep alpha r1 -> rep alpha r2 ->  (-(2)/(k+1) <= r1-r2 <= 2/(k+1))%R.
Proof.
 intros k alpha r1 r2 Hr1 Hr2.
 (* TP: O <= k  *)
 assert (H_k_nonneg:  0 <= k); [ apply Z_to_Qle; apply inj_le; auto with arith|];
 (* TP: Zero < k + 1 *)
 assert (H_k_one_pos: Zero < k + 1); [natq_zero; qnat_one; natq_S k; natq_S (S k); auto|].

 generalize (rep_lb k _ _ Hr1); generalize (rep_lb k _ _ Hr2); generalize (rep_ub k _ _ Hr1); generalize (rep_ub k _ _ Hr2);
 intros H_r2_u H_r1_u H_r2_l H_r1_l;
 generalize (Q_to_Rle _ _ (thesis_5_7_9 k alpha));
 rewrite Q_to_Rdiv; auto; rewrite Q_to_Rminus; rewrite Q_to_Rplus;
 rewrite Z_to_Q_to_R_IZR; simpl; fold Qone; rewrite Q_to_R_Qone; intro H_ub_lb; rewrite Rdiv_Ropp_numerator.
  apply rep_interval_auxiliary with (lb alpha k) (ub alpha k); trivial.
  change R0 with 0%R; rewrite <- Q_to_R_Qone; rewrite <- Q_to_R_Zero; rewrite <- Q_to_Rplus; apply Rlt_not_eq'; apply Q_to_Rlt; auto.
Qed.

Lemma real_value_base_interval:forall alpha, (-1 <= real_value alpha <= 1)%R.
Proof.
 intros alpha; unfold real_value.
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 generalize RiemannInt.Rle_cv_lim; intro H_sandwich; split.

  apply (H_sandwich (fun (n:nat)=>(-1)%R) (fun n : nat => lb alpha n) (-1)%R y); trivial.
   intros n; rewrite <- Q_to_R_Qneg_One; apply Q_to_Rle; apply lb_is_in_base_interval_low.
   apply CV_const.
  apply (H_sandwich (fun n : nat => lb alpha n) (fun (n:nat)=>(1)%R) y (1)%R); trivial.
   intros n; rewrite <- Q_to_R_Qone; apply Q_to_Rle; apply lb_is_in_base_interval_up.
   apply CV_const.
Qed.

Lemma real_value_L:forall alpha, real_value (Cons LL alpha) = (((real_value alpha) -1 )/((real_value alpha)+ 3))%R.
Proof.
 intros alpha; unfold real_value;
 destruct (R_complete (fun n : nat => lb (Cons LL alpha) n) (lb_Cauchy (Cons LL alpha))) as [x H_x];
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 apply SeqProp.UL_sequence with (fun n : nat => lb (Cons LL alpha) n); trivial;
 apply CV_shift_S';
 apply CV_extensionality with (fun n=>(((lb alpha n) - 1) / ((lb alpha n) + 3))%R).

  intro n;
  rewrite lb_S_n;
   set (l':=lb alpha n);
   (* TP: Zero <= l'+ 1 *)
   assert (H_l'_one_nonneg: Zero <= l'+1);
   [ stepr (l'-(Qopp 1)); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_low|];
   (* TP: Zero < l'+3 *)
   assert (H_l'_three_pos: Zero < l'+3);
   [ apply Qle_lt_trans with (l'+1); auto; apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|];
   auto.

  unfold hd, tl; fold l';
  rewrite as_Moebius_Q_L; trivial; unfold tl; rewrite Q_to_Rdiv; auto;
   rewrite Q_to_Rminus; rewrite Q_to_Rplus;  do 2 rewrite Z_to_Q_to_R_IZR; simpl; replace (2+1)%R with 3%R; trivial; ring.

  apply (Rsqrt_def.continuity_seq (fun y=>((y - 1) / (y + 3))%R) (lb alpha) y); trivial;
  unfold Ranalysis1.continuity_pt; unfold Rderiv.continue_in; unfold Rdiv;
  apply (Rlimit.limit_mul (fun y=>(y-1)%R) (fun y=>(Rinv (y+3)))).
   apply (Rlimit.limit_minus (fun y=>y) (fun y=>1%R)).
    apply Rlimit.lim_x.
    apply (Rlimit.limit_free (fun y=>1%R)); exact y.
   apply (Rlimit.limit_inv (fun y=>(y+3)%R)).
    apply (Rlimit.limit_plus (fun y=>y) (fun y=>3%R)).
     apply Rlimit.lim_x.
     apply (Rlimit.limit_free (fun y=>3%R)); exact y.
    apply Rlt_not_eq';
    unfold Un_cv in Hy;
    destruct (Hy 2%R) as [N H_N]; try red; auto;
    assert (H_N_le:N>=N); auto; destruct (Rbasic_fun.Rabs_def2 _ _ (H_N N H_N_le)) as [H1 H2];
    generalize (Q_to_Rle _ _ (lb_is_in_base_interval_low N alpha));
    rewrite Q_to_Ropp; rewrite Q_to_R_Qone;
    apply very_sepcific_0; trivial.
Qed.

Lemma real_value_R:forall alpha, real_value (Cons RR alpha) = (((real_value alpha) +1 )/(-(real_value alpha)+ 3))%R.
Proof.
 intros alpha; unfold real_value;
 destruct (R_complete (fun n : nat => lb (Cons RR alpha) n) (lb_Cauchy (Cons RR alpha))) as [x H_x];
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 apply SeqProp.UL_sequence with (fun n : nat => lb (Cons RR alpha) n); trivial;
 apply CV_shift_S';
 apply CV_extensionality with (fun n=>(((lb alpha n) + 1) / (-(lb alpha n) + 3))%R).
  intro n;
  rewrite lb_S_n;
   set (l':=lb alpha n);
   (* TP: Zero <= -l'+ 1 *)
   assert (H_min_l'_one_nonneg: Zero <= -l'+1);
   [stepr (1-l'); try ring; apply Qle_Qminus_Zero; subst l'; apply lb_is_in_base_interval_up|];
   (* TP: Zero < -l'+3 *)
   assert (H_min_l'_three_pos: Zero < -l'+3);
   [ apply Qle_lt_trans with ((-l')+1); auto;
     apply Qlt_Zero_Qminus; stepr 2; auto; qnat_S 2; qnat_S 1; qnat_one; ring|];
   auto.

  unfold hd, tl; fold l'; rewrite as_Moebius_Q_R; trivial; unfold tl;
   rewrite Q_to_Rdiv; auto; do 2 rewrite Q_to_Rplus;  rewrite Q_to_Ropp; do 2 rewrite Z_to_Q_to_R_IZR; simpl;
   replace (2+1)%R with 3%R; trivial; ring.

  apply (Rsqrt_def.continuity_seq (fun y=>((y + 1) / (-y + 3))%R) (lb alpha) y); trivial;
  unfold Ranalysis1.continuity_pt; unfold Rderiv.continue_in; unfold Rdiv;
  apply (Rlimit.limit_mul (fun y=>(y+1)%R) (fun y=>(Rinv (-y+3)))).
   apply (Rlimit.limit_plus (fun y=>y) (fun y=>1%R)).
    apply Rlimit.lim_x.
    apply (Rlimit.limit_free (fun y=>1%R)); exact y.
   apply (Rlimit.limit_inv (fun y=>(-y+3)%R)).
    apply (Rlimit.limit_plus (fun y=>(Ropp y)) (fun y=>3%R)).
     apply (Rlimit.limit_Ropp (fun y=>y)); apply Rlimit.lim_x.
     apply (Rlimit.limit_free (fun y=>3%R)); exact y.
    apply Rlt_not_eq';
    unfold Un_cv in Hy;
    destruct (Hy 2%R) as [N H_N]; try red; auto;
    assert (H_N_le:N>=N); auto; destruct (Rbasic_fun.Rabs_def2 _ _ (H_N N H_N_le)) as [H1 H2];
    generalize (Q_to_Rle _ _ (lb_is_in_base_interval_up N alpha));
    rewrite Q_to_R_Qone.
    apply very_sepcific_1; trivial.
Qed.

Lemma real_value_M:forall alpha, real_value (Cons MM alpha) = ((real_value alpha)/3)%R.
Proof.
 intros alpha; unfold real_value;
 destruct (R_complete (fun n : nat => lb (Cons MM alpha) n) (lb_Cauchy (Cons MM alpha))) as [x H_x];
 destruct (R_complete (fun n : nat => lb alpha n) (lb_Cauchy alpha)) as [y Hy]; simpl;
 apply SeqProp.UL_sequence with (fun n : nat => lb (Cons MM alpha) n); trivial;
 apply CV_shift_S';
 apply CV_extensionality with (fun n=>((lb alpha n)/3)%R).
  intro n;
  rewrite lb_S_n;
  rewrite as_Moebius_Q_M; unfold tl; rewrite Q_to_Rdiv; auto.
   rewrite Z_to_Q_to_R_IZR; simpl; replace (2+1)%R with 3%R; trivial; ring.

  apply (Rsqrt_def.continuity_seq (fun y=>(y/3)%R) (lb alpha) y); trivial;
  unfold Ranalysis1.continuity_pt; unfold Rderiv.continue_in; unfold Rdiv;
  apply (Rlimit.limit_mul (fun y=>y) (fun y=>(Rinv 3))).
   apply Rlimit.lim_x.
   apply (Rlimit.limit_inv (fun y=>(3)%R)); auto.
   apply (Rlimit.limit_free (fun y=>3%R)); exact y.
Qed.

Lemma real_value_digits: forall d alpha, real_value (Cons d alpha) = as_Moebius d (real_value alpha).
Proof.
 intros [ | | ] alpha; unfold as_Moebius, fst, snd, map_digits;
 [ rewrite real_value_L
 | rewrite real_value_R
 | rewrite real_value_M
 ];
 qZ_numerals; realify_Q; auto; field.
 assert (H_alpha_base:=proj1 (real_value_base_interval alpha)); auto.
 assert (H_alpha_base:=proj2 (real_value_base_interval alpha)); apply Rlt_not_eq'; Fourier.fourier.
Qed.

Theorem rep_real_value : forall alpha, rep alpha (real_value alpha).
Proof.
 cofix.
 intros [[ | | ] alpha].
  rewrite real_value_L; apply rep_L with alpha;
   [ apply real_value_base_interval
   | apply rep_real_value
   | unfold bisim; apply EqSt_reflex].
  rewrite real_value_R; apply rep_R with alpha;
   [ apply real_value_base_interval
   | apply rep_real_value
   | unfold bisim; apply EqSt_reflex].
  rewrite real_value_M; apply rep_M with alpha;
   [ apply real_value_base_interval
   | apply rep_real_value
   | unfold bisim; apply EqSt_reflex].
Qed.

Theorem real_value_implies_rep: forall alpha r, real_value alpha = r -> rep alpha r.
Proof.
 intros [[ | | ] alpha] r Hrep.
  rewrite real_value_L in Hrep; rewrite <- Hrep;
  apply (rep_L alpha (Cons LL alpha) (real_value alpha) (real_value_base_interval alpha) (rep_real_value alpha) (EqSt_reflex _)).
  rewrite real_value_R in Hrep; rewrite <- Hrep;
  apply (rep_R alpha (Cons RR alpha) (real_value alpha) (real_value_base_interval alpha) (rep_real_value alpha) (EqSt_reflex _)).
  rewrite real_value_M in Hrep; rewrite <- Hrep;
  apply (rep_M alpha (Cons MM alpha) (real_value alpha) (real_value_base_interval alpha) (rep_real_value alpha) (EqSt_reflex _)).
Qed.

Theorem rep_implies_real_value: forall alpha r, rep alpha r -> real_value alpha = r.
Proof.
 intros alpha r H_rep.
 apply SeqProp.cond_eq.
 intros eps H_eps.
 set (N:=Zabs_nat (up (2 / eps))).
 destruct (rep_interval N _ _ _  (rep_real_value alpha) H_rep) as [H1 H2].
 elim (Raxioms.archimed (2/eps)); intros H_N _.
 rewrite <- (Z_of_nat_Zabs_nat_pos (up(2/eps))) in H_N; [|apply Zlt_le_weak; auto].
 apply Rbasic_fun.Rabs_def1.

   apply Rle_lt_trans with (2/((Rdefinitions.IZR N)+1))%R.
    stepr (2 / (N + 1))%R; auto.
    rewrite Z_to_Q_to_R_IZR; trivial.
    apply N_2_epsilon_plus_one; auto.

   apply Rlt_le_trans with (-(2/((Rdefinitions.IZR N)+1)))%R.
    apply Ropp_lt_contravar; apply N_2_epsilon_plus_one; auto.
    stepl (-2 / (N + 1))%R; auto.
    rewrite Z_to_Q_to_R_IZR; unfold Rdiv; rewrite IZR_Zneg_Zpos; rewrite Ropp_mult_distr_l_reverse; trivial.
Qed.


From Cat Require Import Cat.
From Cat.Universal Require Import Initial Terminal.
From Cat.Instances Require Import SETOID.

Set Implicit Arguments.

Class Cone {J C : Cat} (F : Functor J C) : Type :=
{
  apex : Ob C;
  legs : NatTrans (ConstFunctor apex J) F;
}.

Arguments apex [J C F] _.
Arguments legs [J C F] _.

Class ConeHom {J C : Cat} {F : Functor J C} (C1 C2 : Cone F) :=
{
  mor : Hom (apex C1) (apex C2);
  cond : forall X : Ob J, mor .> component (legs C2) X == component (legs C1) X
}.

Arguments mor [J C F C1 C2] _.
Arguments cond [J C F C1 C2] _ _.

#[refine]
#[export]
Instance ConeHomSetoid
  {J C : Cat} {F : Functor J C} (C1 C2 : Cone F) : Setoid (ConeHom C1 C2) :=
{
  equiv := fun f g : ConeHom C1 C2 => mor f == mor g
}.
Proof. now solve_equiv. Defined.

#[refine]
#[export]
Instance ConeComp
  {J C : Cat} {F : Functor J C} (C1 C2 C3 : Cone F)
  (f : ConeHom C1 C2) (g : ConeHom C2 C3) : ConeHom C1 C3 :=
{
  mor := mor f .> mor g
}.
Proof.
  now intros; rewrite !comp_assoc, !cond.
Defined.

#[refine]
#[export]
Instance ConeId {J C : Cat} {F : Functor J C} (C1 : Cone F) : ConeHom C1 C1 :=
{
  mor := id (apex C1)
}.
Proof. now cat. Defined.

#[refine]
#[export]
Instance ConeCat {J C : Cat} (F : Functor J C) : Cat :=
{
  Ob := Cone F;
  Hom := ConeHom;
  HomSetoid := ConeHomSetoid;
  comp := ConeComp;
  id := ConeId
}.
Proof. all: now cat. Defined.

Definition isLimit
  {J C : Cat} {F : Functor J C}
  (limit : Cone F)
  (limitMor : forall K : Cone F, ConeHom K limit)
  : Prop := @isTerminal (ConeCat F) limit limitMor.

Definition isLimit' {J C : Cat} {F : Functor J C} (K : Cone F) : Prop :=
  forall K' : Cone F, exists!! _ : ConeHom K' K, True.

Definition allShapedLimits
  {J C : Cat}
  (limit : forall F : Functor J C, Cone F)
  (limitMor : forall {F : Functor J C} (K : Cone F), ConeHom K (limit F))
  : Prop :=
    forall F : Functor J C, @isLimit J C F (limit F) (@limitMor F).

Definition allLimits
  {C : Cat}
  (limit  : forall {J : Cat} (F : Functor J C), Cone F)
  (limitMor : forall {J : Cat} (F : Functor J C) (K : Cone F), ConeHom K (limit F))
  : Prop :=
    forall (J : Cat) (F : Functor J C),
      @allShapedLimits J C (@limit J) (@limitMor J).

Class HasLimits (C : Cat) : Type :=
{
  limit  : forall {J : Cat} (F : Functor J C), Cone F;
  limitMor : forall {J : Cat} (F : Functor J C) (K : Cone F), ConeHom K (limit F);
  (* Proper? *)
  ok : allLimits (@limit) (@limitMor);
}.

Arguments limit    [C _ J] _.
Arguments limitMor [C _ J F] _.

#[refine]
#[export]
Instance ConeImage
  {J C D : Cat} {Diagram : Functor J C}
  (F : Functor C D) (K : Cone Diagram) : Cone (FunctorComp Diagram F) :=
{
  apex := fob F (apex K);
  legs := {| component := fun X : Ob J => _ |}
}.
Proof.
  - exact (fmap F (component (legs K) X)).
  - now cbn; intros; rewrite comp_id_l, <- fmap_comp, (natural (legs K) f); cbn; rewrite comp_id_l.
Defined.

Definition isContinuous {C D : Cat} {F : Functor C D} : Prop :=
  forall (J : Cat) (Diagram : Functor J C) (K : Cone Diagram),
    isLimit' K -> isLimit' (ConeImage F K).

(*
Coercion wut {C D : Cat} (F : Functor C D) : Ob (FunCat C D) := F.

Lemma isLimit_char
  (J C : Cat) (F : Functor J C)
  (K : Cone F) (del : forall K' : Cone F, ConeHom K' K) :
    @isLimit J C F K del
      <->
    forall c : Ob C,
      @isomorphic SETOID (HomSetoid C c (apex K)) (HomSetoid (FunCat J C) (ConstFunctor c J) F).
Proof.
Abort.
*)


Require Export Andell.
Require Export Andelr.
Section ml.
Variables A B C:Prop.
Theorem Andasl: and (and A B) C -> and A (and B C).
Proof.
    intro H0.
    (* split.
    elim H0.
    intro Hab.
    intro Hc.
    apply Andell with B.
    assumption.
    split.
    elim H0.
    intros Hab Hc.
    apply Andelr with A.
    assumption.
    apply Andelr with (and A B).
    assumption. *)
    elim H0.
    intros Hab Hc.
    elim Hab.
    intros Ha Hb.
    split.
    assumption.
    split; assumption.
Qed.
End ml.

Check Andasl.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tG_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable deftogethergreater_1 : (forall A B C D E F : Universe, (exists X : Universe, (tG_ A B C D E F -> (betS_ A B X /\ (cong_ B X C D /\ lt_ E F A X))))).
Variable deftogethergreater2_2 : (forall A B C D E F X : Universe, ((betS_ A B X /\ (cong_ B X C D /\ lt_ E F A X)) -> tG_ A B C D E F)).
Variable lemma_congruencesymmetric_3 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_4 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable cn_sumofparts_5 : (forall A B C E F G : Universe, ((cong_ A B E F /\ (cong_ B C F G /\ (betS_ A B C /\ betS_ E F G))) -> cong_ A C E G)).
Variable lemma_lessthancongruence2_6 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ A B E F) -> lt_ E F C D)).
Variable lemma_lessthancongruence_7 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Variable lemma_betweennotequal_8 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable axiom_nocollapse_9 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable deflessthan_10 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_11 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).

Theorem lemma_together_12 : (forall A B C D F G P Q Xa Xb Xc : Universe, ((tG_ A Xa B Xb C Xc /\ (cong_ D F A Xa /\ (cong_ F G B Xb /\ (betS_ D F G /\ cong_ P Q C Xc)))) -> (lt_ P Q D G /\ (A <> Xa /\ (B <> Xb /\ C <> Xc))))).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Setoids.
Require Import Category7.
Require Import Functor.

Definition functorEq (C D:Category) (F G:Functor C D) : Prop :=
    forall (a b:Obj C) (f:Hom a b), i (F <$> f) == i (G <$> f).

Arguments functorEq {C} {D} _ _.

Definition functorEq' (C D:Category) (F G:Functor C D) : Prop :=
    forall (f:Arr C), Func_ F f == Func_ G f.

Arguments functorEq' {C} {D} _ _.

(*
Lemma functorEqEq' : forall (C D:Category) (F G:Functor C D),
    functorEq F G -> functorEq' F G.
Proof.
    intros C D [F Fe Fs Ft Fc] [G Ge Gs Gt Gc] H. unfold functorEq'.
    intros f. unfold functorEq in H. simpl.
    unfold lift in H. unfold i in H. unfold lift_arrow_ in H.
    simpl in H.

Show.
*)


Require Import Coq.Lists.List.
Require Import Coq.Program.Equality.
Require Import Coq.Sorting.Permutation.
Require Import Metalib.Metatheory.

Set Implicit Arguments.

Hint Constructors Permutation.

(* Decomposition Lemmas *)

Lemma permute_exists_mid : forall (A : Type) (x : A) (xs ys us : list A),
    Permutation (xs ++ x :: ys) us ->
    exists vs ws, vs ++ x :: ws = us /\
                  Permutation (xs ++ ys) (vs ++ ws).
Proof.
  intros A x xs ys us H1. remember (xs ++ x :: ys) as H2.
  generalize dependent ys. generalize dependent xs.
  induction H1 using Permutation_ind_bis; intros xs ys H2; subst.
  - exfalso. eapply app_cons_not_nil. eauto.
  - apply cons_eq_app in H2 as [[zs [H3 H4]] | [H3 H4]]; subst.
    + destruct (IHPermutation zs ys eq_refl) as [vs [ws [H5 H6]]]; subst.
      exists (x0 :: vs), ws. simpl. eauto.
    + exists nil, l'. inversion H4. eauto.
  - apply  cons_eq_app in H2 as [[zs [H3 H4]] | [H3 H4]]; subst.
    + apply cons_eq_app in H4 as [[qs [H5 H6]] | [H5 H6]]; subst.
      * destruct (IHPermutation qs ys eq_refl) as [vs [ws [H7 H8]]]; subst.
        exists (x0 :: y :: vs), ws. simpl. eauto.
      * exists nil, (y :: l'). inversion H6. simpl. eauto.
    + exists (x0 :: nil), l'. inversion H4. simpl. eauto.
  - destruct (IHPermutation1 xs ys eq_refl) as [qs [us [H3 H4]]]; subst.
    destruct (IHPermutation2 qs us eq_refl) as [vs [ws [H5 H6]]]; subst. eauto.
Qed.

Lemma permute_exists_cons : forall (A : Type) (x : A) (xs ys : list A),
    Permutation (x :: xs) ys ->
    exists vs ws, vs ++ x :: ws = ys /\
                  Permutation xs (vs ++ ws).
Proof.
  intros A x xs ys H1. rewrite_env (nil ++ x :: xs) in H1.
  destruct (permute_exists_mid _ _ _ H1) as [vs [ws [H2 H3]]].
  subst. exists vs, ws. simpl in H3. intuition.
Qed.

(* Permutation Properties *)

Lemma dom_permute : forall (A : Type) (E1 E2 : list (atom * A)),
    Permutation E1 E2 ->
    dom E1 [=] dom E2.
Proof.
  intros A E1 E2 H1; induction H1;
    try destruct x as [x1 T1];
    try destruct y as [x2 T2];
    try solve [simpl; fsetdec].
Qed.

Lemma notin_permute : forall (A : Type) (x1 : atom) (E1 E2 : list (atom * A)),
    Permutation E1 E2 ->
    x1 `notin` dom E1 ->
    x1 `notin` dom E2.
Proof.
  intros A x1 E1 E2 H1 H2; induction H1;
    try destruct x as [y1 T1];
    try destruct y as [y2 T2];
    try solve [simpl in *; fsetdec].
Qed.

Lemma uniq_permute : forall (A : Type) (E1 E2 : list (atom * A)),
    Permutation E1 E2 ->
    uniq E1 ->
    uniq E2.
Proof.
  intros A E1 E2 H1 H2; induction H1;
    try destruct x as [x1 T1];
    try destruct y as [x2 T2]; auto.
  - pose proof (dom_permute H1). solve_uniq.
  - solve_uniq.
Qed.

Lemma disjoint_permute : forall {A : Type} (E1 E2 E3 : list (atom * A)),
    Permutation E1 E2 ->
    disjoint E1 E3 ->
    disjoint E2 E3.
Proof.
  unfold disjoint. intros A E1 E2 E3 H1 H2.
  rewrite (dom_permute H1) in H2. auto.
Qed.

Lemma binds_permute : forall A (E1 E2 : list (atom * A)) x1 T1,
    Permutation E1 E2 ->
    binds x1 T1 E1 ->
    binds x1 T1 E2.
Proof.
  intros A E1 E2 x1 T1 H1 H2.
  induction H1 as [| [x2 T2] | [x2 T2] [x3 T3] |]; auto.
  - analyze_binds H2.
  - analyze_binds H2.
Qed.

Hint Resolve dom_permute      : permutation.
Hint Resolve notin_permute    : permutation.
Hint Resolve uniq_permute     : permutation.
Hint Resolve disjoint_permute : permutation.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal80.

Set Printing Depth 1000.
Definition lfind_eval  n x:=
append (rev x) (Cons n Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons Zero Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero Nil).

Compute lfind_eval  (Succ (Succ (Succ Zero))) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Succ Zero) (Nil).

Compute lfind_eval  (Succ (Succ Zero)) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Zero) (Cons (Succ (Succ (Succ Zero))) (Cons (Succ (Succ Zero)) Nil)).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Cons Zero Nil).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Zero) (Cons Zero (Cons Zero Nil)).

Compute lfind_eval  (Zero) (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Succ Zero) (Cons (Succ Zero) Nil).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Succ Zero) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).

Compute lfind_eval  (Zero) (Cons Zero (Cons (Succ Zero) Nil)).

Compute lfind_eval  (Zero) (Nil).

Compute lfind_eval  (Zero) (Nil).


Require Import Bool List.
Import ListNotations.

(** The cbn example is taken from "Another Look at Nested Recursion" *)

Section AnotherLook.

Variable Var : Type.
Hypothesis veq : Var -> Var -> bool.
Hypothesis veq_spec : forall x y : Var, reflect (x = y) (veq x y).

Inductive Term (A : Type) : Type :=
| C : nat -> Term A
| V : A -> Term A
| Add : Term A -> Term A -> Term A
| App : Term A -> A (*Term A*) -> Term A -> Term A.

Arguments C   {A} _.
Arguments V   {A} _.
Arguments Add {A} _ _.
Arguments App {A} _ _ _.

Definition Env : Type := list (Var * nat).

Fixpoint lookup (v : Var) (env : Env) : nat :=
match env with
| [] => 0
| (x, n) :: env' => if veq v x then n else lookup v env'
end.

Fixpoint cbv (t : Term Var) (env : Env) : nat :=
match t with
| C n => n
| V v => lookup v env
| Add t1 t2 => plus (cbv t1 env) (cbv t2 env)
| App t1 x t2 => cbv t1 ((x, cbv t2 env) :: env)
end.

Inductive cbnG : Term Var -> Var -> Term Var -> Term Var -> Type :=
| cbnG_C :
    forall (n : nat) (y : Var) (z : Term Var), cbnG (C n) y z (C n)
| cbnG_V_eq :
    forall (y : Var) (z r : Term Var),
      cbnhG z r -> cbnG (V y) y z r
| cbnG_V_neq :
    forall (v y : Var) (z : Term Var),
      v <> y -> cbnG (V v) y z (V v)
| cbnG_Add :
    forall (t1 t2 : Term Var) (y : Var) (z r1 r2 : Term Var),
      cbnG t1 y z r1 -> cbnG t2 y z r2 ->
        cbnG (Add t1 t2) y z (Add r1 r2)
| cbnG_App :
    forall (t1 t2 : Term Var) (x y : Var) (z r1 r2 : Term Var),
      cbnG t1 x t2 r1 -> cbnG r1 y z r2 ->
        cbnG (App t1 x t2) y z r2

with cbnhG : Term Var -> Term Var -> Type :=
| cbnhG_C :
    forall n : nat, cbnhG (C n) (C n)
| cbnhG_V :
    forall x : Var, cbnhG (V x) (V x)
| cbnhG_Add :
    forall t1 t2 r1 r2 : Term Var,
      cbnhG t1 r1 -> cbnhG t2 r2 -> cbnhG (Add t1 t2) (Add r1 r2)
| cbnhG_App :
    forall (t1 t2 : Term Var) (x : Var) (r : Term Var),
      cbnG t1 x t2 r -> cbnhG (App t1 x t2) r.

Inductive cbnD : Term Var -> Var -> Term Var -> Type :=
| cbnD_C :
    forall (n : nat) (y : Var) (z : Term Var), cbnD (C n) y z
| cbnD_V_eq :
    forall (y : Var) (z : Term Var),
      cbnhD z -> cbnD (V y) y z
| cbnD_V_neq :
    forall (v y : Var) (z : Term Var),
      v <> y -> cbnD (V v) y z
| cbnD_Add :
    forall (t1 t2 : Term Var) (y : Var) (z : Term Var),
      cbnD t1 y z -> cbnD t2 y z ->
        cbnD (Add t1 t2) y z
| cbnD_App :
    forall (t1 t2 : Term Var) (x y : Var) (z r : Term Var),
      cbnG t1 x t2 r -> cbnD r y z ->
        cbnD (App t1 x t2) y z

with cbnhD : Term Var -> Type :=
| cbnhD_C :
    forall n : nat, cbnhD (C n)
| cbnhD_V :
    forall x : Var, cbnhD (V x)
| cbnhD_Add :
    forall t1 t2 : Term Var,
      cbnhD t1 -> cbnhD t2 -> cbnhD (Add t1 t2)
| cbnhD_App :
    forall (t1 t2 : Term Var) (x : Var),
      cbnD t1 x t2 -> cbnhD (App t1 x t2).

Fixpoint cbn
  {t : Term Var} {y : Var} {z : Term Var} (d : cbnD t y z) : Term Var :=
match d with
| cbnD_C n _ _ => C n
| cbnD_V_eq _ _ dz => cbnh dz
| cbnD_V_neq v _ _ _ => V v
| cbnD_Add _ _ _ _ d1 d2 => Add (cbn d1) (cbn d2)
| cbnD_App _ _ _ _ _ _ _ d' => cbn d'
end

with cbnh {t : Term Var} (d : cbnhD t) : Term Var :=
match d with
| cbnhD_C n => C n
| cbnhD_V x => V x
| cbnhD_Add _ _ d1 d2 => Add (cbnh d1) (cbnh d2)
| cbnhD_App _ _ _ d' => cbn d'
end.

Lemma cbnG_cbn :
  forall (t : Term Var) (y : Var) (z : Term Var) (d : cbnD t y z),
    cbnG t y z (cbn d)

with cbnhG_cbnh :
  forall (t : Term Var) (d : cbnhD t),
    cbnhG t (cbnh d).
Proof.
  destruct d; cbn.
    constructor.
    constructor. apply cbnhG_cbnh.
    constructor. assumption.
    constructor; apply cbnG_cbn.
    econstructor.
      exact c.
      apply cbnG_cbn.
  destruct d; cbn.
    constructor.
    constructor.
    constructor; apply cbnhG_cbnh.
    constructor. apply cbnG_cbn.
Restart.
  all: destruct d; cbn; econstructor; eauto.
Qed.

End AnotherLook.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2018   --   Inria - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.
Require list.Reverse.
Require list.NumOcc.

(* Why3 assumption *)
Definition permut {a:Type} {a_WT:WhyType a} (l1:(list a))
  (l2:(list a)): Prop :=
  forall (x:a), ((list.NumOcc.num_occ x l1) = (list.NumOcc.num_occ x l2)).

(* Why3 goal *)
Lemma Permut_refl :
forall {a:Type} {a_WT:WhyType a},
forall (l:(list a)), (permut l l).
Proof.
now intros a a_WT l.
Qed.

(* Why3 goal *)
Lemma Permut_sym :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)), (permut l1 l2) -> (permut l2 l1).
Proof.
now intros a a_WT l1 l2 h1.
Qed.

(* Why3 goal *)
Lemma Permut_trans :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)) (l3:(list a)),
 (permut l1 l2) -> ((permut l2 l3) -> (permut l1 l3)).
Proof.
intros a a_WT l1 l2 l3 h1 h2 x.
now rewrite h1.
Qed.

(* Why3 goal *)
Lemma Permut_cons :
forall {a:Type} {a_WT:WhyType a},
forall (x:a) (l1:(list a)) (l2:(list a)),
 (permut l1 l2) -> (permut (Init.Datatypes.cons x l1)
 (Init.Datatypes.cons x l2)).
Proof.
intros a a_WT x l1 l2 h1 y.
simpl.
now rewrite h1.
Qed.

(* Why3 goal *)
Lemma Permut_swap :
forall {a:Type} {a_WT:WhyType a},
forall (x:a) (y:a) (l:(list a)),
 (permut (Init.Datatypes.cons x (Init.Datatypes.cons y l))
 (Init.Datatypes.cons y (Init.Datatypes.cons x l))).
Proof.
intros a a_WT x y l z.
simpl.
ring.
Qed.

(* Why3 goal *)
Lemma Permut_cons_append :
forall {a:Type} {a_WT:WhyType a},
forall (x:a) (l1:(list a)) (l2:(list a)),
 (permut (Init.Datatypes.app (Init.Datatypes.cons x l1) l2)
 (Init.Datatypes.app l1 (Init.Datatypes.cons x l2))).
Proof.
intros a a_WT x l1 l2 y.
induction l1 as [|l1h l1t IHl1].
easy.
simpl in IHl1 |- *.
rewrite <- IHl1.
ring.
Qed.

(* Why3 goal *)
Lemma Permut_assoc :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)) (l3:(list a)),
 (permut (Init.Datatypes.app (Init.Datatypes.app l1 l2) l3)
 (Init.Datatypes.app l1 (Init.Datatypes.app l2 l3))).
Proof.
intros a a_WT l1 l2 l3 y.
now rewrite List.app_assoc.
Qed.

(* Why3 goal *)
Lemma Permut_append :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)) (k1:(list a)) (k2:(list a)),
 (permut l1 k1) ->
 ((permut l2 k2) -> (permut (Init.Datatypes.app l1 l2)
  (Init.Datatypes.app k1 k2))).
Proof.
intros a a_WT l1 l2 k1 k2 h1 h2 y.
rewrite 2!NumOcc.Append_Num_Occ.
now apply f_equal2.
Qed.

(* Why3 goal *)
Lemma Permut_append_swap :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)),
 (permut (Init.Datatypes.app l1 l2) (Init.Datatypes.app l2 l1)).
Proof.
intros a a_WT l1 l2 y.
rewrite 2!NumOcc.Append_Num_Occ.
apply Zplus_comm.
Qed.

(* Why3 goal *)
Lemma Permut_mem :
forall {a:Type} {a_WT:WhyType a},
forall (x:a) (l1:(list a)) (l2:(list a)),
 (permut l1 l2) -> ((list.Mem.mem x l1) -> (list.Mem.mem x l2)).
Proof.
intros a a_WT x l1 l2 h1 h2.
apply NumOcc.Mem_Num_Occ.
rewrite <- h1.
now apply NumOcc.Mem_Num_Occ.
Qed.

(* Why3 goal *)
Lemma Permut_length :
forall {a:Type} {a_WT:WhyType a},
forall (l1:(list a)) (l2:(list a)),
 (permut l1 l2) -> ((list.Length.length l1) = (list.Length.length l2)).
Proof.
intros a a_WT l1 l2 h1.
revert l2 h1.
induction l1 as [|l1h l1t IHl1].
- destruct l2 as [|l2h l2t].
  easy.
  intros H.
  specialize (H l2h).
  contradict H.
  simpl.
  case why_decidable_eq ; intros H.
  generalize (NumOcc.Num_Occ_NonNeg l2h l2t).
  omega.
  now elim H.
- intros l2 H.
  assert (H': Mem.mem l1h l2).
    apply NumOcc.Mem_Num_Occ.
    specialize (H l1h).
    simpl in H.
    destruct (why_decidable_eq l1h l1h) as [_|H'].
    2: now elim H'.
    generalize (NumOcc.Num_Occ_NonNeg l1h l1t).
    omega.
  destruct (Append.mem_decomp _ _ H') as [l2a [l2b Hl2]].
  rewrite Hl2.
  rewrite Append.Append_length.
  change (1 + Length.length l1t = Length.length l2a + (1 + Length.length l2b))%Z.
  rewrite (IHl1 (l2a ++ l2b)%list).
  rewrite Append.Append_length.
  ring.
  rewrite Hl2 in H.
  assert (H1 := Permut_cons_append l1h l2a l2b).
  apply Permut_sym in H1.
  generalize (Permut_trans _ _ _ H H1).
  change ((l1h :: l2a) ++ l2b)%list with (l1h :: (l2a ++ l2b))%list.
  generalize (l2a ++ l2b)%list.
  clear.
  intros l H y.
  specialize (H y).
  simpl in H.
  omega.
Qed.


Set Implicit Arguments.

Require Import String.
Require Import NatFacts.

Lemma length_append : forall s1 s2, String.length (s1 ++ s2) = String.length s1 + String.length s2.
  induction s1; simpl; intuition.
Qed.

Local Open Scope string.

Lemma prefix_neq : forall (s1 s2 : string), s1 <> "" -> (s1 ++ s2)%string <> s2.
  intros.
  intuition.
  contradict H.
  eapply f_equal with (f := String.length) in H0.
  rewrite length_append in H0.
  eapply plus_eq_right_0 in H0.
  destruct s1; simpl in *; intuition.
  discriminate.
Qed.

Lemma append_inj_2 : forall a b c, (a ++ b = a ++ c -> b = c)%string.
  induction a; simpl; intuition.
  injection H; intros.
  eauto.
Qed.


(**
プログラミング Coq --- 停止性が明らかでない関数を定義するには

http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt7.html
をSSReflectに書き直した。
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import Recdef.

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

Fixpoint merge (l1 l2 : seq nat) :=
  (fix merge' l' :=
    match l1, l' with
    | nil, _ => l'
    | _, nil => l1
    | x::xs, y::ys => if x <= y then x :: merge xs l' else y :: merge' ys
    end
  ) l2.

Fixpoint split (l : seq nat) : seq nat * seq nat :=
  match l with
  | nil => (nil, nil)
  | x::nil => (x :: nil, nil)
  | x::y::zs => (fun l' => (x :: fst l', y :: snd l')) (split zs)
  end.
(*
Function msort (l : seq nat) {measure length l} : seq nat :=
  match l with
  | nil => nil
  | x::nil => x::nil
  | x::y::zs => (fun l' => merge (msort (fst l')) (msort (snd l'))) (split l)
  end.
Proof.
 (* length (snd (split (x::y::zs))) < length (x::y::zs) *)
 intros.
 simpl.
 subst.
 induction (split zs).
  simpl.
  constructor.

  simpl.
  constructor.
  admit.

  simpl.
  intros.
  apply lt_S.
  apply lt_n_S.
  apply IHp.

 (* length (fst (split (x::y::zs))) < length (x::y::zs) *)
 intros.
 subst.
 functional induction (split zs).
  simpl.
  constructor.

  simpl.
  constructor.

  simpl.
  apply lt_n_S.
  apply lt_S.
  apply IHp.
Defined.
*)

(* 問10. *)

(* stardard Coq の not_eq_S. と eq_S の両方 *)
Lemma eq_S_S (n m : nat) : n = m <-> n.+1 = m.+1.
Proof.
  split=> H.
  - by congr (_ .+1).
  - apply/eqP.
    rewrite -eqSS.
    apply/eqP.
    by apply H.
Qed.

Goal forall (n m : nat), n = m \/ n <> m.
Proof.
  elim=> [m | n IHn m].                     (* elim: n *)
  - by elim: m; [left | right].             (* elim: m *)
  - elim: m => [| m _].
    + by right.
    + elim: (IHn m); [left | right].
      * by congr (_ .+1).
      * by move/eq_S_S : H.                 (* move:H; move/eq_S_S *)
Qed.

(* 問11. *)
Goal forall (P Q : nat -> Prop),
       (forall n, P n -> Q n) -> ((forall n, P n) -> (forall n, Q n)).
Proof.
  move=> P Q H H0 n.
  by apply/H/H0.
Qed.

(* END *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sets                                                                    *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect LibList
  LibOperation LibStruct LibInt LibNat LibEpsilon.
Require Export LibBag.

(* ********************************************************************** *)
(** * Construction of sets as predicates *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Definition set (A : Type) := A -> Prop.

Section Operations.
Variables (A B : Type).
Implicit Types x : A.
Implicit Types E F G : set A.

Definition set_st (P:A->Prop) : set A := P.
Definition empty_impl : set A := (fun _ => False).
Definition full_impl : set A := (fun _ => True).
Definition single_impl x := (= x).
Definition in_impl x E := E x.
Definition compl_impl : set A -> set A := @pred_not A. (* todo: as typeclass? *)
Definition union_impl : set A -> set A -> set A := @pred_or A.
Definition inter_impl : set A -> set A -> set A := @pred_and A.
Definition remove_impl : set A -> set A -> set A :=
  fun E F x => E x /\ ~ F x.
Definition incl_impl : set A -> set A -> Prop := @pred_le A.
Definition list_repr_impl (E:set A) (l:list A) :=
  No_duplicates l /\ forall x, Mem x l <-> E x.
Definition to_list (E:set A) := epsilon (list_repr_impl E).
Definition finite (E:set A) := exists l, list_repr_impl E l.
Definition card_impl (E:set A) := LibList.length (to_list E).
Definition fold_impl (m:monoid_def B) (f:A->B) (E:set A) :=
  LibList.fold_right (fun x acc => monoid_oper m (f x) acc)
    (monoid_neutral m) (to_list E).

End Operations.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance set_inhab : forall A, Inhab (set A).
Proof. intros. apply (prove_Inhab (@empty_impl A)). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Lemma in_inst : forall A, BagIn A (set A).
Proof. constructor. exact (@in_impl A). Defined.
Hint Extern 1 (BagIn _ (set _)) => apply in_inst : typeclass_instances.
(* TODO: why is this not an instance like others ? *)

Instance empty_inst : forall A, BagEmpty (set A).
  constructor. apply (@empty_impl A). Defined.
Instance single_inst : forall A, BagSingle A (set A).
  constructor. rapply (@single_impl A). Defined.
Instance union_inst : forall A, BagUnion (set A).
  constructor. rapply (@union_impl A). Defined.
Instance inter_inst : forall A, BagInter (set A).
  constructor. rapply (@inter_impl A). Defined.
Instance remove_inst : forall A, BagRemove (set A) (set A).
  constructor. rapply (@remove_impl A). Defined.
Instance incl_inst : forall A, BagIncl (set A).
  constructor. rapply (@incl_impl A). Defined.
Instance disjoint_inst : forall A, BagDisjoint (set A).
  constructor. rapply (fun E F : set A => E \n F = \{}). Defined.
Instance fold_inst : forall A B, BagFold B (A->B) (set A).
  constructor. rapply (@fold_impl A B). Defined.
Instance card_inst : forall A, BagCard (set A).
  constructor. rapply (@card_impl A). Defined.

Global Opaque set finite in_inst empty_inst single_inst union_inst inter_inst
  remove_inst incl_inst disjoint_inst card_inst fold_inst.

(* ---------------------------------------------------------------------- *)
(** ** Notations for building sets *)

Notation "\set{ x | P }" := (@set_st _ (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x : A | P }" := (@set_st A (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x '\in' E | P }" := (@set_st _ (fun x => x \in E /\ P))
 (at level 0, x ident, P at level 200) : set_scope.

Notation "\set{= e | x '\in' E }" :=
 (@set_st _ (fun a => exists_ x \in E, a = e ))
 (at level 0, x ident, E at level 200) : set_scope.
Notation "\set{= e | x '\in' E , y ''\in' F }" :=
 (@set_st _ (fun a => exists_ x \in E, exists_ y \in F, a = e ))
 (at level 0, x ident, F at level 200) : set_scope.
Notation "\set{= e | x y '\in' E }" :=
 (@set_st _ (fun a => exists_ x y \in E, a = e ))
 (at level 0, x ident, y ident, E at level 200) : set_scope.

(* ********************************************************************** *)
(** * Properties of sets *)

Section Instances.
Variables (A:Type).
Transparent set finite empty_inst single_inst single_impl in_inst
  incl_inst inter_inst union_inst card_inst fold_inst remove_inst
  disjoint_inst.
Hint Constructors Mem.

Ltac unf := unfold finite,
  card_inst, card_impl, card,
  to_list,
  disjoint_inst, disjoint,
  incl_inst, incl_impl,
  empty_inst, empty_impl, empty,
  single_inst, single_impl, single,
  in_inst, in_impl, is_in,
  incl_inst, incl_impl, incl,
  compl_impl, pred_not,
  inter_inst, inter_impl, inter, pred_and,
  union_inst, union_impl, union, pred_or,
  remove_inst, remove_impl, remove,
  fold_inst, fold_impl, fold in *.

(* ---------------------------------------------------------------------- *)
(** set_st *)

Lemma in_set_st_eq : forall A (P:A->Prop) x,
  x \in set_st P = P x.
Proof. intros. apply* prop_ext. Qed.

(* ---------------------------------------------------------------------- *)
(** to_list *)

Lemma to_list_spec : forall (E:set A) L,
  L = to_list E -> finite E -> No_duplicates L /\ (forall x, Mem x L <-> x \in E).
Proof.
  intros. unfolds to_list, finite. spec_epsilon~ as L' (HL'&EL'). subst*.
Qed.

Lemma to_list_empty :
  to_list (\{}:set A) = nil.
Proof.
  unf. spec_epsilon as l.
  exists (@nil A). split. constructor. iff; false_invert.
  inverts Hl. simpls. destruct~ l. false. rewrite <- H0. simple~.
Qed.

Lemma to_list_single : forall (x:A),
  to_list (\{x}) = x::nil.
Proof.
  intros. unfold to_list. spec_epsilon as l.
    exists (x::nil). split.
      constructor*. introv M. inverts M.
      unfold single_inst, single_impl. simple~.
       iff H. inverts* H. inverts* H1. inverts* H.
  unfolds single_inst, single_impl. simpls~.
  inverts Hl as H H0. destruct (H0 x). specializes~ H2.
  destruct l.
    inverts H2.
    tests E: (x = a).
      fequals. destruct l. auto. forwards~: (proj1 (H0 a0)).
       subst. inverts H as M1 M2. false* M1.
      inverts H2. false. forwards~: (proj1 (H0 a)). false.
Qed.

(* ---------------------------------------------------------------------- *)
(** finite *)

Lemma finite_prove : forall A (E:set A) L,
  (forall x, x \in E -> Mem x L) -> finite E.
Proof.
  introv M. sets_eq L1 EQL1: (Remove_duplicates L).
  forwards~ (HN&HM): Remove_duplicates_spec EQL1.
  sets L2: (Filter (fun x => x \in E) L1).
  exists L2. split.
    applys* Filter_No_duplicates.
    intros x. specializes M x. rewrite <- HM in M. unf. iff N.
      subst L2. forwards*: Filter_Mem_inv N.
      applys* Filter_Mem.
Qed.

Lemma finite_prove_exists : forall A (E:set A),
  (exists L, forall x, x \in E -> Mem x L) -> finite E.
Proof. introv (L&H). applys* finite_prove. Qed.

Lemma finite_inv_basic : forall A (E:set A),
  finite E -> exists L, (forall x, x \in E -> Mem x L).
Proof. introv (L&HN&HM). exists L. intros. applys* HM. Qed.

Lemma finite_empty : forall A,
  finite (\{} : set A).
Proof.
(*  intros. apply finite_prove_exists. unf.
  exists (@nil A). introv M. inverts M.
Qed.
*)
Admitted.

Lemma finite_singleton : forall A (a : A),
  finite \{a}.
Proof.
  intros. apply finite_prove_exists. unf.
  exists (a::nil). introv M. hnf in M. subst*.
Qed.

Lemma finite_union : forall A (E F : set A),
  finite E ->
  finite F ->
  finite (E \u F).
Proof.
  introv H1 H2. apply finite_prove_exists.
  lets (L1&E1): finite_inv_basic H1.
  lets (L2&E2): finite_inv_basic H2.
  exists (L1++L2). unf. introv M. rewrite* Mem_app_or_eq.
Qed.

Lemma finite_inter : forall A (E F : set A),
  finite E \/ finite F ->
  finite (E \n F).
Proof.
  introv H. apply finite_prove_exists. destruct H.
  lets (L&EQ): finite_inv_basic H. exists L. unf. autos*.
  lets (L&EQ): finite_inv_basic H. exists L. unf. autos*.
Qed.

Lemma finite_incl : forall A (E F : set A),
  E \c F ->
  finite F ->
  finite E.
Proof.
  introv HI HF. apply finite_prove_exists.
  lets (L&EQ): finite_inv_basic HF. unf. exists* L.
Qed.

Lemma finite_remove : forall A (E F : set A),
  finite E ->
  finite (E \- F).
Proof.
  introv HE. apply finite_prove_exists.
  lets (L&EQ): finite_inv_basic HE. unf. exists* L.
Qed.

(* ---------------------------------------------------------------------- *)
(** fold *)

Lemma fold_empty : forall B m (f:A->B),
  fold m f (\{}:set A) = monoid_neutral m.
Proof.
  intros. unfold fold_inst, fold_impl, fold.
  rewrite to_list_empty. rewrite~ fold_right_nil.
Qed.

Lemma fold_single : forall B (m:monoid_def B) (f:A->B) (x:A),
  Monoid m -> fold m f \{x} = f x.
Proof.
  intros. unfold fold_inst, fold_impl, fold.
  rewrite to_list_single. rewrite~ fold_right_cons.
  rewrite fold_right_nil. rewrite monoid_neutral_r. auto.
Qed.

Lemma fold_union : forall B (m:monoid_def B) (f:A->B) (E F : set A),
  Monoid m ->
  finite E ->
  finite F ->
  E \# F ->
  fold m f (E \u F) = monoid_oper m (fold m f E) (fold m f F).
Proof.
  intros. unfold fold, fold_inst, fold_impl.
  admit. (* todo: under development *)
Qed.

(* ---------------------------------------------------------------------- *)
(** double inclusion *)

Lemma set_ext_eq : forall (E F : set A),
  (E = F) = (forall (x:A), x \in E <-> x \in F).
Proof.
  intros. apply prop_ext. iff H. subst*. apply* prop_ext_1.
Qed.

Lemma set_ext : forall (E F : set A),
  (forall (x:A), x \in E <-> x \in F) -> E = F.
Proof. intros. rewrite~ set_ext_eq. Qed.

(* ---------------------------------------------------------------------- *)
(** set_in, incl *)

Global Instance in_extens_inst : In_extens (A:=A) (T:=set A).
Proof. constructor. intros. rewrite* set_ext_eq. Qed.

Global Instance in_empty_eq_inst : In_empty_eq (A:=A) (T:=set A).
Proof. constructor. intros. apply* prop_ext. Qed.

Global Instance in_single_eq_inst : In_single_eq (A:=A) (T:=set A).
Proof. constructor. intros. apply* prop_ext. Qed.

Global Instance in_union_eq_inst : In_union_eq (A:=A) (T:=set A).
Proof. constructor. intros. unf. apply* prop_ext. Qed.

Global Instance in_inter_eq_inst : In_inter_eq (A:=A) (T:=set A).
Proof. constructor. intros. unf. apply* prop_ext. Qed.

Global Instance in_remove_eq_inst : In_remove_eq (A:=A) (T:=set A).
Proof. constructor. intros. unf. applys* prop_ext. Qed.

Global Instance incl_in_eq_inst : Incl_in_eq (A:=A) (T:=set A).
Proof. constructor. intros. unf. autos*. Qed.

Global Instance disjoint_eq_inst : Disjoint_eq (T:=set A).
Proof.
  constructor. intros. unf. applys prop_ext. iff M.
    intros x. rewrite* <- (@func_same_1 _ _ x _ _ M).
    applys* prop_ext_1.
Qed.

(* ---------------------------------------------------------------------- *)
(** card *)

(* TODO: prove that
  card E = min_of (fun n => exists L, covers L E /\ n = length L)
  where covers L E = forall_ x \in E, Mem x L
*)

Lemma card_is_length_to_list : forall (E:set A),
  finite E -> card E = length (to_list E).
Proof. introv HF. unf. spec_epsilon* as L'. Qed.

Global Instance card_empty_inst : Card_empty (T:=set A).
Proof.
  constructor. lets E: to_list_empty. unf. rewrite E. rew_list~.
Qed.

Global Instance card_single_inst : Card_single (T:=set A).
Proof.
  constructor. intros a. lets E: to_list_single a. unf. rewrite E. rew_list~.
Qed.

Lemma set_card_union_le : forall (E F:set A),
  finite E -> finite F ->
  card (E \u F) <= (card E + card F)%nat.
Proof.
  Local Opaque union. hint finite_union.
  introv FE FF. do 3 rewrite~ card_is_length_to_list.
  forwards~ (NE&HE): to_list_spec E.
  forwards~ (NF&HF): to_list_spec F.
  forwards~ (NG&HG): to_list_spec (E \u F).
  sets LE: (to_list E). sets LF: (to_list F).
  sets G: (E \u F). sets LG: (to_list G).
  asserts RG: (forall x : A, Mem x LG <-> (x \in E \/ x \in F)).
    intros. specializes HG x. subst G. rewrite in_union_eq in HG. auto.
  clear HG. clearbody LG.
  forwards~ M: No_duplicates_length_le LG (LE ++ LF).
   introv N. apply Mem_app_or. rewrite HE, HF. rewrite <- RG. auto.
  rew_length in M. auto.
  Transparent union. (* should not be needed *)
Qed.

(* ---------------------------------------------------------------------- *)
(** structural decomposition *)

Lemma set_isolate : forall (E : set A) x,
  x \in E ->
  E = \{x} \u (E \- \{x}).
Proof.
  introv H. unf. apply prop_ext_1. intros y. iff M.
    tests*: (y = x).
    destruct M. subst*. autos*.
Qed.

End Instances.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

(** Rewriting tactics *)

Hint Rewrite in_set_st_eq : rew_set.
Tactic Notation "rew_set" :=
  autorewrite with rew_set.
Tactic Notation "rew_set" "in" hyp(H) :=
  autorewrite with rew_set in H.
Tactic Notation "rew_set" "in" "*" :=
  autorewrite with rew_set in *.

(* ********************************************************************** *)
(** * Additional predicates on sets *)

(* ---------------------------------------------------------------------- *)
(** ** Foreach *)

(** TODO: derive these lemmas as typeclasses in a generic way in LibBag *)

Section ForeachProp.
Variables (A : Type).
Implicit Types P Q : A -> Prop.
Implicit Types E F : set A.

Lemma foreach_empty : forall P,
  @foreach A (set A) _ P \{}.
Proof. intros_all. false. Qed.
(* TODO: false* @in_empty. typeclass. *)

Lemma foreach_single : forall P X,
  P X -> @foreach A (set A) _ P (\{ X }).
Proof. intros_all. rewrite in_single_eq in H0. subst*. Qed.

Lemma foreach_union : forall P E F,
  foreach P E -> foreach P F -> foreach P (E \u F).
Proof. intros_all. destruct~ (in_union_inv H1). Qed.

Lemma foreach_union_inv : forall P E F,
  foreach P (E \u F) -> foreach P E /\ foreach P F.
Proof.
  introv H. split; introv K.
  apply H. rewrite~ @in_union_eq. typeclass.
  apply H. rewrite~ @in_union_eq. typeclass.
Qed.

Lemma foreach_union_eq : forall P E F,
  foreach P (E \u F) = (foreach P E /\ foreach P F).
Proof.
  intros. extens. iff.
  apply~ foreach_union_inv. apply* foreach_union.
Qed.

Lemma foreach_single_eq : forall P X,
  foreach P (\{X}:set A) = P X.
Proof.
  intros. extens. iff.
  apply H. apply in_single_self.
  apply~ foreach_single.
Qed.

Lemma foreach_weaken : forall P Q E,
  foreach P E -> pred_le P Q -> foreach Q E.
Proof. introv H L K. apply~ L. Qed.

End ForeachProp.

Hint Resolve foreach_empty foreach_single foreach_union.
Hint Rewrite foreach_union_eq foreach_single_eq : rew_foreach.

Tactic Notation "rew_foreach" :=
  autorewrite with rew_foreach.
Tactic Notation "rew_foreach" "in" hyp(H) :=
  autorewrite with rew_foreach in H.
Tactic Notation "rew_foreach" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_foreach).
  (* autorewrite with rew_foreach in *.  *)

Tactic Notation "rew_foreach" "~" :=
  rew_foreach; auto_tilde.
Tactic Notation "rew_foreach" "*" :=
  rew_foreach; auto_star.
Tactic Notation "rew_foreach" "~" "in" constr(H) :=
  rew_foreach in H; auto_tilde.
Tactic Notation "rew_foreach" "*" "in" constr(H) :=
  rew_foreach in H; auto_star.
Tactic Notation "rew_foreach" "~" "in" "*" :=
  rew_foreach in *; auto_tilde.
Tactic Notation "rew_foreach" "*" "in" "*" :=
  rew_foreach in *; auto_star.

(* ********************************************************************** *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove equalities on unions *)

(* Documentation appears further on *)

Lemma for_set_union_assoc : forall A, assoc (union (T:=set A)).
Proof. intros. apply union_assoc. Qed.

Lemma for_set_union_comm : forall A, comm (union (T:=set A)).
Proof. intros. apply union_comm. Qed.

Lemma for_set_union_empty_l : forall A (E:set A), \{} \u E = E.
Proof. intros. apply union_empty_l. Qed.

Lemma for_set_union_empty_r : forall A (E:set A), E \u \{} = E.
Proof. intros. apply union_empty_r. Qed.

Hint Rewrite <- for_set_union_assoc : rew_permut_simpl.
Hint Rewrite for_set_union_empty_l for_set_union_empty_r : rew_permut_simpl.
Ltac rew_permut_simpl :=
  autorewrite with rew_permut_simpl; try typeclass.
Ltac rews_permut_simpl :=
  autorewrite with rew_permut_simpl in *; try typeclass.

Section PermutationTactic.
Context (A:Type).
Implicit Types l : set A.

Lemma permut_get_1 : forall l1 l2,
  (l1 \u l2) = (l1 \u l2).
Proof. intros. auto. Qed.

Lemma permut_get_2 : forall l1 l2 l3,
  (l1 \u l2 \u l3) = (l2 \u l1 \u l3).
Proof. intros. apply union_comm_assoc. Qed.

Lemma permut_get_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l4) = (l2 \u l3 \u l1 \u l4).
Proof.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_2.
Qed.

Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l5)
  = (l2 \u l3 \u l4 \u l1 \u l5).
Proof.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_3.
Qed.

Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6)
  = (l2 \u l3 \u l4 \u l5 \u l1 \u l6).
Proof.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_4.
Qed.

Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l1 \u l7).
Proof.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_5.
Qed.

Lemma permut_get_7 : forall l1 l2 l3 l4 l5 l6 l7 l8,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l1 \u l8).
Proof.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_6.
Qed.

Lemma permut_get_8 : forall l1 l2 l3 l4 l5 l6 l7 l8 l9,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l9)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l1 \u l9).
Proof.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_7.
Qed.

Lemma permut_cancel_1 : forall l1 l2,
  (l1 \u l1 \u l2) = l1 \u l2.
Proof. intros. rewrite union_assoc. rewrite union_self. auto. Qed.

Lemma permut_cancel_2 : forall l1 l2 l3,
  (l1 \u l2 \u l1 \u l3) = (l1 \u l2 \u l3).
Proof.
  intros. rewrite <- (@permut_get_2 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l1 \u l4) = (l1 \u l2 \u l3 \u l4).
Proof.
  intros. rewrite <- (@permut_get_3 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l1 \u l5)
  = (l1 \u l2 \u l3 \u l4 \u l5).
Proof.
  intros. rewrite <- (@permut_get_4 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l1 \u l6)
  = (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof.
  intros. rewrite <- (@permut_get_5 l1). apply permut_cancel_1.
Qed.

Lemma permut_tactic_setup : forall l1 l2,
   (\{} \u l1 \u \{}) = (l2 \u \{}) -> l1 = l2.
Proof. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_keep : forall l1 l2 l3 l4,
  ((l1 \u l2) \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = l4.
Proof. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_simpl : forall l1 l2 l3 l4,
  (l1 \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = (l2 \u l4).
Proof. intros. subst. apply permut_get_2. Qed.

Lemma permut_tactic_trans : forall l1 l2 l3,
  l3 = l2 -> l1 = l3 -> l1 = l2.
Proof. intros. subst~. Qed.

End PermutationTactic.

(** [permut_lemma_get n] returns the lemma [permut_get_n]
    for the given value of [n] *)

Ltac permut_lemma_get n :=
  match nat_from_number n with
  | 1%nat => constr:(permut_get_1)
  | 2%nat => constr:(permut_get_2)
  | 3%nat => constr:(permut_get_3)
  | 4%nat => constr:(permut_get_4)
  | 5%nat => constr:(permut_get_5)
  end.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 \u l2 \u .. \u \{}],
    (some of the lists [li] are put in the form [x::\{}]). *)

Ltac permut_simpl_prepare :=
   rew_permut_simpl;
   apply permut_tactic_setup;
   repeat rewrite <- union_assoc.

(* todo : doc *)

Ltac cancel_all_dup l :=
  repeat first
    [ rewrite (permut_cancel_1 l)
    | rewrite (permut_cancel_2 l)
    | rewrite (permut_cancel_3 l)
    | rewrite (permut_cancel_4 l)
    | rewrite (permut_cancel_5 l) ].

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l \u _ => constr:(1)
  | _ \u l \u _ => constr:(2)
  | _ \u _ \u l \u _ => constr:(3)
  | _ \u _ \u _ \u l \u _ => constr:(4)
  | _ \u _ \u _ \u _ \u l \u _ => constr:(5)
  | _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(6)
  | _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(7)
  | _ \u _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(8)
  | _ => constr:(0) (* not found *)
  end.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing, by cancelling syntactically
    equal elements *)

Ltac permut_simpl_once :=
  match goal with
  | |- (_ \u \{}) = _ => fail 1
  | |- (_ \u (?l \u ?lr)) = ?l' =>
     cancel_all_dup l;
     match permut_index_of l l' with
     | 0 => apply permut_tactic_keep
     | ?n => let F := permut_lemma_get n in
            eapply permut_tactic_trans;
            [ eapply F; try typeclass
            | apply permut_tactic_simpl ]
     end
  end.

Ltac permut_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once;
  rew_permut_simpl;
  try apply refl_equal.

(* TODO: move demos somewhere else *)

Section DemoSetUnion.
Variables (A:Type).

Lemma demo_set_union_permut_simpl_1 :
  forall l1 l2 l3 : set A,
  (l1 \u l2 \u l3 \u l1) = (l3 \u l2 \u l1).
Proof.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_2 :
  forall
  (x:A) l1 l2 l3,
  (l1 \u \{x} \u l3 \u l2) = (l1 \u l2 \u (\{x} \u l3)).
Proof.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_3 : forall (x y:A) l1 l1' l2 l3,
  l1 = l1' ->
  (l1 \u (\{x} \u l2) \u \{x} \u (\{y} \u l3)) = (\{y} \u (l1' \u l2) \u (\{x} \u l3)).
Proof.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  try permut_simpl_once.
  rew_permut_simpl.
Qed.

End DemoSetUnion.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove membership *)

(* TODO: doc & sort *)

Section InUnionGet.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_get_1 : forall x l1 l2,
  x \in l1 -> x \in (l1 \u l2).
Proof. intros. apply in_union_l. auto. Qed.

Lemma in_union_get_2 : forall x l1 l2 l3,
  x \in l2 -> x \in (l1 \u l2 \u l3).
Proof. intros. apply in_union_r. apply~ in_union_get_1. Qed.

Lemma in_union_get_3 : forall x l1 l2 l3 l4,
  x \in l3 -> x \in (l1 \u l2 \u l3 \u l4).
Proof. intros. apply in_union_r. apply~ in_union_get_2. Qed.

Lemma in_union_get_4 : forall x l1 l2 l3 l4 l5,
  x \in l4 -> x \in (l1 \u l2 \u l3 \u l4 \u l5).
Proof. intros. apply in_union_r. apply~ in_union_get_3. Qed.

Lemma in_union_get_5 : forall x l1 l2 l3 l4 l5 l6,
  x \in l5 -> x \in (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof. intros. apply in_union_r. apply~ in_union_get_4. Qed.

End InUnionGet.

Implicit Arguments in_union_get_1 [A x l1 l2].
Implicit Arguments in_union_get_2 [A x l1 l2 l3].
Implicit Arguments in_union_get_3 [A x l1 l2 l3 l4].
Implicit Arguments in_union_get_4 [A x l1 l2 l3 l4 l5].
Implicit Arguments in_union_get_5 [A x l1 l2 l3 l4 l5 l6].

Ltac in_union_get :=
  match goal with H: ?x \in ?A |- ?x \in ?B =>
  match B with context [A] =>
  let go tt := first
        [ apply (in_union_get_1 H)
        | apply (in_union_get_2 H)
        | apply (in_union_get_3 H)
        | apply (in_union_get_4 H)
        | apply (in_union_get_5 H) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r B);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _ \u _) => in_union_get.

Section InUnionExtract.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_extract_1 : forall x l1,
  x \in (\{x} \u l1).
Proof. intros. apply in_union_get_1. apply in_single_self. Qed.

Lemma in_union_extract_2 : forall x l1 l2,
  x \in (l1 \u \{x} \u l2).
Proof. intros. apply in_union_get_2. apply in_single_self. Qed.

Lemma in_union_extract_3 : forall x l1 l2 l3,
  x \in (l1 \u l2 \u \{x} \u l3).
Proof. intros. apply in_union_get_3. apply in_single_self. Qed.

Lemma in_union_extract_4 : forall x l1 l2 l3 l4,
  x \in (l1 \u l2 \u l3 \u \{x} \u l4).
Proof. intros. apply in_union_get_4. apply in_single_self. Qed.

Lemma in_union_extract_5 : forall x l1 l2 l3 l4 l5,
  x \in (l1 \u l2 \u l3 \u l4 \u \{x} \u l5).
Proof. intros. apply in_union_get_5. apply in_single_self. Qed.

End InUnionExtract.

Ltac in_union_extract :=
  match goal with |- ?x \in ?A =>
  match A with context [\{x}] =>
  let go tt := first
        [ apply (in_union_extract_1)
        | apply (in_union_extract_2)
        | apply (in_union_extract_3)
        | apply (in_union_extract_4)
        | apply (in_union_extract_5) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r A);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _) => in_union_extract.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to invert a membership hypothesis *)

(* TODO: doc & sort *)

Section InversionsTactic.
Context (A:Type).
Implicit Types l : set A.
Implicit Types x : A.
Lemma empty_eq_single_inv_1 : forall x l1 l2,
  l1 = l2 -> x \notin l1 -> x \in l2 -> False.
Proof. intros. subst*. Qed.
Lemma empty_eq_single_inv_2 : forall x l1 l2,
  l1 = l2 -> x \notin l2 -> x \in l1 -> False.
Proof. intros. subst*. Qed.
Lemma notin_empty : forall x,
  x \notin (\{}:set A).
Proof. intros. unfold notin. rewrite in_empty_eq. auto. Qed.
End InversionsTactic.
Hint Resolve notin_empty.

Ltac in_union_meta :=
  match goal with
  | |- _ \in \{_} => apply in_single_self
  | |- _ \in \{_} \u _ => apply in_union_l; apply in_single_self
  | |- _ \in _ \u _ => apply in_union_r; in_union_meta
  end.

Ltac fset_inv_core_for H :=
  let go L :=
     false L; [ apply H
              | try apply notin_empty
              | instantiate; try in_union_meta ] in
  match type of H with
  | \{} = _ => go empty_eq_single_inv_1
  | _ = \{} => go empty_eq_single_inv_2
  | _ = _ => go empty_eq_single_inv_1
  end.

Tactic Notation "fset_inv" constr(H) :=
  fset_inv_core_for H.

Ltac fset_inv_core :=
  match goal with
  | |- \{} <> _ => let H := fresh in intro H; fset_inv H
  | |- _ <> \{} => let H := fresh in intro H; fset_inv H
  | H: \{} = _ |- _ => fset_inv H
  | H: _ = \{} |- _ => fset_inv H
  end.

Tactic Notation "fset_inv" :=
  fset_inv_core.

Section InUnionInv.
Variables (A:Type).
Implicit Types l : set A.

Lemma set_in_empty_inv : forall x,
  x \in (\{}:set A) -> False.
Proof. introv. apply notin_empty. Qed.
Lemma set_in_single_inv : forall x y : A,
  x \in (\{y}:set A) -> x = y.
Proof. intros. rewrite @in_single_eq in H. auto. typeclass. Qed.
Lemma set_in_union_inv : forall x l1 l2,
  x \in (l1 \u l2) -> x \in l1 \/ x \in l2.
Proof. introv H. rewrite @in_union_eq in H. auto. typeclass. Qed.

End InUnionInv.

Implicit Arguments set_in_single_inv [A x y].
Implicit Arguments set_in_union_inv [A x l1 l2].

Ltac set_in_inv_base H M :=
  match type of H with
  | _ \in \{} => false; apply (@set_in_empty_inv _ _ H)
  | _ \in \{_} =>
    generalize (set_in_single_inv H); try clear H; intro_subst
  | _ \in _ \u _ =>
    let H' := fresh "TEMP" in
    destruct (set_in_union_inv H) as [H'|H'];
    try clear H; set_in_inv_base H' M
  | _ => rename H into M
  end.

Tactic Notation "set_in" constr(H) "as" ident(M) :=
  set_in_inv_base H M.
Tactic Notation "set_in" constr(H) :=
  let M := fresh "H" in set_in H as M.

(* ---------------------------------------------------------------------- *)
(** ** Tactic to prove two sets equal by double-inclusion *)

Tactic Notation "eq_set" :=
  let H := fresh "TEMP" in
  apply set_ext; iff H; set_in H; in_union_get.
Tactic Notation "eq_set" "*" :=
  eq_set; auto_star.

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

(* FUTURE
  (** Sets of sets *)

  (* todo: typeclass for bigunion and bigintersection *)

  Definition bigunion_impl A (E : set (set A)) : set A :=
    \set{ x | exists_ F \in E, x \in (F:set A) }.

  Definition biguinter_impl A (E : set (set A)) : set A :=
    \set{ x | forall_ F \in E, x \in (F:set A) }.

*)


(*************************************************************)
(*   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 Arith Lia Bool.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.PCP Require Import PCP Util.PCP_facts.

Set Default Proof Using "Type".

Set Implicit Arguments.

Section dec.

  Variable (X : Type) (eqX_dec : forall x y : X, { x = y } + { x <> y }).

  Fact is_a_head_dec (l t : list X) : { x | l = t++x } + { ~ exists x, l = t++x }.
  Proof using eqX_dec.
    revert t.
    induction l as [ | a l IHl ].
    + intros [ | t ].
      * left; exists nil; auto.
      * right; intros ([ | ] & ?); discriminate.
    + intros [ | b t ].
      * left; exists (a::l); auto.
      * destruct (eqX_dec a b) as [ -> | C ].
        - destruct (IHl t) as [ H | C ].
          ++ left; destruct H as (x & ->).
              exists x; auto.
          ++ right; contradict C; destruct C as (x & E).
             exists x; inversion E; subst; auto.
        - right; contradict C; destruct C as (? & E); inversion E; auto.
  Qed.

  Fact is_a_tail_dec (l t : list X) : { exists x, x++t = l } + { ~ exists x, x++t = l }.
  Proof using eqX_dec.
    destruct (is_a_head_dec (rev l) (rev t)) as [ H | H ].
    + left; destruct H as (x & Hx).
      exists (rev x).
      apply f_equal with (f := @rev _) in Hx.
      rewrite rev_app_distr in Hx.
      do 2 rewrite rev_involutive in Hx; auto.
    + right; contradict H.
      destruct H as (x & Hx); exists (rev x); subst.
      apply rev_app_distr.
  Qed.

End dec.

(* * The Post correspondence problem *)

Notation "R ⊳ s ∕ t" := (derivable R s t) (at level 70, format "R  ⊳  s ∕ t").

Section pcp_hand_dec.

  Variable (X : Type) (lc : list (list X * list X)).

  Notation pcp_hand := (fun s t => lc ⊳ s∕t).

  (* Any hand is either a card or of the for x++p/y++q where
      x/y is a non-void card and p/q is a hand *)

  Lemma pcp_hand_inv p q :
           lc ⊳ p∕q -> In (p,q) lc
                    \/ exists x y p' q', In (x,y) lc /\ lc ⊳ p'∕q'
                                      /\ p = x++p' /\ q = y++q'
                        /\  (x <> nil /\ y = nil
                          \/ x = nil /\ y <> nil
                          \/ x <> nil /\ y <> nil ).
  Proof.
    induction 1 as [ x y H | x y p q H1 H2 IH2 ].
    + left; auto.
    + destruct x as [ | a x ]; [ destruct y as [ | b y ] | ].
      * simpl; auto.
      * right; exists nil, (b::y), p, q; simpl; msplit 4; auto.
        right; left; split; auto; discriminate.
      * right; exists (a::x), y, p, q; simpl; msplit 4; auto.
        destruct y.
        - left; split; auto; discriminate.
        - right; right; split; discriminate.
  Qed.

  Section pcp_induction.

    Implicit Type (l m : list X).

    (* Notice that we could downgrade strict_suffix to Prop because
       a and b could be computed from the knowledge of their existence *)

    Definition strict_suffix x y l m := { a : _ & { b | (a <> nil \/ b <> nil) /\ l = a++x /\ m = b++y } }.

    Variable (P : list X -> list X -> Type)
             (IHP : forall l m, (forall l' m', strict_suffix l' m' l m -> P l' m') -> P l m).

    Theorem pcp_induction l m : P l m.
    Proof using IHP.
      induction on l m as IH with measure (length l + length m).
      apply IHP.
      intros l' m' (x & y & H & -> & ->).
      apply IH.
      do 2 rewrite app_length.
      destruct x; destruct y; simpl; try lia.
      destruct H as [ [] | [] ]; auto.
    Qed.

  End pcp_induction.

  (* ** PCP derivability is decidable *)

  Section bounded_dec.

    (* It is only possible to decide pcp_hand, when equality is decidable of course *)

    Variable eqX_dec : forall x y : X, { x = y } + { x <> y }.

    Let eqlX_dec : forall l m : list X, { l = m } + { l <> m }.
    Proof. apply list_eq_dec; auto. Qed.

    Let eqXX_dec : forall p q : list X * list X, { p = q } + { p <> q }.
    Proof. decide equality; auto. Qed.

    (* Replaced induction on length p + length q with strict suffix pair induction *)

    Theorem pcp_hand_dec p q : { lc ⊳ p∕q } + { ~ lc ⊳ p∕q }.
    Proof using eqlX_dec eqX_dec eqXX_dec.
      revert p q; apply pcp_induction; intros p q dec.

      set (P (c : list X * list X) := let (x,y) := c
           in exists d, p = x++fst d /\ q = y++snd d /\ pcp_hand (fst d) (snd d) /\ (x <> nil \/ y <> nil)).
      assert (forall c, { P c } + { ~ P c }) as Pdec.
      { intros (x,y); simpl.
        assert ( { x = nil /\ y = nil } + { x <> nil \/ y <> nil } ) as H.
        1: { destruct (eqlX_dec x nil); destruct (eqlX_dec y nil); tauto. }
        destruct H as [ (H1 & H2) | Hxy ].
        1: { right; intros ((? & ?) & ?); tauto. }
        destruct (is_a_head_dec eqX_dec p x) as [ (p' & Hp') | Hp ].
        2: { right; contradict Hp; revert Hp.
             intros ((p',?) & E & _); exists p'; auto. }
        destruct (is_a_head_dec eqX_dec q y) as [ (q' & Hq') | Hq ].
        2: { right; contradict Hq; revert Hq.
             intros ((?,q') & _ & E & _); exists q'; auto. }
        destruct (dec p' q') as [ H' | H' ].
        + exists x, y; auto.
        + left; exists (p',q'); auto.
        + right; contradict H'; revert H'.
          intros ((u,v) & -> & -> & C & _); simpl in *.
          apply app_inv_head in Hp'.
          apply app_inv_head in Hq'.
          subst; auto. }

      destruct list_dec with (1 := Pdec) (l := lc)
        as [ ((x,y) & H1 & H) | H ]; unfold P in H.
      + left.
        destruct H as ((p',q') & -> & -> & H & _); simpl in *.
        constructor 2; auto.
      + destruct In_dec with (1 := eqXX_dec) (a := (p,q)) (l := lc)
          as [ H2 | H2 ].
        * left; constructor 1; auto.
        * right; contradict H2.
          apply pcp_hand_inv in H2.
          destruct H2 as [ | (x & y & p' & q' & H2 & H3 & -> & -> & H4) ]; auto.
          destruct H with (1 := H2).
          exists (p', q'); msplit 3; tauto.
    Qed.

  End bounded_dec.

End pcp_hand_dec.

(* ** Specializations to BPCP *)

Theorem bpcp_hand_dec R (s t : list bool) : { R ⊳ s∕t } + { ~ R ⊳ s∕t }.
Proof. apply pcp_hand_dec, bool_dec. Qed.

Definition BPCP_input := list (list bool * list bool).
Definition BPCP_problem (R : BPCP_input) := exists l, R ⊳ l∕l.

From Undecidability.Synthetic Require Import Undecidability.
From Undecidability.PCP Require Import PCP_undec.

Theorem BPCP_problem_undec :
  undecidable BPCP_problem.
Proof.
  apply (undecidability_from_reducibility dPCPb_undec).
  exists (fun R => R). intros R. tauto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i 	$Id: Decidable.v 14641 2011-11-06 11:59:10Z herbelin $	 i*)

(** Properties of decidable propositions *)

Definition decidable (P:Prop) := P \/ ~ P.

Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P.
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_True : decidable True.
Proof.
unfold decidable; auto.
Qed.

Theorem dec_False : decidable False.
Proof.
unfold decidable, not; auto.
Qed.

Theorem dec_or :
 forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_and :
 forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_imp :
 forall A B:Prop, decidable A -> decidable B -> decidable (A -> B).
Proof.
unfold decidable; tauto.
Qed.

Theorem dec_iff :
 forall A B:Prop, decidable A -> decidable B -> decidable (A<->B).
Proof.
unfold decidable; tauto.
Qed.

Theorem not_not : forall P:Prop, decidable P -> ~ ~ P -> P.
Proof.
unfold decidable; tauto.
Qed.

Theorem not_or : forall A B:Prop, ~ (A \/ B) -> ~ A /\ ~ B.
Proof.
tauto.
Qed.

Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B.
Proof.
unfold decidable; tauto.
Qed.

Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B.
Proof.
unfold decidable; tauto.
Qed.

Theorem imp_simp : forall A B:Prop, decidable A -> (A -> B) -> ~ A \/ B.
Proof.
unfold decidable; tauto.
Qed.

Theorem not_iff :
  forall A B:Prop, decidable A -> decidable B ->
    ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B).
Proof.
unfold decidable; tauto.
Qed.

(** Results formulated with iff, used in FSetDecide.
    Negation are expanded since it is unclear whether setoid rewrite
    will always perform conversion. *)

(** We begin with lemmas that, when read from left to right,
    can be understood as ways to eliminate uses of [not]. *)

Theorem not_true_iff : (True -> False) <-> False.
Proof.
tauto.
Qed.

Theorem not_false_iff : (False -> False) <-> True.
Proof.
tauto.
Qed.

Theorem not_not_iff : forall A:Prop, decidable A ->
  (((A -> False) -> False) <-> A).
Proof.
unfold decidable; tauto.
Qed.

Theorem contrapositive : forall A B:Prop, decidable A ->
  (((A -> False) -> (B -> False)) <-> (B -> A)).
Proof.
unfold decidable; tauto.
Qed.

Lemma or_not_l_iff_1 : forall A B: Prop, decidable A ->
  ((A -> False) \/ B <-> (A -> B)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_l_iff_2 : forall A B: Prop, decidable B ->
  ((A -> False) \/ B <-> (A -> B)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_r_iff_1 : forall A B: Prop, decidable A ->
  (A \/ (B -> False) <-> (B -> A)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_r_iff_2 : forall A B: Prop, decidable B ->
  (A \/ (B -> False) <-> (B -> A)).
Proof.
unfold decidable. tauto.
Qed.

Lemma imp_not_l : forall A B: Prop, decidable A ->
  (((A -> False) -> B) <-> (A \/ B)).
Proof.
unfold decidable. tauto.
Qed.

(** Moving Negations Around:
    We have four lemmas that, when read from left to right,
    describe how to push negations toward the leaves of a
    proposition and, when read from right to left, describe
    how to pull negations toward the top of a proposition. *)

Theorem not_or_iff : forall A B:Prop,
  (A \/ B -> False) <-> (A -> False) /\ (B -> False).
Proof.
tauto.
Qed.

Lemma not_and_iff : forall A B:Prop,
  (A /\ B -> False) <-> (A -> B -> False).
Proof.
tauto.
Qed.

Lemma not_imp_iff : forall A B:Prop, decidable A ->
  (((A -> B) -> False) <-> A /\ (B -> False)).
Proof.
unfold decidable. tauto.
Qed.

Lemma not_imp_rev_iff : forall A B : Prop, decidable A ->
  (((A -> B) -> False) <-> (B -> False) /\ A).
Proof.
unfold decidable. tauto.
Qed.

(** With the following hint database, we can leverage [auto] to check
    decidability of propositions. *)

Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff
 : decidable_prop.

(** [solve_decidable using lib] will solve goals about the
    decidability of a proposition, assisted by an auxiliary
    database of lemmas.  The database is intended to contain
    lemmas stating the decidability of base propositions,
    (e.g., the decidability of equality on a particular
    inductive type). *)

Tactic Notation "solve_decidable" "using" ident(db) :=
  match goal with
   | |- decidable _ =>
     solve [ auto 100 with decidable_prop db ]
  end.

Tactic Notation "solve_decidable" :=
  solve_decidable using core.