Require Import Coq.NArith.NArith
  Verigen.Sha256 Verigen.Bytestring
  Verigen.Fermat
  Verigen.Functions
  Znumtheory Lia
  Zdiv Zpow_facts.

From Coq Require Import String Ascii.
Open Scope N_scope.

(* https://nvlpubs.nist.gov/nistpubs/FIPS/NIST.FIPS.186-4.pdf*)
(* Verifiable Canonical Generation of the Generator g  *)
(* Input p, q, and domain_seed *)
(* We assume that that the prime p q has been validated and
   generated by using  domain_parameter_seed *)
Module Type Prime.
  Parameters (p q k domain_parameter_seed ggen index : N).
  Axiom prime_p : prime (Z.of_N p).
  Axiom p_len : 1024 <= N.size p.
  Axiom prime_q : prime (Z.of_N q).
  Axiom q_len : 160 <= N.size q.
  Axiom k_gteq_2 : 2 <= k.
  Axiom safe_prime : p = k * q + 1.
  Axiom ggen_hyp : ggen = 0x6767656e.
  Axiom index_8bit : 0 <= index < 0xff.
End Prime.

Module Comp (P : Prime).
Section Generator.

  Let p := P.p.
  Let q := P.q.
  Let k := P.k.
  Let domain_parameter_seed := P.domain_parameter_seed.
  Let ggen : N := P.ggen.
  Let index := P.index.
  Let uh : string :=
    Bytestring.to_string
    (Bytestring.parse
      ((Sha256.big_endien_list_N domain_parameter_seed) ++
      (Sha256.big_endien_list_N ggen) ++
      (Sha256.big_endien_list_N index))).

  Definition append_values (count : N) : string :=
    uh ++
    Bytestring.to_string
      (Bytestring.parse
        (if count <? 0xff then
          ((Sha256.big_endien_list_N 0) ++
           (Sha256.big_endien_list_N count))
          else
          (Sha256.big_endien_list_N count))).

  Inductive Tag : Type :=
  | Invalid : Tag
  | Valid : N -> Tag.

  Local Fixpoint compute_gen (n : nat) (m : N) : Tag :=
    match n with
    | 0%nat => Invalid
    | S n' =>
      let U := append_values m in
      let W := sha256_string U in
      let g := Npow_mod W k p in
      if g <? 2 then compute_gen n' (m + 1) else Valid g
    end.

  Local Fixpoint compute_gen_fast (fuel : nat) (count : N) : Tag :=
    match fuel with
    | 0%nat => Invalid
    | S fuel' =>
      let U := append_values count in
      let W := N.modulo (sha256_string U) p in
      let g := Npow_mod W k p in
      if g <? 2 then compute_gen_fast fuel' (count + 1) else Valid g
    end.

  Definition compute_generator :=
    compute_gen_fast (2^16-1) 1.

  Lemma compute_gen_fast_equal : forall n m,
    compute_gen n m = compute_gen_fast n m.
  Proof.
    induction n.
    - simpl; intros ?.
      reflexivity.
    - simpl; intros ?.
      remember
        (sha256_string
         (append_values m))%N as wt.
      rewrite <-Nmod_reduce_pow.
      destruct (Npow_mod wt k p) eqn:Ht.
      simpl. apply IHn.
      destruct (N.pos p0 <? 2) eqn:Htt.
      apply IHn. reflexivity.
      apply P.prime_p.
  Qed.

  Lemma p_pos : (0 < (Z.of_N p))%Z.
  Proof.
    pose proof P.prime_p as Hp.
    pose proof P.prime_q as Hq.
    pose proof P.k_gteq_2 as Hk.
    pose proof P.safe_prime as Hs.
    lia.
  Qed.

  Lemma q_pos : (0 < (Z.of_N q))%Z.
  Proof.
    pose proof P.prime_p as Hp.
    pose proof P.prime_q as Hq.
    pose proof P.k_gteq_2 as Hk.
    pose proof P.safe_prime as Hs.
    pose proof (prime_ge_2 (Z.of_N q) Hq).
    lia.
  Qed.

  Lemma lt_1_p : (1 < (Z.of_N p))%Z.
  Proof.
    pose proof P.prime_p as Hp.
    pose proof P.prime_q as Hq.
    pose proof P.k_gteq_2 as Hk.
    pose proof P.safe_prime as Hs.
    pose proof (prime_ge_2 (Z.of_N p) Hp).
    lia.
  Qed.

   (* g^q mod p = 1 *)
  Theorem g_is_generator_of_subgroup_of_order_q : forall (t g : N), 1 < t < p ->
    (Z.of_N g = Zpow_mod (Z.of_N t) (Z.of_N k) (Z.of_N p))%Z ->
    Zpow_mod (Z.of_N g) (Z.of_N q) (Z.of_N p) = 1%Z.
  Proof.
    pose proof P.prime_p as Hp.
    pose proof P.prime_q as Hq.
    pose proof P.k_gteq_2 as Hk.
    pose proof P.safe_prime as Hs.
    intros ? ? Ht Hg.
    rewrite Zpow_mod_correct.
    rewrite Zpow_mod_correct in Hg.
    rewrite Hg.
    rewrite <- Zpower_mod.
    rewrite <- Z.pow_mul_r.
    assert (Htt : (Z.of_N k * Z.of_N q = Z.of_N p - 1)%Z) by lia.
    rewrite Htt.
    assert (Hpt: (Z.of_N p - 1 = Z.of_N (p - 1))%Z).
    lia. rewrite Hpt.
    rewrite <-Zpow_mod_correct.
    apply fermat_little_Z.
    exact Hp.
    apply Zrel_prime_neq_mod_0. lia.
    assert (Hrel: rel_prime (Z.of_N t) (Z.of_N p)).
      apply rel_prime_le_prime. auto. lia.
    assumption.
    all:lia.
  Qed.

  (* proof that it generates a correct generator *)
  (* g is the generator of order q *)
  (* g ^ q mod p = 1 *)
  Lemma correct_compute_gen : forall n m g, compute_gen_fast n m = Valid g ->
    Zpow_mod (Z.of_N g) (Z.of_N q) (Z.of_N p) = 1%Z.
  Proof.
    induction n.
    + simpl; intros. inversion H.
    + simpl; intros.
      remember ((append_values m)) as wt.
      remember (sha256_string wt) as W.
      destruct (Npow_mod (W mod p) k p <? 2) eqn:Hw.
      apply IHn with (m := m + 1). exact H.
      inversion H; clear H.
      eapply g_is_generator_of_subgroup_of_order_q with (t := Nmod W p).
      apply N.ltb_ge in Hw.
      assert (Hk : 2 <= k).
      apply P.k_gteq_2.
      assert (Hp : 2 <= p).
      unfold p.
      pose proof (prime_ge_2 (Z.of_N P.p) P.prime_p).
      lia. split.
      assert (W mod p = 0 \/ W mod p = 1 \/ 2 <= W mod p).
      remember (W mod p) as Wp. lia.
      destruct H as [H | [H | H]].
      rewrite wp_mod_zero in Hw.
      lia. apply P.prime_p.
      exact Hk. exact Hp.
      exact H.
      rewrite wp_mod_one in Hw.
      lia. apply P.prime_p.
      exact Hk. exact Hp.
      exact H. lia.
      apply N.mod_lt.
      lia.
      remember (W mod p) as wp.
      apply zmod_nmod.
      apply P.prime_p.
  Qed.

  (* generators are in range 2 <= g < p *)
  Lemma gen_generator_range : forall (n : nat) (m g : N),
    Valid g = compute_gen n m  -> 2 <= g < p.
  Proof.
    induction n.
    - simpl; intros ? ? Hg;
      inversion Hg.
    - simpl; intros ? ? Hg.
      destruct (Npow_mod (sha256_string (append_values m)) k p <? 2) eqn:Ht.
      pose proof (IHn _ _ Hg). exact H.
      inversion Hg; clear Hg.
      remember (Npow_mod (sha256_string (append_values m)) k p) as W.
      split.
      apply N.ltb_ge in Ht. exact Ht.
      rewrite <-npow_mod_exp_unary_binary_eqv in HeqW.
      pose proof Npow_mod_unary_bound (N.to_nat k)
      (sha256_string (append_values m)) p (P.prime_p).
      lia. apply P.prime_p.
  Qed.

  (* generators are in range 2 <= g < p *)
  Lemma generator_in_range_2_p : forall (g : N),
    Valid g = compute_generator  -> 2 <= g < p.
  Proof.
    intros ? Hg.
    eapply gen_generator_range.
    unfold compute_generator in Hg.
    rewrite <-compute_gen_fast_equal in Hg.
    exact Hg.
  Qed.

  Lemma correct_compute_genertor :
    forall g,  Valid g = compute_generator ->
    Zpow_mod (Z.of_N g) (Z.of_N q) (Z.of_N p) = 1%Z.
  Proof.
    intros * Hg.
    unfold compute_generator in Hg.
    rewrite <-compute_gen_fast_equal in Hg.
    eapply correct_compute_gen.
    rewrite <-compute_gen_fast_equal.
    symmetry.
    exact Hg.
  Qed.

  Local Fixpoint verify_generator_rec (n : nat) (count g : N) : bool :=
    match n with
    | 0%nat => false (* reached the end *)
    | S n' =>
      let U := append_values count in
      let W := sha256_string U in
      let y := Npow_mod W k p in
      if y <? 2 then verify_generator_rec n' (count + 1) g
      else g =? y
    end.

  (* procedure that computes the validity of a generator.
     We prove that when compute_generator returns a
     generator, verify_generator always returns true. *)
  Definition verify_generator (g : N) : bool :=
    if negb (andb (2 <=? g) (g <? p)) then false
    else if negb (Npow_mod g q p =? 1) then false
    else verify_generator_rec (2^16-1) 1 g.

  Lemma gen_generator_always_verified_forward : forall (n : nat) (m g : N),
    Valid g = compute_gen n m -> verify_generator_rec n m g = true.
  Proof.
    induction n.
    - simpl; intros ? ? Hg.
      congruence.
    - simpl; intros ? ? Hg.
      destruct (Npow_mod (sha256_string (append_values m)) k p <? 2) eqn:Ht.
      apply IHn. exact Hg.
      inversion Hg.
      apply N.eqb_refl.
  Qed.

  Lemma gen_generator_always_verified_backward : forall (n : nat) (m g : N),
    verify_generator_rec n m g = true -> Valid g = compute_gen n m.
  Proof.
    induction n.
    - simpl; intros ? ? Hg.
      congruence.
    - simpl; intros ? ? Hg.
      destruct (Npow_mod (sha256_string (append_values m)) k p <? 2) eqn:Ht.
      apply IHn.
      exact Hg.
      apply N.eqb_eq in Hg.
      rewrite Hg.
      reflexivity.
  Qed.

  Lemma gen_generator_always_verified : forall (n : nat) (m g : N),
    Valid g = compute_gen n m <-> verify_generator_rec n m g = true.
  Proof.
    intros *; split; intro H.
    eapply gen_generator_always_verified_forward; assumption.
    eapply gen_generator_always_verified_backward; assumption.
  Qed.

  (* Proof that whenever we have a generator, then verifier
    returns true for the same generator.
  *)
  Lemma generator_verifier_correctness_forward : forall g,
    Valid g = compute_generator -> verify_generator g = true.
  Proof.
    intros ? Hg.
    unfold compute_generator in Hg.
    rewrite <-compute_gen_fast_equal in Hg.
    unfold verify_generator.
    assert (Ht : 2 <= g < p).
    eapply gen_generator_range with (n := (2^16-1)%nat) (m := 1).
    exact Hg.
    assert (Hw : Npow_mod g q p = 1).
    apply N2Z.inj.
    rewrite zmod_nmod.
    eapply correct_compute_gen with (n := (2^16-1)%nat) (m := 1).
    symmetry. rewrite <-compute_gen_fast_equal.
    exact Hg. apply P.prime_p.
    destruct (negb ((2 <=? g) && (g <? p))) eqn:Hf.
    apply Bool.negb_true_iff in Hf.
    apply Bool.andb_false_iff in Hf.
    destruct Hf as [Hf | Hf].
    apply N.leb_gt in Hf. lia.
    apply N.ltb_ge in Hf. lia.
    assert (Hv : Npow_mod g q p = 1).
    apply N2Z.inj.
    rewrite zmod_nmod.
    apply correct_compute_gen with (n := (2^16-1)%nat) (m := 1).
    symmetry. rewrite <-compute_gen_fast_equal.
    exact Hg. apply P.prime_p.
    destruct (negb (Npow_mod g q p =? 1))  eqn:Hz.
    apply Bool.negb_true_iff in Hz.
    apply N.eqb_neq in Hz. lia.
    apply gen_generator_always_verified.
    exact Hg.
  Qed.

  Lemma generator_verifier_correctness_backward : forall g,
    verify_generator g = true -> Valid g = compute_generator.
  Proof.
    intros g Hg.
    unfold verify_generator in Hg.
    unfold compute_generator.
    destruct (negb ((2 <=? g) && (g <? p))) eqn:Ht.
    apply Bool.negb_true_iff in Ht.
    apply Bool.andb_false_iff in Ht.
    destruct Ht as [Ht | Ht].
    congruence. congruence.
    clear Ht.
    destruct (negb (Npow_mod g q p =? 1)) eqn:Ht.
    congruence.
    rewrite <-compute_gen_fast_equal.
    apply gen_generator_always_verified_backward.
    exact Hg.
  Qed.

  Lemma generator_verifier_correctness : forall g,
    verify_generator g = true <-> Valid g = compute_generator.
  Proof.
    intros *; split; intro H.
    apply generator_verifier_correctness_backward; assumption.
    apply generator_verifier_correctness_forward; assumption.
  Qed.

End Generator.
End Comp.


Require Export Task.driver_state.
Require Export Task.trig.
Import ListNotations.
Import FloatIO.
Import DebugIO.
Import DScopeNotations.
Import RecordSetNotations'.
Open Scope D_scope.

Definition z_terminate_sim_event := {| key := "z_terminate_sim_event"; time := 0%D |}.

Definition sq (f: float) := f * f.

Definition log_miss (sim: simTy) : simTy :=
  let vars := sim.(vars) in
  let t := svGetFloat SvT vars in
  let x := svGetFloat SvX vars in
  let xd := svGetFloat SvXD vars in
  let z := svGetFloat SvZ vars in
  let zd := svGetFloat SvZD vars in
  let dt_miss := (x * xd + z * zd) / (sq xd + sq zd) in
  let r_miss := sqrt(sq (x - xd * dt_miss) + sq (z - zd * dt_miss)) in
  let miss_vars :=
      [("t", print_float t);
       ("r_miss", print_float r_miss);
       ("dt_miss", print_float dt_miss)] in
  let miss_entry := {| le_caption := "log_miss"; le_vars := miss_vars; le_events := [] |} in
  let result_sim := sim[[log_entries ::= (fun oldlog => miss_entry :: oldlog)]] in
  result_sim.

Definition z_terminate_sim_event_func  : event_function_signature :=
  fun (this: eventTy) (sim: simTy) =>
    let vars := sim.(vars) in
    let z := svGetFloat SvZ vars in
    let result_sim :=
        if (z >=? 0%D) then
          let sim1 := log_miss sim in
          let flags2 := sim1.(flags)[[end_of_run := true]] in
          let sim2 := sim1[[flags := flags2]] in
          sim2
        else
          sim
    in
    (result_sim, None).

Definition model_handlers :=
  ("z_terminate_sim_event", z_terminate_sim_event_func) ::
  driver_default_handlers.

Definition init_sim (sim: simTy) :=
  let sim1 := log_sim "init_sim:sim" sim in
  let sim2 := sim1[[sim_events ::= (fun others => z_terminate_sim_event::others)]] in
  sim2.

Definition differential_equations (sim: simTy) : simTy :=
  let vars := sim.(vars) in
  let x := svGetFloat SvX vars in
  let z := svGetFloat SvZ vars in
  let theta := svGetFloat SvTHETA vars in
  let velocity := svGetFloat SvVELOCITY vars in
  let guidance_gain := svGetFloat SvGUIDANCE_GAIN vars in

  (* Begin math model *)
  (* Calculate velocities *)
  let xd := velocity * CoqTrig.cos(theta) in
  let zd := -velocity * CoqTrig.sin(theta) in
  (* Calculate true LOS rate *)
  let q_s := (z * xd - x * zd) / (x * x + z * z) in
  (* Calculate measured LOS rate *)
  let q_s_meas := q_s in
  (* Calculate guidance comand *)
  let theta_dot_cmd := guidance_gain * q_s_meas in
  (* Calculate airframe rate *)
  let theta_dot := theta_dot_cmd in
  union_vars
    sim
    [
      (SvXD,            xd);
        (SvZD,            zd);
        (SvTHETA_DOT,     theta_dot);
        (SvTHETA_DOT_CMD, theta_dot_cmd);
        (SvQ_S,           q_s);
        (SvQ_S_MEAS,      q_s_meas)
    ].


Require Import Syntax.ScopeSystem.
Require Import Auxiliary.Family.
Require Import Syntax.SyntacticClass.

Section Arity.
  Context `{σ : scope_system}.

  (** \cref{def:arity} *)
  Global Definition arity : Type
    := family (syntactic_class * scope_carrier σ).

  (**
  Entries in the family represent arguments of a constructor; the [σ] component
  represents the variables bound in each argument.

  For instance, the [Π-intro] rule (i.e. fully annotated λ-abstraction) would
  have arity [Family_from_List [(Ty,0), (Ty,1), (Tm,1)]]; application would
  have arity [Family_from_List [(Ty,0), (Ty,1), (Tm,0), (Tm,0)]].

  The use of [family] instead of e.g. [list] serves two purposes. Firstly, it
  abstracts the aspects of the [list] version that we really need, and so makes
  the code significantly cleaner/more robust. Secondly, it allows this
  definition to be later re-used for non-finitary syntax, although we do not
  intend to explore that for now.
   *)

  (* Access functions for arity *)
  Global Definition argument_class {a : arity} (i : a) : syntactic_class
    := fst (a i).
  Global Definition argument_scope {a : arity} (i : a) : σ := snd (a i).

  (* Given a scope, return the arity of that scope in which all the
     syntactic classes are terms. *)
  Local Definition simple (γ : σ) : arity
    := {| family_index := γ
        ; family_element i := (class_term, scope_empty _)
       |}.

End Arity.

Bind Scope family_scope with arity.

Arguments arity _ : clear implicits.


Require Import Reals.
Open Scope R_scope.

Lemma  not_exist : forall (p1 p2:R->Prop),
  (~ exists x, p1 x /\ p2 x) -> (forall x, p1 x -> ~ p2 x).
Proof.
  intros.
  unfold not; intro.
  destruct H; exists x; auto.
Qed.

Lemma total_eq_or_neq : forall r1 r2:R, r1=r2 \/ r1<>r2.
Proof.
  intros.
  generalize (total_order_T r1 r2); intros.
  destruct H. destruct s; auto.
  apply Rlt_not_eq in r; auto.
  apply Rgt_not_eq in r; auto.
Qed.

Lemma Rmult_par_inv_eq : forall r r1:R, r<>0 -> r * (r1 /r) = r*r1/r.
Proof.
  intros; unfold Rdiv.
  rewrite Rmult_assoc; auto.
Qed.

Lemma Rmult_eq_r : forall r r1:R, r<>0 -> r * r1 /r = r1.
Proof.
  intros.
  unfold Rdiv.
  rewrite Rinv_r_simpl_m; auto.
Qed.

Lemma Rmult_0_lt_reg : forall r1 r2:R, 0<r2 -> 0<r1*r2 -> 0<r1.
Proof.
  intros.
  apply Rmult_lt_reg_r with (r:=r2); auto; rewrite Rmult_0_l; auto.
Qed.

Lemma Rmult_le_r :
  forall r r1 r2 r3:R, 0 < r -> r1 * r <= r2 * r <= r3 * r -> r1 <= r2 <= r3.
Proof.
  intros.
  destruct H0.
  split; apply Rmult_le_reg_r with (r:=r); auto.
Qed.

Lemma Rinv_le_r :
  forall r r1 r2 r3:R, 0 < r -> r1 <= r2 <= r3 <-> r1/r <= r2/r <= r3/r.
Proof.
  intros; unfold Rdiv.
  split; intro.
  assert(/r>=0). { apply Rgt_ge. apply Rinv_0_lt_compat; auto. }
  - destruct H0.
    split; apply Rmult_le_compat_r; auto; apply Rge_le; auto.
  - apply Rmult_le_r with (r:=/r); auto.
    apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rminus_plus_r : forall r r1:R, r1-r+r=r1.
Proof.
  intros.
  unfold Rminus; rewrite Rplus_assoc.
  rewrite Rplus_opp_l; rewrite Rplus_0_r; auto.
Qed.

Lemma Rplus_le_3_r:
  forall r r1 r2 r3 : R, r1 <= r2 + r <= r3 <-> r1 - r <= r2 <= r3 - r.
Proof.
  intros.
  split; intros.
  - destruct H; split.
    apply Rplus_le_reg_r with (r:=r).
    rewrite Rminus_plus_r; auto.
    apply Rplus_le_reg_r with (r:=r).
    rewrite Rminus_plus_r; auto.
  - destruct H; split.
    apply Rplus_le_compat_r with (r:=r) in H.
    rewrite Rminus_plus_r in H; auto.
    apply Rplus_le_compat_r with (r:=r) in H0.
    rewrite Rminus_plus_r in H0; auto.
Qed.

Lemma Rlt_x_le :
  forall r r1 r2:R, r>0 -> 0<r1/r<=r2/r -> 0<r1<=r2.
Proof.
  unfold Rdiv; intros.
  assert(/r>0). { apply Rinv_0_lt_compat; auto. }
  destruct H0; split.
  apply Rmult_lt_reg_r with (r:= /r); auto.
  rewrite Rmult_0_l; auto.
  eapply Rmult_le_reg_r. apply H1. apply H2.
Qed.

Lemma Rmult_minus_distr_1_3:
  forall r r1 r2 r3 : R, r * (r1 - r2 - r3) = r * r1 - r * r2 -r * r3.
Proof.
  intros.
  unfold Rminus.
  repeat rewrite Ropp_mult_distr_r.
  rewrite <- Rmult_plus_distr_l with (r1:=r)(r2:=r1)(r3:=- r2).
  rewrite <- Rmult_plus_distr_l with (r1:=r)(r2:=(r1 + - r2))(r3:=- r3); auto.
Qed.

Lemma Rle_abcd : forall a b c d:R, a<=b -> c<=d -> b<=c -> a<=d.
Proof.
  intros.
  assert(a<=c). { eapply Rle_trans. apply H. auto. }
  eapply Rle_trans. apply H2. auto.
Qed.

Lemma Rinv_minus_distr_r:
  forall r1 r2 r3 : R, r3 <> 0 -> (r1 - r2)/r3 = r1/r3 - r2/r3.
Proof.
  intros.
  unfold Rdiv. unfold Rminus.
  rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Rmult_plus_distr_r. auto.
Qed.

Lemma plus_ab_minus_cd : forall a b c d e f:R, (a+b)-(c+d)-(e+f) = (a-c-e)+(b-d-f).
Proof.
 intros; ring.
Qed.

Lemma Rlt_x_le_reg :
  forall r r1 r2:R, r>0 -> 0<r1<=r2 -> 0<r1/r<=r2/r .
Proof.
  unfold Rdiv; intros.
  destruct H0; split.
  apply Rmult_lt_0_compat; auto.
  apply Rinv_0_lt_compat; auto.
  apply Rmult_le_compat_r; auto.
  apply Rlt_le; apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rminus_distr : forall r1 r2 r3:R, r1-(r2-r3) = r1-r2+r3.
Proof.
  intros; ring.
Qed.
Lemma R_distr : forall r1 r2 r3:R, r1-r2+r3=r1+r3-r2.
Proof.
  intros; ring.
Qed.

Lemma Rgt_mult : forall r r1 r2, r>0 -> r1*r>r2->r1>r2/r.
Proof.
  intros.
  apply Rmult_gt_compat_r with (r:=/r)(r1:=r1*r) in H0.
  rewrite Rinv_r_simpl_l with (r1:=r)in H0; unfold Rdiv; auto.
  apply Rgt_not_eq in H; auto.
  apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rlt_mult : forall r r1 r2, r>0 -> r1*r<r2->r1<r2/r.
Proof.
  intros.
  apply Rmult_lt_compat_r with (r:=/r)(r1:=r1*r) in H0.
  rewrite Rinv_r_simpl_l with (r1:=r)in H0; unfold Rdiv; auto.
  apply Rgt_not_eq in H; auto.
  apply Rinv_0_lt_compat; auto.
Qed.

Lemma exist_Rgt_lt : forall r1 r2,r1<r2 -> exists r, r1<r<r2.
Proof.
  intros.
  exists ((r1+r2)/2).
  split.
  - apply Rlt_mult. apply Rlt_0_2.
    rewrite Rmult_comm; rewrite double.
    apply Rplus_lt_compat_l with (r:=r1); auto.
  - apply Rgt_lt; apply Rgt_mult. apply Rlt_0_2.
    rewrite Rmult_comm; rewrite double.
    apply Rplus_gt_compat_r with (r:=r2); auto.
Qed.

Lemma Rinv_mult_rgt0 :forall r r1, r>0 -> r1*/r*r=r1.
Proof.
  intros.
  rewrite Rmult_assoc; rewrite Rinv_l.
  rewrite Rmult_1_r; auto.
  apply Rgt_not_eq in H; auto.
Qed.

Lemma Rlt_inv : forall r1 r2, r1>0 -> r2>0 -> r1</r2-> r2</r1.
Proof.
  intros.
  apply Rmult_lt_reg_r with (r:=/r2); try apply Rinv_0_lt_compat; auto.
  apply Rmult_lt_reg_l with (r:=r1); try apply Rinv_0_lt_compat; auto.
  rewrite Rinv_r; try rewrite Rmult_1_r.
  rewrite <- Rmult_assoc; rewrite Rinv_r; try rewrite Rmult_1_l; auto.
  apply Rgt_not_eq; auto.
  apply Rgt_not_eq; auto.
Qed.

Lemma Rinv_le : forall r1 r2, r1>0 -> r2>0 -> /r1<=r2-> r1>=/r2.
Proof.
  intros.
  apply Rle_ge.
  apply Rmult_le_reg_r with (r:=/r1); try apply Rinv_0_lt_compat; auto.
  apply Rmult_le_reg_l with (r:=r2); try apply Rinv_0_lt_compat; auto.
  rewrite Rinv_r; try rewrite Rmult_1_r.
  rewrite <- Rmult_assoc; rewrite Rinv_r; try rewrite Rmult_1_l; auto.
  apply Rgt_not_eq; auto.
  apply Rgt_not_eq; auto.
Qed.

Lemma Rminus_Rabs : forall a b c d r1 r2,
  a<=r1<=b -> c<=r2<=d -> Rabs(r2 - r1) <= Rabs(d - a) \/ Rabs(r2 - r1) <= Rabs(c - b).
Proof.
  intros.
  destruct H, H0.
  assert(r2-r1<=d-a).
   { unfold Rminus.
     apply Ropp_le_contravar in H.
     apply Rplus_le_compat; auto. }
  assert(c-b<=r2-r1).
    { unfold Rminus.
     apply Ropp_le_contravar in H1.
     apply Rplus_le_compat; auto. }
  generalize (total_order_T (r2-r1) 0); intro.
  destruct H5.
  - destruct s.
    + generalize Rle_lt_trans; intro.
      generalize H4; intro.
      apply H5 with (r3:=0) in H4; auto. clear H5.
      right; repeat rewrite Rabs_left; auto.
      apply Ropp_le_contravar; auto.
    + left; repeat rewrite e.
      rewrite Rabs_R0; apply Rabs_pos.
  - generalize Rge_gt_trans; intro.
    generalize r;intro.
    apply H5 with(r1:=d-a) in r.
    left; repeat rewrite Rabs_right; auto.
    apply Rgt_ge; auto.
    apply Rgt_ge; auto.
    apply Rle_ge; auto.
Qed.

Lemma Real_Order : forall r r1:R, r=r1\/r<>r1.
Proof.
  intros.
  generalize(total_order_T r r1); intro.
  destruct H. destruct s.
  right; apply Rlt_not_eq; auto.
  left; auto.
  right; apply Rgt_not_eq; auto.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import Reals.

Lemma Rsub_sym : forall x y : R, (x - y)%R = (- y + x)%R.
Proof.
intros; ring.
Qed.
Hint Resolve Rsub_sym: real.

Lemma Rmult_1_r : forall r x : R, 1%R = x -> r = (x * r)%R.
Proof.
intros; rewrite <- H; ring.
Qed.
Hint Resolve Rbase_operations.Rmult_1_r: real.

Lemma Rmult_1_r2 : forall r x : R, 1%R = x -> r = (r * x)%R.
Proof.
intros; rewrite <- H; ring.
Qed.
Hint Resolve Rmult_1_r2: real.

Lemma Rplus_plus_r1 : forall r r1 r2 : R, r1 = r2 -> (r1 + r)%R = (r2 + r)%R.
Proof.
intros; auto with real.
Qed.
Hint Resolve Rplus_plus_r1: real.

Lemma Rplus_plus_plus :
 forall r1 r2 r3 r4 : R, r1 = r3 -> r2 = r4 -> (r1 + r2)%R = (r3 + r4)%R.
Proof.
intros; rewrite H; rewrite H0; auto.
Qed.
Hint Resolve Rplus_plus_plus: real.

Lemma Rplus_Rsub_distr : forall x y z : R, (x + y - z)%R = (y + (x - z))%R.
Proof.
intros; ring.
Qed.
Hint Resolve Rplus_Rsub_distr: real.

Lemma eq_2_minus : forall r r1 : R, r = (- r1 * 2)%R -> (- r1)%R = (r + r1)%R.
Proof.
intros; rewrite H; ring.
Qed.
Hint Resolve eq_2_minus: real.

Lemma Rmult_mult_mult :
 forall r1 r2 r3 r4 : R, (r1 * r2 * (r3 * r4))%R = (r3 * r1 * (r4 * r2))%R.
Proof.
intros; ring.
Qed.
Hint Resolve Rmult_mult_mult: real.

Lemma Rmult_5 :
 forall r1 r2 r3 r4 r5 : R,
 (r1 * r2 * (r3 * r4 * r5))%R = (r1 * r3 * (r2 * r4) * r5)%R.
Proof.
intros; ring.
Qed.
Hint Resolve Rmult_5: real.

Lemma Rplus_plus_2 :
 forall r1 r2 r3 r4 : R, (r1 + r2 + r3 + r4)%R = (r1 + r3 + (r2 + r4))%R.
Proof.
intros; ring.
Qed.
Hint Resolve Rplus_plus_2: real.

Lemma Rmult_1l : forall r : R, (1 * r)%R = r.
Proof.
intro; ring.
Qed.
Hint Resolve Rmult_1l: real.

Lemma Rinv_Rmult_bis :
 forall r1 r2 r3 r4 : R,
 (0 < r1)%R ->
 (0 < r2)%R -> (r3 * r2)%R = (r1 * r4)%R -> (r3 * / r1)%R = (r4 * / r2)%R.
Proof.
intros.
apply Rmult_eq_reg_l with r1;
 [ rewrite Rmult_comm; rewrite Rmult_assoc
 | apply Rgt_not_eq; auto with real ].
replace (/ r1 * r1)%R with 1%R;
 [ rewrite RIneq.Rmult_1_r
 | apply Rinv_l_sym; apply Rgt_not_eq; auto with real ].
rewrite <- Rmult_assoc.
apply Rmult_eq_reg_l with r2;
 [ rewrite Rmult_comm; symmetry  in |- *; rewrite Rmult_comm;
    rewrite Rmult_assoc
 | apply Rgt_not_eq; auto with real ].
replace (/ r2 * r2)%R with 1%R;
 [ rewrite RIneq.Rmult_1_r
 | apply Rinv_l_sym; apply Rgt_not_eq; auto with real ].
auto.
Qed.
Hint Resolve Rinv_Rmult_bis: real.


Require Import Coq.Strings.String.
From VFA Require Import Perm.
From VFA Require Import Maps.
Import FunctionalExtensionality.
Module VerySlow.

  Fixpoint loop (input: list nat) (c: nat) (table: total_map bool) : nat :=
    match input with
    | nil => c
    | a::al => if table a
              then loop al (c+1) table
              else loop al c (t_update table a true)
    end.

  Definition collisions (input: list nat) : nat :=
    loop input 0 (t_empty false).
  Example collisions_pi: collisions [3;1;4;1;5;9;2;6] = 1.
  Proof. reflexivity. Qed.

End VerySlow.

Module Integers.

  (*
   binary expression of nat
   1 is xH
   0 + 2n is xO n
   1 + 2n is xI n
   *)
  Inductive positive: Set :=
  | xI: positive -> positive
  | xO: positive -> positive
  | xH: positive.

  Definition ten := xO (xI (xO xH)).

  Fixpoint positive2nat (p: positive): nat :=
    match p with
    | xI q => 1 + 2 * positive2nat q
    | xO q => 0 + 2 * positive2nat q
    | xH => 1
    end.

  Fixpoint print_in_binary (p: positive) : list nat :=
    match p with
    | xI q => print_in_binary q ++ [1]
    | xO q => print_in_binary q ++ [0]
    | xH => [1]
    end.

  Eval compute in positive2nat ten.

  Notation "p ~ 1" := (xI p)
                        (at level 7, left associativity, format "p '~' '1'").
  Notation "p ~ 0" := (xO p)
                        (at level 7, left associativity, format "p '~' '0'").
  Print ten. (* = xH~0~1~0 : positive *)

  Fixpoint succ x :=
    match x with
    | p ~ 1 => (succ p) ~ 0
    | p ~ 0 => p ~ 1
    | xH => xH ~ 0
    end.

  Fixpoint addc (carry: bool) (x y: positive) {struct x} : positive :=
    match carry, x, y with
    | false, p ~ 1, q ~ 1 => (addc true p q) ~ 0
    | false, p ~ 1, q ~ 0 => (addc false p q) ~ 1
    | false, p ~ 1, xH => (succ p) ~ 0
    | false, p ~ 0, q ~ 1 => (addc false p q) ~ 1
    | false, p ~ 0, q ~ 0 => (addc false p q) ~ 0
    | false, p ~ 0, xH => p ~ 1
    | false, xH, q ~ 1 => (succ q) ~ 0
    | false, xH, q ~ 0 => q ~ 1
    | false, xH, xH => xH ~ 0
    | true, p ~ 1, q ~ 1 => (addc true p q) ~ 1
    | true, p ~ 1, q ~ 0 => (addc true p q) ~ 0
    | true, p ~ 1, xH => (succ p) ~ 1
    | true, p ~ 0, q ~ 1 => (addc true p q) ~ 0
    | true, p ~ 0, q ~ 0 => (addc false p q) ~ 1
    | true, p ~ 0, xH => (succ p) ~ 0
    | true, xH, q ~ 1 => (succ q) ~ 1
    | true, xH, q ~ 0 => (succ q) ~ 0
    | true, xH, xH => xH ~ 1
    end.
  Definition add (x y: positive) : positive := addc false x y.

  Hint Unfold positive2nat.
  Hint Unfold succ.
  Lemma succ_corret: forall p,
      positive2nat (succ p) = S (positive2nat p).
  Proof.
    intros.
    induction p.
    simpl. rewrite IHp. omega.
    auto.
    auto.
  Qed.

  Hint Unfold addc.
  Lemma addc_correct: forall (c: bool) (p q: positive),
      positive2nat (addc c p q) =
      (if c then 1 else 0) + positive2nat p + positive2nat q.
  Proof with auto.
    intros.
    generalize dependent q.
    generalize dependent c.
    induction p;
      destruct c;
      destruct q; simpl;
      try rewrite IHp;
      try rewrite succ_corret; omega.
  Qed.

  Theorem add_correct : forall (p q:positive),
      positive2nat (add p q) = positive2nat p + positive2nat q.
  Proof.
    intros.
    unfold add.
    apply addc_correct.
  Qed.

  Inductive comparison : Set :=
    Eq : comparison | Lt : comparison | Gt : comparison.

  Fixpoint compare x y {struct x}:=
    match x, y with
    | p ~ 1, q ~ 1 => compare p q
    | p ~ 1, q ~ 0 => match compare p q with Lt => Lt | _ => Gt end
    | p ~ 1, xH => Gt
    | p ~ 0, q ~ 1 => match compare p q with Gt => Gt | _ => Lt end
    | p ~ 0, q ~ 0 => compare p q
    | p ~ 0, xH => Gt
    | xH, q ~ 1 => Lt
    | xH, q ~ 0 => Lt
    | xH, xH => Eq
    end.

  Lemma positive2nat_pos:
    forall p, positive2nat p > 0.
  Proof.
    intros.
    induction p; simpl; omega.
  Qed.

  Theorem compare_correct:
    forall x y,
      match compare x y with
      | Lt => positive2nat x < positive2nat y
      | Eq => positive2nat x = positive2nat y
      | Gt => positive2nat x > positive2nat y
      end.
  Proof with auto.
    induction x; destruct y; simpl;
    try (specialize (IHx y);
         destruct (compare x y); omega)...
    assert (positive2nat x > 0).
    {apply positive2nat_pos. } omega.
    assert (positive2nat x > 0).
    {apply positive2nat_pos. } omega.
    assert (positive2nat y > 0).
    {apply positive2nat_pos. } omega.
    assert (positive2nat y > 0).
    {apply positive2nat_pos. } omega.
  Qed.

Inductive Z : Set :=
  | Z0 : Z
  | Zpos : positive -> Z
  | Zneg : positive -> Z.

End Integers.

Print positive.

Module RatherSlow.
Definition total_mapz (A: Type) := Z -> A.
Definition empty {A:Type} (default: A) : total_mapz A := fun _ => default.
Definition update {A:Type} (m : total_mapz A)
                    (x : Z) (v : A) :=
  fun x' => if Z.eqb x x' then v else m x'.
Fixpoint loop (input: list Z) (c: Z) (table: total_mapz bool) : Z :=
  match input with
  | nil => c
  | a::al => if table a
                  then loop al (c+1) table
                  else loop al c (update table a true)
 end.
Definition collisions (input: list Z) := loop input 0 (empty false).
Example collisions_pi: collisions [3;1;4;1;5;9;2;6]%Z = 1%Z.
Proof. reflexivity. Qed.
End RatherSlow.

Inductive trie (A : Type) :=
    | Leaf : trie A
    | Node : trie A -> A -> trie A -> trie A.
Arguments Leaf {A}.
Arguments Node {A} _ _ _.

Definition trie_table (A: Type) : Type := (A * trie A)%type.

Definition empty {A: Type} (default: A) : trie_table A :=
      (default, Leaf).

Fixpoint look {A: Type} (default: A) (i: positive) (m: trie A): A :=
    match m with
    | Leaf => default
    | Node l x r =>
        match i with
        | xH => x
        | xO i' => look default i' l
        | xI i' => look default i' r
        end
    end.
Definition lookup {A: Type} (i: positive) (t: trie_table A) : A :=
   look (fst t) i (snd t).
Fixpoint ins {A: Type} default (i: positive) (a: A) (m: trie A): trie A :=
    match m with
    | Leaf =>
        match i with
        | xH => Node Leaf a Leaf
        | xO i' => Node (ins default i' a Leaf) default Leaf
        | xI i' => Node Leaf default (ins default i' a Leaf)
        end
    | Node l o r =>
        match i with
        | xH => Node l a r
        | xO i' => Node (ins default i' a l) o r
        | xI i' => Node l o (ins default i' a r)
        end
    end.
Definition insert {A: Type} (i: positive) (a: A) (t: trie_table A)
                 : trie_table A :=
  (fst t, ins (fst t) i a (snd t)).
Definition three_ten : trie_table bool :=
 insert 3 true (insert 10 true (empty false)).
Eval compute in three_ten.
(* = (false,
        Node (Node Leaf false (Node (Node Leaf true Leaf) false Leaf))
                 false
                 (Node Leaf true Leaf))
     : trie_table bool  *)
Eval compute in
   map (fun i => lookup i three_ten) [3;1;4;1;5]%positive.
(*      = true; false; false; false; false  : list bool *)

Module FastEnough.
Fixpoint loop (input: list positive) (c: nat) (table: trie_table bool) : nat :=
  match input with
  | nil => c
  | a::al => if lookup a table
                  then loop al (1+c) table
                  else loop al c (insert a true table)
 end.
Definition collisions (input: list positive) := loop input 0 (empty false).
Example collisions_pi: collisions [3;1;4;1;5;9;2;6]%positive = 1.
Proof. reflexivity. Qed.
End FastEnough.

Lemma look_leaf:
  forall A (a:A) j, look a j Leaf = a.
Proof.
  intros. induction j; auto. Qed.

Lemma look_ins_same: forall {A} a k (v:A) t, look a k (ins a k v t) = v.
Proof.
  intros.
  generalize dependent a.
  generalize dependent v.
  generalize dependent t.
  induction k; simpl; destruct t; auto.
Qed.

Lemma neq_pos_1 : forall j k,
    (j ~ 1 <> k ~ 1 -> j <> k)%positive.
Proof.
  intros.
  intros contra.
  subst.
  contradiction. Qed.

Lemma neq_pos_0 : forall j k,
    (j ~ 0 <> k ~ 0 -> j <> k)%positive.
Proof.
  intros.
  intros contra. subst. contradiction. Qed.

Lemma look_ins_other: forall {A} a j k (v:A) t,
    j <> k -> look a j (ins a k v t) = look a j t.
Proof with eauto.
  intros.
  generalize dependent k.
  generalize dependent t.
  induction j; intros; destruct k; destruct t; simpl;
    try apply look_leaf...
  - apply neq_pos_1 in H. rewrite IHj. apply look_leaf. auto.
  - apply neq_pos_1 in H. rewrite IHj...
  - apply neq_pos_0 in H. rewrite IHj. apply look_leaf. auto.
  - apply neq_pos_0 in H. rewrite IHj...
  - contradiction.
  - contradiction.
Qed.

Definition nat2pos (n: nat) : positive := Pos.of_succ_nat n.
Definition pos2nat (n: positive) : nat := pred (Pos.to_nat n).

Lemma pos2nat2pos: forall p, nat2pos (pos2nat p) = p.
Proof. (* You don't need to read this proof! *)
  intro. unfold nat2pos, pos2nat.
  rewrite <- (Pos2Nat.id p) at 2.
  destruct (Pos.to_nat p) eqn:?.
  pose proof (Pos2Nat.is_pos p). omega.
  rewrite <- Pos.of_nat_succ.
  reflexivity.
Qed.

Lemma nat2pos2nat: forall i, pos2nat (nat2pos i) = i.
Proof. (* You don't need to read this proof! *)
  intro. unfold nat2pos, pos2nat.
  rewrite SuccNat2Pos.id_succ.
  reflexivity.
Qed.

Lemma pos2nat_injective: forall p q, pos2nat p = pos2nat q -> p=q.
Proof.
  intros.
  rewrite <- pos2nat2pos.
  rewrite <- H.
  symmetry.
  apply pos2nat2pos. Qed.

Lemma nat2pos_injective: forall i j, nat2pos i = nat2pos j -> i=j.
Proof.
  intros.
  rewrite <- nat2pos2nat. rewrite <- H.
  symmetry. apply nat2pos2nat. Qed.

Fixpoint index_trie {A: Type} (t: trie A) (full: trie_table A) (i: positive) : Prop :=
  match t with
  | Leaf => True
  | Node l x r => (lookup i full = x) /\ (index_trie l full (i ~ 0)) /\ (index_trie r full (i ~ 1))
  end.

Inductive index_trie' {A: Type} : trie A -> trie_table A -> positive -> Prop :=
| ST_Leaf : forall tb i, index_trie' Leaf tb i
| ST_Node : forall l x r tb (i: positive),
    lookup i tb = x ->
    index_trie' l tb (i ~ 0) ->
    index_trie' r tb (i ~ 1) ->
    index_trie' (Node l x r) tb i.
(* | ST_Insert : forall tb i v, *)
(*     index_trie' (snd tb) tb xH -> *)
(*     index_trie' (snd (insert i v tb)) (insert i v tb) xH. *)

Definition is_trie {A: Type} (t: trie_table A) : Prop :=
  index_trie' (snd t) t xH.

Lemma lookup_insert_same : forall {A} i (v:A) t,
    lookup i (insert i v t) = v.
Proof.
  unfold lookup, insert.
  intros. simpl. apply look_ins_same. Qed.

(* Inductive is_trie {A: Type} : trie_table A -> Prop := *)
(* | T_Insert : forall t v i, is_trie t -> is_trie (insert i v t) *)
(* | T_Empty : forall a, is_trie (empty a). *)

Definition abstract {A: Type} (t: trie_table A) (n: nat) : A :=
  lookup (nat2pos n) t.
Definition Abs {A: Type} (t: trie_table A) (m: total_map A) :=
  abstract t = m.

Theorem empty_is_trie: forall {A} (default: A), is_trie (empty default).
Proof.
  intros.
  constructor. Qed.

Theorem insert_is_trie: forall {A} i x (t: trie_table A),
    is_trie t -> is_trie (insert i x t).
Proof.
  unfold is_trie.
  intros.
  simpl. Admitted.

Theorem empty_relate: forall {A} (default: A),
    Abs (empty default) (t_empty default).
Proof.
  unfold Abs. unfold abstract.
  intros.
  apply functional_extensionality.
  intros. unfold lookup. simpl.
  rewrite t_apply_empty. apply look_leaf.
Qed.

Theorem insert_relate: forall {A} k (v: A) t cts,
    is_trie t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts (pos2nat k) v).
Proof.
  unfold Abs, abstract, lookup, insert, t_update.
  intros.
  rewrite <- H0.
  simpl.
  apply functional_extensionality.
  intros.
  rewrite <- nat2pos2nat with x.
  remember (nat2pos x) as j.
  bdestruct (pos2nat k =? pos2nat j).
  - apply pos2nat_injective in H1.
    subst. rewrite nat2pos2nat. apply look_ins_same.
  - rewrite pos2nat2pos.  rewrite look_ins_other. auto.
    intros contra. subst. contradiction.
    Qed.

Example Abs_three_ten:
    Abs
       (insert 3 true (insert 10 true (empty false)))
       (t_update (t_update (t_empty false) (pos2nat 10) true) (pos2nat 3) true).
Proof.
try (apply insert_relate; [hnf; auto | ]).
try (apply insert_relate; [hnf; auto | ]).
try (apply empty_relate).
Admitted.

(******************************************************)
(* here is something else *)

Definition iszero (n: nat) : Prop := (n = 0).

Hint Unfold iszero.

Inductive count : (nat -> Prop) -> (list nat) -> nat -> Prop :=
| C_empty: forall f, count f [] 0
| C_Cons1: forall (f: nat -> Prop) x xs n,
    f x ->
    count f xs (n-1) ->
    count f (x :: xs) n
| C_Cons2: forall (f: nat -> Prop) x xs n,
    not (f x) ->
    count f xs n ->
    count f (x :: xs) n.

Example test1:
  count iszero [] 0.
Proof.
  econstructor. Qed.

Example text2:
  count iszero [1;0;0;2;3;0] 3.
Proof.
  apply C_Cons2. unfold iszero. omega.
  apply C_Cons1. unfold iszero. omega.
  apply C_Cons1. unfold iszero. omega.
  apply C_Cons2. unfold iszero. omega.
  apply C_Cons2. unfold iszero. omega.
  apply C_Cons1. unfold iszero. omega.
  apply C_empty. Qed.


Require Export ZArith.
Require Export List.
Require Export Arith.
Require Export Omega.
Require Export Zwf.

Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

Fixpoint mult2 (n:nat) : nat :=
  match n with
  | O => 0%nat
  | S p => S (S (mult2 p))
  end.

Parameter prime : nat->Prop.

Check (fun n:nat=>  fun p:nat => n < p /\ prime p).

Check sig_ind.

Section div_pair_section.
 Open Scope Z_scope.
 Variable div_pair :
    forall a b:Z, 0 < b ->
                       {p:Z*Z | a = (fst p)*b + snd p /\ 0 <= snd p < b}.

 Definition div_pair' (a:Z)(x:{b:Z | 0 < b}) : Z*Z :=
   match x with
   | exist b h => let (v, _) := div_pair a b h in v
   end.
End div_pair_section.

Open Scope Z_scope.
Check (
 forall a b:Z, 0 <= b -> {q:Z &{r:Z | a=q*b + r /\ 0 <= r < b}}).

Check Z_le_gt_dec.

Check Z_lt_ge_dec.

Section div2_of_even_section.
Open Scope nat_scope.

 Variable even : nat->Prop.
 Variables (div2_of_even : forall n:nat, even n -> {p:nat | n = p+p})
           (test_even : forall n:nat, {even n}+{even (pred n)} ).

 Definition div2_gen (n:nat) :
   {p:nat | n = p+p}+{p:nat | pred n = p+p} :=
   match test_even n with
   | left h => inl _ (div2_of_even n h)
   | right h' => inr _ (div2_of_even (pred n) h')
   end.
End div2_of_even_section.

Definition eq_dec (A:Type) := forall x y:A, {x = y}+{x <> y}.

Check (
 forall a b:Z,   {q:Z & {r:Z | a = q*b + r /\ 0 <= r < b}}+{b <= 0}).

Open Scope nat_scope.

Check (forall n:nat, {p:nat | n = S p}+{n = 0}).

Definition pred' (n:nat) : {p:nat | n = S p}+{n = 0} :=
  match n return {p:nat | n = S p}+{n = 0} with
  | O => inright _ (refl_equal 0)
  | S p =>
     inleft _
       (exist (fun p':nat => S p = S p') p (refl_equal (S p)))
  end.

Check ({p:nat | 0 = S p }+{0 = 0}).

Check (fun p:nat =>{p':nat | S p = S p'}+{S p = 0}).

Reset pred'.
Definition pred' : forall n:nat, {p:nat | n = S p}+{n = 0}.
 intros n; case n.
 right; apply refl_equal.
 intros p; left; exists p; reflexivity.
Defined.

Definition pred_partial : forall n:nat, n <> 0 -> nat.
 intros n; case n.
 intros h; elim h; reflexivity.
 intros p h'; exact p.
Defined.

Theorem le_2_n_not_zero : forall n:nat, 2 <= n -> n <> 0.
Proof.
 intros n Hle; elim Hle; intros; discriminate.
Qed.

Theorem le_2_n_pred :
 forall (n:nat)(h: 2 <= n), pred_partial n (le_2_n_not_zero n h) <> 0.
 (*
 intros n h; elim h.
 *)
Abort.

Theorem le_2_n_pred' :
 forall n:nat, 2 <= n -> forall h:n <> 0, pred_partial n h <> 0.
Proof.
 intros n Hle; elim Hle.
 intros; discriminate.
 simpl; intros; apply le_2_n_not_zero; assumption.
Qed.

Theorem le_2_n_pred :
 forall (n:nat)(h:2 <= n), pred_partial n (le_2_n_not_zero n h) <> 0.
Proof.
 intros n h; exact (le_2_n_pred' n h (le_2_n_not_zero n h)).
Qed.

Definition pred_partial_2 (n:nat)(h:2 <= n) : nat :=
  pred_partial (pred_partial n (le_2_n_not_zero n h))
               (le_2_n_pred n h).

Check(forall n:nat, n <> 0 -> {v:nat | n = S v}).

Check (forall n:nat, 2 <= n -> {v:nat | n = S (S v)}).

Definition pred_strong : forall n:nat, n <> 0 -> {v:nat | n = S v}.
 intros n; case n;
  [intros H; elim H | intros p H'; exists p]; trivial.
Defined.

Theorem pred_strong2_th1 :
 forall n p:nat, 2 <= n -> n = S p -> p <> 0.
Proof.
 intros; omega.
Qed.

Theorem pred_th1 : forall n p q:nat, n = S p -> p = S q -> n = S (S q).
Proof.
 intros; subst n; auto.
Qed.

Definition pred_strong2 (n:nat)(h:2<=n):{v:nat | n = S (S v)} :=
  match pred_strong n (le_2_n_not_zero n h) with
  | exist p h' =>
      match pred_strong p (pred_strong2_th1 n p h h') with
      | exist p' h'' =>
          exist (fun x:nat => n = S (S x))
                p' (pred_th1 n p p' h' h'')
      end
  end.

Definition pred_strong2' :
  forall n:nat, 2 <= n -> {v:nat | n = S (S v)}.
 intros n h; case (pred_strong n).
 apply le_2_n_not_zero; assumption.
 intros p h'; case (pred_strong p).
 apply (pred_strong2_th1 n); assumption.
 intros p' h''; exists p'.
 eapply pred_th1; eauto.
Defined.

Section minimal_specification_strengthening.

 Variable prime : nat->Prop.
 Definition divides (n p:nat) : Prop := exists q:_, q*p = n.
 Definition prime_divisor (n p:nat):= prime p /\ divides p n.

 Variable prime_test : nat->bool.
 Hypotheses
   (prime_test_t : forall n:nat, prime_test n = true -> prime n)
   (prime_test_f : forall n:nat, prime_test n = false -> ~prime n).

 Variable get_primediv_weak : forall n:nat, ~prime n -> nat.
 Hypothesis get_primediv_weak_ok :
     forall (n:nat)(H:~prime n), 1 < n ->
        prime_divisor n (get_primediv_weak n H).

 Lemma divides_refl : forall n:nat, divides n n.
  Proof.
  intro n; exists 1; simpl; auto.
 Qed.
 Hint Resolve divides_refl.

 Check (fun E:nat=>  fun n:nat => if prime_test n then n else E).

 Definition bad_get_prime : nat->nat.
  intro n; caseEq (prime_test n).
  intro; exact n.
  intro Hfalse; apply (get_primediv_weak n); auto.
 Defined.

 Print bad_get_prime.

 Theorem bad_get_primediv_ok :
  forall n:nat, 1 < n -> prime_divisor n (bad_get_prime n).
 Proof.
  intros n H; unfold bad_get_prime.
 Abort.

 Definition stronger_prime_test :
   forall n:nat, {(prime_test n)=true}+{(prime_test n)=false}.
  intro n; case (prime_test n);[left | right]; reflexivity.
 Defined.

 Definition get_prime (n:nat) : nat :=
  match stronger_prime_test n with
  | left H => n
  | right H => get_primediv_weak n (prime_test_f n H)
  end.

 Theorem get_primediv_ok :
  forall n:nat, 1 < n -> prime_divisor n (get_prime n).
 Proof.
  intros n H; unfold get_prime.
  case (stronger_prime_test n); auto.
  split; auto.
 Qed.

End minimal_specification_strengthening.

Definition pred_partial' : forall n:nat, n <> 0 -> nat.
 refine
  (fun n =>
    match n as x return x <> 0 -> nat with
    | O => fun h:0 <> 0 => _
    | S p => fun h:S p <> 0 => p
    end).
 elim h; trivial.
Defined.

Definition pred_partial_2' : forall n:nat, le 2 n -> nat.
 refine
  (fun n h=>(fun h':n<>0 => pred_partial (pred_partial n h') _) _).
 apply le_2_n_pred'; auto.
 apply le_2_n_not_zero; auto.
Defined.

Definition pred_strong2'' : forall n:nat, 2<=n -> {v:nat | n = S (S v)}.
 refine
  (fun n h =>
    match pred_strong n _ with
    | exist p h' =>
      match pred_strong p _ with exist p' h'' => exist _ p' _ end
    end).
 apply le_2_n_not_zero; assumption.
 eapply pred_strong2_th1; eauto.
 rewrite <- h''; trivial.
Qed.

Fixpoint div2 (n:nat) : nat :=
  match n with 0 => 0 | 1 => 0 | S (S p) => S (div2 p) end.

Section bad_proof_for_div2_le.

 Theorem div2_le : forall n:nat, div2 n <= n.
 Proof.
  induction n.
  simpl; auto.
  induction n.
  simpl.
  auto.
 Abort.
End bad_proof_for_div2_le.

Theorem div2_le : forall n:nat, div2 n <= n.
Proof.
 intro n.
 cut (div2 n <= n /\ div2 (S n) <= S n).
 tauto.
 elim n.
 simpl; auto.
  intros p [H1 H2].
  split; auto.
  simpl; auto with arith.
Qed.

Theorem nat_2_ind :
 forall P:nat->Prop, P 0 -> P 1 ->(forall n:nat, P n -> P (S (S n)))->
   forall n:nat, P n.
Proof.
 intros P H0 H1 Hrec n; cut (P n /\ P (S n)).
 tauto.
 elim n; intuition.
Qed.

Fixpoint div2'_aux (n:nat) : nat*nat :=
  match n with
  | 0 => (0, 0)
  | S p => let (v1,v2) := div2'_aux p in (v2, S v1)
  end.

Definition div2' (n:nat) : nat := fst (div2'_aux n).

Fixpoint plus' (n m:nat){struct m} : nat :=
  match m with O => n | S p => S (plus' n p)
  end.

Theorem plus'_O_n : forall n:nat, n=(plus' O n).
Proof.
 intros n; elim n; simpl; auto.
Qed.

Theorem plus'_Sn_m : forall n m:nat, S (plus' n m) = plus' (S n) m.
Proof.
 intros n m; elim m; simpl; auto.
Qed.

Theorem plus'_comm : forall n m:nat, plus' n m = plus' m n.
Proof.
 intros n m; elim m; simpl.
 apply plus'_O_n.
 intros p Hrec; rewrite <- plus'_Sn_m; auto.
Qed.

Theorem plus_plus' : forall n m:nat, n+m = plus' n m.
Proof.
 intros n m; rewrite plus'_comm; elim n; simpl; auto.
Qed.

Fixpoint plus'' (n m:nat){struct m} : nat :=
  match m with 0 => n | S p => plus'' (S n) p end.

Theorem plus''_Sn_m : forall n m:nat, S (plus'' n m) = plus'' (S n) m.
Proof.
 intros n m; elim m; simpl; auto.
 intros p Hrec.
 Restart.
 intros n m; generalize n; elim m; simpl.
 auto.
 intros p Hrec n0.
 trivial.
Qed.

Open Scope Z_scope.

Fixpoint div_bin (n m:positive){struct n} : Z*Z :=
 match n with
 | 1%positive => match m with 1%positive =>(1,0) | v =>(0,1) end
 | xO n' =>
   let (q',r'):=div_bin n' m in
   match Z_lt_ge_dec (2*r')(Zpos m) with
   | left Hlt => (2*q', 2*r')
   | right Hge => (2*q' + 1, 2*r' - (Zpos m))
   end
 | xI n' =>
   let (q',r'):=div_bin n' m in
   match Z_lt_ge_dec (2*r' + 1)(Zpos m) with
   | left Hlt => (2*q', 2*r' + 1)
   | right Hge => (2*q' + 1, (2*r' + 1)-(Zpos m))
   end
 end.

Theorem rem_1_1_interval : 0 <= 0 < 1.
Proof.
 omega.
Qed.

Theorem rem_1_even_interval : forall m:positive,  0 <= 1 < Zpos (xO m).
Proof.
 intros n'; split.
 auto with zarith.
 SearchPattern (1 < Zpos _).
 Locate "_ < _".
 compute.
 trivial.
Qed.

Theorem rem_1_odd_interval : forall m:positive, 0 <= 1 < Zpos (xI m).
Proof.
 split;[auto with zarith | compute; auto].
Qed.

Theorem rem_even_ge_interval :
 forall m r:Z, 0 <= r < m ->  2*r >= m -> 0 <= 2*r - m < m.
Proof.
 intros; omega.
Qed.

Theorem rem_even_lt_interval :
 forall m r:Z, 0 <= r < m -> 2*r < m -> 0 <= 2*r < m.
Proof.
 intros; omega.
Qed.

Theorem rem_odd_ge_interval :
 forall m r:Z, 0 <= r < m -> 2*r + 1 >= m -> 2*r + 1 - m <  m.
Proof.
 intros; omega.
Qed.

Theorem rem_odd_lt_interval :
 forall m r:Z, 0 <= r < m -> 2*r + 1 < m -> 0 <= 2*r + 1 < m.
Proof.
 intros; omega.
Qed.
Hint Resolve rem_odd_ge_interval rem_even_ge_interval
 rem_odd_lt_interval rem_even_lt_interval rem_1_odd_interval
 rem_1_even_interval rem_1_1_interval.

Ltac div_bin_tac arg1 arg2 :=
  elim arg1;
   [intros p; lazy beta iota delta [div_bin]; fold div_bin;
      case (div_bin p arg2); unfold snd; intros q' r' Hrec;
      case (Z_lt_ge_dec (2*r' + 1)(Zpos arg2)); intros H
   | intros p; lazy beta iota delta [div_bin]; fold div_bin;
      case (div_bin p arg2); unfold snd; intros q' r' Hrec;
      case (Z_lt_ge_dec (2*r')(Zpos arg2)); intros H
   | case arg2; lazy beta iota delta [div_bin]; intros].

Theorem div_bin_rem_lt :
 forall n m:positive, 0 <= snd (div_bin n m) < Zpos m.
Proof.
 intros n m; div_bin_tac n m; unfold snd; auto.
 omega.
Qed.

SearchRewrite (Zpos (xI _)).

SearchRewrite (Zpos (xO _)).

Theorem div_bin_eq :
 forall n m:positive,
   Zpos n =  (fst (div_bin n m))*(Zpos m) + snd (div_bin n m).
Proof.
 intros n m; div_bin_tac n m;
  rewrite Zpos_xI || (try rewrite Zpos_xO);
  try rewrite Hrec; unfold fst, snd; ring.
Qed.

Inductive div_data (n m:positive) : Set :=
  div_data_def :
  forall q r:Z, Zpos n = q*(Zpos m)+r -> 0<= r < Zpos m -> div_data n m.

Definition div_bin2 : forall n m:positive, div_data n m.
 intros n m; elim n.
 intros n' [q r H_eq H_int].
 case (Z_lt_ge_dec (2*r + 1)(Zpos m)).
 exists (2*q)(2*r + 1).
 rewrite Zpos_xI; rewrite H_eq; ring.
 auto.
 exists (2*q+1)(2*r + 1 - (Zpos m)).
 rewrite Zpos_xI; rewrite H_eq; ring.
 omega.
 intros n' [q r H_eq H_int].
 case (Z_lt_ge_dec (Zmult 2 r)(Zpos m)).
 exists (Zmult 2 q)(Zmult 2 r).
 rewrite Zpos_xO; rewrite H_eq; ring.
 auto.
 exists (Zplus (Zmult 2 q) 1)(Zminus (Zmult 2 r)(Zpos m)).
 rewrite Zpos_xO; rewrite H_eq; ring.
 auto.
 case m.
 exists 0%Z 1%Z.
 ring.
 auto.
 exists 0%Z 1%Z.
 ring.
 auto.
 exists 1%Z 0%Z.
 ring.
 auto.
Qed.

Definition div_bin3 : forall n m:positive, div_data n m.
 refine
  ((fix div_bin3 (n:positive) : forall m:positive, div_data n m :=
      fun m =>
        match n return div_data n m with
        | 1%positive =>
            match m return div_data 1 m with
            | 1%positive => div_data_def 1 1 1 0 _ _
            | xO p => div_data_def 1 (xO p) 0 1 _ _
            | xI p => div_data_def 1 (xI p) 0 1 _ _
            end
        | xO p =>
            match div_bin3 p m with
            | div_data_def q r H_eq H_int =>
                match Z_lt_ge_dec (Zmult 2 r)(Zpos m) with
                | left hlt =>
                    div_data_def (xO p) m (Zmult 2 q)
                                 (Zmult 2 r) _ _
                | right hge =>
                    div_data_def (xO p) m (Zplus (Zmult 2 q) 1)
                      (Zminus (Zmult 2 r)(Zpos m)) _ _
                end
            end
        | xI p =>
            match div_bin3 p m with
            | div_data_def q r H_eq H_int =>
                match Z_lt_ge_dec (Zplus (Zmult 2 r) 1)(Zpos m)
                with
                | left hlt =>
                    div_data_def (xI p) m (Zmult 2 q)
                      (Zplus (Zmult 2 r) 1) _ _
                | right hge =>
                    div_data_def (xI p) m (Zplus (Zmult 2 q) 1)
                      (Zminus (Zplus (Zmult 2 r) 1)(Zpos m)) _ _
                end
            end
        end));
      clear div_bin3; try rewrite Zpos_xI; try rewrite Zpos_xO;
      try rewrite H_eq; auto with zarith; try (ring; fail).
 split;[auto with zarith | compute; auto].
 split;[auto with zarith | compute; auto].
Defined.


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

Require Import Arith Omega.

Set Implicit Arguments.

Tactic Notation "eq" "goal" "with" hyp(H) :=
  match goal with |- ?b => match type of H with ?t => replace b with t; auto end end.

Theorem nat_rev_ind (P : nat -> Prop) (HP : forall n, P (S n) -> P n) x y : x <= y -> P y -> P x.
Proof. induction 1; auto. Qed.

Reserved Notation "f ↑ n" (at level 1, left associativity).

Fixpoint iter X (f : X -> X) n x :=
  match n with
    | 0 => x
    | S n => f (f↑n x)
  end
where "f ↑ n" := (@iter _ f n).

Fact iter_plus X f a b (x : X) : f↑(a+b) x = f↑a (f↑b x).
Proof. induction a; simpl; f_equal; auto. Qed.

Tactic Notation "rew" "iter" constr(f) :=
  repeat match goal with
    | |- context[f ?x]           => change (f x) with (f↑1 x)
    | |- context[f↑?a (f↑?b ?x)] => rewrite <- (iter_plus f a b)
  end.

Section Tortoise_and_Hare_tail_recursive.

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

  Infix "=?" := eqdec (at level 70).

  Variable (f : X -> X) (x0 : X)
           (Hx0 : exists τ, 0 < τ /\ f↑τ x0 = f↑(2*τ) x0).

  Inductive bar_tl i x y : Prop :=
    | in_bar_tl_0 : x = y                        -> bar_tl i x y
    | in_bar_tl_1 : bar_tl (S i) (f x) (f (f y)) -> bar_tl i x y.

  Let tortoise_hare_tail_rec :
    forall i x y, bar_tl i x y -> { k | i <= k /\ f↑(k-i) x = f↑(2*(k-i)) y }.
  Proof.
    refine (fix loop i x y H { struct H } :=
           match x =? y with
             | left E  => exist _ i _
             | right C => match loop (S i) (f x) (f (f y)) _ with
                            | exist _ k Hk => exist _ k _
                          end
           end).
    * split; f_equal; auto; omega.
    * destruct H; auto; contradict C; trivial.
    * destruct Hk; split; try omega.
      revert H1; rew iter f; intros H1.
      eq goal with H1; do 2 f_equal; omega.
  Qed.

  Let bar_tl_1_fx0_ffx0 : bar_tl 1 (f x0) (f (f x0)).
  Proof.
    destruct Hx0 as (k & H1 & H2).
    apply in_bar_tl_0 with (i := k) in H2.
    revert k H1 H2; apply nat_rev_ind.
    intros ? H; apply in_bar_tl_1.
    rew iter f; eq goal with H; do 2 f_equal; omega.
  Qed.

  Definition tortoise_hare_tail : { τ | 0 < τ /\ f↑τ x0 = f↑(2*τ) x0 }.
  Proof.
    refine (match tortoise_hare_tail_rec bar_tl_1_fx0_ffx0 with
      | exist _ k Hk => exist _ k _
    end).
    destruct Hk as (? & Hk); split; try omega.
    revert Hk; rew iter f; intros Hk.
    eq goal with Hk; do 2 f_equal; omega.
  Defined.

End Tortoise_and_Hare_tail_recursive.

Recursive Extraction tortoise_hare_tail.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Logic.Decidable.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Bool.Bool.
Require Import Lists.ListSet.
Require Import Lists.List.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Utils.

Require Export ConvBoolTac ListOrder DecTac.

Require Import Lia.

(** Graph **)

Section graph.

  Variable L : Type.
  Variables edge edge1 edge2 : L -> L -> Prop.
  Variable edge_dec : forall x y, dec (edge x y).

  Hypothesis L_dec : EqDec L eq.

  Local Notation "p --> q" := (edge p q) (at level 55, right associativity).
  Local Notation "p -->b q" := (if decision (edge p q) then true else false) (at level 55, right associativity).

  Inductive Path : L -> L -> list L -> Prop :=
  | PathSingle a : Path a a [a]
  | PathCons {a b c π} : Path a b π -> b --> c -> Path a c (c :: π).

  Local Notation "p -->* q" := (exists π, Path p q π) (at level 55).

  Definition Dom r p q := forall π, Path r q π -> p ∈ π.

  Lemma dominant_root r p : Dom r r p.
  Proof.
    intros π Hpath. induction Hpath;cbn;eauto.
  Qed.

  Lemma dominant_self p q : Dom p q q.
  Proof.
    intros π Hπ. induction Hπ;cbn;eauto.
  Qed.

  Lemma path_front p q r π
        (Hπ : Path p q (r :: π))
    : q = r.
  Proof.
    inversion Hπ;reflexivity.
  Qed.

  Ltac isabsurd :=
    match goal with
    | H : Path _ _ [] |- _ => inversion H
    | _ => try congruence'
    end.

  Lemma path_back p q r π
        (Hπ : Path p q (π ++ [r]))
    : p = r.
  Proof.
    revert dependent q.
    induction π;intros q Hπ;inversion Hπ;subst;cbn in *;eauto;try isabsurd.
  Qed.

  Ltac path_simpl' H :=
    let Q := fresh "Q" in
    lazymatch type of H with
    | Path ?x ?y (?z :: ?π) => replace z with y in *;
                                [|eapply path_front;eauto];
                                match type of H with
                                | Path _ _ (?w :: [])
                                  => fold ([] ++ [w]) in H;
                                    path_simpl' H;
                                    unfold app in H
                                | Path ?x ?y (?w :: ?z :: [])
                                  => fold ([w] ++ [z]) in H;
                                    path_simpl' H;
                                    unfold app in H
                                | _ => idtac
                                end
    | Path ?x ?y (?π ++ [?z]) => replace z with x in *;
                                   [|eapply path_back;eauto]
    end.

  Lemma path_dec p q π :
    {Path p q π} + {~ Path p q π}.
  Proof.
    revert q; induction π; intros q.
    - right. intro N. inversion N.
    - destruct π.
      + decide' (p == a).
        * decide' (p == q);[left;econstructor|].
          right. intro N. eapply c. inversion N;reflexivity.
        * right. intro N. eapply c. inversion N;subst. reflexivity. isabsurd.
      + decide' (q == a).
        * specialize (IHπ l). destruct IHπ.
          -- decide (l --> q).
             ++ left. econstructor;eauto.
             ++ right. intro N. inversion N. subst. path_simpl' H0. congruence.
          -- right. contradict n. inversion n;subst;eauto. path_simpl' H0. eauto.
        * right. intro N. inversion N;subst. congruence.
  Qed.

  Inductive ne_l : list L -> Prop :=
  | neCons a l : ne_l (a :: l).

  Lemma path_non_empty p q π
        (Hπ : Path p q π)
    : ne_l π.
  Proof.
    inversion Hπ;subst;econstructor.
  Qed.

  Lemma path_app π ϕ p q q' r : Path p q π -> q --> q' -> Path q' r ϕ -> Path p r (ϕ ++ π).
  Proof.
    intros Hπ Hedge Hϕ.
    induction Hϕ;cbn;econstructor;eauto.
  Qed.

  Lemma path_app' π ϕ p q r : Path p q π -> Path q r ϕ -> Path p r (ϕ ++ tl π).
  Proof.
    intros Hpath1 Hpath2.
    destruct π;cbn;inversion Hpath1;subst;eauto.
    - rewrite app_nil_r. eauto.
    - eapply path_app;eauto.
  Qed.

  (* this is not used : { *)
  Inductive uniqueIn {A : Type} (a : A) : list A -> Prop :=
  | UniqueIn (l : list A) : a ∉ l -> uniqueIn a (a :: l)
  | UniqueCons (b : A) (l : list A) : uniqueIn a l -> a <> b -> uniqueIn a (b :: l).

  Lemma uniqueIn_app {A : Type} `{EqDec A eq} (a : A) l1 l2
    : uniqueIn a l1 -> a ∉ l2 -> uniqueIn a (l1 ++ l2).
  Proof.
    intros Huq Hin.
    induction l1; cbn; eauto.
    - inversion Huq.
    - decide' (a == a0).
      + econstructor; eauto. inversion Huq; eauto. intro N. eapply in_app_or in N. firstorder.
      + econstructor 2; eauto. eapply IHl1. inversion Huq; [contradiction|eauto].
  Qed.

  Lemma path_glue_loop p r (π0 π1 : list L) :
    Path p r π0
    -> uniqueIn r π0 -> uniqueIn r π1
    -> uniqueIn r (π1 ++ tl π0).
  Proof.
    intros Hpr Huq0 Huq1.
    eapply uniqueIn_app; eauto.
    induction π0; cbn; eauto.
    clear - Huq0 Hpr. eapply path_front in Hpr. cbn in *. subst a. intro N.
    inversion Huq0; eauto.
  Qed.

  Lemma uniqueIn_NoDup {A : Type} `{EqDec A eq} (l : list A)
    : NoDup l <-> forall a, a ∈ l -> uniqueIn a l.
  Proof.
    rename H into Hed.
    split; [intros Hnd a Hin|intros H].
    - induction l; inversion Hin; inversion Hnd; cbn; subst.
      + econstructor; eauto.
      + exploit IHl. econstructor;eauto. intro N. subst. contradiction.
    - induction l; econstructor.
      + specialize (H a (or_introl (eq_refl))). inversion H; eauto.
      + eapply IHl. intros b Hb.
        specialize (H b (or_intror Hb)).
        decide' (a == b); inversion H; eauto; subst; contradiction.
  Qed.
  (* } *)

(*  Lemma prefix_single {A : Type} (a : A) (l : list A)
    : Prefix [a] l -> hd_error (rev l) = Some a.
  Proof.
    intro H. induction l; inversion H; cbn; eauto; subst. inversion H2.
    destruct l; cbn in *; congruence.
  Qed.*)

  Ltac turn_cons a l :=
    let Q := fresh "Q" in
    let a' := fresh a in
    let l' := fresh l in
    rename l into l';
    rename a into a';
    specialize (cons_rcons a' l') as Q;
    destruct Q as [a [l Q]];
    rewrite Q in *.

  Lemma prefix_rcons_eq: forall (A : Type) (a b : A) (l l' : list A), Prefix (l ++ [a]) (l' ++ [b]) -> a = b.
  Proof.
    intros. eapply postfix_hd_eq. eapply prefix_rev_postfix'. cbn.
    do 2 rewrite rev_involutive. eauto.
  Qed.

  Lemma path_prefix_path p q r (π ϕ : list L)
    : Path p q π -> Prefix (r :: ϕ) π -> Path p r (r :: ϕ).
  Proof.
    intros Hpq Hpre.
    turn_cons r ϕ.
    replace r with p in *;cycle 1.
    { destr_r' π;subst π. 1: inversion Hpq.
      path_simpl' Hpq. symmetry. eapply prefix_rcons_eq. eauto.
    }
    enough (exists r, Path p r (ϕ :r: p)).
    { destructH. rewrite <-Q in *. path_simpl' H. auto. }
    clear Q.
    revert dependent q.
    dependent induction Hpre;intros.
    - path_simpl' Hpq. eauto.
    - inversion Hpq;subst. 1: inversion Hpre; congruence'.
      destr_r' l';subst l'. 1: inversion H3. path_simpl' H3.
      eapply IHHpre;eauto.
  Qed.

  Lemma path_app_inv p q t1 t2
        (Hpath : Path p q (t2 ++ t1))
        (Hnemp1 : t1 <> [])
        (Hnemp2 : t2 <> [])
    : exists b1 b2, Path p b1 t1 /\ Path b2 q t2.
  Proof.
    revert dependent q.
    induction t2; intros.
    - contradiction.
    - clear Hnemp2.
      destruct t2 as [| b2 t2 ].
      + clear IHt2. destruct t1 as [| b1 t1 ]; [ contradiction |]. clear Hnemp1.
        exists b1, a. split.
        eapply path_prefix_path; try eassumption.
        * rewrite prefix_eq. exists [a]. reflexivity.
        * eapply path_front in Hpath. subst. econstructor.
      + inv Hpath.
        destruct (IHt2) with (q := b2) as [a1 [a2 [Hp1 Hp2]]]; try eassumption.
        * intro. inv H.
        * eapply path_front in H3 as Heq. subst b. eassumption.
        * exists a1, a2. split. eassumption. econstructor. eapply Hp2.
          eapply path_front in H3. subst b. eassumption.
  Qed.

  Lemma path_front'
    : forall p q r π,
      Path p q π -> q = hd r π.
  Proof.
    intros.
    destruct π.
    - inversion H.
    - cbn. eapply path_front;eauto.
  Qed.

  Lemma path_back'
    : forall p q r π,
      Path p q π -> p = hd r (rev π).
  Proof.
    intros.
    destr_r' π;subst.
    - cbn in *. inversion H.
    - rewrite rev_rcons. cbn. eapply path_back;eauto.
  Qed.

  Lemma prefix_singleton p q π h
        (Hπ : Path p q π)
        (Hpre : Prefix [h] π)
    : p = h.
  Proof.
    induction Hπ.
    - inv Hpre.
      + reflexivity.
      + inv H1.
    - inv Hpre.
      + inv Hπ.
      + eauto.
  Qed.

  Lemma prefix_edge_exists a b p q π ϕ
        (Hπ : Path p q π)
        (Hpre : Prefix (a :: b :: ϕ) π)
    : b --> a.
  Proof.
    induction Hπ.
    - inv Hpre. inv H1.
    - inversion Hpre; [| eauto ].
      subst. inv Hπ; eauto.
  Qed.

  Lemma path_rcons p q r π
        (Hπ : Path p q π)
        (Hedge : r --> p)
    : Path r q (π ++ [r]).
  Proof.
    eapply path_app;eauto. econstructor.
  Qed.

  Lemma path_rcons_inv q r π
        (Hπ : Path r q (q :: π :r: r))
    : exists p, Path p q (q :: π).
  Proof.
    revert dependent q. induction π; intros q Hπ.
    - eexists. econstructor.
    - cbn in *. inversion Hπ. subst. path_simpl' H0. eapply IHπ in H0. destructH.
      eexists. econstructor;eauto.
  Qed.

  Lemma path_rcons_inv' q r π
        (Hπ : Path r q (q :: π :r: r))
    : exists p : L, Path p q (q :: π) /\ edge r p.
  Proof.
    revert dependent q. induction π; intros q Hπ.
    - eexists. split;[econstructor|].
      cbn in Hπ. inversion Hπ;subst. path_simpl' H0. auto.
    - cbn in *. inversion Hπ. subst. path_simpl' H0. eapply IHπ in H0. destructH.
      eexists. split;[econstructor|];eauto.
  Qed.

  Lemma path_to_cons_path p q π
        (Hpath : Path p q π)
    : exists ϕ, π = q :: ϕ.
  Proof.
    inv Hpath;cbn;eexists;eauto.
  Qed.

  Ltac turn_rcons l a :=
    let Q := fresh "Q" in
    let a' := fresh a in
    let l' := fresh l in
    rename l into l';
    rename a into a';
    specialize (rcons_cons a' l') as Q;
    destruct Q as [a [l Q]];
    rewrite Q in *.

  Lemma path_postfix_path p q r (π ϕ : list L)
    : Path p q π -> Postfix (ϕ ++ [r]) π -> Path r q (ϕ ++ [r]).
  Proof.
    intros Hπ Hpost.
    turn_rcons ϕ r.
    replace r with q in *;cycle 1.
    { destruct π. 1: inversion Hπ.
      path_simpl' Hπ. symmetry. eapply postfix_hd_eq;eauto.
    }
    enough (exists r, Path r q (q :: ϕ)).
    { destructH. rewrite <-Q in *.  path_simpl' H. auto. }
    clear Q.
    dependent induction Hpost generalizing p Hπ;intros;subst.
    - eauto.
    - inversion Hπ;subst.
      + rewrite cons_rcons' in H2. eapply rcons_inj in H2. cbn in H2. destruct H2. subst l' q.
        inversion Hpost. congruence'.
      + destruct l';cbn in *.
        * inversion Hpost. congruence'.
        * path_simpl' Hπ. rewrite <-cons_rcons_assoc in Hπ. path_simpl' Hπ.
          rewrite cons_rcons_assoc in Hπ. eapply path_rcons_inv in Hπ. destructH.
          eapply IHHpost;eauto.
  Qed.

  Lemma path_NoDup' p q ϕ : Path p q ϕ -> exists π, Path p q π /\ NoDup π.
  Proof.
    intros Hto.
    induction Hto.
    - exists ([a]). split;econstructor;eauto. econstructor.
    - destruct IHHto as [ψ [IHHto IHnodup]].
      destruct (@In_dec _ _ _ c ψ).
      + eapply prefix_nincl_prefix in H0.
        exists (c :: prefix_nincl c ψ). split.
        * eapply path_prefix_path in H0; eauto; cbn in *; eauto.
        * eapply prefix_NoDup; eauto.
      + exists (c :: ψ). split;econstructor;eauto.
  Qed.

  Lemma path_NoDup p q : p -->* q -> exists π, Path p q π /\ NoDup π.
  Proof.
    intros [ϕ Hto]. eapply path_NoDup';eauto.
  Qed.

  Lemma path_to_elem p q r π : Path p q π -> r ∈ π -> exists ϕ, Path p r ϕ /\ Prefix ϕ π.
  Proof.
    revert dependent q.
    induction π; intros q Hpath Hin; cbn in *; eauto.
    - contradiction.
    - path_simpl' Hpath. destruct Hin.
      + subst q. inversion Hpath.
        * eapply path_front in Hpath as Hfront. subst.
          eexists. split;econstructor.
        * subst; cbn in *. exists (r :: π); split; eauto.
          econstructor.
      + inversion Hpath; subst. 1: contradiction.
        eapply IHπ in H1;eauto. destructH. eexists.
        split;eauto.
        econstructor. eauto.
  Qed.

  Lemma path_from_elem' p q r π : Path p q π -> r ∈ π ->
                                  let ϕ := postfix_nincl r π ++ [r] in
                                  Path r q ϕ /\ Postfix ϕ π.
  Proof.
    intros Hpath Hin.
    assert (Postfix (postfix_nincl r π ++ [r]) π) as H;[|split];eauto.
    - eapply postfix_nincl_spec; eauto.
    - eapply path_postfix_path in Hpath;eauto.
  Qed.

  Lemma path_from_elem p q r π : Path p q π -> r ∈ π -> exists ϕ, Path r q ϕ /\ Postfix ϕ π.
  Proof.
    intros. eexists;eapply path_from_elem';eauto.
  Qed.

  Lemma path_from_elem_to_elem (p q r1 r2 : L) (π : list L)
        (Hπ : Path p q π)
        (Hprec : r2 ≻* r1 | π)
    : exists ϕ : list L, Path r1 r2 ϕ.
  Proof.
    eapply succ_rt_prefix in Hprec.
    destructH' Hprec.
    eapply path_prefix_path in Hprec0 as Hprec2. 2:eauto.
    eapply path_from_elem in Hprec2;eauto.
    destructH. eauto.
  Qed.

  Lemma path_front_eq p p' q q' π
    : Path p q π -> Path p' q' π -> q = q'.
  Proof.
    intros Hpq Hpq'.
    destruct Hpq;inversion Hpq';subst;auto.
  Qed.

  Lemma path_back_eq p p' q q' π
    : Path p q π -> Path p' q' π -> p = p'.
  Proof.
    intros Hpq Hpq'. revert dependent q'.
    induction Hpq;intros;inversion Hpq';subst;auto.
    - inversion H3.
    - inversion Hpq.
    - eauto.
  Qed.

  Lemma dom_nin r p q π : Dom r p q -> Path r p π -> NoDup π -> q ∈ π -> p = q.
  Proof.
    intros Hdom Hpath Hnd Hin. eapply path_to_elem in Hpath as Hpath';eauto.
    destruct Hpath' as [ϕ [Hϕ Hpre]].
    inversion Hpre; subst.
    - subst. eapply path_front_eq in Hpath;eauto.
    - path_simpl' Hpath.
      destruct Hin;[auto|exfalso].
      eapply Hdom in Hϕ as Hϕ'. eapply prefix_incl in Hϕ';eauto.
      inversion Hnd;subst. contradiction.
  Qed.

(*  Lemma in_ne_back {A : Type} `{EqDec A eq} (l : list A) : hd  ∈ l.
  Proof.
    induction l; cbn; eauto.
  Qed.*)

  Lemma path_contains_front (x y : L) l
        (Hpath : Path x y l)
    : y ∈ l.
  Proof.
    induction Hpath; cbn; eauto.
  Qed.

  Lemma path_contains_back (x y : L) l
        (Hpath : Path x y l)
    : x ∈ l.
  Proof.
    induction Hpath; cbn; eauto.
  Qed.

  Lemma dom_trans r h p q : r -->* h -> Dom r h p -> Dom r p q -> Dom h p q.
  Proof.
    intros Hϕ Hdom_h Hdom_p π Hπ.
    eapply path_NoDup in Hϕ as [ϕ [Hϕ Hndup]].
    eapply path_app' in Hπ as Hπ';eauto. eapply Hdom_p in Hπ'.
    eapply in_app_or in Hπ'.
    destruct Hπ'; eauto.
    enough (h = p).
    - subst h. eapply path_contains_back. eauto.
    - eapply dom_nin. 3: eassumption. 1: apply Hdom_h. 1: eauto.
      destruct ϕ; cbn in H; [contradiction|]. right; eauto.
  Qed.

  Definition intersection_edge := fun p q => edge1 p q /\ edge2 p q.

  Definition union_edge := fun p q => edge1 p q \/ edge2 p q.

  Definition minus_edge := fun p q => edge1 p q /\ ~ (edge2 p q).

  Definition sub_graph := forall p q, edge1 p q -> edge2 p q.

  Definition acyclic := forall p q π, p --> q -> Path q p π -> False.

  Lemma path_path_acyclic p q π ϕ : Path p q π -> Path q p ϕ -> p <> q -> ~ acyclic.
  Proof.
    intros Hpath1 Hpath2 Hneq Hacy.
    inversion Hpath1;[contradiction|].
    inversion Hpath2;subst;[contradiction|].
    specialize (Hacy b q (π0 ++ π1) H0). eapply Hacy.
    eapply path_app;eauto.
  Qed.

  Lemma path_path_acyclic' p q π ϕ : Path p q π -> Path q p ϕ -> acyclic -> p = q.
  Proof.
    intros Hpath1 Hpath2 Hacy.
    destruct (L_dec p q);[auto|]. eapply path_path_acyclic in c;eauto. contradiction.
  Qed.

  Lemma acyclic_NoDup p q π
        (Hpath : Path p q π)
        (Hacy : acyclic)
    : NoDup π.
  Proof.
    induction Hpath.
    - econstructor;eauto. econstructor.
    - econstructor;eauto. intro N. eapply path_from_elem in N; eauto. destructH. eapply Hacy;eauto.
  Qed.

  Lemma postfix_path l p q q' l' : (* FIXME: duplicate *)
    Path q' q l'
    -> Postfix (l ++ [p]) l'
    -> Path p q (l ++ [p]).
  Proof.
    intros Hpath Hpost.
    eapply path_postfix_path in Hpost;eauto.
  Qed.

  Lemma succ_in_path_edge π (x y w z : L)
        (Hpath : Path x y π)
        (Hsucc : succ_in π w z)
    : edge z w.
  Proof.
    induction Hpath; unfold succ_in in Hsucc;destructH.
    - repeat destruct l1,l2; cbn in Hsucc; try congruence.
      destruct l2;cbn in Hsucc; congruence.
    - destruct l2.
      + cbn in Hsucc. inversion Hsucc;subst. inversion Hpath;subst;auto.
      + eapply IHHpath. exists l1, l2. inversion Hsucc; subst; eauto.
  Qed.

  Lemma edge_path_hd_edge x y z π
        (Hedge : z --> x)
        (Hpath : Path x y (y :: π))
    : (hd z π) --> y.
  Proof.
    clear edge1 edge2.
    revert y Hpath.
    induction π;intros.
    - cbn. path_simpl' Hpath. auto.
    - cbn. inv Hpath. path_simpl' H0. auto.
  Qed.

  Lemma path_single (a b c : L)
        (Hpath : Path a b [c])
    : a = b /\ b = c.
  Proof.
    inversion Hpath.
    - subst; eauto.
    - inversion H3.
  Qed.

