(**
初心に戻ってリストのappendとreverseを解き直してみる。
*)

From mathcomp Require Import all_ssreflect.
Require Import Program.

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

Section List.

  Variable A : Type.

  (* append 命題 *)
  Inductive append : seq A -> seq A -> seq A -> Prop :=
  | app_nil (b : seq A) : append [::] b b
  | app_cons (h : A) (a b c : seq A) : append a b c -> append (h :: a) b (h :: c).
  Hint Constructors append.

  (* append 関数 *)
  Fixpoint app (a b : seq A) : seq A :=
    match a with
    | [::] => b
    | h :: a => h :: app a b
    end.

  (* 命題と関数の同値の証明 *)
  Lemma appapp : forall (a b c : seq A), append a b c <-> app  a b = c.
  Proof.
    split.
    - elim=> b'' //= a' b' c' H IH.
        by rewrite IH.
    - elim: a b c => //=.
      + by move=> b c ->.
      + move=> n' a' IH b' c' <-.
        apply: app_cons.
          by apply: IH.
  Qed.

  (* Program コマンドで定義する。 *)
  Program Fixpoint app' (a b : seq A) : {c | append a b c} :=
    match a with
    | [::] => b
    | h :: a => h :: app' a b
    end.
  (* Obligation なし *)

  (* ******************************* *)
  (* うしろに append する (snoc) の例 *)
  (* ******************************* *)

  (* reverse1 命題 *)
  Inductive reverse1 : seq A -> seq A -> Prop :=
  | rev_nil : reverse1 [::] [::]
  | rev_cons (h : A) (a b c : seq A) :
      reverse1 a b -> append b [:: h] c -> reverse1 (h :: a) c.
  Hint Constructors reverse1.

  (* rev1 関数 *)
  Fixpoint rev1 (a : seq A) : seq A :=
    match a with
    | [::] => [::]
    | h :: a => app (rev1 a) [:: h]
    end.

  (* 命題と関数の同値の証明 *)
  Lemma revrev1l (a b : seq A) : reverse1 a b <-> rev1 a = b.
  Proof.
    split.
    - elim=> //= n a' b' c' H1 H2 H3.
      apply/appapp.
        by rewrite H2.
  - elim: a b => [b' H | n a IH c H].
    + by rewrite -H.
    + apply: rev_cons.
      * by apply: IH.
      * by apply/appapp.
  Qed.

  (* ************* *)
  (* 末尾再帰 の例 *)
  (* ************* *)

  (* reverse2 命題 *)
  Inductive reverse2 : seq A -> seq A -> seq A -> Prop :=
  | rev2_nil (b : seq A) : reverse2 [::] b b
  | rev2_cons (h : A) (a b c : seq A) :
      reverse2 a (h :: b) c -> reverse2 (h :: a) b c.
  Hint Constructors reverse2.

  (* rev2 関数 *)
  Fixpoint rev2 (a b : seq A) : seq A :=
    match a with
    | [::] => b
    | h :: a => rev2 a (h :: b)
    end.

  (* 命題と関数の同値の証明 *)
  Lemma revrev2 (a b c : seq A) : reverse2 a b c <-> rev2 a b = c.
  Proof.
    split.
    - by elim=> //=.
    - elim: a b c => [b c | h a IH b c H].
      + rewrite /rev2 => <-.
          by apply: rev2_nil.
      + apply: rev2_cons.
          by apply: IH.
  Qed.

  (* Program コマンドを使用する。 *)

  Program Fixpoint rev2' (a b : seq A) : {c : seq A | reverse2 a b c} :=
    match a with
    | [::] => b
    | h :: a => rev2' a (h :: b)
    end.
  (* Obligation なし *)

End List.

Goal reverse2 [:: 1;2;3] [::] [:: 3;2;1].
Proof.
  apply: rev2_cons.
  apply: rev2_cons.
  apply: rev2_cons.
  apply: rev2_nil.
Qed.

Compute rev2 [:: 1;2;3] [::].               (* [:: 3;2;1] *)

Compute proj1_sig (rev2' [:: 1;2;3] [::]).  (* [:: 3;2;1] *)

(**
   依存型Vectorの定義：
   https://www.math.nagoya-u.ac.jp/~garrigue/lecture/2011_AW/coq7.pdf
 *)
Section Vector.

  Variable A : Set.

  (* 依存型Vectorの定義 *)
  Inductive vector : nat -> Set :=
  | Vnil : vector 0
  | Vcons : forall n, A -> vector n -> vector n.+1.

  Check Vnil : vector 0.
  Check fun (h : A) => Vcons h Vnil : vector 1.

  (* vappend命題 *)
  Inductive vappend : forall (n m : nat),
      vector n -> vector m -> vector (n + m) -> Prop :=
  | vapp_nil : forall (n : nat) (b : vector n), vappend Vnil b b
  | vapp_cons : forall (h : A) (n m : nat)
                       (a : vector n) (b : vector m) (c : vector (n + m)),
      vappend a b c -> vappend (Vcons h a) b (Vcons h c).
  Hint Constructors vappend.

  (* vappend関数 *)
  Fixpoint vapp (n m : nat) (a : vector n) (b : vector m) : vector (n + m) :=
    match a with
    | Vnil => b
    | Vcons n h t => Vcons h (vapp t b)
  end.

  (* 命題と関数の同値の証明 *)
  Lemma vappapp (n m : nat) (a : vector n) (b : vector m) (c : vector (n + m)) :
    vappend a b c <-> vapp a b = c.
  Proof.
    split.
    - elim=> //= h n' m' a' b' c' H1 H2.
        by subst.
    - elim: a b c => //= [b c H | n' m' a IHa b c H]; subst.
      + done.
      + apply: vapp_cons.
          by apply: IHa.
  Qed.

  (* Program コマンドで定義する。 *)
  Program Fixpoint vapp' (n m : nat) (a : vector n) (b : vector m)
    : {c | vappend a b c} :=
  match a with
  | Vnil => b
  | Vcons n h t => Vcons h (vapp' t b)
  end.

  (* reverse の命題はうまく定義できない。 *)
  Fail Inductive vreverse : forall (n m : nat),
      vector nat n -> vector nat m -> vector nat (n + m) -> Prop :=
  | vrev_nil : forall (n : nat) (b : vector nat n), vreverse (Vnil nat) b b
  | vrev_cons : forall (h : nat) (n m : nat)
                       (a : vector nat n) (b : vector nat m) (c : vector nat (n + m).+1),
    vreverse a (Vcons h b) c -> vreverse (Vcons h a) b c.
  Fail Hint Constructors vreverse.

  Fail Inductive vreverse : forall (n : nat), vector nat n -> vector nat n -> Prop :=
  | vrev_nil : vreverse (Vnil nat) (Vnil nat)
  | vrev_cons (h : nat) (n : nat) (a b : vector nat n) (c : vector nat n.+1) :
      vreverse a b -> vappend b (Vcons h (Vnil nat)) c -> vreverse (Vcons h a) c.

  Fail Fixpoint vrev (n : nat) (a : vector nat n) : vector nat n :=
  match a with
  | Vnil => Vnil nat
  | Vcons n h t => vapp (vrev a) (Vcons h (Vnil nat))
  end.

  (* vreverse関数 *)
  Program Fixpoint vrev (n m : nat) (a : vector n) (b : vector m)
    : (vector (n + m)) :=
  match a with
  | Vnil => b
  | Vcons n h t => vrev t (Vcons h b)
  end.
  Next Obligation.
  Proof.
      by rewrite addSnnS.
  Defined.

End Vector.

Check Vnil nat : vector nat 0.
Check Vcons 100 (Vnil nat).

Definition data1 := Vcons 1 (Vcons 2 (Vnil nat)).
Definition data2 := Vcons 3 (Vcons 4 (Vnil nat)).
Definition data12 := Vcons 1 (Vcons 2 (Vcons 3 (Vcons 4 (Vnil nat)))).

Goal vappend data1 data2 data12.
Proof.
  apply: vapp_cons.
  apply: vapp_cons.
  apply: vapp_nil.
Qed.

Compute vapp data1 data2. (* = Vcons 1 (Vcons 2 (Vcons 3 (Vcons 4 (Vnil nat)))) *)
Compute proj1_sig (vapp' data1 data2).
(* (* = Vcons 1 (Vcons 2 (Vcons 3 (Vcons 4 (Vnil nat)))) *) *)

Compute vrev data1 (Vnil nat).              (* XXX *)

Require Import Extraction.
Extraction vapp.
(** val vapp : nat -> nat -> 'a1 vector -> 'a1 vector -> 'a1 vector **)
(*
let rec vapp _ m a b =
  match a with
  | Vnil -> b
  | Vcons (n, h, t) -> Vcons ((addn n m), h, (vapp n m t b))
 *)

Extraction vrev.
(** val vrev : nat -> nat -> 'a1 vector -> 'a1 vector -> 'a1 vector **)
(*
let rec vrev _ m a b =
  match a with
  | Vnil -> b
  | Vcons (n, h, t) -> vrev n (S m) t (Vcons (m, h, b))
 *)

(* END *)


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

(* ** Euclidian division and Bezout's identity *)

Require Import List Arith Lia Permutation Extraction.

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

Set Implicit Arguments.

Section Euclid.

  (* Simultaneous comparison and difference *)

  Fixpoint cmp_sub x y : { z | z+y = x } + { x < y }.
  Proof.
    refine (match y as y' return { z | z+y' = x } + { x < y' } with
      | 0    => inleft (exist _ x _)
      | S y' => match x as x' return { z | z+_ = x' } + { x' < _ } with
        | 0    => inright _
        | S x' => match cmp_sub x' y' with
          | inleft (exist _ z Hz) => inleft (exist _ z _)
          | inright H => inright _
        end
      end
    end); abstract lia.
  Defined.

  Definition euclid n d : d <> 0 -> { q : nat & { r | n = q*d+r /\ r < d } }.
  Proof.
    intros Hd; induction on n as euclid with measure n.
    refine (match cmp_sub n d with
      | inleft (exist _ z Hz) =>
      match euclid z _ with
        | existT _ q (exist _ r Hr) => existT _ (S q) (exist _ r _)
      end
      | inright H      => existT _ 0 (exist _ n _)
    end); abstract (simpl; lia).
  Defined.

End Euclid.

Definition arem n d q j := j <= d /\ (n = 2*q*d+j \/ q <> 0 /\ n = 2*q*d-j).

Fact division_by_even n d : d <> 0 -> { q : nat & { j | arem n d q j } }.
Proof.
  intros Hd.
  destruct (@euclid n (2*d)) as (q & r & H1 & H2); try lia.
  destruct (le_lt_dec r d) as [ Hr | Hr ].
  + exists q, r; split; auto; left.
    rewrite H1; ring.
  + exists (S q), (2*d-r); split; lia.
Qed.

Fact own_multiple x p : x = p*x -> x = 0 \/ p = 1.
Proof.
  destruct x as [ | x ].
  + left; trivial.
  + right.
    destruct p as [ | [ | p ] ].
    - simpl in H; discriminate.
    - trivial.
    - exfalso; revert H.
      do 2 (rewrite mult_comm; simpl).
      generalize (p*x); intros; lia.
Qed.

Fact mult_is_one p q : p*q = 1 -> p = 1 /\ q = 1.
Proof.
  destruct p as [ | [ | p ] ].
  + simpl; discriminate.
  + simpl; lia.
  + rewrite mult_comm.
    destruct q as [ | [ | q ] ].
    - simpl; discriminate.
    - simpl; lia.
    - simpl; discriminate.
Qed.

Definition divides n k := exists p, k = p*n.

Section divides.

  Infix "div" := divides (at level 70, no associativity).

  Fact divides_refl x : x div x.
  Proof. exists 1; simpl; lia. Qed.

  Fact divides_anti x y : x div y -> y div x -> x = y.
  Proof.
    intros (p & H1) (q & H2).
    rewrite H1, mult_assoc in H2.
    apply own_multiple in H2.
    destruct H2 as [ H2 | H2 ].
    + subst; rewrite mult_comm; auto.
    + apply mult_is_one in H2; destruct H2; subst; lia.
  Qed.

  Fact divides_trans x y z : x div y -> y div z -> x div z.
  Proof.
    intros (p & H1) (q & H2).
    exists (q*p); rewrite <- mult_assoc, <- H1; auto.
  Qed.

  Fact divides_0 p : p div 0.
  Proof. exists 0; auto. Qed.

  Fact divides_0_inv p : 0 div p -> p = 0.
  Proof. intros (?&?); subst; rewrite Nat.mul_0_r; auto. Qed.

  Fact divides_1 p : 1 div p.
  Proof. exists p; rewrite mult_comm; simpl; auto. Qed.

  Fact divides_1_inv p : p div 1 -> p = 1.
  Proof.
    intros (q & Hq).
    apply mult_is_one with q; auto.
  Qed.

  Fact divides_2_inv p : p div 2 -> p = 1 \/ p = 2.
  Proof.
    intros ([ | k ] & Hk); try discriminate.
    destruct p as [ | [ | [|] ] ]; lia.
  Qed.

  Fact divides_mult p q k : p div q -> p div k*q.
  Proof.
    intros (r & ?); subst.
    exists (k*r); rewrite mult_assoc; auto.
  Qed.

  Fact divides_mult_r p q k : p div q -> p div q*k.
  Proof.
    rewrite mult_comm; apply divides_mult; auto.
  Qed.

  Fact divides_mult_compat a b c d : a div b -> c div d -> a*c div b*d.
  Proof.
    intros (u & ?) (v & ?); exists (u*v); subst.
    repeat rewrite mult_assoc; f_equal.
    repeat rewrite <- mult_assoc; f_equal.
    apply mult_comm.
  Qed.

  Fact divides_minus p q1 q2 : p div q1 -> p div q2 -> p div q1 - q2.
  Proof.
    intros (s1 & H1) (s2 & H2).
    exists (s1 - s2).
    rewrite Nat.mul_sub_distr_r; lia.
  Qed.

  Fact divides_plus p q1 q2 : p div q1 -> p div q2 -> p div q1+q2.
  Proof.
    intros (s1 & H1) (s2 & H2).
    exists (s1 + s2).
    rewrite Nat.mul_add_distr_r; lia.
  Qed.

  Fact divides_plus_inv p q1 q2 : p div q1 -> p div q1+q2 -> p div q2.
  Proof.
     intros H1 H2.
     replace q2 with (q1+q2-q1) by lia.
     apply divides_minus; auto.
  Qed.

  Fact divides_le p q : q <> 0 -> p div q -> p <= q.
  Proof.
    intros ? ([] & ?); subst; lia.
  Qed.

  Fact divides_mult_inv k p q : k <> 0 -> k*p div k*q -> p div q.
  Proof.
    intros H (n & Hn); exists n.
    apply Nat.mul_cancel_r with (1 := H).
    rewrite mult_comm, Hn; ring.
  Qed.

  Lemma divides_fact m p : 1 < p <= m -> p div fact m.
  Proof.
    intros (H1 & H2); induction H2.
    + destruct p; cbn. lia. unfold divides. exists (fact p). ring.
    + cbn. eauto using divides_plus, divides_mult.
  Qed.

  Lemma divides_mult_inv_l p q r : p * q div r -> p div r /\ q div r.
  Proof.
    intros []; split; subst.
    - exists (x * q); ring.
    - exists (x * p); ring.
  Qed.

End divides.

Section gcd_lcm.

  Infix "div" := divides (at level 70, no associativity).

  Hint Resolve divides_0 divides_refl divides_mult divides_1 : core.

  Definition is_gcd p q r := r div p /\ r div q /\ forall k, k div p -> k div q -> k div r.
  Definition is_lcm p q r := p div r /\ q div r /\ forall k, p div k -> q div k -> r div k.

  Fact is_gcd_sym p q r : is_gcd p q r -> is_gcd q p r.
  Proof. intros (? & ? & ?); repeat split; auto. Qed.

  Fact is_gcd_0l p : is_gcd 0 p p.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_0r p : is_gcd p 0 p.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_1l p : is_gcd 1 p 1.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_1r p : is_gcd p 1 1.
  Proof. repeat split; auto. Qed.

  Fact is_gcd_modulus p q k r : p div k -> k <= q -> is_gcd p q r -> is_gcd p (q-k) r.
  Proof.
    intros (n & Hn) Hq (H1 & H2 & H3); subst.
    split; auto.
    split.
    + apply divides_minus; auto.
    + intros k H4 H5.
      apply H3; auto.
      replace q with (q - n*p + n*p) by lia.
      apply divides_plus; auto.
  Qed.

  Fact is_gcd_minus p q r : p <= q -> is_gcd p q r -> is_gcd p (q-p) r.
  Proof. intros H1; apply is_gcd_modulus; auto. Qed.

  Hint Resolve divides_plus : core.

  Fact is_gcd_moduplus p q k r : p div k -> is_gcd p q r -> is_gcd p (q+k) r.
  Proof.
    intros (n & Hn) (H1 & H2 & H3); subst.
    repeat (split; auto).
    intros k H4 H5.
    apply H3; auto.
    rewrite plus_comm in H5.
    apply divides_plus_inv with (2 := H5); auto.
  Qed.

  Fact is_gcd_plus p q r : is_gcd p q r -> is_gcd p (q+p) r.
  Proof. apply is_gcd_moduplus; auto. Qed.

  Fact is_gcd_mult p q r n : is_gcd p (n*p+q) r <-> is_gcd p q r.
  Proof.
    split.
    + replace q with ((n*p+q)-n*p) at 2 by lia.
      apply is_gcd_modulus; auto; lia.
    + rewrite plus_comm; apply is_gcd_moduplus; auto.
  Qed.

  Fact is_gcd_div p q : p div q -> is_gcd p q p.
  Proof. intros (?&?); subst; split; auto. Qed.

  Fact is_gcd_refl p : is_gcd p p p.
  Proof. split; auto. Qed.

  Fact is_gcd_fun p q r1 r2 : is_gcd p q r1 -> is_gcd p q r2 -> r1 = r2.
  Proof. intros (?&?&?) (?&?&?); apply divides_anti; auto. Qed.

  Fact is_lcm_0l p : is_lcm 0 p 0.
  Proof. repeat split; auto. Qed.

  Fact is_lcm_0r p : is_lcm p 0 0.
  Proof. repeat split; auto. Qed.

  Fact is_lcm_sym p q r : is_lcm p q r -> is_lcm q p r.
  Proof. intros (?&?&?); repeat split; auto. Qed.

  Fact is_lcm_fun p q r1 r2 : is_lcm p q r1 -> is_lcm p q r2 -> r1 = r2.
  Proof. intros (?&?&?) (?&?&?); apply divides_anti; auto. Qed.

End gcd_lcm.

Section bezout.

  Infix "div" := divides (at level 70, no associativity).

  Hint Resolve is_gcd_0l is_gcd_0r is_lcm_0l is_lcm_0r divides_refl divides_mult divides_0 is_gcd_minus : core.

  Section bezout_rel_prime.

    (* A Bezout procedure with better extraction *)

    Definition bezout_rel_prime_lt p q :
            0 < p < q
         -> is_gcd p q 1
         -> { a : nat & { b | a*p+b*q = 1+p*q
                           /\ a <= q
                           /\ b <= p } }.
    Proof.
      induction on p q as bezout with measure q; intros (Hp & Hq) H.
      refine (match @euclid q p _ with
        | existT _ n (exist _ r H0) =>
        match eq_nat_dec r 0 with
          | left Hr => existT _ 1 (exist _ 1 _)
          | right Hr => match @bezout r p Hq _ _ with
            | existT _ a (exist _ b G0) =>
               existT _ (b+n*p-n*a) (exist _ a _)
          end
        end
      end); try lia.
      + destruct H0 as (H1 & H2).
        subst r; rewrite plus_comm in H1; simpl in H1.
        assert (is_gcd p q p) as H3.
        { apply is_gcd_div; subst; auto. }
        rewrite (is_gcd_fun H3 H) in *.
        simpl; lia.
      + replace r with (q-n*p) by lia.
        apply is_gcd_sym, is_gcd_modulus; auto; lia.
      + destruct H0 as (H1 & H2).
        destruct G0 as (H3 & H4 & H5).
        split; [ | split ]; auto.
        * rewrite H1, Nat.mul_sub_distr_r, (mult_comm _ p).
          do 3 rewrite Nat.mul_add_distr_l.
          rewrite (plus_comm _ (p*r)), (plus_assoc 1), (mult_comm p r), <- H3.
          rewrite (mult_comm n a), (mult_comm p b), mult_assoc, mult_assoc.
          assert (a*n*p <= p*n*p) as H6.
          { repeat (apply mult_le_compat; auto). }
          revert H6; generalize (b*p) (a*r) (a*n*p) (p*n*p); intros; lia.
        * rewrite H1; generalize (n*p) (n*a); intros; lia.
    Defined.

    Definition bezout_rel_prime p q : is_gcd p q 1 -> { a : nat & { b | a*p+b*q = 1+p*q } }.
    Proof.
      intros H.
      destruct (eq_nat_dec p 0) as [ | Hp ].
      { subst; rewrite (is_gcd_fun (is_gcd_0l _) H); exists 0, 1; auto. }
      destruct (eq_nat_dec q 0) as [ | Hq ].
      { subst; rewrite (is_gcd_fun (is_gcd_0r _) H); exists 1, 0; auto. }
      destruct (lt_eq_lt_dec p q) as [ [ H1 | H1 ] | H1 ].
      + destruct bezout_rel_prime_lt with (2 := H)
          as (a & b & H2 & _); try lia.
        exists a, b; auto.
      + subst; rewrite (is_gcd_fun (is_gcd_refl _) H); exists 1, 1; auto.
      + destruct bezout_rel_prime_lt with (2 := is_gcd_sym H)
          as (a & b & H2 & _); try lia.
        exists b, a; rewrite (mult_comm p q); lia.
    Defined.

    Lemma bezout_nc p q : is_gcd p q 1 -> exists a b, a*p+b*q = 1+p*q.
    Proof.
      intros H.
      destruct bezout_rel_prime with (1 := H) as (a & b & ?).
      exists a, b; auto.
    Qed.

    Hint Resolve divides_1 : core.

    Lemma bezout_sc p q a b m : a*p+b*q = 1 + m -> p div m \/ q div m -> is_gcd p q 1.
    Proof.
      intros H1 H2; do 2 (split; auto).
      intros k H4 H5.
      apply divides_plus_inv with m.
      +  destruct H2 as [ H2 | H2 ];
         apply divides_trans with (2 := H2); auto.
      + rewrite plus_comm, <- H1.
        apply divides_plus; auto.
    Qed.

  End bezout_rel_prime.

  (* We need the simple form of Bezout above to show this *)

  Fact is_rel_prime_div p q k : is_gcd p q 1 -> p div q*k -> p div k.
  Proof.
    intros H1 (u & H2); subst.
    destruct bezout_nc with (1 := H1) as (a & b & H3).
    replace k with (k*(1+p*q) - k*p*q).
    + apply divides_minus.
      - rewrite <- H3, Nat.mul_add_distr_l.
        apply divides_plus.
        * rewrite mult_assoc; auto.
        * rewrite (mult_comm b), mult_assoc, (mult_comm k), H2.
          rewrite mult_comm, mult_assoc; auto.
      - rewrite mult_comm, mult_assoc; auto.
    + rewrite Nat.mul_add_distr_l, mult_assoc.
      generalize (k*p*q); intros; lia.
  Qed.

  Fact is_rel_prime_div_r p q k : is_gcd p q 1 -> p div k*q -> p div k.
  Proof. rewrite mult_comm; apply is_rel_prime_div. Qed.

  Fact divides_is_gcd a b c : divides a b -> is_gcd b c 1 -> is_gcd a c 1.
  Proof.
    intros H1 H2; msplit 2; try apply divides_1.
    intros k H3 H4.
    apply H2; auto.
    apply divides_trans with a; auto.
  Qed.

  Fact is_rel_prime_lcm p q : is_gcd p q 1 -> is_lcm p q (p*q).
  Proof.
    intros H.
    repeat (split; auto).
    rewrite mult_comm; auto.
    intros k (u & ?) (v & ?); subst.
    rewrite (mult_comm u).
    apply divides_mult_compat; auto.
    apply is_gcd_sym in H.
    apply is_rel_prime_div with (1 := H) (k := u).
    rewrite mult_comm, H1; auto.
  Qed.

  Hint Resolve divides_1 divides_mult_compat is_gcd_refl : core.

  Fact is_gcd_0 p q : is_gcd p q 0 -> p = 0 /\ q = 0.
  Proof.
    intros ((a & Ha) & (b & Hb) & H).
    subst; do 2 rewrite mult_0_r; auto.
  Qed.

  Fact is_gcd_rel_prime p q g : is_gcd p q g -> exists a b, p = a*g /\ q = b*g /\ is_gcd a b 1.
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ].
    * intros H; subst.
      apply is_gcd_0 in H; destruct H; subst.
      exists 1, 1 ; simpl; auto.
    * intros ((a & Ha) & (b & Hb) & H).
      exists a, b; repeat (split; auto).
      intros k H1 H2.
      destruct (H (k*g)) as (d & Hd); subst.
      + do 2 rewrite (mult_comm _ g); auto.
      + do 2 rewrite (mult_comm _ g); auto.
      + rewrite mult_assoc in Hd.
        replace g with (1*g) in Hd at 1 by (simpl; lia).
        apply Nat.mul_cancel_r in Hd; auto.
        symmetry in Hd.
        apply mult_is_one in Hd.
        destruct Hd; subst; auto.
  Qed.

  Fact is_lcm_mult p q l k : is_lcm p q l -> is_lcm (k*p) (k*q) (k*l).
  Proof.
    intros (H1 & H2 & H3); repeat (split; auto).
    intros r (a & Ha) (b & Hb).
    destruct (eq_nat_dec k 0) as [ Hk | Hk ].
    + subst; simpl; auto.
    + assert (a*p = b*q) as H4.
      { rewrite <- Nat.mul_cancel_r with (1 := Hk).
        do 2 rewrite <- mult_assoc, (mult_comm _ k).
        rewrite <- Hb; auto. }
      rewrite Ha, mult_assoc, (mult_comm _ k), <- mult_assoc.
      apply divides_mult_compat; auto.
      apply H3; auto.
      rewrite H4; auto.
  Qed.

  Theorem is_gcd_lcm_mult p q g l : is_gcd p q g -> is_lcm p q l -> p*q = g*l.
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ]; intros H1.
    * subst; apply is_gcd_0 in H1.
      destruct H1; subst; simpl; auto.
    * destruct is_gcd_rel_prime with (1 := H1)
        as (u & v & Hu & Hv & H2).
      intros H3.
      rewrite Hu, Hv, (mult_comm u), <- mult_assoc; f_equal.
      rewrite (mult_comm u), (mult_comm v), <- mult_assoc, (mult_comm v).
      apply is_lcm_fun with (2 := H3).
      subst; rewrite (mult_comm u), (mult_comm v).
      apply is_lcm_mult, is_rel_prime_lcm; auto.
  Qed.

  Theorem is_gcd_mult_lcm p q g l : g <> 0 -> is_gcd p q g -> g*l = p*q -> is_lcm p q l.
  Proof.
    intros H0 H1 H2.
    destruct is_gcd_rel_prime with (1 := H1)
        as (u & v & Hu & Hv & H3).
    rewrite Hu, Hv, (mult_comm u), (mult_comm v).
    replace l with (g*(u*v)).
    + apply is_lcm_mult, is_rel_prime_lcm; auto.
    + rewrite <- Nat.mul_cancel_r with (1 := H0).
      rewrite (mult_comm l), H2, Hu, Hv,
              (mult_comm u g), mult_assoc, mult_assoc; auto.
  Qed.

  (*  if   1) p <= q
           2) p = u*g
           3) gcd p q = g
           4) lcm p q = l
      then A) gcd p (q-p) = g
           B) lcm p (q-p) = l-u*p *)

  Lemma is_lcm_minus p q g l u : p <= q -> p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q-p) (l-u*p).
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ].
    + intros _ _ H1 H2.
      subst; apply is_gcd_0 in H1.
      destruct H1; subst; simpl.
      rewrite mult_0_r, Nat.sub_0_r; auto.
    + intros H1 H2 H3 H4.
      apply is_gcd_mult_lcm with (1 := H0).
      * apply is_gcd_minus; auto.
      * do 2 rewrite Nat.mul_sub_distr_l.
        rewrite <- (is_gcd_lcm_mult H3 H4).
        f_equal.
        rewrite H2 at 2.
        rewrite mult_assoc, (mult_comm g); auto.
  Qed.

  (*  if   1) p <= q
           2) p = u*g
           3) gcd p q = g
           4) lcm p q = l
      then A) gcd p (q-k*p) = g
           B) lcm p (q-p) = l-k*u*p *)

  Lemma is_lcm_modulus k p q g l u : k*p <= q -> p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q-k*p) (l-k*u*p).
  Proof.
    rewrite <- mult_assoc.
    intros H1 H2 H3 H4. revert H1.
    induction k as [ | k IHk ]; intros H1.
    + simpl; do 2 rewrite Nat.sub_0_r; auto.
    + replace (q - S k*p) with (q -k*p -p) by (simpl; lia).
      replace (l - S k*(u*p)) with (l - k*(u*p) - u*p).
      - apply is_lcm_minus with (g := g); auto.
        * simpl in H1; lia.
        * apply is_gcd_modulus; auto.
          simpl in H1; lia.
        * apply IHk; simpl in H1; lia.
      - simpl; generalize (u*p) (k*(u*p)); intros; lia.
  Qed.

  (*  if   1) p <= q
           2) p = u*g
           3) gcd p q = g
           4) lcm p q = l
      then A) gcd p (q+p) = g
           B) lcm p (q+p) = l+u*p *)

  Lemma is_lcm_plus p q g l u : p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q+p) (l+u*p).
  Proof.
    destruct (eq_nat_dec g 0) as [ H0 | H0 ].
    + intros _ H1 H2.
      subst; apply is_gcd_0 in H1.
      destruct H1; subst; simpl.
      rewrite mult_0_r, Nat.add_0_r; auto.
    + intros H2 H3 H4.
      apply is_gcd_mult_lcm with (1 := H0).
      * apply is_gcd_plus; auto.
      * do 2 rewrite Nat.mul_add_distr_l.
        rewrite <- (is_gcd_lcm_mult H3 H4).
        f_equal.
        rewrite H2 at 2.
        rewrite mult_assoc, (mult_comm g); auto.
  Qed.

  Lemma is_lcm_moduplus k p q g l u : p = u*g -> is_gcd p q g -> is_lcm p q l -> is_lcm p (q+k*p) (l+k*u*p).
  Proof.
    rewrite <- mult_assoc.
    intros H2 H3 H4.
    induction k as [ | k IHk ].
    + simpl; do 2 rewrite Nat.add_0_r; auto.
    + replace (q + S k*p) with (q +k*p +p) by (simpl; lia).
      replace (l + S k*(u*p)) with (l + k*(u*p) + u*p) by (simpl; lia).
      apply is_lcm_plus with (g := g); auto.
      apply is_gcd_moduplus; auto.
  Qed.

  Section bezout_generalized.

    (* TODO, write this FULLY specified Bezout with a better extraction, following bezout_rel_prime above *)

    Definition bezout_generalized_lt p q :
                         0 < p < q
                      -> { a : nat
                       & { b : nat
                       & { g : nat
                       & { l : nat
                       & { u : nat
                       & { v : nat
                         | a*p+b*q = g + l
                        /\ is_gcd p q g
                        /\ is_lcm p q l
                        /\ p = u*g
                        /\ q = v*g
                        /\ a <= v
                        /\ b <= u } } } } } }.
    Proof.
      induction on p q as IH with measure q; intros (Hp & Hq).
      destruct (@euclid q p) as (k & r & H1 & H2); try lia.
      destruct (eq_nat_dec r 0) as [ Hr | Hr ].
      + exists 1, 1, p, (k*p), 1, k.
        rewrite plus_comm in H1; simpl in H1.
        subst; repeat split; simpl; auto.
        destruct k; lia.
      + destruct (IH r _ Hq) as (a & b & g & l & u & v & H3 & H4 & H5 & H6 & H7 & H8 & H9); try lia.
        exists (b+k*v-k*a), a, g, (l+k*v*p), v, (k*v+u).
        apply is_gcd_sym in H4.
        apply is_lcm_sym in H5.
        rewrite plus_comm in H1.
        assert (g <> 0) as Hg.
        { intro; subst g; apply is_gcd_0, proj1 in H4; lia. }
        split.
        { rewrite H1, plus_assoc, Nat.mul_add_distr_l, <- H3.
          rewrite Nat.mul_sub_distr_r, Nat.mul_add_distr_r.
          rewrite mult_assoc, (mult_comm a k).
          assert (k*a*p <= k*v*p) as G.
          { repeat (apply mult_le_compat; auto). }
          revert G; generalize (b*p) (a*r) (k*a*p) (k*v*p); intros; lia. }
        split.
        { rewrite H1; apply is_gcd_moduplus; auto. }
        split.
        { rewrite H1; apply is_lcm_moduplus with g; auto. }
        split; auto.
        split.
        { rewrite H1, H6, H7, Nat.mul_add_distr_r, mult_assoc; lia. }
        split; auto.
        { rewrite (plus_comm _ u), <- Nat.add_sub_assoc.
          +  apply plus_le_compat; auto.
             generalize (k*v) (k*a); intros; lia.
          + apply mult_le_compat; auto. }
    Defined.

    Hint Resolve is_gcd_sym is_lcm_sym : core.

    Definition bezout_generalized p q : { a : nat
                                      & { b : nat
                                      & { g : nat
                                      & { l : nat
                                        | a*p+b*q = g + l
                                       /\ is_gcd p q g
                                       /\ is_lcm p q l } } } }.
    Proof.
      destruct (eq_nat_dec p 0) as [ | Hp ].
      { subst; exists 0, 1, q, 0; repeat (split; auto). }
      destruct (eq_nat_dec q 0) as [ | Hq ].
      { subst; exists 1, 0, p, 0; repeat (split; auto). }
      destruct (lt_eq_lt_dec p q) as [ [ H1 | H1 ] | H1 ].
      + destruct (@bezout_generalized_lt p q)
          as (a & b & g & l & _ & _ & ? & ? & ? & _); try lia.
        exists a, b, g, l; auto.
      + subst q; exists 1, 1, p, p.
        repeat split; auto; lia.
      + destruct (@bezout_generalized_lt q p)
          as (a & b & g & l & _ & _ & ? & ? & ? & _); try lia.
        exists b, a, g, l; repeat (split; auto); lia.
    Qed.

  End bezout_generalized.

  Section gcd_lcm.

    Let gcd_full p q : sig (is_gcd p q).
    Proof.
      destruct (bezout_generalized p q) as (_ & _ & g & _ & _ & ? & _).
      exists g; auto.
    Qed.

    Definition gcd p q := proj1_sig (gcd_full p q).
    Fact gcd_spec p q : is_gcd p q (gcd p q).
    Proof. apply (proj2_sig _). Qed.

    Let lcm_full p q : sig (is_lcm p q).
    Proof.
      destruct (bezout_generalized p q) as (_ & _ & _ & l & _ & _ & ?).
      exists l; auto.
    Qed.

    Definition lcm p q := proj1_sig (lcm_full p q).
    Fact lcm_spec p q : is_lcm p q (lcm p q).
    Proof. apply (proj2_sig _). Qed.

  End gcd_lcm.

