(* Chap 1 Basics *)
(* Chap 1.1 Data and Functions *)
(* Days of the week *)
Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

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

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

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

(* Booleans *)
Inductive bool : Type :=
  | true
  | false.

Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

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

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

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

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

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1: bool) (b2: bool) : bool := negb (b1 && b2).

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

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

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

(* Types *)
Check true.
Check (negb true).
Check negb.

(* New Types from Old *)
Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p: rgb).

Definition monochrome (c: color) : bool :=
  match c with
  | black => true
  | white => true
  | primary q => false
  end.

Definition isred (c: color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
  end.
(* Note: _ is a shorthand for primary applied
   to any rgb constructor except red. *)

(* Tuples *)
Inductive bit : Type :=
  | B0
  | B1.

Inductive nybble : Type :=
  | bits (b0 b1 b2 b3: bit).

Check (bits B1 B0 B1 B0).

Definition all_zero (nb: nybble) : bool :=
  match nb with
  | (bits B0 B0 B0 B0) => true
  | _ => false
  end.

Compute (all_zero (bits B1 B0 B1 B0)).
Compute (all_zero (bits B0 B0 B0 B0)).

(* Modules *)
(* Note: like namespace in Cpp *)

Module NatPlayground.

(* Numbers *)
Inductive nat : Type :=
  | O
  | S (n: nat).

Inductive nat' : Type :=
  | stop
  | tick (foo: nat').
(* Note: these shows that O and S have no
   special meanings, they are just symbols. *)

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

End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n: nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minustwo 4).

Check S.
Check pred.
Check minustwo.

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

Definition oddb (n: nat) : bool := negb (evenb n).

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

Module NatPlayground2.

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

Compute (plus 3 2).

Fixpoint mult (n m: nat) : nat :=
  match n with
  | O => O
  | S n' => plus m (mult n' m)
  end.
(* Note: (n m: nat) equals to (n: nat) (m: nat) *)

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

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

End NatPlayground2.

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