End graph.

Arguments Path {L}.
Arguments Dom {L}.
Arguments intersection_edge {L}.
Infix "∩" := intersection_edge (at level 50).
Arguments union_edge {L}.
Infix "∪" := union_edge (at level 51).
Arguments minus_edge {L}.
Infix "∖" := minus_edge (at level 49).
Arguments sub_graph {L}.
Arguments acyclic {L}.

Lemma subgraph_refl {L : Type} [edge1 : L -> L -> Prop]
  : sub_graph edge1 edge1.
Proof.
  unfold sub_graph. intros. tauto.
Qed.

Lemma subgraph_path {L : Type} (edge1 edge2 : L -> L -> Prop) p q :
  sub_graph edge1 edge2 -> (exists π, Path edge1 p q π) -> (exists ϕ, Path edge2 p q ϕ).
Proof.
  intros Hsub [π Hpath]. unfold sub_graph in Hsub. induction Hpath.
  - exists ([a]). econstructor.
  - destruct IHHpath as [ϕ IHHpath]. exists (c :: ϕ). econstructor; eauto.
Qed.

Lemma subgraph_path' {L : Type} (edge1 edge2 : L -> L -> Prop) p q π :
  sub_graph edge1 edge2 -> Path edge1 p q π -> Path edge2 p q π.