End bezout.

Section division.

  Fact div_full q p : { n : nat & { r | q = n*p+r /\ (p <> 0 -> r < p) } }.
  Proof.
    case_eq p.
    + intro; exists 0, q; subst; split; auto; intros []; auto.
    + intros k H; destruct (@euclid q p) as (n & r & H1 & H2); try lia.
      exists n, r; rewrite <- H; split; auto.
  Qed.

  Definition div q p := projT1 (div_full q p).
  Definition rem q p := proj1_sig (projT2 (div_full q p)).

  Fact div_rem_spec1 q p : q = div q p * p + rem q p.
  Proof. apply (proj2_sig (projT2 (div_full q p))). Qed.

  Fact div_rem_spec2 q p : p <> 0 -> rem q p < p.
  Proof. apply (proj2_sig (projT2 (div_full q p))). Qed.

  Fact rem_0 q : rem q 0 = q.
  Proof.
    generalize (div_rem_spec1 q 0).
    rewrite mult_comm; auto.
  Qed.

  Fact div_rem_uniq p n1 r1 n2 r2 :
        p <> 0 -> n1*p + r1 = n2*p + r2 -> r1 < p -> r2 < p -> n1 = n2 /\ r1 = r2.
  Proof.
    intros H1 H2 H3 H4.
    assert (n1 = n2) as E.
    destruct (lt_eq_lt_dec n1 n2) as [ [ H | ] | H ]; auto.
    + replace n2 with (n2-n1 + n1) in H2 by lia.
      rewrite Nat.mul_add_distr_r in H2.
      assert (1*p <= (n2-n1)*p) as H5.
      { apply mult_le_compat; lia. }
      simpl in H5; lia.
    + replace n1 with (n1-n2 + n2) in H2 by lia.
      rewrite Nat.mul_add_distr_r in H2.
      assert (1*p <= (n1-n2)*p) as H5.
      { apply mult_le_compat; lia. }
      simpl in H5; lia.
    + subst; lia.
  Qed.

  Fact div_prop q p n r : q = n*p+r -> r < p -> div q p = n.
  Proof.
    intros H1 H2.
    apply (@div_rem_uniq p _ (rem q p) n r); auto.
    + lia.
    + rewrite <- H1; symmetry; apply div_rem_spec1.
    + apply div_rem_spec2; lia.
  Qed.

  Fact rem_prop q p n r : q = n*p+r -> r < p -> rem q p = r.
  Proof.
    intros H1 H2.
    apply (@div_rem_uniq p (div q p) _ n r); auto.
    + lia.
    + rewrite <- H1; symmetry; apply div_rem_spec1.
    + apply div_rem_spec2; lia.
  Qed.

  Fact rem_idem q p : q < p -> rem q p = q.
  Proof. apply rem_prop with 0; auto. Qed.

  Fact rem_rem x m : rem (rem x m) m = rem x m.
  Proof.
    destruct (eq_nat_dec m 0).
    + subst; rewrite !rem_0; auto.
    + apply rem_idem, div_rem_spec2; auto.
  Qed.

  Fact is_gcd_rem p n a : is_gcd p n a <-> is_gcd p (rem n p) a.
  Proof.
    rewrite (div_rem_spec1 n p) at 1; apply is_gcd_mult.
  Qed.

  Fact rem_erase q n p r : q = n*p+r -> rem q p = rem r p.
  Proof.
    destruct (eq_nat_dec p 0) as [ | Hp ]; subst.
    + rewrite mult_comm, rem_0, rem_0; auto.
    + destruct (div_full r p) as (m & r' & H1 & H2).
      specialize (H2 Hp).
      rewrite rem_prop with r p m r'; auto.
      intros; apply rem_prop with (n+m); auto.
      rewrite Nat.mul_add_distr_r; lia.
  Qed.

  Fact divides_div q p : divides p q -> q = div q p * p.
  Proof.
    intros (k & Hk).
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    + subst; do 2 (rewrite mult_comm; simpl); auto.
    + rewrite (@div_prop q p k 0); lia.
  Qed.

  Fact divides_rem_eq q p : divides p q <-> rem q p = 0.
  Proof.
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    * subst; rewrite rem_0; split.
      + apply divides_0_inv.
      + intros; subst; apply divides_0.
    * split.
      + intros (n & Hn).
        apply rem_prop with n; lia.
      + intros H.
        generalize (div_rem_spec1 q p).
        exists (div q p); lia.
  Qed.

  Fact rem_of_0 p : rem 0 p = 0.
  Proof.
    destruct p.
    + apply rem_0.
    + apply rem_prop with 0; lia.
  Qed.

  Hint Resolve divides_0_inv : core.

  Fact divides_dec q p : { k | q = k*p } + { ~ divides p q }.
  Proof.
    destruct (eq_nat_dec p 0) as [ Hp | Hp ].
    + destruct (eq_nat_dec q 0) as [ Hq | Hq ].
      * left; subst; exists 1; auto.
      * right; contradict Hq; subst; auto.
    + destruct (@euclid q p Hp) as (n & [ | r ] & H1 & H2).
      * left; exists n; subst; rewrite plus_comm; auto.
      * right; intros (m & Hm).
        rewrite <- Nat.add_0_r in Hm.
        rewrite Hm in H1.
        destruct (div_rem_uniq _ _ Hp H1); lia.
  Qed.

End division.

Section rem.

  Variable (p : nat) (Hp : p <> 0).

  Fact rem_plus_rem a b : rem (a+rem b p) p = rem (a+b) p.
  Proof.
    rewrite (div_rem_spec1 b p) at 2.
    rewrite plus_assoc.
    symmetry; apply rem_erase with (div (b) p); ring.
  Qed.

  Fact rem_mult_rem a b : rem (a*rem b p) p = rem (a*b) p.
  Proof.
    rewrite (div_rem_spec1 b p) at 2.
    rewrite Nat.mul_add_distr_l, mult_assoc.
    symmetry; apply rem_erase with (a*div b p); auto.
  Qed.

  Fact rem_diag : rem p p = 0.
  Proof. apply rem_prop with 1; lia. Qed.

  Fact rem_lt a : a < p -> rem a p = a.
  Proof. apply rem_prop with 0; lia. Qed.

  Fact rem_plus a b : rem (a+b) p = rem (rem a p + rem b p) p.
  Proof.
    rewrite (div_rem_spec1 a p) at 1.
    rewrite (div_rem_spec1 b p) at 1.
    apply rem_erase with (div a p + div b p).
    ring.
  Qed.

  Fact rem_scal k a : rem (k*a) p = rem (k*rem a p) p.
  Proof.
    rewrite (div_rem_spec1 a p) at 1.
    rewrite Nat.mul_add_distr_l.
    apply rem_erase with (k*div a p).
    ring.
  Qed.

  Fact rem_plus_div a b : divides p b -> rem a p = rem (a+b) p.
  Proof.
    intros (n & Hn); subst.
    rewrite <- rem_plus_rem.
    f_equal.
    rewrite <- rem_mult_rem, rem_diag, Nat.mul_0_r, rem_of_0; lia.
  Qed.

  Fact div_eq_0 n : n < p -> div n p = 0.
  Proof. intros; apply div_prop with n; lia. Qed.

  Fact div_of_0 : div 0 p = 0.
  Proof. apply div_eq_0; lia. Qed.

  Fact div_ge_1 n : p <= n -> 1 <= div n p.
  Proof.
    intros H2.
    rewrite (div_rem_spec1 n p) in H2.
    generalize (div_rem_spec2 n Hp); intros H3.
    destruct (div n p); lia.
  Qed.

End rem.

Fact divides_rem_rem p q a : divides p q -> rem (rem a q) p = rem a p.
Proof.
  destruct (eq_nat_dec p 0) as [ Hp | Hp ].
  { intros (k & ->); subst; rewrite mult_0_r.
    repeat rewrite rem_0; auto. }
  intros H.
  generalize (div_rem_spec1 a q); intros H1.
  destruct H as (k & ->).
  rewrite H1 at 2.
  rewrite plus_comm.
  apply rem_plus_div; auto.
  do 2 apply divides_mult.
  apply divides_refl.
Qed.

Fact divides_rem_congr p q a b : divides p q -> rem a q = rem b q -> rem a p = rem b p.
Proof.
  intros H1 H2.
  rewrite <- (divides_rem_rem a H1),
          <- (divides_rem_rem b H1).
  f_equal; auto.
Qed.

Fact div_by_p_lt p n : 2 <= p -> n <> 0 -> div n p < n.
Proof.
  intros H1 H2.
  rewrite (div_rem_spec1 n p) at 2.
  replace p with (2+(p-2)) at 3 by lia.
  rewrite Nat.mul_add_distr_l.
  generalize (div n p*(p-2)); intros x.
  destruct (le_lt_dec p n) as [ Hp | Hp ].
  + apply div_ge_1 in Hp; lia.
  + rewrite rem_lt; lia.
Qed.

Section rem_2.

  Fact rem_2_is_0_or_1 x : rem x 2 = 0 \/ rem x 2 = 1.
  Proof. generalize (rem x 2) (@div_rem_spec2 x 2); intros; lia. Qed.

  Fact rem_2_mult x y : rem (x*y) 2 = 1 <-> rem x 2 = 1 /\ rem y 2 = 1.
  Proof.
    generalize (rem_2_is_0_or_1 x) (rem_2_is_0_or_1 y).
    do 2 rewrite <- rem_mult_rem, mult_comm.
    intros [ H1 | H1 ] [ H2 | H2 ]; rewrite H1, H2; simpl; rewrite rem_lt; lia.
  Qed.

  Fact rem_2_fix_0 : rem 0 2 = 0.
  Proof. apply rem_lt; lia. Qed.

  Fact rem_2_fix_1 n : rem (2*n) 2 = 0.
  Proof. apply divides_rem_eq; exists n; ring. Qed.

  Fact rem_2_fix_2 n : rem (1+2*n) 2 = 1.
  Proof.
    rewrite <- rem_plus_rem,rem_2_fix_1, rem_lt; lia.
  Qed.

  Fact rem_2_lt n : rem n 2 < 2.
  Proof. apply div_rem_spec2; lia. Qed.

  Fact div_2_fix_0 : div 0 2 = 0.
  Proof. apply div_of_0; lia. Qed.

  Fact div_2_fix_1 n : div (2*n) 2 = n.
  Proof. apply div_prop with 0; lia. Qed.

  Fact div_2_fix_2 n : div (1+2*n) 2 = n.
  Proof. apply div_prop with 1; lia. Qed.

  Fact euclid_2_div n : n = rem n 2 + 2*div n 2 /\ (rem n 2 = 0 \/ rem n 2 = 1).
  Proof.
    generalize (div_rem_spec1 n 2) (@div_rem_spec2 n 2); intros; lia.
  Qed.

  Fact euclid_2 n : exists q, n = 2*q \/ n = 1+2*q.
  Proof.
    exists (div n 2).
    generalize (div_rem_spec1 n 2) (@div_rem_spec2 n 2); intros; lia.
  Qed.

End rem_2.

Local Hint Resolve divides_mult divides_mult_r divides_refl : core.


Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Definition double_bin (b:bin) : bin :=
    match b with
    | Z => Z
    | n => B0 n
    end.

Fixpoint incr (m : bin) : bin :=
    match m with
    | Z => B1 Z
    | B0 n => B1 n
    | B1 n => B0 (incr n)
    end.

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
  | Z => O
  | B0 n => 2 * bin_to_nat n
  | B1 n => 1 + 2 * bin_to_nat n
  end.

Fixpoint nat_to_bin (n:nat) : bin :=
  match n with
  | O => Z
  | S n' => incr (nat_to_bin n')
  end.

