(* Examples of type classes and Setoids *)
(* Version with operational classes *)
(* Some comments by Matthieu *)

Set Implicit Arguments.

Require Import ZArith  Div2  Recdef  Mat.

Class monoid_binop (A:Type) := monoid_op : A -> A -> A.

Delimit Scope M_scope with M.
Infix "*" := monoid_op: M_scope.
Open Scope M_scope.

Class Monoid (A:Type)(dot : monoid_binop  A)(one : A) : Prop := {
  dot_assoc : forall x y z:A, x * (y * z)=  x * y * z;
  one_left : forall x, one * x = x;
  one_right : forall x,  x * one = x}.

(*
one_right :
forall (A : Type) (dot : monoid_binop A) (one : A),
Monoid dot one -> forall x : A, x * one = x
*)

Open Scope Z_scope.

(** Tests :

Compute (@monoid_op _ Zmult 5 6).

*)

Instance Zmult_op : monoid_binop Z | 17:= Zmult.

Instance ZMult : Monoid   Zmult_op  1 | 22.
Proof.
  split;intros; unfold Zmult_op, monoid_op; ring.
Defined.

Require Import Ring.

Section matrices.
 Variables (A:Type)
           (zero one : A)
           (plus mult minus : A -> A -> A)
           (sym : A -> A).
 Notation "0" := zero.
 Notation "1" := one.
 Notation "x + y" := (plus x y).
 Notation "x * y " := (mult x y).

 Variable rt : ring_theory  zero one plus mult minus sym (@eq A).

 Add  Ring Aring : rt.

Global Instance M2_mult_op :  monoid_binop (M2 A) := (M2_mult  plus mult ) .

Global Instance M2_Monoid : Monoid  M2_mult_op (Id2  0 1).
Proof.
  split.
  - destruct x;destruct y;destruct z;unfold monoid_op;simpl.
    unfold M2_mult;apply M2_eq_intros;simpl;  ring.
  - destruct x;simpl;unfold M2_mult_op, monoid_op;
    unfold M2_mult; apply M2_eq_intros; simpl;ring.
  - destruct x;simpl;unfold M2_mult_op, monoid_op;
    unfold M2_mult;apply M2_eq_intros;simpl;ring.
Defined.

End matrices.

Generalizable Variables A dot one.

Instance M2_Z_op : monoid_binop (M2 Z) := M2_mult Zplus Zmult .

Instance M2_mono_Z : Monoid (M2_mult_op _ _)  (Id2  _ _):=  M2_Monoid Zth.

(** Tests :

Compute let m := Build_M2 1 1 1 0 in
          (m  *  m)%M.
*)

Fixpoint power `{M : @Monoid A dot one}(a:A)(n:nat) :=
  match n with 0%nat => one
             | S p => (a * power a p)%M
  end.

Infix "**" := power (at level 30, no associativity):M_scope.

(** Tests :
Compute  (2 ** 5) ** 2.

Compute (Build_M2  1 1 1  0) **    40.
*)

(* A tail recursive linear function *)

Fixpoint power_mult `{M : Monoid }
     (acc x:A)(n:nat) : A (*  acc * (x ** n) *) :=
  match n with 0%nat => acc
             | S p => power_mult (acc * x)%M x p
  end.

Definition tail_recursive_power  `{M : Monoid}(x:A)(n:nat) :=
     power_mult one x n.

Require Import Recdef  Div2.

Function binary_power_mult (A:Type)(dot:monoid_binop A)(one:A)
    (M: @Monoid A dot one) (acc x:A)(n:nat){measure (fun i=>i) n} : A
  (* acc * (x ** n) *) :=
  match n with 0%nat => acc
             | _ => match Even.even_odd_dec n
                    with left H0 => binary_power_mult    _   acc (dot x x) (div2 n)
                       | right H1 =>
                         binary_power_mult   _  (acc * x)%M ( x * x)%M (div2 n)
                    end
  end.
Proof.
  - intros;apply lt_div2; auto with arith.
  - intros;apply lt_div2; auto with arith.
Defined.

Definition binary_power `{M: Monoid} (x:A)(n:nat)  :=
     binary_power_mult    M one  x n.

(** Tests

Compute binary_power  2 5.

Compute  (Build_M2 1 1 1 0) ** 10.

Compute binary_power (Build_M2 1 1 1 0) 20.
*)

Section About_power.

  Context      `(M:Monoid  ).
  Open Scope M_scope.

  Ltac monoid_rw :=
    rewrite one_left || rewrite one_right || rewrite dot_assoc.

  Ltac monoid_simpl := repeat monoid_rw.

  Lemma power_x_plus : forall x n p, (x ** (n + p) = x ** n * x ** p).
  Proof.
   induction n;simpl.
   - intros; monoid_simpl;trivial.
   - intro p;rewrite (IHn p); monoid_simpl;trivial.
  Qed.

  Ltac power_simpl := repeat (monoid_rw || rewrite <- power_x_plus).

  Lemma power_commute : forall x n p,
               x ** n * x ** p = x ** p * x ** n.
  Proof.
   intros x n p;power_simpl;  rewrite (plus_comm n p);trivial.
 Qed.

 Lemma power_commute_with_x : forall x n ,
        x * x ** n = x ** n * x.
 Proof.
  induction n;simpl;power_simpl;trivial.
  repeat rewrite <- dot_assoc; rewrite IHn; trivial.
 Qed.

 Lemma power_of_power : forall x n p,  (x ** n) ** p = x ** (p * n).
 Proof.
   induction p;simpl;[| rewrite power_x_plus; rewrite IHp]; trivial.
Qed.

Lemma power_S : forall x n, x *  x ** n = x ** S n.
Proof. intros;simpl;auto. Qed.

Lemma sqr : forall x, x ** 2 =  x * x.
Proof.
 simpl;intros;monoid_simpl;trivial.
Qed.

Ltac factorize := repeat (
                rewrite <- power_commute_with_x ||
                rewrite  <- power_x_plus  ||
                rewrite <- sqr ||
                rewrite power_S ||
                rewrite power_of_power).

 Lemma power_of_square : forall x n, (x * x) ** n = x ** n * x ** n.
 Proof.
  induction n;simpl;monoid_simpl;trivial.
  repeat rewrite dot_assoc;rewrite IHn; repeat rewrite dot_assoc.
  factorize; simpl;trivial.
 Qed.

 Lemma power_mult_correct :
    forall n x, tail_recursive_power x n = x ** n.
  Proof.
    intros n x;  unfold tail_recursive_power.
    rewrite <-  (one_left  (power x n)).
    assert (forall y:A, power_mult y x n =  y * (power x n)); auto.
       generalize n x;intro p; induction p;simpl;intros; monoid_simpl;auto.
  Qed.

Lemma binary_power_mult_ok :
  forall n a x,  binary_power_mult  M a x n = a * x ** n.
Proof.
  intro n; pattern n;apply lt_wf_ind.
  clear n; intros n Hn;   destruct n.
  -  intros;simpl; rewrite binary_power_mult_equation;monoid_simpl;
    trivial.
  - intros;
    rewrite binary_power_mult_equation; destruct (Even.even_odd_dec (S n)).
   + rewrite Hn.
     * rewrite power_of_square;  factorize.
       pattern (S n) at 3;replace (S n) with (div2 (S n) + div2 (S n))%nat;auto.
       generalize (even_double _ e);simpl;auto.
     *  apply lt_div2;auto with arith.
   +  rewrite Hn.
      * rewrite power_of_square ; factorize.
        pattern (S n) at 3;replace (S n) with (S (div2 (S n) + div2 (S n)))%nat;auto.
        rewrite <- dot_assoc; factorize;auto.
        generalize (odd_double _ o);intro H;auto.
      * apply lt_div2;auto with arith.
Qed.

Lemma binary_power_ok : forall x n, binary_power (x:A)(n:nat) = x ** n.
Proof.
  intros n x;unfold binary_power;rewrite binary_power_mult_ok;
  monoid_simpl;auto.
Qed.

End About_power.

(** An efficient Fibonacci function
*)

Definition fibonacci (n:nat) :=
      c00  (binary_power (Build_M2 1 1 1 0) n).

(** Tests:

Compute fibonacci 20.
*)

(** Abelian Monoids
*)

Class Abelian_Monoid `(M:Monoid):= {
  dot_comm : forall x y, (x * y = y * x)%M}.

Instance ZMult_Abelian : Abelian_Monoid ZMult.
Proof.
  split.
  - exact Zmult_comm.
Defined.

Section Power_of_dot.
 Context `{M: Monoid A} {AM:Abelian_Monoid M}.

 Open Scope M_scope.

 Theorem power_of_mult :
   forall n x y, ((x * y) ** n =  x ** n  * y ** n)%M.
Proof.
 induction n;simpl.
 -  rewrite one_left;auto.
 - intros; rewrite IHn; repeat rewrite dot_assoc.
   rewrite <- (dot_assoc  x y (power x n)); rewrite (dot_comm y (power x n)).
   repeat rewrite dot_assoc;trivial.
Qed.

End Power_of_dot.

Example Ex1:  forall (x y z :Z)(n:nat),  ((x * (y * z)) ** n  =
                        x ** n *  (y ** n  * z ** n))%M.
Proof.
intros; repeat (rewrite power_of_mult); trivial.
Qed.

(*** Monoids with equivalence *)

Require Import Coq.Setoids.Setoid  Morphisms.

Class Equiv A := equiv : relation A.
Infix "==" := equiv (at level 70):type_scope.

  Open Scope M_scope.

  Class EMonoid (A:Type)(E_eq :Equiv A)(E_dot : monoid_binop A)(E_one : A):={
  E_rel :> Equivalence equiv;
  dot_proper :> Proper (equiv ==> equiv ==> equiv) monoid_op;
  E_dot_assoc : forall x y z:A,
      x * (y * z) == x * y * z;
  E_one_left : forall x, E_one * x == x;
  E_one_right : forall x, x * E_one == x}.

Generalizable Variables E_eq E_dot E_one.

(* --- *)

Lemma E_trans  `(M:EMonoid A)  : transitive A  E_eq.
Proof. apply E_rel. Qed.

(* The above proofs are equivalent to the overloaded reflexivity, symmetry and transitivity
   lemmas, already avalable for every EMonoid. i.e.: *)

Lemma E_refl' `(M:EMonoid A) : reflexive A  E_eq.
Proof. intro. change (equiv x x). apply reflexivity. Qed.

Fixpoint Epower `{M : EMonoid }(a:A)(n:nat):A :=
  match n with 0%nat => E_one
             | S p =>  a * (Epower a p)
  end.

About Epower.

Global Instance  Epower_Proper `(M: EMonoid):
  Proper (equiv ==> Logic.eq ==> equiv) Epower.
Proof.
  intros x y H n p e;subst p;induction n.
  -  reflexivity.
  -  apply dot_proper;auto.
Qed.

Instance monoid_op_params : Params (@monoid_op) 2.

Lemma Epower_x_plus `(M: EMonoid) :
   forall x n p,  (Epower x (n + p)) ==
                  (Epower x n) * (Epower x p).
  Proof.
   induction n;simpl.
   -  intros ; rewrite E_one_left;reflexivity.
   -  intro p;  rewrite <- E_dot_assoc;  now rewrite <- IHn.
  Qed.

Lemma Epower_x_mult `(M: EMonoid) :
   forall x n p,  (Epower x (n * p)) ==
                  Epower (Epower x p) n.
  Proof.
   induction n;simpl.
   - reflexivity.
   -intro p; rewrite Epower_x_plus;  now rewrite IHn.
 Qed.

(*** The monoid of function composition *)

Section Definitions.
  Variable A : Type.

  Definition  comp (g f : A -> A): A -> A :=
   fun x :A => g (f x).

  Definition fun_ext (f g: A -> A) :=
   forall x , f x  = g x.

  Lemma fun_ext_refl : reflexive (A -> A)  fun_ext.
  Proof. intros  f x; reflexivity. Qed.

  Lemma fun_ext_sym : symmetric (A -> A)  fun_ext.
 Proof.
  intros f g H x ; rewrite H; reflexivity.
 Qed.

 Lemma fun_ext_trans: transitive (A -> A)  fun_ext.
 Proof.
   intros f g h H H0 x; rewrite H;rewrite H0;reflexivity.
 Qed.

 (* Global instances are not forgotten at the end of sections and keep their visibility. *)

 Global Instance fun_ext_equiv : Equivalence   fun_ext.
  Proof.
    split; [ apply fun_ext_refl| apply fun_ext_sym| apply fun_ext_trans].
  Qed.

End Definitions.

Instance fun_ext_op A : Equiv (A->A) := @fun_ext A.

(* Comp is proper for extensional equality of functions *)
Global Instance comp_proper A : Proper (equiv ==> equiv ==> equiv) (@comp A).
Proof. reduce; unfold comp; rewrite H, H0; reflexivity. Qed.

Instance Rels (A:Type) : EMonoid equiv (@comp  A) (@id A).
Proof.
 split.
 - apply fun_ext_equiv.
 - apply comp_proper.
 - unfold comp;intros f g h x;reflexivity.
 - intros f x;reflexivity.
 - intros f x;reflexivity.
Defined.

Definition fibonacci_alt (n:nat) :=
   fst  (Epower (M:= Rels (Z*Z)) (fun p:Z*Z => let (a,b):= p in (b,a+b)) n (1,1)).

Compute fibonacci_alt 40.

Module SemiRing.

(* Overloaded notations *)

Class RingOne A := ring_one : A.
Class RingZero A := ring_zero : A.
Class RingPlus A := ring_plus :> monoid_binop A.
Class RingMult A := ring_mult :> monoid_binop A.

Infix "+" := ring_plus.
Infix "*" := ring_mult.
Notation "0" := ring_zero.
Notation "1" := ring_one.

Typeclasses Transparent RingPlus RingMult RingOne RingZero.

