Require Export stlc.Maps.

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

Inductive type :=
| tvar : string -> type
| tarr : type -> type -> type.

Inductive term :=
| var : string -> term
| app : term -> term -> term
| lam : string -> type -> term -> term .

(* Exercise 2.1 *)

Definition X_Y_X (X:string) (Y:string) : type :=
  tarr (tvar X) (tarr (tvar Y) (tvar X)).

Definition XX_XX (X:string) : type :=
  tarr (tarr (tvar X) (tvar X)) (tarr (tvar X) (tvar X)).

(* Exercise 2.2 *)

Definition lxly_x (X:string) (Y:string) : term :=
  lam "x" (tvar X) (lam "y" (tvar Y) (var "x")).

Definition lflx_ffx (X:string) : term :=
  lam "f" (tarr (tvar X) (tvar X))
      (lam  "x" (tvar X)
            (app  (var "f")
                  (app  (var "f")
                        (var "x")))).

Definition ctx := partial_map type.

(* Exercise 2.3 *)

Inductive typed : ctx -> term -> type -> Prop :=
  | var_typed : forall E x A,
    E x = Some A ->
    typed E (var x) A

  | app_typed : forall E M N A B,
    typed E M (tarr A B) ->
    typed E N A ->
    typed E (app M N) B

  | lam_typed : forall E x M A B,
    typed (E & { x --> Some A}) M B ->
    typed E (lam x A M) (tarr A B).

(* Exercise 2.4 *)

Lemma test : typed  empty
                    (lxly_x "X" "Y")
                    (X_Y_X "X" "Y").
Proof.
unfold lxly_x. unfold X_Y_X.
apply lam_typed.
apply lam_typed.
apply var_typed.
reflexivity.
Qed.

Fixpoint beq_type (A:type) (B:type) :=
  match A, B with
  | tvar a, tvar b =>
      beq_string a b
  | tarr A1 A2, tarr B1 B2 =>
      beq_type A1 B1 && beq_type A2 B2
  | _,_ =>
      false
end.

Lemma beq_type_eq : forall A B,
beq_type A B = true -> A = B.
Proof.
intros A.
induction A; intros B Hbeq;
destruct B; inversion Hbeq.
- apply beq_string_true_iff in Hbeq.
  rewrite Hbeq. reflexivity.
- apply andb_prop in H0.
  destruct H0 as [Hbeq1 Hbeq2].
  apply IHA1 in Hbeq1.
  apply IHA2 in Hbeq2.
  rewrite Hbeq1. rewrite Hbeq2.
  reflexivity.
Qed.

Lemma beq_type_refl : forall (A: type),
beq_type A A = true.
Proof.
induction A.
+ simpl. rewrite <- beq_string_refl. reflexivity.
+ simpl. rewrite IHA1. rewrite IHA2. reflexivity.
Qed.

Fixpoint beq_term (M: term) (N: term) :=
  match M, N with
  | var m, var n =>
      beq_string m n
  | app M1 M2, app N1 N2 =>
      beq_term M1 N1 && beq_term M2 N2
  | lam x A m, lam y B n =>
      beq_string x y && beq_type A B && beq_term m n
  | _,_ => false
  end.

(* Exercise 2.5 *)

Fixpoint typecheck (E : ctx) (t : term) : option type :=
  match t with
  | var x => E x
  | app M N =>
    match (typecheck E M), (typecheck E N) with
    | Some (tarr A B), Some C =>
        if beq_type A C then Some B
                        else None
    | _,_ => None
    end
  | lam x A M =>
    match (typecheck (E&{x-->Some A}) M) with
    | Some B => Some (tarr A B)
    | _      => None
    end
  end.

(* Exercise 2.6 *)

(*
The typing judgement [typed] will tell us for a given
context, term and type whether the term is of that type.
The type checker [typecheck] will tell us for a given
context and term what the type is (or it will return
nothing if there is no type).
 *)

(* Exercise 2.7 *)

Example pos_typecheck_1 :
typecheck empty (lxly_x "X" "Y") = Some (X_Y_X "X" "Y").
Proof. reflexivity. Qed.

Example pos_typecheck_2 :
typecheck empty (lflx_ffx "X") = Some (XX_XX "X").
Proof. reflexivity. Qed.

Definition lx_xx (X: string) :=
  lam "x" (tvar X) (app (var "x") (var "x")).

Example neg_typecheck_1 :
typecheck empty (lx_xx "X") = None.
Proof. reflexivity. Qed.

Definition lflx_xf (X: string) :=
  lam "f" (tarr (tvar X) (tvar X))
      (lam "x" (tvar X)
           (app (var "x") (var "f")) ).

Example neg_typecheck_2 :
typecheck empty (lflx_xf "X") = None.
Proof. reflexivity. Qed.

(* Exercise 2.8 *)

Lemma typecheck_complete : forall E t A,
  typed E t A ->
  typecheck E t = Some A.
Proof.
intros E t A H.
induction H.
- apply H.
- simpl.
  rewrite IHtyped1. rewrite IHtyped2.
  rewrite beq_type_refl.
  reflexivity.
- simpl.
  rewrite IHtyped. reflexivity.
Qed.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Ltac solve_by_invert :=
  solve_by_inverts 1.

Lemma typecheck_sound : forall E t A,
  typecheck E t = Some A ->
  typed E t A.
Proof.
intros E t.
induction t; intros B Htc. inversion Htc.
- apply var_typed. apply H0.
- simpl typecheck in Htc. simpl (typecheck E t1) in Htc.

unfold typecheck in Htc.
remember (typecheck E t1) as TO1.
  remember (typecheck E t2) as TO2.
  destruct TO1 as [T1|].
  + destruct T1 as [|TA TB].
    *
  +
  destruct TO2 as [T2|]; try solve_by_invert.
  destruct (beq_type T11 T2) eqn: Heqb;
  try solve_by_invert.

  apply beq_type_eq in Heqb.
  apply app_typed; subst..
-

destruct (typecheck E t1) as [T1|].
  destruct T1 as [|TA TB].
  + apply (Some (tvar s) = Some (tvar s)) in IHt1.
  + destruct (typecheck E t2) as [T2|].
  destruct (beq_type TA T2) eqn: Heqa.
  * apply beq_type_eq in Heqa.
    rewrite <- Heqa in IHt2.
    {destruct (beq_type TB B) eqn: Heqb.
    - apply beq_type_eq in Heqb.
      rewrite Heqb in IHt1.
      apply app_typed with (A := TA).
      apply IHt1. reflexivity.
      apply IHt2. reflexivity.
    - Search solve_by_invert.
Search "iff".
    }
    apply app_typed (A := TA) (B := TB).
  *
  assert (Some T1 = Some T1) as HtypT1.
  reflexivity.
  apply IHt1 in HtypT1.
  destruct T1 as [|TA TB].
  + admit.
  + apply app_typed
    with (E := E) (M := t1) (N := t2)
    (A := TA) (B := B).
    *
  + inversion app.

Admitted.

(*
Fixpoint typecheck (E : ctx) (t : term) : option type :=
  match t with
  | var x => E x
  | app M N =>
    match (typecheck E M), (typecheck E N) with
    | Some (tarr A B), Some C =>
        if beq_type A C then Some B
                        else None
    | _,_ => None
    end
  | lam x A M =>
    match (typecheck (E&{x-->Some A}) M) with
    | Some B => Some (tarr A B)
    | _      => None
    end
  end.

Inductive typed : ctx -> term -> type -> Prop :=
  | var_typed : forall E x A,
    E x = Some A ->
    typed E (var x) A
  | app_typed : forall E M N A B,
    typed E M (tarr A B) ->
    typed E N A ->
    typed E (app M N) B
  | lam_typed : forall E x M A B,
    typed (E & { x --> Some A}) M B ->
    typed E (lam x A M) (tarr A B).

Inductive type :=
| tvar : string -> type
| tarr : type -> type -> type.

Inductive term :=
| var : string -> term
| app : term -> term -> term
| lam : string -> type -> term -> term .

    inversion IHt1. with (A := T1).
 try solve by inversion;
    destruct T1 as [|T11 T12]; try solve by inversion.

apply app_typed.
eval typecheck in Htc.
apply app_typed with (A := typecheck E t1).
- eval typecheck in IHt1.

apply app_typed with (A := . destruct typed. destruct typecheck in IHt1.

- remember (typecheck E t1) as TO1.
  remember (typecheck E t2) as TO2.
  destruct TO1 as [T1|]; try solve by inversion;
  destruct T1 as [|T11 T12]; try solve by inversion.
 destruct typecheck in IHt1. inversion IHt1.
+ inversion IHt1.

-

-d apply H in IHt1.

 induction typecheck.
 destruct app in H. simpl H. rewrite H in IHt1.
- apply H in IHt1. simpl typecheck in H.
- apply app_typed.
ast
Lemma typecheck_sound : forall E t A,
  typecheck E t = Some A ->
  typed E t A.
Proof with eauto.
intros E t.
induction t; intros B Htc. inversion Htc.
- apply var_typed. apply H0.
- remember (typecheck E t1) as TO1.
  remember (typecheck E t2) as TO2.
  destruct TO1 as [T1|].
  assert (Some T1 = Some T1) as HtypT1.
  reflexivity.
  apply IHt1 in HtypT1.
  destruct T1 as [|TA TB].
  + admit.
  + apply app_typed
    with (E := E) (M := t1) (N := t2)
    (A := TA) (B := B).
    *
  + inversion app.

Admitted.

*)


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

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

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

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

Lemma len_append : forall x y : lst, len (append x y) = len x + len y.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem len_rev : forall x : lst, len (rev x) = len x.
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl.
    rewrite len_append.
    rewrite IHx.
    simpl.
    rewrite <- plus_n_Sm.
    auto.
Qed.


Require Import Arith.
Import Nat.

Load hoare.

  (* From "Formal Reasoning About Programs"

     factorial(n) {
        a = 1;
        while (n > 0) {
           a = a * n;
           n = n - 1;
        }
        return a;
     }
  *)

  Definition gt01 n m := if gt_dec n m then 1 else 0.

  Notation "[ e1 `*` e2 ]" := (expr_op e1 mul e2).
  Notation "[ e1 `-` e2 ]" := (expr_op e1 sub e2).
  Notation "[ e1 `>` e2 ]" := (expr_op e1 gt01 e2).

  Definition factorial_cmd :=
    seq (assign a (expr_num 1))
        (while [expr_var n `>` expr_num 0]
               (seq (assign a [expr_var a `*` expr_var n])
                    (assign n [expr_var n `-` expr_num 1]))).

  Module MainProof.

    Definition c := seq (assign a  [expr_var a `*` expr_var n])
                        (assign n [expr_var n `-` expr_num 1]).

    Definition linv n0 s := s a * fact (s n) = fact n0.

    (* Control the behavior of `simpl` to allow more unfoldings. *)
    Arguments subst P v e /.
    Arguments set s v / z.
    Arguments var_eq_dec !v1 !v2.
    Arguments gt01 n m / : simpl nomatch.

    Lemma factorial_inv n0 : hoare (fun s => linv n0 s /\ s n > 0)
                                   c
                                   (linv n0).

    Lemma factorial_correct n0 : hoare (fun s => s n = n0)
                                       factorial_cmd
                                       (fun s => s a = fact n0).

  End MainProof.


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

Arguments nil {X}.
Arguments cons {X}.

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

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

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

Theorem app_nil_r : forall (X:Type), forall l:list X, l ++ [] = l.
Proof.
  intros x l.
  induction l.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A), l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A l m n.
  induction l.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite IHl. reflexivity.