(* Exercise factorial *)
Fixpoint factorial (n: nat) : nat :=
  match n with
  | O => S O
  | S n' => mult (S n') (factorial n')
  end.

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

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

Check ((0 + 1) + 1).

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

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

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

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
Example test_leb3': (4 <=? 2) = false.
Proof. simpl. reflexivity. Qed.

(* Exercise ltb *)

Definition ltb (n m : nat) : bool :=
  (leb n m) && (negb (eqb n m)).

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

(* Chap 1.2 Proof by Simplification *)
Theorem plus_O_n: forall n: nat, 0 + n = n.
Proof.
  intros n.
  simpl.   (* Note: sometimes we don't need simpl. *)
  reflexivity.
Qed.

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

Theorem mult_0_l: forall n:nat, 0 * n = 0.
Proof.
  intros n.
  reflexivity.
Qed.
(* Note: _l means on the left (is L not one) *)

(* Chap 1.3 Proof by rewriting *)
Theorem plus_id_example: forall n m: nat,
  n = m -> n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_exercise: forall n m o: nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o H1 H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Theorem mult_0_plus: forall n m: nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

(* Exercise: mult_S_1 *)
Theorem mult_S_1: forall n m: nat,
  m = S n -> m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> plus_1_l.
  rewrite <- H.
  reflexivity.
Qed.

(* Chap 1.4 Proof by Case Analysis *)
Theorem plus_1_neq_0: forall n: nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  destruct n.
  - reflexivity.
  - reflexivity.
Qed.

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

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

Theorem andb3_exchange:
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d.
  destruct b.
  - destruct c.
    + destruct d.
      * reflexivity.
      * reflexivity.
    + destruct d.
      * reflexivity.
      * reflexivity.
  - reflexivity.
Qed.

Theorem plus_1_neq_0': forall n: nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.
(* Note: means exactly same as:
  intros n'.
  destruct n' as [|n].*)

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

(* Exercise andb_true_elim2 *)
Theorem andb_true_elim2: forall b c: bool,
  andb b c = true -> c = true.
Proof.
  intros b c.
  destruct c.
  - reflexivity.
  - intros H.
    rewrite <- H.
    rewrite -> andb_commutative.
    reflexivity.
Qed.

(* Exercise zero_nbeq_plus_1 *)
Theorem zero_nbeq_plus_1: forall n: nat,
  0 =? (n + 1) = false.
Proof.
  intros n.
  destruct n.
  - reflexivity.
  - reflexivity.
Qed.

(* Chap 1.5 More Exercises *)

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

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

Inductive bin : Type :=
  | Z
  | A (n: bin)
  | B (n: bin).

Fixpoint incr (m: bin) : bin :=
  match m with
  | Z => B Z
  | A n => B n
  | B n => A (incr n)
  end.

Example test_bin_inc1: incr Z = B Z.
Proof. reflexivity. Qed.
Example test_bin_inc2: incr (A (A (B Z))) = (B (A (B Z))).
Proof. reflexivity. Qed.
Example test_bin_inc3: incr (B (B (B Z))) = (A (A (A (B Z)))).
Proof. reflexivity. Qed.

Fixpoint bin_to_nat' (m: bin) : nat :=
  match m with
  | Z => O
  | A m => plus (bin_to_nat' m) (bin_to_nat' m)
  | B m => plus (plus (bin_to_nat' m) (bin_to_nat' m)) (S O)
  end.
(* Original Form: too stupid. *)

Fixpoint bin_to_nat (m: bin) : nat :=
  match m with
  | Z => 0
  | A m => 2 * (bin_to_nat m)
  | B m => 1 + 2 * (bin_to_nat m)
  end.

Example test_bin_to_nat1: bin_to_nat (A (A (A (B Z)))) = 8.
Proof. reflexivity. Qed.
Example test_bin_to_nat2: bin_to_nat (B (A (B Z))) = 5.
Proof. reflexivity. Qed.


From mathcomp Require Import ssreflect.

Require Import collect_operator.
Require Import direct_product.
Require Import binary_relation.

(* 写像のグラフは集合である.
   グラフは2つの集合の直積集合の部分集合であり,第一射影の要素に対して第二射影の要素がただ一つ決まる. *)
(* 写像のグラフが満たさないと行けない条件 *)
Definition ConditionOfGraphOfMapping {U:Type} (G:TypeOfDirectProduct U) (A B:Collection U) :=
  G ⊂ A × B /\ forall x:U, x ∈ A -> exists! y:U, <|x,y|> ∈ G.

Definition MappingFunction {U:Type} (f: U -> U) (A B:Collection U) :=
  forall x:U, x ∈ A -> exists y:U, y = f x /\ y ∈ B.

(* 関数が与えられると決定されるGraph *)
Definition GraphOfFunction {U:Type} (f: U -> U) (A B:Collection U) :
  TypeOfDirectProduct U := GraphOfBinaryRelation (fun (x y:U) => y = f x) A B.

Definition IdentityFunction U : U -> U := fun x:U => x.

Definition GraphOfIdentity {U:Type} (X:Collection U) : TypeOfDirectProduct U :=
  GraphOfFunction (IdentityFunction U) X X.

Definition CompoundFunction {U:Type} (g f: U -> U) : U -> U :=
  fun x:U => g ( f x ).

(* Unicode ◦ :25E6*)
Notation "g ◦ f" :=  (CompoundFunction g f) (right associativity, at level 33).

Axiom AxiomOfFuncionalExtensionality: forall (U:Type) (f g :U -> U),
    (forall x:U, f x = g x) -> f = g.

Section Mapping.
  Variable U:Type.

  Theorem function_determine_domain:
    forall {f:U -> U} (A B:Collection U) (G:TypeOfDirectProduct U),
      G = GraphOfFunction f A B -> 𝕯( G ) ⊂ A.
  Proof.
    move => f A B G HG.
    move: (relation_determine_domain U (fun (x y:U) => y = f x) A B G).
    apply.
    rewrite HG.
    reflexivity.
  Qed.

  Theorem function_determine_range:
    forall {f:U -> U} (A B:Collection U) (G:TypeOfDirectProduct U),
      G = GraphOfFunction f A B -> 𝕽( G ) ⊂ B.
  Proof.
    move => f A B G HG.
    move: (relation_determine_range U (fun (x y:U) => y = f x) A B G).
    apply.
    rewrite HG.
    reflexivity.
  Qed.

  Theorem direct_product_included_graph_of_function:
    forall (f:U -> U) (A B:Collection U) (G:TypeOfDirectProduct U),
      G = GraphOfFunction f A B -> G ⊂ A × B.
  Proof.
    move => A B G.
    apply graph_of_correspondence_is_subset_of_direct_product.
  Qed.

  Lemma rewrite_function_range:
    forall (f:U -> U) (A B:Collection U),
      (forall x:U, exists y:U, y = f x /\ <|x, y|> ∈ A × B) ->
      (forall x:U, exists y:U, x ∈ A /\ y = f x /\ y ∈ B).
  Proof.
    move => f A B H x.
    move: (H x) => Hx.
    inversion Hx as [y [Hf HAB]].
    exists y.
    apply ordered_pair_in_direct_product_to_in_and in HAB.
    inversion HAB as [HA HB].
    split;[trivial|split; trivial].
  Qed.

  Theorem function_satisfies_graph_of_mapping:
    forall (f:U -> U) (A B:Collection U) (G:TypeOfDirectProduct U),
      (forall x:U, exists y:U, y = f x /\ <|x, y|> ∈ A × B) ->
      G = GraphOfFunction f A B ->
      ConditionOfGraphOfMapping G A B.
  Proof.
    move => f A B G HF HG.
    split.
    +apply (direct_product_included_graph_of_function f). by [].
    +move => x HA.
     move: (HF x) => HFx.
     inversion HFx as [y []].
     exists y.
     split.
     rewrite HG.
     split.
     exists x.
     exists y.
     split; [reflexivity|split;trivial].
     move => z HG0.
     rewrite HG in HG0.
     inversion HG0.
     inversion H1 as [x0 [z0 [Heqz [Hfz HABz]]]].
     apply ordered_pair_to_and in Heqz.
     inversion Heqz.
     rewrite -H3 -H4 in Hfz.
     rewrite -Hfz in H.
     trivial.
  Qed.

  Theorem image_of_function_of_domain_is_empty_is_empty:
    forall (f:U -> U) (A B:Collection U) (G:TypeOfDirectProduct U),
      G = GraphOfFunction f A B -> 𝕴𝖒( G , `Ø` ) = `Ø`.
  Proof.
    move => f A B G HG.
    apply (image_of_domain_is_empty_is_empty U (fun x y:U => y = f x) A B).
    rewrite HG.
    reflexivity.
  Qed.

  Theorem condition_of_image_of_function_is_not_empty:
    forall (f:U -> U) (A B C:Collection U) (G:TypeOfDirectProduct U),
      MappingFunction f A B ->
      C <> `Ø` -> C ⊂ A ->
      G = GraphOfFunction f A B ->
      exists (y:U), y ∈ 𝕴𝖒( G , C ).
  Proof.
    move => f A B C G HF HNEC HCA HG.
    apply: (condition_of_image_of_binary_relation_is_not_empty U (fun x y:U => y = f x) A B).
    apply HF.
    apply HNEC.
    apply HCA.
    trivial.
  Qed.

  Theorem mapping_function_to_singleton_image:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      y = f x ->
      {|y|} = 𝕴𝖒( F , {|x|} ).
  Proof.
    move => f X Y F x y Hf HF HxX Hyfx.
    have L1: exists y:U, y = f x /\ y ∈ Y.
    apply Hf.
    trivial.
    apply mutally_included_to_eq.
    split.
    +move => y0 H.
     apply singleton_to_eq in H.
     split.
     exists x.
     split.
     apply eq_to_singleton.
     reflexivity.
     rewrite H.
     rewrite HF.
     split.
     inversion L1 as [y1].
     exists x.
     exists y.
     split.
     reflexivity.
     split.
     trivial.
     apply ordered_pair_in_direct_product_iff_in_and.
     split.
     trivial.
     inversion H0.
     rewrite H1 in H2.
     rewrite Hyfx.
     assumption.
    +move => y0 H.
     inversion H as [y1].
     inversion H0 as [x0].
     inversion H2.
     apply singleton_to_eq in H3.
     rewrite H3 in H4.
     rewrite HF in H4.
     inversion H4 as [Z' [x1 [y2]]].
     inversion H5.
     apply ordered_pair_to_and in H7.
     inversion H7.
     rewrite -H10 -H9 in H8.
     inversion H8.
     rewrite H11.
     apply eq_to_singleton.
     apply eq_sym.
     assumption.
  Qed.

  Theorem singleton_image_to_mapping_function:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      {|y|} = 𝕴𝖒( F , {|x|} ) ->
      y = f x.
  Proof.
    move => f X Y F x y Hf HF HxX H.
    have L1: exists y:U, y = f x /\ y ∈ Y.
    apply Hf.
    trivial.
    apply mutally_included_iff_eq in H.
    inversion H.
    inversion L1 as [y0].
    inversion H2.
    rewrite -H3.
    apply eq_sym.
    apply singleton_to_eq.
    apply: (H1 y0).
    split.
    exists x.
    split.
    apply singleton_iff_eq.
    reflexivity.
    rewrite HF.
    split.
    exists x.
    exists y0.
    split.
    reflexivity.
    split.
    trivial.
    apply ordered_pair_in_direct_product_iff_in_and.
    split; assumption.
  Qed.

  Theorem mapping_function_iff_singleton_image:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      y = f x <->
      {|y|} = 𝕴𝖒( F , {|x|} ).
  Proof.
    move => f X Y F x y Hf HF HxX.
    rewrite /iff; split;
      [apply: (mapping_function_to_singleton_image f X Y)|
       apply: (singleton_image_to_mapping_function f X Y)];
      trivial;
      trivial;
      assumption.
  Qed.

  Theorem singleton_domain_image_eq_to_function_eq:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U) (x:U),
      MappingFunction f X Y ->
      MappingFunction g X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g X Y ->
      x ∈ X ->
      𝕴𝖒( F , {|x|} ) = 𝕴𝖒( G , {|x|} ) ->
      f x = g x.
  Proof.
    move => f g X Y F G x Hf Hg HF HG HxX HI.
    have L1: exists y:U, y = f x /\ y ∈ Y.
    apply Hf.
    trivial.
    have L2: exists y:U, y = g x /\ y ∈ Y.
    apply Hg.
    trivial.
    inversion L1 as [y0].
    inversion L2 as [y1].
    inversion H.
    inversion H0.
    apply eq_sym.
    rewrite -H3.
    apply: (singleton_image_to_mapping_function f X Y F x y1);trivial.
    rewrite HI.
    apply: (mapping_function_to_singleton_image g X Y G x y1);trivial.
  Qed.

  Theorem function_eq_to_singleton_domain_image_eq:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U) (x:U),
      MappingFunction f X Y ->
      MappingFunction g X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g X Y ->
      x ∈ X ->
      f x = g x ->
      𝕴𝖒( F , {|x|} ) = 𝕴𝖒( G , {|x|} ).
  Proof.
    move => f g X Y F G x Hf Hg HF HG HxX Heq.
    apply mutally_included_to_eq.
    split => y H;
               inversion H as [y0 [x0]];
               inversion H0;
               apply singleton_to_eq in H2;
               rewrite H2 in H3;[rewrite HF in H3|
                                 rewrite HG in H3];
               split;
               exists x; split.
    +apply singleton_iff_eq;reflexivity.
     rewrite HG.
     inversion H3.
     inversion H4 as [x1 [y1]].
     inversion H6.
     apply ordered_pair_to_and in H7.
     inversion H7.
     rewrite -H9 -H10 in H8.
     split.
     exists x.
     exists y.
     split;[reflexivity|rewrite Heq in H8;assumption].
    +apply singleton_iff_eq;reflexivity.
     rewrite HF.
     inversion H3.
     inversion H4 as [x1 [y1]].
     inversion H6.
     apply ordered_pair_to_and in H7.
     inversion H7.
     rewrite -H9 -H10 in H8.
     split.
     exists x.
     exists y.
     split;[reflexivity|rewrite -Heq in H8;assumption].
  Qed.

  Theorem singleton_domain_image_eq_iff_function_eq:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U) (x:U),
      MappingFunction f X Y ->
      MappingFunction g X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g X Y ->
      x ∈ X ->
      𝕴𝖒( F , {|x|} ) = 𝕴𝖒( G , {|x|} ) <->
      f x = g x.
  Proof.
    move => f g X Y F G x Hf Hg HF HG HxX.
    rewrite /iff.
    split;[apply (singleton_domain_image_eq_to_function_eq f g X Y)|
           apply (function_eq_to_singleton_domain_image_eq f g X Y)];
    trivial;
    trivial;
    trivial;
    trivial.
  Qed.

  Theorem graph_of_function_eq_to_function_eq:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      MappingFunction g X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g X Y ->
      F = G -> (forall x:U, x ∈ X -> f x = g x).
  Proof.
    move => f g X Y F G Hf Hg HF HG Heq x HxX.
    apply (singleton_domain_image_eq_to_function_eq f g X Y F G);trivial.
    rewrite Heq.
    reflexivity.
  Qed.

  Theorem function_eq_to_graph_of_function_eq:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      MappingFunction g X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g X Y ->
      (forall x:U, x ∈ X -> f x = g x) ->
      F = G.
  Proof.
    move => f g X Y F G Hf Hg HF HG Heq.
    rewrite HF HG.
    apply mutally_included_to_eq.
    split => Z' H; inversion H as [Z0' [x0 [y0]]];
               [inversion H0 as [HZ0' [Hy0fx0 HX0Y0]]|
                inversion H0 as [HZ0' [Hy0gx0 HX0Y0]]];
               apply ordered_pair_in_direct_product_iff_in_and in HX0Y0;
               inversion HX0Y0;
               split;
               exists x0;
               exists y0;
               move: (Heq x0) => Heqx0;
                                   apply Heqx0 in H2;
                                   [rewrite -H2|rewrite H2];trivial.
  Qed.

  Theorem graph_of_function_eq_iff_function_eq:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      MappingFunction g X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g X Y ->
      F = G <-> (forall x:U, x ∈ X -> f x = g x).
  Proof.
    move => f g X Y F G Hf Hg HF HG.
    rewrite /iff.
    split;[apply (graph_of_function_eq_to_function_eq f g X Y F G)|
           apply (function_eq_to_graph_of_function_eq f g X Y F G)];
    trivial.
  Qed.

  Theorem singleton_image_to_ordered_pair_in_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      {| y |} = 𝕴𝖒( F , {| x |} ) ->
      <|x,y|> ∈ F.
  Proof.
    move => f X Y F x y Hf HF HxX HI.
    have L1: exists y:U, y = f x /\ y ∈ Y.
    apply Hf.
    trivial.
    inversion L1 as [y0 [Hy0fx HY]].
    apply (singleton_image_to_mapping_function f X Y F) in HI.
    rewrite HF.
    split.
    exists x.
    exists y0.
    rewrite -HI in Hy0fx.
    rewrite Hy0fx.
    rewrite Hy0fx in HY.
    split;[reflexivity|split;[trivial|
                              apply ordered_pair_in_direct_product_iff_in_and;
                              split;
                              trivial]].
    trivial.
    trivial.
    assumption.
  Qed.

  Theorem ordered_pair_in_graph_to_singleton_image:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      <|x,y|> ∈ F ->
      {| y |} = 𝕴𝖒( F , {| x |} ).
  Proof.
    move => f X Y F x y Hf HF HxX HoF.
    have L1: exists y:U, y = f x /\ y ∈ Y.
    apply Hf.
    trivial.
    inversion L1 as [y0 [Hy0fx HY]].
    apply (mapping_function_to_singleton_image f X Y F); trivial.
    rewrite HF in HoF.
    inversion HoF.
    inversion H as [x1 [y1]].
    inversion H1.
    apply ordered_pair_to_and in H2.
    inversion H2.
    rewrite -H4 -H5 in H3.
    apply H3.
  Qed.

  Theorem singleton_image_iff_ordered_pair_in_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      {| y |} = 𝕴𝖒( F , {| x |} ) <->
      <|x, y|> ∈ F.
  Proof.
    move => f X Y F x y Hf HF HxX.
    rewrite /iff; split;
      [apply (singleton_image_to_ordered_pair_in_graph f X Y F)|
       apply (ordered_pair_in_graph_to_singleton_image f X Y F)];
      trivial;
      trivial;
      assumption.
  Qed.

  Theorem singleton_image_is_unique:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U) (x y y':U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      x ∈ X ->
      {|y|} = 𝕴𝖒( F , {|x|} ) /\ {|y'|} = 𝕴𝖒( F , {|x|} ) ->
      y = y'.
  Proof.
    move => f X Y F x y y' Hf HF HxX [Hy Hy'].
    apply (singleton_image_to_mapping_function f X Y) in Hy;trivial.
    apply (singleton_image_to_mapping_function f X Y) in Hy';trivial.
    rewrite Hy Hy'.
    reflexivity.
  Qed.

  Theorem cup_domain_is_cup_image_in_function:
    forall (f:U -> U) (A B C D:Collection U) (G:TypeOfDirectProduct U),
      G = GraphOfFunction f A B ->
      𝕴𝖒( G , C ∪ D ) = 𝕴𝖒( G , C ) ∪ 𝕴𝖒( G , D ).
  Proof.
    move => f A B C D G HG.
    apply (cup_domain_is_cup_image U (fun x y:U => y = f x) A B).
    apply HG.
  Qed.

  Theorem image_of_correspondence_function_include_chain_image:
    forall (f g:U -> U) (X Y Z:Collection U) (F G GF:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      GF = GraphOfCompoundCorrespondence G F ->
      𝕴𝖒( G ,  𝕴𝖒( F, X ) ) ⊂ 𝕴𝖒( GF, X ).
  Proof.
    move => f g X Y Z F G GF HF HG HGF z.
    apply: (image_of_correspondence_include_chain_image
              U (fun x y => y = f x) (fun y z => z = g y) X Y Z F G GF);trivial.
  Qed.

  Theorem chain_image_include_image_of_correspondence_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G GF:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      GF = GraphOfCompoundCorrespondence G F ->
      𝕴𝖒( GF, X ) ⊂ 𝕴𝖒( G, 𝕴𝖒( F , X )).
  Proof.
    move => f g X Y Z F G GF HF HG HGF z.
    apply: (chain_image_include_image_of_correspondence
              U (fun x y => y = f x) (fun y z => z = g y) X Y Z F G GF); trivial.
  Qed.

  Theorem chain_image_is_image_of_correspondence_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G GF:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      GF = GraphOfCompoundCorrespondence G F ->
      𝕴𝖒( G, 𝕴𝖒( F , X )) = 𝕴𝖒( GF, X ).
  Proof.
    move => f g X Y Z F G GF HF HG HGF.
    apply (chain_image_is_image_of_correspondence U (fun x y => y = f x) (fun y z => z = g y) X Y Z F G GF);trivial.
  Qed.

  Theorem compound_graph_of_function_include_graph_of_compound_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      GraphOfFunction (CompoundFunction g f) X Z ⊂ G ⊙ F.
  Proof.
    move => f g X Y Z F G Hf HF HG Z' H.
    inversion H as [Z0'].
    inversion H0 as [x [z]].
    inversion H2.
    inversion H4.
    split.
    exists x.
    exists z.
    split;[trivial|].
    apply ordered_pair_in_direct_product_iff_in_and in H6.
    inversion H6.
    apply Hf in H7.
    inversion H7 as [y].
    inversion H9.
    exists y.
    split;[rewrite HF|rewrite HG];split.
    exists x.
    exists y.
    split;[reflexivity|split;
                       [trivial|
                        apply ordered_pair_in_direct_product_iff_in_and;
                        split;[apply H6|trivial]]].
    exists y.
    exists z.
    split;[reflexivity|split;
                       [rewrite H10;trivial|
                        apply ordered_pair_in_direct_product_iff_in_and;
                        split;trivial]].
  Qed.

  Theorem graph_of_compound_function_include_compound_graph_of_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      G ⊙ F ⊂ GraphOfFunction (CompoundFunction g f) X Z.
  Proof.
    move => f g X Y Z F G HF HG Z' H.
    inversion H as [Z0'].
    inversion H0 as [x [z]].
    inversion H2.
    inversion H4 as [y].
    inversion H5.
    rewrite H3.
    split.
    exists x.
    exists z.
    split;[reflexivity|].
    rewrite HF in H6.
    rewrite HG in H7.
    inversion H6 as [Y' [x0 [y0]]].
    inversion H8.
    inversion H11.
    inversion H7.
    inversion H7 as [Z1' [y1 [z1]]].
    inversion H16.
    inversion H19.
    apply ordered_pair_to_and in H10.
    inversion H10.
    rewrite -H22 -H23 in H12.
    apply ordered_pair_to_and in H18.
    inversion H18.
    rewrite -H24 -H25 in H20.
    rewrite H12 in H20.
    split.
    trivial.
    rewrite -H22 -H23 in H13.
    rewrite -H24 -H25 in H21.
    apply ordered_pair_in_direct_product_iff_in_and in H13.
    apply ordered_pair_in_direct_product_iff_in_and in H21.
    apply ordered_pair_in_direct_product_iff_in_and.
    split;[apply H13|apply H21].
  Qed.

  Theorem compound_graph_of_function_eq_graph_of_compound_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      GraphOfFunction (CompoundFunction g f) X Z = G ⊙ F.
  Proof.
    move => f g X Y Z F G Hf HF HG.
    apply mutally_included_iff_eq.
    split;[apply (compound_graph_of_function_include_graph_of_compound_function f g X Y Z F G)|
           apply (graph_of_compound_function_include_compound_graph_of_function f g X Y Z F G)];
    trivial.
  Qed.

  Theorem compound_function_to_in_image_of_graph_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      MappingFunction g Y Z ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      z = (CompoundFunction g f) x -> z ∈ 𝕴𝖒((GraphOfFunction (CompoundFunction g f) X Z), {|x|}).
  Proof.
    move => f g X Y Z F G x z Hf Hg HF HG HxX H.
    split.
    exists x.
    split.
    apply singleton_iff_eq.
    reflexivity.
    split.
    exists x.
    exists z.
    split.
    reflexivity.
    split.
    trivial.
    apply ordered_pair_in_direct_product_iff_in_and.
    split;[trivial|].
    apply Hf in HxX.
    inversion HxX as [y Hfx].
    unfold MappingFunction in Hg.
    inversion Hfx as [Hyfx HyY].
    apply Hg in HyY.
    inversion HyY as [z0].
    rewrite Hyfx in H0.
    inversion H0.
    unfold CompoundFunction in H.
    rewrite -H in H1.
    rewrite -H1.
    trivial.
  Qed.

  Theorem in_image_of_graph_function_to_compound_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G: TypeOfDirectProduct U) (x z:U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      z ∈ (𝕴𝖒((GraphOfFunction (CompoundFunction g f) X Z), {|x|})) -> z = (CompoundFunction g f) x.
  Proof.
    move => f g X Y Z F G x z HF HG HxX H.
    inversion H as [z0].
    inversion H0 as [x0].
    inversion H2.
    apply singleton_to_eq in H3.
    rewrite H3 in H4.
    inversion H4.
    inversion H5 as [x1 [z1]].
    inversion H7.
    apply ordered_pair_to_and in H8.
    inversion H8.
    inversion H9.
    rewrite H10 H11.
    trivial.
  Qed.

  Theorem compound_function_iff_in_image_of_graph_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      MappingFunction g Y Z ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      z = (g ◦ f) x <-> z ∈ 𝕴𝖒((GraphOfFunction (CompoundFunction g f) X Z), {|x|}).
  Proof.
    move => f g X Y Z F G x z Hf Hg HF HG HxX.
    rewrite /iff.
    split;[apply (compound_function_to_in_image_of_graph_function f g X Y Z F G)|
           apply (in_image_of_graph_function_to_compound_function f g X Y Z F G)];
    trivial.
  Qed.

  Theorem mapping_compound_function_to_singleton_image:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      MappingFunction g Y Z ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      z = (g ◦ f) x ->
      {|z|} = 𝕴𝖒( G ⊙ F , {|x|} ).
  Proof.
    move => f g X Y Z F G x z Hf Hg HF HG HxX Hgf.
    rewrite -(compound_graph_of_function_eq_graph_of_compound_function f g X Y Z F G).
    apply (mapping_function_iff_singleton_image (g ◦ f) X Z (GraphOfFunction (g ◦ f) X Z) x z).
    move => x' Hx'X.
    apply Hf in Hx'X.
    inversion Hx'X as [y'].
    inversion H.
    apply Hg in H1.
    inversion H1 as [z'].
    inversion H2.
    exists z'.
    split.
    rewrite H0 in H3.
    trivial.
    trivial.
    reflexivity.
    trivial.
    trivial.
    trivial.
    trivial.
    trivial.
  Qed.

  Theorem singleton_image_to_mapping_compound_function:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      MappingFunction g Y Z ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      {|z|} = 𝕴𝖒( G ⊙ F , {|x|} ) ->
      z = (g ◦ f) x.
  Proof.
    move => f g X Y Z F G x z Hf Hg HF HG HxX HI.
    apply (singleton_image_to_mapping_function (g ◦ f) X Z (GraphOfFunction (g ◦ f) X Z) x z).
    move => x' Hx'X.
    apply Hf in Hx'X.
    inversion Hx'X as [y'].
    inversion H.
    apply Hg in H1.
    inversion H1 as [z'].
    inversion H2.
    exists z'.
    rewrite H0 in H3.
    split; trivial.
    reflexivity.
    trivial.
    rewrite (compound_graph_of_function_eq_graph_of_compound_function f g X Y Z F G); trivial.
  Qed.

  Theorem mapping_compound_function_iff_singleton_image:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      MappingFunction g Y Z ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      z = (g ◦ f) x <->
      {|z|} = 𝕴𝖒( G ⊙ F , {|x|} ).
  Proof.
    move => f g X Y Z F G x z Hf Hg HF HG HxX.
    rewrite /iff.
    split;
      [apply (mapping_compound_function_to_singleton_image f g X Y Z F G x z)|
       apply (singleton_image_to_mapping_compound_function f g X Y Z F G x z)];
    trivial.
  Qed.

  Theorem compound_function_value_exists_unique:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      MappingFunction g Y Z ->
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      forall x:U, x ∈ X ->
                  exists z:U, {|z|} = 𝕴𝖒( G ⊙ F , {|x|} ) ->
                              forall z':U, {|z'|} = 𝕴𝖒( G ⊙ F , {|x|} ) -> z = z'.
  Proof.
    move => f g X Y Z F G Hf Hg HF HG x HxX.
    move Hfgz: (g (f x)) => z.
    exists z.
    move => H z' H0.
    apply (mapping_compound_function_iff_singleton_image f g X Y Z F G x z') in H0; trivial.
    rewrite H0 -Hfgz.
    reflexivity.
  Qed.

  Theorem compound_function_value_unique:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      forall x z z':U, x ∈ X ->
                       {|z|} = 𝕴𝖒( G ⊙ F , {|x|} ) ->
                       {|z'|} = 𝕴𝖒( G ⊙ F , {|x|} ) -> z = z'.
  Proof.
    move => f g X Y Z F G HF HG x z z' HxX HIz HIz'.
    apply singleton_eq_iff_element_eq.
    rewrite HIz HIz'.
    reflexivity.
  Qed.

  Theorem singleton_image_of_compound_graph_to_ordered_pair_in_compound_graph:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      {| z |} = 𝕴𝖒( G ⊙ F , {| x |} ) ->
      <|x,z|> ∈ G ⊙ F.
  Proof.
    move => f g X Y Z F G x z Hf HF Hg HG HxX H.
    apply (singleton_image_iff_ordered_pair_in_graph (g ◦ f) X Z (G ⊙ F) x z).
    move => x' Hx'X.
    apply Hf in Hx'X.
    inversion Hx'X as [y [Hyfx' HyY]].
    apply Hg in HyY.
    inversion HyY as [z' [Hzgy Hz'Z]].
    exists z'.
    split.
    unfold CompoundFunction.
    rewrite -Hyfx'.
    trivial.
    trivial.
    apply sym_eq.
    rewrite (compound_graph_of_function_eq_graph_of_compound_function f g X Y Z F G).
    reflexivity.
    trivial.
    trivial.
    trivial.
    trivial.
    assumption.
  Qed.

  Theorem ordered_pair_in_compound_graph_to_singleton_image_of_compound_graph:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      <|x,z|> ∈ G ⊙ F ->
          {| z |} = 𝕴𝖒( G ⊙ F , {| x |} ).
  Proof.
    move => f g X Y Z F G x z Hf HF Hg HG HxX H.
    apply (singleton_image_iff_ordered_pair_in_graph (g ◦ f) X Z (G ⊙ F) x z).
    move => x' Hx'X.
    apply Hf in Hx'X.
    inversion Hx'X as [y [Hyfx' HyY]].
    apply Hg in HyY.
    inversion HyY as [z' [Hzgy Hz'Z]].
    exists z'.
    split.
    unfold CompoundFunction.
    rewrite -Hyfx'.
    trivial.
    trivial.
    rewrite (compound_graph_of_function_eq_graph_of_compound_function f g X Y Z F G).
    reflexivity.
    trivial.
    trivial.
    trivial.
    trivial.
    assumption.
  Qed.

  Theorem singleton_image_of_compound_graph_iff_ordered_pair_in_compound_graph:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U) (x z:U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      x ∈ X ->
      {| z |} = 𝕴𝖒( G ⊙ F , {| x |} ) <->
      <|x,z|> ∈ G ⊙ F.
  Proof.
    move => f g X Y Z F G x z Hf HF Hg HG HxX.
    rewrite /iff.
    split; [apply (singleton_image_of_compound_graph_to_ordered_pair_in_compound_graph f g X Y Z)|
            apply (ordered_pair_in_compound_graph_to_singleton_image_of_compound_graph f g X Y Z)];
    trivial.
  Qed.

  Theorem image_singleton_domain_of_graph_of_identity_eq_singleton_domain:
    forall (X:Collection U) (x:U),
      x ∈ X -> {|x|} = 𝕴𝖒( GraphOfIdentity X , {|x|} ).
  Proof.
    move => X x HxX.
    apply mutally_included_to_eq.
    split; move => x0 H.
    apply singleton_to_eq in H.
    split.
    exists x0.
    split;[apply singleton_iff_eq;trivial|
           split;
           exists x0;
           exists x0;
           split;[reflexivity|
                  split]].
    trivial.
    rewrite H.
    apply ordered_pair_in_direct_product_iff_in_and.
    split; trivial.
    inversion H as [x'].
    inversion H0 as [x0'].
    inversion H2.
    inversion H4.
    inversion H5 as [x1 [x2]].
    inversion H7.
    inversion H9.
    rewrite H10 in H8.
    apply ordered_pair_to_and in H8.
    inversion H8.
    rewrite -H12 in H13.
    rewrite H13.
    assumption.
  Qed.

  Theorem compound_graph_eq_to_compound_function_eq:
    forall (f0 f1 g0 g1:U->U) (X Y Z:Collection U) (F0 F1 G0 G1:TypeOfDirectProduct U),
      MappingFunction f0 X Y ->
      F0 = GraphOfFunction f0 X Y ->
      MappingFunction f1 X Y ->
      F1 = GraphOfFunction f1 X Y ->
      MappingFunction g0 Y Z ->
      G0 = GraphOfFunction g0 Y Z ->
      MappingFunction g1 Y Z ->
      G1 = GraphOfFunction g1 Y Z ->
      G0 ⊙ F0 = G1 ⊙ F1 ->
      forall x:U, x ∈ X -> (g0 ◦ f0) x = (g1 ◦ f1) x.
  Proof.
    move => f0 f1 g0 g1 X Y Z F0 F1 G0 G1 Hf0 HF0 Hf1 HF1 Hg0 HG0 Hg1 HG1 Heq x HxX.
    have Hg0f0: MappingFunction (g0 ◦ f0) X Z.
    move => x0 Hx0X.
    apply Hf0 in Hx0X.
    inversion Hx0X as [y [Hyf0x0 HyY]].
    apply Hg0 in HyY.
    inversion HyY as [z [Hzg0y HzZ]].
    exists z.
    split;[unfold CompoundFunction; rewrite -Hyf0x0|];trivial.
    have Hg1f1: MappingFunction (g1 ◦ f1) X Z.
    move => x0 Hx0X.
    apply Hf1 in Hx0X.
    inversion Hx0X as [y [Hyf1x0 HyY]].
    apply Hg1 in HyY.
    inversion HyY as [z [Hzg1y HzZ]].
    exists z.
    split;[unfold CompoundFunction; rewrite -Hyf1x0|];trivial.
    apply (graph_of_function_eq_iff_function_eq (g0 ◦ f0) (g1 ◦ f1) X Z (G0 ⊙ F0) (G1 ⊙ F1));trivial.
    apply sym_eq.
    apply (compound_graph_of_function_eq_graph_of_compound_function f0 g0 X Y Z F0 G0); trivial.
    apply sym_eq.
    apply (compound_graph_of_function_eq_graph_of_compound_function f1 g1 X Y Z F1 G1); trivial.
  Qed.

  Theorem compound_function_eq_to_compound_graph_eq:
    forall (f0 f1 g0 g1:U->U) (X Y Z:Collection U) (F0 F1 G0 G1:TypeOfDirectProduct U),
      MappingFunction f0 X Y ->
      F0 = GraphOfFunction f0 X Y ->
      MappingFunction f1 X Y ->
      F1 = GraphOfFunction f1 X Y ->
      MappingFunction g0 Y Z ->
      G0 = GraphOfFunction g0 Y Z ->
      MappingFunction g1 Y Z ->
      G1 = GraphOfFunction g1 Y Z ->
      (forall x:U, x ∈ X -> (g0 ◦ f0) x = (g1 ◦ f1) x) ->
      G0 ⊙ F0 = G1 ⊙ F1.
  Proof.
    move => f0 f1 g0 g1 X Y Z F0 F1 G0 G1 Hf0 HF0 Hf1 HF1 Hg0 HG0 Hg1 HG1 H.
    have Hg0f0: MappingFunction (g0 ◦ f0) X Z.
    move => x0 Hx0X.
    apply Hf0 in Hx0X.
    inversion Hx0X as [y [Hyf0x0 HyY]].
    apply Hg0 in HyY.
    inversion HyY as [z [Hzg0y HzZ]].
    exists z.
    split;[unfold CompoundFunction; rewrite -Hyf0x0|];trivial.
    have Hg1f1: MappingFunction (g1 ◦ f1) X Z.
    move => x0 Hx0X.
    apply Hf1 in Hx0X.
    inversion Hx0X as [y [Hyf1x0 HyY]].
    apply Hg1 in HyY.
    inversion HyY as [z [Hzg1y HzZ]].
    exists z.
    split;[unfold CompoundFunction; rewrite -Hyf1x0|];trivial.
    apply (graph_of_function_eq_iff_function_eq (g0 ◦ f0) (g1 ◦ f1) X Z (G0 ⊙ F0) (G1 ⊙ F1)).
    trivial.
    trivial.
    apply sym_eq.
    apply (compound_graph_of_function_eq_graph_of_compound_function f0 g0 X Y Z F0 G0); trivial.
    apply sym_eq.
    apply (compound_graph_of_function_eq_graph_of_compound_function f1 g1 X Y Z F1 G1); trivial.
    assumption.
  Qed.

  Theorem compound_graph_eq_iff_compound_function_eq:
    forall (f0 f1 g0 g1:U->U) (X Y Z:Collection U) (F0 F1 G0 G1:TypeOfDirectProduct U),
      MappingFunction f0 X Y ->
      F0 = GraphOfFunction f0 X Y ->
      MappingFunction f1 X Y ->
      F1 = GraphOfFunction f1 X Y ->
      MappingFunction g0 Y Z ->
      G0 = GraphOfFunction g0 Y Z ->
      MappingFunction g1 Y Z ->
      G1 = GraphOfFunction g1 Y Z ->
      (G0 ⊙ F0 = G1 ⊙ F1 <->
       forall x:U, x ∈ X -> (g0 ◦ f0) x = (g1 ◦ f1) x).
  Proof.
    move => f0 f1 g0 g1 X Y Z F0 F1 G0 G1 Hf0 HF0 Hf1 HF1 Hg0 HG0 Hg1 HG1.
    rewrite /iff.
    split;[apply (compound_graph_eq_to_compound_function_eq f0 f1 g0 g1 X Y Z F0 F1 G0 G1)|
           apply (compound_function_eq_to_compound_graph_eq f0 f1 g0 g1 X Y Z F0 F1 G0 G1)];trivial.
  Qed.

  Theorem ordered_pair_in_graph_of_identity:
    forall (X:Collection U) (x:U),
      x ∈ X -> <|x,x|> ∈ GraphOfIdentity X.
  Proof.
    move => X x HxX.
    split.
    exists x.
    exists x.
    split;[reflexivity|split;
                       [reflexivity|
                        apply ordered_pair_in_direct_product_iff_in_and;
                        split;
                        assumption]].
  Qed.

  Theorem ordered_pair_in_graph_to_eq:
    forall (X:Collection U) (x x':U),
      <|x,x'|> ∈ GraphOfIdentity X -> x = x'.
  Proof.
    move => X x x' H.
    inversion H as [Z [x0 [x0']]].
    inversion H0 as [H2 [H3]].
    apply ordered_pair_to_and in H2.
    inversion H2.
    rewrite -H5 -H6 in H3.
    rewrite H3.
    reflexivity.
  Qed.

  Theorem same_element_pair_in_identity:
    forall (X:Collection U) (x x':U),
      x ∈ X /\ x = x' -> <|x,x'|> ∈ GraphOfIdentity X.
  Proof.
    move => X x x'.
    case => HxX Heq.
    rewrite -Heq.
    apply ordered_pair_in_graph_of_identity.
    assumption.
  Qed.

  Theorem ordered_pair_in_graph_iff_eq:
    forall (X:Collection U) (x x':U),
      x ∈ X /\ x = x' <-> <|x,x'|> ∈ GraphOfIdentity X.
  Proof.
    move => X x x'.
    rewrite /iff.
    split.
    +case => HxX Heq.
     rewrite -Heq.
     apply ordered_pair_in_graph_of_identity.
     assumption.
    +move => H.
     inversion H.
     inversion H0 as [x0 [x'0]].
     inversion H2.
     inversion H4.
     rewrite -H3 in H6.
     apply ordered_pair_in_direct_product_iff_in_and in H6.
     inversion H6.
     apply ordered_pair_to_and in H3.
     inversion H3.
     rewrite -H9 -H10 in H5.
     split;[trivial|apply eq_sym;assumption].
  Qed.

  Theorem compound_identity_function_r:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      F = F ⊙ GraphOfIdentity X.
  Proof.
    move => f' X Y F HF.
    rewrite HF.
    apply mutally_included_to_eq.
    split => Z HFZ;
               inversion HFZ as [Z0 [x0 [y0]]];
               inversion H.
    inversion H2.
    split.
    exists x0.
    exists y0.
    split;[trivial|].
    exists x0.
    split.
    apply ordered_pair_in_graph_of_identity.
    apply ordered_pair_in_direct_product_to_in_and in H4.
    apply H4.
    split.
    exists x0.
    exists y0.
    split;[reflexivity|trivial].
    inversion H2 as [x0'].
    inversion H3.
    apply ordered_pair_in_graph_to_eq in H4.
    rewrite -H4 in H5.
    rewrite H1.
    assumption.
  Qed.

  Theorem compound_identity_function_l:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      F = GraphOfIdentity Y ⊙ F.
  Proof.
    move => f' X Y F HF.
    rewrite HF.
    apply mutally_included_to_eq.
    split => Z H;
               inversion H;
               inversion H0 as [x [y]].
    +inversion H2 as [H3 [H4 H5]].
     split.
     exists x.
     exists y.
     split;[trivial|exists y;
                    rewrite -H3;
                    split;[trivial|
                           apply ordered_pair_in_graph_of_identity;
                           apply ordered_pair_in_direct_product_iff_in_and in H5;
                           apply H5]].
    +inversion H2 as [H3 H4].
     inversion H4 as [y' [H5 H6]].
     apply ordered_pair_in_graph_to_eq in H6.
     rewrite H6 in H5.
     rewrite H3.
     assumption.
  Qed.

  Theorem associativity_of_graph_of_function:
    forall (f g h:U -> U) (X Y Z W:Collection U) (F G H:TypeOfDirectProduct U),
      F = GraphOfFunction f X Y ->
      G = GraphOfFunction g Y Z ->
      H = GraphOfFunction h Z W ->
      (H ⊙ G) ⊙ F = H ⊙ (G ⊙ F).
  Proof.
    move => f' g' h' X Y Z W F G H HF HG HH.
    apply (associativity_of_graph_of_binary_relation U
                                                     (fun x y => y = f' x)
                                                     (fun x y => y = g' x)
                                                     (fun x y => y = h' x)
                                                     X Y Z W F G H);trivial.
  Qed.

End Mapping.

Require Export binary_relation.


Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Bool_nat.
Require Import Init.Nat.
Import ListNotations.

Definition vertex := nat.
Definition edge := prod vertex vertex.

Inductive graph {X : Type} : Set :=
| Empty : graph
| Add_node : forall (x : X) (g : graph), x

Check " :> ".
Definition cover := list edge.

Definition size (c : cover) := length c.

Definition gt n m := negb (n <=? m).

Definition empty : graph := Graph [] [].

Definition incident (v : vertex) (e : edge) :=
match e with
| (x,y) => x = v \/ y = v
end.

Definition incident_b (v : vertex) (e : edge) :=
match e with
| (x,y) => orb (x =? v) (y =? v)
end.

Definition is_cover (es : cover) (g : graph) :=
incl es (e_list g) /\
forall v : vertex, In v (v_list g) ->
  ex (fun e => In e (e_list g) /\ incident v e).

Fixpoint elem {X : Type} (f : X -> X -> bool) e l :=
match l with
| [] => false
| x::xs => if f e x then true else elem f e xs
end.

Definition incl_b {X : Type} f (l m : list X) := forallb (fun x => elem f x m) l.
Definition is_cover_b (es : cover) (g : graph) :=
andb
(incl_b (fun e1 e2 => match (e1,e2) with ((x1,y1),(x2,y2)) => andb (eqb x1 x2) (eqb y1 y2) end)
 es (e_list g))
(forallb (fun v => existsb (incident_b v) es) (v_list g)).

Fixpoint all_subset {X : Type} (l : list X) :=
match l with
| [] => [[]]
| x::xs =>
  let subsets := all_subset xs in
  subsets ++ (map (fun e => x::e) subsets)
end.

Compute all_subset [1;2;3].
Check option.

Search (False -> _).
Check fold_left.
Definition min (l : list nat) d := fold_left (fun acc x => if x <? acc then x else acc) l d.

Fixpoint min_vc (g : graph) : option nat :=
let covers := filter (fun c => is_cover_b c g) (all_subset (e_list g)) in
match covers with
| [] => None
| x::xs =>
  let k := min (map (fun c => length c) covers) (length x) in
    Some k
end.

Compute min_vc (Graph [1;2;3;4;5] [(1,2);(3,2);(3,4);(5,4)]).

Theorem min_vc_correct : forall (k : nat) (g : graph),
min_vc g = Some k -> ~ ex (fun c => is_cover c g /\  size c <= k).
Proof.
Admitted.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (lf3 : natural) : natural :=
  plus Zero (plus z lf3).


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (lf3 : natural) : natural :=
  plus Zero (plus lf3 z).


(* Adapted from Barendregt: https://gist.github.com/palmskog/341da4e54ff7e805077b6e0b3af7d21d *)
Section Barendregt.

Variable P : Prop.

Fixpoint B (n : nat) := match n with | O => P | S n' => P <-> B n' end.

Lemma B2n: forall n, B (1 + n * 2).
Proof.
exact (fix B2n n : B (1 + n * 2) :=
  match n with
  | O => iff_refl P
  | S n' => let IH : B (1 + n' * 2) := B2n n' in
            ltac:(tauto) : P <-> (P <-> B (1 + n' * 2))
  end).
Qed.

End Barendregt.

Lemma iffP : forall P : Prop, P <-> (P <-> (P <-> (P <-> (P <-> (P <-> (P <-> (P <-> (P <-> P)))))))).
Proof.
exact (fun P => B2n P 4).
Qed.


Require Import Relation_Definitions.
Require Import Relation_Operators.

Section FixDomain.

  Variable M : Set.

  Definition terminates (gamma : M) (R : relation M) :=
    Acc R gamma.

  Inductive clos (A : Type) (R : A -> A -> Prop) : bool -> A -> A -> Prop :=
  | clos_refl : forall a, clos A R false a a
  | clos_step : forall s a b, R a b -> clos A R s a b
  | clos_trans : forall s a b c,
    clos A R s a b -> clos A R s b c -> clos A R s a c.

  Lemma clos_faithful (A : Type) (R : relation A) (strict : bool) :
    forall l r,
      clos A R strict l r <->
      if strict
        then Relation_Operators.clos_trans A R l r
        else clos_refl_trans A R l r.
  Proof.
    split.
      induction 1; try (destruct s); econstructor solve[eauto].
      destruct strict; induction 1; econstructor solve[eauto].
  Qed.

  Definition clos_unstrict A (R : relation A) a b
    (step : clos A R true a b) : clos A R false a b.
  Proof.
    induction step; eauto using clos.
  Defined.

  Inductive clos_left (A : Type) (R : A -> A -> Prop) :
    bool -> A -> A -> Prop :=
  | clos_left_refl : forall a, clos_left A R false a a
  | clos_left_step : forall s a b, R a b -> clos_left A R s a b
  | clos_left_ext : forall s a b c,
    R a b -> clos_left A R s b c -> clos_left A R s a c.

  Lemma clos_left_trans (A : Type) (R : A -> A -> Prop)
    strict a b c :
    clos_left A R strict a b -> clos_left A R strict b c ->
    clos_left A R strict a c.
    induction 1.
    auto.
    apply clos_left_ext. assumption.
    intros. specialize (IHclos_left H1).
    eapply clos_left_ext; eassumption.
  Qed.

  Lemma clos_iff_left (A : Type) (R : A -> A -> Prop)
    strict a b : clos A R strict a b <-> clos_left A R strict a b.
  Proof.
    split.
    induction 1.
    constructor.
    constructor;assumption.
    eapply clos_left_trans;eassumption.

    induction 1.
    constructor.
    constructor;assumption.
    eauto using clos.
  Qed.

  Lemma clos_cons_lt A (R : relation A) a b s c :
    clos A R true a b -> clos A R s b c -> clos A R true a c.
  Proof. induction 2;eauto using clos. Qed.

  Lemma clos_trans_lt A (R : relation A) a b s c :
    clos A R s a b -> clos A R false b c -> clos A R s a c.
  Proof. destruct s; eauto using clos_cons_lt, clos. Qed.

  Lemma clos_cons_rt A (R : relation A) a s b c :
    clos A R s a b -> clos A R true b c -> clos A R true a c.
  Proof. induction 1;eauto using clos. Qed.

  Lemma clos_cat A (R : relation A) a s1 b s2 c :
    clos A R s1 a b -> clos A R s2 b c -> clos A R (orb s1 s2) a c.
  Proof.
    destruct s1. apply clos_cons_lt.
    destruct s2. apply clos_cons_rt.
    apply clos_trans.
  Qed.

  Lemma clos_cat' A (R : relation A) a s1 b s2 s3 c :
    clos A R s1 a b -> clos A R s2 b c -> s3 = orb s1 s2 -> clos A R s3 a c.
  Proof.
    destruct s1; destruct s2; intros; rewrite H1; eapply clos_cat; eauto.
  Qed.

  Definition impliesb (a b : bool) :=
    a = false \/ b = true.

  Lemma clos_cat'' A (R : relation A) a s1 b s2 s3 c :
    clos A R s1 a b -> clos A R s2 b c -> impliesb s3 (orb s1 s2) -> clos A R s3 a c.
  Proof.
    intros; destruct s1; destruct s2; destruct s3.
    eapply clos_cat'; eauto.
    try (apply clos_unstrict; eauto using clos ).
    eapply (clos_cat' A R _ _ _ _ _ _ H H0). compute. reflexivity.
    try (apply clos_unstrict; eauto using clos ).
    eapply (clos_cat' A R _ _ _ _ _ _ H H0). compute. reflexivity.
    eapply (clos_cat' A R _ _ _ _ _ _ H H0). compute. reflexivity.
    try (apply clos_unstrict; eauto using clos ).
    eapply (clos_cat' A R _ _ _ _ _ _ H H0). compute. reflexivity.
    compute in H1; destruct H1; inversion H1.
    eapply (clos_cat' A R _ _ _ _ _ _ H H0). compute. reflexivity.
Qed.

  Lemma terminates_fwd (R : relation M) (gamma : M) :
    terminates gamma R ->
    forall strict gamma', clos M R strict gamma' gamma ->
      terminates gamma' R.
  Proof.
    intros.
    induction H0.
    assumption.
    destruct H. apply H. assumption.
    auto.
  Qed.

  Lemma clos_weaken (A : Type) (R1 R2 : relation A) strict x y :
    (forall a b, R1 a b -> R2 a b) ->
    clos A R1 strict x y -> clos A R2 strict x y.
  Proof. induction 2; eauto using clos. Defined.

  Lemma Acc_weaken A (R1 R2 : relation A)
    (HWeak : forall a b, R2 a b -> R1 a b)
    (x : A) : Acc R1 x -> Acc R2 x.
  Proof. induction 1; constructor; auto. Qed.

End FixDomain.


From Hammer Require Import Hammer.

Require Import PeanoNat Lt.

Local Open Scope nat_scope.

Implicit Types m n p : nat.

Section Well_founded_Nat.

Variable A : Type.

Variable f : A -> nat.
Definition ltof (a b:A) := f a < f b.
Definition gtof (a b:A) := f b > f a.

Theorem well_founded_ltof : well_founded ltof.
Proof. hammer_hook "Wf_nat" "Wf_nat.well_founded_ltof".
assert (H : forall n (a:A), f a < n -> Acc ltof a).
{ induction n.
- intros; absurd (f a < 0); auto with arith.
- intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb.
apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. }
intros a. apply (H (S (f a))). auto with arith.
Defined.

Theorem well_founded_gtof : well_founded gtof.
Proof. hammer_hook "Wf_nat" "Wf_nat.well_founded_gtof".
exact well_founded_ltof.
Defined.

Theorem induction_ltof1 :
forall P:A -> Set,
(forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
Proof. hammer_hook "Wf_nat" "Wf_nat.induction_ltof1".
intros P F.
assert (H : forall n (a:A), f a < n -> P a).
{ induction n.
- intros; absurd (f a < 0); auto with arith.
- intros a Ha. apply F. unfold ltof. intros b Hb.
apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. }
intros a. apply (H (S (f a))). auto with arith.
Defined.

Theorem induction_gtof1 :
forall P:A -> Set,
(forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
Proof. hammer_hook "Wf_nat" "Wf_nat.induction_gtof1".
exact induction_ltof1.
Defined.

Theorem induction_ltof2 :
forall P:A -> Set,
(forall x:A, (forall y:A, ltof y x -> P y) -> P x) -> forall a:A, P a.
Proof. hammer_hook "Wf_nat" "Wf_nat.induction_ltof2".
exact (well_founded_induction well_founded_ltof).
Defined.

Theorem induction_gtof2 :
forall P:A -> Set,
(forall x:A, (forall y:A, gtof y x -> P y) -> P x) -> forall a:A, P a.
Proof. hammer_hook "Wf_nat" "Wf_nat.induction_gtof2".
exact induction_ltof2.
Defined.

Variable R : A -> A -> Prop.

Hypothesis H_compat : forall x y:A, R x y -> f x < f y.

Theorem well_founded_lt_compat : well_founded R.
Proof. hammer_hook "Wf_nat" "Wf_nat.well_founded_lt_compat".
assert (H : forall n (a:A), f a < n -> Acc R a).
{ induction n.
- intros; absurd (f a < 0); auto with arith.
- intros a Ha. apply Acc_intro. intros b Hb.
apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. }
intros a. apply (H (S (f a))). auto with arith.
Defined.

End Well_founded_Nat.

Lemma lt_wf : well_founded lt.
Proof. hammer_hook "Wf_nat" "Wf_nat.lt_wf".
exact (well_founded_ltof nat (fun m => m)).
Defined.

Lemma lt_wf_rec1 :
forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
Proof. hammer_hook "Wf_nat" "Wf_nat.lt_wf_rec1".
exact (fun p P F => induction_ltof1 nat (fun m => m) P F p).
Defined.

Lemma lt_wf_rec :
forall n (P:nat -> Set), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
Proof. hammer_hook "Wf_nat" "Wf_nat.lt_wf_rec".
exact (fun p P F => induction_ltof2 nat (fun m => m) P F p).
Defined.

Lemma lt_wf_ind :
forall n (P:nat -> Prop), (forall n, (forall m, m < n -> P m) -> P n) -> P n.
Proof. hammer_hook "Wf_nat" "Wf_nat.lt_wf_ind".
intro p; intros; elim (lt_wf p); auto with arith.
Qed.

Lemma gt_wf_rec :
forall n (P:nat -> Set), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
Proof. hammer_hook "Wf_nat" "Wf_nat.gt_wf_rec".
exact lt_wf_rec.
Defined.

Lemma gt_wf_ind :
forall n (P:nat -> Prop), (forall n, (forall m, n > m -> P m) -> P n) -> P n.
Proof. hammer_hook "Wf_nat" "Wf_nat.gt_wf_ind".  exact (lt_wf_ind). Qed.

Lemma lt_wf_double_rec :
forall P:nat -> nat -> Set,
(forall n m,
(forall p q, p < n -> P p q) ->
(forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
Proof. hammer_hook "Wf_nat" "Wf_nat.lt_wf_double_rec".
intros P Hrec p; pattern p; apply lt_wf_rec.
intros n H q; pattern q; apply lt_wf_rec; auto with arith.
Defined.

Lemma lt_wf_double_ind :
forall P:nat -> nat -> Prop,
(forall n m,
(forall p (q:nat), p < n -> P p q) ->
(forall p, p < m -> P n p) -> P n m) -> forall n m, P n m.
Proof. hammer_hook "Wf_nat" "Wf_nat.lt_wf_double_ind".
intros P Hrec p; pattern p; apply lt_wf_ind.
intros n H q; pattern q; apply lt_wf_ind; auto with arith.
Qed.

Hint Resolve lt_wf: arith.
Hint Resolve well_founded_lt_compat: arith.

Section LT_WF_REL.
Variable A : Set.
Variable R : A -> A -> Prop.

Variable F : A -> nat -> Prop.
Definition inv_lt_rel x y := exists2 n, F x n & (forall m, F y m -> n < m).

Hypothesis F_compat : forall x y:A, R x y -> inv_lt_rel x y.
Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x.
Proof. hammer_hook "Wf_nat" "Wf_nat.acc_lt_rel".
intros x [n fxn]; generalize dependent x.
pattern n; apply lt_wf_ind; intros.
constructor; intros.
destruct (F_compat y x) as (x0,H1,H2); trivial.
apply (H x0); auto.
Qed.

Theorem well_founded_inv_lt_rel_compat : well_founded R.
Proof. hammer_hook "Wf_nat" "Wf_nat.well_founded_inv_lt_rel_compat".
constructor; intros.
case (F_compat y a); trivial; intros.
apply acc_lt_rel; trivial.
exists x; trivial.
Qed.

End LT_WF_REL.

Lemma well_founded_inv_rel_inv_lt_rel :
forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F).
Proof. hammer_hook "Wf_nat" "Wf_nat.well_founded_inv_rel_inv_lt_rel".
intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial.
Qed.

Set Implicit Arguments.

Require Import Le.
Require Import Compare_dec.
Require Import Decidable.

Definition has_unique_least_element (A:Type) (R:A->A->Prop) (P:A->Prop) :=
exists! x, P x /\ forall x', P x' -> R x x'.

Lemma dec_inh_nat_subset_has_unique_least_element :
forall P:nat->Prop, (forall n, P n \/ ~ P n) ->
(exists n, P n) -> has_unique_least_element le P.
Proof. hammer_hook "Wf_nat" "Wf_nat.dec_inh_nat_subset_has_unique_least_element".
intros P Pdec (n0,HPn0).
assert
(forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'')
\/ (forall n', P n' -> n<=n')).
{ induction n.
- right. intros. apply Nat.le_0_l.
- destruct IHn as [(n' & IH1 & IH2)|IH].
+ left. exists n'; auto with arith.
+ destruct (Pdec n) as [HP|HP].
* left. exists n; auto with arith.
* right. intros n' Hn'.
apply Nat.le_neq; split; auto. intros <-. auto. }
destruct (H n0) as [(n & H1 & H2 & H3)|H0]; [exists n | exists n0];
repeat split; trivial;
intros n' (HPn',Hn'); apply Nat.le_antisymm; auto.
Qed.

Unset Implicit Arguments.

Notation iter_nat n A f x := (nat_rect (fun _ => A) x (fun _ => f) n) (only parsing).


Require Import Omega.
Require Import ssreflect.
Section ScalarRec.

Variable T:Type.
Variable g : nat -> T -> T.

Fixpoint rec_fn (n:nat) (s:T) := match n with
  | 0 => s
  | S n => (rec_fn n (g n s))
  end.

Fixpoint rec_fn_rev_acc (n:nat) (m:nat) (s:T) := match n with
  | 0 => s
  | S n => g (m - n - 1) (rec_fn_rev_acc n m s)
  end.

Definition rec_fn_rev (n:nat) (s:T) :=
  rec_fn_rev_acc n n s.

Lemma rec_fn_rev_acc_S : forall m n s,
  rec_fn_rev_acc (S n) (S m) s = rec_fn_rev_acc n m (g m s).
Proof.
  induction n => s. simpl.
  by rewrite Nat.sub_0_r .
  change (rec_fn_rev_acc (S (S n)) (S m) s) with (g (S m - S n - 1) (rec_fn_rev_acc (S n) (S m) s)).
  rewrite IHn.
  simpl.
  reflexivity.
Qed.

Theorem Tail_Head_equiv : forall n s, rec_fn n s = rec_fn_rev n s.
Proof.
  induction n => s //.
  rewrite /rec_fn_rev rec_fn_rev_acc_S.
  simpl.
  by rewrite IHn.
Qed.

End ScalarRec.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (x : natural) (lf1 : natural) : natural :=
  mult x y.


Add LoadPath "/Users/lubis/Documents/study/software_foundations".
Require Export Induction.
Require Export Basics.

Module NatList.

Compute (bin_to_nat Z).

Inductive natprod: Type :=
  | pair (n1 n2: nat).

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.

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. reflexivity. Qed.

Theorem surjective_pairing_stuck:
  forall p: natprod, p = (fst p, snd p).
Proof. Abort.

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

(* Exercise starts *)

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.

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

(* Exercise ends *)

Inductive natlist: Type :=
  | nil
  | cons (n: nat) (l: 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
  | nil => O
  | h :: t => S (length t)
  end.

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

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

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 starts. Page 56. *)

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].
Proof. reflexivity. Qed.

Compute (negb false).

Fixpoint oddmembers (l: natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t =>
    match (evenb h) with
    | false => h :: (oddmembers t)
    | true => oddmembers t
    end
  end.

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

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

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

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

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

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | nil, nil => nil
  | nil, h :: t => l2
  | h :: t, nil => l1
  | 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. reflexivity. Qed.

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

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

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

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => O
  | h :: t =>
    match (eqb h v) with
    | true => S (count v t)
    | false => count v t
    end
  end.

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

Definition sum (s1 s2: bag) : bag := app s1 s2.

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

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

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

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

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

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

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t =>
    match (eqb h v) with
    | true => t
    | false => h :: (remove_one v t)
    end
  end.

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

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

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

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

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t =>
    match (eqb h v) with
    | true => remove_all v t
    | false => h :: remove_all v t
    end
  end.

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

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

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

(* Exercise ends. *)

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 l. destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
    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 *)
    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. reflexivity.  Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity.  Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - (* l = [] *)
    reflexivity.
  - (* l = n :: l' *)
    simpl.
    rewrite <- IHl'.
Abort.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    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.

(* Exercise starts. Page 65 *)

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - 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 l1' IHl1'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl1', app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr, IHl'.
    simpl. 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 l1' IHl1'].
  - simpl. rewrite -> app_assoc. reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity.
Qed.

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

Fixpoint eqblist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | nil, nil => true
  | nil, h :: t => false
  | h :: t, nil => false
  | h1 :: t1, h2 :: t2 =>
    match (eqb h1 h2) with
    | true => eqblist t1 t2
    | false => false
    end
  end.

Example test_eqblist1 :
  (eqblist nil nil = true).
Proof. reflexivity. Qed.

Example test_eqblist2 :
  eqblist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.

Example test_eqblist3 :
  eqblist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

Theorem eqblist_refl : forall l:natlist,
  true = eqblist l l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite <- eqb_refl, IHl'. reflexivity.
Qed.

(* Exercise ends. *)

(* Exercise starts. Page 66. *)

Theorem count_member_nonzero : forall (s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
  intros s. induction s as [| n s' IHs'].
  - reflexivity.
  - reflexivity.
Qed.

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

Theorem remove_does_not_increase_count: forall (s : bag),
  (count 0 (remove_one 0 s)) <=? (count 0 s) = true.
Proof.
  intros s. induction s as [| n s' IHs'].
  - simpl. reflexivity.
  - destruct n as [| n'].
    + simpl. rewrite -> leb_n_Sn. reflexivity.
    + simpl. rewrite -> IHs'. reflexivity.
Qed.

(* Exercise ends. *)

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

Inductive natoption : Type :=
  | Some (n : nat)
  | None.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match 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 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.
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 l default. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. reflexivity.
Qed.

Inductive id: Type :=
  | Id (n: nat).

Definition eqb_id (x1 x2: id) : bool :=
  match x1, x2 with
  | Id n1, Id n2 => n1 =? n2
  end.

Theorem eqb_id_refl:
  forall x: id, true = eqb_id x x.
Proof.
  intros x. destruct x as [x']. simpl.
  rewrite <- eqb_refl. reflexivity.
Qed.

Inductive partial_map: Type :=
  | empty
  | record (i: id) (v: nat) (m: 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 eqb_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 as [| i n d' IHd'].
  - simpl. rewrite <- eqb_id_refl. reflexivity.
  - simpl. rewrite <- eqb_id_refl. reflexivity.
Qed.

Theorem update_neq:
  forall (d:partial_map) (x y:id) (o:nat),
  eqb_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros d x y o. intros H.
  induction d as [| i v d' IHd'].
  - simpl. rewrite -> H. reflexivity.
  - simpl. rewrite -> H. reflexivity.
Qed.

End NatList.


(** * Lecture 02 Exercises *)

(** infer some type arguments automatically *)
Set Implicit Arguments.

Inductive list (A: Set) : Set :=
| nil : list A
| cons : A -> list A -> list A.

Arguments nil {A}.

Fixpoint length (A: Set) (l: list A) : nat :=
  match l with
  | nil => O
  | cons x xs => S (length xs)
  end.

(** add one list to the end of another *)
Fixpoint app (A: Set) (l1: list A) (l2: list A) : list A :=
  match l1 with
  | nil => l2
  | cons x xs => cons x (app xs l2)
  end.

Theorem app_nil:
  forall A (l: list A),
  app l nil = l.
Proof.
  intros.
  induction l.
  + simpl. reflexivity.
  + simpl. rewrite IHl. reflexivity.
Qed.

Theorem app_assoc:
  forall A (l1 l2 l3: list A),
  app (app l1 l2) l3 = app l1 (app l2 l3).
Proof.
  intros.
  induction l1.
  + simpl. reflexivity.
  + simpl. rewrite IHl1. reflexivity.
Qed.

(** simple but inefficient way to reverse a list *)
Fixpoint rev (A: Set) (l: list A) : list A :=
  match l with
  | nil => nil
  | cons x xs => app (rev xs) (cons x nil)
  end.

(** tail recursion is faster, but more complicated *)
Fixpoint fast_rev_aux (A: Set) (l: list A) (acc: list A) : list A :=
  match l with
  | nil => acc
  | cons x xs => fast_rev_aux xs (cons x acc)
  end.

Definition fast_rev (A: Set) (l: list A) : list A :=
  fast_rev_aux l nil.

(** add an element to the end of a list *)
Fixpoint snoc (A: Set) (l: list A) (x: A) : list A :=
  match l with
  | nil => cons x nil
  | cons y ys => cons y (snoc ys x)
  end.

Theorem snoc_app_singleton:
  forall A (l: list A) (x: A),
  snoc l x = app l (cons x nil).
Proof.
  intros.
  induction l.
  - simpl. reflexivity.
  - simpl. rewrite IHl.
    reflexivity.
Qed.

Theorem app_snoc_l:
  forall A (l1: list A) (l2: list A) (x: A),
  app (snoc l1 x) l2 = app l1 (cons x l2).
Proof.
  intros.
  induction l1.
  - simpl. reflexivity.
  - simpl. rewrite IHl1.
    reflexivity.
Qed.

Theorem app_snoc_r:
  forall A (l1: list A) (l2: list A) (x: A),
  app l1 (snoc l2 x) = snoc (app l1 l2) x.
Proof.
  intros.
  induction l1.
  - simpl. reflexivity.
  - simpl. rewrite IHl1.
    reflexivity.
Qed.

(** simple but inefficient way to reverse a list *)
Fixpoint rev_snoc (A: Set) (l: list A) : list A :=
  match l with
  | nil => nil
  | cons x xs => snoc (rev_snoc xs) x
  end.

Lemma fast_rev_ok_snoc:
  forall A (l: list A),
  fast_rev l = rev_snoc l.
Proof.
  (** TODO -- you will need to define a helper lemma
              very similar to how we proved fast_ref_ok *)
Admitted.

(** useful in proving rev_length below *)
Lemma plus_1_S:
  forall n,
  plus n 1 = S n.
Proof.
  intros.
  induction n.
  + simpl. reflexivity.
  + simpl. rewrite IHn. reflexivity.
Qed.

Lemma rev_length:
  forall A (l: list A),
  length (rev l) = length l.
Proof.
  (** TODO -- you will need to define a helper lemma
              that relates length and app *)
Admitted.

Lemma rev_involutive:
  forall A (l: list A),
  rev (rev l) = l.
Proof.
  (** TODO -- you will need to define a helper lemma
              that relates rev and app, its proof should
              use app_assoc *)
Admitted.L02_exercise.vL02_exercise.vL02_exercise.vL02_exercise.vL02_exercise.v


(** Sketch of the proof of {p:nat|p<=n} = {p:nat|p<=m} -> n=m

  - preliminary results on the irrelevance of boundedness proofs
  - introduce the notion of finite cardinal |A|
  - prove that |{p:nat|p<=n}| = n
  - prove that |A| = n /\ |A| = m -> n = m if equality is decidable on A
  - prove that equality is decidable on A
  - conclude
*)

(** * Preliminary results on [nat] and [le] *)

(** Proving axiom K on [nat] *)

Require Import Eqdep_dec.
Require Import Arith.

Theorem eq_rect_eq_nat :
  forall (p:nat) (Q:nat->Type) (x:Q p) (h:p=p), x = eq_rect p Q x p h.
Proof.
intros.
apply K_dec_set with (p := h).
apply eq_nat_dec.
reflexivity.
Qed.

(** Proving unicity of proofs of [(n<=m)%nat] *)

Scheme le_ind' := Induction for le Sort Prop.

Theorem le_uniqueness_proof : forall (n m : nat) (p q : n <= m), p = q.
Proof.
induction p using le_ind'; intro q.
 replace (le_n n) with
  (eq_rect _ (fun n0 => n <= n0) (le_n n) _ (refl_equal n)).
 2:reflexivity.
  generalize (refl_equal n).
    pattern n at 2 4 6 10, q; case q; [intro | intros m l e].
     rewrite <- eq_rect_eq_nat; trivial.
     contradiction (le_Sn_n m); rewrite <- e; assumption.
 replace (le_S n m p) with
  (eq_rect _ (fun n0 => n <= n0) (le_S n m p) _ (refl_equal (S m))).
 2:reflexivity.
  generalize (refl_equal (S m)).
    pattern (S m) at 1 3 4 6, q; case q; [intro Heq | intros m0 l HeqS].
     contradiction (le_Sn_n m); rewrite Heq; assumption.
     injection HeqS; intro Heq; generalize l HeqS.
      rewrite <- Heq; intros; rewrite <- eq_rect_eq_nat.
      rewrite (IHp l0); reflexivity.
Qed.

(** Proving irrelevance of boundedness proofs while building
    elements of interval *)

Lemma dep_pair_intro :
  forall (n x y:nat) (Hx : x<=n) (Hy : y<=n), x=y ->
    exist (fun x => x <= n) x Hx = exist (fun x => x <= n) y Hy.
Proof.
intros n x y Hx Hy Heq.
generalize Hy.
rewrite <- Heq.
intros.
rewrite (le_uniqueness_proof x n Hx Hy0).
reflexivity.
Qed.

(** * Proving that {p:nat|p<=n} = {p:nat|p<=m} -> n=m *)

(** Definition of having finite cardinality [n+1] for a set [A] *)

Definition card (A:Set) n :=
  exists f,
    (forall x:A, f x <= n) /\
    (forall x y:A, f x = f y -> x = y) /\
    (forall m, m <= n -> exists x:A, f x = m).

Require Import Arith.

(** Showing that the interval [0;n] has cardinality [n+1] *)

Theorem card_interval : forall n, card {x:nat|x<=n} n.
Proof.
intro n.
exists (fun x:{x:nat|x<=n} => proj1_sig x).
split.
(* bounded *)
intro x; apply (proj2_sig x).
split.
(* injectivity *)
intros (p,Hp) (q,Hq).
simpl.
intro Hpq.
apply dep_pair_intro; assumption.
(* surjectivity *)
intros m Hmn.
exists (exist (fun x : nat => x <= n) m Hmn).
reflexivity.
Qed.

(** Showing that equality on the interval [0;n] is decidable *)

Lemma interval_dec :
  forall n (x y : {m:nat|m<=n}), {x=y}+{x<>y}.
Proof.
intros n (p,Hp).
induction p; intros ([|q],Hq).
left.
  apply dep_pair_intro.
  reflexivity.
right.
  intro H; discriminate H.
right.
  intro H; discriminate H.
assert (Hp' : p <= n).
  apply le_Sn_le; assumption.
assert (Hq' : q <= n).
  apply le_Sn_le; assumption.
destruct (IHp Hp' (exist (fun m => m <= n) q Hq'))
  as [Heq|Hneq].
left.
  injection Heq; intro Heq'.
  apply dep_pair_intro.
  apply eq_S.
  assumption.
right.
  intro HeqS.
  injection HeqS; intro Heq.
  apply Hneq.
  apply dep_pair_intro.
  assumption.
Qed.

(** Showing that the cardinality relation is functional on decidable sets *)

Lemma card_inj_aux :
  forall (A:Type) f g n,
    (forall x:A, f x <= 0) ->
    (forall x y:A, f x = f y -> x = y) ->
    (forall m, m <= S n -> exists x:A, g x = m)
     -> False.
Proof.
intros A f g n Hfbound Hfinj Hgsurj.
destruct (Hgsurj (S n) (le_n _)) as (x,Hx).
destruct (Hgsurj n (le_S _ _ (le_n _))) as (x',Hx').
assert (Hfx : 0 = f x).
apply le_n_O_eq.
apply Hfbound.
assert (Hfx' : 0 = f x').
apply le_n_O_eq.
apply Hfbound.
assert (x=x').
apply Hfinj.
rewrite <- Hfx.
rewrite <- Hfx'.
reflexivity.
rewrite H in Hx.
rewrite Hx' in Hx.
apply (n_Sn _ Hx).
Qed.

(** For [dec_restrict], we use a lemma on the negation of equality
that requires proof-irrelevance. It should be possible to avoid this
lemma by generalizing over a first-order definition of [x<>y], say
[neq] such that [{x=y}+{neq x y}] and [~(x=y /\ neq x y)]; for such
[neq], unicity of proofs could be proven *)

  Require Import Classical.
  Lemma neq_dep_intro :
   forall (A:Set) (z x y:A) (p:x<>z) (q:y<>z), x=y ->
      exist (fun x => x <> z) x p = exist (fun x => x <> z) y q.
  Proof.
  intros A z x y p q Heq.
   generalize q; clear q; rewrite <- Heq; intro q.
   rewrite (proof_irrelevance _ p q); reflexivity.
  Qed.

Lemma dec_restrict :
  forall (A:Set),
    (forall x y :A, {x=y}+{x<>y}) ->
     forall z (x y :{a:A|a<>z}), {x=y}+{x<>y}.
Proof.
intros A Hdec z (x,Hx) (y,Hy).
destruct (Hdec x y) as [Heq|Hneq].
left; apply neq_dep_intro; assumption.
right; intro Heq; injection Heq; exact Hneq.
Qed.

Lemma pred_inj : forall n m,
  0 <> n -> 0 <> m -> pred m = pred n -> m = n.
Proof.
destruct n.
intros m H; destruct H; reflexivity.
destruct m.
intros _ H; destruct H; reflexivity.
simpl; intros _ _ H.
rewrite H.
reflexivity.
Qed.

Lemma le_neq_lt : forall n m, n <= m -> n<>m -> n < m.
Proof.
intros n m Hle Hneq.
destruct (le_lt_eq_dec n m Hle).
assumption.
contradiction.
Qed.

Lemma inj_restrict :
  forall (A:Set) (f:A->nat) x y z,
    (forall x y : A, f x = f y -> x = y)
    -> x <> z -> f y < f z -> f z <= f x
    -> pred (f x) = f y
    -> False.

(* Search error sans le type de f !! *)
Proof.
intros A f x y z Hfinj Hneqx Hfy Hfx Heq.
assert (f z <> f x).
  apply sym_not_eq.
  intro Heqf.
  apply Hneqx.
  apply Hfinj.
  assumption.
assert (f x = S (f y)).
  assert (0 < f x).
    apply le_lt_trans with (f z).
    apply le_O_n.
    apply le_neq_lt; assumption.
  apply pred_inj.
  apply O_S.
  apply lt_O_neq; assumption.
  exact Heq.
assert (f z <= f y).
destruct (le_lt_or_eq _ _ Hfx).
  apply lt_n_Sm_le.
  rewrite <- H0.
  assumption.
  contradiction Hneqx.
  symmetry.
  apply Hfinj.
  assumption.
contradiction (lt_not_le (f y) (f z)).
Qed.

Theorem card_inj : forall m n (A:Set),
  (forall x y :A, {x=y}+{x<>y}) ->
  card A m -> card A n -> m = n.
Proof.
induction m; destruct n;
intros A Hdec
 (f,(Hfbound,(Hfinj,Hfsurj)))
 (g,(Hgbound,(Hginj,Hgsurj))).
(* 0/0 *)
reflexivity.
(* 0/Sm *)
destruct (card_inj_aux _ _ _ _ Hfbound Hfinj Hgsurj).
(* Sn/0 *)
destruct (card_inj_aux _ _ _ _ Hgbound Hginj Hfsurj).
(* Sn/Sm *)
destruct (Hgsurj (S n) (le_n _)) as (xSn,HSnx).
rewrite IHm with (n:=n) (A := {x:A|x<>xSn}).
reflexivity.
(* decidability of eq on {x:A|x<>xSm} *)
apply dec_restrict.
assumption.
(* cardinality of {x:A|x<>xSn} is m *)
pose (f' := fun x' : {x:A|x<>xSn} =>
    let (x,Hneq) := x' in
    if le_lt_dec (f xSn) (f x)
    then pred (f x)
    else f x).
exists f'.
split.
(* f' is bounded *)
unfold f'.
intros (x,_).
destruct (le_lt_dec (f xSn) (f x)) as [Hle|Hge].
change m with (pred (S m)).
apply le_pred.
apply Hfbound.
apply le_S_n.
apply le_trans with (f xSn).
exact Hge.
apply Hfbound.
split.
(* f' is injective *)
unfold f'.
intros (x,Hneqx) (y,Hneqy) Heqf'.
destruct (le_lt_dec (f xSn) (f x)) as [Hlefx|Hgefx];
destruct (le_lt_dec (f xSn) (f y)) as [Hlefy|Hgefy].
(* f xSn <= f x et f xSn <= f y *)
assert (Heq : x = y).
  apply Hfinj.
  assert (f xSn <> f y).
    apply sym_not_eq.
    intro Heqf.
    apply Hneqy.
    apply Hfinj.
    assumption.
  assert (0 < f y).
    apply le_lt_trans with (f xSn).
    apply le_O_n.
    apply le_neq_lt; assumption.
  assert (f xSn <> f x).
    apply sym_not_eq.
    intro Heqf.
    apply Hneqx.
    apply Hfinj.
    assumption.
  assert (0 < f x).
    apply le_lt_trans with (f xSn).
    apply le_O_n.
    apply le_neq_lt; assumption.
  apply pred_inj.
  apply lt_O_neq; assumption.
  apply lt_O_neq; assumption.
  assumption.
apply neq_dep_intro; assumption.
(* f y < f xSn <= f x *)
destruct (inj_restrict A f x y xSn); assumption.
(* f x < f xSn <= f y *)
symmetry in Heqf'.
destruct (inj_restrict A f y x xSn); assumption.
(* f x < f xSn et f y < f xSn *)
assert (Heq : x=y).
  apply Hfinj; assumption.
apply neq_dep_intro; assumption.
(* f' is surjective *)
intros p Hlep.
destruct (le_lt_dec (f xSn) p) as [Hle|Hlt].
(* case f xSn <= p *)
destruct (Hfsurj (S p) (le_n_S _ _ Hlep)) as (x,Hx).
assert (Hneq : x <> xSn).
  intro Heqx.
  rewrite Heqx in Hx.
  rewrite Hx in Hle.
  apply le_Sn_n with p; assumption.
exists (exist (fun a => a<>xSn) x Hneq).
unfold f'.
destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt'].
rewrite Hx; reflexivity.
rewrite Hx in Hlt'.
contradiction (le_not_lt (f xSn) p).
apply lt_trans with (S p).
apply lt_n_Sn.
assumption.
(* case p < f xSn *)
destruct (Hfsurj p (le_S _ _ Hlep)) as (x,Hx).
assert (Hneq : x <> xSn).
  intro Heqx.
  rewrite Heqx in Hx.
  rewrite Hx in Hlt.
  apply (lt_irrefl p).
  assumption.
exists (exist (fun a => a<>xSn) x Hneq).
unfold f'.
destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt'].
  rewrite Hx in Hle'.
  contradiction (lt_irrefl p).
  apply lt_le_trans with (f xSn); assumption.
  assumption.
(* cardinality of {x:A|x<>xSn} is n *)
pose (g' := fun x' : {x:A|x<>xSn} =>
   let (x,Hneq) := x' in
   if Hdec x xSn then 0 else g x).
exists g'.
split.
(* g is bounded *)
unfold g'.
intros (x,_).
destruct (Hdec x xSn) as [_|Hneq].
apply le_O_n.
assert (Hle_gx:=Hgbound x).
destruct (le_lt_or_eq _ _ Hle_gx).
apply lt_n_Sm_le.
assumption.
contradiction Hneq.
apply Hginj.
rewrite HSnx.
assumption.
split.
(* g is injective *)
unfold g'.
intros (x,Hneqx) (y,Hneqy) Heqg'.
destruct (Hdec x xSn) as [Heqx|_].
contradiction Hneqx.
destruct (Hdec y xSn) as [Heqy|_].
contradiction Hneqy.
assert (Heq : x=y).
  apply Hginj; assumption.
apply neq_dep_intro; assumption.
(* g is surjective *)
intros p Hlep.
destruct (Hgsurj p (le_S _ _ Hlep)) as (x,Hx).
assert (Hneq : x<>xSn).
  intro Heq.
  rewrite Heq in Hx.
  rewrite Hx in HSnx.
  rewrite HSnx in Hlep.
  contradiction (le_Sn_n _ Hlep).
exists (exist (fun a => a<>xSn) x Hneq).
simpl.
destruct (Hdec x xSn) as [Heqx|_].
contradiction Hneq.
assumption.
Qed.

(** Conclusion *)

Theorem interval_discr :
  forall n m, {p:nat|p<=n} = {p:nat|p<=m} -> n=m.
Proof.
intros n m Heq.
apply card_inj with (A := {p:nat|p<=n}).
apply interval_dec.
apply card_interval.
rewrite Heq.
apply card_interval.
Qed.


Require Export ZArith.
Require Export Arith.

Fixpoint check_range (v:Z)(r:nat)(sr:Z){struct r} : bool :=
  match r with
    O => true
  | S r' =>
    match (v mod sr)%Z with
      Z0 => false
    | _ => check_range v r' (Z.pred sr)
    end
  end.

Definition check_primality (n:nat) :=
  check_range (Z_of_nat n)(pred (pred n))(Z_of_nat (pred n)).

Theorem verif_divide :
    forall m p:nat, 0 < m -> 0 < p ->
    (exists q:nat, m = q*p) -> (Z_of_nat m mod Z_of_nat p = 0)%Z.
Proof.
 intros m p Hltm Hltp (q, Heq); rewrite Heq.
 rewrite inj_mult.
 replace (Z_of_nat q * Z_of_nat p)%Z with (0 + Z_of_nat q * Z_of_nat p)%Z;
    try ring.
 rewrite Z_mod_plus; auto.
 omega.
Qed.

Theorem divisor_smaller :
    forall m p:nat, 0 < m -> forall q:nat, m = q*p -> q <= m.
Proof.
 intros m p Hlt; case p.
 -  intros q Heq; rewrite Heq in Hlt; rewrite mult_comm in Hlt.
     elim (lt_irrefl 0);exact Hlt.
 -  intros p' q; case q.
    +  intros Heq; rewrite Heq in Hlt.
       elim (lt_irrefl _ Hlt).
    + intros q' Heq; rewrite Heq.
      rewrite mult_comm; simpl; auto with arith.
Qed.

Theorem Zabs_nat_0 : forall x:Z, Z.abs_nat x = 0 -> (x = 0)%Z.
Proof.
 intros x; case x.
 -  simpl; auto.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
 -  intros p Heq; elim (lt_irrefl 0).
    pattern 0 at 2; rewrite <- Heq.
    simpl; apply lt_O_nat_of_P.
Qed.

Theorem Z_to_nat_and_back :
 forall x:Z, (0 <= x)%Z -> (Z.of_nat (Z.abs_nat x))=x.
Proof.
 intros x; case x.
 - reflexivity.
 -  intros p Hd; elim p.
   +  unfold Z.abs_nat; intros p' Hrec; rewrite nat_of_P_xI.
      rewrite inj_S,  inj_mult,  Zpos_xI.
      unfold Z.succ; rewrite Hrec;  simpl; auto.
   +  unfold Z.abs_nat; intros p' Hrec; rewrite nat_of_P_xO.
      rewrite inj_mult,  Zpos_xO.
      unfold Z.succ; rewrite Hrec; simpl; auto.
   +  simpl; auto.

 -  intros p' Hd; elim Hd;auto.
Qed.

Theorem  check_range_correct :
  forall (v:Z)(r:nat)(rz:Z),
  (0 < v)%Z -> Z_of_nat (S r) = rz -> check_range v r rz = true ->
  ~(exists k:nat, k <= S r /\ k <> 1 /\
                       (exists q:nat, Z.abs_nat v = q*k)).
Proof.
 intros v r; elim r.
 -  intros rz Hlt H1 H2 Hex; case Hex; intros k; case k.
   +  intros (Hle, (Hne1, (q, Heq))).
      rewrite mult_comm in Heq; simpl in Heq.
      rewrite (Zabs_nat_0 _ Heq) in Hlt.
      elim (Z.lt_irrefl 0); assumption.

   + intros k' (Hle, (Hne1, (q, Heq))).
     inversion Hle.
     *  assert (H':k'=0) by  assumption.
        rewrite H' in Hne1; elim Hne1;auto.
     *  assert (H': S k' <= 0) by  assumption.
        inversion H'.

 -  intros r' Hrec rz Hlt H1 H2 Hex; case Hex; intros k; case k.
    intros (Hle, (Hne1, (q, Heq))).
    rewrite mult_comm in Heq; simpl in Heq.
    rewrite (Zabs_nat_0 _ Heq) in Hlt.
    elim (Z.lt_irrefl 0); assumption.
    intros k' (Hle, (Hne1, (q, Heq))).
    inversion Hle.
    rewrite <- H1 in H2.
    rewrite <- (Z_to_nat_and_back v) in H2.
    assert (Hmod:(Z.of_nat (Z.abs_nat v) mod Z.of_nat (S (S r')) = 0)%Z).
    +  apply verif_divide.
       replace 0 with (Z.abs_nat 0%Z).
       apply Zabs_nat_lt.
       omega.
       simpl; auto.
       auto with arith.
       exists q.
       assert (H': k' = S r') by  assumption.
       rewrite <- H'.
       assumption.
    +  unfold check_range in H2.
       rewrite Hmod in H2.
       discriminate H2.
      + omega.
      + unfold check_range in H2; fold check_range in H2.
        case_eq ((v mod rz)%Z).
        *  intros Heqmod; rewrite Heqmod in H2; discriminate H2.
        *  intros pmod Heqmod; rewrite Heqmod in H2;  elim (Hrec (Z.pred rz) Hlt).
           rewrite <- H1; repeat rewrite inj_S;  rewrite <- Zpred_succ; auto.
          assumption.
          exists (S k'); repeat split;auto.
          exists q; assumption.

        * intros p Hmod; elim (Z_mod_lt v rz).
          rewrite Hmod; unfold Z.le; simpl; intros Hle'; elim Hle';auto.
          rewrite <- H1; rewrite inj_S; unfold Z.succ;
            generalize (Zle_0_nat (S r')).
          intros; omega.
Qed.

Theorem nat_of_P_Psucc :
 forall p:positive, nat_of_P (Pos.succ p) = S (nat_of_P p).
Proof.
 intros p; elim p.
 - simpl; intros p'; rewrite nat_of_P_xO.
   intros Heq; rewrite Heq.
   rewrite nat_of_P_xI; ring.
- intros p' Heq; simpl; rewrite nat_of_P_xI; rewrite nat_of_P_xO;auto.
-  auto.
Qed.

Theorem nat_to_Z_and_back:
 forall n:nat, Z.abs_nat (Z_of_nat n) = n.
Proof.
 intros n; elim n.
 -  auto.
 - intros n'; simpl; case n'.
  +  simpl; auto.
  +  intros n''; simpl; rewrite nat_of_P_Psucc; intros Heq; rewrite Heq; auto.
Qed.

Theorem check_correct :
  forall p:nat, 0 < p -> check_primality p = true ->
  ~(exists k:nat, k <> 1 /\ k <> p /\ (exists q:nat, p = q*k)).
Proof.
 unfold lt; intros p Hle; elim Hle.
 -  intros Hcp (k, (Hne1, (Hne1bis, (q, Heq)))); rewrite mult_comm in Heq.
    assert (Hle' : k < 1).
    +  elim (le_lt_or_eq k 1); try(intuition; fail).
       apply divisor_smaller with (2:= Heq); auto.
    +  case_eq k.
       *  intros Heq'; rewrite Heq' in Heq; simpl in Heq; discriminate Heq.
       *  intros; omega.
 -  intros p' Hlep' Hrec; unfold check_primality.
    assert (H':(exists p'':nat, p' = (S p''))).
   +  inversion Hlep'.
      *     exists 0; auto.
      *  eapply ex_intro;eauto.
   +  elim H'; intros p'' Hp''; rewrite Hp''.
      repeat rewrite <- pred_Sn.
      intros Hcr Hex;  elim check_range_correct with (3:= Hcr).
     *  rewrite inj_S; generalize (Zle_0_nat (S p'')).
        intros; omega.
     *  auto.
     *  elim Hex; intros k (Hne1, (HneSSp'', (q, Heq))); exists k.
       split.
       assert (HkleSSp'': k <= S (S p'')).
       apply (divisor_smaller (S (S p'')) q); auto with arith.
       rewrite mult_comm; assumption.
       omega.
       split.
       assumption.
       exists q; now  rewrite nat_to_Z_and_back.
Qed.