Class Distribute `{Equiv A} (f g: A -> A -> A): Prop :=
  { distribute_l a b c: f a (g b c) == g (f a b) (f a c)
  ; distribute_r a b c: f (g a b) c == g (f a c) (f b c) }.

Class Commutative {A B} `{Equiv B} (m: A -> A -> B): Prop :=
  commutativity x y : m x y = m y x.

Class Absorb {A} `{Equiv A} (m: A -> A -> A) (x : A) : Prop :=
  { absorb_l c : m x c = x ;
    absorb_r c : m c x = x }.

Class ECommutativeMonoid `(Equiv A) (E_dot : monoid_binop A)(E_one : A):=
  { e_commmonoid_monoid :> EMonoid equiv E_dot E_one;
    e_commmonoid_commutative :> Commutative E_dot }.

Class ESemiRing (A:Type) (E_eq :Equiv A) (E_plus : RingPlus A) (E_zero : RingZero A)
            (E_mult : RingMult A) (E_one : RingOne A):=
  { add_monoid :> ECommutativeMonoid equiv ring_plus ring_zero ;
    mul_monoid :> EMonoid equiv ring_mult ring_one ;
    ering_dist :> Distribute ring_mult ring_plus ;
    ering_0_mult :> Absorb ring_mult 0
  }.

Print Absorb.

Section SemiRingTheory.

  Context `{ESemiRing A}.

  Definition ringtwo := 1 + 1.

  Lemma ringtwomult : forall x : A, ringtwo * x == x + x.
  Proof.
    intros;unfold ringtwo;    rewrite distribute_r.
    now rewrite (E_one_left x).
  Qed.

End SemiRingTheory.

End SemiRing.

(** Monoid of Partial Commutation *)

Require Import Coq.Lists.List  Relation_Operators  Operators_Properties.

Section Partial_Com.

Inductive Act : Set := a | b | c.

(** action a commutes with action b *)

Inductive transpose : list Act -> list Act -> Prop :=
 transpose_hd : forall w, transpose(a::b::w) (b::a::w)
|transpose_tl : forall x w u, transpose  w u -> transpose (x::w) (x::u).

Definition commute := clos_refl_sym_trans _ transpose.

Instance Commute_E : Equivalence  commute.
Proof.
split.
- constructor 2.
- constructor 3;auto.
- econstructor 4;eauto.
Qed.

Instance CE : Equiv (list Act) := commute.

Example ex1 :  (c::a::a::b::nil) == (c::b::a::a::nil).
Proof.
 constructor 4 with (c::a::b::a::nil).
 - constructor 1.
   constructor 2.
   constructor 2.
   constructor 1.
 - constructor 1.
   right;left.
Qed.

Instance cons_transpose_Proper (x:Act): Proper (transpose ==> transpose)
                                         (cons x).
Proof.
 intros  l l' H;constructor ;auto.
Defined.

Instance append_transpose_Proper (l:list Act): Proper (transpose ==> transpose)
                                         (app l).
Proof.
 induction l.
 - intros z t Ht;simpl;auto.
 - intros z t Ht;simpl;constructor;auto.
Qed.

Instance append_transpose_Proper_1  : Proper (transpose ==> Logic.eq  ==> transpose)
                                         (@app Act).
Proof.
 intros x y H;induction H;intros z t e;subst t.
 -  simpl;constructor.
 -  generalize (IHtranspose z z (refl_equal z)); simpl;constructor;auto.
Qed.

Instance append_commute_Proper_1 :
Proper (Logic.eq ==> commute  ==> commute)
                                         (@app Act).
Proof.
 intros x y e;subst y;intros z t H;elim H.
 - constructor 1.
  apply append_transpose_Proper;auto.
 -  reflexivity.
 -  constructor 3;auto.
 -  intros x0 y z0;constructor 4 with (x++y);auto.
Qed.

Instance  append_commute_Proper_2 :
Proper (commute ==> Logic.eq   ==> commute) (@app Act).
Proof.
intros x y H; elim H.
-  intros x0 y0 H0  z t e; subst t; constructor 1.
   apply append_transpose_Proper_1;auto.
-  intros x0 z t e; subst t;constructor 2;auto.
-   intros x0 y0 H0 H1 z t e;subst t.
    constructor 3.
    apply H1;auto.
-  intros x0 y0 z0 H1 H2 H3 H4 z t e;subst t.
   transitivity (y0 ++ z).
   +  apply H2;reflexivity.
   +  apply H4;reflexivity.
Qed.

Instance append_Proper : Proper (commute ==> commute ==> commute) (@app Act).
Proof.
 intros x y H z t H0; transitivity (y++z).
 - now rewrite H.
 - now rewrite H0.
Qed.

Instance app_op :  monoid_binop (list Act):=  @app Act.

Instance PCom  : EMonoid   commute app_op nil.
Proof.
 split.
 - apply Commute_E.
 - apply append_Proper.
 - unfold monoid_op;induction x;simpl;auto.
   + reflexivity.
   + intros;simpl;unfold app_op; rewrite app_assoc;reflexivity.
 - unfold monoid_op;simpl;reflexivity.
 - unfold monoid_op,app_op;intro;rewrite app_nil_r;reflexivity.
Qed.

Example ex2:  Epower  (c::a::a::b::nil) 10 ==
     Epower (Epower  (c::b::a::a::nil) 5)  2.
Proof.
  rewrite ex1, <- Epower_x_mult.
  reflexivity.
Qed.

End Partial_Com.

Section Z_additive.

Local Instance Z_plus_op :  monoid_binop Z | 2:= Zplus.

Require Import ZArithRing.

Instance ZAdd : Monoid   Z_plus_op 0 | 2.
Proof.
  split;intros;unfold Z_plus_op, monoid_op; simpl;ring.
Defined.

Example Ex2 : (2 * 5)%M = 7.
Proof. reflexivity. Qed.

Example Ex3 : 2 ** 5 = 10.
Proof. reflexivity. Qed.

Example Ex4 : power  (M:=ZMult) 2 5 = 32.
Proof. reflexivity. Qed.

(* OK, let's remove ZAdd *)
End Z_additive.

Example Ex5 : (2  * 5)%M = 10.
Proof. reflexivity. Qed.

(** Let us build a new instance with priority 1 *)

Instance Zplus_op : monoid_binop Z | 7 := Zplus.

Instance : Monoid   Zplus_op  0 | 1.
split;intros;  unfold  monoid_op, Zplus_op; simpl; ring.
Defined.

Example Ex6 : (2 * 5)%M = 7.
Proof. reflexivity. Qed.

(* The least priority level wins *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import BinInt.
Local Open Scope Z_scope.

(** An alternative power function for Z *)

(** This [Zpower_alt] is extensionally equal to [Z.pow],
    but not convertible with it. The number of
    multiplications is logarithmic instead of linear, but
    these multiplications are bigger. Experimentally, it seems
    that [Zpower_alt] is slightly quicker than [Z.pow] on average,
    but can be quite slower on powers of 2.
*)

Definition Zpower_alt n m :=
  match m with
    | Z0 => 1
    | Zpos p => Pos.iter_op Z.mul p n
    | Zneg p => 0
  end.

Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope.

Lemma Piter_mul_acc : forall f,
 (forall x y:Z, (f x)*y = f (x*y)) ->
 forall p k, Pos.iter f k p = (Pos.iter f 1 p)*k.
Proof.
 intros f Hf.
 induction p; simpl; intros.
 - set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Hf, Z.mul_assoc.
 - set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Z.mul_assoc.
 - now rewrite Hf, Z.mul_1_l.
Qed.

Lemma Piter_op_square : forall p a,
 Pos.iter_op Z.mul p (a*a) = (Pos.iter_op Z.mul p a)*(Pos.iter_op Z.mul p a).
Proof.
 induction p; simpl; intros; trivial. now rewrite IHp, Z.mul_shuffle1.
Qed.

Lemma Zpower_equiv a b : a^^b = a^b.
Proof.
 destruct b as [|p|p]; trivial.
 unfold Zpower_alt, Z.pow, Z.pow_pos.
 revert a.
 induction p; simpl; intros.
 - f_equal.
   rewrite Piter_mul_acc.
   now rewrite Piter_op_square, IHp.
   intros. symmetry; apply Z.mul_assoc.
 - rewrite Piter_mul_acc.
   now rewrite Piter_op_square, IHp.
   intros. symmetry; apply Z.mul_assoc.
 - now Z.nzsimpl.
Qed.

Lemma Zpower_alt_0_r n : n^^0 = 1.
Proof. reflexivity. Qed.

Lemma Zpower_alt_succ_r a b : 0<=b -> a^^(Z.succ b) = a * a^^b.
Proof.
 destruct b as [|b|b]; intros Hb; simpl.
 - now Z.nzsimpl.
 - now rewrite Pos.add_1_r, Pos.iter_op_succ by apply Z.mul_assoc.
 - now elim Hb.
Qed.

Lemma Zpower_alt_neg_r a b : b<0 -> a^^b = 0.
Proof.
 now destruct b.
Qed.

Lemma Zpower_alt_Ppow p q : (Zpos p)^^(Zpos q) = Zpos (p^q).
Proof.
 now rewrite Zpower_equiv, Pos2Z.inj_pow.
Qed.


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

Module FunProg.

(** * Enumeration datatypes *)

Inductive unit : Set := tt.

Check tt.

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

Check unit.

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

Inductive empty : Set := .

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]

*)

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_plus1 n m := nat_rec (fun _ => nat) m (fun n' m' => m'.+1) n.

Eval compute in my_plus1 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
   | n1.+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
]]
*)

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

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

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

Fixpoint two_power n :=
 match n with
  | 0 => 1
  | n'.+1 =>(two_power n' ) * 2
 end.

Check two_power.
Eval compute in two_power 0.
Eval compute in two_power 5.

Print nat_rec.

Definition two_power' n:=
 nat_rec (fun _ => nat) 1 (fun n' m => m * 2) n.
Eval compute in two_power' 0.
Eval compute in two_power' 5.

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

Fixpoint evenB n :=
 match n with
  | 0 => true
  | n'.+1 => negate (evenB n')
 end.

Eval compute in evenB 0.
Eval compute in evenB 1.
Eval compute in evenB 2.

Fixpoint evenB' n := nat_rec (fun _ => _) true (fun n' m => negate m) n.
Eval compute in evenB' 0.
Eval compute in evenB' 1.
Eval compute in evenB' 2.

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

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

*)

Fixpoint div4 n :=
 match n-3 with
  | 0 => 0
  | n'.+1 => (div4 n').+1
 end.

Eval compute in div4 0.
Eval compute in div4 3.
Eval compute in div4 4.
Eval compute in div4 5.
Eval compute in div4 11.
Eval compute in div4 12.
Eval compute in div4 13.

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

Inductive rrn : Type :=
 | l : rrn
 | N : rrn -> rrn
 | D : rrn -> rrn.

Check N (D l).
Search pair.
(* Representing rational numbers -> Fraction *)

Fixpoint rrn_fra (r:rrn) : prod nat nat:=
 match r with
  | l => (1,1)
  | N r' => ( fst (rrn_fra r') +  snd (rrn_fra r') , snd (rrn_fra r') )
  | D r' => ( fst (rrn_fra r') , fst (rrn_fra r') +  snd (rrn_fra r') )
 end.

Eval compute  in rrn_fra l.
Eval compute  in rrn_fra ( N l ).
Eval compute  in rrn_fra ( D l ).
Eval compute  in rrn_fra ( N ( N l ) ).
Eval compute  in rrn_fra ( D ( N l ) ).
Eval compute  in rrn_fra ( N ( D l ) ).
Eval compute  in rrn_fra ( D ( D l ) ).

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

Fixpoint take_n {A:Type} (n:nat) (l:list A) :list A:=
 match n with
  | 0 => nil
  | n'.+1 =>
   match l with
    | nil => nil
    | h :: t => cons h (take_n n' t)
  end
 end.

Eval compute in take_n 0 (1::2::3::4::5::nil) .
Eval compute in take_n 2 (1::2::3::4::5::nil) .
Eval compute in take_n 5 (1::2::3::4::5::nil) .
Eval compute in take_n 8 (1::2::3::4::5::nil) .

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

(*
Fixpoint gene_range n :=
 match n with
  | 0 => nil
  | n'.+1 => (gene_range n') :: n
 end.
*)

Fixpoint gene_range n:=nat_rec (fun _ => list _ ) nil (fun n l => l ++ (n.+1 :: nil) ) n.
Eval compute in gene_range 0.
Eval compute in gene_range 1.
Eval compute in gene_range 9.

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

Print option.

Fixpoint list_find  {A:Type} (f:A -> bool) l :=
 match l with
  | nil => None
  | h::t => if f h is true then Some h else list_find f t
 end.

Eval compute in list_find evenB nil.
Eval compute in list_find evenB (1::3::6::8::nil).
Eval compute in list_find evenB (1::3::nil).

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

*)

Search "beq".
Require Import EqNat.
Print beq_nat.

Fixpoint nostutter (ls:list nat) :=
 match ls with
  | nil => nil
  | h::t =>
   match t with
    | nil => ls
    | h'::t' =>
     if (beq_nat h h')
      then nostutter t
      else h :: (nostutter t)
   end
 end.

Eval compute in nostutter [::].
Eval compute in nostutter [:: 0;1;2;3].
Eval compute in nostutter [:: 0;0;1;3;3].
Eval compute in nostutter [:: 1;1;1].

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

Fixpoint alternate (l1 l2:list nat):=
 match l1 with
  | nil => l2
  | h1::t1 =>
   match l2 with
    | nil => l1
    | h2::t2 => h1::h2::(alternate t1 t2)
   end
  end.

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

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

Fixpoint mod_4 n:=
match n-3 with
 | 0 => n
 | n'.+1 => mod_4 n'
end.

Eval compute in mod_4 0.
Eval compute in mod_4 1.
Eval compute in mod_4 4.
Eval compute in mod_4 7.

Check nat_rec.
(*
Definition dep_exr n :=
if evenB (mod_4 n) then 2*n else
if mod_4 n is 1 then true else false.
*)

Eval compute in dep_exr 0.
Eval compute in dep_exr 1.
Eval compute in dep_exr 2.
Eval compute in dep_exr 3.
Eval compute in dep_exr 4.

End FunProg.


Require Import List Lia.
Require Import TypeClasses Ltacs Vector.
Import VectorNotations.
Import ListNotations.
(*
Formallizing a matrix so that we can use them for operations
*)

(*
  At its most fundamental level, a matrix is a list of lists.

  We want every list within the top-level list to be the same length.

  Maybe this would be better represented using vectors?
*)

Inductive Matrix {A : Type} : nat -> nat -> Type :=
| mtMatrix  : forall (rows cols : nat), rows = 0 ->
    Matrix rows cols
| nMatrix   : forall (rows cols : nat) {rows' : nat}
      (curRow : (@Vector A cols)),
    S rows' = rows ->
    Matrix rows' cols ->
    Matrix rows cols.

Definition mat_num_rows {A : Type} {rows cols : nat} (m : (@Matrix A rows cols)) :=
  rows.

Definition mat_num_cols {A : Type} {rows cols : nat} (m : (@Matrix A rows cols)) :=
  cols.

(** Testing Matrix Row/Cols
    - We want the establishment of matrices to have n = rows, m = cols
      so that they can be specified using a row by columns idea
*)
Definition tMat1 := nMatrix 2 3 (<[ 1 ; 2; 3]) eq_refl (nMatrix 1 3 (<[4;5;6]) eq_refl (mtMatrix 0 3 eq_refl)).
Example testTmat1_rows : mat_num_rows tMat1 = 2. reflexivity. Defined.
Example testTmat1_cols : mat_num_cols tMat1 = 3. reflexivity. Defined.

Fixpoint matrix_get_value_row {A : Type} {rows cols : nat} (mat : @Matrix A rows cols)
        (rowIndex : nat) : option (@Vector A _) :=
  match rowIndex with
  | 0 =>
      match mat with
      | mtMatrix _ _ _ => None
      | nMatrix rows' cols' curVec rowProof subMat =>
          Some curVec
      end
  | S ri' =>
      match mat with
      | mtMatrix _ _ _ => None
      | nMatrix rows' cols' curVec rowProof subMat =>
          matrix_get_value_row subMat ri'
      end
  end.

Definition matrix_get_value {A : Type} {rows cols : nat} (mat : @Matrix A rows cols)
        (rowInd colInd : nat) : option A :=
  match (matrix_get_value_row mat rowInd) with
  | None => None (* row index out of bounds*)
  | Some rowVec =>
      rowVec <@[colInd]
  end.

Lemma mgv_lt_r_c_some : forall {A : Type} {r c : nat} (m : @Matrix A r c)
  (rowInd colInd : nat),
  rowInd < r /\ colInd < c ->
  exists out,
    matrix_get_value m rowInd colInd = Some out.
Proof.
  induction m; smp; intros; subst; eauto.
  - inv H. lia.
  - destruct rowInd, colInd, H; unfold matrix_get_value in *; smp.
    * pose proof (@vgv_lt_len_some A cols 0 curRow); eauto.
    * pose proof (@vgv_lt_len_some A cols (S colInd) curRow); eauto.
    * eapply IHm; lia.
    * eapply IHm; lia.
Qed.

Lemma mgv_gt_r_c_none : forall {A : Type} {r c : nat} (m : @Matrix A r c)
    (rowInd colInd : nat),
  rowInd > r \/ colInd > c ->
  matrix_get_value m rowInd colInd = None.
Proof.
  induction m; smp; intros; subst; eauto.
  - unfold matrix_get_value; smp.
    destruct rowInd; eauto.
  - destruct rowInd, colInd, H; unfold matrix_get_value in *; smp; eauto;
    try lia;
    try (eapply vgv_gte_len_none; lia);
    try (eapply IHm; lia).
Qed.

Fixpoint matrix_set_value {A : Type} {rows cols : nat} (mat : @Matrix A rows cols)
        (rowInd colInd : nat) (newV : A) {struct mat} : (@Matrix A rows cols).

destruct rowInd eqn:RI.
- (* rowInd = 0 *)
  destruct mat eqn:MAT.
  * (* mat = mtMatrix *)
    apply mat.
  * (* mat = nMatrix rows cols curRow e m *)
    apply (nMatrix rows cols (curRow set<@[colInd] <- newV) e m).
    (* updating the row since we are at it (rowInd = 0 )*)
- (* rowInd = S n *)
  destruct mat eqn:MAT.
  * (* mat = mtMatrix *)
    apply mat.
  * (* mat = nMatrix rows cols curRow e m *)
    apply (nMatrix rows cols curRow e (matrix_set_value _ _ _ m n colInd newV)).
    (* recursive case, keep moving down rows *)
Defined.

(** Testing Matrix Get/Set
    - Want intuitive get/set functions
*)
Definition inVec := (<[ <[ 0 ; 1] ; <[ 2; 3] ; <[ 4; 5]]).
Definition tMat2 := nMatrix 3 2 (<[ 0 ; 1]) eq_refl (nMatrix 2 2 (<[ 2 ; 3]) eq_refl
  (nMatrix 1 2 (<[ 4 ; 5]) eq_refl (mtMatrix 0 2 eq_refl))).
(* Testing gets *)
Example testTmat2_get1 : matrix_get_value tMat2 0 0 = Some 0. reflexivity. Defined.
Example testTmat2_get2 : matrix_get_value tMat2 0 1 = Some 1. reflexivity. Defined.
Example testTmat2_get3 : matrix_get_value tMat2 1 0 = Some 2. reflexivity. Defined.
Example testTmat2_get4 : matrix_get_value tMat2 1 1 = Some 3. reflexivity. Defined.
Example testTmat2_get5 : matrix_get_value tMat2 2 0 = Some 4. reflexivity. Defined.
Example testTmat2_get6 : matrix_get_value tMat2 2 1 = Some 5. reflexivity. Defined.
(* Testing sets *)
Example testTmat2_set1 : matrix_set_value tMat2 0 0 42 =
  nMatrix 3 2 (<[ 42 ; 1]) eq_refl (
    nMatrix 2 2 (<[ 2 ; 3]) eq_refl (
      nMatrix 1 2 (<[ 4 ; 5]) eq_refl (
        mtMatrix 0 2 eq_refl
      )
    )
  ). reflexivity. Defined.
Example testTmat2_set2 : matrix_set_value tMat2 0 1 42 =
    nMatrix 3 2 (<[ 0 ; 42]) eq_refl (
    nMatrix 2 2 (<[ 2 ; 3]) eq_refl (
      nMatrix 1 2 (<[ 4 ; 5]) eq_refl (
        mtMatrix 0 2 eq_refl
      )
    )
  ). reflexivity. Defined.
Example testTmat2_set3 : matrix_set_value tMat2 1 0 42 =
    nMatrix 3 2 (<[ 0 ; 1]) eq_refl (
    nMatrix 2 2 (<[ 42 ; 3]) eq_refl (
      nMatrix 1 2 (<[ 4 ; 5]) eq_refl (
        mtMatrix 0 2 eq_refl
      )
    )
    ). reflexivity. Defined.
Example testTmat2_set4 : matrix_set_value tMat2 1 1 42 =
    nMatrix 3 2 (<[ 0 ; 1]) eq_refl (
    nMatrix 2 2 (<[ 2 ; 42]) eq_refl (
      nMatrix 1 2 (<[ 4 ; 5]) eq_refl (
        mtMatrix 0 2 eq_refl
      )
    )
  ). reflexivity. Defined.
Example testTmat2_set5 : matrix_set_value tMat2 2 0 42 =
    nMatrix 3 2 (<[ 0 ; 1]) eq_refl (
    nMatrix 2 2 (<[ 2 ; 3]) eq_refl (
      nMatrix 1 2 (<[ 42 ; 5]) eq_refl (
        mtMatrix 0 2 eq_refl
      )
    )
  ). reflexivity. Defined.
Example testTmat2_set6 : matrix_set_value tMat2 2 1 42 =
    nMatrix 3 2 (<[ 0 ; 1]) eq_refl (
    nMatrix 2 2 (<[ 2 ; 3]) eq_refl (
      nMatrix 1 2 (<[ 4 ; 42]) eq_refl (
        mtMatrix 0 2 eq_refl
      )
    )
  ). reflexivity. Defined.

Fixpoint default_matrix {A : Type} `{H : Defaultable A} (n : nat) (m : nat) : (@Matrix A n m).
destruct n.
- (* n = 0 (rows) *)
  apply (@mtMatrix A 0 m eq_refl).
