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

(** * Object-level representation of Diophantine equations *)
(** ** Diophantine logic *)

Require Import Arith Nat Omega.
Require Import gcd.

Set Implicit Arguments.

Section diophantine_expressions.

  Inductive dio_op := do_add | do_mul.

  Definition do_eval o :=
    match o with
      | do_add => plus
      | do_mul => mult
    end.

  Inductive dio_expression : Set :=
    | de_cst  : nat -> dio_expression
    | de_var  : nat -> dio_expression
    | de_comp : dio_op -> dio_expression -> dio_expression -> dio_expression.

  Definition de_add := de_comp do_add.
  Definition de_mul := de_comp do_mul.

  Fixpoint de_size e :=
    match e with
      | de_cst n => 1
      | de_var x => 1
      | de_comp _ p q => 1 + de_size p + de_size q
    end.

  Fixpoint de_size_Z e :=
    (match e with
      | de_cst n => 1
      | de_var x => 1
      | de_comp _ p q => 1 + de_size_Z p + de_size_Z q
    end)%Z.

  Fact de_size_Z_spec e : de_size_Z e = Z.of_nat (de_size e).
  Proof.
    induction e as [ | | o f Hf g Hg ]; auto.
    simpl de_size; unfold de_size_Z; fold de_size_Z.
    rewrite Nat2Z.inj_succ, Nat2Z.inj_add; omega.
  Qed.

  Fixpoint de_eval ν e  :=
    match e with
      | de_cst n => n
      | de_var x => ν x
      | de_comp o p q => do_eval o (de_eval ν p) (de_eval ν q)
    end.

  Fact de_eval_ext e ν ω : (forall x, ν x = ω x) -> de_eval ν e = de_eval ω e.
  Proof.
    intros H; induction e as [ | | [] ]; simpl; auto.
  Qed.

  (* ρ σ ν *)

  Fixpoint de_subst σ e :=
    match e with
      | de_cst n => de_cst n
      | de_var x => σ x
      | de_comp o p q => de_comp o (de_subst σ p) (de_subst σ q)
    end.

  Fact de_eval_subst σ ν e : de_eval ν (de_subst σ e) = de_eval (fun x => de_eval ν (σ x)) e.
  Proof. induction e as [ | | [] ]; simpl; auto. Qed.

  Fact de_subst_subst σ1 σ2 e : de_subst σ1 (de_subst σ2 e) = de_subst (fun x => de_subst σ1 (σ2 x)) e.
  Proof. induction e as [ | | [] ]; simpl; f_equal; auto. Qed.

  Definition de_ren ρ := de_subst (fun x => de_var (ρ x)).

  Fact de_ren_size ρ e : de_size (de_ren ρ e) = de_size e.
  Proof.
    revert ρ; induction e as [ | | o e He f Hf ]; intros rho; auto.
    unfold de_ren; simpl de_subst; unfold de_size; fold de_size.
    f_equal; [ f_equal | ].
    * apply He.
    * apply Hf.
  Qed.

  Fact de_ren_size_Z ρ e : de_size_Z (de_ren ρ e) = de_size_Z e.
  Proof. do 2 rewrite de_size_Z_spec; f_equal; apply de_ren_size. Qed.

  Fact de_eval_ren ρ ν e : de_eval ν (de_ren ρ e)  = de_eval (fun x => ν (ρ x)) e.
  Proof. apply de_eval_subst. Qed.

  Definition de_lift := de_ren S.

  Fact de_eval_lift ν e : de_eval ν (de_lift e) = de_eval (fun x => ν (S x)) e.
  Proof. apply de_eval_ren. Qed.

End diophantine_expressions.

Definition dio_expr t := { e | forall ν, de_eval ν e = t ν }.

Notation 𝔻P := dio_expr.

Section dio_expr.

  (* How to analyse meta-level diophantine expressions *)

  Implicit Types r t : (nat -> nat) -> nat.

  Fact dio_expr_var i : 𝔻P (fun v => v i).
  Proof. exists (de_var i); simpl; auto. Defined.

  Fact dio_expr_cst c : 𝔻P (fun _ => c).
  Proof. exists (de_cst c); simpl; auto. Defined.

  Fact dio_expr_plus r t : 𝔻P r -> 𝔻P t -> 𝔻P (fun ν => r ν + t ν).
  Proof. intros (e1 & H1) (e2 & H2); exists (de_add e1 e2); simpl; auto. Defined.

  Fact dio_expr_mult r t : 𝔻P r -> 𝔻P t -> 𝔻P (fun ν => r ν * t ν).
  Proof. intros (e1 & H1) (e2 & H2); exists (de_mul e1 e2); simpl; auto. Defined.

  Fact dio_expr_ren t ρ : 𝔻P t -> 𝔻P (fun ν => t (fun i => ν (ρ i))).
  Proof. intros (e & He); exists (de_ren ρ e); intros; rewrite de_eval_ren, He; tauto. Defined.

  Fact dio_expr_subst t σ : 𝔻P t -> 𝔻P (fun ν => t (fun i => de_eval ν (σ i))).
  Proof. intros (e & He); exists (de_subst σ e); intros; rewrite de_eval_subst, He; tauto. Defined.

End dio_expr.

Hint Resolve dio_expr_var dio_expr_cst dio_expr_plus dio_expr_mult dio_expr_ren.

Section diophantine_logic.

  (* De Bruin syntax for diophantine formulas of the form

         A,B ::= e1 = e2 | A /\ B | A \/ B | ∃x.A

   *)

  Inductive dio_formula : Set :=
    | df_atm  : dio_expression -> dio_expression -> dio_formula   (* a = b *)
    | df_conj : dio_formula -> dio_formula -> dio_formula
    | df_disj : dio_formula -> dio_formula -> dio_formula
    | df_exst : dio_formula -> dio_formula.

  Fixpoint df_size f :=
    match f with
      | df_atm a b  => 1 + de_size a + de_size b
      | df_conj f g => 1 + df_size f + df_size g
      | df_disj f g => 1 + df_size f + df_size g
      | df_exst f   => 1 + df_size f
    end.

  Fixpoint df_size_Z f :=
    (match f with
      | df_atm a b  => 1 + de_size_Z a + de_size_Z b
      | df_conj f g => 1 + df_size_Z f + df_size_Z g
      | df_disj f g => 1 + df_size_Z f + df_size_Z g
      | df_exst f   => 1 + df_size_Z f
    end)%Z.

  Fact df_size_Z_spec f : df_size_Z f = Z.of_nat (df_size f).
  Proof.
    induction f as [ a b | f Hf g Hg | f Hf g Hg | f Hf ]; simpl df_size;
      rewrite Nat2Z.inj_succ; try rewrite Nat2Z.inj_add; unfold df_size_Z; fold df_size_Z; auto; try omega.
    do 2 rewrite de_size_Z_spec; omega.
  Qed.

  (* dv_lift : lifting of a diophantive valuation *)

  Definition dv_lift X ν (x : X) n :=
     match n with
       | 0   => x
       | S n => ν n
     end.

  Fixpoint df_pred f ν :=
    match f with
      | df_atm a b  => de_eval ν a  = de_eval ν b
      | df_conj f g => df_pred f ν /\ df_pred g ν
      | df_disj f g => df_pred f ν \/ df_pred g ν
      | df_exst f   => exists n, df_pred f (dv_lift ν n)
    end.

  Fact df_pred_atm a b ν : df_pred (df_atm a b) ν = (de_eval ν a = de_eval ν b).
  Proof. auto. Qed.

  Fact df_pred_conj f g ν : df_pred (df_conj f g) ν = (df_pred f ν /\ df_pred g ν).
  Proof. auto. Qed.

  Fact df_pred_disj f g ν : df_pred (df_disj f g) ν = (df_pred f ν \/ df_pred g ν).
  Proof. auto. Qed.

  Fact df_pred_exst f ν : df_pred (df_exst f) ν = exists n, df_pred f (dv_lift ν n).
  Proof. auto. Qed.

  Fact df_pred_ext f ν ω : (forall x, ν x = ω x) -> df_pred f ν <-> df_pred f ω.
  Proof.
    revert ν ω; induction f as [ a b | f Hf g Hg | f Hf g Hg | f Hf ]; intros ν ω H; simpl.
    + do 2 rewrite de_eval_ext with (1 := H); tauto.
    + rewrite Hf, Hg; auto; tauto.
    + rewrite Hf, Hg; auto; tauto.
    + split; intros (n & Hn); exists n; revert Hn; apply Hf;
        intros []; simpl; auto.
  Qed.

  (* Lifting of a diophantine expression renaming *)

  Definition der_lift ρ x := match x with 0 => 0 | S x => S (ρ x) end.

  Fixpoint df_ren ρ f :=
    match f with
      | df_atm a b  => let σ := fun x => de_var (ρ x) in df_atm (de_subst σ a) (de_subst σ b)
      | df_conj f g => df_conj (df_ren ρ f) (df_ren ρ g)
      | df_disj f g => df_disj (df_ren ρ f) (df_ren ρ g)
      | df_exst f   => df_exst (df_ren (der_lift ρ) f)
    end.

  Fact df_ren_size ρ f : df_size (df_ren ρ f) = df_size f.
  Proof.
    revert ρ; induction f; intros; simpl; auto; do 2 f_equal; auto.
    all: apply de_ren_size.
  Qed.

  Fact df_ren_size_Z ρ f : df_size_Z (df_ren ρ f) = df_size_Z f.
  Proof.
    do 2 rewrite df_size_Z_spec; f_equal; apply df_ren_size.
  Qed.

  Fact df_pred_ren f ν ρ : df_pred (df_ren ρ f) ν <-> df_pred f (fun x => ν (ρ x)).
  Proof.
    revert ν ρ; induction f as [ a b | f Hf g Hg | f Hf g Hg | f Hf ]; intros ν ρ; simpl.
    + repeat rewrite de_eval_subst; simpl; tauto.
    + rewrite Hf, Hg; tauto.
    + rewrite Hf, Hg; tauto.
    + split; intros (n & Hn); exists n; revert Hn; rewrite Hf;
        apply df_pred_ext; intros []; simpl; auto.
  Qed.

  (* Lifting of a diophantine expression substitutions *)

  Definition des_lift σ x := match x with 0 => de_var 0 | S x => de_ren S (σ x) end.

  Fixpoint df_subst σ f :=
    match f with
      | df_atm a b  => df_atm (de_subst σ a) (de_subst σ b)
      | df_conj f g => df_conj (df_subst σ f) (df_subst σ g)
      | df_disj f g => df_disj (df_subst σ f) (df_subst σ g)
      | df_exst f   => df_exst (df_subst (des_lift σ) f)
    end.

  Fact df_pred_subst f ν σ : df_pred (df_subst σ f) ν <-> df_pred f (fun x => de_eval ν (σ x)).
  Proof.
    revert ν σ; induction f as [ a b | f Hf g Hg | f Hf g Hg | f Hf ]; intros ν σ; simpl.
    + repeat rewrite de_eval_subst; simpl; tauto.
    + rewrite Hf, Hg; tauto.
    + rewrite Hf, Hg; tauto.
    + split; intros (n & Hn); exists n; revert Hn; rewrite Hf;
        apply df_pred_ext; intros []; simpl; auto;
        rewrite de_eval_ren; apply de_eval_ext; auto.
  Qed.

  Definition df_lift := df_ren S.

  Fact df_pred_lift f ν : df_pred (df_lift f) ν <-> df_pred f (fun x => ν (S x)).
  Proof. apply df_pred_ren. Qed.