Proof.
  intros Hsub Hpath. unfold sub_graph in Hsub. induction Hpath.
  - econstructor.
  - econstructor; eauto.
Qed.

Lemma acyclic_subgraph_acyclic {L : Type} (edge1 edge2 : L -> L -> Prop) :
  sub_graph edge1 edge2 -> acyclic edge2 -> acyclic edge1.
Proof.
  intros Hsub Hacy p q Hedge N. unfold acyclic, sub_graph in *.
  intro Hp. eapply Hacy; eauto.
  eapply subgraph_path' in Hp; eauto.
Qed.

Lemma union_subgraph1 (L : Type) (f g : L -> L -> Prop)
  : sub_graph f (f ∪ g).
Proof.
  unfold sub_graph, union_edge. intros. auto.
Qed.

Lemma minus_subgraph {L : Type} (edge1 edge2 : L -> L -> Prop) :
  sub_graph (edge1 ∖ edge2) edge1.
Proof.
  intros p q Hsub. unfold minus_edge in Hsub. conv_bool. firstorder.
Qed.

Lemma intersection_subgraph1 {L : Type} (edge1 edge2 : L -> L -> Prop) :
  sub_graph (edge1 ∩ edge2) edge1.
Proof.
  intros p q Hinter. unfold intersection_edge in Hinter. conv_bool. firstorder.
