Require Export Lists.

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

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

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

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

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

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

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

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

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

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

Implicit Arguments nil [[X]].
Implicit Arguments cons [[X]].
Implicit Arguments length [[X]].
Implicit Arguments app [[X]].
Implicit Arguments rev [[X]].
Implicit Arguments snoc [[X]].

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

Definition mynil : list nat := nil.

Definition mynil' := @nil nat.

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

(** **** Exercise: 2 stars, optional (poly_exercises) *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Fill in the definitions
    and complete the proofs below. *)

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

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

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

Theorem rev_snoc : forall X : Type,
                     forall v : X,
                     forall s : list X,
  rev (snoc s v) = v :: (rev s).
Proof.
  intros X v s.
  induction s.
  Case "s = []".
  reflexivity.
  Case "s = x :: s".
  simpl.
  rewrite IHs.
  reflexivity.
Qed.

Theorem snoc_append : forall X : Type, forall (l : list X) (n:X),
  snoc l n = l ++ [n].
Proof.
  intros X l n. induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem rev1 :forall X : Type, forall (l : list X) (n:X),
  rev  (l ++ [n]) = n::(rev l) .
Proof.
  intros X l n. induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    rewrite -> IHl'.
    rewrite -> snoc_append.
    rewrite -> snoc_append.
    reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros X l.
  induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    rewrite -> snoc_append.
    rewrite -> rev1.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem snoc_with_append : forall X : Type,
                         forall l1 l2 : list X,
                         forall v : X,
  snoc (l1 ++ l2) v = l1 ++ (snoc l2 v).
Proof.

  intros X l1 l2 v.
  induction l1 as [| h l1'].
  Case "l1 = []".
    reflexivity.
  Case "l1 = h :: l1'".
    simpl.
    rewrite -> IHl1'.
    reflexivity.
Qed.
(** [] *)

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

Implicit Arguments pair [[X] [Y]].

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

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

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

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

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

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

(** **** Exercise: 1 star, optional (combine_checks) *)
(** Try answering the following questions on paper and
    checking your answers in coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does
        Eval simpl in (combine [1,2] [false,false,true,true]).
      print?   []
*)

(** **** Exercise: 2 stars, recommended (split) *)
(** The function [split] is the right inverse of combine: it takes a
    list of pairs and returns a pair of lists.  In many functional
    programing languages, this function is called [unzip].

    Uncomment the material below and fill in the definition of
    [split].  Make sure it passes the given unit tests. *)

Definition addPair {X Y : Type} (p : X * Y)
(l : (list X)*(list Y))  :  (list X)*(list Y) :=
  match p,l with
  |(x,y), (l1,l2) => (x::l1,y::l2)
  end.
Fixpoint split {X Y : Type} (l : list (X*Y))
           : (list X)*(list Y) :=
  match l with
  |h::l'=>addPair h (split l')
  |[] => ([],[])
  end.

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

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

Implicit Arguments Some [[X]].
Implicit Arguments None [[X]].

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

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

(** **** Exercise: 1 star, optional (hd_opt_poly) *)
(** Complete the definition of a polymorphic version of the
    [hd_opt] function from the last chapter. Be sure that it
    passes the unit tests below. *)

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

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_opt.

Example test_hd_opt1 :  hd_opt [1,2] = Some 1.
Proof. reflexivity.  Qed.
Example test_hd_opt2 :   hd_opt  [[1],[2]]  = Some [1].
Proof. reflexivity.  Qed.
(** [] *)

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

Check @doit3times.

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

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

Check plus.

Definition plus3 := plus 3.
Check plus3.

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

(** **** Exercise: 2 stars, optional (currying) *)
(** In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

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

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

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

(** (Thought exercise: before running these commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]?) *)

Check @prod_curry.
Check @prod_uncurry.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [].
Proof. reflexivity.  Qed.
(** [] *)

(** **** Exercise: 3 stars (partition) *)
(** Use [filter] to write a Coq function [partition]:
  partition : forall X : Type,
              (X -> bool) -> list X -> list X * list X
   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list.
*)

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

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

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

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

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

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

(** **** Exercise: 3 stars, optional (map_rev) *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Theorem map1 : forall (X Y : Type) (f : X -> Y) (l : list X) (n: X),
  map f (l++[n]) = (map f l)++[f n].
Proof.
  intros X Y f l n.
  induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    rewrite IHl'.
  reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l.
  induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    rewrite snoc_append.
    rewrite map1.
    rewrite <- IHl'.
    rewrite snoc_append.
    reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, recommended (flat_map) *)
(** The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:
        flat_map (fun n => [n,n+1,n+2]) [1,5,10]
      = [1, 2, 3, 5, 6, 7, 10, 11, 12].
*)

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

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

(** [] *)

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

(** **** Exercise: 2 stars, optional (implicit_args) *)
(** The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.  [] *)

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

Check (fold plus).
Eval simpl in (fold plus [1,2,3,4] 0).

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

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

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

(** **** Exercise: 1 star, optional (fold_types_different) *)
(** Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different?

Для преобразования списка в другую коллекцию.
Например: Y - дерево, f - добавление эелмента в дерево.

 *)

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

Definition ftrue := constfun true.

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

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

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

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

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

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

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

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

(** **** Exercise: 1 star (override_example) *)
(** Before starting to work on the following proof, make sure you
    understand exactly what the theorem is saying and can paraphrase
    it in your own words.  The proof itself is straightforward. *)

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

Inductive boolllist : nat -> Type :=
  boollnil  : boolllist O
| boollcons : forall n, bool -> boolllist n -> boolllist (S n).

Implicit Arguments boollcons [[n]].

Check (boollcons true (boollcons false (boollcons true boollnil))).

Fixpoint blapp {n1} (l1: boolllist n1)
               {n2} (l2: boolllist n2)
             : boolllist (n1 + n2) :=
  match l1 with
  | boollnil        => l2
  | boollcons _ h t => boollcons h (blapp t l2)
  end.

Inductive llist (X:Type) : nat -> Type :=
  lnil  : llist X O
| lcons : forall n, X -> llist X n -> llist X (S n).

Implicit Arguments lnil [[X]].
Implicit Arguments lcons [[X] [n]].

Check (lcons true (lcons false (lcons true lnil))).

Fixpoint lapp (X:Type)
              {n1} (l1: llist X n1)
              {n2} (l2: llist X n2)
            : llist X (n1 + n2) :=
  match l1 with
  | lnil        => l2
  | lcons _ h t => lcons h (lapp X t l2)
  end.

