From NaturalNumbers Require Export Base Tutorial Addition.

Require Import Ring_theory.
Require Export Ring.

Module SemiRingFaking.
    (* Some stuff to fake the `simpl` tactic to only affect
    our own version of addition by defining some sort of fake
    multiplication and a bunch of axioms to make the semi-ring
    structure hold *)

    Axiom _fake_mul : mynat -> mynat -> mynat.
    Axiom _fake_one : mynat.

    Axiom _fake_one_mul : forall a : mynat, _fake_mul _fake_one a = a.
    Axiom _fake_zero_mul : forall a : mynat, _fake_mul 0 a = 0.
    Axiom _fake_mul_comm : forall (a b: mynat), _fake_mul a b = _fake_mul b a.
    Axiom _fake_mul_assoc : forall (a b c: mynat), _fake_mul a (_fake_mul b c) = _fake_mul (_fake_mul a b) c.
    Axiom _fake_distr_mul : forall (a b c : mynat), _fake_mul (a + b) c = (_fake_mul a c) + (_fake_mul b c).

    Lemma assoc_add (a b c : mynat) : a + (b + c) = (a + b) + c.
    Proof.
        rewrite add_assoc; easy.
    Qed.

    Definition mynat_semi_ring :=
        mk_srt 0 _fake_one add _fake_mul (@eq _)
        zero_add add_comm assoc_add _fake_one_mul _fake_zero_mul _fake_mul_comm
        _fake_mul_assoc _fake_distr_mul.

End SemiRingFaking.

Add Ring _fake_mynat_ring : SemiRingFaking.mynat_semi_ring.

Lemma test (a b c d e : mynat) : (((a+b)+c)+d)+e=(c+((b+e)+a))+d.
Proof.
    ring.
Qed.

Fixpoint mul (n m : mynat) : mynat :=
    match m with
    | O => O
    | S p => (mul n p) + n
    end.

Infix "*" := mul.
Notation "(*)" := mul (only parsing).
Notation "( f *)" := (mul f) (only parsing).
Notation "(* f )" := (fun g => mul g f) (only parsing).

Fact mul_zero (a : mynat) : a * 0 = 0.
Proof.
    trivial.
Qed.

Fact mul_succ (a b : mynat) : a * S b = a * b + a.
Proof.
    trivial.
Qed.

(* Level 0 data *)
(* name `zero_mul` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 0 prologue *)
(*
I have just defined multiplication for you. It is defined to satisfy the following
two statements:

`Fact mul_zero (a : mynat) : a * 0 = 0.`

`Fact mul_succ (a b : mynat) : a * S b = a * b + a.`

Basically, we have defined multiplication inductively on the second variable.

You can still use all your theorems from Addition World, even from levels you have
not completed yet! I do recommend you complete all of them before you continue,
just so you are familiar with them.

Anyway, just like for addition in the previous world, we know next to nothing
about multiplication so let's start proving some lemmas! Remember that the
`induction` tactic will come in very useful, like in the previous world.
*)
Lemma zero_mul (m : mynat) : 0 * m = 0.
Proof.
    induction m as [| ? H].
    - rewrite mul_zero; easy.
    - rewrite mul_succ. easy.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 1 data *)
(* name `mul_one` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 1 prologue *)
(*
Recall that you can find all the theorems we have shown before in the side
menu on the left. In this level in particular, we will need to use
```
#Fact one_eq_succ_zero : 1 = S 0.
```
Let's prove that `1` is actually the neutral element for multiplication
(at least on the right, since we don't know that multiplication is commutative yet)!
*)
Lemma mul_one (m : mynat) : m * 1 = m.
Proof.
    rewrite one_eq_succ_zero, mul_succ.
    rewrite mul_zero, zero_add.
    reflexivity.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 2 *)
(* Level 2 data *)
(* name `one_mul` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 2 prologue *)
(*
Let's show that `1` is also a unit on the left. the following theorems
may be useful:

`Fact one_eq_succ_zero : 1 = S 0.`

`Fact succ_eq_add_one a : S a = a + 1`

*)
Lemma one_mul (m : mynat) : 1 * m = m.
Proof.
    induction m as [| ? H].
    - trivial.
    - rewrite mul_succ.
      now rewrite H.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 3 *)
(* Level 3 data *)
(* name `mul_add` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 3 prologue *)
(*
The goal for this world is to show `mul_comm` and `mul_assoc`,
i.e. that multiplication is commutative (`a * b = b * a`) and associative
(`(a * b) * c = a * (b * c)`). However, we also want to show
how multiplication interacts with addition. In this level
we show that multiplication is left distributive. Note that
the name of the lemma (`mul_add`) refers to the order in which
the operations are written here, and is not `mul_left_distrib`
or something like that, which would be much harder to remember!
*)
Lemma mul_add (t a b : mynat) : t * (a + b) = t * a + t * b.
Proof.
    induction b as [| ? H].
    - easy.
    - rewrite add_succ.
      repeat rewrite mul_succ.
      rewrite H.
      ring.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 4 *)
(* Level 4 data *)
(* name `mul_assoc` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 4 prologue *)
(*
Alright, time to show that multiplication is associative!

By the way, did you know you could add the tactic `now` before
any tactic you type, and it will check if it can be easily
shown (for example by `reflexivity`) after performing the
tactic you write after it. So for example, you could write
```
now rewrite mul_add.
```
to perform a `rewrite mul_add`, and then check if the proof
can easily be finished. You can think of this as if it was
the same as
```
rewrite mul_add.
reflexivity.
```
for now. Try it out!
*)
Lemma mul_assoc (a b c : mynat) : (a * b) * c = a * (b * c).
Proof.
    induction c as [| ? H].
    - repeat rewrite mul_zero; easy.
    - repeat rewrite mul_succ.
      rewrite H.
      now rewrite mul_add.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 5 *)
(* Level 5 data *)
(* name `succ_mul` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 5 prologue *)
(*
The `ring` tactic is powerful, but not almighty. For example,
it does not know that it can rewrite expressions inside of
the successor function `S`, so if we have a goal of the form
```S (a + b) = S (b + a)```
our `ring` tactic won't solve it. Thankfully, we know that
`succ_eq_add_one`, which we can use to turn this goal into
```a + b + 1 = b + a + 1```
which our `ring` tactic can solve!
*)
Lemma succ_mul (a b : mynat) : (S a) * b = a * b + b.
Proof.
    induction b as [| ? H].
    - repeat rewrite mul_zero; easy.
    - repeat rewrite mul_succ.
      rewrite H.
      repeat rewrite add_succ.
      repeat rewrite succ_eq_add_one.
      ring.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 6 *)
(* Level 6 data *)
(* name `add_mul` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 6 prologue *)
(*
We already have `mul_add`, but we have not shown how multiplication
interacts on the right with addition. If you end up with a goal
that only contains addition, with some messy parentheses or different
orders of terms, try not to mess with `rewrite add_comm` and friends,
but use the powerful `ring` tactic instead!
*)
Lemma add_mul (a b t : mynat) : (a + b) * t = a * t + b * t.
Proof.
    induction t as [| ? H].
    - now repeat rewrite mul_zero.
    - repeat rewrite mul_succ.
      rewrite H.
      ring.
Qed.
(* Level epilogue *)
(* Level end *)

(* Level 7 *)
(* Level 7 data *)
(* name `mul_comm` (boss level!) *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 7 prologue *)
(*
The boss level for this world! You should be well prepared,
if you've done all the levels so far.
*)
Lemma mul_comm (a b : mynat) : a * b = b * a.
Proof.
    induction b as [| ? H].
    - now rewrite mul_zero, zero_mul.
    - rewrite mul_succ, succ_mul.
      now rewrite H.
Qed.
(* Level epilogue *)
(*
Now we know that `mynat` is a commutative semiring! Just one
more level and we will be able to beef up our `ring` tactic!
*)
(* Level end *)

(* Level 8 *)
(* Level 8 data *)
(* name `mul_left_assoc` *)
(* tactics ring *)
(* theorems mul_succ *)
(* Level 8 prologue *)
(*
Equipped with

`Lemma mul_assoc (a b c : mynat) : (a * b) * c = a * (b * c).`

`Lemma mul_comm (a b : mynat) : a * b = b * a.`

this level should be a piece of cake!
*)
Lemma mul_left_assoc (a b c : mynat) : a * (b * c) = (a * b) * c.
Proof.
    rewrite <- mul_assoc.
    reflexivity.
Qed.
(* Level epilogue *)
(*
And now, after I invert `add_assoc` into
```
#Lemma add_left_assoc (a b c : mynat) : a + (b + c) = (a + b) + c.
```
I can type
```
#Definition mynat_semi_ring : semi_ring_theory 0 1 add mul (@eq _).
#Proof.
#    constructor.
#    - exact zero_add.
#    - exact add_comm.
#    - exact add_left_assoc.
#    - exact one_mul.
#    - exact zero_mul.
#    - exact mul_comm.
#    - exact mul_left_assoc.
#    - exact add_mul.
#Qed.
#
#Add Ring mynat_ring : mynat_semi_ring.
```
and our `ring` tactic will now also solve basic
equations involving multiplications for us!

If you click "Next Level", you will be sent to Power World.
This world is optional, but can be seen as kind of a "Boss World",
involving the theorems we have shown in Addition and Multiplication World.

If you want to skip this world though, you can go back to the main menu to
go to Function World instead!
*)
(* Level end *)