End diophantine_logic.

Section examples.

  Variable ν : nat -> nat.

  Definition df_true := df_atm (de_cst 0) (de_cst 0).
  Definition df_false := df_atm (de_cst 0) (de_cst 1).

  Fact df_true_spec : df_pred df_true ν <-> True.
  Proof. simpl; split; auto. Qed.

  Fact df_false_spec : df_pred df_false ν <-> False.
  Proof. simpl; split; try discriminate; tauto. Qed.

  Notation "'⟦' x '⟧'" := (de_eval ν x).

  Definition df_le x y := df_exst (df_atm (de_add (de_var 0) (de_lift x)) (de_lift y)).

  Fact df_le_spec x y : df_pred (df_le x y) ν <-> ⟦x⟧ <= ⟦y⟧.
  Proof.
    simpl.
    split.
    + intros (n & Hn); revert Hn; do 2 rewrite de_eval_lift; simpl.
      change (fun x => ν x) with ν; intros; omega.
    + exists (de_eval ν y - de_eval ν x); simpl.
      repeat rewrite de_eval_lift; simpl.
      change (fun x => ν x) with ν; omega.
  Qed.

  Definition df_lt x y := df_exst (df_atm (de_add (de_cst 1) (de_add (de_var 0) (de_lift x))) (de_lift y)).

  Fact df_lt_spec x y : df_pred (df_lt x y) ν <-> ⟦x⟧ < ⟦y⟧.
  Proof.
    simpl.
    split.
    + intros (? & Hn); revert Hn; simpl.
      do 2 rewrite de_eval_lift; simpl.
      change (fun x => ν x) with ν; intros; omega.
    + exists (de_eval ν y - de_eval ν x - 1); simpl.
      repeat rewrite de_eval_lift; simpl.
      change (fun x => ν x) with ν; omega.
  Qed.

  Definition df_eq x y := df_atm x y.

  Fact df_eq_spec x y : df_pred (df_eq x y) ν <-> ⟦x⟧ = ⟦y⟧.
  Proof. simpl; tauto. Qed.

  Definition df_neq x y := df_disj (df_lt x y) (df_lt y x).

  Fact df_neq_spec x y : df_pred (df_neq x y) ν <-> ⟦x⟧ <> ⟦y⟧.
  Proof.
    unfold df_neq.
    rewrite df_pred_disj, df_lt_spec, df_lt_spec.
    omega.
  Qed.

  Definition df_div x y := df_exst (df_atm (de_lift y) (de_mul (de_var 0) (de_lift x))).

  Fact df_div_spec x y : df_pred (df_div x y) ν <-> divides ⟦x⟧ ⟦y⟧.
  Proof.
    simpl; unfold divides.
    split; intros (n & H); exists n; revert H; repeat rewrite de_eval_lift;
      simpl; change (fun x => ν x) with ν; auto.
  Qed.

End examples.

Definition dio_rel R := { f | forall ν, df_pred f ν <-> R ν }.
Notation 𝔻R := dio_rel.

Section dio_rel.

  (** How to analyse diophantine relations ... these are proved by
      explicitely given the witness which we will avoid later on *)

  Implicit Types R S : (nat -> nat) -> Prop.

  Fact dio_rel_True : 𝔻R (fun _ => True).
  Proof.
    exists df_true.
    intros; rewrite df_true_spec; tauto.
  Defined.

  Fact dio_rel_False : 𝔻R (fun _ => False).
  Proof.
    exists df_false.
    intros; rewrite df_false_spec; tauto.
  Defined.

  Fact dio_rel_eq r t : 𝔻P r -> 𝔻P t -> 𝔻R (fun ν => r ν = t ν).
  Proof.
    intros (e1 & H1) (e2 & H2); exists (df_atm e1 e2).
    intros; rewrite df_pred_atm, H1, H2; tauto.
  Defined.

  Fact dio_rel_le r t : 𝔻P r -> 𝔻P t -> 𝔻R (fun ν => r ν <= t ν).
  Proof.
    intros (e1 & H1) (e2 & H2); exists (df_le e1 e2).
    intro; rewrite df_le_spec, H1, H2; tauto.
  Defined.

  Fact dio_rel_lt r t : 𝔻P r -> 𝔻P t -> 𝔻R (fun ν => r ν < t ν).
  Proof.
    intros (e1 & H1) (e2 & H2); exists (df_lt e1 e2).
    intro; rewrite df_lt_spec, H1, H2; tauto.
  Defined.

  Fact dio_rel_neq r t : 𝔻P r -> 𝔻P t -> 𝔻R (fun ν => r ν <> t ν).
  Proof.
    intros (e1 & H1) (e2 & H2); exists (df_neq e1 e2).
    intros; rewrite df_neq_spec, H1, H2; tauto.
  Defined.

  Fact dio_rel_div r t : 𝔻P r -> 𝔻P t -> 𝔻R (fun ν => divides (r ν) (t ν)).
  Proof.
    intros (e1 & H1) (e2 & H2); exists (df_div e1 e2).
    intros; rewrite df_div_spec, H1, H2; tauto.
  Defined.

  Fact dio_rel_conj R S : 𝔻R R -> 𝔻R S -> 𝔻R (fun ν => R ν /\ S ν).
  Proof.
    intros (fR & H1) (fS & H2).
    exists (df_conj fR fS); intros v.
    rewrite df_pred_conj, H1, H2; tauto.
  Defined.

  Fact dio_rel_disj R S : 𝔻R R -> 𝔻R S -> 𝔻R (fun ν => R ν \/ S ν).
  Proof.
    intros (fR & H1) (fS & H2).
    exists (df_disj fR fS); intros v.
    rewrite df_pred_disj, H1, H2; tauto.
  Defined.

  Fact dio_rel_exst (K : nat -> (nat -> nat) -> Prop) :
                   𝔻R (fun v => K (v 0) (fun n => v (S n)))
      -> 𝔻R (fun ν => exists x, K x ν).
  Proof.
    intros (f & Hf).
    exists (df_exst f); intros v.
    rewrite df_pred_exst.
    split; intros (n & Hn); exists n; revert Hn; rewrite Hf; simpl; auto.
  Defined.

  Lemma dio_rel_equiv R S : (forall ν, S ν <-> R ν) -> 𝔻R R -> 𝔻R S.
  Proof.
    intros H (f & Hf); exists f; intro; rewrite Hf, H; tauto.
  Defined.

  Lemma dio_rel_ren R f : 𝔻R R -> 𝔻R (fun v => R (fun n => v (f n))).
  Proof.
    intros (r & HR).
    exists (df_ren f r).
    intros; rewrite df_pred_ren, HR; tauto.
  Defined.

  Lemma dio_rel_subst R f : 𝔻R R -> 𝔻R (fun v => R (fun n => de_eval v (f n))).
  Proof.
    intros (r & HR).
    exists (df_subst f r).
    intros; rewrite df_pred_subst, HR; tauto.
  Defined.

End dio_rel.

Hint Resolve dio_rel_True dio_rel_False dio_rel_eq dio_rel_neq
             dio_rel_le dio_rel_lt dio_rel_div
             dio_rel_conj
             dio_rel_disj
             dio_rel_exst.

Ltac dio_rel_auto := repeat ((apply dio_rel_exst || apply dio_rel_conj || apply dio_rel_disj || apply dio_rel_eq); auto).

Section more_examples.

  Fact ndivides_eq x y : ~ (divides x y) <-> x = 0 /\ y <> 0 \/ exists a b, y = a*x+b /\ 0 < b < x.
  Proof.
    split.
    + intros H.
      destruct x as [ | x ].
      * left; split; auto; contradict H; subst; apply divides_0.
      * right; exists (div y (S x)), (rem y (S x)); split.
        - apply div_rem_spec1.
        - rewrite divides_rem_eq in H.
          generalize (@div_rem_spec2 y (S x)); intros; omega.
    + intros [ (H1 & H2) | (a & b & H1 & H2) ].
      * subst; contradict H2; revert H2; apply divides_0_inv.
      * rewrite divides_rem_eq.
        rewrite (div_rem_spec1 y x) in H1.
        apply div_rem_uniq in H1; try omega.
        apply div_rem_spec2; omega.
  Qed.

  Lemma dio_rel_ndivides x y : 𝔻P x -> 𝔻P y -> 𝔻R (fun ν => ~ divides (x ν) (y ν)).
  Proof.
    intros.
    apply dio_rel_equiv with (1 := fun v => ndivides_eq (x v) (y v)).
    dio_rel_auto.
  Qed.

  Hint Resolve dio_rel_ndivides.

  Fact rem_equiv p x r : r = rem x p <-> (p = 0 /\ x = r)
                                      \/ (p <> 0 /\ r < p /\ exists n, x = n*p + r).
  Proof.
    split.
    + intro; subst.
      destruct (eq_nat_dec p 0) as [ Hp | Hp ].
      * left; split; auto; subst; rewrite rem_0; auto.
      * right; split; auto; split.
        - apply div_rem_spec2; auto.
        - exists (div x p);apply div_rem_spec1.
    + intros [ (H1 & H2) | (H1 & H2 & n & H3) ].
      * subst; rewrite rem_0; auto.
      * symmetry; apply rem_prop with n; auto.
  Qed.

  Lemma dio_rel_remainder p x r : 𝔻P p -> 𝔻P x -> 𝔻P r
                               -> 𝔻R (fun ν => r ν = rem (x ν) (p ν)).
  Proof.
    intros.
    apply dio_rel_equiv with (1 := fun v => rem_equiv (p v) (x v) (r v)).
    dio_rel_auto.
  Defined.

  (* Eval compute in proj1_sig (dio_rel_remainder (dio_expr_var 0) (dio_expr_var 1) (dio_expr_var 2)). *)

  Hint Resolve dio_rel_remainder.

  Fact congr_equiv x y p : rem x p = rem y p <-> (exists r, r = rem x p /\ r = rem y p).
  Proof.
    split.
    + intros H; exists (rem x p); auto.
    + intros (? & ? & ?); subst; auto.
  Qed.

  Lemma dio_rel_congruence x y p : 𝔻P x -> 𝔻P y -> 𝔻P p
                                -> 𝔻R (fun ν => rem (x ν) (p ν) = rem (y ν) (p ν)).
  Proof.
    intros.
    apply dio_rel_equiv with (1 := fun v => congr_equiv (x v) (y v) (p v)).
    dio_rel_auto.
  Defined.

  Hint Resolve dio_rel_congruence.

  Fact not_divides_eq p x : ~ divides p x <-> exists r, r = rem x p /\ r <> 0.
  Proof.
    rewrite divides_rem_eq.
    split.
    + exists (rem x p); auto.
    + intros (? & ? & ?); subst; auto.
  Qed.

  Lemma dio_rel_not_divides x p : 𝔻P x -> 𝔻P p -> 𝔻R (fun ν => ~ divides (x ν) (p ν)).
  Proof.
    intros.
    apply dio_rel_equiv with (1 := fun v => not_divides_eq (x v) (p v)).
    dio_rel_auto.
  Defined.