Fixpoint normalize (b:bin) : bin :=
    match b with
    | Z => Z
    | B0 Z => Z
    | B0 n => B0(normalize(n))
    | B1 n => B1(normalize(n))
    end.

 Lemma double_incr_bin : forall b,
    double_bin (incr b) = incr (incr (double_bin b)).
Proof.
  intros b. induction b as [| b' | b'].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  Qed.

Lemma n_plus_0_eq_n : forall n : nat,
  n + 0 = n.
Proof.
  intros n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
  Qed.

Lemma l8r : forall b : bin,
  bin_to_nat b + bin_to_nat b = 2 * bin_to_nat b.
Proof.
    intros b. simpl. rewrite -> n_plus_0_eq_n. reflexivity.
    Qed.

Lemma l9r : forall b : bin,
    bin_to_nat(B0 b) = 2 * bin_to_nat b.
Proof.
    intros b. reflexivity.
    Qed.

Lemma add_assoc : forall n m p : nat,
    n + (m + p) = (n + m) + p.
Proof. Admitted.

Lemma l12r : forall b : bin,
  nat_to_bin(2 * bin_to_nat b) = double_bin(nat_to_bin(bin_to_nat b)).
Proof.
  intros b. induction b as [| b' | b'].
  - simpl. reflexivity.
  - simpl. rewrite -> n_plus_0_eq_n. rewrite -> n_plus_0_eq_n. rewrite -> l8r. rewrite <- l9r. rewrite -> l8r.

