(* exercise 8.5 *)
(****************)

Require Export List.
Require Export Arith.
(* In our exercises we consider strings with only opeing and closing
  parentheses. *)

Inductive par : Set :=
  | open : par
  | close : par.
(* This is the definition of well-parenthesized expressions that is
  probably the easiest to agree on. solution to \ref{exo-wp-1} *)

Inductive wp : list par -> Prop :=
  | wp_nil : wp nil
  | wp_concat : forall l1 l2:list par, wp l1 -> wp l2 -> wp (l1 ++ l2)
  | wp_encapsulate :
      forall l:list par, wp l -> wp (open :: l ++ close :: nil).

Theorem wp_oc : wp (open :: close :: nil).
Proof.
 change (wp (open :: nil ++ close :: nil)) in |- *.
 apply wp_encapsulate.
 apply wp_nil.
Qed.

Theorem wp_o_head_c :
 forall l1 l2:list par, wp l1 -> wp l2 -> wp (open :: l1 ++ close :: l2).
Proof.
 intros l1 l2 H1 H2.
 replace (open :: l1 ++ close :: l2) with ((open :: l1 ++ close :: nil) ++ l2).
 apply wp_concat.
 apply wp_encapsulate; trivial.
 trivial.
 repeat (simpl in |- *; rewrite app_ass); simpl in |- *.
 trivial.
Qed.

Theorem wp_o_tail_c :
 forall l1 l2:list par,
   wp l1 -> wp l2 -> wp (l1 ++ open :: l2 ++ close :: nil).
Proof.
 intros l1 l2 H1 H2.
 apply wp_concat.
 trivial.
 apply wp_encapsulate.
 trivial.
Qed.

(* exercice 8.6 *)
(****************)

(* The structure of well-parenthesized expressions can actually be
  represented by binary trees.*)

Inductive bin : Set :=
  | L : bin
  | N : bin -> bin -> bin.

Fixpoint bin_to_string (t:bin) : list par :=
  match t with
  | L => nil (A:=par)
  | N u v => open :: bin_to_string u ++ close :: bin_to_string v
  end.

Eval compute in (bin_to_string (N (N L L) L)).
Eval compute in (bin_to_string (N (N L L) (N L L))).

Theorem bin_to_string_wp : forall t:bin, wp (bin_to_string t).
Proof.
 simple induction t.
 simpl ; apply wp_nil.
 simpl ; intros t1 H1 t2 H2; apply wp_o_head_c; trivial.
Qed.

Hint Resolve wp_nil wp_concat wp_encapsulate wp_o_head_c wp_o_tail_c wp_oc.

Fixpoint bin_to_string' (t:bin) : list par :=
  match t with
  | L => nil (A:=par)
  | N u v =>
      bin_to_string' u ++ open :: bin_to_string' v ++ close :: nil
  end.

(* This is the correction for exercise 8.7 *)

Theorem bin_to_string'_wp : forall t:bin, wp (bin_to_string' t).
Proof.
 simple induction t; simpl ; auto.
Qed.

(*  This is the correction for exercise 8.24 *)

Inductive parse_rel : list par -> list par -> bin -> Prop :=
  | parse_node :
      forall (l1 l2 l3:list par) (t1 t2:bin),
        parse_rel l1 (close :: l2) t1 ->
        parse_rel l2 l3 t2 -> parse_rel (open :: l1) l3 (N t1 t2)
  | parse_leaf_nil : parse_rel nil nil L
  | parse_leaf_close :
      forall l:list par, parse_rel (close :: l) (close :: l) L.

Theorem parse_rel_sound_aux :
 forall (l1 l2:list par) (t:bin),
   parse_rel l1 l2 t -> l1 = bin_to_string t ++ l2.
Proof.
 intros l1 l2 t H; elim H; clear H l1 l2 t.
 intros l1 l2 l3 t1 t2 Hp Hr1 Hp2 Hr2.
 simpl.
 rewrite app_ass.
 rewrite Hr1.
 simpl.
 rewrite Hr2.
 reflexivity.
 reflexivity.
 intro l; reflexivity.
Qed.

Theorem parse_rel_sound :
 forall l:list par, (exists t : bin, parse_rel l nil t) -> wp l.
Proof.
 intros l [t H]; replace l with (bin_to_string t).
 apply bin_to_string_wp.
 symmetry.
 replace (bin_to_string t) with (bin_to_string t ++ nil).
 apply parse_rel_sound_aux.
 auto.
 rewrite app_nil_end; auto.
Qed.

(* correction to exercise 8.19 *)

(* This is another possible definition of well-parenthesized expressions,
  actually better adapted to showing that a given parser is correct. *)

Inductive wp' : list par -> Prop :=
  | wp'_nil : wp' nil
  | wp'_cons :
      forall l1 l2:list par,
        wp' l1 -> wp' l2 -> wp' (open :: l1 ++ close :: l2).
(* To prove that the two definitions of well-parenthesized expressions are
  equivalent, we need to prove that each predicate satisfies the constructors
  of the other. *)

Theorem wp'_concat :
 forall l1 l2:list par, wp' l1 -> wp' l2 -> wp' (l1 ++ l2).
Proof.
 intros l1 l2 H; generalize l2; clear l2.
 elim H.
 simpl; auto.
 intros l1' l2' Hb1' Hr1 Hb2' Hr2 l2 Hb2.
 simpl.
 rewrite app_ass.
 simpl.
 apply wp'_cons; auto.
Qed.