- (* need Matrix (S n) m *)
  pose proof (default_matrix A H n m).
  pose proof (defaultable_vector m) as curRow.
  destruct curRow.
  apply (nMatrix (S n) m defVal eq_refl X).
Defined.

#[global]
Instance defaultable_matrix {A : Type} `{H : Defaultable A} (n : nat) (m : nat) : Defaultable (@Matrix A n m) :=
{
  defVal := default_matrix n m
}.

Fixpoint vec_of_vecs_to_matrix {A : Type} {rows cols : nat}
    (vVec : (@Vector (@Vector A cols) rows)) : (@Matrix A rows cols).
destruct vVec eqn:VEC.
- (* vVec = <[] *)
  apply (mtMatrix 0 cols eq_refl).
- (* vVec = x <:: v *)
  pose proof (vec_of_vecs_to_matrix A n cols v).
  apply (nMatrix (S n) cols x eq_refl X).
Defined.

Module MatrixNotations.
Declare Scope matrix_scope.
(* For constructing matrices from the vector vector more easily *)
Notation "'MAT' v" := (vec_of_vecs_to_matrix v) (at level 50) : matrix_scope.
(* For lookup *)
Notation "m @[ x ][ y ]" := (matrix_get_value m x y) (at level 70, right associativity) : matrix_scope.
(* For setting values *)
Notation "m set@[ x ][ y ] <- v" := (matrix_set_value m x y v) (at level 75, right associativity) :
matrix_scope.
Open Scope matrix_scope.
End MatrixNotations.

Import MatrixNotations.
Definition exampleMatrix : (@Matrix nat 2 2) :=
  (nMatrix 2 2 (<[ 1 ; 2 ]) eq_refl (nMatrix 1 2 (<[ 3; 4]) eq_refl (mtMatrix 0 2 eq_refl))).

Example em1test1 : (exampleMatrix @[1][1]) = Some 4. reflexivity. Defined.
Example em1test2 : (exampleMatrix @[0][1]) = Some 2. reflexivity. Defined.
Example vecGetTest : ((<[ 1 ; 2 ; 3]) <@[2]) = Some 3. reflexivity. Defined.
Example em1setTest : (exampleMatrix set@[1][1] <- 42) = (nMatrix 2 2 (<[ 1 ; 2 ]) eq_refl (nMatrix 1 2 (<[ 3; 42]) eq_refl (mtMatrix 0 2 eq_refl))). reflexivity. Defined.
Example defMatrices : ((@defaultable_matrix nat _ 3 3).(defVal))
  = (nMatrix 3 3 (<[ 0 ; 0 ; 0 ]) eq_refl (nMatrix 2 3 (<[ 0 ; 0 ; 0]) eq_refl (nMatrix 1 3 (<[ 0 ; 0 ;0 ]) eq_refl (mtMatrix 0 3 eq_refl)))). reflexivity. Defined.
(** Testing Matrix Notation
    - We want the matrix notation to make sense and be easy to use
*)
Definition tMat3 := (MAT <[ <[ 1 ; 2 ; 3] ; <[ 4 ; 5 ; 6] ; <[ 7 ; 8; 9]]).
(* Testing getters *)
Example testTmat3_get1 : tMat3 @[0][0] = Some 1. reflexivity. Defined.
Example testTmat3_get2 : tMat3 @[1][1] = Some 5. reflexivity. Defined.
Example testTmat3_get3 : tMat3 @[2][2] = Some 9. reflexivity. Defined.
Example testTmat3_get4 : tMat3 @[0][2] = Some 3. reflexivity. Defined.
Example testTmat3_get5 : tMat3 @[2][0] = Some 7. reflexivity. Defined.
(* Testing setters *)
Example testTmat3_set1 : (tMat3 set@[0][0] <- 42) =
(MAT <[ <[ 42 ; 2 ; 3] ; <[ 4 ; 5 ; 6] ; <[ 7 ; 8; 9]]). reflexivity. Defined.
Example testTmat3_set2 : (tMat3 set@[1][1] <- 42) =
(MAT <[ <[ 1 ; 2 ; 3] ; <[ 4 ; 42 ; 6] ; <[ 7 ; 8; 9]]). reflexivity. Defined.
Example testTmat3_set3 : (tMat3 set@[2][2] <- 42) =
(MAT <[ <[ 1 ; 2 ; 3] ; <[ 4 ; 5 ; 6] ; <[ 7 ; 8; 42]]). reflexivity. Defined.
Example testTmat3_set4 : (tMat3 set@[0][2] <- 42) =
(MAT <[ <[ 1 ; 2 ; 42] ; <[ 4 ; 5 ; 6] ; <[ 7 ; 8; 9]]). reflexivity. Defined.
Example testTmat3_set5 : (tMat3 set@[2][0] <- 42) =
(MAT <[ <[ 1 ; 2 ; 3] ; <[ 4 ; 5 ; 6] ; <[ 42 ; 8; 9]]). reflexivity. Defined.

Fixpoint eqb_matrix {A : Type} `{H : EqClass A}
    {rows1 cols1 rows2 cols2: nat}
    (m1 : (@Matrix A rows1 cols1))
    (m2 : (@Matrix A rows2 cols2)): bool :=
  match m1, m2 with
  | mtMatrix r1 c1 _, mtMatrix r2 c2 _ =>
      if (andb (eqb r1 r2) (eqb c1 c2))
      then (* if number of rows and cols eq *)
          true
      else false
  | nMatrix r1 c1 curR1 pf1 subM1, nMatrix r2 c2 curR2 pf2 subM2 =>
      if (andb (eqb r1 r2) (andb (eqb c1 c2) (eqb_vector curR1 curR2)))
      then (* rows, cols, and current row eq *)
          eqb_matrix subM1 subM2
      else false
  | _, _ => false
  end.