Qed.

Lemma intersection_subgraph2 {L : Type} (edge1 edge2 : L -> L -> Prop) :
  sub_graph (edge1 ∩ edge2) edge2.
Proof.
  intros p q Hinter. unfold intersection_edge in Hinter. conv_bool. firstorder.
Qed.

Lemma intersection2_subgraph {L : Type} (edge edge1 edge2 : L -> L -> Prop) :
  sub_graph edge1 edge2
  -> sub_graph (edge1 ∩ edge) (edge2 ∩ edge).
Proof.
  intros Hsub p q Hinter. unfold intersection_edge in *. unfold sub_graph in Hsub.
  conv_bool. destruct Hinter as [Hinter1 Hinter2]. auto.
Qed.

Lemma union_subgraph {L : Type} (edge1 edge1' edge2 edge2' : L -> L -> Prop) :
  sub_graph edge1 edge1' -> sub_graph edge2 edge2' -> sub_graph (edge1 ∪ edge2) (edge1' ∪ edge2').
Proof.
  intros Hsub1 Hsub2 p q Hu. unfold union_edge, sub_graph in *.
  conv_bool. destruct Hu as [Hu|Hu];firstorder 1.
Qed.

Lemma dom_intersection {L : Type} (edge1 edge2 : L -> L -> Prop) r p q :
  Dom edge1 r p q -> Dom (edge1 ∩ edge2) r p q.
