Require Import Bool Arith Coq.Arith.Euclid List.
Require Import BellantoniCook.Lib BellantoniCook.Bitstring BellantoniCook.BC BellantoniCook.BCLib.

Fixpoint unary_preserv (e : BC) : bool :=
  match e with
    | zero => true
    | proj n s j => true
    | succ b => b
    | pred => true
    | cond => true
    | rec g h0 h1 => unary_preserv g  &&
                     unary_preserv h0 &&
                     unary_preserv h1
    | comp _ _ h nl sl => unary_preserv h &&
                          forallb unary_preserv nl &&
                          forallb unary_preserv sl
  end.

 Lemma preservation : forall (e : BC) (vnl vsl : list bs),
  unary_preserv e = true ->
  forallb unary vnl = true ->
  forallb unary vsl = true ->
  unary (sem e vnl vsl) = true.
Proof.
 induction e using BC_ind2; simpl; intros; trivial.

 case n; simpl.
 apply forallb_nth; simpl; trivial.
 intros; case (leb i n0); apply forallb_nth; simpl; trivial.

 subst; simpl; apply forallb_hd; simpl; trivial.

 apply forallb_tl; trivial.
 apply forallb_hd; simpl; trivial.

 destruct vsl; simpl; trivial.
 simpl in H1;rewrite andb_true_iff in H1.
 destruct vsl; simpl; trivial.
 simpl in H1;rewrite andb_true_iff in H1.
 destruct vsl; simpl; trivial.
 case l; trivial; tauto.
 destruct vsl; simpl; trivial.
 simpl in H1;rewrite andb_true_iff in H1.
 case l; trivial; intros.
 tauto.
 case b; tauto.
 simpl in H1;rewrite andb_true_iff,andb_true_iff in H1.
 case l; trivial; try tauto; intros.
 case b; tauto.

 repeat rewrite andb_true_iff in H.
 assert (unary (hd nil vnl) = true).
 apply forallb_hd; trivial.
 induction (hd nil vnl); simpl in *; intros.
 apply IHe1; [ tauto | apply forallb_tl | ];  trivial.
 case a.
 rewrite andb_true_iff in H2.
 apply IHe3; [ tauto | | ]; simpl.
 rewrite andb_true_iff; split; [tauto | ].
 apply forallb_tl; trivial.
 rewrite andb_true_iff; split.
 apply IHl; tauto.
 trivial.
 rewrite andb_true_iff in H2.
 apply IHe2; [ tauto | | ]; simpl.
 rewrite andb_true_iff; split; [tauto | ].
 apply forallb_tl; trivial.
 rewrite andb_true_iff; split.
 apply IHl; tauto.
 trivial.

 repeat rewrite andb_true_iff in H1.
 apply IHe; [ tauto | | ].
 apply forallb_map; auto; intros.
 apply H; trivial.
 rewrite forallb_forall in H1.
 decompose [and] H1.
 auto.
 apply forallb_map; auto; intros.
 apply H0; trivial.
 decompose [and] H1.
 rewrite forallb_forall in H6.
 auto.
Qed.

(** * Zero

  - with any arities (n, s)
*)

Lemma zero_correct n s l1 l2:
 length (sem (zero_e n s) l1 l2) = 0.
Proof.
 intros; simpl; trivial.
Qed.

(** * One

  - with any arities (n, s)
*)

Definition one_e (n s:nat) : BC :=
  comp n s (comp 0 0 (succ true) nil (zero :: nil)) nil nil.

Lemma one_correct n s l1 l2:
 length (sem (one_e n s) l1 l2) = 1.
Proof.
 intros; simpl; trivial.
Qed.

(** * Successor

  - arities: (1, 0)
*)

Definition succ_e : BC := succ true.

Lemma succ_correct :
  forall n, length (sem succ_e nil [n]) = S (length n).
Proof.
 intros; simpl; trivial.
Qed.

(** * Conversion from [nat] to [BC]

  - with any arities (n, s)
*)

Fixpoint nat2BC (n s x:nat) : BC :=
  match x with
    | 0 => zero_e n s
    | S x' => comp n s succ_e nil [nat2BC n s x']
  end.

Lemma nat2BC_arities : forall n s x, arities (nat2BC n s x) = ok_arities n s.
Proof.
induction x as [ | x IH].
trivial.
simpl nat2BC.
rewrite comp_arities.
trivial.
trivial.
simpl; trivial.
simpl; tauto.
Qed.

Lemma nat2BC_correct :
  forall n s x nl sl, length (sem (nat2BC n s x) nl sl) = x.
Proof.
induction x as [ | x IH].
trivial.
intros nl sl.
simpl nat2BC.
rewrite sem_comp.
simpl.
rewrite IH.
trivial.
Qed.

Opaque succ_e.

(** * Addition

  - arities: (1,1)
*)

Definition plus_e : BC :=
  rec (proj 0 1 0)
      (comp 1 2 succ_e nil ((proj 1 2 1) :: nil))
      (comp 1 2 succ_e nil ((proj 1 2 1) :: nil)).

Lemma plus_correct :
  forall m n, length (sem plus_e [m] [n]) = length m + length n.
Proof.
  induction m; simpl in *; intros; trivial.
  case a; simpl; rewrite succ_correct; auto.
Qed.

Opaque plus_e.

Fixpoint plusl_e (n:nat)(el:list BC) : BC :=
  match el with
    | nil => zero_e n 0
    | e' :: el' => comp n 0 plus_e [e'] [plusl_e n el']
  end.

Lemma plusl_arities n el :
  andl (fun e => arities e = ok_arities n 0) el ->
  arities (plusl_e n el) = ok_arities n 0.
Proof.
induction el as [ | e' el' IH].
trivial.
intro H.
simpl in H.
simpl plusl_e.
rewrite comp_arities.
trivial.
trivial.
simpl; tauto.
simpl; tauto.
Qed.

Lemma plusl_correct :
  forall n nl el,
  length (sem (plusl_e n el) nl nil) = plusl (map (fun e => length (sem e nl nil)) el).
Proof.
induction el as [ | e el IH]; simpl.
trivial.
rewrite plus_correct, IH.
trivial.
Qed.

(** * Logical or

  - arities: (1,1)
*)

Notation or_e := plus_e (only parsing).

Lemma or_correct :
  forall b1 b2, bs2bool (sem or_e [bool2bs b1] [bool2bs b2]) = b1 || b2.
Proof.
intros [ | ] [ | ]; reflexivity.
Qed.

(** * Multiplication

  - arities: (2,0)
*)

Definition mult_e : BC :=
  rec (zero_e 1 0)
      (comp 2 1 plus_e ((proj 2 0 1) :: nil) ((proj 2 1 2) :: nil))
      (comp 2 1 plus_e ((proj 2 0 1) :: nil) ((proj 2 1 2) :: nil)).

Lemma mult_correct :
  forall m n, length (sem mult_e [m; n] nil) = (length m) * (length n).
Proof.
induction m; intro n; trivial; simpl in *.
case a; rewrite plus_correct; auto.
Qed.

Opaque mult_e.

(** Logical and

  - arities: (2,0)
*)

Notation and_e := mult_e (only parsing).

Lemma and_correct :
  forall b1 b2, bs2bool
    (sem and_e [bool2bs b1; bool2bs b2] nil) = b1 && b2.
Proof.
intros [ | ] [ | ]; reflexivity.
Qed.

(** * Minus (with reversed arguments)

  - arities: (1,1)
*)

Definition minus_rev_e : BC :=
  rec (proj 0 1 0)
      (comp 1 2 pred nil ((proj 1 2 1) :: nil))
      (comp 1 2 pred nil ((proj 1 2 1) :: nil)).

Lemma minus_rev_correct :
  forall m n, length (sem minus_rev_e [n] [m]) = (length m) - (length n).
Proof.
 induction n; simpl in *; [ omega | ].
 case a; rewrite length_tail, IHn; omega.
Qed.

Opaque minus_rev_e.

(** * Less than predicate

  - arities: (1,1)
*)

Notation lt_e := minus_rev_e.

Lemma lt_correct v1 v2:
  bs2bool (sem lt_e [v1] [v2]) = true ->
  length v1 < length v2.
Proof.
  intros; simpl in *.
  apply bs_nat2bool_true in H.
  rewrite minus_rev_correct in H; omega.
Qed.

Lemma unary_tl l :
  unary l = true ->
  unary (tl l) = true.
Proof.
 intros.
 destruct l; simpl; trivial.
 simpl in H.
 rewrite andb_true_iff in H; tauto.
Qed.

Lemma lt_correct_conv_bool v1 v2:
  unary v2 = true ->
  length v1 < length v2 ->
  bs2bool (sem lt_e [v1] [v2]) = true.
Proof.
  intros; simpl in *.
  apply bs_nat2bool_true_conv.
  Transparent lt_e.
  simpl.
  Opaque lt_e.
  induction v1; simpl; trivial.
  case a.
  apply unary_tl.
  apply IHv1.
  simpl in *; omega.
  apply unary_tl.
  apply IHv1.
  simpl in *; omega.
  rewrite minus_rev_correct.
  omega.
Qed.

Lemma lt_correct_conv v1 v2 :
  unary v1 = true ->
  unary v2 = true ->
  bs2bool (sem lt_e [v1] [v2]) = false ->
  length v2 <= length v1.
