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

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

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

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

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

Compute fst (pair 3 5).

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

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

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

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

Fixpoint nonzeros (l : natlist) : natlist :=
  match l with
  | nil    => nil
  | O :: l => nonzeros l
  | x :: l => x :: nonzeros l
  end.

Compute nonzeros [0;1;0;2;0;3;0;4].

Fixpoint oddmembers' (l : natlist) : natlist :=
  match l with
  | nil          => nil
  | x :: nil     => l
  | x :: y :: l' => x :: oddmembers' l'
  end.

Compute oddmembers' [0;1;0;2;0;3;0;4].

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

Fixpoint oddmembers (l : natlist) : natlist :=
  match l with
  | nil    => nil
  | x :: l => if odd x then x :: oddmembers l else oddmembers l
  end.

Compute oddmembers [0;1;0;2;0;3;0;4].

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

Fixpoint countmembers (l : natlist) : nat :=
  match l with
  | nil    => O
  | x :: l => add x (countmembers l)
  end.

Compute countmembers [0;1;0;2;0;3;0;4].

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

(* TODO: how to do this? *)
Fail Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => nil
  | x :: l1' =>
    match l2 with
    | _ :: l2' => x :: alternate l2' l1'
    | nil      => nil
    end
  end.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => l2
  | x :: l1' =>
    match l2 with
    | y :: l2' => x :: y :: alternate l1' l2'
    | nil      => x :: alternate l1' l2
    end
  end.

Compute alternate [1;2;3] [4;5;6].

Definition bag := natlist.

(* TODO: how to do this? *)
Fail Fixpoint count (v : nat) (l : natlist) : nat :=
  match l with
  | nil     => O
  | v :: l' => S (count v l')
  | _ :: l' => count v l'
  end.

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

Fixpoint count (v : nat) (l : natlist) : nat :=
  match l with
  | nil     => O
  | x :: l' => if eqb x v then S (count v l') else count v l'
  end.

Compute count 1 [1;2;1].

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

Compute sum [1; 2; 3] [1; 4; 1].

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

Definition member (v : nat) (s : bag) : bool :=
  if count v s then false else true.

Compute member 1 [1;2;3].
Compute member 1 [0;2;3].

Fixpoint remove1 (v : nat) (s : bag) : bag :=
  match s with
  | x :: s' => if eqb x v then s' else x :: remove1 v s'
  | nil     => nil
  end.

Compute remove1 1 [1;1;2].

Fixpoint remove_all (v : nat) (s : bag) : bag :=
  match s with
  | x :: s' => if eqb x v then remove_all v s' else x :: remove_all v s'
  | nil     => nil
  end.

Compute remove_all 1 [1;1;2].

Lemma eqb_reflexivity :
  forall (n : nat), eqb n n = true.
Proof.
intros.
induction n as [|n' IHn'].
- simpl.
  reflexivity.
- simpl.
  rewrite IHn'.
  reflexivity.
Qed.