Proof.
  intros Hdom.
  unfold Dom in *. intros. apply Hdom.
  eapply subgraph_path';eauto.
  eapply intersection_subgraph1.
Qed.

Lemma path_nlrcons (L : Type) (x y z : L) (l : list L) e
      (Hpath : Path e x y (l ++ [z]))
  : z = x.
Proof.
  revert dependent y.
  induction l;intros;cbn in *;inversion Hpath;subst;auto.
  - inversion H3.
  - congruence'.
  - eapply IHl;eauto.
Qed.

Ltac path_simpl' H :=
  let Q := fresh "Q" in
  lazymatch type of H with
  | Path ?e ?x ?y (?z :: ?π) => replace z with y in *;
                              [|eapply path_front;eauto];
                              match type of H with
                              | Path _ _ _ (?w :: [])
                                => fold ([] ++ [w]) in H;
                                  path_simpl' H;
                                  unfold app in H
                              | Path ?e ?x ?y (?w :: ?z :: [])
                                => fold ([w] ++ [z]) in H;
                                  path_simpl' H;
                                  unfold app in H
                              | _ => idtac
                              end
  | Path ?e ?x ?y (?π ++ [?z]) => replace z with x in *;
                                 [|eapply path_back;eauto]
  end.

Lemma path_rcons_rinv
  : forall (L : Type) (edge : L -> L -> Prop) (p q r : L) (π : list L),
    Path edge r p ((π :r: q) :r: r) -> Path edge q p (π :r: q).