Example eqb_matrix_test1 :
eqb_matrix (MAT <[ <[ 1 ; 2] ; <[ 3 ; 4]]) (MAT <[ <[ 1; 2] ; <[3;4]]) = true. reflexivity. Defined.

Lemma eqb_matrix_refl : forall {A : Type} `{H : EqClass A} {n m : nat}
  (mat : (@Matrix A n m)),
  eqb_matrix mat mat = true.
Proof.
  induction mat; simpl; repeat (rewrite gen_deceq_eqb_refl); eauto.
  simpl. rewrite eqb_vector_refl. auto.
Qed.

Theorem eqb_matrix_same_length : forall {A : Type} {rows1 rows2 cols1 cols2 : nat}
  `{H : EqClass A}
  (m1 : (@Matrix A rows1 cols1)) (m2 : (@Matrix A rows2 cols2)),
    eqb_matrix m1 m2 = true ->
    rows1 = rows2 /\ cols1 = cols2.
Proof.
  induction m1; destruct m2; intros; inversion H0.
  - destruct (gen_deceq_eqb rows rows0) eqn:Req;
    destruct (gen_deceq_eqb cols cols0) eqn:Ceq;
    simpl in *; try congruence.
    apply gen_eqb_impl_eqb_leibniz in Req.
    apply gen_eqb_impl_eqb_leibniz in Ceq; eauto.
  - destruct (gen_deceq_eqb rows rows0) eqn:Req;
    destruct (gen_deceq_eqb cols cols0) eqn:Ceq;
    simpl in *; try congruence.
    apply gen_eqb_impl_eqb_leibniz in Req.
    apply gen_eqb_impl_eqb_leibniz in Ceq; eauto.
Qed.

Theorem eqb_matrix_works : forall {A : Type} `{H : EqClass A} {rows cols : nat}
  (m1 m2 : @Matrix A rows cols),
  eqb_matrix m1 m2 = true ->
  (forall (i j : nat),
    (m1 @[i][j]) = (m2 @[i][j])).
Proof.
  induction m1; destruct m2; eauto; intros; try inversion H0.
  unfold matrix_get_value.
  assert (gen_deceq_eqb rows rows = true). apply gen_eqb_impl_eqb_leibniz; auto.
  assert (gen_deceq_eqb cols cols = true). apply gen_eqb_impl_eqb_leibniz; auto.
  rewrite H1, H3 in *. simpl in H2.
  destruct (eqb_vector curRow curRow0) eqn:EQvec.
  - (* eqb_matrix m1 m2 = true *)
    assert (rows' = rows'0). lia. subst.
    pose proof (IHm1 m2 H2).
    unfold matrix_get_value in H4.
    destruct i.
    * (* i = 0 *)
      simpl. eapply eqb_vector_works. eauto.
    * (* i = S i *)
      simpl. eauto.
  - congruence.
Qed.

Module MatrixTypeClass.

(** UIP is needed here because the proofs embedded in each matrix
    are unable to be proven equal without it.
    This is a safe assumption to make here as eq_refl on nats will
    have unique identity proofs and should be considered roughly
    proof irrelevant
*)
Axiom uip : forall A (x y : A) (p q : x = y), p = q.

#[global]
Instance deceq_matrix {A : Type} `{H : EqClass A} {n m : nat} : DecEq (@Matrix A n m).
constructor.
induction x1; destruct x2; simpl in *.
- assert (e = e0). apply uip. subst. eauto.
- right. qcon.
- right. qcon.
- destruct (eqb curRow curRow0) eqn:Eqvec.
  * (* vecs eq *)
    rewrite eqb_leibniz in Eqvec. subst.
    assert (rows' = rows'0). lia. subst.
    specialize IHx1 with x2.
    destruct IHx1.
    ** (* rest eq *)
      subst. left.
      assert (eq_refl = e0). eapply uip.
      subst. eauto.
    ** (* rest neq *)
      right. qcon.
      exT H1. exT H1. congruence.
  * (* vecs neq *)
    rewrite neqb_leibniz in Eqvec.
    right. qcon. exT H2.
    congruence.
Defined.