Qed.

Search (_ = _ + 0).

Lemma app_length : forall (X:Type) (l1 l2 : list X), length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros x l1 l2.
  induction l1.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite <- IHl1. reflexivity.
Qed.


(*|
############################################
Coq: Associativity of relational composition
############################################

:Link: https://stackoverflow.com/q/70377028
|*)

(*|
Question
********

I am working on verifying a system based on relation algebra. I found
D. Pous's relation algebra library popular among the Coq society.

https://github.com/damien-pous/relation-algebra

On this page, binary relation ``hrel`` is defined together with its
relational composition ``hrel_dot``.

http://perso.ens-lyon.fr/damien.pous/ra/html/RelationAlgebra.rel.html

In this library, a binary relation is defined as
|*)

Universe U.
Definition hrel (n m : Type@{U}) := n -> m -> Prop.

(*|
And the relational composition of two binary relations is defined as
|*)

Definition hrel_dot n m p (x : hrel n m) (y : hrel m p) : hrel n p :=
  fun i j => exists2 k, x i k & y k j.

(*| I believe that the relational composition is associative, i.e. |*)

Lemma dot_assoc :
  forall m n p q (x : hrel m n) (y : hrel n p) (z : hrel p q),
    hrel_dot m p q (hrel_dot m n p x y) z = hrel_dot m n q x (hrel_dot n p q y z).

(*|
I got to the place where I think the LHS and RHS of the expressions
are equivalent, but I have no clues about the next steps.
|*)

  intros. (* .none *) unfold hrel_dot. (* .none *)
  Show. (* .unfold .messages *)

(*|
I don't know how to reason about the nested ``exists2``, although the
results seem straightforward by exchanging the variables ``k`` and
``k0``.

----

**A (Ana Borges):** I'm not sure you can prove the *equality* of those
two expressions, at least not without proof irrelevance. If you
rewrite your goal as a logical equivalence things should be easier.
|*)

(*|
Answer
******

As Ana pointed out, it is not possible to prove this equality without
assuming extra axioms. One possibility is to use functional and
propositional extensionality:
|*)

Reset Initial. (* .none *)
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.

Universe U.
Definition hrel (n m : Type@{U}) := n -> m -> Prop.

Definition hrel_dot n m p (x : hrel n m) (y : hrel m p) : hrel n p :=
  fun i j => exists2 k, x i k & y k j.

Lemma dot_assoc :
  forall m n p q (x : hrel m n) (y : hrel n p) (z : hrel p q),
    hrel_dot m p q (hrel_dot m n p x y) z = hrel_dot m n q x (hrel_dot n p q y z).
Proof.
  intros m n p q x y z.
  apply functional_extensionality. intros a.
  apply functional_extensionality. intros b.
  apply propositional_extensionality.
  unfold hrel_dot; split.
  - intros [c [d ? ?] ?]. eauto.
  - intros [c ? [d ? ?]]. eauto.
Qed.


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

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

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof. simpl. reflexivity. Qed.

(******************************* Booleans **************************************)

(**These are defined in Coq.Init.Datatypes **)
Inductive bool : Type :=
  | true : bool
  | false : bool.

(* Negate a boolean by pattern matching on the data constructor *)
Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

(* Given two bools, and a, and a b, compute their conjunction  *)
Definition andb (a:bool) (b:bool) : bool :=
  match a with
  | true => b
  | false => false
  end.

(* Given two bools, compute thier disjunction *)
(* in haskell this type is Bool -> Bool -> Bool *)
Definition orb (a:bool) (b:bool) : bool :=
  match a with
  | true => true
  | false => b
  end.

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

(* Is notation a macro or a function? *)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

(* test the new notation *)
(* NOT LEGAL: Example test_&&: *)
Example test_and: false || false || true = true.
Proof. simpl. reflexivity. Qed.

(* Some exercises *)