Proof.
  clear.
  intros. revert dependent p. induction π;cbn in *;intros.
  - path_simpl' H. econstructor.
  - path_simpl' H. inversion H;[congruence'|subst].
    econstructor;eauto.
Qed.

Lemma path_nlrcons_edge {A : Type} (a b c : A) l f
      (Hpath : Path f b c (l :r: a :r: b))
  : f b a.
Proof.
  revert dependent c.
  induction l; intros; inversion Hpath; subst; cbn in *.
  - inversion H3. subst b0 b;auto. inversion H5.
  - congruence'.
  - eauto.
Qed.

Ltac path_simpl2' H :=
  let Q:= fresh "Q" in
  lazymatch type of H with
  | Path ?e ?x ?y (?z :: ?π) =>
    replace y with z in *; [ | symmetry;eapply path_front;eauto ];
                              match type of H with
                              | Path _ _ _ (?w :: [])
                                => fold ([] ++ [w]) in H;
                                  path_simpl' H;
                                  unfold app in H
                              | Path _ _ _ (?w :: ?z :: [])
                                => fold ([w] ++ [z]) in H;
                                  path_simpl' H;
                                  unfold app in H
                              | _ => idtac
                              end
  | Path ?e ?x ?y (?π ++ [?z]) => replace x with z in *; [ | symmetry;eapply path_back; eauto ]
  end.