End more_examples.

Hint Resolve dio_rel_congruence dio_rel_not_divides.

(* Even computation in Coq works well

Eval compute in proj1_sig (dio_rel_congruence (dio_expr_var 0) (dio_expr_var 1) (dio_expr_var 2)).
Eval compute in proj1_sig (dio_rel_not_divides (dio_expr_var 0) (dio_expr_var 1)).

*)

Section dio_rel_compose.

  Variable (f : (nat -> nat) -> nat) (R : nat -> (nat -> nat) -> Prop).
  Hypothesis (Hf : 𝔻R (fun ν => ν 0 = f (fun x => ν (S x))))
             (HR : 𝔻R (fun ν => R (ν 0) (fun x => ν (S x)))).

  Lemma dio_rel_compose : 𝔻R (fun ν => R (f ν) ν).
  Proof.
    apply dio_rel_equiv with (R := fun v => exists y, y = f v /\ R y v).
    + intros v; split.
      * exists (f v); auto.
      * intros (? & -> & ?); auto.
    + dio_rel_auto.
  Defined.

End dio_rel_compose.

Section multiple_exists.

  Fixpoint df_mexists n f :=
    match n with
      | 0   => f
      | S n => df_mexists n (df_exst f)
    end.

  Fact df_mexists_size n f : df_size (df_mexists n f) = n + df_size f.
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; auto; simpl df_mexists.
    rewrite IHn; simpl; omega.
  Qed.

  Fact df_mexists_size_Z n f : df_size_Z (df_mexists n f) = (Z.of_nat n + df_size_Z f)%Z.
  Proof.
    rewrite df_size_Z_spec, df_mexists_size, Nat2Z.inj_add, df_size_Z_spec; omega.
  Qed.

  (* We only use it once so there is no need to automatize it *)

  Lemma df_mexists_spec n f ν :
           df_pred (df_mexists n f) ν
       <-> exists π, df_pred f (fun i => if le_lt_dec n i then ν (i-n) else π i).
  Proof.
    revert f ν; induction n as [ | n IHn ]; intros f v.
    + simpl; split; [ intros H; exists (fun _ => 0) | intros (_ & H) ]; revert H;
        apply df_pred_ext; intros; f_equal; omega.
    + simpl df_mexists; rewrite IHn; split; intros (pi & Hpi).
      * revert Hpi; rewrite df_pred_exst.
        intros (u & Hu).
        exists (fun i => match i with 0 => u | S i => pi i end).
        revert Hu; apply df_pred_ext.
        intros [ | i ].
        - replace (0-S n) with 0 by omega; simpl; auto.
        - replace (S i - S n) with (i-n) by omega.
          simpl dv_lift.
          destruct (le_lt_dec (S n) (S i)); destruct (le_lt_dec n i); auto; omega.
      * exists (fun i => pi (S i)).
        rewrite df_pred_exst; exists (pi 0).
        revert Hpi; apply df_pred_ext.
        intros [ | i ].
        - replace (0-S n) with 0 by omega; simpl; auto.
        - replace (S i - S n) with (i-n) by omega.
          simpl dv_lift.
          destruct (le_lt_dec (S n) (S i)); destruct (le_lt_dec n i); auto; omega.
  Qed.

End multiple_exists.


Require Export TopologicalSpaces Neighborhoods OpenBases.
From ZornsLemma Require Export IndexedFamilies EnsemblesSpec.

Record neighborhood_basis {X:TopologicalSpace}
  (NB:Family X) (x:point_set X) : Prop := {
  neighborhood_basis_elements: forall N:Ensemble X,
    In NB N -> neighborhood N x;
  neighborhood_basis_cond: forall N:Ensemble X,
    neighborhood N x -> exists N':Ensemble X,
    In NB N' /\ Included N' N
}.

Record open_neighborhood_basis {X:TopologicalSpace}
  (NB:Family X) (x:point_set X) : Prop := {
  open_neighborhood_basis_elements: forall U:Ensemble X,
    In NB U -> open_neighborhood U x;
  open_neighborhood_basis_cond: forall U:Ensemble X,
    open_neighborhood U x -> exists V:Ensemble X,
    In NB V /\ Included V U
}.

Lemma open_neighborhood_basis_is_neighborhood_basis:
  forall {X:TopologicalSpace} (NB:Family X) (x:point_set X),
  open_neighborhood_basis NB x -> neighborhood_basis NB x.
Proof.
intros.
destruct H.
constructor; intros.
- apply open_neighborhood_is_neighborhood.
  auto.
- destruct H as [U [? ?]].
  destruct (open_neighborhood_basis_cond0 U H) as [V [? ?]].
  exists V.
  split; auto with sets.
Qed.

Lemma open_basis_to_open_neighborhood_basis:
  forall {X:TopologicalSpace} (B:Family X) (x:point_set X),
    open_basis B -> open_neighborhood_basis
                    [ U:Ensemble X | In B U /\ In U x ]
                    x.
Proof.
intros.
destruct H.
constructor;
  intros.
- now split;
    destruct H as [[? ?]];
    [ apply open_basis_elements | ].
- destruct H.
  destruct (open_basis_cover x U H H0).
  destruct H1 as [? [? ?]].
  exists x0.
  now repeat split.
Qed.

Lemma open_neighborhood_bases_to_open_basis:
  forall {X:TopologicalSpace} (NB : point_set X -> Family X),
    (forall x:point_set X, open_neighborhood_basis (NB x) x) ->
    open_basis (IndexedUnion NB).
Proof.
intros.
constructor;
  intros.
- destruct H0.
  destruct (H a).
  now destruct (open_neighborhood_basis_elements0 x H0).
- destruct (H x).
  assert (open_neighborhood U x) by
    now constructor.
  destruct (open_neighborhood_basis_cond0 U H2) as [V [? ?]].
  exists V.
  repeat split; trivial.
  + now exists x.
  + now destruct (open_neighborhood_basis_elements0 V H3).
Qed.

Section build_from_open_neighborhood_bases.

Variable X:Type.
Variable NB : X -> Family X.

Hypothesis neighborhood_basis_cond :
  forall (U V:Ensemble X) (x:X), In (NB x) U -> In (NB x) V ->
    exists W:Ensemble X, In (NB x) W /\ Included W (Intersection U V).
Hypothesis neighborhood_basis_cond2 :
  forall (U:Ensemble X) (x:X), In (NB x) U -> In U x.
Hypothesis neighborhood_basis_inhabited_cond :
  forall x:X, Inhabited (NB x).
Hypothesis neighborhood_basis_system_cond :
  forall (x y:X) (U:Ensemble X), In (NB x) U -> In U y ->
  exists V:Ensemble X, In (NB y) V /\ Included V U.

Definition Build_TopologicalSpace_from_open_neighborhood_bases :
  TopologicalSpace.
refine (Build_TopologicalSpace_from_open_basis (IndexedUnion NB)
  _ _);
  red; intros.