Proof.
  intros; trivial.
  apply bs_nat2bool_false in H1.
  rewrite minus_rev_correct in H1.
  omega.
  apply preservation; simpl; try reflexivity;
  rewrite andb_true_iff; auto.
Qed.

Lemma lt_correct_conv_nil v1 v2 :
  unary v1 = true ->
  unary v2 = true ->
  sem lt_e [v1] [v2] = nil ->
  length v2 <= length v1.
Proof.
  intros; trivial.
  assert (bs2bool (sem lt_e [v1] [v2]) = false).
  rewrite H1; simpl; trivial.
  apply bs_nat2bool_false in H2.
  rewrite minus_rev_correct in H2.
  omega.
  apply preservation; simpl; try reflexivity;
  rewrite andb_true_iff; auto.
Qed.

(** * Less than or equal to predicate

  - arities: (1,1)
*)

Definition le_e : BC :=
  comp 1 1 lt_e (proj 1 0 0 :: nil) (comp 1 1 succ_e nil (proj 1 1 1 :: nil) :: nil).

Lemma le_correct : forall v1 v2,
  bs2bool (sem le_e [v1] [v2]) = true ->
  length v1 <= length v2.
Proof.
  intros v1 v2 H; simpl in H.
  apply lt_correct in H.
  rewrite succ_correct in H.
  omega.
Qed.

Lemma le_correct_conv v1 v2 :
  unary v1 = true ->
  unary v2 = true ->
  bs2bool (sem le_e [v1] [v2]) = false ->
  length v2 < length v1.
Proof.
  intros; trivial.
  simpl in H1.
  apply lt_correct_conv in H1.
  rewrite succ_correct in H1.
  omega.
  trivial.
  apply preservation; simpl; try reflexivity;
    rewrite andb_true_iff; auto.
Qed.

Lemma le_correct_conv_nil v1 v2 :
  unary v1 = true ->
  unary v2 = true ->
  sem le_e [v1] [v2] = nil ->
  S (length v2) <= length v1.
Proof.
  intros; trivial.
  simpl in H1.
  apply lt_correct_conv_nil in H1.
  rewrite succ_correct in H1.
  omega.
  trivial.
  apply preservation; simpl; try reflexivity;
  rewrite andb_true_iff; auto.
Qed.

Opaque le_e.

(** * Minus

  - arities: (2,0)
*)

Notation minus_e := (inv_e (from_11_to_20 minus_rev_e)) (only parsing).

Lemma minus_correct :
  forall m n, length (sem minus_e [n; m] nil) = (length n) - (length m).
Proof.
 intros; simpl; rewrite minus_rev_correct; trivial.
Qed.

(** * Maximum

  - arities: (2,0)
*)

Definition max_e : BC :=
  comp 2 0 (rec (proj 2 0 0) (proj 3 1 2) (proj 3 1 2) )
  [ P'_e; proj 2 0 0; proj 2 0 1] nil.

Lemma max_correct_l v1 v2 : length v2 <= length v1 ->
  sem max_e [v1; v2] nil = v1.
Proof.
  simpl; intros.
  rewrite P_correct; unfold P.
  rewrite skipn_nil; simpl; trivial.
Qed.

Lemma max_correct_r v1 v2 : length v1 < length v2 ->
  sem max_e [v1; v2] nil = v2.
Proof.
  simpl; intros.
  rewrite P_correct; unfold P.
  case_eq (  (skipn (length v1) v2) ); simpl; intros.
  contradict H.
  apply le_not_lt.
  apply skipn_nil_length; trivial.
  case b; trivial.
Qed.

(** * Euclidean division

  - arities: (2,0)
*)

Fixpoint div' (q y:nat)(x:nat) : nat :=
  match q with
  | 0 => 0
  | S q' => if leb (q' * y) x then q' else div' q' y x
  end.