Ltac inv_path H :=
  try path_simpl' H;
  let x := fresh "x" in
  inversion H as [ | ? x ]; subst;
  match goal with
  | Q : Path _ _ x _ |- _ => path_simpl2' Q
  | Q : Path _ _ _ [] |- _ => inversion Q
  | |- _ => idtac
  end.

Lemma acyclic_path_path (L : Type) (e : L -> L -> Prop)
  : (forall p q π ϕ, p <> q -> Path e p q π -> ~ Path e q p ϕ) -> (forall p q, e p q -> q <> p) -> acyclic e.
Proof.
  intros. intros p q π Hedge Hpath. revert p q Hedge Hpath.
  induction π;intros;inv_path Hpath.
  - eapply H0;eauto.
  - eapply H.
    + eapply H0. eapply Hedge.
    + eapply Hpath.
    + instantiate (1:=[q;p]).
      econstructor;eauto.
      econstructor.
Qed.

Lemma rotate_forward' (L : Type) (e : L -> L -> Prop) (p q : L) π
      (Hedge : e q p)
      (Hpath : Path e p q π)
  : let π' := p :: r_tl π in
    let q' := hd p (rev π') in
    e p q' /\ Path e q' p π'.
Proof.
  intros. subst q' π'. cbn.
  destr_r' π;subst;cbn.
  1: inv Hpath.
  rewrite r_tl_rcons.
  rewrite hd_rcons'. path_simpl' Hpath.
  destr_r' l;subst;cbn in *.
  + path_simpl' Hpath. split; assumption.
  + rewrite rev_rcons. cbn.
    split.
    * eapply path_nlrcons_edge in Hpath;eauto.
    * eapply path_rcons_rinv in Hpath. econstructor;eauto.