Theorem silly1 : forall (n m o p : nat),
     n = m  ->
     [n,o] = [n,p] ->
     [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  rewrite <- eq1.
  (* At this point, we could finish with "[rewrite -> eq2. reflexivity.]"
     as we have done several times above. But we can achieve the
     same effect in a single step by using the [apply] tactic instead: *)
  apply eq2.  Qed.

Theorem silly2 : forall (n m o p : nat),
     n = m  ->
     (forall (q r : nat), q = r -> [q,o] = [r,p]) ->
     [n,o] = [m,p].
Proof.
  intros n m o p eq1 eq2.
  apply eq2. apply eq1.  Qed.

Theorem silly2a : forall (n m : nat),
     (n,n) = (m,m)  ->
     (forall (q r : nat), (q,q) = (r,r) -> [q] = [r]) ->
     [n] = [m].
Proof.
  intros n m eq1 eq2.
  apply eq2. apply eq1.  Qed.

(** **** Exercise: 2 stars, optional (silly_ex) *)
(** Complete the following proof without using [simpl]. *)

Theorem silly_ex :
     (forall n, evenb n = true -> oddb (S n) = true) ->
     evenb 3 = true ->
     oddb 4 = true.
Proof.
  intros n eq1.
  apply eq1.  Qed.

(** [] *)

Theorem silly3_firsttry : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  simpl.
  (* Here we cannot use [apply] directly *)
Admitted.

Theorem silly3 : forall (n : nat),
     true = beq_nat n 5  ->
     beq_nat (S (S n)) 7 = true.
Proof.
  intros n H.
  symmetry.
  simpl. (* Actually, this [simpl] is unnecessary, since
            [apply] will do a [simpl] step first. *)
  apply H.  Qed.

(** **** Exercise: 3 stars, recommended (apply_exercise1) *)

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Proof.
  (* Hint: you can use [apply] with previously defined lemmas, not
     just hypotheses in the context.  Remember that [SearchAbout] is
     your friend. *)
  intros l l' H.
  rewrite H.
  symmetry.
  apply rev_involutive.
Qed.

(** [] *)

(** **** Exercise: 1 star (apply_rewrite) *)
(** Briefly explain the difference between the tactics [apply] and
    [rewrite].  Are there situations where both can usefully be
    applied?

apply пвтается полностью сопоставить цель и гипотезу/теорему.
rewrite ищет в цели вхождения левой или правой части равенства из
гипотезы/теоремы и заменяет их.
apply может не сработать, если левая и правя части в одном из равенств
поменены местами.
*)
(** [] *)

Theorem unfold_example_bad : forall m n,
  3 + n = m ->
  plus3 n + 1 = m + 1.
Proof.
  intros m n H.
  (* At this point, we'd like to do [rewrite -> H], since
     [plus3 n] is definitionally equal to [3 + n].  However,
     Coq doesn't automatically expand [plus3 n] to its
     definition. *)
  Admitted.

(** The [unfold] tactic can be used to explicitly replace a
    defined name by the right-hand side of its definition.  *)

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

(** Now we can prove a first property of [override]: If we
    override a function at some argument [k] and then look up [k], we
    get back the overridden value. *)

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

(** This proof was straightforward, but note that it requires
    [unfold] to expand the definition of [override]. *)

(** **** Exercise: 2 stars (override_neq) *)
Theorem override_neq : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  f k1 = x1 ->
  beq_nat k2 k1 = false ->
  (override f k2 x2) k1 = x1.
Proof.
  intros X x1 x2 k1 k2 f H1 H2.
  unfold override.
  rewrite  H2.
  rewrite  H1.
  reflexivity.
Qed.
(** [] *)

Theorem eq_add_S : forall (n m : nat),
     S n = S m ->
     n = m.
Proof.
  intros n m eq. inversion eq. reflexivity.  Qed.

Theorem silly4 : forall (n m : nat),
     [n] = [m] ->
     n = m.
Proof.
  intros n o eq. inversion eq. reflexivity.  Qed.

Theorem silly5 : forall (n m o : nat),
     [n,m] = [o,o] ->
     [n] = [m].
Proof.
  intros n m o eq. inversion eq. reflexivity. Qed.

(** **** Exercise: 1 star (sillyex1) *)
Example sillyex1 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = z :: j ->
     y :: l = x :: j ->
     x = y.
Proof.
  intros X x y z l j H1 H2.
  inversion H2.
  reflexivity.
Qed.
(** [] *)

Theorem silly6 : forall (n : nat),
     S n = O ->
     2 + 2 = 5.
Proof.
  intros n contra. inversion contra. Qed.

Theorem silly7 : forall (n m : nat),
     false = true ->
     [n] = [m].
Proof.
  intros n m contra. inversion contra.  Qed.

(** **** Exercise: 1 star (sillyex2) *)
Example sillyex2 : forall (X : Type) (x y z : X) (l j : list X),
     x :: y :: l = [] ->
     y :: l = z :: j ->
     x = z.
Proof.
  intros X x y z l j H1 H2.
  inversion H1.
Qed.
(** [] *)

Lemma eq_remove_S : forall n m,
  n = m -> S n = S m.
Proof. intros n m eq. rewrite -> eq. reflexivity. Qed.

(** Here's another illustration of [inversion].  This is a slightly
    roundabout way of stating a fact that we have already proved
    above.  The extra equalities force us to do a little more
    equational reasoning and exercise some of the tactics we've seen
    recently. *)

Theorem length_snoc' : forall (X : Type) (v : X)
                              (l : list X) (n : nat),
     length l = n ->
     length (snoc l v) = S n.
Proof.
  intros X v l. induction l as [| v' l'].
  Case "l = []". intros n eq. rewrite <- eq. reflexivity.
  Case "l = v' :: l'". intros n eq. simpl. destruct n as [| n'].
    SCase "n = 0". inversion eq.
    SCase "n = S n'".
      apply eq_remove_S. apply IHl'. inversion eq. reflexivity. Qed.

Theorem beq_nat_eq_FAILED : forall n m,
  true = beq_nat n m -> n = m.
Proof.
  intros n m H. induction n as [| n'].
  Case "n = 0".
    destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl in H. inversion H.
  Case "n = S n'".
    destruct m as [| m'].
    SCase "m = 0". simpl in H. inversion H.
    SCase "m = S m'".
      apply eq_remove_S.
      (* stuck here because the induction hypothesis
         talks about an extremely specific m *)
      Admitted.

Theorem beq_nat_eq : forall n m,
  true = beq_nat n m -> n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
    intros m. destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'". simpl. intros contra. inversion contra.
  Case "n = S n'".
    intros m. destruct m as [| m'].
    SCase "m = 0". simpl. intros contra. inversion contra.
    SCase "m = S m'". simpl. intros H.
      apply eq_remove_S. apply IHn'. apply H. Qed.

(** **** Exercise: 2 stars (beq_nat_eq_informal) *)
(** Give an informal proof of [beq_nat_eq]. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars (beq_nat_eq') *)
(** We can also prove beq_nat_eq by induction on [m], though we have
    to be a little careful about which order we introduce the
    variables, so that we get a general enough induction hypothesis --
    this is done for you below.  Finish the following proof.  To get
    maximum benefit from the exercise, try first to do it without
    looking back at the one above. *)

Theorem beq_nat_eq' : forall m n,
  beq_nat n m = true -> n = m.
Proof.
  intros m. induction m as [| m'].
  Case "m = 0".
    destruct n.
    SCase "n = 0".
      reflexivity.
    SCase "n = S n'".
      intros H. inversion H.
  Case "m = S m'".
    destruct n.
    SCase "n = 0".
      intros H. inversion H.
    SCase "n = S n'".
      intros H.
      apply eq_remove_S.
      apply IHm'.
      inversion H.
      reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (practice) *)
(** Some nontrivial but not-too-complicated proofs to work together in
    class, and some for you to work as exercises.  Some of the
    exercises may involve applying lemmas from earlier lectures or
    homeworks. *)

Theorem beq_nat_0_l : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
  intros n H.
  destruct n as [| n'].
  Case "n = 0".
    reflexivity.
  SCase "n = S n'".
  inversion H.
Qed.

Theorem beq_nat_0_r : forall n,
  true = beq_nat 0 n -> 0 = n.
Proof.
  intros n H.
  destruct n as [| n'].
  Case "n = 0".
    reflexivity.
  SCase "n = S n'".
  inversion H.
Qed.
(** [] *)

(** **** Exercise: 3 stars (apply_exercise2) *)
(** In the following proof opening, notice that we don't introduce [m]
    before performing induction.  This leaves it general, so that the
    IH doesn't specify a particular [m], but lets us pick.  Finish the
    proof. *)

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
  destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'".
      reflexivity.
  Case "n = S n'".
  destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'".
    apply IHn'.
Qed.
(** [] *)

(** **** Exercise: 3 stars (beq_nat_sym_informal) *)
(** Provide an informal proof of this lemma that corresponds
    to your formal proof above:

   Theorem: For any [nat]s [n] [m], [beq_nat n m = beq_nat m n].

   Proof:
   (* FILL IN HERE *)
[]
 *)

Theorem S_inj : forall (n m : nat) (b : bool),
     beq_nat (S n) (S m) = b  ->
     beq_nat n m = b.
Proof.
  intros n m b H. simpl in H. apply H.  Qed.

Theorem silly3' : forall (n : nat),
  (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
     true = beq_nat n 5  ->
     true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H.
  symmetry in H. apply eq in H. symmetry in H.
  apply H.  Qed.

(** **** Exercise: 3 stars, recommended (plus_n_n_injective) *)
(** You can practice using the "in" variants in this exercise. *)

Theorem unS : forall n m,
     n  = m  ->
     S n = S m.
Proof.
  intros n m H.
  rewrite H.
  reflexivity.
Qed.

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".
  destruct m as [| m'].
    SCase "m = 0". reflexivity.
    SCase "m = S m'".
    intros H.
    inversion H.
  Case "n = S n'".
  destruct m as [| m'].
    SCase "m = 0".
    intros H.
    inversion H.
    SCase "m = S m'".
    rewrite <- plus_n_Sm.
    rewrite <- plus_n_Sm.
simpl.
    intros H.
    apply unS.
    apply IHn'.
    inversion H.
  reflexivity.
Qed.

    (* Hint: use the plus_n_Sm lemma *)
(** [] *)

(* ###################################################### *)
(** ** Using [destruct] on Compound Expressions *)

(** We have seen many examples where the [destruct] tactic is
    used to perform case analysis of the value of some variable.  But
    sometimes we need to reason by cases on the result of some
    _expression_.  We can also do this with [destruct].

    Here are some examples: *)

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Proof.
  intros n. unfold sillyfun.
  destruct (beq_nat n 3).
    Case "beq_nat n 3 = true". reflexivity.
    Case "beq_nat n 3 = false". destruct (beq_nat n 5).
      SCase "beq_nat n 5 = true". reflexivity.
      SCase "beq_nat n 5 = false". reflexivity.  Qed.

(** After unfolding [sillyfun] in the above proof, we find that
    we are stuck on [if (beq_nat n 3) then ... else ...].  Well,
    either [n] is equal to [3] or it isn't, so we use [destruct
    (beq_nat n 3)] to let us reason about the two cases. *)

(** **** Exercise: 1 star (override_shadow) *)
Theorem override_shadow : forall {X:Type} x1 x2 k1 k2 (f : nat->X),
  (override (override f k1 x2) k1 x1) k2 = (override f k1 x1) k2.
Proof.
  intros X x1 x3 k1 k2 f.
  unfold override.
  destruct (beq_nat k1 k2).
    Case "beq_nat k1 k2 = true". reflexivity.
    Case "beq_nat k1 k2 = false". reflexivity.
Qed.
(** [] *)

(** **** Exercise: 3 stars, recommended (combine_split) *)
Theorem combine_split : forall X Y (l : list (X * Y)) l1 l2,
  split l = (l1, l2) ->
  combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| [x y] l'].
  Case "l = []".
    intros.
    inversion H.
    reflexivity.
  Case "l = (x, y) :: l'".
    intros.
    inversion H.
    destruct (split l').
Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (split_combine) *)
(** Thought exercise: We have just proven that for all lists of pairs,
    [combine] is the inverse of [split].  How would you state the
    theorem showing that [split] is the inverse of [combine]?

    Hint: what property do you need of [l1] and [l2] for [split]
    [combine l1 l2 = (l1,l2)] to be true?

    State this theorem in Coq, and prove it. (Be sure to leave your
    induction hypothesis general by not doing [intros] on more things
    than necessary.) *)

(* FILL IN HERE *)
(** [] *)

(* ###################################################### *)
(** ** The [remember] Tactic *)

(** (Note: the [remember] tactic is not strictly needed until a
    bit later, so if necessary this section can be skipped and
    returned to when needed.) *)

(** We have seen how the [destruct] tactic can be used to
    perform case analysis of the results of arbitrary computations.
    If [e] is an expression whose type is some inductively defined
    type [T], then, for each constructor [c] of [T], [destruct e]
    generates a subgoal in which all occurrences of [e] (in the goal
    and in the context) are replaced by [c].

    Sometimes, however, this substitution process loses information
    that we need in order to complete the proof.  For example, suppose
    we define a function [sillyfun1] like this: *)

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

(** And suppose that we want to convince Coq of the rather
    obvious observation that [sillyfun1 n] yields [true] only when [n]
    is odd.  By analogy with the proofs we did with [sillyfun] above,
    it is natural to start the proof like this: *)

Theorem sillyfun1_odd_FAILED : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3).
  (* stuck... *)
Admitted.

(** We get stuck at this point because the context does not
    contain enough information to prove the goal!  The problem is that
    the substitution peformed by [destruct] is too brutal -- it threw
    away every occurrence of [beq_nat n 3], but we need to keep at
    least one of these because we need to be able to reason that
    since, in this branch of the case analysis, [beq_nat n 3 = true],
    it must be that [n = 3], from which it follows that [n] is odd.

    What we would really like is not to use [destruct] directly on
    [beq_nat n 3] and substitute away all occurrences of this
    expression, but rather to use [destruct] on something else that is
    _equal_ to [beq_nat n 3].  For example, if we had a variable that
    we knew was equal to [beq_nat n 3], we could [destruct] this
    variable instead.

    The [remember] tactic allows us to introduce such a variable. *)

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
   remember (beq_nat n 3) as e3.
   (* At this point, the context has been enriched with a new
      variable [e3] and an assumption that [e3 = beq_nat n 3].
      Now if we do [destruct e3]... *)
   destruct e3.
   (* ... the variable [e3] gets substituted away (it
     disappears completely) and we are left with the same
      state as at the point where we got stuck above, except
      that the context still contains the extra equality
      assumption -- now with [true] substituted for [e3] --
      which is exactly what we need to make progress. *)
     Case "e3 = true". apply beq_nat_eq in Heqe3.
       rewrite -> Heqe3. reflexivity.
     Case "e3 = false".
      (* When we come to the second equality test in the
        body of the function we are reasoning about, we can
         use [remember] again in the same way, allowing us
         to finish the proof. *)
       remember (beq_nat n 5) as e5. destruct e5.
         SCase "e5 = true".
           apply beq_nat_eq in Heqe5.
           rewrite -> Heqe5. reflexivity.
         SCase "e5 = false". inversion eq.  Qed.

(** **** Exercise: 2 stars (override_same) *)
Theorem override_same : forall {X:Type} x1 k1 k2 (f : nat->X),
  f k1 = x1 ->
  (override f k1 x1) k2 = f k2.
Proof.
  intros.
  unfold override.
 remember (beq_nat k1 k2) as e3.

   destruct e3.
     Case "e3 = true". apply beq_nat_eq in Heqe3.
       rewrite -> Heqe3 in H.
       symmetry.
       apply H.
     Case "e3 = false".
       reflexivity.
 Qed.
(** [] *)

(** **** Exercise: 3 stars, optional (filter_exercise) *)
(** This one is a bit challenging.  Be sure your initial [intros] go
    only up through the parameter on which you want to do
    induction! *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Proof.
  intros X test x l lf.
  induction l as [| h l'].
  Case "l = []".
  intros.
    inversion H.
  Case "l = h::l'".
    remember (test h) as e3.
    destruct e3.
    SCase "e3 = true".
      simpl.
      rewrite <- Heqe3.
      intros.
      inversion H.
      rewrite H1 in Heqe3.
      symmetry.
      apply Heqe3.
    SCase "e3 = false".
      simpl.
      rewrite <- Heqe3.
      apply IHl'.
Qed.

(** [] *)

(* ###################################################### *)
(** ** The [apply ... with ...] Tactic *)

(** The following silly example uses two rewrites in a row to
    get from [[a,b]] to [[e,f]]. *)

Example trans_eq_example : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  rewrite -> eq1. rewrite -> eq2. reflexivity.  Qed.

(** Since this is a common pattern, we might
    abstract it out as a lemma recording once and for all
    the fact that equality is transitive. *)

Theorem trans_eq : forall {X:Type} (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.  Qed.

(** Now, we should be able to use [trans_eq] to
    prove the above example.  However, to do this we need
    a slight refinement of the [apply] tactic. *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a,b] = [c,d] ->
     [c,d] = [e,f] ->
     [a,b] = [e,f].
Proof.
  intros a b c d e f eq1 eq2.
  (* If we simply tell Coq [apply trans_eq] at this point,
     it can tell (by matching the goal against the
     conclusion of the lemma) that it should instantiate [X]
     with [[nat]], [n] with [[a,b]], and [o] with [[e,f]].
     However, the matching process doesn't determine an
     instantiation for [m]: we have to supply one explicitly
     by adding [with (m:=[c,d])] to the invocation of
     [apply]. *)
  apply trans_eq with (m:=[c,d]). apply eq1. apply eq2.   Qed.

(**  Actually, we usually don't have to include the name [m]
    in the [with] clause; Coq is often smart enough to
    figure out which instantiation we're giving. We could
    instead write: apply trans_eq with [c,d]. *)

(** **** Exercise: 3 stars, recommended (apply_exercises) *)
Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Proof.
  intros.
  rewrite H0.
  apply H.
Qed.

Theorem beqTrue : forall n, true = beq_nat n n.
Proof.
  intros.
  induction n as[| n'].

  reflexivity.
  simpl.
  apply IHn'.
Qed.

Theorem beq_nat_trans : forall n m p,
  true = beq_nat n m ->
  true = beq_nat m p ->
  true = beq_nat n p.
Proof.

  intros.
apply beq_nat_eq in H.
apply beq_nat_eq in H0.
  rewrite H.
  rewrite H0.
  apply beqTrue.
Qed.

Theorem override_permute : forall {X:Type} x1 x2 k1 k2 k3 (f : nat->X),
  false = beq_nat k2 k1 ->
  (override (override f k2 x2) k1 x1) k3 = (override (override f k1 x1) k2 x2) k3.
Proof.
  intros.
  unfold override.
 remember (beq_nat k1 k3) as e3.

   destruct e3.
     Case "e3 = true". apply beq_nat_eq in Heqe3.
       rewrite -> Heqe3 in H.
       rewrite <- H.
       reflexivity.
     Case "e3 = false".
       reflexivity.
 Qed.
(** [] *)

(* ################################################################## *)
(** * Review *)

(** We've now seen a bunch of Coq's fundamental tactics -- enough to
    do pretty much everything we'll want for a while.  We'll introduce
    one or two more as we go along through the next few lectures, and
    later in the course we'll introduce some more powerful
    _automation_ tactics that make Coq do more of the low-level work
    in many cases.  But basically we've got what we need to get work
    done.

    Here are the ones we've seen:

      - [intros]:
        move hypotheses/variables from goal to context

      - [reflexivity]:
        finish the proof (when the goal looks like [e = e])

      - [apply]:
        prove goal using a hypothesis, lemma, or constructor

      - [apply... in H]:
        apply a hypothesis, lemma, or constructor to a hypothesis in
        the context (forward reasoning)

      - [apply... with...]:
        explicitly specify values for variables that cannot be
        determined by pattern matching

      - [simpl]:
        simplify computations in the goal

      - [simpl in H]:
        ... or a hypothesis

      - [rewrite]:
        use an equality hypothesis (or lemma) to rewrite the goal

      - [rewrite ... in H]:
        ... or a hypothesis

      - [symmetry]:
        changes a goal of the form [t=u] into [u=t]

      - [symmetry in H]:
        changes a hypothesis of the form [t=u] into [u=t]

      - [unfold]:
        replace a defined constant by its right-hand side in the goal

      - [unfold... in H]:
        ... or a hypothesis

      - [destruct... as...]:
        case analysis on values of inductively defined types

      - [induction... as...]:
        induction on values of inductively defined types

      - [inversion]:
        reason by injectivity and distinctness of constructors

      - [remember (e) as x]:
        give a name ([x]) to an expression ([e]) so that we can
        destruct [x] without "losing" [e]

      - [assert (e) as H]:
        introduce a "local lemma" [e] and call it [H]
*)

(* ###################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 2 stars, optional (fold_length) *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternate definition of [length]: *)

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

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

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

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

(** **** Exercise: 3 stars, recommended (fold_map) *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

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

(** Write down a theorem in Coq stating that [fold_map] is correct,
    and prove it. *)

Theorem fold_map_correct : forall X Y (l : list X) (f : X -> Y),
  fold_map f l = map f l.
Proof.
  intros.
  induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    unfold fold_length.
    simpl.
    rewrite <- IHl'.
    unfold fold_length.
    reflexivity.
Qed.
(** [] *)

Module MumbleBaz.
(** **** Exercise: 2 stars, optional (mumble_grumble) *)
(** Consider the following two inductively defined types. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.
Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
      - [d (b a 5)] - нет типа после d
      - [d mumble (b a 5)] - well-typed
      - [d bool (b a 5)] - well-typed
      - [e bool true] - well-typed
      - [e mumble (b c 0)] - well-typed
      - [e bool (b c 0)] - вместо bool должен быть mumble,
                           или в скобках должан быть bool
      - [c] - well-typed

[] *)
(** **** Exercise: 2 stars, optional (baz_num_elts) *)
(** Consider the following inductive definition: *)

Inductive baz : Type :=
   | x : baz -> baz
   | y : baz -> bool -> baz.

(** How _many_ elements does the type [baz] have?

Здесь не хватает базисного элемента.
=> нельзя постоить ни одного элемента

[] *)

End MumbleBaz.

(** **** Exercise: 4 stars, recommended (forall_exists_challenge) *)
(** Challenge problem: Define two recursive [Fixpoints],
    [forallb] and [existsb].  The first checks whether every
    element in a list satisfies a given predicate:
      forallb oddb [1,3,5,7,9] = true

      forallb negb [false,false] = true

      forallb evenb [0,2,4,5] = false

      forallb (beq_nat 5) [] = true
    The function [existsb] checks whether there exists an element in
    the list that satisfies a given predicate:
      existsb (beq_nat 5) [0,2,3,6] = false

      existsb (andb true) [true,true,false] = true

      existsb oddb [1,0,0,0,0,3] = true

      existsb evenb [] = false
    Next, create a _nonrecursive_ [Definition], [existsb'], using
    [forallb] and [negb].

    Prove that [existsb'] and [existsb] have the same behavior.
*)

Fixpoint forallb {X :Type} (f : X -> bool) (l : list X) : bool :=
  match l with
  |[] => true
  |h::l' => if f h then forallb f l' else false
  end.
Example forallb_example1 : forallb oddb [1,3,5,7,9] = true.
Proof. reflexivity. Qed.
Example forallb_example2 : forallb evenb [0,2,4,5] = false.
Proof. reflexivity. Qed.
Example forallb_example3 : forallb (beq_nat 5) [] = true.
Proof. reflexivity. Qed.
Example forallb_example4 : forallb negb [false,false] = true.
Proof. reflexivity. Qed.
Fixpoint existsb {X :Type} (f : X -> bool) (l : list X) : bool :=
  match l with
  |[] => false
  |h::l' => if f h then true else existsb f l'
  end.
Example existsb_example1 : existsb (beq_nat 5) [0,2,3,6] = false.
Proof. reflexivity. Qed.
Example existsb_example2 : existsb (andb true) [true,true,false] = true.
Proof. reflexivity. Qed.
Example existsb_example3 : existsb oddb [1,0,0,0,0,3] = true.
Proof. reflexivity. Qed.
Example existsb_example4 : existsb evenb [] = false.
Proof. reflexivity. Qed.
Definition existsb' {X :Type} (f : X -> bool) (l : list X) : bool :=
negb (forallb (fun n => negb(f n)) l).
Theorem fold_existsb_correct : forall X (l : list X) (f : X -> bool),
  existsb f l = existsb' f l.
Proof.
  intros.
  induction l as [| h l'].
  Case "l = []".
    reflexivity.
  Case "l = h :: l'".
    simpl.
    unfold existsb'.
    simpl.
    remember (f h) as e3.
    destruct e3.
    SCase "e3 = true".
      reflexivity.
    SCase "e3 = false".
      simpl.
      rewrite -> IHl'.
      unfold existsb'.
      reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (index_informal) *)
(** Recall the definition of the [index] function:
   Fixpoint index {X : Type} (n : nat) (l : list X) : option X :=
     match l with
     | [] => None
     | a :: l' => if beq_nat n O then Some a else index (pred n) l'
     end.
   Write an informal proof of the following theorem:
   forall X n l, length l = n -> @index X (S n) l = None.
(* FILL IN HERE *)
*)
(** [] *)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Archetypal.PreOrder_Cat.PreOrder_Cat.

Require Import Coq.Arith.Arith.

Delimit Scope omegacat_scope with omegacat.

Local Open Scope omegacat_scope.

(** Since we can't eliminate prop to define functors in a simple way,
we redefine the notion of le (less than or equal) for natural numbers
in Type (Tle).

We show that le implies Tle (and vise versa).

What follows are some properties of Tle.
 *)
Inductive Tle (n : nat) : nat → Type :=
| Tle_n : Tle n n
| Tle_S : ∀ m, Tle n m → Tle n (S m)
.

Hint Constructors Tle.

Notation "n ≤ m" := (Tle n m) : omegacat_scope.

Definition Tle_addS (n m : nat) : n ≤ m → S n ≤ S m.
Proof.
  intros H.
  induction H; auto.
Qed.

Definition Tle_trans (n m t : nat) : n ≤ m → m ≤ t → n ≤ t.
Proof.
  intros H1 H2.
  induction H2; auto.
Defined.

Definition Tle_remS (n m : nat) : S n ≤ S m → n ≤ m.
Proof.
  revert n.
  induction m.
  intros n H.
  induction n; auto.
  inversion H as [Hx | m H1 H2]; inversion H1.
  intros n H.
  inversion H; auto.
Qed.

Theorem Not_S_Tle (n : nat) : Tle (S n) n → False.
Proof.
  intros H.
  induction n; inversion H; auto.
  apply IHn.
  apply Tle_remS; trivial.
Qed.

(** Tle is decidable. This is crutial in conversion from le to Tle. *)
Definition Tle_dec (n m : nat) : (n ≤ m) + ((n ≤ m) → False).
Proof.
  revert m.
  induction n.
  - left; induction m; auto.
  - induction m.
    + right; intros H; inversion H.
    + destruct IHm as [H1|H1].
      left; auto.
      destruct (IHn m) as [H2|H2].
      * left; apply Tle_addS; trivial.
      * right.
        intros H3.
        contradict H2.
        apply Tle_remS; trivial.
Qed.

(** This is prety straightforward. *)
Definition Tle_le {n m : nat} : n ≤ m → le n m.
Proof.
  intros H.
  induction H; auto.
Qed.

(** The contrapositive of conversion from le to Tle. *)
Definition NTle_Nle {n m : nat} : (n ≤ m → False) → (le n m → False).
Proof.
  intros H1 H2.
  induction H2.
  + apply H1; trivial.
  + apply IHle.
    intros H3.
    apply H1; auto.
Qed.

(** This is the actual conversion from le to Tle.

Here, the trick is that we use decidability of Tle.
In case the relation holds, we have the proof.
In case it does not, we can refute the le relation.

Hence, this conversion is (as expected) does not
preform an explicit elimination of le (as it is
impossible) and hence is not computationally
simplifiable.
 *)
Definition le_Tle {n m : nat} : le n m → n ≤ m.
Proof.
  intros H.
  destruct (Tle_dec n m) as [H1|H1]; auto.
  contradict H.
  unfold not; apply NTle_Nle; trivial.
Qed.

(** We show that (homotopy-type-theoretically speaking) Tle is a mere
    proposition. That is, any two proofs of a ≤ b are equal. Note that
Tle is in Type and not in Pop and hence we can't use proof-irrelevance.

This is a proof in a hurry, and can perhaps be simplified later.
 *)
Theorem Tle_is_HProp {n m : nat} (H H' : Tle n m) : H = H'.
Proof.
  dependent induction H.
  dependent induction H'; trivial.
  {
    inversion H' as [H1| m' H1 H2].
    {
      contradict H1; clear.
      induction m; auto.
    }
    {
      subst.
      contradict H1; clear.
      induction m'.
      + intros H; inversion H.
      + intros H.
        apply IHm'.
        apply Tle_remS; trivial.
    }
  }
  {
    inversion H'.
    + subst.
      clear IHTle.
      contradict H; clear.
      intros H.
      induction m.
      * inversion H.
      * apply IHm.
        apply Tle_remS; trivial.
    + subst.
      dependent destruction H'.
      {
        clear IHTle.
        contradict H; clear.
        intros H.
        induction m.
        * inversion H.
        * apply IHm.
          apply Tle_remS; trivial.
      }
      {
        apply f_equal.
        apply IHTle.
      }
  }
Qed.

(** Natural numbers form a preorder with le (less than or equal relation). *)
Definition OmegaPreOrder :=
  {|
    PreOrder_car := nat : Type;
    PreOrder_rel := Tle : _ → _ → Type;
    PreOrder_rel_isProp :=
      fun _ _ h h' => Tle_is_HProp h h';
    PreOrder_refl := Tle_n;
    PreOrder_trans := Tle_trans
  |}.

(** The pre-order category ω. *)
Definition OmegaCat : Category := PreOrder_Cat OmegaPreOrder.

Notation "'ω'" := (OmegaCat) : omegacat_scope.

Lemma le_Tle_n (n : nat) : le_Tle (le_n n) = Tle_n n.
Proof.
  apply Tle_is_HProp.
Qed.

Lemma le_Tle_S (n m : nat) (H : le n m) :
  le_Tle (le_S _ _ H) = Tle_S _ _ (le_Tle H).
Proof.
  apply Tle_is_HProp.
Qed.

Lemma le_Tle_trans (n m k : nat) (H : le n m) (H' : le m k) :
  le_Tle (le_trans _ _ _ H H') = Tle_trans _ _ _ (le_Tle H) (le_Tle H').
Proof.
  apply Tle_is_HProp.
Qed.

(** Given a map f from natural numbers to objects of a category C
and a map from (f (S n) –≻ f n), we construct a functor from
ωᵒᵖ to C. *)
(** This is the arrow map of the functor being constructed. *)
Local Fixpoint FA_fx {C : Category}
      (OOF_O : nat → C)
      (OOF_A : ∀ n, ((OOF_O (S n)) –≻ (OOF_O n))%morphism)
      (n m : nat) (h : Tle n m)
      {struct h} : (OOF_O m –≻ OOF_O n)%morphism
  :=
    match h in _ ≤ w return
          (OOF_O w –≻ OOF_O n)%morphism
    with
    | Tle_n _ =>
      id (OOF_O n)
    | Tle_S _ m' H' =>
      ((FA_fx OOF_O OOF_A _ _ H') ∘ (OOF_A m'))%morphism
    end
.

(** This is the the functor described above. *)
Program Definition OmegaCat_Op_Func {C : Category}
      (OOF_O : nat → C)
      (OOF_A : ∀ n, ((OOF_O (S n)) –≻ (OOF_O n))%morphism)
  : ((ω^op) –≻ C)%functor :=
  {|
    FO := OOF_O;
    FA := fun m n h => FA_fx OOF_O OOF_A _ _ h
  |}
.

Next Obligation.
Proof.
  induction f as [|m t IHt].
  + cbn; auto.
  + replace (Tle_trans _ _ _ g (Tle_S _ _ t))
    with (Tle_S _ _ (Tle_trans _ _ _ g t)).
    cbn.
    rewrite IHt.
    auto.
    apply Tle_is_HProp.
Qed.

(** Similar functor from ω to C. *)
Definition OmegaCat_Func {C : Category}
           (OMF_O : nat → C)
           (OMF_A : ∀ n, ((OMF_O n) –≻ (OMF_O (S n)))%morphism)
  : (OmegaCat –≻ C)%functor
  := (@OmegaCat_Op_Func (C^op) OMF_O OMF_A)^op.

(** Any functor from ωᵒᵖ to C is freely generated by its object map and the
    image of the arrow map under (le_S _ _ (le_n n)) (proof of (le n (S n))). *)
Lemma OmegaCat_Op_Func_unique {C : Category} (F : ((ω^op) –≻ C)%functor) :
  F = OmegaCat_Op_Func (FO F) (fun n => FA F (Tle_S _ _ (Tle_n n))).
Proof.
  Func_eq_simpl.
  extensionality y.
  extensionality x.
  extensionality h.
  cbn in *.
  revert x y h.
  induction x.
  {
    intros y h.
    induction y.
    + dependent destruction h.
      rewrite (F_id F).
      trivial.
    + dependent destruction h.
      cbn in *.
      rewrite <- (IHy h).
      rewrite <- F_compose.
      match goal with
        [|- (F _a)%morphism ?A = (F _a)%morphism ?B] =>
        set (l := A); set (l' := B); cbn in l, l'; PIR
      end.
      trivial.
  }
  {
    intros y h.
    induction y.
    + inversion h.
    + dependent destruction h.
      * rewrite (F_id F).
        trivial.
      * cbn.
        rewrite <- (IHy h).
        rewrite <- F_compose.
        match goal with
          [|- (F _a)%morphism ?A = (F _a)%morphism ?B] =>
          set (l := A); set (l' := B); cbn in l, l'; PIR
        end.
        trivial.
  }
Qed.

(** Any functor from ω to C is freely generated by its object map and the image
    of the arrow map under (le_S _ _ (le_n n)) (proof of (le n (S n))). *)
Lemma OmegaCat_Func_unique {C : Category} (F : (ω –≻ C)%functor) :
  F = OmegaCat_Func (FO F) (fun n => FA F (Tle_S _ _ (Tle_n n))).
Proof.
  unfold OmegaCat_Func.
  cbn_rewrite <- ((OmegaCat_Op_Func_unique (F^op))).
  trivial.
Qed.


(** * Equivalência entre o Princípio da Indução Matemática e o Princípio da Indução Forte *)

Require Import Arith.

(** Seja [P] uma propriedade sobre os números naturais. O Princípio da *)
(** Indução Matemática (PIM) pode ser enunciado da seguinte forma:  *)

Definition PIM :=
  forall P: nat -> Prop,
    (P 0) ->
    (forall n, P n -> P (S n)) ->
    forall n, P n.

(** Seja [Q] uma propriedade sobre os números naturais. O Princípio da *)
(** Indução Forte (PIF) pode ser enunciado da seguinte forma:  *)

Definition PIF :=
  forall Q: nat -> Prop,
    (forall n, (forall m, m<n -> Q m) -> Q n) ->
    forall n, Q n.

(** Prove que estes princípios são equivalentes: *)

Lemma PIF_to_PIM: PIF -> PIM.
Proof.
(* Substitua esta linha pela sua prova*) Admitted.

Lemma PIM_to_PIF: PIM -> PIF.
Proof.
(* Substitua esta linha pela sua prova*) Admitted.

Theorem PIM_equiv_PIF: PIM <-> PIF.
Proof.
  (* Substitua esta linha pela sua prova*) Admitted.


Require Import Arith.
Require Import Coq.Lists.List.
Require Import extEqualNat.
Require Import primRec.
Require Vector.
Require Import Div2.

Definition sumToN (n : nat) :=
  nat_rec (fun _ => nat) 0 (fun x y : nat => S x + y) n.

Lemma sumToN1 : forall n : nat, n <= sumToN n.
Proof.
intros.
induction n as [| n Hrecn].
auto.
simpl in |- *.
apply le_n_S.
apply le_plus_l.
Qed.

Lemma sumToN2 : forall b a : nat, a <= b -> sumToN a <= sumToN b.
Proof.
intro.
induction b as [| b Hrecb]; intros.
simpl in |- *.
rewrite <- (le_n_O_eq _ H).
simpl in |- *.
auto.
induction (le_lt_or_eq _ _ H).
apply le_trans with (sumToN b).
apply Hrecb.
apply lt_n_Sm_le.
auto.
simpl in |- *.
apply le_S.
apply le_plus_r.
rewrite H0.
auto.
Qed.

Lemma sumToNIsPR : isPR 1 sumToN.
Proof.
unfold sumToN in |- *.
apply indIsPR with (f := fun x y : nat => S x + y).
apply
 compose2_2IsPR
  with (f := fun x y : nat => S x) (g := fun x y : nat => y) (h := plus).
apply filter10IsPR.
apply succIsPR.
apply pi2_2IsPR.
apply plusIsPR.
Qed.

Definition cPair (a b : nat) := a + sumToN (a + b).

Lemma cPairIsPR : isPR 2 cPair.
Proof.
intros.
unfold cPair in |- *.
apply
 compose2_2IsPR
  with
    (f := fun x y : nat => x)
    (g := fun x y : nat => sumToN (x + y))
    (h := plus).
apply pi1_2IsPR.
apply compose2_1IsPR.
apply plusIsPR.
apply sumToNIsPR.
apply plusIsPR.
Qed.

Section CPair_Injectivity.

Remark cPairInjHelp :
 forall a b c d : nat, cPair a b = cPair c d -> a + b = c + d.
Proof.
assert (forall a b : nat, a < b -> a + sumToN a < sumToN b).
simple induction b.
intros.
elim (lt_n_O _ H).
intros.
simpl in |- *.
assert (a <= n).
apply lt_n_Sm_le.
assumption.
induction (le_lt_or_eq a n H1).
apply lt_trans with (sumToN n).
auto.
apply le_lt_n_Sm.
apply le_plus_r.
rewrite H2.
apply lt_n_Sn.
unfold cPair in |- *.
assert
 (forall a b c d : nat,
  a <= c -> b <= d -> a + sumToN c = b + sumToN d -> c = d).
intros.
induction (le_or_lt c d).
induction (le_lt_or_eq _ _ H3).
assert (a + sumToN c < sumToN d).
apply le_lt_trans with (c + sumToN c).
apply plus_le_compat_r.
auto.
auto.
rewrite H2 in H5.
elim (lt_not_le _ _ H5).
apply le_plus_r.
auto.
assert (b + sumToN d < sumToN c).
apply le_lt_trans with (d + sumToN d).
apply plus_le_compat_r.
auto.
auto.
rewrite <- H2 in H4.
elim (lt_not_le _ _ H4).
apply le_plus_r.
intros.
eapply H0.
apply le_plus_l.
apply le_plus_l.
auto.
Qed.

Lemma cPairInj1 : forall a b c d : nat, cPair a b = cPair c d -> a = c.
Proof.
intros.
assert (a + b = c + d).
apply cPairInjHelp.
auto.
eapply plus_reg_l.
unfold cPair in H.
rewrite (plus_comm a) in H.
rewrite (plus_comm c) in H.
rewrite H0 in H.
apply H.
Qed.

Lemma cPairInj2 : forall a b c d : nat, cPair a b = cPair c d -> b = d.
Proof.
intros.
assert (a + b = c + d).
apply cPairInjHelp.
auto.
assert (a = c).
eapply cPairInj1.
apply H.
eapply plus_reg_l.
rewrite H1 in H0.
apply H0.
Qed.

End CPair_Injectivity.

Section CPair_projections.

Let searchXY (a : nat) :=
  boundedSearch (fun a y : nat => ltBool a (sumToN (S y))) a.

Definition cPairPi1 (a : nat) := a - sumToN (searchXY a).
Definition cPairPi2 (a : nat) := searchXY a - cPairPi1 a.

Lemma cPairProjectionsHelp :
 forall a b : nat, b < sumToN (S a) -> sumToN a <= b -> searchXY b = a.
Proof.
intros.
unfold searchXY in |- *.
induction (boundedSearch2 (fun b y : nat => ltBool b (sumToN (S y))) b).
rewrite H1.
induction (eq_nat_dec b a).
auto.
elim (ltBoolFalse b (sumToN (S a))).
apply (boundedSearch1 (fun b y : nat => ltBool b (sumToN (S y))) b).
rewrite H1.
induction (nat_total_order _ _ b0).
elim (lt_not_le _ _ H2).
apply le_trans with (sumToN a).
apply sumToN1.
auto.
auto.
auto.
set (c := boundedSearch (fun b y : nat => ltBool b (sumToN (S y))) b) in *.
induction (eq_nat_dec c a).
auto.
elim (ltBoolFalse b (sumToN (S a))).
apply (boundedSearch1 (fun b y : nat => ltBool b (sumToN (S y))) b).
fold c in |- *.
induction (nat_total_order _ _ b0).
elim (le_not_lt _ _ H0).
apply lt_le_trans with (sumToN (S c)).
apply ltBoolTrue.
auto.
assert (S c <= a).
apply lt_n_Sm_le.
apply lt_n_S.
auto.
apply sumToN2.
auto.
auto.
auto.
Qed.

Lemma cPairProjections : forall a : nat, cPair (cPairPi1 a) (cPairPi2 a) = a.
Proof.
assert
 (forall a b : nat, b < sumToN a -> cPair (cPairPi1 b) (cPairPi2 b) = b).
intros.
induction a as [| a Hreca].
simpl in H.
elim (lt_n_O _ H).
induction (le_or_lt (sumToN a) b).
assert (searchXY b = a).
apply cPairProjectionsHelp; auto.
unfold cPair in |- *.
replace (cPairPi1 b + cPairPi2 b) with a.
unfold cPairPi1 in |- *.
rewrite H1.
rewrite plus_comm.
rewrite <- le_plus_minus.
reflexivity.
auto.
unfold cPairPi2 in |- *.
rewrite <- le_plus_minus.
auto.
unfold cPairPi1 in |- *.
rewrite H1.
simpl in H.
apply (fun p n m : nat => plus_le_reg_l n m p) with (sumToN a).
rewrite <- le_plus_minus.
rewrite plus_comm.
apply lt_n_Sm_le.
auto.
auto.
apply Hreca.
auto.
intros.
apply H with (S a).
apply lt_le_trans with (S a).
apply lt_n_Sn.
apply sumToN1.
Qed.

Remark searchXYIsPR : isPR 1 searchXY.
Proof.
unfold searchXY in |- *.
apply boundSearchIsPR with (P := fun a y : nat => ltBool a (sumToN (S y))).
unfold isPRrel in |- *.
apply
 compose2_2IsPR
  with
    (h := charFunction 2 ltBool)
    (f := fun a y : nat => a)
    (g := fun a y : nat => sumToN (S y)).
apply pi1_2IsPR.
apply filter01IsPR with (g := fun y : nat => sumToN (S y)).
apply compose1_1IsPR.
apply succIsPR.
apply sumToNIsPR.
apply ltIsPR.
Qed.

Lemma cPairPi1IsPR : isPR 1 cPairPi1.
Proof.
unfold cPairPi1 in |- *.
apply
 compose1_2IsPR
  with
    (g := minus)
    (f := fun x : nat => x)
    (f' := fun a : nat => sumToN (searchXY a)).
apply idIsPR.
apply compose1_1IsPR.
apply searchXYIsPR.
apply sumToNIsPR.
apply minusIsPR.
Qed.

Lemma cPairPi2IsPR : isPR 1 cPairPi2.
Proof.
unfold cPairPi2 in |- *.
apply compose1_2IsPR with (g := minus) (f := searchXY) (f' := cPairPi1).
apply searchXYIsPR.
apply cPairPi1IsPR.
apply minusIsPR.
Qed.

Lemma cPairProjections1 : forall a b : nat, cPairPi1 (cPair a b) = a.
Proof.
intros.
unfold cPair in |- *.
unfold cPairPi1 in |- *.
replace (searchXY (a + sumToN (a + b))) with (a + b).
rewrite plus_comm.
apply minus_plus.
symmetry  in |- *.
apply cPairProjectionsHelp.
simpl in |- *.
apply le_lt_n_Sm.
apply plus_le_compat_r.
apply le_plus_l.
apply le_plus_r.
Qed.

Lemma cPairProjections2 : forall a b : nat, cPairPi2 (cPair a b) = b.
Proof.
intros.
unfold cPairPi2 in |- *.
rewrite cPairProjections1.
unfold cPair in |- *.
replace (searchXY (a + sumToN (a + b))) with (a + b).
apply minus_plus.
symmetry  in |- *.
apply cPairProjectionsHelp.
simpl in |- *.
apply le_lt_n_Sm.
apply plus_le_compat_r.
apply le_plus_l.
apply le_plus_r.
Qed.

End CPair_projections.

Section CPair_Order.

Lemma cPairLe1 : forall a b : nat, a <= cPair a b.
Proof.
intros.
unfold cPair in |- *.
apply le_plus_l.
Qed.

Lemma cPairLe1A : forall a : nat, cPairPi1 a <= a.
intros.
apply le_trans with (cPair (cPairPi1 a) (cPairPi2 a)).
apply cPairLe1.
rewrite cPairProjections.
apply le_n.
Qed.

Lemma cPairLe2 : forall a b : nat, b <= cPair a b.
Proof.
intros.
unfold cPair in |- *.
eapply le_trans.
apply le_plus_r.
apply plus_le_compat_l.
apply le_trans with (a + b).
apply le_plus_r.
apply sumToN1.
Qed.

Lemma cPairLe2A : forall a : nat, cPairPi2 a <= a.
intros.
apply le_trans with (cPair (cPairPi1 a) (cPairPi2 a)).
apply cPairLe2.
rewrite cPairProjections.
apply le_n.
Qed.

Lemma cPairLe3 :
 forall a b c d : nat, a <= b -> c <= d -> cPair a c <= cPair b d.
Proof.
intros.
unfold cPair in |- *.
apply le_trans with (a + sumToN (b + d)).
apply plus_le_compat_l.
apply sumToN2.
apply le_trans with (a + d).
apply plus_le_compat_l.
auto.
apply plus_le_compat_r.
auto.
apply plus_le_compat_r.
auto.
Qed.

Lemma cPairLt1 : forall a b : nat, a < cPair a (S b).
Proof.
intros.
unfold cPair in |- *.
rewrite (plus_comm a (S b)).
simpl in |- *.
rewrite plus_comm.
simpl in |- *.
rewrite plus_comm.
unfold lt in |- *.
apply le_n_S.
apply le_plus_l.
Qed.

Lemma cPairLt2 : forall a b : nat, b < cPair (S a) b.
Proof.
intros.
unfold cPair in |- *.
simpl in |- *.
unfold lt in |- *.
apply le_n_S.
eapply le_trans.
apply le_plus_r.
apply plus_le_compat_l.
apply le_S.
eapply le_trans.
apply le_plus_l.
rewrite plus_comm.
apply le_plus_l.
Qed.

End CPair_Order.

Section code_nat_list.

Fixpoint codeList (l : list nat) : nat :=
  match l with
  | nil => 0
  | n :: l' => S (cPair n (codeList l'))
  end.

Lemma codeListInj : forall l m : list nat, codeList l = codeList m -> l = m.
Proof.
intro.
induction l as [| a l Hrecl].
intros.
destruct m as [| n l].
reflexivity.
discriminate H.
intros.
destruct m as [| n l0].
discriminate H.
simpl in H.
replace n with a.
rewrite (Hrecl l0).
reflexivity.
eapply cPairInj2.
apply eq_add_S.
apply H.
eapply cPairInj1.
apply eq_add_S.
apply H.
Qed.

Definition codeNth (n m : nat) : nat.
intros.
assert nat.
induction n as [| n Hrecn].
exact m.
exact (cPairPi2 (pred Hrecn)).
exact (cPairPi1 (pred H)).
Defined.

Let drop (n : nat) : forall (l : list nat), list nat.
induction n as [| n Hrecn].
exact (fun l => l).
intros.
apply Hrecn.
destruct l.
exact (nil (A:=nat)).
exact l.
Defined.

Lemma codeNthCorrect :
 forall (n : nat) (l : list nat), codeNth n (codeList l) = nth n l 0.
Proof.
unfold codeNth in |- *.
set
 (A :=
  fun l : list nat => match l with
                      | nil => nil (A:=nat)
                      | _ :: l0 => l0
                      end) in *.
assert (forall l : list nat, cPairPi2 (pred (codeList l)) = codeList (A l)).
destruct l.
simpl in |- *.
apply (cPairProjections2 0 0).
simpl in |- *.
apply cPairProjections2.
assert
 (forall (n : nat) (l : list nat),
  nat_rec (fun _ : nat => nat) (codeList l)
    (fun _ Hrecn : nat => cPairPi2 (pred Hrecn)) n =
  codeList (drop n l)).
simple induction n.
simpl in |- *.
reflexivity.
simpl in |- *.
intros.
rewrite H0.
rewrite H.
unfold A in |- *.
clear H0.
generalize l.
clear l.
induction n0 as [| n0 Hrecn0]; simpl in |- *; intros.
reflexivity.
destruct l.
apply (Hrecn0 nil).
apply Hrecn0.
intros.
replace (nth n l 0) with match drop n l with
                         | nil => 0
                         | a :: _ => a
                         end.
rewrite H0.
destruct (drop n l).
simpl in |- *.
apply (cPairProjections1 0 0).
simpl in |- *.
apply cPairProjections1.
generalize l.
clear l.
induction n as [| n Hrecn].
destruct l; reflexivity.
destruct l.
simpl in Hrecn.
destruct n; apply (Hrecn nil).
simpl in |- *.
auto.
Qed.

Lemma codeNthIsPR : isPR 2 codeNth.
Proof.
intros.
unfold codeNth in |- *.
apply
 compose2_1IsPR
  with
    (g := fun x : nat => cPairPi1 (pred x))
    (f := fun n m : nat =>
          nat_rec (fun _ : nat => nat) m
            (fun _ Hrecn : nat => cPairPi2 (pred Hrecn)) n).
apply
 ind1ParamIsPR
  with
    (g := fun m : nat => m)
    (f := fun _ Hrecn m : nat => cPairPi2 (pred Hrecn)).
apply filter010IsPR with (g := fun x : nat => cPairPi2 (pred x)).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi2IsPR.
apply idIsPR.
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi1IsPR.
Qed.

End code_nat_list.

Section Strong_Recursion.

Definition evalStrongRecHelp (n : nat) (f : naryFunc (S (S n))) :
  naryFunc (S n) :=
  evalPrimRecFunc n (evalComposeFunc n 0 (Vector.nil _) (codeList nil))
    (evalComposeFunc (S (S n)) 2
       (Vector.cons _ f _
          (Vector.cons _ (evalProjFunc (S (S n)) n (lt_S _ _ (lt_n_Sn _))) _
             (Vector.nil _))) (fun a b : nat => S (cPair a b))).

Definition evalStrongRec (n : nat) (f : naryFunc (S (S n))) :
  naryFunc (S n) :=
  evalComposeFunc (S n) 1
    (Vector.cons _ (fun z : nat => evalStrongRecHelp n f (S z)) _ (Vector.nil _))
    (fun z : nat => cPairPi1 (pred z)).

Lemma evalStrongRecIsPR :
 forall (n : nat) (f : naryFunc (S (S n))),
 isPR _ f -> isPR _ (evalStrongRec n f).
Proof.
intros.
unfold evalStrongRec, evalStrongRecHelp in |- *.
fold (naryFunc (S n)) in |- *.
set
 (A :=
  evalPrimRecFunc n (evalComposeFunc n 0 (Vector.nil (naryFunc n)) (codeList nil))
    (evalComposeFunc (S (S n)) 2
       (Vector.cons (naryFunc (S (S n))) f 1
          (Vector.cons (naryFunc (S (S n)))
             (evalProjFunc (S (S n)) n (lt_S n (S n) (lt_n_Sn n))) 0
             (Vector.nil (naryFunc (S (S n)))))) (fun a b : nat => S (cPair a b))))
 in *.
assert (isPR (S n) A).
unfold A in |- *.
assert (isPR 2 (fun a b : nat => S (cPair a b))).
apply compose2_1IsPR.
apply cPairIsPR.
apply succIsPR.
assert (isPR 1 (fun z : nat => cPairPi1 (pred z))).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi1IsPR.
induction H as (x, p).
induction H0 as (x0, p0).
induction H1 as (x1, p1).
exists
 (primRecFunc n (composeFunc n 0 (PRnil _) zeroFunc)
    (composeFunc (S (S n)) 2
       (PRcons _ _ x
          (PRcons _ _ (projFunc (S (S n)) n (lt_S n (S n) (lt_n_Sn n)))
             (PRnil _))) x0)).
apply
 extEqualTrans
  with
    (evalPrimRecFunc n (evalComposeFunc n 0 (Vector.nil _) 0)
       (evalComposeFunc (S (S n)) 2
          (Vector.cons _ (evalPrimRec _ x) _
             (Vector.cons _ (evalProjFunc (S (S n)) n (lt_S n (S n) (lt_n_Sn n))) _
                (Vector.nil _))) (evalPrimRec _ x0))).
apply extEqualRefl.
apply extEqualPrimRec.
simpl in |- *.
apply extEqualRefl.
apply extEqualCompose.
unfold extEqualVector, extEqualVectorGeneral, Vector.t_rect in |- *.
repeat split; auto.
apply extEqualRefl.
auto.
assert (isPR (S n) (fun z : nat => A (S z))).
apply compose1_NIsPR.
auto.
apply succIsPR.
clear H0.
assert (isPR 1 (fun z : nat => cPairPi1 (pred z))).
apply compose1_1IsPR.
apply predIsPR.
apply cPairPi1IsPR.
induction H0 as (x, p).
induction H1 as (x0, p0).
exists (composeFunc (S n) 1 (PRcons _ _ x0 (PRnil _)) x).
simpl in |- *.
fold (naryFunc n) in |- *.
intros.
apply extEqualCompose.
unfold extEqualVector in |- *.
simpl in |- *.
repeat split.
apply (p0 c).
auto.
Qed.

Lemma computeEvalStrongRecHelp :
 forall (n : nat) (f : naryFunc (S (S n))) (c : nat),
 evalStrongRecHelp n f (S c) =
 compose2 n (evalStrongRecHelp n f c)
   (fun a0 : nat =>
    evalComposeFunc n 2
      (Vector.cons (naryFunc n) (f c a0) 1
         (Vector.cons (naryFunc n) (evalConstFunc n a0) 0 (Vector.nil (naryFunc n))))
      (fun a1 b0 : nat => S (cPair a1 b0))).
Proof.
intros.
unfold evalStrongRecHelp at 1 in |- *.
simpl in |- *.
fold (naryFunc n) in |- *.
induction (eq_nat_dec n (S n)).
elim (lt_not_le n (S n)).
apply lt_n_Sn.
rewrite <- a.
auto.
induction (eq_nat_dec n n).
replace
 (evalPrimRecFunc n (evalComposeFunc n 0 (Vector.nil (naryFunc n)) 0)
    (fun a0 a1 : nat =>
     evalComposeFunc n 2
       (Vector.cons (naryFunc n) (f a0 a1) 1
          (Vector.cons (naryFunc n) (evalConstFunc n a1) 0 (Vector.nil (naryFunc n))))
       (fun a2 b0 : nat => S (cPair a2 b0))) c) with
 (evalStrongRecHelp n f c).
reflexivity.
unfold evalStrongRecHelp at 1 in |- *.
simpl in |- *.
fold (naryFunc n) in |- *.
induction (eq_nat_dec n (S n)).
elim b.
auto.
induction (eq_nat_dec n n).
reflexivity.
elim b1.
auto.
elim b0.
auto.
Qed.

Let listValues (f : naryFunc 2) (n : nat) : list nat.
intros.
induction n as [| n Hrecn].
exact nil.
exact (evalStrongRec _ f n :: Hrecn).
Defined.

Lemma evalStrongRecHelp1 :
 forall (f : naryFunc 2) (n m : nat),
 m < n -> codeNth (n - S m) (evalStrongRecHelp _ f n) = evalStrongRec _ f m.
Proof.
assert
 (forall (f : naryFunc 2) (n : nat),
  evalStrongRecHelp _ f n = codeList (listValues f n)).
intros.
induction n as [| n Hrecn].
simpl in |- *.
unfold evalStrongRecHelp in |- *.
simpl in |- *.
reflexivity.
unfold evalStrongRecHelp in |- *.
simpl in |- *.
unfold evalStrongRecHelp in Hrecn.
simpl in Hrecn.
rewrite Hrecn.
unfold evalStrongRec in |- *.
simpl in |- *.
rewrite cPairProjections1.
rewrite Hrecn.
reflexivity.
intros.
rewrite H.
rewrite codeNthCorrect.
induction n as [| n Hrecn].
elim (lt_n_O _ H0).
induction (le_lt_or_eq _ _ H0).
rewrite <- minus_Sn_m.
simpl in |- *.
rewrite Hrecn.
reflexivity.
apply lt_S_n.
auto.
apply lt_n_Sm_le.
auto.
inversion H1.
rewrite <- minus_n_n.
clear H3 H1 Hrecn H0 m.
simpl in |- *.
reflexivity.
Qed.

Lemma evalStrongRecHelpParam :
 forall (a n c : nat) (f : naryFunc (S (S (S a)))),
 extEqual a (evalStrongRecHelp (S a) f n c)
   (evalStrongRecHelp a (fun x y : nat => f x y c) n).
Proof.
intros.
unfold evalStrongRecHelp in |- *.
eapply extEqualTrans.
apply extEqualSym.
apply evalPrimRecParam.
assert
 (extEqual (S a)
    (evalPrimRecFunc a
       (evalComposeFunc (S a) 0 (Vector.nil (naryFunc (S a))) (codeList nil) c)
       (fun x y : nat =>
        evalComposeFunc (S (S (S a))) 2
          (Vector.cons (naryFunc (S (S (S a)))) f 1
             (Vector.cons (naryFunc (S (S (S a))))
                (evalProjFunc (S (S (S a))) (S a)
                   (lt_S (S a) (S (S a)) (lt_n_Sn (S a)))) 0
                (Vector.nil (naryFunc (S (S (S a)))))))
          (fun a0 b : nat => S (cPair a0 b)) x y c))
    (evalPrimRecFunc a
       (evalComposeFunc a 0 (Vector.nil (naryFunc a)) (codeList nil))
       (evalComposeFunc (S (S a)) 2
          (Vector.cons (naryFunc (S (S a))) (fun x y : nat => f x y c) 1
             (Vector.cons (naryFunc (S (S a)))
                (evalProjFunc (S (S a)) a (lt_S a (S a) (lt_n_Sn a))) 0
                (Vector.nil (naryFunc (S (S a))))))
          (fun a0 b : nat => S (cPair a0 b))))).
apply
 (extEqualPrimRec a
    (evalComposeFunc (S a) 0 (Vector.nil (naryFunc (S a))) (codeList nil) c)).
simpl in |- *.
apply extEqualRefl.
simpl in |- *.
fold (naryFunc a) in |- *.
induction
 (sumbool_rec
    (fun _ : {a = S a} + {a <> S a} => {S a = S (S a)} + {S a <> S (S a)})
    (fun a0 : a = S a => left (S a <> S (S a)) (f_equal S a0))
    (fun b : a <> S a => right (S a = S (S a)) (not_eq_S a (S a) b))
    (eq_nat_dec a (S a))).
elim (lt_not_le (S a) (S (S a))).
apply lt_n_Sn.
rewrite <- a0.
auto.
induction
 (sumbool_rec (fun _ : {a = a} + {a <> a} => {S a = S a} + {S a <> S a})
    (fun a0 : a = a => left (S a <> S a) (f_equal S a0))
    (fun b0 : a <> a => right (S a = S a) (not_eq_S a a b0))
    (eq_nat_dec a a)).
induction (eq_nat_dec a (S a)).
elim (lt_not_le a (S a)).
apply lt_n_Sn.
rewrite <- a1.
auto.
induction (eq_nat_dec a a).
intros.
apply extEqualRefl.
elim b1.
auto.
elim b0.
auto.
apply (H n).
Qed.

Lemma evalStrongRecHelp2 :
 forall (a : nat) (f : naryFunc (S (S a))) (n m : nat),
 m < n ->
 extEqual _
   (evalComposeFunc _ 1 (Vector.cons _ (evalStrongRecHelp _ f n) 0 (Vector.nil _))
      (fun b : nat => codeNth (n - S m) b)) (evalStrongRec _ f m).
Proof.
intro.
fold (naryFunc a) in |- *.
induction a as [| a Hreca].
simpl in |- *.
apply evalStrongRecHelp1.
simpl in |- *.
intros.
fold (naryFunc a) in |- *.
set (g := fun x y : nat => f x y c) in *.
assert
 (extEqual a
    (evalComposeFunc a 1
       (Vector.cons (naryFunc a) (evalStrongRecHelp a g n) 0 (Vector.nil (naryFunc a)))
       (fun b : nat => codeNth (n - S m) b)) (evalStrongRec a g m)).
apply Hreca.
auto.
unfold g in H0.
clear g Hreca.
apply extEqualTrans with (evalStrongRec a (fun x y : nat => f x y c) m).
apply
 extEqualTrans
  with
    (evalComposeFunc a 1
       (Vector.cons (naryFunc a) (evalStrongRecHelp a (fun x y : nat => f x y c) n)
          0 (Vector.nil (naryFunc a))) (fun b : nat => codeNth (n - S m) b)).
apply extEqualCompose.
unfold extEqualVector in |- *.
simpl in |- *.
repeat split.
apply evalStrongRecHelpParam.
apply extEqualRefl.
apply H0.
unfold evalStrongRec in |- *.
simpl in |- *.
fold (naryFunc a) in |- *.
apply extEqualCompose.
unfold extEqualVector in |- *.
simpl in |- *.
repeat split.
apply extEqualSym.
apply evalStrongRecHelpParam.
apply extEqualRefl.
Qed.

Lemma callIsPR :
 forall g : nat -> nat,
 isPR 1 g -> isPR 2 (fun a recs : nat => codeNth (a - S (g a)) recs).
Proof.
intros.
apply
 compose2_2IsPR
  with (f := fun a recs : nat => a - S (g a)) (g := fun a recs : nat => recs).
apply filter10IsPR with (g := fun a : nat => a - S (g a)).
apply
 compose1_2IsPR with (f := fun a : nat => a) (f' := fun a : nat => S (g a)).
apply idIsPR.
apply compose1_1IsPR.
assumption.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
Qed.

End Strong_Recursion.

Lemma div2IsPR : isPR 1 div2.
Proof.
assert
 (isPR 1
    (evalStrongRec 0
       (fun n recs : nat =>
        switchPR n
          (switchPR (pred n) (S (codeNth (n - S (pred (pred n))) recs)) 0) 0))).
apply evalStrongRecIsPR.
assert (isPR 2 (fun n recs : nat => 0)).
exists (composeFunc 2 0 (PRnil _) zeroFunc).
simpl in |- *.
auto.
apply
 compose2_3IsPR
  with
    (f1 := fun n recs : nat => n)
    (f2 := fun n recs : nat =>
           switchPR (pred n) (S (codeNth (n - S (pred (pred n))) recs)) 0)
    (f3 := fun n recs : nat => 0).
apply pi1_2IsPR.
apply
 compose2_3IsPR
  with
    (f1 := fun n recs : nat => pred n)
    (f2 := fun n recs : nat => S (codeNth (n - S (pred (pred n))) recs))
    (f3 := fun n recs : nat => 0).
apply filter10IsPR.
apply predIsPR.
apply
 compose2_1IsPR
  with (f := fun n recs : nat => codeNth (n - S (pred (pred n))) recs).
apply
 compose2_2IsPR
  with
    (f := fun n recs : nat => n - S (pred (pred n)))
    (g := fun n recs : nat => recs).
apply filter10IsPR with (g := fun n : nat => n - S (pred (pred n))).
apply
 compose1_2IsPR
  with (f := fun n : nat => n) (f' := fun n : nat => S (pred (pred n))).
apply idIsPR.
apply compose1_1IsPR with (f := fun n : nat => pred (pred n)).
apply compose1_1IsPR; apply predIsPR.
apply succIsPR.
apply minusIsPR.
apply pi2_2IsPR.
apply codeNthIsPR.
apply succIsPR.
auto.
apply switchIsPR.
auto.
apply switchIsPR.
induction H as (x, p).
exists x.
eapply extEqualTrans.
apply p.
clear p x.
simpl in |- *.
intros.
set
 (f :=
  fun n recs : nat =>
  switchPR n (switchPR (pred n) (S (codeNth (n - S (pred (pred n))) recs)) 0)
    0) in *.
elim c using ind_0_1_SS.
unfold evalStrongRec in |- *.
simpl in |- *.
auto.
unfold evalStrongRec in |- *.
simpl in |- *.
apply cPairProjections1.
intros.
unfold evalStrongRec in |- *.
unfold evalComposeFunc in |- *.
unfold evalOneParamList in |- *.
rewrite computeEvalStrongRecHelp.
unfold f at 2 in |- *.
set (A := S (S n) - S (pred (pred (S (S n))))) in *.
simpl in |- *.
rewrite cPairProjections1.
apply eq_S.
rewrite <- H.
unfold A in |- *.
apply evalStrongRecHelp1.
auto.
Qed.


Lemma mult_0_r : forall n: nat,
                   n * 0 = 0.
Proof.
  intros n.
  induction n.
  + simpl.
    reflexivity.
  + simpl.
    apply IHn.
Qed.

Lemma add_swap: forall l n m:nat, l + (n + m) = n + (l + m).
- intros.
  induction l.
  simpl.
  reflexivity.
  simpl.
  rewrite IHl.
  assert(I: forall m n: nat, S(m + n) = m + S n).
  * intros m1 m2.
    induction m1.
    simpl.
    reflexivity.
    simpl.
    rewrite IHm1.
    reflexivity.
  * rewrite I.
    reflexivity.
Qed.

Lemma add_remove_l: forall j k l m n:nat,
                      j + k = l + m ->
                      n + j + k = n + l + m.
Proof.
  intros j k l m n.
  intros H.
  induction n.
  + simpl.
    apply H.
  + simpl.
    rewrite IHn.
    reflexivity.
Qed.

Lemma mult_succ : forall m n:nat,
                    n * S m = n + n * m.
Proof.
  intros m n.
  induction n.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHn.
    - assert(H: (m + (n + n*m)) = (n + (m + n * m))).
      rewrite add_swap.
      reflexivity.
      rewrite H.
      reflexivity.
Qed.

Theorem mult_plus_distr_r : forall m n p: nat,
                              (n + m) * p = n * p + m * p.
Proof.
  intros m n p.
  induction p.
  + rewrite mult_0_r.
    rewrite mult_0_r.
    rewrite mult_0_r.
    reflexivity.
  + rewrite mult_succ.
    rewrite mult_succ.
    rewrite mult_succ.
    rewrite IHp.
    assert (H: m + (n * p + m *p) = n * p + (m + m * p)).
    - rewrite add_swap.
      reflexivity.
    - apply add_remove_l.
      apply add_swap.
Qed.

Theorem mult_plus_distr_l : forall m n p: nat,
                              p * (n + m) = p *n + p * m.
Proof.
  intros m n p.
  induction p.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHp.
    assert(H: m + (p * n + p * m) = p * n + (m + p * m)).
    - rewrite add_swap.
      reflexivity.
    - apply add_remove_l.
      apply add_swap.
Qed.

Theorem mult_assoc : forall n m p: nat,
                       n * (m * p) = (n * m) * p.
Proof.
  intros n m p.
  induction m.
  + simpl.
    rewrite mult_0_r.
    simpl.
    reflexivity.
  + simpl.
    rewrite mult_succ.
    rewrite mult_plus_distr_r.
    rewrite mult_plus_distr_l.
    rewrite IHm.
    reflexivity.
Qed.

Lemma add_succ : forall n m: nat,
                   n + S m = S (n + m).
Proof.
  intros n m.
  induction n.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHn.
    reflexivity.
Qed.

Theorem plus_swap' : forall n m p: nat,
                       n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  induction n.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHn.
    rewrite add_succ.
    reflexivity.
Qed.

Inductive bin: Type :=
| O  : bin
| B  : bin -> bin
| BPlus : bin -> bin.

Fixpoint incb(b: bin) : bin :=
  match b with
    | O => BPlus O
    | B b' => BPlus b'
    | BPlus b' => B (incb b')
  end.

Fixpoint to_nat (b: bin) : nat :=
  match b with
    | O => 0
    | B b' => (to_nat b') * 2
    | BPlus b' => (to_nat b') * 2 + 1
  end.

Lemma add_0_r: forall n: nat,
                 n + 0 = n.
Proof.
  intros n.
  induction n.
  + reflexivity.
  + simpl.
    rewrite IHn.
    reflexivity.
Qed.

Theorem to_nat_comm: forall b: bin,
         to_nat (incb b) = S (to_nat b).
Proof.
  intros b.
  induction b.
  + simpl.
    reflexivity.
  + simpl.
    rewrite add_succ.
    rewrite add_0_r.
    reflexivity.
  + simpl.
    rewrite add_succ.
    rewrite add_0_r.
    rewrite IHb.
    simpl.
    reflexivity.
Qed.

Fixpoint to_bin (n :nat) :bin :=
  match n with
    | 0 => O
    | S n => incb (to_bin n)
  end.

Theorem nat_bin_nat: forall n: nat,
                       to_nat (to_bin n) = n.
Proof.
  intros n.
  induction n.
  + simpl. reflexivity.
  + simpl.
    rewrite to_nat_comm.
    rewrite IHn.
    reflexivity.
Qed.

Definition id_bin (b: bin): bin :=
  to_bin (to_nat b).

Theorem bin_nat_bin: forall b: bin,
                       to_bin (to_nat b) = b.
Proof.
  intros b.
  induction b.
  + simpl.
    reflexivity.
  + simpl.


(* Exercise coq_nat_11 *)

(* Do you know that having stamps of nominals 3 and 5 you can
   pay any value greater or equal than 8?
   Below is a Coq specification of this statemant - can you
   prove it? *)
Require Import Arith.

(* Hint: for arithmetical reasoning you may try to use the
         'lia' tactic. If you do that you will only get
	 Correct for this exercise (and not Solved), as this
	 is one of the powerful automated Coq tactics, that
	 are in principle not allowed to be used for solving
	 those exercises. In this case, however, it is ok
	 to use lia.

   Remark: if afterwards you decide to try to prove it without
           the use of lia, it should give you a good idea
	   of how helpful such automated tactics can be!
*)
Require Import Lia.

Lemma stamps : forall i, exists v3, exists v5, i + 8 = 3*v3 + 5*v5.

Proof.
intros.
induction i.
exists 1.
exists 1.
simpl.
reflexivity.
(* Remove 3*3 and add 2* 5*)
Qed.


Require Import ZArith.
Open Scope Z_scope.

Definition square (a b:Z) := a^2 = b.
Definition pre_sqrt (x n:Z) := x^2 <= n.
Definition sqrt (x n:Z) := x^2 <= n < (x+1)^2.


(**
A Gentle Introduction to Type Classes and Relations in Coq
の Chapter 2 An Introductory Example: Computing x^n
の抜萃をもとに説明のための修正を加えました。

@suharahiromichi

2017_09_10
*)

Set Implicit Arguments.

Require Import Arith.                       (* for ring. *)
Require Import ZArith.
Require Import Div2.
Require Import Program.

(** Monoid モノイド
- carrier (台) A
- binary, associative operation 'dot' on A
- neutral element 1 ∈ A for 'dot'
 *)
Class Monoid {A : Type} (dot : A -> A -> A) (one : A) : Type :=
  {
    dot_assoc : forall x y z: A, dot x (dot y z) = dot (dot x y) z;
    one_left  : forall x, dot one x = x;
    one_right : forall x, dot x one = x
  }.

(* **************** *)
(* 自然数 (nat,*,1) *)
(* **************** *)
Program Instance Mult : Monoid mult 1%nat.
Obligation 1.                               (* x * (y * z) = x * y * z *)
Proof.
  ring.
Qed.
Obligation 3.                               (* x * 1 = x *)
Proof.
  ring.
Qed.

(* ************ *)
(* 整数 (Z,*,1) *)
(* ************ *)
Open Scope Z_scope.                         (* 以降、自然数は 1%nat のように。 *)

Program Instance ZMult : Monoid Zmult 1.
Obligation 1.                               (* x * (y * z) = x * y * z *)
Proof.
  ring.
Qed.
Obligation 2.                               (* 1 * x = x *)
Proof.
  now destruct x.
Qed.
Obligation 3.                               (* x * 1 = x *)
Proof.
  ring.
Qed.

(* 2x2 行列 Matrix の定義 *)
Section M2_def.

  Variable (A : Type).
  Variable (zero one : A).
  Variable (plus mult : A -> A -> A).

  (*
  (* ring タクティクのために ring_theory を使う場合。 *)
  Variable (minus : A -> A -> A).
  Variable (sym : A -> A).
  Variable rth : ring_theory zero one plus mult minus sym (@eq A).
  Add Ring Aring : rth.
   *)
  (* ring タクティクのために semi_ring_theory を使う場合。 *)
  Variable sth : semi_ring_theory zero one plus mult (@eq A).
  Add Ring Aring : sth.

  Notation "0" := zero.
  Notation "1" := one.
  Notation "x + y" := (plus x y).
  Notation "x * y" := (mult x y).

  Structure M2 : Type := {c00 : A;  c01 : A;
                          c10 : A;  c11 : A}.

  Definition Id2 : M2 := Build_M2 1 0 0 1.

  Definition M2_mult (m m' : M2) : M2 :=
    Build_M2 (c00 m * c00 m' + c01 m * c10 m')
             (c00 m * c01 m' + c01 m * c11 m')
             (c10 m * c00 m' + c11 m * c10 m')
             (c10 m * c01 m' + c11 m * c11 m').

  Lemma M2_eq_intros : forall a b c d a' b' c' d',
      a = a' -> b = b' -> c = c' -> d = d' ->
      Build_M2 a b c d = Build_M2 a' b' c' d'.
  Proof.
    intros; now f_equal.
  Qed.

  Program Instance M2_Monoid : Monoid M2_mult Id2.
  Obligation 1.
  (*
  M2_mult plus mult x (M2_mult plus mult y z) =
   M2_mult plus mult (M2_mult plus mult x y) z
   *)
  Proof.
    destruct x; destruct y; destruct z; simpl.
    unfold M2_mult; apply M2_eq_intros; simpl; ring.
  Qed.
  Obligation 2.                             (* M2_mult plus mult (Id2 0 1) x = x *)
    destruct x; simpl;
    unfold M2_mult; apply M2_eq_intros; simpl; ring.
  Qed.
  Obligation 3.                             (* M2_mult plus mult x (Id2 0 1) = x *)
    destruct x; simpl;
    unfold M2_mult; apply M2_eq_intros; simpl; ring.
  Qed.

  Check M2_Monoid : Monoid M2_mult Id2.
End M2_def.
Check M2_Monoid : forall (A : Type) (zero one : A) (plus mult : A -> A -> A),
    semi_ring_theory zero one plus mult eq ->
    Monoid (M2_mult plus mult) (Id2 zero one).

(* ************* *)
(* 自然数2x2行列 *)
(* ************* *)
Lemma nat_sth : semi_ring_theory 0%nat 1%nat plus mult (@eq nat).
Proof.
  split.
  - exact plus_0_l.
  - exact plus_comm.
  - exact plus_assoc.
  - exact mult_1_l.
  - exact mult_0_l.
  - exact mult_comm.
  - exact mult_assoc.
  - exact mult_plus_distr_r.
Qed.

Instance M2nat : Monoid _ _ := M2_Monoid nat_sth.
Check Monoid (M2_mult plus mult) (Id2 0%nat 1%nat). (* 左辺 *)
Check @M2_Monoid nat 0%nat 1%nat plus mult nat_sth. (* 右辺 *)

(* *********** *)
(* 整数2x2行列 *)
(* *********** *)
Check Zth : ring_theory 0 1 Z.add Z.mul Z.sub Z.opp eq.
(* https://coq.inria.fr/library/Coq.setoid_ring.InitialRing.html で定義 *)
(* ./plugins/setoid_ring/InitialRing.v *)

Lemma Z_sth : semi_ring_theory 0 1 Z.add Z.mul eq.
Proof.
  split.
  - exact Z.add_0_l.
  - exact Z.add_comm.
  - exact Z.add_assoc.
  - exact Z.mul_1_l.
  - exact Z.mul_0_l.
  - exact Z.mul_comm.
  - exact Z.mul_assoc.
  - exact Z.mul_add_distr_r.
Qed.

Instance M2Z : Monoid _ _ := M2_Monoid Z_sth.
Check Monoid (M2_mult Z.add Z.mul) (Id2 0 1). (* 左辺 *)
Check @M2_Monoid Z 0 1 Z.add Z.mul Z_sth.     (* 右辺 *)

(***************)
(* ベキ乗の定義 *)
(***************)
Generalizable Variables A dot one.

Fixpoint power `{Monoid A dot one} (a : A) (n : nat) := (* 「`」 でコンテキスト *)
  match n with
    | 0%nat => one
    | S p => dot a (power a p)
  end.

Section binary_power.
  Context `{M : Monoid A dot one}.          (* コンテキスト *)

  Program Fixpoint binary_power_mult (acc : A) (x : A) (n : nat) {measure n} : A :=
    (* Implicit generalization によって、
       (A:Type) (dot:A->A->A) (one:A) (M: @Monoid A dot one)
       が省かれている。 *)
    (* acc * (x ** n) *)
    let M' := M in
    match n with
      | 0%nat => acc
      | _ => if  Even.even_odd_dec n
             then
               binary_power_mult  acc (dot x x) (div2 n)
             else
               binary_power_mult  (dot acc  x) (dot  x  x) (div2 n)
    end.
  Obligations.
  Next Obligation.                          (* Obligation 1 *)
    set (M' := M); apply lt_div2.
    apply neq_0_lt in H.
    apply H.
    Defined.
  Next Obligation.                          (* Obligation 2 と 3 *)
    set (M' := M); apply lt_div2; auto with arith.
    Defined.
  Check binary_power_mult.                  (* A -> A -> nat -> A *)
(*
  証明を1行にまとめると、以下になる。Next Obligation も要らないので、注意。
  Solve Obligations using program_simpl; set (M' := M); apply lt_div2; auto with arith.
 *)

  Import WfExtensionality.
  Lemma binary_power_mult_equation (acc x : A) (n : nat) :
    binary_power_mult acc x n =
    match n with
      | 0%nat => acc
      | _ => if Even.even_odd_dec n
             then
               binary_power_mult acc (dot x x) (div2 n)
             else
               binary_power_mult (dot acc  x) (dot  x  x) (div2 n)
    end.
  Proof.
    unfold binary_power_mult at 1.
    on_call binary_power_mult_func
            ltac:(fun c =>
                    unfold_sub @binary_power_mult_func c;
                    fold binary_power_mult_func).
    simpl. destruct n; reflexivity.
  Qed.

  Definition binary_power x n := binary_power_mult one x n.

End binary_power.

Check binary_power : Z -> nat -> Z.
Check binary_power : nat -> nat -> nat.
Check binary_power : M2 Z -> nat -> M2 Z.
Check binary_power : M2 nat -> nat -> M2 nat.

(****************)
(* 整数のベキ乗 *)
(****************)
Compute binary_power 2%nat 5.               (* = 32%nat : nat *)
Compute binary_power 2 5.                   (* = 32 : Z *)
Compute binary_power 2 100.
(* = 1267650600228229401496703205376 : Z *)

(************************)
(* 整数の2x2行列のベキ乗 *)
(************************)
Compute power (Build_M2 1 1 1 0) 40.
Compute binary_power (Build_M2 1 1 1 0) 40.
(* = {|
       c00 := 165580141;
       c01 := 102334155;
       c10 := 102334155;
       c11 := 63245986 |}
     : M2 Z
 *)

Definition fibonacci (n : nat) :=
  c00 (power (Build_M2 1 1 1 0) n).
Compute fibonacci 20.                       (* = 10946 : Z *)

(* ********************************************* *)
(* power と binary_power が等価なことを証明する。 *)
(* ********************************************* *)
Section About_power.

  Require Import Arith.
  Context `(M : Monoid A dot one ).

  Ltac monoid_rw :=
    rewrite (@one_left A dot one M) ||
            rewrite (@one_right A dot one M)||
            rewrite (@dot_assoc A dot one M).

  Ltac monoid_simpl := repeat monoid_rw.

  Local Infix "*" := dot.
  Local Infix "**" := power (at level 30, no associativity).
  (* "+" はnat のplusである。power : A -> nat -> A だから。 *)

  Lemma power_x_plus :
    forall x n p, x ** (n + p) =  x ** n *  x ** p.
  Proof.
    induction n as [| p IHp]; simpl.
    intros; monoid_simpl; trivial.
    intro q; rewrite (IHp q); 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.
  (* plus_comm は、nat のそれ。 *)
  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 A dot one M); 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 binary_power_mult_ok :
    forall n a x,  binary_power_mult a x n = a * x ** n.
  Proof.
    intro n; pattern n;apply lt_wf_ind.
    clear n; intros n Hn; destruct n.
    intros; simpl; 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 : A) (n : nat), binary_power x n = x ** n.
  Proof.
    intros n x; unfold binary_power; rewrite binary_power_mult_ok;
    monoid_simpl; auto.
  Qed.
  About binary_power_ok.
End About_power.

(* ****************************** *)
(** 可換モノイド、アーベルモノイド *)
(* ****************************** *)
(** モノイド M に可換則を追加して得られる。 *)
Class Abelian_Monoid `(M : Monoid ):=
  {
    dot_comm : forall x y, dot x y = dot y x
  }.
Print Abelian_Monoid.

(**
ZMult_Abelian は、
ZMultモノイド（整数積のモノイド）に可換則を追加したもの。
 *)
Instance ZMult_Abelian : Abelian_Monoid ZMult.
Proof.
  split.
  exact Zmult_comm.
Qed.

(*************************************)
(* (x * y)^n = x^n * y^n を証明する。 *)
(*************************************)
Section Power_of_dot.
  Context `{M : Monoid A} {AM : Abelian_Monoid M}.

  Theorem power_of_mult :
    forall n x y, power (dot x y)  n =  dot (power x n) (power y n).
  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.

(* END *)