(* Chapter 1  *)

(* (No exercises) *)

(* Chapter 2 *)

(* Ex 2.1 *)

Open Scope nat_scope.

(* Ex 2.1.a *)

Check (plus 3).

(* Application:

-----------------
Definition: 'App'
-----------------

E, G |- e1 : A -> B    E, G |- e2 : A
-------------------------------------
E, G |- e1 e2 : B

Simplification: make the context implicit.

e1 : A -> B    e2 : A
---------------------
e1 e2 : B

Clarification: add parens.

(e1) : (A -> B)  ,  (e2) : (A)
---------------------
(e1 e2) : B

Clarification: put assumptions long-wise instead of wide-wise.

- e1 : (A -> B)
- e2 : A
-----------------
(e1 e2) : B

Clarification: use words and indentation.

if:
  - e1 : (A -> B)
  - e2 : A
then:
  (e1 e2) : B

*)

(* Now let's instantiate 'App' for the expression-term `plus 3`

if:
  - plus : (A -> B)
  - 3 : A
then:
  (plus 3) : B  -- (1)

if:
  - A = nat
  - B = nat
  - (1)
then:
  - plus : nat -> nat  -- (2)
  - 3 : nat  -- (3)

if:
  - (2)
  - (3)
then:
  - (plus 3) : nat
*)

(* Ex 2.1.b *)

Require Import ZArith.

Open Scope Z_scope.
Check (Zmult (-5)).

(*

if:
  - e1 : (A -> B)
  - e2 : A
then:
  (e1 e2) : B

Use that:

if:
  - ZMult : (A ~ Z -> B ~ (Z -> Z))
  - (-5) : A ~ Z
then:
  (ZMult (-5)) : B ~ (Z -> Z)

*)

(* Ex 2.1.c *)

Check Z.abs_nat : Z -> nat.

(*

No application, instead it's an identifier. Identifier typing rule, as an inference rule:

-----------------
Definition: 'Var'
-----------------

(x, A) \in E \or G
------------------
E, G |- x : A

in words: 'if the identifier 'x' appears with type 'A' in the env or ctx, then x has type A in this (env, ctx).

Long-wise and iffily:

if:
  - (x, A) \in ctx
then:
  x : A

Instantiate:

if:
  - (Z.abs_nat, Z -> nat) \in ctx
then:
  Z.abs_nat : Z -> nat
*)

(* Ex 2.1.d *)

Open Scope nat_scope.
Check Z.abs_nat.
Check ((5) + Z.abs_nat (5 - 19)) : nat.

(* Ex 2.2 *)

(* Abstraction

-----------------
Definition: 'Lam'
-----------------

E, G :: (v : A) |- e : B
------------------------
E, G |- ((fun (v: A) => e): A -> B)

Simplification: make context implicit:

augmenting (v : A) |- e : B
---------------------------
(fun v: A => e) : A -> B

Clarification: long-wise:

if:
  - augmenting (v : A) |- e : B
then:
  (fun (v: A) => e) : A -> B
*)

(*
infer type: fun a b c: Z => (b * b - 4*a*c)%Z

Z -> Z -> Z -> Z
*)

Check (fun a b c: Z => (b * b - 4*a*c)%Z) : Z -> Z -> Z -> Z.

(* Ex 2.3

infer type: fun (f g : nat -> nat) (n:nat) => g (f n)

(nat -> nat) -> (nat -> nat) -> nat -> nat
*)

Check (fun (f g : nat -> nat) (n:nat) => g (f n)) : (nat -> nat) -> (nat -> nat) -> nat -> nat.

(* Ex 2.4

--------------------
Definition: 'Let-in'
--------------------

E, G |- t1 : A       E, G :: (v := t1 : A) |- t2 : B
----------------------------------------------------
E, G |- let v := t1 in t2 : B

Simplification:

if
  - t1 : A
  - augmenting (v := t1 : A) |- t2 : B
then
  (let v := t1 in t2) : B

Expression to type:

fun n p : nat =>
  (
    let diff := n - p in
    let square := diff * diff in
        square * (square + n)
  )%nat

How many typing rules to type this expression?

Not yet sure of order, but some points:

- Lam (for fun n)
- Lam (for fun p)
- Let-in (for diff)
  - Var (for (-))
  - App* (for (-))
- Let-in (for square)
  - Var (for ( * ))
  - Var (for (+))
  - App* (for ( * ))
- App* (for (+))
- App* (for ( * ))

So 8 rules, of type: Lam, Let-in, App*.
Ignoring duplicated 'Var' rules, assuming we cache the identifier lookup.

*)

(* Ex 2.5 *)

Open Scope Z_scope.

Definition add5 := fun x1 x2 x3 x4 x5 : Z => x1 + x2 + x3 + x4 + x5.

(* Ex 2.6 *)

Section ex26.

  Variables x1 x2 x3 x4 x5 : Z.

  Definition add5s := x1 + x2 + x3 + x4 + x5.
End ex26.

Eval compute in add5s 1 2 3 4 5.
Eval compute in add5 1 2 3 4 5.

(* Ex 2.7 *)

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

Eval compute in ex27 2.
Eval compute in ex27 3.
Eval compute in ex27 4.

(*

Definition: Every term whose type is 'Set' is called a 'specification'
Definition: Every term whose type is a specification is called a 'program'

nat : Set -- the term 'nat' is a specification
5 : nat   -- the term '5' is a program, because its type is 'nat', and nat is a specification.

How do we type types? There are typing rules for that. For function types:

----------------------
Definition: 'Prod-Set'
----------------------

E, G |- A : Set    E, G |- B : Set
----------------------------------
E, G |- (A -> B) : Set

Simplify:

if:
  - A : Set
  - B : Set
then:
  (A -> B) : Set

Higher types
============

5 : nat
nat : Set
Set : Type (i), forall i
Type (i) : Type (j), j > i

To summarise, terms are organised in levels:

Level 0: Programs. Examples: `0`, `S`, `trinomial`, `my_fun`
Level 1: Specifications. Examples: `nat`, `nat -> nat`, `(Z -> Z) -> nat -> nat`
Level 2: Sorts. Example: `Set`
Level 3, Universe-0s: `Type (0)`
Level 3 + i, Universe-is: `Type (i)`

The type of every term at level j is a term at level j + 1. As an ambiguity,
however, any universe of rank i also has as type *any* universe at rank j, j >
i. But let's not worry about that too much.

*)

(*
3. Propositions and Proofs

Minimal prepositional logic: formulas comprise just variables and implication, such as:

(P => Q) => ((Q => R) => (P => R))

Tarski's method of solution
---------------------------
Enumerate each possible value of each variable: true or false. Check the
expression is true under all assignments.

Heyting's method of solution
----------------------------
Try to find a process to construct a proof of the right-hand side from a proof
of the left-hand side.

- Tarski's method corresponds to classical logic, where we assume the principle of excluded middle (each proposition is either true or false).
- Heyting's method corresponds to intuitionistic logic, where we don't assume that.

Some formulas are true in classical logic, but can't be proved in intuitionistic logic.

Observation: Intuitionistic logic is less powerful than classical logic.

Coq mainly supports Heyting's intuitionistic approach.

Propositions and Proofs in terms of Coq's terms
===============================================

There is another term in Level 2 (Sorts), alongside `Set`: we now have `{Set, Prop}`.

As for `Set`, `Prop : Type(i), forall i`.

Terms of type `Prop` (at Level 1) are called 'propositions'.

Terms whose type is a proposition are called 'proofs'.

We have some equivalences:

`Set` <=> `Prop`
specification <=> proposition
proof <=> program

More fully,

                     Type(i)
                      ^  ^
                      |  |
                      |  |
                    Set Prop
                      ^  ^
                      |  |
 +-------+------------+  +-----------+------+
 |       |            |  |           |      |
 |       |            |  |           |      |
 |       |            |  |           |      |
...    specB      specA  propA     propB   ...
                  ^ ^ ^  ^  ^ ^
     +------------+ | |  |  | +------------+
     |              | |  |  |              |
     |      +-------+ |  |  +-------+      |
     |      |         |  |          |      |
    ...  progA2  progA1 proofA1  proofA2  ...

One asymmetry between programs and proofs is that we generally care about the
difference between programs fulfilling the same specification, while we don't
care as much about the difference between two proofs of the same proposition: we
only care that one exists. This irrelevance of the nature of proof terms is
called 'proof irrelevance'.

Where we can declare local variables that are programs, using the syntax,

`Variable h : nat`

we can also declare variables that are proofs, using the same syntax. If the
term is a proof, we call the variable a 'hypothesis'.

There is actually alternative syntax in such a case,

`Hypothesis h: P`, (where P stands for some proposition.)

Where we can declare *global* variables that are programs, using the syntax,

`Parameter x: nat`

we can also declare variables that are proofs using the same syntax. If the term
is a proof, we call the variable an 'axiom'.

There is actually alternative syntax in such as case,

`Axiom x: P`

The environment contains all the axioms, while the context contains all the
current hypotheses.

Definition: A global *definition* of an identifier whose type is a proposition
(i.e. an identifier that is a proof term) is called either a 'theorem' or a
'lemma'.

Definition: A 'goal' is a pair (local context, well-formed type, `t`). Typically
`t` is a proposition, i.e. a term of type `Prop`.

In the context of a goal, a term of type `t`, i.e. a proof of that proposition,
is called a 'solution'.

Definition: A tactic is a command that is applied to a goal, whose effect is to
produce a new, possibly empty, list of goals. The tactic is able to construct a
solution to the input goal, given a solution for each output goal.
*)

Section Minimal_propositional_logic.
  Variables P Q R T : Prop.

  Theorem imp_trans : (P -> Q) -> (Q -> R) -> P -> R.

  intros H H' p.

  apply H'.

  apply H.

  assumption.

  Qed.

(*

We have typing rules just like we had in the world of `Set`, but in the world of `Prop`.

Note this is a typing rule for typing propositions themselves, i.e. terms of type `Prop`, not for typing proofs.

As we had _Prod-Set_, for typing specifications involving arrows, we have _Prod-Prop_, for typing propositions involving arrows

-----------------------
Definition: 'Prod-Prop'
-----------------------

E, G |- P : Prop        E, G |- Q : Prop
----------------------------------------
          E, G |- (P -> Q) : Prop

*)

(* Chapter 3: Propositions and Proofs *)

(* Ex 3.1

Type this:

(P -> Q) -> (Q -> R) -> P -> R

- Apply _Var_ at P                                     P : Prop
- Apply _Var_ at R                                     R : Prop
- Apply _Prop-Prop_ at P, R                            P -> R : Prop
- Apply _Prop-Prop_ at Q, R                            Q -> R : Prop
- Apply _Prop-Prop_ at (Q -> R), (P ->R)               (Q -> R) -> (P -> R) : Prop
- Apply _Prop-Prop_ at P, Q                            P -> Q : Prop
- Apply _Prop-Prop_ at (P -> Q), (Q -> R) -> P -> R    (P -> Q) -> ((Q -> R) -> (P -> R)) : Prop

*)

(*

We can unify Prod-Set and Prod-Prop by parametrizing the type:

------------------
Definition: 'Prod'
------------------

E, G |- P : s        E, G |- Q : s    s \in {Set, Prop}
-------------------------------------------------------
          E, G |- (P -> Q) : s

if:
  - s \in {Set, Prop}
  - P : s
  - Q : s
then:
  (P -> Q) : s
*)

(*
Definition: For a term `t : P_1 -> ... P_n -> Q`,

  the 'head type of rank k of t' is the term `P_k -> P_n -> Q`

  Examples:
    - The head type of rank 1 is just the type of t
    - The head type of rank n is P_n -> Q

  The term Q is also called the 'final type' of t
*)

(* Ex 3.2 *)

(* 3.2a *)
Lemma id_P : P -> P.
intro H.
exact H.
Qed.

(* 3.2b *)
Lemma id_PP : (P -> P) -> (P -> P).
intro H.
exact H.
Qed.

(* (3.2c done earlier) *)

(* 3.2d *)
Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
intros pqr q p.
exact (pqr p q).
Qed.

(* 3.2e *)
Lemma ignore_Q : (P -> R) -> P -> Q -> R.
intros pr p q.
exact (pr p).
Qed.

(* 3.2f *)
Lemma delta_imp : (P -> P -> Q) -> P -> Q.
exact (fun ppq p => ppq p p).
(* exact (ppq p p). *)
Qed.

(* 3.2g *)
Lemma delta_impR : (P -> Q) -> (P -> P -> Q).

intros pq p1 p2.
exact (pq p1).
Qed.

(* 3.2h *)
Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
intros pq pr qrt p.
exact (qrt (pq p) (pr p)).
Qed.

(* 3.2i *)
Lemma weak_peirce :((((P -> Q) -> P) -> P) -> Q) -> Q.
intro f.
apply f.
intro g.
apply g.
intro p.

apply f.
intro h.
exact p.
Qed.