Theorem bag_theorem :
  forall (v : nat) (s : bag), count v (add' v s) = S (count v s).
Proof.
intros.
unfold add'.
simpl.
rewrite eqb_reflexivity.
reflexivity.
Qed.

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

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

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.

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

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

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

Theorem rev_head :
  forall (l : natlist) (n : nat),
  rev (n :: l) = rev l ++ [n].
Proof.
intros l.
induction l as [|x l' IHl'].
- simpl.
  reflexivity.
- intros.
  simpl.
  reflexivity.
Qed.

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

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

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

    rewrite IHl'.
    reflexivity.
Qed.

Fixpoint eqblist (l1 l2 : natlist) : bool :=
  match l1, l2 with
  | nil, nil             => true
  | x1 :: l1', x2 :: l2' => if eqb x1 x2 then eqblist l1' l2' else false
  | _, _                 => false
  end.

Theorem eqb_refl :
  forall (n : nat), eqb n n = true.
Proof.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

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

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

Notation "x <=? y" := (leb x y) (at level 60).

Theorem count_member_nonzero :
  forall (s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
intros.
simpl.
destruct (count 1 s); reflexivity.
Qed.

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

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

Theorem bag_count_sum :
  forall (a b : bag) (n : nat), count n (sum a b) = count n a + count n b.
Proof.
intros.
induction a as [|x a' IHa'].
Admitted. (* TODO *)

Lemma cons_is_app :
  forall (l : natlist) (n : nat), n :: l = [n] ++ l.
Proof.
intros.
induction l; simpl; reflexivity.
Qed.

Lemma cons_app_commute :
  forall (l1 l2 : natlist) (n : nat), (n :: l1) ++ l2 = n :: (l1 ++ l2).
Proof.
intros.
rewrite -> cons_is_app.
assert (n :: l1 ++ l2 = [n] ++ (l1 ++ l2)).
- rewrite cons_is_app. reflexivity.
- rewrite -> H.
  rewrite app_assoc.
  reflexivity.
Qed.

Lemma app1_not_empty :
  forall (l : natlist) (n : nat), not (l ++ [n] = []).
Proof.
intros.
induction l.
- simpl.
  discriminate.
- rewrite cons_app_commute.
  discriminate.
Qed.

Lemma rev_empty :
  forall (a : natlist), rev a = [] -> a = [].
Proof.
intro.
destruct a.
- simpl.
  intros.
  reflexivity.
- simpl.
  intros.
  exfalso.
  apply app1_not_empty in H.
  assumption.
Qed.

Theorem rev_injective :
  forall (a b : natlist), rev a = rev b -> a = b.
Proof.
intros a.
induction a.
- simpl.
  symmetry.
  symmetry in H.
  apply rev_empty.
  assumption.
- destruct b.
  + assert (rev [] = []).
    * simpl. reflexivity.
    * rewrite H.
      apply rev_empty.
  + (* rev (n :: a) = rev (n0 :: b) -> n :: a = n0 :: b *)
Admitted.

Theorem rev_injective_simple :
  forall (a b : natlist), rev a = rev b -> a = b.
Proof.
intros.
assert (rev (rev a) = rev (rev b)).
- rewrite H.
  reflexivity.
- rewrite rev_involutive in H0.
  rewrite rev_involutive in H0.
  assumption.
Qed.

(* New stuff: symmetry, exfalso, apply ... in ... VS rewrite *)

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

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil     => None
  | a :: l' => match n with
               | O    => Some a
               | S n' => nth_error l' n'
               end
  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
  | x :: _ => Some x
  end.

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

Theorem optional_elimit_hd :
  forall (l : natlist) (d : nat), hd d l = option_elim d (hd_error l).
Proof.
intros.
induction l; simpl; reflexivity.
Qed.

(* Remaining tasks too simple *)


Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.

(* Arithmetic expressions and string expressions. *)

(* Arithmetic expressions which evaluate to natural numbers *)
Inductive aexpr : Type :=
  AE_Lit : forall (n : nat), aexpr
| AE_Add : aexpr -> aexpr -> aexpr
| AE_Mult : aexpr -> aexpr -> aexpr.

(* Task 1: Write a function which evaluates an aexpr to a natural number. *)
Fixpoint eval_aexpr (ae : aexpr) : nat. Admitted.

(* Expressions which evaluate to strings. *)
Inductive strexpr : Type :=
  SE_Lit : forall (s : string), strexpr
| SE_Append : strexpr -> strexpr -> strexpr
| SE_Repeat : aexpr -> strexpr -> strexpr.

(* Helper function: Repeat a string n times. *)
Fixpoint repeat_str (num : nat) (str : string) : string :=
  match num with
  | O => ""%string
  | S n' => String.append str (repeat_str n' str)
  end.

(* Task 2: Write a function which evaluates a strexpr to a string. *)
Fixpoint eval_strexpr (se : strexpr) : string. Admitted.

(* The Stack Machine *)

(* We formalize a model of a simple stack machine. The stack itself is a list of strings and nats.
   The following instructions for our stack machine are available:
   - Push_nat : Push a nat on the stack.
   - Push_string : Push a string on the stack.
   - Add  : Pop two nats from the stack, add them and push the result on the stack.
   - Mult : Pop two nats from the stack, multiply them and push the result on the stack.
   - Append : Pop two strings from the stack, append them and push the result on the stack.
   - Repeat : Pop a string and a nat from the stack, repeat the string n times and push
              the result on the stack.

  Note that the behaviour of the stack machine is undefined if the required operands of an
  operation cannot be popped from the stack.
 *)

Inductive instruction : Type :=
| Push_nat : forall (n : nat), instruction
| Push_string : forall (s : string), instruction
| Add : instruction
| Mult : instruction
| Append : instruction
| Repeat : instruction.

Definition stack : Type := list (nat + string).
Definition program : Type := list instruction.
Definition state : Type := stack * program.

(* Execute one instruction from the program *)
(* Task 3: Fill in the missing cases *)
Inductive execute_step : state -> state -> Prop :=
| exec_push_nat : forall (n : nat)(st : stack)(pr : program),
    execute_step (st, Push_nat n :: pr) (inl n :: st, pr)
| exec_add : forall (n m : nat) (st : stack) (pr : program),
    execute_step (inl n :: inl m :: st, Add :: pr) (inl (n + m) :: st, pr).

Example push_nat_example : execute_step ([], [Push_nat 3]) ([inl 3],[]).
Proof.
  apply exec_push_nat.
Qed.

(* Execute all the instructions from the program. This results with the state
   of the stack at the end of execution. *)
Inductive execute : state -> stack -> Prop :=
  execute_nop : forall (st : stack), execute (st, []) st
| execute_cons : forall (s s' : state) (st : stack),
    execute_step s s' ->
    execute s' st ->
    execute s st.

(* Task 4: Give a proof of the following example. *)
Example addition_example : execute ([], [Push_nat 2; Push_nat 4; Add]) [inl 6].
Proof.
  admit.
Admitted.

(* Compiling expressions into stack programs. *)

(* We now have expressions for nats and strings, a stack machine, and want to relate them by
   a compilation step. We want to be able to compile expressions into programs for our
   stack machine. *)

(* Task 5: Define the following two compilation functions. *)
Fixpoint compile_aexpr (ae : aexpr) : program. Admitted.

Fixpoint compile_strexpr (se : strexpr) : program. Admitted.

Definition example_prog : program :=
  (compile_strexpr (SE_Repeat (AE_Add (AE_Lit 1) (AE_Lit 1)) (SE_Append (SE_Lit "Hello ") (SE_Lit "World ")))).

(* Task 6: Define the tactic "execute_tac" which can solve the goal below.
   You should use "match goal" for this. Alternatively, you can solve this goal by hand. *)
Ltac execute_tac := idtac.

Lemma example_prog_execute : execute ([], example_prog) [inr "Hello World Hello World "%string].
Proof.
  unfold example_prog. simpl.
  repeat execute_tac.
  admit.
Admitted.


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

Require Import List Arith Omega.

Require Import wf_utils llist.

Set Implicit Arguments.

(* We provide an implementation of FIFO as a triple of lazy lists
   satisfying the axioms in fifo_axm.v *)

Section fifo_three_lazy_lists.

  (** From "Simple and Efficient Purely Functional Queues and Deques" by Chris Okasaki
          Journal of Functional Programming 5(4):583-592

      this implements and prove the spec from page 587 with lazy lists (llist)
      with invariant (l,r,l') : llength l' + llength r = llength l

      let rec llist_rotate l r a := match r with
        | lcons y r -> match l with
          | lnil      -> lcons y a
          | lcons x l -> lcons x (llist_rotate l' r' (lcons y a))

      let fifo_3q_nil = (lnil,lnil,lnil)

      let fifo_3q_make l r l' = match l' with
        | lnil       -> let l' = llist_rotate l r lnil in (l',lnil,l')
        | lcons _ l' -> (l, r, l')

      let fifo_3q_enq (l,r,l') x = fifo_3q_make l (lcons x r) l'

      let fifo_3q_deq (lcons x l,r,l') = (x,fifo_3q_make l r l')

      let fifo_3q_void (l,r,n) = l = lnil

    *)

  Variable X : Type.

  Implicit Types (l r : llist X).

  Let Q_spec (c : llist X * llist X * llist X) :=
    match c with (l,r,l') => exists Hl Hr Hl', lfin_length l' Hl' + lfin_length r Hr = lfin_length l Hl end.

  Definition fifo := sig Q_spec.

  Implicit Types (q : fifo) (x : X).

  Definition fifo_list : fifo -> list X.
  Proof.
    intros (((l,r),l') & H).
    refine (llist_list l _ ++ rev (llist_list r _));
    destruct H as (? & ? & _); assumption.
  Defined.

  Let fifo_nil_val : fifo.
  Proof.
    refine (exist _ (lnil,lnil,lnil) _).
    exists (lfin_lnil _), (lfin_lnil _), (lfin_lnil _); simpl.
    rewrite lfin_length_fix_0; auto.
  Defined.

  Definition fifo_nil : { q | fifo_list q = nil }.
  Proof. exists fifo_nil_val; trivial. Defined.

  Definition fifo_make l r l' : (exists Hl Hr Hl', lfin_length l' Hl' + lfin_length r Hr = 1 + lfin_length l Hl) -> fifo.
  Proof.
    destruct l' as [ | x l'' ]; intros E.
    + cut (lfin l); [ intros Hl1 | ].
      cut (lfin r); [ intros Hr1 | ].
      2-3 : cycle 1.
      cut (lfin_length r Hr1 = 1 + lfin_length l Hl1); [ intros E1 | ].
      2-4 : cycle 1.
      refine (let l'' := @llist_rotate _ l r lnil Hl1 Hr1 (@lfin_lnil _) E1
              in exist _ (l'',lnil,l'') _).
      all: cycle 1.
      * destruct E as (? & ? & _); assumption.
      * destruct E as (? & ? & _); assumption.
      * destruct E as (Hl & Hr & Hl' & E).
        rewrite lfin_length_fix_0 in E.
        rewrite (lfin_length_eq _ Hr), (lfin_length_eq _ Hl); auto.
      * exists (lfin_rotate _ _ (@lfin_lnil _) E1),
             (@lfin_lnil _),
             (lfin_rotate _ _ (@lfin_lnil _) E1).
        unfold l''; rewrite llist_rotate_length; auto.
    + refine (exist _ (l,r,l'') _).
      destruct E as (Hl & Hr & Hl'' & E).
      exists Hl, Hr, (lfin_inv Hl'').
      rewrite lfin_length_fix_1 in E; omega.
  Defined.

  Hint Resolve llist_list_eq.

  Fact fifo_make_spec l r l' Hl Hr H : llist_list l Hl ++ rev (llist_list r Hr) = fifo_list (@fifo_make l r l' H).
  Proof.
    destruct H as (Hl1 & Hr1 & Hl' & E).
    unfold fifo_list, fifo_make; destruct l' as [ | x l' ].
    + rewrite (llist_rotate_eq _ _ (@lfin_lnil _) _).
      repeat rewrite llist_list_fix_0; simpl.
      repeat rewrite <- app_nil_end; repeat (f_equal; auto).
    + repeat (f_equal; auto).
  Qed.

  Let fifo_enq_val q x : fifo.
  Proof.
    destruct q as (((l,r),l') & H).
    refine (@fifo_make l (lcons x r) l' _).
    destruct H as (Hl & Hr & Hl' & E).
    exists Hl, (lfin_lcons _ Hr), Hl'.
    rewrite lfin_length_fix_1, (lfin_length_eq _ Hr); omega.
  Defined.

  Definition fifo_enq q x : { q' | fifo_list q' = fifo_list q ++ x :: nil }.
  Proof.
    exists (fifo_enq_val q x).
    revert q x.
    unfold fifo_enq_val.
    intros  (((l,r),l') & Hl & Hr & Hl' & E) x.
    rewrite <- (@fifo_make_spec _ _ _ Hl (lfin_lcons _ Hr)).
    unfold fifo_list.
    rewrite llist_list_fix_1, app_ass; trivial.
  Defined.

  Let fifo_deq_val q : fifo_list q <> nil -> X * fifo.
  Proof.
    destruct q as (((l,r),l') & H); revert H.
    refine (match l with
      | lnil      => fun H1 H2 => _
      | lcons x l => fun H1 H2 => (x,@fifo_make l r l' _)
    end); [ exfalso | ]; destruct H1 as (Hl & Hr & Hl' & E).
    + unfold fifo_list in H2.
      destruct r.
      * do 2 rewrite llist_list_fix_0 in H2; destruct H2; trivial.
      * rewrite lfin_length_fix_1, lfin_length_fix_0 in E; omega.
    + exists (lfin_inv Hl), Hr, Hl'.
      rewrite E, lfin_length_fix_1; auto.
  Defined.

  Definition fifo_deq q : fifo_list q <> nil -> { c : X * fifo | let (x,q') := c in fifo_list q = x::fifo_list q' }.
  Proof.
    intros Hq.
    exists (fifo_deq_val q Hq).
    revert q Hq.
    unfold fifo_deq_val.
    intros ((([ | x l],r),n) & Hl & Hr & Hl' & E) Hq.
    + exfalso.
      unfold fifo_list in Hq.
      destruct r.
      * do 2 rewrite llist_list_fix_0 in Hq; destruct Hq; trivial.
      * rewrite lfin_length_fix_1, lfin_length_fix_0 in E; omega.
    + rewrite <- (@fifo_make_spec _ _ _ (lfin_inv Hl) Hr).
      unfold fifo_list.
      rewrite llist_list_fix_1; auto.
  Defined.

  Let fifo_void_val : fifo -> bool.
  Proof.
    intros ((([ | x l],_),_) & _).
    + exact true.
    + exact false.
  Defined.

  Definition fifo_void q : { b : bool | b = true <-> fifo_list q = nil }.
  Proof.
    exists (fifo_void_val q).
    revert q.
    unfold fifo_list, fifo_void_val.
    intros ((([ | x l],r),n) & Hl & Hr & Hl' & E).
    + split; auto; intros _.
      rewrite llist_list_fix_0.
      destruct r.
      * rewrite llist_list_fix_0; auto.
      * rewrite lfin_length_fix_0, lfin_length_fix_1 in E; omega.
    + split; try discriminate.
      rewrite llist_list_fix_1; discriminate.
  Defined.

End fifo_three_lazy_lists.

Arguments fifo_nil {X}.
Arguments fifo_deq {X}.


Require Export P03.

Theorem proj1 : forall P Q : Prop,
    P /\ Q -> P.
Proof.
  intros P Q H. inversion H. apply H0.
Qed.

Theorem proj2 : forall P Q : Prop,
    P /\ Q -> Q.
Proof.
  intros P Q H. inversion H. apply H1.
Qed.

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split.
  - (* -> *) intros H. inversion  H.
    + split.
      { left. apply H0. }
      { left. apply H0. }
    + split.
      { apply proj1 in H0. right. apply H0. }
      { apply proj2 in H0. right. apply H0. }
  - (* <- *) intros H. inversion H.
    + destruct H1.
      { left. apply H1. }
      { destruct H0.
        { left. apply H0. }
        { right. split.
          { apply H0. }
          { apply H1. } } }
Qed.


Require Import ssreflect ssrfun ssrbool eqtype.

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

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

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

Theorem plus0n: forall (n: nat),
  plus O n = n.
Proof.
  done.
Qed.

Theorem plusn0: forall (n: nat),
  plus n O = n.
Proof.
  elim=> [ // | n' IH ] /=.
    by rewrite IH.
Qed.

Theorem plusSn: forall (n m: nat),
  plus n (S m) = S (plus n m).
Proof.
  elim=> [ // | n' IH m ] /=.
    by rewrite IH.
Qed.

Theorem plusC: forall (n m: nat),
  plus n m = plus m n.
Proof.
  elim=> [ m | n' IH m ] /=.
    by rewrite plusn0.
    by rewrite plusSn IH.
Qed.

Theorem plusA: forall (n m o: nat),
  plus n (plus m o) = plus (plus n m) o.
Proof.
  elim=> [ // | n' IH m o ] /=.
    by rewrite IH.
Qed.

Theorem mult0n: forall (n: nat),
  mult O n = O.
Proof.
  done.
Qed.

Theorem multn0: forall (n: nat),
  mult n O = O.
Proof.
  elim=> [ // | n' IH ] /=.
    by rewrite IH.
Qed.

Theorem mult1n: forall (n: nat),
  mult (S O) n = n.
Proof.
  by apply plusn0.
Qed.

Theorem multn1: forall (n: nat),
  mult n (S O) = n.
Proof.
  elim=> [ // | n' IH ] /=.
    by rewrite IH.
Qed.

Theorem plusSwap: forall (n m o: nat),
  plus n (plus m o) = plus m (plus n o).
Proof.
  move=> n m o.
  by rewrite plusA [X in plus X]plusC -plusA.
Qed.

Theorem multSn: forall (n m: nat),
  mult m (S n) = plus m (mult m n).
Proof.
  move=> n m.
  move: m.
  elim=> [ // | m' IH ].
    rewrite /=.
Qed.

Theorem multC: forall (n m: nat),
  mult n m = mult m n.
Proof.
  induction n as [ | n' IH ].
    (* n = 0 *)
    intros m.
    simpl.
    rewrite -> multn0.
    reflexivity.

    (* n = S n' *)
    intros m.
    simpl.


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

Require Export List.
Require Export Sorting.
Require Export Setoid Basics Morphisms.
Set Implicit Arguments.
Unset Strict Implicit.

(** * Logical relations over lists with respect to a setoid equality
      or ordering. *)

(** This can be seen as a complement of predicate [lelistA] and [sort]
    found in [Sorting]. *)

Section Type_with_equality.
Variable A : Type.
Variable eqA : A -> A -> Prop.

(** Being in a list modulo an equality relation over type [A]. *)

Inductive InA (x : A) : list A -> Prop :=
  | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l)
  | InA_cons_tl : forall y l, InA x l -> InA x (y :: l).

Hint Constructors InA.

(** TODO: it would be nice to have a generic definition instead
    of the previous one. Having [InA = Exists eqA] raises too
    many compatibility issues. For now, we only state the equivalence: *)

Lemma InA_altdef : forall x l, InA x l <-> Exists (eqA x) l.
Proof. split; induction 1; auto. Qed.

Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l.
Proof.
 intuition. invlist InA; auto.
Qed.

Lemma InA_nil : forall x, InA x nil <-> False.
Proof.
 intuition. invlist InA.
Qed.

(** An alternative definition of [InA]. *)

Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l.
Proof.
 intros; rewrite InA_altdef, Exists_exists; firstorder.
Qed.

(** A list without redundancy modulo the equality over [A]. *)

Inductive NoDupA : list A -> Prop :=
  | NoDupA_nil : NoDupA nil
  | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l).

Hint Constructors NoDupA.

(** An alternative definition of [NoDupA] based on [ForallOrdPairs] *)

Lemma NoDupA_altdef : forall l,
 NoDupA l <-> ForallOrdPairs (complement eqA) l.
Proof.
 split; induction 1; constructor; auto.
 rewrite Forall_forall. intros b Hb.
 intro Eq; elim H. rewrite InA_alt. exists b; auto.
 rewrite InA_alt; intros (a' & Haa' & Ha').
 rewrite Forall_forall in H. exact (H a' Ha' Haa').
Qed.

(** lists with same elements modulo [eqA] *)

Definition inclA l l' := forall x, InA x l -> InA x l'.
Definition equivlistA l l' := forall x, InA x l <-> InA x l'.

Lemma incl_nil l : inclA nil l.
Proof. intro. intros. inversion H. Qed.
Hint Resolve incl_nil : list.

(** lists with same elements modulo [eqA] at the same place *)

Inductive eqlistA : list A -> list A -> Prop :=
  | eqlistA_nil : eqlistA nil nil
  | eqlistA_cons : forall x x' l l',
      eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l').

Hint Constructors eqlistA.

(** We could also have written [eqlistA = Forall2 eqA]. *)

Lemma eqlistA_altdef : forall l l', eqlistA l l' <-> Forall2 eqA l l'.
Proof. split; induction 1; auto. Qed.

(** Results concerning lists modulo [eqA] *)

Hypothesis eqA_equiv : Equivalence eqA.

Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv).
Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv).
Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv).

Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA.

(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *)

Global Instance equivlist_equiv : Equivalence equivlistA.
Proof.
 firstorder.
Qed.

Global Instance eqlistA_equiv : Equivalence eqlistA.
Proof.
 constructor; red.
 induction x; auto.
 induction 1; auto.
 intros x y z H; revert z; induction H; auto.
 inversion 1; subst; auto. invlist eqlistA; eauto with *.
Qed.

(** Moreover, [eqlistA] implies [equivlistA]. A reverse result
    will be proved later for sorted list without duplicates. *)

Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA.
Proof.
  intros x x' H. induction H.
  intuition.
  red; intros.
  rewrite 2 InA_cons.
  rewrite (IHeqlistA x0), H; intuition.
Qed.

(** InA is compatible with eqA (for its first arg) and with
    equivlistA (and hence eqlistA) for its second arg *)

Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA.
Proof.
 intros x x' Hxx' l l' Hll'. rewrite (Hll' x).
 rewrite 2 InA_alt; firstorder.
Qed.

(** For compatibility, an immediate consequence of [InA_compat] *)

Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
Proof.
 intros l x y H H'. rewrite <- H; auto.
Qed.
Hint Immediate InA_eqA.

Lemma In_InA : forall l x, In x l -> InA x l.
Proof.
 simple induction l; simpl; intuition.
 subst; auto.
Qed.
Hint Resolve In_InA.

Lemma InA_split : forall l x, InA x l ->
 exists l1 y l2, eqA x y /\ l = l1++y::l2.
Proof.
induction l; intros; inv.
exists (@nil A); exists a; exists l; auto.
destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
exists (a::l1); exists y; exists l2; auto.
split; simpl; f_equal; auto.
Qed.

Lemma InA_app : forall l1 l2 x,
 InA x (l1 ++ l2) -> InA x l1 \/ InA x l2.
Proof.
 induction l1; simpl in *; intuition.
 inv; auto.
 elim (IHl1 l2 x H0); auto.
Qed.

Lemma InA_app_iff : forall l1 l2 x,
 InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2.
Proof.
 split.
 apply InA_app.
 destruct 1; generalize H; do 2 rewrite InA_alt.
 destruct 1 as (y,(H1,H2)); exists y; split; auto.
 apply in_or_app; auto.
 destruct 1 as (y,(H1,H2)); exists y; split; auto.
 apply in_or_app; auto.
Qed.

Lemma InA_rev : forall p m,
 InA p (rev m) <-> InA p m.
Proof.
 intros; do 2 rewrite InA_alt.
 split; intros (y,H); exists y; intuition.
 rewrite In_rev; auto.
 rewrite <- In_rev; auto.
Qed.

Section NoDupA.

Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' ->
  (forall x, InA x l -> InA x l' -> False) ->
  NoDupA (l++l').
Proof.
induction l; simpl; auto; intros.
inv.
constructor.
rewrite InA_alt; intros (y,(H4,H5)).
destruct (in_app_or _ _ _ H5).
elim H2.
rewrite InA_alt.
exists y; auto.
apply (H1 a).
auto.
rewrite InA_alt.
exists y; auto.
apply IHl; auto.
intros.
apply (H1 x); auto.
Qed.

Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l).
Proof.
induction l.
simpl; auto.
simpl; intros.
inv.
apply NoDupA_app; auto.
constructor; auto.
intro; inv.
intros x.
rewrite InA_alt.
intros (x1,(H2,H3)).
intro; inv.
destruct H0.
rewrite <- H4, H2.
apply In_InA.
rewrite In_rev; auto.
Qed.

Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l').
Proof.
 induction l; simpl in *; intros; inv; auto.
 constructor; eauto.
 contradict H0.
 rewrite InA_app_iff in *.
 rewrite InA_cons.
 intuition.
Qed.

Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l').
Proof.
 induction l; simpl in *; intros; inv; auto.
 constructor; eauto.
 assert (H2:=IHl _ _ H1).
 inv.
 rewrite InA_cons.
 red; destruct 1.
 apply H0.
 rewrite InA_app_iff in *; rewrite InA_cons; auto.
 apply H; auto.
 constructor.
 contradict H0.
 rewrite InA_app_iff in *; rewrite InA_cons; intuition.
 eapply NoDupA_split; eauto.
Qed.

Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y ->
 NoDupA (x::l) -> NoDupA (l1++y::l2) ->
 equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
Proof.
 intros; intro a.
 generalize (H2 a).
 rewrite !InA_app_iff, !InA_cons.
 inv.
 assert (SW:=NoDupA_swap H1). inv.
 rewrite InA_app_iff in H0.
 split; intros.
 assert (~eqA a x) by (contradict H3; rewrite <- H3; auto).
 assert (~eqA a y) by (rewrite <- H; auto).
 tauto.
 assert (OR : eqA a x \/ InA a l) by intuition. clear H6.
 destruct OR as [EQN|INA]; auto.
 elim H0.
 rewrite <-H,<-EQN; auto.
Qed.

End NoDupA.

Section Fold.

Variable B:Type.
Variable eqB:B->B->Prop.
Variable st:Equivalence eqB.
Variable f:A->B->B.
Variable i:B.
Variable Comp:Proper (eqA==>eqB==>eqB) f.

Lemma fold_right_eqlistA :
   forall s s', eqlistA s s' ->
   eqB (fold_right f i s) (fold_right f i s').
Proof.
induction 1; simpl; auto with relations.
apply Comp; auto.
Qed.

(** Fold with restricted [transpose] hypothesis. *)

Section Fold_With_Restriction.
Variable R : A -> A -> Prop.
Hypothesis R_sym : Symmetric R.
Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.

(*

(** [ForallOrdPairs R] is compatible with [equivlistA] over the
    lists without duplicates, as long as the relation [R]
    is symmetric and compatible with [eqA]. To prove this fact,
    we use an auxiliary notion: "forall distinct pairs, ...".
*)

Definition ForallNeqPairs :=
 ForallPairs (fun a b => ~eqA a b -> R a b).

(** [ForallOrdPairs] and [ForallNeqPairs] are related, but not completely
    equivalent. For proving one implication, we need to know that the
    list has no duplicated elements... *)

Lemma ForallNeqPairs_ForallOrdPairs : forall l, NoDupA l ->
 ForallNeqPairs l -> ForallOrdPairs R l.
Proof.
 induction l; auto.
 constructor. inv.
 rewrite Forall_forall; intros b Hb.
 apply H0; simpl; auto.
 contradict H1; rewrite H1; auto.
 apply IHl.
 inv; auto.
 intros b c Hb Hc Hneq.
 apply H0; simpl; auto.
Qed.

(** ... and for proving the other implication, we need to be able
   to reverse relation [R]. *)

Lemma ForallOrdPairs_ForallNeqPairs : forall l,
 ForallOrdPairs R l -> ForallNeqPairs l.
Proof.
 intros l Hl x y Hx Hy N.
 destruct (ForallOrdPairs_In Hl x y Hx Hy) as [H|[H|H]].
 subst; elim N; auto.
 assumption.
 apply R_sym; assumption.
Qed.

*)

(** Compatibility of [ForallOrdPairs] with respect to [inclA]. *)

Lemma ForallOrdPairs_inclA : forall l l',
 NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'.
Proof.
induction l' as [|x l' IH].
constructor.
intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto.
rewrite Forall_forall; intros y Hy.
assert (Ix : InA x (x::l')) by (rewrite InA_cons; auto).
 apply Incl in Ix. rewrite InA_alt in Ix. destruct Ix as (x' & Hxx' & Hx').
assert (Iy : InA y (x::l')) by (apply In_InA; simpl; auto).
 apply Incl in Iy. rewrite InA_alt in Iy. destruct Iy as (y' & Hyy' & Hy').
rewrite Hxx', Hyy'.
destruct (ForallOrdPairs_In FOP x' y' Hx' Hy') as [E|[?|?]]; auto.
absurd (InA x l'); auto. rewrite Hxx', E, <- Hyy'; auto.
Qed.

(** Two-argument functions that allow to reorder their arguments. *)
Definition transpose (f : A -> B -> B) :=
  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)).

(** A version of transpose with restriction on where it should hold *)
Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) :=
  forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)).

Variable TraR :transpose_restr R f.

Lemma fold_right_commutes_restr :
  forall s1 s2 x, ForallOrdPairs R (s1++x::s2) ->
  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
Proof.
induction s1; simpl; auto; intros.
reflexivity.
transitivity (f a (f x (fold_right f i (s1++s2)))).
apply Comp; auto.
apply IHs1.
invlist ForallOrdPairs; auto.
apply TraR.
invlist ForallOrdPairs; auto.
rewrite Forall_forall in H0; apply H0.
apply in_or_app; simpl; auto.
Qed.

Lemma fold_right_equivlistA_restr :
  forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
  equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
Proof.
 simple induction s.
 destruct s'; simpl.
 intros; reflexivity.
 unfold equivlistA; intros.
 destruct (H2 a).
 assert (InA a nil) by auto; inv.
 intros x l Hrec s' N N' F E; simpl in *.
 assert (InA x s') by (rewrite <- (E x); auto).
 destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
 subst s'.
 transitivity (f x (fold_right f i (s1++s2))).
 apply Comp; auto.
 apply Hrec; auto.
 inv; auto.
 eapply NoDupA_split; eauto.
 invlist ForallOrdPairs; auto.
 eapply equivlistA_NoDupA_split; eauto.
 transitivity (f y (fold_right f i (s1++s2))).
 apply Comp; auto. reflexivity.
 symmetry; apply fold_right_commutes_restr.
 apply ForallOrdPairs_inclA with (x::l); auto.
  red; intros; rewrite E; auto.
Qed.

Lemma fold_right_add_restr :
  forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s ->
  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
Proof.
 intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto.
Qed.

End Fold_With_Restriction.

(** we now state similar results, but without restriction on transpose. *)

Variable Tra :transpose f.

Lemma fold_right_commutes : forall s1 s2 x,
  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
Proof.
induction s1; simpl; auto; intros.
reflexivity.
transitivity (f a (f x (fold_right f i (s1++s2)))); auto.
apply Comp; auto.
Qed.

Lemma fold_right_equivlistA :
  forall s s', NoDupA s -> NoDupA s' ->
  equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
Proof.
intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True);
 repeat red; auto.
apply ForallPairs_ForallOrdPairs; try red; auto.
Qed.

Lemma fold_right_add :
  forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s ->
  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
Proof.
 intros; apply (@fold_right_equivlistA s' (x::s)); auto.
Qed.

End Fold.

Section Remove.

Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.

Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
Proof.
induction l.
right; auto.
intro; inv.
destruct (eqA_dec x a).
left; auto.
destruct IHl.
left; auto.
right; intro; inv; contradiction.
Defined.

Fixpoint removeA (x : A) (l : list A) : list A :=
  match l with
    | nil => nil
    | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl)
  end.

Lemma removeA_filter : forall x l,
  removeA x l = filter (fun y => if eqA_dec x y then false else true) l.
Proof.
induction l; simpl; auto.
destruct (eqA_dec x a); auto.
rewrite IHl; auto.
Qed.

Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y.
Proof.
induction l; simpl; auto.
split.
intro; inv.
destruct 1; inv.
intros.
destruct (eqA_dec x a); simpl; auto.
rewrite IHl; split; destruct 1; split; auto.
inv; auto.
destruct H0; transitivity a; auto.
split.
intro; inv.
split; auto.
contradict n.
transitivity y; auto.
rewrite (IHl x y) in H0; destruct H0; auto.
destruct 1; inv; auto.
right; rewrite IHl; auto.
Qed.

Lemma removeA_NoDupA :
  forall s x, NoDupA s ->  NoDupA (removeA x s).
Proof.
simple induction s; simpl; intros.
auto.
inv.
destruct (eqA_dec x a); simpl; auto.
constructor; auto.
rewrite removeA_InA.
intuition.
Qed.

Lemma removeA_equivlistA : forall l l' x,
  ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l').
Proof.
unfold equivlistA; intros.
rewrite removeA_InA.
split; intros.
rewrite <- H0; split; auto.
contradict H.
apply InA_eqA with x0; auto.
rewrite <- (H0 x0) in H1.
destruct H1.
inv; auto.
elim H2; auto.
Qed.

End Remove.

(** Results concerning lists modulo [eqA] and [ltA] *)

Variable ltA : A -> A -> Prop.
Hypothesis ltA_strorder : StrictOrder ltA.
Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA.

Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder).

Notation InfA:=(lelistA ltA).
Notation SortA:=(sort ltA).

Hint Constructors lelistA sort.

Lemma InfA_ltA :
 forall l x y, ltA x y -> InfA y l -> InfA x l.
Proof.
 destruct l; constructor. inv; eauto.
Qed.

Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA.
Proof.
 intros x x' Hxx' l l' Hll'.
 inversion_clear Hll'.
 intuition.
 split; intro; inv; constructor.
 rewrite <- Hxx', <- H; auto.
 rewrite Hxx', H; auto.
Qed.

(** For compatibility, can be deduced from [InfA_compat] *)
Lemma InfA_eqA :
 forall l x y, eqA x y -> InfA y l -> InfA x l.
Proof.
 intros l x y H; rewrite H; auto.
Qed.
Hint Immediate InfA_ltA InfA_eqA.

Lemma SortA_InfA_InA :
 forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
Proof.
 simple induction l.
 intros. inv.
 intros. inv.
 setoid_replace x with a; auto.
 eauto.
Qed.

Lemma In_InfA :
 forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
Proof.
 simple induction l; simpl; intros; constructor; auto.
Qed.

Lemma InA_InfA :
 forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
Proof.
 simple induction l; simpl; intros; constructor; auto.
Qed.

(* In fact, this may be used as an alternative definition for InfA: *)

Lemma InfA_alt :
 forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
Proof.
split.
intros; eapply SortA_InfA_InA; eauto.
apply InA_InfA.
Qed.

Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
Proof.
 induction l1; simpl; auto.
 intros; inv; auto.
Qed.

Lemma SortA_app :
 forall l1 l2, SortA l1 -> SortA l2 ->
 (forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
 SortA (l1 ++ l2).
Proof.
 induction l1; simpl in *; intuition.
 inv.
 constructor; auto.
 apply InfA_app; auto.
 destruct l2; auto.
Qed.

Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
Proof.
 simple induction l; auto.
 intros x l' H H0.
 inv.
 constructor; auto.
 intro.
 apply (StrictOrder_Irreflexive x).
 eapply SortA_InfA_InA; eauto.
Qed.

(** Some results about [eqlistA] *)

Section EqlistA.

Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'.
Proof.
induction 1; auto; simpl; congruence.
Qed.

Global Instance app_eqlistA_compat :
 Proper (eqlistA==>eqlistA==>eqlistA) (@app A).
Proof.
 repeat red; induction 1; simpl; auto.
Qed.

(** For compatibility, can be deduced from app_eqlistA_compat **)
Lemma eqlistA_app : forall l1 l1' l2 l2',
   eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2').
Proof.
intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity.
Qed.

Lemma eqlistA_rev_app : forall l1 l1',
   eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' ->
   eqlistA ((rev l1)++l2) ((rev l1')++l2').
Proof.
induction 1; auto.
simpl; intros.
do 2 rewrite app_ass; simpl; auto.
Qed.

Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A).
Proof.
repeat red. intros.
rewrite (app_nil_end (rev x)), (app_nil_end (rev y)).
apply eqlistA_rev_app; auto.
Qed.

Lemma eqlistA_rev : forall l1 l1',
   eqlistA l1 l1' -> eqlistA (rev l1) (rev l1').
Proof.
apply rev_eqlistA_compat.
Qed.

Lemma SortA_equivlistA_eqlistA : forall l l',
   SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'.
Proof.
induction l; destruct l'; simpl; intros; auto.
destruct (H1 a); assert (InA a nil) by auto; inv.
destruct (H1 a); assert (InA a nil) by auto; inv.
inv.
assert (forall y, InA y l -> ltA a y).
intros; eapply SortA_InfA_InA with (l:=l); eauto.
assert (forall y, InA y l' -> ltA a0 y).
intros; eapply SortA_InfA_InA with (l:=l'); eauto.
clear H3 H4.
assert (eqA a a0).
 destruct (H1 a).
 destruct (H1 a0).
 assert (InA a (a0::l')) by auto. inv; auto.
 assert (InA a0 (a::l)) by auto. inv; auto.
 elim (StrictOrder_Irreflexive a); eauto.
constructor; auto.
apply IHl; auto.
split; intros.
destruct (H1 x).
assert (InA x (a0::l')) by auto. inv; auto.
rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto.
destruct (H1 x).
assert (InA x (a::l)) by auto. inv; auto.
rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto.
Qed.

End EqlistA.

(** A few things about [filter] *)

Section Filter.

Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l).
Proof.
induction l; simpl; auto.
intros; inv; auto.
destruct (f a); auto.
constructor; auto.
apply In_InfA; auto.
intros.
rewrite filter_In in H; destruct H.
eapply SortA_InfA_InA; eauto.
Qed.

Implicit Arguments eq [ [A] ].

Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
 forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
Proof.
clear ltA ltA_compat ltA_strorder.
intros; do 2 rewrite InA_alt; intuition.
destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
  rewrite (H _ _ H0); auto.
destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition.
  rewrite <- (H _ _ H0); auto.
Qed.

Lemma filter_split :
 forall f, (forall x y, f x = true -> f y = false -> ltA x y) ->
 forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l.
Proof.
induction l; simpl; intros; auto.
inv.
rewrite IHl at 1; auto.
case_eq (f a); simpl; intros; auto.
assert (forall e, In e l -> f e = false).
  intros.
  assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)).
  case_eq (f e); simpl; intros; auto.
  elim (StrictOrder_Irreflexive e).
  transitivity a; auto.
replace (List.filter f l) with (@nil A); auto.
generalize H3; clear; induction l; simpl; auto.
case_eq (f a); auto; intros.
rewrite H3 in H; auto; try discriminate.
Qed.

End Filter.
End Type_with_equality.

Hint Constructors InA eqlistA NoDupA sort lelistA.

Section Find.

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

Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B :=
 match l with
  | nil => None
  | (a,b)::l => if f a then Some b else findA f l
 end.

Lemma findA_NoDupA :
 forall l a b,
 NoDupA (fun p p' => eqA (fst p) (fst p')) l ->
 (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
  findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
Proof.
set (eqk := fun p p' : A*B => eqA (fst p) (fst p')).
set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p').
induction l; intros; simpl.
split; intros; try discriminate.
invlist InA.
destruct a as (a',b'); rename a0 into a.
invlist NoDupA.
split; intros.
invlist InA.
compute in H2; destruct H2. subst b'.
destruct (eqA_dec a a'); intuition.
destruct (eqA_dec a a'); simpl.
contradict H0.
revert e H2; clear - eqA_equiv.
induction l.
intros; invlist InA.
intros; invlist InA; auto.
destruct a0.
compute in H; destruct H.
subst b.
left; auto.
compute.
transitivity a; auto. symmetry; auto.
rewrite <- IHl; auto.
destruct (eqA_dec a a'); simpl in *.
left; split; simpl; congruence.
right. rewrite IHl; auto.
Qed.

End Find.

(** Compatibility aliases. [Proper] is rather to be used directly now.*)

Definition compat_bool {A} (eqA:A->A->Prop)(f:A->bool) :=
 Proper (eqA==>Logic.eq) f.

Definition compat_nat {A} (eqA:A->A->Prop)(f:A->nat) :=
 Proper (eqA==>Logic.eq) f.

Definition compat_P {A} (eqA:A->A->Prop)(P:A->Prop) :=
 Proper (eqA==>impl) P.

Definition compat_op {A B} (eqA:A->A->Prop)(eqB:B->B->Prop)(f:A->B->B) :=
 Proper (eqA==>eqB==>eqB) f.


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

(*i $Id: Zpower.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Wf_nat.
Require Import ZArith_base.
Require Export Zpow_def.
Require Import Omega.
Require Import Zcomplements.
Open Local Scope Z_scope.

Infix "^" := Zpower : Z_scope.

(** * Definition of powers over [Z]*)

(** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary
    integer (type [nat]) and [z] a signed integer (type [Z]) *)

Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1.

(** [Zpower_nat_is_exp] says [Zpower_nat] is a morphism for
    [plus : nat->nat] and [Zmult : Z->Z] *)

Lemma Zpower_nat_is_exp :
  forall (n m:nat) (z:Z),
    Zpower_nat z (n + m) = Zpower_nat z n * Zpower_nat z m.
Proof.
  intros; elim n;
   [ simpl in |- *; elim (Zpower_nat z m); auto with zarith
     | unfold Zpower_nat in |- *; intros; simpl in |- *; rewrite H;
       apply Zmult_assoc ].
Qed.

(** This theorem shows that powers of unary and binary integers
   are the same thing, modulo the function convert : [positive -> nat] *)

Lemma Zpower_pos_nat :
  forall (z:Z) (p:positive), Zpower_pos z p = Zpower_nat z (nat_of_P p).
Proof.
  intros; unfold Zpower_pos in |- *; unfold Zpower_nat in |- *;
    apply iter_nat_of_P.
Qed.

(** Using the theorem [Zpower_pos_nat] and the lemma [Zpower_nat_is_exp] we
   deduce that the function [[n:positive](Zpower_pos z n)] is a morphism
   for [add : positive->positive] and [Zmult : Z->Z] *)

Lemma Zpower_pos_is_exp :
  forall (n m:positive) (z:Z),
    Zpower_pos z (n + m) = Zpower_pos z n * Zpower_pos z m.
Proof.
  intros.
  rewrite (Zpower_pos_nat z n).
  rewrite (Zpower_pos_nat z m).
  rewrite (Zpower_pos_nat z (n + m)).
  rewrite (nat_of_P_plus_morphism n m).
  apply Zpower_nat_is_exp.
Qed.

Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith.
Hint Unfold Zpower_pos Zpower_nat: zarith.

Theorem Zpower_exp :
  forall x n m:Z, n >= 0 -> m >= 0 -> x ^ (n + m) = x ^ n * x ^ m.
Proof.
  destruct n; destruct m; auto with zarith.
  simpl; intros; apply Zred_factor0.
  simpl; auto with zarith.
  intros; compute in H0; elim H0; auto.
  intros; compute in H; elim H; auto.
Qed.

Section Powers_of_2.

  (** * Powers of 2 *)

  (** For the powers of two, that will be widely used, a more direct
      calculus is possible. We will also prove some properties such
      as [(x:positive) x < 2^x] that are true for all integers bigger
      than 2 but more difficult to prove and useless. *)

  (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *)

  Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z.
  Definition shift_pos (n z:positive) := iter_pos n positive xO z.
  Definition shift (n:Z) (z:positive) :=
    match n with
      | Z0 => z
      | Zpos p => iter_pos p positive xO z
      | Zneg p => z
    end.

  Definition two_power_nat (n:nat) := Zpos (shift_nat n 1).
  Definition two_power_pos (x:positive) := Zpos (shift_pos x 1).

  Lemma two_power_nat_S :
    forall n:nat, two_power_nat (S n) = 2 * two_power_nat n.
  Proof.
    intro; simpl in |- *; apply refl_equal.
  Qed.

  Lemma shift_nat_plus :
    forall (n m:nat) (x:positive),
      shift_nat (n + m) x = shift_nat n (shift_nat m x).
  Proof.
    intros; unfold shift_nat in |- *; apply iter_nat_plus.
  Qed.

  Theorem shift_nat_correct :
    forall (n:nat) (x:positive), Zpos (shift_nat n x) = Zpower_nat 2 n * Zpos x.
  Proof.
    unfold shift_nat in |- *; simple induction n;
      [ simpl in |- *; trivial with zarith
	| intros; replace (Zpower_nat 2 (S n0)) with (2 * Zpower_nat 2 n0);
	  [ rewrite <- Zmult_assoc; rewrite <- (H x); simpl in |- *; reflexivity
	    | auto with zarith ] ].
  Qed.

  Theorem two_power_nat_correct :
    forall n:nat, two_power_nat n = Zpower_nat 2 n.
  Proof.
    intro n.
    unfold two_power_nat in |- *.
    rewrite (shift_nat_correct n).
    omega.
  Qed.

  (** Second we show that [two_power_pos] and [two_power_nat] are the same *)
  Lemma shift_pos_nat :
    forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x.
  Proof.
    unfold shift_pos in |- *.
    unfold shift_nat in |- *.
    intros; apply iter_nat_of_P.
  Qed.

  Lemma two_power_pos_nat :
    forall p:positive, two_power_pos p = two_power_nat (nat_of_P p).
  Proof.
    intro; unfold two_power_pos in |- *; unfold two_power_nat in |- *.
    apply f_equal with (f := Zpos).
    apply shift_pos_nat.
  Qed.

  (** Then we deduce that [two_power_pos] is also correct *)

  Theorem shift_pos_correct :
    forall p x:positive, Zpos (shift_pos p x) = Zpower_pos 2 p * Zpos x.
  Proof.
    intros.
    rewrite (shift_pos_nat p x).
    rewrite (Zpower_pos_nat 2 p).
    apply shift_nat_correct.
  Qed.

  Theorem two_power_pos_correct :
    forall x:positive, two_power_pos x = Zpower_pos 2 x.
  Proof.
    intro.
    rewrite two_power_pos_nat.
    rewrite Zpower_pos_nat.
    apply two_power_nat_correct.
  Qed.

  (** Some consequences *)

  Theorem two_power_pos_is_exp :
    forall x y:positive,
      two_power_pos (x + y) = two_power_pos x * two_power_pos y.
  Proof.
    intros.
    rewrite (two_power_pos_correct (x + y)).
    rewrite (two_power_pos_correct x).
    rewrite (two_power_pos_correct y).
    apply Zpower_pos_is_exp.
  Qed.

  (** The exponentiation [z -> 2^z] for [z] a signed integer.
      For convenience, we assume that [2^z = 0] for all [z < 0]
      We could also define a inductive type [Log_result] with
      3 contructors [ Zero | Pos positive -> | minus_infty]
      but it's more complexe and not so useful. *)

  Definition two_p (x:Z) :=
    match x with
      | Z0 => 1
      | Zpos y => two_power_pos y
      | Zneg y => 0
    end.

  Theorem two_p_is_exp :
    forall x y:Z, 0 <= x -> 0 <= y -> two_p (x + y) = two_p x * two_p y.
  Proof.
    simple induction x;
      [ simple induction y; simpl in |- *; auto with zarith
	| simple induction y;
	  [ unfold two_p in |- *; rewrite (Zmult_comm (two_power_pos p) 1);
	    rewrite (Zmult_1_l (two_power_pos p)); auto with zarith
	    | unfold Zplus in |- *; unfold two_p in |- *; intros;
	      apply two_power_pos_is_exp
	    | intros; unfold Zle in H0; unfold Zcompare in H0;
	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ]
	| simple induction y;
	  [ simpl in |- *; auto with zarith
	    | intros; unfold Zle in H; unfold Zcompare in H;
	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith
	    | intros; unfold Zle in H; unfold Zcompare in H;
	      absurd (Datatypes.Gt = Datatypes.Gt); trivial with zarith ] ].
  Qed.

  Lemma two_p_gt_ZERO : forall x:Z, 0 <= x -> two_p x > 0.
  Proof.
    simple induction x; intros;
      [ simpl in |- *; omega
	| simpl in |- *; unfold two_power_pos in |- *; apply Zorder.Zgt_pos_0
	| absurd (0 <= Zneg p);
	  [ simpl in |- *; unfold Zle in |- *; unfold Zcompare in |- *;
	    do 2 unfold not in |- *; auto with zarith
	    | assumption ] ].
  Qed.

  Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x.
  Proof.
    intros; unfold Zsucc in |- *.
    rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)).
    apply Zmult_comm.
  Qed.

  Lemma two_p_pred : forall x:Z, 0 <= x -> two_p (Zpred x) < two_p x.
  Proof.
    intros; apply natlike_ind with (P := fun x:Z => two_p (Zpred x) < two_p x);
      [ simpl in |- *; unfold Zlt in |- *; auto with zarith
	| intros; elim (Zle_lt_or_eq 0 x0 H0);
	  [ intros;
	    replace (two_p (Zpred (Zsucc x0))) with (two_p (Zsucc (Zpred x0)));
	      [ rewrite (two_p_S (Zpred x0));
		[ rewrite (two_p_S x0); [ omega | assumption ]
		  | apply Zorder.Zlt_0_le_0_pred; assumption ]
		| rewrite <- (Zsucc_pred x0); rewrite <- (Zpred_succ x0);
		  trivial with zarith ]
	    | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *;
	      auto with zarith ]
	| assumption ].
  Qed.

  Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y.
    intros; omega. Qed.

  End Powers_of_2.

Hint Resolve two_p_gt_ZERO: zarith.
Hint Immediate two_p_pred two_p_S: zarith.

Section power_div_with_rest.

  (** * Division by a power of two. *)

  (** To [n:Z] and [p:positive], [q],[r] are associated such that
      [n = 2^p.q + r] and [0 <= r < 2^p] *)

  (** Invariant: [d*q + r = d'*q + r /\ d' = 2*d /\ 0<= r < d /\ 0 <= r' < d'] *)
  Definition Zdiv_rest_aux (qrd:Z * Z * Z) :=
    let (qr, d) := qrd in
      let (q, r) := qr in
	(match q with
	   | Z0 => (0, r)
	   | Zpos xH => (0, d + r)
	   | Zpos (xI n) => (Zpos n, d + r)
	   | Zpos (xO n) => (Zpos n, r)
	   | Zneg xH => (-1, d + r)
	   | Zneg (xI n) => (Zneg n - 1, d + r)
	   | Zneg (xO n) => (Zneg n, r)
	 end, 2 * d).

  Definition Zdiv_rest (x:Z) (p:positive) :=
    let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in qr.

  Lemma Zdiv_rest_correct1 :
    forall (x:Z) (p:positive),
      let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p.
  Proof.
    intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1));
      rewrite (two_power_pos_nat p); elim (nat_of_P p);
	simpl in |- *;
	  [ trivial with zarith
	    | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *;
	      elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1));
		destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z);
		  assumption ].
  Qed.

  Lemma Zdiv_rest_correct2 :
    forall (x:Z) (p:positive),
      let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in
	let (q, r) := qr in x = q * d + r /\ 0 <= r < d.
  Proof.
    intros;
      apply iter_pos_invariant with
	(f := Zdiv_rest_aux)
	(Inv := fun qrd:Z * Z * Z =>
          let (qr, d) := qrd in
            let (q, r) := qr in x = q * d + r /\ 0 <= r < d);
	[ intro x0; elim x0; intro y0; elim y0; intros q r d;
	  unfold Zdiv_rest_aux in |- *; elim q;
	    [ omega
	      | destruct p0;
		[ rewrite BinInt.Zpos_xI; intro; elim H; intros; split;
		  [ rewrite H0; rewrite Zplus_assoc; rewrite Zmult_plus_distr_l;
		    rewrite Zmult_1_l; rewrite Zmult_assoc;
		      rewrite (Zmult_comm (Zpos p0) 2); apply refl_equal
		    | omega ]
		  | rewrite BinInt.Zpos_xO; intro; elim H; intros; split;
		    [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zpos p0) 2);
		      apply refl_equal
		      | omega ]
		  | omega ]
	      | destruct p0;
		[ rewrite BinInt.Zneg_xI; unfold Zminus in |- *; intro; elim H; intros;
		  split;
		    [ rewrite H0; rewrite Zplus_assoc;
		      apply f_equal with (f := fun z:Z => z + r);
			do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc;
			  rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc;
			    apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z);
			      omega
		      | omega ]
		  | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros;
		    split;
		      [ rewrite H0; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2);
			apply refl_equal
			| omega ]
		  | omega ] ]
	  | omega ].
  Qed.

  Inductive Zdiv_rest_proofs (x:Z) (p:positive) : Set :=
    Zdiv_rest_proof :
    forall q r:Z,
      x = q * two_power_pos p + r ->
      0 <= r -> r < two_power_pos p -> Zdiv_rest_proofs x p.

  Lemma Zdiv_rest_correct : forall (x:Z) (p:positive), Zdiv_rest_proofs x p.
  Proof.
    intros x p.
    generalize (Zdiv_rest_correct1 x p); generalize (Zdiv_rest_correct2 x p).
    elim (iter_pos p (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)).
    simple induction a.
    intros.
    elim H; intros H1 H2; clear H.
    rewrite H0 in H1; rewrite H0 in H2; elim H2; intros;
      apply Zdiv_rest_proof with (q := a0) (r := b); assumption.
  Qed.

End power_div_with_rest.


Section SetTheory.

Require Import Ensembles. (*集合論のライブラリ*)
Require Import Classical.

(*集合の定義
Variable U : Type.
Definition Ensemble := U -> Prop.*)

(*要素関係
Definition In (A:Ensemble) (x:U) : Prop := A x.*)

(*
集合の包含関係の定義である．
Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x.*)

(*全体集合と空集合の定義である．*)
(*Inductive Full set : Ensemble := Full intro : forall x:U, In Full set x.
Inductive Empty set : Ensemble :=.*)
(*Definitionだと以下
Definition Full set : Ensemble := fun x:U=>True.
Definition Empty set : Ensemble := fun x:U=>False.*)

(*集合に関する演算の和集合 (union)∪，共通部分 (intersection)

Inductive Union (B C:Ensemble) : Ensemble :=
| Union introl : forall x:U, In B x -> In (Union B C) x
| Union intror : forall x:U, In C x -> In (Union B C) x.

Inductive Intersection (B C:Ensemble) : Ensemble :=
Intersection intro : forall x:U,
  In B x -> In C x -> In (Intersection B C) x.*)

Ltac ok:= trivial; contradiction.
Ltac hairihou := apply NNPP; intro.

Variable U : Type.
Notation Shugo := (Ensemble U).
Notation "x ∈ A":=(In U A x)(at level 55,no associativity).
Notation "A ⊆ B":=(Included U A B)(at level 54, no associativity).
Notation "A ∩ B":=(Intersection U A B)(at level 53, right associativity).
Notation "A ∪ B" :=(Union U A B)(at level 53, right associativity).
Notation Ω:=(Full_set U).
Notation ø :=(Empty_set U).

Lemma in_or_not : forall A, forall x,
      (x ∈ A) \/ ~(x ∈ A).
Proof. intros; apply classic. Qed.

Lemma bubun_transitive : forall A B C,
    (A ⊆ B) /\ (B ⊆ C) -> A ⊆ C.
Proof. unfold Included. intros. destruct H as [H H1]. apply H1. apply H. ok. Qed.

Ltac bubun := unfold Included; intros.

Lemma empty_bubun : forall A, ø ⊆ A.
Proof. bubun.  destruct H. Qed.

Lemma bubun_full : forall A, A ⊆ Ω.
Proof. bubun. apply Full_intro. Qed.

Ltac seteq := apply Extensionality_Ensembles; unfold Same_set; split.

Lemma Union_aa : forall A, A ∪ A = A.
Proof. intros. seteq. bubun.
       inversion H. apply H0. apply H0.
       bubun. apply Union_introl. apply H.
Qed.

Lemma Union_comm : forall A B, A ∪ B = B ∪ A.
Proof. intros. seteq; bubun;
       destruct H; try (apply Union_intror; apply H); try (apply Union_introl; apply H).
Qed.

Lemma Union_3 : forall A B C, A ∪ ( B ∪ C ) = (A ∪ B) ∪ C.
Proof. intros. seteq; bubun. induction H. repeat (apply Union_introl). apply H. induction H. apply Union_introl.
       apply Union_intror. apply H. apply Union_intror. apply H.
       induction H. induction H. apply Union_introl. apply H. apply Union_intror. apply Union_introl. apply H.
       repeat (apply Union_intror). apply H.
Qed.

Lemma bubun_AB_A : forall A B, A ⊆ (A ∪ B).
Proof. intros. bubun. apply Union_introl. apply H. Qed.

Lemma bubun_AB_B : forall A B, B ⊆ (A ∪ B).
Proof. intros. bubun. apply Union_intror. apply H. Qed.

Lemma bubun_3 : forall A B C, A ⊆ C -> B ⊆ C -> A ∪ B ⊆ C.
Proof. bubun. inversion H1. apply H. apply H2. apply H0. apply H2. Qed.

Lemma and_AA : forall A, A ∩ A = A.
Proof. intros. seteq. bubun. inversion H. apply H0. bubun. split; apply H. Qed.

Lemma and_comm : forall A B, A ∩ B = B ∩ A.
Proof. intros. seteq; bubun; inversion H; split; assumption. Qed.

Lemma and_3 : forall A B C, A ∩ (B ∩ C) = (A ∩ B) ∩ C.
Proof. intros. seteq. bubun. inversion H as [H0  H1]; inversion H2. repeat (split); assumption.
       bubun. destruct H. destruct H. repeat (split); assumption. Qed.

Lemma and_ABA : forall A B, A ∩ B ⊆ A.
Proof. intros. bubun. inversion H. apply H0. Qed.

Lemma and_ABB : forall A B, A ∩ B ⊆ B.
Proof. intros. bubun. inversion H. apply H1. Qed.

Lemma and_CAB : forall A B C, C ⊆ A -> C ⊆ B -> C ⊆ A ∩ B.
Proof. intros. split. apply H in H1. assumption. apply H0 in H1. assumption. Qed.

Lemma and_In_iff : forall A B, A ⊆ B <-> A ∩ B = A.
Proof. intros. split. bubun. seteq. bubun. inversion H0. apply H1. bubun. split. apply H0. apply H. apply H0.
       intros. bubun. rewrite <- H in H0. inversion H0. apply H2. Qed.

(*Ensembles では，Disjoint は次のように定義されている．

Inductive Disjoint (B C:Ensemble) : Prop :=
  Disjoint intro : (forall x:U, ˜In (Intersection B C) x) -> Disjoint B C.

 B ∩ C に元がないときに，Disjoint B C と定義している．*)

Lemma Kuu :forall A B, Disjoint U A B <-> (A ∩ B) = ø.
Proof.
  split. intros. seteq. bubun. destruct H. specialize (H x). ok. apply empty_bubun.
  intros. apply Disjoint_intro. intros. unfold not. intros. rewrite H in H0. inversion H0.
Qed.


Coq < Section Predicate.

Coq < Require Import Classical.

Coq < Variable D : Set.
D is assumed

Coq < Variable R : D -> D -> Prop.
R is assumed

Coq < Section R_sym_trans.

Coq < Hypothesis R_symmetric : forall x y:D, R x y -> R y x.
R_symmetric is assumed

Coq < Hypothesis R_transitive : forall x y z:D, R x y -> R y z -> R x z.
R_transitive is assumed

Coq < Lemma refl_if : forall x:D, (exists y, R x y) -> R x x.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  ============================
   forall x : D, (exists y : D, R x y) -> R x x

refl_if < Check ex.
ex
     : forall A : Type, (A -> Prop) -> Prop

refl_if < intros x x_Rlinked.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  ============================
   R x x

refl_if < intro y.
Toplevel input, characters 0-7:
> intro y.
> ^^^^^^^
Error: No product even after head-reduction.

refl_if < elim x_Rlinked.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  ============================
   forall x0 : D, R x x0 -> R x x

refl_if < intros y Rxy.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  y : D
  Rxy : R x y
  ============================
   R x x

refl_if < apply R_transitive with y.
2 subgoals

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  y : D
  Rxy : R x y
  ============================
   R x y

subgoal 2 is:
 R y x

refl_if < assumption.
1 subgoal

  D : Set
  R : D -> D -> Prop
  R_symmetric : forall x y : D, R x y -> R y x
  R_transitive : forall x y z : D, R x y -> R y z -> R x z
  x : D
  x_Rlinked : exists y : D, R x y
  y : D
  Rxy : R x y
  ============================
   R y x

refl_if < apply R_symmetric; assumption.
No more subgoals.

refl_if < Qed.
intros x x_Rlinked.
elim x_Rlinked.
intros y Rxy.
apply R_transitive with y.
 assumption.

 apply R_symmetric; assumption.

refl_if is defined


Require Import Cases.
Definition admit {T:Type} : T. Admitted.

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

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

(* 1. Explain why proving the following lemma the "obvious" way gets stuck. *)
Lemma even__even_broken: forall n : nat, even n -> ev n.
Proof. induction n. Admitted.
(*
you must induct on the proof of evenness (where 'next' is 'S (S _)'), not on the even number (where 'next' is 'S'). "ev n" can prove "ev (S (S n))" but not "ev (S n)".
*)

(* SearchAbout *)

(*
"ev -> even" is easy because we induct on ev
"even -> ev" is hard

*)

Lemma even__iff__even_SS : forall n,
even (S (S n)) <-> even n.
Proof. intros. split.

Case "<-". intros. inversion H. assumption.

Case "->". intros. induction n.
auto. inversion H. apply H1.

Qed.

Lemma ev_implies_even : forall n : nat,
ev n -> even n.
intros. induction H.
reflexivity.
apply even__iff__even_SS. assumption.
Qed.

Lemma even_not_odd : forall n,
even n -> ~(even (S n)).
unfold not. intros. induction n.
inversion H0.
apply IHn; assumption.
Qed.

Lemma odd_not_even : forall n,
~(even (S n)) -> even n.
intros. induction n.
reflexivity.
rewrite even__iff__even_SS in H.
apply H in IHn. contradiction.
intros A. apply H.
inversion A as [A1].
unfold even.

Admitted.

(* 2. Complete the following proof instead. *)
Lemma even__even : forall n : nat,
(even n -> ev n) /\ (even (S n) -> ev (S n)).
Proof. intro. apply and_comm. split.

Case "n". intros. induction n.

inversion H.

apply ev_SS. rewrite even__iff__even_SS in H.
admit.

Case "S n". admit.
Qed.

(* cant do it *)

(* 3. Construct a proof object demonstrating the following proposition. *)
Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
fun (P Q R : Prop) (pq : P /\ Q) (qr : Q /\ R) =>
(* take proof of P from PQ and proof of Q from QR to make a proof of PR *)
conj
 match pq with conj p q => p end
 match qr with conj q r => r end
.

(* 4. Distributing or over and *)
(* This one is provided from the notes... *)
Theorem or_distributes_over_and_1 : forall P Q R : Prop,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. intros H. inversion H as [HP | [HQ HR]].
    Case "left". split.
      SCase "left". left. apply HP.
      SCase "right". left. apply HP.
    Case "right". split.
      SCase "left". right. apply HQ.
      SCase "right". right. apply HR. Qed.

(* Prove the reverse direction... *)
Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
intros. inversion H as [[HP | HQ] [HP' | HR]].
left. assumption.
left. assumption.
left. assumption.
right. split; assumption.
Qed.

(* ...and give a *short* proof of the if-and-only-if *)
Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof. split.
 apply or_distributes_over_and_1.
 apply or_distributes_over_and_2.
Qed.

(* 5. Facts about not and or *)
Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~ Q -> ~ P).
Proof.
unfold not. intros P Q. intros A B C.
apply B. apply A. apply C.
Qed.

Theorem not_both_true_and_false : forall P:Prop, ~(P /\ ~ P).
Proof.
intros P H. unfold not in *. inversion H.
apply (H1 H0).
Qed.

(* Why does the following lemma get stuck? *)
Lemma broken : forall (P Q:Prop),
  (P -> Q) -> (~ P -> False) -> Q.
Proof.
  intros. apply H. unfold not in *. Admitted.
(* we just cant prove P. its on the left of the hypotheses. if we try the contrapositive, we just get the same *)

(* 6. Tricky!  The following five statements are often
      considered as characterizations of classical logic.  We can't
      prove them in Coq, but we can add any of them as an unproven
      axiom if we want to work in classical logic.

      For credit in this problem, prove that "de_morgan_not_and_not"
      and "excluded_middle" are equivalent.

      For extra credit, prove that all five definitions are
      equivalent.  If you try this part:
        Hint 1: You can prove this equivalence in just five
                implications.
        Hint 2: Follow the ordering of the definitions below.
*)

Definition peirce := forall P Q: Prop,
  ((P -> Q) -> P) -> P.
Definition classic := forall P:Prop,
  ~~P  ->  P.
Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~P/\~Q)  ->  P\/Q.
Definition excluded_middle := forall P:Prop,
  P \/ ~P.
Definition implies_to_or := forall P Q:Prop,
  (P -> Q)  ->  (~P\/Q).

Theorem peirce_implies_classic : peirce -> classic.
unfold peirce, classic. intros Peirce P.
unfold not at 2. intro NN. apply (Peirce P False). intro N.
contradiction.
Qed.

Theorem classic_implies_demorgan : classic -> de_morgan_not_and_not.
unfold classic, de_morgan_not_and_not.
intro Classic. intros P Q. unfold not.
intro nan. apply Classic. unfold not.
intro nor. apply nan.
split.
 intro. apply nor. left. assumption.
 intro. apply nor. right. assumption.
Qed.

Theorem demorgan_implies_exclude : de_morgan_not_and_not -> excluded_middle.
unfold de_morgan_not_and_not, excluded_middle.
intros Demogran P. apply Demogran. unfold not. intro.
inversion H. contradiction.
Qed.

Theorem exclude__implies__imply_is_or : excluded_middle -> implies_to_or.
unfold excluded_middle, implies_to_or.
intros EM. intros P Q H.
Check EM P.
remember (EM P) as either_or. inversion either_or as [T|F].
(* syntax for "inversion (EM P)" ? *)
Case "P is true". right. apply (H T).
Case "P is false". left. assumption.
Qed.

Theorem O2I : forall P Q : Prop,
 (P -> False) \/ Q -> (P -> Q).
Proof. intros. inversion H. contradiction. assumption.
Qed.

(*
Theorem __classical__or_iff_implies : forall P Q : Prop,
 classic ->
 ((P -> Q)  <->  (P -> False) \/ Q).
Proof. intros.
apply classic_implies_demorgan in H.
apply demorgan_implies_exclude in H.
apply exclude__implies__imply_is_or in H.
split. apply H. apply O2I.
Qed.
*)

Theorem __classical__or_iff_implies : forall P Q : Prop,
 ((P -> Q)  <->  (P -> False) \/ Q).
Admitted.

Theorem imply_is_or__implies__peirce : implies_to_or -> peirce.
unfold implies_to_or, peirce, not.
intros I2O. intros P Q. intros H.

remember H as H'. clear HeqH'.
apply I2O in H.
assert (OiffI := __classical__or_iff_implies).
rewrite (OiffI P Q) in H.

destruct H as [A|B].
(* rewrite de_morgan_not_and_not in A. *)

(*
rewrite (I2O P Q) in L.
apply H. intro HP.
apply I2O in H. destruct H as [L|R].
*)

Case "hard". (* admit. dammit, the last one *)
admit.

Case "easy". assumption.
Admitted.

(* remember (I2O (P->Q) P H) as A. clear HeqA. inversion A as [L|R].
Case "P left". apply H.
 remember (P -> Q) as PiQ. clear HeqPiQ. apply PiQ in L.
Case "P right". assumption.
*)

(* 7. Forall and exists, in classical logic *)
Theorem forall__not_exists_not :
  forall (X:Type) (P : X -> Prop),
    (forall x, P x) -> ~ (exists x, ~ P x).
Proof. (* This should be a *short* proof *)
unfold not. intros X P A E.
 inversion E. apply H. apply A.
Qed.

Theorem not_exists_not__forall : excluded_middle ->
  forall (X : Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof. unfold excluded_middle. unfold not.
intros EM. intro X. intro P. intro NN. intro x.

assert (P x \/ (P x -> False)). apply EM.
inversion H as [L|R].

assumption.

assert False. apply NN. exists x.
assumption.
contradiction.

Qed.

(* Theorem not_exists__forall_not : excluded_middle ->
  forall (X : Type) (P : X -> Prop),
    ~ (exists x, P x) -> (forall x, ~ P x).
Proof.
unfold excluded_middle. unfold not. intros EM X P E w H.
apply E. exists w. assumption.
Qed.
*)

(* 8. Multi-place relations *)
Inductive R : nat -> nat -> nat -> Prop :=
   | c1 : R 0 0 0
   | c2 : forall m n o, R m n o -> R (S m) n (S o)
   | c3 : forall m n o, R m n o -> R m (S n) (S o)
   | c4 : forall m n o, R (S m) (S n) (S (S o)) -> R m n o
   | c5 : forall m n o, R m n o -> R n m o.

(* The relation R above relates triples of numbers.  Which of the
   following two terms are provable?

   R 1 1 2
   R 2 2 6 *)
Goal R 1 1 2. apply c3. apply c2. apply c1. Qed.

(* If we dropped the constructor c5 from the definition of R, would
   the set of provable propositions change?  Why? (1-sentence answer)
 *)
(* ANSWER no because "apply c5. apply c2." is just "apply c3." when m <> n (and does nothing otherwise) *)

(* If  we dropped the constructor c4, would the set of provable
   propositions change?  Why?  (1-sentence answer) *)
(* ANSWER no because  "apply c5." undoes "apply c2. apply c3." *)

(* In words, describe what common relationship between numbers is
   expressed by R. *)
(* "m, n and o are related by R iff m+n=o." nice. *)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Category.
From Categories Require Import Category.Opposite.

Local Open Scope morphism_scope.

(** The basic Definition of an isomorphism in a category.
An isomorphism is a pair of arrows f : a -> b and g : b -> a such that
g ∘ f = id a and f ∘ g = id b. *)
Record Isomorphism {C : Category} (a b : C) : Type :=
{
  iso_morphism : a –≻ b;

  inverse_morphism : b –≻ a;

  left_inverse : (inverse_morphism ∘ iso_morphism)%morphism = id;

  right_inverse : (iso_morphism ∘ inverse_morphism)%morphism = id
}.

Bind Scope morphism_scope with Isomorphism.
Bind Scope isomorphism_scope with Isomorphism.

Hint Resolve left_inverse.

Hint Resolve right_inverse.

Coercion iso_morphism : Isomorphism >-> Hom.

Arguments iso_morphism {_ _ _} _.
Arguments inverse_morphism {_ _ _} _.
Arguments left_inverse {_ _ _} _.
Arguments right_inverse {_ _ _} _.

Notation "f '⁻¹'" := (inverse_morphism f) : morphism_scope.

Notation "a ≃ b" := (Isomorphism a b) : isomorphism_scope.

Notation "a ≃≃ b ::> C" := (@Isomorphism C a b) : isomorphism_scope.

Local Open Scope isomorphism_scope.

(* basic tactics for isomorphisms *)

Ltac simpl_isos_in_goal :=
  repeat(
      match goal with
      | [|- context[(iso_morphism ?A ∘ inverse_morphism ?A)%morphism]] =>
        rewrite (right_inverse A); simpl_ids
      | [|- context[(inverse_morphism ?A ∘ iso_morphism ?A)%morphism] ] =>
        rewrite (left_inverse A); simpl_ids
(* disabled due to problems with reveal_comp complexity *)
(*        | [|- context[iso_morphism ?A] ] =>
          reveal_comp (inverse_morphism A) (iso_morphism A) +
          reveal_comp (iso_morphism A) (inverse_morphism A) *)
      end
    )
.

Ltac simpl_isos_in_I I :=
  repeat(
      match type of I with
      | context[(iso_morphism ?A ∘ inverse_morphism ?A)%morphism] =>
        rewrite (right_inverse A) in I; simpl_ids in I
      | context[(inverse_morphism ?A ∘ iso_morphism ?A)%morphism] =>
        rewrite (left_inverse A) in I; simpl_ids in I
(* disabled due to problems with reveal_comp complexity *)
(*        | context[inverse_morphism ?A] =>
          reveal_comp (inverse_morphism A) (iso_morphism A) in I +
          reveal_comp (iso_morphism A) (inverse_morphism A) in I *)
      end
    )
.

Tactic Notation "simpl_isos" := simpl_isos_in_goal.

Tactic Notation "simpl_isos" "in" hyp(I) := simpl_isos_in_I I.

Hint Extern 3 => progress simpl_isos.

Hint Extern 3 => progress (dohyps (fun H => simpl_isos in H)).

(** simplifies equality of iso-morphisms. This theorem uses proof irrelevance
to assume any two proofs for left and right inverse properties are equal.
In other words, two isomorphisms are equal if their underlying morphisms are. *)
Theorem Isomorphism_eq_simplify {C : Category} {a b : C} (I I' : a ≃ b) :
  (iso_morphism I = iso_morphism I') →
  (inverse_morphism I = inverse_morphism I') → I = I'.
Proof.
  intros H1 H2.
  destruct I as [iI inI Il Ir]; destruct I' as [iI' inI' Il' Ir'].
  cbn in *.
  destruct H1; destruct H2.
  destruct (proof_irrelevance _ Il Il').
  destruct (proof_irrelevance _ Ir Ir').
  trivial.
Qed.

(** Isomorphism is an equivalence relation on objects. *)

(** The identity morphism forms an isomorphism, i.e., it is inverse to itself.
This is reflexivity property for the equivalence relation of isomorphism
on objects. *)
Program Definition Isomorphism_id {C : Category} {a : C} : a ≃ a :=
{|
  iso_morphism := id;
  inverse_morphism := id
|}.

(** Each ismorphism has an inverse isomorphism. Simply swap the morphisms and
proofs of left and right inverse properties. This is symmetry property for the
equivalence relation of isomorphism on objects. *)
Definition Inverse_Isomorphism {C : Category} {a b : C} (I : a ≃ b) : b ≃ a :=
{|
  iso_morphism := I⁻¹;
  inverse_morphism := I;
  left_inverse := right_inverse I;
  right_inverse := left_inverse I
|}.

Notation "f '⁻¹'" := (Inverse_Isomorphism f) : isomorphism_scope.

(** Isomorphisms compose. Simply compose the underlying morphisms of the
isomorphism. Left and right inverse properties follow straightforwardly.
This is transitivty property for the equivalence relation of isomorphism
on objects. *)
Program Definition Isomorphism_Compose
        {C : Category} {a b c : C} (I : a ≃ b) (I' : b ≃ c) : a ≃ c
  :=
{|
  iso_morphism := I' ∘ I;
  inverse_morphism := I⁻¹ ∘ I'⁻¹
|}.

Next Obligation.
Proof.
  rewrite assoc.
  rewrite (assoc_sym I).
  auto.
Qed.

Next Obligation.
Proof.
  rewrite assoc.
  rewrite (assoc_sym (I'⁻¹)).
  auto.
Qed.

Notation "f ∘ g" := (Isomorphism_Compose g f) : isomorphism_scope.

Local Close Scope isomorphism_scope.

(** A monic arrow (AKA, mono, monomorphic arrow and monomorphism) m is an arrow
such that for any two arrows g and h (of the appropriate domain and codomain)
we have if m ∘ g = m ∘ h then g = h. *)
Record Monic {C : Category} (a b : Obj) :=
{
  mono_morphism : a –≻ b;
  mono_morphism_monomorphic : ∀ (c : Obj) (g h : c –≻ a),
      (mono_morphism ∘ g = mono_morphism ∘ h) → g = h
}.

Coercion mono_morphism : Monic >-> Hom.

Arguments mono_morphism {_ _ _} _.
Arguments mono_morphism_monomorphic {_ _ _} _ _ _ _ _.

Notation "a ≫–> b" := (Monic a b) : morphism_scope.

Bind Scope morphism_scope with Monic.

(** An epic arrow (AKA, epi, epimorphic arrow and epimorphism) is a monomorphism
in the opposite category. That is, m is epic if for any pair of arrows g and h
(of the appropriate domain and codomain) we have if g ∘ m = h ∘ m then g = h. *)
Definition Epic {C : Category} (a b : C) := @Monic (C^op) b a.

Notation "a –≫ b" := (Epic a b) : morphism_scope.

Bind Scope morphism_scope with Epic.

(** The condition for a morphism to be mono-morphic. *)
Definition is_Monic {C : Category} {a b : Obj} (f : a –≻ b) :=
  ∀ (c : Obj) (g h : c –≻ a), (f ∘ g = f ∘ h) → g = h.

(** A mono-morphic morphism forms a Monic. *)
Definition is_Monic_Monic
           {C : Category}
           {a b : Obj}
           {f : a –≻ b}
           (H : is_Monic f)
  : Monic a b
  :=
    {|
      mono_morphism := f;
      mono_morphism_monomorphic := H
    |}
.

(** A morphism is ipic if it is monic in the opposit category. *)
Definition is_Epic {C : Category} {a b : C} (f : a –≻ b) :=
  @is_Monic (C^op) b a f.

(** A morphism f : a –≻ b is split monic if there is another morphism
g : b –≻ a such that g ∘ f = idₐ *)
Record is_split_Monic {C : Category} {a b : Obj} (f : a –≻ b) :=
  {
    is_split_monic_left_inverse : b –≻ a;
    is_split_monic_left_inverse_is_left_inverse :
      (is_split_monic_left_inverse ∘ f) = id
  }
.

Arguments is_split_monic_left_inverse {_ _ _ _} _.
Arguments is_split_monic_left_inverse_is_left_inverse {_ _ _ _} _.

(** A morphism is ipic if it is monic in the opposit category. *)
Definition is_split_Epic {C : Category} {a b : C} (f : a –≻ b) :=
  @is_split_Monic (C^op) b a f.

(** A split monic morphism is a monomorphism. *)
Program Definition is_split_Monic_Monic
           {C : Category}
           {a b : Obj}
           {f : a –≻ b}
           (H : is_split_Monic f)
  : Monic a b
  :=
    {|
      mono_morphism := f;
      mono_morphism_monomorphic := fun c g h H1 => _
    |}
.

Next Obligation.
Proof.
  assert (H2 := f_equal (fun w : c –≻ b => (is_split_monic_left_inverse H) ∘ w) H1).
  cbn in H2.
  repeat rewrite assoc_sym in H2.
  rewrite is_split_monic_left_inverse_is_left_inverse in H2.
  auto.
Qed.

(** If a monic morphism is split epic, it forms an isomorphism. *)
Program Definition Monic_is_split_Epic_Iso
        {C : Category}
        (a b : Obj)
        (f : a ≫–> b)
        (H : is_split_Epic f)
  :
    (a ≃ b)%isomorphism
  :=
    {|
      iso_morphism := f;
      inverse_morphism := is_split_monic_left_inverse H;
      right_inverse := is_split_monic_left_inverse_is_left_inverse H
    |}
.

Next Obligation.
Proof.
  apply (mono_morphism_monomorphic f).
  rewrite assoc_sym.
  cbn_rewrite (is_split_monic_left_inverse_is_left_inverse H).
  auto.
Qed.

(** If both g and (f ∘ g) are monic, then so is f. *)
Program Definition Compose_Monic_is_Monic_then_Monic
           {C : Category}
           {a b c : C}
           (M : a –≻ b)
           (M' : b ≫–> c)
           (H : is_Monic (M' ∘ M))
  :
    Monic a b
  :=
    {|
      mono_morphism := M;
      mono_morphism_monomorphic := fun d g h H1 => _
    |}
.

Next Obligation.
Proof.
  assert (H2 := f_equal (fun w : d –≻ b => M' ∘ w) H1).
  cbn in H2.
  repeat rewrite assoc_sym in H2.
  apply H; trivial.
Qed.

(** Monomorphisms compose. The case for epis follows by duality.*)
Section Mono_compose.
  Context {C : Category} {a b c : C} (M : a ≫–> b) (M' : b ≫–> c).

  Local Hint Resolve mono_morphism_monomorphic.

  Local Obligation Tactic := eauto.

  Program Definition Mono_compose : a ≫–> c :=
    {|
      mono_morphism := M' ∘ M
    |}.

End Mono_compose.

Local Open Scope isomorphism_scope.

(** An isomorphism is both monic and epic. *)
Section Iso_Mono_Epi.
  Context {C : Category} {a b : Obj} (I : a ≃ b).

  Program Definition Ismorphism_Monic : a ≫–> b :=
    {|
      mono_morphism := I
    |}.

  Next Obligation. (* mono_morphism_monomorphism *)
  Proof.
    match goal with
        [ H : (_ ∘ ?f = _ ∘ ?f')%morphism |- ?f = ?f'] =>
        match type of H with
            ?A = ?B =>
            let H' := fresh "H" in
            cut (I⁻¹ ∘ A = I⁻¹ ∘ B)%morphism; [auto | rewrite H; trivial]
        end
    end.
    repeat rewrite assoc_sym.
    auto.
  Qed.

  Program Definition Ismorphism_Epic : b –≫ a :=
    {|
      mono_morphism := inverse_morphism I
    |}.
  Next Obligation. (* epi_morphism_epimorphism *)
  Proof.
    match goal with
        [ H : (?f ∘ _ = ?f' ∘ _)%morphism |- ?f = ?f'] =>
        match type of H with
            ?A = ?B =>
            let H' := fresh "H" in
            cut (A ∘ I = B ∘ I)%morphism; [auto | rewrite H; trivial]
        end
    end.
    repeat rewrite assoc.
    auto.
  Qed.

End Iso_Mono_Epi.

(** If two objects are isomorphic in category C then they are also isomorphic
in C^op. *)
Theorem CoIso {C : Category} (a b : C) : a ≃≃ b ::> C → a ≃≃ b ::> C^op.
Proof.
  intros I.
  eapply (Build_Isomorphism (C^op)%category _ _ (I⁻¹) I);
    unfold compose; simpl; auto.
Qed.


Set Warnings "-notation-overriden,-parsing".
Require Export Poly.
Theorem silly1: forall (n m o p: nat),
    n = m ->
    [n;o] = [n;p] ->
    [n;o] = [m;p].
Proof.
  intros n m o p eq1 eq2. rewrite <- eq1. apply eq2. Qed.
Theorem silly2: forall (n m o p: nat),
    n = m ->
    (forall (q r: nat), q = r -> [q;o] = [r;p]) ->
    [n;o] = [m;p].
Proof. intros n m o p eq1 eq2. apply eq2. apply eq1. Qed.
Theorem silly2a: forall (n m : nat),
    (n, n) = (m, m) ->
    (forall (q r: nat), (q, q) = (r, r) -> [q] = [r]) ->
    [n] = [m].
Proof. intros n m eq1 eq2. apply eq2. apply eq1. Qed.
(** *Exercise silly_ex *)
Theorem silly_ex:
  (forall n, evenb n = true -> oddb (S n) = true) ->
  evenb 3 = true -> oddb 4 = true.
Proof. intros H1 H2. apply H1. apply H2. Qed.
Theorem silly3_firsttry: forall (n: nat),
    true = beq_nat n 5 -> beq_nat (S (S n)) 7 = true.
Proof. intros n H. symmetry. simpl. apply H. Qed.
(** *Exercise apply_exercise1 *)
Theorem rev_exercise1: forall (l l': list nat),
    l = rev l' -> l' = rev l.
Proof. intros l l' H. rewrite -> H. symmetry. apply rev_involutive. Qed.
(** *Exercise apply_rewrite
    apply is a tool to match the target against a consequent of a statement.
    rewrite performs substitution if the target and the consequent are
    equalities. *)
Example trans_eq_example: forall (a b c d e f: nat),
    [a;b] = [c;d] -> [c;d] = [e;f] -> [a;b] = [e;f].
Proof. intros a b c d e f eq1 eq2. rewrite -> eq1, -> eq2. reflexivity. Qed.
Theorem trans_eq: forall (X:Type) (n m o:X),
    n = m -> m = o -> n = o.
Proof. intros X n m o eq1 eq2. rewrite -> eq1, -> eq2. reflexivity. Qed.
Example trans_eq_example': forall a b c d e f : nat,
    [a;b]=[c;d] -> [c;d]=[e;f] -> [a;b]=[e;f].
Proof.
  intros a b c d e f eq1 eq2. apply trans_eq with (m:=[c;d]).
  apply eq1. apply eq2. Qed.
(** *Exercise apply_with_exercise *)
Example trans_eq_exercise: forall n m o p: nat,
    m = minustwo o -> n + p = m -> n + p = minustwo o.
Proof. intros n m o p eq1 eq2. apply trans_eq with m. apply eq2. apply eq1. Qed.

Theorem S_injective: forall n m : nat, S n = S m -> n = m.
Proof. intros n m H. inversion H. reflexivity. Qed.

Theorem inversion_ex1: forall n m o: nat,
    [n;m]=[o;o] -> [n]=[m].
Proof. intros n m o H. inversion H. reflexivity. Qed.

Theorem inversion_ex2: forall n m: nat, [n] = [m] -> n = m.
Proof. intros n m H. inversion H as [Hnm]. reflexivity. Qed.

(** *Exercise inversion_ex3 *)
Example inversion_ex3: forall(X: Type)(x y z: X) (l j: list X),
    x::y::l = z::j -> y::l = x::j -> x = y.
Proof.
  intros X x y z  l j eq1 eq2. inversion eq2. reflexivity. Qed.
Theorem beq_nat_0_l: forall n, beq_nat 0 n = true -> n = 0.
Proof.
  destruct n as [| n'].
  - intros H. reflexivity.
  - simpl. intros H. inversion H. Qed.
Theorem inversion_ex4: forall n, S n = O -> 2 + 2 = 5.
Proof. intros n contra. inversion contra. Qed.
Theorem inversion_ex5: forall n m: nat, false = true -> [n] = [m].
Proof. intros n m contra. inversion contra. Qed.
(** *Exercise inversion_ex6 *)
Example inversion_ex6: forall(X: Type)(x y z: X)(l j: list X),
    x::y::l = [] -> y::l=z::j -> x = z.
Proof. intros X x y z l j H. inversion H. Qed.

Theorem f_equal: forall (A B: Type)(f: A -> B)(x y: A),
    x = y -> f x = f y.
Proof. intros A B f x y eq. rewrite eq. reflexivity. Qed.

Theorem S_inj: forall (n m: nat)(b: bool), beq_nat (S n) (S m) = b -> beq_nat n m = b.
Proof. intros n m b H. simpl in H. apply H. Qed.
Theorem silly3': forall n: nat,
    (beq_nat n 5 = true -> beq_nat (S (S n)) 7 = true) ->
    true = beq_nat n 5 -> true = beq_nat (S (S n)) 7.
Proof.
  intros n eq H. symmetry in H. apply eq in H. symmetry in H. apply H. Qed.
(** *Exercise plus_n_n_injectie *)
Theorem plus_n_n_injective: forall n m, n + n = m + m -> n = m.
Proof.
  intros n. induction n as [| n' I].
  - destruct m as [|m'].
    + intros _. reflexivity.
    + intros H. inversion H.
  - intros m H. destruct m as [|m'].
    + inversion H.
    + rewrite <- ?plus_n_Sm in H. simpl in H. inversion H as [H'].
      apply I in H'. rewrite H'. reflexivity. Qed.

Theorem double_injective_FAILED: forall n m, double n = double m -> n = m.
Proof.
  intros n m. induction n as [|n'].
  - simpl. intros eq. destruct m as [|m'].
    + reflexivity.
    + inversion eq.
  - intros eq. destruct m as [|m'].
    + inversion eq.
    + apply f_equal.
Abort.
Theorem double_injective: forall n m, double n = double m -> n = m.
Proof.
  intros n. induction n as [|n' I].
  - simpl. intros m eq. destruct m as [|m'].
    + reflexivity.
    + inversion eq.
  - simpl. intros m eq. destruct m as [|m'].
    + simpl. inversion eq.
    + apply f_equal. apply I. inversion eq. reflexivity. Qed.
(** *Exercise beq_nat_true *)
Theorem beq_nat_true: forall n m, beq_nat n m = true -> n = m.
Proof.
  induction n as [|n I].
  - destruct m as [|m].
    + reflexivity.
    + intros c. inversion c.
  - simpl. destruct m as [|m].
    + intros c. inversion c.
    + intros H. apply f_equal. apply I. apply H.
Qed.
(** *Exercise beq_nat_true_informal
We need to prove forall n m, beq_nat n m = true -> n = m.
Proceed by induction on n:
if n = 0, then forall m, beq_nat 0 m = true -> 0 = m is obvious.
Assume, forall m, plus n m = true -> n = m. Then for S n we need to prove
forall m, beq_nat (S n) m = true -> S n = m.
It is sufficient to consider m of the form S _, since the antecedent is false
otherwise.
Thus, it simplifies to forall m, beq_nat n m -> n = m, which is the assumption.
*)

Theorem double_injective_take2: forall n m, double n = double m -> n = m.
Proof.
  intros n m. generalize dependent n.
  induction m as [|m']; destruct n as [|n']; intros H.
  - reflexivity.
  - inversion H.
  - inversion H.
  - apply f_equal. simpl in H. inversion H as [H1]. apply IHm' in H1. exact H1.
Qed.

Theorem beq_id_true: forall x y, beq_id x y = true -> x = y.
Proof.
  intros [m] [n]. simpl. intros H.
  assert (H': m = n).
  { apply beq_nat_true. apply H. }
  rewrite H'. reflexivity.
Qed.

(** *Exercise gen_dep_practice *)
Theorem nth_error_after_last: forall (n: nat)(X: Type)(l: list X),
    length l = n -> nth_error l n = None.
Proof.
  intros n X l. generalize dependent n.
  induction l as [|h t I]; intros n H.
  - reflexivity.
  - simpl in H. destruct n as [|n].
    + inversion H.
    + simpl. apply I. inversion H. reflexivity.
Qed.

Definition square n := n * n.
Lemma square_mult: forall n m, square (n * m) = square n * square m.
Proof.
  intros n m. simpl. unfold square.
  rewrite mult_assoc.
  assert (H: n * m * n = n * n * m).
  { rewrite mult_comm. apply mult_assoc. }
  rewrite H. rewrite mult_assoc. reflexivity. Qed.

Definition foo (x: nat) := 5.
Fact silly_fact_1: forall m, foo m + 1 = foo (m+1)+1.
Proof. intros m. simpl. reflexivity. Qed.
Definition bar x :=
  match  x with
  | O => 5
  | S _ => 5
  end.
Fact silly_fact_2_FAILED: forall m, bar m + 1 = bar (m + 1) + 1.
Proof. intros m. simpl. Abort.
Fact silly_fact_2: forall m, bar m + 1 = bar (m + 1) + 1.
Proof. destruct m; reflexivity. Qed.
Fact silly_fact_2': forall m, bar m + 1 = bar (m + 1) + 1.
Proof.
  intros m. unfold bar. destruct m; reflexivity. Qed.

Definition sillyfun (n: nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
       else false.

Theorem silly_fun_false: forall(n:nat), sillyfun n = false.
Proof. intros n. unfold sillyfun. destruct (beq_nat n 3).
       - reflexivity.
       - destruct (beq_nat n 5); reflexivity.
Qed.
(** *Exercise combine_split *)
Fixpoint split {X Y: Type} (l: list (X*Y)): (list X)*(list Y) :=
  match l with
  | [] => ([],[])
  | (x,y) :: t =>
    match split t with
    | (lx, ly) => (x::lx, y::ly)
    end
  end.
Theorem combine_split: forall X Y (l: list (X*Y)) l1 l2,
    split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  intros X Y l. induction l as [| h t I]; intros l1 l2 H.
  - simpl in H. inversion H. reflexivity.
  - simpl in H. destruct h as [x y].
    destruct (split t) as [lx ly]. inversion H. simpl.
    apply f_equal. apply I. reflexivity.
Qed.
Definition sillyfun1 (n:nat):bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
       else false.
Theorem sillyfun1_odd_FAILED: forall n:nat,
    sillyfun1 n = true -> oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3). Abort.
Theorem sillyfun1_odd: forall n:nat, sillyfun1 n = true -> oddb n = true.
Proof.
  intros n eq. unfold sillyfun1 in eq.
  destruct (beq_nat n 3) eqn:Heqe3.
  - apply beq_nat_true in Heqe3. rewrite -> Heqe3. reflexivity.
  - destruct (beq_nat n 5) eqn:Heqe5.
    + apply beq_nat_true in Heqe5. rewrite Heqe5. reflexivity.
    + inversion eq. Qed.
(** *Exercise destruct_eqn_practice *)
Theorem bool_fn_applied_thrice:
  forall (f: bool -> bool) (b: bool), f (f (f b)) = f b.
Proof.
  intros f b.
  destruct b eqn:eb; destruct (f true) eqn:eqf1;
    destruct (f false) eqn:eqf2; rewrite ?eqf1; rewrite ?eqf2;
      try reflexivity.
Qed.

(** *Exercise beq_nat_sym *)
Theorem beq_nat_sym: forall n m, beq_nat n m = beq_nat m n.
Proof.
  induction n as [|n I]; intros m.
  - simpl. destruct m; reflexivity.
  - simpl. destruct m.
    + reflexivity.
    + simpl. apply I.
Qed.

(** *Exercise beq_nat_sym_informal
Theorem: for any n m, beq_nat n m = beq_nat m n.
Use induction on n.
* First we need to prove for any m, beq_nat 0 m = beq_nat m 0.
  beq_nat 0 m is true if m is 0 and false if m = S m'. Considering both
  cases let's reduce beq_nat m 0. So, it follows.
* Prove for any m, beq_nat (S n') m = beq_nat m (S n'), if we know
  that for any m, beq_nat n' m = beq_nat m n'.
  Consider cases for m:
  * m = 0, then both parts evaluate to false.
  * m = S m', then beq_nat (S n') (S m') reduces to beq_nat n' m' and
    beq_nat (S m') (S n') reduces to beq_nat m' n', thus giving the assumption.
 *)

(** *Exercise beq_nat_trans *)
Theorem beq_nat_trans: forall n m p,
    beq_nat n m = true -> beq_nat m p = true -> beq_nat n p = true.
Proof.
  intros n m p H1 H2. apply beq_nat_true in H1. rewrite -> H1. apply H2. Qed.

(** *Exercise split_combine *)
Definition split_combine_statement: Prop :=
  forall (X Y: Type)(l1: list X)(l2: list Y),
    length l1 = length l2 -> split (combine l1 l2) = (l1,l2).
Theorem split_combine: split_combine_statement.
Proof.
  intros X Y. induction l1 as [|h1 t1 I]; intros l2 H.
  - destruct l2 as [|h2 t2].
    + reflexivity.
    + inversion H.
  - destruct l2 as [|h2 t2].
    + inversion H.
    + simpl in H. inversion H as [H']. apply I in H'. simpl.
      rewrite H'. reflexivity.
Qed.

(** *Exercise filter_exercise *)
Theorem filter_exercise: forall (X:Type)(test:X->bool)(x:X)(l lf:list X),
    filter test l = x :: lf -> test x = true.
Proof.
  intros X test x l. induction l as [|h t I]; intros lf H.
  - inversion H.
  - simpl in H. destruct (test h) eqn:e.
    + inversion H as [H']. rewrite H' in e. apply e.
    + apply I in H. exact H.
Qed.

(** *Exercise forall_exists_challenge *)
Fixpoint forallb {X: Type}(p: X -> bool)(l: list X): bool :=
  match l with
  | [] => true
  | h::t => p h && forallb p t
  end.
Fixpoint existb {X: Type}(p: X -> bool)(l: list X): bool :=
  match l with
  | [] => false
  | h::t => p h || existb p t
  end.

Example forallb_test1: forallb oddb [1;3;5;7;9] = true.
Proof. reflexivity. Qed.
Example forallb_test2: forallb negb [false;false] = true.
Proof. reflexivity. Qed.
Example forallb_test3: forallb evenb [0;2;4;5] = false.
Proof. reflexivity. Qed.
Example forallb_test4: forallb (beq_nat 5) [] = true.
Proof. reflexivity. Qed.

Example existb_test1: existb (beq_nat 5) [0;2;3;6] = false.
Proof. reflexivity. Qed.
Example existb_test2: existb (andb true) [true;true;false] = true.
Proof. reflexivity. Qed.
Example existb_test3: existb oddb [1;0;0;0;0;3] = true.
Proof. reflexivity. Qed.
Example existb_test4: existb evenb [] = false.
Proof. reflexivity. Qed.

Definition existb' {X:Type}(p: X -> bool)(l: list X) :=
  negb (forallb (fun x => negb (p x)) l).

Theorem existb_existb': forall (X: Type)(p: X -> bool)(l: list X),
    existb p l = existb' p l.
Proof.
  intros X p. induction l as [|h t I].
  - reflexivity.
  - unfold existb'. simpl. destruct (p h) eqn:eqn1; simpl.
    + reflexivity.
    + apply I.
Qed.


Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O =>
      match m with
      | O => true
      | S m' => 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.

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

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

Module NatList.

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

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

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | [] => 0
  | x :: xs =>
      match eqb v x with
      | true => S (count v xs)
      | false => count v xs
      end
  end.

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

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | [] => []
  | x :: xs =>
      match eqb x v with
      | true => xs
      | false => x :: remove_one v xs
      end
  end.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | [] => true
  | x :: xs => andb (member x s2) (subset xs (remove_one x s2))
  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.

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

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

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.

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

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. induction s as [|x xs].
  -(*[]*)
    simpl. reflexivity.
  -(*x :: xs*)
    simpl. destruct x as [|y].
    +(*0*)
      simpl.
      rewrite leb_n_Sn.
      reflexivity.
    +(*S y*)
      simpl.
      rewrite IHxs.
      reflexivity.
Qed.