- destruct H as [y U'].
  destruct H0 as [z V'].
  destruct H1.
  destruct (neighborhood_basis_system_cond y x U' H H1) as
    [U'' [? ?]].
  destruct (neighborhood_basis_system_cond z x V' H0 H2) as
    [V'' [? ?]].
  destruct (neighborhood_basis_cond U'' V'' x H3 H5) as
    [W [? ?]].
  exists W.
  repeat split.
  + now exists x.
  + now apply neighborhood_basis_cond2.
  + apply H4.
    now destruct (H8 _ H9).
  + apply H6.
    now destruct (H8 _ H9).
- destruct (neighborhood_basis_inhabited_cond x) as [U].
  exists U.
  split; auto.
  now exists x.
Defined.

Lemma Build_TopologicalSpace_from_open_neighborhood_bases_basis:
  forall x:X,
    open_neighborhood_basis (NB x) x
      (X:=Build_TopologicalSpace_from_open_neighborhood_bases).
Proof.
assert (open_basis (IndexedUnion NB)
  (X:=Build_TopologicalSpace_from_open_neighborhood_bases))
  by apply Build_TopologicalSpace_from_open_basis_basis.
destruct H.
intros.
constructor;
  intros.
- constructor.
  + apply open_basis_elements.
    now exists x.
  + now apply neighborhood_basis_cond2.
- destruct H.
  destruct (open_basis_cover x U H H0) as [V [? []]].
  destruct H1 as [y V].
  destruct (neighborhood_basis_system_cond y x V H1 H3) as [W []].
  exists W.
  auto with sets.
Qed.

End build_from_open_neighborhood_bases.


Require Import CT.Category.
Require Import CT.Functor.

(** * Faithful Functors

A "faithful" functor is one that is injective on hom-sets. That is,
A functor \(F : C \to D\) is _faithful_ if \(\forall x, y \in C\), the function
\(F : C(x, y) \to D(F(x), F(y))\) is injective.

So we require a [Functor] and a proof that injectivity of hom-sets is satisfied.
*)
Section FaithfulFunctor.
  Context {A B : Category}.
  Variable (F : Functor A B).

  (* Injectivity of [F_mor] *)
  Definition FaithfulFunctor :=
    forall {a b} (f : mor A a b) (g : mor A a b),
      F_mor F f = F_mor F g -> f = g.
End FaithfulFunctor.


Require Import SAT.project_lib.

(* Exercise 2.1 *)
Inductive form :=
  | f_var : id -> form
  | f_true : form
  | f_false : form
  | f_and : form -> form -> form
  | f_or : form -> form -> form
  | f_impl : form -> form -> form
  | f_neg : form -> form.

(* Custom Notation *)
Declare Custom Entry sat.
Notation "<{ e }>" := e (e custom sat at level 99).
Notation "( x )" := x (in custom sat, x at level 99).
Notation "x" := x (in custom sat at level 0, x constr at level 0).
Notation "x -> y" := (f_impl x y) (in custom sat at level 70, right associativity).
Notation "x /\ y" := (f_and x y) (in custom sat at level 40, left associativity).
Notation "x \/ y" := (f_or x y) (in custom sat at level 50, left associativity).
Notation "~ x" := (f_neg x) (in custom sat at level 30).
Notation "'true'"  := true (at level 1).
Notation "'true'" := f_true (in custom sat at level 0).
Notation "'false'"  := false (at level 1).
Notation "'false'" := f_false (in custom sat at level 0).
Coercion f_var : id >-> form.

Definition x : id := (Id 0).
Definition y : id := (Id 1).
Definition z : id := (Id 2).
Local Hint Unfold x : core.
Local Hint Unfold y : core.
Local Hint Unfold z : core.

(* Exercise 2.2 *)
Definition twotwoone := <{(x \/ ~y) /\ (~x \/ y)}>.
Definition twotwotwo := <{ ~y -> (x \/ y) }> .
Definition twotwothree := <{ x /\ ~x /\ true }>.

Definition valuation := id -> bool .
Definition empty_valuation : valuation := fun x => false .
Definition override (V : valuation ) (x : id) (b : bool ) : valuation :=
  fun y => if beq_id x y then b else V y.

(* Exercise 2.3 *)
Fixpoint interp (V : valuation) (p : form ) : bool :=
  match p with
  | f_true => true
  | f_false => false
  | f_var x => V x
  | <{ x /\ y }> => (interp V x) && (interp V y)
  | <{ x \/ y }> => (interp V x) || (interp V y)
  | <{ ~x }> => negb (interp V x)
  | <{ x -> y }> => negb (interp V x) || (interp V y)
  end.

Notation "'Ø'" := empty_valuation.
Notation "m '|[' x '|->' v ']|'" := (override m x v)  (at level 100, v at next level, right associativity).

(* A test valuation, assigning  x = false, y = true, z = true using the custom notation*)
Definition testval := Ø|[x |-> false]||[y |-> true]||[z |-> true]|.

Example interp_test1 : interp testval twotwoone = false.
Proof. reflexivity. Qed.

Example interp_test2 : interp testval twotwotwo = true.
Proof. reflexivity. Qed.

Example interp_test3 : interp testval twotwothree = false.
Proof. reflexivity. Qed.

(* Satisfiability states that there exists some valuation, making the interpretation of the formular true *)
Definition satisfiable (p : form ) : Prop := exists V : valuation , interp V p = true.

(* Exercise 2.4 *)
Lemma test1 : satisfiable twotwoone .
Proof.
  unfold satisfiable, twotwoone. exists Ø. reflexivity.
Qed.

Lemma test2 : satisfiable twotwotwo .
Proof.
  unfold satisfiable, twotwotwo. exists (Ø|[ x |-> true]|). reflexivity.
Qed.

(* Helper function to add an element to a list, only if the element
   is not already present within the list
*)
Fixpoint set_add (x : id) (l : list id) :=
  match l with
  | nil => [x]
  | a :: l' => if beq_id a x then l else a :: (set_add x l')
  end.

(* Computes the union of two lists as if they were sets,
   i.e. disallowing duplicate entries
*)
Fixpoint set_union (l1 l2 : list id) : list id :=
  match l1 with
  | nil => l2
  | x :: l' => set_add x (set_union l' l2)
  end.

(* Computes the list of id's present in a given formular p *)
Fixpoint occuring_vars (p : form) : list id :=
  match p with
  | f_true => nil
  | f_false => nil
  | f_var x => [x]
  | <{ x /\ y }> => set_union (occuring_vars x) (occuring_vars y)
  | <{ x \/ y }> => set_union (occuring_vars x) (occuring_vars y)
  | <{ ~x }> => (occuring_vars x)
  | <{ x -> y }> => set_union (occuring_vars x) (occuring_vars y)
  end.

Example test_occuring_vars :occuring_vars twotwoone = [Id 1; Id 0].
Proof. reflexivity. Qed.

(* Computes a list of all possible valuations, given a list id possible id's *)
Fixpoint allValuations (l : list id) : list valuation :=
  match l with
  | nil => [empty_valuation]
  | x :: l' => let lv := allValuations l' in (map (fun V => override V x false) lv) ++ (map (fun V => override V x true) lv)
  end.

(* Expecting length 4, since 2 variables both with mappings to true/false *)
Example test_length_of_allValuations : length (allValuations (occuring_vars twotwoone)) = 4.
Proof. reflexivity. Qed.

Fixpoint find_valuation_helper (p : form) (l : list valuation) : option valuation :=
  match l with
  | nil => None
  | v :: l' => if interp v p then Some v else find_valuation_helper p l'
  end.

Definition find_valuation (p : form ) : option valuation :=
  find_valuation_helper p (allValuations (occuring_vars p)).

Definition solver (p : form ) : bool :=
  match find_valuation p with
  | Some _ => true
  | None => false
  end.

(* Exercse 2.6

   Satisfiable is a definition, stating that there exists some valuation in which the formula is true.
   It requires you to provide a witness, namely a valuation in which the formula's interpretation is true.

   Solver is a function which returns true / false, depending on whether or not the formula is satisfiable,
   enumerating all possible valuations to find one.
*)

(* Exercise 2.7 *)

Example two7pos1 : solver twotwoone = true.
Proof. reflexivity. Qed.

Example two7pos2 : solver twotwotwo = true.
Proof. reflexivity. Qed.

Example two7neg1 : solver twotwothree = false.
Proof. reflexivity. Qed.

Example two7neg2 : solver <{ (x \/ y) /\ (~x \/ y) /\ (x \/ ~y) /\ (~x \/ ~y)  }> = false.
Proof. reflexivity. Qed.

Lemma solver_sound_helper : forall l p v, find_valuation_helper p l = Some v -> interp v p = true.
Proof. intros l. induction l; intros.
  - easy.
  - cbn in H. destruct (interp a p) eqn:E. inversion H. subst. auto. apply (IHl _ _ H).
Qed.

(* Exercise 2.8
   The proof that the solver is sound. Uses a helper function defined above to do so.
*)
Lemma solver_sound : forall p, solver p = true -> satisfiable p.
Proof. intros. unfold satisfiable. unfold solver in H. destruct (find_valuation p) eqn:E; try easy. exists v.
  unfold find_valuation in E. apply solver_sound_helper in E. auto.
Qed.

(* Helper lemma stating that an equivalent valuation exists in the list of allValuations,
   for all possible valuations over the id's in said valuation
*)
Lemma val_in_allvals : forall l (v: valuation), exists v', In v' (allValuations l) /\ forall x0, In x0 l ->  v x0 = v' x0.
Proof. induction l; intros.
  - exists Ø. split. left. reflexivity. intros. inversion H.
  - destruct (IHl v) as [v']. destruct H. destruct (v a) eqn:E1.
    + exists (v'|[a |-> true]|). cbn. remember (fun V : valuation => V |[ a |-> true ]|) as f. assert (f v' = (v'|[a |-> true]|)) by (rewrite Heqf; reflexivity).
       split.
        * apply in_app_iff. right. rewrite <- H1. apply in_map. auto.
        * intros. destruct H2.
          -- subst. unfold override. rewrite <- beq_id_refl. apply E1.
          -- apply H0 in H2. destruct (beq_id a x0) eqn:E;
            unfold override; rewrite E.
            ++ symmetry in E. apply beq_id_eq in E. subst. assumption.
            ++ unfold override. apply H2.
    + exists (v'|[a |-> false]|). cbn. remember (fun V : valuation => V |[ a |-> false ]|) as f. assert (f v' = (v'|[a |-> false]|)) by (rewrite Heqf; reflexivity).
    split.
      * apply in_app_iff. left. rewrite <- H1. apply in_map.  auto.
      * intros. destruct H2.
        -- subst. unfold override. rewrite <- beq_id_refl. apply E1.
        -- apply H0 in H2. destruct (beq_id a x0) eqn:E; unfold override; rewrite E.
          ++ symmetry in E. apply beq_id_eq in E. subst. assumption.
          ++ apply H2.
Qed.

(* Following couple of functions are helper functions for performing set operations on lists. *)
Lemma in_set_add: forall x l, In x (set_add x l).
Proof. intros. induction l.
  - cbn. left. reflexivity.
  - cbn. destruct (beq_id a x0) eqn:E.
    + symmetry in E. apply beq_id_eq in E. subst. left. reflexivity.
    + cbn. right. auto.
Qed.

Lemma in_set_add': forall x a l, In x l -> In x (set_add a l).
Proof. intros. induction l.
      * inversion H.
      * cbn. destruct (beq_id a0 a) eqn:E. auto. destruct H.
        ++ subst. left. reflexivity.
        ++ right. auto.
Qed.

Lemma in_set_union_l: forall x l1 l2, In x l1 -> In x (set_union l1 l2).
Proof. intros. induction l1.
  - inversion H.
  - destruct H.
    + subst. cbn. apply in_set_add.
    + cbn. apply in_set_add'. auto.
Qed.

Lemma in_set_union_r: forall x l1 l2, In x l2 -> In x (set_union l1 l2).
Proof. intros. induction l1.
  - cbn. auto.
  - cbn. apply in_set_add'. auto.
Qed.

(* If a formula is satisfiable then a valuation exists over the occuring vars which interpretation is true *)
Lemma satisfiable_helper : forall p, satisfiable p -> exists v, In v (allValuations (occuring_vars p)) /\ interp v p = true.
Proof. intros. destruct H as [v]. destruct (val_in_allvals (occuring_vars p) v) as [v']. destruct H0. exists v'.
  split.
    - apply H0.
    - clear H0. rewrite <- H. clear H. induction p; cbn;
      try reflexivity; try (rewrite <- H1; auto; left; auto);
      try (rewrite IHp1, IHp2; try reflexivity; intros; apply H1; cbn; [ apply in_set_union_r |  apply in_set_union_l]; auto);
      (rewrite IHp; auto).
Qed.

Lemma solver_complete_help : forall l p v, interp v p = true -> In v l -> exists v', find_valuation_helper p l = Some v'.
Proof. induction l; intros.
  - easy.
  - destruct H0.
    + subst. exists v. cbn. rewrite H. reflexivity.
    + cbn. destruct (interp a p); eauto.
Qed.

(* Exercise 2.9. Proof of completeness of the solver. *)
Lemma solver_complete : forall p, satisfiable p -> solver p = true.
Proof.
  intros. unfold solver, find_valuation. apply satisfiable_helper in H. destruct H. destruct H.
  pose proof (solver_complete_help (allValuations (occuring_vars p)) p x0 H0 H).
  destruct H1. rewrite H1. reflexivity.
Qed.

(* Transforms (p1 -> p2) into (~p1 \/ p2) *)
Fixpoint negation_nf_1 p :=
  match p with
  | <{ p1 -> p2 }> => f_or (f_neg (negation_nf_1 p1)) (negation_nf_1 p2)
  | <{ p1 /\ p2 }> => f_and (negation_nf_1 p1) (negation_nf_1 p2)
  | <{ p1 \/ p2 }> => f_or (negation_nf_1 p1) (negation_nf_1 p2)
  | <{ ~p1 }> => f_neg (negation_nf_1 p1)
  | _ => p
  end.

(* De Morgan's Law, transforming ~(p1 \/ p2) into (~p1) /\ (~p2) and ~(p1 /\ p2) into (~p1) \/ (~p2)
   Note. This is only called on negations, so whenever (p1 \/ p2) is encountered, this is actually
   ~(p1 \/ p2). Therefore, if ~p1 is seen this actually means ~~p1 which is why p1 is returned (double neg elim).
*)
Fixpoint de_morg p :=
  match p with
  | <{(p1 \/ p2) }> => f_and (de_morg p1) (de_morg p2)
  | <{(p1 /\ p2) }> => f_or (de_morg p1) (de_morg p2)
  | f_neg p1 => p1
  | _ => f_neg p
  end.

(* Applies De Morgan's Law + double negation elimination to a formula which is assumed to have no implications *)
Fixpoint negation_nf_2 p :=
  match p with
  | <{ ~p1 }> => de_morg (negation_nf_2 p1)
  | <{ p1 /\ p2 }> => f_and (negation_nf_2 p1) (negation_nf_2 p2)
  | <{ p1 \/ p2 }> => f_or (negation_nf_2 p1) (negation_nf_2 p2)
  | _ => p
  end.

(* Converts an arbitrary formula into an equivalent one on NNF *)
Definition negation_nf p :=
  let p1 := negation_nf_1 p in
  negation_nf_2 p1.

Fixpoint distr_left p q :=
  match q with
  | <{q1 /\ q2 }> => f_and (distr_left p q1) (distr_left p q2)
  | _ => <{p \/ q}>
  end.

Fixpoint distr_right q p :=
  match q with
  | <{q1 /\ q2 }> => f_and (distr_right q1 p) (distr_right q2 p)
  | _ => distr_left q p
  end.

(* Distributes Disjunctions from left and right *)
Definition distribute p :=
  match p with
  | <{p \/ q}> => distr_right p q
  | _ => p
  end.

(* Assuming s is on negation normal form, turns it into cnf *)
Fixpoint cnf s :=
  match s with
  | <{ p /\ q }> => f_and (cnf p) (cnf q)
  | <{ p \/ q}> => distribute (f_or (cnf p) (cnf q))
  | _ => s
  end.

(* Converts a boolean formula to CNF *)
Definition cnf_conv p :=
  let p1 := negation_nf p in
  cnf p1.

Fixpoint verify_cnf_aux s (seenor : bool) :=
  match s with
  | <{ p /\ q }> => if seenor then false else (verify_cnf_aux p false) && (verify_cnf_aux q false)
  | <{ p \/ q }> => (verify_cnf_aux p true) && (verify_cnf_aux q true)
  | f_false | f_true | f_var _ => true
  | f_neg (f_var _) | f_neg (f_false) | f_neg (f_true)  => true
  | _ => false
  end.

(* Verifies that a formula is on CNF - uses helper function to ensure no more conjunctions are seen after the first disjunction*)
Definition verify_cnf s := verify_cnf_aux s false.

Conjecture cnf_works : forall p, verify_cnf (cnf_conv p) = true.

(* Check that the semantics of cnf_conv is preserved *)
Conjecture cnf_sat : forall p, solver p = solver (cnf_conv p).

From QuickChick Require Import QuickChick.

(* Derivies arbitrary for required parts, and executes QuickChick on the defined Conjectures. *)
Derive Arbitrary for id.
Derive Arbitrary for form.
Derive Show for id.
Derive Show for form.

QuickChick cnf_works.
QuickChick cnf_sat.


(** * Verifying Programming Contest Problems *)

(** ** Introduction *)

(**
    In programming contests, one of the most frustrating (and common!) verdicts to receive is Wrong Answer (WA).
    One of the reasons behind this is that there are often many potential sources of WA that a programmer has to hunt down.
    A WA could come from a typo in the implementation, or it could come from the use of a greedy observation which does not always hold, or many other reasons.

    In this tutorial, I will try to give a brief overview of how you can _prove your programs correct_ by writing specifications and proofs in the Coq proof assistant.
    Coq is based on a dependent type theory that allows you to define your programs and write proofs about them.
    Writing proofs by hand can be quite laborious, so Coq also has an interactive proving system using _tactics_ that allows you to automate away tedious parts of proofs and also prove things in a much more natural way.
    This very document is a (literate) Coq file, so you can download the source and follow along.
    By the end of this tutorial, you should be able to compile this Coq file, extract it to Ocaml, and submit your solution to an online judge!
*)

(** *** Some Disclaimers *)

(**    There are, of course, several caveats I should point out.
    The first of which is that writing out a specification and proving an algorithm correct takes a significant amount of time, even for experienced users.
    It would be utterly impractical for a contest setting, where "proofs by AC" are quite common.
    My goal is to use contest problems as a vehicle to introduce formal verification in a small-scale, concrete way--although of course program verification is also used on much larger projects.

    Secondly, we may be limited in the kinds of problems we can (easily) verify and write efficient solutions for.
    For instance, many contest problems involve mutable arrays, while when using Coq, we tend to prefer lists and other functional data structures because they are easier to reason about.
*)

(** ** A Simple Example *)

(**
    For our example, we'll solve the Codeforces problem Red and Blue Beans:
    #https://codeforces.com/contest/1519/problem/A#
    %\url{https://codeforces.com/contest/1519/problem/A}%.

    This is a pretty basic problem involving only basic arithmetic.
    The answer is [YES] if and only if [b <= r * (d+1)] and [r <= b * (d+1)].

    How can we prove this is the right condition?
    Without loss of generality, we can assume that [r <= b].
    If we wanted to maximize the number of blue beans for a given number of red beans, we would create [r] packets, each with [1] red bean and [d+1] blue beans.
    Therefore, if we have more than [r * (d+1)] blue beans, we cannot distribute all the beans; otherwise, we can.

    Now, let's get to programming our solution!
*)

Require Import Lia.
Require Import Bool.
Require Import List.
Require Import Arith.Arith.
Import ListNotations.
Require Extraction.

Definition can_distribute (r b d : nat) : bool :=
  (b <=? (r * (d + 1))) && (r <=? (b * (d + 1))).

(**
    That wasn't too bad!
    If we were programming in another language like Java or C++, we would stop here and submit our solution.
    However, even after passing hundreds of tests, we still can't be sure that is correct for all inputs.
    The only way to be certain of a program's correctness is to prove it, like we did above.
    But how do we know our _proof_ is correct?
    People make mistakes in proofs all the time.
    Luckily, Coq's type system is expressive enough to allow you to write propositions about your programs as types.
    If we can find a term [t] that has type [T], we say that [T] is _inhabited_. Interpreting [T] as a proposition, we say that [t] is _evidence_ for [T] being true.
    This effectively means that we can use Coq's type-checker as a proof-checker!
    This is known as the
    #Curry-Howard correspondence#.
*)

(**
   Okay, here's a concrete example of writing a proposition and its proof in Coq.
   When writing a specification for our original problem, we'll need to define a function [abs] that takes two natural numbers [a] and [b] and returns the absolute value [|a-b|].
*)

Definition abs (a b : nat) := max (b-a) (a-b).

(**
    Note that since we are working with natural numbers, subtraction is capped at zero--so [3 - 5 = 0], for instance.

    To show that [abs] is defined correctly, we can prove that it satisfies the properties want for all possible inputs.
    For instance, we would expect that [abs a b] is the same as [abs b a].
    We can write this proposition in Coq like so:
*)
Theorem abs_comm : forall (a b : nat), abs a b = abs b a.
(**
    We can read this like a sentence in first-order logic:
    "For all [a b], [abs a b] and [abs b a] are equal."

    By writing Proof., we enter into the interactive proving mode, where we can prove our goal by entering a series of tactics.
*)
Proof.
  (* This will make the most sense if you are following along in your own IDE! *)
  (* First, we move [a] and [b] into our local context using the [intros] tactic.
     This is like writing "Let a and b be arbitrary natural numbers." in a written proof. *)
  intros a b.
  (* Next, we unfold the definition of [abs] using the [unfold] tactic.
     Since [abs] is defined in terms of the [max] function, we can use properties about [max] to prove our goal. *)
  unfold abs.
  (* The theorem [Nat.max_comm] should be useful. We can check its type using the [Check] directive: *)
  Check Nat.max_comm.
  (* We can introduce a new hypothesis using [assert], prove it, and then use it to help prove our original goal.
   This is like introducing a lemma in a written proof. *)
  assert (H : max (b-a) (a-b) = max (a-b) (b-a)).
  (* Our lemma follows directly from the [Nat.max_comm] theorem, so we can use the [apply] tactic: *)
  { apply Nat.max_comm. }
  (* The most important thing about equalities is that if [x = y],
     then [x] and [y] are interchangeable in every context.
     We can use the [rewrite] tactic to change [max (b-a) (a-b)] in our goal to [max (a-b) (b-a)].*)
  rewrite H.
  (* Now, both sides of the equality are exactly the same, so we can discharge the goal using [reflexivity].*)
  reflexivity.
Qed.

(** It's important to stress that tactics are only high-level directions that tell Coq how to create the proof.
    The proof term itself is often much longer and harder to understand, and it is what is checked by the typechecker to verify that you have proven your theorem. You can view the proof [abs_comm] using the [Print] directive.
*)
Print abs_comm.
(* begin details : *)
(**
[[
abs_comm =
fun a b : nat =>
let H :
  Init.Nat.max (b - a) (a - b) = Init.Nat.max (a - b) (b - a) :=
  Nat.max_comm (b - a) (a - b) in
eq_ind_r (fun n : nat => n = Init.Nat.max (a - b) (b - a))
  eq_refl H
     : forall a b : nat, abs a b = abs b a
]]
*)

(* end details *)

(**
    Let's prove one more property about [abs].
    [abs a b] should be equal to the distance between [a] and [b], so if [a < b], then [a + abs a b = b], and if [b < a], then [b + abs a b = b].

    To prove this, we can use the [lia] tactic, which is a decision procedure for linear integer arithmetic.
    As our original problem involves a lot of arithmetic, [lia] will frequently come in handy.
*)

Theorem abs_correct : forall (a b : nat),
    (a  a + abs a b = b) /\
    (b  b + abs a b = a).
Proof.
  intros.
  unfold abs.
  lia.
Qed.

(** ** Specification Using Lists
*)

(** Now let's return to our original problem.
    We can write a proposition that defines whether there is a valid distribution of beans.
    For any [r,b,d], there exists a _correct distribution_ of beans if and only if there exists a set of packets such that
    - the sum of all the red beans is [r],
    - the sum of all the blue beans is [b],
    - each packet contains a positive number of red and blue beans,
    - for each packet, the number of red and blue beans should not differ by more than [d].

    The simplest way to represent a set of packets is a list.
    We'll define a [packet] as a pair of natural numbers, and we'll define the function [packet_sum] which adds up the number of red and blue beans in a list of packets.
*)

Module ListSpec.

Definition packet : Set := nat * nat.

Fixpoint packet_sum (l : list packet) := match l with
  | [] => (0,0)
  | (r,b) :: rest => let (x,y) := packet_sum rest in (r+x,b+y)
  end.

(** Now we can define what a [correct_distribution] means as define above. Here, we use the existential quantifier [exists], meaning that to prove this proposition, we must supply a valid list that all the conditions. *)

Definition correct_distribution (r b d : nat) :=
  exists l, packet_sum l = (r,b) /\ Forall (fun '(x,y) => abs x y <= d /\ x > 0 /\ y > 0) l.

Example ex1 : correct_distribution 1 1 0.
Proof.
  exists [(1,1)].
  split; unfold abs; auto.
  repeat constructor; lia.
Qed.

Example ex2 : correct_distribution 2 7 3.
Proof.
  exists [(1,4);(1,3)].
  split; unfold abs; auto.
  repeat constructor; lia.
Qed.

(** Finally, we can relate our algorithm [can_distribute] to our specification [correct_distribution].
    Our algorithm should return true if and only if [correct_distribution] is provable, meaning that there exists a list of packets that meets the conditions defined in [correct_distribution].
*)

Definition algorithm_iff_correct_distribution :=
  forall r b d,
    can_distribute r b d = true <-> correct_distribution r b d.

(** If we can prove this theorem (meaning we can find a term which has this type), we know that our algorithm is correct.
    Moreover, other people do not even need to read our proof to trust that our algorithm is correct.
    They can simply read the specification and make sure the program typechecks.
*)

(** *** Some helpful lemmas
*)

(** A few lemmas about arithmetic that will come in handy.
    We make heavy use of the [lia] to avoid having to deal with most of these proofs by hand, but for some cases (multiplication by non-constants), we need to help guide the solver: *)

Lemma d_leq_mult_d : forall d r, r > 0 -> d <= r * d.
Proof.
  intros.
  induction d; lia.
Qed.

Lemma d_bound : forall r b d x y,
  r > 0 ->
  b <= r + d ->
  y <= x * (d+1) ->
  b + y <= (r + x) * (d + 1).
Proof.
  intros.
  assert ((r+x)*(d+1) = x*(d+1) + r*(d+1)). { lia. } rewrite H2.
  assert (r+d <= r*(d+1)); try lia.
  pose proof (d_leq_mult_d d r). lia.
Qed.

(** This lemma says that we can exchange the uses of [r] and [b], meaning that if we can distribute [r] red beans and [b] blue beans, we must also be able to distribute [b] red beans and [r] blue beans, and vice versa.
    Although the proof is a bit complicated, the intuition is simple: we can flip the number of blue and red beans in each packet.
*)

Lemma distribution_flip : forall r b d,
  correct_distribution r b d <-> correct_distribution b r d.
Proof.
  assert (H:forall r b d, correct_distribution r b d -> correct_distribution b r d). {
  unfold correct_distribution.
  intros r b d [l [H2 H3]].
  generalize dependent r.
  generalize dependent b.
  induction l; intros.
  + simpl in H2. inversion H2; subst. exists []; auto.
  + destruct a as [r' b']. simpl in H2.
    remember (packet_sum l) as X. destruct X as [x y].
    inversion H2; subst.
    specialize IHl with y x.
    destruct IHl; auto. inversion H3; auto.
    destruct H.
    exists ((b',r')::x0).
    split. simpl. rewrite H. auto.
    constructor; auto. inversion H3; subst. destruct H5 as [Ha [Hr Hb]]. split; auto; unfold abs in *; try lia.
  }
  split; apply H.
Qed.

(** Here is the crucial lemma proving that our algorithm's conditions is sufficient. Note that we assume that [r <= b], like we did in the informal proof.
 *)
Lemma can_make_distr : forall r b d,
    r <= b ->
    b <= r * (d+1) ->
    correct_distribution r b d.
Proof.
  intros r b d r_leq_b H.
  generalize dependent b.
  induction r; intros.
  - assert (b = 0). lia. subst. exists []. auto.
  - remember (min (b - r) (d + 1)) as t.
    specialize IHr with (b-t).
    assert (Hr : r <= b - t). { lia. } apply IHr in Hr.
    destruct Hr as [l [Hl1 Hl2]].
    exists ((1,t) :: l); split.
    + simpl. rewrite Hl1.
      assert (Htb: t + (b - t) = b). { lia. } rewrite Htb.
      reflexivity.
    + constructor; try auto; split; try lia. unfold abs; lia.
    + simpl in H.
      pose proof (Nat.min_spec (b-r) (d+1)) as [[Hmin1 minEq] | [Hmin2 minEq]]; rewrite minEq in Heqt.
      subst. assert (b - (b - r) = r). lia. rewrite H0.
      rewrite plus_comm. rewrite <- mult_n_Sm. lia.

      subst. lia.
Qed.

(** Next, we'll prove that our algorithm's condition is necessary, meaning that if there is a list [l] that shows that [correct_distribution r b d] is true, then [b <= r * (d + 1)] and [r <= b * (d + 1)].

    The proof proceeds by induction on the list [l].

*)
Theorem algorithm_condition_necessary : forall r b d,
  correct_distribution r b d -> can_distribute r b d = true.
Proof.
  unfold correct_distribution, can_distribute.
  intros.
  destruct H as [l [H1 H2]].
  unfold can_distribute.
  rewrite andb_true_iff. repeat rewrite Nat.leb_le.
  generalize dependent b.
  generalize dependent r.
  induction l; intros.
  + simpl in H1. inversion H1; subst. lia.
  + destruct a as [r' b']. simpl in H1. remember (packet_sum l) as X. destruct X as [x y]. inversion H1; subst; clear H1.
    inversion H2; subst. apply IHl with x y in H3; auto.
    unfold abs in H1.
    split; apply d_bound; lia.
Qed.

(** *** The proof of correctness!
*)
Theorem algorithm_correct : algorithm_iff_correct_distribution.
Proof.
  unfold algorithm_iff_correct_distribution.
  intros.
  split; intros.
  - unfold can_distribute in H.
    rewrite andb_true_iff in H. repeat rewrite Nat.leb_le in H. destruct H as [H1 H2].
    (* Case on whether r <= b or b <= r. *)
    assert (r <= b \/ b <= r) as [Hrb | Hbr]. lia.
    + apply can_make_distr; auto.
    + apply distribution_flip. apply can_make_distr; auto.

  - apply algorithm_condition_necessary; auto.
Qed.
End ListSpec.

(** ** Specification Using Inductive Relations *)

(**
    We've done it! We have defined our specification using lists and proven that our algorithm always computes the correct answer according to our specification.

    Now that we know for certain that our program is correct, we can proceed to extracting the program into Ocaml.
    Before we move on, however, I want to present another specification for this problem, this time defining [correct_distribution] as an inductive proposition.

    While it may be natural to interpret the specification using lists, it does make the definitions more complicated, which affects the length and readability of the proofs.
    This alternate specification is equivalent (in fact, proving that these two specifications are equivalent is a good exercise), but it requires a lot less unfolding and destructing, which simplifies the proofs.

*)

Module InductiveSpec.
Inductive correct_distribution : nat -> nat -> nat -> Prop :=
  | no_packets : forall d,
      correct_distribution 0 0 d
  | add_packet : forall r b r' b' d,
      correct_distribution r b d ->
      r' > 0 ->
      b' > 0 ->
      abs r' b' <= d ->
      correct_distribution (r'+r) (b'+b) d.
Hint Constructors correct_distribution : core.

Definition algorithm_iff_correct_distribution :=
  forall r b d,
    can_distribute r b d = true <-> correct_distribution r b d.

Lemma distribution_flip : forall r b d,
  correct_distribution r b d <-> correct_distribution b r d.
Proof.
  assert (H:forall r b d, correct_distribution r b d -> correct_distribution b r d). {
  intros r b d H.
  induction H.
  - auto.
  - constructor; auto. unfold abs in *. lia. }

  split; apply H.
Qed.

Lemma can_make_distr : forall r b d,
    r <= b ->
    b <= r * (d+1) ->
    correct_distribution r b d.
Proof.
  intros r b d r_leq_b H.
  generalize dependent b.
  induction r; intros.
  - assert (b = 0). lia. subst. auto.
  - remember (min (b - r) (d + 1)) as t.
    specialize IHr with (b-t).
    assert (Hb: b = t+(b-t)). { lia. } rewrite Hb.
    assert (Hr: S r = 1 + r). { lia. } rewrite Hr.
    constructor; unfold abs; try apply IHr; try lia.
Qed.

Theorem algorithm_correct : algorithm_iff_correct_distribution.
Proof.
  unfold algorithm_iff_correct_distribution.
  split; intros.
  - unfold can_distribute in H.
    rewrite andb_true_iff in H. repeat rewrite Nat.leb_le in H. destruct H as [H1 H2].
    (* Case on whether r <= b or b <= r. *)
    assert (r <= b \/ b <= r) as [Hrb | Hbr]. lia.
    + apply can_make_distr; auto.
    + apply distribution_flip. apply can_make_distr; auto.
  - unfold can_distribute.
    rewrite andb_true_iff. repeat rewrite Nat.leb_le.
    induction H.
    + lia.
    + split; apply ListSpec.d_bound; unfold abs in H2; try lia.
Qed.

End InductiveSpec.

(** ** Extraction *)
(**
    Now we can extract our verified algorithm to Ocaml.
    We don't extract our proofs, since they not actually meant to be run.
    So in this case, we only need to extract our function [can_distribute], which is quite simple.
    We can try running the extraction command now:
*)
Extraction "imp.ml" can_distribute.
(**
    If you look in the file [imp.ml], you will see the following datatype definitions at the top:

[[
type bool =
  | True
  | False
]]

[[
type nat =
  | O
  | S of nat
]]

Without any directions on how to perform the extraction, Coq will redefine all the datatypes that are used, including booleans and nat.
This is a big problem for nat, since defining numbers Peano-style is quite inefficient--if you look how addition is defined, adding two numbers is actually linear in the size of the first number.
We can tell Coq to extract nat to [int] or [int64], but this can be quite dangerous. This is because theorems about nat may no longer hold. For instance, it is a theorem for nat that [x + y >= x], but this is not true for [int] or [int64], since there may be overflow cases.

In this case, since we know that the inputs are less than [10^9], we can determine that we will not run into overflow issues.
So, we can safely extract nat to [int64].
So, I chose
If you would like, you can also extract to an arbitrary precision integer type like [big_int].
*)

Module ExtractionDefs.
Module ExtrNatToInt64.
Extract Inductive nat => "int64"
  [ "Int64.zero" "(fun x -> Int64.succ x)" ]
  "(fun zero succ n -> if Int64.compare n 0 = 0 then zero () else succ (Int64.pred n))".
Extract Constant plus => "Int64.add".
Extract Constant mult => "Int64.mul".
Extract Constant leb => "(fun x y -> Int64.compare x y <= 0)".
End ExtrNatToInt64.

Extract Inductive bool => "bool" [ "true" "false" ].
End ExtractionDefs.

Extraction "imp.ml" can_distribute.
(**
    And there we have it--a fully verified program that you can submit to Codeforces!
    You can see #here# for a version that includes the input/output plumbing.

*)


(** Advanced recursive functions *)
(** Recursion using Function *)

Require Import FunInd.
Require Import Coq.Lists.List.
Require Import Arith.
Require Import Recdef.
Require Import Program.
Load CpdtTactics.

(* Using {struct n}
   structural recursive function -
   like Fixpoint
*)

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

(* Using {measure n}
   non-structural recursive function
*)

Function revapp (m n : list nat) {measure length n} :=
match n with
| nil => m
| _   => cons (hd 0 n) (revapp m (tl n))
end.
intros. eauto.
Defined.

(** Equal equation to get rid of the decreasing lemma in subsequent proofs *)
Check revapp_equation.

Definition lengthOrder (x y:list nat) :=
   length x < length y.

Hint Constructors Acc.

Theorem lengthOrder_wf' : forall len,
     forall ls, length ls <= len ->
          Acc lengthOrder ls.
Proof.
unfold lengthOrder; induction len; crush.
Qed.

Function revapp_ (m n : list nat) {wf lengthOrder n} :=
match n with
| nil => m
| _   => cons (hd 0 n) (revapp_ m (tl n))
end.
intros. simpl. unfold lengthOrder. eauto.
unfold well_founded. intro.
eapply lengthOrder_wf'. auto.
Defined.

Check revapp_equation.

(** Tactic functional induction (qualid term+) *)
(* The tactic functional induction performs case analysis and induction
   following the definition of a function. It makes use of a principle
   generated by Function or Functional Scheme.
*)

Functional Scheme revapp_ind := Induction for revapp Sort Prop.

Check revapp_ind.

(** ?? func_ind only possible for simple(?) cases*)

(** Simple example proof with functional induction*)

Functional Scheme minus_ind := Induction for minus Sort Prop.

Check minus_ind.

Lemma le_minus (n m:nat) : n - m <= n.
(* 1 subgoal

  n, m : nat
  ============================
  n - m <= n
*)
functional induction (minus n m) using minus_ind; simpl; auto.

Qed.

(** using program fixpoint - nested recursion is possible*)

Program Fixpoint revapp' (m n : list nat) {measure (length n)}  :=
  match n with
  | nil => m
  | _   => cons (hd 0 n) (revapp' m (tl n))
  end.

Obligations.

Print All.

(** Diff between Program Fixpoint and Function *)
(* As you already mentioned, Program Fixpoint allows the measure to look at more than one argument.
Function creates a foo_equation lemma that can be used to rewrite calls to foo with its RHS. Very useful to avoid problems like Coq simpl for Program Fixpoint.
In some (simple?) cases, Function can define a foo_ind lemma to perform induction along the structure of recursive calls of foo. Again, very useful to prove things about foo without effectively repeating the termination argument in the proof.
Program Fixpoint can be tricked into supporting nested recursion, see https://stackoverflow.com/a/46859452/946226. This is also why Program Fixpoint can define the Ackermann function when Function cannot.*)


Require Import Omega.
Require Import Tactics.Tactics.
From Equations Require Import Equations.
Import Sigma_Notations.

Set Implicit Arguments.
Open Scope equations_scope.
Notation "{< x >}" := (sigmaI _ _ x).

Inductive Fin : nat -> Set :=
| FZ : forall k, Fin (S k)
| FS : forall k, Fin k -> Fin (S k).

Inductive Vect : nat -> Type -> Type :=
| Nil : forall A, Vect 0 A
| Cons : forall n A, A -> Vect n A -> Vect (S n) A.
Derive Signature Subterm for Vect.

Arguments Nil {A}.

Section Length.
  Equations length {A} {n} (xs : Vect n A) : nat :=
    length Nil := 0;
    length (Cons x xs) := S (length xs).

  Theorem lengthCorrect :
    forall A n (xs : Vect n A), length xs = n.
  Proof.
    intros; funelim (length xs); auto.
  Qed.
End Length.

Equations tail {A} {n} (xs : Vect (S n) A) : Vect n A :=
  tail (Cons x xs) := xs.

Equations head {A} {n} (xs : Vect (S n) A) : A :=
  head (Cons x xs) := x.

Equations last {A} {n} (xs : Vect (S n) A) : A :=
last xs by rec (signature_pack xs) Vect_subterm :=
  last (Cons x Nil) := x;
  last (Cons x ys) := last ys.

Equations init {A} {n} (xs : Vect (S n) A) : Vect n A :=
init xs by rec (signature_pack xs) Vect_subterm :=
  init (Cons x Nil) := Nil;
  init (Cons x ys) := Cons x (init ys).

Equations index {A} {n} (f : Fin n) (xs : Vect n A) : A :=
  index FZ (Cons x xs) := x;
  index (FS f) (Cons x xs) := index f xs.

Equations insertAt {A} {n} (f : Fin (S n)) (y : A) (xs : Vect n A) : Vect (S n) A :=
  insertAt FZ y xs := Cons y xs;
  insertAt (FS f) y (Cons x xs) := Cons x (insertAt f y xs).

Equations replaceAt {A} {n} (f : Fin n) (y : A) (xs : Vect n A) : Vect n A :=
  replaceAt FZ y (Cons x xs) := Cons y xs;
  replaceAt (FS f) y (Cons x xs) := Cons x (replaceAt f y xs).

Theorem replaceIndex :
  forall A n (y : A) (xs : Vect n A) (f : Fin n),
    index f (replaceAt f y xs) = y.
Proof.
  induction xs; intros.
  - depelim f.
  - depelim f; simp replaceAt index.
Qed.

Equations take {A} n {m} (xs : Vect (n + m) A) : Vect n A :=
  take 0 xs := Nil;
  take (S n) (Cons x xs) := Cons x (take n xs).

Equations drop {A} n {m} (xs : Vect (n + m) A) : Vect m A :=
  drop 0 xs := xs;
  drop (S n) (Cons x xs) := drop n xs.

Equations takeWhile {A} {n} (p : A -> bool) (xs : Vect n A) :
    &{ m : nat & Vect m A } :=
  takeWhile p Nil := {< Nil >};
  takeWhile p (Cons x xs) <= p x => {
    takeWhile p (Cons x xs) true :=
      let ys := takeWhile p xs in {< Cons x (ys.2) >};
    takeWhile p (Cons x xs) false :=
      {< Nil >}
  }.

Equations dropWhile {A} {n} (p : A -> bool) (xs : Vect n A) :
    &{ m : nat & Vect m A } :=
  dropWhile p Nil := {< Nil >};
  dropWhile p (Cons x xs) <= p x => {
    dropWhile p (Cons x xs) true := dropWhile p xs;
    dropWhile p (Cons x xs) false := {< Cons x xs >}
  }.

Equations append {A} {n m} (xs : Vect n A) (ys : Vect m A) : Vect (n + m) A :=
  append Nil ys := ys;
  append (Cons x xs) ys := Cons x (append xs ys).

Equations replicate {A} n (x : A) : Vect n A :=
  replicate 0 x := Nil;
  replicate (S n) x := Cons x (replicate n x).

Theorem takeDropAppend :
  forall A n m (xs : Vect (n + m) A),
    append (take n xs) (drop n xs) = xs.
Proof.
  induction n; intros.
  - trivial.
  - depelim xs; simp take drop append.
    now rewrite IHn.
Qed.

Lemma Vectn :
  forall A n m, Vect n A = Vect m A -> n = m.
Proof.
Admitted.

Lemma JMeqCons :
  forall A n m (a : A) (b : Vect n A) (c : Vect m A),
    b ~= c -> Cons a b ~= Cons a c.
Proof.
  intros. depelim H.
  apply Vectn in H; subst.
  now rewrite H0.
Qed.

Theorem takeDropWhileAppend :
  forall A n (p : A -> bool) (xs : Vect n A),
    append (takeWhile p xs).2 (dropWhile p xs).2 ~= xs.
Proof.
  induction n; intros.
  - depelim xs; intuition.
  - funelim (takeWhile p xs); funelim (dropWhile p (Cons a v)); simpl in *.
    + simp append.
      specialize (IHn p v0).
      remember (append (takeWhile p v0).2 (dropWhile p v0).2) as ys; clear Heqys.
      now apply JMeqCons.
    + rewrite Heq in Heq0; discriminate.
    + rewrite Heq in Heq0; discriminate.
    + simp append.
Qed.

Section Reverse.
  Equations Vect_plus_n_O_inject {A} {n} (xs : Vect n A) : Vect (n + 0) A :=
    Vect_plus_n_O_inject xs := _.
  Next Obligation.
    rewrite <- plus_n_O; exact xs.
  Defined.

  Equations Vect_plus_S_inject {A} {n m} (xs : Vect (S n + m) A)
      : Vect (n + S m) A :=
    Vect_plus_S_inject xs := _.
  Next Obligation.
    assert (S n + m = n + S m). omega.
    rewrite <- H; exact xs.
  Defined.

  Equations reverseHelper {A} {n} {m} (acc : Vect n A) (ys : Vect m A)
      : Vect (n + m) A :=
  reverseHelper acc ys by rec (signature_pack ys) Vect_subterm :=
    reverseHelper acc Nil := Vect_plus_n_O_inject acc;
    reverseHelper acc (Cons y ys) :=
      Vect_plus_S_inject (reverseHelper (Cons y acc) ys).

  Equations reverse {A} {n} (xs : Vect n A) : Vect n A :=
    reverse xs := reverseHelper Nil xs.

  Lemma reverseInvolutive :
    forall A n (xs : Vect n A),
      reverse (reverse xs) = xs.
  Proof.
    intros; simp reverse.
  Admitted.
End Reverse.


From Coq Require Import Arith Bool.

(* At its core, Coq is a *typed* programing language *)
(* There are a few (not many!) built-in types *)
(*

   On the online version, you can move your cursor up and down with
   Alt+p and Alt+n respectively.

   The result of the command should show up in the lower right hand
   side of the screen.

   Remember to leave it time to load up at the very beginning!

 *)
Check 3.
Check 3 + 4.
Check true.
Check (true && false).

(* And so it can evaluate progr==ams *)
Eval compute in (3 + 4).
Eval compute in (true && false).

(* Every top-level command starts with a capital letter and ends with a period. *)
(* Grammar was very important to the original implementers... *)

(* No side effects though, so no printing, scanning or reading from a file! *)
Fail Check print.

(* Not to be confused with the *top level command* "Print", which asks
the Coq *system* to print a definition. *)
Print bool.

(*

  NB: Every piece of data in a program is *constant* and *immutable*
  There are good reasons for this, which we will go into later.

 *)

(* We can define types. This is a simple sum type *)
Inductive week_day :=
| Monday : week_day
| Tuesday : week_day
| Wednesday : week_day
| Thursday : week_day
| Friday : week_day
| Saturday : week_day
| Sunday : week_day.

Check Thursday.

(* And we can define functions *)
Definition add_one (x : nat) : nat := x + 1.
Definition return_monday (w : week_day) : week_day := Monday.

Check add_one.
Eval compute in (add_one 2).

Check return_monday.

(* We can work by cases over sum types. *)
Definition is_monday (w : week_day) : bool :=
  match w with
  | Monday => true
  | _ => false
  end.

Check is_monday.

Eval compute in (is_monday Tuesday).

(* There is a powerful search feature, which takes types and returns
     potentially useful functions with similar types *)
(* WARNING: this does not work on the online version! *)

Search (bool -> bool).

(* We can define types which may be recursive, e.g. the type of lists *)
Inductive week_day_list :=
| Nil : week_day_list
| Cons : week_day -> week_day_list -> week_day_list.

Check (Cons Monday (Cons Tuesday Nil)).
Eval compute in (Cons Monday (Cons Tuesday Nil)).

(* Ok, we have lisp-style lists. Can we define head? *)
Definition head (l : week_day_list) (default : week_day) : week_day :=
  match l with
  | Nil => default
  | Cons w _ => w
  end.
(* We need a default value! A little unfortunate... but the price of being pure! *)

(* How about tail? *)
Definition tail (l : week_day_list) : week_day_list :=
  match l with
  | Nil => Nil
  | Cons _ w => w
  end.

Eval compute in (tail (Cons Monday (Cons Tuesday Nil))).

(* List notation a la lisp is tedious. Thankfully, Coq's notation system is incredibly powerful! *)

Notation "[ ]" := Nil.

Notation "[ w ]" := (Cons w Nil).

Notation "[ w1 ; w2 ; .. ; wn ]" := (Cons w1 (Cons w2 .. (Cons wn Nil) .. )).

Definition work_week := [Monday; Tuesday; Wednesday; Thursday; Friday].

Eval compute in work_week.

(* All right, let's define some funner things. *)

Definition eq_wd (w1 : week_day) (w2 : week_day) : bool :=
  match (w1, w2) with
  | (Monday, Monday) => true
  | (Tuesday, Tuesday) => true
  | (Wednesday, Wednesday) => true
  | (Thursday, Thursday) => true
  | (Friday, Friday) => true
  | (Saturday, Saturday) => true
  | (Sunday, Sunday) => true
  | _ => false
  end.

(* How about a length function? This requires a special syntax: *)
Fixpoint length (l : week_day_list) : nat :=
  match l with
  | [] => 0
  | Cons w ws => (length ws) + 1
  end.

Eval compute in (length work_week).

(* Now let's define a membership function *)
Fixpoint is_a_member (w : week_day) (l : week_day_list) : bool :=
  match l with
  | [] => false
  | Cons w' ws => eq_wd w w' || is_a_member w ws
  end.

(* Let's test it: *)
Eval compute in (is_a_member Monday work_week).
Eval compute in (is_a_member Sunday work_week).

(* Ok, we're ready for some specifications! *)
(* The simplest kind of specification is equality: *)
Check (Monday = Monday).

(* The Prop type is the type of *specifications*. It is *not* bool! *)
Check (forall w, w = Monday).
Check (exists w, w = Monday).

(* The basic propositional connectives: *)
(* True. Always provable. *)
(* False. Never provable. *)
(* P\/Q. Provable if one of P or Q (or both) is provable. *)
(* P/\Q. Provable if both P and Q are provable. *)
(* P -> Q. Provable if, when *assuming* P is provable, then so is Q. *)
(* ~P. Provable if P is *never* provable *)
(* forall x : A, P x. Provable if for an *arbitrary* x (of type A), P x is provable. *)
(* exists x : A, P x. Provable if there is some *specific* a such that P a is provable. *)
(* a = b. Provable if, in fact, a is equal to b. Not to be confused
   with ":=" which is how we define functions and constants (and is
   *not* a connective).  *)

(* Obviously, we can state specifications about infinite types as well: *)

Check (forall l : week_day_list, l = [] \/ exists w l', l = Cons w l').

(* Some of these specifications are provable, some are not. *)

(* We give some basic tools to prove some of these specs: *)

Lemma test1 : forall x y : week_day, x = y -> x = y.
Proof.
Abort.

(* ---------------------------------------------------------
     There are some simple cheats on how to prove various kinds of specifications:
     roughly, one can try certain tactics based on the *shape* of the goal and the
     hypotheses. The breakdown is like this:

     |               |   in goal   |   in hypotheses   |
     |---------------+-------------+------------------ |
     | A -> B        |  intros     |      apply        |
     | A /\ B        |  split      |     destruct      |
     | A \/ B        |  left/right |     destruct      |
     | ~A            |  intro      |      apply        |
     |  True         |  trivial    |       N/A         |
     |  False        |    N/A      |   contradiction   |
     | forall x, P x |  intros     |      apply        |
     | exists x, P x |  exists t   |     destruct      |
     | t = u         | reflexivity | rewrite/inversion |

     but of course, these will not always suffice in all situations.
 *)

(* Here's how one proves trivial equalities: *)
Lemma test2 : Monday = Monday.
Proof.
Abort.

(* It's nice to know that this doesn't always work: *)
Lemma test2_fail : Monday = Friday.
Proof.
  Fail reflexivity.
Abort.

(* We can also perform computation steps in proofs, in order to
     prove things about functions: *)
Lemma test3 : return_monday Friday = Monday.
Proof.
Abort.

Lemma test3' : length work_week = 5.
Proof.
Abort.

(* But really we're interested in behavior over *all inputs*. *)
Lemma test4 : forall x : week_day, return_monday x = Monday.
Proof.
Abort.

(* How about this? Hint: use the [case some_variable] tactic *)
Lemma test5 : forall x : week_day, eq_wd x x = true.
Proof.
Abort.

(* Let's play with some logical connectives *)
Lemma test6 : forall x y z : week_day, x = y -> y = z -> x = y /\ y = z.
Proof.
Abort.

Lemma test7 : forall x y z : week_day, x = y -> x = y \/ y = z.
Proof.
Abort.

Lemma test8 : forall x y z : week_day, x = y /\ y = z -> y = z.
Proof.
Abort.

(* This one is a little tougher! tactic order matters! *)
Lemma test9 : forall x y z : week_day, x = y \/ x = z -> x = z \/ x = y.
Proof.
Abort.

(* Proofs involving equalities *)
Lemma test10 : forall x y, x = Monday -> y = x -> y = Monday.
Proof.
Abort.

Lemma test11 : Monday = Tuesday -> False.
Proof.
Abort.

(* All right we're ready for some serious stuff *)
Lemma first_real_lemma : forall x y, x = y -> eq_wd x y = true.
Proof.
Abort.

(* The other direction is harder! *)
Lemma second_real_lemma : forall x y, eq_wd x y = true -> x = y.
Proof.
Abort.

(* Now we have a program which we have proven correct! We can use this to prove some theorems! *)
Lemma test12 : Monday = Monday.
Proof.
Abort.

(* Let's show correctness of our membership function! But first we need to *specify* membership. *)
(* To do this, we specify an *inductive predicate*, which describes all the ways an element can be in a list. *)
(* We can again use the keyword inductive. *)
Inductive Mem : forall (w : week_day) (l : week_day_list), Prop :=
| Mem_head : forall w l, Mem w (Cons w l)
| Mem_tail : forall w w' l, Mem w l -> Mem w (Cons w' l).

(* We can apply constructors of Mem like lemmas *)
Lemma test13 : Mem Monday [Tuesday; Monday; Thursday].
Proof.
Abort.

(* Here's some fun existential statements: *)
Lemma test14 : exists w, Mem w work_week.
Proof.
Abort.

(* This is harder! We'll be able to prove this easily once we have the
     theorems.
 *)
Lemma test15 : exists w, ~ (Mem w work_week).
Proof.
Abort.

(* The theorems we want are these: *)
Theorem is_a_member_correct : forall w l, is_a_member w l = true -> Mem w l.
Proof.
Abort.

Theorem is_a_member_complete : forall w l, Mem w l -> is_a_member w l = true.
Proof.
Abort.

(*

  Finally, it's important to note that I purposefully hid a number of
  powerful tactics from you, for pedagogical reasons. The easiest of
  these is [auto], which tries to apply simple steps to finish a
  goal. Exercise: how much easier are the lemmas to prove using
  [auto]?

*)

(*

  There is still a lot to learn! You can check out the resources on
  https://coq.inria.fr/, most notably the tutorials on
  https://coq.inria.fr/documentation.

  You can try more online stuff on rhino-coq:
  https://x80.org/rhino-coq/

  I have a few things on my github:
  https://github.com/codyroux?tab=repositories&q=&type=&language=coq

  Or create an account on https://coq.zulipchat.com, and ask questions
  there!

  Go forth and prove!

 *)