(*
Tacticals
=========

Simple composition
------------------

`tac1; tac2`: When applied to a goal `g`, this command applies `tac1` to `g`, and `tac2` to all the goals generated by `tac1`.

This can be chained, like `tac1; tac2; tac3`.

Generalised composition
-----------------------

Simple composition requires that `tac2` succeeds when applied to all goals
generated by `tac1`. If not, we can provide a tactic to apply to each generated
goal:

`tac1; [tac11 | tac12 | tac13]`

This works when `tac1` generates exactly 3 goals.

The sub-tactics can themselves use tacticals:

`tac1; [tac11a; tac11b | tac12 | tac13]`

Alternative (||)
----------------

We can combine tactics so that a second tactic is applied to those goals on which the first fails.

`tac1 || tac2`

This applies `tac1` to the goal. If this succeeds then we are done; if it fails, we apply `tac2`

Utility tacticals
-----------------

`idtac`: the identity tactic: always succeeds, and leaves the goal unchanged.
`fail`: always fails.

Optional (`try`)
----------------

We can apply a tactic, and do nothing if it fails:

`try tac1`

This is equivalent to `tac1 || idtac`.

If the argument of `try` is a complex expression, we can use parentheses:

`try (tac1; fail)`

*)

(* Ex 3.3 *)

(* 3.3a *)
Lemma id_P_tactically : P -> P.
intro; assumption.
Qed.

(* 3.3b *)
Lemma id_PP_tactically : (P -> P) -> (P -> P).
intro; assumption.
Qed.

(* 3.3c *)
Lemma imp_trans_tactically : (P -> Q) -> (Q -> R) -> P -> R.
intros pq qr p; apply qr; apply pq; assumption.
Qed.

(* 3.3d *)
Lemma imp_perm_tactically : (P -> Q -> R) -> (Q -> P -> R).
intros pqr q p; apply pqr; assumption.
Qed.

(* 3.3e *)
Lemma ignore_Q_tactically : (P -> R) -> P -> Q -> R.
intros pr p q; apply pr; assumption.
Qed.

(* 3.3f *)
Lemma delta_imp_tactically : (P -> P -> Q) -> P -> Q.
intros ppq p; apply ppq; assumption.
Qed.

(* 3.3g *)
Lemma delta_impR_tactically : (P -> Q) -> (P -> P -> Q).
intros pq p; assumption.
Qed.

(* 3.3h *)
Lemma diamond_tactically : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
intros pq pr qrt p. apply qrt; [apply pq; assumption | apply pr; assumption].
Qed.

(* 3.3i *)
Lemma weak_peirce_tactically :((((P -> Q) -> P) -> P) -> Q) -> Q.
intro f; apply f; intro g; apply g; intro p; apply f; intro g2; assumption.
Qed.

(* The `cut` tactic *)

Section section_for_cut_example.

Hypotheses (H : P -> Q)
           (H0 : Q -> R)
           (H1 : (P -> R) -> T -> Q)
           (H2 : (P -> R) -> T).

Theorem cut_example : Q.
Proof.

cut (P -> R).

intro pr.
apply H1.
exact pr.
apply H2.
exact pr.
intro p.
apply H0.
apply H.
exact p.

Qed.

(* Ex 3.5 *)

Theorem cut_example_without_cut : Q.
Proof.

apply H1.

(* Note that without cut, we repeat this pattern *)
intro p.
apply H0.
apply H.
exact p.

apply H2.

(* Note that without cut, we repeat this pattern *)
intro p.
apply H0.
apply H.
exact p.

Qed.

(*
Tactics
=======

Basic

- `exact p`: Use `p` to prove the current goal.
- `assumption`: Search the current context for a proof of the current goal, and use that.
- `apply f`: For a function whose final type matches the current goal, produce a goal to solve each non-final type (i.e. each argument) of `f`.
- `intro`, `intros`: When the current goal is a function, extract the leftmost argument of that function as a hypothesis in the context

Intermediate

- `cut (P : Prop)`: Provide a new goal to prove, that will then become a hypothesis of the current goal (an extra argument), and we will generate an extra goal to prove the argument-goal itself.
- `assert (P : Prop)`: Like `cut`, but we prove the provided goal first. You can name the proof like so: `assert (H : P)`
- `auto`: Uses a combination of `assumption`, `intros`, `apply` to solve a goal. It either solves a goal, or leaves it unchanged.
*)

Theorem cut_example_with_assert: Q.
Proof.

assert (H3 : (P -> R)).

intro p.
apply H0.
apply H.
exact p.

apply H1.

exact H3.
apply H2.
exact H3.

Qed.

End section_for_cut_example.

(* Ex 3.6 *)

Theorem auto_example_1: (P -> Q) -> P -> Q.
Proof.
auto 1.
Qed.

Theorem auto_example_3: (((P -> Q) -> Q) -> Q) -> P -> Q.
Proof.
auto 3.
Qed.

Theorem auto_example_4: (((((P -> Q) -> Q) -> Q) -> Q) -> Q) -> P -> Q.
Proof.
auto 4.
Qed.