Lemma kk : forall b : bin,
    nat_to_bin (bin_to_nat (B0 b)) = double_bin(nat_to_bin (bin_to_nat b)).
Proof.
    intros b. induction b as [| b' | b'].
    - simpl. reflexivity.
    - simpl. rewrite -> n_plus_0_eq_n. rewrite -> n_plus_0_eq_n. rewrite -> l8r. rewrite <- l9r. rewrite -> IHb'. rewrite -> l8r. rewrite ->  l9r.

(* Lemma jj : forall b : bin,
    normalize(B0 b) = normalize(double_bin(normalize(b))).
Proof.
  intros b. induction b as [| b' | b'].
  - reflexivity.
  -  *)

(* Lemma l10r : forall b : bin,
    double_bin(normalize b) = normalize(double_bin b).
Proof.
  intros b. induction b as [| b' | b'].
  - reflexivity.
  - *)

(* Lemma l11r : forall b : bin,
    normalize(normalize b) = normalize b.
Proof.
  intros b. induction b as [| b' | b'].
  - simpl. reflexivity.
  -  *)

Lemma l13r : forall b : bin,
  incr(double_bin (b)) = B1 b.
Proof.
  intros b. induction b as [| b' | b'].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  Qed.

Theorem bin_nat_bin : forall b,
    nat_to_bin (bin_to_nat b) = normalize b.
Proof.
    intros b. induction b as [| b' | b'].
    - reflexivity.
    - rewrite -> kk. rewrite -> IHb'. rewrite -> jj.
    rewrite -> l10r. rewrite -> l11r. reflexivity.
    - simpl. rewrite -> n_plus_0_eq_n. rewrite -> l8r. rewrite <- IHb'.
    rewrite -> l12r. rewrite -> IHb'. rewrite -> l13r. reflexivity.
    Qed.


Section ExerciseOne.

Lemma Ex1A : forall a b c : Prop, (a \/ b) \/ c -> a \/ (b \/ c).
Proof.
intros a b c H.
destruct H as [HO | H3].
destruct HO as [H1 | H2].
  left.
  exact H1.
  right.
  left.
  exact H2.
  right.
  right.
  exact H3.
Qed.

Lemma Ex1B : forall a b c : Prop, (b -> c) -> a \/ b -> a \/ c.
intros a b c H1 H2.
destruct H2 as [H3 | H4].
  left.
  exact H3.
  right.
  apply H1.
  exact H4.
Qed.

Lemma Ex1C : forall a b c : Prop, (a /\ b) /\ c -> a /\ (b /\ c).
intros a b c H.
destruct H as [HO H3].
destruct HO as [H1 H2].
  split.
    exact H1.
    split.
      exact H2.
      exact H3.
Qed.

Lemma Ex1D : forall a b c : Prop, a \/ (b \/ c) -> (a \/ b) \/ (a \/ c).
intros a b c H.
destruct H as [HO | H3].
  left.
  left.
  exact HO.
  destruct H3 as [H1 | H2].
    left.
    right.
    exact H1.
    right.
    right.
    exact H2.
Qed.

Lemma Ex1E : forall a b c : Prop, (a /\ b) \/ (a /\ c) <-> a /\ (b \/ c).
intros a b c.
split.
  (* left to right *)
  intros H.
  split.
    destruct H as [H1 | H2].
    destruct H1 as [H3 H4].
    exact H3.
    destruct H2 as [H5 H6].
    exact H5.
  destruct H as [H1 | H2].
  destruct H1 as [H3 H4].
  left.
  exact H4.
  destruct H2 as [H5 H6].
  right.
  exact H6.
  (* right to left *)
  intros H.
  destruct H as [H1 H2].
  destruct H2 as [H3 | H4].
  left.
  split.
  exact H1.
  exact H3.
  right.
  split.
  exact H1.
  exact H4.
Qed.

Lemma Ex1F : forall a b c : Prop, (a \/ b) /\ (a \/ c) <-> a \/ (b /\ c).
Proof.
intros a b c.
split.
  (* left to right *)
  intros H.
  destruct H as [H1 H2].
  destruct H1 as [H3 | H4].
  left; exact H3.
  destruct H2 as [H5 | H6].
  left; exact H5.
  right.
  split.
    exact H4.
    exact H6.
  (* right to left *)
  intro H.
  split; destruct H as [H1 | H2].
    left; exact H1.
    destruct H2 as [H3 H4].
    right; exact H3.
    left; exact H1.
    destruct H2 as [H3 H4].
    right; exact H4.
Qed.


Require Import FSets MapFunction.
Require Import Arith EqNat Euclid ArithRing ZArith.
Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

(** First, let's define powers of 2 and binomial function
    for later expressing the cardinal of powersets. *)

Fixpoint two_power (n:nat) : nat := match n with
 | O => 1
 | S n => 2 * (two_power n)
 end.

Fixpoint binomial n k { struct n } := match n, k with
  | _, O => 1
  | O, _ => 0
  | S n', S k' => binomial n' k' + binomial n' k
 end.

Fixpoint fact n := match n with
  | O => 1
  | S n' => n * (fact n')
 end.

Lemma binomial_0 : forall n k, k>n -> binomial n k = 0.
Proof.
induction n; destruct k; simpl; auto.
inversion 1.
inversion 1.
intros.
do 2 (rewrite IHn; auto with arith).
Qed.

Lemma binomial_rec : forall n k, k<=n ->
 (binomial n k)*(fact k * fact (n-k)) = fact n.
Proof.
induction n; destruct k.
simpl; auto.
inversion 1.
simpl; intros; ring.
intros.
change (fact (S n)) with ((1+n)*(fact n)).
change (fact (S k)) with ((1+k)*(fact k)).
simpl (S n - S k).
simpl binomial.
inversion_clear H.
rewrite (@binomial_0 n (S n)); auto.
pattern (fact n) at 2; rewrite <- (IHn n); auto; ring.
cut ((binomial n k)*(fact k*fact (n-k))*(1+k) +
     (binomial n (S k))*(fact (S k)*fact (n-S k))*(n-k) =
     (1+n)*fact n).
intros H; rewrite <- H.
replace (n-k) with (S (n-S k)) by omega.
simpl; ring.
rewrite (IHn k); auto with arith.
rewrite (IHn (S k)); auto with arith.
cut (((1+k)+(n-k))*(fact n) = (1+n)*(fact n)).
intro H; rewrite <- H; ring.
replace (1+k+(n-k)) with (1+n) by omega; auto.
Qed.

Lemma fact_pos : forall k, fact k > 0.
Proof.
 induction k; simpl; auto with arith.
Qed.

Lemma binomial_den_pos : forall n k, fact k * fact (n-k) > 0.
Proof.
 intros; generalize (fact_pos k) (fact_pos (n-k)).
 unfold gt; intros.
 change 0 with (0*(fact (n-k))).
 apply mult_lt_compat_r; auto with arith.
Qed.

Definition binomial' n k :=
 let (q,_) := quotient (fact k * fact (n-k)) (binomial_den_pos n k) (fact n)
 in q.

Lemma binomial_alt : forall n k, k<=n ->
 binomial n k = binomial' n k.
Proof.
intros.
unfold binomial'.
destruct quotient as (q,(r,(H1,H2))).
assert (H3:=binomial_rec H).
assert (H4:=binomial_den_pos n k).
set (D:=fact k * fact (n-k)) in *.
assert (r = fact n - q * D) by omega.
rewrite <- H3 in H0.
assert (r = (binomial n k - q)*D) by (rewrite H0;auto with arith).
rewrite H5 in H2; unfold gt in H2.
case_eq (binomial n k - q); intros.
rewrite H6 in *; simpl in *.
rewrite H5 in *; simpl in *.
rewrite plus_comm in H1; simpl in H1.
rewrite H1 in H3.
assert (0 = q*D - binomial n k*D) by (rewrite H3; auto with arith).
assert (0 = (q - binomial n k)*D) by (rewrite H7; auto with arith).
case_eq (q - binomial n k); intros.
omega.
assert (0 * D < S n0 * D).
 apply mult_lt_compat_r; auto with arith.
rewrite <- H9 in H10; rewrite <- H8 in H10; simpl in H10; inversion H10.
assert (1 * D <= S n0 * D).
 apply mult_le_compat; auto with arith.
rewrite <- H6 in H7.
simpl in H7; rewrite plus_comm in H7; simpl in H7.
omega.
Qed.

Module PowerSet (M:S).

(* M is our base sets structure. *)
(* MM is a "sets of sets" structure: *)
Module MM := FSetList.Make M.
(* Adding a map function to MM... *)
Module MM' := MapFunction.MapFunction MM.
(* Properties functors *)
Module P := FSetProperties.Properties M.
Module P' := FSetProperties.OrdProperties M.
Module F := P.FM.
Module PEP := FSetEqProperties.EqProperties MM.
Module PP := PEP.MP.
Module FF := PP.FM.
Module ME := OrderedTypeFacts M.E.

Infix "[=]" := M.Equal (at level 70, no associativity).
Infix "[==]" := MM.Equal (at level 70, no associativity).

(** Computing the set of all subsets of a particular set [s] *)