Qed.

Lemma rotate_forward (L : Type) (e : L -> L -> Prop) (p q : L) π
      (Hedge : e q p)
      (Hpath : Path e p q π)
  : exists π' q', e p q' /\ Path e q' p π'.
Proof.
  do 2 eexists;eapply rotate_forward';eauto.
Qed.

Lemma rotate_find (L : Type) `{EqDec L eq} (e : L -> L -> Prop) (p q : L) π
      (Hpath : Path e p p π)
      (Hin : q ∈ π)
  : exists ϕ, Path e q q ϕ /\ π =' ϕ /\ | π | = | ϕ |.
Proof.
  inv_path Hpath.
  - exists [p]. destruct Hin;[subst|contradiction]. split_conj;eauto. split;eauto.
  - eapply path_to_elem in Hin as Hto;eauto.
    destructH.
    eapply prefix_eq in Hto1. destructH.
    destruct ϕ;[inv Hto0|]. path_simpl' Hto0.
    eapply path_postfix_path in Hpath as Hfrom.
    2: { eapply postfix_eq. exists ϕ. rewrite <-app_cons_rcons. eassumption. }
    exists (q :: ϕ ++ tl (l2' ++ [q])).
    destruct l2'.
    + cbn in *. rewrite app_nil_r. eapply path_single in Hfrom. destructH. subst p.
      split_conj.
      * eassumption.
      * rewrite Hto1. reflexivity.
      * inv Hto1. reflexivity.
    + cbn. cbn in Hto1,Hfrom. inv Hto1.
      split_conj.
      * rewrite app_comm_cons.
        replace (l2' :r: q) with (tl (l0 :: l2' :r: q)) by (cbn;eauto). eapply path_app';eauto.
      * split;cbn.
        -- intros y Hy. destruct Hy;subst.
           ++ rewrite app_comm_cons. eapply in_or_app. left. eapply path_contains_back;eauto.
           ++ eapply in_app_or in H2. firstorder.
        -- intros y Hy. destruct Hy;subst. 1: firstorder.
           eapply in_app_or in H2. rewrite In_rcons in H2.
           rewrite app_comm_cons. eapply in_or_app. firstorder.
      * do 3 rewrite app_length. cbn. lia.
Qed.

Lemma acyclic_path_NoDup (L : Type) `{EqDec L eq} (ed : L -> L -> Prop) (π : list L) p q
      (Hpath : Path ed p q π)
      (Hacy : acyclic ed)
  : NoDup π.
Proof.
  induction Hpath.
  - econstructor;eauto. econstructor.
  - econstructor;eauto.
    intro N.
    eapply path_from_elem in N;eauto.
    destructH.
    eapply Hacy;eauto.
Qed.

Lemma acy_path_incl_cons (L : Type) `{EqDec L eq} (ed : L -> L -> Prop) (π ϕ : list L) p q
      (Hpath : Path ed p q π)
      (Hincl : π ⊆ (q :: ϕ))
      (Hacy : acyclic ed)
  : tl π ⊆ ϕ.
Proof.
  inv_path Hpath;cbn;eauto.
  unfold incl in *.
  intros a Ha.
  specialize (Hincl a). exploit Hincl.
  destruct Hincl;subst.
  - eapply acyclic_path_NoDup in Hpath;eauto.
    inv Hpath. contradiction.
  - auto.
Qed.

Lemma path_acyclic_no_loop (L : Type) (e : L -> L -> Prop) (a b c : L) (π : list L)
      (Hacy : acyclic e)
  : ~ Path e a a (b :: c :: π).
Proof.
  intro N.
  inv_path N.
  eapply Hacy;eauto.
Qed.

Lemma path_split2 (L : Type) (e : L -> L -> Prop) x y z π ϕ
      (Hpath : Path e x y (π ++ z :: ϕ))
  : Path e z y (π ++ [z]).
Proof.
  revert y Hpath.
  induction π;cbn;intros.
  - path_simpl' Hpath. econstructor.
  - path_simpl' Hpath. destruct π;cbn in *;inv Hpath.
    + econstructor;eauto.
    + econstructor;eauto.
Qed.

Lemma path_same_front (L : Type) (e : L -> L -> Prop) (p q' q : L) π
      (Hpath1 : Path e p q π)
      (Hpath2 : Path e p q' π)
  : q = q'.
Proof.
  destruct π.
  - inv Hpath1.
  - path_simpl' Hpath1. path_simpl' Hpath2. reflexivity.
Qed.

Lemma path_same_back (L : Type) (e : L -> L -> Prop) (p p' q : L) π
      (Hpath1 : Path e p q π)
      (Hpath2 : Path e p' q π)
  : p = p'.
Proof.
  destr_r' π;subst.
  - inv Hpath1.
  - path_simpl' Hpath1. path_simpl' Hpath2. reflexivity.
Qed.