Lemma add_left_assoc (a b c : mynat) : a + (b + c) = (a + b) + c.
Proof.
    rewrite <- add_assoc.
    reflexivity.
Qed.

Definition mynat_semi_ring : semi_ring_theory 0 1 add mul (@eq _).
Proof.
    constructor.
    - exact zero_add.
    - exact add_comm.
    - exact add_left_assoc.
    - exact one_mul.
    - exact zero_mul.
    - exact mul_comm.
    - exact mul_left_assoc.
    - exact add_mul.
Qed.

Add Ring mynat_ring : mynat_semi_ring.


Require Import List Omega.

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

(* Extract Inductive nat => "Prelude.Int" ["0" "\x -> x + 1"] *)
(*                             "\zero succ n -> *)
(*                               if n == 0 then zero () else succ (n-1)". *)

Extract Inductive nat => "int"
  [ "0" "(fun x -> x + 1)" ]
  "(fun zero succ n ->
    if n=0 then zero () else succ (n-1))".

Inductive bintree : Type :=
| leaf : bintree
| branch : nat -> bintree -> bintree -> bintree.

Fixpoint lookup (n:nat) (t:bintree) : Prop :=
  match t with
  | leaf => False
  | branch n' l r =>
    if eq_nat_dec n n'
    then True
    else if le_lt_dec n n'
    then lookup n l
    else lookup n r
  end.

Fixpoint insert (x : nat) (t:bintree) : bintree :=
  match t with
  | leaf => branch x leaf leaf
  | branch y l r =>
    if le_dec x y
    then branch y (insert x l) r
    else branch y l (insert x r)
  end.

Fixpoint list2bin (l : list nat) : bintree :=
  match l with
  | [] => leaf
  | x :: xs => insert x (list2bin xs)
  end.

Fixpoint inorder (t : bintree) : list nat :=
  match t with
  | leaf => []
  | branch x l r => inorder l ++ (x :: inorder r)
  end.

Definition binsort (l : list nat) : list nat :=
  inorder (list2bin l).

Extraction "binsort_core.ml" binsort.

Example lookup_1 : lookup 1 (branch 1 leaf leaf).
Proof. reflexivity. Qed.

Example lookup_2 : lookup 2 (branch 1 leaf (branch 2 leaf leaf)).
Proof. simpl. reflexivity. Qed.

Example lookup_3 : lookup 3 (branch 4 (branch 3 leaf leaf) (branch 5 leaf leaf)).
Proof. reflexivity. Qed.

Example lookup_4 : ~ (lookup 4 (branch 1 leaf (branch 2 leaf leaf))).
Proof. unfold not. simpl. intros. assumption. Qed.

Lemma lookup_left : forall l r x n, lookup x (branch n l r) -> x < n -> lookup x l.
Proof.
  intros. unfold lookup in H.
  destruct (Nat.eq_dec x n); [omega | ].
  destruct (le_lt_dec x n); [assumption | ].
  unfold not in n0. contradiction n0. omega.
Qed.

Lemma lookup_right : forall l r x n, lookup x (branch n l r) -> n < x -> lookup x r.
Proof.
  intros. unfold lookup in H.
  destruct (Nat.eq_dec x n); [omega | ].
  destruct (le_lt_dec x n); [| assumption].
  unfold not in n0. contradiction n0. omega.
Qed.

Inductive valid : forall (t : bintree), Prop :=
| val_leaf : valid leaf
| val_cons : forall (l r : bintree) n,
    valid l -> valid r ->
    (forall x, lookup x l -> x <= n) ->
    (forall x, lookup x r -> x > n) ->
    valid (branch n l r).

Example valid_1 : valid (leaf).
Proof. apply val_leaf. Qed.

Lemma valid_end : forall x, valid (branch x leaf leaf).
Proof.
  induction x.
  - apply (val_cons _ _ 0 val_leaf val_leaf); intros; contradiction H.
  - apply (val_cons _ _ (S x) val_leaf val_leaf); intros; contradiction H.
Qed.

Lemma lookup_insert : forall t x y, valid t -> lookup x t -> lookup x (insert y t).
Proof.
  intros. generalize dependent x. generalize dependent y.
  induction H; intros; [inversion H0 | ].
  intros. simpl in *. destruct (Nat.eq_dec x n).
  destruct (le_dec y n).
  - simpl. rewrite e. destruct (Nat.eq_dec n n); [assumption | ].
    destruct (le_lt_dec n n); omega.
  - simpl. destruct (Nat.eq_dec x n); [assumption | ].
    rewrite e. destruct (le_lt_dec n n); omega.
  - unfold not in n0. destruct (le_dec y n); simpl;
    (destruct (Nat.eq_dec x n); [apply I | ]).
    + destruct (le_lt_dec x n); [| assumption].
      apply (IHvalid1 _ _ H3).
    + destruct (le_lt_dec x n); [assumption |].
      apply (IHvalid2 _ _ H3).
Qed.

Lemma lookup_branch_x : forall l r x, lookup x (branch x l r).
Proof.
  induction l.
  - intros. simpl. destruct (Nat.eq_dec x x); [apply I |].
    destruct (le_lt_dec x x); omega.
  - intros. simpl. destruct (Nat.eq_dec x x); [apply I |].
    destruct (le_lt_dec x x); omega.
Qed.

Lemma insert_lookup_x : forall t x, valid t -> lookup x (insert x t).
Proof.
  intros. generalize dependent x. assert (H' : valid t). assumption.
  induction H; intros; simpl.
  - destruct (Nat.eq_dec x x); [apply I |].
    destruct (le_lt_dec x x); omega.
  - destruct (le_dec x n).
    + pose proof (IHvalid1 H n). destruct (insert n l); [inversion H3 |].
      simpl in *. destruct (Nat.eq_dec x n); [apply I |].
      destruct (le_lt_dec x n); [| omega].
      apply (IHvalid1 H x).
    + pose proof (IHvalid2 H0 n). destruct (insert n r); [inversion H3 |].
      simpl in *. destruct (Nat.eq_dec x n); [apply I |] .
      destruct (le_lt_dec x n); [omega |].
      apply (IHvalid2 H0 x).
Qed.

Lemma lookup_branch : forall l r x n, valid (branch n l r) ->
                                lookup x (branch n l r) ->
                                x = n \/ lookup x l \/ lookup x r.
Proof.
  intros. inversion H. unfold lookup in H0.
  destruct (Nat.eq_dec x n); [(left; assumption) |].
  destruct (le_lt_dec x n); right; [left | right]; assumption.
Qed.

Lemma insert_lookup : forall t x y,
    valid t -> x <> y -> lookup x (insert y t) -> lookup x t.
Proof.
  intros. generalize dependent x. generalize dependent y.
  induction H; intros; simpl in *.
  - destruct (Nat.eq_dec x y); [omega |].
    destruct (le_lt_dec x y); omega.
  - destruct (Nat.eq_dec x y); [omega |]; simpl.
    destruct (Nat.eq_dec x n); [apply I |].
    destruct (le_lt_dec x n).
    + destruct (le_dec y n); simpl in H4.
      * destruct (Nat.eq_dec x n); [omega | ].
        {destruct (le_lt_dec x n); [ | omega ].
          - apply IHvalid1 with (y := y); assumption.
        }
      * destruct (Nat.eq_dec x n); [omega | ].
        destruct (le_lt_dec x n); [| omega]; assumption.
    + destruct (le_dec y n); simpl in H4.
      * destruct (Nat.eq_dec x n); [omega | ].
        destruct (le_lt_dec x n); [ omega | assumption ].
      * destruct (Nat.eq_dec x n); [omega | ].
        destruct (le_lt_dec x n); [ omega | ].
        apply IHvalid2 with (y := y). assumption. assumption.
Qed.

Lemma lookup_cases : forall t x y, valid t ->
                              lookup x (insert y t) -> x = y \/ lookup x t.
Proof.
  intros. destruct (Nat.eq_dec x y); [(left ; assumption) |].
  right. induction t.
  - simpl in *. destruct (Nat.eq_dec x y); [omega | ].
    destruct (le_lt_dec x y); assumption.
  - simpl. destruct (Nat.eq_dec x n0); [apply I | ].
    destruct (le_lt_dec x n0).
    + simpl in H0. destruct (le_dec y n0).
      * simpl in H0. destruct (Nat.eq_dec x n0); [omega |].
        destruct (le_lt_dec x n0); [ | omega].
        simpl in H. destruct (le_dec y n0); [ | omega].
        inversion H. apply (IHt1 H4 H0).
      * simpl in H0. destruct (Nat.eq_dec x n0); [omega |].
        destruct (le_lt_dec x n0); [ | omega].
        simpl in H. destruct (le_dec y n0); [ omega | assumption ].
    + simpl in H0. destruct (le_dec y n0).
      * simpl in H0. destruct (Nat.eq_dec x n0); [omega |].
        destruct (le_lt_dec x n0); [ omega | ].
        simpl in H. destruct (le_dec y n0); [ assumption | omega].
      * simpl in H0. destruct (Nat.eq_dec x n0); [omega |].
        destruct (le_lt_dec x n0); [ omega | ].
        simpl in H. destruct (le_dec y n0); [ omega | ].
        inversion H. apply (IHt2 H5 H0).
Qed.

Lemma insert_preserves : forall t x, valid t -> valid (insert x t).
Proof.
intros. induction H.
- simpl. constructor 2; (intros; try constructor; inversion H).
- simpl. destruct (le_dec x n).
  + apply val_cons; intros; [ assumption | assumption | | (apply H2; assumption)].
    destruct (lookup_cases _ _ _ H H3); [omega | ].
    apply (H1 _ H4).
  + constructor 2; intros; [assumption | assumption | (apply H1; assumption) |].
      intros. destruct (lookup_cases _ _ _ H0 H3); [omega | ].
      apply H2. assumption.
Qed.

Lemma in_app_iff : forall A l l' (a:A),
  In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros. split.
  - generalize dependent l'. induction l.
    + simpl. intros. right. assumption.
    + simpl. intros. destruct H; [(left; left; assumption) | ].
      rewrite or_assoc. right. apply (IHl _ H).
  - intros. generalize dependent l'. induction l.
    + simpl. intros. destruct H; [contradiction H | assumption].
    + simpl. intros. rewrite or_assoc in H.
      destruct H; [(left; assumption) |].
      right. apply (IHl _ H).
Qed.

Inductive ordered : list nat -> Prop :=
| o_nil : ordered []
| o_singleton x : ordered [x]
| o_step x y xs : x <= y -> ordered (y :: xs) -> ordered (x :: y :: xs).

Lemma ordered_app (xs ys : list nat)
  (Hxs : ordered xs) (Hys : ordered ys)
  (H : match (rev xs), ys with
       | x::_, y::_ => x <= y
       | _, _ => True
       end) :
  ordered (xs ++ ys).
Proof.
  induction Hxs; simpl in *; [assumption | |].
  - destruct ys; [apply o_singleton |].
    + apply (o_step x n ys H Hys).
  - apply (o_step x y (xs ++ ys) H0).
    + apply IHHxs. destruct (rev xs); simpl in *; apply H.
Qed.

Lemma lookup_in_inorder : forall t x, lookup x t -> In x (inorder t).
Proof.
  induction t; intros; simpl in *; [assumption | ].
  rewrite in_app_iff. destruct (Nat.eq_dec x n).
  - right. rewrite e. apply in_eq.
  - destruct (le_lt_dec x n).
    + left. apply IHt1. assumption.
    + right. apply in_cons. apply IHt2. assumption.
Qed.

Lemma order_cons (x:nat) (l:list nat )
  (H1: ordered l)
  (H2 : match l with
  | [] => True
  | y :: _ => x <= y
  end) : ordered (x :: l).
Proof.
  generalize dependent H2. induction H1; intros.
  - apply o_singleton.
  - apply o_step. assumption. apply o_singleton.
  - apply o_step. assumption. apply o_step. assumption. assumption.
Qed.

Lemma lookup_tree : forall t n, {lookup n t} + {~(lookup n t)}.
Proof.
  induction t; intros; simpl in *.
  - right. unfold not. intros. assumption.
  - destruct (Nat.eq_dec n0 n); [(left; apply I) |].
    destruct (le_lt_dec n0 n); [apply IHt1 | apply IHt2 ].
Qed.

Lemma cons_ordered : forall l x, ordered (x :: l) -> ordered l.
Proof.
  induction l.
  - intros. apply o_nil.
  - intros. inversion H. assumption.
Qed.

Lemma app_ordered_left : forall l1 l2, ordered (l1 ++ l2) -> ordered l1.
Proof.
  induction l1; intros; [apply o_nil |].
  simpl in *. apply order_cons.
  - apply (IHl1 l2). inversion H; [apply o_nil | assumption].
  - destruct l1; [apply I |].
    inversion H. assumption.
Qed.

Lemma app_sing : forall X (l1 l2 : list X) x,
   l1 ++ (x :: l2) = (l1 ++ [x]) ++ l2.
Proof.
  intros. replace (x :: l2) with ([x] ++ l2); [| reflexivity].
  rewrite app_assoc. reflexivity.
Qed.

Lemma app_ordered_right: forall l2 l1, ordered (l1 ++ l2) -> ordered l2.
Proof.
  induction l1; intros; [assumption |].
  simpl in H. pose proof (cons_ordered _ _ H). apply (IHl1 H0).
Qed.

Lemma in_inorder_lookup : forall t x, valid t ->
                                 In x (inorder t) -> lookup x t.
Proof.
  induction t; intros; simpl in *; [assumption |].
  simpl. destruct (Nat.eq_dec x n), (le_lt_dec x n); [apply I | apply I | |].
  - simpl in *. rewrite app_sing in H0.
    rewrite in_app_iff in H0. inversion H.
    apply (IHt1 _ H4).
    + destruct H0.
      * rewrite in_app_iff in H0. destruct H0; [assumption | ].
        inversion H0; [| inversion H8].
        unfold not in n0. exfalso. symmetry in H8.
        apply (n0 H8).
      * pose proof (IHt2 _ H5 H0). pose proof (H7 _ H8). omega.
  - simpl in *. inversion H. rewrite in_app_iff in H0.
    apply (IHt2 _ H5). destruct H0.
    + pose proof (IHt1 _ H4 H0). pose proof (H6 _ H8). omega.
    + inversion H0; [| assumption].
      unfold not in n0. symmetry in H8. contradiction (n0 H8).
Qed.

Lemma gt_leb : forall a b, a > b -> b <= a.
Proof.
  - intros. omega.
Qed.

Lemma inorder_valid_sorted (t : bintree) (H : valid t) : ordered (inorder t).
Proof.
  induction H; simpl; [apply o_nil |].
  apply (ordered_app _ _ IHvalid1).
  - apply (order_cons n (inorder r) IHvalid2).
    destruct (inorder r) eqn:Hr; simpl; [apply I | ].
    simpl in *. apply gt_leb. apply H2.
    apply in_inorder_lookup; [assumption |].
    rewrite Hr. constructor. reflexivity.
  - destruct (rev (inorder l)) eqn:Hr; [apply I | ].
    apply H1. apply in_inorder_lookup; [assumption |].
    assert (In n0 (n0 :: l0)); [constructor; reflexivity |].
    rewrite <- Hr in H3. rewrite <- in_rev in H3. assumption.
Qed.

Theorem list2bin_valid : forall (l : list nat), valid (list2bin l).
Proof.
  intros. induction l; [constructor |].
  simpl. apply insert_preserves. assumption.
Qed.

Theorem ordered_binsort (l : list nat) : ordered (binsort l).
Proof.
  unfold binsort. induction l; simpl; [constructor |].
  simpl. apply inorder_valid_sorted. apply insert_preserves.
  apply list2bin_valid.
Qed.

Lemma app_nil_nil : forall X (l1 l2 : list X), l1 ++ l2 = [] -> l1 = [] /\ l2 = [].
Proof.
  induction l1; intros; simpl in H; [| inversion H].
  split; [reflexivity | assumption].
Qed.

Lemma inorder_insert_nil_false : forall t x, inorder (insert x t) = [] -> False.
Proof.
  induction t; intros; [inversion H | ].
  simpl in H. destruct (le_dec x n).
  - inversion H. destruct (app_nil_nil _ _ _ H1); inversion H2.
  - simpl in H. destruct (app_nil_nil _ _ _ H). inversion H1.
Qed.

Lemma insert_leaf_false : forall t x, insert x t = leaf -> False.
Proof.
  induction t; intros; [inversion H | ].
  intros. simpl in H. destruct (le_dec x n); inversion H.
Qed.

Lemma binsort_perm_lr x (xs : list nat) : In x xs -> In x (binsort xs).
  generalize dependent x. induction xs; intros; [inversion H |].
  inversion H.
  - pose proof (list2bin_valid xs). rewrite H0.
    unfold binsort. simpl. apply lookup_in_inorder.
    apply insert_lookup_x. assumption.
  - unfold binsort in *. pose proof (list2bin_valid xs).
    apply lookup_in_inorder. simpl.
    apply (lookup_insert _ _ _ H1).
    apply (in_inorder_lookup _ _ H1).
    apply (IHxs _ H0).
Qed.

Lemma binsort_perm_rl x (xs : list nat) : In x (binsort xs) -> In x xs.
  generalize dependent x. unfold binsort in *. induction xs; intros; [inversion H |].
  simpl in H. destruct (Nat.eq_dec x a).
  - constructor 1. symmetry. assumption.
  - constructor 2. pose proof (list2bin_valid xs).
    apply IHxs. apply lookup_in_inorder.
    apply (insert_lookup _ _ _ H0 n).
    apply in_inorder_lookup; [| assumption].
    apply (insert_preserves _ _ H0).
Qed.

Theorem binsort_perm x (xs : list nat) : In x xs <-> In x (binsort xs).
Proof.
  split; [apply binsort_perm_lr | apply binsort_perm_rl].
Qed.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From LF Require Export IndProp.

Module ProofObjects.
Import IndProp.

Print IndProp.ev.

Theorem ev_4 : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

Print ev_4.

Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

Definition ev_4''' : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

Theorem ev_8 : ev 8.
Proof.
  apply ev_SS.
  apply ev_SS.
  apply ev_4.
Qed.

Definition ev_8' : ev 8 :=
  ev_SS 6 (ev_SS 4 ev_4).

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

Definition ev_plus4'' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS _ (ev_SS _ H).

Definition add1 : nat -> nat.
  intros n.
  Show Proof.
  apply S.
  Show Proof.
  apply n. Defined.

Print add1.

Module Props.

  Module And.
    Inductive and (P Q : Prop) : Prop :=
      | conj : P -> Q -> and P Q.
    Arguments conj [P] [Q].
    Notation "P /\ Q" := (and P Q) : type_scope.

    Print prod.

    Theorem proj1' : forall P Q,
      P /\ Q -> P.
    Proof.
      intros P Q HPQ. destruct HPQ as [HP HQ]. apply HP.
      Show Proof.
    Qed.

    Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P.
    Proof.
      intros P Q. split.
      - intros [HP HQ]. split.
        + apply HQ.
        + apply HP.
      - intros [HQ HP]. split.
        + apply HP.
        + apply HQ.
    Qed.

    Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
      fun p => fun q => fun r => fun pq => fun qr =>
        match pq with
        | conj p' q' =>
          match qr with
          | conj q'' r' => conj p' r'
          end
        end.
  End And.

  Module Or.
    Inductive or (P Q : Prop) : Prop :=
      | or_introl : P -> or P Q
      | or_intror : Q -> or P Q.
    Arguments or_introl [P] [Q].
    Arguments or_intror [P] [Q].
    Notation "P \/ Q" := (or P Q) : type_scope.

    Definition inj_l : forall (P Q : Prop), P -> P \/ Q :=
      fun P Q HP => or_introl HP.

    Theorem inj_l' : forall (P Q : Prop), P -> P \/ Q.
    Proof.
      intros P Q HP. left. apply HP.
    Qed.

    Definition or_elim : forall (P Q R : Prop), (P \/ Q) -> (P -> R) -> (Q -> R) -> R :=
      fun P Q R HPQ HPR HQR =>
        match HPQ with
        | or_introl HP => HPR HP
        | or_intror HQ => HQR HQ
        end.

    Theorem or_elim' : forall (P Q R : Prop), (P \/ Q) -> (P -> R) -> (Q -> R) -> R.
    Proof.
      intros P Q R HPQ HPR HQR.
      destruct HPQ as [HP | HQ].
      - apply HPR. apply HP.
      - apply HQR. apply HQ.
    Qed.

    Definition or_commut' : forall P Q, P \/ Q -> Q \/ P :=
      fun P Q PQ =>
        match PQ with
        | or_introl HP => or_intror HP
        | or_intror HQ => or_introl HQ
        end.
  End Or.

  Module Ex.
    Inductive ex {A : Type} (P : A -> Prop) : Prop :=
      | ex_intro : forall (x : A), P x -> ex P.

    Print ex_intro.

    Notation "'exists' x , p" :=
      (ex (fun x => p))
        (at level 200, right associativity) : type_scope.

    Check ex (fun n => ev n) : Prop.

    Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
      ex_intro _ 1 (ev_SS _ ev_0).
  End Ex.

  Module TrueFalse.
    Inductive True : Prop :=
      | I : True.

    Definition p_implies_true : forall P, P -> True :=
      fun P HP => I.

    Inductive False : Prop := .

    Definition ex_falso_quodlibet' : forall P, False -> P :=
      fun P F => match F with end.
  End TrueFalse.
End Props.

Module MyEquality.
  Inductive eq {X:Type} : X -> X -> Prop :=
    | eq_refl : forall x, eq x x.
  Notation "x == y" := (eq x y)
                         (at level 70, no associativity)
                       : type_scope.

  Lemma four: 2 + 2 == 1 + 3.
  Proof.
    apply eq_refl.
  Qed.

  Definition four' : 2 + 2 == 1 + 3 :=
    eq_refl 4.

  Definition singleton : forall (X:Type) (x:X), [] ++ [x] == x :: []  :=
    fun (X:Type) (x:X) => eq_refl [x].

  Lemma equality__leibniz_equality : forall (X : Type) (x y: X),
    x == y -> forall (P: X -> Prop), P x -> P y.
  Proof.
    intros.
    destruct H.
    apply H0.
  Qed.

  Lemma leibniz_equality__equality : forall (X : Type) (x y: X),
    (forall (P : X -> Prop), P x -> P y) -> x == y.
  Proof.
    intros.
    destruct (H (fun i => i == x)).
    - apply eq_refl.
    - apply eq_refl.
  Qed.
End MyEquality.

End ProofObjects.


(** * Teorija tipov in λ-račun. *)

(** Tipi so posplošitev množic, topološki prostorov in podatkovnih tipov. Naivno si jih
    lahko predstavljamo kot množice. Dejstvo, da ima izraz [e] tip [A] pišemo [e : A].

    Razne konstrukcije tipov se vedno uvede po istem vzorcu:

    - _formacija_: kako se naredi nov tip

    - _vpeljava_: kako se naredi ali sestavi elemente tipa (konstruktorji)

    - _uporaba_: kako se elemente uporabi ali razstavi na sestavne dele (eliminatorji)

    - _enačbe_: kakšne enačbe povezujejo konstruktorje in eliminatorje
*)

(** ** Funkcije

  Za vsaka dva tipa [A] in [B] lahko tvorimo tip funkcij:

  - _formacija_: če sta [A] in [B] tipa, je tudi [A -> B] tip

  - _vpeljava_: če je [x : A] spremenljivka tipa [A] in [t : B] izraz tipa [B],
    odvisen od [x], potem je [fun (x : A) => t] tipa [A -> B]. Izrazu [fun ...]
    pravimo _λ-abstrakcija_, ker se v logiki piše $\lambda x : A . t$.

  - _uporaba_: če je [f : A -> B] in [e : A] potem je [f e : B]. Pravimo, da smo
    funkcijo [f] aplicirali na argumentu [e].

  - _enačbe_:

    - _pravilo $\beta$_: [(fun (x : A) => t) e = t{e/x}] kjer zapis "[t{e/x}]" pomeni,
      da v izrazu [t] vstavimo [e] namesto [x].

    - _pravilo $\eta$_: [(fun (x : A) => f x) = f]
*)

(** ** Kartezični produkt

    Da bomo lahko počeli kaj zanimivega, vpeljemo še kartezični produkt tipov:

    - _formacija_: če sta [A] in [B] tipa, je [A * B] tip (matematični zapis $A \times B$)

    - _vpeljava_: če je [a : A] in [b : B], potem je [(a,b) : A * B], _urejeni par_

    - _uporaba_: če je [p : A * B], potem imamo

      - _prva projekcija_: [fst p : A]
      - _druga projekcija_: [snd p : B]

    - enačbe, pri čemer je [a : A], [b : B] in [p : A * B]:
      - [fst (a, b) = a]
      - [snd (a, b) = b]
      - [p = (fst p, snd p)]

    Poznamo še enotski tip:

    - _formacija_: [unit] je tip
    - _vpeljava_: [tt : unit]
    - _uporaba_: pravil za uporabo ni
    - _enačbe_: če je [u : unit], je [u = tt].
*)

(** V Coqu lahko datoteko razdelimo na posamične razdelke z [Section X.] in [End X.] *)
Section RazneFunkcije.

  (* Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  Definition vaja1_1 : A * B -> B * A :=
    fun (u : A * B) => (snd u, fst u).

  Definition vaja1_2 : (A * B) * C -> A * (B * C).
  Admitted.

  Definition vaja1_3 : A -> (B -> A).
  Admitted.

  Definition vaja1_4 : (A -> B -> C) -> (A -> B) -> (A -> C).
  Admitted.

  Definition vaja1_5 : (A * B -> C) -> (A -> (B -> C)).
  Admitted.

  Definition vaja1_6 : (A -> (B -> C)) -> (A * B -> C).
  Admitted.

  Definition vaja1_7 : unit * A -> A.
  Admitted.

  Definition vaja1_8 : A -> unit * A.
  Admitted.

End RazneFunkcije.

(** Ko zapremo razdelek [RazneFunkcije] nimamo več predpostavke, da so [A], [B], [C] tipi,
    vse definicije iz razdelka pa postanejo funkcije z dodatnimi parametri [A], [B], [C]. *)
Print vaja1_1.

(** Coq pravi: "Arguments [A], [B] are implicit and maximally inserted". To pomeni,
    da jih ni treba podati, ko uporabimo funkcijo [vaja1_1]. *)
Eval compute in vaja1_1 (42, false).

(* Če želimo eksplicitno nastaviti tudi [A] in [B], pišemo [@vaja1_1] namesto [vaja1_1]: *)
Eval compute in @vaja1_1 nat bool (42, false).

(** ** Izomorfni tipi

   Pravimo, da sta tipa [X] in [Y] izomorfna, če obstajata [f : X -> Y] in
   [g : Y -> X], da velja [g (f x) = x] za vse [x : X] in [g (g y) = y] za vse [y : Y].
*)
Definition iso (X : Type) (Y : Type) :=
  exists (f : X -> Y) (g : Y -> X),
    (forall x : X, g (f x) = x) /\ (forall y : Y, f (g y) = y).

(** V Coqu lahko uvedemo prikladno notacijo za izomorfizem. *)
Notation "X <~> Y" := (iso X Y) (at level 60).

Section Izomorfizmi1.
  (** Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  (** Dokaži, da so naslednji tipi izomorfni. *)

  Lemma vaja2_1 : A * B <~> B * A.
  Proof.
    admit.
  Qed.

  Lemma vaja2_2 : (A * B) * C <~> A * (B * C).
  Proof.
    admit.
  Qed.

  Lemma vaja2_3 : unit * A <~> A.
  Proof.
    admit.
  Qed.

  (** Pravimo, da sta funkciji [f g : X -> Y] _enaki po točkah_, če velja [forall x : X, f
      x = g x]. Aksiom _funkcijske ekstenzionalnosti_ pravi, da sta funkciji enaki,
      če sta enaki po točkah. Coq ne verjame v ta aksiom, zato ga po potrebi predpostavimo.
      Najprej ga definirajmo. *)
  Definition funext :=
    forall (X Y : Type) (f g : X -> Y), (forall x, f x = g x) -> f = g.

  (** S pomočjo ekstenzionalnosti lahko dokažemo nekatere izomorfizme. *)
  Lemma vaja2_4 (F : funext) : (A * B -> C) <~> (A -> (B -> C)).
  Proof.
    admit.
  Qed.

  Lemma vaja2_5 (F : funext) : (unit -> A) <~> A.
  Proof.
    admit.
  Qed.

  Lemma vaja2_6 (F : funext) : (A -> unit) <~> unit.
  Proof.
    admit.
  Qed.
End Izomorfizmi1.

(** ** Vsota tipov

   Vsota tipov je kot disjunktna unija v teorijo množic ali koprodukt v kategorijah:

   - _formacija_: če sta [A] in [B] tipa, je [A + B] tip

   - _vpeljava_:

      - če je [a : A], potem je [inl a : A + B]
      - če je [b : B], potem je [inr b : A + B]

   - _uporaba_: če pri predpostavki [x : A] velja [u(x) : C] in
     če pri predpostavki [y : B] velja [v(y) : C] in če je [t : A + B], potem
     ima
     [(match t with
       | inl x => u(x)
       | inr y => v(y)
      end)]
     tip [C].

   - _enačbe_:

      - [match (inl a) with
         | x => u(x)
         | y => v(y)
         end] je enako [u(a)].

      - [match (inr b) with
         | x => u(x)
         | y => v(y)
         end] je enako [v(b)].

      - [match t with
         | inl x => inl x
         | inr y => inr y
         end] je enako [t].

*)

(** ** Prazen tip

    Nekoliko bolj nenavaden je prazen tip:

    - _formacija_: [Empty_set] je tip

    - _vpeljava_: ni pravil za uporabo

    - _uporaba_: če [t : Empty_set], potem ima [match t with end] tip [A]

    - _enačbe_: [match t with end] je enako [a] za vse [a : A]
*)

Section FunkcijeVsote.
  (** Predpostavimo, da imamo tipe [A], [B] in [C]. *)
  Context {A B C : Type}.

  Definition vaja3_1 : (A + B -> C) -> (A -> C) * (B -> C).
  Admitted.

  (* S stavkom match obravnavmo element, ki je vsota tipov. *)

  Definition vaja3_2 : A + B -> B + A.
  Admitted.

  Definition vaja3_3 : (A + B) * C -> A * C + B * C.
  Admitted.

  Definition vaja3_4 : A * C + B * C -> (A + B) * C.
  Admitted.

  Definition vaja3_5 : (A -> C) * (B -> C) -> (A + B -> C).
  Admitted.

  Definition vaja3_6 : Empty_set -> A.
  Admitted.

  Definition vaja3_7 : Empty_set + A -> A.
  Admitted.

  Definition vaja3_8 : A -> ((A -> Empty_set) -> Empty_set).
  Admitted.

  Definition vaja3_9 : A + (A -> Empty_set) -> (((A -> Empty_set) -> Empty_set) -> A).
  Admitted.

End FunkcijeVsote.

Section Izomorfizmi2.
  (** Sam ugotovi, kje potrebuješ funkcijsko ekstenzionalnost. *)

  Context {A B C : Type}.

  Lemma vaja4_1 : A + B <~> B + A.
  Proof.
    admit.
  Qed.

  Lemma vaja4_2 : (A + B) * C <~> A * C + B * C.
  Proof.
    admit.
  Qed.

  Lemma vaja4_3 : (A + B -> C) <~> (A -> C) * (B -> C).
  Proof.
    admit.
  Qed.

  Lemma vaja4_4 : Empty_set + A <~> A.
  Proof.
    admit.
  Qed.

  Lemma vaja4_5 : (A -> Empty_set) <~> Empty_set.
  Proof.
    admit.
  Qed.

  Lemma vaja5_5 : (Empty_set -> A) <~> unit.
  Proof.
    admit.
  Qed.

End Izomorfizmi2.

Section Zabava.
  (** Pa še neka vaj za zabavo. *)
  Context {A B : Type}.

  (* Koliko funkcij A * B -> A + B lahko definiraš? *)
  Definition vaja5_1_XX : A * B -> A + B.
  Admitted.

  (* Koliko funkcij tipa (A * A) * A -> A * A lahko definiraš? *)
  Definition vaja5_2_XX : (A * A) * A -> A * A.
  Admitted.

  (* Koliko funkcij tipa (A -> A) -> (A -> A) lahko definiraš? *)
  Definition vaja5_3_XX : (A -> A) -> (A -> A).
  Admitted.

End Zabava.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) : natural := mult (Succ Zero) lf2.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf2 : natural) (y : natural) (x : natural) (lf1 : natural)
  : natural := plus lf1 x.


Require Export GeoCoq.Elements.OriginalProofs.lemma_extension.
Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence2.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_TTflip2 :
   forall A B C D E F G H,
   TT A B C D E F G H ->
   TT A B C D H G F E.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists J, (BetS E F J /\ Cong F J G H /\ TG A B C D E J)) by (conclude_def TT );destruct Tf as [J];spliter.
let Tf:=fresh in
assert (Tf:exists K, (BetS A B K /\ Cong B K C D /\ Lt E J A K)) by (conclude_def TG );destruct Tf as [K];spliter.
assert (neq F J) by (forward_using lemma_betweennotequal).
assert (neq G H) by (conclude axiom_nocollapse).
assert (neq H G) by (conclude lemma_inequalitysymmetric).
assert (neq E F) by (forward_using lemma_betweennotequal).
assert (neq F E) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists L, (BetS H G L /\ Cong G L F E)) by (conclude lemma_extension);destruct Tf as [L];spliter.
assert (Cong L G E F) by (forward_using lemma_congruenceflip).
assert (Cong G H F J) by (conclude lemma_congruencesymmetric).
assert (BetS L G H) by (conclude axiom_betweennesssymmetry).
assert (Cong L H E J) by (conclude cn_sumofparts).
assert (Cong H L L H) by (conclude cn_equalityreverse).
assert (Cong H L E J) by (conclude lemma_congruencetransitive).
assert (Cong E J H L) by (conclude lemma_congruencesymmetric).
assert (Lt H L A K) by (conclude lemma_lessthancongruence2).
assert (TG A B C D H L) by (conclude_def TG ).
assert (TT A B C D H G F E) by (conclude_def TT ).
close.
Qed.

End Euclid.


Require Import Ashley.Axioms.
Require Import Ashley.PartialOrder.
Require Import Ashley.Set.
Require Import Ashley.SetFunction.
Require Import Ashley.Lattice.

Class Topology (A : Type) : Type :=
{
  open : set (set A);
  top_empty_is_open : open empty;
  top_full_is_open : open full;
  top_intersect_is_open : all a:open, all b:open, open (intersect a b);
  top_Union_is_open : forall ff, ff <= open -> open (Union ff)
}.

Definition topology_open {A} (top: Topology A) : set (set A) := @open _ top.

Definition open_type {A} (top: Topology A) := set_type open.

Definition open_val {A} {t: Topology A} (x: set A): open x -> open_type t := stc open x.

Lemma val_open: forall {A:Type} `{Topology A} (v:set A) (st:open v), val (open_val v st) = v.
intros.
unfold open_val.
apply val_stc.
Qed.

Definition topology_union {A} {top: Topology A} (u v: open_type top): open_type top.
apply (open_val (join (val u) (val v))).
case u.
case v.
intros.
unfold val.
unfold join.
unfold indexed_JoinSemilattice.
unfold join.
unfold prop_JoinSemilattice.
fold (union x0 x).
rewrite <- Union2.
apply top_Union_is_open.
unfold within. unfold indexed_Preorder.
unfold within. unfold prop_Preorder.
intros.
destruct H.
rewrite H.
apply o0.
rewrite H.
apply o.
Defined.

Instance open_JoinSemilattice `(top: Topology) : JoinSemilattice (open_type top) :=
{
  join := topology_union
}.
intros.
apply set_type_ext.
unfold topology_union.
unfold open_val.
unfold val.
case p.
case q.
case r.
intros.
firstorder.
apply join_associates.
intros.
apply set_type_ext.
unfold topology_union.
unfold open_val.
unfold val.
case p.
case q.
firstorder.
apply join_commutes.
intros.
apply set_type_ext.
unfold topology_union.
unfold open_val.
unfold val.
case p.
firstorder.
apply join_idem.
Defined.

Definition topology_intersect {A} {top: Topology A} (u v: open_type top): open_type top.
apply (open_val (meet (val u) (val v))).
case u.
case v.
unfold val.
intros.
apply top_intersect_is_open.
exact o0.
exact o.
Defined.

Instance open_MeetSemilattice `(top: Topology) : MeetSemilattice (open_type top) :=
{
  meet := topology_intersect
}.
intros.
apply set_type_ext.
unfold topology_intersect. unfold open_val. unfold val.
case p. case q. case r.
intros.
apply meet_associates.
intros.
apply set_type_ext.
unfold topology_intersect. unfold open_val. unfold val.
case p. case q.
intros.
apply meet_commutes.
intros.
apply set_type_ext.
unfold topology_intersect. unfold open_val. unfold val.
case p.
intros.
apply meet_idem.
Defined.

Instance open_Preorder `(top: Topology) : Preorder (open_type top) :=
{
  within a b := within (val a) (val b)
}.
intros.
apply within_reflex.
intros.
apply (within_trans (val p) (val q) (val r)).
exact H.
exact H0.
Defined.

Instance open_PartialOrder `(top: Topology) : PartialOrder (open_type top) :=
{
}.
intros.
apply within_antisym.
exact H.
exact H0.
Defined.

Instance open_Lattice `(top: Topology) : Lattice (open_type top) :=
{
}.
intros.
unfold within. unfold open_Preorder.
unfold join. unfold open_JoinSemilattice.
replace (topology_union p q = q) with (val (topology_union p q) = val q).
unfold topology_union. rewrite val_open.
apply join_within.
apply set_type_ext_eq.

intros.
unfold join. unfold open_JoinSemilattice.
unfold meet. unfold open_MeetSemilattice.
apply set_type_ext.
unfold topology_union.
unfold topology_intersect.
rewrite !val_open.
apply meet_join_absorbs.

intros.
unfold join. unfold open_JoinSemilattice.
unfold meet. unfold open_MeetSemilattice.
apply set_type_ext.
unfold topology_union.
unfold topology_intersect.
rewrite !val_open.
apply join_meet_absorbs.
Defined.

Definition topology_bottom {A} {t: Topology A}: open_type t.
apply (open_val bottom).
unfold bottom. unfold indexed_BoundedPartialOrder.
unfold bottom. unfold prop_BoundedPartialOrder.
apply top_empty_is_open.
Defined.

Definition topology_top {A} {t: Topology A}: open_type t.
apply (open_val top).
unfold top. unfold indexed_BoundedPartialOrder.
unfold top. unfold prop_BoundedPartialOrder.
apply top_full_is_open.
Defined.

Instance open_BoundedPartialOrder `(t: Topology) : BoundedPartialOrder (open_type t) :=
{
  bottom := topology_bottom;
  top := topology_top
}.
intros.
unfold within. unfold open_Preorder.
apply bottom_within.

intros.
unfold within. unfold open_Preorder.
apply top_without.
Defined.

Require Import Ashley.BoundedLattice.

Instance open_BoundedLattice `(t: Topology) : BoundedLattice (open_type t) :=
{
}.

Definition topology_Join {A} {t: Topology A} (uu: set (open_type t)): open_type t.
apply (open_val (Union (map val uu))).
apply top_Union_is_open.
unfold within. unfold indexed_Preorder.
unfold within. unfold prop_Preorder.
unfold map.
intros.
destruct H.
destruct H.
rewrite <- H0.
apply struct.
Defined.

Lemma Join_is_Union: forall {A} (f:set (set A)), Join f = Union f.
intros.
unfold Join. unfold indexed_SemicompleteBoundedLattice.
unfold Join. unfold prop_SemicompleteBoundedLattice.
unfold Union.
apply member_ext.
intros.
unfold map.
split.
intros.
destruct H.
exists x0.
destruct H.
split.
exact H.
rewrite H0.
trivial.
intros.
destruct H.
destruct H.
exists x0.
split.
exact H.
apply prop_ext.
firstorder.
Qed.

Instance open_SemicompleteBoundedLattice `(t: Topology) : SemicompleteBoundedLattice (open_type t) :=
{
  Join := topology_Join
}.
intros.
unfold within. unfold open_Preorder.
unfold topology_Join. rewrite val_open.
rewrite <- Join_is_Union.
apply Join_bound.
unfold map.
exists a.
firstorder.

intros.
unfold within. unfold open_Preorder.
unfold topology_Join. rewrite val_open.
unfold within in H. unfold open_Preorder in H.
rewrite <- Join_is_Union.
apply Join_least.
intros.
unfold map in H0.
destruct H0.
destruct H0.
rewrite <- H1.
apply (H x).
exact H0.
Defined.

(*
Instance top_empty {A} {top: Topology A}: set_type open :=
*)
Definition tunion {A} {top: Topology A} (u v: open_type top): open_type top := topology_union u v.

Instance discrete {A} : Topology A :=
{
  open := full
}.
apply all_full.
apply all_full.
intros.
apply all_full.
intros.
apply all_full.
Defined.

Instance indiscrete {A} : Topology A :=
{
  open := {s : set A | not_empty s -> is_full s}
}.
firstorder.
firstorder.
firstorder.
firstorder.
Defined.

Instance particular_point {A} (p:A) : Topology A :=
{
  open := {s : set A | not_empty s -> s p}
}.
firstorder.
firstorder.
firstorder.
firstorder.
Defined.

Definition sierpinski := particular_point True.

Notation "'all_open' x : t , P" := (all x : topology_open t, P) (at level 20, x at level 99).
Notation "'some_open' x : t , P" := (some x : topology_open t, P) (at level 20, x at level 99).

Class Continuous {A} {B} (TA : Topology A) (TB : Topology B) : Type :=
{
  f: A -> B;
  is_continuous: all_open sb: TB, topology_open TA {a : A|sb (f a)}
}.

Definition continuous_f {A} {B} {TA:Topology A} {TB:Topology B} (c: Continuous TA TB) := @f _ _ _ _ c.

Require Import Ashley.Proposition.

Lemma not_noncontinuous: forall (cont: Continuous sierpinski sierpinski), ~ continuous_f cont = not.
unfold sierpinski.
intro.
intro.
destruct cont.
unfold continuous_f in H.
unfold f in H.
unfold topology_open in is_continuous0.
rewrite H in is_continuous0.
clear H f0.
specialize (is_continuous0 {b:Prop|b}).
firstorder.
specialize (H False).
firstorder.
Defined.

Class Cover {A} `{SemicompleteBoundedLattice A} (s : A) : Type :=
{
  cover_sets : set A;
  covering : Join cover_sets >= s
}.

Definition OpenCover {A} (top : Topology A) (s : open_type top) : Type := Cover s.


Require Import
        Coq.Vectors.Vector
        VectorLib.

Inductive Bit := Zero | One.

Definition And (x y : Bit) :=
  match x, y with
  | One, One => One
  | _, _ => Zero
  end.

Definition Or (x y : Bit) :=
  match x, y with
  | Zero, Zero => Zero
  | _, _ => One
  end.

Definition Bitflip (x : Bit) : Bit :=
  match x with
  | Zero => One
  | One => Zero
  end.

Lemma and_bit_flip : forall (x : Bit), And x (Bitflip x) = Zero.
Proof.
  refine (fun x => match x with
                | Zero => eq_refl
                | One => eq_refl
                end).
Qed.

Lemma bit_and_flip : forall (x : Bit), And (Bitflip x) x = Zero.
Proof.
  refine (fun x => match x with
                | Zero => eq_refl
                | One => eq_refl
                end).
Qed.

Definition Bitstream (n : nat) := Vector.t Bit n.

Fixpoint repeatN (n : nat) (x : Bit) : Bitstream n :=
  match n with
  | O => nil _
  | S n' => cons _ x _ (repeatN n' x)
  end.

Definition zipBits {n : nat} (f : Bit -> Bit -> Bit) (xs ys : Bitstream n) : Bitstream n :=
  zip_vectors f n xs ys.

Definition mapBits {n : nat} (f : Bit -> Bit) (xs : Bitstream n) : Bitstream n :=
  map_vector f n xs.

Definition appendBits {n m : nat} (xs : Bitstream n) (ys : Bitstream m) : Bitstream (n + m) :=
  append_vector n m xs ys.

(* All bits are zero *)
Definition allZero (n : nat) := repeatN n Zero.

(* All bits are One *)
Definition allOne (n : nat) := repeatN n One.

Definition bitstreamAnd {n : nat} (xs ys : Bitstream n) : Bitstream n :=
  zipBits And xs ys.

Definition bistreamOr {n : nat} (xs ys : Bitstream n) : Bitstream n :=
  zipBits Or xs ys.

Definition bitstreamFlip {n : nat} (xs : Bitstream n) : Bitstream n :=
  mapBits Bitflip xs.

(* n is index. n = 0 means set the 0th bit *)
Fixpoint setBit {m : nat} (n : nat) : Bitstream (n + S m) -> Bitstream (n + S m).
  refine (match n as n' return n = n' -> Bitstream (n' + S m) -> Bitstream (n' + S m) with
          | O => fun H v => _
          | S n' => fun H v => _
          end eq_refl); inversion v.
  + exact (cons _ One _ H1).
  + exact (cons _ One _ (setBit _ _ H1)).
Defined.

Fixpoint fetchBit {m : nat} (n : nat) : Bitstream (n + S m) -> Bit.
  refine (match n as n' return n = n' -> Bitstream (n' + S m) -> Bit with
          | O => fun H v => _
          | S n' => fun H v => _
          end eq_refl); inversion v.
  + exact h.
  + exact (fetchBit _ _ H1).
Defined.

Theorem  compliment_of_each_other :
  forall (n : nat) (xs : Bitstream n), bitstreamAnd xs (bitstreamFlip xs) = allZero n.
Proof.
  unfold Bitstream; unfold bitstreamAnd; unfold bitstreamFlip;
    unfold zipBits; unfold mapBits; unfold allZero.
  induction xs.
  + auto.
  + cbn. rewrite IHxs. rewrite and_bit_flip.
    auto.
Qed.


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma div_abs_sgn_nonneg a b : 0 <= Z.sgn (Z.abs a / Z.abs b).
  Proof.
    generalize (Zdiv_sgn (Z.abs a) (Z.abs b)).
    destruct a, b; simpl; lia.
  Qed.
  Hint Resolve div_abs_sgn_nonneg : zarith.
End Z.


(** * Poly: Polymorphism and Higher-Order Functions *)

(* Final reminder: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
From LF Require Export Lists.

(* ################################################################# *)
(** * Polymorphism *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).  We begin with polymorphism. *)

(* ================================================================= *)
(** ** Polymorphic Lists *)

(** For the last chapter, we've been working with lists
    containing just numbers.  Obviously, interesting programs also
    need to be able to manipulate lists with elements from other
    types -- lists of booleans, lists of lists, etc.  We _could_ just
    define a new inductive datatype for each of these, for
    example... *)

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

Check boollist.

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.) and all
    their properties ([rev_length], [app_assoc], etc.) for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the function header on the first line,
    and the occurrences of [natlist] in the types of the constructors
    have been replaced by [list X].

    What sort of thing is [list] itself?  A good way to think about it
    is that the definition of [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it more concisely, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is the [Inductive]ly defined set of lists whose
    elements are of type [X]. *)

Check list : Type -> Type.

(** The parameter [X] in the definition of [list] automatically
    becomes a parameter to the constructors [nil] and [cons] -- that
    is, [nil] and [cons] are now polymorphic constructors; when we use
    them, we must now provide a first argument that is the type of the
    list they are building. For example, [nil nat] constructs the
    empty list of type [nat]. *)

Check (nil nat) : list nat.

(** Similarly, [cons nat] adds an element of type [nat] to a list of
    type [list nat]. Here is an example of forming a list containing
    just the natural number 3. *)

Check (cons nat 3 (nil nat)) : list nat.

(** What might the type of [nil] be? We can read off the type
    [list X] from the definition, but this omits the binding for [X]
    which is the parameter to [list]. [Type -> list X] does not
    explain the meaning of [X]. [(X : Type) -> list X] comes
    closer. Coq's notation for this situation is [forall X : Type,
    list X]. *)

Check nil : forall X : Type, list X.

(** Similarly, the type of [cons] from the definition looks like
    [X -> list X -> list X], but using this convention to explain the
    meaning of [X] results in the type [forall X, X -> list X -> list
    X]. *)

Check cons : forall X : Type, X -> list X -> list X.

(** (Side note on notation: In .v files, the "forall" quantifier
    is spelled out in letters.  In the generated HTML files and in the
    way various IDEs show .v files, depending on the settings of their
    display controls, [forall] is usually typeset as the usual
    mathematical "upside down A," though you'll still see the
    spelled-out "forall" in a few places.  This is just a quirk of
    typesetting: there is no difference in meaning.) *)

(** Having to supply a type argument for every single use of a
    list constructor would be rather burdensome; we will soon see ways
    of reducing this annotation burden. *)

Check (cons nat 2 (cons nat 1 (nil nat)))
      : list nat.

(** We can now go back and make polymorphic versions of all the
    list-processing functions that we wrote before.  Here is [repeat],
    for example: *)

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

(** As with [nil] and [cons], we can use [repeat] by applying it
    first to a type and then to an element of this type (and a number): *)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

(** **** Exercise: 2 stars, standard (mumble_grumble)

    Consider the following two inductively defined types. *)

Module MumbleGrumble.

Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.

Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?  (Add YES or NO to each line.)
      - [d (b a 5)]
      - [d mumble (b a 5)]
      - [d bool (b a 5)]
      - [e bool true]
      - [e mumble (b c 0)]
      - [e bool (b c 0)]
      - [c]  *)
(* FILL IN HERE *)
End MumbleGrumble.

(* Do not modify the following line: *)
Definition manual_grade_for_mumble_grumble : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [repeat] again, but this time we
    won't specify the types of any of the arguments.  Will Coq still
    accept it? *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

(** Indeed it will.  Let's see what type Coq has assigned to [repeat']: *)

Check repeat'
  : forall X : Type, X -> nat -> list X.
Check repeat
  : forall X : Type, X -> nat -> list X.

(** It has exactly the same type as [repeat].  Coq was able to
    use _type inference_ to deduce what the types of [X], [x], and
    [count] must be, based on how they are used.  For example, since
    [X] is used as an argument to [cons], it must be a [Type], since
    [cons] expects a [Type] as its first argument; matching [count]
    with [0] and [S] means it must be a [nat]; and so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations can still be quite useful as documentation and sanity
    checks, so we will continue to use them much of the time. *)

(* ----------------------------------------------------------------- *)
(** *** Type Argument Synthesis *)

(** To use a polymorphic function, we need to pass it one or
    more types in addition to its other arguments.  For example, the
    recursive call in the body of the [repeat] function above must
    pass along the type [X].  But since the second argument to
    [repeat] is an element of [X], it seems entirely obvious that the
    first argument can only be [X] -- why should we have to write it
    explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write a "hole" [_], which can be
    read as "Please try to figure out for yourself what belongs here."
    More precisely, when Coq encounters a [_], it will attempt to
    _unify_ all locally available information -- the type of the
    function being applied, the types of the other arguments, and the
    type expected by the context in which the application appears --
    to determine what concrete type should replace the [_].

    This may sound similar to type annotation inference -- and, indeed,
    the two procedures rely on the same underlying mechanisms.  Instead
    of simply omitting the types of some arguments to a function, like

      repeat' X x count : list X :=

    we can also replace the types with holes

      repeat' (X : _) (x : _) (count : _) : list X :=

    to tell Coq to attempt to infer the missing information.

    Using holes, the [repeat] function can be written like this: *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference in both keystrokes and
    readability is nontrivial.  For example, suppose we want to write
    down a list containing the numbers [1], [2], and [3].  Instead of
    this... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use holes to write this: *)

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ----------------------------------------------------------------- *)
(** *** Implicit Arguments *)

(** In fact, we can go further and even avoid writing [_]'s in most
    cases by telling Coq _always_ to infer the type argument(s) of a
    given function.

    The [Arguments] directive specifies the name of the function (or
    constructor) and then lists its argument names, with curly braces
    around any arguments to be treated as implicit.  (If some
    arguments of a definition don't have a name, as is often the case
    for constructors, they can be marked with a wildcard pattern
    [_].) *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** Now, we don't have to supply type arguments at all: *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** Alternatively, we can declare an argument to be implicit
    when defining the function itself, by surrounding it in curly
    braces instead of parens.  For example: *)

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

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [repeat'''].  Indeed, it would be invalid to
    provide one, because Coq is not expecting it.)

    We will use the latter style whenever possible, but we will
    continue to use explicit [Argument] declarations for [Inductive]
    constructors.  The reason for this is that marking the parameter
    of an inductive type as implicit causes it to become implicit for
    the type itself, not just for its constructors.  For instance,
    consider the following alternative definition of the [list]
    type: *)

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

