Require Export Induction.
Module NatList.

Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

Check (pair 3 5).

Definition fst (p: natprod) : nat :=
  match p with
  | pair x _ => x
  end.

Definition snd (p: natprod) : nat :=
  match p with
  | pair _ y => y
  end.

Compute (fst (pair 3 5)).

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

Compute (snd (4, 7)).

Definition swap_pair (p: natprod) : natprod :=
  match p with
  | (x, y) => (y, x)
  end.

Theorem surjective_pairing: forall p:natprod,
  p = (fst p, snd p).
Proof.
  intros.
  destruct p as [n m].
  simpl. reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros.
  destruct p as [n m].
  simpl. reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p: natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros.
  destruct p as [n m].
  simpl. reflexivity.
Qed.

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

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

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

Fixpoint repeat (n count: nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: repeat n count'
  end.

Fixpoint length (l: natlist) : nat :=
  match l with
  | [] => O
  | _ :: l' => S (length l')
  end.

Fixpoint app (l1 l2: natlist) : natlist :=
  match l1 with
  | nil => l2
  | x :: xs => x :: (app xs l2)
  end.

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

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd (def:nat) (l:natlist) : nat :=
  match l with
  | nil => def
  | h :: _ => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | _ :: t => t
  end.

Example test_hd1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd2: hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | 0 :: t => nonzeros t
  | h :: t => h :: nonzeros t
  end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. simpl. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => if (evenb h) then oddmembers t
                           else h :: oddmembers t
  end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. simpl. reflexivity. Qed.

Definition countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof. simpl. reflexivity. Qed.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof. simpl. reflexivity. Qed.

Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof. simpl. reflexivity. Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | [], r2 => r2
  | r1, [] => r1
  | h1 :: t1, h2 :: t2 => h1 :: h2 :: (alternate t1 t2)
  end.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. simpl. reflexivity. Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof. simpl. reflexivity. Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof. simpl. reflexivity. Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof. simpl. reflexivity. Qed.

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | [] => 0
  | h :: t => (if beq_nat h v then 1 else 0) + (count v t)
  end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. simpl. reflexivity. Qed.

Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. simpl. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. simpl. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag := v :: s.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. simpl. reflexivity. Qed.

Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. simpl. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  blt_nat 0 (count v s).

Example test_member1: member 1 [1;4;1] = true.
Proof. simpl. reflexivity. Qed.