#[global]
Instance eq_class_matrix {A : Type} `{H : EqClass A} {n m : nat} : EqClass (@Matrix A n m) :=
{
  eqb := gen_deceq_eqb ;
  eqb_leibniz := gen_eqb_impl_eqb_leibniz ;
  neqb_leibniz := gen_eqb_impl_neqb_leibniz ;
}.

End MatrixTypeClass.

Fixpoint matrix_entries {A : Type} {r c : nat} (m : @Matrix A r c) : list A :=
  match m with
  | mtMatrix _ _ _ => nil
  | nMatrix rows cols curRow rPrf subMat =>
      vec_to_list curRow ++ matrix_entries subMat
  end.

Example m_ent_1 : (matrix_entries (MAT <[ <[ 1;2] ; <[3;4]])) = [1;2;3;4].
reflexivity. Defined.

Example m_ent_2 : (matrix_entries (MAT <[ <[ 41;42;40] ; <[40;41;42]])) = [41;42;40;40;41;42].
reflexivity. Defined.

Lemma in_app_impl_or_in : forall {A : Type} (l1 l2 : list A) x,
  In x (l1 ++ l2) ->
  In x l1 \/ In x l2.
Proof.
  induction l1; smp; eauto; intros.
  dest H; eauto.
  eapply IHl1 in H. dest H; eauto.
Qed.
(*
Lemma matrix_column_height_change_get : forall {A : Type} {r c : nat}
  (m : @Matrix A r c) curRow ent x,
  forall (i j : nat), (nMatrix (S r) c curRow eq_refl m @[i][j] = Some ent) ->
    exists (i j : nat), (nMatrix (S r) (S c) (x <:: curRow) eq_refl m @[i][j] = Some ent). *)

Lemma in_impl_exists'' : forall {A : Type} {c : nat} (curRow : @Vector A c) ent,
  In ent (vec_to_list curRow) ->
  (exists (j : nat),
    curRow <@[j] = Some ent).
Proof.
  induction curRow; intros; smp; eauto.
  - inv H.
  - dest H; subst.
    * exists 0. refl.
    * eapply IHcurRow in H. dest H.
      exists (S x0); eauto.
Qed.

Lemma in_impl_exists' : forall {A : Type} {r c : nat} (curRow : @Vector A c) (m : @Matrix A r c) ent,
  In ent (vec_to_list curRow) ->
  exists (i j : nat), (nMatrix (S r) c curRow eq_refl m @[i][j] = Some ent).
Proof.
  induction curRow; intros; eauto.
  - inv H.
  - inv H; subst.
    * exists 0, 0. refl.
    * exists 0. unfold matrix_get_value. smp.
      pose proof (@in_impl_exists'' _ _ _ _ H0).
      dest H1. exists (S x0). eauto.
Qed.

Lemma in_impl_exists : forall {A : Type} {r c : nat} (m : @Matrix A r c) ent,
  In ent (matrix_entries m) ->
  exists (i j : nat), (m @[i][j] = Some ent).
Proof.
  induction m; intros; smp; eauto.
  - inv H.
  - apply in_app_impl_or_in in H. dest H.
    * (* in curRow *)
      dest (curRow); smp.
      ** inv H.
      ** eapply in_impl_exists'. eauto.
    * eapply IHm in H. dest H. dest H.
      exists (S x). exists x0.
      unfold matrix_get_value; smp. eauto.
Qed.

Lemma all_matrix_entries_in_matrix : forall {A : Type} {r c : nat} (m : @Matrix A r c) lm,
  matrix_entries m = lm ->
  (forall ent, In ent lm ->
      exists (i j : nat), m @[i][j] = Some ent).
Proof.
  intros. rewrite <- H in *.
  eapply in_impl_exists. eauto.
Qed.


From elpi Require Import elpi.
From HB Require Import structures.
From mathcomp Require Import all_ssreflect.

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

(**

----------------------------------------------------------
#
#
** Roadmap of the second lesson

  Playing with basic arithmetics

  - Order
  - Division
  - Primality

#
#
----------------------------------------------------------
*)

(**
----------------------------------------------------------
#
#
** Reminder

  Natural numbers

#
#
*)
Check nat.
(* nat : Set *)

Print nat.
(* Inductive nat : Set :=
   O : nat | S : nat -> nat *)

Check O.
(* 0 : nat *)

Check S O.
(* 1 : nat *)

Check S (S O).
(* 2 : nat *)

Check 2.+1.
(* 3 : nat *)

Set Printing All.
Check 4.
(* S (S (S O)) : nat *)

Unset Printing All.
Check 5.
(* 5 : nat *)

(**
#

#
----------------------------------------------------------
*)

(**
----------------------------------------------------------
#
#
** Reminder

  Proof by case

#
#
*)

Goal forall (P : pred nat),
     P 0 -> (forall n, P n.+1) -> forall n, P n.
Proof.
move=> P HP0 HPS n.
case: n => [|n].
  exact: HP0.
by apply: HPS.
Qed.

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Reminder

  Proof by induction

#
#
*)

Goal forall (P : pred nat),
     P 0 -> (forall n, P n -> P n.+1) -> forall n, P n.
Proof.
move=> P HP0 HPS n.
elim: n => [|n IH].
  exact: HP0.
by apply: HPS.
Qed.

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Reminder

  Eq type

#
#
*)

Check eqn.
(* eqn : nat -> nat -> bool *)

Print eqn.
(* fix eqn (m n : nat) {struct m} : bool :=
   match m with ... end. *)

Compute 1 == 1.
(* true : bool *)

Compute 2 == 3.
(* false : bool *)

Goal forall m n, m.+1 == n.+1 -> m == n.
Proof.
move=> m n mEn.
exact: mEn.
Qed.
(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural numbers

  Addition
#
#
*)

Check addn.
(* addn : nat -> nat -> nat *)

Check addn 2 3.
(* 2 + 3 : nat *)

Compute 2 + 3.
(* 5 : nat *)

Goal forall m n, m.+1 + n = (m + n).+1.
Proof.
move=> m n.
by [].
Qed.

Search (_.+1 + _ = _.+1) in ssrnat.
(*
add1n: forall n : nat, 1 + n = n.+1
addSn: forall m n : nat, m.+1 + n = (m + n).+1
add2n: forall m : nat, 2 + m = m.+2
add3n: forall m : nat, 3 + m = m.+3
add4n: forall m : nat, 4 + m = m.+4
*)

Goal forall m n, m + n.+1 = (m + n).+1.
Proof.
move=> m n.
elim: m => [|m IH].
  by [].
rewrite !addSn.
rewrite IH.
by [].
Qed.

Search (_ + _.+1 = _.+1) in ssrnat.
(*
addn1: forall n : nat, n + 1 = n.+1
addnS: forall m n : nat, m + n.+1 = (m + n).+1
addn2: forall m : nat, m + 2 = m.+2
addn3: forall m : nat, m + 3 = m.+3
addn4: forall m : nat, m + 4 = m.+4
*)

Search (_.+1 + _ = _ + _.+1) in ssrnat.
(* addSnnS: forall m n : nat, m.+1 + n = m + n.+1*)

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural Numbers
  Subtraction

#
#
*)

Check subn.
(* subn : nat -> nat -> nat *)

Check subn 3 2.
(* 3 - 2 : nat *)

Compute 3 - 2.
(* 1 : nat *)

Compute 3 - 4.
(* 0 : nat *)

Goal forall n, 0 - n = 0.
Proof.
move=> n.
by [].
Qed.

Search left_zero subn in ssrnat.
(* sub0n: left_zero 0 subn *)

Goal forall n, n - 0 = n.
Proof.
case => [|n].
- by [].
by [].
Qed.

Search (_.+1 - _.+1 = _) in ssrnat.
(* sub0n: left_zero 0 subn *)

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural Numbers
  Order

#
#
*)

Check leq.
(* nat -> nat -> bool *)

Check 0 <= 2.
(* 0 <= 2 : bool *)

Compute (0 <= 2).
(* true : bool *)

Print leq.
(* leq = fun m n : nat => m - n == 0
     : nat -> nat -> bool
*)

(**
#
#

  One definition several notations

#
#

*)

Goal forall m n, m >= n -> n <= m.
Proof.
by [].
Qed.

Goal forall m n, m.+1 <= n -> m < n.
Proof.
by [].
Qed.

Goal forall n, n <= n.+1.
Proof.
elim=> [|n IH].
  by [].
exact: IH.
Qed.

Search (?_1 <= ?_1.+1) in ssrnat.
(* eqnSn: forall n : nat, n <= n.+1 *)

(**
#
#

  Reflexivity

#
#

*)

Search (?_1 <= ?_1) in ssrnat.
(*
leqnn: forall n : nat, n <= n
ltnSn: forall n : nat, n < n.+1
*)

(**
#
#

  Antisymmetry

#
#

*)

Search (~~ _) (_ <= _) in ssrnat.
(*#
ltnNge: forall m n : nat, (m < n) = ~~ (n <= m)
leqNgt: forall m n : nat, (m <= n) = ~~ (n < m)
lt0n_neq0: forall [n : nat], 0 < n -> n != 0
ltnNleqif: forall [x y : nat] [C : bool], x <= y ?= iff ~~ C -> (x < y) = C
ltn_leqif: forall [a b : nat] [C : bool], a <= b ?= iff C -> (a < b) = ~~ C
lt0n: forall n : nat, (0 < n) = (n != 0)
eqn0Ngt: forall n : nat_eqType, (n == 0) = ~~ (0 < n)
contraNleq: forall [b : bool] [m n : nat], (n < m -> b) -> ~~ b -> m <= n
contra_leqT: forall [b : bool] [m n : nat], (~~ b -> m < n) -> n <= m -> b
contra_ltnT: forall [b : bool] [m n : nat], (~~ b -> m <= n) -> n < m -> b
contraTleq: forall [b : bool] [m n : nat], (n < m -> ~~ b) -> b -> m <= n
contraNltn: forall [b : bool] [m n : nat], (n <= m -> b) -> ~~ b -> m < n
contra_ltnN: forall [b : bool] [m n : nat], (b -> m <= n) -> n < m -> ~~ b
contraTltn: forall [b : bool] [m n : nat], (n <= m -> ~~ b) -> b -> m < n
contra_leqN: forall [b : bool] [m n : nat], (b -> m < n) -> n <= m -> ~~ b
#*)

Search (_ == _ = _) (_ <= _) in ssrnat.
(*#
subn_eq0: forall m n : nat, (m - n == 0) = (m <= n)
eqn0Ngt: forall n : nat_eqType, (n == 0) = ~~ (0 < n)
eqn_leq: forall m n : nat_eqType, (m == n) = (m <= n <= m)
ltn_eqF: forall [m n : nat], m < n -> (m == n) = false
gtn_eqF: forall [m n : nat], m < n -> (n == m) = false
neq0_lt0n: forall [n : nat_eqType], (n == 0) = false -> 0 < n
expn_eq0: forall m e : nat, (m ^ e == 0) = (m == 0) && (0 < e)
eqn_pmul2l: forall [m n1 n2 : nat], 0 < m -> (m * n1 == m * n2) = (n1 == n2)
eqn_exp2r: forall (m n : nat) [e : nat], 0 < e -> (m ^ e == n ^ e) = (m == n)
eqn_pmul2r: forall [m n1 n2 : nat], 0 < m -> (n1 * m == n2 * m) = (n1 == n2)
eqn_exp2l:
  forall [m : nat] (n1 n2 : nat), 1 < m -> (m ^ n1 == m ^ n2) = (n1 == n2)
#*)

(**
#
#

  Transitivity

#
#

*)

Search nat "trans" in ssrnat.
(*#
leq_trans: forall [n m p : nat], m <= n -> n <= p -> m <= p
leqif_trans:
  forall [m1 m2 m3 : nat] [C12 C23 : bool],
  m1 <= m2 ?= iff C12 -> m2 <= m3 ?= iff C23 -> m1 <= m3 ?= iff C12 && C23
leq_ltn_trans: forall [n m p : nat], m <= n -> n
 m < p
ltn_trans: forall [n m p : nat], m < n -> n
 m < p
#*)

Goal forall m n p, m < n -> n <= p -> m
 m n p.
have trans := leq_trans.
have trans_Sm_n := leq_trans (_ : m < n) (_ : n <= p).
by [].
Qed.

Goal forall (P : pred nat),
      P 0 ->
      (forall m,  (forall n, n <= m -> P n) -> P m.+1) ->
      (forall m, P m).
Proof.
move=> P HC IHs m.
move: (leqnn m).
move: {-2}m.
elim: m => [|m IH].
  by case.
case=> // n nLm.
apply: IHs => k kLn.
apply: IH.
apply: leq_trans kLn nLm.
Qed.

Goal forall a b c,
   a  b < c -> a <= c.
Proof.
move=> a b c aLb bLc.
apply: leq_trans (_ : b <= _).
  by apply: ltnW.
by apply: ltnW.
Qed.

(**
#
#

  Proof by case

#
#

*)

Goal forall (m : nat) (n : nat) (P : nat -> bool),
   (n <= m -> P n) -> (m < n -> P n) -> P n.
Proof.
move=> m n P LP GP.
case: (leqP n m).
  by apply: LP.
by apply: GP.
Qed.

Goal forall (m : nat) (n : nat) (P : nat -> bool),
   (n < m -> P n) -> (m < n -> P n) -> (n = m -> P n) -> P n.
Proof.
move=> m n P LP GP EP.
case: (ltngtP n m).
- by apply: LP.
- by apply: GP.
by apply: EP.
Qed.

Check leq_eqVlt.
(* leq_eqVlt
	 : forall m n : nat, (m <= n) = (m == n) || (m < n)
*)

Goal forall (P : pred nat) m n, P n ->
    (m < n -> P m) -> m <= n -> P m.
Proof.
move=> P m n Pn PL.
rewrite leq_eqVlt.
move=> /orP[|].
  move/eqP->.
  by [].
exact: PL.
Qed.

Goal forall (P : pred nat) m n, P n ->
    (m < n -> P m) -> m <= n -> P m.
Proof.
move=> P m n Pn GP.
case: ltngtP.
- move=> mLn _.
  by apply: GP.
- by [].
move=> -> _.
exact: Pn.
Qed.

(**
#
#

  Addition

#
#

*)

Search (_ <= _ + _) in ssrnat.
(*#
leq_addr: forall m n : nat, n <= n + m
leq_addl: forall m n : nat, n <= m + n
leq_add2r: forall p m n : nat, (m + p <= n + p) = (m <= n)
leq_add2l: forall p m n : nat, (p + m <= p + n) = (m <= n)
ltn_addl: forall [m n : nat] (p : nat), m < n -> m < p + n
leq_subLR: forall m n p : nat, (m - n <= p) = (m <= n + p)
ltn_addr: forall [m n : nat] (p : nat), m < n -> m < n + p
ltn_add2r: forall p m n : nat, (m + p < n + p) = (m < n)
ltn_add2l: forall p m n : nat, (p + m < p + n) = (m < n)
leq_add:
  forall [m1 m2 n1 n2 : nat], m1 <= n1 -> m2 <= n2 -> m1 + m2 <= n1 + n2
addn_gt0: forall m n : nat, (0 < m + n) = (0 < m) || (0 < n)
ltn_subLR: forall [m n : nat] (p : nat), n <= m -> (m - n < p) = (m < n + p)
ltn_psubLR: forall (m n : nat) [p : nat], 0
 (m - n < p) = (m < n + p)
#*)

Goal forall m n, n <= m -> n.*2 <= m + n.
Proof.
move=> m n nLm.
rewrite -addnn.
rewrite leq_add2r.
by [].
Qed.

(**
#
#

  Multiplication

#
#

*)

Search  _ (_ <= _ * _) in ssrnat.
(*#
leq_pmulr: forall (m : nat) [n : nat], 0 < n -> m <= m * n
leq_pmull: forall (m : nat) [n : nat], 0 < n -> m <= n * m
leq_mul:
  forall [m1 m2 n1 n2 : nat], m1 <= n1 -> m2 <= n2 -> m1 * m2 <= n1 * n2
ltn_Pmull: forall [m n : nat], 1 < n -> 0 < m -> m < n * m
ltn_Pmulr: forall [m n : nat], 1 < n -> 0 < m -> m < m * n
muln_gt0: forall m n : nat, (0 < m * n) = (0 < m) && (0 < n)
ltn_mul: forall [m1 m2 n1 n2 : nat], m1 < n1 -> m2 < n2 -> m1 * m2 < n1 * n2
leq_pmul2l: forall [m n1 n2 : nat], 0 < m -> (m * n1 <= m * n2) = (n1 <= n2)
leq_pmul2r: forall [m n1 n2 : nat], 0 < m -> (n1 * m <= n2 * m) = (n1 <= n2)
leq_mul2r: forall m n1 n2 : nat, (n1 * m <= n2 * m) = (m == 0) || (n1 <= n2)
leq_mul2l: forall m n1 n2 : nat, (m * n1 <= m * n2) = (m == 0) || (n1 <= n2)
ltn_mul2l: forall m n1 n2 : nat, (m * n1 < m * n2) = (0 < m) && (n1 < n2)
ltn_mul2r: forall m n1 n2 : nat, (n1 * m < n2 * m) = (0 < m) && (n1 < n2)
ltn_pmul2r: forall [m n1 n2 : nat], 0 < m -> (n1 * m < n2 * m) = (n1 < n2)
ltn_pmul2l: forall [m n1 n2 : nat], 0 < m -> (m * n1 < m * n2) = (n1 < n2)
#*)

Goal forall m n, n <= m -> n ^ 2 <= m * n.
Proof.
move=> m n nLm.
rewrite -mulnn.
rewrite leq_mul2r.
rewrite nLm.
rewrite orbT.
by [].
Qed.

(** Conditional comparison **)

Search (_ <= _ ?= iff _) (_ && _) in ssrnat.
(*#
eqif_trans:
  forall [m1 m2 m3 : nat] [C12 C23 : bool],
  m1 <= m2 ?= iff C12 -> m2 <= m3 ?= iff C23 -> m1 <= m3 ?= iff C12 && C23
leqif_add:
  forall [m1 n1 : nat] [C1 : bool] [m2 n2 : nat] [C2 : bool],
  m1 <= n1 ?= iff C1 ->
  m2 <= n2 ?= iff C2 -> m1 + m2 <= n1 + n2 ?= iff C1 && C2
leqif_mul:
  forall [m1 n1 : nat] [C1 : bool] [m2 n2 : nat] [C2 : bool],
  m1 <= n1 ?= iff C1 ->
  m2 <= n2 ?= iff C2 -> m1 * m2 <= n1 * n2 ?= iff (n1 * n2 == 0) || C1 && C2
#*)

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural Numbers

  Division

#
#
*)

Check (modn 21 2).
(* 21 %% 2 : nat *)

Compute 21 %% 2.
(* 1 : nat *)

Check (divn 21 2).
(* 21 %/ 2 : nat *)

Compute 21 %/ 2.
(* 10 : nat *)

Check (dvdn 2 21).

Compute 2 %| 21.

Print dvdn.
(*#
dvdn = fun d m : nat => m %% d == 0
	 : nat -> nat -> bool
#*)

Search (_ %| _ + _) in div.
(*#
dvdn_add: forall [d m n : nat], d %| m -> d %| n -> d %| m + n
dvdn_add_eq: forall [d m n : nat], d %| m + n -> (d %| m) = (d %| n)
dvdn_addl: forall [n d : nat] (m : nat), d %| n -> (d %| m + n) = (d %| m)
dvdn_addr: forall [m d : nat] (n : nat), d %| m -> (d %| m + n) = (d %| n)
Bezoutl:
  forall [m : nat] (n : nat),
  0 < m -> {a : nat | a < m & m %| gcdn m n + a * n}
Bezoutr:
  forall (m : nat) [n : nat],
  0 < n -> {a : nat | a < n & n %| gcdn m n + a * m}
#*)

Search ((_ + _) %/ _) in div.
(*#
divnDr:
  forall (m : nat) [n d : nat], d %| n -> (m + n) %/ d = m %/ d + n %/ d
divnDl:
  forall [m : nat] (n : nat) [d : nat],
  d %| m -> (m + n) %/ d = m %/ d + n %/ d
leq_divDl: forall p m n : nat, (m + n) %/ p <= m %/ p + n %/ p + 1
divnDMl: forall (q m : nat) [d : nat], 0 < d -> (m + q * d) %/ d = m %/ d + q
divnMDl: forall (q m : nat) [d : nat], 0 < d -> (q * d + m) %/ d = q + m %/ d
divnD:
  forall (m n : nat) [d : nat],
  0 < d -> (m + n) %/ d = m %/ d + n %/ d + (d <= m %% d + n %% d)
#*)

Search (?_1 %/ ?_1) in div.
(*# divnn: forall d : nat, d %/ d = (0 < d) #*)

Compute 0 %/ 0.
(*# 0 : nat #*)

Search (_ %| _ * _) in div.
(*#
dvdn_mulr: forall [d m : nat] (n : nat), d %| m -> d %| m * n
dvdn_mull: forall [d : nat] (m : nat) [n : nat], d %| n -> d %| m * n
dvdn_mul:
  forall [d1 d2 m1 m2 : nat], d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2
Gauss_dvdl:
  forall [m : nat] (n : nat) [p : nat],
  coprime m p -> (m %| n * p) = (m %| n)
Gauss_dvdr:
  forall [m n : nat] (p : nat), coprime m n -> (m %| n * p) = (m %| p)
dvdn_pmul2l: forall [p d m : nat], 0
 (p * d %| p * m) = (d %| m)
dvdn_pmul2r: forall [p d m : nat], 0
 (d * p %| m * p) = (d %| m)
dvdn_divLR:
  forall [p d : nat] (m : nat),
  0
 p %| d -> (d %/ p %| m) = (d %| m * p)
#*)

Search ((_ * _) %/ _) in div.
(*#
divnA: forall (m : nat) [n p : nat], p %| n -> m %/ (n %/ p) = (m * p) %/ n
muln_divA:
  forall [d : nat] (m : nat) [n : nat], d %| n -> m * (n %/ d) = (m * n) %/ d
divn_mulAC: forall [d m : nat] (n : nat), d %| m -> m %/ d * n = (m * n) %/ d
mulKn: forall (m : nat) [d : nat], 0 < d -> (d * m) %/ d = m
mulnK: forall (m : nat) [d : nat], 0 < d -> (m * d) %/ d = m
divnMl: forall [p m d : nat], 0
 (p * m) %/ (p * d) = m %/ d
divnMr: forall [p m d : nat], 0
 (m * p) %/ (d * p) = m %/ d
#*)

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural Numbers

  Odd

#
#
*)

Compute odd 4.
(* false : bool *)

Compute odd 5.
(* true : bool *)

Print odd.
(*
odd =
fix odd (n : nat) : bool :=
  match n with
  | 0 => false
  | n'.+1 => ~~ odd n'
  end
	 : nat -> bool
*)

Search odd (_ %% _) in div.
(*#
modn2: forall m : nat, m %% 2 = odd m
odd_mod: forall (m : nat) [d : nat], odd d = false -> odd (m %% d) = odd m
#*)

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural Numbers

  Gcd and Lcm

#
#
*)

Compute gcdn 42 49.
(* 7 : nat *)

Compute lcmn 42 49.
(* 294 : nat *)

Search gcdn lcmn in div.
(*
muln_lcm_gcd: forall m n : nat, lcmn m n * gcdn m n = m * n
*)

Search gcdn (_ * _) in div.
(*#
gcdnMr: forall n m : nat, gcdn n (n * m) = n
gcdnMl: forall n m : nat, gcdn n (m * n) = n
muln_lcm_gcd: forall m n : nat, lcmn m n * gcdn m n = m * n
gcdnMDl: forall k m n : nat, gcdn m (k * m + n) = gcdn m n
muln_divCA_gcd: forall n m : nat, n * (m %/ gcdn n m) = m * (n %/ gcdn n m)
Gauss_gcdl:
  forall [p : nat] (m : nat) [n : nat],
  coprime p n -> gcdn p (m * n) = gcdn p m
Gauss_gcdr:
  forall [p m : nat] (n : nat), coprime p m -> gcdn p (m * n) = gcdn p n
Bezoutl:
  forall [m : nat] (n : nat),
  0 < m -> {a : nat | a < m & m %| gcdn m n + a * n}
Bezoutr:
  forall (m : nat) [n : nat],
  0 < n -> {a : nat | a < n & n %| gcdn m n + a * m}
EgcdnSpec:
  forall [m n km kn : nat],
  km * m = kn * n + gcdn m n -> kn * gcdn m n < m -> egcdn_spec m n (km, kn)
#*)

(**
----------------------------------------------------------
#
#
#
#
*)

(**
----------------------------------------------------------
#
#
** Natural Numbers

  Coprime & Prime

#
#
*)

Check coprime.
(* coprime : nat -> nat -> bool *)

Compute coprime 3 5.
(* true : bool *)

Compute coprime 21 7.
(* false : true *)

Print coprime.
(*
coprime = fun m n : nat => gcdn m n == 1
	 : nat -> nat -> bool
*)

Search coprime (_ %| _) in div prime.
(*#
coprime_dvdr: forall [m n p : nat], m %| n -> coprime p n -> coprime p m
coprime_dvdl: forall [m n p : nat], m %| n -> coprime n p -> coprime m p
prime_coprime:
  forall [p : nat] (m : nat), prime p -> coprime p m = ~~ (p %| m)
Gauss_dvdr:
  forall [m n : nat] (p : nat), coprime m n -> (m %| n * p) = (m %| p)
Gauss_dvdl:
  forall [m : nat] (n : nat) [p : nat],
  coprime m p -> (m %| n * p) = (m %| n)
Gauss_dvd:
  forall [m n : nat] (p : nat),
  coprime m n -> (m * n %| p) = (m %| p) && (n %| p)
#*)

Check prime.
(* prime : nat -> bool *)

Compute prime 21.
(* false : bool *)

Compute prime 22.
(* false : bool *)

Compute prime 23.
(* true : bool *)

Print prime.
(*#
prime =
fun p : nat =>
match prime_decomp p with
| [:: (_, 1)]  => true
| _ => false
end     : nat -> bool
#*)

Compute primes 21.
(*# [:: 3, 7] : seq nat #*)
Compute primes 22.
(*# [:: 2; 11] : seq nat #*)

Compute primes 23.
(*# [:: 23] : seq nat #*)

Check primeP.
(*#
primeP
	 : reflect (1 < ?p /\ (forall d : nat, d %| ?p -> (d == 1) || (d == ?p)))
         (prime ?p)
#*)

Goal prime 2.
Proof.
apply/primeP.
split.
  by [].
move=> d.
case: d.
  by [].
case.
  by [].
by case.
Qed.

Search prime (_ %| _) in div prime.
(*#
Euclid_dvd1: forall [p : nat], prime p -> (p %| 1) = false
prime_coprime:
  forall [p : nat] (m : nat), prime p -> coprime p m = ~~ (p %| m)
dvdn_prime2: forall [p q : nat], prime p -> prime q -> (p %| q) = (p == q)
pdivP: forall [n : nat], 1 < n -> {p : nat | prime p & p %| n}
Euclid_dvdM:
  forall (m n : nat) [p : nat],
  prime p -> (p %| m * n) = (p %| m) || (p %| n)
p'natE: forall [p : nat] (n : nat), prime p -> (p^').-nat n = ~~ (p %| n)
Euclid_dvdX:
  forall (m n : nat) [p : nat], prime p -> (p %| m ^ n) = (p %| m) && (0 < n)
dvdn_pfactor:
  forall [p : nat] (d n : nat),
  prime p -> reflect (exists2 m : nat, m <= n & d = p ^ m) (d %| p ^ n)
lognE:
  forall p m : nat,
  logn p m =
  (if [&& prime p, 0 < m & p %| m] then (logn p (m %/ p)).+1 else 0)
pfactor_dvdn:
  forall [p : nat] (n : nat) [m : nat],
  prime p -> 0 < m -> (p ^ n %| m) = (n <= logn p m)
prime_nt_dvdP:
  forall [d : nat_eqType] [p : nat],
  prime p -> d != 1 -> reflect (d = p) (d %| p)
pnatP:
  forall (pi : nat_pred) [n : nat],
  0 < n ->
  reflect (forall p : nat, prime p -> p %| n -> p \in pi) (pi.-nat n)
mem_primes:
  forall (p : nat_eqType) (n : nat),
  (p \in primes n) = [&& prime p, 0 < n & p %| n]
primePn:
  forall {n : nat},
  reflect (n < 2 \/ (exists2 d : nat, 1 < d < n & d %| n)) (~~ prime n)
logn_count_dvd:
  forall [p : nat] (n : nat),
  prime p -> logn p n = \sum_(1 <= k < n) (p ^ k %| n)
primePns:
  forall {n : nat},
  reflect (n < 2 \/ (exists p : nat, [/\ prime p, p ^ 2 <= n & p %| n]))
	(~~ prime n)
primeP:
  forall {p : nat},
  reflect (1
 xpred2 1 p d)) (prime p)
Euclid_dvd_prod:
  forall [I : Type] (r : seq I) (P : pred I) (f : I -> nat) [p : nat],
  prime p ->
  (p %| \prod_(i <- r | P i) f i) = \big[orb/false]_(i <- r | P i) (p %| f i)
mem_prime_decomp:
  forall [n : nat] [p e : nat_eqType],
  (p, e) \in prime_decomp n -> [/\ prime p, 0 < e & p ^ e %| n]
#*)

Check logn.
(* logn : nat -> nat -> nat*)

Compute logn 3 8.
(* 0 : nat *)
Compute logn 3 9.
(* 2 : nat *)

Search logn in prime.
(*#
logn0: forall p : nat, logn p 0 = 0
logn1: forall p : nat, logn p 1 = 0
pfactor_dvdnn: forall p n : nat, p ^ logn p n %| n
logn_part: forall p m : nat, logn p m`_p = logn p m
logn_coprime: forall [p m : nat], coprime p m -> logn p m = 0
lognX: forall p m n : nat, logn p (m ^ n) = n * logn p m
p_part: forall p n : nat, n`_p = p ^ logn p n
pfactorK: forall [p : nat] (n : nat), prime p -> logn p (p ^ n) = n
pfactor_gt0: forall p n : nat, 0 < p ^ logn p n
ltn_logl: forall (p : nat) [n : nat], 0 < n -> logn p n < n
ltn_log0: forall [p n : nat], n
 logn p n = 0
logn_Gauss:
  forall [p m : nat] (n : nat), coprime p m -> logn p (m * n) = logn p n
pfactorKpdiv:
  forall [p : nat] (n : nat), prime p -> logn (pdiv (p ^ n)) (p ^ n) = n
logn_prime: forall (p : nat) [q : nat], prime q -> logn p q = (p == q)
logn_div:
  forall (p : nat) [m n : nat],
  m %| n -> logn p (n %/ m) = logn p n - logn p m
dvdn_leq_log:
  forall (p : nat) [m n : nat], 0 < n -> m %| n -> logn p m <= logn p n
prime_decompE:
  forall n : nat, prime_decomp n = [seq (p, logn p n) | p <- primes n]
eqn_from_log:
  forall [m n : nat], 0 < m -> 0 < n -> logn^~ m =1 logn^~ n -> m = n
logn_gt0: forall p n : nat, (0 < logn p n) = (p \in primes n)
lognE:
  forall p m : nat,
  logn p m =
  (if [&& prime p, 0 < m & p %| m] then (logn p (m %/ p)).+1 else 0)
logn_lcm:
  forall (p : nat) [m n : nat],
  0 < m -> 0 < n -> logn p (lcmn m n) = maxn (logn p m) (logn p n)
lognM:
  forall (p : nat) [m n : nat],
  0 < m -> 0 < n -> logn p (m * n) = logn p m + logn p n
logn_gcd:
  forall (p : nat) [m n : nat],
  0 < m -> 0 < n -> logn p (gcdn m n) = minn (logn p m) (logn p n)
pfactor_dvdn:
  forall [p : nat] (n : nat) [m : nat],
  prime p -> 0 < m -> (p ^ n %| m) = (n <= logn p m)
pfactor_coprime:
  forall [p n : nat],
  prime p -> 0 < n -> {m : nat | coprime p m & n = m * p ^ logn p n}
logn_count_dvd:
  forall [p : nat] (n : nat),
  prime p -> logn p n = \sum_(1 <= k < n) (p ^ k %| n)
totientE:
  forall [n : nat],
  0 < n -> totient n = \prod_(p <- primes n) (p.-1 * p ^ (logn p n).-1)
widen_partn:
  forall [m : nat] (pi : nat_pred) [n : nat],
  n <= m -> n`_pi = \prod_(0 <= p < m.+1 | p \in pi) p ^ logn p n