(* Why doesn't this work? *)
(* Notation "¬ x" := (negb x). *)

(* Definition nandb (a:bool) (b:bool) : bool = ¬(a && b) *)
Definition nandb (a:bool) (b:bool) : bool := (negb (andb a b)).

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

(* Exercise 2 *)
Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool := (b1 && (b2 && b3)).

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

(******************************* Function Types ********************************)
(* Check is :t in ghci *)
Check negb.
(* negb *)
(*      : bool -> bool *)

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

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

Definition monochrome (c:color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false (*Notice that c is being unboxed to a primary p*)
  end.

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

(*Why not this? *)
(* Definition isred (c:color) : bool := *)
(*   match c with *)
(*   | primary red => true *)
(*   | _ => false *)
(*   end. *)

(******************************* Numbers ***************************************)

Module NatPlayground.

(* Peano Axioms *)
Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

(* Remember these are just representations, the meaning is in the semantics *)
(* deep embedding ayy-o *)
Inductive nat' : Type :=
  | stop : nat'
  | tick : nat' -> nat'.

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

End NatPlayground.

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

Definition minustwo (n:nat) : nat :=
  match n with
  | O => O             (* zero minus two is zero in set nat *)
  | S O => O           (* one minus two is zero in set nat*)
  | S (S b) => b       (* any other number minus two is that number minus two *)
end.

Compute (minustwo 1729).

(* Check out these types *)
Check S.             (* nat -> nat*)
Check pred.          (* nat -> nat*)
Check minustwo.      (* nat -> nat*)

(* The data constructor S has the same type as these functions that operate on
nat. But these are fundamentally different, the functions have computation rules
attached to them. The constructor S is just a way to write down numbers, it is
data! *)

(* We use fixpoint for recursive functions. We pattern match on numbers. If zero
then true, if one then false, if greater than one, then minus two and recur. If
it is even you'll get to 0, if not you'll get to one. *)
Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S b) => evenb b
  end.

(* oddb is just negation composed with evenb. Wouldn't this look nice with
function composition and eta reduction *)
Definition oddb (n:nat) : bool := negb (evenb n).

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

Module NatPlayground2.

(* addition, we check the first argument for zero, if it is zero we return the
second arg. If not zero, then we take an S from the first argument and build a
recursive bunch of S's. so (plus 2 1) turns into (S (S (plus 0 1))) = 3 *)
Fixpoint plus (n:nat) (m:nat) : nat :=
  match n with
  | O => m
  | S newN => S (plus newN m)
  end.

(* check the plus function *)
Compute (plus 3 2).

(* This is the simplification that happens for plus *)
(*  plus (S (S (S O))) (S (S O))
==> S (plus (S (S O)) (S (S O)))
      by the second clause of the match
==> S (S (plus (S O) (S (S O))))
      by the second clause of the match
==> S (S (S (plus O (S (S O)))))
      by the second clause of the match
==> S (S (S (S (S O))))
      by the first clause of the match
*)

(* multiplication we just add the second parameter, the number of times of the
first *)
Fixpoint mult (n m : nat) : nat :=
  match n with
  | O => O
  | S newN => plus m (mult newN m)
  end.

(* The lack of a comma between (a b : nat) and the require comma in the match
pattern bothers me *)
Fixpoint minus (a b : nat) : nat :=
  match a,b with
  | O,_ => O
  | S _, O => a
  | S newA, S newB => minus newA newB
  end.

End NatPlayground2.

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

(********************************* Exercises ***********************************)
(* factorial function. I wonder if it has the same memory issues as haskell? It
shouldn't*)
Fixpoint factorial (n:nat) : nat :=
  match n with
  | O => 1
  | S newN => mult n (factorial newN)
  end.

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

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

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

Fixpoint leb (a b : nat) : bool :=
  match a with
  | O => true
  | S newA => match b with
             | O => false
             | S newB => leb newA newB
             end
  end.

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

(* Exercise 2 less than *)
Definition blt_nat (a b : nat) : bool := negb (beq_nat a b) && leb a b.
Example test_blt_nat1: (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3: (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.

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

(* reflexivity can perform simple reduction, so simpl. is not actuall required*)
Theorem plus_O_n' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

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

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

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

(****************************** Exercises **************************************)
Theorem plus_id_exercise : forall n m o : nat,
    n = m -> m = o -> n + m = m + o.
Proof.
  (* introduce all the varibles *)
  intros n m o.
  (* introduce all both hypotheses *)
  intros H I.
  (* rewrite the left side with hypothesis H *)
  rewrite -> H.
  (* rewrite the right side with hypothesis I *)
  rewrite <- I.
  (* Oh look both sides equate yay! *)
  reflexivity. Qed.

(* We can rewrite using these proven theorems *)
Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.  (* Like this! *)
  reflexivity. Qed.

Theorem mult_S_1 : forall n m : nat,
    m = S n -> m * (1 + n) = m * m.
Proof.
  (* introduce our variables *)
  intros n m.
  (* introduce the hypothesis given by implication *)
  intros H.
  (* looks like we can rewrite the left side for equivalence *)
  rewrite -> H.
  (* and we can  *)
  reflexivity. Qed.

(****************************** Case **************************************)
(* Theorem plus_1_neq_0_firsttry : forall n : nat, *)
(*   beq_nat (n + 1) 0 = false. *)
(* Proof. *)
(*   intros n. *)
(*   simpl. (* does nothing! *) *)
(* Abort. *)

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

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

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

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
  { destruct c.
    { reflexivity. }
    { reflexivity. } }
Qed.

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

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(****************************** Exercises **************************************)
(* There must be a cleaner way to write this than the direct case enum *)
Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct b.
  - destruct c.
    + reflexivity.
    + intros H.
      rewrite <- H.
      simpl.
      reflexivity.
 - destruct c.
   + reflexivity.
   + intros H.
     rewrite <- H.
     simpl. reflexivity.
     Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
  intros [].
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

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

(****************************** More Exercises *********************************)
Theorem identity_fn_applied_twice :
  forall (f : bool -> bool), (forall (x : bool), f x = x) -> forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool), (forall (x : bool), f x = negb x) -> forall (b : bool), f (f b) = b.
Proof.
  intros f H [].
  - rewrite -> H.
    rewrite -> H.
    simpl. reflexivity.
  - rewrite ->  H.
    rewrite -> H.
    simpl. reflexivity.
Qed.

Lemma  eq_commutative : forall (a b : bool), (a = b -> b = a).
  Proof.
    intros [] [].
    - reflexivity.
    - intros H. rewrite -> H. reflexivity.
    - intros H. rewrite -> H. reflexivity.
    - reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool), (andb b c = orb b c) -> b = c.
Proof.
  intros b c.
  destruct b.
  - simpl. intros H. rewrite -> H. reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
Qed.

(* a *)
Inductive bin : Type :=
| OO : bin
| S' : bin -> bin
| SS : bin -> bin.

(* b *)

(* Fixpoint mult (n m : nat) : nat := *)
(*   match n with *)
(*   | O => O *)
(*   | S newN => plus m (mult newN m) *)
(*   end. *)
Fixpoint incr (a : bin) : bin := S' a.

Fixpoint bin_to_nat (a : bin) : nat :=
  match a with
  | OO => O
  | S' a' => S (bin_to_nat a')
  | SS a' => 2 * (bin_to_nat a')
  end.

(* unary counting can still work *)
Example test1: bin_to_nat (S' (S' (S' (S' OO)))) = 4.
Proof. simpl. reflexivity. Qed.

(* or we can do 2^2 * 1 *)
Example test2: bin_to_nat (SS (SS (S' OO))) = 4.
Proof. simpl. reflexivity. Qed.

(* just checking that 2^10 = 1024 *)
Example test3: bin_to_nat (SS (SS (SS (SS (SS (SS (SS (SS (SS (SS (S' OO))))))))))) = 1024.
Proof. simpl. reflexivity. Qed.


(*
 Copyright 2022 ZhengPu Shi
  This file is part of coq-matrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : auxiliary library for nat.
  author    : ZhengPu Shi
  date      : 2021.05
*)

Require Export Nat Arith Lia.

(* ######################################################################### *)
(** * More properties for nat *)

(** a natural number must be odd or even *)
Lemma nat_split : forall (n : nat), exists (x : nat),
  n = 2 * x \/ n = 2 * x + 1.
Proof.
  induction n.
  - exists 0. auto.
  - destruct IHn. destruct H.
    + exists x. right. subst. lia.
    + exists (x+1). left. subst. lia.
Qed.

(** Two step induction principle for natural number *)
Theorem nat_ind2 : forall (P : nat -> Prop),
  (P 0) -> (P 1) -> (forall n, P n -> P (S (S n))) -> (forall n, P n).
Proof.
  intros. destruct (nat_split n). destruct H2; subst; induction x; auto.
  - replace (2 * S x) with (S (S (2 * x))); [apply H1; auto | lia].
  - replace (2 * S x + 1) with (S (S (2 * x + 1))); [apply H1; auto | lia].
Qed.

(** Connect induction principle between nat and list *)
Lemma ind_nat_list {A} : forall (P : list A -> Prop) ,
  (forall n l, length l = n -> P l) -> (forall l, P l).
Proof.
  intros. apply (H (length l)). auto.
Qed.

(* ######################################################################### *)
(** * Extension for nat from (Verified Quantum Computing). *)

  (* https://www.cs.umd.edu/~rrand/vqc/index.html *)

  (*******************************)
  (* Automation *)
  (*******************************)

  Lemma double_mult : forall (n : nat), (n + n = 2 * n).
  Proof. intros. lia. Qed.

Require Export Arith Lia Lra.
Require Import Setoid. (* R ==> R', Morphisms.respectful R R' *)
  Lemma pow_two_succ_l : forall x, 2^x * 2 = 2 ^ (x + 1).
  Proof. intros. rewrite Nat.mul_comm. rewrite <- Nat.pow_succ_r'. intuition. Qed.

  Lemma pow_two_succ_r : forall x, 2 * 2^x = 2 ^ (x + 1).
  Proof. intros. rewrite <- Nat.pow_succ_r'. intuition. Qed.

  Lemma double_pow : forall (n : nat), 2^n + 2^n = 2^(n+1).
  Proof. intros. rewrite double_mult. rewrite pow_two_succ_r. reflexivity. Qed.

  Lemma pow_components : forall (a b m n : nat), a = b -> m = n -> a^m = b^n.
  Proof. intuition. Qed.

  Ltac unify_pows_two :=
    repeat match goal with
    (* NB: this first thing is potentially a bad idea, do not do with 2^1 *)
    | [ |- context[ 4%nat ]]                  => replace 4%nat with (2^2)%nat
                                                 by reflexivity
    | [ |- context[ (0 + ?a)%nat]]            => rewrite Nat.add_0_l
    | [ |- context[ (?a + 0)%nat]]            => rewrite Nat.add_0_r
    | [ |- context[ (1 * ?a)%nat]]            => rewrite Nat.mul_1_l
    | [ |- context[ (?a * 1)%nat]]            => rewrite Nat.mul_1_r
    | [ |- context[ (2 * 2^?x)%nat]]          => rewrite <- Nat.pow_succ_r'
    | [ |- context[ (2^?x * 2)%nat]]          => rewrite pow_two_succ_l
    | [ |- context[ (2^?x + 2^?x)%nat]]       => rewrite double_pow
    | [ |- context[ (2^?x * 2^?y)%nat]]       => rewrite <- Nat.pow_add_r
    | [ |- context[ (?a + (?b + ?c))%nat ]]   => rewrite Nat.add_assoc
    | [ |- (2^?x = 2^?y)%nat ]                => apply pow_components; try lia
    end.

  (** Restoring Matrix dimensions *)
  Ltac is_nat_equality :=
    match goal with
    | |- ?A = ?B => match type of A with
                  | nat => idtac
                  end
    end.


(* Definitions that are used by ott-generated output (when using non-expanded lists) *)

Require Import Bool.
Require Import List.
Set Implicit Arguments.

Section list_predicates.
Variable (A : Set). (* should be Type in coq >= V8.1 *)

(* Test whether a predicate [p] holds for every element of a list [l]. *)
Definition forall_list (p:A->bool) (l:list A) :=
  fold_left (fun b (z:A) => b && p z) l true.

(* Test whether a predicate [p] holds for some element of a list [l]. *)
Definition exists_list (p:A->bool) (l:list A) :=
  fold_left (fun b (z:A) => b || p z) l false.

(* Assert that a property holds for every element of a list *)
Inductive Forall_list (P:A->Prop) : list A -> Prop :=
  | Forall_nil : Forall_list P nil
  | Forall_cons :
    forall x l, P x -> Forall_list P l -> Forall_list P (x::l).
(* Assert that a property holds for some element of a list *)
Inductive Exists_list (P:A->Prop) : list A -> Prop :=
  | Exists_head : forall x l, P x -> Exists_list P (x::l)
  | Exists_tail : forall x l, Exists_list P l -> Exists_list P (x::l).

End list_predicates.
Hint Constructors Forall_list Exists_list.

Section list_mem.
(* Functions about membership in a list, with equality between a list
   element and a potential member being decided by [eq_dec]. *)
Variable (A : Set). (* should be Type in coq >= V8.1 *)
Variable (eq_dec : forall (a b:A), {a=b} + {a<>b}).

(* Test whether [x] appears in [l]. *)
Fixpoint list_mem (x:A) (l:list A) {struct l} : bool :=
  match l with
  | nil => false
  | cons h t => if eq_dec h x then true else list_mem x t
end.

(* Remove any element of [l1] that is present in [l2]. *)
Fixpoint list_minus (l1 l2:list A) {struct l1} : list A :=
  match l1 with
  | nil => nil
  | cons h t =>
    if (list_mem h l2) then list_minus t l2 else cons h (list_minus t l2)
end.
End list_mem.

Section Flat_map_definition.
Variables (A B : Set). (* should be Type in coq >= V8.1 *)
Variable (f : A -> list B).
(* This definition is almost the same as the one in the standard library of
   Coq V8.0 or V8.1. The difference is that this version has the shape
    fun A B f => (fix flat_map l := _)
   while the standard library has
    fun A B => (fix flat_map f l := _)
   Our version has the advantage of making recursive definitions such as
    fix foo x := match x with ... | List xs => flat_map foo xs end
   well-founded.
 *)
Fixpoint flat_map (l:list A) {struct l} : list B :=
  match l with
    | nil => nil
    | cons x t => (f x) ++ (flat_map t)
  end.
End Flat_map_definition.

(* Provide helper lemmas for {{coq-equality}} homs. *)
Require Export ott_list_eq_dec.


(** Comments in Coq are as in Ocaml and SML:  they start with a left-paren
   and asterisk, and are closed with an asterisk and right-paren. *)

Require Import Arith.

(** [Require Import Arith.] is a top-level command that tells Coq to import
   the definitions from the [Arith] library (arithmetic) and to make the
   definitions available at the top-level.  All top-level commands end
   with a period.
*)

Definition four : nat := 4.

(** A top-level definition begins with the keyword [Definition], followed
   by an identifier (in this case [four]) that we want to use, a colon,
   a type, [:=], and then an expression followed by a period.
   Here the type of the number [4] is [nat] which stands for natural number.  *)

Definition four' := 2 + 2.
(** You can leave off the type information and Coq can often infer it.
   But it can't always infer types, and it's good documentation to put
   the types on complicated definitions. *)

Eval compute in four'.

Eval compute in four + four'.
(** [Eval compute in <exp>.] lets you evaluate an expression to see the
   resulting value and type. *)

Check four'.
(** [Check <exp>] lets you check the type of an expression. *)

Print four'.
(** [Print <identifier>] lets you see the definition of the identifier. *)

Definition four'' := (6 - 4) * 2.

Check four''.
Eval compute in four''.
Print four''.

Definition inc (x:nat) : nat := x + 1.
(** To define a function, we just make a parameterized definition.*)

Check inc.
Eval compute in inc.
Eval compute in inc four.

Definition inc' x := x + 1.
(** As in Ocaml, we can leave off the types and Coq can usually infer them,
   but not always. *)

Check inc'.
Print inc'.
Eval compute in inc' four.

Definition inc'' := fun (x:nat) => x + 1.
(** Parameterized definitions are just short-hand for a regular definition
   using a lambda expression. *)

Check inc''.
Eval compute in inc'' four.

Definition add1 x y := x + y.
Definition add2 (x:nat) (y:nat) := x + y.
Definition add3 (x y:nat) := x + y.
(** When the types are the same, we can group parameters as in [add']. *)
Definition add4 := fun x => fun y => x + y.
(** Multiple parameters are just iterated lambdas. *)

Check add1.
Check add2.
Check add3.
Check add4.
Eval compute in add1 5 4.
Eval compute in add2 5 4.

Definition inc''' := add1 1.
Eval compute in inc'''.
Eval compute in inc''' 4.

Inductive bool : Type :=
| true
| false.
(** An inductive definition is just like an Ocaml datatype definition,
   though the syntax is a little different.  Here, we are defining
   a new [Type] called [bool] with constructors [true] and [false].
   Unlike Ocaml, we can (and generally need to) provide the type of
   each data constructor, hence both [true] and [false] are defined
   as constructors that immediately return a [bool].

   Notice that when we evaluate this definition, Coq says that not
   only is [bool] defined, but also [bool_rect], [bool_ind], and
   [bool_rec].  We'll discuss those later on when we start talking
   about proving things.
*)
Check true.
Check false.
Print bool.

Definition negb (b:bool) : bool :=
  match b with
    | true => false
    | false => true
  end.
(** The definition above shows how we use pattern-matching to tear apart
   an inductive type, in this case a [bool].  The syntax is similar to
   Ocaml except that we use "=>" for the guard instead of "->" and we
   have to put an "end" to terminate the "match". *)

Check negb.
Eval compute in negb true.
Eval compute in negb false.

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

Eval compute in andb true false.
Eval compute in andb true true.

Definition orb b1 b2 :=
  match b1 with
    | true => true
    | _ => b2
  end.

Eval compute in orb true false.
Eval compute in orb true true.

(** The [Arith] module defines this [nat] type already.  It is a way to
   represent the natural numbers, with a base case of zero, "0" and
   successor constructor [S]. Notice that the type of [S] declares
   it to take a [nat] as an argument, before returning a [nat].

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

type nat = O | S of nat
*)

Print nat.

(**
   A digression:

   In informal math, we tend to think of a "type" as a set of
   objects.  For instance, we think of [nat] as the set of
   objects {0,1,2,3,...}.  But we can also form sets out of
   sets.  For instance, we can have {nat,bool,string}.  Technically,
   to avoid circularities, [nat] is considered a "small" set,
   and {nat,bool,string} is considered a "large" set, sometimes
   called a class.  Stratifying our sets is necessary to avoid
   constructions such as S = { s : set | s is not contained in s }
   (Russell's paradox.)

   In Coq, the identifier [Set] refers to a universe of
   types, including {nat,bool,string,...}.  So in some sense,
   the identifier [Set] names a class of types.  We sometimes
   say that [Set] is the type of the collection
   {nat,bool,string,...}. When we build
   certain kinds of new types out of elements of [Set], then we
   have to move up to a new universe.  Internally, that universe
   is called Type_1.  (Actually, [Set] is represented as Type_0
   internally.)  And if we build certain types out of Type_1,
   we have to move up to Type_2.  So Coq has an infinite hierarchy
   Set a.k.a. Type_0, Type_1, Type_2, ...

   Now figuring out where in this hierarchy a definition should go
   isn't that hard, and in fact, Coq automagically infers this
   for you.  When you write [Type], you are really writing [Type_x]
   and Coq is later solving for [x] to make sure your definitions
   don't contain a circularity.  In fact, with the exception of
   [Set] and one more very special universe, [Prop], you can't
   even explicitly say at what level you want a given definition.

   For now, we can just ignore this and use [Type] everywhere.
*)
Check O.
Check 0.   (** the numeral 0 is just notation for the constructor O *)
Eval compute in 0.
Eval compute in 3.
Check S.
Check S 0. (** 1,2,3 are short-hand for (S O), (S (S O)) and (S (S (S O))). *)
Check S (S (S 0)).

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

Fixpoint add'' (n m:nat) : nat :=
  match m with
    | 0 => n
    | S m' => S (add'' n m')
  end.
(** We construct recursive functions by using the keyword "Fixpoint". *)

Eval compute in add'' 4 3.
Print add''.

Definition add5 :=
  fix local_add (n m:nat) : nat :=
  match n with
    | 0 => m
    | S n' => S (local_add n' m)
  end.
(** Alternatively, we can use a "fix" expression which builds a recursive
   functions, similar to the way "fun" builds a non-recursive function.
*)

Eval compute in add5 4 3.
Print add5.

(** Pairs *)
Definition p1 : nat * nat := (3,4).  (** pair of nats *)
Definition p2 : nat * bool := (3, true).  (** nat and bool *)
Definition p3 : nat * bool * nat := (3,true,2).

Eval compute in add3 (fst p1) (snd p1).
(** [fst] extracts the first component of a pair, and [snd]
   extracts the second component. *)

Eval compute in fst p3.
Eval compute in snd p3.

Print pair.
Eval compute in match p1 with
                  | pair x y => x + y
                end.
Locate "_ * _".

(** Notice that [(3,true,2)] is really short-hand for [((3,true),2)].
   and [nat * bool * nat] is short for [(nat * bool) * nat]. *)

(** Options *)
Definition opt1 : option nat := None.
Definition opt2 : option nat := Some 4.
(** An [option t] is either [None] or [Some] applied to a value of type [t].
   Notice that unlike Ocaml, we write [option nat] instead of [nat option].
*)
Print option.

Fixpoint subtract (m n:nat) : option nat :=
  match m, n with
    | _, 0 => Some m
    | 0, S _ => None
    | S m', S n' => subtract m' n'
  end.
Eval compute in subtract 5 2.
Eval compute in subtract 2 5.

Definition subt (m n:nat) : nat :=
  match subtract m n with
    | None => 0
    | Some i => i
  end.
Eval compute in subt 5 2.
Eval compute in subt 2 5.

(** Sums *)
Locate "_ + _".
Print sum.

Definition s1 : nat + bool := inl 3.
Definition s2 : nat + bool := inr true.

Print s1.

(** We build something of type [t1 + t2] by using either [inl] or
   [inr].  It's important to provide Coq enough type information
   that it can figure out what the other type is. *)

Definition add_nat_or_bool (s1 s2: nat + bool) : nat + bool :=
  match s1, s2 with
    | inl n1, inl n2 => inl (n1 + n2)
    | inr b1, inr b2 => inr (orb b1 b2)
    | _, _ => inr false
  end.

(** Lists *)
Require Import List.
Print list.
Definition l1 : list nat := nil.
Definition l2 : list nat := 3::2::1::nil.
Definition l3 : list bool := true::false::nil.
Definition l4 : list (nat + bool) := (inl 3)::(inr true)::nil.

Fixpoint append (l1 l2:list nat) : list nat :=
  match l1 with
    | nil => l2
    | h::t => h::(append t l2)
  end.

Eval compute in append l2 l2.

Fixpoint add_list (l1 l2:list nat) : option (list nat) :=
  match l1, l2 with
    | nil, nil => Some nil
    | n1::l1, n2::l2 =>
      match add_list l1 l2 with
        | None => None
        | Some l => Some ((n1+n2)::l)
      end
    | _, _ => None
  end.

Eval compute in add_list l2 l2.
Eval compute in add_list l2 (1::nil).
(** Polymorphism *)

Fixpoint generic_append (A:Type) (l1 l2: list A) : list A :=
  match l1 with
    | nil => l2
    | h::t => h::(generic_append A t l2)
  end.
(** Unlike Ocaml, we make type parameters explicit in Coq.  Here,
   we've defined a generic append function, which abstracts over
   a type [A].  Notice that the types of the arguments [l1] and
   [l2] depend upon [A], as does the result type.  Notice also
  that when we call this function, we must provide an actual
  type for the instantiation of [A].
*)

Eval compute in generic_append bool l3 l3.
Eval compute in generic_append nat l1 l2.
Eval compute in generic_append _ l3 l3.
Eval compute in generic_append _ nil nil.
(** Coq can usually figure out what the types are, and we can
   leave out the type by just putting an underscore there
   instead.  But there are cases where it can't figure it
   out (e.g., generic_append _ nil nil).
*)

Fixpoint generic_append' {A:Type} (l1 l2:list A) : list A :=
  match l1 with
    | nil => l2
    | h::t => h::(generic_append' t l2)
  end.
(** The curly braces tell Coq to make an argument implicit.  That
   means it's up to Coq to fill in the argument for you.  Notice
   that in the recursive call, we didn't have to specify the type. *)

Eval compute in generic_append' l1 l1.
Eval compute in generic_append' l2 l2.
Eval compute in generic_append' nil nil.
Eval compute in generic_append _ nil nil.

(** This won't work though:
Definition foo := generic_append' nil nil.
   We can fix it by either giving enough information in the context
   or by using "@" to override the implicit arguments:
*)
Definition foo : list nat := generic_append' nil nil.
Definition foo1 := @generic_append' nat nil nil.

(** Assignment *)
(** Problem0 *)
Fixpoint length {A:Type} (l:list A): nat :=
  match l with
    | nil => 0
    | h::t => 1+ (length t)
  end.

Eval compute in length (3::2::1::nil).
Eval compute in length (generic_append' l2 l2).

(** Problem1  Write a function rev that reverses a list.
 rev : forall {A:Type}, list A -> list A *)

Fixpoint rev {A:Type} (l : list A) : list A :=
  match l with
    | nil => nil
    | h ::t => generic_append' (rev t) (h::nil)
   end.

SearchAbout (list _ ->list _ ->list _).
Locate app.

Eval compute in rev l2.
Eval compute in rev (generic_append' l2 l2).
Eval compute in rev (5::4::3::2::1::nil).

(** Problem 2: Write a function ith that returns the ith element of a list,
 if the list has enough elements, and otherwise returns None.
 We are working zero-based, so for instance, ith 2 (1::2::3::4::nil)
 should return Some 3, whereas ith 4 (1::2::3::4::nil)
 should return None.*)

Fixpoint ith {A:Type} (n:nat) (l:list A): option A :=
  match l, n with
    |nil, _ => None
    |h ::t, 0 => Some h
    |h::t, S n' => ith n' t
  end.

Eval compute in ith 2 nil.
Eval compute in ith 4 (1::2::3::4::nil).
Eval compute in ith 0 (1::2::3::4::nil).
Eval compute in ith 2 (1::2::3::4::nil).

(** Problem 3:  Write a generic function comp to compose two functions.
 comp : forall {A B C:Type}, (A -> B) -> (B -> C) -> (A -> C)*)

Definition comp {A B C:Type} (f1: A->B) (f2: B->C) : A-> C :=
  fun (a: A) => f2 (f1 a).

Check comp.

Eval compute in comp length add5.
Eval compute in comp length add5 (3::2::1::nil).
Eval compute in comp length add5 (3::2::1::nil) 10.

(** Problem4:  Write a function sum that adds up all of the nats
in a list. sum : list nat -> nat
*)

Fixpoint sum (l:list nat): nat :=
  match l with
    | nil => 0
    | h ::t => h + (sum t)
end .

Eval compute in sum l1.
Eval compute in sum l2.

(** Problem5: Write a function map that maps a function
 over the elements in a list, producing a new list.
 map : forall {A B:Type}, (A -> B) -> list A -> list B
*)

Fixpoint map {A B:Type} (f : A-> B) (l:list A): list B :=
  match l with
    | nil => nil
    | h::t => f (h) :: (map f t)
end.

Eval compute in map is_zero (0::1::2::3::0::0::nil).

(** Problem6: Write a generic "fold-right" for a list such that,
 for instance. fold (fun x y => x + y) 0 (1::2::3::nil) evaluates to 6.
 fold : forall {A B:Type}, (A -> B -> B) -> B -> list A -> B
*)

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

Eval compute in fold (fun x y => x + y) 0 (1::2::3::nil).
Eval compute in fold (fun x y => x + y) 10 (1::2::3::nil).

(** Problem7:  Write a function add_pairs that takes a list of pairs of
 nats and returns the list of the corresponding sums.
 For instance, add_pairs ((1,2)::(3,4)::nil) should
 return 3::7::nil. add_pairs : list (nat * nat) -> list nat
*)

Fixpoint add_pairs (l : list (nat * nat)): list nat :=
  match l with
    | nil => nil
    | (a,b)::t => (a+b)::(add_pairs t)
  end.

Eval compute in add_pairs ((1,2)::(3,4)::nil).

(** Problem8: Given the following definition for trees:
Inductive tree (A:Type) : Type :=
| Leaf : tree A
| Node : tree A -> A -> tree A -> tree A.

Implicit Arguments Leaf [A]. Implicit Arguments Node [A].
*)

Inductive tree (A:Type) : Type :=
| Leaf : tree A
| Node : tree A -> A -> tree A -> tree A.

Print tree.

(** Write a function which flattens the tree into a list.
For instance, flatten on the tree:
3 / \ 1 7 / \ / \ o o o o
should yield 1::3::7::nil. flatten : forall {A:Type}, tree A -> list A
*)

(** Problem 10.
Inductive order : Type :=
| Less
| Equal
| Greater.

10. Write a function which when given two numbers n and m,
returns Less if n < m, Equal if n = m, and otherwise returns Greater.
 nat_cmp : nat -> nat -> order

*)

Inductive order : Type :=
| Less
| Equal
| Greater.

Fixpoint nat_cmp (n m: nat) : order :=
  match n, m with
    | 0, 0 => Equal
    | 0, S m' => Less
    | S n', 0 => Greater
    | S n', S m' => nat_cmp n' m'
end.

Eval compute in nat_cmp 0 0.
Eval compute in nat_cmp 4 0.
Eval compute in nat_cmp 5 9.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.

(* Syntax of Clock-based Dynamic Logic *)

(* Syntax of SEP_exp (Synchonous Event Program) *)

(* ========================= Syntax of SEP_exp ========================*)

(* =============== Syntax of Expressions ===================*)

(* Arith Expression `e'*)
Inductive e_exp :=
  enumC : nat -> e_exp |
  evarC : string -> e_exp |
  eplusC : e_exp -> e_exp -> e_exp |
  (*non-necessary expression*)
  eminusC : e_exp -> e_exp -> e_exp |
  emulLC : nat -> e_exp -> e_exp |
  emulRC : e_exp -> nat -> e_exp |
  edivC : e_exp -> nat -> e_exp
.
Print e_exp.

Notation "e1 '+ e2" := (eplusC e1 e2) (at level 31, right associativity).
Locate "'+".
Notation "e1 '- e2" := (eminusC e1 e2) (at level 31, right associativity).

Notation "n '*l' e" := (emulLC n e) (at level 21, right associativity).
Notation "e '*r' n" := (emulRC e n) (at level 21, right associativity).
Locate "*".
Check 4 *l (enumC 5 '+ enumC 6).

Notation "e1 '/ n" := (edivC e1 n) (at level 21, right associativity).
Check (enumC 4)'/4.

Coercion enumC : nat >-> e_exp.
Coercion evarC : string >-> e_exp.
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Definition k : string := "k".

Check 4 *l (5 '+ 2).
Check (5 '+ 4) *r 8.
Check x '- 3.
Check 5 '+ 4 *r 5.

(* Boolean Expression `P'*)
Inductive P_exp :=
  PtrueC : P_exp |
  PlteC : e_exp -> e_exp -> P_exp |
  PnegC : P_exp -> P_exp |
  PandC : P_exp -> P_exp -> P_exp |
  (*non-necesarry expression*)
  PfalseC : P_exp |
  PltC : e_exp -> e_exp -> P_exp |
  PgtC : e_exp -> e_exp -> P_exp |
  PgteC : e_exp -> e_exp -> P_exp |
  PeqC : e_exp -> e_exp -> P_exp |
  PorC : P_exp -> P_exp -> P_exp |
  PimpC : P_exp -> P_exp -> P_exp
.
Print P_exp.

(* 33 - 41 *)
Notation "''tt'" := PtrueC (at level 35).
Notation "e1 '<= e2" := (PlteC e1 e2) (at level 33).
Notation "'~ P" := (PnegC P) (at level 36).
Notation "P1 '/\ P2" := (PandC P1 P2) (at level 37, right associativity).
Notation "''ff'" := PfalseC (at level 35).
Notation "e1 '< e2" := (PltC e1 e2) (at level 33).
Notation "e1 '> e2" := (PgtC e1 e2) (at level 33).
Notation "e1 '>= e2" := (PgteC e1 e2) (at level 33).
Notation "e1 '= e2" := (PeqC e1 e2) (at level 33).
Notation "P1 '\/ P2" := (PorC P1 P2) (at level 37, right associativity).
Notation "P1 '-> P2" := (PimpC P1 P2) (at level 38, right associativity).

Locate "'/\".
Check 'tt '-> 'ff.
Check 5 '+ x '>= 5 '-> 3 '> 7.

(* Evaluation *)
(***
  Definging the evaluation for expressions is for checking the validation of FOL formulas after
  transformation.
***)

Fixpoint eval_e_exp (e : e_exp) (st : string -> nat) : nat :=
(* st maps each var name to a value --- it is a state *)
  match e with
  | enumC n => n
  | evarC s => st s
  | eplusC e1 e2 => (eval_e_exp e1 st) + (eval_e_exp e2 st)
  | eminusC e1 e2 => (eval_e_exp e1 st) - (eval_e_exp e2 st)
  | emulLC n e' => n * (eval_e_exp e' st)
  | emulRC e' n => (eval_e_exp e' st) * n
  | edivC e' n => (eval_e_exp e' st) / n
  end.

Fixpoint eval_P_exp (P : P_exp) (st : string -> nat) : Prop :=
  match P with
  | PtrueC => True
  | PlteC e1 e2 => (eval_e_exp e1 st) <= (eval_e_exp e2 st)
  | PnegC P' => ~ (eval_P_exp P' st)
  | PandC P1 P2 => (eval_P_exp P1 st) /\ (eval_P_exp P1 st)
  | PfalseC => False
  | PltC e1 e2 => (eval_e_exp e1 st) < (eval_e_exp e2 st)
  | PgtC e1 e2 => (eval_e_exp e1 st) > (eval_e_exp e2 st)
  | PgteC e1 e2 => (eval_e_exp e1 st) >= (eval_e_exp e2 st)
  | PeqC e1 e2 => (eval_e_exp e1 st) = (eval_e_exp e2 st)
  | PorC P1 P2 => (eval_P_exp P1 st) \/ (eval_P_exp P1 st)
  | PimpC P1 P2 => (eval_P_exp P1 st) -> (eval_P_exp P1 st)
  end.

(* =============== Syntax of Event ===================*)

(* Event *)
Inductive EvtElement :=
  sigC : string -> e_exp -> EvtElement | (* Signal *)
  assC : string -> e_exp -> EvtElement  (* Assignment *)
.
Check EvtElement.

Notation "s ! e" := (sigC s e) (at level 45).
Notation "x ':= e" := (assC x e) (at level 45).

(* currently we do not make distinguish between variable and clock names, both are strings*)
Definition c : string := "c".
Definition d : string := "d".
Definition c1 : string := "c1".
Definition c2 : string := "c2".
Definition c3 : string := "c3".
Definition c4 : string := "c4".

Check x ':= 4.
Check c ! (x '+ 4).

Definition Evt := list EvtElement.

Check Evt.
Check (x ':= 4) :: (c!(x '+ 4)) :: nil.

Definition idle : Evt := nil.
Check idle.

(* ========================= Syntax of program ========================*)
Inductive SEP_exp : Type :=
  skip : SEP_exp | (* skip program $\varepsilon$ *)
  evtC : Evt -> SEP_exp | (* Event *)
  tstC : P_exp -> Evt -> SEP_exp | (* Test *)
  seqC : SEP_exp -> SEP_exp -> SEP_exp | (* sequence *)
  choC : SEP_exp -> SEP_exp -> SEP_exp | (* choice *)
  loopC : SEP_exp -> SEP_exp (* loop *)
.

Coercion evtC : Evt >-> SEP_exp.
Notation "{ a1 .. an }" := (evtC a1 :: .. :: an :: nil).
Notation "P ? a" := (tstC P a) (at level 47).
Notation "P1 ; P2" := (seqC P1 P2) (at level 48).
Notation "P1 'U' P2" := (choC P1 P2) (at level 49).
Notation "P **" := (loopC P) (at level 46).

Locate "**".
Check x ':= 4 :: nil.
Check evtC (x ':= 4 :: nil).

(* ========================================= Syntax of CDL Formula ===============================================*)

(* ================== CCSL ======================== *)
(* clock relation *)
(***
  Currently, we model clocks as `strings', becuase now we don't need to give its semantics.
  It won't work anymore if we consider its semantics later.
***)

Inductive CRel :=
  crSubClC : string -> string -> CRel |
  crExclC : string -> string -> CRel |
  crPrecC : string -> string -> CRel |
  crCausC : string -> string -> CRel
.
Check CRel.

(* ================== CDL Formula ======================== *)
(* Clock relation in formula *)
Inductive rel :=
  rRelC : CRel -> rel |
  rConjC : list CRel -> rel
.
Print rel.

(* Arith Expression `E' *)
(*DEL
(* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
Definition CntClk := string -> string.

(* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
Definition StClk := string -> string.
DEL*)

Inductive E_exp :=
  EvarC : string -> E_exp |
  ECntClkC : string -> E_exp | (* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
  EStClkC : string -> E_exp | (* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
  EnumC : nat -> E_exp |
  EplusC : E_exp -> E_exp -> E_exp |
  EmulC : E_exp -> E_exp -> E_exp |
  (* unecessary expression *)
  EminusC : E_exp -> E_exp -> E_exp
.
Print E_exp.

(* CDL Formula *)
Inductive CDL_exp :=
  cdl_trueC : CDL_exp |
  cdl_ltC : E_exp -> E_exp -> CDL_exp |
  cdl_box1C : SEP_exp -> rel -> CDL_exp |
  cdl_box2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_negC : CDL_exp -> CDL_exp |
  cdl_andC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_forallC : string -> CDL_exp -> CDL_exp |
  (* unnecessary expressions *)
  cdl_falseC : CDL_exp |
  cdl_lteC : E_exp -> E_exp -> CDL_exp |
  cdl_gtC : E_exp -> E_exp -> CDL_exp |
  cdl_gteC : E_exp -> E_exp -> CDL_exp |
  cdl_eqC : E_exp -> E_exp -> CDL_exp |
  cdl_dia1C : SEP_exp -> rel -> CDL_exp |
  cdl_dia2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_orC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_impC : CDL_exp -> CDL_exp -> CDL_exp
.

(* ====================================================== Definition of Sequent =========================== *)
(* To be simple, we firstly define a sequent as a triple (\Gamma, formula, \Delta), where \Gamma and \Delta are the context of
the formula that we are going to transform. *)

Definition Gamma := list CDL_exp.
Definition Delta := list CDL_exp.

Definition SequentL := Gamma -> CDL_exp -> Delta.
Definition SequentR := Gamma -> CDL_exp -> Delta.

(* we arrange a place special for the dynamic formula we want to verify in the sequent, other formulas in Gamma
and Delta are pure FOL formulas.

We define two types of sequent: sequentL and sequentR, where L and R indicate the verifiying formula is on the left
or right side of the sequent.
*)

(* ===================================================== CDL Calculus ======================================*)


Require Import ZArith.
Require Import Omega.
Require Import List.
Require Import FunctionalExtensionality.

Import ListNotations.

Require Import listutils.
Require Import rollingsum.
Require Import seqi.

Definition fv (l : list Z) (i : nat) : Z :=
  Z.abs(sum (firstn i l) - sum (skipn i l)).

Open Scope Z_scope.

Definition fulcrumRS (input : list Z) : list Z :=
  let sl := rollingSum input in
  let sr := rev (rollingSum (rev input)) in
  map (fun p => Z.abs (fst p - snd p)) (combine sl sr)
.

Definition fulcrum (input : list Z) : option (nat * Z) :=
  minIndex_b (fulcrumRS input).

Example ex_fulcrumRS :
  let input := [5;-2;8;10;2;5] in
  fulcrumRS input = map (fun i => fv input i) (seqi (length input)).
Proof.
intros.
unfold fv.
unfold fulcrumRS.
simpl.
auto.
Qed.

Theorem fulcrumRS_correct : forall input,
  input <> nil ->
  fulcrumRS input = map (fun i => fv input i) (seqi (length input)).
Proof.
intros. unfold fv.
unfold fulcrumRS.
repeat (rewrite rollingSum_summ).
unfold seqi.
rewrite rev_length.
rewrite <- map_rev.
rewrite rev_seq.
rewrite map_map.
rewrite combine_map.
rewrite map_map.
apply map_eq.
intros.
apply in_seq in H0.
simpl.
replace (length input + 1 - x - 1)%nat with (length input - x)%nat by omega.
destruct (Nat.eq_dec x 0).
* subst. simpl.
  rewrite Nat.sub_0_r.
  rewrite <- rev_length.
  rewrite firstn_all.
  rewrite <- sum_rev.
  auto.
* assert(L: (length input > 0)%nat). { destruct input. contradiction. simpl. omega. }
  rewrite firstn_skipn_rev with (x := (length input - x)%nat).
  rewrite rev_involutive.
  rewrite <- sum_rev.
  rewrite rev_length.
  replace (length input - (length input - x))%nat with x by omega.
  auto.

  rewrite rev_length. omega.
Qed.

Theorem fulcrum_correct : forall l i v j,
   (j < length l)%nat -> fulcrum l = Some (i, v) -> fv l j >= fv l i.
Proof.
intros.
unfold fulcrum in H0.
rewrite fulcrumRS_correct in H0.
apply minIndex_b_map_seq in H0.
destruct H0.
apply H1.
omega.
destruct l. inversion H.
intro contra.
inversion contra.
Qed.


Definition peirce := forall P Q:Prop, ((P->Q)->P)->P.
Definition classic := forall P:Prop, ~~P -> P.
Definition excluded_middle := forall P:Prop, P\/~P.
Definition de_morgan_not_and_not := forall P Q:Prop, ~(~P/\~Q)->P\/Q.
Definition implies_to_or := forall P Q:Prop, (P->Q)->(~P\/Q).

Lemma excluded_middle_peirce : excluded_middle->peirce.
Proof.
 unfold peirce; intros H P Q H0.
 case (H P).
 trivial.
 intro H1; apply H0; intro H2; absurd P; auto.
Qed.

Lemma peirce_classic : peirce->classic.
Proof.
 unfold classic; intros H P H0.
 apply (H P False).
 intro H1.
 case H0.
 assumption.
Qed.

Lemma classic_excluded_middle: classic->excluded_middle.
Proof.
 unfold excluded_middle; intros H P.
 apply H.
 unfold not at 1; intro H0.
 absurd P.
 intro H1; apply H0; auto.
 apply H; intro H1; apply H0; auto.
Qed.

Lemma excluded_middle_implies_to_or :  excluded_middle -> implies_to_or.
Proof.
 unfold implies_to_or; intros H P Q H0.
 case (H P); intro H1.
 right; auto.
 left; trivial.
Qed.

Lemma implies_to_or_excluded_middle : implies_to_or -> excluded_middle.
Proof.
 unfold excluded_middle; intros H P.
 case (H P P); auto.
Qed.

Lemma classic_de_morgan_not_and_not : classic ->
                                      de_morgan_not_and_not.
Proof.
 unfold de_morgan_not_and_not; intros H P Q H0.
 apply H.
 intro H1.
 apply H0.
 split;intro;apply H1; auto.
Qed.

Lemma de_morgan_not_and_not_excluded_middle : de_morgan_not_and_not ->
                                              excluded_middle.
Proof.
 unfold excluded_middle; intros H P.
 apply H; intro H1; elim H1; auto.
Qed.


Set Implicit Arguments.
Require Import Arith.

  Definition divides a b := exists k, a * k = b.
  Notation "( a | b )" := (divides a b).

  Lemma divides_refl : forall n, (n | n).
  Proof.
    exists 1. firstorder.
  Qed.

  Section Gcd.

    Definition state : Set := nat * nat.    (*  (a, b)  *)

    Inductive step : state -> state -> Prop :=
      step_a : forall a b, a > b -> step (a, b) (a - b, b)
    | step_b : forall a b, a < b -> step (a, b) (a, b - a).

    Lemma div_inv a b a' b' : step (a, b) (a', b') ->
                              forall z, (z | a) /\ (z | b) <-> (z | a') /\ (z | b').

    Definition is_gcd (a b z : nat) :=
      (z | a) /\ (z | b) /\ forall z', (z' | a) -> (z' | b) -> (z' | z).

    Lemma gcd_inv a b a' b' : step (a, b) (a', b') ->
                              forall z, is_gcd a b z <-> is_gcd a' b' z.

  End Gcd.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

(* elim tactic *)

Goal forall n : nat, n + n = 2 * n.
Show Proof.
elim.
Show Proof.
done.
move=> n IH.
ring.
Qed.

Check Wf_nat.lt_wf_ind.

(* SSReflect idiom for strong induction *)

Lemma mylt_wf_ind : forall (n : nat) (P : nat -> Prop),
  (forall n0 : nat, (forall m : nat, (m < n0) -> P m) -> P n0) ->
  P n.
Proof.
move=> n.
move: (leqnn n).
move: {-2}n.
move: n.
elim.
  case=> //.
  move=> _ P.
  apply.
  done.
move=> n IH m mn P HP.
move: (HP).
apply => k km.
apply IH => //.
rewrite -ltnS.
by apply: leq_trans mn.
Qed.

(* rewrite tactic *)

Goal forall n : nat, n = 0 -> forall m : nat, m + n = m.
move=> n n0 m.
rewrite n0.
rewrite addn0.
done.
Qed.

Goal forall n : nat, n = 0 -> forall m : nat, n + m = n.
move=> n n0 m.
rewrite n0.
(* rewrite both occurrences *)
Undo.
rewrite {1}n0.
(* rewrite only the first occurrence *)
Undo.
rewrite {2}n0.
(* rewrite only the second occurrence *)
Undo.
rewrite {-2}n0.
(* rewrite all the occurrences except the second one *)
Undo.
Abort.                                      (* o.k. *)
(* NB: this is the same occurrence switch <occ-switch> as we used in the proof of strong induction *)

(* the following two example are taken from the ssreflect manual *)

Goal forall x y : nat,
  (forall t u, t + u = u + t) ->
  x + y = y + x.
move=> x y H.
(* rewrite H. changes the lhs, what if I want to change the rhs? *)
(* <rstep> =def= [<r-prefix>]<r-item>
   <r-prefix> =def= ... [ [<r-pattern>] ]
   <r-pattern> =def= <term> | ...
*)
Fail rewrite {2}H.
rewrite H.                                  (* x + y が書き換えられる。 *)
Undo.
rewrite [y + _]H.                           (* y + x が書き換えられる。 *)
done.
Qed.

Goal forall x y : nat,
  (forall t u, t + u * 0 = t) ->
  x + y * 4 + 2 * 0 = x + 2 * 0.
Proof.
move=> x y H.
Fail rewrite [x + _]H.
(* rewrite does not try to recover from a pattern-match failure *)
rewrite [x + 2 * _]H.
Abort.                                      (* ok. *)

(* contextual pattern *)
Goal forall (a b c : nat),
  (a + b) + (2 * (b + c)) = 0.
move=> a b c.
(* commute b and c *)
Fail rewrite {2}addnC.
rewrite [b + _]addnC.         (* b + c が対象 *)
rewrite [in 2 * _]addnC.      (* 2 * (c + b) の中のどっかが対象 *)
rewrite [in X in _ + X]addnC. (* (a + b) + 2 * (b + c) の中の 2 * (b + c) の中のどこがが対象 *)
Abort.                        (* ok. *)

(* the same as above but detailed, naming conventions to be explained later *)
Goal forall n : nat, n + n = 2 * n.
elim.
  rewrite addn0.
  rewrite muln0.
  done.
move=> n IH.
rewrite mulnS.
rewrite -IH.
rewrite -addSnnS.
rewrite addnCA.
rewrite -addn2.
rewrite addnA.
done.
Qed.
(* ringを使う。 *)
Goal forall n : nat, n + n = 2 * n.
  by elim=> [|n IH]; ring.
Qed.

(* structured scripts *)

Lemma undup_filter {A : eqType} (P : pred A) (s : seq A) :
  undup (filter P s) = filter P (undup s).
Proof.
elim: s => // h t IH /=.
case: ifP => /= [Ph | Ph].
- case: ifP => [Hh | Hh].
  + have ->// : h \in t.
      move: Hh; by rewrite mem_filter => /andP [].
  + have : h \in t = false.
      apply: contraFF Hh; by rewrite mem_filter Ph.
    move=> -> /=; by rewrite Ph IH.
- case: ifP => // ht.
  by rewrite IH /= Ph.
Qed.

Fixpoint flat {A : eqType} (l : seq (seq A)) : seq A :=
  if l is h :: t then h ++ flat t else [::].

(* Structure the following script *)
Lemma exo10 {A : eqType} (s : seq (seq A)) a :
  reflect (exists2 s', s' \in s & a \in s') (a \in flat s).
Proof.
Abort.

(* equation generation *)

Goal forall s1 s2 : seq nat, rev (s1 ++ s2) = rev s2 ++ rev s1.
move=> s1.
move H : (size s1) => n.
move: n s1 H.
elim.
  case => //.
  rewrite /=.
  move=> _ s2.
  by rewrite cats0.
move=> n IH.
case=> // h t.
case=> tn.
move=> s2.
rewrite /=.
rewrite rev_cons.
rewrite IH //.
rewrite rcons_cat.
by rewrite rev_cons.
Qed.

(* from the ssreflect manual *)

Goal forall a b : nat,
  a <> b.
move=> a b.
case H : a => [|n].
Show 2.
Abort.                                      (* ok. *)

(* congr tactic *)

Goal forall a b c a' b' c', a + b + c = a' + b' + c'.
move=> a b c a' b' c'.
congr (_ + _ + _).
Abort.                                      (* |- a = a', |- b = b',  |- c = c' *)

(* Search command *)

Search (_ < _)%N.
Search (_ < _ = _)%N.

Search _ (_ <= _)%N.
Search _ (_ <= _)%N "-"%N.
Search _ (_ <= _)%N "-"%N addn.
Search _ (_ <= _)%N "-"%N addn "add".
Search _ (_ <= _)%N "-"%N addn "add" in ssrnat.

(* commutativity of addition? *)
Search (_ + _ = _ + _)%N.
Search _ "commutative".
Search _ commutative.
Search _ addn "C" in ssrnat.

(* END *)


From MyCoq.Lib Require Export Nat.

Inductive list (X : Type) : Type :=
  | nil
  | cons (x : X) (l : list X).
Arguments nil {X}.
Arguments cons {X} _ _.

Fixpoint repeat {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | O => nil
  | S count' => cons x (repeat x count')
  end.

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

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

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

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

Theorem app_nil_r: forall (X : Type), forall l : list X,
  l ++ [] = l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite IHl'.
    reflexivity.
Qed.

Theorem app_assoc: forall A (l m n : list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  induction l as [| x l'].
  - reflexivity.
  - simpl.
    intros m n.
    rewrite IHl'.
    reflexivity.
Qed.

Lemma app_length: forall (X : Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  induction l1 as [| n1 l1'].
  - reflexivity.
  - simpl.
    intros l2.
    rewrite IHl1'.
    reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  induction l1 as [| n1 l1'].
  - simpl.
    intros l2.
    rewrite app_nil_r.
    reflexivity.
  - simpl.
    intros l2.
    rewrite IHl1'.
    rewrite app_assoc.
    reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite rev_app_distr.
    simpl.
    rewrite IHl'.
    reflexivity.
Qed.

Inductive prod (X Y : Type) : Type :=
  | pair (x : X) (y : Y).
Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.

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

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

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

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
  match l with
  | nil => (nil, nil)
  | x :: y => match x with
              | (m, n) => match split y with
                              | (l1, l2) => (m :: l1, n :: l2)
                              end
              end
  end.

Inductive option (X : Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X} _.
Arguments None {X}.

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
  match l with
  | nil => None
  | x :: y => if n =? O
              then Some x
              else nth_error y (pred n)
  end.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | nil => None
  | x :: y => Some x
  end.

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

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

Lemma map_app: forall (X Y : Type) (f : X -> Y) (l1 l2 : list X),
  map f (l1 ++ l2) = (map f l1) ++ (map f l2).
Proof.
  induction l1 as [| n1 l1'].
  - reflexivity.
  - simpl.
    intros l2.
    rewrite -> IHl1'.
    reflexivity.
Qed.

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

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

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

Fixpoint fold {X Y: Type} (f : X -> Y -> Y) (l : list X) (b : Y) : Y :=
  match l with
  (* 需要一个起始元素 *)
  | nil => b
  | h :: t => f h (fold f t b)
  end.

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

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

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

Theorem fold_map_correct: forall (X Y : Type) (f : X -> Y) (l : list X),
  fold_map f l = map f l.
Proof.
  induction l as [| n l'].
  - reflexivity.
  - simpl.
    rewrite <- IHl'.
    (* reflexivity 化简力度比 simpl 更强 *)
    reflexivity.
Qed.

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

Definition prod_uncurry {X Y Z : Type} (f : X -> Y -> Z) (p : X * Y) : Z :=
  f (fst p) (snd p).

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

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


Require Import Coq.Bool.Bool.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.Ascii.

(* Returns the comparison of two ASCII characters. *)
Definition compare_ascii (a b : ascii) : comparison  :=
  N.compare (N_of_ascii a) (N_of_ascii b).

(* Prove that the compare_ascii function implies the equality of two ASCII
 * characters. *)
Theorem compare_ascii_implies_equality : forall (a b : ascii),
  (compare_ascii a b) = Eq -> a = b.
Proof.
  intros.
  rewrite <- ascii_N_embedding with (a := a).
  rewrite <- ascii_N_embedding with (a := b).
  f_equal.
  now apply N.compare_eq_iff.
Qed.

(* Prove that comparing an ASCII character to itself gives Eq. *)
Lemma compare_ascii_reflexive : forall (a : ascii),
  compare_ascii a a = Eq.
Proof.
  intro x.
  unfold compare_ascii.
  now apply N.compare_eq_iff.
Qed.

(** Prove that compare_ascii is symmetric when the result is Eq. *)
Lemma compare_ascii_eq_symmetric : forall (a b : ascii),
    compare_ascii a b = Eq -> compare_ascii b a = Eq.
Proof.
  intros.
  rewrite compare_ascii_implies_equality with (a := a) (b := b).
  + rewrite compare_ascii_reflexive.
    reflexivity.
  + rewrite H.
    reflexivity.
Qed.

(** Prove that compare_ascii is asymmetric when the result is not Eq. **)
Lemma compare_ascii_lt_gt_asymmetric : forall (a b : ascii),
    (compare_ascii a b) = Lt <-> (compare_ascii b a) = Gt.
Proof.
  split.
  + unfold compare_ascii.
    intros.
    apply N.compare_gt_iff in H.
    rewrite H.
    reflexivity.
  + unfold compare_ascii.
    intros.
    apply N.compare_gt_iff in H.
    rewrite H.
    reflexivity.
Qed.

(** Prove that compare_ascii is transitive when the result is Eq. *)
Lemma compare_ascii_eq_transitive : forall (a b c : ascii),
    compare_ascii a b = Eq /\ compare_ascii b c = Eq -> compare_ascii a c = Eq.
Proof.
  intros.
  rewrite compare_ascii_implies_equality with (a := a) (b := b). (* Intuition? *)
  + decompose [and] H.
    rewrite H1.
    reflexivity.
  + decompose [and] H.
    rewrite H0.
    reflexivity.
Qed.

(* Boolean equality for ASCII characters. *)
Definition beq_ascii (a b : ascii) : bool :=
  match compare_ascii a b with
    | Eq => true
    | _ => false
  end.

(* Prove boolean equality for ASCII characters is reflexive. *)
Lemma beq_ascii_reflexive : forall (a : ascii),
  beq_ascii a a = true.
Proof.
  intros.
  unfold beq_ascii.
  rewrite -> compare_ascii_reflexive.
  reflexivity.
Qed.

(* Prove that beq_ascii is symmetric. *)
Theorem beq_ascii_symmetric : forall (a b : ascii),
    beq_ascii a b = beq_ascii b a.
Proof.
  intros.
  unfold beq_ascii.
  case_eq (compare_ascii a b).
  + intros.
    apply compare_ascii_eq_symmetric in H.
    rewrite H.
    reflexivity.
  + intros.
    apply compare_ascii_lt_gt_asymmetric in H.
    rewrite H.
    reflexivity.
  + intros.
    apply compare_ascii_lt_gt_asymmetric in H.
    rewrite H.
    reflexivity.
Qed.

(** Prove that (beq_ascii a b) is true if and only if a = b. *)
Lemma beq_ascii_iff_equality : forall (a b : ascii),
    beq_ascii a b = true <-> a = b.
Proof.
  split.
  unfold beq_ascii.
  case_eq (compare_ascii a b).
  + intros.
    apply compare_ascii_implies_equality with (a := a) (b := b) in H.
    rewrite H.
    reflexivity.
  + intros.
    contradict H0.
    intuition.
  + intros.
    contradict H0.
    intuition.
  + intros.
    rewrite H.
    rewrite beq_ascii_reflexive.
    reflexivity.
Qed.

(** Prove that beq_ascii is transitive. *)
Theorem beq_ascii_transitive : forall (a b c : ascii),
    beq_ascii a b = true /\ beq_ascii b c = true -> beq_ascii a c = true.
Proof.
  intros.
  rewrite beq_ascii_iff_equality in H.
  rewrite beq_ascii_iff_equality in H.
  elim H. (* Elim will split the conjunction in H then introduce the hypotheses to the goal. *)
  intros.
  (* decompose [and] H. *) (* This tactic can also be used to decompose the conjunction in H directly. *)
  rewrite H0.
  rewrite H1.
  rewrite beq_ascii_reflexive.
  reflexivity.
Qed.

(* Boolean less than for ASCII characters. *)
Definition blt_ascii (a b : ascii) : bool :=
  match compare_ascii a b with
    | Lt => true
    | _ => false
  end.

(** Prove that boolean less than for ASCII characters is antireflexive. *)
Theorem blt_ascii_antireflexive : forall (a : ascii),
  blt_ascii a a = false.
Proof.
  intros.
  unfold blt_ascii.
  rewrite compare_ascii_reflexive.
  reflexivity.
Qed.

(** Prove that boolean less than for ASCII characters is asymmetric. *)
Theorem blt_ascii_asymmetric : forall (a b : ascii),
    blt_ascii a b = true -> blt_ascii b a = false.
Proof.
  intros a b.
  unfold blt_ascii.
  case_eq (compare_ascii a b).
  + intros.
    contradict H0. (* Contradiction, if blt_ascii a b = true then compare_ascii a b <> Eq. *)
    intuition.
  + intros.
    rewrite compare_ascii_lt_gt_asymmetric in H.
    rewrite H.
    reflexivity.
  + intros.
    contradict H0. (* Contradiction, if blt_ascii a b = true then compare_ascii a b <> Gt. *)
    intuition.
Qed.

(* TODO: blt_ascii_transitive *)

(* Boolean less than or equal to for ASCII characters. *)
Definition bleq_ascii (a b : ascii) : bool :=
  orb (blt_ascii a b) (beq_ascii a b).

(* Prove that boolean less than or equal to for ASCII characters is reflexive. *)
Theorem bleq_ascii_reflexive : forall (a : ascii),
    bleq_ascii a a = true.
Proof.
  intros.
  unfold bleq_ascii.
  rewrite beq_ascii_reflexive.
  intuition. (* We end up with a disjunction with true = true, solved by intuition. *)
Qed.

(* Boolean greater than for ASCII characters. *)
Definition bgt_ascii (a b : ascii) : bool :=
  match compare_ascii a b with
    | Gt => true
    | _ => false
  end.

(** Prove that boolean greater than for ASCII characters is antireflexive. *)
Theorem bgt_ascii_antireflexive : forall (a : ascii),
    bgt_ascii a a = false.
Proof.
  intros.
  unfold bgt_ascii.
  rewrite compare_ascii_reflexive.
  reflexivity.
Qed.

(** Prove that boolean greater than for ASCII characters is asymmetric. *)
Theorem bgt_ascii_asymmetric : forall (a b : ascii),
    bgt_ascii a b = true -> bgt_ascii b a = false.
Proof.
  intros a b.
  unfold bgt_ascii.
  case_eq (compare_ascii a b).
  + intros.
    contradict H0.
    intuition.
  + intros.
    contradict H0.
    intuition.
  + intros.
    rewrite <- compare_ascii_lt_gt_asymmetric in H.
    rewrite H.
    reflexivity.
Qed.

(* TODO: bgt_ascii_transitive *)

(* Boolean greater than or equal to for ASCII characters. *)
Definition bgeq_ascii (a b : ascii) : bool :=
  orb (bgt_ascii a b) (beq_ascii a b).

(** Prove that boolean greater than or equal to for ASCII characters is reflexive. *)
Theorem bgeq_ascii_reflexive : forall (a : ascii),
    bgeq_ascii a a = true.
Proof.
  intros.
  unfold bgeq_ascii.
  rewrite beq_ascii_reflexive.
  intuition.
Qed.

(* TODO: bgeq_ascii_antisymmetric *)

(* TODO: bgeq_ascii_transitive *)

(* Boolean equality for option ASCII characters. *)
Definition beq_option_ascii (a b : option ascii) : bool :=
  match a, b with
    | None, None => true
    | Some a', Some b' => beq_ascii a' b'
    | _, _ => false
  end.

(* TODO: Proofs for beq_option_ascii. *)

(* Equality notations module for ASCII characters. *)
Module AsciiEqualityNotations.

  (* Boolean equality operator. *)
  Notation "a ==_a b" := (beq_ascii a b) (at level 30).

  (* Boolean equality operator (including option). *)
  Notation "a ?==_a b" := (beq_option_ascii a b) (at level 30).

  (* Boolean less than operator. *)
  Notation "a <_a b" := (blt_ascii a b) (at level 30).

  (* Boolean less than or equal to operator. *)
  Notation "a <=_a b" := (bleq_ascii a b) (at level 30).

  (* Boolean greater than operator. *)
  Notation "a >_a b" := (bgt_ascii a b) (at level 30).

  (* Boolean greater than or equal to operator. *)
  Notation "a >=_a b" := (bgeq_ascii a b) (at level 30).

End AsciiEqualityNotations.


Inductive nat_tree : Set :=
| NNode' : nat -> list nat_tree -> nat_tree.
Section All.
  Variable T : Set.
  Variable P : T -> Prop.

  Fixpoint All (ls : list T) : Prop :=
    match ls with
      | nil => True
      | cons h t => P h /\ All t
    end.
End All.

Section nat_tree_ind'.
  Variable P : nat_tree -> Prop.

  Hypothesis NNode'_case : forall (n : nat) (ls : list nat_tree),
    All nat_tree P ls -> P (NNode' n ls).

  Fixpoint nat_tree_ind' (tr : nat_tree) : P tr :=
    match tr with
      | NNode' n ls => NNode'_case n ls
        ((fix list_nat_tree_ind (ls : list nat_tree) : All nat_tree P ls :=
          match ls with
            | nil => I
            | cons tr' rest => conj (nat_tree_ind' tr') (list_nat_tree_ind rest)
          end) ls)
    end.
End nat_tree_ind'.

Section map.
  Variables T T' : Set.
  Variable F : T -> T'.

  Fixpoint map (ls : list T) : list T' :=
    match ls with
      | nil => nil
      | cons h t => cons (F h) (map t)
    end.
End map.

Fixpoint sum (ls : list nat) : nat :=
  match ls with
    | nil => O
    | cons h t => plus h (sum t)
  end.

(*Now we can define a size function over our trees.*)

Fixpoint ntsize (tr : nat_tree) : nat :=
  match tr with
    | NNode' _ trs => S (sum (map _ _ ntsize trs))
  end.

(* Notice that Coq was smart enough to expand the definition of map
 to verify that we are using proper nested recursion, even through
a use of a higher-order function.*)

Fixpoint ntsplice (tr1 tr2 : nat_tree) : nat_tree :=
  match tr1 with
    | NNode' n nil => NNode' n (cons tr2 nil)
    | NNode' n (cons tr trs) => NNode' n (cons (ntsplice tr tr2) trs)
  end.

(*We have defined another arbitrary notion of tree splicing,
 similar to before, and we can prove an analogous theorem about
 its relationship with tree size. We start with a useful lemma about addition.*)

Add LoadPath "/home/user/Downloads/cpdt/".
Require Import Cpdt.CpdtTactics. (*!!! HOW TO src*)
(**)
Lemma plus_S : forall n1 n2 : nat,
  plus n1 (S n2) = S (plus n1 n2).
  induction n1; crush.
Qed.

(*Now we begin the proof of the theorem, adding the lemma plus_S as a hint.*)

Theorem ntsize_ntsplice : forall tr1 tr2 : nat_tree, ntsize (ntsplice tr1 tr2)
  = plus (ntsize tr2) (ntsize tr1).
  Hint Rewrite plus_S.
(*
We know that the standard induction principle is insufficient for the task, so we need to provide a using clause for the induction tactic to specify our alternate principle.
*)
  induction tr1 using nat_tree_ind'; crush.
(*
One subgoal remains:
  n : nat
  ls : list nat_tree
  H : All
        (fun tr1 : nat_tree =>
         forall tr2 : nat_tree,
         ntsize (ntsplice tr1 tr2) = plus (ntsize tr2) (ntsize tr1)) ls
  tr2 : nat_tree
  ============================
   ntsize
     match ls with
     | Nil => NNode' n (Cons tr2 Nil)
     | Cons tr trs => NNode' n (Cons (ntsplice tr tr2) trs)
     end = S (plus (ntsize tr2) (sum (map ntsize ls)))

After a few moments of squinting at this goal, it becomes apparent that we need to do a case analysis on the structure of ls. The rest is routine.
*)
  destruct ls; crush.
(*
We can go further in automating the proof by exploiting the hint mechanism.
*)
  Restart.

  Hint Extern 1 (ntsize (match ?LS with nil => _ | cons _ _ => _ end) = _) =>
    destruct LS; crush.
  induction tr1 using nat_tree_ind'; crush.
Defined.
Qed.


Require Export Basics.

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

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

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

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

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n as [| n' IHn'].
  - simpl. rewrite <- plus_n_0. reflexivity.
  - simpl. rewrite -> IHn'. rewrite <- plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.

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

Lemma double_plus : forall n, double n = n + n .
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite <- plus_n_Sm. rewrite <- IHn'. reflexivity.
Qed.

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - rewrite -> IHn'.
    rewrite -> negb_involutive.
    simpl. reflexivity.
Qed.

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

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

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

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

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p. destruct n.
  - simpl. reflexivity.
  - simpl. rewrite <- plus_n_Sm.
    assert (H: n + m = m + n).
    { rewrite -> plus_comm. reflexivity. }
    rewrite -> plus_assoc'. rewrite -> H.
    rewrite -> plus_assoc'. reflexivity.
Qed.

Theorem mult_n_Sm : forall n m : nat,
  n * S m = n * m + n.
Proof.
  intros n m. induction n as [|n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'.
    rewrite -> plus_n_Sm.
    rewrite -> plus_n_Sm.
    rewrite <- plus_assoc'.
    reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  intros m n. induction n as [|n' IHn'].
  - simpl. rewrite -> mult_0_r. reflexivity.
  - destruct m.
    + simpl. rewrite -> mult_0_r. reflexivity.
    + simpl. rewrite <- IHn'. simpl.
      rewrite -> plus_swap.
      rewrite -> mult_n_Sm.
      assert (H: m * n' + m = m + m * n').
      { rewrite -> plus_comm. reflexivity. }
      rewrite -> H. reflexivity.
Qed.

Theorem leb_refl : forall n : nat,
  true = leb n n.
Proof.
  intros n. induction n as [|n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem zero_nbeq_S : forall n : nat,
  beq_nat 0 (S n) = false.
Proof.
  intros n. simpl. reflexivity.
Qed.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  intros b. destruct b.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem plus_ble_compat_l : forall n m p : nat,
  leb n m = true -> leb (p + n) (p + m) = true.
Proof.
  intros n m p H.
  induction p as [|p' IHn'].
  - simpl. rewrite -> H. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem S_nbeq_0 : forall n : nat,
  beq_nat (S n) 0 = false.
Proof.
  intros n. simpl. reflexivity.
Qed.

Theorem mult_1_l : forall n : nat, 1 * n = n.
Proof.
  intros n. simpl. rewrite <- plus_n_0.
  reflexivity.
Qed.

Theorem all3_spec : forall b c : bool,
  orb
    (andb b c)
      (orb (negb b)
        (negb c))
  = true.
Proof.
  intros b c. destruct b.
  - simpl. destruct c.
    + simpl. reflexivity.
    + simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  intros n m p. induction n as [|n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'.
    rewrite -> plus_assoc'.
    reflexivity.
Qed.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  intros n m p.
  induction n as [|n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'.
    rewrite -> mult_plus_distr_r.
    reflexivity.
Qed.

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  intros n. induction n as [|n' IHn'].
  - 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. destruct n.
  - simpl. reflexivity.
  - simpl. rewrite <- plus_n_Sm.
    rewrite -> plus_assoc'.
    rewrite -> plus_assoc'.
    replace (n + m) with (m + n).
    + reflexivity.
    + rewrite -> plus_comm. reflexivity.
Qed.