Definition powerset s :=
  M.fold
   (fun (x:M.elt)(ss:MM.t) => MM.union ss (MM'.map (M.add x) ss))
   s
   (MM.singleton M.empty).

(** Proofs about powerset *)

Lemma map_add : forall s s' x, MM.In s' (MM'.map (M.add x) s)
 <-> M.In x s' /\ (MM.In s' s \/ MM.In (M.remove x s') s).
Proof.
intros.
rewrite MM'.map_In by (intros; rewrite H; reflexivity).
unfold M.eq in *.
split; [intros (b & IN & EQ) | intros (IN,[OR1|OR2]) ].
assert (M.In x s') by (rewrite <- EQ; auto with set).
split; auto.
destruct (P.In_dec x b); [left|right];
 apply MM.In_1 with (2:=IN); P.Dec.fsetdec.
 (* sans le P.Dec.fsetdec :
     rewrite <- IN; red; intro a; F.set_iff; intuition.
     eauto with set. ----> anomaly *)

exists s'; split; auto; P.Dec.fsetdec.
exists (M.remove x s'); split; auto; P.Dec.fsetdec.
Qed.

Lemma compat_op_pow :
 compat_op M.E.eq MM.Equal
  (fun x0 ss => MM.union ss (MM'.map (M.add x0) ss)).
Proof.
repeat red; intros; FF.set_iff.
do 2 rewrite map_add; rewrite H; rewrite H0; intuition.
Qed.
Hint Resolve compat_op_pow : set.

Lemma singleton_empty : forall s, MM.In s (MM.singleton M.empty) <-> M.Empty s.
Proof.
intros.
rewrite FF.singleton_iff; split; unfold M.eq; auto with set.
Qed.

Lemma powerset_base : forall s, M.Empty s -> powerset s [==] MM.singleton M.empty.
Proof.
intros; unfold powerset.
rewrite (@P.fold_1 s MM.t MM.Equal FF.Equal_ST); auto with set.
Qed.

Lemma powerset_step : forall s1 s2 x, P'.Above x s1 -> P.Add x s1 s2 ->
 powerset s2 [==] MM.union (powerset s1) (MM'.map (M.add x) (powerset s1)).
Proof.
intros; unfold powerset.
rewrite (@P'.fold_3 s1 s2 x MM.t MM.Equal FF.Equal_ST); auto with set.
Qed.

Lemma powerset_is_powerset:
 forall s s', MM.In s' (powerset s) <-> M.Subset s' s.
Proof.
induction s using P'.set_induction_max; intros.

rewrite (powerset_base H).
rewrite singleton_empty; firstorder.

rewrite (powerset_step H H0).
FF.set_iff.
rewrite map_add.
do 2 rewrite IHs1; clear IHs1.
split; [intros [U|[U [V|V]]]|intros U].
firstorder.
firstorder.
red; intro a; generalize (H a)(H0 a); F.set_iff; destruct (F.eq_dec a x); intuition.
(*eauto with set. (* Anomaly: uncaught exception Failure "Cannot print a global reference". *)*)
apply H6; apply V; auto with set.
destruct (P.In_dec x s'); [right|left].
split; auto.
right.
red; intro a; generalize (U a)(H0 a); F.set_iff; intuition.
red; intro a; generalize (U a)(H0 a); intuition.
elim n; rewrite H4; auto.
Qed.

Lemma powerset_cardinal:
 forall s, MM.cardinal (powerset s) = two_power (M.cardinal s).
Proof.
induction s using P'.set_induction_max; intros.

rewrite (powerset_base H).
rewrite PP.singleton_cardinal.
rewrite P.cardinal_1; simpl; auto.

rewrite (powerset_step H H0).
rewrite PP.union_cardinal.
rewrite MM'.map_cardinal.
rewrite IHs1.
rewrite (@P.cardinal_2 s1 s2 x); auto.
simpl; auto.
red; intros.
elim (@M.E.lt_not_eq x x); auto.
intros; rewrite H1; reflexivity.
intros u v; do 2 rewrite powerset_is_powerset.
red; red; intros.
generalize (H3 a) (H1 a) (H2 a); F.set_iff; clear H3 H1 H2.
intuition; elim (@M.E.lt_not_eq a x); auto.
intros u (A,B).
rewrite powerset_is_powerset in A.
rewrite map_add in B; destruct B as (B,_).
elim (@M.E.lt_not_eq x x); auto.
Qed.

(** Computing the set of all subsets of cardinal k for a particular set [s] *)

Definition powerset_k s k :=
 MM.filter (fun s => beq_nat (M.cardinal s) k) (powerset s).

(** Proofs about powerset_k *)

Lemma powerset_k_is_powerset_k : forall k s s',
 MM.In s' (powerset_k s k) <-> M.Subset s' s /\ M.cardinal s' = k.
Proof.
unfold powerset_k; intros.
rewrite FF.filter_iff by (red; intros; f_equal; auto).
rewrite powerset_is_powerset.
intuition.
apply beq_nat_eq; auto.
subst; symmetry; apply beq_nat_refl.
Qed.

Lemma powerset_k_cardinal : forall s k,
 MM.cardinal (powerset_k s k) = binomial (M.cardinal s) k.
Proof.
assert (forall k, compat_bool M.Equal (fun s0 => beq_nat (M.cardinal s0) k)).
 red; intros; f_equal; auto.
induction s using P'.set_induction_max; unfold powerset_k; intros.

rewrite P.cardinal_1; auto.
destruct k.
rewrite <- (@PP.Equal_cardinal (MM.singleton M.empty)).
 apply PP.singleton_cardinal.
 red; intros.
 rewrite FF.filter_iff; auto.
 rewrite powerset_base; auto.
 rewrite singleton_empty.
 intuition.
 rewrite P.cardinal_1; auto.
rewrite <- (@PP.Equal_cardinal MM.empty).
 apply PP.cardinal_1; auto.
 red; intros.
 rewrite FF.empty_iff; rewrite FF.filter_iff; auto.
 rewrite powerset_base; auto.
 rewrite singleton_empty.
 intuition.
 rewrite (P.cardinal_1 H2) in H3; simpl in H3; discriminate.

assert (H2 := powerset_step H0 H1).
rewrite (FF.filter_equal (H k) H2).
rewrite PEP.filter_union; auto.
rewrite PP.union_cardinal; auto.
unfold powerset_k in IHs1.
rewrite IHs1.
rewrite MM'.map_filter by (auto; intros; rewrite H3; reflexivity).
rewrite MM'.map_cardinal.
destruct k.
rewrite PP.cardinal_1.
destruct (M.cardinal s1); destruct (M.cardinal s2); auto.
red; intro a; rewrite FF.filter_iff.
red; destruct 1.
case_eq (M.cardinal (M.add x a)); intros.
elim (@P.cardinal_inv_1 _ H5 x); F.set_iff; auto.
rewrite H5 in H4; simpl in H4; inversion H4.
repeat red; intros; f_equal; rewrite H3; auto.
assert (MM.filter (fun x0 => beq_nat (M.cardinal (M.add x x0)) (S k)) (powerset s1)
   [==] MM.filter (fun x0 => beq_nat (M.cardinal x0) k) (powerset s1)).
red; intros.
rewrite FF.filter_iff by (repeat red; intros; f_equal; rewrite H3; auto).
rewrite FF.filter_iff by (repeat red; intros; f_equal; rewrite H3; auto).
rewrite powerset_is_powerset.
intuition.
assert (~M.In x a).
 red; intros; elim (@ME.lt_antirefl x); auto.
rewrite P.add_cardinal_2 in H5; simpl in H5; auto.
assert (~M.In x a).
 red; intros. elim (@ME.lt_antirefl x); auto.
rewrite P.add_cardinal_2; simpl; auto.
rewrite H3.
rewrite IHs1.
rewrite (@P.cardinal_2 s1 s2 x); auto.
simpl; auto with arith.
red; intros; elim (@ME.lt_antirefl x); auto.

intros; rewrite H3; reflexivity.

intros.
rewrite FF.filter_iff in H3.
destruct H3.
rewrite FF.filter_iff in H4.
destruct H4.
rewrite powerset_is_powerset in H3.
rewrite powerset_is_powerset in H4.
assert (~M.In x x0).
 red; intros; elim (@ME.lt_antirefl x); auto.
assert (~M.In x y).
 red; intros; elim (@ME.lt_antirefl x); auto.
red; red; intros.
generalize (H5 a); clear H5; do 2 rewrite F.add_iff.
intuition.
elim H8; apply M.In_1 with a; auto.
elim H8; apply M.In_1 with a; auto.
elim H9; apply M.In_1 with a; auto.
elim H9; apply M.In_1 with a; auto.
repeat red; intros; f_equal; rewrite H7; auto.
repeat red; intros; f_equal; rewrite H6; auto.

intros.
rewrite !FF.filter_iff by (red; intros; subst; auto).
rewrite map_add.
rewrite !powerset_is_powerset.
intros ((A,_),((B,_),_)).
elim (@ME.lt_antirefl x); auto.
Qed.

(** A more "direct" definition *)

Definition powerset_k' s :=
  M.fold
  (fun (x:M.elt)(ff:nat->MM.t)(k:nat) => match k with
    | O => ff 0
    | S k' => MM.union (ff k) (MM'.map (M.add x) (ff k'))
   end)
  s
  (fun k => if k then MM.singleton M.empty else MM.empty).

Lemma powerset_k'_is_powerset_k :
 forall s s' k, MM.In s' (powerset_k' s k) <-> M.Subset s' s /\ M.cardinal s' = k.
Proof.
assert (ST : Setoid_Theory _ (fun g h => forall k:nat, g k [==] h k)).
 constructor; red; auto with set.
 intros; apply PP.equal_trans with (y k); auto with set.

induction s using P'.set_induction_max; intros.

intros; unfold powerset_k'.
assert (T:=P.fold_1 ST (s:=s)).
simpl in T; rewrite T; clear T; auto.

destruct k.
rewrite singleton_empty.
intuition idtac.
firstorder.
intuition.
intuition.
rewrite FF.empty_iff.
intuition.
rewrite P.cardinal_1 in H2; try discriminate; firstorder.

intros; unfold powerset_k'.
assert (T:=P'.fold_3 ST (s:=s1) (s':=s2) (x:=x)).
simpl in T; rewrite T; clear T; auto.

change (MM.In s' (match k with
         | O => powerset_k' s1 0
         | S k' => MM.union (powerset_k' s1 k) (MM'.map (M.add x) (powerset_k' s1 k'))
         end) <-> M.Subset s' s2 /\ M.cardinal s' = k).
destruct k.
rewrite IHs1.
intuition idtac.
red; intros.
elim (P.cardinal_inv_1 H3 H1).
red; intros.
elim (P.cardinal_inv_1 H3 H1).
FF.set_iff.
rewrite map_add.
do 3 rewrite IHs1; clear IHs1.
split; destruct 1.
destruct H1; split; auto.
apply P.subset_trans with s1; auto; red; intros; rewrite (H0 a); auto.
destruct H1.
destruct H2; intuition idtac.
firstorder.
elim (@M.E.lt_not_eq x x); auto.
red; intro a; generalize (H3 a)(H0 a); F.set_iff; destruct (F.eq_dec a x); intuition.
rewrite <- H4.
symmetry; apply P.remove_cardinal_1; auto.
destruct (P.In_dec x s').
right.
 split; auto.
 right; split.
 red; intro a; generalize (H1 a)(H0 a); F.set_iff; intuition.
 generalize (P.remove_cardinal_1 i); auto.
 rewrite H2; inversion 1; auto.
left.
 split; auto.
 red; intro a; generalize (H1 a)(H0 a); intuition.
 elim n; rewrite H6; auto.

unfold compat_op, Proper, respectful; intros.
destruct k0; auto.
red; intros; FF.set_iff.
rewrite !map_add, !H2, H1; split; auto.
Qed.

Lemma powerset_k_alt :
 forall s k, powerset_k' s k [==] powerset_k s k.
Proof.
red; intros.
rewrite powerset_k'_is_powerset_k.
rewrite powerset_k_is_powerset_k.
split; auto.
Qed.

End PowerSet.

(** An example: *)

Open Scope positive_scope.

Module P := FSetList.Make Positive_as_OT.
Module PS := PowerSet P.
Module PP := PS.MM.

(* The set containing numbers 1..n *)
Fixpoint interval (n:nat) {struct n} : P.t := match n with
 | O => P.empty
 | S n => P.add (P_of_succ_nat n) (interval n)
 end.

Eval vm_compute in P.elements (interval 10).

Definition powerset_5 := PS.powerset (interval 5).

Eval vm_compute in map P.elements (PP.elements powerset_5).

Definition subsets_size2_in5 := PS.powerset_k' (interval 5) 2.

Eval vm_compute in map P.elements (PP.elements subsets_size2_in5).


(* sem0.v *)

(**** Expressions ****)

(* Integer expressions *)

Require Export ZArith.
Open Scope Z.

Inductive expr : Set :=
| Cte : Z -> expr
| Plus : expr -> expr -> expr
| Moins : expr -> expr -> expr
| Mult : expr -> expr -> expr
| Div : expr -> expr -> expr.

Inductive eval : expr -> Z -> Prop :=
| ECte : forall c : Z , eval (Cte c) c
| EPlus : forall (e1 e2 : expr ) (v1 v2 v : Z),
  eval e1 v1 -> eval e2 v2 -> v = v1 + v2 -> eval (Plus e1 e2) v
| EMoins : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval e1 v1 -> eval e2 v2 -> v = v1 - v2 -> eval (Moins e1 e2) v
| EMult : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval e1 v1 -> eval e2 v2 -> v = v1 * v2 -> eval (Mult e1 e2) v
| EDiv : forall (e1 e2 : expr) (v1 v2 v : Z),
  eval e1 v1 -> eval e2 v2 -> v = v1 / v2 -> eval (Div e1 e2) v.

Lemma eval0 : eval (Plus (Cte 1) (Cte 1)) 2.
Proof.
  eapply EPlus.
  apply ECte.
  apply ECte.
  auto.
Qed.

Lemma eval1 : eval (Mult (Plus (Cte 4) (Cte 2)) (Moins (Cte 9) (Cte 2))) 42.
Proof.
  eapply EMult.
  eapply EPlus.
  apply ECte.
  apply ECte.
  auto.
  eapply EMoins.
  apply ECte.
  apply ECte.
  auto.
  auto.
Save.

Ltac apply_eval :=
  repeat
    eapply EPlus || eapply EMoins || eapply EMult || eapply EDiv ||
    apply ECte || auto.

Lemma eval0b : eval (Plus (Cte 1) (Cte 1)) 2.
Proof.
  apply_eval.
Save.

Lemma eval1b :
  eval (Mult (Plus (Cte 4) (Cte 2)) (Moins (Cte 9) (Cte 2))) 42.
Proof.
  apply_eval.
Save.

Fixpoint f_eval (e : expr) : Z :=
  match e with
  | Cte c => c
  | Plus e1 e2 =>
    let v1 := f_eval e1 in
    let v2 := f_eval e2 in
    v1 + v2
  | Moins e1 e2 =>
    let v1 := f_eval e1 in
    let v2 := f_eval e2 in
    v1 - v2
  | Mult e1 e2 =>
    let v1 := f_eval e1 in
    let v2 := f_eval e2 in
    v1 * v2
  | Div e1 e2 =>
    let v1 := f_eval e1 in
    let v2 := f_eval e2 in
    v1 / v2
  end.

Lemma eval0t : f_eval (Plus (Cte 1) (Cte 1)) = 2.
Proof.
  simpl; reflexivity.
Save.

Lemma eval1t :
  f_eval (Mult (Plus (Cte 4) (Cte 2)) (Moins (Cte 9) (Cte 2))) = 42.
Proof.
  simpl; reflexivity.
Save.

Functional Scheme f_eval_ind := Induction for f_eval Sort Prop.

Theorem f_eval_sound :
  forall (e : expr) (v : Z), (f_eval e) = v -> eval e v.
Proof.
  intro; functional induction (f_eval e) using f_eval_ind; intros.
  rewrite H; apply ECte.
  apply EPlus with (v1 := (f_eval e1)) (v2 := (f_eval e2));
    [ apply (IHz (f_eval e1)); auto | apply (IHz0 (f_eval e2)); auto | auto ].
  apply EMoins with (v1 := (f_eval e1)) (v2 := (f_eval e2));
    [ apply (IHz (f_eval e1)); auto | apply (IHz0 (f_eval e2)); auto | auto ].
  apply EMult with (v1 := (f_eval e1)) (v2 := (f_eval e2));
    [ apply (IHz (f_eval e1)); auto | apply (IHz0 (f_eval e2)); auto | auto ].
  apply EDiv with (v1 := (f_eval e1)) (v2 := (f_eval e2));
    [ apply (IHz (f_eval e1)); auto | apply (IHz0 (f_eval e2)); auto | auto ].
Save.


(* -- DISCLAIMER: definitions in this file remain to be renamed,
      e.g. mmin and mmax. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Minimum/Maximum w.r.t. an order relation                                *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibReflect LibOperation
  LibRelation LibOrder LibEpsilon.
Generalizable Variables A.

(* This module offers the functions [mmin] and [mmax] which produce
   the minimum and maximum elements of a non-empty, bounded set. *)

(**************************************************************************)
(* * Lower bound and minimum*)

(* [lower_bound le P x] means that [x] is a lower bound for the
   set [P] with respect to the ordering [le]. *)

Definition lower_bound A (le:binary A) (P:A->Prop) (x:A) :=
  forall y, P y -> le x y.

(* [min_element le P x] means that [x] is a minimal element of
   [P], i.e., it is both a member of [P] and a lower bound for
   [P]. *)

Definition min_element A (le:binary A) (P:A->Prop) (x:A) :=
  P x /\ lower_bound le P x.

(* [mmin le P] is a minimal element of [P] with respect to [le],
   when such an element exists. *)

Definition mmin `{Inhab A} (le:binary A) (P:A->Prop) :=
  epsilon (min_element le P).

(**************************************************************************)
(* * Upper bound and maximum *)

(* [upper_bound le P x] means that [x] is a lower bound for the
   set [P] with respect to the ordering [le]. *)

Definition upper_bound A (le:binary A) (P:A->Prop) (x:A) :=
  forall y, P y -> le y x.

(* [max_element le P x] means that [x] is a maximal element of
   [P], i.e., it is both a member of [P] and a lower bound for
   [P]. *)

Definition max_element A (le:binary A) (P:A->Prop) (x:A) :=
  P x /\ upper_bound le P x.

(* [mmax le P] is a minimal element of [P] with respect to [le],
   when such an element exists. *)

Definition mmax `{Inhab A} (le:binary A) (P:A->Prop) :=
  epsilon (max_element le P).

(**************************************************************************)
(* * Least upper bound and greatest lower bound *)

(* [lub le P x] means that [x] is a least upper bound
   for the set [P] with respect to the ordering [le]. *)

Definition lub A (le:binary A) (P:A->Prop) (x:A) :=
  min_element le (upper_bound le P) x.

(* [glb le P x] means that [x] is a greatest lower bound
   for the set [P] with respect to the ordering [le]. *)

Definition glb A (le:binary A) (P:A->Prop) (x:A) :=
  max_element le (lower_bound le P) x.

(**************************************************************************)
(* * Connexion between lower and bounds *)

Lemma upper_bound_inverse : forall A (le:binary A),
  upper_bound le = lower_bound (inverse le).
Proof using.
  extens. intros P x. unfolds lower_bound, upper_bound. iff*.
Qed.

Lemma max_element_inverse : forall A (le:binary A) (P:A->Prop) (x:A),
  max_element le P x = min_element (inverse le) P x.
Proof using.
  extens. unfold max_element, min_element. rewrite* upper_bound_inverse.
Qed.

Lemma mmax_inverse : forall `{Inhab A} (le:binary A) (P:A->Prop),
  mmax le P = mmin (inverse le) P.
Proof using.
  intros. applys epsilon_eq. intros x. rewrite* max_element_inverse.
Qed.

(**************************************************************************)
(* * Elimination roperties *)

(* [bounded_has_minimal le] means that, at type [A], it is
   the case that every non-empty set that admits a lower
   bound has a minimal element. *)

Definition bounded_has_minimal A (le:binary A) :=
  (* Recall that [ex P] means that [P] has an inhabitant; i.e.,
     it is equivalent to [exists x, P x]. *)
  forall P,
  ex P ->
  ex (lower_bound le P) ->
  ex (min_element le P).

(* If the set [P] is non-empty and admits a lower bound, and if the type
   [A] is such that every such set has a minimal element, then [P] has a
   minimal element, and this element is [mmin le P]. *)

Lemma mmin_spec : forall `{Inhab A} (le:binary A) (P:A->Prop) m,
  m = mmin le P ->
  ex P ->
  ex (lower_bound le P) ->
  bounded_has_minimal le ->
  min_element le P m.
Proof using.
  intros. subst. unfold mmin. epsilon* m.
Qed.

(**************************************************************************)
(* * Application to [nat] *)

From TLC Require Import LibNat.

(* The type [nat] enjoys this property. *)

Lemma increment_lower_bound_nat : forall (P : nat->Prop) x,
  lower_bound le P x ->
  ~ P x ->
  lower_bound le P (x + 1)%nat.
Proof using.
  introv hlo ?. intros y ?.
  destruct (eq_nat_dec x y).
    { subst. tauto. }
    { forwards: hlo; eauto. nat_math. }
Qed.

Lemma bounded_has_minimal_nat :
  @bounded_has_minimal nat le.
Proof using.
  (* Assume a set [P], such that [y] is an inhabitant of [P]
     and [x] is a lower bound for [P]. *)
  intros P [ y ? ].
  (* We reason by induction on the difference [y + 1 - x].
     Reasoning with [y - x] would work too, but this choice
     is more elegant, as it makes the base case a contradiction,
     and avoids a little duplication. *)
  cut (
    forall (k x : nat), (y + 1 - x)%nat = k ->
    lower_bound le P x ->
    exists z, min_element le P z
  ). { intros ? [ x ? ]. eauto. }
  induction k; introv ? hlo.
  (* Base. *)
  (* Our hypotheses imply that [x] must be less than or equal to
     [y]. Because in this case the difference [y + 1 - x] is zero,
     this leads to a contradiction. *)
  { false. forwards: hlo; eauto. nat_math. }
  (* Step. *)
  (* Eeither [P x] holds, or it does not. If it does, then [x]
     is the desired minimal element. If it does not, this implies
     that [x + 1] is a lower bound for [P], and the induction
     hypothesis can be used. *)
  destruct (prop_inv (P x)).
    { exists x. split; eauto. }
    { eapply (IHk (x + 1)%nat). nat_math. eauto using increment_lower_bound_nat. }
Qed.

Hint Resolve bounded_has_minimal_nat : bounded_has_minimal.

(* Furthermore, at type [nat], every set admits a lower bound. *)

Lemma admits_lower_bound_nat : forall (P : nat->Prop),
  ex (lower_bound le P).
Proof using.
  exists 0%nat. unfold lower_bound. nat_math.
Qed.

Hint Resolve admits_lower_bound_nat : admits_lower_bound.

(* At type [nat], every non-empty set that admits an upper bound
   has a maximal element. *)

Lemma bounded_has_maximal_nat :
  @bounded_has_minimal nat (inverse le).
Proof using.
  (* Assume a set [P], such that [y] is an inhabitant of [P]
     and [x] is an upper bound for [P]. *)
  intros P [ y ? ] [ x h ].
  assert (y <= x).
    { forwards: h. eauto. eauto. }
  (* We apply our previous result to the image of [P] through
     the function that maps [i] to [x - i]. (We note that this
     function is its own inverse.) This yields a minimal
     element [z] of this image. Thus, [x - z] is the desired
     maximal element of [P]. *)
  assert (self_inverse: forall i, i <= x -> (x - (x - i))%nat = i).
    intros. nat_math.
  forwards [ z [ ? hz ]]: (@bounded_has_minimal_nat (fun i => P (x - i)%nat)).
    { exists (x - y)%nat. rewrite self_inverse by eauto. eauto. }
    { eauto using admits_lower_bound_nat. }
  exists (x - z)%nat.
  clear dependent y.
  split; [ assumption | ].
  intros y ?.
  assert (y <= x).
    { forwards: h. eauto. eauto. }
  forwards: hz (x - y)%nat.
    { rewrite self_inverse by eauto. eauto. }
  unfold inverse. nat_math.
Qed.

Hint Resolve bounded_has_maximal_nat : bounded_has_minimal.

Lemma mmin_spec_nat:
  forall (P:nat->Prop) m,
  m = mmin le P ->
  ex P ->
  P m /\ (forall x, P x -> m <= x).
Proof using.
  introv E Q. applys (@mmin_spec _ _ _ P m E Q).
  applys admits_lower_bound_nat.
  applys bounded_has_minimal_nat.
Qed.

(**************************************************************************)
(* * Typeclasses *)

(* [MMin P] is [mmin le P], in a context where the desired
   ordering can be inferred. *)

Definition MMin `{Inhab A} `{Le A} := mmin le.

(* [MMax P] is [mmax le P], in a context where the desired
   ordering can be inferred. *)

Definition MMax `{Inhab A} `{Le A} := mmax le.


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.

Compute (next_weekday monday).

(** assertion *)
Example test_next_weekday :
  (next_weekday (next_weekday monday)) = tuesday. Admitted.

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

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

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

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

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

Example test_orb2 : (orb true true) = true.
Proof. simpl. reflexivity. Qed.

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

Example test_orb4 : (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5 : false || false || true = true.
Proof. simpl. reflexivity. Qed.

Check true.

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.

Inductive color : Type :=
  | black : color
  | white : color
  | primary : rgb->color.

Definition monochrome (c:color) : bool :=
  match c with
  | black => true
  | white => true
  | primary red => true
  | primary _ => false
  end.

Compute (monochrome (primary red)).

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

Definition pred (x : nat) : nat :=
  match x with
  |O => O
  |S x' => x'
  end.
End test_nat.

Compute (S (S (S O))).
Check (S (S(S(S(S O))))).

Fixpoint evenb (x:nat) : bool :=
  match x with
  | O => true
  | S n => negb (evenb n)
  end.
Definition oddb (x:nat):bool := negb (evenb x).

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_oddb2: oddb 100 = false.
Proof. simpl. reflexivity. Qed.

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

Compute (plus 2 3).

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

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

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

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

Notation "x + y" := (plus x y).

Fixpoint beq_nat (x y:nat):bool :=
  match x with
  | 0 => match y with
         | 0 => true
         | _ => false
         end
  | S x' => match y with
         | 0 => false
         | S y' => beq_nat x' y'
         end
  end.

Fixpoint leb (x y:nat) : bool :=
  match x with
  | 0 => true
  | S x' => match y with
            | 0 => false
            | S y' => leb x' y'
            end
  end.

Example test_leb1 : (leb 2 2) = true.
Proof. simpl. reflexivity. Qed.

Example test_leb2 : (leb 2 4) = true.
Proof. simpl. reflexivity. Qed.

Example test_leb3 : (leb 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

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

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

Theorem plus_id_example : forall n m:nat,
  n = m -> n+n = m+m.
Proof.
  intros n m.
  intros H.
  rewrite <- H.
  reflexivity.
Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.

   rewrite -> plus_1_l.
   rewrite -> H.
(*   rewrite -> H. *)
(*   rewrite plus_1_l. *)

  simpl.
  reflexivity.
Qed.

Theorem plus_1_neq_0 : forall n:nat,
  beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  destruct n as [| n'].
  - reflexivity.
  - simpl. reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem add_commutative : forall b c ,
  andb b c = andb c b.
Proof.
  intros b c.
  destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.


(** * Tutoriel 1 - Prouver avec Coq : Logique propositionnelle *)

Require Import Bool.

(** ** I. Un premier exemple *)

(** Souvenez-vous de cet exposé sur Coq (et sur K) !
    Je vous avais expliqué cette preuve : *)

Lemma andb_prop : forall b1 b2,
  andb b1 b2 = true -> b1 = true /\ b2 = true.
Proof.
  intros b1 b2 H.
  (* introduit les hypothèses *)
  split. (* sépare le but en deux sous-buts *)
  - destruct b1. (* raisonnement par cas *)
    + reflexivity. (* true = true *)
    + simpl in H. exact H. (* ce que l'on veut montrer est une hypothèse *)
  - destruct b2. (* raisonnement par cas *)
    + reflexivity. (* true = true *)
    + destruct b1.  (* raisonnement par cas *)
      * simpl in H. exact H. (* ce que l'on veut montrer est une hypothèse *)
      * simpl in H. exact H. (* ce que l'on veut montrer est une hypothèse *)
Qed.

(** Cette preuve montre l'utilisation de plusieurs tactiques que nous
    allons expliquer plus précisément au fur et à mesure des feuilles
    d'exercices.

    Notez déjà l'utilisation massive des bullets [+] afin d'identifier
    les points de branchement dans une preuve.
    Les autres bullets possibles sont [*], [-], [**], [+++], etc.
    Si une bullet est utilisée pour un sous-but, cette même bullet doit être
    utilisée pour tous les autres sous-buts du même niveau.
    Il est également possible d'utiliser les accolades pour délimiter un but. *)

(** Dans cette feuille d'exercices, nous nous intéressons uniquement à des
    énoncés exprimables dans la logique propositionnelle.
    Vous n'avez donc besoin que des tactiques suivantes :
     - intro / intros : introduction de l'implication ->
     - apply H : pour utiliser un énoncé, une hypothèse
     - exact H / assumption : la règle nommée "axiome"
     - left et right : pour l'introduction de la disjonction \/
     - split : pour l'introduction de la conjonction /\
     - destruct H : pour l'élimination de la conjonction /\, la disjonction \/,
                    de [False]
     - unfold d in H : pour dérouler une définition [d] dans une hypothèse [H].
*)

(** Dans Coq, le type des propositions est [Prop].
    Nous déclarons trois objets arbitraires de ce type. *)

Variable P : Prop.
Variable Q : Prop.
Variable R : Prop.

(** La requête [Check] peut être utilisée pour vérifier que les expressions ont
    un sens, mais aussi de voir leur type.
    Les requêtes suivantes montrent les notations Coq pour la disjonction (\/),
    la conjonction (/\) et l'implication (->). *)

Check True.
Check P \/ Q.
Check False /\ P.
Check P -> Q -> R.

(** ** II. Commutativité de la conjonction.

    Ici, nous déclarons un objectif sans nom, et nous le prouvons.
    Une preuve est une succession de tactiques, chaque tactique réduisant le
    premier sous-but à une nouvelle liste (éventuellement vide) de sous-buts. *)

Goal P /\ Q -> Q /\ P.
Proof.
  intro H.
  destruct H.
  split.
   + exact H0.
   + exact H.
Qed.

(** ** III. Commutativité de la disjonction. *)

Goal P \/ Q -> Q \/ P.
Proof.
  intro H.
  destruct H.
   + right. exact H.
   + left.  exact H.
Qed.

(** ** IV. Distributivité *)

(** *** Exercice 1 - A vous de jouer ! *)

Goal P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R).
Proof.
  intro H.
  destruct H.
  destruct H0.
  +left. split. exact H. exact H0.
  +right. split. exact H. exact H0.
Qed.

Goal (P /\ Q) \/ (P /\ R) -> P /\ (Q \/ R).
Proof.
 intro H. destruct H.
  +split. destruct H. exact H. destruct H. left. exact H0.
  +split. destruct H. exact H. destruct H. right. exact H0.
Qed.

(** ** V. Une forme de commutativité pour l'implication.

    A noter ici :
      - l'associativité de l'implication
      - la variante [intros] de [intro]. *)

Goal (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros H HQ HP.
  apply H.
   + exact HP.
   + exact HQ.
Qed.

(** ** VI. Hypothèses multiples

    Prouvez l'équivalence suivante, en gardant à l'esprit que
    [P <-> Q] est une notation pour [(P -> Q) /\ (Q -> P)].
    Vous pouvez le vérifier en utilisant la tactique [unfold iff]. *)

(** *** Exercice 2 - A vous de jouer ! *)

Goal (P -> Q -> R) <-> (P /\ Q -> R).
Proof.
  split.
  +intros H HQ. apply H. destruct HQ. exact H0. destruct HQ. exact H1.
  +intros H HP HQ. apply H. split. exact HP. exact HQ.
Qed.

(** Note : En Coq, on écrit généralement [P -> Q -> R] plutôt que [P /\ Q -> R],
    puisque la première forme est plus facile à travailler en utilisant les
    tactiques fournies. *)

(** ** VII. Négation

    La négation [~ P] est une notation pour [P -> False]. *)

Goal P -> ~ ~ P.
Proof.
  intros H Hn.
  unfold not in Hn.
  apply Hn.
  exact H.
Qed.

(** *** Exercice 3 - A vous de jouer ! *)

Goal (~P /\ ~Q) -> ~(P \/ Q).
Proof.
intros H Hn. destruct H. unfold not in H. unfold not in H0. destruct Hn.
  +apply H. exact H1.
  +apply H0. exact H1.
Qed.

Lemma not_or : forall (P Q : Prop), ~(P \/ Q) -> (~P /\ ~Q).
Proof.
  intros P Q H. split.
    + unfold not in H. intro Hn. destruct H. left. exact Hn.
    + unfold not in H. intro Hn. destruct H. right. exact Hn.
Qed.

Goal (~P \/ ~Q) -> ~(P /\ Q).
Proof.
intros H Hn. destruct H.
  + unfold not in H. destruct Hn. apply H. exact H0.
  + unfold not in H. destruct Hn. apply H. exact H1.
Qed.

(** *** Exercice 4 - Avec le modus ponens *)

(** Note : Les quantifications [forall P : Prop] sont
           des quantifications d'ordre supérieur.
           Nous quittons donc la logique propositionnelle. *)

Lemma modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
intros P Q H0 H1. apply H1. exact H0.
Qed.

(** Démontrer à nouveau l'énoncé suivant, mais cette fois en utilisant
    [modus_ponens]. *)
Lemma impl_not : forall P : Prop, P -> ~ ~ P.
Proof.
intro P. unfold not. apply modus_ponens.
Qed.

(** Démontrer l'énoncé suivant à partir de [impl_not]. *)
Lemma P_notP_contradiction : forall P : Prop, ~ (P /\ ~ P).
Proof.
intro P. unfold not. intro Hn. destruct Hn. apply H0. exact H.
Qed.

Lemma not_and : forall P Q : Prop, P \/ Q -> ~(~ P /\ ~Q).
Proof.
intros P Q. intro H. unfold not. intro Hn. destruct Hn. destruct H.
  + apply H0. exact H.
  + apply H1. exact H.
Qed.

(** ** VIII.  Raisonnement classique

    Coq implémente une logique constructive.
    Cela veut dire que la logique interne de Coq n'a pas l'axiome du tiers exclu,
    ou un équivalent. Il n'est également pas possible de prouver le tiers exclu.
    Nous verrons les conséquences de ce choix plus tard. *)

(** *** Exercice 5 - Tiers exclu avec Coq *)

(** Pour le raisonnement classique, il faut donc déclarer un axiome.
    Note : [RAA] signifie pour Reductio Ad Absurdum.

    Ces objectifs de preuve sont un peu plus difficiles. *)

Axiom RAA : forall A:Prop, ~~A -> A.

Goal ~(P /\ Q) -> (~P \/ ~Q).
Proof.
intro H. apply RAA. intro Hn. apply not_or in Hn. destruct Hn. apply RAA in H0. apply RAA in H1.
apply H. split. exact H0. exact H1.
Qed.

(** [LEM] pour Law of Excluded Middle. *)
Lemma LEM : P \/ ~P.
Proof.
apply RAA. intro H. apply not_or in H. apply H. destruct H. exact H.
Qed.

Goal (P -> Q) \/ (Q -> P).
Proof.
apply RAA. intro H. apply not_or in H. destruct H.
apply H. intro P. apply RAA. intro nQ.
apply H0. intro Q. apply RAA. intro nP. apply nP. exact P.
Qed.

(** Merci à David Baelde et Catherine Dubois. *)


Require Import magma.
Require Import ZArith.
Require Import Coq.Arith.Mult.

Generalizable Variables A o.

Class semigroup (A : Type) `{M : magma A o} : Prop := {
  dot_assoc : forall x y z,
                o x (o y z) = o (o x y) z
}.

Instance list_concat_semigroup {A : Type} : semigroup (list A).
Proof.
  split.
  intros.
  induction x.
  reflexivity.
  simpl.
  rewrite IHx.
  reflexivity.
Qed.

Instance nat_mult_semigroup : semigroup nat.
Proof.
  split.
  intros.
  induction x.
  reflexivity.
  simpl.
  rewrite IHx.
  rewrite mult_plus_distr_r.
  reflexivity.
Qed.

Instance z_add_semigroup : semigroup Z.
Proof.
  split.
  apply Zplus_assoc.
Qed.


Require Import Expression.
Require Import Util.
(**
Definition. The set [K] of lambda-kinds is defined
inductively as follows:

- [kappa] is in [K]
- If [x] is a variable and [A] is in [E] (i.e.,
  [A] is a lambda-expression) and [B] is in [K],
  then [KLam x:A.B] is in [K].
*)
Inductive kind : Type :=
 | kappa : kind                (* kind constant *)
 | KLam : exp -> kind -> kind. (* lambda kind *)

(**
Theorem. If [k] is a Lambda-Kind, then either
[k = kappa] or [k = KLam t k'] where [t] is some [exp]
and [k'] is another Lambda-Kind.

(As a consequence, it makes sense to talk about the
"length" of a [kind] by counting the number of [KLam]
constants that appear.)
*)
Theorem canonical_form_of_kinds :
 forall k : kind, k = kappa \/ (exists (t : exp) (k' : kind), k = KLam t k').
Proof.
  intuition.
  induction k.
  (* Case: k = kappa *)
  - left. reflexivity.
  (* Case: k = KLam e k *)
  - right. eauto .
Qed.


Require Import Coq.Arith.Lt.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Fixpoint len (l : lst) : nat :=
    match l with
    | Nil => 0
    | Cons x y => 1 + len y
    end.

Fixpoint append (l1 : lst) (l2 : lst) : lst :=
  match l1 with
  | Nil => l2
  | Cons x y => Cons x (append y l2)
  end.

Fixpoint rev (l1 : lst) : lst :=
    match l1 with
    | Nil => Nil
    | Cons x y => append (rev y) (Cons x Nil)
    end.

Theorem consLT : forall l1 n, (len l1) < (len (Cons n l1)).
Proof.
  intros.
  simpl. apply lt_n_Sn.
Qed.

Theorem appendLT : forall l1 l2 n, (len l1) < (len (append l1 (Cons n l2))).
Proof.
    intros. induction l1.
    - simpl. apply lt_0_Sn.
    - simpl. apply lt_n_S. assumption.
Qed.


(** %\chapter{Functional Programming in Coq} *)

(** * Enumeration datatypes *)

Inductive unit : Set := tt.

Check tt.

(**
[[
tt
     : unit
]]
*)

Check unit.

(**
[[
unit
     : Set
]]
*)

Inductive empty : Set := .

From mathcomp
Require Import ssreflect ssrbool.

Print bool.
(**
[[
Inductive bool : Set :=  true : bool | false : bool
]]
*)

(**

Let us now try to define some functions that operate with the bool
datatype ignoring for a moment the fact that most of them, if not all,
are already defined in the standard Coq/SSReflect library.  Our first
function will simply negate the boolean value and return its opposite:

*)

Definition negate b :=
  match b with
  | true  => false
  | false => true
  end.

Check negate.
(**
[negate : bool -> bool
]

* Simple recursive datatypes and programs

*)

Print nat.

(**
[Inductive nat : Set :=  O : nat | S : nat -> nat]

*)

From mathcomp
Require Import ssrnat.

Fixpoint my_plus n m :=
 match n with
 | 0     => m
 | n'.+1 => let: tmp := my_plus n' m in tmp.+1
 end.

Eval compute in my_plus 5 7.
(**
[  = 12 : nat]
*)

Fixpoint my_plus' n m := if n is n'.+1 then (my_plus' n' m).+1 else m.

(**
[[
Fixpoint my_plus_buggy n m :=
    if n is n'.+1 then (my_plus_buggy n m).+1 else m.
]]

we immediately get the following error out of the Coq interpreter:

[[
Error: Cannot guess decreasing argument of fix.
]]

*)

Check nat_rec.
(**
[[
nat_rec : forall P : nat -> Set,
          P 0 -> (forall n : nat, P n -> P n.+1) -> forall n : nat, P n
]]

To see how [nat_rec] is implemented, let us explore its generalized
version, [nat_rect]:

*)

Print nat_rect.
(**
[[
nat_rect =
 fun (P : nat -> Type) (f : P 0) (f0 : forall n : nat, P n -> P n.+1) =>
 fix F (n : nat) : P n :=
   match n as n0 return (P n0) with
   | 0 => f
   | n0.+1 => f0 n0 (F n0)
   end
      : forall P : nat -> Type,
        P 0 -> (forall n : nat, P n -> P n.+1) -> forall n : nat, P n
]]

*)

Definition my_plus'' n m := nat_rec (fun _ => nat) m (fun n' m' => m'.+1) n.

Eval compute in my_plus'' 16 12.

(**
[    = 28 : (fun _ : nat => nat) 16]

** Dependent function types and pattern matching

*)

Check nat_rec.

Definition sum_no_zero n :=
 let: P := (fun n => if n is 0 then unit else nat) in
 nat_rec P tt (fun n' m =>
 match n' return P n' -> _ with
 | 0 => fun _ => 1
 | n1.+1 => fun m => my_plus m (n'.+1)
 end m) n.

(*
Definition three_to_unit n :=
 let: P := (fun n => if n is 3 then unit else nat) in
 nat_rec P 0 (fun n' _ => match n' return P n'.+1 with
               | 2 => tt
               | _ => n'.+1
               end) n.

Eval compute in three_to_unit 0.
*)

Eval compute in sum_no_zero 0.

(**

[
     = tt
     : (fun n : nat => match n with
                       | 0 => unit
                       | _.+1 => nat
                       end) 0
]

*)

Eval compute in sum_no_zero 5.
(**
[[
     = 15
     : (fun n : nat => match n with
                       | 0 => unit
                       | _.+1 => nat
                       end) 5
]]

Had we omitted the [return] clauses in the pattern matching, we would
get the following type-checking error, indicating that Coq cannot
infer that the type of [my_plus]' argument is always [nat], so it
complains:

[[
Definition sum_no_zero' n :=
 let: P := (fun n => if n is 0 then unit else nat) in
 nat_rec P tt (fun n' m =>
match n' with
   | 0 => fun _ => 1
   | n''.+1 => fun m => my_plus m (n'.+1)
end m) n.
]]

[[
Error:
In environment
n : ?37
P := fun n : nat => match n with
                    | 0 => unit
                    | _.+1 => nat
                    end : nat -> Set
n' : nat
m : P n'
The term "m" has type "P n'" while it is expected to have type "nat".
]]
*)

(** ** Recursion principle and non-inhabited types *)

Check empty_rect.

(**
[[
empty_rect
     : forall (P : empty -> Type) (e : empty), P e
]]

Assuming existence of a value, which \emph{cannot be constructed}, we
will be able to construct \emph{anything}.

*)

Inductive strange : Set :=  cs : strange -> strange.

Check strange_rect.

(**
[[
strange_rect
     : forall P : strange -> Type,
       (forall s : strange, P s -> P (cs s)) -> forall s : strange, P s
]]
*)

Definition strange_to_empty (s: strange): empty :=
  strange_rect (fun _ => empty) (fun s e => e) s.

(** * More datatypes *)

(* Pairs *)

Check prod.

(**
[[
prod : Type -> Type -> Type

]]
*)

Print prod.

(**
[[
Inductive prod (A B : Type) : Type :=  pair : A -> B -> A * B

For pair: Arguments A, B are implicit and maximally inserted
For prod: Argument scopes are [type_scope type_scope]
For pair: Argument scopes are [type_scope type_scope _ _]
]]
*)

Check pair 1 tt.

(**
[[
(1, tt) : nat * unit

]]

If one wants to explicitly specify the type arguments of a
constructor, the [@]-prefixed notation can be used:

*)

Check @pair nat unit 1 tt.

(**
[[

(1, tt) : nat * unit

]]

*)

Check fst.
(**
[[
fst : forall A B : Type, A * B -> A
]]
*)

Check snd.
(**
[[
fst : forall A B : Type, A * B -> B
]]

The notation "[_ * _]" is not hard-coded into Coq, but rather is
defined as a lightweight syntactic sugar on top of standard Coq
syntax. Very soon we will see how one can easily extend Coq's syntax
by defining their own notations. We will also see how is it possible
to find what a particular notation means.
*)

Print sum.
(**
[[
Inductive sum (A B : Type) : Type :=  inl : A -> A + B | inr : B -> A + B
]]
*)

From mathcomp Require Import seq.
Print seq.

(**
[[
Notation seq := list
]]

*)

Print list.

(**
[[
Inductive list (A : Type) : Type := nil : list A | cons : A -> list A -> list A
]]
*)

(** * Searching for definitions and notations *)

Search "filt".
(**
[[
List.filter  forall A : Type, (A -> bool) -> list A -> list A
List.filter_In
   forall (A : Type) (f : A -> bool) (x : A) (l : list A),
   List.In x (List.filter f l) <-> List.In x l /\ f x = true
]]
*)

Search "filt" (_ -> list _).
(**
[[
List.filter  forall A : Type, (A -> bool) -> list A -> list A
]]
*)

Search _ ((?X -> ?Y) -> _ ?X -> _ ?Y).
(**
[[
option_map  forall A B : Type, (A -> B) -> option A -> option B
List.map  forall A B : Type, (A -> B) -> list A -> list B
...
]]
*)

Search _ (_ * _ : nat).

Search _ (_ * _: Type).

(* Locate machinery *)

Locate "_ + _".

(**
[[
Notation            Scope
"x + y" := sum x y   : type_scope

"m + n" := addn m n  : nat_scope
]]
*)

Locate map.

(**
[[
Constant Coq.Lists.List.map
  (shorter name to refer to it in current context is List.map)
Constant Ssreflect.ssrfun.Option.map
  (shorter name to refer to it in current context is ssrfun.Option.map)
...
]]
*)

(** * An alternative syntax to define inductive datatypes *)

Inductive my_prod (A B : Type) : Type :=  my_pair of A & B.

(**
[[
Check my_pair 1 tt.

Error: The term "1" has type "nat" while it is expected to have type "Type".
]]
*)

(* Declaring implicit arguments *)

Arguments my_pair [A B].

(* Defining custom notation *)

Notation "X ** Y" := (my_prod X Y) (at level 2).
Notation "( X ,, Y )" := (my_pair X Y).

Check (1 ,, 3).

(**
[[
(1,, 3)
     : nat ** nat
]]

*)

Check nat ** unit ** nat.

(**
[[
(nat ** unit) ** nat
     : Set
]]
*)

(** * Sections and modules *)

Section NatUtilSection.

Variable n: nat.

Fixpoint my_mult m := match (n, m) with
 | (0, _) => 0
 | (_, 0) => 0
 | (_, m'.+1) => my_plus (my_mult m') n
 end.

End NatUtilSection.

Print my_mult.

(**

[[
my_mult =
fun n : nat =>
fix my_mult (m : nat) : nat :=
  let (n0, y) := (n, m) in
  match n0 with
  | 0 => 0
  | _.+1 => match y with
            | 0 => 0
            | m'.+1 => my_plus (my_mult m') n
            end
  end
     : nat -> nat -> nat
]]
*)

Module NatUtilModule.

Fixpoint my_fact n :=
  if n is n'.+1 then my_mult n (my_fact n') else 1.

Module Exports.
Definition fact := my_fact.
End Exports.

End NatUtilModule.

Export NatUtilModule.Exports.

(**
[[
Check my_fact.

Error: The reference my_fact was not found in the current environment.
]]
*)

Check fact.

(**
[[
fact
     : nat -> nat
]]
*)

(*******************************************************************)
(**                     * Exercices *                              *)
(*******************************************************************)

From mathcomp Require Import eqtype.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
---------------------------------------------------------------------
Exercise [Power of two]
---------------------------------------------------------------------

Write the function [two_power] of type [nat -> nat], such that
[two_power n = 2^n]. Use the functions that we have defined earlier.
*)

(**
---------------------------------------------------------------------
Exercise [Even numbers]
---------------------------------------------------------------------

Define the function [evenB] of type [nat -> bool], such that it
returns [true] for even numbers and [false] otherwise. Use the
function we have already defined.
*)

(**
---------------------------------------------------------------------
Exercise [Division by four]
---------------------------------------------------------------------

Define the function [div4] that maps any natural number [n] to the
integer part of [n/4].
*)

(**
---------------------------------------------------------------------
Exercise [Representing rational numbers]
---------------------------------------------------------------------

Every strictly positive rational number can be obtained in a unique
manner by a succession of applications of functions [N] and [D] on the
number one, where [N] and [D] defined as follows:

[[
N(x) = 1 + x

D(x) = 1/(1 + 1/x)
]]

Define an inductive type (with three constructors), such that it
uniquely defines strictly positive rational using the representation
above.

Then, define the function that takes an element of the defined type
and returns a numerator and denominator of the corresponding fraction.
*)

(**
---------------------------------------------------------------------
Exercise [Infinitely-branching trees]
---------------------------------------------------------------------

Define an inductive type of infinitely-branching trees (parametrized
over a type [T]), whose leafs are represented by a constructor that
doesn't take parameters and a non-leaf nodes contain a value _and_ a
function that takes a natural number and returns a child of the node
with a corresponding natural index.

Define a boolean function that takes such a tree (instantiated with a
type [nat]) and an argument of [n] type [nat] and checks whether the
zero value occurs in it at a node reachable only by indices smaller
than a number [n]. Then write some "test-cases" for the defined
function.

Hint: You might need to define a couple of auxiliary functions for
this exercise.

Hint: Sometimes you might need to provide the type arguments to
constructors explicitly.

*)

(**
---------------------------------------------------------------------
Exercise [Take n]
---------------------------------------------------------------------

Write a function that takes a type [A], and number [n] and a list [l]
of elements of type [A] as arguments and returns first [n] elements of
the list (as another list) of [l] if they exist.
*)

(**
---------------------------------------------------------------------
Exercise [Generate a range]
---------------------------------------------------------------------

Implement a function that takes a number [n] and returns the list
containing the natural numbers from [1] to [n], _in this order_.
*)

(**
---------------------------------------------------------------------
Exercise [List-find]
---------------------------------------------------------------------

Write a function that take a type [A], a function [f] of type [A ->
bool] and a list [l], and return the first element [x] in [l], such
that [f x == true].

Hint: Use Coq's [option] type to account for the fact that the
 function of interest is partially-defined.
*)

(**
---------------------------------------------------------------------
Exercise [Standard list combinators]
---------------------------------------------------------------------

Implement the following higher-order functions on lists

- map
- filter
- fold_left
- fold_right
- tail-recursive list reversal
*)

(**
---------------------------------------------------------------------
Exercises [No-stuttering lists]
---------------------------------------------------------------------

We say that a list of numbers "stutters" if it repeats the same number
consecutively. The predicate "nostutter ls" means that ls does not
stutter. Formulate an inductive definition for nostutter. Write some
"unit tests" for this function.

*)

(**
---------------------------------------------------------------------
Exercise [List alternation]
---------------------------------------------------------------------

Implement the recursive function [alternate] of type [seq nat -> seq
nat -> seq nat], so it would construct the alternation of two
sequences according to the following "test cases".

Eval compute in alternate [:: 1;2;3] [:: 4;5;6].
[[
     = [:: 1; 4; 2; 5; 3; 6]
     : seq nat
]]

Eval compute in alternate [:: 1] [:: 4;5;6].
[[
     = [:: 1; 4; 5; 6]
     : seq nat
]]
Eval compute in alternate [:: 1;2;3] [:: 4].
[[
     = [:: 1; 4; 2; 3]
     : seq nat
]]

Hint: The reason why the "obvious" elegant solution might fail is
 that the argument is not strictly decreasing.
*)

(**
---------------------------------------------------------------------
Exercise [Functions with dependently-typed result type]
---------------------------------------------------------------------

Write a function that has a dependent result type and whose result is
[true] for natural numbers of the form [4n + 1], [false] for numbers
of the form [4n + 3] and [n] for numbers of the from [2n].

Hint: Again, you might need to define a number of auxiliary
 (possibly, higher-order) functions to complete this exercise.
*)


(** * Indu\u00e7\u00e3o em Coq *)

Add LoadPath "/Users/marcosmonteiro/desktop/coq".
Require Export aula04_provas.

(* ############################################### *)
(** * Prova por indu\u00e7\u00e3o *)

(** Nem sempre \u00e9 poss\u00edvel provar somente por:
    - simplifica\u00e7\u00e3o
    - reescrita
    - an\u00e1lise de casos *)

(** Na aula passada, vimos o seguinte teorema *)

Print plus_O_n.

(** E se quisermos provar n + 0 = n? *)

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0 .
Proof.
  intros n.
  simpl. (* n\u00e3o simplifica nada *)
  try reflexivity.
(** [reflexivity] n\u00e3o funciona, pois [n]
    em [n + 0] \u00e9 um n\u00famero arbitr\u00e1rio e
    n\u00e3o caso padr\u00e3o com o [+] *)
  Print NatPlayground2.plus.
Abort.

(** An\u00e1lise de casos tamb\u00e9m n\u00e3o ajuda. *)

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    simpl. reflexivity. (* quando [n] \u00e9 0, funciona *)
  - (* n = S n' *)
    simpl.       (* aqui [n] \u00e9 [S n'],
                  outro n\u00famero arbitr\u00e1rio *)
Abort.

(** Chamadas sucessivas a [destruct n']
    tamb\u00e9m n\u00e3o ajudaria. Precisamos de indu\u00e7\u00e3o. *)

Theorem plus_n_O : forall n:nat, n = n + 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite <- IHn'.
                   reflexivity.
Qed.

(** Outro exemplo. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.
Qed.

(** Nota: [induction] move automaticamente
    vari\u00e1veis quantificadas para o contexto. *)

(** **** Exercise: (basic_induction)  *)
(** Prove os seguintes teoremas. Ser\u00e1 necess\u00e1rio
    buscar por resultados previamente provados. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros n. induction n.
  - simpl. reflexivity.
  - simpl. rewrite -> IHn. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m. induction n.
  - simpl. reflexivity.
  - simpl. rewrite -> IHn. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n.
  - simpl. rewrite <- plus_n_O. reflexivity.
  - simpl. rewrite -> IHn. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n.
  - reflexivity.
  - simpl. rewrite -> IHn. reflexivity.
Qed.

(* ############################################### *)
(** * Provas aninhadas *)

(** \u00c9 possivel/aconselh\u00e1vel quebrar provas maiores
    em subprovas. Isto pode ser feito a partir de
    [Lemma], como tamb\u00e9m a partir de "sub-teoremas". *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
  {
    simpl. reflexivity.
  }
  rewrite -> H.
  reflexivity.
Qed.

(** Outro exemplo: veja que a t\u00e1tica [rewrite]
    n\u00e3o \u00e9 muito "inteligente" sobre onde aplicar
    a reescrita no objetivo. *)

Theorem plus_rearrange_firsttry :
  forall n m p q : nat,
    (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q. Print plus_comm.
  (* S\u00f3 queremos trocar (n + m) por (m + n). *)
  rewrite -> plus_comm.
  (* Mas  reescrita n\u00e3o faz o que queremos. *)
Abort.

(** Veja a pr\u00f3xima prova. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.
Qed.

(** Mas tamb\u00e9m funcionaria s\u00f3 instanciando
    [n] e [m], deixando [p] e [q] ligados. *)
Theorem plus_rearrange' : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m.
  rewrite -> plus_comm. reflexivity.
Qed.

(** Contudo, a ordem das quantifica\u00e7\u00f5es
    pode vir a ser um problema. *)

Theorem plus_rearrange'' : forall n p q m : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.
Qed.

(* ############################################### *)
(** * Mais exerc\u00edcios *)

(** **** Exercise: (mult_comm)  *)
(** Use [assert] para ajudar na prova. N\u00e3o \u00e9
    necess\u00e1rio usar indu\u00e7\u00e3o. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p. rewrite plus_assoc. rewrite plus_assoc.
  assert (H: n + m = m + n).
  { rewrite plus_comm. reflexivity. }
  rewrite H. reflexivity.
Qed.

(** Agora, prove comutatividade da multiplica\u00e7\u00e3o.
    Talvez seja necess\u00e1rio provar um teorema auxiliar.
    O teorema [plus_swap] ser\u00e1 \u00fatil. *)

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros m n. induction m.
  - simpl. rewrite <- mult_n_O. reflexivity.
  - rewrite <- mult_n_Sm. simpl. rewrite plus_comm.
  assert (H: m * n = n * m).
  { rewrite IHm. reflexivity. }
  rewrite IHm. reflexivity.
Qed.

(* ############################################### *)
(** * Leitura sugerida *)

(** Software Foundations: volume 1
  - Induction
  https://softwarefoundations.cis.upenn.edu/lf-current/Induction.html
*)