(* week_38c_mystery_functions.v *)
(* dIFP 2014-2015, Q1, Week 38 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* ********** *)

(* Are the following specifications unique?
   What are then the corresponding functions?

   Spend the rest of your dIFP weekly time
   to answer these questions
   for the specifications below.
   (* At least 7 specifications would be nice. *)
*)

(* ********** *)
Require Import Arith.
Require Import unfold_tactic.

(* Helper stuff *)

Lemma unfold_plus_bc :
  forall j : nat,
    plus 0 j = j.
Proof.
  unfold_tactic plus.
Qed.

Lemma unfold_plus_ic :
  forall i' j : nat,
    plus (S i') j = S (plus i' j).
Proof.
  unfold_tactic plus.
Qed.

(* Helper for later *)
Proposition plus_1_S :
  forall n : nat,
    S n = plus 1 n.
Proof.
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)
    rewrite -> (plus_0_r 1).
    reflexivity.

  (* Inductive case: *)
    rewrite -> (unfold_plus_ic 0 (S n')).
    rewrite -> (plus_0_l (S n')).
    reflexivity.
Qed.

Proposition plus_S_1 :
  forall n : nat,
    S n = plus n 1.
Proof.
  intro.
  induction n as [ | n' IHn'].

  (* Base case: *)
    rewrite -> (plus_0_l 1).
    reflexivity.

  (* Inductive case: *)
    rewrite -> (unfold_plus_ic n' 1).
    rewrite -> (IHn').
    reflexivity.
Qed.

Lemma unfold_mult_bc :
  forall y : nat,
    0 * y = 0.
(* left-hand side in the base case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic mult.
Qed.

Lemma unfold_mult_ic :
  forall x' y : nat,
    (S x') * y = y + (x' * y).
(* left-hand side in the inductive case
   =
   the corresponding conditional branch *)
Proof.
  unfold_tactic mult.
Qed.

Lemma nat_ind2 :
  forall P : nat -> Prop,
    P 0 ->
    P 1 ->
    (forall i : nat,
      P i -> P (S i) -> P (S (S i))) ->
    forall n : nat,
      P n.
Proof.
  intros P H_P0 H_P1 H_PSS n.
  assert(consecutive :
           forall x : nat,
             P x /\ P (S x)).
    intro x.
    induction x as [ | x' [IHx' IHSx']].
      split.
        exact H_P0.
      exact H_P1.

      split.
        exact IHSx'.
      exact (H_PSS x' IHx' IHSx').

      destruct (consecutive n) as [ly _].

      exact ly.
Qed.

Definition specification_of_the_mystery_function_0 (f : nat -> nat) :=
  (f 0 = 1)
  /\
  (forall i j : nat,
    f (S (i + j)) = f i + f j).

Proposition there_is_only_one_mystery_function_0 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_0 f ->
    specification_of_the_mystery_function_0 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_0.
  intros [H_mys_bc1 H_mys_ic1].
  intros [H_mys_bc2 H_mys_ic2].
  intro n.
  induction n as [ | n' IHn'].
  (* Base case: *)
    rewrite -> (H_mys_bc1).
    rewrite -> (H_mys_bc2).
    reflexivity.

  (* Inductive case: *)
    rewrite <- (plus_0_r n').
    rewrite -> (H_mys_ic1 n' 0).
    rewrite -> (H_mys_ic2 n' 0).
    rewrite -> (H_mys_bc1).
    rewrite -> (H_mys_bc2).
    rewrite -> (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_0_is_dot_dot_dot :
  specification_of_the_mystery_function_0 S.
Proof.

  unfold specification_of_the_mystery_function_0.
  split.
    reflexivity.

    intros i j.
    rewrite -> (plus_1_S).
    rewrite -> (plus_S_1).
    rewrite -> (plus_1_S).
    rewrite -> (plus_assoc 1 i j).
    Check(plus_1_S).
    rewrite <- (plus_1_S i).
    rewrite <- (plus_assoc (S i) j 1).
    rewrite <- (plus_S_1 j).
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_1 (f : nat -> nat) :=
  (f 0 = 0)
  /\
  (forall i j : nat,
    f (i + S j) = f i + S (f j)).

Proposition there_is_only_one_mystery_function_1 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_1 f ->
    specification_of_the_mystery_function_1 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_1.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)
    rewrite <- (plus_0_l (S n')).
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    rewrite (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_1_is_id :
  specification_of_the_mystery_function_1 id.
Proof.
  unfold specification_of_the_mystery_function_1.
  unfold id.
  split.

    reflexivity.

    intros i j.
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_2 (f : nat -> nat) :=
  (f 0 = 0)
  /\
  (forall i j : nat,
    f (S (i + j)) = S (f i) + S (f j)).

Proposition there_is_only_one_mystery_function_2 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_2 f ->
    specification_of_the_mystery_function_2 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_2.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)
    Check(plus_n_Sm).
    rewrite <- (plus_0_l (S n')).
    rewrite <- (plus_n_Sm 0 n').
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    rewrite -> (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_2_is_mult_2 :
  specification_of_the_mystery_function_2 (mult 2).
Proof.
  unfold specification_of_the_mystery_function_2.
  split.

    rewrite -> (mult_0_r 2).
    reflexivity.

    intros i j.
    rewrite -> (plus_n_Sm i j).
    rewrite <- (plus_0_r j).
    rewrite -> (plus_n_Sm j 0).
    rewrite -> (plus_assoc i j 1).
    rewrite -> (plus_0_r j).
    rewrite <- (plus_0_r (2*i)).
    rewrite -> (plus_n_Sm (2*i) 0).
    rewrite <- (plus_0_r (2*j)).
    rewrite -> (plus_n_Sm (2*j) 0).
    rewrite <- (plus_assoc i j 1).
    rewrite -> (plus_comm j 1).
    rewrite -> (plus_assoc i 1 j).
    rewrite -> (mult_plus_distr_l 2 (i+1) j).
    rewrite -> (mult_plus_distr_l 2 i 1).
    rewrite -> (plus_comm (2*j) 1).
    rewrite -> (plus_assoc (2*i+1) 1 (2*j)).
    rewrite -> (mult_1_r 2).
    Check(plus_assoc).
    rewrite <- (plus_assoc (2*i) 1 1).
    rewrite <- (plus_1_S 1).
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_3 (f : nat -> nat) :=
  (f 0 = 1)
  /\
  (forall i j : nat,
    f (S (i + j)) = S (f i) + S (f j)).

Proposition there_is_only_one_mystery_function_3 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_3 f ->
    specification_of_the_mystery_function_3 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_3.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)

    rewrite <- (plus_0_l (S n')).
    rewrite <- (plus_n_Sm 0 n').
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    rewrite -> (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_3_is_mult_3_plus_1 :
  specification_of_the_mystery_function_3 (fun x => (3*x +1)).
Proof.
  unfold specification_of_the_mystery_function_3.
  split.

    rewrite -> (mult_0_r).
    rewrite -> (plus_0_l).
    reflexivity.

    intros i j.
    rewrite -> (plus_S_1 (i + j)).
    rewrite -> (mult_plus_distr_l).
    rewrite -> (mult_plus_distr_l).
    rewrite -> (plus_S_1 (3*i + 1)).
    rewrite -> (plus_1_S (3*j + 1)).
    rewrite <- (plus_assoc (3*i) 1 1).
    rewrite <- (plus_1_S 1).
    rewrite -> (mult_1_r 3).
    rewrite <- (plus_assoc (3*i + 3*j) 3 1).
    rewrite <- (plus_S_1 3).
    rewrite -> (plus_comm (3*j) 1).
    rewrite -> (plus_assoc 1 1 (3*j)).
    rewrite <- (plus_S_1 1).
    rewrite -> (plus_assoc (3*i + 2) 2 (3 * j)).
    rewrite <- (plus_assoc (3*i) 2 2).
    rewrite <- (plus_n_Sm 2 1).
    rewrite <- (plus_n_Sm 2 0).
    rewrite -> (plus_0_r 2).
    rewrite <- (plus_assoc (3*i) 4 (3*j)).
    rewrite -> (plus_comm 4 (3*j)).
    rewrite -> (plus_assoc (3*i) (3*j) 4).
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_4 (f : nat -> nat) :=
  (f 0 = 0)
  /\
  (forall i j : nat,
    f (i + j) = f i + f j).

Proposition there_is_only_one_mystery_function_4 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_4 f ->
    specification_of_the_mystery_function_4 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_4.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)

    rewrite -> (plus_1_S n').
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (plus_1_S 0).
Abort.

Lemma mystery_function_4_is_not_unique :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_4 f ->
    specification_of_the_mystery_function_4 g ->
    exists n : nat,
      ~(f n = g n).

Theorem possible_mystery_function_4_is_plus_0 :
  specification_of_the_mystery_function_4 (plus 0).
Proof.
  unfold specification_of_the_mystery_function_4.
  split.
    rewrite -> (plus_0_l).
    reflexivity.

    intros i j.
    rewrite ->3 (plus_0_l).
    reflexivity.
Qed.

Theorem another_possibility_for_mystery_function_4_is_mult_1 :
  specification_of_the_mystery_function_4 (mult 1).
Proof.
  unfold specification_of_the_mystery_function_4.
  split.
    rewrite -> (mult_0_r).
    reflexivity.

    intros i j.
    rewrite ->3 (mult_1_l).
    reflexivity.
Qed.

Theorem and_the_mystery_function_4_is_mult_id :
  specification_of_the_mystery_function_4 id.
Proof.
  unfold specification_of_the_mystery_function_4.
  split.

    unfold id.
    reflexivity.

    intros i j.
    unfold id.
    reflexivity.
Qed.

(* ********** *)

Lemma binomial_2 :
  forall x y : nat,
    (x + y) * (x + y) = (x * x) + 2 * x * y + (y * y).
Proof.
  intros x y.

  rewrite -> mult_plus_distr_r.
  rewrite -> mult_plus_distr_l.
  rewrite -> mult_plus_distr_l.
  rewrite -> (mult_comm y x).
  symmetry.

  rewrite -> (unfold_mult_ic 1 x).
  rewrite -> (unfold_mult_ic 0 x).
  rewrite -> unfold_mult_bc.
  rewrite -> plus_0_r.
  rewrite -> mult_plus_distr_r.
  rewrite -> plus_assoc.
  rewrite -> plus_assoc.
  reflexivity.
Qed.

Definition specification_of_the_mystery_function_5 (f : nat -> nat) :=
  (f 0 = 0)
  /\
  (forall i : nat,
    f (S i) = S (2 * i + f i)).

Proposition there_is_only_one_mystery_function_5 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_5 f ->
    specification_of_the_mystery_function_5 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_5.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)

    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_5_is_square :
  specification_of_the_mystery_function_5 (fun x => x * x).
Proof.
  unfold specification_of_the_mystery_function_5.
  split.
    rewrite -> (mult_0_r).
    reflexivity.

    intro i.
    rewrite -> (plus_1_S).
    rewrite -> (plus_1_S (2*i + i*i)).
    rewrite -> (plus_assoc 1 (2*i) (i*i)).
    rewrite <- (mult_1_r (2*i)).
    rewrite <- (mult_assoc 2 i 1).
    rewrite -> (mult_comm i 1).
    rewrite -> (mult_assoc 2 1 i).
    rewrite -> (binomial_2).
    rewrite <- (mult_1_l 1) at 5.
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_6 (f : nat -> nat) :=
  (forall i j : nat,
    f (i + j) = f i + 2 * i * j + f j).

Proposition there_is_only_one_mystery_function_6 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_6 f ->
    specification_of_the_mystery_function_6 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_6.
  intros H_f H_g.
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite <- (plus_0_l 0).
    rewrite -> (H_f).
    rewrite -> (H_g).
Abort.

Theorem and_the_mystery_function_6_is_power :
  specification_of_the_mystery_function_6 (fun x => x*x).
Proof.
  unfold specification_of_the_mystery_function_6.
  intros i j.
  apply (binomial_2).
Qed.

Lemma rewriting_in_short_form_v1 :
  forall a b c d : nat,
    a + b + c + d = a + d + b + c.
Proof.
  intros a b c d.
  rewrite <- (plus_assoc a d b).
  rewrite -> (plus_comm d b).
  rewrite <- (plus_assoc a (b + d) c).
  rewrite -> (plus_comm b d).
  rewrite <- (plus_assoc d b c).
  rewrite -> (plus_comm d (b + c)).
  rewrite -> (plus_assoc a (b + c) d).
  rewrite -> (plus_assoc a b c).
  reflexivity.
Qed.

Theorem and_the_mystery_function_6_could_also_be :
  specification_of_the_mystery_function_6 (fun x => x*x + 2*x).
Proof.
  unfold specification_of_the_mystery_function_6.
  intros i j.
  rewrite -> (binomial_2).
  rewrite -> (mult_plus_distr_l).
  rewrite -> (plus_comm (2*i) (2*j)).
  rewrite <- (plus_assoc (i*i) (2*i) (2*i*j)).
  rewrite -> (plus_comm (2*i) (2*i*j)).
  rewrite -> (plus_assoc (i*i) (2*i*j) (2*i)).
  rewrite ->2 (plus_assoc).
  rewrite -> (rewriting_in_short_form_v1 (i*i + 2*i*j) (j*j) (2*j) (2*i)).
  reflexivity.
Qed.

(* ********** *)

Fixpoint exp (x n : nat)  :=
  match n with
      | 0 => 1
      | S n' => mult x (exp x n')
end.

Lemma unfold_exp_bc :
  forall x : nat,
    exp x 0 = 1.
Proof.
  unfold_tactic exp.
Qed.

Lemma unfold_exp_ic :
  forall (x n : nat),
    exp x (S n) = mult x (exp x n).
Proof.
  unfold_tactic exp.
Qed.

Definition specification_of_the_mystery_function_7 (f : nat -> nat) :=
  (f 0 = 1)
  /\
  (forall i j : nat,
    f (S (i + j)) = 2 * f i * f j).

Proposition there_is_only_one_mystery_function_7 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_7 f ->
    specification_of_the_mystery_function_7 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_7.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)

    rewrite <- (plus_0_l (S n')).
    rewrite <- (plus_n_Sm 0 n').
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (IHn').
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.
Qed.

Lemma exp_is_distributive :
  forall (x n m : nat),
    mult (exp x n) (exp x m) = exp x (n+m).
Proof.
  intros x n m.
  induction n as [ | n' IHn'].

  (*Base case: *)

    rewrite -> (unfold_exp_bc).
    rewrite -> (plus_0_l m).
    rewrite -> (mult_1_l).
    reflexivity.

  (* Inductive case: *)

    rewrite -> (unfold_exp_ic).
    rewrite -> (plus_1_S).
    rewrite <- (plus_assoc 1 n' m).
    rewrite <- (plus_1_S (n' +m)).
    rewrite -> (unfold_exp_ic).
    rewrite <- (IHn').
    rewrite -> (mult_assoc x (exp x n') (exp x m)).
    reflexivity.
Qed.

Theorem and_the_mystery_function_7_is_power_of_2 :
  specification_of_the_mystery_function_7 (exp 2).
Proof.
  unfold specification_of_the_mystery_function_7.
  split.

    rewrite -> (unfold_exp_bc).
    reflexivity.

    intros i j.
    rewrite -> (unfold_exp_ic).
    rewrite <- (mult_assoc 2 (exp 2 i) (exp 2 j)).
    rewrite -> (exp_is_distributive).
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_power_8 (f : nat -> nat) :=
  (f 0 = 2)
  /\
  (forall i j : nat,
    f (S (i + j)) = f i * f j).

Proposition there_is_only_one_mystery_function_power_8 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_power_8 f ->
    specification_of_the_mystery_function_power_8 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_power_8.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)

    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)

    rewrite <- (plus_0_l (S n')).
    rewrite <- (plus_n_Sm 0 n').
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    rewrite -> (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_8_is_mult_2_power_of_2 :
  specification_of_the_mystery_function_power_8 (fun x => mult 2 (exp 2 x)).
Proof.
  unfold specification_of_the_mystery_function_power_8.
  split.

    rewrite -> (unfold_exp_bc).
    rewrite -> (mult_1_r).
    reflexivity.

    intros i j.
    rewrite -> (unfold_exp_ic).
    rewrite -> (mult_assoc 2 2 (exp 2 (i + j))).
    rewrite <- (exp_is_distributive).
    rewrite -> (mult_assoc).
    rewrite -> (mult_assoc).
    rewrite -> (mult_comm (2 * 2) (exp 2 i)).
    rewrite -> (mult_comm 2 (exp 2 i)).
    rewrite -> (mult_assoc).
    reflexivity.
Qed.

(* ********** *)

Definition specification_of_the_mystery_function_9 (f : nat -> nat) :=
  (f 0 = 0)
  /\
  (f 1 = 1)
  /\
  (f 2 = 1)
  /\
  (forall p q : nat,
    f (S (p + q)) = f (S p) * f (S q) + f p * f q).

Proposition there_is_only_one_mystery_function_9 :
  forall f g : nat -> nat,
    specification_of_the_mystery_function_9 f ->
    specification_of_the_mystery_function_9 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_9.
  intros [H_f_bc0 [H_f_bc1 [H_f_bc2 H_f_ic]]]
         [H_g_bc0 [H_g_bc1 [H_g_bc2 H_g_ic]]].
  intro n.
  induction n as [ | | n' IH_n' IH_Sn'] using nat_ind2.

  (* Base case 1: *)
    rewrite -> H_f_bc0.
    rewrite -> H_g_bc0.
    reflexivity.

  (* Base case 2: *)
    rewrite -> H_f_bc1.
    rewrite -> H_g_bc1.
    reflexivity.

  (* Inductive case: *)
    rewrite -> (plus_1_S n').
    rewrite -> (H_f_ic 1 n').
    rewrite -> (H_g_ic 1 n').
    rewrite -> IH_n'.
    rewrite -> (H_f_bc2).
    rewrite -> (H_g_bc2).
    rewrite -> IH_Sn'.
    rewrite -> (H_f_bc1).
    rewrite -> (H_g_bc1).
    reflexivity.
Qed.

Fixpoint fib_ds (n : nat) : nat :=
  match n with
    | 0 => 0
    | S n' => match n' with
                | 0 => 1
                | S n'' => fib_ds n' + fib_ds n''
              end
  end.

Lemma unfold_fib_ds_base_case_0 :
  fib_ds 0 = 0.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma unfold_fib_ds_base_case_1 :
  fib_ds 1 = 1.
Proof.
  unfold_tactic fib_ds.
Qed.

Lemma shorthand_rewrite_with_fib :
  forall a b c d : nat,
    (a + b) * c + a* d = a*(c + d) + b*c.
Proof.
  intros a b c d .
  rewrite -> (mult_plus_distr_r).
  rewrite <- (plus_assoc (a*c) (b*c) (a*d)).
  rewrite -> (plus_comm (b*c) (a*d)).
  rewrite -> (plus_assoc (a*c) (a*d) (b*c)).
  Check(mult_plus_distr_l).
  rewrite <- (mult_plus_distr_l a c d).
  reflexivity.
Qed.

Lemma unfold_fib_ds_induction_case :
  forall n'' : nat,
    fib_ds (S (S n'')) = fib_ds (S n'') + fib_ds n''.
Proof.
  unfold_tactic fib_ds.
Qed.

Theorem and_the_mystery_function_9_is_fib :
  specification_of_the_mystery_function_9 (fib_ds).
Proof.
  unfold specification_of_the_mystery_function_9.
  split.

    rewrite -> (unfold_fib_ds_base_case_0).
    reflexivity.

    split.

      rewrite -> (unfold_fib_ds_base_case_1).
      reflexivity.

      split.

        rewrite -> (unfold_fib_ds_induction_case).
        rewrite -> (unfold_fib_ds_base_case_1).
        rewrite -> (unfold_fib_ds_base_case_0).
        rewrite -> (plus_0_r).
        reflexivity.

        intros p q.
        revert p. (* To strengthen my hypothesis *)
        induction q as [ | q' IHq'].

        (* Base case *)
          intro p.
          rewrite -> (plus_0_r).
          rewrite -> (unfold_fib_ds_base_case_0).
          rewrite -> (unfold_fib_ds_base_case_1).
          rewrite -> (mult_0_r).
          rewrite -> (mult_1_r).
          rewrite -> (plus_0_r).
          reflexivity.

        (* Inductive case: *)

          intro p.
          rewrite -> (plus_1_S q') at 1.
          rewrite -> (plus_assoc p 1 q').
          rewrite <- (plus_S_1 p).
          rewrite -> (IHq' (S p)).
          rewrite ->2 (unfold_fib_ds_induction_case).
          rewrite -> (shorthand_rewrite_with_fib (fib_ds (S p)) (fib_ds p) (fib_ds (S q')) (fib_ds q')).
          reflexivity.
Qed.

(* ********** *)

Require Import Bool.

Definition specification_of_the_mystery_function_power_10 (f : nat -> bool) :=
  (f 0 = true)
  /\
  (f 1 = false)
  /\
  (forall i j : nat,
     f (i + j) = eqb (f i) (f j)).

Proposition there_is_only_one_mystery_function_power_10 :
  forall f g : nat -> bool,
    specification_of_the_mystery_function_power_10 f ->
    specification_of_the_mystery_function_power_10 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_power_10.
  intros [H_f_bc0 [H_f_bc1 H_f_ic]].
  intros [H_g_bc0 [H_g_bc1 H_g_ic]].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case. *)
    rewrite -> (H_f_bc0).
    rewrite -> (H_g_bc0).
    reflexivity.

  (* Inductive case: *)
    rewrite -> (plus_1_S n').
    rewrite -> (H_f_ic).
    rewrite -> (H_f_bc1).
    rewrite -> (IHn').
    rewrite -> (H_g_ic).
    rewrite -> (H_g_bc1).
    reflexivity.
Qed.

Fixpoint evenp (n : nat) : bool :=
  match n with
    | 0 => true
    | S 0 => false
    | S (S n'') => evenp n''
  end.

Lemma unfold_evenp_bc0 :
  evenp 0 = true.
Proof.
  unfold_tactic evenp.
Qed.

Lemma unfold_evenp_bc1 :
  evenp 1 = false.
Proof.
  unfold_tactic evenp.
Qed.

Lemma unfold_evenp_ic :
  forall n'' : nat,
    evenp (S (S n'')) = evenp n''.
Proof.
  unfold_tactic evenp.
Qed.

Lemma about_mystery_evenp_v2 :
    forall x : nat,
      evenp (S x) = negb (evenp x).
Proof.
  intro x.
  induction x as [ | x' IHx'].

  rewrite -> (unfold_evenp_bc0).
  rewrite -> (unfold_evenp_bc1).
  unfold negb.
  reflexivity.

  rewrite -> (unfold_evenp_ic).
  rewrite -> (IHx').
  rewrite -> (negb_involutive).
  reflexivity.
Qed.

Lemma eqb_if_both_even_or_odd :
  forall x y : nat,
    eqb (evenp x) (evenp y) = eqb (evenp (S x)) (evenp (S y)).
Proof.
  intro x.
  induction x as [ | x' IHx'].

  (* Base case: *)

    intros [ | y'].

      rewrite -> (unfold_evenp_bc0).
      rewrite -> (unfold_evenp_bc1).
      unfold eqb.
      reflexivity.

    rewrite -> (unfold_evenp_bc1).
    rewrite -> (unfold_evenp_bc0).
    rewrite -> (unfold_evenp_ic).
    rewrite -> (about_mystery_evenp_v2 y').
    destruct (evenp y') as [ | ] eqn:H_y.
      unfold negb.
      unfold eqb.
      reflexivity.

    unfold negb.
    unfold eqb.
    reflexivity.

  (* Inductive case: *)

    rewrite -> (unfold_evenp_ic).
    rewrite -> (about_mystery_evenp_v2).
    intros [ | y'].

      rewrite -> (unfold_evenp_bc0).
      rewrite -> (IHx' 1).
      rewrite -> (unfold_evenp_ic).
      rewrite -> (unfold_evenp_bc0).
      rewrite -> (about_mystery_evenp_v2).
      reflexivity.

    rewrite <- (about_mystery_evenp_v2).
    rewrite <- (IHx' y').
    rewrite -> (unfold_evenp_ic).
    reflexivity.
Qed.

Theorem fun_theorem_about_evenp :
  forall x y : nat,
    evenp (x + y) = eqb (evenp x) (evenp y).
Proof.
  intro x.
  induction x as [ | x' IHx'].

  (* Base case: *)

  intro y.
  rewrite -> (plus_0_l).
  rewrite -> (unfold_evenp_bc0).
  unfold eqb.
  destruct (evenp y) as [ | ] eqn:H_y. (* Boolean expression *)
    reflexivity.
  reflexivity.

  intros [ | y'].
  rewrite -> (unfold_evenp_bc0).
  rewrite -> (plus_0_r).
  unfold eqb.
  destruct (evenp (S x')) as [ | ] eqn:H_Sx'. (* Boolean expression *)
    reflexivity.
  reflexivity.
  rewrite -> (plus_S_1 x').
  rewrite <- (plus_assoc x' 1 (S y')).
  rewrite <- (plus_1_S (S y')).
  rewrite (IHx' (S (S y'))).
  rewrite <- (plus_S_1 x').
  rewrite -> (unfold_evenp_ic).
  rewrite -> (eqb_if_both_even_or_odd).
  reflexivity.
Qed.

Theorem and_the_mystery_function_10_is_is_evenp :
  specification_of_the_mystery_function_power_10 evenp.
Proof.
  unfold specification_of_the_mystery_function_power_10.
  split.
    rewrite -> (unfold_evenp_bc0).
    reflexivity.
    split.
      rewrite -> (unfold_evenp_bc1).
      reflexivity.

    apply (fun_theorem_about_evenp).
Qed.

Definition specification_of_the_mystery_function_11 (f : nat -> nat * nat) :=
  (f 0 = (1, 0))
  /\
  (forall n' : nat,
    f (S n') = let (x, y) := f n'
               in (x + y, x)).

Fixpoint fib_co_acc (n : nat) : nat * nat :=
  match n with
    | O => (1, 0)
    | S n' => let (x, y) := fib_co_acc n'
              in (x + y, x)
  end.

Lemma unfold_fib_co_acc_base_case :
  fib_co_acc 0 = (1, 0).
Proof.
  unfold_tactic fib_co_acc.
Qed.

Lemma unfold_fib_co_acc_induction_case :
  forall n' : nat,
    fib_co_acc (S n') = let (x, y) := fib_co_acc n'
                        in (x + y, x).
Proof.
  unfold_tactic fib_co_acc.
Qed.

Proposition there_is_only_one_mystery_function_11 :
  forall f g : nat -> nat * nat,
    specification_of_the_mystery_function_11 f ->
    specification_of_the_mystery_function_11 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_11.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.
  induction n as [ | n' IHn'].

  (* Base case: *)
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (IHn').
    reflexivity.
Qed.

Theorem and_the_mystery_function_11_is_power_fibonacci_accumulator :
  specification_of_the_mystery_function_11 fib_co_acc.
Proof.
  unfold specification_of_the_mystery_function_11.
  split.
    rewrite -> (unfold_fib_co_acc_base_case).
    reflexivity.

    intro n'.
    rewrite -> (unfold_fib_co_acc_induction_case).
    reflexivity.
Qed.

(* ********** *)

Fixpoint fac_co_acc (n : nat) : nat * nat :=
  match n with
    | 0 => (0, 1)
    | S n' => let (x,y) := fac_co_acc n'
              in (S x, y * S x)
end.

Definition specification_of_the_mystery_function_12 (f : nat -> nat * nat) :=
  (f 0 = (0, 1))
  /\
  (forall n' : nat,
    f (S n') = let (x, y) := f n'
               in (S x, y * S x)).

Proposition there_is_only_one_mystery_function_12 :
  forall f g : nat -> nat * nat,
    specification_of_the_mystery_function_12 f ->
    specification_of_the_mystery_function_12 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_the_mystery_function_12.
  intros [H_f_bc H_f_ic].
  intros [H_g_bc H_g_ic].
  intro n.

  induction n as [ | n' IHn'].

  (* Base case: *)
    rewrite -> (H_f_bc).
    rewrite -> (H_g_bc).
    reflexivity.

  (* Inductive case: *)
    rewrite -> (H_f_ic).
    rewrite -> (H_g_ic).
    rewrite -> (IHn').
    reflexivity.
Qed.

Lemma unfold_fac_co_acc_base_case :
  fac_co_acc 0 = (0, 1).
Proof.
  unfold_tactic fac_co_acc.
Qed.

Lemma unfold_fac_co_acc_induction_case :
  forall n' : nat,
    fac_co_acc (S n') = let (x, y) := fac_co_acc n'
                        in (S x, y * S x).
Proof.
  unfold_tactic fac_co_acc.
Qed.

Theorem and_the_mystery_function_12_is_tuple_index_and_factorial :
  specification_of_the_mystery_function_12 fac_co_acc.
Proof.
  unfold specification_of_the_mystery_function_12.
  split.
    rewrite -> (unfold_fac_co_acc_base_case).
    reflexivity.

    intro n'.
    rewrite -> (unfold_fac_co_acc_induction_case).
    reflexivity.
Qed.

(* end of week_38c_mystery_functions.v *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (x : natural) (y : natural) (lf2 : natural) : natural :=
  plus (plus y x) lf2.


Require Import Arith.

Require Import folLogic3.
Require Import folProp.
Require Import subProp.
Require Export NN.

Lemma natNE :
 forall a b : nat,
 a <> b -> SysPrf NN (notH (equal (natToTerm a) (natToTerm b))).
Proof.
assert
 (forall a b : nat,
  a < b -> SysPrf NN (notH (equal (natToTerm a) (natToTerm b)))).
intro.
induction a as [| a Hreca]; intros.
destruct b as [| n].
elim (lt_n_O _ H).
simpl in |- *.
apply impE with (notH (equal (Succ (natToTerm n)) Zero)).
apply cp2.
apply impI.
apply eqSym.
apply Axm; right; constructor.
apply nn1.
destruct b as [| n].
elim (lt_n_O _ H).
simpl in |- *.
apply impE with (notH (equal (natToTerm a) (natToTerm n))).
apply cp2.
apply nn2.
apply Hreca.
apply lt_S_n.
auto.
intros.
induction (nat_total_order _ _ H0).
apply H.
auto.
apply impE with (notH (equal (natToTerm b) (natToTerm a))).
apply cp2.
apply impI.
apply eqSym.
apply Axm; right; constructor.
apply H.
auto.
Qed.

Lemma natLE :
 forall a b : nat,
 b <= a -> SysPrf NN (notH (LT (natToTerm a) (natToTerm b))).
Proof.
intros.
induction b as [| b Hrecb].
apply nn7.
simpl in |- *.
apply
 impE
  with
    (notH
       (orH (LT (natToTerm a) (natToTerm b))
          (equal (natToTerm a) (natToTerm b)))).
apply cp2.
apply nn8.
apply nOr.
apply andI.
apply Hrecb.
apply le_S_n.
apply le_S.
auto.
apply natNE.
unfold not in |- *; intros.
apply (le_not_lt _ _ H).
rewrite H0.
apply lt_n_Sn.
Qed.

Lemma natLT :
 forall a b : nat, a < b -> SysPrf NN (LT (natToTerm a) (natToTerm b)).
Proof.
intros.
eapply orE.
apply nn9 with (a := natToTerm b) (b := natToTerm a).
apply impI.
apply contradiction with (LT (natToTerm b) (natToTerm a)).
apply Axm; right; constructor.
apply sysWeaken.
apply natLE.
apply lt_le_weak.
auto.
apply impI.
apply orSys.
apply contradiction with (equal (natToTerm b) (natToTerm a)).
apply Axm; right; constructor.
apply sysWeaken.
apply natNE.
unfold not in |- *; intros.
apply (le_not_lt _ _ H).
rewrite H0.
apply lt_n_Sn.
apply Axm; right; constructor.
Qed.

Lemma natPlus :
 forall a b : nat,
 SysPrf NN (equal (Plus (natToTerm a) (natToTerm b)) (natToTerm (a + b))).
Proof.
intros.
induction b as [| b Hrecb].
rewrite plus_comm.
simpl in |- *.
apply nn3.
rewrite plus_comm.
simpl in |- *.
apply eqTrans with (Succ (Plus (natToTerm a) (natToTerm b))).
apply nn4.
apply eqSucc.
rewrite plus_comm.
apply Hrecb.
Qed.

Lemma natTimes :
 forall a b : nat,
 SysPrf NN (equal (Times (natToTerm a) (natToTerm b)) (natToTerm (a * b))).
Proof.
intros.
induction b as [| b Hrecb].
rewrite mult_comm.
simpl in |- *.
apply nn5.
rewrite mult_comm.
simpl in |- *.
eapply eqTrans.
apply nn6.
rewrite plus_comm.
apply eqTrans with (Plus (natToTerm (b * a)) (natToTerm a)).
apply eqPlus.
rewrite mult_comm.
apply Hrecb.
apply eqRefl.
apply natPlus.
Qed.

Lemma boundedLT :
 forall (m : nat) (a : Formula) (x : nat),
 (forall n : nat,
  n < m -> SysPrf NN (substituteFormula LNN a x (natToTerm n))) ->
 SysPrf NN (impH (LT (var x) (natToTerm m)) a).
Proof.
simple induction m; intros.
apply impI.
apply contradiction with (LT (var x) (natToTerm 0)).
apply Axm; right; constructor.
apply sysWeaken.
apply nn7.
apply impI.
eapply orE.
apply impE with (LT (var x) (natToTerm (S n))).
apply sysWeaken.
simpl in |- *.
apply nn8.
apply Axm; right; constructor.
apply sysWeaken.
apply H.
intros.
apply H0.
apply lt_S.
auto.
apply sysWeaken.
apply impI.
rewrite <- (subFormulaId LNN a x).
apply impE with (substituteFormula LNN a x (natToTerm n)).
apply (subWithEquals LNN).
apply eqSym.
apply Axm; right; constructor.
apply sysWeaken.
apply H0.
apply lt_n_Sn.
Qed.

Lemma nnPlusNotNeeded :
 forall n : nat,
 SysPrf NN
   (impH (orH (LT (var 1) (natToTerm n)) (equal (var 1) (natToTerm n)))
      (LT (var 1) (Succ (natToTerm n)))).
Proof.
intros.
induction n as [| n Hrecn].
simpl in |- *.
apply impI.
apply orSys.
apply contradiction with (LT (var 1) Zero).
apply Axm; right; constructor.
apply sysWeaken.
apply nn7.
rewrite <- (subFormulaId LNN (LT (var 1) (Succ Zero)) 1).
apply impE with (substituteFormula LNN (LT (var 1) (Succ Zero)) 1 Zero).
apply (subWithEquals LNN).
apply eqSym.
apply Axm; right; constructor.
apply sysWeaken.
replace (substituteFormula LNN (LT (var 1) (Succ Zero)) 1 Zero) with
 (LT (natToTerm 0) (natToTerm 1)).
apply natLT.
auto.
unfold LT in |- *.
rewrite (subFormulaRelation LNN).
reflexivity.
simpl in |- *.
apply impI.
apply orSys.
apply
 impE with (orH (LT (var 1) (natToTerm n)) (equal (var 1) (natToTerm n))).
apply sysWeaken.
apply impTrans with (LT (var 1) (natToTerm (S n))).
apply Hrecn.
apply boundedLT.
intros.
replace
 (substituteFormula LNN (LT (var 1) (Succ (Succ (natToTerm n)))) 1
    (natToTerm n0)) with (LT (natToTerm n0) (natToTerm (S (S n)))).
apply natLT.
apply lt_S.
assumption.
unfold LT in |- *.
rewrite (subFormulaRelation LNN).
simpl in |- *.
rewrite (subTermNil LNN).
reflexivity.
apply closedNatToTerm.
apply impE with (LT (var 1) (Succ (natToTerm n))).
apply sysWeaken.
apply nn8.
apply Axm; right; constructor.
rewrite <- (subFormulaId LNN (LT (var 1) (Succ (Succ (natToTerm n)))) 1).
apply
 impE
  with
    (substituteFormula LNN (LT (var 1) (Succ (Succ (natToTerm n)))) 1
       (Succ (natToTerm n))).
apply (subWithEquals LNN).
apply eqSym.
apply Axm; right; constructor.
apply sysWeaken.
replace
 (substituteFormula LNN (LT (var 1) (Succ (Succ (natToTerm n)))) 1
    (Succ (natToTerm n))) with (LT (natToTerm (S n)) (natToTerm (S (S n)))).
apply natLT.
apply lt_n_Sn.
unfold LT in |- *.
rewrite (subFormulaRelation LNN).
simpl in |- *.
rewrite (subTermNil LNN).
reflexivity.
apply closedNatToTerm.
Qed.


(*

 HUGHES LISTS

 Evgeny V Ivashkevich

 E-mail: ivashkev@yandex.ru

 March 2, 2019

 Abstract: In this file, we formalize the short paper by R. John Muir Hughes,
           "A novel repesentation of lists and its application to the function
           reverse". Information Pocessing Letters 22 (1986) 141-144,
           where fast algorithm for lists reverse function was proposed.
*)

Require Import FunctionalExtensionality.
Require Import List.
Import ListNotations.

Set Implicit Arguments.

Module ArrowType.

Section Hughes.

Variable T : Type.

Definition A := list T.

Definition R := A -> A.

Definition rep (x : A) : R := app x.

Check rep.

Definition abs (f : R) : A := f [].

Check abs.

Print abs.

Theorem abs_rep :
  forall a : A,
  abs (rep a) = a.
Proof.
  unfold abs, rep.
  intros a.
  rewrite app_nil_r.
  reflexivity.
Qed.

Parameter find_rep : forall f : R, { F : A | f = rep F }.

Theorem rep_abs :
  forall f : R,
  rep (abs f) = f.
Proof.
  intros f.
  destruct (find_rep f) as [ F Hf ].
  rewrite Hf.
  rewrite abs_rep.
  reflexivity.
Qed.

Definition appendR (f g : R) : R := fun x => f (g x).

Check appendR.

Theorem appendR_rep :
  forall (a b : A),
  appendR (rep a) (rep b) = rep (a ++ b).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold appendR, rep; simpl.
  apply app_assoc.
Qed.

Theorem abs_appendR :
  forall (f g : R),
  abs (appendR f g) = (abs f) ++ (abs g).
Proof.
  intros.
  destruct (find_rep f) as [ F Hf ].
  destruct (find_rep g) as [ G Hg ].
  rewrite Hf. rewrite Hg. rewrite appendR_rep.
  unfold abs, rep; simpl.
  repeat rewrite app_nil_r.
  reflexivity.
Qed.

Fixpoint rev (x : A) : R :=
  match x with
  | nil => id
  | a :: y => fun (t : A) => (rev y) (a :: t)
  end.

Definition reverse (x : A) := (rev x) [].

Theorem rev_app :
  forall (x y : A),
  rev x y = rev x [] ++ y.
Proof.
  intros.
  induction y as [| h t ].
  { simpl. rewrite app_nil_r. reflexivity. }
  { assert (H1 : rev x [] = abs (rev x)). reflexivity.
    assert (H2 : h :: t = abs (app (h :: t))).
    { unfold abs. rewrite app_nil_r. reflexivity. }
    rewrite H1. rewrite H2 at 2.
    rewrite <- abs_appendR.
    unfold appendR, abs, rep; simpl.
    rewrite app_nil_r. reflexivity.
  }
Qed.

Theorem rev_app_distr:
  forall (x y : A),
  reverse (x ++ y) = reverse y ++ reverse x.
Proof.
  intros.
  unfold reverse.
  induction x as [| h t ].
  { simpl. rewrite app_nil_r. reflexivity. }
  { simpl.
    rewrite (rev_app t [h]).
    rewrite rev_app.
    rewrite IHt.
    rewrite app_assoc.
    reflexivity.
  }
Qed.

Theorem app_length :
  forall x y : A,
  length (x ++ y) = length x + length y.
Proof.
  intros x y.
  induction x as [| h t ].
  { reflexivity. }
  { simpl. rewrite -> IHt. reflexivity. }
Qed.

Theorem reverse_length :
  forall x : A,
  length (reverse x) = length x.
Proof.
  intros x.
  unfold reverse.
  induction x as [| h t ].
  { reflexivity. }
  { assert (H : rev (h :: t) [] = rev t [] ++ [h]).
    { simpl. rewrite rev_app. reflexivity. }
    rewrite H.
    rewrite app_length.
    rewrite IHt.
    rewrite PeanoNat.Nat.add_comm.
    simpl. reflexivity.
  }
Qed.

Theorem reverse_involutive :
  forall x : A,
  reverse (reverse x) = x.
Proof.
  induction x.
  { reflexivity. }
  { simpl.
    replace (a :: x) with ([a] ++ x).
    { repeat rewrite rev_app_distr.
      rewrite IHx. reflexivity.
    }
    { reflexivity. }
  }
Qed.

Theorem rev_injective :
  forall (x y : A),
  reverse x = reverse y -> x = y.
Proof.
  intros x y reveq.
  rewrite <- reverse_involutive.
  rewrite <- reveq.
  rewrite -> reverse_involutive.
  reflexivity.
Qed.

End Hughes.

Compute reverse [2;3;6;3;6;9].

Compute reverse [true;true;true;false;false;false].

End ArrowType.

(* In the next module we change representation type from
   functional (R := A -> A) to inductive type with additional condition
   that we consider only those functions on lists that can be generated
   with the help of the function append.
*)

Module InductiveType.

Section Hughes.

Variable T : Type.

Definition A := list T.

Record R : Type
  := build { func : A -> A ; prop : exists x : A, func = app x }.

Definition rep (x : A) : R.
Proof.
  apply build with (app x).
  exists x; reflexivity.
Defined.

Check rep.

Print rep.

Definition abs (F : R) : A.
Proof.
  destruct F as [ f _ ].
  apply (f []).
Defined.

Check abs.

Print abs.

Theorem abs_rep :
  forall a : A,
  abs (rep a) = a.
Proof.
  unfold abs, rep.
  intros a.
  rewrite app_nil_r.
  reflexivity.
Qed.

Definition find_rep :
  forall F : R,
  { x : A | F = rep x }.
Proof.
  intros [ f Hf ].
  exists (f []).
  destruct Hf as [ x H ].
  subst f. unfold rep.
  rewrite app_nil_r.
  reflexivity.
Defined.

Theorem rep_abs :
  forall F : R,
  rep (abs F) = F.
Proof.
  intros F.
  destruct (find_rep F) as [ x H ].
  subst F. rewrite abs_rep.
  reflexivity.
Qed.

Theorem func_unique :
  forall F G : R,
  func F = func G -> F = G.
Proof.
  intros.
  rewrite <- (rep_abs F).
  rewrite <- (rep_abs G).
  destruct F as [ f [ x Hf ]].
  destruct G as [ g [ y Hg ]].
  simpl in *. rewrite H.
  reflexivity.
Qed.

Definition appendR (F G : R) : R.
Proof.
  destruct F as [ f Hf ].
  destruct G as [ g Hg ].
  exists (fun y => f (g y)).
  destruct Hf as [ F Hf ].
  destruct Hg as [ G Hg ].
  subst f. subst g.
  exists (app F G).
  apply functional_extensionality.
  intros x.
  rewrite app_assoc.
  reflexivity.
Defined.

Check appendR.

Print appendR.

Theorem appendR_rep :
  forall (a b : A),
  appendR (rep a) (rep b) = rep (a ++ b).
Proof.
  intros.
  apply func_unique. simpl.
  apply functional_extensionality.
  intros t. rewrite app_assoc. reflexivity.
Qed.

Theorem abs_appendR :
  forall (f g : R),
  abs (appendR f g) = (abs f) ++ (abs g).
Proof.
  intros.
  destruct (find_rep f) as [ F Hf ].
  destruct (find_rep g) as [ G Hg ].
  rewrite Hf. rewrite Hg. rewrite appendR_rep.
  unfold abs, rep; simpl.
  repeat rewrite app_nil_r.
  reflexivity.
Qed.

Definition rev (x : A) : R.
Proof.
  set (f := (fix rev (x : A) : A -> A :=
    match x with
    | [] => id
    | a :: y => fun (t : A) => rev y (a :: t)
    end)).
  exists (f x).
  exists ((f x) []).
  induction x.
  { simpl. reflexivity. }
  { simpl. rewrite IHx.
    apply functional_extensionality.
    intros t; simpl. rewrite <- app_assoc. reflexivity.
  }
Defined.

Definition reverse (x : A) := func (rev x) [].

Theorem rev_app :
  forall (x y : A),
  func (rev x) y = func (rev x) [] ++ y.
Proof.
  intros.
  induction y as [| h t ].
  { rewrite app_nil_r. reflexivity. }
  { assert (H1 : func (rev x) [] = abs (rev x)). reflexivity.
    assert (H2 : h :: t = abs (rep (h :: t))).
    { unfold abs, rep. rewrite app_nil_r. reflexivity. }
    rewrite H1. rewrite H2 at 2.
    rewrite <- abs_appendR.
    unfold appendR, abs, rep; simpl.
    rewrite app_nil_r. reflexivity.
  }
Qed.

Theorem rev_app_distr:
  forall (x y : A),
  reverse (x ++ y) = reverse y ++ reverse x.
Proof.
  intros.
  unfold reverse.
  induction x as [| h t ].
  { simpl. rewrite app_nil_r. reflexivity. }
  { replace (func (rev ((h :: t) ++ y)) []) with (func (rev (t ++ y)) [h]).
    replace (func (rev (h :: t)) []) with (func (rev t) [h]).
    rewrite (rev_app t [h]).
    rewrite rev_app.
    rewrite IHt.
    rewrite app_assoc.
    reflexivity.
    reflexivity.
    reflexivity.
  }
Qed.

Theorem app_length :
  forall x y : A,
  length (x ++ y) = length x + length y.
Proof.
  intros x y.
  induction x as [| h t ].
  { reflexivity. }
  { simpl. rewrite -> IHt. reflexivity. }
Qed.

Theorem reverse_length :
  forall x : A,
  length (reverse x) = length x.
Proof.
  intros x.
  unfold reverse.
  induction x as [| h t ].
  { reflexivity. }
  { assert (H : func (rev (h :: t)) [] = func (rev t) [] ++ [h]).
    { replace (func (rev (h :: t)) []) with (func (rev t) [h]).
      rewrite rev_app. reflexivity.
      reflexivity.
    }
    rewrite H.
    rewrite app_length.
    rewrite IHt.
    rewrite PeanoNat.Nat.add_comm.
    simpl. reflexivity.
  }
Qed.

Theorem reverse_involutive :
  forall x : A,
  reverse (reverse x) = x.
Proof.
  induction x.
  { reflexivity. }
  { simpl.
    replace (a :: x) with ([a] ++ x).
    { repeat rewrite rev_app_distr.
      rewrite IHx. reflexivity.
    }
    { reflexivity. }
  }
Qed.

Theorem rev_injective :
  forall (x y : A),
  reverse x = reverse y -> x = y.
Proof.
  intros x y reveq.
  rewrite <- reverse_involutive.
  rewrite <- reveq.
  rewrite -> reverse_involutive.
  reflexivity.
Qed.

End Hughes.

Compute reverse [2;3;6;3;6;9].

Compute reverse [true;true;true;false;false;false].

End InductiveType.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Permutation.v

    Defintion and properties of permutations
   **********************************************************************)
Require Export List.
Require Export ListAux.

Section permutation.
Variable A : Set.

(**************************************
   Definition of permutations as sequences of adjacent transpositions
 **************************************)

Inductive permutation : list A -> list A -> Prop :=
  | permutation_nil : permutation nil nil
  | permutation_skip :
      forall (a : A) (l1 l2 : list A),
      permutation l2 l1 -> permutation (a :: l2) (a :: l1)
  | permutation_swap :
      forall (a b : A) (l : list A), permutation (a :: b :: l) (b :: a :: l)
  | permutation_trans :
      forall l1 l2 l3 : list A,
      permutation l1 l2 -> permutation l2 l3 -> permutation l1 l3.
Hint Constructors permutation : core.

(**************************************
   Reflexivity
 **************************************)

Theorem permutation_refl : forall l : list A, permutation l l.
simple induction l.
apply permutation_nil.
intros a l1 H.
apply permutation_skip with (1 := H).
Qed.
Hint Resolve permutation_refl : core.

(**************************************
   Symmetry
   **************************************)

Theorem permutation_sym :
 forall l m : list A, permutation l m -> permutation m l.
intros l1 l2 H'; elim H'.
apply permutation_nil.
intros a l1' l2' H1 H2.
apply permutation_skip with (1 := H2).
intros a b l1'.
apply permutation_swap.
intros l1' l2' l3' H1 H2 H3 H4.
apply permutation_trans with (1 := H4) (2 := H2).
Qed.

(**************************************
   Compatibility with list length
   **************************************)

Theorem permutation_length :
 forall l m : list A, permutation l m -> length l = length m.
intros l m H'; elim H'; simpl in |- *; auto.
intros l1 l2 l3 H'0 H'1 H'2 H'3.
rewrite <- H'3; auto.
Qed.

(**************************************
   A permutation of the nil list is the nil list
   **************************************)

Theorem permutation_nil_inv : forall l : list A, permutation l nil -> l = nil.
intros l H; generalize (permutation_length _ _ H); case l; simpl in |- *;
 auto.
intros; discriminate.
Qed.

(**************************************
   A permutation of the singleton list is the singleton list
   **************************************)

Let permutation_one_inv_aux :
  forall l1 l2 : list A,
  permutation l1 l2 -> forall a : A, l1 = a :: nil -> l2 = a :: nil.
intros l1 l2 H; elim H; clear H l1 l2; auto.
intros a l3 l4 H0 H1 b H2.
injection H2; intros; subst; auto.
rewrite (permutation_nil_inv _ (permutation_sym _ _ H0)); auto.
intros; discriminate.
Qed.

Theorem permutation_one_inv :
 forall (a : A) (l : list A), permutation (a :: nil) l -> l = a :: nil.
intros a l H; apply permutation_one_inv_aux with (l1 := a :: nil); auto.
Qed.

(**************************************
   Compatibility with the belonging
   **************************************)

Theorem permutation_in :
 forall (a : A) (l m : list A), permutation l m -> In a l -> In a m.
intros a l m H; elim H; simpl in |- *; auto; intuition.
Qed.

(**************************************
   Compatibility with the append function
   **************************************)

Theorem permutation_app_comp :
 forall l1 l2 l3 l4,
 permutation l1 l2 -> permutation l3 l4 -> permutation (l1 ++ l3) (l2 ++ l4).
intros l1 l2 l3 l4 H1; generalize l3 l4; elim H1; clear H1 l1 l2 l3 l4;
 simpl in |- *; auto.
intros a b l l3 l4 H.
cut (permutation (l ++ l3) (l ++ l4)); auto.
intros; apply permutation_trans with (a :: b :: l ++ l4); auto.
elim l; simpl in |- *; auto.
intros l1 l2 l3 H H0 H1 H2 l4 l5 H3.
apply permutation_trans with (l2 ++ l4); auto.
Qed.
Hint Resolve permutation_app_comp : core.

(**************************************
   Swap two sublists
   **************************************)

Theorem permutation_app_swap :
 forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1).
intros l1; elim l1; auto.
intros; rewrite <- app_nil_end; auto.
intros a l H l2.
replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l).
apply permutation_trans with (l ++ l2 ++ a :: nil); auto.
apply permutation_trans with (((a :: nil) ++ l2) ++ l); auto.
simpl in |- *; auto.
apply permutation_trans with (l ++ (a :: nil) ++ l2); auto.
apply permutation_sym; auto.
replace (l2 ++ a :: l) with ((l2 ++ a :: nil) ++ l).
apply permutation_app_comp; auto.
elim l2; simpl in |- *; auto.
intros a0 l0 H0.
apply permutation_trans with (a0 :: a :: l0); auto.
apply (app_ass l2 (a :: nil) l).
apply (app_ass l2 (a :: nil) l).
Qed.

(**************************************
   A transposition is a permutation
   **************************************)

Theorem permutation_transposition :
 forall a b l1 l2 l3,
 permutation (l1 ++ a :: l2 ++ b :: l3) (l1 ++ b :: l2 ++ a :: l3).
intros a b l1 l2 l3.
apply permutation_app_comp; auto.
change
  (permutation ((a :: nil) ++ l2 ++ (b :: nil) ++ l3)
     ((b :: nil) ++ l2 ++ (a :: nil) ++ l3)) in |- *.
repeat rewrite <- app_ass.
apply permutation_app_comp; auto.
apply permutation_trans with ((b :: nil) ++ (a :: nil) ++ l2); auto.
apply permutation_app_swap; auto.
repeat rewrite app_ass.
apply permutation_app_comp; auto.
apply permutation_app_swap; auto.
Qed.

(**************************************
   An element of a list can be put on top of the list to get a permutation
   **************************************)

Theorem in_permutation_ex :
 forall a l, In a l -> exists l1 : list A, permutation (a :: l1) l.
intros a l; elim l; simpl in |- *; auto.
intros H; case H; auto.
intros a0 l0 H [H0| H0].
exists l0; rewrite H0; auto.
case H; auto; intros l1 Hl1; exists (a0 :: l1).
apply permutation_trans with (a0 :: a :: l1); auto.
Qed.

(**************************************
   A permutation of a cons can be inverted
   **************************************)

Let permutation_cons_ex_aux :
  forall (a : A) (l1 l2 : list A),
  permutation l1 l2 ->
  forall l11 l12 : list A,
  l1 = l11 ++ a :: l12 ->
  exists l3 : list A,
    (exists l4 : list A,
       l2 = l3 ++ a :: l4 /\ permutation (l11 ++ l12) (l3 ++ l4)).
intros a l1 l2 H; elim H; clear H l1 l2.
intros l11 l12; case l11; simpl in |- *; intros; discriminate.
intros a0 l1 l2 H H0 l11 l12; case l11; simpl in |- *.
exists (nil (A:=A)); exists l1; simpl in |- *; split; auto.
injection H1; intros; subst; auto.
injection H1; intros H2 H3; rewrite <- H2; auto.
intros a1 l111 H1.
case (H0 l111 l12); auto.
injection H1; auto.
intros l3 (l4, (Hl1, Hl2)).
exists (a0 :: l3); exists l4; split; simpl in |- *; auto.
injection H1; intros; subst; auto.
injection H1; intros H2 H3; rewrite H3; auto.
intros a0 b l l11 l12; case l11; simpl in |- *.
case l12; try (intros; discriminate).
intros a1 l0 H; exists (b :: nil); exists l0; simpl in |- *; split; auto.
injection H; intros; subst; auto.
injection H; intros H1 H2 H3; rewrite H2; auto.
intros a1 l111; case l111; simpl in |- *.
intros H; exists (nil (A:=A)); exists (a0 :: l12); simpl in |- *; split; auto.
injection H; intros; subst; auto.
injection H; intros H1 H2 H3; rewrite H3; auto.
intros a2 H1111 H; exists (a2 :: a1 :: H1111); exists l12; simpl in |- *;
 split; auto.
injection H; intros; subst; auto.
intros l1 l2 l3 H H0 H1 H2 l11 l12 H3.
case H0 with (1 := H3).
intros l4 (l5, (Hl1, Hl2)).
case H2 with (1 := Hl1).
intros l6 (l7, (Hl3, Hl4)).
exists l6; exists l7; split; auto.
apply permutation_trans with (1 := Hl2); auto.
Qed.

Theorem permutation_cons_ex :
 forall (a : A) (l1 l2 : list A),
 permutation (a :: l1) l2 ->
 exists l3 : list A,
   (exists l4 : list A, l2 = l3 ++ a :: l4 /\ permutation l1 (l3 ++ l4)).
intros a l1 l2 H.
apply (permutation_cons_ex_aux a (a :: l1) l2 H nil l1); simpl in |- *; auto.
Qed.

(**************************************
   A permutation can be simply inverted if the two list starts with a cons
   **************************************)

Theorem permutation_inv :
 forall (a : A) (l1 l2 : list A),
 permutation (a :: l1) (a :: l2) -> permutation l1 l2.
intros a l1 l2 H; case permutation_cons_ex with (1 := H).
intros l3 (l4, (Hl1, Hl2)).
apply permutation_trans with (1 := Hl2).
generalize Hl1; case l3; simpl in |- *; auto.
intros H1; injection H1; intros H2; rewrite H2; auto.
intros a0 l5 H1; injection H1; intros H2 H3; rewrite H2; rewrite H3; auto.
apply permutation_trans with (a0 :: l4 ++ l5); auto.
apply permutation_skip; apply permutation_app_swap.
apply (permutation_app_swap (a0 :: l4) l5).
Qed.

(**************************************
   Take a list and return tle list of all pairs of an element of the
   list and the remaining list
   **************************************)

Fixpoint split_one (l : list A) : list (A * list A) :=
  match l with
  | nil => nil (A:=A * list A)
  | a :: l1 =>
      (a, l1)
      :: map (fun p : A * list A => (fst p, a :: snd p)) (split_one l1)
  end.

(**************************************
   The pairs of the list are a permutation
   **************************************)

Theorem split_one_permutation :
 forall (a : A) (l1 l2 : list A),
 In (a, l1) (split_one l2) -> permutation (a :: l1) l2.
intros a l1 l2; generalize a l1; elim l2; clear a l1 l2; simpl in |- *; auto.
intros a l1 H1; case H1.
intros a l H a0 l1 [H0| H0].
injection H0; intros H1 H2; rewrite H2; rewrite H1; auto.
generalize H H0; elim (split_one l); simpl in |- *; auto.
intros H1 H2; case H2.
intros a1 l0 H1 H2 [H3| H3]; auto.
injection H3; intros H4 H5; (rewrite <- H4; rewrite <- H5).
apply permutation_trans with (a :: fst a1 :: snd a1); auto.
apply permutation_skip.
apply H2; auto.
case a1; simpl in |- *; auto.
Qed.

(**************************************
   All elements of the list are there
   **************************************)

Theorem split_one_in_ex :
 forall (a : A) (l1 : list A),
 In a l1 -> exists l2 : list A, In (a, l2) (split_one l1).
intros a l1; elim l1; simpl in |- *; auto.
intros H; case H.
intros a0 l H [H0| H0]; auto.
exists l; left; subst; auto.
case H; auto.
intros x H1; exists (a0 :: x); right; auto.
apply
 (in_map (fun p : A * list A => (fst p, a0 :: snd p)) (split_one l) (a, x));
 auto.
Qed.

(**************************************
   An auxillary function to generate all permutations
   **************************************)

Fixpoint all_permutations_aux (l : list A) (n : nat) {struct n} :
 list (list A) :=
  match n with
  | O => nil :: nil
  | S n1 =>
      flat_map
        (fun p : A * list A =>
         map (cons (fst p)) (all_permutations_aux (snd p) n1)) (
        split_one l)
  end.
(**************************************
   Generate all the permutations
   **************************************)

Definition all_permutations (l : list A) := all_permutations_aux l (length l).

(**************************************
   All the elements of the list are permutations
   **************************************)

Let all_permutations_aux_permutation :
  forall (n : nat) (l1 l2 : list A),
  n = length l2 -> In l1 (all_permutations_aux l2 n) -> permutation l1 l2.
intros n; elim n; simpl in |- *; auto.
intros l1 l2; case l2.
simpl in |- *; intros H0 [H1| H1].
rewrite <- H1; auto.
case H1.
simpl in |- *; intros; discriminate.
intros n0 H l1 l2 H0 H1.
case in_flat_map_ex with (1 := H1).
clear H1; intros x; case x; clear x; intros a1 l3 (H1, H2).
case in_map_inv with (1 := H2).
simpl in |- *; intros y (H3, H4).
rewrite H4; auto.
apply permutation_trans with (a1 :: l3); auto.
apply permutation_skip; auto.
apply H with (2 := H3).
apply eq_add_S.
apply trans_equal with (1 := H0).
change (length l2 = length (a1 :: l3)) in |- *.
apply permutation_length; auto.
apply permutation_sym; apply split_one_permutation; auto.
apply split_one_permutation; auto.
Qed.

Theorem all_permutations_permutation :
 forall l1 l2 : list A, In l1 (all_permutations l2) -> permutation l1 l2.
intros l1 l2 H; apply all_permutations_aux_permutation with (n := length l2);
 auto.
Qed.

(**************************************
   A permutation is in the list
   **************************************)

Let permutation_all_permutations_aux :
  forall (n : nat) (l1 l2 : list A),
  n = length l2 -> permutation l1 l2 -> In l1 (all_permutations_aux l2 n).
intros n; elim n; simpl in |- *; auto.
intros l1 l2; case l2.
intros H H0; rewrite permutation_nil_inv with (1 := H0); auto with datatypes.
simpl in |- *; intros; discriminate.
intros n0 H l1; case l1.
intros l2 H0 H1;
 rewrite permutation_nil_inv with (1 := permutation_sym _ _ H1) in H0;
 discriminate.
clear l1; intros a1 l1 l2 H1 H2.
case (split_one_in_ex a1 l2); auto.
apply permutation_in with (1 := H2); auto with datatypes.
intros x H0.
apply in_flat_map with (b := (a1, x)); auto.
apply in_map; simpl in |- *.
apply H; auto.
apply eq_add_S.
apply trans_equal with (1 := H1).
change (length l2 = length (a1 :: x)) in |- *.
apply permutation_length; auto.
apply permutation_sym; apply split_one_permutation; auto.
apply permutation_inv with (a := a1).
apply permutation_trans with (1 := H2).
apply permutation_sym; apply split_one_permutation; auto.
Qed.

Theorem permutation_all_permutations :
 forall l1 l2 : list A, permutation l1 l2 -> In l1 (all_permutations l2).
intros l1 l2 H; unfold all_permutations in |- *;
 apply permutation_all_permutations_aux; auto.
Qed.

(**************************************
   Permutation is decidable
   **************************************)

Definition permutation_dec :
  (forall a b : A, {a = b} + {a <> b}) ->
  forall l1 l2 : list A, {permutation l1 l2} + {~ permutation l1 l2}.
intros H l1 l2.
case (In_dec (list_eq_dec H) l1 (all_permutations l2)).
intros i; left; apply all_permutations_permutation; auto.
intros i; right; contradict i; apply permutation_all_permutations; auto.
Defined.

End permutation.

(**************************************
   Hints
   **************************************)

Global Hint Constructors permutation : core.
Global Hint Resolve permutation_refl : core.
Global Hint Resolve permutation_app_comp : core.
Global Hint Resolve permutation_app_swap : core.

(**************************************
   Implicits
   **************************************)

Arguments permutation [A] _ _.
Arguments split_one [A] _.
Arguments all_permutations [A] _.
Arguments permutation_dec [A].

(**************************************
   Permutation is compatible with map
   **************************************)

Theorem permutation_map :
 forall (A B : Set) (f : A -> B) l1 l2,
 permutation l1 l2 -> permutation (map f l1) (map f l2).
intros A B f l1 l2 H; elim H; simpl in |- *; auto.
intros l0 l3 l4 H0 H1 H2 H3; apply permutation_trans with (2 := H3); auto.
Qed.
Global Hint Resolve permutation_map : core.

(**************************************
  Permutation  of a map can be inverted
  *************************************)

Local Definition permutation_map_ex_aux :
  forall (A B : Set) (f : A -> B) l1 l2 l3,
  permutation l1 l2 ->
  l1 = map f l3 -> exists l4, permutation l4 l3 /\ l2 = map f l4.
intros A1 B1 f l1 l2 l3 H; generalize l3; elim H; clear H l1 l2 l3.
intros l3; case l3; simpl in |- *; auto.
intros H; exists (nil (A:=A1)); auto.
intros; discriminate.
intros a0 l1 l2 H H0 l3; case l3; simpl in |- *; auto.
intros; discriminate.
intros a1 l H1; case (H0 l); auto.
injection H1; auto.
intros l5 (H2, H3); exists (a1 :: l5); split; simpl in |- *; auto.
injection H1; intros; subst; auto.
intros a0 b l l3; case l3.
intros; discriminate.
intros a1 l0; case l0; simpl in |- *.
intros; discriminate.
intros a2 l1 H; exists (a2 :: a1 :: l1); split; simpl in |- *; auto.
injection H; intros; subst; auto.
intros l1 l2 l3 H H0 H1 H2 l0 H3.
case H0 with (1 := H3); auto.
intros l4 (HH1, HH2).
case H2 with (1 := HH2); auto.
intros l5 (HH3, HH4); exists l5; split; auto.
apply permutation_trans with (1 := HH3); auto.
Qed.

Theorem permutation_map_ex :
 forall (A B : Set) (f : A -> B) l1 l2,
 permutation (map f l1) l2 ->
 exists l3, permutation l3 l1 /\ l2 = map f l3.
intros A0 B f l1 l2 H; apply permutation_map_ex_aux with (l1 := map f l1);
 auto.
Qed.

(**************************************
   Permutation is compatible with flat_map
 **************************************)

Theorem permutation_flat_map :
 forall (A B : Set) (f : A -> list B) l1 l2,
 permutation l1 l2 -> permutation (flat_map f l1) (flat_map f l2).
intros A B f l1 l2 H; elim H; simpl in |- *; auto.
intros a b l; auto.
repeat rewrite <- app_ass.
apply permutation_app_comp; auto.
intros k3 l4 l5 H0 H1 H2 H3; apply permutation_trans with (1 := H1); auto.
Qed.


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

(** Extraction of breadth-first numbering algorithm from Coq to Ocaml

       see http://okasaki.blogspot.com/2008/07/breadth-first-numbering-algorithm-in.html
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/jfp95queue.pdf
       and https://www.cs.cmu.edu/~rwh/theses/okasaki.pdf
       and https://www.westpoint.edu/eecs/SiteAssets/SitePages/Faculty%20Publication%20Documents/Okasaki/icfp00bfn.pdf

*)

Require Import List Arith Omega Wellfounded.
Require Import list_utils wf_utils bt bft.

Set Implicit Arguments.

Implicit Types (a n x: nat).

Section seq_an.

  (* seq_an a n = [a;a+1;...;a+(n-1)] *)

  Fixpoint seq_an a n: list nat :=
    match n with
      | 0    => nil
      | S n  => a::seq_an (S a) n
    end.

  Fact seq_an_length a n : length (seq_an a n) = n.
  Proof. revert a; induction n; simpl; intros; f_equal; auto. Qed.

  Fact seq_an_spec a n x : In x (seq_an a n) <-> a <= x < a+n.
  Proof.
    revert x a; induction n as [ | n IHn ]; intros x a; simpl;
      [ | rewrite IHn ]; omega.
  Qed.

  Fixpoint is_seq_from n (l: list nat) { struct l }: Prop :=
    match l with
      | nil  => True
      | x::l => n=x /\ is_seq_from (S n) l
    end.

  Theorem is_seq_from_spec a (l: list nat): is_seq_from a l <-> exists n, l = seq_an a n.
  Proof.
    revert a; induction l as [ | x l IH ]; intros a; simpl.
    + split; auto; exists 0; auto.
    + rewrite IH; split.
      * intros (? & n & Hn); subst x; exists (S n); subst; auto.
      * intros ([ | n ] & ?); subst; try discriminate.
        simpl in H; inversion H; subst; split; auto.
        exists n; auto.
  Qed.

End seq_an.

(** Of course, this needs to be replaced by a queue to obtain something efficient *)

Definition list_snoc_match (X: Type) (l: list X) : 2 <= length l -> { x : X & { y : _ & { m | l = m++y::x::nil } } }.
Proof.
  rewrite <- (rev_involutive l), rev_length.
  destruct (rev l) as [ | x [ | y l' ] ]; simpl; try omega; intros _.
  exists x, y, (rev l'); rewrite app_ass; simpl; auto.
Defined.

Section bfn.

  Variable (X : Type).

  Implicit Types (t : bt X) (l: list(bt X)).

  (* the forest (list of bt nat) is a breadth first numbering from n if
     its breadth first traversal yields [n;n+1;....;m[ for some m
   *)

  Definition is_bfn_from n (l: list (bt nat)): Prop := is_seq_from n (bft_f l).

  (* Breadth First Numbering: maps a forest X to a forest nat such that
          1) the two forests are of the same shape
          2) the result is a breadth first numbering from n
   *)

  Definition bfn_f n l : { m | l ~lt m /\ is_bfn_from n m }.
  Proof.
    induction on n l as bfn_f with measure (lsum l).
    refine (match l as l' return l = l' -> _ with
      | nil              => fun H => exist _ nil _
      | leaf x :: ll     => fun H => let (mm,Hm) := bfn_f (S n) ll _ in exist _ (leaf n::mm) _
      | node a x b :: ll => fun H => let (mm,Hmm) := bfn_f (S n) (ll++a::b::nil) _ in
                                     match list_snoc_match mm _ with
                                       | existT _ v (existT _ u (exist _ m Hm)) => exist _ (node u n v::m) _
                                     end
    end eq_refl).
    1,2,4,5: cycle 1.

    + subst; simpl; auto.
    + subst; simpl; rewrite lsum_app; simpl; omega.

    + apply proj1, Forall2_length in Hmm.
      rewrite <- Hmm, app_length; simpl; omega.
    + subst; split.
      * constructor.
      * red; rewrite bft_f_fix_0; simpl; auto.
    + destruct Hm as (H1 & H2).
      subst; split; auto.
      red in H2 |- *; rewrite bft_f_fix_3.
      simpl; rewrite <- app_nil_end; auto.
    + subst; destruct Hmm as (H1 & H2).
      Forall2 inv H1 as H3.
      * Forall2 inv H1 as H4.
        Forall2 inv H1 as H5.
        split; auto.
        red in H2 |- *.
        rewrite bft_f_fix_3; simpl; auto.
      * apply Forall2_length in H1.
        do 2 rewrite app_length in H1; simpl in H1; omega.
  Defined.

  Section bfn.

    Let bfn_full t : { t' | t ~t t' /\ is_seq_from 0 (bft_std t') }.
    Proof.
      refine (match @bfn_f 0 (t::nil) with
        | exist _ l Hl      =>
        match l as l' return l = l' -> _ with
          | nil   => fun E => _
          | t'::l => fun E => exist _ t' _
        end eq_refl
      end); simpl in *.
      + exfalso; subst; apply proj1 in Hl; inversion Hl.
      + subst; destruct Hl as (H1 & H2).
        Forall2 inv H1 as H3.
        Forall2 inv H1 as H1.
        subst; split; auto.
        red in H2.
        rewrite <- bft_std_eq_bft; auto.
    Qed.

    Definition bfn t := proj1_sig (bfn_full t).

    Fact bfn_spec_1 t : t ~t bfn t.
    Proof. apply (proj2_sig (bfn_full t)). Qed.

    Fact bfn_spec_2 t : exists n, bft_std (bfn t) = seq_an 0 n.
    Proof. apply is_seq_from_spec, (proj2_sig (bfn_full t)). Qed.

  End bfn.

End bfn.

Recursive Extraction bfn.

Check bfn.
Check bfn_spec_1.
Check bfn_spec_2.


Require Import Coq.Arith.Div2.
Require Import Coq.micromega.Lia.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import bbv.N_Z_nat_conversions.
Require Export bbv.Nomega.

Set Implicit Arguments.

Fixpoint mod2 (n : nat) : bool :=
  match n with
    | 0 => false
    | 1 => true
    | S (S n') => mod2 n'
  end.

Ltac rethink :=
  match goal with
    | [ H : ?f ?n = _ |- ?f ?m = _ ] => replace m with n; simpl; auto
  end.

Theorem mod2_S_double : forall n, mod2 (S (2 * n)) = true.
  induction n; simpl; intuition; rethink.
Qed.

Theorem mod2_double : forall n, mod2 (2 * n) = false.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; rethink.
Qed.

Theorem div2_double : forall n, div2 (2 * n) = n.
  induction n; simpl; intuition; rewrite <- plus_n_Sm; f_equal; rethink.
Qed.

Theorem div2_S_double : forall n, div2 (S (2 * n)) = n.
  induction n; simpl; intuition; f_equal; rethink.
Qed.

Notation pow2 := (Nat.pow 2).

Fixpoint Npow2 (n : nat) : N :=
  match n with
    | O => 1
    | S n' => 2 * Npow2 n'
  end%N.

Theorem untimes2 : forall n, n + (n + 0) = 2 * n.
  auto.
Qed.

Section strong.
  Variable P : nat -> Prop.

  Hypothesis PH : forall n, (forall m, m < n -> P m) -> P n.

  Lemma strong' : forall n m, m <= n -> P m.
    induction n; simpl; intuition; apply PH; intuition.
    elimtype False; lia.
  Qed.

  Theorem strong : forall n, P n.
    intros; eapply strong'; eauto.
  Qed.
End strong.

Theorem div2_odd : forall n,
  mod2 n = true
  -> n = S (2 * div2 n).
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *.
    discriminate.
  destruct n as [|n]; simpl in *; intuition.
  do 2 f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem div2_even : forall n,
  mod2 n = false
  -> n = 2 * div2 n.
  induction n as [n] using strong; simpl; intuition.

  destruct n as [|n]; simpl in *; intuition.
  destruct n as [|n]; simpl in *.
    discriminate.
  f_equal.
  replace (div2 n + S (div2 n + 0)) with (S (div2 n + (div2 n + 0))); auto.
Qed.

Theorem drop_mod2 : forall n k,
  2 * k <= n
  -> mod2 (n - 2 * k) = mod2 n.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; repeat rewrite untimes2 in *; intuition).

  destruct k; simpl in *; intuition.

  destruct k; simpl; intuition.
  rewrite <- plus_n_Sm.
  repeat rewrite untimes2 in *.
  simpl; auto.
  apply H; lia.
Qed.

Theorem div2_minus_2 : forall n k,
  2 * k <= n
  -> div2 (n - 2 * k) = div2 n - k.
  induction n as [n] using strong; intros.

  do 2 (destruct n; simpl in *; intuition; repeat rewrite untimes2 in *).
  destruct k; simpl in *; intuition.

  destruct k; simpl in *; intuition.
  rewrite <- plus_n_Sm.
  apply H; lia.
Qed.

Theorem div2_bound : forall k n,
  2 * k <= n
  -> k <= div2 n.
  intros ? n H; case_eq (mod2 n); intro Heq.

  rewrite (div2_odd _ Heq) in H.
  lia.

  rewrite (div2_even _ Heq) in H.
  lia.
Qed.

Lemma two_times_div2_bound: forall n, 2 * Nat.div2 n <= n.
Proof.
  eapply strong. intros n IH.
  destruct n.
  - constructor.
  - destruct n.
    + simpl. constructor. constructor.
    + simpl (Nat.div2 (S (S n))).
      specialize (IH n). lia.
Qed.

Lemma div2_compat_lt_l: forall a b, b < 2 * a -> Nat.div2 b < a.
Proof.
  induction a; intros.
  - lia.
  - destruct b.
    + simpl. lia.
    + destruct b.
      * simpl. lia.
      * simpl. apply lt_n_S. apply IHa. lia.
Qed.

(* otherwise b is made implicit, while a isn't, which is weird *)
Arguments div2_compat_lt_l {_} {_} _.

Lemma pow2_add_mul: forall a b,
  pow2 (a + b) = (pow2 a) * (pow2 b).
Proof.
  induction a; destruct b; firstorder auto with arith; simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_1_r; auto.
  repeat rewrite Nat.add_0_r.
  rewrite IHa.
  simpl.
  repeat rewrite Nat.add_0_r.
  rewrite Nat.mul_add_distr_r; auto.
Qed.

Lemma mult_pow2_bound: forall a b x y,
  x < pow2 a -> y < pow2 b -> x * y < pow2 (a + b).
Proof.
  intros.
  rewrite pow2_add_mul.
  apply Nat.mul_lt_mono_nonneg; lia.
Qed.

Lemma mult_pow2_bound_ex: forall a c x y,
  x < pow2 a -> y < pow2 (c - a) -> c >= a -> x * y < pow2 c.
Proof.
  intros.
  replace c with (a + (c - a)) by lia.
  apply mult_pow2_bound; auto.
Qed.

Lemma lt_mul_mono' : forall c a b,
  a < b -> a < b * (S c).
Proof.
  induction c; intros.
  rewrite Nat.mul_1_r; auto.
  rewrite Nat.mul_succ_r.
  apply lt_plus_trans.
  apply IHc; auto.
Qed.

Lemma lt_mul_mono : forall a b c,
  c <> 0 -> a < b -> a < b * c.
Proof.
  intros.
  replace c with (S (c - 1)) by lia.
  apply lt_mul_mono'; auto.
Qed.

Lemma zero_lt_pow2 : forall sz, 0 < pow2 sz.
Proof.
  induction sz; simpl; lia.
Qed.

Lemma one_lt_pow2:
  forall n,
    1 < pow2 (S n).
Proof.
  intros.
  induction n.
  simpl; lia.
  remember (S n); simpl.
  lia.
Qed.

Lemma one_le_pow2 : forall sz, 1 <= pow2 sz.
Proof.
  intros. pose proof (zero_lt_pow2 sz). lia.
Qed.

Lemma pow2_ne_zero: forall n, pow2 n <> 0.
Proof.
  intros.
  pose proof (zero_lt_pow2 n).
  lia.
Qed.

Lemma mul2_add : forall n, n * 2 = n + n.
Proof.
  induction n; firstorder auto with zarith.
Qed.

Lemma pow2_le_S : forall sz, (pow2 sz) + 1 <= pow2 (sz + 1).
Proof.
  induction sz; simpl; auto.
  repeat rewrite Nat.add_0_r.
  rewrite pow2_add_mul.
  repeat rewrite mul2_add.
  pose proof (zero_lt_pow2 sz).
  lia.
Qed.

Lemma pow2_bound_mono: forall a b x,
  x < pow2 a -> a <= b -> x < pow2 b.
Proof.
  intros.
  replace b with (a + (b - a)) by lia.
  rewrite pow2_add_mul.
  apply lt_mul_mono; auto.
  pose proof (zero_lt_pow2 (b - a)).
  lia.
Qed.

Lemma pow2_inc : forall n m, n < m -> pow2 n < pow2 m.
Proof.
  intros n m; revert n; induction m as [|m IH]; intros n nLm; [lia|].
  destruct n; [now apply one_lt_pow2|].
  assert (H : pow2 n < pow2 m) by (apply IH; lia).
  simpl; lia.
Qed.

Lemma pow2_S: forall x, pow2 (S x) = 2 * pow2 x.
Proof. intros. reflexivity. Qed.

Lemma mod2_S_S : forall n,
  mod2 (S (S n)) = mod2 n.
Proof.
  intros.
  destruct n; auto; destruct n; auto.
Qed.

Lemma mod2_S_not : forall n,
  mod2 (S n) = if (mod2 n) then false else true.
Proof.
  intros.
  induction n; auto.
  rewrite mod2_S_S.
  destruct (mod2 n); replace (mod2 (S n)); auto.
Qed.

Lemma mod2_S_eq : forall n k,
  mod2 n = mod2 k ->
  mod2 (S n) = mod2 (S k).
Proof.
  intros.
  do 2 rewrite mod2_S_not.
  rewrite H.
  auto.
Qed.

Theorem drop_mod2_add : forall n k,
  mod2 (n + 2 * k) = mod2 n.
Proof.
  intros.
  induction n.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by lia.
  apply mod2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by lia.
  apply mod2_S_eq; auto.
Qed.

Lemma mod2sub: forall a b,
  b <= a ->
  mod2 (a - b) = xorb (mod2 a) (mod2 b).
Proof.
  intros. remember (a - b) as c. revert dependent b. revert a. revert c.
  change (forall c,
    (fun c => forall a b, b <= a -> c = a - b -> mod2 c = xorb (mod2 a) (mod2 b)) c).
  apply strong.
  intros c IH a b AB N.
  destruct c.
  - assert (a=b) by lia. subst. rewrite Bool.xorb_nilpotent. reflexivity.
  - destruct c.
    + assert (a = S b) by lia. subst a. simpl (mod2 1). rewrite mod2_S_not.
      destruct (mod2 b); reflexivity.
    + destruct a; [lia|].
      destruct a; [lia|].
      simpl.
      apply IH; lia.
Qed.

Theorem mod2_pow2_twice: forall n,
  mod2 (pow2 n + (pow2 n + 0)) = false.
Proof.
  intros.
  replace (pow2 n + (pow2 n + 0)) with (2 * pow2 n) by lia.
  apply mod2_double.
Qed.

Theorem div2_plus_2 : forall n k,
  div2 (n + 2 * k) = div2 n + k.
Proof.
  induction n; intros.
  simpl.
  rewrite Nat.add_0_r.
  replace (k + k) with (2 * k) by lia.
  apply div2_double.
  replace (S n + 2 * k) with (S (n + 2 * k)) by lia.
  destruct (Even.even_or_odd n).
  - rewrite <- even_div2.
    rewrite <- even_div2 by auto.
    apply IHn.
    apply Even.even_even_plus; auto.
    apply Even.even_mult_l; repeat constructor.

  - rewrite <- odd_div2.
    rewrite <- odd_div2 by auto.
    rewrite IHn.
    lia.
    apply Even.odd_plus_l; auto.
    apply Even.even_mult_l; repeat constructor.
Qed.

Lemma pred_add:
  forall n, n <> 0 -> pred n + 1 = n.
Proof.
  intros; rewrite pred_of_minus; lia.
Qed.

Lemma pow2_zero: forall sz, (pow2 sz > 0)%nat.
Proof.
  induction sz; simpl; auto; lia.
Qed.

Theorem Npow2_nat : forall n, nat_of_N (Npow2 n) = pow2 n.
  induction n as [|n IHn]; simpl; intuition.
  rewrite <- IHn; clear IHn.
  case_eq (Npow2 n); intuition; zify; intuition.
Qed.

Theorem pow2_N : forall n, Npow2 n = N.of_nat (pow2 n).
Proof.
  intro n. apply nat_of_N_eq. rewrite Nat2N.id. apply Npow2_nat.
Qed.

Lemma Z_of_N_Npow2: forall n, Z.of_N (Npow2 n) = (2 ^ Z.of_nat n)%Z.
Proof.
  intros.
  rewrite pow2_N.
  rewrite nat_N_Z.
  rewrite Nat2Z.inj_pow.
  reflexivity.
Qed.

Lemma pow2_S_z:
  forall n, Z.of_nat (pow2 (S n)) = (2 * Z.of_nat (pow2 n))%Z.
Proof.
  intros.
  replace (2 * Z.of_nat (pow2 n))%Z with
      (Z.of_nat (pow2 n) + Z.of_nat (pow2 n))%Z by lia.
  simpl.
  repeat rewrite Nat2Z.inj_add.
  ring.
Qed.

Lemma pow2_le:
  forall n m, (n <= m)%nat -> (pow2 n <= pow2 m)%nat.
Proof.
  intros.
  assert (exists s, n + s = m) by (exists (m - n); lia).
  destruct H0; subst.
  rewrite pow2_add_mul.
  pose proof (pow2_zero x).
  replace (pow2 n) with (pow2 n * 1) at 1 by lia.
  apply mult_le_compat_l.
  lia.
Qed.

Lemma Zabs_of_nat:
  forall n, Z.abs (Z.of_nat n) = Z.of_nat n.
Proof.
  unfold Z.of_nat; intros.
  destruct n; auto.
Qed.

Lemma Npow2_not_zero:
  forall n, Npow2 n <> 0%N.
Proof.
  induction n; simpl; intros; [discriminate|].
  destruct (Npow2 n); auto.
  discriminate.
Qed.

Lemma Npow2_S:
  forall n, Npow2 (S n) = (Npow2 n + Npow2 n)%N.
Proof.
  simpl; intros.
  destruct (Npow2 n); auto.
  rewrite <-Pos.add_diag.
  reflexivity.
Qed.

Lemma Npow2_pos: forall a,
    (0 < Npow2 a)%N.
Proof.
  intros.
  destruct (Npow2 a) eqn: E.
  - exfalso. apply (Npow2_not_zero a). assumption.
  - constructor.
Qed.

Lemma minus_minus: forall a b c,
  c <= b <= a ->
  a - (b - c) = a - b + c.
Proof. intros. lia. Qed.

Lemma even_odd_destruct: forall n,
  (exists a, n = 2 * a) \/ (exists a, n = 2 * a + 1).
Proof.
  induction n.
  - left. exists 0. reflexivity.
  - destruct IHn as [[a E] | [a E]].
    + right. exists a. lia.
    + left. exists (S a). lia.
Qed.

Lemma mul_div_undo: forall i c,
    c <> 0 ->
    c * i / c = i.
Proof.
  intros.
  pose proof (Nat.div_mul_cancel_l i 1 c) as P.
  rewrite Nat.div_1_r in P.
  rewrite Nat.mul_1_r in P.
  apply P; auto.
Qed.

Lemma mod_add_r: forall a b,
    b <> 0 ->
    (a + b) mod b = a mod b.
Proof.
  intros. rewrite <- Nat.add_mod_idemp_r by lia.
  rewrite Nat.mod_same by lia.
  rewrite Nat.add_0_r.
  reflexivity.
Qed.

Lemma mod2_cases: forall (n: nat), n mod 2 = 0 \/ n mod 2 = 1.
Proof.
  intros.
  assert (n mod 2 < 2). {
    apply Nat.mod_upper_bound. congruence.
  }
  lia.
Qed.

Lemma div_mul_undo: forall a b,
    b <> 0 ->
    a mod b = 0 ->
    a / b * b = a.
Proof.
  intros.
  pose proof Nat.div_mul_cancel_l as A. specialize (A a 1 b).
  replace (b * 1) with b in A by lia.
  rewrite Nat.div_1_r in A.
  rewrite mult_comm.
  rewrite <- Nat.divide_div_mul_exact; try assumption.
  - apply A; congruence.
  - apply Nat.mod_divide; assumption.
Qed.

Lemma Smod2_1: forall k, S k mod 2 = 1 -> k mod 2 = 0.
Proof.
  intros k C.
  change (S k) with (1 + k) in C.
  rewrite Nat.add_mod in C by congruence.
  pose proof (Nat.mod_upper_bound k 2).
  assert (k mod 2 = 0 \/ k mod 2 = 1) as E by lia.
  destruct E as [E | E]; [assumption|].
  rewrite E in C. simpl in C. discriminate.
Qed.

Lemma mod_0_r: forall (m: nat),
    m mod 0 = match (1 mod 0) with | 0 => 0 | _ => m end.
Proof.
  intros. reflexivity.
Qed.

Lemma sub_mod_0: forall (a b m: nat),
    a mod m = 0 ->
    b mod m = 0 ->
    (a - b) mod m = 0.
Proof.
  intros. assert (m = 0 \/ m <> 0) as C by lia. destruct C as [C | C].
  - subst. rewrite mod_0_r in *. simpl in *. now subst.
  - assert (a - b = 0 \/ b < a) as D by lia. destruct D as [D | D].
    + rewrite D. apply Nat.mod_0_l. assumption.
    + apply Nat2Z.inj. simpl.
      rewrite Zdiv.mod_Zmod by assumption.
      rewrite Nat2Z.inj_sub by lia.
      rewrite Zdiv.Zminus_mod.
      rewrite <-! Zdiv.mod_Zmod by assumption.
      rewrite H. rewrite H0.
      apply Z.mod_0_l.
      lia.
Qed.

Lemma mul_div_exact: forall (a b: nat),
    b <> 0 ->
    a mod b = 0 ->
    b * (a / b) = a.
Proof.
  intros. edestruct Nat.div_exact as [_ P]; [eassumption|].
  specialize (P H0). symmetry. exact P.
Qed.


Require Import Coq.Init.Prelude Coq.ZArith.ZArith. Local Open Scope Z_scope.

Definition step (n : Z) :=
  if Z.eqb n 1 then None else
  if Z.even n
  then Some (Z.div2 n)
  else Some (3*n + 1).

Ltac collatz :=
  intros;
  repeat
  lazymatch goal with
  | H: _ = ?RHS |- _ =>
    lazymatch RHS with
    | Some ?n =>
    let H := lazymatch goal with H:n = _ |- _ => H end in
    first
      [
        let n' := open_constr:(_) in
        let n'' := fresh "n" in
        let Hn'' := fresh "H" n'' in
        refine (let n'' : Z := n' in let Hn'' : n'' = n' := eq_refl in _); clearbody Hn'';
        eassert (step n = Some n'') by (rewrite H; cbv; refine eq_refl); clearbody n''
      | exists n; rewrite H; refine eq_refl ]
    end
  end.

(* 350 steps *)
Goal forall n, n = 77031 -> Some n = Some n -> exists n, step n = None.
Time collatz. Time Qed.
(*
Finished transaction in 7.02 secs (6.882u,0.102s) (successful)
Finished transaction in 0.119 secs (0.119u,0.s) (successful)
*)

(* 685 steps *)
Goal forall n, n = 8400511 -> Some n = Some n -> exists n, step n = None.
Time collatz. Time Qed.
(*
Finished transaction in 37.63 secs (37.103u,0.351s) (successful)
Finished transaction in 0.286 secs (0.282u,0.003s) (successful)
*)


Inductive and (P Q : Prop) : Prop  :=
 | conj : P -> Q -> and P Q
.

Notation "P /\ Q" := (and P Q) : type_scope.

Inductive or (P Q : Prop) : Prop  :=
 | orl : P -> or P Q
 | orr : Q -> or P Q
.

Notation "P \/ Q" := (or P Q) : type_scope.

Inductive False : Prop := .
(* nothing can prove False .  False is a inductive/type/proposition with no constructor/value/proof *)

Inductive True : Prop := truth : True.

Theorem Truth : True.
Proof. apply truth. Qed.
(*
apply :proof
true witnesses True
true proves proposition True
true is of type True
*)

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. assumption. Qed.

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.
Definition classic := forall P:Prop,
  ~~P -> P.
Definition excluded_middle := forall P:Prop,
  P \/ ~P.
Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P/\~Q) -> P\/Q.
Definition implies_to_or := forall P Q:Prop,
  (P->Q) -> (~P\/Q).

Theorem peirce_to_classic : peirce -> classic.
unfold classic. unfold peirce. unfold not.
intro H. intro P. intro A. (* CONTRAPOSITIVE *)

Theorem classicals :
(*
peirce <-> classic <-> excluded_middle <-> de_morgan_not_and_not <-> implies_to_or.
*)


Require Import Coq.Logic.ClassicalFacts.
Require Import Essentials.Omega.
Require Import Essentials.Notations.
Require Import Essentials.Facts_Tactics Essentials.Definitions.
Require Import Lattice.PartialOrder Lattice.MLattice.
Require Import Metrics.Mappings.

Require Import Coq.Logic.Classical_Pred_Type.

(** Propositional extensionality assumed locally. *)
Local Axiom PropExt : prop_extensionality.

Delimit Scope bisected_scope with bisected.

Local Open Scope bisected_scope.

(** Bisected distance. Distances are 2⁻ⁿ for n a natural number or zero.
Intuitively, bisected distances are sequences of Prop such that whenever an element is
inhabitted then so are all elements before it. In other words, they are of the form

#
<pre>
True, True, True, True, True, True, True, ...
or
True, True, True, False, False, False, False, False, ...
|...............|
     n times
</pre>
#
where True and False are archetypal inhabitted and uninhabitted Propositions.

In this encoding, a sequence with n inhabitted elements at its beginning represents
2⁻ⁿ and the sequence of all trues represents zero (2^{-∞}).
 *)
Record BiDist : Type :=
  {
    BD_agree :> nat → Prop;
    BD_decreases : ∀ n m, n ≤ m → BD_agree m → BD_agree n
  }
.

Arguments BD_agree _ _ : assert.
Arguments BD_decreases _ _ _ _ _ : assert.

Local Hint Resolve BD_decreases.

(** Two bisected distances are equal if they are equal as sequences. *)
Theorem BiDist_eq_simpl (d d' : BiDist) : BD_agree d = BD_agree d' → d = d'.
Proof.
  intros H.
  destruct d; destruct d'; cbn in *.
  ElimEq.
  PIR; trivial.
Qed.

(** The less than equal relation. *)
Definition BD_LE (d d' : BiDist) : Prop :=
  ∀ n, d' n → d n
.

Notation "d ⊑ d'" := (BD_LE d d') : bisected_scope.

(** The less than relation. *)
Definition BD_LT (d d' : BiDist) : Prop :=
  d ⊑ d' ∧ d ≠ d'
.

Notation "d ⊏ d'" := (BD_LT d d') : bisected_scope.

(** The bottom element (zero). *)
Definition BD_bot : BiDist :=
  {|
    BD_agree := fun _ => True;
    BD_decreases := fun _ _ _ _ => I
  |}
.

Notation "⊥" := BD_bot : bisected_scope.

(** ⊥ is the least element. *)
Theorem BD_bot_LE : ∀ d, ⊥ ⊑ d.
Proof.
  intros d n.
  cbn; tauto.
Qed.

Local Hint Resolve BD_bot_LE.

(** The top element (one). *)
Definition BD_top : BiDist :=
  {|
    BD_agree := fun _ => False;
    BD_decreases := fun _ _ _ H => False_rect _ H
  |}
.

Notation "⊤" := BD_top : bisected_scope.

(** ⊤ is the greatest element. *)
Theorem BD_LE_top : ∀ d, d ⊑ ⊤.
Proof.
  intros d n.
  cbn; tauto.
Qed.

Local Hint Resolve BD_LE_top.

(** Reflexivity of less than equal relation. *)
Theorem BD_LE_Refl : ∀ d, d ⊑ d.
Proof.
  intros d n; trivial.
Qed.

(** Asymmetry of less than equal relation. *)
Theorem BD_LE_ASym : ∀ d d', d ⊑ d' → d' ⊑ d → d = d'.
Proof.
  intros d d' H1 H2.
  apply BiDist_eq_simpl.
  extensionality n.
  specialize (H1 n).
  specialize (H2 n).
  apply PropExt; intuition.
Qed.

(** Transitivity of less than equal relation. *)
Theorem BD_LE_Trans : ∀ d d' d'', d ⊑ d' → d' ⊑ d'' → d ⊑ d''.
Proof.
  intros d d' d'' H1 H2 n.
  auto.
Qed.

Local Obligation Tactic := idtac.

(** Half of the given distance. *)
Program Definition BD_Half_of (d : BiDist) : BiDist :=
  {|
    BD_agree :=
      fun n =>
        match n return Prop with
        | O => True
        | S n' => d n'
        end
  |}.

Next Obligation.
Proof.
  intros d n m H1 H2; cbn in *.
  destruct n; destruct m; trivial; try omega.
  eapply (BD_decreases _ _ m); trivial; omega.
Qed.

(** Half of is a monotone function. *)
Theorem BD_Half_of_monotone : ∀ (d d' : BiDist), d ⊑ d' → (BD_Half_of d) ⊑ (BD_Half_of d').
Proof.
  intros d d' H1 n H2.
  destruct n; cbn; trivial.
  apply H1; trivial.
Qed.

(** Half of is a non-expansive function. *)
Theorem BD_Half_of_non_expansive : ∀ (d : BiDist), (BD_Half_of d) ⊑ d.
Proof.
  intros d n H.
  destruct n; cbn; trivial.
  apply BD_decreases with (m := S n); [do 2 constructor|trivial].
Qed.

(** Given a positive distance, half of it is positive. *)
Theorem BD_pos_half_pos : ∀ d, ⊥ ⊏ d → ⊥ ⊏ BD_Half_of d.
Proof.
  intros d [H11 H12].
  split.
  {
    intros n H2.
    destruct n; cbn; auto.
  }
  {
    intros H2.
    apply H12.
    apply BiDist_eq_simpl.
    extensionality n.
    apply (f_equal (fun x => BD_agree x (S n))) in H2.
    trivial.
  }
Qed.

(** If an element is positive then its half is strictly smaller than it. *)
Theorem BD_pos_half_strictly_less : ∀ d, ⊥ ⊏ d → BD_Half_of d ⊏ d.
Proof.
  intros d [H11 H12].
  split.
  {
    intros n H2.
    destruct n; cbn; eauto.
  }
  {
    intros H2.
    apply H12.
    apply BD_LE_ASym; auto.
    intros n _.
    induction n.
    + apply (f_equal (fun x => BD_agree x 0)) in H2.
      rewrite <- H2; cbn; trivial.
    + apply (f_equal (fun x => BD_agree x (S n))) in H2.
      rewrite <- H2.
      trivial.
  }
Qed.

(** Half of any distance is less than 1. *)
Theorem BD_half_of_less_than_1 : ∀ d, BD_Half_of d ⊏ ⊤.
Proof.
  intros d.
  split.
  + intros n H; cbn in H; tauto.
  + intros H.
    cbn_rewrite <- (equal_f (f_equal BD_agree H) 0).
    trivial.
Qed.

(** nᵗʰ power of 1/2. *)
Definition BD_Half_pow (n : nat) := iterate BD_Half_of ⊤ n.

(** The nᵗʰ element of the sequence for the (n+1)ᵗʰ power of 1/2 is inhabitted. *)
Theorem BD_Half_pow_Sn_n (n : nat) : BD_Half_pow (S n) n.
Proof.
  induction n; cbn; trivial.
Qed.

(** The kᵗʰ element (k < n) of the sequence for the nᵗʰ power of 1/2 is inhabitted. *)
Theorem BD_Half_pow_lt (n k : nat) : k < n → BD_Half_pow n k.
Proof.
  intros H.
  induction H.
  apply BD_Half_pow_Sn_n.
  apply BD_decreases with (m := S k); [do 2 constructor | trivial].
Qed.

(** The kᵗʰ element (k < n) of the sequence for the nᵗʰ power of 1/2 is inhabitted. *)
Theorem BD_Half_pow_ge (n k : nat) : n ≤ k → ¬ (BD_Half_pow n k).
Proof.
  intros H.
  induction H.
  {
    induction n; tauto.
  }
  {
    intros H'.
    contradict IHle.
    apply BD_decreases with (m := S m); [do 2 constructor | trivial].
  }
Qed.

(** BD_Half_pow is monotone. *)
Theorem BD_Half_pow_monotone (n k : nat) : n ≤ k → (BD_Half_pow k) ⊑ (BD_Half_pow n).
Proof.
  intros H.
  induction H.
  + apply BD_LE_Refl.
  + eapply BD_LE_Trans; [|apply IHle].
    apply BD_Half_of_non_expansive.
Qed.

(** Less than BD_Half_pow. *)
Theorem Less_than_BD_Half_pow (d : BiDist) (n : nat) :
  d n → d ⊑ (BD_Half_pow n).
Proof.
  intros H m H'.
  apply (BD_decreases d _ n); trivial.
  destruct (le_lt_dec m n); trivial.
  exfalso; eapply BD_Half_pow_ge; eauto.
Qed.

(** nᵗʰ power of 1/2 is positive. *)
Theorem BD_Half_pow_pos (n : nat) : ⊥ ⊏ (BD_Half_pow n).
Proof.
  split; trivial.
  intros H.
  apply (BD_Half_pow_ge n (S n)); [do 2 constructor |].
  match goal with
    [|- ?A] =>
    replace A with (⊥ (S n)); cbn; trivial
  end.
  apply (equal_f (f_equal BD_agree H) (S n)).
Qed.

(** If an element is less than all finite powers 1/2 is the least element. *)
Theorem BD_approach_bot : ∀ d, (∀ d', ⊥ ⊏ d' → d ⊏ d') → d = ⊥.
Proof.
  intros d H1.
  apply BD_LE_ASym; [|apply BD_bot_LE].
  intros n H2.
  cut (d ⊏ BD_Half_pow (S n)); [intros [H31 H32]|].
  {
    apply H31.
    apply BD_Half_pow_Sn_n.
  }
  {
    apply H1.
    split; auto.
    intros H3.
    apply (f_equal (fun x => BD_agree x (S n))) in H3.
    cbn in H3.
    induction n.
    + cbn in H3.
      rewrite <- H3; trivial.
    + apply IHn; trivial.
  }
Qed.

(** The least upper bound. *)
Program Definition BD_lub {X : Type} (f : X → BiDist) : BiDist :=
  {|
    BD_agree := fun n => ∀ x, f x n
  |}
.

Next Obligation.
Proof.
  cbn.
  intros d d' n m H1 H2.
  intuition eauto.
Qed.

Notation "⊔ᵍ y" := (BD_lub y) : bisected_scope.

(** The least upper bound is an upper bound. *)
Theorem BD_lub_ub : ∀ {X : Type} (f : X → BiDist),
    ∀ x, f x ⊑ ⊔ᵍ f.
Proof.
  intros f d d' n; cbn; intuition.
Qed.

(** The lease upper bound is indeed the least among upper bounds. *)
Theorem BD_lub_lst : ∀ {X : Type} (f : X → BiDist) (d : BiDist),
    (∀ x, f x ⊑ d) → (⊔ᵍ f) ⊑ d.
Proof.
  intros X f d H1 n H2 x; apply H1; trivial.
Qed.

(** BiDist forms a partial order. *)
Definition BiDistPO : PartialOrder :=
  {|
    PO_Carrier := BiDist;
    PO_LE := BD_LE;
    PO_Refl := BD_LE_Refl;
    PO_ASym := BD_LE_ASym;
    PO_Trans := BD_LE_Trans
  |}.

(** BiDist as a partial order has least upper bounds. *)
Program Definition BD_LUB {X : Type} (f : X → BiDist) : (@LUB BiDistPO _ f)%order :=
  {|
    lub := ⊔ᵍ f;
    lub_ub := BD_lub_ub f;
    lub_lst := BD_lub_lst f
  |}.

Inductive BD_ApprType : BiDist → Type :=
| Appr_Half_Pow : ∀ n, BD_ApprType (BD_Half_pow n)
.

Definition BD_appr_pos := fun (x : BiDistPO) (H : BD_ApprType x) =>
        match H in (BD_ApprType b) return ⊥ ⊏ b with
        | Appr_Half_Pow n => BD_Half_pow_pos n
        end.

Require Import Coq.Logic.Classical_Pred_Type
        Coq.Logic.ChoiceFacts.

Local Axiom ConstructiveIndefiniteDescription_nat : ConstructiveIndefiniteDescription_on nat.

Theorem EveryBiDistAppr_helper (b : BiDist) :
  ⊥ ⊏ b → {n : nat | (BD_Half_pow n) ⊑ b}.
Proof.
  intros H1.
  apply ConstructiveIndefiniteDescription_nat.
  cut (∃ n, ¬ b n).
  {
    intros [n H2].
    exists n.
    intros m H3.
    destruct (le_gt_dec n m) as [H4|H4].
    + contradict H2.
      apply BD_decreases with (m := m); trivial.
    + apply BD_Half_pow_lt; trivial.
  }
  {
    apply not_all_ex_not.
    intros H2.
    apply H1.
    apply BD_LE_ASym;trivial.
    intros ? ?; trivial.
  }
Qed.

Definition BD_dichotomy_left
           (x : BiDist)
           (H : BD_ApprType x)
  :
    {y : BiDist & BD_ApprType y & (⊥ ⊏ y) ∧ (y ⊏ x)}
  :=
    existT2
      _
      _
      (BD_Half_of x)
      match H in (BD_ApprType b) return (BD_ApprType (BD_Half_of b)) with
      | Appr_Half_Pow n => Appr_Half_Pow (S n)
      end
      (conj (BD_pos_half_pos x (BD_appr_pos x H))
            (BD_pos_half_strictly_less x (BD_appr_pos x H)))
.

(** BiDist forms an MLattice. *)
Program Definition BiDistML : MLattice :=
  {|
    ML_PO := BiDistPO;
    ML_meets := @BD_LUB;
    ML_top := ⊤;
    ML_top_top := BD_LE_top;
    ML_bot := (⊥);
    ML_bot_bottom := BD_bot_LE;
    ML_appr_cond := BD_ApprType;
    ML_appr_top := Appr_Half_Pow 0;
    ML_appr_pos := BD_appr_pos;
    ML_appr_dominate_pos := _;
    ML_bottom_dichotomy := inl BD_dichotomy_left;
    ML_all_approximatable :=
      fun x H =>
        existT2
          _
          _
          (BD_Half_pow (proj1_sig (EveryBiDistAppr_helper x H)))
          (proj2_sig (EveryBiDistAppr_helper x H))
          (Appr_Half_Pow _)
  |}.

Next Obligation.
Proof.
  intros x H1.
  apply BD_LE_ASym; trivial.
  intros n _.
  specialize (H1 _ (Appr_Half_Pow (S n))).
  apply H1.
  apply BD_Half_pow_Sn_n.
Qed.

(** Powers of 1/2 are strictly decreasing *)
Theorem BD_Half_pow_strict_decreasing (n k : nat) : k < n → BD_Half_pow n ⊏ BD_Half_pow k.
Proof.
  intros H.
  induction H.
  apply BD_pos_half_strictly_less; apply BD_Half_pow_pos.
  eapply (@LE_LT_Trans BiDistPO); [|apply IHle].
  apply BD_pos_half_strictly_less; apply BD_Half_pow_pos.
Qed.

(** If a power of 1/2 is less than another, then the exponent is greater. *)
Theorem BD_Half_pow_strictly_less_exponent_strictly_less
        (n k : nat) : BD_Half_pow n ⊏ BD_Half_pow k → k < n.
Proof.
  intros [H11 H12].
  destruct (le_lt_dec n k) as [H2|H2]; trivial.
  apply BD_Half_pow_monotone in H2.
  contradict H12.
  apply BD_LE_ASym; auto.
Qed.

(** Given a positive distance, half of it is positive. *)
Theorem Strictly_less_less_than_BD_pos_half_pos :
  ∀ d d', d ⊏ d' → BD_ApprType d → BD_ApprType d' → d ⊑ BD_Half_of d'.
Proof.
  intros d d' H1 H2 H3.
  destruct H2 as [n].
  destruct H3 as [m].
  apply BD_Half_pow_strictly_less_exponent_strictly_less in H1.
  assert (H5 : (S m) ≤ n) by omega.
  apply (BD_Half_pow_monotone (S m) n H5).
Qed.

(** half_of forms a contraction rate! *)
Program Definition Half_ContrRate : ContrRate BiDistML :=
  {|
    CR_fun := BD_Half_of;
    CR_monotone := BD_Half_of_monotone;
    CR_non_expansive := BD_Half_of_non_expansive;
    CR_contracts := BD_pos_half_strictly_less;
    CR_rate_indicator := _
  |}.

Next Obligation.
Proof.
  intros ε ε'.
  destruct ε as [ε [n]].
  destruct ε' as [ε' [n']].
  cbn.
  exists (S (n - n')).
  unfold BD_Half_pow.
  rewrite iterate_after_iterate.
  apply BD_Half_pow_strict_decreasing.
  omega.
Qed.


From Coq Require Import
  Arith
  List.
From FunProofs.Lib Require Import
  List.

(* Enumerate all lists of length n using the elements of vals. *)
Fixpoint enumerate {A} (vals : list A) (n : nat) : list (list A) :=
  match n with
  | 0 => [[]]
  | S n' =>
    let fs := map cons vals in
    let vs := enumerate vals n' in
    flat_map (fun xs => map (fun f => f xs) fs) vs
  end.

Section Enumerate.
  Context {A : Type}.

  Lemma enumerate_length n : forall (vals : list A),
    length (enumerate vals n) = length vals ^ n.
  Proof.
    induction n; cbn; intros; auto.
    rewrite flat_map_concat_map.
    rewrite (concat_length _ (length vals)).
    { rewrite map_length, IHn; auto. }
    rewrite Forall_forall; intros *.
    rewrite in_map_iff; intros (? & ? & ?); subst.
    rewrite !map_length; auto.
  Qed.

  (* For any finite type, enumerate contains all sets of that type. *)
  Lemma enumerate_finite xs : forall (vals : list A),
    (forall x : A, In x vals) -> In xs (enumerate vals (length xs)).
  Proof.
    induction xs; cbn; intros * Hfinite; auto.
    rewrite in_flat_map.
    eexists; rewrite map_map, in_map_iff; eauto.
  Qed.
End Enumerate.


Set Warnings "-notation-overridden,-parsing".
Require Export Tactics.

Check 3 = 3.
Check forall n m : nat, n + m = m + n.
Check 2 = 2.
Check forall n : nat, n = 2.
Check 3 = 4.

Theorem plus_2_2_is_4 : 2 + 2 = 4.
Proof. reflexivity. Qed.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true : plus_fact.
Proof. reflexivity. Qed.

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three.

Definition injective {A B} (f : A -> B) :=
  forall (x y : A), f x = f y -> (x = y).
Check injective.

Check eq.
Check @eq.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof. split; reflexivity. Qed.

Lemma and_intro :
  forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB.
  split. { apply HA. } { apply HB. }
Qed.

Check and_intro.

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro; reflexivity.
Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros n m H. rewrite plus_comm in H.
  apply and_intro;
  destruct m in H. { simpl in H. apply H. }
  { inversion H. }

(* doing this forward may be a clue on
   how to do this in a fxnal style *)