Theorem auto_example_5: (((((((P -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> P -> Q.
Proof.
auto 5.
Qed.

Theorem auto_example_6: (((((((((P -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> Q) -> P -> Q.
Proof.
auto 6.
Qed.

(* General pattern: Add two '-> Q' on the RHS of the first hypothesis, to increase the 'auto' ceiling by one. *)

End Minimal_propositional_logic.

(* Chapter 4: Dependent Products *)

(*

A dependent product lets us build functions where the result type depends on the argument value.

Categorisation of value-type interactions
-----------------------------------------

- Function argument is a program of some type. Function result is a program of another type.

  Gives us: Simply-typed lambda calculus.

  Example, in Haskell syntax:

    succ : Nat -> Nat

- Function argument is a program of some type. Function result is a program, whose type depends on the type of the function argument.

  Gives us: polymorphism.

  Example, in Haskell syntax:

    just : (a : Type) -> (x : a) -> Maybe a

  So the result is a program, whose type depends on the value of the type-term `a`.

- Function argument is a type. Function result is a type, whose value depends on the value of the function argument.

  Gives us: type families, i.e. type-level functions.

  Example, in pseudo-Haskell syntax:

    a : (t : Type) -> Type

- Function argument is a program of some type. Function result is a type, whose value depends on the value of the function argument.

  Gives us: Dependent types.

  Examples, in pseudo-Haskell syntax:

    zeros : (n : Nat) -> Vec n [ (Vec n) is a specification, i.e. `(Vec n) : Set`]

    lt : (n : Nat) -> (n <= n)  [ (n <= n) is a proposition, i.e. `(n <= n) : Prop` ]

    disj_comm : P -> Q -> (P \/ Q) -> (Q \/ P)

A dependent type is a type that is the result of functions applied to appropriate expressions.

---------------------------------------------
input output  what it allows
---------------------------------------------
| term | term | simply typed lambda calculus
| type | term | polymorphism
| term | type | dependent types
| type | type | type operators, define type constructors like Maybe

Typing rules to type dependent types
------------------------------------

----------------------
Definition: 'Prod-dep'
----------------------

E, G |- A : Set       E, G |- B : Type
--------------------------------------
         E, G |- (A -> B) : Type

Simplifying, dropping env & ctx, writing iffily:

if:
  - A : Set
  - B : Type
then:
  - (A -> B) : Type

Note that in this case, the function returns a value of type 'Type', such as
'Prop' or 'Set'. This is _not_ generalising the earlier product rules, it's
supplementing them with a new rule that lets us generate types that return types
(specifications, or propositions).

If we choose `B ~ Prop`, then we have a rule that lets us type predicates:
functions of the form `A -> Prop`.

If we choose `B = Set`, then we have a rule that lets us type
value-parametrized-types: functions of the form `A -> Set`, such as `nat -> Set`
to define types of length-indexed vectors.

Compare with rule 'Prod':

E, G |- P : s        E, G |- Q : s    s \in {Set, Prop}
-------------------------------------------------------
          E, G |- (P -> Q) : s

The 'Prop' typing rule lets us type functions that return proofs or programs.

*)

(* Ex 4.1

1. (nat -> nat) -> Prop

- nat : Set ('Var', x = nat, A = Set)
- (nat -> nat) : Set ('Prod-Set', A = nat, B = nat)
- (nat -> nat) -> Prop : Type ('Prod-dep', A = (nat -> nat), B = Prop)

Example such a term might represent:

*)
(* L1: Simple types *)
(* ================ *)
(* (s={Set, Prop}, s'={Set, Prop}) *)

(* s=Set, s'=Set *)
Check (nat -> bool).
(* Same, restated with dependent product syntax *)
Check (forall n: nat, bool).

(* s=Set, s'=Prop *)
Check (nat -> 1 < 2).
(* Same, restated with dependent product syntax *)
Check (forall n: nat, 1 < 2).
(* Actually defining dependent product *)

Open Scope nat_scope.

Check (forall n: nat, n < 2).

(* s=Prop, s'=Set *)
Check (1 < 2 -> bool).
(* Same, restated with dependent product syntax *)
Check (forall p: (1 < 2), bool).
Check (forall n:nat, forall p: (n < 2), bool).

(* s=Prop, s'=Prop *)
Check (1 < 2 -> 1 < 3).
Check (forall n:nat, n < 2 -> n < 3).

(* L2: Impredicativity in `Prop` *)
(* ============================= *)
(* (s=Type, s'=s''=Prop) *)

(* A=Set *)
Check (Set -> 1 < 2).
(* With dependent product syntax *)
Check (forall t: Set, 1 < 2).

(* A=Prop *)
Check (Prop -> 1 < 2).
(* With dependent product syntax, and actually using it *)
Check (forall p: Prop, p /\ (not p)).

(* L3: Dependence *)
(* ============== *)
(* (s={Set, Prop}, s'=s''=Type) *)

(* s=Set, B=Set *)
Check (nat -> Set).
(* Dependent syntax *)
Check (forall n: nat, Set).

(* s=Set, B=Prop *)
Check (nat -> Prop).
(* Dependent syntax *)
Check (forall n: nat, Prop).

(* s=Prop, B=Set *)
Check (1 < 2 -> Set).
(* Dependent syntax *)
Check (forall p: Prop, Set).

(* s=Prop, B=Prop *)
Check (1 < 2 -> Prop).
(* Dependent syntax *)
Check (forall p: Prop, Prop).

Check eq nat nat.
Check eq 2 2.
Check nat = nat.

Check (forall p: nat, eq p p).
Check (eq 1 1).
Check (eq_refl 1).

(* Ex 4.3 *)

Section A_declared.

  Variables (A: Set) (P Q: A -> Prop) (R: A -> A -> Prop).

  Theorem all_perm : (forall a b: A, R a b) -> forall a b: A, R b a.
  Proof.
  intro H.
  intros a b.
  apply H.
  Qed.

  Theorem all_imp_dist : (forall a b:A, P a -> Q a) -> (forall a:A, P a) -> forall a:A, Q a.
  Proof.

  intros H1 H2.
  intro a.

  apply H1.

  exact a.
  apply H2.
  Qed.

  Theorem all_delta : (forall a b:A, R a b) -> forall a:A, R a a.
  Proof.
  intros H a.
  exact (H a a).
  Qed.

End A_declared.

Definition id: forall A: Set, A -> A := fun A x => x.

Eval compute in (id nat 21).

Definition diag: forall (A B: Set), (A -> A -> B) -> A -> B
  := fun A B f a => f a a.

Eval compute in (diag nat nat (fun a b => a) 0).

(* Chapter 5: Practical Aspects of Dependent Products *)

(* Ex 5.3 *)

Theorem ex_5_3_1 : ~False.
Proof.
intro.
exact H.
Qed.

Theorem ex_5_3_2: forall P: Prop, ~~~P -> ~P.
Proof.

intros Prp H P.

apply H.
intro.

exact (H0 P).
Qed.

Theorem ex_5_3_3: forall P Q: Prop, ~~~P -> P -> Q.
intros.

exfalso.

apply H.
intro.

exact (H1 H0).
Qed.

Theorem ex_5_3_4: forall P Q: Prop, (P -> Q) -> ~Q -> ~P.
intros.
intro.
exact (H0 (H H1)).
Qed.

Theorem ex_5_3_5: forall P Q R: Prop, (P -> Q) -> (P -> ~Q) -> P -> R.
intros.
exfalso.
exact ((H0 H1) (H H1)).
Qed.

(* Ex 5.4 *)

Theorem ex_5_4_1: ~(forall P Q: Prop, (P -> Q) -> (Q -> P)).
intro.

apply (H False True).

intro.
elim H0.

trivial.
Qed.

Theorem ex_5_4_2: ~(forall P Q: Prop, (P -> Q) -> (~P -> ~Q)).

intro.
apply (H False True).

intro.
elim H0.

intro.
elim H0.

trivial.
Qed.

(* Ex 5.5 *)

Theorem ex_5_5 : forall (A: Set) (a b c d: A), a=c \/ b=c \/ c=c \/ d=c.

Proof.

intros.

right.
right.
left.

Check eq_refl.
exact eq_refl.
Qed.

(* Ex 5.6 *)

Theorem ex_5_6_1 : forall (A B C: Prop), A /\ (B /\ C) -> (A /\ B) /\ C.
Proof.

intros.

case H as [H1 [H2 H3]].
split.

exact (conj H1 H2).

exact H3.
Qed.

Theorem ex_5_6_2 : forall (A B C D: Prop), (A -> B) /\ (C -> D) /\ A /\ C -> B /\ D.
Proof.

intros.

case H as [H1 [H2 [H3 H4]]].
split.

exact (H1 H3).
exact (H2 H4).
Qed.

Theorem ex_5_6_3 : forall A: Prop, ~(A /\ ~A).
Proof.

intros.
intro.
case H as [HA HNA].
exact (HNA HA).
Qed.

Theorem ex_5_6_4 : forall A B C: Prop, A \/ (B \/ C) -> (A \/ B) \/ C.
Proof.

intros.

case H as [H1 | [H2 | H3]].
left.
left.
assumption.

left.
right.
assumption.

right.
assumption.

Qed.

Theorem ex_5_6_5 : forall A: Prop, ~~(A \/ ~A).
intros.
intro.
apply H.
right.
intro.
apply H.
left.
exact H0.
Qed.

Theorem ex_5_6_6 : forall A B: Prop, (A \/ B) /\ ~A -> B.
intros.
case H as [H1 H2].
case H1 as [H1A | H1B].

elim (H2 H1A).

exact H1B.
Qed.

(* Ex 5.7 *)

Theorem ex_5_7_peirce_imp_classic : (forall P Q: Prop, ((P -> Q) -> P) -> P) -> (forall R: Prop, ~~R -> R).
intros.

apply (H R False).
intro.
elim (H0 H1).
Qed.

Theorem ex_5_7_classic_imp_exclmiddle : (forall R: Prop, ~~R -> R) -> (forall P: Prop, P \/ ~P).
intros.

apply H.
exact (ex56_5 P).
Qed.

Theorem ex_5_7_exclmiddle_imp_demorgannotandnot : (forall P: Prop, P \/ ~P) -> (forall P Q: Prop, ~(~P /\ ~Q) -> P \/ Q).
intros.

case (H P) as [H1 | H2].

left.
exact H1.

right.

case (H Q) as [HQ1 | HQ2].

exact  HQ1.

exfalso.
exact (H0 (conj H2 HQ2)).
Qed.

Theorem ex_5_7_demorgannotandnot_imp_impliestoor : (forall P Q: Prop, ~(~P /\ ~Q) -> P \/ Q) -> (forall P Q: Prop, (P -> Q) -> (~P \/ Q)).
intros.

apply (H (~P) Q).

intro.

case H1 as [H1A H1B].

apply H1A.
intro.

apply (ex56_3 Q).

exact (conj (H0 H1) H1B).
Qed.

(* TODO *)
(* Theorem ex_5_7_impliestoor_imp_peirce
  :
  (forall P Q: Prop, (P -> Q) -> (~P \/ Q))
  ->
  (forall R S: Prop, ((R -> S) -> R) -> R)
  .

intros.

apply H0.
intro.
intuition. *)

(*
More Tacticals
==============

repeat
------

Repeat a tactic until failure or complete success
*)

(* Ex 5.8 *)

(* Ex 5.8.1 *)
(* Q. What does the tactic `repeat idtac` do? *)
(* A.

The textbook says:
'apply <tactic> until failure or complete success'

I think it would loop indefinitely, because `idtac` never fails, nor completely succeeds. *)

Theorem ex_5_8_1 : forall A: Prop, A -> A.
intros.
idtac.
repeat idtac.
exact H.
Qed.

(* Ex 5.8.2 *)
(* Q. What does the tactic `repeat fail` do? *)
(* A.

I think it will do nothing, because `fail` fails, so the end-condition for
`repeat` will be satisfied after one iteration.
*)

Theorem ex_5_8_2 : forall A: Prop, A -> A.
intros.
repeat fail.
exact H.
Qed.

(* Ex 5.9 *)

(* Ex 5.9.1 *)

Section ex59.

  Variables A : Set.
  Variables P Q : A -> Prop.

  Theorem ex_5_9_1 : (exists x:A, P x \/ Q x) -> (ex P) \/ (ex Q).
    intro H.
    elim H.
    intros x Hx.
    case Hx as [HxP | HxQ].

    left.
    exists x.
    exact HxP.

    right.
    exists x.
    exact HxQ.

    Qed.

  Theorem ex_5_9_2 : (ex P) \/ (ex Q) -> exists x:A, P x \/ Q x.
    intro H.

    case H as [HP | HQ].

    elim HP.
    intros x Px.
    exists x.
    left.
    exact Px.

    elim HQ.
    intros x Qx.
    exists x.
    right.
    exact Qx.

    Qed.

  Theorem ex_5_9_3 : (forall x:A, P x) -> ~(exists y:A, ~P y).
    intro Pxx.
    intro.
    elim H.
    intros x nPx.
    apply nPx.
    exact (Pxx x).
    Qed.
End ex59.

(* Ex 5.10 *)
Theorem plus_permute2 : forall n m p : nat, n + m + p = n + p + m.
  intros n m p.
  rewrite <- plus_assoc.
  rewrite <- plus_assoc.
  rewrite (plus_comm m p).
  reflexivity.
Qed.

(* Ex 5.11 *)
Theorem eq_trans_manual : forall (A: Type) (x y z : A), x = y -> y = z -> x = z.
intros A x y z.
intros xeqy yeqz.
exact (eq_ind y (eq x) xeqy z yeqz).
Qed.

(* Using rewrites *)
Theorem eq_trans_rw : forall (A: Type) (x y z : A), x = y -> y = z -> x = z.

intros A x y z.
intros xeqy yeqz.
rewrite xeqy.
rewrite yeqz.
reflexivity.
Qed.

(* Ex 5.12 *)

Definition my_True : Prop := forall P: Prop, P -> P.

Definition my_False : Prop := forall P: Prop, P.

Check my_True.

Check id.

Theorem my_I : my_True.
exact id.
Qed.

Definition my_I_prog : my_True := fun P x => x.

Theorem my_False_ind : forall P: Prop, my_False -> P.
intros P f.
exact (f P).
Qed.

Definition my_False_ind_prog : forall P: Prop, my_False -> P
  := fun P f => f P.

(* Ex 5.13 *)

Definition my_not (P: Prop) : Prop := P -> my_False.

Theorem ex_5_13_a : my_not (my_False).
exact (id my_False).
Qed.

Theorem ex_5_13_b : forall P: Prop, my_not (my_not(my_not(P))) -> my_not(P).
intro.
unfold my_not.
intros H p.
apply H.
intro pToF.
apply pToF.
exact p.
Qed.

Theorem ex_5_13_c : forall P Q: Prop, my_not (my_not(my_not(P))) -> P -> Q.
intros P Q H p.
unfold my_not in H.
apply H.
intro pToF.
apply pToF.
exact p.
Qed.

Theorem ex_5_13_d : forall P Q: Prop, (P -> Q) -> my_not(Q) -> my_not(P).
intros P Q pq nq.
unfold my_not.
intro p.
unfold my_not in nq.
apply nq.
apply pq.
exact p.
Qed.

Theorem ex_5_13_e : forall P Q R: Prop, (P -> Q) -> (P -> my_not(Q)) -> P -> R.
intros P Q R pq pnq p.
unfold my_not in pnq.
apply pnq.
exact p.
apply pq.
exact p.
Qed.

Section leibniz.
  Set Implicit Arguments.
  Unset Strict Implicit.

  Variable A: Set.

  Definition leibniz (a b : A) : Prop :=
    forall P: A -> Prop, P a -> P b.

  Require Import Relations.

  Theorem leibniz_sym : symmetric A leibniz.
    unfold symmetric.

    unfold leibniz.
    intros x y H Q.

    apply H.
    trivial.

    Qed.

    (* Ex 5.14 *)

    Theorem leibniz_refl : reflexive A leibniz.
    unfold reflexive.
    intros x.
    unfold leibniz.
    intros P Px.
    exact Px.
    Qed.

    Theorem leibniz_trans : transitive A leibniz.
    unfold transitive.
    intros x y z lxy lyz.
    unfold leibniz in lxy.
    unfold leibniz in lyz.
    unfold leibniz.
    intros P Px.
    apply lyz.
    apply lxy.
    exact Px.
    Qed.

    Theorem leibniz_equiv : equiv A leibniz.
    unfold equiv.
    split.
    exact leibniz_refl.
    split.
    exact leibniz_trans.
    exact leibniz_sym.
    Qed.

    Theorem leibniz_least_reflexive : forall R: relation A, reflexive A R -> inclusion A leibniz R.
    intros R reflAR.
    unfold inclusion.
    intros x y lxy.
    unfold leibniz in lxy.
    apply lxy.
    unfold reflexive in reflAR.
    apply reflAR.
    Qed.

    Theorem leibniz_eq : forall a b : A, leibniz a b -> a = b.
    intros a b lab.
    unfold leibniz in lab.
    apply lab.
    reflexivity.
    Qed.

    Theorem eq_leibniz : forall a b : A, a = b -> leibniz a b.
    intros a b aeqb.
    unfold leibniz.
    intros P Pa.
    rewrite <- aeqb.
    exact Pa.
    Qed.

    Theorem leibniz_ind : forall (x:A)(P: A -> Prop), P x -> forall y:A, leibniz x y -> P y.

    intros x P Px.
    intros y lxy.
    unfold leibniz in lxy.
    apply lxy.
    exact Px.
    Qed.

    Unset Implicit Arguments.
End leibniz.

(* Ex 5.15 *)

Definition my_and (P Q : Prop) :=
  forall R:Prop, (P -> Q -> R) -> R.

Definition my_or (P Q : Prop) :=
  forall R:Prop, (P -> R) -> (Q -> R) -> R.

Definition my_ex (A: Set) (P: A -> Prop) :=
  forall R:Prop, (forall x:A, P x -> R) -> R.

(* Ex 5.15.a *)

Theorem ex_5_15_a : forall P Q : Prop, my_and P Q -> P.
intros P Q paq.
unfold my_and in paq.
apply (paq P).
intros p q.
exact p.
Qed.

Theorem ex_5_15_b : forall P Q : Prop, my_and P Q -> Q.
intros P Q paq.
unfold my_and in paq.
apply (paq Q).
intros p q.
exact q.
Qed.

Theorem ex_5_15_c : forall P Q R : Prop, (P -> Q -> R) -> my_and P Q -> R.
intros P Q R pqr paq.
unfold my_and in paq.
apply (paq R).
exact pqr.
Qed.

Theorem ex_5_15_d : forall P Q : Prop, P -> my_or P Q.
intros P Q poq.
unfold my_or.
intros R pr qr.
apply pr.
exact poq.
Qed.

Theorem ex_5_15_e : forall P Q : Prop, Q -> my_or P Q.
intros P Q poq.
unfold my_or.
intros R pr qr.
apply qr.
exact poq.
Qed.

Theorem ex_5_15_f : forall P Q R : Prop, (P -> R) -> (Q -> R) -> my_or P Q -> R.
intros P Q R pr qr poq.
unfold my_or in poq.
apply (poq R).
exact pr.
exact qr.
Qed.

Theorem ex_5_15_g : forall P : Prop, my_or P my_False -> P.
intros P pof.
unfold my_or in pof.
apply (pof P).
trivial.
unfold my_False.
intro f.
exact (f P).
Qed.

Theorem ex_5_15_h : forall P Q : Prop, my_or P Q -> my_or Q P.
intros P Q poq.
unfold my_or in poq.
unfold my_or.
intros R qr pr.
exact (poq R pr qr).
Qed.

Theorem ex_5_15_i : forall (A: Set) (P: A -> Prop) (a: A), P a -> my_ex A P.
intros A P a Pa.
unfold my_ex.
intros R foo.
exact (foo a Pa).
Qed.

Theorem ex_5_15_j : forall (A: Set) (P: A -> Prop), my_not (my_ex A P) -> forall a : A, my_not (P a).
intros A AP neap a.
unfold my_not.
intro APa.
unfold my_not in neap.
apply neap.
unfold my_ex.
intros R foo.
apply (foo a).
exact APa.
Qed.

(* Ex 5.16 *)

Definition my_le (n p : nat) :=
  forall P : nat -> Prop, P n -> (forall q:nat, P q -> P (S q)) -> P p.

(* Ex 5.16.a *)

Lemma my_le_n : forall n : nat, my_le n n.
intros n.
unfold my_le.
intros P Pn H.
exact Pn.
Qed.

(* Ex 5.16.b *)

Theorem my_le_S : forall n p : nat, my_le n p -> my_le n (S p).
intros n p le_n_p.
unfold my_le.
intros P Pn H.
apply H.
unfold my_le in le_n_p.
apply le_n_p.
exact Pn.
intros q Pq.
apply H.
exact Pq.
Qed.

(* Ex 5.16.c *)

Theorem my_le_le : forall n p : nat, my_le n p -> n <= p.
intros n p le_n_p.
unfold my_le in le_n_p.
apply (le_n_p (le n)).
Search (?n <= ?n).
exact (le_refl n).
intros q n_le_q.
Search ((?n <= ?m) -> ?n <= (S ?m)).
exact (le_S n q n_le_q).
Qed.


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.PeanoNat.

(*FW:
i better off at FIRST implement a variant of [taboo] called [r2l] which is neither random nor taboo, namely bruteforce,  -- otherwise you can not keep my motivation at all I bet. hence let's get started. *)

(** *Objective function *)

(** so far, [designspace] is only supported a subset of nat. *)
Definition designSpace := nat.
Definition range := nat.
Definition objFun := designSpace -> range.
Definition ev (x:designSpace) (f:objFun) := f x.

(** *Non-randomized taboo alg. [r2l] *)
Definition r2l (f:objFun) : range :=
  (fix r2l' x xBest yBest :=
     let y := (ev x f) in
     let (xBest', yBest') := if y <? yBest then (x, y) else (xBest, yBest) in
     match x with
       | 0   => xBest
       | S n => r2l' n xBest' yBest'
     end) 10 10 100.

Fixpoint r2l'' f (x xBest: designSpace) (yBest : range) : designSpace :=
  let y := (ev x f) in
  let (xBest', yBest') := if y <? yBest then (x, y) else (xBest, yBest) in
  match x with
    | 0   => xBest
    | S n => r2l'' f n xBest' yBest'
  end.

Fixpoint r2l' f xInit := r2l'' f xInit 10 100.

Lemma defaultArgsWork: forall f, (r2l f) = (r2l' f 10).
Proof. auto. Qed.

Inductive randBit := Zero|One|Either.
(* Inductive nat' : Set := O' : nat' | S' : nat' -> nat' | Inf : nat' . *)
Inductive randBits : Set := B : randBits | ConB : randBit -> randBits.
Require Import List.
Import ListNotations.

Fixpoint genBits (len : nat)  :=
  match len with
    | S n => Either :: (genBits n)
    | O => nil
  end.

Require Import Coq.NArith.BinNat.
Import N.
Locate "_ - _".
(* Notation            Scope      *)
(* "x - y" := sub x y   : N_scope  *)
(* "x - y" := Init.Nat.sub x y    : nat_scope *)
(*                       (default interpretation) *)

Open Scope N_scope.
Check (two - two).
Compute (two * two).
Compute (succ_double two).
Compute (size_nat 1024).
Compute iter 1 (fun foo => foo+1) two.
     (* = 3 *)
     (* : N *)
Compute iter 3 (fun foo => foo+1) two.
     (* = 5 *)
     (* : N *)

Definition init (seed l mu: nat) := genBits seed (l*mu).

Inductive opt (A : Type) : Type := Som : A -> opt A | Non : opt A.
Inductive opt' (A : Type) : Type := Som' : A -> opt' A | Non' : opt' A.

Inductive option__nat := Some': forall n : nat, option__nat n | None : option__nat.
Inductive nat' (m : nat)  := Fin : forall m : nat,  nat' m | Inf : nat' m.
Inductive nat' : Set := O' : nat' | S' : nat' -> nat' | Inf : nat' .
Check Inf.
End FW__ClassInheritenceClass.

Definition three : nat' := 3.

(* Check (3 : nat'). *)
(* Definition isInf : nat' := ca  *)
(* Corollary defaultArgsWork': forall f, (r2l f) = (r2l' f infAlmost). *)
(* Proof. *)
(*   auto. *)
(* Qed.   *)

Module TEST1.
  Definition parabola : objFun := fun x => (x-2)*2.
  Check parabola.
 Compute parabola.
  Check (ev 3 parabola).
  (* ev 3 parabola *)
  (*      : range *)
  Compute (ev 3 parabola).
  (* = 6 *)
  (* : range *)
  Compute (r2l TEST1.parabola).
End TEST1.

(*FW:
 Well done! next is multi-stared xor randomized ver. well both are hard! but former is relatively easy.

But before moving on, let's me try refoctoring: default argumenting.
*)

Module FW__DefaultArgument.
  Definition foo x y := x*y.
  Print foo.
  Definition foo2 x := x*2.
  Print foo2.
  Definition foo2' x := foo x 2.

  Theorem defaltArgumentWorks : forall x, foo2 x = foo2' x.
  Proof.
    intro.
    unfold foo2.
    unfold foo2'.
    unfold foo.
    reflexivity.
  Qed.
End FW__DefaultArgument.

(*FW:
 Making multi-started ver. is useful because, end of the day, I have to GA and SA -- both are population-based alg., namely multi started.
*)
(** **Vevify exhaustness *)
(** *[r2l__pop]: a population-based [r2l] *)
(*FW:
well, ok, now I have to import List lib. to deal with a bunch of particles. to do so, cf.
https://github.com/STakashimizu/ConShift/blob/master/Main.v
would be useful.
*)

Require Import Coq.Lists.List.
Import ListNotations.

Module FW__recallHowToHandleLists.
  Check [3; 4].
  Check [].
  Check ([] : list nat).
  Theorem empty_list_annotation: forall A:Type, ([] : list A) = (nil : list A).
    reflexivity.
  Qed.

  Check cons nil.
  Check cons 111 nil.
  Check cons 111 (cons 222 nil).

  Fixpoint len {A : Type} (ns: list A) : nat :=
    (fix len' ns l := match ns with
                       | nil => l
                       | cons _ ms => len' ms l+1
                     end
    ) ns 0.
  Theorem lis3: len [11; 22; 33] = 3.
    unfold len.
    simpl.
    reflexivity.
  Qed.

  (** FW: Good on us! *)
End FW__recallHowToHandleLists.

Check r2l.

Definition r2l__pop xs (f : objFun) :=
  let fix map__f xs := match xs with
                     | nil         => nil
                     | cons x' xs' => cons (f x') (map__f xs')
                   end in
  map__f xs.                      (* Refa: Find and use the built-in [map] function. *)

Theorem ifObjFunIsConvexThenAllPopsAreEndUpToMeetASamePositon: forall x x' : designSpace, forall f : objFun, (r2l f x) = (r2l f x').


From Theories Require Import
  Tactics Chap_2_Framework.

(** * Specification *)

(** ** Syntax *)

Definition Id  := nat.
Definition Loc := nat.

Inductive Typ :=
  | t_arr (t1 t2 : Typ)
  | t_unit
  | t_ref (t : Typ).

Inductive Exp :=
  | e_var (x : nat)
  | e_app (e1 e2 : Exp)
  | e_abs (e : Exp)
  | e_unit
  | e_ref (e : Exp)
  | e_get (e : Exp)
  | e_set (e1 e2 : Exp).

(** ** Type System *)

Definition TypEnv := List Typ.

Inductive ExpTyp : TypEnv -> Exp -> Typ -> Prop :=
  | et_var :
      forall x te t1,
      indexr x te = some t1 ->
      ExpTyp te (e_var x) t1
  | et_app :
      forall te e1 e2 t1 t2,
      ExpTyp te e1 (t_arr t1 t2) ->
      ExpTyp te e2 t1 ->
      ExpTyp te (e_app e1 e2) t2
  | et_abs :
      forall te e t1 t2,
      ExpTyp (t1 :: te) e t2 ->
      ExpTyp te (e_abs e) (t_arr t1 t2)
  | et_unit :
      forall te,
      ExpTyp te e_unit t_unit
  | et_ref :
      forall te e t,
      ExpTyp te e t ->
      ExpTyp te (e_ref e) (t_ref t)
  | et_get :
      forall te e t,
      ExpTyp te e (t_ref t) ->
      ExpTyp te (e_get e) t
  | et_set :
      forall te e1 e2 t,
      ExpTyp te e1 (t_ref t) ->
      ExpTyp te e2 t ->
      ExpTyp te (e_set e1 e2) t_unit
  .

(** ** Semantics *)

Inductive Val :=
  | v_abs (ve : List Val) (e : Exp)
  | v_unit
  | v_loc (l : Loc).

Definition ValEnv := List Val.
Definition ValStore := List Val.

Fixpoint eval (n : nat) (ve : ValEnv) (vs : ValStore) (e : Exp) :
  CanTimeout (CanErr (Val * ValStore))
:=
  match n with
  | 0 =>
      timeout
  | S n =>
      match e with
      | e_var x =>
          done (omap (fun v => (v, vs)) (indexr x ve))
      | e_abs e =>
          done (noerr (v_abs ve e, vs))
      | e_app e1 e2 =>
          '(v_abs ve1' e1', vs) <- eval n ve vs e1;
          '(v2, vs) <- eval n ve vs e2;
          eval n (v2 :: ve1') vs e1'
      | e_unit =>
          done (noerr (v_unit, vs))
      | e_ref e =>
          '(v, vs) <- eval n ve vs e;
          done (noerr (v_loc (length vs), v :: vs))
      | e_get e =>
          '(v_loc l, vs) <- eval n ve vs e;
          done (omap (fun v => (v, vs)) (indexr l vs))
      | e_set e1 e2 =>
          '(v_loc l, vs) <- eval n ve vs e1;
          '(v2, vs) <- eval n ve vs e2;
          done (noerr (v_unit, update l v2 vs))
      end
  end.

(** ** Type Soundness *)

Definition TypStore := List Typ.

Inductive ValTyp : TypStore -> Val -> Typ -> Prop :=
  | vt_abs :
      forall ts ve te e t1 t2,
      Forall2 (ValTyp ts) ve te ->
      ExpTyp (t1 :: te) e t2 ->
      ValTyp ts (v_abs ve e) (t_arr t1 t2)
  | vt_unit :
      forall ts,
      ValTyp ts v_unit t_unit
  | vt_loc :
      forall ts l t,
      indexr l ts = some t ->
      ValTyp ts (v_loc l) (t_ref t)
  .

Definition WfEnv (ve : ValEnv) (te : TypEnv) (ts : TypStore) : Prop :=
  Forall2 (ValTyp ts) ve te.

Definition WfStore (vs : ValStore) (ts : TypStore) : Prop :=
  Forall2 (ValTyp ts) vs ts.

Notation SubStore := IsSuffixOf.

(** * Theorems *)

Hint Constructors Typ Exp Val ExpTyp ValTyp Opt List.
Hint Unfold indexr length ValEnv TypEnv ValStore TypStore SubStore omap update WfEnv.
Hint Resolve ex_intro.

(* Scheme wfenv_valtype_ind := Induction for WfEnv   Sort Prop *)
(* with   valtype_wfenv_ind := Induction for ValTyp Sort Prop. *)
(* Combined Scheme wfenv_valtype_mutind from wfenv_valtype_ind, valtype_wfenv_ind. *)
(* Combined Scheme valtype_wfenv_mutind from valtype_wfenv_ind, wfenv_valtype_ind. *)

Lemma valtype_wfenv_substore :
  (forall (ve : ValEnv) (te : TypEnv) (ts1 : TypStore),
   WfEnv ve te ts1 ->
   forall (ts2 : TypStore),
   SubStore ts1 ts2 ->
   WfEnv ve te ts2) /\
  (forall (ts1 : TypStore) (v : Val) (t : Typ),
   ValTyp ts1 v t ->
   forall (ts2 : TypStore),
   SubStore ts1 ts2 ->
   ValTyp ts2 v t).
Proof.
Admitted.
(*   eapply wfenv_valtype_mutind. *)
(*   - intros. econstructor. *)
(*   - intros. econstructor. eapply H. *)
(*     + exact H1. *)
(*     + eapply H0. exact H1. *)
(*   - intros. econstructor. *)
(*     + eapply H. exact H0. *)
(*     + assumption. *)
(*   - intros. econstructor. *)
(*   - intros. econstructor. eapply indexr_suffix. *)
(*     + exact e. *)
(*     + exact H. *)
(* Qed. *)

Lemma valtype_substore :
  forall (v : Val) (t : Typ) (ts1 ts2 : TypStore),
  ValTyp ts1 v t ->
  SubStore ts1 ts2 ->
  ValTyp ts2 v t.
Proof.
  intros; eapply valtype_wfenv_substore; eauto.
Qed.

Lemma wfenv_substore:
  forall (te : TypEnv) (ve : ValEnv) (ts1 ts2 : TypStore),
  WfEnv ve te ts1 ->
  SubStore ts1 ts2 ->
  WfEnv ve te ts2.
Proof.
  intros; eapply valtype_wfenv_substore; eauto.
Qed.

Lemma wfstore_extend_inner:
  forall (ts ts' : TypStore) (vs : ValStore) (t : Typ),
    Forall2 (ValTyp ts') vs ts ->
    Forall2 (ValTyp (t :: ts')) vs ts.
Proof.
  intros until 0; intros Hwfs.
  eapply (fa2_map _ _ Hwfs).
  intros x y vt. eapply valtype_substore.
  * exact vt.
  * exists [t]. reflexivity.
Qed.

Lemma wfstore_extend:
  forall (v : Val) (vs : ValStore) (t : Typ) (ts : TypStore),
  WfStore vs ts ->
  ValTyp ts v t ->
  WfStore (v :: vs) (t :: ts).
Proof.
  intros until 0; intros Hwfs Hvt.
  econstructor.
  - eapply valtype_substore.
    + exact Hvt.
    + exists [t]. reflexivity.
  - eapply wfstore_extend_inner. exact Hwfs.
Qed.

Tactic Notation "destruct_eval" constr(e) "as" "[" ident(mv) ident(Heval) "]" :=
  remember (eval _ _ _ e) as mmv eqn:Heval; symmetry in Heval;
  destruct mmv as [mv|]; [|solve by inversion].

Theorem type_soundness :
  forall n e te ve vs ts res t,
  eval n ve vs e = done res ->
  ExpTyp te e t ->
  WfStore vs ts ->
  WfEnv ve te ts ->
  exists v vs' ts',
    res = some (v, vs') /\
    WfStore vs' ts' /\
    SubStore ts ts' /\
    ValTyp ts' v t.
Proof.
  intros n. induction n.

  Case "n = 0". intros until 0. intros Heval. inversion Heval.

  Case "n = S n". intros until 0. intros Heval Htype Hwfs Hwfe. destruct e.

    Case2 "var".
      simpl in Heval.
      inversion Heval as [Heval']; clear Heval Heval'.
      inversion Htype; subst te0 x t1; rename H1 into Htype'.
      destruct (fa2_indexr Hwfe Htype') as [v [I V]].
      rewrite I. simpl. exists v. exists vs. exists ts. intuition. apply suffix_refl.

    Case2 "app".
      inversion Htype; subst t2 e0 e3 te0;
        rename H2 into Htype1; rename H4 into Htype2; rename t into t2.

      simpl in Heval.

      destruct_eval e1 as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      (* Find out that [v1 = v_abs ve0 e]. *)
      inversion HV1; rename H3 into Hwfe3; rename H4 into Htype3; subst.

      assert (Hwfe1 : WfEnv ve te ts1). {
        eauto using wfenv_substore.
      }

      destruct_eval e2 as [mv2 Heval2].
      destruct (IHn _ _ _ _ _ _ _ Heval2 Htype2 Hwfs1 Hwfe1)
        as [v2 [vs2 [ts2 [E2 [Hwfs2 [Hss2 HV2]]]]]].
      subst mv2.

      assert (Hwfe3' : WfEnv (v2 :: ve0) (t1 :: te0) ts2). {
        econstructor. assumption.
        eapply wfenv_substore. eassumption. assumption.
      }

      destruct (IHn _ _ _ _ _ _ _ Heval Htype3 Hwfs2 Hwfe3')
        as [v3 [vs3 [ts3 [E3 [Hwfs3 [Hss3 HV3]]]]]].

      (* whats missing for the last IHn to match the goal is [SubStore ts ts3]. *)
      assert (Hss : SubStore ts ts3). {
        eauto using suffix_trans.
        (* exact (substore_trans _ _ _ Hss1 (substore_trans _ _ _ Hss2 Hss3)). *)
      }

      subst res.
      exists v3. exists vs3. exists ts3. intuition.

    Case2 "abs".
      inversion Htype; subst te0 e0. subst t.
      inversion Heval as [Heval']; clear Heval Heval'.
      exists (v_abs ve e). exists vs. exists ts.
      intuition. apply suffix_refl. eapply vt_abs; eauto.

    Case2 "unit".
      inversion Htype; subst te0. subst t.
      inversion Heval as [Heval']; clear Heval Heval'.
      do 3 eexists. intuition eauto. apply suffix_refl.

    Case2 "ref".
      inversion Htype; subst te0 e0. subst t. rename H1 into Htype1.
      simpl in Heval.

      destruct_eval e as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      inversion Heval; clear Heval; subst res.
      exists (v_loc (length vs1)). exists (v1 :: vs1). exists (t0 :: ts1).
      { intuition.
        - eauto using wfstore_extend.
        - eapply suffix_trans.
          + apply Hss1.
          + exists [t0]. reflexivity.
        - econstructor.
          rewrite (fa2_length Hwfs1).
          simpl.
          rewrite Nat.eqb_refl.
          reflexivity.
      }

    Case2 "get".
      inversion Htype; subst te0 e0. subst t. rename H1 into Htype1.
      simpl in Heval.

      destruct_eval e as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      inversion HV1; subst.
      destruct (fa2_indexr Hwfs1 H2) as [v [Hindex' HV']].
      rewrite Hindex' in Heval; simpl in Heval.
      inversion Heval; subst res.
      exists v, vs1, ts1. eauto.

    Case2 "set".
      inversion Htype; subst te0 e0 e3; rename H2 into Htype1; rename H4 into Htype2.
      subst t.

      simpl in Heval.

      destruct_eval e1 as [mv1 Heval1].
      destruct (IHn _ _ _ _ _ _ _ Heval1 Htype1 Hwfs Hwfe)
        as [v1 [vs1 [ts1 [E1 [Hwfs1 [Hss1 HV1]]]]]].
      subst mv1.

      inversion HV1; subst ts0 t. subst v1.

      assert (Hwfe1 : WfEnv ve te ts1). {
        eauto using wfenv_substore.
      }

      destruct_eval e2 as [mv2 Heval2].
      destruct (IHn _ _ _ _ _ _ _ Heval2 Htype2 Hwfs1 Hwfe1)
        as [v2 [vs2 [ts2 [E2 [Hwfs2 [Hss2 HV2]]]]]].
      subst mv2.

      inversion Heval; subst res.
      exists v_unit, (update l v2 vs2), ts2.
      { splits.
        - eauto.
        - eapply fa2_update_l; eauto using indexr_suffix.
        - eauto using suffix_trans.
        - eauto.
      }
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 6 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

(** * Syntax *)

Notation value := nat.

Inductive arith : Set :=
| Const : nat -> arith
| Var : var -> arith
| Eq : arith -> arith -> arith.

Notation pid := nat.

Inductive cmd :=
(** Normal commands *)
| Assign : var -> arith -> cmd
| If : arith -> list cmd (* then *) -> list cmd (* else *) -> cmd
| While : arith -> list cmd -> cmd
(** For message-passing *)
| SendMsg : pid (* to *) -> list arith -> cmd
| ReceiveMsg : list var -> cmd
(** End *)
| Return : arith -> cmd.

Notation pgm := (list cmd).
Notation pgms := (list (pid * pgm)).

(** Notations *)

Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Infix "==" := Eq (at level 75) : arith_scope.
Delimit Scope arith_scope with arith.
Notation "x <- e" := (Assign x e%arith) (at level 75) : cmd_scope.
Notation "'if_' c 'then' t 'else' f" := (If c%arith t f) (at level 75) : cmd_scope.
Notation "'while' ( c ) cm" := (While c%arith cm) (at level 75) : cmd_scope.
Notation "'send' es 'to' i" := (SendMsg i es%arith) (at level 75) : cmd_scope.
Notation "'receive' xs" := (ReceiveMsg xs) (at level 75) : cmd_scope.
Notation "'ret' e" := (Return e%arith) (at level 75) : cmd_scope.

Delimit Scope cmd_scope with cmd.

(** * Problem 1: operational semantics *)

(* Put your semantics here! *)

(** * End of Problem 1 *)

(** * An implementation and the correctness proof: a very simple client and an echo server. *)

Section Echo.
  Variables (n: nat).

  (** Implementation *)

  Definition client_pid := 0.
  Definition server_pid := 1.

  Definition request_to_server := 1.
  Definition response_from_server := 2.

  Definition client := [
    "done" <- 0;
    while ("done" == 0) [
      send [Const request_to_server; Const n] to server_pid;
      receive ["code"; "res"];
      if_ "code" == response_from_server then [
        "done" <- 1
      ] else []
    ];
    ret "res"
  ]%cmd.

  Definition server := [
    while (1) [
      receive ["code"; "n"];
      if_ "code" == request_to_server then [
        send [Const response_from_server; Var "n"] to client_pid
      ] else []
    ];
    ret 0
  ]%cmd.

  Definition echo_client_server : pgms :=
    [(client_pid, client); (server_pid, server)].

  (** * Problem 2: correctness of the echo system *)

  (* Put your correctness statement and the proof here! *)

  (** * End of Problem 2 *)

End Echo.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Bit vectors. Contribution by Jean Duprat (ENS Lyon). *)

Require Export Bool Sumbool.
Require Vector.
Export Vector.VectorNotations.
Require Import Minus.

Open Local Scope nat_scope.

(**
We build bit vectors in the spirit of List.v.
The size of the vector is a parameter which is too important
to be accessible only via function "length".
The first idea is to build a record with both the list and the length.
Unfortunately, this a posteriori verification leads to
numerous lemmas for handling lengths.
The second idea is to use a dependent type in which the length
is a building parameter. This leads to structural induction that
are slightly more complex and in some cases we will use a proof-term
as definition, since the type inference mechanism for pattern-matching
is sometimes weaker that the one implemented for elimination tactiques.
*)

Section BOOLEAN_VECTORS.

(**
A bit vector is a vector over booleans.
Notice that the LEAST significant bit comes first (little-endian representation).
We extract the least significant bit (head) and the rest of the vector (tail).
We compute bitwise operation on vector: negation, and, or, xor.
We compute size-preserving shifts: to the left (towards most significant bits,
we hence use Vshiftout) and to the right (towards least significant bits,
we use Vshiftin) by inserting a 'carry' bit (logical shift) or by repeating
the most significant bit (arithmetical shift).
NOTA BENE: all shift operations expect predecessor of size as parameter
(they only work on non-empty vectors).
*)

Definition Bvector := Vector.t bool.

Definition Bnil := @Vector.nil bool.

Definition Bcons := @Vector.cons bool.

Definition Bvect_true := Vector.const true.

Definition Bvect_false := Vector.const false.

Definition Blow := @Vector.hd bool.

Definition Bhigh := @Vector.tl bool.

Definition Bsign := @Vector.last bool.

Definition Bneg n (v : Bvector n) := Vector.map negb v.

Definition BVand n (v : Bvector n) := Vector.map2 andb v.

Definition BVor n (v : Bvector n) := Vector.map2 orb v.

Definition BVxor n (v : Bvector n) := Vector.map2 xorb v.

Definition BshiftL (n:nat) (bv:Bvector (S n)) (carry:bool) :=
  Bcons carry n (Vector.shiftout bv).

Definition BshiftRl (n:nat) (bv:Bvector (S n)) (carry:bool) :=
  Bhigh (S n) (Vector.shiftin carry bv).

Definition BshiftRa (n:nat) (bv:Bvector (S n)) :=
  Bhigh (S n) (Vector.shiftrepeat bv).

Fixpoint BshiftL_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
  match p with
    | O => bv
    | S p' => BshiftL n (BshiftL_iter n bv p') false
  end.

Fixpoint BshiftRl_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
  match p with
    | O => bv
    | S p' => BshiftRl n (BshiftRl_iter n bv p') false
  end.

Fixpoint BshiftRa_iter (n:nat) (bv:Bvector (S n)) (p:nat) : Bvector (S n) :=
  match p with
    | O => bv
    | S p' => BshiftRa n (BshiftRa_iter n bv p')
  end.

End BOOLEAN_VECTORS.


(* nat上の商と余りを計算する *)

Require Import Arith.
Require Import Euclid.

Definition quotient_modulo :
  forall n,
    n > 0 ->
    forall m:nat, {qr : nat * nat |  let '(q, r) := qr in m = q * n + r /\ n > r}.
Proof.
  induction m as (m,H0) using gt_wf_rec.
  destruct (le_gt_dec n m) as [Hlebn|Hgtbn].
  - destruct (H0 (m - n)) as (qr & Hqr); auto with arith.
    destruct qr as (q, r). exists (S q, r).
    destruct Hqr as (Heq & Hgt). split; [| now trivial].
    simpl. rewrite <- plus_assoc. rewrite <- Heq. now auto with arith.
  - exists (0, m). simpl. now auto with arith.
Defined.

Definition quot_mod x y :=
  match y with
  | O => (O, x)
  | S p =>
    let '(exist _ (q,r) _) := quotient_modulo (S p) (lt_O_Sn p) x in
    (q, r)
  end.

Theorem quot_mod_sound : forall x y q r,
  y > 0 -> quot_mod x y = (q, r) -> x = q * y + r /\ y > r.
Proof.
  intros x y q r Hgt0. destruct y; [now destruct (gt_irrefl 0)|].
  simpl.
  destruct (quotient_modulo (S y) _ x) as [(q',r') Hr'].
  intros Heq_qr. injection Heq_qr. intros Heq_r Heq_q. subst.
  assumption.
Qed.

Theorem quot_mod_complete : forall x y q r,
    y > 0 ->
    x = q * y + r ->
    y > r ->
    quot_mod x y = (q, r).
Proof.
Admitted.


Require Import Basics.

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

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

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.

Theorem evenb_n__oddb_Sn : forall n : nat,
  evenb n = negb (evenb (S n)).
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
  reflexivity.
  Case "n = S n'".
  simpl.
  inversion IHn'.
  rewrite -> H0.
  rewrite -> (negb_involutive (oddb n')).
  reflexivity.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Euclidean Division *)

Require Import NZAxioms NZMulOrder.

(** The first signatures will be common to all divisions over NZ, N and Z *)

Module Type DivMod (Import A : Typ).
 Parameters Inline div modulo : t -> t -> t.
End DivMod.

Module Type DivModNotation (A : Typ)(Import B : DivMod A).
 Infix "/" := div.
 Infix "mod" := modulo (at level 40, no associativity).
End DivModNotation.

Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A.

Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A).
 Declare Instance div_wd : Proper (eq==>eq==>eq) div.
 Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo.
 Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b).
 Axiom mod_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
End NZDivSpec.

(** The different divisions will only differ in the conditions
    they impose on [modulo]. For NZ, we have only described the
    behavior on positive numbers.
*)

Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A.
Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A.

Module Type NZDivProp
 (Import A : NZOrdAxiomsSig')
 (Import B : NZDiv' A)
 (Import C : NZMulOrderProp A).

(** Uniqueness theorems *)

Theorem div_mod_unique :
 forall b q1 q2 r1 r2, 0<=r1<b -> 0<=r2<b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b.
assert (U : forall q1 q2 r1 r2,
            b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False).
 intros q1 q2 r1 r2 EQ LT Hr1 Hr2.
 contradict EQ.
 apply lt_neq.
 apply lt_le_trans with (b*q1+b).
 rewrite <- add_lt_mono_l. tauto.
 apply le_trans with (b*q2).
 rewrite mul_comm, <- mul_succ_l, mul_comm.
 apply mul_le_mono_nonneg_l; intuition; try order.
 rewrite le_succ_l; auto.
 rewrite <- (add_0_r (b*q2)) at 1.
 rewrite <- add_le_mono_l. tauto.

intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]].
elim (U q1 q2 r1 r2); intuition.
split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto.
elim (U q2 q1 r2 r1); intuition.
Qed.

Theorem div_unique:
 forall a b q r, 0<=a -> 0<=r<b ->
   a == b*q + r -> q == a/b.
Proof.
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound_pos; order.
rewrite <- div_mod; order.
Qed.

Theorem mod_unique:
 forall a b q r, 0<=a -> 0<=r<b ->
  a == b*q + r -> r == a mod b.
Proof.
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound_pos; order.
rewrite <- div_mod; order.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, 0<a -> a/a == 1.
Proof.
intros. symmetry.
apply div_unique with 0; intuition; try order.
now nzsimpl.
Qed.

Lemma mod_same : forall a, 0<a -> a mod a == 0.
Proof.
intros. symmetry.
apply mod_unique with 1; intuition; try order.
now nzsimpl.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof.
intros. symmetry.
apply div_unique with a; intuition; try order.
now nzsimpl.
Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof.
intros. symmetry.
apply mod_unique with 0; intuition; try order.
now nzsimpl.
Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, 0<a -> 0/a == 0.
Proof.
intros; apply div_small; split; order.
Qed.

Lemma mod_0_l: forall a, 0<a -> 0 mod a == 0.
Proof.
intros; apply mod_small; split; order.
Qed.

Lemma div_1_r: forall a, 0<=a -> a/1 == a.
Proof.
intros. symmetry.
apply div_unique with 0; try split; try order; try apply lt_0_1.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0.
Proof.
intros. symmetry.
apply mod_unique with a; try split; try order; try apply lt_0_1.
now nzsimpl.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof.
intros; apply div_small; split; auto. apply le_0_1.
Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof.
intros; apply mod_small; split; auto. apply le_0_1.
Qed.

Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a.
Proof.
intros; symmetry.
apply div_unique with 0; try split; try order.
apply mul_nonneg_nonneg; order.
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0.
Proof.
intros; symmetry.
apply mod_unique with a; try split; try order.
apply mul_nonneg_nonneg; order.
nzsimpl; apply mul_comm.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
Proof.
intros. destruct (le_gt_cases b a).
apply le_trans with b; auto.
apply lt_le_incl. destruct (mod_bound_pos a b); auto.
rewrite lt_eq_cases; right.
apply mod_small; auto.
Qed.

(* Division of positive numbers is positive. *)

Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b.
Proof.
intros.
rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl.
rewrite (add_le_mono_r _ _ (a mod b)).
rewrite <- div_mod by order.
nzsimpl.
apply mod_le; auto.
Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof.
intros a b (Hb,Hab).
assert (LE : 0 <= a/b) by (apply div_pos; order).
assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order).
rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto.
exfalso; revert Hab.
rewrite (div_mod a b), <-EQ; nzsimpl; order.
Qed.

Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b).
Proof.
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b); auto.
symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto.
apply div_small; auto.
Qed.

Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b).
Proof.
intros a b Ha Hb. split; intros H; auto using mod_small.
rewrite <- div_small_iff; auto.
rewrite <- (mul_cancel_l _ _ b) by order.
rewrite <- (add_cancel_r _ _ (a mod b)).
rewrite <- div_mod, H by order. now nzsimpl.
Qed.

Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a).
Proof.
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b) as [LT|LE]; auto.
rewrite <- div_small_iff in LT; order.
apply div_str_pos; auto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof.
intros.
assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1).
destruct (lt_ge_cases a b).
rewrite div_small; try split; order.
rewrite (div_mod a b) at 2 by order.
apply lt_le_trans with (b*(a/b)).
rewrite <- (mul_1_l (a/b)) at 1.
rewrite <- mul_lt_mono_pos_r; auto.
apply div_str_pos; auto.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> 0<=a<=b -> a/c <= b/c.
Proof.
intros a b c Hc (Ha,Hab).
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; auto.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_bound_pos b c); order.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order.
Qed.

(** The following two properties could be used as specification of div *)

Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a.
Proof.
intros.
rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order.
rewrite <- (add_0_r a) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
Qed.

Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
Proof.
intros.
rewrite (div_mod a b) at 1 by order.
rewrite (mul_succ_r).
rewrite <- add_lt_mono_l.
destruct (mod_bound_pos a b); auto.
Qed.

(** The previous inequality is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros. rewrite (div_mod a b) at 1 by order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additionnal inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by order.
apply le_lt_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite (mul_le_mono_pos_l _ _ b) by order.
apply le_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<=a -> 0<b -> b*q <= a -> q <= a/b.
Proof.
intros a b q Ha Hb H.
destruct (lt_ge_cases 0 q).
rewrite <- (div_mul q b); try order.
apply div_le_mono; auto.
rewrite mul_comm; split; auto.
apply lt_le_incl, mul_pos_pos; auto.
apply le_trans with 0; auto; apply div_pos; auto.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r ->
    p/r <= p/q.
Proof.
 intros p q r Hp (Hq,Hqr).
 apply div_le_lower_bound; auto.
 rewrite (div_mod p r) at 2 by order.
 apply le_trans with (r*(p/r)).
 apply mul_le_mono_nonneg_r; try order.
 apply div_pos; order.
 rewrite <- (add_0_r (r*(p/r))) at 1.
 rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order.
Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
 (a + b * c) mod c == a mod c.
Proof.
 intros.
 symmetry.
 apply mod_unique with (a/c+b); auto.
 apply mod_bound_pos; auto.
 rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
 now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
 (a + b * c) / c == a / c + b.
Proof.
 intros.
 apply (mul_cancel_l _ _ c); try order.
 apply (add_cancel_r _ _ ((a+b*c) mod c)).
 rewrite <- div_mod, mod_add by order.
 rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
 now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0<b ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 intros. apply div_add; auto.
Qed.

(** Cancellations. *)

Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c ->
 (a*c)/(b*c) == a/b.
Proof.
 intros.
 symmetry.
 apply div_unique with ((a mod b)*c).
 apply mul_nonneg_nonneg; order.
 split.
 apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order.
 rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto.
 rewrite (div_mod a b) at 1 by order.
 rewrite mul_add_distr_r.
 rewrite add_cancel_r.
 rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c ->
 (c*a)/(c*b) == a/b.
Proof.
 intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto.
Qed.

Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
 intros.
 rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
 rewrite <- div_mod.
 rewrite div_mul_cancel_l; auto.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
 rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, 0<=a -> 0<n ->
 (a mod n) mod n == a mod n.
Proof.
 intros. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff.
Qed.

Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Ha Hb Hn. symmetry.
 generalize (mul_nonneg_nonneg _ _ Ha Hb).
 rewrite (div_mod a n) at 1 2 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 intros. rewrite mod_add; auto.
 now rewrite mul_comm.
 apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto.
Qed.

Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto.
Qed.

Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity.
 now destruct (mod_bound_pos b n).
Qed.

Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Ha Hb Hn. symmetry.
 generalize (add_nonneg_nonneg _ _ Ha Hb).
 rewrite (div_mod a n) at 1 2 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 intros. rewrite mod_add; trivial. reflexivity.
 apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto.
Qed.

Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto.
Qed.

Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity.
 now destruct (mod_bound_pos b n).
Qed.

Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Ha Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b); trivial.
 (* begin 0<= ... <b*c *)
 destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos.
 split.
 apply add_nonneg_nonneg; auto.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + b).
 rewrite <- add_lt_mono_l; auto.
 rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto.
 (* end 0<= ... < b*c *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof.
 intros a b c Ha Hb Hc.
 apply add_cancel_l with (b*c*(a/(b*c))).
 rewrite <- div_mod by (apply neq_mul_0; split; order).
 rewrite <- div_div by trivial.
 rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
 rewrite <- div_mod by order.
 apply div_mod; order.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof.
 intros.
 apply div_le_lower_bound; auto.
 apply mul_nonneg_nonneg; auto.
 rewrite mul_assoc, (mul_comm b c), <- mul_assoc.
 apply mul_le_mono_nonneg_l; auto.
 apply mul_div_le; auto.
Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, 0<=a -> 0<b ->
 (a mod b == 0 <-> exists c, a == b*c).
Proof.
 split.
 intros. exists (a/b). rewrite div_exact; auto.
 intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto.
 rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order.
Qed.

End NZDivProp.


Require Export Category Functor InitialTerminalCategory.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope equiv_scope.
Local Open Scope morphism_scope.
Local Open Scope category_scope.

Section CommaCategory.
  Variable A : PreCategory.
  Variable B : PreCategory.
  Variable C : PreCategory.
  Variable S : Functor A C.
  Variable T : Functor B C.

  (** Quoting Wikipedia:

      Suppose that [A], [B], and [C] are categories, and [S] and [T]
      are functors

      [S : A -> C <- B : T]

      We can form the comma category [(S ↓ T)] as follows:

      (o) The objects are all triples [(α, β, f)] with [α] an object
          in [A], [β] an object in [B], and [f : S α -> T β] a
          morphism in [C].

      (o) The morphisms from [(α, β, f)] to [(α', β', f')] are all
          pairs [(g, h)] where [g : α -> α'] and [h : β -> β'] are
          morphisms in [A] and [B] respectively, such that the
          following diagram commutes:

<<
               S g
          S α -----> S α'
           |          |
         f |          | f'
           |          |
           V          V
          T β -----> T β'
               T h
>>

     Morphisms are composed by taking [(g, h) ∘ (g', h')] to be [(g ∘
     g', h ∘ h')], whenever the latter expression is defined.  The
     identity morphism on an object [(α, β, f)] is [(Identity α,
     Identity β)].  *)

  Record CommaCategory_Object :=
    {
      CCO_a : A;
      CCO_b : B;
      CCO_f : Morphism C (S CCO_a) (T CCO_b)
    }.

  Local Notation CommaCategory_Object_sig_T :=
    ({ CCO_a : A
     | { CCO_b : B
       | Morphism C (S CCO_a) (T CCO_b) }}).

  Lemma CommaCategory_Object_sig_equiv
  : CommaCategory_Object_sig_T <~> CommaCategory_Object.
  Proof.
    issig (@Build_CommaCategory_Object)
          (@CCO_a)
          (@CCO_b)
          (@CCO_f).
  Defined.

  Global Instance trunc_CommaCategory_Object `{IsTrunc n A, IsTrunc n B}
         `{forall s d, IsTrunc n (Morphism C s d)}
  : IsTrunc n CommaCategory_Object.
  Proof.
    eapply trunc_equiv';
    [ exact CommaCategory_Object_sig_equiv | ].
    typeclasses eauto.
  Qed.

  Lemma CommaCategory_Object_eq' (x y : CommaCategory_Object)
  : forall (Hα : CCO_a x = CCO_a y)
           (Hβ : CCO_b x = CCO_b y),
      match Hα in _ = X, Hβ in _ = Y return Morphism C (S X) (T Y) with
        | idpath, idpath => CCO_f x
      end = CCO_f y
      -> x = y.
  Proof.
    destruct x, y; simpl.
    intros; path_induction; reflexivity.
  Defined.

  Record CommaCategory_Morphism (abf a'b'f' : CommaCategory_Object) :=
    {
      CCM_g : Morphism A (CCO_a abf) (CCO_a a'b'f');
      CCM_h : Morphism B (CCO_b abf) (CCO_b a'b'f');
      CCM_p : MorphismOf T CCM_h ∘ CCO_f abf = CCO_f a'b'f' ∘ MorphismOf S CCM_g
    }.

  Local Notation CommaCategory_Morphism_sig_T abf a'b'f' :=
    ({ CCM_g : Morphism A (CCO_a abf) (CCO_a a'b'f')
     | { CCM_h : Morphism B (CCO_b abf) (CCO_b a'b'f')
       | MorphismOf T CCM_h ∘ CCO_f abf = CCO_f a'b'f' ∘ MorphismOf S CCM_g }}).

  Lemma CommaCategory_Morphism_sig_equiv abf a'b'f'
  : (CommaCategory_Morphism_sig_T abf a'b'f')
      <~> CommaCategory_Morphism abf a'b'f'.
  Proof.
    issig (@Build_CommaCategory_Morphism abf a'b'f')
          (@CCM_g abf a'b'f')
          (@CCM_h abf a'b'f')
          (@CCM_p abf a'b'f').
  Defined.

  Global Instance trunc_CommaCategory_Morphism abf a'b'f'
         `{IsTrunc n (Morphism A (CCO_a abf) (CCO_a a'b'f'))}
         `{IsTrunc n (Morphism B (CCO_b abf) (CCO_b a'b'f'))}
         `{forall m1 m2,
             IsTrunc n (T ₁ m2 ∘ CCO_f abf = CCO_f a'b'f' ∘ S ₁ m1)}
  : IsTrunc n (CommaCategory_Morphism abf a'b'f').
  Proof.
    eapply trunc_equiv';
    [ exact (CommaCategory_Morphism_sig_equiv _ _) | ].
    typeclasses eauto.
  Qed.

  Lemma CommaCategory_Morphism_eq abf a'b'f'
        (gh g'h' : CommaCategory_Morphism abf a'b'f')
  : CCM_g gh = CCM_g g'h'
    -> CCM_h gh = CCM_h g'h'
    -> gh = g'h'.
  Proof.
    destruct gh, g'h'; simpl.
    intros; path_induction.
    f_ap.
    exact (center _).
  Qed.

  Definition CommaCategory_Compose s d d'
             (gh : CommaCategory_Morphism d d') (g'h' : CommaCategory_Morphism s d)
  : CommaCategory_Morphism s d'.
  Proof.
    exists (CCM_g gh ∘ CCM_g g'h') (CCM_h gh ∘ CCM_h g'h').
    hnf in *; simpl in *.
    abstract (
        destruct_head CommaCategory_Morphism;
        repeat rewrite FCompositionOf;
        repeat try_associativity ltac:(t_rev_with t')
      ).
  Defined.

  Global Arguments CommaCategory_Compose _ _ _ _ _ / .

  Definition CommaCategory_Identity x : CommaCategory_Morphism x x.
    exists (Identity (CCO_a x)) (Identity (CCO_b x)).
    abstract (
        simpl; autorewrite with category; reflexivity
      ).
  Defined.

  Global Arguments CommaCategory_Identity _ / .

  Local Ltac comma_eq_t :=
    intros;
    apply CommaCategory_Morphism_eq;
    simpl;
    autorewrite with category;
    reflexivity.

  Definition CommaCategory : PreCategory.
    refine (@Build_PreCategory
              CommaCategory_Object
              CommaCategory_Morphism
              CommaCategory_Identity
              CommaCategory_Compose
              _
              _
              _
              _
           );
    abstract comma_eq_t.
  Defined.

  Section strict.
    Global Instance CommaCategory_IsStrict `{IsStrictCategory A, IsStrictCategory B}
    : IsStrictCategory CommaCategory.
    Proof.
      typeclasses eauto.
    Qed.
  End strict.

(*  Section category.
    Context `{IsCategory A, IsCategory B}.
    (*Context `{Funext}. *)

    Definition CommaCategory_isotoid (x y : CommaCategory)
    : x ≅ y -> x = y.
    Proof.
      intro i.
      destruct i as [i [i' ? ?]].
      hnf in *.
      destruct i, i'.
      simpl in *.

    Global Instance CommaCategory_IsCategory `{IsCategory A, IsCategory B}
    : IsCategory CommaCategory.
    Proof.
      hnf.
      unfold IsStrictCategory in *.
      typeclasses eauto.
    Qed.
  End category.
*)
End CommaCategory.

Hint Unfold CommaCategory_Compose CommaCategory_Identity : category.
Hint Constructors CommaCategory_Morphism CommaCategory_Object : category.

Section SliceCategory.
  Variable A : PreCategory.
  Variable C : PreCategory.
  Variable a : C.
  Variable S : Functor A C.

  Definition SliceCategory := CommaCategory S (FunctorFromTerminal C a).
  Definition CosliceCategory := CommaCategory (FunctorFromTerminal C a) S.

  (** [x ↓ F] is a coslice category; [F ↓ x] is a slice category; [x ↓ F] deals with morphisms [x -> F y]; [F ↓ x] has morphisms [F y -> x] *)
End SliceCategory.

Section SliceCategoryOver.
  Variable C : PreCategory.
  Variable a : C.

  Definition SliceCategoryOver := SliceCategory a (IdentityFunctor C).
  Definition CosliceCategoryOver := CosliceCategory a (IdentityFunctor C).
End SliceCategoryOver.

Section ArrowCategory.
  Variable C : PreCategory.

  Definition ArrowCategory := CommaCategory (IdentityFunctor C) (IdentityFunctor C).
End ArrowCategory.

Notation "C / a" := (@SliceCategoryOver C a) : category_scope.
Notation "a \ C" := (@CosliceCategoryOver C a) : category_scope.

Definition CC_Functor' (C : PreCategory) (D : PreCategory) := Functor C D.
Coercion CC_FunctorFromTerminal' (C : PreCategory) (x : C) : CC_Functor' TerminalCategory C := FunctorFromTerminal C x.
Arguments CC_Functor' / .
Arguments CC_FunctorFromTerminal' / .

(* ASCII notations *)
(* Set some notations for printing *)
Notation "x |v| F" := (CosliceCategory x F) : category_scope.
Notation "F |v| x" := (SliceCategory x F) : category_scope.
Notation "S |v| T" := (CommaCategory S T) : category_scope.
(* set the notation for parsing *)
Notation "S |v| T" := (CommaCategory (S : CC_Functor' _ _)
                                     (T : CC_Functor' _ _)) : category_scope.

(* Unicode Notations *)
(* Set some notations for printing *)
Notation "x ↓ F" := (CosliceCategory x F) : category_scope.
Notation "F ↓ x" := (SliceCategory x F) : category_scope.
Notation "S ↓ T" := (CommaCategory S T) : category_scope.
(* set the notation for parsing *)
Notation "S ↓ T" := (CommaCategory (S : CC_Functor' _ _)
                                   (T : CC_Functor' _ _)) : category_scope.
(*Set Printing All.
Check (fun (C : Category)(D : Category)(E : Category)(S : Functor C D) (T : Functor E D) => (S ↓ T)%category).
Check (fun (D : Category)(E : Category)(S : Functor E D) (x : D) => (x ↓ S)%category).
Check (fun (D : Category)(E : Category)(S : Functor E D) (x : D) => (S ↓ x)%category).*)


Set Warnings "-notation-overridden,-parsing".
Require Import ProofObjects.
Parameter MISSING: Type.

Module Check.

Ltac check_type A B :=
match type of A with
| context[MISSING] => idtac "Missing:" A
| ?T => first [unify T B; idtac "Type: ok" | idtac "Type: wrong - should be (" B ")"]
end.

Ltac print_manual_grade A :=
first [
match eval compute in A with
| ?T => idtac "Score:" T
end
| idtac "Score: Ungraded"].

End Check.

Require Import ProofObjects.
Import Check.

Goal True.

idtac "-------------------  eight_is_even  --------------------".
idtac " ".

idtac "#> ev_8".
idtac "Possible points: 1".
check_type @ev_8 ((ev 8)).
idtac "Assumptions:".
Abort.
Print Assumptions ev_8.
Goal True.
idtac " ".

idtac "#> ev_8'".
idtac "Possible points: 1".
check_type @ev_8' ((ev 8)).
idtac "Assumptions:".
Abort.
Print Assumptions ev_8'.
Goal True.
idtac " ".

idtac "-------------------  equality__leibniz_equality  --------------------".
idtac " ".

idtac "#> equality__leibniz_equality".
idtac "Possible points: 2".
check_type @equality__leibniz_equality (
(forall (X : Type) (x y : X), x = y -> forall P : X -> Prop, P x -> P y)).
idtac "Assumptions:".
Abort.
Print Assumptions equality__leibniz_equality.
Goal True.
idtac " ".

idtac " ".

idtac "Max points - standard: 4".
idtac "Max points - advanced: 4".
Abort.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* G. Huet 1-9-95 *)

Require Import Permut Setoid.

Set Implicit Arguments.

Section multiset_defs.

  Variable A : Type.
  Variable eqA : A -> A -> Prop.
  Hypothesis eqA_equiv : Equivalence eqA.
  Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}.

  Inductive multiset : Type :=
    Bag : (A -> nat) -> multiset.

  Definition EmptyBag := Bag (fun a:A => 0).
  Definition SingletonBag (a:A) :=
    Bag (fun a':A => match Aeq_dec a a' with
                       | left _ => 1
                       | right _ => 0
                     end).

  Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a.

  (** multiset equality *)
  Definition meq (m1 m2:multiset) :=
    forall a:A, multiplicity m1 a = multiplicity m2 a.

  Lemma meq_refl : forall x:multiset, meq x x.
  Proof.
    destruct x; unfold meq; reflexivity.
  Qed.

  Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
  Proof.
    unfold meq in |- *.
    destruct x; destruct y; destruct z.
    intros; rewrite H; auto.
  Qed.

  Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
  Proof.
    unfold meq in |- *.
    destruct x; destruct y; auto.
  Qed.

  (** multiset union *)
  Definition munion (m1 m2:multiset) :=
    Bag (fun a:A => multiplicity m1 a + multiplicity m2 a).

  Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x).
  Proof.
    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
  Qed.

  Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
  Proof.
    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
  Qed.

  Require Plus. (* comm. and ass. of plus *)

  Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
  Proof.
    unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
    destruct x; destruct y; auto with arith.
  Qed.

  Lemma munion_ass :
    forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)).
  Proof.
    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
    destruct x; destruct y; destruct z; auto with arith.
  Qed.

  Lemma meq_left :
    forall x y z:multiset, meq x y -> meq (munion x z) (munion y z).
  Proof.
    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
    destruct x; destruct y; destruct z.
    intros; elim H; auto with arith.
  Qed.

  Lemma meq_right :
    forall x y z:multiset, meq x y -> meq (munion z x) (munion z y).
  Proof.
    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
    destruct x; destruct y; destruct z.
    intros; elim H; auto.
  Qed.

  (** Here we should make multiset an abstract datatype, by hiding [Bag],
      [munion], [multiplicity]; all further properties are proved abstractly *)

  Lemma munion_rotate :
    forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)).
  Proof.
    intros; apply (op_rotate multiset munion meq).
      apply munion_comm.
      apply munion_ass.
      exact meq_trans.
      exact meq_sym.
      trivial.
  Qed.

  Lemma meq_congr :
    forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t).
  Proof.
    intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right.
      exact meq_trans.
  Qed.

  Lemma munion_perm_left :
    forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)).
  Proof.
    intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym.
      exact meq_trans.
  Qed.

  Lemma multiset_twist1 :
    forall x y z t:multiset,
      meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z).
  Proof.
    intros; apply (twist multiset munion meq); auto using munion_comm, munion_ass, meq_sym, meq_left, meq_right.
    exact meq_trans.
  Qed.

  Lemma multiset_twist2 :
    forall x y z t:multiset,
      meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t).
  Proof.
    intros; apply meq_trans with (munion (munion x (munion y z)) t).
    apply meq_sym; apply munion_ass.
    apply meq_left; apply munion_perm_left.
  Qed.

  (** specific for treesort *)

  Lemma treesort_twist1 :
    forall x y z t u:multiset,
      meq u (munion y z) ->
      meq (munion x (munion u t)) (munion (munion y (munion x t)) z).
  Proof.
    intros; apply meq_trans with (munion x (munion (munion y z) t)).
    apply meq_right; apply meq_left; trivial.
    apply multiset_twist1.
  Qed.

  Lemma treesort_twist2 :
    forall x y z t u:multiset,
      meq u (munion y z) ->
      meq (munion x (munion u t)) (munion (munion y (munion x z)) t).
  Proof.
    intros; apply meq_trans with (munion x (munion (munion y z) t)).
    apply meq_right; apply meq_left; trivial.
    apply multiset_twist2.
  Qed.

  (** SingletonBag *)

  Lemma meq_singleton : forall a a',
    eqA a a' -> meq (SingletonBag a) (SingletonBag a').
  Proof.
    intros; red; simpl; intro a0.
    destruct (Aeq_dec a a0) as [Ha|Ha]; rewrite H in Ha;
      decide (Aeq_dec a' a0) with Ha; reflexivity.
  Qed.

(*i theory of minter to do similarly
Require Min.
(* multiset intersection *)
Definition minter := [m1,m2:multiset]
    (Bag [a:A](min (multiplicity m1 a)(multiplicity m2 a))).
i*)

End multiset_defs.

Unset Implicit Arguments.

Hint Unfold meq multiplicity: v62 datatypes.
Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right
  munion_empty_left: v62 datatypes.
Hint Immediate meq_sym: v62 datatypes.


Require Import Omega.
Require Import Equalities.

Open Scope nat_scope.

Definition var := nat.

Inductive typ :=
  TUnit
| Tarr (arg res : typ).

Definition env := var -> option typ.

Inductive exp :=
  EVar (v : var)
| EAbs (v : var) (vty : typ) (body : exp)
| EApp (fn arg : exp)
| ETrue | EFalse
| EIf (cond btrue bfalse : exp).

Definition is_value (e : exp) : bool :=
  match e with
  | EAbs _ _ _ => true
  | ETrue      => true
  | EFalse     => true
  | _          => false
  end.

Inductive value : exp -> Prop :=
  value_abs   : forall v vty body, value (EAbs v vty body)
| value_true  : value ETrue
| value_false : value EFalse.

Hint Constructors value.

Lemma value_is_value : forall e, value e <-> is_value e = true.
Proof with auto.
  split;
  induction e;
  simpl;
  intro H;
  inversion H;
  subst...
Qed.

Reserved Notation "'[' x ':=' e ']' e'" (at level 20).

Fixpoint subst (x : var) (e e' : exp) : exp :=
  match e' with
  | EVar x'      => if x =? x' then e else e'
  | EAbs x' t e1 => EAbs x' t (if x =? x' then e1 else [x:=e]e1)
  | EApp e1 e2   => EApp ([x:=e]e1) ([x:=e]e2)
  | EIf e1 e2 e3 => EIf ([x:=e]e1) ([x:=e]e2) ([x:=e]e3)
  | _            => e'
  end
where "'[' x ':=' e ']' e'" := (subst x e e').

Inductive substi (x : var) (e : exp) : exp -> exp -> Prop :=
  s_var1  : substi x e (EVar x) e
| s_var2  : forall x', x <> x' -> substi x e (EVar x') (EVar x')
| s_abs1  : forall t e1, substi x e (EAbs x t e1) (EAbs x t e1)
| s_abs2  : forall x', x <> x' -> forall e1 e1',
      substi x e e1 e1' -> forall t,
        substi x e (EAbs x' t e1) (EAbs x' t e1')
| s_app   : forall e1 e1', substi x e e1 e1' -> forall e2 e2',
      substi x e e2 e2' ->
      substi x e (EApp e1 e2) (EApp e1' e2')
| s_true  : substi x e ETrue  ETrue
| s_false : substi x e EFalse EFalse
| s_if    : forall e1 e1', substi x e e1 e1' -> forall e2 e2',
      substi x e e2 e2' -> forall e3 e3',
        substi x e e3 e3' ->
        substi x e (EIf e1 e2 e3) (EIf e1' e2' e3').

Hint Constructors substi.

Lemma substi_subst : forall x e e' e'', substi x e e' e'' <-> [x:=e]e' = e''.
Proof with auto.
  split.
  - intro H;
    induction H;
    subst;
    simpl;
    try rewrite Nat.eqb_refl;
    try (apply Nat.eqb_neq in H; rewrite H)...
  - generalize dependent e''.
    induction e';
    intros;
    unfold subst in H;
    subst; fold subst in *;
      try (destruct (Nat.eq_dec x v);
           [ subst; rewrite Nat.eqb_refl |
             replace (x =? v) with false in *; simpl in * ]; auto;
           symmetry; apply Nat.eqb_neq)...
Qed.

Fixpoint step (e : exp) : option exp :=
  match e with
  | EApp e1 e2 =>
    if is_value e1
    then if is_value e2
         then match e1 with
              | EAbs x t e1' => Some ([x:=e2]e1')
              | _            => None
              end
         else match step e2 with
              | Some e2' => Some (EApp e1 e2')
              | None     => None
              end
    else match step e1 with
         | Some e1' => Some (EApp e1' e2)
         | None     => None
         end
  | EIf e1 e2 e3 =>
    if is_value e1
    then match e1 with
         | ETrue  => Some e2
         | EFalse => Some e3
         | _      => None
         end
    else match step e1 with
         | Some e1' => Some (EIf e1' e2 e3)
         | None     => None
         end
  | _ => None
  end.

Lemma step_not_value : forall e e', step e = Some e' -> is_value e = false.
Proof with auto.
  destruct e; try (intros; inversion H)...
Qed.

Lemma value_not_step : forall e, is_value e = true -> step e = None.
Proof with auto.
  intros.
  destruct (step e) eqn:Hstep...
  apply step_not_value in Hstep.
  rewrite Hstep in H.
  inversion H.
Qed.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive stepR : exp -> exp -> Prop :=
  ST_AppAbs  : forall e2, value e2 -> forall x t e1,
      EApp (EAbs x t e1) e2 ==> [x:=e2]e1
| ST_App1    : forall e1 e1', e1 ==> e1' -> forall e2,
      EApp e1 e2 ==> EApp e1' e2
| ST_App2    : forall e1, value e1 -> forall e2 e2',
      e2 ==> e2' ->
      EApp e1 e2 ==> EApp e1 e2'
| ST_IfTrue  : forall e1 e2, EIf ETrue e1 e2 ==> e1
| ST_IfFalse : forall e1 e2, EIf EFalse e1 e2 ==> e2
| ST_If      : forall e1 e1', e1 ==> e1' -> forall e2 e3,
      EIf e1 e2 e3 ==> EIf e1' e2 e3
where "e1 '==>' e2" := (stepR e1 e2).

Hint Constructors stepR.

Lemma stepR_step : forall e1 e2, stepR e1 e2 <-> step e1 = Some e2.
Proof with simpl in *; eauto.
  split.
  - intro H.
    induction H;
    simpl;
    try (apply value_is_value in H; rewrite H);
    try erewrite step_not_value;
    try rewrite IHstepR...
  - generalize dependent e2.
    induction e1; intros; inversion H...
    + destruct (is_value e1_1) eqn:Hv1.
      * destruct (is_value e1_2) eqn:Hv2.
        ** destruct e1_1; inversion Hv1; inversion H; subst.
           constructor.
           apply value_is_value...
        ** destruct (step e1_2); inversion H.
           apply ST_App2...
           apply value_is_value...
      * destruct (step e1_1); inversion H...
    + destruct (is_value e1_1) eqn:Hv1.
      * destruct e1_1; inversion Hv1; inversion H...
      * destruct (step e1_1); inversion H...
Qed.

Fixpoint multistep_rec' n e : option exp :=
  match n with
  | 0    => None
  | S n' => match step e with
           | Some e' => multistep_rec' n' e'
           | None    => None
           end
  end.

Definition bigNumber : nat := 5000.

Definition multistep' : exp -> option exp :=
  multistep_rec' bigNumber.

Lemma multistep_rec'_None : forall n e, multistep_rec' n e = None.
Proof with auto.
  induction n...
  induction e; simpl...
  - destruct (is_value e1) eqn:Hv1.
    + destruct (is_value e2).
      * destruct e1; inversion Hv1...
      * destruct (step e2)...
    + destruct (step e1)...
  - destruct (is_value e1) eqn:Hv1.
    + destruct e1; inversion Hv1...
    + destruct (step e1)...
Qed.

Definition multistep'_None : forall e, multistep' e = None :=
  multistep_rec'_None bigNumber.

Fixpoint multistep_rec n e : option exp :=
  if is_value e then Some e
  else
    match n with
    | 0    => Some e
    | S n' => match step e with
             | None    => None
             | Some e' => multistep_rec n' e'
             end
    end.

Definition multistep : exp -> option exp :=
  multistep_rec bigNumber.

Inductive multi {A} (R : A -> A -> Prop) : A -> A -> Prop :=
  multi_refl : forall x, multi R x x
| multi_step : forall x y z,
    R x y ->
    multi R y z ->
    multi R x z.

Hint Constructors multi.

Definition multistepR : exp -> exp -> Prop := multi stepR.

Lemma multistepR_multistep_rec : forall e e', multistepR e e' <-> exists n, multistep_rec n e = Some e'.
Proof with simpl in *; auto.
  split.
  - intros.
    induction H...
    + exists 0.
      simpl.
      destruct (is_value x)...
    + destruct IHmulti.
      exists (S x0).
      simpl.
      replace (is_value x) with false;
      apply stepR_step in H;
      [ | apply step_not_value in H];
      rewrite H...
  - intros [n H].
    generalize dependent e.
    generalize dependent e'.
    induction n; intros.
    + inversion H.
      destruct (is_value e); inversion H1; constructor.
    + inversion H; subst.
      destruct (is_value e); inversion H1; subst; try constructor...
      destruct (step e) eqn:Hstep; inversion H1.
      apply stepR_step in Hstep.
      apply multi_step with e0...
      apply IHn.
      destruct (is_value e); inversion H; subst...
Qed.

Lemma multistep_multistepR : forall e e', multistep e = Some e' -> multistepR e e'.
Proof with eauto.
  intros.
  apply multistepR_multistep_rec...
Qed.


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

Require Import Arith ZArith Lia List.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list gcd prime php utils_nat.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.H10.Dio
  Require Import dio_logic dio_single.

From Undecidability.H10.ArithLibs
  Require Import Zp lagrange.

Set Implicit Arguments.

Section diophantine_polynomial.

  Variable (V P : Set).

  Inductive dio_polynomial : Set :=
    | dp_cnst : Z -> dio_polynomial                  (* integer constant *)
    | dp_var : V   -> dio_polynomial                  (* existentially quantified variable *)
    | dp_par : P   -> dio_polynomial                  (* parameter *)
    | dp_comp : dio_op -> dio_polynomial -> dio_polynomial -> dio_polynomial.

  Notation dp_add := (dp_comp do_add).
  Notation dp_mul := (dp_comp do_mul).

  Fixpoint dp_var_list p :=
    match p with
      | dp_cnst _      => nil
      | dp_var v      => v::nil
      | dp_par _      => nil
      | dp_comp _ p q => dp_var_list p ++ dp_var_list q
    end.

  Fixpoint dp_par_list p :=
    match p with
      | dp_cnst _      => nil
      | dp_var _      => nil
      | dp_par x      => x::nil
      | dp_comp _ p q => dp_par_list p ++ dp_par_list q
    end.

  (* ρ σ ν φ *)

  Fixpoint dp_eval φ ν p :=
    match p with
      | dp_cnst n => n
      | dp_var v => φ v
      | dp_par i => ν i
      | dp_comp do_add p q => dp_eval φ ν p + dp_eval φ ν q
      | dp_comp do_mul p q => dp_eval φ ν p * dp_eval φ ν q
    end % Z.

  Fact dp_eval_ext φ ν φ' ν' p :
        (forall v, In v (dp_var_list p) -> φ v = φ' v)
     -> (forall i, In i (dp_par_list p) -> ν i = ν' i)
     -> dp_eval φ ν p = dp_eval φ' ν' p.
  Proof.
    induction p as [ | | | [] p Hp q Hq ]; simpl; intros H1 H2; f_equal; auto;
      ((apply Hp || apply Hq); intros; [ apply H1 | apply H2 ]; apply in_or_app; auto).
  Qed.

  Fact dp_eval_fix_add φ ν p q : dp_eval φ ν (dp_add p q) = (dp_eval φ ν p + dp_eval φ ν q) % Z.
  Proof. trivial. Qed.

  Fact dp_eval_fix_mul φ ν p q : dp_eval φ ν (dp_mul p q) = (dp_eval φ ν p * dp_eval φ ν q) % Z.
  Proof. trivial. Qed.

  Fixpoint dp_size p :=
    match p with
      | dp_cnst n => 1
      | dp_var v => 1
      | dp_par i => 1
      | dp_comp _ p q => 1 + dp_size p + dp_size q
    end.

  Fact dp_size_fix_comp o p q : dp_size (dp_comp o p q) = 1 + dp_size p + dp_size q.
  Proof. auto. Qed.

  Definition dio_single := (dio_polynomial * dio_polynomial)%type.
  Definition dio_single_size (e : dio_single) := dp_size (fst e) + dp_size (snd e).

  Definition dio_single_pred e ν := exists φ, dp_eval φ ν (fst e) = dp_eval φ ν (snd e).

End diophantine_polynomial.

Arguments dp_cnst {V P}.
Arguments dp_var {V P}.
Arguments dp_par {V P}.
Arguments dp_comp {V P}.

Notation dp_add := (dp_comp do_add).
Notation dp_mul := (dp_comp do_mul).

Definition H10Z_PROBLEM := { n : nat & dio_polynomial (pos n) (pos 0) }.

(* The original H10 over relative intergers is P(x1,..,xn) = 0 *)

Definition H10Z : H10Z_PROBLEM -> Prop.
Proof.
  intros (n & p).
  exact (exists Φ, dp_eval Φ (fun _ => 0%Z) p = 0%Z).
Defined.


Require Import Brzozowski.Alphabet.
Require Import Brzozowski.Regex.

Fixpoint compare_regex (p q: regex) : comparison :=
  match p with
  | emptyset => match q with
    | emptyset => Eq
    | _ => Lt
    end
  | emptystr => match q with
    | emptyset => Gt
    | emptystr => Eq
    | _ => Lt
    end
  | symbol x => match q with
    | emptyset => Gt
    | emptystr => Gt
    | symbol y => compare_alphabet x y
    | _ => Lt
    end
  | or p1 p2 => match q with
    | emptyset => Gt
    | emptystr => Gt
    | symbol _ => Gt
    | or q1 q2 =>
      match compare_regex p1 q1 with
      | Lt => Lt
      | Eq => compare_regex p2 q2
      | Gt => Gt
      end
    | _ => Lt
    end
  | neg p1 => match q with
    | emptyset => Gt
    | emptystr => Gt
    | symbol _ => Gt
    | or _ _ => Gt
    | neg q1 => compare_regex p1 q1
    | _ => Lt
    end
  | concat p1 p2 => match q with
    | emptyset => Gt
    | emptystr => Gt
    | symbol _ => Gt
    | or _ _ => Gt
    | neg _ => Gt
    | concat q1 q2 =>
      match compare_regex p1 q1 with
      | Lt => Lt
      | Eq => compare_regex p2 q2
      | Gt => Gt
      end
    | _ => Lt
    end
  | star p1 => match q with
    | star q1 => compare_regex p1 q1
    | _ => Gt
    end
  end.