Example test_member2: member 2 [1;4;1] = false.
Proof. simpl. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | [] => []
  | h :: t => if beq_nat v h then t else h :: remove_one v t
  end.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. simpl. reflexivity. Qed.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. simpl. reflexivity. Qed.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. simpl. reflexivity. Qed.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. simpl. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  | [] => []
  | h :: t => if beq_nat v h then remove_all v t else h :: remove_all v t
  end.

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. simpl. reflexivity. Qed.

Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. simpl. reflexivity. Qed.

Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. simpl. reflexivity. Qed.

Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. simpl. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | [] => true
  | h :: t => (member h s2) && (subset t (remove_one h s2))
  end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. simpl. reflexivity. Qed.

Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. simpl. reflexivity. Qed.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros.
  destruct l as [| n l'].
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros.
  induction l1 as [| h1 t1 IH1'].
  - simpl. reflexivity.
  - simpl. rewrite -> IH1'. reflexivity.
Qed.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | [] => []
  | h :: t => (rev t) ++ [h]
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem app_length: forall l1 l2: natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros.
  induction l1 as [| n l1' IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem rev_length: forall l:natlist,
  length (rev l) = length l.
Proof.
  intros.
  induction l as [| h l' IHl'].
  - simpl. reflexivity.
  - simpl.
    rewrite -> app_length, plus_comm.
    rewrite -> IHl'.
    reflexivity.
Qed.

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl. rewrite -> IH. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros.
  induction l1 as [| h1 t1 IH].
  - simpl. destruct l2 as [| h2 t2].
    + simpl. reflexivity.
    + simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. destruct l2 as [| h2 t2].
    + simpl. rewrite -> app_nil_r. reflexivity.
    + rewrite -> IH. simpl. rewrite -> app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr.
    simpl. rewrite -> IH.
    reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros.
  rewrite -> app_assoc.
  rewrite -> app_assoc.
  reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros.
  induction l1 as [| h t IH].
  - simpl. reflexivity.
  - simpl.
    destruct h as [| h'].
    + simpl. rewrite -> IH. reflexivity.
    + simpl. rewrite -> IH. reflexivity.
Qed.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | [], [] => true
  | [], _ => false
  | _, [] => true
  | h1 :: t1, h2 :: t2 => (beq_nat h1 h2) && (beq_natlist t1 t2)
  end.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
Proof. reflexivity. Qed.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl. induction h as [| h' IH'].
    + simpl. rewrite <- IH. reflexivity.
    + simpl. rewrite <- IH'. reflexivity.
Qed.

Theorem count_member_nonzero : forall (s : bag),
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  intros.
  destruct s as [| h t].
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem leb_n_Sn : forall n,
  leb n (S n) = true.
Proof.
  intros.
  induction n as [| n' IH].
  - reflexivity.
  - simpl. rewrite -> IH. reflexivity.
Qed.

Theorem remove_decreases_count: forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros.
  induction s as [| h t IH].
  - simpl. reflexivity.
  - destruct h as [| h'].
    + simpl. rewrite -> leb_n_Sn. reflexivity.
    + simpl. rewrite -> IH. reflexivity.
Qed.

Theorem bag_count_sum: forall (s1 s2:bag),
  count 0 (sum s1 s2) = (count 0 s1) + (count 0 s2).
Proof.
  intros.
  induction s1 as [| h1 t1 IH].
  - simpl. reflexivity.
  - destruct h1 as [| h1'].
    + simpl. rewrite -> IH. reflexivity.
    + simpl. rewrite -> IH. reflexivity.
Qed.

Theorem rev_injective: forall (l1 l2 : natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
Qed.

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | [] => None
  | x :: l' => match n with
               | O => Some x
               | S n' => nth_error l' n'
               end
  end.

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

Definition option_elim (def : nat) (o : natoption) : nat :=
  match o with
  | None => def
  | Some x => x
  end.

Definition hd_error (l : natlist) : natoption :=
  match l with
  | [] => None
  | h :: _ => Some h
  end.

Example test_hd_error1 : hd_error [] = None.
Proof. reflexivity. Qed.

Example test_hd_error2 : hd_error [1] = Some 1.
Proof. reflexivity. Qed.

Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. reflexivity. Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  intros.
  destruct l.
  - reflexivity.
  - reflexivity.
Qed.

End NatList.

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id (i j: id) :=
  match i, j with
  | Id x, Id y => beq_nat x y
  end.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  intros.
  destruct x as [x'].
  simpl. rewrite <- beq_nat_refl.
  reflexivity.
Qed.

Module PartialMap.
Export NatList.

Inductive partial_map : Type :=
  | empty : partial_map
  | record : id -> nat -> partial_map -> partial_map.

Definition update (d:partial_map) (x:id) (val:nat) :=
  record x val d.

Fixpoint find (x:id) (d:partial_map) : natoption :=
  match d with
  | empty => None
  | record k v d' => if beq_id x k then Some v
                                    else find x d'
  end.

Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
  intros.
  simpl. rewrite <- beq_id_refl. reflexivity.
Qed.

Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    beq_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros.
  simpl. rewrite -> H. reflexivity.
Qed.

End PartialMap.


(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library defines the type [ord] of tree ordinals.
   This formalisation of tree ordinals is based on notes by Peter Hancock:
     (Ordinal-theoretic) Proof Theory.
     Course notes from Midlands Graduate School, 2008.
     % \url{http://personal.cis.strath.ac.uk/~ph/} %
     # http://personal.cis.strath.ac.uk/~ph/ #
     % http://events.cs.bham.ac.uk/mgs2008/notes/proofTheory.pdf %
     # http://events.cs.bham.ac.uk/mgs2008/notes/proofTheory.pdf #
  See also the formalisation in Isabelle by Michael Compton:
  % http://www4.informatik.tu-muenchen.de/~isabelle/html-data/library/HOL/Induct/Tree.html %
  # http://www4.informatik.tu-muenchen.de/~isabelle/html-data/library/HOL/Induct/Tree.html #
*)

Set Implicit Arguments.

Require Import Coq.Init.Specif.
Require Import Coq.Logic.Classical.

Delimit Scope ord_scope with ord.
Open Scope ord_scope.

(** Inductive type for tree ordinals. *)
Inductive ord : Set :=
  | Zero  : ord
  | Succ  : ord -> ord
  | Limit : (nat -> ord) -> ord.

(** The intuition is that the [Limit] constructor represents the least
   upper bound of its argument sequence.
   We might like to exclude sequences such as (4,4,4,...), since they would
   not necessarily represent a limit ordinal. A way to do this is by
   imposing a monotonicity property on the [Limit] arguments. We first
   define an ordering on [ord] and, using that, define a subset of [ord]
   where the [Limit] arguments are monotone (in library [WfOrdinal]). *)

(** Type of predecessor indices of an ordinal. *)
Fixpoint pd_type (alpha : ord) : Set :=
  match alpha with
  | Zero       => False
  | Succ alpha => (unit + pd_type alpha) % type
  | Limit f    => { n : nat & pd_type (f n) }
  end.

Reserved Notation "alpha [ i ]" (at level 60).

(** Predecessor indices of an ordinal are essentially the paths on its tree
   structure starting from the root that cross at least one [Succ]
   constructor. *)

(** Predecessor of an ordinal for a given predecessor index. *)
Fixpoint pd (alpha : ord) : pd_type alpha -> ord :=
  match alpha with
  | Zero       => False_rect _
  | Succ alpha => fun i => match i with
                           | inl tt => alpha
                           | inr t  => alpha[t]
                           end
  | Limit f    => fun i => match i with
                           | existT _ n t => (f n)[t]
                           end
  end
where "alpha [ i ]" := (pd alpha i) : ord_scope.

(** [pd_type] and [pd] can be seen as defining a 'subtree' partial order on
   [ord]. We use it to define an extensional non-strict order on [ord]. *)

(** Non-strict order on [ord]. *)
Inductive ord_le : ord -> ord -> Prop :=
  | Ord_le_Zero  : forall beta,
                      Zero <= beta
  | Ord_le_Succ  : forall alpha beta i,
                      alpha <= beta[i] ->
                      Succ alpha <= beta
  | Ord_le_Limit : forall f beta,
                      (forall n, f n <= beta) ->
                      Limit f <= beta
where "alpha <= beta" := (ord_le alpha beta) : ord_scope.

(** Strict order on [ord]. *)
Definition ord_lt (alpha beta : ord) := exists i, alpha <= beta[i].
Infix " < " := ord_lt : ord_scope.

(** Equality on [ord]. *)
Definition ord_eq alpha beta := alpha <= beta /\ beta <= alpha.
Infix " == " := ord_eq (no associativity, at level 75) : ord_scope.

(** We proceed with some useful lemmas about these relations. *)

(** First predecessor of a successor is the original ordinal. *)
Lemma first_pd_after_succ_id :
  forall alpha, alpha = Succ alpha [inl (pd_type alpha) tt].
Proof.
trivial.
Qed.

(** No successor ordinal <= zero. *)
Lemma ord_le_not_succ_zero :
  forall alpha, ~ Succ alpha <= Zero.
Proof.
intros alpha H.
inversion_clear H.
destruct i.
Qed.

Lemma ord_lt_not_zero :
  forall alpha, ~ (alpha < Zero)%ord.
Proof.
  intros.
  intro H.
  destruct H.
  destruct x.
Qed.

(** No double successor <= 1. *)
Lemma ord_le_not_succ_succ_one :
  forall alpha, ~ Succ (Succ alpha) <= Succ Zero.
Proof.
intros alpha H.
inversion_clear H.
destruct i.
destruct u.
apply (@ord_le_not_succ_zero alpha).
assumption.
assumption.
Qed.

(** If alpha <= zero, alpha <= any ordinal. *)
Lemma ord_le_zero_right :
  forall alpha beta,
    alpha <= Zero ->
    alpha <= beta.
Proof.
induction alpha as [| alpha _ | f IH]; intros beta H.
constructor.
inversion_clear H.
destruct i.
inversion_clear H.
constructor.
intro n.
apply IH.
trivial.
Qed.

(** If alpha <= a predecessor of beta, alpha <= beta. *)
Lemma ord_le_pd_right :
  forall alpha beta (i : pd_type beta),
    alpha <= beta[i] ->
    alpha <= beta.
Proof.
induction alpha as [| alpha IH | f IH]; intros beta i H.
constructor.
apply Ord_le_Succ with i.
inversion H as [| a b j |].
apply IH with j.
assumption.
constructor.
intro n.
inversion_clear H.
apply IH with i.
trivial.
Qed.

(** If alpha <= beta, all predecessors of alpha <= beta. *)
Lemma ord_le_pd_left :
  forall alpha beta (i : pd_type alpha),
    alpha <= beta ->
    alpha[i] <= beta.
Proof.
intros alpha beta i H.
induction H as [| alpha beta j H IH | f beta H IH].
destruct i.
destruct i as [[] | i']; apply ord_le_pd_right with j.
apply H.
apply IH.
destruct i.
apply IH.
Qed.

(** If alpha <= beta, alpha <= the successor of beta. *)
Lemma ord_le_succ_right :
  forall alpha beta,
    alpha <= beta ->
    alpha <= Succ beta.
Proof.
induction alpha as [| alpha _ | f IH]; intros beta H.
constructor.
inversion_clear H.
apply Ord_le_Succ with (inr unit i).
assumption.
constructor.
intro n.
apply IH.
inversion_clear H.
trivial.
Qed.

(** If the successor of alpha <= beta, alpha <= beta. *)
Lemma ord_le_succ_left :
  forall alpha beta,
    Succ alpha <= beta ->
    alpha <= beta.
Proof.
intros alpha beta H.
rewrite (first_pd_after_succ_id alpha).
apply ord_le_pd_left.
assumption.
Qed.

(** If the successor of alpha <= the successor of beta, alpha <= beta. *)
Lemma ord_le_succ_elim :
  forall alpha beta,
    Succ alpha <= Succ beta ->
    alpha <= beta.
Proof.
inversion_clear 1.
destruct i as [[] |]; [| apply ord_le_pd_right with p]; assumption.
Qed.

(** If the alpha <= beta, the successor of alpha <= the successor of beta. *)
Lemma ord_le_succ_intro :
  forall alpha beta,
    alpha <= beta ->
    Succ alpha <= Succ beta.
Proof.
intros.
apply Ord_le_Succ with (inl (pd_type beta) tt).
assumption.
Qed.

(** No successor of alpha is <= alpha. *)
Lemma ord_le_not_succ :
  forall alpha, ~ Succ alpha <= alpha.
Proof.
induction alpha as [| alpha IH | f IH]; intro H.
apply ord_le_not_succ_zero with Zero.
assumption.
apply IH.
exact (ord_le_succ_elim H).
inversion_clear H as [| a b i H' |].
inversion_clear H' as [| | a b H].
destruct i as [n i].
apply IH with n.
apply Ord_le_Succ with i.
apply H.
Qed.

(** If alpha <= a function value, alpha <= the limit of that function.
   Suggested by Bruno Barras. *)
Lemma ord_le_limit_right :
  forall alpha f n,
    alpha <= f n ->
    alpha <= Limit f.
Proof.
induction alpha as [| alpha _ | f IH]; intros g n H.
constructor.
inversion_clear H.
apply Ord_le_Succ with (existT (fun n => pd_type (g n)) n i).
assumption.
constructor.
intro m.
apply (IH m g n).
inversion_clear H.
trivial.
Qed.

(** If a limit <= alpha, any value value of the function <= alpha. *)
Lemma ord_le_limit_left :
  forall alpha f n,
    Limit f <= alpha ->
    f n <= alpha.
Proof.
intros alpha f n H.
inversion_clear H.
trivial.
Qed.

(** [<=] is reflexive. *)
Lemma ord_le_refl :
  forall alpha, alpha <= alpha.
Proof.
induction alpha as [| alpha IH | f IH].
constructor.
apply Ord_le_Succ with (inl (pd_type alpha) tt).
assumption.
constructor.
intro n.
apply ord_le_limit_right with n.
apply IH.
Qed.

(* Added *)
Lemma ord_lt_succ_alpha :
  forall alpha, alpha < Succ alpha.
Proof.
  intros.
  exists (inl (pd_type alpha) tt).
  apply ord_le_refl.
Qed.

(** Added *)
Lemma ord_le_limit_is_bound :
  forall (f : nat -> ord) (n : nat),
    f n <= Limit f.
Proof. intros. apply ord_le_limit_left. apply ord_le_refl. Qed.

(** [<=] is transitive. *)
Lemma ord_le_trans :
  forall alpha beta gamma,
    alpha <= beta ->
    beta <= gamma ->
    alpha <= gamma.
Proof.
intros alpha beta gamma H1.
revert gamma.
induction H1 as [| alpha beta i H IH | f beta H IH]; intros gamma H2.
constructor.
induction H2 as [| beta gamma j H' _ | f gamma H' IH'].
destruct i.
apply Ord_le_Succ with j.
apply IH.
destruct i as [[] | i']; simpl in * |- *.
assumption.
apply ord_le_pd_left.
assumption.
destruct i as [n i]; simpl in * |- *.
apply (IH' n i H IH).
constructor.
intro n.
exact (IH n gamma H2).
Qed.

(** [<=] is antisymmetric (for [==]). *)
Lemma ord_le_antisymm :
  forall alpha beta,
    alpha <= beta ->
    beta <= alpha ->
    alpha == beta.
Proof.
intros.
unfold ord_eq.
split; assumption.
Qed.

(* Added *)
(** [<=] is total *)
Lemma ord_le_ge_cases :
  forall alpha beta, alpha <= beta \/ beta <= alpha.
Proof.
  assert( ord_le_le : forall (A:Type) (R Q : A->Prop),
    (forall n, R(n) \/ Q(n)) ->
    (forall n, R(n)) \/ exists n, Q(n)).
  {
    intros.
      assert ((forall x, R x) \/ exists x, ~R x).
      {
        case (classic (exists x, ~R x)).
        - intro. right. apply H0.
        - intro. left. apply not_ex_not_all. apply H0.
      }
      case H0.
      - intro. left. apply H1.
      - intro. right. destruct H1.  exists x.
        case (H x). intro. contradiction H2. trivial.
  }
  induction alpha.
  intro. left. constructor.
  intro.
    induction beta.
    right. constructor.
    case IHbeta.
      intro. left. apply ord_le_succ_right. assumption.
      intro.
        case (IHalpha beta).
          intro H0.
            left.
            exact (ord_le_succ_intro H0).
          intro H0.
            right.
            exact (ord_le_succ_intro H0).
    assert ((forall n0 : nat, (o n0 <= Succ alpha)%ord) \/ (exists n0, (Succ alpha <= o n0)%ord)).
    {
      apply ord_le_le. intro.
      case (H n); intro. right; assumption.
      left; assumption.
    }
    case (H0).
      intro. right. constructor. assumption.
      intro. destruct H1. left. apply ord_le_trans with (o x). assumption.
      apply ord_le_limit_is_bound.
  intro.
    assert ((forall (n : nat), (o n <= beta)%ord) \/ (exists n, (beta <= o n)%ord)). {
      apply ord_le_le.
      intro n.
      apply (H n beta).
    }
    case H0.
      intro. left. constructor. assumption.
      intro. destruct H1. right.
      apply ord_le_trans with (o x).
      assumption.
      apply ord_le_limit_is_bound.
Qed.

(** [==] is reflexive. *)
Lemma ord_eq_refl :
  forall alpha, alpha == alpha.
Proof.
split; apply ord_le_refl.
Qed.

(** [==] is symmetric. *)
Lemma ord_eq_symm :
  forall alpha beta,
    alpha == beta ->
    beta == alpha.
Proof.
split; apply H.
Qed.

(** [==] is transitive. *)
Lemma ord_eq_trans :
  forall alpha beta gamma,
    alpha == beta ->
    beta == gamma ->
    alpha == gamma.
Proof.
destruct 1.
destruct 1.
split; apply ord_le_trans with beta; assumption.
Qed.

(** Not zero < zero. *)
Lemma ord_lt_zero_zero :
  ~ Zero < Zero.
Proof.
intro H.
destruct H as [i H].
elim i.
Qed.

(** If alpha <= beta, not beta <= a predecessor of alpha. *)
Lemma ord_le_not_pd_right :
  forall alpha beta i,
    alpha <= beta ->
    ~ beta <= alpha[i].
Proof.
induction alpha as [| alpha IH | f IH]; intros beta i H1 H2.
destruct i.
destruct i.
destruct u.
apply ord_le_not_succ with alpha.
apply ord_le_trans with beta; assumption.
exact (IH beta p (ord_le_succ_left H1) H2).
destruct i.
inversion_clear H1.
exact (IH x beta p (H x) H2).
Qed.

(** Not alpha <= a predecessor of alpha. *)
Lemma ord_le_not_pd_right_weak :
  forall alpha i, ~ alpha <= alpha[i].
Proof.
intros.
apply ord_le_not_pd_right.
apply ord_le_refl.
Qed.

(** [<] is transitive. *)
Lemma ord_lt_trans :
  forall alpha beta gamma,
    alpha < beta ->
    beta < gamma ->
    alpha < gamma.
Proof.
intros alpha beta gamma.
destruct 1 as [i].
destruct 1 as [j].
exists j.
apply ord_le_trans with beta; [apply ord_le_pd_right with i |]; assumption.
Qed.

(** [<] is irreflexive. *)
Lemma ord_lt_irrefl :
  forall alpha, ~ alpha < alpha.
Proof.
intros alpha H.
destruct H as [i H].
exact (ord_le_not_pd_right_weak i H).
Qed.

(** [<] is asymmetric. *)
Lemma ord_lt_asymm :
  forall alpha beta,
    alpha < beta ->
    ~ beta < alpha.
Proof.
intros alpha beta H1 H2.
destruct H1 as [i H1].
destruct H2 as [j H2].
apply (@ord_le_not_pd_right alpha beta j);
  [apply ord_le_pd_right with i |]; assumption.
Qed.

(** [pd_type] is closed under transitivity. *)
Lemma pd_trans :
  forall alpha i j,
    exists k, pd alpha k = pd (pd alpha i) j.
Proof.
induction alpha as [| alpha IH | f IH]; intros.
elim i.
destruct i as [[] | i]; simpl in j |- *.
exists (inr _ j).
reflexivity.
destruct (IH i j) as [k H].
exists (inr _ k).
assumption.
destruct i as [n i]; simpl in j |- *.
destruct (IH n i j) as [k H].
exists (existT (fun n => pd_type (f n)) n k).
assumption.
Qed.

(** If the successor of alpha < beta, alpha < beta. *)
Lemma ord_lt_succ_left :
  forall alpha beta,
    Succ alpha < beta ->
    alpha < beta.
Proof.
intros alpha beta.
destruct 1 as [i H].
exists i.
apply ord_le_succ_left.
assumption.
Qed.

(** If alpha < beta, alpha < the successor of beta. *)
Lemma ord_lt_succ_right :
  forall alpha beta,
    alpha < beta ->
    alpha < Succ beta.
Proof.
intros alpha beta.
destruct 1 as [i H].
exists (inl (pd_type beta) tt).
apply ord_le_pd_right with i.
assumption.
Qed.

(** Added *)
Lemma ord_lt_le_succ_right :
  forall alpha beta,
    alpha < beta ->
    Succ alpha <= beta.
Proof.
    intros alpha beta H.
    destruct H as [i H].
    apply Ord_le_Succ with i.
    assumption.
Qed.

(** Added *)
Lemma ord_lt_limit_left :
  forall alpha f n,
    Limit f < alpha ->
    f n < alpha.
Proof.
intros alpha ff n H1.
destruct H1.
exists x.
apply ord_le_limit_left. trivial.
Qed.

(** If alpha < beta, alpha <= beta. *)
Lemma ord_lt_ord_le :
  forall alpha beta, alpha < beta -> alpha <= beta.
Proof.
intros alpha beta.
destruct 1 as [i H].
apply ord_le_pd_right with i.
assumption.
Qed.

(** If alpha < beta, the successor of alpha <= beta. *)
Lemma ord_lt_ord_le_succ :
  forall alpha beta,
    alpha < beta ->
    Succ alpha <= beta.
Proof.
intros alpha beta.
destruct 1 as [i H].
apply Ord_le_Succ with i.
assumption.
Qed.

(** If alpha < beta, not beta <= alpha. *)
Lemma ord_lt_not_ord_le :
  forall alpha beta,
    alpha < beta ->
    ~ beta <= alpha.
Proof.
intros alpha beta H1 H2.
destruct H1 as [i H1].
apply (@ord_le_not_pd_right beta alpha i); assumption.
Qed.

(** If alpha <= a predecessor of the successor of beta, alpha <= beta. *)
Lemma ord_le_succ_pd_right :
  forall alpha beta i,
    alpha <= Succ beta [i] ->
    alpha <= beta.
Proof.
(* This is a messy proof *)
induction alpha; intros.
simpl in H.
destruct i.
destruct u.
assumption.
apply Ord_le_Zero.
destruct beta.
destruct i.
destruct u.
destruct (ord_le_not_succ_zero H).
destruct p.
apply Ord_le_Succ with (inl (pd_type beta) tt).
simpl.
simpl in H.
destruct i.
destruct u.
apply ord_le_succ_elim.
assumption.
destruct p.
apply ord_le_succ_left.
destruct u.
assumption.
apply ord_le_succ_left.
apply ord_le_pd_right with p.
assumption.
simpl in H.
destruct i.
destruct u.
assumption.
destruct p.
apply ord_le_limit_right with x.
apply ord_le_pd_right with p.
assumption.
apply Ord_le_Limit.
intro.
inversion_clear H0.
apply H with i.
apply H1.
Qed.

(** Added *)
Lemma ord_le_lt_trans : forall alpha beta gamma,
      alpha <= beta  ->
      beta < gamma ->
      alpha < gamma.
Proof.
intros alpha beta gamma.
intros H1 H2.
destruct H2 as [i H3].
exists i.
apply ord_le_trans with (beta) ; assumption.
Qed.

(** Added *)
Lemma ord_lt_le_trans : forall alpha beta gamma,
      alpha < beta  ->
      beta <= gamma ->
      alpha < gamma.
Proof.
intros alpha beta gamma H1 H2.
induction H2.
- destruct H1. destruct x.
- exists i. apply ord_le_trans with (alpha0). destruct H1.
  apply ord_le_succ_pd_right with (x); assumption. assumption.
- destruct H1. destruct x. apply H0 with (n:=x). exists p. apply H1.
Qed.

(** Added *)
Lemma ord_lt_limit_right :
  forall alpha f n,
    alpha < f n ->
    alpha < Limit f.
Proof.
intros.
apply ord_lt_le_trans with (beta:=(f n)).
assumption.
apply ord_le_limit_is_bound.
Qed.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.

Instance ord_eq_wd : Equivalence (ord_eq).
split.
  - unfold Reflexive. apply ord_eq_refl.
  - unfold Symmetric. apply ord_eq_symm.
  - unfold Transitive. apply ord_eq_trans.
Qed.

Instance ord_le_wd : Proper (ord_eq==>ord_eq==>iff) ord_le.
Proof.
reduce.
split.
- intro H2. apply ord_le_trans with (x). apply H.
  apply ord_le_trans with (x0). apply H2. apply H0.
- intro H2. apply ord_le_trans with (y). apply H.
  apply ord_le_trans with (y0). apply H2. apply H0.
Qed.

Instance ord_lt_wd : Proper (ord_eq==>ord_eq==>iff) ord_lt.
Proof.
reduce.
destruct H. destruct H0.
split.
- intro. apply ord_lt_le_trans with (x0); try apply ord_le_lt_trans with (x); assumption.
- intro. apply ord_lt_le_trans with (y0); try apply ord_le_lt_trans with (y); assumption.
Qed.

(** Ordinal arithmetic. *)

Fixpoint add (alpha beta : ord) : ord :=
  match beta with
  | Zero      => alpha
  | Succ beta => Succ (add alpha beta)
  | Limit f   => Limit (fun o => add alpha (f o))
  end.

Fixpoint mul (alpha beta : ord) : ord :=
  match beta with
  | Zero      => Zero
  | Succ beta => add (mul alpha beta) alpha
  | Limit f   => Limit (fun o => mul alpha (f o))
  end.

Fixpoint exp (alpha beta : ord) : ord :=
  match beta with
  | Zero      => Succ Zero
  | Succ beta => mul (exp alpha beta) alpha
  | Limit f   => Limit (fun o => exp alpha (f o))
  end.

Lemma ord_le_add_right :
  forall alpha beta,
    alpha <= add alpha beta.
Proof.
intros alpha beta.
induction beta as [| beta IH | f IH].
apply ord_le_refl.
apply ord_le_succ_right.
exact IH.
apply ord_le_limit_right with 0.
apply IH.
Qed.

Lemma ord_le_add :
  forall alpha beta gamma,
    beta <= gamma ->
    add alpha beta <= add alpha gamma.
Proof.
intros alpha beta gamma H.
induction H as [gamma | beta gamma i H IH | f gamma H IH].
apply ord_le_add_right.
induction gamma as [| gamma IHg | f IHg]; simpl.
elim i.
destruct i as [[] | i].
apply Ord_le_Succ with (inl (pd_type (add alpha gamma)) tt).
apply IH.
apply ord_le_succ_right.
apply IHg with i; assumption.
destruct i as [n i].
apply ord_le_limit_right with n.
apply IHg with i; assumption.
constructor.
intro n.
apply IH.
Qed.

Lemma ord_lt_add :
  forall alpha beta gamma,
    beta < gamma ->
    add alpha beta < add alpha gamma.
Proof.
intros alpha beta gamma H.
unfold ord_lt; destruct H as [i H].
induction gamma as [| gamma _ | f IH]; simpl.
destruct i.
exists (inl _ tt); simpl.
apply ord_le_add.
destruct i as [[] | i].
assumption.
apply ord_le_pd_right with i.
assumption.
destruct i as [n i].
specialize IH with n i.
destruct IH as [j IH].
assumption.
exists (existT (fun n => pd_type (add alpha (f n))) n j).
assumption.
Qed.

(** The natural numbers can be coerced into finite ordinals. *)

Fixpoint nat_as_ord (n : nat) : ord :=
  match n with
  | O   => Zero
  | S n => Succ (nat_as_ord n)
  end.

Coercion nat_as_ord : nat >-> ord.

(** The smallest infinite ordinal is the limit of the natural numbers. *)
Definition omega := Limit (fun n => n).

(** We show that [<=] and [<] on ordinals are the same as [<=] and [<] on
   natural numbers. *)

Require Import Le.

Lemma le_implies_ord_le : forall n m, (n <= m)%nat -> n <= m.
Proof.
induction n as [| n IH]; intros m H.
constructor.
destruct m as [| m].
contradiction le_Sn_0 with n.
apply ord_le_succ_intro.
apply IH.
apply le_S_n.
assumption.
Qed.

Lemma ord_le_implies_le : forall (n m : nat), n <= m -> (n <= m)%nat.
Proof.
induction n as [| n IH]; intros m H.
apply le_0_n.
destruct m as [| m].
contradiction ord_le_not_succ_zero with n.
apply le_n_S.
apply IH.
apply ord_le_succ_elim.
assumption.
Qed.

Lemma ord_le_le : forall n m, (n <= m)%nat <-> n <= m.
Proof.
split.
apply le_implies_ord_le.
apply ord_le_implies_le.
Qed.

Require Import Lt.

Lemma lt_implies_ord_lt : forall n m, (n < m)%nat -> n < m.
Proof.
induction n as [| n IH]; intros m H.
destruct H; exists (inl _ tt); constructor.
destruct m as [| m].
contradiction lt_n_O with (S n).
exists (inl _ tt).
apply ord_lt_ord_le_succ; simpl.
apply IH.
apply lt_S_n.
assumption.
Qed.

Lemma ord_lt_implies_lt : forall (n m : nat), n < m -> (n < m)%nat.
Proof.
induction n as [| n IH]; intros m H.
destruct H as [i H].
destruct m as [| m].
elim i.
apply lt_0_Sn.
destruct H as [i H].
destruct m as [| m].
elim i.
apply lt_n_S.
apply IH.
(* this can be cleaned up *)
destruct m as [| m].
destruct i as [[] | []].
contradiction ord_le_not_succ_zero with n.
exists (inl _ tt).
destruct i as [[] | [[] | i]].
apply ord_le_succ_elim.
assumption.
apply ord_le_succ_left.
assumption.
apply ord_le_succ_left.
apply ord_le_pd_right with i.
assumption.
Qed.

Lemma ord_lt_lt : forall n m, (n < m)%nat <-> n < m.
Proof.
split.
apply lt_implies_ord_lt.
apply ord_lt_implies_lt.
Qed.

(** We now prove two simple facts about our equality [==] containing
   different representations of omega. *)

Lemma fact_a :
  Limit (fun n => S n) == omega.
Proof.
split; constructor; intro n.
apply Ord_le_Succ with (existT (fun n:nat => pd_type n) (S n) (inl _ tt)).
apply ord_le_refl.
destruct n as [| n].
constructor.
apply Ord_le_Succ with (existT (fun n:nat => pd_type (S n)) n (inl _ tt)).
apply ord_le_refl.
Qed.

Lemma fact_b :
  Limit (fun n => n * 2) == omega.
Proof.
split; constructor; intro n.
destruct n as [| n]; simpl.
constructor.
apply Ord_le_Succ with (existT (fun n:nat => pd_type n) (S (S (n * 2))) (inl _ tt)).
apply ord_le_refl.
destruct n as [| n].
constructor.
apply Ord_le_Succ with (existT (fun n:nat => pd_type (n * 2)) (S n) (inl _ tt)).
simpl.
induction n as [| n IH]; simpl.
constructor.
apply ord_le_succ_right.
apply ord_le_succ_intro.
exact IH.
Qed.

(** A weak inversion property of ordinals equal to omega. *)
Lemma ord_eq_omega_discriminate :
  forall alpha,
    alpha == omega ->
    exists f, alpha = Limit f.
Proof.
intros [| alpha | f] [H1 H2].
inversion_clear H2.
contradict (ord_le_not_succ_zero (H 1)).
inversion_clear H1.
inversion_clear H2.
destruct i as [n i].
contradict (ord_le_not_pd_right i (ord_le_succ_elim (H0 (S n))) H).
exists f; reflexivity.
Qed.

Close Scope ord_scope.


Require Export Induction.
Module NatList.

  Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

  Check pair 3 5.

  Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.
Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.
Compute (fst (pair 3 5)).
(* ===> 3 *)

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

Definition fst' (p : natprod) : nat :=
  match p with
  | (x,y) => x
  end.
Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) => y
  end.
Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  (*simpl.*)
  reflexivity. Qed.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  simpl. (* Doesn't reduce anything! *)
Abort.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p. destruct p as [n m]. simpl. reflexivity. Qed.

(*Exercise: 1 star (snd_fst_is_swap)*)
Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as [n m].
  simpl.
  reflexivity.
Qed.

(**Exercise: 1 star, optional (fst_swap_is_snd)*)
Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intro p.
  destruct p as [m n].
  simpl.
  reflexivity.
Qed.

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

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

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

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

Compute length mylist1.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof.  reflexivity. Qed.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity. Qed.

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.
Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.
Example test_hd1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.
Example test_hd2: hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

(**Exercise: 2 stars, recommended (list_funs)
Complete the definitions of nonzeros, oddmembers and countoddmembers below. Have a look at the tests to understand what these functions should do.*)
Fixpoint nonzeros (l:natlist) : natlist  :=
  match l with
  | nil => nil
  | h :: t => match h with
              | O => nonzeros t
              | S n => [h] ++ nonzeros t
               end
  end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
  simpl.
  reflexivity.
Qed.

Compute oddb 4. (*Tests whether a number is odd*)

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match oddb h with
             | true => [h] ++ oddmembers t
             | false => oddmembers t
             end
  end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
  simpl.
  reflexivity.
Qed.

Definition countoddmembers (l:natlist) : nat :=
  match oddmembers l with
  |nil => 0
  |h :: t => 1 + length t
  end.

Compute countoddmembers [1;0;3;1;4;5;7;2;2;5].

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
  reflexivity.
Qed.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
reflexivity.
  Qed.

Example test_countoddmembers3:
  countoddmembers nil = 0.
reflexivity.
  Qed.

(**Exercise: 3 stars, advanced (alternate)
Complete the definition of alternate, which "zips up" two lists into one, alternating between elements taken from the first list and elements from the second. See the tests below for more specific examples.
Note: one natural and elegant way of writing alternate will fail to satisfy Coq's requirement that all Fixpoint definitions be "obviously terminating." If you find yourself in this rut, look for a slightly more verbose solution that considers elements of both lists at the same time. (One possible solution requires defining a new kind of pairs, but this is not the only way.)*)

  Fixpoint alternate (l1 l2 : natlist) : natlist :=
    match l1 with
    |nil => l2
    |h :: t => match l2 with
               | nil => l1
               | a :: b => [h] ++ [a] ++ alternate t b
               end
    end.

Compute alternate [] [20;30].

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
simpl.
reflexivity.
Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
simpl.
reflexivity.
  Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
simpl.
reflexivity.
  Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
simpl.
reflexivity.
  Qed.

  Definition bag := natlist.

  (**Exercise: 3 stars, recommended (bag_functions)
Complete the following definitions for the functions count, sum, add, and member for bags.*)
(**Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t => if beq_nat v h then 1 + count v t else count v t
  end.*)

  Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t => match beq_nat h v with
              | true => 1 + count v t
              | false => count v t
              end
  end.

Compute count 1 [1;2;3;1;4;1].
Example test_count1: count 1 [1;2;3;1;4;1] = 3.
simpl.
reflexivity.
  Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
simpl.
reflexivity.
  Qed.

  Definition sum : bag -> bag -> bag :=
    app. (*or alternate*)

   Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
   simpl.
   reflexivity.
   Qed.

  (**Another way of implementing sum using anonymouys function*)
(** Definition sum : bag -> bag -> bag :=
    fun x y =>
      match x,y with
      | [], y => y
      | x, [] => x
      | x, y => x ++ y
      end.*)

  Definition add (v:nat) (s:bag) : bag :=
    match s with
    | nil => [v]
    | h :: t => [v] ++ s
  end.

  Compute add 1 [1;4;1].

  Example test_add1: count 1 (add 1 [1;4;1]) = 3.
  simpl.
  reflexivity.
  Qed.

  Example test_add2: count 5 (add 1 [1;4;1]) = 0.
  simpl.
  reflexivity.
  Qed.

  Definition member (v:nat) (s:bag) : bool :=
    match count v s with
    | 0 => false
    | _ => true
    end.

  (**Fixpoint member (v:nat) (s:bag) : bool :=
    match s with
    | nil => false
    | h :: t => if beq_nat h v then true else member  v t
    end.*)

  Example test_member1: member 1 [1;4;1] = true.
  simpl.
  reflexivity.
  Qed.

  Example test_member2: member 2 [1;4;1] = false.
  simpl.
  reflexivity.
  Qed.

  Fixpoint remove_one (v:nat) (s:bag) : bag :=
    match s with
    | nil => nil
    | h :: t => if beq_nat h v then t else [h] ++ remove_one v t
    end.

  Compute remove_one 2 [2;3;5;3;2;7].

  Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
  simpl.
  reflexivity.
  Qed.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
simpl.
reflexivity.
Qed.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
simpl.
reflexivity.
  Qed.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
simpl.
reflexivity.
  Qed.

  Fixpoint remove_all (v:nat) (s:bag) : bag :=
    match s with
    | nil => nil
    | h :: t => if beq_nat h v then remove_all v t else [h] ++ remove_all v t
    end.

  Compute remove_all 5 [5;5;5;2;7;2;1;5;4;5;1;5;4].

  Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
  simpl.
  reflexivity.
  Qed.

  Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
  simpl.
  reflexivity.
  Qed.

Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
simpl.
reflexivity.
  Qed.

Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
simpl.
  reflexivity.
  Qed.

  Fixpoint subset (s1:bag) (s2:bag) : bool :=
    match s1, s2 with
    | nil, _ => true (**nil is subset of anything*)
    | _, nil => false (**nothing is subset of nil*)
    | h :: t, s2 => if member h s2 then subset t (remove_one h s2) else false
    end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
simpl.
reflexivity.
  Qed.

Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
simpl.
reflexivity.
  Qed.

  (**my theorem*)
Theorem bag_theorem : forall (l: bag) (x: nat), length( add (count x l) l ) = length (add x l).
Proof.
  intros l x.
  induction l.
  -
    simpl.
    reflexivity.
  -
    simpl.
    reflexivity.
Qed.

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. simpl. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - (* l = nil *)
    simpl.
    reflexivity.
  - (* l = cons n l' *)
    simpl.
    reflexivity. Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    simpl.
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity. Qed.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.
Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. simpl. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. simpl. reflexivity. Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l =  *)
    simpl.
    reflexivity.
  - (* l = n :: l' *)
    (* This is the tricky case.  Let's begin as usual
       by simplifying. *)
    simpl.
    (* Now we seem to be stuck: the goal is an equality
       involving ++, but we don't have any useful equations
       in either the immediate context or in the global
       environment!  We can make a little progress by using
       the IH to rewrite the goal... *)
    rewrite <- IHl'.
    (* ... but now we can't go any further. *)
Abort.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  (* WORKED IN CLASS *)
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    simpl.
    reflexivity.
  - (* l1 = cons *)
    simpl. rewrite -> IHl1'. reflexivity. Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons *)
    simpl. rewrite -> app_length, plus_comm.
    simpl. rewrite -> IHl'. reflexivity. Qed.

Search rev.

(**List Exercises, Part 1*)
Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l.
  induction l as [| n l' IHl].
  -
    simpl.
    reflexivity.
  -
    simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2.
  induction l1 as [| n l IHl].
  -
    simpl.
    rewrite -> app_nil_r.
    reflexivity.
  -
    simpl.
    rewrite -> IHl.
    Search app.
    rewrite -> app_assoc.
    reflexivity.
Qed.

Search app.

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

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  induction l1 as [|n l' IHl].
  -
    simpl.
    rewrite -> app_assoc.
    reflexivity.
  -
    simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  induction l1 as [|n l' IHl].
  -
    simpl.
    reflexivity.
  -
    Search nonzeros.
    induction n.
    +
      simpl.
      rewrite -> IHl.
      reflexivity.
    +
      simpl.
      rewrite IHl.
      reflexivity.
Qed.

Search count.

(**Auxiliar Fixpoint for Definition member_nat*)
Fixpoint count_nat (v:nat) (s:natlist) : nat :=
  match s with
  | nil => 0
  | h :: t => if beq_nat v h then 1 + count_nat v t else count_nat v t
  end.

(**Auxiliar Definition for Fixpoint beq_natlist*)
Definition member_nat (v:nat) (s:natlist) : bool :=
      match count_nat v s with
    | 0 => false
    | _ => true
    end.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | nil, nil => true
  | nil, _ => false
  | _, nil => false
  | h::t, d::l =>  if beq_nat h d then beq_natlist t l else false
  end.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
simpl.
reflexivity.
  Qed.

  Example test_beq_natlist2 :
    beq_natlist [1;2;3] [1;2;3] = true.
  simpl.
  reflexivity.
  Qed.

  Example test_beq_natlist3 :
    beq_natlist [1;2;3] [1;2;4] = false.
  simpl.
  reflexivity.
  Qed.

  Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intro l.
  induction l as [|n].
  -
    simpl.
    reflexivity.
  -
    rewrite -> IHl.
    induction n.
    +
      simpl.
      reflexivity.
    +
      rewrite -> IHn.
      reflexivity.
Qed.

Theorem count_member_nonzero : forall (s : bag),
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  intro l.
  induction l as [|n IHl].
  -
    simpl.
    reflexivity.
  -
    simpl.
    reflexivity.
Qed.

(**The following lemma about leb might help you in the next exercise.*)
Theorem ble_n_Sn : forall n,
  leb n (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl. reflexivity.
  - (* S n' *)
    simpl. rewrite IHn'. reflexivity. Qed.

(**Exercise: 3 stars, advanced (remove_does_not_increase_count)*)
Theorem remove_does_not_increase_count: forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s.
  induction s as [|n].
  -
    simpl.
    reflexivity.
  -
    rewrite <- IHs.
    induction n.
    +
      simpl.
      rewrite -> ble_n_Sn.
      rewrite -> IHs.
      reflexivity.
    +
      simpl.
      reflexivity.
Qed.

Theorem bag_count_sum : forall (n : nat) (s : bag), leb (count n s) (count n (sum [n] s)) = true.
Proof.
  intros n s.
  induction n.
  -
    simpl.
    rewrite -> ble_n_Sn.
    reflexivity.
  -
    simpl.
    rewrite <- beq_nat_refl.
    rewrite -> ble_n_Sn.
    reflexivity.
Qed.

Require Import Setoid.

  Theorem rev_injective : forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2 H.
  rewrite <- rev_involutive at 1.
  rewrite H.
  rewrite rev_involutive.
  reflexivity.
Qed.

  Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
  match l with
  | nil => 42 (* arbitrary! *)
  | a :: l' => match beq_nat n O with
               | true => a
               | false => nth_bad l' (pred n)
               end
  end.

  Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

  Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.

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

Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error' l' (pred n)
  end.

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

Definition hd_error (l : natlist) : natoption :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

Example test_hd_error1 : hd_error [] = None.
simpl.
reflexivity.
Qed.

Example test_hd_error2 : hd_error [1] = Some 1.
simpl.
reflexivity.
Qed.

Example test_hd_error3 : hd_error [5;6] = Some 5.
simpl.
reflexivity.
Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  intros l default.
  induction l as [|head].
  -
    simpl.
    reflexivity.
  -
    simpl.
    reflexivity.
Qed.

End NatList.

Inductive id : Type :=
| Id : nat -> id.

Definition beq_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  intro x.
  induction x.
  -
    simpl.
    induction n.
    +
      simpl.
      reflexivity.
    +
      simpl.
      rewrite <- IHn.
      reflexivity.
Qed.

Module PartialMap.
Export NatList.
Inductive partial_map : Type :=
  | empty : partial_map
  | record : id -> nat -> partial_map -> partial_map.

Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty => None
  | record y v d' => if beq_id x y
                     then Some v
                     else find x d'
  end.

Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
  intros d x v.
  induction d.
  -
    simpl.
    rewrite <- beq_id_refl.
    reflexivity.
  -
    simpl.
    rewrite <- beq_id_refl.
    reflexivity.
Qed.

Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    beq_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros d x y o.
  intro Hxy.
  induction d.
  -
    simpl.
    rewrite -> Hxy.
    reflexivity.
  -
    simpl.
    rewrite -> Hxy.
    reflexivity.
Qed.
End PartialMap.


Theorem bool_cases : forall b:bool, b = true \/ b = false.
Proof
  bool_ind (fun b:bool => b = true \/ b = false)
    (or_introl _ (refl_equal true)) (or_intror _ (refl_equal false)).

Theorem bool_cases' : forall b:bool, b = true \/ b = false.
Proof.
 intro b; pattern b; apply bool_ind; [ left | right ]; reflexivity.
Qed.

(** version with destruct :
*)
Theorem bool_cases'' : forall b:bool, b = true \/ b = false.
Proof.
 destruct b;[left | right]; reflexivity.
Qed.


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

(* * Shared libraries *)

(* ** Finitary sums and products over monoids *)

Require Import List Arith ZArith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list binomial.

Set Implicit Arguments.

Record monoid_theory (X : Type) (m : X -> X -> X) (u : X) := mk_monoid {
  monoid_unit_l : forall x, m u x = x;
  monoid_unit_r : forall x, m x u = x;
  monoid_assoc  : forall x y z, m x (m y z) = m (m x y) z;
}.

Fact Nat_plus_monoid : monoid_theory plus 0.
Proof. exists; intros; ring. Qed.

Fact Nat_mult_monoid : monoid_theory mult 1.
Proof. exists; intros; ring. Qed.

Fact Zplus_monoid : monoid_theory Zplus 0%Z.
Proof. exists; intros; ring. Qed.

Fact Zmult_monoid : monoid_theory Zmult 1%Z.
Proof. exists; intros; ring. Qed.

#[export] Hint Resolve Nat_plus_monoid Nat_mult_monoid
             Zplus_monoid Zmult_monoid : core.

Section msum.

  Variable (X : Type) (m : X -> X -> X) (u : X).

  Infix "⊕" := m (at level 50, left associativity).

  Fixpoint msum n f :=
    match n with
      | 0   => u
      | S n => f 0 ⊕ msum n (fun n => f (S n))
    end.

  Notation "∑" := msum.

  Fact msum_fold_map n f : ∑ n f = fold_right m u (map f (list_an 0 n)).
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; f_equal; auto.
    rewrite IHn, <-  map_S_list_an, map_map; auto.
  Qed.

  Fact msum_0 f : ∑ 0 f = u.
  Proof. auto. Qed.

  Fact msum_S n f : ∑ (S n) f = f 0 ⊕ ∑ n (fun n => f (S n)).
  Proof. auto. Qed.

  Hypothesis Hmonoid : monoid_theory m u.

  Fact msum_1 f : ∑ 1 f = f 0.
  Proof.
    destruct Hmonoid as [ H1 H2 ].
    rewrite msum_S, msum_0, H2; auto.
  Qed.

  Fact msum_plus a b f : ∑ (a+b) f = ∑ a f ⊕ ∑ b (fun i => f (a+i)).
  Proof.
    destruct Hmonoid as [ H1 _ H3 ].
    revert f; induction a as [ | a IHa ]; intros f; simpl; auto.
    rewrite <- H3; f_equal; apply IHa.
  Qed.

  Fact msum_plus1 n f : ∑ (S n) f = ∑ n f ⊕ f n.
  Proof.
    destruct Hmonoid as [ _ H2 _ ].
    replace (S n) with (n+1) by lia.
    rewrite msum_plus; simpl; f_equal.
    rewrite H2; f_equal; lia.
  Qed.

  Fact msum_ext n f g : (forall i, i < n -> f i = g i) -> ∑ n f = ∑ n g.
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g Hfg; simpl; f_equal; auto.
    + apply Hfg; lia.
    + apply IHn; intros; apply Hfg; lia.
  Qed.

  Fact msum_unit n : ∑ n (fun _ => u) = u.
  Proof.
    destruct Hmonoid as [ H1 _ _ ].
    induction n as [ | n IHn ]; simpl; auto.
    rewrite IHn; auto.
  Qed.

  Fact msum_comm a n f : (forall i, i < n -> f i ⊕ a = a ⊕ f i) -> ∑ n f ⊕ a = a ⊕ ∑ n f.
  Proof.
    destruct Hmonoid as [ H1 H2 H3 ].
    revert f; induction n as [ | n IHn ]; intros f H; simpl; auto.
    + rewrite H1, H2; auto.
    + rewrite H3, <- H; try lia.
      repeat rewrite <- H3; f_equal.
      apply IHn.
      intros; apply H; lia.
  Qed.

  Fact msum_sum n f g : (forall i j, i < j < n -> f j ⊕ g i = g i ⊕ f j) -> ∑ n (fun i => f i ⊕ g i) = ∑ n f ⊕ ∑ n g.
  Proof.
    destruct Hmonoid as [ H1 H2 H3 ].
    revert f g; induction n as [ | n IHn ]; intros f g H; simpl; auto.
    rewrite IHn.
    + repeat rewrite <- H3; f_equal.
      repeat rewrite H3; f_equal.
      symmetry; apply msum_comm.
      intros; apply H; lia.
    + intros; apply H; lia.
  Qed.

  Fact msum_of_unit n f : (forall i, i < n -> f i = u) -> ∑ n f = u.
  Proof.
    intros H.
    rewrite <- (msum_unit n).
    apply msum_ext; auto.
  Qed.

  Fact msum_only_one n f i : i < n
                          -> (forall j, j < n -> i <> j -> f j = u)
                          -> ∑ n f = f i.
  Proof.
    destruct Hmonoid as [ M1 M2 M3 ].
    intros H1 H2.
    replace n with (i + 1 + (n-i-1)) by lia.
    do 2 rewrite msum_plus.
    rewrite msum_of_unit, msum_1, msum_of_unit, M1, M2.
    + f_equal; lia.
    + intros j Hj; destruct (H2 (i+1+j)); auto; lia.
    + intros j Hj; destruct (H2 j); auto; lia.
  Qed.

  Fact msum_msum n k f :
          (forall i1 j1 i2 j2, i1 < n -> j1 < k -> i2 < n -> j2 < k -> f i1 j1 ⊕ f i2 j2 = f i2 j2 ⊕ f i1 j1)
       -> ∑ n (fun i => ∑ k (f i)) = ∑ k (fun j => ∑ n (fun i => f i j)).
  Proof.
    revert k f; induction n as [ | n IHn ]; intros k f Hf.
    + rewrite msum_0, msum_of_unit; auto.
    + rewrite msum_S, IHn.
      * rewrite <- msum_sum.
        - apply msum_ext.
          intros; rewrite msum_S; trivial.
        - intros; symmetry; apply msum_comm.
          intros; apply Hf; lia.
      * intros; apply Hf; lia.
  Qed.

  Fact msum_ends n f : (forall i, 0 < i <= n -> f i = u) -> ∑ (n+2) f = f 0 ⊕ f (S n).
  Proof.
    destruct Hmonoid as [ H1 H2 H3 ].
    intros H.
    replace (n+2) with (1 + n + 1) by lia.
    do 2 rewrite msum_plus; simpl.
    rewrite msum_of_unit.
    + rewrite H2, H2, H2; do 2 f_equal; lia.
    + intros; apply H; lia.
  Qed.

  Fact msum_first_two n f : 2 <= n -> (forall i, 2 <= i -> f i = u) -> ∑ n f = f 0 ⊕ f 1.
  Proof.
    destruct Hmonoid as [ _ M2 _ ].
    intros Hn H1.
    destruct n as [ | [ | n ] ]; try lia.
    do 2 rewrite msum_S.
    rewrite msum_of_unit.
    + rewrite M2; trivial.
    + intros; apply H1; lia.
  Qed.

  Definition mscal n x := msum n (fun _ => x).

  Fact mscal_0 x : mscal 0 x = u.
  Proof. apply msum_0. Qed.

  Fact mscal_S n x : mscal (S n) x = x ⊕ mscal n x.
  Proof. apply msum_S. Qed.

  Fact mscal_1 x : mscal 1 x = x.
  Proof.
    destruct Hmonoid as [ _ H2 _ ].
    rewrite mscal_S, mscal_0, H2; trivial.
  Qed.

  Fact mscal_of_unit n : mscal n u = u.
  Proof. apply msum_of_unit; auto. Qed.

  Fact mscal_plus a b x : mscal (a+b) x = mscal a x ⊕ mscal b x.
  Proof. apply msum_plus. Qed.

  Fact mscal_plus1 n x : mscal (S n) x = mscal n x ⊕ x.
  Proof. apply msum_plus1. Qed.

  Fact mscal_comm n x y : x ⊕ y = y ⊕ x -> mscal n x ⊕ y = y ⊕ mscal n x.
  Proof. intros H; apply msum_comm; auto. Qed.

  Fact mscal_sum n x y : x ⊕ y = y ⊕ x -> mscal n (x ⊕ y) = mscal n x ⊕ mscal n y.
  Proof. intro; apply msum_sum; auto. Qed.

  Fact mscal_mult a b x : mscal (a*b) x = mscal a (mscal b x).
  Proof.
    induction a as [ | a IHa ]; simpl.
    + do 2 rewrite mscal_0; auto.
    + rewrite mscal_plus, IHa, mscal_S; auto.
  Qed.

  Fact msum_mscal n k f : (forall i j, i < n -> j < n -> f i ⊕ f j = f j ⊕ f i)
                       -> ∑ n (fun i => mscal k (f i)) = mscal k (∑ n f).
  Proof. intros H; apply msum_msum; auto. Qed.

End msum.

Section msum_morphism.

  Variable (X Y : Type) (m1 : X -> X -> X) (u1 : X)
                        (m2 : Y -> Y -> Y) (u2 : Y)
           (H1 : monoid_theory m1 u1)
           (H2 : monoid_theory m2 u2)
           (phi : X -> Y)
           (Hphi1 : phi u1 = u2)
           (Hphi2 : forall x y, phi (m1 x y) = m2 (phi x) (phi y)).

  Fact msum_morph n f : phi (msum m1 u1 n f) = msum m2 u2 n (fun x => phi (f x)).
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; auto.
    rewrite Hphi2, IHn; trivial.
  Qed.

  Fact mscal_morph n x : phi (mscal m1 u1 n x) = mscal m2 u2 n (phi x).
  Proof. apply msum_morph. Qed.

End msum_morphism.

Section binomial_Newton.

  Variable (X : Type) (sum times : X -> X -> X) (zero one : X).

  Infix "⊕" := sum (at level 50, left associativity).
  Infix "⊗" := times (at level 40, left associativity).

  Notation z := zero.
  Notation o := one.

  Notation scal := (mscal sum zero).
  Notation expo := (mscal times one).

  Hypothesis (M_sum : monoid_theory sum zero)
             (sum_comm : forall x y, x ⊕ y = y ⊕ x)
             (sum_cancel : forall x u v, x ⊕ u = x ⊕ v -> u = v)
             (M_times : monoid_theory times one)
             (distr_l : forall x y z, x ⊗ (y⊕z) = x⊗y ⊕ x⊗z)
             (distr_r : forall x y z, (y⊕z) ⊗ x = y⊗x ⊕ z⊗x).

  Fact times_zero_l x : z ⊗ x = z.
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    apply sum_cancel with (z⊗x).
    rewrite S2, <- distr_r, S1; trivial.
  Qed.

  Fact times_zero_r x : x ⊗ z = z.
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    apply sum_cancel with (x⊗z).
    rewrite S2, <- distr_l, S1; trivial.
  Qed.

  Notation "∑" := (msum sum zero).

  Fact sum_0n_scal n k f : ∑ n (fun i => scal k (f i)) = scal k (∑ n f).
  Proof. apply msum_mscal; auto. Qed.

  Fact scal_times k x y : scal k (x⊗y) = x⊗scal k y.
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    induction k as [ | k IHk ].
    + rewrite mscal_0, mscal_0, times_zero_r; auto.
    + rewrite mscal_S, mscal_S, IHk, distr_l; auto.
  Qed.

  Fact scal_one_comm k x : scal k o ⊗ x = x ⊗ scal k o.
  Proof.
    destruct M_times as [ T1 T2 T3 ].
    induction k as [ | k IHk ].
    + rewrite mscal_0, times_zero_l, times_zero_r; auto.
    + rewrite mscal_S, distr_l, distr_r; f_equal; auto.
      rewrite T1, T2; auto.
  Qed.

  Corollary scal_one k x : scal k x = scal k o ⊗ x.
  Proof.
    destruct M_times as [ T1 T2 T3 ].
    rewrite <- (T2 x) at 1.
    rewrite scal_times.
    symmetry; apply scal_one_comm.
  Qed.

  Fact sum_0n_distr_l b n f : ∑ n (fun i => b⊗f i) = b⊗∑ n f.
  Proof.
    revert f; induction n as [ | n IHn ]; intros f.
    + do 2 rewrite msum_0; rewrite times_zero_r; auto.
    + do 2 rewrite msum_S; rewrite IHn, distr_l; auto.
  Qed.

  Fact sum_0n_distr_r b n f : ∑ n (fun i => f i⊗b) = ∑ n f ⊗ b.
  Proof.
    revert f; induction n as [ | n IHn ]; intros f.
    + do 2 rewrite msum_0; rewrite times_zero_l; auto.
    + do 2 rewrite msum_S; rewrite IHn, distr_r; auto.
  Qed.

  (*   Newton Binomial theorem for (X,⊕,z,⊗,o) where
          1) (X,⊕,z) is a cancellative commutative monoid
          2) (X,⊗,o) is a monoid
          3) ⊗ distributes over ⊕ on the left and one the right

        cancellative could be weakened into z is left and right
        absorbing for ⊗, ie a⊗z = z⊗a = z

   *)

  Theorem binomial_Newton n a b :
        a ⊗ b = b ⊗ a
     -> expo n (a ⊕ b) = ∑ (S n) (fun i => scal (binomial n i) (expo (n - i) a ⊗ expo i b)).
  Proof.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    intros Hab; induction n as [ | n IHn ].
    + rewrite mscal_0, msum_S, msum_0; simpl.
      rewrite mscal_0, mscal_0, mscal_1; auto.
      rewrite S2, T1; auto.
    + rewrite msum_S with (n := S n), binomial_n0, mscal_1; auto.
      rewrite mscal_0, Nat.sub_0_r; auto.
      rewrite T2.
      rewrite msum_ext with (g := fun i => b ⊗ scal (binomial n i) (expo (n-i) a ⊗ expo i b)
                                         ⊕ a ⊗ scal (binomial n (S i)) (expo (n-S i) a ⊗ expo (S i) b)).
      2: { intros; rewrite binomial_SS, mscal_plus; auto.
           replace (S n - S i) with (n-i) by lia; f_equal.
           * rewrite mscal_S.
             do 3 rewrite scal_times.
             do 2 rewrite T3; f_equal.
             apply mscal_comm; auto.
           * destruct (le_lt_dec n i).
             + rewrite binomial_gt; try lia.
               do 2 rewrite mscal_0.
               rewrite times_zero_r; auto.
             + replace (n - i) with (S (n - S i)) by lia.
               rewrite mscal_S.
               repeat rewrite scal_times.
               repeat rewrite T3; auto. }
      rewrite msum_sum; auto.
      do 2 rewrite sum_0n_distr_l.
      rewrite <- IHn.
      rewrite msum_plus1, binomial_gt; auto.
      rewrite mscal_0, S2.
      generalize (msum_S sum z n (fun i => scal (binomial n i) (expo (n-i) a ⊗ expo i b))); intros H.
      rewrite Nat.sub_0_r, binomial_n0, mscal_1, mscal_0, T2 in H; auto.
      rewrite S3, (sum_comm (expo _ _)), <- S3.
      rewrite mscal_S with (x :=a), <- distr_l, <- H, <- IHn.
      rewrite mscal_S, distr_r.
      apply sum_comm.
  Qed.

End binomial_Newton.

Section Newton_nat.

  Notation power := (mscal mult 1).
  Notation "∑" := (msum plus 0).

  Fact sum_fold_map n f : ∑ n f = fold_right plus 0 (map f (list_an 0 n)).
  Proof. apply msum_fold_map. Qed.

  Fact power_0 x : power 0 x = 1.
  Proof. apply mscal_0. Qed.

  Fact power_S n x : power (S n) x = x * power n x.
  Proof. apply mscal_S. Qed.

  Fact power_1 x : power 1 x = x.
  Proof. apply mscal_1, Nat_mult_monoid. Qed.

  Fact power_of_0 n : 0 < n -> power n 0 = 0.
  Proof. destruct n; try lia; rewrite power_S; auto. Qed.

  Fact power_of_1 n : power n 1 = 1.
  Proof. rewrite mscal_of_unit; auto. Qed.

  Fact power_plus p a b : power (a+b) p = power a p * power b p.
  Proof. apply mscal_plus, Nat_mult_monoid. Qed.

  Fact power_mult p a b : power (a*b) p = power a (power b p).
  Proof. apply mscal_mult; auto. Qed.

  Fact power_ge_1 k p : p <> 0 -> 1 <= power k p.
  Proof.
    intros Hp.
    induction k as [ | k IHk ].
    + rewrite power_0; auto.
    + rewrite power_S.
      apply (mult_le_compat 1 _ 1); lia.
  Qed.

  Fact power2_gt_0 n : 0 < power n 2.
  Proof. apply power_ge_1; discriminate. Qed.

  Fact power_sinc k p : 2 <= p -> power k p < power (S k) p.
  Proof.
    intros Hp; rewrite power_S.
    rewrite <- (Nat.mul_1_l (power k p)) at 1.
    apply mult_lt_compat_r; try lia.
    apply power_ge_1; lia.
  Qed.

  Fact power_ge_n k p : 2 <= p -> k <= power k p.
  Proof.
    intros Hp.
    induction k as [ | k IHk ].
    + rewrite power_0; auto.
    + apply le_lt_trans with (2 := power_sinc _ Hp); auto.
  Qed.

  Fact power_mono_l p q x : 1 <= x -> p <= q -> power p x <= power q x.
  Proof.
    intros Hx.
    induction 1 as [ | q H IH ]; auto.
    apply le_trans with (1 := IH).
    rewrite power_S.
    rewrite <- (Nat.mul_1_l (power _ _)) at 1.
    apply mult_le_compat; auto.
  Qed.

  Definition power_mono := power_mono_l.

  Fact power_smono_l p q x : 2 <= x -> p < q -> power p x < power q x.
  Proof.
    intros H1 H2.
    apply lt_le_trans with (1 := power_sinc _ H1).
    apply power_mono_l; lia.
  Qed.

  Fact power_mono_r n p q : p <= q -> power n p <= power n q.
  Proof.
    intros H.
    induction n as [ | n IHn ].
    + do 2 rewrite power_0; auto.
    + do 2 rewrite power_S; apply mult_le_compat; auto.
  Qed.

  Fact power_0_inv p n : power p n = 0 <-> n = 0 /\ 0 < p.
  Proof.
    induction p as [ | p IHp ].
    + rewrite power_0; lia.
    + rewrite power_S; split.
      * intros H.
        apply mult_is_O in H.
        rewrite IHp in H; lia.
      * intros (?&?); subst; simpl; auto.
  Qed.

  Fact plus_cancel_l : forall a b c, a + b = a + c -> b = c.
  Proof. intros; lia. Qed.

  Let plus_cancel_l':= plus_cancel_l.

  Fact sum_0n_scal_l n k f : ∑ n (fun i => k*f i) = k*∑ n f.
  Proof.
    apply sum_0n_distr_l with (3 := Nat_mult_monoid); auto.
    intros; ring.
  Qed.

  Fact sum_0n_scal_r n k f : ∑ n (fun i => (f i)*k) = (∑ n f)*k.
  Proof.
    apply sum_0n_distr_r with (3 := Nat_mult_monoid); auto.
    intros; ring.
  Qed.

  Fact sum_0n_mono n f g : (forall i, i < n -> f i <= g i) -> ∑ n f <= ∑ n g.
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g H.
    + do 2 rewrite msum_0; auto.
    + do 2 rewrite msum_S; apply plus_le_compat.
      * apply H; lia.
      * apply IHn; intros; apply H; lia.
  Qed.

  Fact sum_0n_le_one n f i : i < n -> f i <= ∑ n f.
  Proof.
    revert f i; induction n as [ | n IHn ]; intros f i H.
    + lia.
    + rewrite msum_S.
      destruct i as [ | i ]; try lia.
      apply lt_S_n, IHn with (f := fun i => f (S i)) in H.
      lia.
  Qed.

  Fact sum_power_lt k n f : k <> 0 -> (forall i, i < n -> f i < k) -> ∑ n (fun i => f i * power i k) < power n k.
  Proof.
    intros Hk.
    revert f; induction n as [ | n IHn ]; intros f Hf.
    + rewrite msum_0, power_0; lia.
    + rewrite msum_S, power_S, power_0, Nat.mul_1_r.
      apply le_trans with (k+ k * (power n k-1)).
      * apply (@plus_le_compat (S (f 0))).
        - apply Hf; lia.
        - rewrite msum_ext with (g := fun i => k*(f (S i)*power i k)).
          ++ rewrite sum_0n_distr_l with (one := 1); auto; try (intros; ring).
             apply mult_le_compat_l.
             apply le_S_n, le_trans with (power n k); try lia.
             apply IHn; intros; apply Hf; lia.
          ++ intros; rewrite power_S; ring.
      * generalize (power_ge_1 n Hk); intros ?.
        replace (power n k) with (1+(power n k - 1)) at 2 by lia.
        rewrite Nat.mul_add_distr_l.
        apply plus_le_compat; lia.
  Qed.

  Theorem Newton_nat a b n :
       power n (a + b) = ∑ (S n) (fun i => binomial n i * power (n - i) a * power i b).
  Proof.
    rewrite binomial_Newton with (1 := Nat_plus_monoid) (4 := Nat_mult_monoid); try (intros; ring); auto.
    apply msum_ext; intros i Hi.
    rewrite scal_one with (1 := Nat_plus_monoid) (3 := Nat_mult_monoid); auto; try (intros; ring).
    rewrite <-mult_assoc; f_equal; auto.
    generalize (binomial n i); intros k.
    induction k as [ | k IHk ].
    + rewrite mscal_0; auto.
    + rewrite mscal_S, IHk; auto; apply plus_cancel_l.
  Qed.

  Theorem Newton_nat_S a n :
       power n (1 + a) = ∑ (S n) (fun i => binomial n i * power i a).
  Proof.
    rewrite Newton_nat.
    apply msum_ext.
    intros; rewrite power_of_1; ring.
  Qed.

  Lemma binomial_le_power n i : binomial n i <= power n 2.
  Proof.
    destruct (le_lt_dec i n) as [ Hi | Hi ].
    + change 2 with (1+1).
      rewrite Newton_nat_S.
      eapply le_trans.
      2:{ apply sum_0n_le_one with (f := fun i => binomial n i * power i 1).
          apply le_n_S, Hi. }
      rewrite power_of_1; lia.
    + rewrite binomial_gt; auto; lia.
  Qed.

  Corollary binomial_lt_power n i : binomial n i < power (S n) 2.
  Proof.
    apply le_lt_trans with (1 := binomial_le_power _ _), power_sinc; auto.
  Qed.

End Newton_nat.


(* week_39b_arithmetic_expressions.v *)
(* dIFP 2014-2015, Q1, Week 38 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

(* Working version, make sure to download
   the updated version after class.
*)

(* ********** *)

Require Import Arith Bool unfold_tactic List.

Notation "A =n= B" := (beq_nat A B) (at level 70, right associativity).

(* ********** *)

(* Source syntax: *)

Inductive arithmetic_expression : Type :=
  | Lit : nat -> arithmetic_expression
  | Plus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
  | Times : arithmetic_expression -> arithmetic_expression -> arithmetic_expression
  | Minus : arithmetic_expression -> arithmetic_expression -> arithmetic_expression.

(* Exercise 0:
   Write samples of arithmetic expressions.
*)

Compute (Times (Lit 5) (Plus (Lit 3) (Lit 4))).
Compute (Plus (Lit 1) (Lit 2)).
Compute (Times (Lit 1) (Lit 2)).
Compute (Plus (Lit 1) (Plus (Lit 2) (Plus (Lit 3) (Lit 4)))).
Compute (Times (Lit 1) (Times (Lit 2) (Times (Lit 3) (Lit 4)))).

(* ********** *)

Definition specification_of_interpret (interpret : arithmetic_expression -> nat) :=
  (forall n : nat,
     interpret (Lit n) = n)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Plus ae1 ae2) = (interpret ae1) + (interpret ae2))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Times ae1 ae2) = (interpret ae1) * (interpret ae2))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     interpret (Minus ae1 ae2) = (interpret ae1) - (interpret ae2)).

(* Exercise 1:
   Write unit tests.
*)

(* TODO: Lav nogle flere *)
Definition unit_test_for_interpret (interpret : arithmetic_expression -> nat) :=
  (interpret (Lit 5) =n= 5)
  &&
  (interpret (Times (Lit 1) (Lit 2)) =n= 2)
  &&
  (interpret (Plus (Lit 1) (Plus (Lit 2) (Lit 3))) =n= 6)
  &&
  (interpret (Times (Plus (Lit 1) (Lit 2)) (Plus (Lit 2) (Lit 3))) =n= 15)
  && (interpret (Times (Times (Lit 2) (Lit 3)) (Times (Lit 4) (Lit 5))) =n= 120)
  .

(* Exercise 2:
   Define an interpreter as a function
   that satisfies the specification above
   and verify that it passes the unit tests.
*)

Fixpoint interpreter ( ae : arithmetic_expression) : nat :=
  match ae with
    | Lit n => n
    | Plus ae1 ae2 => (interpreter ae1) + (interpreter ae2)
    | Times ae1 ae2 => (interpreter ae1) * (interpreter ae2)
    | Minus ae1 ae2 => (interpreter ae1) - (interpreter ae2)
  end.

Compute (interpreter (Times (Lit 7) (Plus (Lit 5) (Lit 6)))).
Compute unit_test_for_interpret interpreter.

Lemma unfold_interpreter_lit :
  forall n : nat,
    interpreter (Lit n) = n.
Proof.
  unfold_tactic interpreter.
Qed.

Lemma unfold_interpreter_times :
  forall a b : arithmetic_expression,
    interpreter (Times a b) = (interpreter a) * (interpreter b).
Proof.
  unfold_tactic interpreter.
Qed.

Lemma unfold_interpreter_plus :
  forall a b : arithmetic_expression,
    interpreter (Plus a b) = (interpreter a) + (interpreter b).
Proof.
  unfold_tactic interpreter.
Qed.

Lemma unfold_interpreter_minus :
  forall a b : arithmetic_expression,
    interpreter (Minus a b) = (interpreter a) - (interpreter b).
Proof.
  unfold_tactic interpreter.
Qed.

Lemma interpreter_fits_the_specification_of_interpreter :
  forall exp : arithmetic_expression,
    specification_of_interpret interpreter.
Proof.
  unfold specification_of_interpret.
  split.

    intro n.
    apply (unfold_interpreter_lit n).

    split.

      intros ae1 ae2.
      apply (unfold_interpreter_plus ae1 ae2).

      split.
        intros ae1 ae2.
        apply (unfold_interpreter_times ae1 ae2).

        intros ae1 ae2.
        apply (unfold_interpreter_minus ae1 ae2).

Qed.

(* Byte-code instructions: *)

Inductive byte_code_instruction : Type :=
  | PUSH : nat -> byte_code_instruction
  | ADD : byte_code_instruction
  | MUL : byte_code_instruction
  | SUB : byte_code_instruction.

(* ********** *)

(* Byte-code programs: *)

Definition byte_code_program := list byte_code_instruction.

(* Data stack: *)

Definition data_stack := list nat.

(* ********** *)

(* Exercise 3:
   specify a function
     execute_byte_code_instruction : instr -> data_stack -> data_stack
   that executes a byte-code instruction, given a data stack
   and returns this stack after the instruction is executed.

   * Executing (PUSH n) given s has the effect of pushing n on s.

   * Executing ADD given s has the effect of popping two numbers
     from s and then pushing the result of adding them.

   * Executing MUL given s has the effect of popping two numbers
     from s and then pushing the result of multiplying them.

   For now, if the stack underflows, just assume it contains zeroes.
*)

(*
  Also, execute_byte_code_instruction is not recursive, so make sure to define it with Definition, not with Fixpoint.
*)

(* TODO: Skal vi ændre den måde x :: stack virker? *)
Definition execute_byte_code_instruction (instruction : byte_code_instruction) ( dstack : data_stack) : data_stack :=
  match instruction with
    | PUSH n => n :: dstack
    | ADD => match dstack with
               | x :: y :: stack => (plus x y) :: stack
               | x :: stack => x :: stack
               | nil => 0 :: nil
             end
    | MUL => match dstack with
               | x :: y :: stack => (mult x y) :: stack
               | x :: stack => x :: stack
               | nil => 0 :: nil
             end
    | SUB => match dstack with
               | x :: y :: stack => (minus x y) :: stack
               | x :: stack => x :: stack
               | nil => 0 :: nil
             end
  end.

Compute(execute_byte_code_instruction (PUSH 4) (1 :: 2 :: nil)).
Compute(execute_byte_code_instruction (MUL) (nil)).
Compute(execute_byte_code_instruction (MUL) (3 :: 2 :: nil)).
Compute(execute_byte_code_instruction (MUL) (1 :: nil)).

(* ********** *)

(* Exercise 4:
   Define a function
     execute_byte_code_program : byte_code_program -> data_stack -> data_stack
   that executes a given byte-code program on a given data stack,
   and returns this stack after the program is executed.
*)

Fixpoint execute_byte_code_program (program : byte_code_program) (dstack : data_stack) : data_stack :=
  match program with
    | nil => dstack
    | p1 :: byte_codes => execute_byte_code_program byte_codes (execute_byte_code_instruction p1 dstack)
  end.

Compute(execute_byte_code_program ((PUSH 4) :: (PUSH 3) :: (MUL) :: nil) (0 :: nil)).

(* ********** *)

(* Exercise 5:
   Prove that for all programs p1, p2 and data stacks s,
   executing (p1 ++ p2) with s
   gives the same result as
   (1) executing p1 with s, and then
   (2) executing p2 with the resulting stack.

  DOING INDUCTION ON P1
*)

Lemma unfold_byte_code_program_bc :
  forall s : data_stack,
    execute_byte_code_program nil s = s.
Proof.
  unfold_tactic execute_byte_code_program.
Qed.

Lemma unfold_byte_code_program_ic :
  forall (p1 : byte_code_instruction) (program : byte_code_program) (s : data_stack),
    execute_byte_code_program (p1 :: program) s =
    execute_byte_code_program program (execute_byte_code_instruction p1 s).
Proof.
  unfold_tactic execute_byte_code_program.
Qed.

Theorem about_list_of_instructions :
  forall ( p1 p2 : byte_code_program) (s : data_stack),
    execute_byte_code_program p2 (execute_byte_code_program p1 s) =
    execute_byte_code_program  (p1 ++ p2) s.
Proof.
  intros p1 p2.
  induction p1 as [ | p1' p1s' IHsp1'].

  intro s.
  unfold app.
  rewrite -> unfold_byte_code_program_bc.
  reflexivity.

  intro s.
  rewrite -> unfold_byte_code_program_ic.
  rewrite <- (app_comm_cons).
  rewrite -> (unfold_byte_code_program_ic).
  rewrite -> (IHsp1' (execute_byte_code_instruction p1' s)).
  reflexivity.
Qed.

(* ********** *)

Definition specification_of_compile (compile : arithmetic_expression -> byte_code_program) :=
  (forall n : nat,
     compile (Lit n) = PUSH n :: nil)
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Plus ae1 ae2) = (compile ae2) ++ (compile ae1) ++ (ADD :: nil))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Times ae1 ae2) = (compile ae2) ++ (compile ae1)++ (MUL :: nil))
  /\
  (forall ae1 ae2 : arithmetic_expression,
     compile (Minus ae1 ae2) = (compile ae2) ++ (compile ae1) ++ (SUB :: nil)).

(* Exercise 6:
   Define a compiler as a function
   that satisfies the specification above
   and uses list concatenation, i.e., ++.
*)

Fixpoint compile_plusplus (ae : arithmetic_expression) : byte_code_program :=
  match ae with
    | Lit n => (PUSH n) :: nil
    | Plus ae1 ae2 => (compile_plusplus ae2) ++ (compile_plusplus ae1) ++ (ADD :: nil)
    | Times ae1 ae2 => (compile_plusplus ae2) ++ (compile_plusplus ae1) ++ (MUL :: nil)
    | Minus ae1 ae2 => (compile_plusplus ae2) ++ (compile_plusplus ae1) ++ (SUB :: nil)
  end.

Lemma unfold_compile_plusplus_lit :
  forall n : nat,
    compile_plusplus (Lit n) = (PUSH n) :: nil.
Proof.
  unfold_tactic compile_plusplus.
Qed.

Lemma unfold_compile_plusplus_plus :
  forall ae1 ae2 : arithmetic_expression,
    compile_plusplus (Plus ae1 ae2) = (compile_plusplus ae2) ++ (compile_plusplus ae1) ++ (ADD :: nil).
Proof.
  unfold_tactic compile_plusplus.
Qed.

Lemma unfold_compile_plusplus_times :
  forall ae1 ae2 : arithmetic_expression,
    compile_plusplus (Times ae1 ae2) = (compile_plusplus ae2) ++ (compile_plusplus ae1) ++ (MUL :: nil).
Proof.
  unfold_tactic compile_plusplus.
Qed.

Lemma unfold_compile_plusplus_minus :
  forall ae1 ae2 : arithmetic_expression,
    compile_plusplus (Minus ae1 ae2) = (compile_plusplus ae2) ++ (compile_plusplus ae1) ++ (SUB :: nil).
Proof.
  unfold_tactic compile_plusplus.
Qed.

Theorem compile_plusplus_fits_the_specification_of_compile :
  forall ae : arithmetic_expression,
    specification_of_compile compile_plusplus.
Proof.
  unfold specification_of_compile.
  split.
    intro n.
    apply (unfold_compile_plusplus_lit).

    split.
      intros ae1 ae2.
      apply (unfold_compile_plusplus_plus).

      split.
        intros ae1 ae2.
        apply (unfold_compile_plusplus_times).

        intros ae1 ae2.
        apply (unfold_compile_plusplus_minus).
Qed.

(* Exercise 7:
   Write a compiler as a function with an accumulator
   that does not use ++ but :: instead,
   and prove it equivalent to the compiler of Exercise 6.
*)

Fixpoint compile_acc (ae : arithmetic_expression) (acc : byte_code_program) : byte_code_program :=
  match ae with
    | Lit n => (PUSH n) :: acc
    | Plus ae1 ae2 => (compile_acc ae2 (compile_acc ae1 (ADD :: acc)))
    | Times ae1 ae2 => (compile_acc ae2 (compile_acc ae1 (MUL :: acc)))
    | Minus ae1 ae2 => (compile_acc ae2 (compile_acc ae1 (SUB :: acc)))
  end.

Compute(compile_acc (Plus (Lit 5) (Lit 3)) nil).

Lemma unfold_compile_acc_lit :
  forall (n : nat) (acc : byte_code_program),
    compile_acc (Lit n) acc = (PUSH n) :: acc.
Proof.
  unfold_tactic compile_acc.
Qed.

Lemma unfold_compile_acc_plus :
  forall (ae1 ae2 : arithmetic_expression) (acc : byte_code_program),
    compile_acc (Plus ae1 ae2) acc = compile_acc ae2 (compile_acc ae1 (ADD :: acc)).
Proof.
  unfold_tactic compile_acc.
Qed.

Lemma unfold_compile_acc_times :
  forall (ae1 ae2 : arithmetic_expression) (acc : byte_code_program),
    compile_acc (Times ae1 ae2) acc = compile_acc ae2 (compile_acc ae1 (MUL :: acc)).
Proof.
  unfold_tactic compile_acc.
Qed.

Lemma unfold_compile_acc_minus :
  forall (ae1 ae2 : arithmetic_expression) (acc : byte_code_program),
    compile_acc (Minus ae1 ae2) acc = compile_acc ae2 (compile_acc ae1 (SUB :: acc)).
Proof.
  unfold_tactic compile_acc.
Qed.

Compute(execute_byte_code_program(compile_plusplus (Minus (Lit 5) (Lit 3))) nil).

Compute(execute_byte_code_program(compile_plusplus (Minus (Lit 3) (Lit 5))) nil).

Compute(execute_byte_code_program(compile_acc (Minus (Lit 5) (Lit 3)) nil) nil).

Compute(execute_byte_code_program(compile_acc (Minus (Lit 3) (Lit 5)) nil) nil).

(* EUREKA *)

Lemma about_compile_acc :
  forall (ae : arithmetic_expression) (acc bcp : byte_code_program),
    (compile_acc ae acc) ++ bcp = compile_acc ae (acc ++ bcp).
Proof.
  intro ae.
  induction ae as [ n | ae1 IHa1 ae2 IHa2 | ae1' IHa1' ae2' IHa2' | ae1'' IHa1'' ae2'' IHa2'' ].

  intros acc bcp.
  rewrite ->2 (unfold_compile_acc_lit).
  Check(app_comm_cons).
  rewrite <- (app_comm_cons).
  reflexivity.

  intros acc bcp.
  rewrite ->2 (unfold_compile_acc_plus).
  rewrite -> (app_comm_cons).
  rewrite <- (IHa1 (ADD :: acc) bcp).
  rewrite <- (IHa2).
  reflexivity.

  intros acc bcp.
  rewrite ->2 (unfold_compile_acc_times).
  rewrite -> (app_comm_cons).
  rewrite <- (IHa1' (MUL :: acc) bcp).
  rewrite <- (IHa2').
  reflexivity.

  intros acc bcp.
  rewrite ->2 (unfold_compile_acc_minus).
  rewrite -> (app_comm_cons).
  rewrite <- (IHa1'' (SUB :: acc) bcp).
  rewrite <- (IHa2'').
  reflexivity.
Qed.

Lemma compile_plusplus_fits_compile_acc :
  forall (ae : arithmetic_expression) (acc : byte_code_program),
    compile_acc ae acc = (compile_plusplus ae) ++ acc.
Proof.
  intro ae.
  induction ae as [ n | ae1 IHa1 ae2 IHa2 | ae1' IHa1' ae2' IHa2' | ae1'' IHa1'' ae2'' IHa2''].
  intro acc.
  rewrite -> (unfold_compile_acc_lit).
  rewrite -> (unfold_compile_plusplus_lit).
  unfold app.
  reflexivity.

  intro acc.
  rewrite -> (unfold_compile_acc_plus).
  rewrite -> (unfold_compile_plusplus_plus).
  rewrite <- (IHa1).
  rewrite <- (IHa2).
  rewrite ->2 (about_compile_acc).
  unfold app.
  reflexivity.

  intro acc.
  rewrite -> (unfold_compile_acc_times).
  rewrite -> (unfold_compile_plusplus_times).
  rewrite <- (IHa1').
  rewrite <- (IHa2').
  rewrite ->2 (about_compile_acc).
  unfold app.
  reflexivity.

  intro acc.
  rewrite -> (unfold_compile_acc_minus).
  rewrite -> (unfold_compile_plusplus_minus).
  rewrite <- (IHa1'').
  rewrite <- (IHa2'').
  rewrite ->2 (about_compile_acc).
  unfold app.
  reflexivity.

Qed.

(* ********** *)

(* Exercise 8:
   Prove that interpreting an arithmetic expression gives the same result
   as first compiling it and then executing the compiled program
   over an empty data stack.
  INDUCTION ON THE AE
*)

Definition check_stack (stack : data_stack) : nat :=
  match stack with
    | x :: nil => x
    | _ => 0
  end.

Check(specification_of_compile).
Check(specification_of_interpret).

Lemma executing_compile_is_the_same_as_interpreting :
  forall (ae : arithmetic_expression),
    interpreter ae = check_stack ( execute_byte_code_program (compile_acc ae nil) nil).
Proof.
  intro ae.
  induction ae as [ a | ae1 IHa1 ae2 IHa2 | ae1' IHa1' ae2' IHa2' | ae1'' IHa1'' ae2'' IHa2''].

  rewrite -> (unfold_interpreter_lit).
  rewrite -> (unfold_compile_acc_lit).
  rewrite -> (unfold_byte_code_program_ic).
  rewrite -> (unfold_byte_code_program_bc).
  unfold execute_byte_code_instruction.
  unfold check_stack.
  reflexivity.

  rewrite -> (unfold_interpreter_plus).
  rewrite -> (unfold_compile_acc_plus).

  rewrite -> (IHa1).
  rewrite -> (IHa2).
  rewrite ->4 (compile_plusplus_fits_compile_acc).
  rewrite <- (about_list_of_instructions).
  SearchAbout(app).
  rewrite -> (app_assoc).
  rewrite -> (about_list_of_instructions).
  rewrite <-3 (compile_plusplus_fits_compile_acc).

  rewrite -> (unfold_byte_code_program_ic).

(* ********** *)

(* Exercise 9:
   Write a Magritte-style execution function for a byte-code program
   that does not operate on natural numbers but on syntactic representations
   of natural numbers:

   Definition data_stack := list arithmetic_expression.

   * Executing (PUSH n) given s has the effect of pushing (Lit n) on s.

   * Executing ADD given s has the effect of popping two arithmetic
     expressions from s and then pushing the syntactic representation of
     their addition.

   * Executing MUL given s has the effect of popping two arithmetic
     expressions from s and then pushing the syntactic representation of
     their multiplication.

   Again, for this week's exercise,
   assume there are enough arithmetic expressions on the data stack.
   If that is not the case, just pad it up with syntactic representations
   of zero.

*)

(* Exercise 10:
   Prove that the Magrite-style execution function from Exercise 9
   implements a decompiler that is the left inverse of the compiler
   of Exercise 6.
*)

(* ********** *)

(* end of week_39b_arithmetic_expressions.v *)