Hint Resolve wp'_nil wp'_cons wp'_concat.
(* This is the other constructor of wp, also satisfied by wp'. *)

Theorem wp'_encapsulate :
 forall l:list par, wp' l -> wp' (open :: l ++ close :: nil).
Proof.
 intros l H; elim H; auto.
Qed.

(* One interpretation of inductive definitions of predicates is that
  the defined predicate is the least (with respect to implication) to
  satisfy the constructors.  Thus, having proved that one of the predicates
  satisfies the constructors of the other gives a simple way to prove
  that one predicate implies the other.  The proof is done by induction
  on the predicate. solution to \ref{exo-wp-2}*)

Theorem wp_imp_wp' : forall l:list par, wp l -> wp' l.
Proof.
 intros l H; elim H.
 apply wp'_nil.
 intros; apply wp'_concat; trivial.
 intros; apply wp'_encapsulate; trivial.
Qed.

Theorem wp'_imp_wp : forall l:list par, wp' l -> wp l.
Proof.
 intros l H; elim H; auto.
Qed.

(* correction of exercise 8.20 *)

(* Here is an alternative definition, the same as before, but with the
  second constructor that privileges parentheses on the right. *)

Inductive wp'' : list par -> Prop :=
  | wp''_nil : wp'' nil
  | wp''_cons :
      forall l1 l2:list par,
        wp'' l1 -> wp'' l2 -> wp'' (l1 ++ open :: l2 ++ close :: nil).

Hint Resolve wp''_nil wp''_cons.

(* Obviously this one also satisfies the concatenation property. *)

Lemma wp''_concat :
 forall l1 l2:list par, wp'' l1 -> wp'' l2 -> wp'' (l1 ++ l2).
Proof.
 (* Only a proof by induction on the fact that the second list is
    well-parenthesized   is needed. *)
 intros l1 l2 H1 H2; generalize l1 H1; clear H1 l1.
 elim H2.
 intros; rewrite <- app_nil_end; trivial.
 intros; rewrite ass_app; auto.
Qed.

Theorem wp''_encapsulate :
 forall l:list par, wp'' l -> wp'' (open :: l ++ close :: nil).
Proof.
 intros l H; change (wp'' (nil ++ open :: l ++ close :: nil)).
 auto.
Qed.
Hint Resolve wp''_concat wp''_encapsulate.
(* solution to exercise \ref{exo-wp-4} *)

Theorem wp_imp_wp'' : forall l:list par, wp l -> wp'' l.
Proof.
 simple induction 1; auto.
Qed.

Theorem wp''_imp_wp : forall l:list par, wp'' l -> wp l.
Proof.
 simple induction 1; auto.
Qed.

Fixpoint recognize (n:nat) (l:list par) {struct l} : bool :=
  match l with
  | nil => match n with
           | O => true
           | _ => false
           end
  | open :: l' => recognize (S n) l'
  | close :: l' => match n with
                   | O => false
                   | S n' => recognize n' l'
                   end
  end.

(* solution to exercise 8.21 *)

Theorem recognize_complete_aux :
 forall l:list par,
   wp l ->
   forall (n:nat) (l':list par), recognize n (l ++ l') = recognize n l'.
Proof.
 intros l H; elim H.
 simpl; auto.
 intros l1 l2 H1 Hrec1 H2 Hrec2 n l'.
 rewrite app_ass; transitivity (recognize n (l2 ++ l')); auto.
 intros l1 H1 Hrec n l'; simpl ; rewrite app_ass; rewrite Hrec;
 simpl ; auto.
Qed.

Theorem recognize_complete : forall l:list par, wp l -> recognize 0 l = true.
Proof.
 intros l H; rewrite (app_nil_end l); rewrite recognize_complete_aux; auto.
Qed.

(* solution of exercise 8.22 *)
Theorem app_decompose :
 forall (A:Set) (l1 l2 l3 l4:list A),
   l1 ++ l2 = l3 ++ l4 ->
   (exists l1' : list A, l1 = l3 ++ l1' /\ l4 = l1' ++ l2) \/
   (exists a : A,
      exists l2' : list A, l3 = l1 ++ a :: l2' /\ l2 = (a :: l2') ++ l4).
Proof.
 simple induction l1.
 intros l2 l3; case l3.
 intros l4 H; left; exists (nil (A:=A)); auto.
 intros a l3' Heq; right; exists a; exists l3'; auto.
 clear l1; intros a l1 Hrec l2 l3; case l3.
 intros l4 H; left; exists (a :: l1); auto.
 simpl ; intros a' l3' l4 Heq; injection Heq; intros Heq' Heq''.
 elim Hrec with (1 := Heq').
 intros [l1' [Heq3 Heq4]]; left; exists l1'; split; auto.
 rewrite Heq''; rewrite Heq3; auto.
 intros [a'' [l2' [Heq3 Heq4]]]; right; exists a''; exists l2'; split; auto.
 rewrite Heq''; rewrite Heq3; auto.
Qed.

(* length of lists is actually an abstract view of lists.  There is
  a morphism between appending and addition.  This is already visible
  in the structure of the two functions app and plus and the proof of
  this theorem follows in a simple way the structure of app (and plus by
  the same occasion). *)

Theorem length_app :
 forall (A:Set) (l1 l2:list A), length (l1 ++ l2) = length l1 + length l2.
Proof.
 simple induction l1; simpl in |- *; auto.
Qed.

Theorem length_rev : forall (A:Set) (l:list A), length l = length (rev l).
Proof.
 simple induction l; auto.
 intros a l' H; simpl in |- *.
 rewrite length_app.
 simpl in |- *; rewrite <- plus_n_Sm; rewrite H; auto with arith.
Qed.

Theorem cons_to_app_end :
 forall (A:Set) (l:list A) (a:A),
    exists b : A, exists l' : list A, a :: l = l' ++ b :: nil.
Proof.
 intros A l a.
 rewrite <- (rev_involutive (a :: l)).
 (* We want to use the first element of (rev (cons a l)) but we
  need to say that this list has at least one element. *)
 cut (0 < length (rev (a :: l))).
 case (rev (a :: l)).
 (* If (rev (cons a l)) was nil, then there would be a contradiction. *)
 simpl ; intros H'; elim (lt_n_O 0); auto.
 intros b l'; exists b; exists (rev l'); simpl ; auto.
 (* Now we need to show that the reversed list has more than one element *)
 rewrite <- length_rev; simpl ; auto with arith.
Qed.

Theorem last_same :
 forall (A:Set) (a b:A) (l1 l2:list A),
   l1 ++ a :: nil = l2 ++ b :: nil -> l1 = l2 /\ a = b.
Proof.
 intros A a b l1 l2 H.
 cut (a :: rev l1 = b :: rev l2).
 intros H'; injection H'; intros H1 H2; split; auto.
 rewrite <- (rev_involutive l1).
 rewrite H1.
 apply rev_involutive.
 repeat rewrite <- rev_unit.
 rewrite H; auto.
Qed.

Theorem wp_remove_oc_aux :
 forall l:list par,
   wp l ->
   forall l1 l2:list par, l1 ++ l2 = l -> wp (l1 ++ open :: close :: l2).
Proof.
 intros l H; elim H.
 (* In the first case l is the empty list, there is only one way to insert
  an open-string pair.  We use the theorem app_eq_nil to determine
  l1 and l2.  This theorem has implicit arguments. *)
 intros l1 l2 H1; elim (app_eq_nil _ _ H1); auto.
 simpl in |- *; intros Heq1 Heq2; rewrite Heq1; rewrite Heq2; apply wp_oc.
 (* In the second case l is already a concatenation of two well-parenthesized
    expressions l1 and l2.  We need to now whether the open-close pair is
   inserted in l1' or in l2', the theorem app_decompose helps here. *)
 intros l1 l2 Hp1 Hr1 Hp2 Hr2 l3 l4 Heq.
 elim app_decompose with (1 := Heq).
 intros [l1' [Heq1 Heq2]].
 rewrite Heq1.
 rewrite app_ass.
 apply wp_concat; auto.
 intros [a' [l2' [Heq1 Heq2]]].
 rewrite Heq2.
 repeat rewrite app_comm_cons.
 rewrite ass_app.
 apply wp_concat; auto.
(* In the third case, we haev to check three possibilities: either
   the open-close pair has been inserted before the existing open character,
  or between the two parentheses, or after. *)
 idtac.
 intros l' Hp'' Hrec l1; case l1.
 simpl ; intros l2 Heq; rewrite Heq.
 change (wp (open :: nil ++ close :: open :: l' ++ close :: nil));
 auto.
 simpl; intros c l1' l2; case l2.
(* If l2 is nil, then the open-close pair was introduced after the
  closing parenthesis. *)
 intros Heq; injection Heq; intros Heq1 Heq2.
 rewrite <- app_nil_end in Heq1; rewrite Heq1; rewrite Heq2.
 rewrite app_comm_cons.
 apply wp_concat; auto.
(* if l2 is non nil then the open-close pair was introduced between the
   parentheses *)
 intros c' l2'.
 elim (cons_to_app_end par l2' c').
 intros c'' [l2'' Heq]; rewrite Heq.
 rewrite ass_app; intros Heq1.
 injection Heq1; intros Heq2 Heq3.
 elim last_same with (1 := Heq2).
 intros Heq4 Heq5; rewrite Heq5; rewrite Heq3.
 change (wp (open :: l1' ++ (open :: close :: l2'') ++ close :: nil)) .
 rewrite ass_app; auto.
Qed.

Theorem wp_remove_oc :
 forall l1 l2:list par, wp (l1 ++ l2) -> wp (l1 ++ open :: close :: l2).
Proof.
 intros; apply wp_remove_oc_aux with (l := l1 ++ l2); auto.
Qed.

Fixpoint make_list (A:Set) (a:A) (n:nat) {struct n} :
 list A := match n with
           | O => nil (A:=A)
           | S n' => a :: make_list A a n'
           end.

Theorem make_list_end :
 forall (A:Set) (a:A) (n:nat) (l:list A),
   make_list A a (S n) ++ l = make_list A a n ++ a :: l.
Proof.
 simple induction n; simpl.
 trivial.
 intros n' H l; rewrite H; trivial.
Qed.

(* Now we want to express that only well-parenthesized expressions are accepted.  Again,
  we prove a more general statement, where n is understood as the number of
  unmatched opening parentheses recognized so far. *)

Theorem recognize_sound_aux :
 forall (l:list par) (n:nat),
   recognize n l = true -> wp (make_list _ open n ++ l).
Proof.
 simple induction l; simpl.
 intros n; case n.
 simpl ; intros; apply wp_nil.
 intros n' H; discriminate H.
 intros a; case a; simpl ; clear a.
 intros l' H n H0.
 rewrite <- make_list_end; auto.
 intros l' H n; case n; clear n.
 intros H'; discriminate H'.
 intros n H0.
 rewrite make_list_end.
 apply wp_remove_oc.
 auto.
Qed.

(* The soundness statement is the general statement specialized to value 0.
 *)

Theorem recognize_sound : forall l:list par, recognize 0 l = true -> wp l.
Proof.
 intros l H; generalize (recognize_sound_aux _ _ H).
 simpl; auto.
Qed.

(* Now we want to write a real parser, that is, a function that constructs a term
  representing the structure of the string.
  The parsing function is a tail-recursive representation of a stack automaton.
   The argument s is the stack, the argument t is the tree representing the
  the last well-formed expression that was recognized.  The return value is
  None if the string is rejected and (Some t) if the string is accepted.  In
  this case one should be able to reconstruct the recognized string from t,
  but this is done later as another exercise. *)

(* exercise 8.23 *)
Fixpoint parse (s:list bin) (t:bin) (l:list par) {struct l} :
 option bin :=
  match l with
  | nil => match s with
           | nil => Some t
           | _ => None (A:=bin)
           end
  | open :: l' => parse (t :: s) L l'
  | close :: l' =>
      match s with
      | t' :: s' => parse s' (N t' t) l'
      | _ => None (A:=bin)
      end
  end.

(* The length of the stack plays the same role as argument n in the
  function recognize. *)

Theorem parse_reject_indep_t :
 forall (l:list par) (s:list bin) (t:bin),
   parse s t l = None ->
   forall (s':list bin) (t':bin),
     length s' = length s -> parse s' t' l = None.
Proof.
 simple induction l.
 intros s; case s.
 simpl .
 intros t H; discriminate H.
 intros t0 s0 t H s'; case s'.
 simpl; intros t' Hle; discriminate Hle.
 simpl; auto.
 intros a; case a; simpl; clear a; intros l' Hrec s.
 intros t H s' t' Hle.
 apply Hrec with (1 := H).
 simpl; auto with arith.
 case s.
 intros t H s'; case s'; simpl.
 auto.
 intros t0 s0 t' Hle; discriminate Hle.
 intros t0 s0 t H s'; case s'; simpl.
 intros t' H0; discriminate H0.
 intros t'0 s'0 t' Hle; apply Hrec with (1 := H).
 simpl in Hle; auto with arith.
Qed.

(* Rejected strings are those for which the return value is None.
  In the completeness theorem we actually talk about the rejected strings.
  Here it is more convenient to use wp' as the definition of well-parenthesized
  expressions to organize the proof.*)

Theorem parse_complete_aux :
 forall l:list par,
   wp' l ->
   forall (s:list bin) (t:bin) (l':list par),
     parse s t (l ++ l') = None ->
     forall (s':list bin) (t':bin),
       length s' = length s -> parse s' t' l' = None.
Proof.
 simple induction 1.
 simpl; intros; eapply parse_reject_indep_t; eauto.
 intros l1 l2 Hp1 Hr1 Hp2 Hr2 s t l' Hrej s' t' Hle.
 apply Hr2 with (s := s') (t := N t L).
 change (parse (t :: s') L (close :: l2 ++ l') = None) in |- *.
 simpl in Hrej.
 rewrite app_ass in Hrej.
 apply Hr1 with (1 := Hrej).
 simpl; auto with arith.
 auto.
Qed.

Theorem parse_complete : forall l:list par, wp l -> parse nil L l <> None.
Proof.
 intros.
 replace l with (l ++ nil).
 red in |- *; intros H'.
 cut (parse nil L nil = None).
 simpl; discriminate.
 apply parse_complete_aux with (2 := H'); auto.
 apply wp_imp_wp'; auto.
 rewrite <- app_nil_end; auto.
Qed.

(* We will use bin_to_string' to map binary trees to strings of characters.
  Stacks also represent strings. *)

Fixpoint unparse_stack (s:list bin) : list par :=
  match s with
  | nil => nil (A:=par)
  | t :: s' => unparse_stack s' ++ bin_to_string' t ++ open :: nil
  end.

Theorem parse_invert_aux :
 forall (l:list par) (s:list bin) (t t':bin),
   parse s t l = Some t' ->
   bin_to_string' t' = unparse_stack s ++ bin_to_string' t ++ l.
Proof.
 simple induction l.
 intros s; case s.
 simpl.
 intros t t' H; injection H; intros Heq.
 rewrite Heq; apply app_nil_end.
 simpl ; intros t0 s0 t t' H; discriminate H.
 intros a; case a; simpl; clear a; intros l' Hrec s.
 intros t t' H.
 rewrite Hrec with (1 := H).
 simpl.
 repeat (rewrite app_ass; simpl).
 auto.
 case s.
 intros t t' H; discriminate H.
 intros t0 s0 t t' Hp; rewrite Hrec with (1 := Hp).
 simpl.
 repeat (rewrite app_ass; simpl).
 auto.
Qed.

Theorem parse_invert :
 forall (l:list par) (t:bin), parse nil L l = Some t -> bin_to_string' t = l.
Proof.
 intros; replace l with (unparse_stack nil ++ bin_to_string' L ++ l); auto.
 apply parse_invert_aux; auto.
Qed.

(* With this last theorem, we know that our parser is correct, that is
  sound and complete. *)

Theorem parse_sound :
 forall (l:list par) (t:bin), parse nil L l = Some t -> wp l.
Proof.
 intros l t H; rewrite <- parse_invert with (1 := H).
 apply bin_to_string'_wp.
Qed.

(* Now, an exercise for which we do not give the solution is the exercise
          where strings can also contain other characters that play no role
          with  respect to parentheses, but should not be forgotten by the
 parser.*)


Inductive expr : Type :=
 | Int : nat -> expr
 | Add : expr -> expr -> expr
 | Mul : expr -> expr -> expr.

(* Fixpoint = let rec *)
Fixpoint eval (e:expr) : nat :=
match e with
| Int x => x
| Add e1 e2 => (eval e1) + (eval e2)
| Mul e1 e2 => (eval e1) * (eval e2)
end.

(* Calcul 3+4 *)
Compute (eval (Add (Int 3) (Int 4))).

(* 1 + 1 = 2 *)
Lemma onePlusone : (eval (Add (Int 1) (Int 1))) = 2.
Proof.
    simpl.
    reflexivity.
Qed.

(* x + 0 = x*)
(* Preuve sur les entiers naturel (type de Coq) *)
Lemma nPlusZero : forall n, n = n+0.
Proof.
    intro n.
    induction n.
    - simpl. reflexivity.
    - simpl. rewrite <- IHn. reflexivity. Qed.

(* Preuve sur notre système d'expression *)
Lemma xPlusZero : forall n, (eval (Add (Int n) (Int 0))) = n.
Proof.
    intro n.
    induction n.
    - simpl. reflexivity.
    - rewrite <- IHn. simpl. rewrite <- nPlusZero. reflexivity. Qed.

Lemma xPlusB : forall a b, a+b = b+a.
Proof.
    intros a b.
    induction a.
    - simpl. rewrite <- nPlusZero. reflexivity.
    - simpl.
(* Assert = preuve auxiliaire *)
assert (forall x y, S (x+y) = x + S y) as H_assert.
{ intros x y.
  induction x.
  - simpl. reflexivity.
  - simpl. rewrite IHx. reflexivity. }
  rewrite IHa. rewrite H_assert. reflexivity.
Qed.


Require Import
  Arith
  List
  Omega
  Orders
  Recdef
  Relations
  Permutation
  Setoid
  Sorted.

Set Implicit Arguments.

Module Type InsertionSort(Import X:Orders.TotalLeBool).

  Fixpoint Insertion(n : X.t)(l : list X.t) :=
    match l with
    | nil => n :: nil
    | l_head :: l_tail =>
        match X.leb n l_head with
        | true => n :: l_head ::l_tail
        | false => l_head :: Insertion n l_tail
        end
    end.

  Fixpoint InsertionSort(l : list X.t) : list X.t :=
    match l with
    | nil => nil
    | l_head :: l_tail => Insertion l_head (InsertionSort l_tail)
    end.

  Theorem InsertionLength : forall n l, length(Insertion n l) = S (length l).
    intro.
    induction l.
    trivial.
    simpl in *.
    destruct (leb n a).
    trivial.
    intuition.
    simpl in *.
    auto.
  Qed.

  Theorem InsertionSortSameLength : forall l, length (InsertionSort l) = length l.
    intros.
    induction l.
    trivial.
    simpl in *.
    rewrite InsertionLength.
    auto.
  Qed.

  Theorem InsertionPermutationSelf : forall n l,
    Permutation (n :: l) (Insertion n l).
    intros.
    induction l.
    trivial.
    simpl in *.
    case (leb n a).
    trivial.
    intros.
    assert(Permutation (n :: a :: l) (a :: n :: l)).
    constructor.
    apply(perm_trans H).
    auto.
  Qed.

  Theorem InsertionPermutation :
    forall n l r, Permutation l r -> Permutation (n :: l) (Insertion n r).
    induction 1.
    trivial.
    simpl in *.
    case(leb n x).
    auto.
    intros.
    assert (Permutation (n :: x :: l) (x :: n :: l)) as T.
    constructor.
    apply(perm_trans T).
    auto.
    simpl in *.
    case(leb n x),(leb n y).
    constructor.
    constructor.
    constructor.
    constructor.
    assert (Permutation (n :: y :: x :: l) (n :: x :: y :: l)) as T.
    constructor.
    constructor.
    apply(perm_trans T).
    constructor.
    assert(Permutation (n :: y :: x :: l) (x :: y :: n :: l)) as T.
    assert(Permutation (n :: y :: x :: l) (x :: n :: y :: l)) as T.
    assert(Permutation (n :: y :: x :: l) (n :: x :: y :: l)) as T.
    constructor.
    constructor.
    apply(perm_trans T).
    constructor.
    apply(perm_trans T).
    constructor.
    constructor.
    apply(perm_trans T).
    constructor.
    constructor.
    apply InsertionPermutationSelf.
    assert (Permutation (n :: l) (n :: l')) as T.
    auto.
    apply(perm_trans T).
    trivial.
  Qed.

  Theorem InsertionSortPermutation : forall l, Permutation l (InsertionSort l).
    induction l.
    trivial.
    inversion IHl.
    trivial.
    subst.
    simpl in *.
    apply InsertionPermutation.
    trivial.
    subst.
    simpl in *.
    apply InsertionPermutation.
    trivial.
    subst.
    simpl in *.
    apply InsertionPermutation.
    trivial.
  Qed.

  Theorem InsertionSortNil : forall l, InsertionSort l = nil -> l = nil.
    intros.
    destruct l.
    trivial.
    simpl in *.
    remember(InsertionSort l).
    destruct l0.
    simpl in *.
    inversion H.
    simpl in *.
    destruct (leb t0 t1).
    inversion H.
    inversion H.
  Qed.

  Definition Sorted := Sorted (fun l r => is_true(X.leb l r)).

  Theorem SortedCons : forall e l,
    Sorted (e :: l) ->
      Sorted l.
    intros.
    induction l.
    constructor.
    inversion H.
    trivial.
  Qed.

  Theorem InsertionSorted : forall e l,
    Sorted l ->
      Sorted (Insertion e l).
    intros.
    induction l.
    simpl in *.
    constructor.
    auto.
    trivial.
    simpl in *.
    remember (X.leb e a).
    destruct b.
    constructor.
    trivial.
    auto.
    constructor.
    apply IHl.
    eapply SortedCons.
    eauto.
    induction l.
    simpl in *.
    constructor.
    case(X.leb_total a e).
    trivial.
    subst.
    eauto with *.
    simpl in *.
    remember (X.leb e a0).
    destruct b.
    constructor.
    case(X.leb_total a e).
    trivial.
    eauto with *.
    constructor.
    inversion H.
    subst.
    inversion H3.
    trivial.
  Qed.

  Theorem InsertionSortSorted : forall l, Sorted (InsertionSort l).
    induction l.
    simpl in *.
    constructor.
    simpl in *.
    apply InsertionSorted.
    trivial.
  Qed.

End InsertionSort.


Require Export aula3 aula4.

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.
Proof.
  intros n.
  simpl.
Abort.

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    reflexivity.
  - (* n = S n' *)
    simpl.
Abort.

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

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

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


Require Import PeanoNat.

(* bijection from nat * nat to nat *)
Definition embed '(x, y) : nat :=
  y + (nat_rec _ 0 (fun i m => (S i) + m) (y + x)).

(* bijection from nat to nat * nat *)
Definition unembed (n : nat) : nat * nat :=
  nat_rec _ (0, 0) (fun _ '(x, y) => match x with S x => (x, S y) | _ => (S y, 0) end) n.

Lemma embedP {xy: nat * nat} : unembed (embed xy) = xy.
Proof.
  assert (forall n, embed xy = n -> unembed n = xy).
    intro n. revert xy. induction n as [|n IH].
      intros [[|?] [|?]]; intro H; inversion H; reflexivity.
    intros [x [|y]]; simpl.
      case x as [|x]; simpl; intro H.
        inversion H.
      rewrite (IH (0, x)); [reflexivity|].
      inversion H; simpl. rewrite Nat.add_0_r. reflexivity.
    intro H. rewrite (IH (S x, y)); [reflexivity|].
    inversion H. simpl. rewrite Nat.add_succ_r. reflexivity.
  apply H. reflexivity.
Qed.

Lemma unembedP {n: nat} : embed (unembed n) = n.
Proof.
  induction n as [|n IH]; [reflexivity|].
  simpl. revert IH. case (unembed n). intros x y.
  case x as [|x]; intro Hx; rewrite <- Hx; simpl.
    rewrite Nat.add_0_r. reflexivity.
  rewrite ?Nat.add_succ_r. simpl. rewrite ?Nat.add_succ_r. reflexivity.
Qed.
Arguments embed : simpl never.

Module EmbedNatNotations.
  Notation "⟨ a , b ⟩" := (embed (a, b)) (at level 0).
End EmbedNatNotations.


(* ----------------------------------------------------------------- *)
(*                        Elementary Algebra                         *)
(* ----------------------------------------------------------------- *)

From Practice Require Import Basin.Base.
Require Import Permutation.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

(* ----------------------------------------------------------------- *)
(*                       Equivalence on list                         *)
(* ----------------------------------------------------------------- *)

(* Equivalence on list *)
Instance equiv_list U `(D: Setoid U): Equivalence (Forall2 equiv).
Proof with eauto.
  split; red.
  - (* Reflexivity *)
    elim=> [|a x' IH]; constructor...
  - (* Symmetry *)
    move=> x y. elim=> []...
  - (* Transitivity *)
    move=> x y + H.
    elim: H => [|hx hy x' y' E Hxy IH] z Hy...
    inversion Hy; subst. constructor...
Qed.

(* Setoid on list required *)
Instance setoid_list U `(D: Setoid U): Setoid (list U) := {
  equiv := Forall2 equiv
}.

Add Parametric Morphism U `(Setoid U): (@app U)
  with signature equiv ==> equiv ==> equiv as app_mor.
Proof with auto.
  move=> l1 l2.
  elim=> [|h1 h2 l1' l2' Eh El IH] m1 m2 Em...
  simpl. constructor... by apply: IH.
Qed.

(* ----------------------------------------------------------------- *)
(*               Elementary Algebra on single operator               *)
(* ----------------------------------------------------------------- *)

Create HintDb alg discriminated.

Definition Operator U: Type := U -> U -> U.

Section Op.
Context {U} `(D: Setoid U) (op: Operator U).

Class Magma: Type := {
  op_proper: Proper (equiv ==> equiv ==> equiv) op
}.

Local Add Parametric Morphism `(Magma): op
  with signature equiv ==> equiv ==> equiv as mop_mor.
Proof. apply op_proper. Qed.

Local Infix "@" := op (at level 25, left associativity).

Class Associative: Prop :=
  associativity: forall x y z, x @ (y @ z) == (x @ y) @ z.
Class Commutative: Prop :=
  commutativity: forall x y, x @ y == y @ x.
Class HasIdentity: Type := {
  mid: U
; mid_left: forall x, mid @ x == x
; mid_right: forall x, x @ mid == x
}.

Class Semigroup: Type := {
  sem_mag :> Magma
; sem_assoc :> Associative
}.

Class Monoid: Type := {
  mon_sem :> Semigroup
; mon_hasid :> HasIdentity
}.

Class CommMonoid: Type := {
  cm_mon :> Monoid
; cm_comm :> Commutative
}.

(* Semigroup concatenation with starting element on right *)
Definition SCatWith `{S: Semigroup} (d: U) (l: list U): U :=
  fold_right op d l.

Add Parametric Morphism `(Semigroup): (@SCatWith _)
  with signature equiv ==> equiv ==> equiv as scatwith_mor.
Proof.
  move=> a b E x y.
  elim=> {x y} [|hx hy x' y' Hh _ IH] //=.
  rewrite Hh IH. auto.
Qed.

Lemma scatwith_app: forall `(Semigroup) d e l1 l2,
  SCatWith d l1 @ SCatWith e l2 == SCatWith e (l1 ++ d :: l2).
Proof.
  move=> ? d e l1 l2.
  elim: l1 => [|h l1' IH] /=; auto.
  rewrite <- associativity. rw_refl.
Qed.

(* Monoid concatenation *)
Definition MCat `{M: Monoid} (l: list U): U :=
  fold_right op mid l.

Add Parametric Morphism `(Monoid): (@MCat _)
with signature equiv ==> equiv as mcat_mor.
Proof.
  move=> x y. elim=> {x y} [|hx hy x' y' Hh Hl IH] //=.
  all: rw_refl.
Qed.

Lemma mcat_nil: forall `(Monoid),
  MCat [] == mid.
Proof. reflexivity. Qed.

Lemma mcat_app: forall `(Monoid) (l1 l2: list U),
  MCat l1 @ MCat l2 == MCat (l1 ++ l2).
Proof.
  move=> ? l1 l2. elim: l1 => [|h l1' IH] /=.
  - apply: mid_left.
  - rewrite <- associativity. rw_refl.
Qed.

Lemma mcat_single: forall `(Monoid) a,
  MCat [a] == a.
Proof. move=> > /=. apply: mid_right. Qed.

Lemma mcat_couple: forall `(Monoid) a b,
  MCat [a; b] == a @ b.
Proof. move=> > /=. rewrite mid_right. reflexivity. Qed.

(* Induction on mcat *)
Lemma mcat_ind: forall `(Monoid) (l: list U) (P: U -> Prop),
  P mid -> (forall a b, P a -> P b -> P (a @ b)) ->
  Forall P l -> P (MCat l).
Proof.
  move=> M l P Hid Hop.
  elim=> {l} [|x l' Hx Hl' IH] //=.
  by apply: Hop.
Qed.

(* Commutative monoid -> Can permutate *)
Lemma mcat_perm: forall `(CommMonoid) (l m: list U),
  Permutation l m -> MCat l == MCat m.
Proof with eauto.
  move=> C l m. elim=> {l m} [| a l m HP IH | a b l |] /=...
  - rw_refl.
  - rewrite !associativity (commutativity a)...
Qed.

Definition MCatOver {V} `{M: Monoid} (f: V -> U) (l: list V): U :=
  MCat (map f l).

End Op.

Arguments mid {U D} op {HasIdentity}.
Arguments SCatWith {U D} op {S}.
Arguments MCat {U D} op {M}.
Arguments MCatOver {U D} op {V M}.

#[export]
Hint Resolve associativity commutativity mid_left mid_right
  scatwith_app
  mcat_nil mcat_app mcat_perm: alg.

(* ----------------------------------------------------------------- *)
(*                          El. Alg. Examples                        *)
(* ----------------------------------------------------------------- *)

(* List: monoid *)
Program Instance magma_list U `(Setoid U): Magma _ (@app U).

Program Instance assoc_app U `(Setoid U): Associative _ (@app U).
Next Obligation. rewrite app_assoc. reflexivity. Qed.

Program Instance hasid_app U `(Setoid U): HasIdentity _ (@app U) := { mid := [] }.
Next Obligation. reflexivity. Qed.
Next Obligation. rewrite app_nil_r. reflexivity. Qed.

Program Instance semigroup_app U `(Setoid U): Semigroup _ (@app U).
Program Instance monoid_app U `(Setoid U): Monoid _ (@app U).

(* Nat add: commutative monoid *)
Program Instance magma_nat_add: Magma _ Nat.add.

Program Instance assoc_nat_add: Associative _ Nat.add.
Next Obligation. apply Nat.add_assoc. Qed.

Program Instance comm_nat_add: Commutative _ Nat.add.
Next Obligation. apply Nat.add_comm. Qed.

Program Instance hasid_nat_add: HasIdentity _ Nat.add := { mid := 0 }.

Program Instance semigroup_nat_add: Semigroup _ Nat.add.
Program Instance monoid_nat_add: Monoid _ Nat.add.
Program Instance cmon_nat_add: CommMonoid _ Nat.add.

(* Nat mul: commutative monoid *)
Program Instance magma_nat_mul: Magma _ Nat.mul.

Program Instance assoc_nat_mul: Associative _ Nat.mul.
Next Obligation. apply Nat.mul_assoc. Qed.

Program Instance comm_nat_mul: Commutative _ Nat.mul.
Next Obligation. apply Nat.mul_comm. Qed.

Program Instance hasid_nat_mul: HasIdentity _ Nat.mul := { mid := 1 }.
Next Obligation. apply Nat.mul_1_r. Qed.

Program Instance semigroup_nat_mul: Semigroup _ Nat.mul.
Program Instance monoid_nat_mul: Monoid _ Nat.mul.
Program Instance cmon_nat_mul: CommMonoid _ Nat.mul.


Require Export Poly_J.

Theorem plus_2_2_is_4 :
  2 + 2 = 4.
Proof. reflexivity. Qed.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity. Qed.

Definition strange_prop1 : Prop :=
  (2 + 2 = 5) -> (99 + 26 = 42).

Definition strange_prop2 :=
  forall n, (ble_nat n 17 = true) -> (ble_nat n 99 = true).

Definition even (n:nat) : Prop :=
  evenb n = true.

Definition even_n__even_SSn (n:nat) : Prop :=
  (even n) -> (even (S (S n))).

Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

Definition teen : nat->Prop := between 13 19.

Definition true_for_zero (P:nat->Prop) : Prop :=
  P 0.

Definition true_for_n__true_for_Sn (P:nat->Prop) (n:nat) : Prop :=
  P n -> P (S n).

Definition preserved_by_S (P:nat->Prop) : Prop :=
  forall n', P n' -> P (S n').

Definition true_for_all_numbers (P:nat->Prop) : Prop :=
  forall n, P n.

Definition our_nat_induction (P:nat->Prop) : Prop :=
     (true_for_zero P) ->
     (preserved_by_S P) ->
     (true_for_all_numbers P).

Inductive good_day : day -> Prop :=
  | gd_sat : good_day saturday
  | gd_sun : good_day sunday.

Theorem gds : good_day sunday.
Proof. apply gd_sun. Qed.

Inductive day_before : day -> day -> Prop :=
  | db_tue : day_before tuesday monday
  | db_wed : day_before wednesday tuesday
  | db_thu : day_before thursday wednesday
  | db_fri : day_before friday thursday
  | db_sat : day_before saturday friday
  | db_sun : day_before sunday saturday
  | db_mon : day_before monday sunday.

Inductive fine_day_for_singing : day -> Prop :=
  | fdfs_any : forall d:day, fine_day_for_singing d.

Theorem fdfs_wed : fine_day_for_singing wednesday.
Proof. apply fdfs_any. Qed.

Definition fdfs_wed' : fine_day_for_singing wednesday :=
  fdfs_any wednesday.

Inductive ok_day : day -> Prop :=
  | okd_gd : forall d,
      good_day d ->
      ok_day d
  | okd_before : forall d1 d2,
      ok_day d2 ->
      day_before d2 d1 ->
      ok_day d1.

Definition okdw : ok_day wednesday :=
  okd_before wednesday thursday
    (okd_before thursday friday
       (okd_before friday saturday
         (okd_gd saturday gd_sat)
         db_sat)
       db_fri)
    db_thu.

Theorem okdw' : ok_day wednesday.
Proof.
  apply okd_before with (d2:=thursday).
    apply okd_before with (d2:=friday).
      apply okd_before with (d2:=saturday).
          apply okd_gd. apply gd_sat.
          apply db_sat.
      apply db_fri.
  apply db_thu. Qed.

Print okdw'.

Definition okd_before2 := forall d1 d2 d3,
  ok_day d3 ->
  day_before d2 d1 ->
  day_before d3 d2 ->
  ok_day d1.

Theorem okd_before2_valid : okd_before2.
Proof.
  unfold okd_before2.
  intros.
  apply okd_before in H0. apply H0.
  apply okd_before in H1. apply H1.
  apply H. Qed.

Definition okd_before2_valid' : okd_before2 :=
  fun (d1 d2 d3 : day) =>
  fun (H : ok_day d3) =>
  fun (H0 : day_before d2 d1) =>
  fun (H1 : day_before d3 d2) =>
  okd_before d1 d2 (okd_before d2 d3 H H1) H0.

Theorem mult_0_r' : forall n:nat,
  n * 0 = 0.
Proof.
  apply nat_ind.
  Case "O". reflexivity.
  Case "S". simpl. intros n IHn. rewrite -> IHn.
    reflexivity. Qed.

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

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

Check rgb_ind.

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.

Inductive ExSet : Type :=
  | con1 : bool -> ExSet
  | con2 : nat -> ExSet -> ExSet.

Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.
Check tree_ind.

Inductive mytype (X:Type): Type :=
  | constr1 : X -> mytype X
  | constr2 : nat -> mytype X
  | constr3 : mytype X -> nat -> mytype X.

Check mytype_ind.

Inductive foo (X Y:Type) : Type :=
  | bar : X -> foo X Y
  | baz : Y -> foo X Y
  | quux : (nat -> foo X Y) -> foo X Y.

Check foo_ind.

Inductive foo' (X:Type) : Type :=
  | C1 : list X -> foo' X -> foo' X
  | C2 : foo' X.

Check foo'_ind.

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

Definition P_m0r' : nat->Prop :=
  fun n => n * 0 = 0.

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  Case "n = O". reflexivity.
  Case "n = S n'".
    unfold P_m0r. simpl. intros n' IHn'.
    apply IHn'. Qed.


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

Definition one  : Nat := S O.
Definition two : Nat := S (S O).
Definition three : Nat := S (S (S O)).
Definition four : Nat := S (S (S (S O))).
Definition five : Nat := S (S (S (S O))).
Definition six  : Nat := S (S four).

Definition isOne (n : Nat) : bool :=
  match n with
  | S O => true
  | _ => false
  end.

Eval compute in isOne four.
Eval compute in isOne six.
Eval compute in isOne O.
Eval compute in isOne (S O).

Fixpoint twice (n : Nat) : Nat :=
   match n with
   | O => O
   | S n' => S (S (twice n'))
   end.

Eval compute in twice six.

Lemma SStwice : forall (n : Nat), S (S (S (twice n))) = S (twice (S n)).
Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

Fixpoint f (n : Nat) : Nat := match n with
  | O => O
  | S n => f n
  end.

Check Type.

Lemma a (a : Nat) : f a = O.
Proof.
 induction a.
 - simpl. reflexivity.
 - simpl. rewrite IHa. reflexivity.
Qed.

(* Fixpoint f (n : Nat) : Nat := f n. *)

Fixpoint plus (n m : Nat) {struct n} : Nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Eval compute in plus (twice six) (twice four).

Notation "x + y" := (plus x y)
  (at level 50, left associativity).

Lemma leftid (n : Nat) : O + n = n.
Proof.
  simpl. reflexivity.
Qed.

Lemma rightid (n : Nat) : n + O = n.
Proof.
 induction n.
 - simpl. reflexivity.
 - simpl. rewrite IHn. reflexivity.
Qed.

Lemma assoc (a b c : Nat) : (a + b) + c = a + (b + c).
Proof.
  induction a.
  - simpl. reflexivity.
  - simpl. rewrite IHa. reflexivity.
Qed.

Lemma cong (f : Nat -> Nat)(a b : Nat) : a = b -> f a = f b.
Proof.
  intros a_eq_b.
  rewrite a_eq_b.
  reflexivity.
Qed.

Lemma plus_r_s : forall (a b : Nat), S a + b = a + S b.
Proof.
  intros.
  induction a0.
  - simpl. reflexivity.
  - simpl. rewrite <- IHa0. simpl. reflexivity.
Qed.

Fixpoint max (a b : Nat) : Nat :=
  match a, b with
  | O, b => b
  | S a, O => S a
  | S a, S b => S (max a b)
  end.

Compute (max four six).

Lemma idmax : forall (n : Nat ), (max O n) = n.
 intros n.
 simpl.
 reflexivity.
Qed.

Lemma idleftmax : forall (n : Nat ), (max n O) = n.
 induction n.
 all: simpl.
 all: reflexivity.
Qed.

Lemma comm (a b : Nat) : a + b = b + a.
Proof.
  induction a.
  - Check (rightid b). rewrite (rightid b). simpl. reflexivity.
  - rewrite <- (plus_r_s). simpl. rewrite IHa. reflexivity.
Qed.

Fixpoint pred (n : Nat) : Nat :=
  match n with
  | O => O
  | S n' => n'
  end.

(*Lemma S_inj (a b : Nat) : S a = S b -> a = b.
Proof.
  intros.*)

(*Definition P : Nat -> Prop := fun n => *)

(*Lemma O_S_disj (a : Nat) : O <> S a.
Proof. *)

Fixpoint times (a b : Nat) : Nat :=
  match a with
  | O => O
  | S O => b
  | S a' => b + (times a' b)
  end.

Notation "x * y" := (times x y)
  (at level 40, left associativity).

Lemma times_leftid (a : Nat) : S O * a = a.
Proof.
  simpl.
  reflexivity.
Qed.

Lemma times_rightid (a : Nat) : a * S O = a.
Proof.
  induction a.
  - simpl. reflexivity.
  - simpl. rewrite IHa. induction a0.
    * simpl. reflexivity.
    * reflexivity.
Qed.

Lemma times_leftzero (a : Nat) : O * a = O.
Proof.
  simpl.
  reflexivity.
Qed.

Lemma times_rightzero (a : Nat) : a * O = O.
Proof.
  induction a.
  - simpl. reflexivity.
  - simpl.  rewrite IHa. induction a0. all: auto.
Qed.

Lemma times_assoc (a b c : Nat) : (a * b) * c = a * (b * c).

(*Lemma times_comm (a b : Nat) : a * b = b * a.*)

(*Lemma decEq (a b : Nat) : a = b \/ a <> b.*)

*)

Inductive BinaryTree : Type :=
| Leaf (n : Nat)
| Node (l r : BinaryTree).

Definition tree : BinaryTree := Node (Node (Leaf one) (Node (Leaf  two) (Leaf three))) (Node (Leaf four) (Leaf five)).

Fixpoint height (t : BinaryTree) : Nat :=
  match t with
  | Leaf _ => O
  | Node t t' => one + (max (height t) (height t'))
  end.

Fixpoint leaves_count (t : BinaryTree) : Nat :=
  match t with
  | Leaf _ => one
  | Node l r => (leaves_count l) + (leaves_count r)
  end.

(*
 nehez HF:
  exp2 (height t)
  leaves_count t
*)

Fixpoint sum1 (t : BinaryTree) : Nat :=
match t with
| Leaf n => n
| Node l r => sum1 l + sum1 r
end.

Fixpoint sum2 (t : BinaryTree) : Nat :=
match t with
| Leaf n => n
| Node l r => sum2 r + sum2 l
end.

Lemma sum1_2_eq : forall t : BinaryTree, sum1 t = sum2 t.
Proof.
  intros.
  induction t.
  - simpl. reflexivity.
  - simpl. rewrite <- IHt2. rewrite <- IHt1. rewrite (comm). reflexivity.
Qed.

Fixpoint exp2 (n : Nat) : Nat :=
  match n with
  | O => S O
  | S m => exp2 m + exp2 m (* 2*2^m *)
  end.

Lemma leaves_height (t : BinaryTree) :
  max (exp2 (height t)) (leaves_count t) =
  exp2 (height t).


Set Warnings "-notation-overridden,-parsing".
Require Export logic.
Require Coq.omega.Omega.

Inductive ev : nat -> Prop :=
| ev_0 : ev 0
| ev_SS : forall n : nat, ev n -> ev (S (S n)).

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

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

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.
Lemma double_plus : forall n, double n = n + n.
  Proof.
Admitted.

Theorem ev_double : forall n,
  ev (double n).
Proof.
Admitted.
(** intros.
induction n.
-  apply ev_0.
- rewrite double_plus in IHn. unfold double. simpl.
  rewrite plus_comm. simpl. apply ev_SS. apply IHn.
Qed.
**)

Theorem ev_minus2 : forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E.
  inversion E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'. Qed.

Theorem evSS_ev : forall n,
  ev (S (S n)) -> ev n.
Proof.
intros. inversion H.
apply H1. Qed.

Theorem one_not_even : ~ ev 1.
Proof.
  intros H. inversion H. Qed.

Theorem SSSSev__even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
intros. inversion H. inversion H1. apply H3. Qed.

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
intros. inversion H. inversion H1. inversion H3. Qed.

Lemma ev_even_firsttry : forall n,
  ev n -> exists k, n = double k.
Proof.
intros.
inversion H.
- exists 0. reflexivity.
-(** assert (I : exists k', n' = double k' ->
                exists k, (S (S n')) = double k).
    { intros [k' Hk']. rewrite Hk'. exists (S k'). reflexivity. }
   apply I.**)
Admitted.

Lemma doublenum : forall n,
double n = n + n.
Proof.
Admitted.

Lemma ev_even : forall n,
  ev n -> exists k, n = double k.
Proof.
Admitted.
(**
  intros n E.
  induction E as [|n' E' IH].
  - (* E = ev_0 *)
    exists 0. reflexivity.
  - (* E = ev_SS n' E'
       with IH : exists k', n' = double k' *)
    destruct IH as [k' Hk'].
    rewrite Hk'. exists(S k'). simpl. rewrite plus_comm. simpl.
    symmetry. rewrite doublenum. reflexivity.
Qed.
**)

Theorem ev_even_iff : forall n,
  ev n <-> exists k, n = double k.
Proof.
intros.
split.
- apply ev_even.
- intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

Theorem ev_sum : forall n m, ev n -> ev m -> ev (n + m).
Proof.
intros.
induction H as [| n' En' EIHn' ].
- simpl. apply H0.
- apply ev_SS. apply EIHn'.
Qed.

Theorem ev_ev_ev : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
intros.
induction H0.
- simpl in H. apply H.
- simpl in H. inversion H.
  + apply IHev. apply H2.
Qed.

Lemma plus00 : forall n m,
m+n = 0 -> m =0 /\ n= 0.
Proof.
Admitted.

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
intros n m p Enm Enp.
apply ev_sum with (n:= n+m) (m:= n+p) in Enm.
replace (n+m +(n+p)) with ((n+n)+(m+p)) in Enm.
replace (n+n) with (double n) in Enm.
apply ev_ev_ev with (m:= m+p) in Enm.
apply Enm.
replace (double n+ (m+p)+(m+p)) with (double n + double (m+p)).
apply ev_sum.
apply ev_double.
apply ev_double.
rewrite double_plus with (n:=m+p).
rewrite plus_assoc. reflexivity.
rewrite double_plus. reflexivity.
rewrite <- plus_assoc.
replace (n+(m+p)) with (m+(n+p)).
rewrite plus_assoc.
reflexivity.
rewrite plus_assoc.
rewrite ( plus_comm m n).
rewrite <- plus_assoc. reflexivity.
apply Enp.
Qed.

Inductive le : nat -> nat -> Prop :=
  | le_n : forall n, le n n
  | le_S : forall n m, (le n m) -> (le n (S m)).

Notation "m <= n" := (le m n).

Theorem test_le1 :
  3 <= 3.
Proof.
  apply le_n. Qed.

Theorem test_le2 :
  3 <= 6.
Proof.
  (* WORKED IN CLASS *)
  apply le_S. apply le_S. apply le_S. apply le_n. Qed.

Theorem test_le3 :
  (2 <= 1) -> 2 + 2 = 5.
Proof.
intros.
inversion H. inversion H2. Qed.

Definition relation (X:Type) := X -> X -> Prop.
Definition reflexive {X:Type} (R: relation X) :=
	forall a : X, R a a.
Definition transitive {X:Type} (R: relation X) :=
forall n m o : X, (R n m) -> (R m o) -> (R n o).

Lemma le_trans : forall m n o, m <= n -> n <= o -> m <= o.
Proof.
intros m n o Hnm Hno.
  induction Hno.
  - apply Hnm.
  - apply le_S. apply IHHno. apply Hnm. Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
intros.
induction n.
- apply le_n.
- apply le_S. apply IHn.
Qed.

Lemma nleSn : forall n,
n<= S n.
Proof.
Admitted.

Lemma nlessSm : forall n m,
n<=m -> n <= S m.
Proof.
Admitted.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H.
  apply le_n.
  apply le_S. apply IHle.
Qed.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
intros. inversion H.
- apply le_n.
- apply le_trans with (n := S n). apply nleSn.
 apply H2. Qed.

Lemma plusO : forall n,
n+0 = n.
Proof.
Admitted.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
intros.
induction b.
- rewrite plusO. apply le_n.
- rewrite plus_comm. simpl. apply le_S.
rewrite plus_comm. apply IHb.
Qed.

Definition lt (n m:nat) := le (S n) m.
Notation "m < n" := (lt m n).

Lemma O_lt_n : forall n,
  0 < n.
Proof.
Admitted.
Lemma lessS : forall n m,
 n <= m ->  n <= S m.
Proof.
Admitted.

Lemma nleqn : forall n,
n<= n.
Proof.
Admitted.
Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
unfold lt.
Admitted.

Theorem lt_S : forall n m,
  n < m ->
  n < S m.
Proof.
intros.
inversion H.
- unfold lt. apply le_S. apply nleqn.
- unfold lt. apply le_S. apply lessS in H0. apply H0.
Qed.

Inductive reg_exp {T : Type} : Type :=
| EmptySet : reg_exp
| EmptyStr : reg_exp
| Char : T -> reg_exp
| App : reg_exp -> reg_exp -> reg_exp
| Union : reg_exp -> reg_exp -> reg_exp
| Star : reg_exp -> reg_exp.

Inductive exp_match {T} : list T -> reg_exp -> Prop :=
| MEmpty : exp_match [] EmptyStr
| MChar : forall x, exp_match [x] (Char x)
| MApp : forall s1 re1 s2 re2,
           exp_match s1 re1 ->
           exp_match s2 re2 ->
           exp_match (s1 ++ s2) (App re1 re2)
| MUnionL : forall s1 re1 re2,
              exp_match s1 re1 ->
              exp_match s1 (Union re1 re2)
| MUnionR : forall re1 s2 re2,
              exp_match s2 re2 ->
              exp_match s2 (Union re1 re2)
| MStar0 : forall re, exp_match [] (Star re)
| MStarApp : forall s1 s2 re,
               exp_match s1 re ->
               exp_match s2 (Star re) ->
               exp_match (s1 ++ s2) (Star re).

Notation "s =~ re" := (exp_match s re) (at level 80).

Example reg_exp_ex1 : [1] =~ Char 1.
Proof.
  apply MChar.
Qed.

Example reg_exp_ex2 : [1; 2] =~ App (Char 1) (Char 2).
Proof.
apply (MApp [1] _ [2]).
- apply MChar.
- apply MChar.
Qed.

Example reg_exp_ex3 : ~ ([1; 2] =~ Char 1).
Proof.
  intros H. inversion H.
Qed.

Fixpoint reg_exp_of_list {T: Type} (l : list T) :=
  match l with
  | [] => EmptyStr
  | x :: l' => App (Char x) (reg_exp_of_list l')
  end.

Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3].
Proof.
simpl. apply ( MApp [1]). apply MChar. apply ( MApp [2]).
apply MChar. apply ( MApp [3]). apply MChar. apply MEmpty.
Qed.

Lemma MStar1 :
  forall T s (re : @reg_exp T) ,
    s =~ re ->
    s =~ Star re.
Proof.
intros.
rewrite <- (app_nil_r T s).
apply (MStarApp s [] re).
apply H. apply MStar0.
Qed.

Lemma empty_is_empty : forall T (s : list T),
  ~ (s =~ EmptySet).
Proof.
intros.
induction s.
- unfold not.
intros.
inversion H.
Admitted.

Lemma MUnion' : forall T (s : list T) (re1 re2 : @reg_exp T),
  s =~ re1 \/ s =~ re2 ->
  s =~ Union re1 re2.
Proof.
intros.
inversion H.
- apply MUnionL. apply H0.
- apply MUnionR. apply H0.
Qed.

Lemma MStar' : forall T (ss : list (list T)) (re : reg_exp),
  (forall s, In s ss -> s =~ re) ->
  fold app ss [] =~ Star re.
Proof.
intros.
Admitted.

Lemma reg_exp_of_list_spec : forall T (s1 s2 : list T),
  s1 =~ reg_exp_of_list s2 <-> s1 = s2.
Proof.
intros.
unfold iff.
split.
- intros.
Admitted.

Fixpoint re_chars {T} (re : reg_exp) : list T :=
  match re with
  | EmptySet => []
  | EmptyStr => []
  | Char x => [x]
  | App re1 re2 => re_chars re1 ++ re_chars re2
  | Union re1 re2 => re_chars re1 ++ re_chars re2
  | Star re => re_chars re
  end.
Lemma equalrelist : forall T (s : list T) (re : reg_exp),
 s =~ re -> s = (re_chars re).
Proof.
Admitted.

Theorem in_re_match : forall T (s : list T) (re : reg_exp) (x : T),
  s =~ re ->
  In x s ->
  In x (re_chars re).
Proof.
(**intros. apply equalrelist in H. rewrite <- H. apply H0.**)
intros T s re x Hmatch Hin.
  induction Hmatch
    as [| x'
        | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
        | s1 re1 re2 Hmatch IH | re1 s2 re2 Hmatch IH
        | re | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  - (* MEmpty *)
    apply Hin.
  - (* MChar *)
    apply Hin.
  - simpl. rewrite In_app_iff in *.
    destruct Hin as [Hin | Hin].
    + (* In x s1 *)
      left. apply (IH1 Hin).
    + (* In x s2 *)
      right. apply (IH2 Hin).
  - (* MUnionL *)
    simpl. rewrite In_app_iff.
    left. apply (IH Hin).
  - (* MUnionR *)
    simpl. rewrite In_app_iff.
    right. apply (IH Hin).
  - (* MStar0 *)
    destruct Hin.
- (* MStarApp *)
    simpl. rewrite In_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    + (* In x s1 *)
      apply (IH1 Hin).
    + (* In x s2 *)
      apply (IH2 Hin).
Qed.


Require Import Bool.

(* Please ignore:
   negb is just another name for
   the not function for booleans,
   more on that later.
*)
Definition not := negb.

Theorem deMorgen: forall x y:bool,
  not (x || y) = (not x) && (not y).
Proof.
Abort.

Theorem deMorgen_answer: forall x y:bool,
  not (x || y) = (not x) && (not y).
Proof.
intros.
(* We can start by doing case analysis on x into its two cases.
   Almost like a truth table for computer scientists or
   A very lame induction for mathematicians.
*)
Print bool.
(*
  We can see that a bool is either true of false
*)
case x.
(* Now we have two cases to prove,
   lets focus on our first goal
*)
-
(* Seems like some of this equation is simply solvable.
   simpl can partially apply functions,
   for you have only supplied limited arguments. *)
  simpl.
(* false = false is true by reflexivity *)
  reflexivity.
(* Coq helps us remember all cases.
   The proof cannot complete,
   if we haven't proved it for all cases.
*)
- (* seems like this can also be simplified *)
  simpl.
  (* not y = not y, no matter what y is *)
  reflexivity.
Qed.
(* Qed = Proven *)


Require Import Ashley.Set.

Class Equivalence (A:Type) : Type :=
{
  eqv : A -> A -> Prop;
  equiv_reflexive : forall a, eqv a a;
  equiv_symmetric : forall a b, eqv a b -> eqv b a;
  equiv_transitive : forall a b c, (eqv a b /\ eqv b c) -> eqv a c
}.

Definition equivalence_class {A} (E : Equivalence A) (p : A) : set A := {a : A|eqv p a}.

Lemma in_equivalence_class : forall A (e : Equivalence A) (p : A), equivalence_class e p p.
intros.
unfold equivalence_class.
apply equiv_reflexive.
Save.

Definition quotient {A} (e : Equivalence A) : set (set A) :=
  {sa : set A| exists a1, (sa = equivalence_class e a1)}.

Lemma quotient_disjoint : forall A (e : Equivalence A), all p1 : quotient e, all p2 : quotient e,
  (undisjoint p1 p2 -> p1 = p2).
firstorder.
rewrite H.
rewrite H0.
apply member_ext.
rewrite H in H1.
rewrite H0 in H2.
firstorder.
apply (equiv_transitive x0 x x2).
split.
apply (equiv_transitive x0 x1 x).
split.
apply H2.
apply equiv_symmetric.
apply H1.
apply H3.
apply (equiv_transitive x x1 x2).
split.
apply H1.
apply (equiv_transitive x1 x0 x2).
split.
apply equiv_symmetric.
apply H2.
apply H3.
Save.

Lemma quotient_Union : forall A (e : Equivalence A), is_full (Union (quotient e)).
intros.
unfold Union.
unfold quotient.
unfold is_full.
intros.
exists (equivalence_class e x).
split.
exists x.
trivial.
unfold equivalence_class.
apply equiv_reflexive.
Save.

Lemma quotient_no_empty : forall A (e : Equivalence A) (s : set A), quotient e s -> not_empty s.
unfold quotient.
unfold not_empty.
intros.
destruct H.
exists x.
rewrite H.
apply in_equivalence_class.
Save.

Require Import Ashley.SetFunction.

Definition quotient_type {A:Type} (e: Equivalence A) : Type :=  set_type (quotient e).


(* week-03_binary-trees.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 29 Aug 2017 *)

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

(* Paraphernalia: *)

Ltac unfold_tactic name := intros; unfold name; (* fold name; *) reflexivity.

Require Import Arith Bool.

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

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

Inductive binary_tree : Type :=
| Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Definition test_number_of_leaves (candidate: binary_tree -> nat) :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 2)) (Leaf 3)) =n= 3)
  (* etc. *)
  .

Fixpoint number_of_leaves (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    1
  | Node t1 t2 =>
    (number_of_leaves t1) + (number_of_leaves t2)
  end.

Compute (test_number_of_leaves number_of_leaves).

Lemma unfold_number_of_leaves_Leaf :
  forall n : nat,
    number_of_leaves (Leaf n) =
    1.
Proof.
  unfold_tactic number_of_leaves.
Qed.

Lemma unfold_number_of_leaves_Node :
  forall t1 t2 : binary_tree,
    number_of_leaves (Node t1 t2) =
    (number_of_leaves t1) + (number_of_leaves t2).
Proof.
  unfold_tactic number_of_leaves.
Qed.

Fixpoint number_of_nodes (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    0
  | Node t1 t2 =>
    S ((number_of_nodes t1) + (number_of_nodes t2))
  end.

Lemma unfold_number_of_nodes_Leaf :
  forall n : nat,
    number_of_nodes (Leaf n) =
    0.
Proof.
  unfold_tactic number_of_nodes.
Qed.

Lemma unfold_number_of_nodes_Node :
  forall t1 t2 : binary_tree,
    number_of_nodes (Node t1 t2) =
    S ((number_of_nodes t1) + (number_of_nodes t2)).
Proof.
  unfold_tactic number_of_nodes.
Qed.

Theorem on_the_relative_number_of_leaves_and_nodes_in_a_binary_tree :
  forall t : binary_tree,
    number_of_leaves t = S (number_of_nodes t).
Proof.
  intro t.
  induction t as [ n | t1 IH_t1 t2 IH_t2].

  Check(unfold_number_of_leaves_Leaf n).
  rewrite -> (unfold_number_of_leaves_Leaf n).
  Check(unfold_number_of_nodes_Leaf n).
  rewrite -> (unfold_number_of_nodes_Leaf n).
  reflexivity.

  Check (unfold_number_of_leaves_Node t1 t2).
  rewrite -> (unfold_number_of_leaves_Node t1 t2).
  Check (unfold_number_of_nodes_Node t1 t2).
  rewrite -> (unfold_number_of_nodes_Node t1 t2).
  rewrite -> IH_t1.
  rewrite -> IH_t2.
  Search (S _ + S _ = S (S (_ + _))).
  Search (S _ + S _ = S _ ).
  Check (plus_Sn_m (number_of_nodes t1) (S (number_of_nodes t2))).
  rewrite -> (plus_Sn_m (number_of_nodes t1) (S (number_of_nodes t2))).
  Search (_ + S _ = S _).
  rewrite -> (Nat.add_succ_r (number_of_nodes t1) (number_of_nodes t2)).
  reflexivity.

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

(* end of week-03_binary-trees.v *)


Require Import ZArith.
Require Import Equivalence.
Require Import Morphisms.

Module ZFunc.

Local Open Scope Z.

Definition add {A: Type} (f g: A -> Z): A -> Z :=
  fun a => f a + g a.

Definition sub {A: Type} (f g: A -> Z): A -> Z :=
  fun a => f a - g a.

Definition mul {A: Type} (f g: A -> Z): A -> Z :=
  fun a => f a * g a.

Definition test_eq {A: Type} (f g: A -> Z): A -> Prop :=
  fun a => f a = g a.

Definition test_le {A: Type} (f g: A -> Z): A -> Prop :=
  fun a => f a <= g a.

Definition equiv {A: Type} (f g: A -> Z): Prop :=
  forall a, f a = g a.

Definition le {A: Type} (f g: A -> Z): Prop :=
  forall a, f a <= g a.

End ZFunc.

Declare Scope func_scop.
Delimit Scope func_scope with Func.

Notation "f + g" := (ZFunc.add f g): func_scope.
Notation "f - g" := (ZFunc.sub f g): func_scope.
Notation "f * g" := (ZFunc.mul f g): func_scope.

Lemma Func_equiv_refl: forall A, Reflexive (@ZFunc.equiv A).
Proof.
  intros.
  unfold Reflexive.
  unfold ZFunc.equiv.
  intros.
  reflexivity.
Qed.

Lemma Func_equiv_sym: forall A, Symmetric (@ZFunc.equiv A).
Proof.
  intros.
  unfold Symmetric.
  unfold ZFunc.equiv.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Func_equiv_trans: forall A, Transitive (@ZFunc.equiv A).
Proof.
  intros.
  unfold Transitive.
  unfold ZFunc.equiv.
  intros.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_add_equiv: forall A,
  Proper (@ZFunc.equiv A ==> @ZFunc.equiv A ==> @ZFunc.equiv A) ZFunc.add.
Proof.
  intros.
  unfold Proper, respectful.
  intros f1 f2 ? g1 g2 ?.
  unfold ZFunc.equiv in H.
  unfold ZFunc.equiv in H0.
  unfold ZFunc.equiv.
  intros.
  unfold ZFunc.add.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_sub_equiv: forall A,
  Proper (@ZFunc.equiv A ==> @ZFunc.equiv A ==> @ZFunc.equiv A) ZFunc.sub.
Proof.
  intros.
  unfold Proper, respectful.
  intros f1 f2 ? g1 g2 ?.
  unfold ZFunc.equiv in H.
  unfold ZFunc.equiv in H0.
  unfold ZFunc.equiv.
  intros.
  unfold ZFunc.sub.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma Func_mul_equiv: forall A,
  Proper (@ZFunc.equiv A ==> @ZFunc.equiv A ==> @ZFunc.equiv A) ZFunc.mul.
Proof.
  intros.
  unfold Proper, respectful.
  intros f1 f2 ? g1 g2 ?.
  unfold ZFunc.equiv in H.
  unfold ZFunc.equiv in H0.
  unfold ZFunc.equiv.
  intros.
  unfold ZFunc.mul.
  rewrite H, H0.
  reflexivity.
Qed.

Existing Instances Func_equiv_refl
                   Func_equiv_sym
                   Func_equiv_trans
                   Func_add_equiv
                   Func_sub_equiv
                   Func_mul_equiv.