eq_partn_from_log:
  forall [m n : nat] [pi : nat_pred],
  0 < m -> 0 < n -> {in pi, logn^~ m =1 logn^~ n} -> m`_pi = n`_pi
#*)

(**
----------------------------------------------------------
#
#
#
#
*)


Inductive bird : Set :=
  | app : bird -> bird -> bird.

Module thm_9_3.

  Variable A : bird. (* 同調鳥を示す変数 *)

  (*
    合成鳥の存在を示すのと同値な仮定
    (鳥の合成ルールを示す仮定)
  *)
  Hypothesis Hc : forall (A B x : bird), app A (app B x) = app (app A B) x.

  (* 同調鳥の性質を示す仮定 *)
  Hypothesis Ha : forall (B : bird), (exists (x' : bird), app A x' = app B x').
  Hypothesis Ha' : forall (x : bird), (exists (x' : bird), app A x' = app (app x A) x').
  (*
    Coqの証明で、HaからHa'を導く手順がわからなかったため、
    今回は手動でHa'を作成し、Ha'を使って証明。
  *)

  Theorem thm_9_3 :
    forall (P : bird),
      exists (x : bird), app P x = x.
    (*
      結論：
      任意の P について、ある x が存在して、 P x = x となる。
    *)
  Proof.
    intros P.
    destruct Ha' with (x := P) as [x' Ha''].
    exists (app A x').
    rewrite Hc with (A := P) (B := A) (x := x').
    rewrite Ha''.
    reflexivity.
  Qed.

  From mathcomp
  Require Import ssreflect.

  Theorem thm_9_3_ssr :
    forall (P : bird),
      exists (x : bird), app P x = x.
  Proof.
    move=> P.
    case Ha' with (x := P) => [x' Ha''].
    exists (app A x').
    rewrite Hc.
    rewrite Ha''.
    done.
  Qed.

End thm_9_3.


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

Require Import
        List
        Finite.FiniteType
        Tactics.Tactics.

Import ListNotations.

(** definition of a DFA *)

Section DFA.
  Variable sigma : finType.

  Definition word := list sigma.
  Definition epsilon : word := (@nil sigma).

  Record dfa : Type
    := DFA {
        S :> finType      (** state set      *)
      ; s : S             (** starting state *)
      ; F : dec_pred S    (** final state predicate *)
      ; d : S -> sigma -> S (** transition function *)
      }.

  Section ACCEPT.
    Variable M : dfa.

  (** extended transition function *)

    Fixpoint d_star (q : M)(w : word) :=
      match w with
      | [] => q
      | c :: w' => d_star (d q c) w'
      end.

    Definition accept (w : word) := F (@d_star s w).

    Instance accept_dec w : dec (accept w).
    Proof.
      auto.
    Defined.

    Inductive reach (q : M) : M -> Prop :=
    | Refl : reach q q
    | Step q' c : reach (d q c) q' -> reach q q'.

    Hint Constructors reach.

    Definition reach_with q w q' := d_star q w = q'.

    Lemma reach_is_reach_with (q q' : M) : reach q q' <-> exists w, reach_with q w q'.
    Proof.
      split.
      +
        intros H ; induction H ; crush.
        -
          now exists epsilon.
        -
          exists (c :: x) ; crush.
      +
        intros [w H]. revert q H ; induction w ; intros q H ; crush.
        -
          econstructor 2.
          apply IHw.
          apply H.
    Qed.

    Hint Resolve reach_is_reach_with.

    Lemma reach_transitive (q : M ) q' q'': reach q q' /\ reach q' q'' -> reach q q''.
    Proof.
      intros [R R']. induction R ; eauto.
    Qed.

    Lemma reach_d_star q w: reach q (d_star q w).
    Proof.
      apply reach_is_reach_with. now exists w.
    Qed.

    Definition step_reach (states : list M)(q : M)
      := exists q' x, q' el states /\ reach_with q' [x] q.

    Lemma step_reach_consistent: step_consistent step_reach.
    Proof.
      intros B q H B' sub.
      destruct H as [q' [x [E R]]].
      exists* q' x.
    Qed.

    Definition reachable_states (q : M) := finite_iter step_reach [q].

    Lemma reachable_states_least_fp q
      : least_fp_containing (finite_iter_step step_reach)
                            (reachable_states q) [q].
    Proof.
      apply step_consistent_least_fp.
      apply step_reach_consistent.
    Qed.

    Lemma reachable_states_correct1 (q : M) : inclp (reachable_states q) (reach q).
    Proof.
      apply finite_iter_ind.
      -
        intros x ; crush.
      -
        intros set q' H [q'' [x [E H1]]] ; eapply reach_transitive ; split.
        +
          apply (H _ E).
        +
          apply reach_is_reach_with.
          exists* [x].
    Qed.

    Lemma reachable_states_correct2' q q' : q' el reachable_states q ->
                                 forall q'', reach q' q'' -> q'' el reachable_states q.
    Proof.
      intros E q'' H ; induction H ; crush.
      -
        apply IHreach. apply closure_finite_iter. now exists* q0 c.
    Qed.

    Lemma reachable_states_correct2 q: forall q', reach q q' -> q' el reachable_states q.
    Proof.
      apply reachable_states_correct2'. apply preservation_finite_iter ; crush.
    Qed.

    Lemma reachable_states_correct q q' : reach q q' <-> q' el (reachable_states q).
    Proof.
      split ; [ apply reachable_states_correct2
              | apply reachable_states_correct1].
    Qed.

    Global Instance reach_dec q q': dec (reach q q').
    Proof.
      eapply dec_prop_iff.
      -
        symmetry. apply reachable_states_correct.
      - auto.
    Qed.

    Global Instance reach_with_something_dec q q' : dec (exists w, reach_with q w q').
    Proof.
      apply dec_prop_iff with (X := reach q q') ; eauto.
    Qed.

    Lemma reachable_states_reach_with q q'
      : (exists w, reach_with q w q') <-> q' el reachable_states q.
    Proof.
      rewrite <- reach_is_reach_with.  apply reachable_states_correct.
    Qed.

    Lemma d_star_reachable_states w q : d_star q w el (reachable_states q).
    Proof.
      apply reachable_states_reach_with. now exists w.
    Qed.

    Notation in_lang w := (accept w) (only parsing).

    (** accepting all words in sigma* *)

    Lemma accepts_sigma_star_if_all_states_final
      : (forall w, in_lang w) <-> forall q : M, q el (reachable_states s) -> F q.
    Proof.
      split.
      -
        intros H q Hel.
        rewrite <- reachable_states_reach_with in Hel.
        destruct Hel as [w Hw]. unfolds in Hw.
        rewrite <- Hw. apply (H w).
      -
        intros H w. apply (H (d_star s w)). apply d_star_reachable_states.
    Qed.

    Global Instance accepts_sigma_star_dec : dec (forall w, in_lang w).
    Proof.
      decide( forall q, q el reachable_states s -> F q) as [H | H].
      - left. now apply accepts_sigma_star_if_all_states_final.
      - right. now rewrite accepts_sigma_star_if_all_states_final.
    Defined.

    (** rejecting all words, empty language *)

    Definition empty := forall w, ~ in_lang w.

    Definition negate_final_states := DecPred (fun x => ~ (@F M x)).

    Definition complement := DFA s negate_final_states (@d M).
  End ACCEPT.

  Notation in_lang A w := (accept A w) (only parsing).

  Section OPERATIONS.
    Variable M : dfa.

    Lemma complement_correct w : accept (complement M) w <-> ~ (accept M w).
    Proof.
      splits*.
    Qed.

    Global Instance empty_dec : dec (empty M).
    Proof.
      apply (dec_trans (@accepts_sigma_star_dec (complement M))).
      now setoid_rewrite complement_correct.
    Qed.

    Lemma empty_reachable_states
      : empty M <-> forall (q : M), q el (reachable_states s) -> ~ (F q).
    Proof.
      split.
      - intros empt q E F . rewrite <- reachable_states_reach_with in E.
        destruct E as [w R].
        specialize (empt w). apply empt. unfold accept. now rewrite R.
      - intros H w acc. specialize (H (d_star s w)). apply H.
        + apply d_star_reachable_states.
        + exact acc.
    Qed.

    Instance exists_accept_dec: dec (exists w, accept M w).
    Proof.
      decide (empty M) as [H | H].
      - firstorder.
      - left. unfold empty in H.  rewrite empty_reachable_states in H.
        rewrite DM_notAll in H.
        + destruct H as [q H]. destruct (dec_DM_impl _ _ H) as [H' acc].
          rewrite <- reachable_states_reach_with in H'.
          destruct H' as [w R]. exists w.  rewrite <- R in acc.
          apply dec_DN; auto.
        + auto.
    Qed.

    Instance exists_not_accept_dec : dec (exists w, ~ accept M w).
    Proof.
      decide (forall w, accept M w) as [H | H].
      - right. firstorder.
      - left. rewrite accepts_sigma_star_if_all_states_final in H.
        rewrite DM_notAll in H.
        + destruct H as [q H].  destruct (dec_DM_impl _ _ H) as [H' acc].
          rewrite <- reachable_states_reach_with in H'.
          destruct H' as [w R]. exists w.  now rewrite <- R in acc.
        + auto.
    Qed.
End OPERATIONS.

    (** DFA recognizing epsilon *)

Definition Epsilon_autom : dfa.
Proof.
  refine (DFA (inl tt)
              (DecPred (fun q: unit + unit => if q then True else False))
              (fun _ _ => inr tt)).
  intros [[]|[]]; auto.
Defined.

Lemma inr_fix_epsilon w : (@d_star Epsilon_autom (inr tt) w) = inr tt.
Proof.
  now induction w.
Qed.

Lemma Epsilon_autom_correct w: accept Epsilon_autom w <-> w = nil.
Proof.
  split.
  - cbn. destruct w.
    + reflexivity.
    + cbn. now rewrite inr_fix_epsilon.
  - intros H. subst w. cbn. exact I.
Qed.

(** DFA for a symbol x *)

Definition F_cons (M : dfa) (q : option M + unit) :=
  match q with
  | inl None => False
  | inl (Some q) => F q
  | inr tt => False
  end.

Definition d_cons x (M : dfa)
           (q : option M + unit) y  :=
  match q with
  | inl None => if decision (y = x) then inl (Some s) else inr tt
  | inl (Some q) => inl (Some (d q y))
  | inr tt => inr tt
  end.

Instance F_cons_dec  (M : dfa) (q : option M + unit) : dec (F_cons q).
Proof.
  destruct q.
  - destruct o ; auto.
  - destruct u ; auto.
Qed.

Definition cons (M : dfa) (x : sigma) :=
  DFA (inl None) (DecPred (@F_cons M)) (@d_cons x M).

Lemma inr_fix M x w : (@d_star (cons M x) (inr tt) w) = inr tt.
Proof.
  now induction w.
Qed.

Lemma cons_correct  (M : dfa) x w : accept M w <-> accept (cons M x) (x::w).
Proof.
  cbn in *. deq x. unfold accept. generalize (@s M).  induction w; firstorder.
Qed.

(** word automata *)

Fixpoint word_dfa (w : word) : dfa :=
  match w with
  | [] => Epsilon_autom
  | x :: xs => cons (word_dfa xs) x
  end.

Lemma word_dfa_correct : forall w, accept (word_dfa w) w.
Proof.
  induction w ; try now auto.
  -
    simpl.
    now rewrite <- cons_correct.
Qed.

End DFA.


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

(**
  ----
  ** Exercise 1 *)

(**
Try to define a next function over 'I_n that correspond to the
successor function over the natural plus the special case that
"n -1" is mapped to zero *)

Definition onext n (x : 'I_n) : 'I_n.
Proof.
refine (
(* Sub takes two arguments *)
  Sub
(* Write the valued in the following line *)
(*D*)(x.+1 %% n)
(* Leave _ for the proof, you will fill it in by tactics later *)
_
).
(*D*) by case: x => [m /= ltmn]; rewrite ltn_mod (leq_trans _ ltmn).
Defined.

Eval compute in val (onext (Ordinal (isT : 2 < 4))).
Eval compute in val (onext (Ordinal (isT : 3 < 4))).

(**
  ----
  ** Exercise 2
*)

(**
   Show that injectivity is decidable for a function f : aT -> rT
   with  aT a finite
*)

Module MyInj.

Check injective.

Definition injectiveb (aT : finType) (rT : eqType) (f : aT -> rT) : bool :=
(*D*) [forall x : aT, forall y : aT, (f x == f y) ==> (x == y)].

Lemma injectiveP (aT : finType) (rT : eqType) (f : aT -> rT) :
  reflect (injective f) (injectiveb f).
Proof.
(*D*)apply: (iffP forallP) => [Ibf x y Efxy|If x].
(*D*)  by move: Ibf => /(_ x) /forallP /(_ y); rewrite Efxy eqxx => /eqP.
(*D*)by apply/forallP=> y; apply/implyP => /eqP Efxy; apply/eqP; apply: If.
(*A*)Qed.

End MyInj.

(**
  ----
  ** Exercise 3

  Build a function that maps an element of an ordinal to another element
  of the same ordinal with a p subtracted from it.
*)

Lemma neg_offset_ord_proof n (i : 'I_n) (p : nat) : i - p < n.
Proof.
(*D*)apply: leq_ltn_trans (ltn_ord i).
(*D*)apply: leq_subr.
(*A*)Qed.

Definition neg_offset_ord n (i : 'I_n) p := Ordinal (neg_offset_ord_proof i p).

Eval compute in (val (neg_offset_ord (Ordinal (isT : 7 < 9)) 4)).

(**
  ----
  ** Exercise 4
*)

(**
   Try to formalize the following problem
*)

(**
  Given a parking  where the boolean indicates if the slot is occupied or not
*)

Definition parking n := 'I_n -> 'I_n -> bool.

(**
   Number of cars at line i
*)

Definition sumL n (p : parking n) i := \sum_(j < n) p i j.

(**
   Number of cars at column j
*)

Definition sumC n (p : parking n) j := \sum_(i < n) p i j.

(**
   Show that if 0 < n there is always two lines, or two columns, or a column and a line
   that have the same numbers of cars
*)

(* Two intermediate lemmas to use injectivity  *)

Lemma leq_sumL n (p : parking n) i : sumL p i < n.+1.
Proof.
(*D*)have {2}<-: \sum_(i < n) 1 = n by rewrite -[X in _ = X]card_ord sum1_card.
(*D*)by apply: leq_sum => k; case: (p _ _).
(*A*)Qed.

Lemma leq_sumC n (p : parking n) j : sumC p j < n.+1.
Proof.
(*D*)have {2}<-: \sum_(i < n) 1 = n by rewrite -[X in _ = X]card_ord sum1_card.
(*D*)by apply: leq_sum => k; case: (p _ _).
(*A*)Qed.

Lemma inl_inj {A B} : injective (@inl A B). Proof. by move=> x y []. Qed.
Lemma inr_inj {A B} : injective (@inr A B). Proof. by move=> x y []. Qed.

Lemma result n (p : parking n) : 0 < n ->
  exists i, exists j,
   [\/  (i != j) /\ (sumL p i = sumL p j),
        (i != j) /\ (sumC p i = sumC p j) | sumL p i = sumC p j].
Proof.
(*D*)case: n p => [//|[|n]] p _ /=.
(*D*)  exists ord0, ord0; apply: Or33.
(*D*)  by rewrite /sumL /sumC !big_ord_recl !big_ord0.
(*D*)pose sLC (i : 'I_n.+2 + 'I_n.+2) :=
(*D*)  match i with
(*D*)  | inl i => Ordinal (leq_sumL p i)
(*D*)  | inr i => Ordinal (leq_sumC p i) end.
(*D*)have [sC_inj | /injectivePn /=] := altP (injectiveP sLC).
(*D*)  have := max_card (mem (codom sLC)); rewrite card_codom // card_sum !card_ord.
(*D*)  by rewrite !addnS !addSn !ltnS -ltn_subRL subnn ltn0.
(*D*)move=> [[i|i] [[j|j] //=]]; [| |move: i j => j i|];
(*D*)rewrite ?(inj_eq inj_inl, inj_eq inj_inr) => neq_ij [];
(*D*)by exists i, j; do ?[exact: Or31|exact: Or32|exact: Or33].
(*A*)Qed.

(**
  ----
  ** Exercise 5
*)

(**
   Prove the following state by induction and by following Gauss proof.
 *)

Lemma gauss_ex_p1 : forall n, (\sum_(i < n) i).*2 = n * n.-1.
Proof.
(*D*)elim=> [|n IH]; first by rewrite big_ord0.
(*D*)rewrite big_ord_recr /= doubleD {}IH.
(*D*)case: n => [|n /=]; first by rewrite muln0.
(*D*)by rewrite -muln2 -mulnDr addn2 mulnC.
(*A*)Qed.

Lemma gauss_ex_p2 : forall n, (\sum_(i < n) i).*2 = n * n.-1.
Proof.
(*D*)case=> [|n/=]; first by rewrite big_ord0.
(*D*)rewrite -addnn.
(*D*)have Hf i : n - i < n.+1.
(*D*)  by apply: leq_trans (leq_subr _ _) _.
(*D*)pose f (i : 'I_n.+1) := Ordinal (Hf i).
(*D*)have f_inj : injective f.
(*D*)  move=> x y /val_eqP/eqP H.
(*D*)  apply/val_eqP => /=.
(*D*)  rewrite -(eqn_add2l (n - x)) subnK -1?ltnS  //.
(*D*)  by rewrite [n - x]H subnK -1?ltnS.
(*D*)rewrite {1}(reindex_inj f_inj) -big_split /=.
(*D*)rewrite -[X in _ = X * _]card_ord -sum_nat_const.
(*D*)by apply: eq_bigr => i _; rewrite subnK // -ltnS.
(*A*)Qed.

Lemma gauss_ex_p3 : forall n, (\sum_(i < n) i).*2 = n * n.-1.
Proof.
(*D*)case=> [|n/=]; first by rewrite big_ord0.
(*D*)rewrite -addnn {1}(reindex_inj rev_ord_inj) -big_split /=.
(*D*)rewrite -[X in _ = X * _]card_ord -sum_nat_const.
(*D*)by apply: eq_bigr => i _; rewrite subSS subnK // -ltnS.
(*A*)Qed.

(**
  ----
   ** Exercise 6
*)

Lemma sum_odd1 : forall n, \sum_(i < n) (2 * i + 1) = n ^ 2.
Proof.
(*D*)case=> [|n/=]; first by rewrite big_ord0.
(*D*)rewrite big_split -big_distrr /= mul2n gauss_ex_p3 sum_nat_const.
(*D*)by rewrite card_ord -mulnDr addn1 mulnn.
(*A*)Qed.

(**
  ----
  ** Exercise 7
*)

Lemma sum_exp : forall x n, x ^ n.+1 - 1 = (x - 1) * \sum_(i < n.+1) x ^ i.
Proof.
(*D*)move=> x n.
(*D*)rewrite mulnBl big_distrr mul1n /=.
(*D*)rewrite big_ord_recr [X in _ = _ - X]big_ord_recl /=.
(*D*)rewrite [X in _ = _ - (_ + X)](eq_bigr (fun i : 'I_n =>  x * x ^ i))
(*D*)      => [|i _]; last by rewrite -expnS.
(*D*)rewrite [X in _ = X - _]addnC [X in _ = _ - X]addnC subnDA addnK.
(*D*)by rewrite expnS expn0.
(*A*)Qed.

(**
  ----
 ** Exercise 8
*)

(** Prove the following state by induction and by using a similar trick
   as for Gauss noticing that n ^ 3 = n * (n ^ 2) *)

Lemma bound_square : forall n, \sum_(i < n) i ^ 2 <= n ^ 3.
Proof.
(*D*)move=> n.
(*D*)rewrite expnS -[X in _ <= X * _]card_ord -sum_nat_const /=.
(*D*)elim/big_ind2: _ => // [* |i]; first exact: leq_add.
(*D*)by rewrite leq_exp2r // ltnW.
(*A*)Qed.

(**
  ----
  ** Exercise 9

  Prove the following statement using only big operator theorems.
  [big_cat_nat], [big_nat_cond], [big_mkcondl], [big1]
*)
Lemma sum_prefix_0 (f : nat -> nat) n m : n <= m ->
  (forall k, k < n -> f k = 0) ->
  \sum_(0 <= i < m) f i = \sum_(n <= i < m) f i.
Proof.
(*D*)pose H := big_cat_nat.
(*D*)move => nm f0; rewrite (big_cat_nat addn_monoid _ f (leq0n n)) /=; last by [].
(*D*)rewrite big_nat_cond big_mkcondl big1 ?add0n //.
(*D*)move => i _; case cnd : (0 <= i < n) => //.
(*D*)apply: f0.
(*D*)by move/andP: cnd => [_ it].
(*A*)Qed.

(**
  ----
  ** Exercise 10
*)

(**
  building a monoid law
*)

Section cex.

Variable op2 : nat -> nat -> nat.

Hypothesis op2n0 : right_id 0 op2.

Hypothesis op20n : left_id 0 op2.

Hypothesis op2A : associative op2.

Hypothesis op2add : forall x y, op2 x y = x + y.

Canonical Structure op2Mon : Monoid.law 0 :=
  Monoid.Law op2A op20n op2n0.

Lemma ex_op2 : \big[op2/0]_(i < 3) i = 3.
Proof.
(*D*)by rewrite !big_ord_recr big_ord0 /= !op2add.
(*A*)Qed.

End cex.


(* Exercise coq_list_06 *)

(* Those are the definitions from the previous exercise: *)

Inductive natlist : Set :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Fixpoint append (l m : natlist) {struct l} : natlist :=
  match l with
  | nil => m
  | cons x xs => cons x (append xs m)
  end.

Fixpoint length (l : natlist) : nat :=
match l with
  nil => 0
 | cons a k => S(length k)
end.
 (* copy your definition from the previous exercise here *)

Fixpoint reverse (l : natlist) : natlist :=
match l with
 nil => nil
 | cons a k => append (reverse k) (cons a nil)
end.

 (* copy your definition from the previous exercise here *)

(* Now let us prove that reverse does not change the length
   of a list *)

(* For this we may need a result proven in one of the previous
   exercises and some results about natural numbers (remember
   the exercises concerning natural numbers?) *)
Axiom append_length : forall l m,
  length (append l m) = length l + length m.
Require Import Arith.

Search (?n + 1).

Lemma reverse_length : forall l,
  length l = length (reverse l).

Proof.
  intros.
  induction l.
  simpl; reflexivity.
  simpl.
  rewrite append_length.
  simpl.
  rewrite Nat.add_1_r.
  rewrite IHl.
  reflexivity.
Qed.


(* 1 *)
Example a :
  (True \/ False) /\ (False \/ True).
Proof.
  split.
  - left. apply I.
  - right. apply I.
Qed.

Example b : forall P : Prop,
  P -> not (not P).
Proof.
  intros P H H0. apply H0. apply H.
Qed.

Example c : forall P Q R : Prop,
  P /\ (Q \/ R) -> (P /\ Q) \/ (P /\ R).
Proof.
  intros P Q R [H1 H2]. destruct H2.
  - left. split; assumption.
  - right. split; assumption.
Qed.

(* 2 *)
Example a : forall (T : Type) p x q f,
  p x ->
  (forall x : T, p x -> exists y, q x y) ->
  (forall x y, q x y -> q y (f y)) ->
  exists z, q z (f z).
Proof.
  intros. apply H in X. destruct X as [y X].
  apply H0 in X.
  exists y. apply X.
Qed.


Require Export NArith.
Require Import TacticEx.
Require Import BinPosEx.
Require Import Pnat.

Definition Nminus x y :=
match x, y with
| x, N0 => x
| N0, _ => N0
| Npos a, Npos b =>
  match (Pcompare a b Eq) with
  | Gt => Npos (Pminus a b)
  | _ => N0
  end
end.

Lemma Nminus_plus: forall p q : N, (Nminus (q + p) q) = p.
Proof.
intros [|a] [|b]; try reflexivity.
simpl.
rewrite Pcompare_refl.
reflexivity.
simpl.
rewrite nat_of_P_gt_Gt_compare_complement_morphism.
rewrite Pminus_plus.
reflexivity.
rewrite nat_of_P_plus_morphism.
destruct (ZL4 a).
rewrite H.
rewrite <- plus_n_Sm.
auto with *.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Sorted ZArith.

Module Quicksort.

Lemma split_accto_pivot : forall {A}
                                 (ord : A -> A -> Prop)
                                 (total : forall a b, {ord a b} + {ord b a})
                                 pivot list,
                            {pre | { post |
                             (forall x, In x pre -> ord x pivot) /\
                             (forall x, In x post -> ord pivot x) /\
                             (forall x, In x list <->
                                        In x pre \/ In x post) /\
                             (length pre + length post = length list)}}.
Proof.
  intros ? ? ? pivot list; induction list as [|a ? IHlist];
  [exists nil,nil;firstorder
  |destruct IHlist as [pre [post ?]];
   destruct (total pivot a);
   [exists pre,(a::post)|exists (a::pre),post]; firstorder subst; auto;
   simpl; omega].
Qed.

Lemma quicksort_conc_lemma : forall {A}
                                    (ord : A -> A -> Prop)
                                    a b c,
                               Sorted ord a -> Sorted ord (b :: c) -> (forall x, In x a -> ord x b) -> Sorted ord (a ++ (b :: c)).
Proof.
  intros A ord a b c H H0 H1.
  induction a.
  apply H0.
  assert (tmp1 : (a :: a0) ++ b :: c = a :: (a0 ++ b :: c)).
  reflexivity.
  rewrite -> tmp1.
  apply Sorted_cons.
  apply IHa.
  inversion H.
  auto.
  intros x inx.
  apply H1.
  apply in_cons.
  apply inx.
  destruct a0.
  apply HdRel_cons.
  apply H1.
  apply in_eq.
  apply HdRel_cons.
  inversion H.
  inversion H5.
  auto.
Qed.

Theorem quicksort : forall {A}
                           (ord : A -> A -> Prop)
                           (total : forall a b, {ord a b} + {ord b a})
                           L,
                      {L' | (forall x, In x L <-> In x L') /\ Sorted ord L'}.
Proof.
  intros A ord total L.
  refine ((fix f n L (lenc : length L <= n) : {L' | (forall x, In x L <-> In x L') /\ Sorted ord L'} :=
             match n as m return (m = n -> _) with
               | 0 => fun eq => _
               | S m' => fun eq => _
             end eq_refl) (length L) L _).
  rewrite <- eq in lenc.
  destruct L.
  exists nil.
  split.
  intros a.
  split.
  trivial.
  trivial.
  apply Sorted_nil.
  contradict lenc.
  unfold length.
  intros Q.
  inversion Q.

  destruct L.
  exists nil.
  split.
  intros x.
  split.
  trivial.
  trivial.
  apply Sorted_nil.
  assert ({pre | { post |
                   (forall x, In x pre -> ord x a) /\
                   (forall x, In x post -> ord a x) /\
                   (forall x, In x L <->
                              In x pre \/ In x post) /\
                   (length pre + length post = length L)}}).
  apply split_accto_pivot.
  apply total.
  elim X.
  intros pre QQ.
  elim QQ.
  intros post QQQ.
  elim QQQ.
  intros B Bc1.
  elim Bc1.
  intros B0 Bc2.
  elim Bc2.
  intros B1 B2.
  assert (X0 : {post' : list A | (forall x : A, In x post <-> In x post') /\ Sorted ord post'}).
  apply (f m').
  apply Le.le_S_n.
  apply (Le.le_trans _ (length (a :: L))).
  replace (length (a :: L)) with (S (length L)).
  rewrite <- B2.
  auto.
  assert (tmp1 : S (length pre + length post) = length pre + S (length post)).
  auto.
  rewrite -> tmp1.
  apply Plus.le_plus_r.
  auto.
  rewrite -> eq.
  auto.
  elim X0.
  intros post' X1.
  elim X1.
  intros X2 X3.
  assert (Y0 : {pre' : list A | (forall x : A, In x pre <-> In x pre') /\ Sorted ord pre'}).
  apply (f m').
  apply Le.le_S_n.
  apply (Le.le_trans _ (length (a :: L))).
  apply (Le.le_trans _ (length (a :: L))).
  replace (length (a :: L)) with (S (length L)).
  rewrite <- B2.
  assert (tmp1 : S (length pre + length post) = S(length pre) + length post).
  auto.
  rewrite -> tmp1.
  apply Plus.le_plus_l.
  auto.
  auto.
  rewrite -> eq.
  auto.
  elim Y0.
  intros pre' Y1.
  elim Y1.
  intros Y2 Y3.
  exists (pre' ++ (a :: post')).
  split.
  split.
  intros inxal.
  inversion inxal.
  apply in_or_app.
  apply or_intror.
  rewrite <- H.
  apply in_eq.
  assert (In x pre \/ In x post).
  apply B1.
  apply H.
  elim H0.
  intros H1.
  apply in_or_app.
  apply or_introl.
  apply Y2.
  apply H1.
  intros H1.
  apply in_or_app.
  apply or_intror.
  apply in_cons.
  apply X2.
  apply H1.

  intros inx.

  assert (inx' : In x pre' \/ In x (a :: post')).
  apply in_app_or.
  apply inx.
  elim inx'.
  intros inxpre'.
  assert (inxpre : In x pre).
  apply Y2.
  apply inxpre'.
  apply in_cons.
  apply B1.
  auto.

  intros inxpost'.
  inversion inxpost'.
  rewrite <- H.
  apply in_eq.
  apply in_cons.
  assert (inxpost : In x post).
  apply X2.
  apply H.
  apply B1.
  auto.
  apply quicksort_conc_lemma.
  apply Y3.
  apply Sorted_cons.
  apply X3.
  destruct post'.
  apply HdRel_nil.
  apply HdRel_cons.
  apply B0.
  apply X2.
  apply in_eq.
  intros x inxpre'.
  apply B.
  apply Y2.
  apply inxpre'.
  auto.
Qed.

End Quicksort.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Open Scope Z_scope.

(* Why3 goal *)
Theorem Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).
(* YOU MAY EDIT THE PROOF BELOW *)
intros n m Hmn.
cut (0 <= m); auto with zarith.
apply Z_lt_induction with
  (P:= fun m =>
      0 <= m -> pow2 (n + m) = pow2 n * pow2 m);
  auto with zarith.
intros x Hind Hxpos.
assert (h:(x = 0 \/ x > 0)) by omega.
destruct h.
subst x.
rewrite Power_0.
replace (n+0) with n by omega.
replace (pow2 n * 1) with (pow2 n)  by omega.
auto.
replace (x) with ((x-1)+1) by omega.
rewrite Power_s;auto with zarith.
replace (n + (x-1+1)) with (n+(x-1)+1) by omega.
rewrite Power_s;auto with zarith.
rewrite Hind;auto with zarith.
rewrite Zmult_permute.
auto with zarith.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (lf1 : natural) : natural :=
  plus Zero (plus lf2 lf1).