(** Because [X] is declared as implicit for the _entire_ inductive
    definition including [list'] itself, we now have to write just
    [list'] whether we are talking about lists of numbers or booleans
    or anything else, rather than [list' nat] or [list' bool] or
    whatever; this is a step too far. *)

(** Let's finish by re-implementing a few other standard list
    functions on our new polymorphic lists... *)

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

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

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

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

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

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity. Qed.

(* ----------------------------------------------------------------- *)
(** *** Supplying Type Arguments Explicitly *)

(** One small problem with declaring arguments [Implicit] is
    that, once in a while, Coq does not have enough local information
    to determine a type argument; in such cases, we need to tell Coq
    that we want to give the argument explicitly just this time.  For
    example, suppose we write this: *)

Fail Definition mynil := nil.

(** (The [Fail] qualifier that appears before [Definition] can be
    used with _any_ command, and is used to ensure that that command
    indeed fails when executed. If the command does fail, Coq prints
    the corresponding error message, but continues processing the rest
    of the file.)

    Here, Coq gives us an error because it doesn't know what type
    argument to supply to [nil].  We can help it by providing an
    explicit type declaration (so that Coq has more information
    available when it gets to the "application" of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

Check @nil : forall X : Type, list X.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

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

(** Now lists can be written just the way we'd hope: *)

Definition list123''' := [1; 2; 3].

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 2 stars, standard, optional (poly_exercises)

    Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

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

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

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

(** **** Exercise: 2 stars, standard, optional (more_poly_exercises)

    Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. induction l1; simpl.
  - rewrite app_nil_r. reflexivity.
  - rewrite IHl1. rewrite app_assoc. reflexivity.
Qed.

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

(* ================================================================= *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the definition for pairs of
    numbers that we gave in the last chapter can be generalized to
    _polymorphic pairs_, often called _products_: *)

Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).

Arguments pair {X} {Y} _ _.

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

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

(** We can also use the [Notation] mechanism to define the standard
    notation for product _types_: *)

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

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should only be used when parsing types, not when parsing
    expressions.  This avoids a clash with the multiplication
    symbol.) *)

(** It is easy at first to get [(x,y)] and [X*Y] confused.
    Remember that [(x,y)] is a _value_ built from two other values,
    while [X*Y] is a _type_ built from two other types.  If [x] has
    type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

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

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

(** The following function takes two lists and combines them
    into a list of pairs.  In other functional languages, it is often
    called [zip]; we call it [combine] for consistency with Coq's
    standard library. *)

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

(** **** Exercise: 1 star, standard, optional (combine_checks)

    Try answering the following questions on paper and
    checking your answers in Coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does

        Compute (combine [1;2] [false;false;true;true]).

      print?

    [] *)

(** **** Exercise: 2 stars, standard, recommended (split)

    The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y) :=
               match l with
               | nil => ([], [])
               | (x, y) :: t => match split t with
                                | (xs, ys) => (x :: xs, y :: ys)
                                end
               end.

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

(* ================================================================= *)
(** ** Polymorphic Options *)

(** Our last polymorphic type for now is _polymorphic options_,
    which generalize [natoption] from the previous chapter.  (We put
    the definition inside a module because the standard library
    already defines [option] and it's this one that we want to use
    below.) *)

Module OptionPlayground.

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

Arguments Some {X} _.
Arguments None {X}.

End OptionPlayground.

(** We can now rewrite the [nth_error] function so that it works
    with any type of lists. *)

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

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, standard, optional (hd_error_poly)

    Complete the definition of a polymorphic version of the
    [hd_error] function from the last chapter. Be sure that it
    passes the unit tests below. *)

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

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

Check @hd_error : forall X : Type, list X -> option X.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. simpl. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. simpl. reflexivity. Qed.
(** [] *)

(* ################################################################# *)
(** * Functions as Data *)

(** Like most modern programming languages -- especially other
    "functional" languages, including OCaml, Haskell, Racket, Scala,
    Clojure, etc. -- Coq treats functions as first-class citizens,
    allowing them to be passed as arguments to other functions,
    returned as results, stored in data structures, etc. *)

(* ================================================================= *)
(** ** Higher-Order Functions *)

(** Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

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

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

Check @doit3times : forall X : Type, (X -> X) -> X -> X.

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

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

(* ================================================================= *)
(** ** Filter *)

(** Here is a more useful higher-order function, taking a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filtering" the list, returning a new list containing just
    those elements for which the predicate returns [true]. *)

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

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

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

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

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

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)

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

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

(* ================================================================= *)
(** ** Anonymous Functions *)

(** It is arguably a little sad, in the example just above, to
    be forced to define the function [length_is_1] and give it a name
    just to be able to pass it as an argument to [filter], since we
    will probably never use it again.  Moreover, this is not an
    isolated example: when using higher-order functions, we often want
    to pass as arguments "one-off" functions that we will never use
    again; having to give each of these functions a name would be
    tedious.

    Fortunately, there is a better way.  We can construct a function
    "on the fly" without declaring it at the top level or giving it a
    name. *)

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

(** The expression [(fun n => n * n)] can be read as "the function
    that, given a number [n], yields [n * n]." *)

(** Here is the [filter] example, rewritten to use an anonymous
    function. *)

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

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

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

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun x => andb (negb (x <=? 7)) (evenb x)) l.

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

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

(** **** Exercise: 3 stars, standard (partition)

    Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a predicate of type [X -> bool] and a [list X],
   [partition] should return a pair of lists.  The first member of the
   pair is the sublist of the original list containing the elements
   that satisfy the test, and the second is the sublist containing
   those that fail the test.  The order of elements in the two
   sublists should be the same as their order in the original list. *)

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

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

(* ================================================================= *)
(** ** Map *)

(** Another handy higher-order function is called [map]. *)

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

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

(** The element types of the input and output lists need not be
    the same, since [map] takes _two_ type arguments, [X] and [Y]; it
    can thus be applied to a list of numbers and a function from
    numbers to booleans to yield a list of booleans: *)

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

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a _list of lists_ of booleans: *)

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

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 3 stars, standard (map_rev)

    Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros. induction l.
  - reflexivity.
  - simpl.
    assert (H: forall xs, forall v, map f (xs ++ [v]) = map f xs ++ [f v]). {
      intros. induction xs.
        + reflexivity.
        + simpl. rewrite IHxs. reflexivity.
    }
    rewrite H. rewrite IHl. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, recommended (flat_map)

    The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
*)

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

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

(** Lists are not the only inductive type for which [map] makes sense.
    Here is a [map] for the [option] type: *)

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

(** **** Exercise: 2 stars, standard, optional (implicit_args)

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

(* ================================================================= *)
(** ** Fold *)

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

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

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1;2;3;4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,

       fold plus [1;2;3;4] 0

    yields

       1 + (2 + (3 + (4 + 0))).

    Some more examples: *)

Check (fold andb) : list bool -> bool -> bool.

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

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

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

(** **** Exercise: 1 star, advanced (fold_types_different)

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

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_fold_types_different : option (nat*string) := None.
(** [] *)

(* ================================================================= *)
(** ** Functions That Construct Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as arguments.  Let's look at some examples that
    involve _returning_ functions as the results of other functions.
    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

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

Definition ftrue := constfun true.

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

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

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus : nat -> nat -> nat.

(** Each [->] in this expression is actually a _binary_ operator
    on types.  This operator is _right-associative_, so the type of
    [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it
    can be read as saying that "[plus] is a one-argument function that
    takes a [nat] and returns a one-argument function that takes
    another [nat] and returns a [nat]."  In the examples above, we
    have always applied [plus] to both of its arguments at once, but
    if we like we can supply just the first.  This is called _partial
    application_. *)

Definition plus3 := plus 3.
Check plus3 : nat -> nat.

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

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

Module Exercises.

(** **** Exercise: 2 stars, standard (fold_length)

    Many common functions on lists can be implemented in terms of
    [fold].  For example, here is an alternative definition of [length]: *)

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

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

(** Prove the correctness of [fold_length].  (Hint: It may help to
    know that [reflexivity] simplifies expressions a bit more
    aggressively than [simpl] does -- i.e., you may find yourself in a
    situation where [simpl] does nothing but [reflexivity] solves the
    goal.) *)

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

(** **** Exercise: 3 stars, standard (fold_map)

    We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

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

(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it.  (Hint: again, remember that
   [reflexivity] simplifies expressions a bit more aggressively than
   [simpl].) *)

Theorem fold_map_correct: forall X Y : Type, forall l : list X, forall f : X -> Y,
  fold_map f l = map f l.
Proof.
  intros. induction l.
  - reflexivity.
  - simpl. rewrite <- IHl. reflexivity.
Qed.

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_fold_map : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, advanced (currying)

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

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

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

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

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

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

(** As a (trivial) example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

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

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

Check @prod_curry.
Check @prod_uncurry.

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

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

(** **** Exercise: 2 stars, advanced (nth_error_informal)

    Recall the definition of the [nth_error] function:

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

   Write an informal proof of the following theorem:

   forall X l n, length l = n -> @nth_error X l n = None
*)
(* FILL IN HERE *)

(* Theorem nth_of_length_n: forall X l n,
  length l = n -> @nth_error X l n = None.
Proof.
  intros. induction l as [ | h t IHl'].
  - simpl. reflexivity.
  - simpl in H.
Qed. *)

(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (nat*string) := None.
(** [] *)

(** The following exercises explore an alternative way of defining
    natural numbers, using the so-called _Church numerals_, named
    after mathematician Alonzo Church.  We can represent a natural
    number [n] as a function that takes a function [f] as a parameter
    and returns [f] iterated [n] times. *)

Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

(** Similarly, [two] should apply [f] twice to its argument: *)

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

(** Defining [zero] is somewhat trickier: how can we "apply a function
    zero times"?  The answer is actually simple: just return the
    argument untouched. *)

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

(** More generally, a number [n] can be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f].  Notice in
    particular how the [doit3times] function we've defined previously
    is actually just the Church representation of [3]. *)

Definition three : cnat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** **** Exercise: 1 star, advanced (church_succ)  *)

(** Successor of a natural number: given a Church numeral [n],
    the successor [succ n] is a function that iterates its
    argument once more than [n]. *)
Definition succ (n : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => n X f (f x).

Example succ_1 : succ zero = one.
Proof. simpl. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. simpl. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. simpl. reflexivity. Qed.

(** [] *)

(** **** Exercise: 1 star, advanced (church_plus)  *)

(** Addition of two natural numbers: *)
Definition plus (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => n X f (m X f x).

Example plus_1 : plus zero one = one.
Proof. simpl. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
Proof. simpl. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. simpl. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_mult)  *)

(** Multiplication: *)
Definition mult (n m : cnat) : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => n X (m X f) x.

Example mult_1 : mult one one = one.
Proof. simpl. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. simpl. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. simpl. reflexivity. Qed.

(** [] *)

(** **** Exercise: 2 stars, advanced (church_exp)  *)

(** Exponentiation: *)

(** (_Hint_: Polymorphism plays a crucial role here.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type.  Iterating over [cnat] itself is usually problematic.) *)

Definition exp (n m : cnat) : cnat . Admitted.

Example exp_1 : exp two two = plus two two.
Proof. Admitted.

Example exp_2 : exp three zero = one.
Proof. Admitted.

Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. Admitted.

(** [] *)

End Church.

End Exercises.

(* Tue Oct 8 15:58:02 EDT 2019 *)