Lemma div'_coq_correct : forall (q x y : nat) (Hy:y>0),
  (q > proj1_sig (quotient y Hy x) ->
    div' q y x = proj1_sig (quotient y Hy x)) /\
  (q <= proj1_sig (quotient y Hy x) ->
    div' q y x = Peano.pred q).
Proof.
intros q x y Hy.
destruct (quotient y Hy x) as (qu & r & H1 & H2); simpl.
induction q as [ | q' IH]; simpl; [ omega | ].
case_eq (leb (q' * y) x); intro H.
clear IH.
apply leb_complete in H; split; subst x; intros; trivial.
assert (qu <= q') as H1 by omega; clear H0.
apply le_lt_or_eq in H1.
destruct H1; auto.
contradict H.
apply lt_not_le.
apply lt_le_trans with (qu * y + y); [ omega | ].
rewrite <- mult_succ_l.
apply mult_le_compat_r; omega.
apply leb_complete_conv in H; split; intros; subst.
assert (q'=qu \/ q'>qu) as [H3 | H3]; subst; omega.
assert (S q' = qu \/ S q' < qu) as [H4 | H4] by omega; subst.
contradict H.
apply le_not_lt; simpl; omega.
contradict H4.
apply le_not_lt.
apply mult_S_le_reg_l with (Peano.pred y).
rewrite <- S_pred with (m:=0), mult_comm, (mult_comm y (S q')).
simpl; omega.
omega.
Qed.

Definition div (x y:nat) : nat := div' (S x) y x.

Lemma div_coq_correct : forall (x y:nat) (Hy:y>0),
  div x y = proj1_sig (quotient y Hy x).
Proof.
unfold div; intros x y Hy.
generalize (div'_coq_correct (S x) x y Hy).
destruct (quotient y Hy x) as (q & r & H1 & H2); simpl.
intros [H3 _].
apply H3; subst x.
apply le_gt_S.
apply le_trans with (q*y); [ | omega ].
rewrite <- (mult_1_r q) at 1.
apply mult_le_compat_l; omega.
Qed.

Definition div'_e : BC :=
  rec (zero_e 1 1)
  (comp 2 2 cond nil
    [comp 2 2 le_e [comp 2 0 mult_e [proj 2 0 0; proj 2 0 1] nil]
      [proj 2 2 3]; proj 2 2 2; proj 2 2 0; proj 2 2 2])
  (comp 2 2 cond nil
    [comp 2 2 le_e [comp 2 0 mult_e [proj 2 0 0; proj 2 0 1] nil]
      [proj 2 2 3]; proj 2 2 2; proj 2 2 0; proj 2 2 2]).

Lemma hd_cons l a l' :
  l = a :: l' ->
  bs2bool l = a.
Proof.
  intros; subst; trivial.
Qed.

Ltac elim_if :=  match goal with
   | |- context [if ?c then ?c1 else ?c2]  => case_eq c
 end.

Lemma div'_correct v1 v2 v3 :
  unary v1 = true -> unary v2 = true -> unary v3 = true ->
  length (sem div'_e [v1;v2] [v3]) =
  div' (length v1) (length v2) (length v3).
Proof.
 intros; induction v1; simpl in *; intros; trivial.
 rewrite andb_true_iff in H.
 case a; simpl.
 case_eq ( sem le_e [sem mult_e [v1; v2] nil] [v3] ); intros.
 rewrite IHv1; trivial.
 apply le_correct_conv_nil in H2.
 rewrite mult_correct in H2.
 rewrite leb_correct_conv; trivial.
 apply preservation; trivial; simpl.
 repeat rewrite andb_true_iff; tauto.
 trivial.
 tauto.
 apply hd_cons in H2.
 destruct b.
 apply le_correct in H2.
 rewrite mult_correct in H2.
 rewrite leb_correct; trivial.
 apply le_correct_conv in H2; trivial.
 simpl in IHv1; rewrite IHv1; clear IHv1; try tauto.
 rewrite leb_correct_conv; trivial.
 rewrite mult_correct in H2; trivial.
 apply preservation; trivial; simpl.
 do 2 rewrite andb_true_iff; tauto.
 case_eq ( sem le_e [sem mult_e [v1; v2] nil] [v3] ); intros.
 rewrite IHv1; trivial.
 apply le_correct_conv_nil in H2.
 rewrite mult_correct in H2.
 rewrite leb_correct_conv; trivial.
 apply preservation; trivial; simpl.
 repeat rewrite andb_true_iff; tauto.
 trivial.
 tauto.
 apply hd_cons in H2.
 destruct b.
 apply le_correct in H2.
 rewrite mult_correct in H2.
 rewrite leb_correct; trivial.
 apply le_correct_conv in H2; trivial.
 simpl in IHv1; rewrite IHv1; clear IHv1; try tauto.
 rewrite leb_correct_conv; trivial.
 rewrite mult_correct in H2; trivial.
 apply preservation; trivial; simpl.
 do 2 rewrite andb_true_iff; tauto.
Qed.

Opaque div'_e.

Definition div_e : BC :=
  comp 2 0 div'_e [comp 2 0 succ_e nil [proj 2 0 0]; proj 2 0 1] [proj 2 0 0].

Lemma div_correct v1 v2 :
  unary v1 = true -> unary v2 = true ->
  length (sem div_e [v1; v2] nil) = div (length v1) (length v2).
Proof.
  intros; simpl sem.
  rewrite div'_correct; trivial.
Qed.

(** * Multiplication by a constant

  - with any arities: (n,0)
*)

Fixpoint scalar_e (a:nat)(n:nat)(e:BC) : BC :=
  match a with
  | 0 => zero_e n 0
  | S a' => comp n 0 plus_e [e] [scalar_e a' n e]
  end.

Lemma scalar_arities :
  forall a n e,
  arities e = ok_arities n 0 ->
  arities (scalar_e a n e) = ok_arities n 0.
Proof.
induction a as [ | a IH]; simpl.
trivial.
intros n e H.
rewrite H, (IH _ _ H).
simpl.
rewrite <- beq_nat_refl.
trivial.
Qed.

Opaque plus_e.

Lemma scalar_correct :
  forall a n nl e,
  length (sem (scalar_e a n e) nl nil) = a * length (sem e nl nil).
Proof.
induction a as [ | a IH]; simpl.
trivial.
intros n nl e.
rewrite plus_correct, IH.
trivial.
Qed.

(** * Multiplication of a list of expressions

  - with any arities: (n,0)
*)

Fixpoint multl_e (n:nat)(el:list BC) : BC :=
  match el with
    | nil => one_e n 0
    | e' :: el' => comp n 0 mult_e [e'; multl_e n el'] nil
  end.

Lemma multl_arities :
  forall el n,
  andl (fun e => arities e = ok_arities n 0) el ->
  arities (multl_e n el) = ok_arities n 0.
Proof.
induction el as [ | e el IH]; simpl.
trivial.
intros n [H1 H2].
rewrite H1, (IH _ H2).
simpl.
rewrite <- beq_nat_refl.
trivial.
Qed.

Opaque mult_e.

Lemma multl_correct :
  forall n nl el,
  length (sem (multl_e n el) nl nil) = multl (map (fun e => length (sem e nl nil)) el).
Proof.
induction el as [ | e el IH]; simpl.
trivial.
rewrite mult_correct, IH.
trivial.
Qed.


(** 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 (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus Zero (plus x y).


(** 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 (y : natural) (x : natural) : natural := plus (mult x y) y.


(*************************************************************)
(*      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      *)
(*************************************************************)

Require Import ZArith Znumtheory.

Set Implicit Arguments.

Open Scope Z_scope.

Lemma rel_prime_mod: forall a b, 1 < b ->
  rel_prime a b -> a mod b <> 0.
Proof.
intros a b H H1 H2.
case (not_rel_prime_0 _ H).
rewrite <- H2.
apply rel_prime_mod; auto with zarith.
Qed.

Lemma Zmodpl: forall a b n, 0 < n ->
  (a mod n + b) mod n = (a + b) mod n.
Proof.
intros a b n H.
rewrite Zplus_mod; auto.
rewrite Zmod_mod; auto.
apply sym_equal; apply Zplus_mod; auto.
Qed.

Lemma Zmodpr: forall a b n, 0 < n ->
  (b + a mod n) mod n = (b + a) mod n.
Proof.
intros a b n H; repeat rewrite (Zplus_comm b).
apply Zmodpl; auto.
Qed.

Lemma Zmodml: forall a b n, 0 < n ->
  (a mod n * b) mod n = (a * b) mod n.
Proof.
intros a b n H.
rewrite Zmult_mod; auto.
rewrite Zmod_mod; auto.
apply sym_equal; apply Zmult_mod; auto.
Qed.

Lemma Zmodmr: forall a b n, 0 < n ->
  (b * (a mod n)) mod n = (b * a) mod n.
Proof.
intros a b n H; repeat rewrite (Zmult_comm b).
apply Zmodml; auto.
Qed.

Ltac is_ok t :=
  match t with
  | (?x mod _ + ?y mod _) mod _ => constr:(false)
  | (?x mod _ * (?y mod _)) mod _ => constr:(false)
  |  ?x mod _ => x
  end.

Ltac  rmod t :=
  match t with
    (?x + ?y) mod _ =>
     match (is_ok x) with
     | false => rmod x
     | ?x1   =>  match (is_ok y) with
                |false => rmod y
                | ?y1 =>
                   rewrite <- (Zplus_mod x1 y1)
                |false => rmod y
                end
     end
  | (?x * ?y) mod _ =>
     match (is_ok x) with
     | false => rmod x
     | ?x1 =>  match (is_ok y) with
                |false => rmod y
                | ?y1 => rewrite <- (Zmult_mod x1 y1)
                end
     | false => rmod x
     end
  end.

Lemma Zmod_div_mod: forall n m a, 0 < n -> 0 < m ->
  (n | m) -> a mod n = (a mod m) mod n.
Proof.
intros n m a H1 H2 H3.
pattern a at 1; rewrite (Z_div_mod_eq a m); auto with zarith.
case H3; intros q Hq; pattern m at 1; rewrite Hq.
rewrite (Zmult_comm q).
rewrite Zplus_mod; auto.
rewrite <- Zmult_assoc; rewrite Zmult_mod; auto.
rewrite Z_mod_same; try rewrite Zmult_0_l; auto with zarith.
rewrite (Zmod_small 0); auto with zarith.
rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith.
Qed.


Require Export Iron.Language.SystemF2Cap.Type.Exp.
Require Export Iron.Language.SystemF2Cap.Type.Relation.WfT.
Require Import Coq.Bool.Bool.

(********************************************************************)
(* Type variable is free in type *)
Fixpoint FreeT (n : nat) (tt : ty) {struct tt} :=
 match tt with
 | TVar ix        => n = ix
 | TForall k t    => FreeT (S n) t
 | TApp t1 t2     => FreeT n t1 \/ FreeT n t2
 | TSum t1 t2     => FreeT n t1 \/ FreeT n t2
 | TBot k         => False

 | TCon0 tc       => False
 | TCon1 tc t1    => FreeT n t1
 | TCon2 tc t1 t2 => FreeT n t1 \/ FreeT n t2
 | TCap _         => False
 end.

(********************************************************************)
Lemma freeT_wfT
 :  forall n1 n2 t
 ,  n2 >= n1
 -> WfT n1 t
 -> ~FreeT n2 t.
Proof.
 intros. gen n1 n2.
 induction t; intros; inverts H0;
  unfold not; intros; snorm; subst; try omega.

 - cut (~ FreeT (S n2) t); firstorder.

 - inverts H0.
   cut (~ FreeT n2 t1); firstorder.
   cut (~ FreeT n2 t2); firstorder.

 - inverts H0.
   cut (~ FreeT n2 t1); firstorder.
   cut (~ FreeT n2 t2); firstorder.

 - cut (~ FreeT n2 t0); firstorder.

 - inverts H0.
   cut (~ FreeT n2 t2); firstorder.
   cut (~ FreeT n2 t3); firstorder.
Qed.
Hint Resolve freeT_wfT.

Lemma freeT_closedT
 :  forall t n
 ,  ClosedT t
 -> ~FreeT n t.
Proof.
 intros.
 eapply freeT_wfT; eauto.
Qed.

Lemma freeT_wfT_drop
 :  forall n t
 ,  WfT (S n) t
 -> ~FreeT n t
 -> WfT  n    t.
Proof.
 intros. gen n.
 induction t; snorm; inverts H; firstorder.
Qed.

Lemma freeT_isEffectOnVar
 :  forall d t
 ,  ~FreeT d t
 -> isEffectOnVar d t = false.
Proof.
 intros.
 destruct t; snorm.
 destruct t0; snorm;
  try (solve [rewrite andb_false_iff; tauto]).

 - rewrite andb_false_iff. right.
   rewrite beq_nat_false_iff. auto.
Qed.
Hint Resolve freeT_isEffectOnVar.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

(* Bit-vector arithmetic operations for Cava. *)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bvector.
Require Import Coq.Init.Byte.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.Vectors.Vector.
Require Import Cava.Util.Nat.
Require Import Cava.Util.Vector.
Require Import Cava.Util.Byte.
Require Coq.Strings.HexString.
Import ListNotations.
Local Open Scope list_scope.

(* List and vector functions for conversion between nats and bit-vectors *)

Module N.
  (* Converts list of bits to a binary natural number, interpreting list as
     little-endian *)
  Definition of_list_bits (bits : list bool) : N :=
    Bv2N (Vector.of_list bits).

  (* Converts an N to a (little-endian) list of bits *)
  Definition to_list_bits (n : N) : list bool :=
    Vector.to_list (N2Bv n).

  (* Converts an N to a (little-endian) list of bits of the specified length *)
  Definition to_list_bits_sized (size : nat) (n : N) : list bool :=
    Vector.to_list (N2Bv_sized size n).
End N.

Example b2n_empty : N.of_list_bits [] = 0%N.
Proof. reflexivity. Qed.

Example b2n_0 : N.of_list_bits [false] = 0%N.
Proof. reflexivity. Qed.

Example b2n_1 : N.of_list_bits [true] = 1%N.
Proof. reflexivity. Qed.

Example b2n_10 : N.of_list_bits [false; true] = 2%N.
Proof. reflexivity. Qed.

Example b2n_01 : N.of_list_bits [true; false] = 1%N.
Proof. reflexivity. Qed.

Example b2n_11 : N.of_list_bits [true; true] = 3%N.
Proof. reflexivity. Qed.

Example n2b_0_1 : N.to_list_bits 0 = [].
Proof. reflexivity. Qed.

Example n2b_1_1 : N.to_list_bits 1 = [true].
Proof. reflexivity. Qed.

Example n2b_2_2 : N.to_list_bits 2 = [false; true].
Proof. reflexivity. Qed.

Example n2b_2_3 : N.to_list_bits 3 = [true; true].
Proof. reflexivity. Qed.

(******************************************************************************)
(* Functions useful for Vector operations                                     *)
(******************************************************************************)

Definition bitvec_to_nat {n : nat} (bits : Bvector n) : nat :=
  N.to_nat (Bv2N n bits).

Definition bv3_0 : Bvector 3 := [false; false; false]%vector.
Example bv3_0_ex : bitvec_to_nat bv3_0 = 0.
Proof. reflexivity. Qed.

Definition bv1 : Bvector 1 := [true]%vector.
Example bv1_ex : bitvec_to_nat bv1 = 1.
Proof. reflexivity. Qed.

Definition bv3_1 : Bvector 3 := [true; false; false]%vector.
Example bv3_1_ex : bitvec_to_nat bv3_1 = 1.
Proof. reflexivity. Qed.

Definition bv3_2 : Bvector 3 := [false; true; false]%vector.
Example bv3_2_ex : bitvec_to_nat bv3_2 = 2.
Proof. reflexivity. Qed.

Definition nat_to_bitvec (v : nat) : Bvector (N.size_nat (N.of_nat v)) :=
  N2Bv (N.of_nat v).

Definition nat_to_bitvec_sized (n : nat) (v : nat) : Bvector n :=
  N2Bv_sized n (N.of_nat v).

Example bv3_0_cancellev : nat_to_bitvec_sized 3 0 = bv3_0.
Proof. reflexivity. Qed.

Example bv3_1_cancellev : nat_to_bitvec_sized 3 1 = bv3_1.
Proof. reflexivity. Qed.

Example bv3_2_cancellev : nat_to_bitvec_sized 3 2 = bv3_2.
Proof. reflexivity. Qed.

(******************************************************************************)
(* Functions useful for examples and tests                                    *)
(******************************************************************************)

Definition nat2bool (n : nat) : bool :=
  match n with
  | 0 => false
  | _ => true
  end.

Definition n2bool (n : N) : bool :=
  match n with
  | 0%N => false
  | _   => true
  end.

Definition fromVec := List.map Nat.b2n.
Definition toVec := List.map nat2bool.

Definition Bv2Hex {n} (x: Vector.t bool n) := HexString.of_N (Bv2N x).
Definition Hex2Bv {n} (s : String.string) := N2Bv_sized n (HexString.to_N s).

Definition byte_reverse {n} (x: Vector.t bool (n*8)) := flatten (reverse (reshape (m:=8) x)).

Definition bitvec_to_byte (v : Vector.t bool 8) : Byte.byte :=
  let '(b0,v) := Vector.uncons v in
  let '(b1,v) := Vector.uncons v in
  let '(b2,v) := Vector.uncons v in
  let '(b3,v) := Vector.uncons v in
  let '(b4,v) := Vector.uncons v in
  let '(b5,v) := Vector.uncons v in
  let '(b6,v) := Vector.uncons v in
  let '(b7,v) := Vector.uncons v in
  Byte.of_bits (b0,(b1,(b2,(b3,(b4,(b5,(b6,b7))))))).

Definition byte_to_bitvec (b : Byte.byte) : Vector.t bool 8 :=
  Ndigits.N2Bv_sized 8 (Byte.to_N b).
Definition bitvec_to_bytevec n (v : Vector.t bool (n * 8)) : Vector.t Byte.byte n :=
  Vector.map bitvec_to_byte (reshape v).
Definition bytevec_to_bitvec n (v : Vector.t Byte.byte n) : Vector.t bool (n * 8) :=
  flatten (Vector.map byte_to_bitvec v).

Definition bytevec_to_wordvec
           bytes_per_word n (v : Vector.t Byte.byte (n * bytes_per_word))
  : Vector.t (Vector.t Byte.byte bytes_per_word) n := reshape v.

Definition bitvec_to_wordvec
           bits_per_word n (v : Vector.t bool (n * bits_per_word))
  : Vector.t (Vector.t bool bits_per_word) n := reshape v.

Definition wordvec_to_bytevec
           bytes_per_word {n} (v : Vector.t (Vector.t Byte.byte bytes_per_word) n)
  : Vector.t Byte.byte (n * bytes_per_word) := flatten v.
Definition wordvec_to_bitvec
           bits_per_word {n} (v : Vector.t (Vector.t bool bits_per_word) n)
  : Vector.t bool (n * bits_per_word) := flatten v.

(******************************************************************************)
(* Arithmetic operations                                                      *)
(******************************************************************************)

Definition unsignedAddBool {m n : nat}
                           (av_bv : Bvector m *  Bvector n)
: Bvector (1 + max m n) :=
  let (av, bv) := av_bv in
  let a := Bv2N av in
  let b := Bv2N bv in
  let sumSize := 1 + max m n in
  let sum := (a + b)%N in
  N2Bv_sized sumSize sum.

Definition unsignedMultBool {m n : nat}
           (av_bv : Bvector m *  Bvector n)
  : Bvector (m + n) :=
  let (av, bv) := av_bv in
  let a := Bv2N av in
  let b := Bv2N bv in
  let product := (a * b)%N in
  N2Bv_sized (m + n) product.

Definition greaterThanOrEqualBool {m n : nat}
           (av_bv : Bvector m *  Bvector n) : bool :=
  let (av, bv) := av_bv in
  (Bv2N bv <=? Bv2N av)%N.


Lemma eq_sym : forall (X : Type)(x y : X), x = y -> y = x.
intros X x y A.
rewrite A.
reflexivity.
Qed.

Lemma modus_ponens : forall X Y : Prop, X -> (X -> Y) -> Y.
intros X Y x A.
exact (A x).
Qed.

Lemma barbara : forall X Y Z : Prop, (X -> Y) -> (Y -> Z) -> (X -> Z).
intros X Y Z A B x.
exact (B (A x)).
Qed.

Lemma eq_trans : forall (X : Type)(x y z : X), x = y -> y = z -> x = z.
intros.
transitivity y.
assumption.
apply H0.
Qed.

Goal forall p q : nat -> Prop, p 7 -> (forall x, p x -> q x) -> q 7.
Proof.
intros p q A B.
apply B.
exact A.
Qed.

Lemma const : forall X Y, X -> Y -> X.
intros.
apply X0.
Qed.

Goal forall X Y, (forall Z, (X -> Y -> Z) -> Z) -> X.
intros X Y Z0.
apply Z0.
apply const.
Qed.

Lemma const' : forall X Y, X -> Y -> Y.
intros.
apply X1.
Qed.

Goal forall X Y, (forall Z, (X -> Y -> Z) -> Z) -> Y.
intros.
apply X0.
apply const'.
Qed.

Goal forall (p : bool -> Prop)(x : bool), p true -> p false -> p x.
Proof.
intros.
induction x.
apply H.
apply H0.
Qed.

Goal forall (p : nat -> Prop)(x : nat), p O -> (forall n, p n -> p (S n)) -> p x.
intros.
induction x.
apply H.
apply H0.
apply IHx.
Qed.

Goal forall (X : Type)(p : list X -> Prop)(xs : list X), p nil -> (forall x xs, p xs -> p (cons x xs)) -> p xs.
Proof.
intros.
induction xs.
apply H.
apply H0.
apply IHxs.
Qed.

Goal forall X : Type, (fun x : X => x) = (fun y : X => y).
intros.
reflexivity.
Qed.

Goal forall X Y : Prop, (X -> Y) -> forall x : X, Y.
intros.
apply (H x).
Qed.

Goal forall X Y : Prop, (forall x : X, Y) -> X -> Y.
intros.
apply (H H0).
Qed.

Goal forall X Y : Prop, (X -> Y) = (forall x : X, Y).
intros.
reflexivity.
Qed.

Lemma double_negation : forall X : Prop, X -> ~~X.
intros X x A.
exact (A x).
Qed.

Goal forall X : Prop, ~~X -> (X -> ~X) -> X.
intros X A B.
exfalso.
apply A.
intros x.
exact (B x x).
Qed.

Goal forall X Y : Prop, ~~(((X -> Y) -> X) -> X).
intros.
tauto.
Qed.

Goal forall X Y : Prop, X /\ Y -> Y /\ X.
intros X Y A.
destruct A as [x y].
split.
apply y.
apply x.
Qed.

Goal forall X Y : Prop, X \/ Y -> Y \/ X.
intros X Y A.
destruct A as [x|y].
right. exact x.
left. exact y.
Qed.

Goal forall X Y Z : Prop, X \/ (Y /\ Z) -> (X \/ Y) /\ (X \/ Z).
intros X Y Z [x|[y z]].
split. left. exact x.
left. exact x.
split. right. exact y.
right. exact z.
Qed.

Goal forall X Y Z W : Prop, (X -> Y) \/ (X -> Z) -> (Y -> W) /\ (Z -> W) -> X -> W.
tauto.
Qed.

Goal forall X Y: Prop, X /\ Y -> Y /\ X.
intros X Y [x y].
split.
assumption.
apply x.
Qed.

Goal forall (X : Type)(p q : X -> Prop),(exists x, p x /\ q x) -> exists x, p x.
intros X p q A.
destruct A as [x B].
destruct B as [C _].
exists x.
apply C.
Qed.

Definition diagonal : Prop := forall (X : Type)(p : X -> X -> Prop), ~ exists x, forall y, p x y <-> ~ p y y.

Lemma circuit (X : Prop): ~(X <-> ~X).
tauto.
Qed.

Goal diagonal.
Proof.
intros X p [x A].
apply (@circuit(p x x)).
exact (A x).
Qed.

Goal diagonal.
intros X p [x A].
specialize (A x).
tauto.
Qed.

Axiom doub_neg : forall (X : Prop), ~~X -> X.

Variable X : Type.

Lemma fst_law :
 forall (p : X -> Prop), ~ (forall x:X, ~ p x) -> exists x : X, p x.
Proof.
intros P notall.
apply doub_neg.
intro abs.
apply notall.
intros x H.
apply abs.
exists x.
exact H.
Qed.

Lemma de_morgan_quatifier :
 forall p:X -> Prop, ~ (forall x:X, p x) -> exists x : X, ~ p x.
Proof.
intros P notall.
apply fst_law.
intro all; apply notall.
intro n; apply doub_neg.
apply all.
Qed.

Lemma conj_intro : forall X Y : Prop, X -> Y -> X /\ Y.
tauto.
Defined.

Lemma conj_elim_fst : forall X Y : Prop, X /\ Y -> X.
tauto.
Defined.

Lemma conj_elim_snd : forall X Y : Prop, X /\ Y -> Y.
tauto. Defined.


(** 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 (y : natural) (x : natural) : natural := mult (Succ y) x.


(** 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 (y : natural) (x : natural) : natural := plus (mult y x) x.


(** 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 (lf1 : natural) (y : natural) (x : natural) : natural :=
  Succ (plus Zero x).


(** 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 (y : natural) (x : natural) (lf2 : natural) : natural :=
  plus (plus y x) lf2.


(* Software Foundations *)
(* Exercice 1 star, SSSSev__even *)

Inductive ev: nat -> Prop :=
|ev_0: ev 0
|ev_ss: forall n: nat, ev n -> ev (S (S n)).

Theorem SSSSev__even : forall n, ev (S (S (S (S n)))) -> ev n.
Proof.
    intros.
    inversion H.
    inversion H1.
    apply H3.
Qed.


(** 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 (y : natural) (x : natural) (lf1 : natural) : natural :=
  plus x (Succ (plus lf1 y)).


From mathcomp Require Import all_ssreflect zify.

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

Lemma odd_add (n m : nat) : odd (m + n) = odd m (+) odd n.
Proof. lia. Qed.


(** 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 (y : natural) (x : natural) (lf2 : natural) : natural :=
  plus x (Succ (plus y lf2)).


Require Import mathcomp.ssreflect.ssreflect.

Lemma foo2 : forall n: nat, n + 0 = n.
Proof.
  intro.
  induction n. {
    simpl.
    reflexivity.
  } {
    simpl.
    have foo: 0 = 0 by simpl; reflexivity.
    have foo2: 0 = 0 by assumption.
    have foo3: 0 = 0 by trivial.
    have foo4: 0 = 0 by exact foo3.
    have foo5: 0 = 0 by apply foo4.
    (* have ihn : 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 +  n + 0 = n by assumption. *)
    rewrite -> IHn.
    reflexivity.
  }
Qed.


Require Import Bool List Arith Nat Coq.Arith.Div2.
Import ListNotations.

Fixpoint bit_n (l : list bool) : nat :=
  match l with
    | [] => 0
    | a :: tl => 2 * bit_n tl + Nat.b2n a
  end.

Fixpoint n_bit (n : nat) (k : nat) : option (list bool) :=
    match n with
      | 0 => match k with
             | 0 => Some []
             | S _ => None
             end
      | S n' => match n_bit n' (Nat.div2 k) with
                  | None => None
                  | Some l => Some (Nat.odd k :: l)
                end
    end.

Compute pow 2 8.
Check leb 2 3.

SearchAbout (_ mod _).

Lemma size_n_bit : forall (n k: nat) (l : list bool),
    n_bit n k = Some l -> length l = n.
Proof.
  induction n.
  -intros k l.
   induction k.
   +intros.
    inversion H.
    reflexivity.
   +simpl.
    discriminate.
  -intros k l.
   simpl.
   case_eq (n_bit n (Nat.div2 k)).
   +intros.
    inversion H0.
    assert (help1: forall (l' : list bool) (b : bool), length l' = n -> length(b :: l') = S n).
    {
      induction l'.
      -intros b.
       simpl.
       intros.
       rewrite H1.
       reflexivity.
      -intros b.
       simpl.
       intros.
       rewrite H1.
       reflexivity.
    }
    apply help1.
    specialize (IHn (Nat.div2 k)).
    apply IHn.
    exact H.
   +intros.
    discriminate.
Qed.

(* first proof that we need on binary representation *)
Theorem n_bit_n : forall (l : list bool) (n k : nat),
                    n_bit n k = Some l -> bit_n l = k.
Proof.
  assert (I : forall (l : list bool) (n k : nat), n_bit n k = Some l -> bit_n l = k).
  {
    intros l; induction l; intros n k.
    simpl.
    assert (I_1 : n_bit n k = Some [] -> bit_n [] = k).
    {
      induction k.
      - reflexivity.
       (* the hypothesis is false so we will need to find how to demonstrate this *)
      - assert (I_1_1 : n_bit n (S k) = Some [] -> bit_n [] = S k).
       {
         induction n.
         - discriminate.
         - unfold n_bit; fold n_bit.
           destruct (n_bit n (Nat.div2 (S k))); discriminate.
       }
       exact I_1_1.
    }
    exact I_1.
    assert (I_2 : n_bit n k = Some (a :: l) -> bit_n (a :: l) = k).
    {
      intros H.
      simpl.
      About Nat.div2_odd.
      rewrite (Nat.div2_odd k).
      simpl.
      destruct n; simpl in H.
      - destruct k; discriminate.
      - destruct (n_bit n (Nat.div2 k)) eqn:Hl; try discriminate.
        inversion H; subst.
        erewrite IHl; eauto.
    }
    assumption.
  }
  assumption.
Qed.

(* second proof *)
Theorem bit_n_bit : forall (l : list bool) (n : nat),
                      n = length l -> (n_bit n (bit_n l)) = Some l.
Proof.
  assert (I : forall (l : list bool) (n : nat), n = length l -> n_bit n (bit_n l) = Some l).
  {
    induction l.
    assert (I_1 : forall n : nat, n = length ([] : list bool) -> n_bit n (bit_n []) = Some []).
    {
      simpl.
      intros n H.
      rewrite H.
      reflexivity.
    }
    exact I_1.
    assert (I_2 : forall n : nat, n = length (a :: l) -> n_bit n (bit_n (a :: l)) = Some (a :: l)).
    {
      intros n.
      simpl.
      destruct a.
      assert (I_2_1 : n = length (true :: l) -> n_bit n (bit_n (true :: l)) = Some (true :: l)).
      {
        simpl.
        Search (_ + 0).
        rewrite <- plus_n_O.
        intros H.
        rewrite H.
        simpl.
        assert (I_2_1_1 : forall l' : (list bool), bit_n l' + bit_n l' = 2 * bit_n l').
        {
          induction l'.
          -reflexivity.
          -simpl.
           rewrite <- plus_n_O.
           rewrite <- plus_n_O.
           reflexivity.
        }
        rewrite I_2_1_1.
        Search (_ + 1 = S _).
        Search (Nat.div2 _).
        rewrite Nat.add_1_r.
        Check even_div2.
        rewrite <- even_div2.
        -Search (Nat.div2 (2 * _)).
         rewrite div2_double.
         rewrite IHl.
         +assert (I_2_1_2 : forall (n' : nat), Nat.odd (S (2 * n')) = true).
          {
            intros n'.
            induction n'.
            -reflexivity.
            -simpl.
             rewrite <- plus_n_Sm.
             simpl in IHn'.
             rewrite <- IHn'.
             Search (Nat.odd (S (S _))).
             rewrite Nat.odd_succ_succ. reflexivity.
          }
          rewrite I_2_1_2.
          reflexivity.
         +reflexivity.
        -assert (I_2_1_3 : Even.even (2 * bit_n l)).
         {
           (* this is supposed to be trivial -_-_-_-_-_-_-_-_-_-_-_-_- *)
           Check Nat.even_add_mul_2.
           Search (0 + _).
           rewrite <- Nat.add_0_l.
           SearchAbout (even (_ + _)).
           specialize (Nat.even_add_mul_2 0 (bit_n l)).
           intros.
           Check Even.even_equiv.
           apply Even.even_equiv.
           (* even spec *)
           Check Nat.even_spec.
           simpl in H0.
           Search (_ + _ = 2 * _).
           Check I_2_1_1.
           rewrite <- I_2_1_1.
           assert (0 + (bit_n l + bit_n l) = bit_n l + (bit_n l + 0)).
           { simpl. Search (_ + 0). rewrite <- plus_n_O. reflexivity. }
           rewrite H1.
           rewrite Nat.even_spec in H0.
           exact H0.
         }
         exact I_2_1_3.
      }
      exact I_2_1.
      assert (I_2_2 : n = S (length l) -> n_bit n (bit_n l + (bit_n l + 0) + Nat.b2n false) = Some (false :: l)).
      {
        simpl.
        Search (_ + 0).
        rewrite <- plus_n_O.
        rewrite <- plus_n_O.
        intros H.
        rewrite H.
        simpl.
        Search (2 * _ = _).
        assert (I_2_2_0 : forall (n' : nat), 2 * n' = n' + n').
        {
          intros n'. simpl. rewrite <- plus_n_O. reflexivity.
        }
        rewrite <- I_2_2_0.
        rewrite div2_double.
        rewrite IHl.
        -assert (I_2_2_1 : forall (n' : nat), Nat.odd (2 * n') = false).
         {
           induction n'.
           -simpl. Search (Nat.odd 0).
            rewrite Nat.odd_0. reflexivity.
           -simpl.
            Search (_ + 0).
            rewrite <- plus_n_O.
            Search (_ + _ = _ + _).
            rewrite <- plus_Snm_nSm.
            Search (S _ + _).
            rewrite plus_Sn_m.
            Search (Nat.odd (S (S _))).
            rewrite Nat.odd_succ_succ.
            simpl in IHn'.
            rewrite <- plus_n_O in IHn'.
            rewrite IHn'.
            reflexivity.
         }
         rewrite I_2_2_1.
         reflexivity.
        -reflexivity.
      }
      exact I_2_2.
    }
    exact I_2.
  }
  exact I.
Qed.


Require Import BinNat.
Require Import Program.Basics.
Require Import Logic.FunctionalExtensionality.
Require Import micromega.Lia.
Require Import Nnat.
Require Import Omega.
Require Import bin_prelims.
Require repeater.
Open Scope N_scope.

(*
====================================================================================
*********** SECTION 9: BINARY HYPEROPS, ACKERMANN AND REPEATER *********************
====================================================================================
 *)

(*
 * We introduce "bin_repeater" and how to use it to define the
 * bin_hyperoperations and binary Ackermann function.
 *
 * We also prove several results about the value of hypeopererations at small
 * numbers and levels, which are treated as known in the paper but need to be
 * rigourously proven here to be used in the proofs of theorems in the paper.
 *
 * Several similar results for the Ackermann function are also provided.
 * Note that some results here may not be related to results in the paper, but
 * appear for reasons of completeness.
 *)

(* ****** REPEATER ********************************* *)

Definition bin_repeater_from (f : N -> N) (a : N) (n : N) : N :=
  match n with
  | 0      => a
  | Npos p =>
      let fix bin_repeater_pos (g : N -> N) (p : positive) (a' : N) : N :=
        match p with
        | xH    => g a'
        | xO p' => let g' := bin_repeater_pos g p' in g' (g' a')
        | xI p' => let g' := bin_repeater_pos g p' in g (g' (g' a'))
        end in bin_repeater_pos f p a
  end.

(* Repeater is a functional way to look at repeat.
   See "repeat" in "prelims.v" *)
Theorem bin_repeater_repeat :
    forall a f n, bin_repeater_from f a n = repeat f (N.to_nat n) a.
Proof.
  intros a f n. destruct n; trivial. simpl.
  generalize dependent a.
  induction p; intro a; [ | |trivial];
  [replace (Pos.to_nat p~1) with
    (S (Pos.to_nat p + Pos.to_nat p))%nat by lia|
  replace (Pos.to_nat p~0) with
    (Pos.to_nat p + Pos.to_nat p)%nat by lia];
    simpl; f_equal; rewrite repeat_plus;
      repeat rewrite IHp; trivial.
Qed.

(* Repeater on N is consistent with its counterpart on nat *)
Theorem bin_repeater_Nnat :
    forall a f n, bin_repeater_from f a n =
      N.of_nat (repeater.repeater_from
                  (to_nat_func f) (N.to_nat a) (N.to_nat n)).
Proof.
  intros a f n. rewrite bin_repeater_repeat.
  rewrite repeater.repeater_from_repeat.
  remember (N.to_nat n) as m. clear Heqm.
  unfold to_nat_func.
  induction m; simpl; [ |rewrite <- IHm];
    rewrite N2Nat.id; trivial.
Qed.

(* ****** HYPEROPS ********************************* *)

(* A function to summarize the initial values of the bin_hyperoperations *)
Definition bin_hyperop_init (a : N) (n : nat) : N :=
  match n with 0%nat => a | 1%nat => 0 | _ => 1 end.

(* Our definition for bin_hyperops using bin_repeater_from *)
Fixpoint bin_hyperop (a : N) (n : nat) (b : N) : N :=
  match n with
  | 0%nat => 1 + b
  | S n'  => bin_repeater_from (bin_hyperop a n') (bin_hyperop_init a n') b
  end.

(* A handy theorem to transform goals involving bin_hyperops *)
Lemma bin_hyperop_recursion :
  forall (n : nat) (a : N),
    bin_hyperop a (S n) = bin_repeater_from (bin_hyperop a n)
                                            (bin_hyperop_init a n).
Proof. intros. apply functional_extensionality. intro b. trivial. Qed.

(* Proof that the two bin_hyperops are the same *)
Theorem bin_hyperop_correct :
  forall n a b, bin_hyperop a n b =
                N.of_nat (repeater.hyperop (N.to_nat a) n (N.to_nat b)).
Proof.
  intros n a. induction n; intro b.
  - unfold bin_hyperop. unfold repeater.hyperop. lia.
  - rewrite bin_hyperop_recursion.
    replace (repeater.hyperop (N.to_nat a) (S n) (N.to_nat b)) with
    (repeater.repeater_from (repeater.hyperop (N.to_nat a) n)
                          (repeater.hyperop_init (N.to_nat a) n)
                          (N.to_nat b)) by trivial.
    replace (repeater.hyperop_init (N.to_nat a) n) with
    (N.to_nat (bin_hyperop_init a n)) by repeat (destruct n; trivial).
    rewrite bin_repeater_Nnat. repeat f_equal.
    apply functional_extensionality; intro c.
    unfold to_nat_func. rewrite IHn. repeat rewrite Nat2N.id. trivial.
Qed.

(*
 * The first few functions in the bin_hyperops.
 * Useful for pointing out their inverses specifically
 *)

Lemma bin_hyperop_1 : forall a b, bin_hyperop a 1 b = b + a.
Proof.
  intros. rewrite bin_hyperop_correct. rewrite repeater.hyperop_1. lia.
Qed.

Lemma bin_hyperop_2 : forall a b, bin_hyperop a 2 b = b * a.
Proof.
  intros. rewrite bin_hyperop_correct. rewrite repeater.hyperop_2. lia.
Qed.

Lemma bin_hyperop_3 : forall a b, bin_hyperop a 3 b = a ^ b.
Proof.
  intros. rewrite bin_hyperop_correct. rewrite repeater.hyperop_3.
  remember (N.to_nat a) as a0. replace a with (N.of_nat a0) by lia.
  clear Heqa0.
  remember (N.to_nat b) as b0. replace b with (N.of_nat b0) by lia.
  clear Heqb0.
  induction b0; trivial.
  replace (N.of_nat (S b0)) with (1 + N.of_nat b0) by lia.
  rewrite N.pow_add_r. rewrite N.pow_1_r. simpl. rewrite <- IHb0. lia.
Qed.

(*
 * A beautiful result about hypeops value at b = 1.
 * Used in the proof of the theorem "ack_bin_hyperop",
 *  which is also included just for completeness
 *)
Lemma bin_hyperop_n_1 :
    forall n a, (2 <= n)%nat -> bin_hyperop a n 1 = a.
Proof.
  intros n a Hn. do 2 (destruct n; [omega|]).
  clear Hn. induction n; trivial.
Qed.

(* ****** ACKERMANN FUNCTION ********************************* *)

(* Our definition using bin_repeater_from *)
Definition bin_ackermann (n m : N) : N :=
  let fix ack_nat (n0 : nat) (m0 : N) : N :=
   match n0 with
   | 0%nat => 1 + m0
   | S n1  => bin_repeater_from (ack_nat n1) (ack_nat n1 1) m0
   end in ack_nat (N.to_nat n) m.

(* Proof that the above are the same *)
Theorem bin_ackermann_correct : forall n m,
    bin_ackermann n m =
      N.of_nat (repeater.ackermann (N.to_nat n) (N.to_nat m)).
Proof.
  intros n m. unfold bin_ackermann. unfold repeater.ackermann.
  generalize dependent m. induction (N.to_nat n); intro m; [lia| ].
  rewrite bin_repeater_Nnat. repeat f_equal;
  [unfold to_nat_func; apply functional_extensionality; intro p| ];
  rewrite IHn0; repeat rewrite Nat2N.id; trivial.
Qed.


Require Import ZArith.

Open Scope Z_scope.

Definition pol := fun x:Z => 2*x*x + 3*x +3.
Reset pol.

Definition pol (x:Z) : Z := 2*x*x + 3*x +3.

Eval compute in (pol (-6)).
Eval compute in (pol 1024).


Require Import Coq.ZArith.BinInt.
Require Import Coq.micromega.Psatz.
Require Import Crypto.Util.ForLoop.
Require Import Crypto.Util.ForLoop.InvariantFramework.
Require Import Crypto.Util.ZUtil.

Local Open Scope Z_scope.

Check (for i (:= 0; += 1; < 10) updating (v := 5) {{ v + i }}).
Check (for (int i = 0; i < 5; i++) updating ( '(v1, v2) = (0, 0) ) {{ (v1 + i, v2 + i) }}).

Compute for (int i = 0; i < 5; i++) updating (v = 0) {{ v + i }}.
Compute for (int i = 0; i <= 5; i++) updating (v = 0) {{ v + i }}.
Compute for (int i = 5; i > -1; i--) updating (v = 0) {{ v + i }}.
Compute for (int i = 5; i >= 0; i--) updating (v = 0) {{ v + i }}.
Compute for (int i = 0; i < 5; i += 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 0; i <= 5; i += 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 5; i > -1; i -= 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 5; i >= 0; i -= 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 0; i < 6; i += 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 0; i <= 6; i += 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 6; i > -1; i -= 2) updating (v = 0) {{ v + i }}.
Compute for (int i = 6; i >= 0; i -= 2) updating (v = 0) {{ v + i }}.
Check eq_refl : for (int i = 0; i <= 5; i++) updating (v = 0) {{ v + i }} = 15.
Check eq_refl : for (int i = 0; i < 5; i++) updating (v = 0) {{ v + i }} = 10.
Check eq_refl : for (int i = 5; i >= 0; i--) updating (v = 0) {{ v + i }} = 15.
Check eq_refl : for (int i = 5; i > -1; i--) updating (v = 0) {{ v + i }} = 15.
Check eq_refl : for (int i = 0; i <= 5; i += 2) updating (v = 0) {{ v + i }} = 6.
Check eq_refl : for (int i = 0; i < 5; i += 2) updating (v = 0) {{ v + i }} = 6.
Check eq_refl : for (int i = 5; i > -1; i -= 2) updating (v = 0) {{ v + i }} = 9.
Check eq_refl : for (int i = 5; i >= 0; i -= 2) updating (v = 0) {{ v + i }} = 9.
Check eq_refl : for (int i = 0; i <= 6; i += 2) updating (v = 0) {{ v + i }} = 12.
Check eq_refl : for (int i = 0; i < 6; i += 2) updating (v = 0) {{ v + i }} = 6.
Check eq_refl : for (int i = 6; i > -1; i -= 2) updating (v = 0) {{ v + i }} = 12.
Check eq_refl : for (int i = 6; i >= 0; i -= 2) updating (v = 0) {{ v + i }} = 12.

Local Notation for_sumT n'
  := (let n := Z.pos n' in
      (2 *
       for (int i = 0; i <= n; i++) updating (v = 0) {{
         v + i
       }})%Z
      = n * (n + 1))
       (only parsing).

Check eq_refl : for_sumT 5.

(** Here we show that if we add the numbers from 0 to n, we get [n * (n + 1) / 2] *)
Example for_sum n' : for_sumT n'.
Proof.
  intro n.
  apply for_loop_ind_le1.
  { compute; reflexivity. }
  { intros; nia. }
Qed.


Require Export Lists.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Fixpoint length (X:Type) (l:list X) : nat :=
  match l with
  | nil _ => 0
  | cons _ h t => S (length X t)
  end.

Example test_length1 :
    length nat (cons nat 1 (cons nat 2 (nil nat))) = 2.
Proof. reflexivity.  Qed.

Example test_length2 :
    length bool (cons bool true (nil bool)) = 1.
Proof. reflexivity.  Qed.

Fixpoint app (X : Type) (l1 l2 : list X)
                : (list X) :=
  match l1 with
  | nil _     => l2
  | cons _ h t => cons X h (app X t l2)
  end.

Fixpoint snoc (X:Type) (l:list X) (v:X) : (list X) :=
  match l with
  | nil _      => cons X v (nil X)
  | cons _ h t => cons X h (snoc X t v)
  end.

Fixpoint rev (X:Type) (l:list X) : list X :=
  match l with
  | nil _      => nil X
  | cons _ h t => snoc X (rev X t) h
  end.

Example test_rev1 :
    rev nat (cons nat 1 (cons nat 2 (nil nat)))
  = (cons nat 2 (cons nat 1 (nil nat))).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev bool (nil bool) = nil bool.
Proof. reflexivity.  Qed.

Arguments nil {X}.
Arguments cons {X} _ _.  (* use underscore for argument position that has no name *)
Arguments length {X} l.
Arguments app {X} l1 l2.
Arguments rev {X} l.
Arguments snoc {X} l v.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Fixpoint repeat {X : Type} (n : X) (count : nat) : list X :=
  match count with
  | 0 => []
  | S count' => n :: (repeat n count')
  end.

Example test_repeat1:
  repeat true 2 = cons true (cons true nil).
Proof. reflexivity. Qed.

Theorem nil_app : forall X:Type, forall l:list X,
  app [] l = l.
Proof. reflexivity. Qed.

Theorem rev_snoc : forall X : Type,
                     forall v : X,
                     forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
  intros.
  induction s as [| n t].
  reflexivity.
  simpl.
  rewrite IHt.
  reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros.
  induction l as [| n t].
  reflexivity.
  simpl.
  rewrite rev_snoc.
  rewrite IHt.
  reflexivity.
Qed.

Theorem snoc_with_append : forall X : Type,
                         forall l1 l2 : list X,
                         forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.
  intros. induction l1 as [|v' l1'].
  reflexivity.
  simpl.
  rewrite IHl1'.
  reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with (x,y) => x end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with (x,y) => y end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match (lx,ly) with
  | ([],_) => []
  | (_,[]) => []
  | (x::tx, y::ty) => (x,y) :: (combine tx ty)
  end.

Fixpoint subsplit {X Y : Type} (l : list (X*Y)) (xs: list X) (ys: list Y)
           : (list X) * (list Y) :=
  match l with
  | [] => (xs, ys)
  | (x, y) :: xys => subsplit xys (x :: xs) (y :: ys)
  end.

Definition split
           {X Y : Type} (l : list (X*Y))
           : (list X) * (list Y) :=
  match subsplit l [] [] with
  | (xs, ys) => (rev xs, rev ys)
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. reflexivity. Qed.

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

Fixpoint index {X : Type} (n : nat)
               (l : list X) : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else index (pred n) l'
  end.

Example test_index1 :    index 0 [4;5;6;7]  = Some 4.
Proof. reflexivity.  Qed.
Example test_index2 :    index  1 [[1];[2]]  = Some [2].
Proof. reflexivity.  Qed.
Example test_index3 :    index  2 [true]  = None.
Proof. reflexivity.  Qed.

Definition hd_opt {X : Type} (l : list X)  : option X :=
  match l with
  | [] => None
  | v :: _ => Some v
  end.

Example test_hd_opt1 :  hd_opt [1;2] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt2 :   hd_opt  [[1];[2]]  = Some [1].
Proof. reflexivity. Qed.

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

Definition plus3 := plus 3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z :=
  match p with
  | (x, y) => f x y
  end.

Theorem uncurry_curry : forall (X Y Z : Type) (f : X -> Y -> Z) x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof. reflexivity. Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                               (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros.
  destruct p as [m n].
  reflexivity.
Qed.

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars (filter_even_gt7) *)

(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun i => andb (evenb i) (blt_nat 7 i)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

Definition partition {X : Type} (f: X -> bool) (l: list X) : list X * list X :=
  (filter f l, filter (fun v => negb (f v)) l).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. reflexivity. Qed.

Fixpoint map {X Y:Type} (f:X->Y) (l:list X)
             : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

Example test_map2: map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity.  Qed.

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

Theorem map_snoc: forall (X Y : Type) (f : X -> Y) (l : list X) (v : X),
  map f (snoc l v) = snoc (map f l) (f v).
Proof.
  intros.
  induction l as [|w m].
  reflexivity.
  simpl.
  rewrite IHm.
  reflexivity.
Qed.

(** ** Map for options *)
(** **** Exercise: 3 stars (map_rev) *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)
Theorem map_rev: forall (X Y : Type) (f : X -> Y) (l : list X), map f (rev l) = rev (map f l).
Proof.
  intros.
  induction l as [|v m].
  reflexivity.
  simpl.
  rewrite <- IHm.
  rewrite map_snoc.
  reflexivity.
Qed.

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
                   : (list Y) :=
  match l with
  | [] => []
  | x :: xs => f x ++ flat_map f xs
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y) : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Example fold_example1 : fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 : fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 : fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Definition override {X: Type} (f: nat->X) (k:nat) (x:X) : nat->X:=
  fun (k':nat) => if beq_nat k k' then x else f k'.

Definition fmostlytrue := override (override ftrue 1 false) 3 false.

Example override_example1 : fmostlytrue 0 = true.
Proof. reflexivity. Qed.

Example override_example2 : fmostlytrue 1 = false.
Proof. reflexivity. Qed.

Example override_example3 : fmostlytrue 2 = true.
Proof. reflexivity. Qed.

Example override_example4 : fmostlytrue 3 = false.
Proof. reflexivity. Qed.

Theorem override_example : forall (b:bool),
  (override (constfun b) 3 true) 2 = b.
Proof. reflexivity. Qed.

Theorem unfold_example : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  unfold plus3.
  rewrite -> H.
  reflexivity.  Qed.

Theorem beq_nat_refl : forall n : nat, beq_nat n n = true.
Proof. intros. induction n as [| n']. reflexivity. simpl. rewrite IHn'. reflexivity. Qed.

Theorem override_eq : forall {X:Type} x k (f:nat->X),
  (override f k x) k = x.
Proof.
  intros X x k f.
  unfold override.
  rewrite beq_nat_refl.
  reflexivity.  Qed.

Theorem override_neq : forall (X:Type) x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  intros.
  unfold override.
  rewrite H0.
  assumption.
Qed.

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

(** Prove the correctness of [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros.
  induction l as [|n l'].
  reflexivity.
  simpl.
  rewrite <- IHl'.
  reflexivity.
Qed.

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y :=
  fold (fun elem acc => f elem :: acc) l [].

Example test_fold_map1: fold_map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

Example test_fold_map2: fold_map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_fold_map3:
   fold_map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

Theorem fold_map_eq: forall (X Y : Type) (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  intros. induction l as [|n l'].
  reflexivity.
  simpl.
  rewrite <- IHl'.
  reflexivity.
Qed.


(** 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 (lf1 : natural) (y : natural) (x : natural) : natural :=
  mult (Succ x) (Succ y).


Require Import Coq.Program.Basics.

Lemma rmConj (P Q R: Prop): iff (P /\ Q -> R) (P -> Q -> R).
Proof.
  unfold impl; tauto.
Qed.

Lemma rmDisj (P Q R: Prop): iff (P \/ Q -> R) ((P -> R) /\ (Q -> R)).
Proof.
  unfold impl; tauto.
Qed.

Lemma dupConj (P Q R: Prop): iff (P -> (Q /\ R)) ((P -> Q) /\ (P -> R)).
Proof.
  unfold impl; tauto.
Qed.

Lemma bool_true a: iff (a = true -> False) (a = false).
Proof.
  destruct a; intuition discriminate.
Qed.

Lemma bool_false a: iff (a = false -> False) (a = true).
Proof.
  destruct a; intuition discriminate.
Qed.

Lemma quantConj A (P Q: A -> Prop): iff (forall a, P a /\ Q a) ((forall a, P a) /\ (forall a, Q a)).
Proof.
  split; intros; firstorder fail.
Qed.

#[global] Hint Rewrite rmConj rmDisj dupConj bool_true bool_false quantConj: basicLogic.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Properties of Unary and Binary Operations                               *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics.

(* ********************************************************************** *)
(** * Types of unary and binary operators and relations *)

Definition oper1 (A : Type) := A -> A.
Definition oper2 (A : Type) := A -> A -> A.
Definition predb (A:Type) := A -> bool.

(* ********************************************************************** *)
(** * Definition of the properties of operators *)

Section Definitions.

Variable (A : Type).
Implicit Types f g : oper2 A.
Implicit Types i : oper1 A.

(* ---------------------------------------------------------------------- *)
(** ** Commutativity, associativity *)

(** Commutativity *)

Definition comm f := forall x y,
  f x y = f y x.

(** Associativity *)

Definition assoc f := forall x y z,
  f x (f y z) = f (f x y) z.

(** Combined associativity commutativity *)

Definition comm_assoc f := forall x y z,
  f x (f y z) = f y (f x z).

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

(** Distributivity of unary operator *)

Definition distrib i f := forall x y,
  i (f x y) = f (i x) (i y).

(** Commutative distributivity of unary operator *)

Definition distrib_comm i f := forall x y,
  i (f x y) = f (i y) (i x).

(** Left distributivity *)

Definition distrib_l f g := forall x y z,
  f x (g y z) = g (f x y) (f x z).

(** Right distributivity *)

Definition distrib_r f g := forall x y z,
  f (g y z) x = g (f y x) (f z x).

(* ---------------------------------------------------------------------- *)
(** ** Neutral and absorbant *)

(** Left Neutral *)

Definition neutral_l f e:= forall x,
  f e x = x.

(** Right Neutral *)

Definition neutral_r f e := forall x,
  f x e = x.

(** Left Absorbant *)

Definition absorb_l f a := forall x,
  f a x = a.

(** Right Absorbant *)

Definition absorb_r f a := forall x,
  f x a = a.

(** Idempotence *)

Definition idempotent i := forall x,
  i (i x) = i x.

Lemma use_idempotent : forall i x y,
  idempotent i ->
  y = i x ->
  i y = y.
  (* Expanded statement, for easier use by [eauto]. *)
Proof using.
  intros. subst. eauto.
Qed.

(** Idempotence *)

Definition involutive i := forall x,
  i (i x) = x.

(** Idempotence for binary operators *) (* TEMPORARY strange terminology! *)

Definition idempotent2 f := forall x,
  f x x = x.

(** Self Neutral *)

Definition self_neutral f e x :=
  f x x = e.

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

(** Left Inverse *)

Definition inverse_for_l f e a b :=
  f a b = e.

(** Right Inverse *)

Definition inverse_for_r f e a b :=
  f b a = e.

(** Left Inverse function -- todo arguments in order f i e ? *)

Definition inverse_l f e i := forall x,
  f (i x) x = e.

(** Right Inverse function *)

Definition inverse_r f e i := forall x,
  f x (i x) = e.

(** Self Inverse *)

Definition self_inverse i x :=
  i x = x.

End Definitions.

(* ---------------------------------------------------------------------- *)
(** ** Morphism and automorphism *)

(** Morphism *)

Definition morphism (A B : Type) (h : A -> B) (f : oper2 A) (g : oper2 B) :=
  forall x y, h (f x y) = g (h x) (h y).

(** Auto-morphism *)

Definition automorphism A := @morphism A A.
Implicit Arguments automorphism [A].

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

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

(* ********************************************************************** *)
(** * Derived properties *)

Section OpProperties.

Variable (A : Type).
Implicit Types f g : oper2 A.
Implicit Types h : oper1 A.

(** For commutative operators, right-properties can be derived from
    corresponding left-properties *)

Lemma neutral_r_from_comm_neutral_l : forall f e,
  comm f -> neutral_l f e -> neutral_r f e.
Proof using. introv C N. intros_all. rewrite* C. Qed.

Lemma inverse_r_from_comm_inverse_l : forall f e i,
  comm f -> inverse_l f e i -> inverse_r f e i.
Proof using. introv C I. intros_all. rewrite* C. Qed.

Lemma distrib_r_from_comm_distrib_l : forall f g,
  comm f -> distrib_l f g -> distrib_r f g.
Proof using.
  introv C N. intros_all. unfolds distrib_l.
  do 3 rewrite <- (C x). auto.
Qed.

(** [comm_assoc] derivable *)

Lemma comm_assoc_prove : forall f,
  comm f -> assoc f -> comm_assoc f.
Proof using.
  introv C S. intros_all. rewrite C.
  rewrite <- S. rewrite~ (C x).
Qed.

End OpProperties.


(* Basics: Functional Programming *)

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Eval simpl in (next_weekday friday).

Eval simpl in (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true : bool
  | false : bool.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Definition xorb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => b2
  | true => negb(b2)
  end.

Example test_xorb_10:
   (xorb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | false => true
  | true => negb(b2)
  end.

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  match b1 with
  | true => andb b2 b3
  | false => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check negb true.
Check negb.
Check andb3.

Module Playground1.

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

Definition pred (n : nat) : nat :=
  match n with
    | O => O
    | S m => m
  end.

End Playground1.

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Check (S (S (S (S O)))).
Eval simpl in (minustwo 4).

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

Definition oddb (n:nat) : bool := negb (evenb n).

Example test_oddb1: (oddb (S O)) = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: (oddb (S (S (S (S O))))) = false.
Proof. simpl. reflexivity. Qed.

Module Playground2.

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

Eval simpl in (plus (S (S (S O))) (S (S O))).

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => plus m (mult n' m)
  end.

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O , _ => O
  | S _ , O => n
  | S n', S m' => minus n' m'
  end.

End Playground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

(* Exercise: 1 star (factorial) *)

Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => S O
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

(* end of proof *)

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

Check ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Example test_ble_nat1: (ble_nat 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat2: (ble_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ble_nat3: (ble_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* Exercise: 2 stars (blt_nat) *)

Definition blt_nat (n m : nat) : bool :=
  andb (negb (beq_nat n m)) (ble_nat n m).

Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* end of proof *)

(* Proof By Simplification *)
Theorem plus_O_n : forall n:nat, 0 + n = n.
Proof. simpl. reflexivity. Qed.

Eval simpl in (forall n:nat, n + 0 = n).

Eval simpl in (forall n:nat, 0 + n = n).

Theorem plus_O_n'' : forall n:nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

(* Proof by Rewriting *)
Theorem plus_id_example : forall n m:nat,
  n = m ->
  n + n = m + m.
Proof.
  intros n m. (* move both quantifiers into the context *)
  intros H. (* move the hypothesis into the context *)
  rewrite <- H. (* Rewrite the goal using the hypothesis *)
  reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H.
  rewrite -> H.
  intros H2.
  rewrite -> H2. reflexivity. Qed.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity. Qed.

Theorem mult_1_plus : forall n m : nat,
  (1 + n) * m = m + (n * m).
Proof.
  intros n m.
  rewrite -> plus_1_l.
  reflexivity. Qed.