Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Require Export List.

Require Import
  Program Omega Factorial
  Bool util Morphisms Relations RelationClasses Permutation.

Hint Resolve
  in_map Permutation_refl.

Hint Constructors NoDup.

Hint Constructors
  NoDup Permutation.

Arguments length {A}.
Arguments Permutation {A}.
Arguments map {A B}.
Arguments tail {A}.

Section count.

  Context {X: Type} (p: X -> bool).

  Fixpoint count (l: list X): nat :=
    match l with
    | nil => 0
    | h :: t => if p h then S (count t) else count t
    end.

  Lemma count_app l l': count (l ++ l') = count l + count l'.
  Proof with auto.
    induction l...
    simpl.
    destruct (p a)...
    intros.
    rewrite IHl...
  Qed.

  Lemma count_0 l: (forall x, In x l -> p x = false) -> count l = 0.
  Proof with auto. induction l... simpl. intros. rewrite H... Qed.

  Lemma count_le l: count l <= length l.
  Proof with auto with arith.
    induction l...
    simpl.
    destruct (p a)...
  Qed.

  Lemma count_filter_le (f: X -> bool) x: count (filter f x) <= count x.
  Proof with auto with arith.
    induction x...
    simpl.
    destruct (f a).
      simpl.
      destruct (p a)...
    destruct (p a)...
  Qed.

  Hint Resolve count_le.

  Lemma count_lt v l: In v l -> p v = false -> count l < length l.
  Proof with auto with arith.
    induction l; simpl; intros.
      elimtype False...
    inversion_clear H.
      subst.
      rewrite H0...
    destruct (p a)...
  Qed.

End count.

Hint Resolve @count_le.

Lemma NoDup_map_inv' A B (f: A -> B) (l: list A): NoDup (map f l) -> NoDup l.
Proof with auto.
  induction l...
  simpl.
  intros.
  inversion_clear H.
  apply NoDup_cons...
Qed.

Lemma length_filter X (p: X -> bool) (l: list X): length (filter p l) = count p l.
Proof with auto. intros. induction l... simpl. destruct (p a)... simpl... Qed.

Lemma length_filter_le T (p: T -> bool) (l: list T): length (filter p l) <= length l.
Proof. intros. rewrite length_filter. apply count_le. Qed.

Lemma filter_all X (p: X -> bool) (l: list X):
  (forall x, In x l -> p x = true) -> filter p l = l.
Proof with auto.
  induction l...
  simpl.
  intros.
  rewrite H...
  rewrite IHl...
Qed.

Lemma In_filter T (p: T -> bool) (t: T): p t = true -> forall l, In t l -> In t (filter p l).
Proof. intros. destruct (filter_In p t l). apply H2; auto. Qed.

Lemma incl_filter X (p: X -> bool) (l: list X): incl (filter p l) l.
Proof with auto.
  unfold incl.
  induction l; simpl...
  intros.
  destruct (p a); firstorder.
Qed.

Lemma incl_trans A (x y: list A): incl x y -> forall z, incl y z -> incl x z.
Proof. do 5 intro. apply H0. apply H. assumption. Qed.

Hint Resolve incl_filter.

Lemma filter_preserves_incl X (p: X -> bool) (a b: list X): incl a b -> incl (filter p a) (filter p b).
Proof with auto.
  unfold incl.
  intros.
  destruct (filter_In p a0 a).
  clear H2.
  destruct (H1 H0).
  clear H1.
  apply In_filter...
Qed.

Hint Resolve filter_preserves_incl.

Lemma In_inv_perm X (x: X) (l: list X):
  In x l -> exists l', Permutation (x :: l') l.
Proof with eauto.
  induction l; intros; inversion_clear H. subst...
  destruct IHl...
Qed.

Lemma In_map_inv T U (f: T -> U) (l: list T) (y: U): In y (map f l) -> exists x, f x = y /\ In x l.
Proof. induction l; firstorder. Qed.

Arguments In_map_inv [T U f l y].

Instance In_Permutation A (x: A): Proper (Permutation ==> iff) (In x).
Proof.
  repeat intro.
  pose proof (Permutation_in).
  pose proof (Permutation_sym).
  firstorder.
Qed.

Instance Permutation_NoDup {X}: Proper (Permutation ==> iff) (@NoDup X).
Proof with firstorder auto.
  pose proof NoDup_cons.
  intros ? ? E.
  induction E; [firstorder | | | firstorder].
    split; intro A; inversion_clear A; apply NoDup_cons...
      rewrite <- E...
    rewrite E...
  split; intro A; inversion_clear A; inversion_clear H1...
Qed.

Hint Resolve incl_tran.

Lemma Permutation_incl X (a b: list X): Permutation a b -> incl a b.
Proof. induction 1; firstorder. Qed.

Instance count_perm A: Proper (pointwise_relation _ eq ==> Permutation ==> eq) (@count A).
Proof with auto.
  intros p p' E.
  assert (forall l, count p l = count p' l).
    induction l...
    simpl. rewrite E, IHl...
  intros l l' P.
  induction P; intros; simpl...
      rewrite IHP.
      rewrite E...
    repeat rewrite E. (*rewrite E at 3.*)
    destruct (p' y); destruct (p' x)...
  rewrite IHP1.
  rewrite <- H...
Qed.

Lemma pointwise_eq_refl A B (x: A -> B): pointwise_relation A eq x x.
Proof. reflexivity. Qed.
Hint Immediate pointwise_eq_refl.
  (* this really should be redundant *)

Instance count_perm_simple A (p: A -> bool): Proper (Permutation ==> eq) (count p).
Proof. intros. apply count_perm. auto. Qed.
  (* just an instantiation of count_perm, but rewriting with the latter can produce nasty existentials *)

Instance filter_eq_morphism T: Proper (pointwise_relation _ eq ==> eq ==> eq) (@filter T).
Proof with auto.
  repeat intro.
  subst.
  induction y0...
  simpl.
  rewrite H.
  rewrite IHy0...
Qed.

Instance filter_perm X: Proper (pointwise_relation _ eq ==> Permutation ==> Permutation) (@filter X).
Proof with auto.
  repeat intro.
  induction H0; rewrite H in *; simpl...
      destruct (y x0)...
    destruct (y y0); destruct (y x0)...
  eauto.
Qed.

Lemma complementary_filter_perm A (p: A -> bool) (l: list A):
  Permutation l (filter p l ++ filter (negb ∘ p) l).
Proof with auto.
  induction l...
  simpl.
  unfold compose.
  destruct (p a); simpl...
  apply Permutation_cons_app...
Qed.

Lemma filter_none X (p: X -> bool) (l: list X): (forall x, In x l -> p x = false) <-> filter p l = nil.
Proof with auto.
  induction l.
    split...
    intros.
    inversion H0.
  destruct IHl.
  split; simpl; intros.
    rewrite H1...
  destruct H2.
    subst.
    destruct (p x)...
    discriminate.
  apply H0...
  destruct (p a)...
  discriminate.
Qed.

Lemma incl_map X Y (f: X -> Y) (a b: list X): incl a b -> incl (map f a) (map f b).
Proof with auto.
  do 3 intro.
  destruct (In_map_inv H0).
  destruct H1.
  subst...
Qed.

Lemma incl_in T (a b: list T): incl a b -> forall x, In x a -> In x b.
Proof. auto. Qed.

Lemma incl_In X (x: X) (l: list X): In x l -> forall l', incl l l' -> In x l'.
Proof. intros. apply H0. assumption. Qed. (* todo: move *)

Lemma NoDup_filter T (p: T -> bool) (l: list T):
  NoDup l -> NoDup (filter p l).
Proof with auto.
  induction l...
  simpl.
  intros.
  inversion_clear H.
  destruct (p a)...
  apply NoDup_cons...
  intro.
  apply H0...
  apply (incl_filter p l)...
Qed.

Lemma length_excl_counts X (p: X -> bool) (l: list X):
  length l = count p l + count (negb ∘ p) l.
Proof with auto.
  unfold compose.
  induction l...
  intros.
  simpl.
  rewrite IHl.
  destruct (p a); simpl...
Qed.

Lemma count_filtered X (p q: X -> bool):
  (forall x, q x = true -> p x = false) ->
  forall l, count p (filter q l) = 0.
Proof with auto.
  induction l...
  simpl.
  cset (H a).
  destruct (q a)...
  simpl.
  rewrite H0...
Qed.

Lemma app_nil_r T (l: list T): l ++ nil = l.
Proof with auto. induction l... simpl. rewrite IHl... Qed.

Hint Resolve Permutation_map.

Lemma map_cons T U (f: T -> U) (h: T) (l: list T): map f (h :: l) = f h :: map f l.
Proof. auto. Qed.

(* concat *)

Definition concat {T}: list (list T) -> list T := fold_right (@app _) nil.

Lemma concat_app T (x y: list (list T)): concat (x ++ y) = concat x ++ concat y.
Proof with auto.
  induction x...
  simpl.
  intros.
  rewrite IHx.
  rewrite app_ass...
Qed.

Lemma In_concat X (l: list (list X)) (s: list X) (x: X): In x s -> In s l -> In x (concat l).
Proof with auto.
  induction l...
  intros.
  simpl.
  apply in_or_app.
  inversion_clear H0.
    subst...
  right...
Qed.

Lemma In_concat_inv X (x: X) (l: list (list X)):
  In x (concat l) -> exists s, In x s /\ In s l.
Proof with auto.
  induction l.
    intros.
    elimtype False...
  simpl.
  intros.
  destruct (in_app_or _ _ _ H).
    exists a.
    split...
  destruct (IHl H0).
  destruct H1.
  exists x0...
Qed.

Definition eq_count X (d: forall (x y: X), { x = y } + { x <> y }) (x: X): list X -> nat :=
 count (fun y => unsum_bool (d x y)).

Lemma eq_count_0 X (d: forall (x y: X), { x = y } + { x <> y }) (x: X) l:
  ~ In x l -> eq_count d x l = 0%nat.
Proof with auto.
  induction l...
  simpl.
  intros.
  destruct (d x a).
    elimtype False.
    apply H.
    left...
  simpl.
  apply IHl.
  intro.
  apply H.
  right...
Qed.

Lemma eq_count_NoDup X (d: forall (x y: X), { x = y } + { x <> y }) (x: X) l:
  NoDup l -> eq_count d x l <= 1.
Proof with auto.
  induction l...
  simpl.
  intros.
  inversion_clear H...
  destruct (d x a); simpl...
  subst.
  rewrite eq_count_0...
Qed.

Lemma NoDup_incl_Permutation A (a b: list A):
  length a = length b -> NoDup a -> incl a b -> Permutation a b.
Proof with auto. (* todo: prove in terms of the vec equivalent *)
  induction a in b |- *; intros.
    destruct b.
      apply perm_nil.
    discriminate.
  assert (In a b).
    apply H1.
    left...
  destruct (In_inv_perm a b H2).
  apply perm_trans with (a :: x)...
  apply perm_skip.
  apply IHa.
      cset (Permutation_length H3).
      rewrite <- H in H4.
      inversion_clear H4...
    inversion_clear H0...
  cut (incl a0 (a :: x)).
    intros.
    intro.
    intros.
    cset (H4 a1 H5).
    inversion_clear H6...
    subst.
    inversion_clear H0.
    elimtype False...
  apply incl_tran with b...
    intro.
    intros.
    apply H1.
    right...
  apply Permutation_incl.
  apply Permutation_sym...
Qed.

Lemma NoDup_map' A B (f: A -> B) (l: list A):
  (forall x y: A, In x l -> In y l -> x <> y -> f x <> f y) ->
  NoDup l -> NoDup (map f l).
Proof with auto.
  induction l; simpl...
  intros.
  inversion_clear H0.
  apply NoDup_cons...
  intro.
  destruct (In_map_inv H0).
  destruct H3.
  apply (H x a)...
  intro.
  subst...
Qed. (* todo: replace NoDup_map *)

Lemma NoDup_map A B (f: A -> B) l:
  (forall x y, In x l -> In y l -> f x = f y -> x = y) -> NoDup l -> NoDup (map f l).
Proof with simpl; auto.
  induction l...
  intros.
  simpl.
  inversion_clear H0.
  apply NoDup_cons...
  intro.
  apply H1.
  destruct (In_map_inv H0).
  destruct H3.
  rewrite (H a x)...
Qed.

Inductive InP (X: Type) (P: X -> Prop): list X -> Prop :=
  | InP_head x t: P x -> InP P (x :: t)
  | InP_tail x t: InP P t -> InP P (x :: t).

Inductive NoDupL (A: Type): list (list A) -> Prop :=
  | NoDupL_nil: NoDupL nil
  | NoDupL_cons (l: list A) (ll: list (list A)): NoDup l ->
      (forall x, In x l -> ~ InP (In x) ll) -> NoDupL ll -> NoDupL (l :: ll).

Hint Constructors NoDupL.

Lemma InP_In (X: Type) (l: list X) (ll: list (list X)): In l ll -> forall x, In x l -> InP (In x) ll.
Proof with auto.
  induction ll.
    intros.
    inversion H.
  intros.
  inversion_clear H; [left | right]...
  subst...
Qed.

Lemma InP_In_inv X (x: X) (ll: list (list X)):
  InP (In x) ll -> exists l, In x l /\ In l ll.
Proof with auto.
  intros H.
  induction H.
    exists x0.
    split...
    left...
  destruct IHInP.
  destruct H0.
  exists x1.
  split...
  right...
Qed.

Arguments InP_In_inv [X x ll].

Lemma NoDup_concat A (l: list (list A)): NoDupL l -> NoDup (concat l).
Proof with auto.
  induction l; simpl; intros.
    apply NoDup_nil.
  inversion_clear H.
  induction a...
  inversion_clear H0.
  simpl.
  apply NoDup_cons...
    intro.
    destruct (in_app_or _ _ _ H0)...
    apply (H1 a).
      left...
    destruct (In_concat_inv _ _ H4).
    destruct H5.
    apply InP_In with x...
  apply IHa...
  intros.
  apply H1.
  right...
Qed.

Lemma In_filter_inv A (f: A -> bool) (x: A) (l: list A): In x (filter f l) -> In x l /\ f x = true.
Proof. intros. destruct (filter_In f x l). apply H0. assumption. Qed.

(* Partitioning *)

Section Partitioning.

  Variable T: Set.

  Definition Partitioning: Set := comparison -> list T.

  Lemma partition_oblig c l h
    (H: {p: Partitioning | Permutation (p Eq ++ p Lt ++ p Gt) l}):
    Permutation
      ((if cmp_cmp c Eq then h :: proj1_sig H Eq else proj1_sig H Eq) ++
      (if cmp_cmp c Lt then h :: proj1_sig H Lt else proj1_sig H Lt) ++
      (if cmp_cmp c Gt then h :: proj1_sig H Gt else proj1_sig H Gt))
      (h :: l).
  Proof with auto.
    intros.
    destruct H. simpl.
    apply Permutation_sym.
    cset (Permutation_sym p).
    destruct c; simpl.
        apply perm_skip...
      apply Permutation_cons_app...
    rewrite <- app_ass in *.
    apply Permutation_cons_app...
  Qed.

  Definition addToPartitioning (c: comparison) (l: list T) (h: T) (H: {p: Partitioning | Permutation (p Eq ++ p Lt ++ p Gt) l}): {p: Partitioning | Permutation (p Eq ++ p Lt ++ p Gt) (h :: l)} :=
    exist (fun p => Permutation (p Eq ++ p Lt ++ p Gt) (h :: l))
      (fun c' => if cmp_cmp c c' then h :: proj1_sig H c' else proj1_sig H c')
      (partition_oblig c h H).

  Definition emp: {p: Partitioning | Permutation (p Eq ++ p Lt ++ p Gt) nil} :=
    exist (fun p => Permutation (p Eq ++ p Lt ++ p Gt) nil) (fun _ => nil) (perm_nil T).

End Partitioning.

Fixpoint repeat T (n: nat) (x: T): list T :=
  match n with
  | 0 => nil
  | S n' => x :: repeat n' x
  end.

Lemma map_concat T U (l: list (list T)) (f: T -> U): map f (concat l) = concat (map (map f) l).
Proof with auto.
  induction l...
  intros.
  simpl.
  rewrite map_app.
  congruence.
Qed.

Lemma length_0_nil A (l: list A): length l = 0%nat <-> l = nil.
Proof with auto.
  intuition.
    destruct l...
    discriminate.
  subst...
Qed.

Lemma length_ne_0_ne_nil A (l: list A): length l <> 0%nat -> l <> nil.
Proof. destruct l. auto. intros. discriminate. Qed.

Inductive elemsR A B (R: A -> B -> Prop): list A -> list B -> Prop :=
  | eR_nil: elemsR R nil nil
  | eR_cons (a: A) (b: B): R a b -> forall l l', elemsR R l l' -> elemsR R (a :: l) (b :: l').

Hint Constructors elemsR.

Instance elemsR_trans A `{R: relation A} {TR: Transitive R}: Transitive (elemsR R).
Proof with auto.
  intro.
  induction x.
    intros.
    destruct y...
    inversion H.
  intros.
  destruct y.
    inversion H.
  destruct z.
    inversion H0.
  inversion_clear H.
  inversion_clear H0.
  apply eR_cons...
    transitivity a0...
  apply IHx with y...
Qed.

Lemma elemsR_le_S a b: elemsR le a b -> elemsR le (map S a) (map S b).
Proof. intros. induction H; simpl; auto with arith. Qed.

Lemma elemsR_map A (R: relation A) f l:
  (forall x, In x l -> R (f x) x) -> elemsR R (map f l) l.
Proof. induction l; simpl; intuition. Qed.

Lemma elemsR_map_map (X Y: Type) (f g: Y -> X) (l: list Y) (R: relation X): (forall x, In x l -> R (f x) (g x)) -> elemsR R (map f l) (map g l).
Proof with auto.
  induction l. simpl...
  intros.
  apply eR_cons; intuition.
Qed.

Lemma elemsR_impl A (R R' : relation A): (forall x y: A, R x y -> R' x y) -> forall l l', elemsR R l l' -> elemsR R' l l'.
Proof. induction l; intros; inversion_clear H0; auto. Qed.

Section Permuted.

  Context {A: Type} (R: relation A).

  Inductive Permuted: relation (list A) :=
    | permuted_nil : Permuted nil nil
    | permuted_skip : forall (x x': A), R x x' -> forall (l l' : list A), Permuted l l' -> Permuted (x :: l) (x' :: l')
    | permuted_swap : forall (x y: A) (l: list A), Permuted (y :: x :: l) (x :: y :: l)
    | permuted_trans : forall l l' l'' : list A, Permuted l l' -> Permuted l' l'' -> Permuted l l''.

  Hint Constructors Permuted.

  Context {Rrefl: Reflexive R}.

  Lemma permuted_refl l: Permuted l l.
  Proof. induction l; auto. Qed.

  Hint Immediate permuted_refl.

  Lemma elemsR_permuted l l': elemsR R l l' -> Permuted l l'.
  Proof. induction l in l' |- *; intros; inversion_clear H; auto. Qed.

  (* the following looks like a more powerful type for the swap ctor, but it isn't, because we can implement it with the others: *)

  Lemma alt_permuted_swap (x x' y y': A): R x x' -> R y y' ->
    forall (l l': list A), elemsR R l l' -> Permuted (y :: x :: l) (x' :: y' :: l').
  Proof with auto.
    intros.
    apply permuted_trans with (y' :: x' :: l)...
    apply permuted_trans with (y' :: x' :: l')...
    apply permuted_skip...
    apply permuted_skip...
    apply elemsR_permuted...
  Qed.

End Permuted.

Hint Constructors Permuted.

Lemma map_map_comp A B C (f: A -> B) (g: B -> C) (l: list A):
  map g (map f l) = map (g ∘ f) l.
Proof.
  intros.
  rewrite map_map.
  reflexivity.
Qed.

Lemma concat_map_singleton A (l: list A): concat (map (fun x => x :: nil) l) = l.
Proof.
  induction l. intuition.
  simpl. congruence.
Qed.

Lemma Permuted_sub A (R: relation A) x y: Permuted R x y -> forall (R': relation A), (forall x y, R x y -> R' x y) -> Permuted R' x y.
Proof with auto.
  intros.
  induction H...
  apply permuted_trans with l'...
Qed.

(*
Lemma Permuted_map_old (A B: Type) (R: relation B) (f: A -> B) x y:
  Permuted (on f R) x y -> Permuted R (map f x) (map f y).
Proof with auto.
  intros.
  induction H.
        simpl...
      apply permuted_skip...
    simpl.
    apply permuted_swap...
  apply permuted_trans with (map f l')...
Qed.
*)

Lemma Permuted_map A B (R: relation B) (f: A -> B): Proper (Permuted (on f R) ==> Permuted R) (map f).
Proof. repeat intro. induction H; simpl; eauto. Qed.

Definition add := fold_right plus (0%nat).

Lemma add_same c l: (forall x, In x l -> x = c) -> add l = length l * c.
Proof with auto.
  induction l...
  intros.
  simpl.
  intuition.
Qed.

Lemma length_concat T (l: list (list T)):
  length (concat l) = add (map (@length _) l).
Proof with auto.
  induction l...
  simpl.
  rewrite app_length, IHl...
Qed.

Lemma concat_map_nil T U (l: list T): concat (map (fun _ => nil) l) = @nil U.
Proof. induction l; auto. Qed.

Definition product A B (aa: list A) (bb: list B): list (A * B) :=
  concat (map (fun a => map (pair a) bb) aa).

Instance Permutation_concat T: Proper (Permutation ==> Permutation) (@concat T).
Proof with auto.
  repeat intro.
  induction H...
      simpl.
      apply Permutation_app...
    simpl.
    repeat rewrite <- app_ass.
    apply Permutation_app...
    apply Permutation_app_swap.
  eauto.
Qed.

Lemma concat_map_singleton_f T A (f: A -> T) l: concat (map (fun x : A => (f x)::nil) l) = map f l.
Proof with auto.
  induction l...
  simpl.
  congruence.
Qed.

Lemma map_concat_map T U V (g: T -> list U) (f: U -> V) l:
  map f (concat (map g l)) = concat (map (map f ∘ g) l).
Proof with auto.
  unfold Basics.compose.
  induction l...
  simpl.
  rewrite map_app.
  congruence.
Qed.

Lemma concat_concat T (x: list (list (list T))):
  concat (concat x) = concat (map concat x).
Proof with auto.
  induction x...
  simpl.
  rewrite concat_app.
  congruence.
Qed.

Section two_lists_rect.

  Variables (T: Type) (P: list T -> list T -> Type)
    (Pnil_l: forall x, P nil x) (Pnil_r: forall x, P x nil)
    (Pcons: forall x x' y y', P x' (y :: y') -> P (x :: x') y' -> P (x :: x') (y :: y')).

  Let R: relation (list T * list T) := pair_rel (ltof (list T) (@length _)) (ltof (list T) (@length _)).

  Let wf_R: well_founded R.
  Proof. apply well_founded_pairs; apply well_founded_ltof. Qed.

  Lemma two_lists_rect_pre (p: list T * list T): P (fst p) (snd p).
  Proof with auto.
    apply (well_founded_induction_type wf_R (fun p => P (fst p) (snd p))).
    unfold R, ltof.
    destruct x as [[|A] [|B]]...
    intros.
    simpl.
    apply Pcons.
      apply (X (l, B :: l0)).
      apply pair_rel_l...
    apply (X (A :: l, l0)).
    apply pair_rel_r...
  Defined.

  Definition two_lists_rect x y: P x y := two_lists_rect_pre (x, y).

End two_lists_rect.

Instance Reflexive_Permutation T: Reflexive Permutation := @Permutation_refl T.
Instance Reflexive_Symmetric T: Symmetric Permutation := @Permutation_sym T.
Instance Reflexive_Transitive T: Transitive Permutation := @perm_trans T.

Instance app_Permutation_mor T: Proper (Permutation ==> Permutation ==> Permutation) (@app T).
Proof. repeat intro. apply Permutation_app; assumption. Qed.

Instance map_Permutation_mor T U (f: T -> U): Proper (Permutation ==> Permutation) (map f) :=
  Permutation_map f.

(*
Lemma concatMap_concatMap T U V (g: T -> list U) (f: U -> list V) l:
  concat (map f (concat (map g l))) = concat (concat (map (map f ∘ g) l)).
Proof with auto.
  intros.
  rewrite map_concat_map...

  intros.
  rewrite <- map_map_comp.
  rewrite <- map_concat...
Qed.
*)

Lemma concatMap_concatMap' T U V (g: T -> list U) (f: U -> list V) l:
  concat (map f (concat (map g l))) = concat (map (concat ∘ map f ∘ g) l).
Proof with auto.
  induction l...
  simpl.
  rewrite <- IHl.
  unfold Basics.compose.
  rewrite map_app.
  rewrite concat_app...
Qed.

Lemma Permutation_concatMap T U (f g: T -> list U) l:
  (forall x, In x l -> Permutation (f x) (g x)) ->
  Permutation (concat (map f l)) (concat (map g l)).
Proof with auto.
  induction l...
  simpl.
  intros.
  rewrite IHl...
  rewrite H...
Qed.

Hint Resolve Permutation_concat.

Lemma Permutation_concat_map_app T A (f g: A -> list T) l:
  Permutation (concat (map (fun x => f x ++ g x) l)) (concat (map f l ++ map g l)).
Proof with auto.
  induction l...
  simpl.
  rewrite IHl.
  repeat rewrite concat_app.
  simpl.
  rewrite app_ass.
  apply Permutation_app...
  rewrite Permutation_app_swap.
  rewrite app_ass.
  apply Permutation_app...
  apply Permutation_app_swap.
Qed.

Lemma concat_product T U V (f: U -> T -> list V) l l':
  Permutation
    (concat (map (fun x => concat (map (fun y => f y x) l')) l))
    (concat (map (fun x => concat (map (f x) l)) l')).
Proof with auto.
  induction l...
    intros.
    simpl.
    rewrite concat_map_nil...
  intros.
  simpl.
  rewrite IHl.
  apply Permutation_sym.
  rewrite Permutation_concat_map_app.
  rewrite concat_app...
Qed.

Instance map_eq_morphism A B: Proper (pointwise_relation _ eq ==> eq ==> eq) (@map A B).
Proof with auto.
  repeat intro.
  subst.
  induction y0...
  simpl.
  congruence.
Qed.

Section splits_and_perms.

  Context {T: Type}.

  Fixpoint splits (l: list T): list (T * list T) :=
    match l with
    | nil => nil
    | h :: t => (h, t) :: map (fun xy => (fst xy, h :: snd xy)) (splits t)
    end.

  Lemma length_splits l: length (splits l) = length l.
  Proof with auto.
    induction l...
    simpl.
    rewrite map_length.
    intuition.
  Qed.

  Lemma splits_are_perms l p: In p (splits l) -> Permutation (fst p :: snd p) l.
  Proof with auto.
    induction l in p |- *...
      simpl.
      intuition.
    simpl.
    intros.
    destruct H.
      subst...
    destruct (fst (conj_prod (in_map_iff _ _ _)) H).
    destruct H0.
    apply IHl in H1.
    subst.
    simpl...
    apply perm_trans with (a :: fst x :: snd x).
      apply perm_swap.
    apply perm_skip...
  Qed.

  Lemma length_in_splits l p: In p (splits l) -> S (length (snd p)) = length l.
  Proof.
    intros.
    apply splits_are_perms in H.
    exact (Permutation_length H).
  Qed.

  Fixpoint insert_everywhere (x: T) (l: list T): list (list T) :=
    match l with
    | nil => (x :: nil) :: nil
    | h :: t => (x :: h :: t) :: map (cons h) (insert_everywhere x t)
    end.

  Lemma insert_everywhere_are_perms x l:
    forall y, In y (insert_everywhere x l) -> Permutation y (x :: l).
  Proof with auto.
    induction l...
      intros.
      simpl in H.
      intuition.
      subst...
    intros.
    simpl in H.
    destruct H.
      subst...
    apply in_map_iff in H. destruct H as [x0 [A B]].
    subst.
    apply IHl in B.
    eauto.
  Qed.

  Lemma length_insert_everywhere x l:
    length (insert_everywhere x l) = S (length l).
  Proof with auto.
    induction l...
    simpl.
    rewrite map_length.
    congruence.
  Qed.

  Definition perms: list T -> list (list T)
    := fold_right (fun h => concat ∘ map (insert_everywhere h)) (nil :: nil).

  Lemma perms_are_perms l a: In a (perms l) -> Permutation a l.
  Proof with auto.
    induction l in a |- *.
      simpl.
      intuition.
      subst...
    intros.
    simpl in H.
    unfold Basics.compose in H.
    apply In_concat_inv in H. destruct H. destruct H.
    apply in_map_iff in H0. destruct H0 as [x0 [A B]].
    subst.
    eauto using insert_everywhere_are_perms.
  Qed.

  Lemma length_perms l: length (perms l) = fact (length l).
  Proof with auto.
    induction l...
    simpl.
    unfold Basics.compose.
    rewrite length_concat.
    rewrite map_map.
    rewrite (@add_same (S (length l)) (map (fun x => length (insert_everywhere a x)) (perms l))).
      rewrite map_length.
      rewrite IHl.
      rewrite Mult.mult_comm...
    intros.
    destruct (in_map_iff (fun x => length (insert_everywhere a x)) (perms l) x).
    clear H1.
    apply H0 in H. clear H0.
    destruct H. destruct H.
    subst.
    rewrite length_insert_everywhere.
    f_equal.
    apply Permutation_length.
    apply perms_are_perms...
  Qed.

  Definition alt_perms l: list (list T) :=
    match l with
    | nil => nil :: nil
    | _ => concat (map (fun p => (map (cons (fst p)) (perms (snd p)))) (splits l))
    end.

  Lemma splits_permuted (l l': list T): Permutation l l' ->
    Permuted (fun x y => fst x = fst y /\ Permutation (snd x) (snd y)) (splits l) (splits l').
  Proof with auto.
    intro.
    set (fun x y: T * list T => fst x = fst y /\ Permutation (snd x) (snd y)).
    intros.
    induction H.
          simpl...
        simpl.
        apply permuted_skip...
          split...
        apply Permuted_map.
        unfold on.
        subst P.
        simpl.
        apply (Permuted_sub IHPermutation).
        intuition.
      simpl.
      subst P.
      apply alt_permuted_swap...
      repeat rewrite map_map.
      simpl.
      apply elemsR_map_map.
      simpl...
    eauto.
  Qed.

  Inductive merges_spec: list T -> list T -> list (list T) -> Prop :=
    | merges_left_nil x: merges_spec nil x (x :: nil)
    | merges_right_nil x: merges_spec x nil (x :: nil)
    | merges_cons x y h t r r':
      merges_spec y (h :: t) r ->
      merges_spec (x :: y) t r' ->
      merges_spec (x :: y) (h :: t) (map (cons x) r ++ map (cons h) r').

  Hint Constructors merges_spec.

  Lemma merges_uniq a b r:
    merges_spec a b r ->
    forall r', merges_spec a b r' -> r = r'.
  Proof with auto.
    intros H.
    induction H; intros.
        inversion_clear H...
      inversion_clear H...
    inversion_clear H1.
    apply IHmerges_spec1 in H2.
    apply IHmerges_spec2 in H3.
    congruence.
  Qed.

  Lemma length_merges (F: nat -> nat -> nat) a b r:
    (forall n, F 0 n = 1) ->
    (forall n, F n 0 = 1) ->
    (forall n n', F n (S n') + F (S n) n' = F (S n) (S n')) ->
    merges_spec a b r -> length r = F (length a) (length b).
  Proof with auto.
    intros.
    induction H2.
        simpl...
      simpl...
    rewrite app_length.
    repeat rewrite map_length.
    rewrite IHmerges_spec1. clear IHmerges_spec1.
    rewrite IHmerges_spec2. clear IHmerges_spec2.
    simpl @length...
  Qed.

  Definition me (ab: list T * list T): nat := length (fst ab) + length (snd ab).

  Program Fixpoint merges_ex (ab: list T * list T) {measure (me ab)}: sig (merges_spec (fst ab) (snd ab)) :=
    match ab with
    | (nil, x) => x :: nil
    | (x, nil) => x :: nil
    | (x :: y, h :: t) => map (cons x) (merges_ex (y, h :: t)) ++ map (cons h) (merges_ex (x :: y, t))
    end.

  Next Obligation. unfold me. simpl. omega. Qed.
  Next Obligation. repeat destruct_call merges_ex; auto. Qed.

  Definition merges (a b: list T): list (list T) := proj1_sig (merges_ex (a, b)).

  Lemma merges_real_eq a b: merges a b =
    match a, b with
    | nil, x => x :: nil
    | x, nil => x :: nil
    | x :: y, h :: t => map (cons x) (merges y (h :: t)) ++ map (cons h) (merges (x :: y) t)
    end.
  Proof with auto.
    intros.
    apply (@merges_uniq a b).
      unfold merges. destruct_call merges_ex...
    destruct a... destruct b...
    unfold merges. repeat destruct_call merges_ex...
  Qed.

  Lemma merges_nil_r a: merges a [] = [a].
  Proof with auto.
    intros.
    rewrite merges_real_eq.
    destruct a...
  Qed.

  Hint Resolve Permutation_concat.

  Lemma product_app: forall T (a b c: list T), product (a ++ b) c = product a c ++ product b c.
  Proof with auto.
    intros.
    unfold product.
    rewrite map_app.
    rewrite concat_app...
  Qed.

  Lemma product_concat: forall T (a: list (list T)) (b: list T), product (concat a) b = concat (map (flip (@product _ _) b) a).
  Proof with auto.
    induction a...
    simpl.
    unfold flip at 1.
    intros.
    rewrite <- IHa.
    apply product_app.
  Qed. (* todo: this shouldn't need induction anymore *)

  Lemma concatMap_insert_everywhere_comm x y l: Permutation
    (concat (map (insert_everywhere x) (insert_everywhere y l)))
    (concat (map (insert_everywhere y) (insert_everywhere x l))).
  Proof with auto.
    induction l...
      simpl...
    simpl.
    rewrite perm_swap.
    apply perm_skip.
    apply perm_skip.
    rewrite (map_map (cons a) (insert_everywhere x)).
    rewrite (map_map (cons a) (insert_everywhere y)).
    simpl.
    rewrite (Permutation_concat_map_app (fun x0 => (x :: a :: x0) :: nil) (fun x0 => map (cons a) (insert_everywhere x x0)) (insert_everywhere y l)).
    apply Permutation_sym.
    rewrite (Permutation_concat_map_app (fun x0 => (y :: a :: x0) :: nil) (fun x => map (cons a) (insert_everywhere y x)) (insert_everywhere x l)).
    repeat rewrite concat_app.
    repeat rewrite concat_map_singleton_f.
    rewrite <- (map_map (insert_everywhere x) (map (cons a))).
    rewrite <- (map_map (insert_everywhere y) (map (cons a))).
    repeat rewrite <- map_concat.
    repeat rewrite map_map.
    repeat rewrite <- app_ass.
    symmetry in IHl...
    apply Permutation_app...
    apply Permutation_app_swap.
  Qed.

  Instance Permutation_perms: Proper (Permutation ==> Permutation) perms.
  Proof with eauto 2.
    intros l l' P.
    induction P...
      simpl.
      apply Permutation_concat...
    simpl.
    unfold Basics.compose.
    set (perms l). clearbody l0. clear l. rename l0 into l.
    repeat rewrite concatMap_concatMap'.
    apply Permutation_concatMap.
    intros.
    unfold Basics.compose.
    apply concatMap_insert_everywhere_comm.
  Qed.

  Lemma merges_insert_everywhere a l: insert_everywhere a l = merges (a :: nil) l.
  Proof with auto.
    induction l...
    simpl.
    rewrite IHl.
    rewrite (merges_real_eq [a] (a0::l)).
    rewrite (merges_real_eq [] (a0::l)).
    simpl...
  Qed.

  Lemma merges_insert_everywhere' a l: Permutation (insert_everywhere a l) (merges l (a :: nil)).
  Proof with auto.
    induction l...
    simpl.
    transitivity ((a :: a0 :: l) :: map (cons a0) (merges l [a]))...
    rewrite (merges_real_eq (a0::l) [a]).
    rewrite (merges_real_eq (a0::l) []).
    simpl.
    transitivity ([a :: a0 :: l] ++ map (cons a0) (merges l [a]))...
    apply Permutation_app_swap.
  Qed.

  Lemma insert_everywhere_merges_commute a x y: Permutation
    (concat (map (insert_everywhere a) (merges y x)))
    (concat (map (merges y) (insert_everywhere a x))).
      (* written with list monad notation, this would be:
        Permutation
          (insert_everywhere a >>= merges y x)
          (merges y >>= insert_everywhere a x). *)
  Proof with auto.
    revert x y.
    apply two_lists_rect; intros.
        simpl.
        rewrite merges_nil_r.
        simpl.
        repeat rewrite app_nil_r.
        apply merges_insert_everywhere'.
      simpl.
      rewrite app_nil_r.
      rewrite (map_ext (merges []) (fun x0 => [x0])).
        rewrite concat_map_singleton...
      intros.
      apply merges_real_eq.
    rewrite (merges_real_eq (y :: y') (x :: x')).
    rewrite map_app.
    rewrite concat_app.
    repeat rewrite map_map.
    simpl insert_everywhere.
    rewrite (Permutation_concat_map_app (fun x0 => [a :: y :: x0]) (fun x0 => map (cons y) (insert_everywhere a x0))).
    rewrite (Permutation_concat_map_app (fun x0 => [a :: x :: x0]) (fun x0 => map (cons x) (insert_everywhere a x0))).
    repeat rewrite concat_app.
    repeat rewrite concat_map_singleton_f.
    rewrite app_ass.
    rewrite <- (map_map (insert_everywhere a) (map (cons x))).
    rewrite <- (map_map (insert_everywhere a) (map (cons y))).
    rewrite <- map_concat.
    rewrite <- map_concat.
    rewrite H. rewrite H0.
    clear H H0.
    simpl @map at 7.
    simpl @concat at 3.
    rewrite map_map.
    rewrite (merges_real_eq (y :: y') (a :: x :: x')).
    rewrite (merges_real_eq (y :: y') (x :: x')).
    rewrite map_app.
    repeat rewrite map_map.
    rewrite app_ass.
    apply Permutation_sym.
    rewrite (Permutation_app_swap (map (cons y) (merges y' (a :: x :: x')))).
    repeat rewrite app_ass.
    apply Permutation_app...
    apply Permutation_sym.
    rewrite (Permutation_app_swap (map (cons y) (concat (map (merges y') (insert_everywhere a (x :: x')))))).
    repeat rewrite app_ass.
    apply Permutation_app...
    simpl.
    rewrite map_map.
    rewrite map_app.
    rewrite (map_ext (fun x0 : list T => merges (y :: y') (x :: x0)) (fun x0 : list T => map (cons y) (merges y' (x :: x0)) ++ map (cons x) (merges (y :: y') x0))).
      Focus 2.
      intros.
      rewrite merges_real_eq...
    apply Permutation_sym.
    rewrite Permutation_concat_map_app.
    rewrite concat_app.
    rewrite app_ass.
    rewrite <- (map_map (fun x0 => merges y' (x :: x0)) (map (cons y))).
    rewrite <- map_concat.
    rewrite Permutation_app_swap.
    rewrite <- app_ass.
    apply Permutation_app...
    rewrite <- (map_map (fun x0 => merges (y :: y') x0) (map (cons x))).
    rewrite <- map_concat.
    apply Permutation_app...
  Qed. (* wow, can hardly believe it's true after this ordeal *)

  Lemma merges_sym x y: Permutation (merges x y) (merges y x).
  Proof with auto.
    intros.
    unfold merges at 1.
    destruct_call merges_ex.
    simpl in *.
    induction m...
      rewrite merges_nil_r...
    rewrite IHm1.
    rewrite IHm2.
    rewrite (merges_real_eq (h :: t) (x :: y)).
    apply Permutation_app_swap.
  Qed.

  Hint Immediate merges_sym.

  Lemma perms_app (a b: list T): Permutation (perms (a ++ b)) (concat (map (uncurry merges) (product (perms a) (perms b)))).
  Proof with auto.
    unfold product.
    intros.
    rewrite map_concat.
    rewrite map_map.
    induction a.
      simpl.
      rewrite app_nil_r.
      rewrite map_map.
      unfold uncurry.
      simpl.
      rewrite (map_ext (fun x => merges [] x) (fun x => x :: nil))...
      rewrite concat_map_singleton...
    simpl.
    unfold Basics.compose.
    rewrite IHa. clear IHa.
    rewrite (map_ext (fun x : list T => map (uncurry merges) (map (pair x) (perms b)))
      (fun x : list T => map (merges x) (perms b))).
      rewrite (map_ext (fun x : list T => map (uncurry merges) (map (pair x) (perms b)))
        (fun x : list T => map (merges x) (perms b))).
        rewrite concat_concat.
        rewrite concat_concat.
        rewrite map_map.
        rewrite map_map.
        rewrite map_concat_map.
        rewrite concat_concat.
        rewrite map_map.
        rewrite map_concat_map.
        rewrite concat_concat.
        rewrite map_map.
        apply Permutation_concatMap.
        intros.
        unfold Basics.compose.
        rewrite map_concat_map.
        rewrite concat_concat.
        rewrite map_map.
        rewrite (map_ext (fun x0 => concat ((map (insert_everywhere a) ∘ merges x) x0))
          (concat ∘ (map (insert_everywhere a) ∘ merges x)))...
        transitivity (concat (map (concat ∘ map (merges x) ∘ insert_everywhere a) (perms b))).
          apply Permutation_concatMap.
          intros.
          unfold Basics.compose.
          apply insert_everywhere_merges_commute.
        apply Permutation_sym.
        rewrite <- (concat_product merges (perms b) (insert_everywhere a x)).
        apply Permutation_concatMap.
        intros.
        unfold Basics.compose.
        apply Permutation_sym.
        rewrite <- insert_everywhere_merges_commute.
        transitivity (concat (map (merges x0) (insert_everywhere a x))).
          apply Permutation_sym.
          rewrite <- insert_everywhere_merges_commute...
          rewrite merges_sym...
        apply Permutation_concatMap.
        intros...
      intros.
      rewrite map_map...
    intros.
    rewrite map_map...
  Qed.

  Lemma filter_merges p (x y: list T):
     (forall z, In z x -> p z = true) ->
     (forall z, In z y -> p z = false) ->
     forall r, In r (map (filter p) (merges x y)) -> r = x.
  Proof with auto.
    pattern x, y.
    apply two_lists_rect.
        intros.
        rewrite merges_real_eq in H1.
        simpl in H1.
        intuition.
        subst.
        apply (filter_none p x0)...
      intros.
      rewrite merges_nil_r in H1.
      simpl in H1.
      intuition.
      subst.
      apply filter_all...
    intros.
    rewrite merges_real_eq in H3.
    rewrite map_app in H3.
    repeat rewrite map_map in H3.
    apply in_app_or in H3.
    simpl in H3.
    destruct H3.
      rewrite H1 in H3.
        Focus 2. left...
      rewrite <- (map_map (filter p) (cons x0)) in H3.
      apply in_map_iff in H3.
      destruct H3.
      destruct H3.
      subst.
      f_equal.
      apply H...
      intuition.
    rewrite H2 in H3.
      Focus 2. left...
    apply H0...
    intuition.
  Qed.

  (* While a closed formula for merges length is tricky, we can easily prove that the length depends only on the
  length of the arguments. *)

  Instance length_merges_mor: Proper (on length eq ==> on length eq ==> on length eq) merges.
  Proof with auto.
    unfold on.
    do 4 intro.
    generalize y H. clear y H.
    unfold merges at 1.
    destruct merges_ex.
    simpl in *.
    induction m; intros.
        destruct y...
        discriminate.
      destruct y0.
        rewrite merges_nil_r...
      discriminate.
    destruct y0. discriminate.
    destruct y1. discriminate.
    inversion H.
    inversion H0.
    rewrite merges_real_eq.
    repeat rewrite app_length.
    repeat rewrite map_length...
  Qed.

  Lemma merges_ne_nil x y: merges x y <> nil.
  Proof with try discriminate; auto.
    intros.
    unfold merges.
    destruct merges_ex.
    simpl in *.
    induction m...
    destruct r...
  Qed.

End splits_and_perms.

Existing Instance Permutation_perms.

Lemma map_repeat A B (f: A -> B) c (l: list A):
  (forall x, In x l -> f x = c) -> map f l = repeat (length l) c.
Proof with auto.
  induction l...
  simpl.
  intros.
  rewrite IHl...
  rewrite H...
Qed.

Lemma repeat_plus T (c: T) n m: repeat (n + m) c = repeat n c ++ repeat m c.
Proof. induction n. auto. simpl. congruence. Qed.

Lemma concat_repeat T n m (c: T): concat (repeat n (repeat m c)) = repeat (n * m) c.
Proof with auto.
  induction n. auto.
  simpl. intros. rewrite IHn, repeat_plus...
Qed.

Lemma filter_perms T p (l: list T):
  Permutation
    (map (filter p) (perms l))
    (concat (map (repeat (fact (length (filter (negb ∘ p) l)) * length (merges (filter p l) (filter (negb ∘ p) l)))) (perms (filter p l)))).
  (* this horrible first argument to repeat is inconsequential. what matters is that we express
        perms (filter p l)
    in terms of
        map (filter p) (perms l)
  *)
Proof with auto.
  intros.
  rewrite (complementary_filter_perm p l) at 1.
  rewrite perms_app.
  rewrite map_concat_map.
  unfold product.
  rewrite concatMap_concatMap'.
  apply Permutation_concatMap.
  intros.
  unfold Basics.compose.
  rewrite map_map.
  unfold uncurry.
  simpl.
  set (t := repeat (length (merges x (filter (fun q => negb (p q)) l))) x).
  rewrite (@map_repeat _ _ (fun x0 : list T => map (filter p) (merges x x0)) t (perms (filter (fun x0 : T => negb (p x0)) l))).
    rewrite length_perms.
    subst t.
    rewrite concat_repeat.
    pose proof (Permutation_length (perms_are_perms _ _ H)).
    rewrite (length_merges_mor H0 refl_equal)...
  intros.
  rewrite (@map_repeat _ _ (filter p) x (merges x x0)).
    subst t.
    pose proof (Permutation_length (perms_are_perms _ _ H0)).
    rewrite (length_merges_mor refl_equal H1)...
  intros.
  apply (filter_merges) with p x0...
    intros.
    apply (filter_In p z l)...
    apply Permutation_in with x...
    apply perms_are_perms...
  intros.
  pose proof (Permutation_in _ (perms_are_perms _ _ H0) H2).
  cut (negb (p z) = true).
    intros.
    destruct (p z)...
  apply (filter_In (fun q => negb (p q)) z l)...
Qed.

Instance Permutation_length_morphism T: Proper (Permutation ==> eq) (@length T) :=
  @Permutation_length T.

Lemma repeat_map_comm A B (f: A -> B) n: ext_eq (map f ∘ repeat n) (repeat n ∘ f).
Proof with auto.
  unfold ext_eq.
  unfold Basics.compose.
  induction n...
  simpl in *.
  congruence.
Qed.

Lemma length_repeat T (c: T) n: length (repeat n c) = n.
Proof with auto.
  induction n...
  simpl.
  congruence.
Qed.

Hint Immediate length_repeat.

Instance map_ext_eq_mor A B: Proper (@ext_eq A B ==> ext_eq) map.
  repeat intro.
  apply map_ext.
  assumption.
Qed.

Lemma concat_nil X (l: list (list X)): (forall x, In x l -> x = nil) -> concat l = nil.
Proof with intuition.
  induction l...
  simpl.
  rewrite IHl...
  rewrite (H a)...
Qed.

Lemma empty_nil X (x: list X): length x = 0%nat -> x = nil.
  destruct x.
    reflexivity.
  intro.
  discriminate.
Qed.

Lemma Permuted_Permutation_map T U (R: relation T) (f: T -> U):
  (forall x y, R x y -> f x = f y) -> forall a b,
  Permuted R a b ->
  Permutation (map f a) (map f b).
Proof with auto.
  intros.
  induction H0...
    simpl.
    rewrite (H x x')...
  eauto.
Qed.

Lemma elemsR_length A (R: A -> A -> Prop) a b (H: elemsR R a b):
  length a = length b.
Proof with auto.
  induction H...
  simpl.
  intuition.
Qed.

Lemma elemsRimpl A B (R: A -> B -> Prop) (l: list A): (forall x, In x l -> sig (R x)) -> sig (elemsR R l).
Proof with intuition; eauto.
  induction l...
  intros.
  destruct IHl...
  destruct (X a)...
Qed.

Lemma elemsRuniq A B (R: A -> B -> Prop) (l: list A):
  (forall x, In x l -> forall y, R x y -> forall y', R x y' -> y = y') -> forall r, elemsR R l r -> forall r', elemsR R l r' -> r = r'.
Proof with intuition; auto.
  induction l.
    intros.
    inversion_clear H0. inversion_clear H1...
  intros.
  inversion_clear H0.
  inversion_clear H1.
  rewrite (H a) with b b0...
  rewrite IHl with l' l'0...
  apply H with x...
Qed.

Definition triple0 A B C (t: A * B * C): A := fst (fst t).
Definition triple1 A B C (t: A * B * C): B := snd (fst t).
Definition triple2 A B C (t: A * B * C): C := snd t.

Fixpoint rsplits T (l: list T): list (list T * T * list T) :=
  match l with
  | nil => nil
  | h :: t => (nil, h, t) :: map (fun p => (h :: triple0 p, triple1 p, triple2 p)) (rsplits t)
  end.

Lemma splits_rsplits (T: Set) (l: list T): splits l = map (fun p => (triple1 p, triple0 p ++ triple2 p)) (rsplits l).
Proof with auto.
  induction l...
  simpl.
  rewrite map_map.
  simpl.
  rewrite IHl. clear IHl.
  unfold triple1.
  simpl.
  rewrite map_map.
  simpl...
Qed.

Lemma insert_everywhere_rsplits (T: Set) (x: T) (l: list T):
  insert_everywhere x l =
   map (fun x0 => triple0 x0 ++ x :: triple1 x0 :: triple2 x0) (rsplits l) ++ [l ++ [x]].
Proof with auto.
  induction l...
  simpl.
  rewrite IHl. clear IHl.
  unfold triple0, triple1, triple2.
  repeat rewrite map_map.
  rewrite map_app.
  rewrite map_map...
Qed.

Lemma elemsR_map':
  forall (A B: Type) (Ra: relation A) (Rb: relation B) (f : A -> B)
    (fR: forall x y, Ra x y -> Rb (f x) (f y)) (l l': list A),
      elemsR Ra l l' -> elemsR Rb (map f l) (map f l').
Proof. intros. induction H; simpl; auto... Qed.

Instance Permutation_cons_morphism A: Proper (eq ==> Permutation ==> Permutation) (@cons A).
Proof with auto.
  repeat intro.
  subst...
Qed.

Lemma concatMap_insert_everywhere T (x: T) (l: list (list T)):
  Permutation
    (concat (map (insert_everywhere x) l))
    (map (cons x) l ++ concat (map (tail ∘ insert_everywhere x) l)).
Proof with auto.
  induction l...
  simpl @concat.
  rewrite IHl.
  apply Permutation_sym.
  rewrite Permutation_app_swap.
  unfold compose.
  simpl.
  rewrite app_ass.
  generalize (concat (map (fun x0 : list T => tail (insert_everywhere x x0)) l)). intro.
  rewrite (Permutation_app_swap l0).
  rewrite <- app_ass.
  rewrite <- app_ass.
  apply Permutation_app...
  destruct a...
  simpl.
  rewrite Permutation_app_swap.
  simpl.
  apply perm_skip.
  apply Permutation_app_swap.
Qed.

Lemma map_length_filter_permuted_splits T (l l': list T): Permutation l l' ->
  forall p,
  Permutation
    (map (fun x => length (filter (p (fst x)) (snd x))) (splits l))
    (map (fun x => length (filter (p (fst x)) (snd x))) (splits l')).
Proof with auto.
  intros.
  apply (@Permuted_Permutation_map (T * list T) nat (fun x y => fst x = fst y /\ Permutation (snd x) (snd y))  (fun x => length (filter (p (fst x)) (snd x)))).
    intros.
    destruct H0.
    destruct x. destruct y.
    simpl in H0. subst.
    simpl.
    simpl in H1.
    rewrite H1...
  apply splits_permuted...
Qed.

Lemma perms_alt_perms T (l: list T): Permutation (perms l) (alt_perms l).
Proof with auto.
  unfold alt_perms.
  induction l...
  simpl.
  unfold Basics.compose.
  rewrite concatMap_insert_everywhere.
  apply Permutation_app...
  rewrite IHl. clear IHl.
  destruct l...
  rewrite map_concat.
  rewrite map_map.
  generalize (splits (t :: l)). intro.
  setoid_rewrite map_map.
  unfold compose.
  rewrite concat_concat.
  rewrite map_map.
  simpl @fst. simpl @snd.
  simpl.
  unfold compose.
  setoid_rewrite map_concat.
  setoid_rewrite map_map...
Qed.

Lemma map_single A B (f: A -> B) x: map f [x] = [f x].
Proof. reflexivity. Qed.


Require Import Options.

Require Import Coq.micromega.Lia.

(*
  This page contains some example proofs.
  Replace it with your project's files.
*)

Example subtract_one : forall n,
  n > 0 ->
  n - 1 <> n.
Proof.

induction n; lia.

Qed.

Lemma even_plus_two : forall n,
  Nat.even n = true ->
  Nat.even (n + 2) = true.
Proof.

induction n; simpl; try reflexivity.

destruct n as [| n'].
1: intros Hf; inversion Hf.

intros.
replace (S n' + 2) with (S (S (S n'))) by lia.

simpl.
assumption.

Qed.

Example two_n_always_even : forall n,
  Nat.even (2*n) = true.
Proof.

induction n; simpl; try reflexivity.
replace (n + S (n + 0)) with (S (2*n)) by lia.
assumption.

Qed.

Example even_plus_one_is_odd : forall n,
  Nat.even n = true ->
  Nat.odd (n + 1) = true.
Proof.

intros.

unfold Nat.odd.
apply Bool.negb_true_iff.

destruct (DecidableTypeEx.Nat_as_DT.eq_dec n 0); subst; try solve [simpl; auto].
destruct (DecidableTypeEx.Nat_as_DT.eq_dec n 1); subst; try solve [simpl; auto].
destruct (DecidableTypeEx.Nat_as_DT.eq_dec n 2); subst; try solve [simpl; auto].

assert (Nat.even (n - 1) = false). {
  assert (exists k, S k = n). { exists (n-1). lia. }
  destruct H0 as [k Hk].
  replace (n-1) with k by lia. subst n.

  destruct (Sumbool.sumbool_of_bool (Nat.even k)); auto.
  exfalso.

  induction k.
  1: { simpl in *; inversion H. }
  destruct (DecidableTypeEx.Nat_as_DT.eq_dec k 1); subst; try solve [simpl; auto].
  simpl in *. inversion H.
}

replace (n + 1) with (S (S (n - 1))) by lia.
simpl.
assumption.

Qed.

Lemma not_both_even_and_odd : forall n,
  ~ (Nat.even n = true /\ Nat.odd n = true).
Proof.

intros. unfold not; intros Hf. destruct Hf.
unfold Nat.odd in H0.
apply Bool.negb_true_iff in H0.
rewrite H in H0.
inversion H0.

Qed.


(* File: My_Arith.v  (last edited on 25/10/2000) (c) Klaus Weich  *)

Require Import Le.
Require Import Lt.
Require Import List.
Require Import Plus.

(******* List stuff ***********************************************)

Lemma fold_right_perm :
 forall (A B : Set) (f : B -> A -> A) (o : A) (l0 l1 : list B) (x : B),
 (forall (a b : B) (c : A), f a (f b c) = f b (f a c)) ->
 fold_right f o (l0 ++ x :: l1) = fold_right f o (x :: l0 ++ l1).
intros A B f o l0 l1 x f_perm.
elim l0; clear l0.
trivial.
intros a0 l0 ih.
simpl in |- *.
 rewrite ih.
simpl in |- *.
apply f_perm.
Qed.

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

Lemma plus_O : forall n : nat, n + 0 = n.
intros n.
 rewrite (plus_comm n 0).
simpl in |- *.
trivial.
Qed.

Lemma n_Sn_false : forall n : nat, n = S n -> False.
intros n; elim n; clear n.
intro u0;  discriminate u0.
intros n ih u0.
apply ih.
 injection u0; trivial.
Qed.

Lemma le_reg : forall m n : nat, n <= m -> S n <= S m.
intros m; elim m; clear m.
intros n; case n; clear n.
intros.
apply le_n.
intros.
inversion_clear H.
intros m ih n H.
inversion_clear H.
apply le_n.
apply le_S.
apply ih; assumption.
Qed.

Lemma eq_lt_trans : forall n m p : nat, n = m -> m < p -> n < p.
intros n m p eq lt.
 rewrite eq; assumption.
Qed.

Lemma S_reg : forall n m : nat, n = m -> S n = S m.
intros.
 rewrite H.
trivial.
Qed.

Lemma plus_reg : forall l m n : nat, m = n -> l + m = l + n.
intros.
elim l; clear l; simpl in |- *.
assumption.
intros l' ih.
 rewrite ih.
trivial.
Qed.

Lemma lt_plus_assoc_l :
 forall n m k l : nat, n + m + k < l -> n + (m + k) < l.
intros n m k l lt.
 rewrite (plus_assoc n m k); assumption.
Qed.

Lemma my_lt_weak : forall n m : nat, S n < m -> n < m.
intros n m H.
apply lt_S_n.
apply lt_trans with m; try assumption.
apply lt_n_Sn.
Qed.

(********************************************************************)
(*      max                                                         *)

Fixpoint max (n m : nat) {struct n} : nat :=
  match n with
  | O => m
  | S p => match m with
           | O => S p
           | S q => S (max p q)
           end
  end.

Lemma le_n_max1 : forall n m : nat, n <= max n m.
intros n; elim n; clear n.
simpl in |- *.
intros m.
apply le_O_n.
intros n ih m.
case m; clear m.
simpl in |- *.
trivial.
intros m0; simpl in |- *.
apply le_n_S.
apply ih.
Qed.

Lemma le_n_max2 : forall n m : nat, n <= max m n.
intros n; elim n; clear n.
intros m.
apply le_O_n.
intros n ih m.
case m; clear m.
simpl in |- *.
trivial.
intros m0; simpl in |- *.
apply le_n_S.
apply ih.
Qed.

Lemma max_n_n : forall n : nat, max n n = n.
simple induction n; clear n; simpl in |- *.
trivial.
intros n ih.
 rewrite ih.
trivial.
Qed.

Lemma max_Sn_n : forall n : nat, max (S n) n = S n.
simple induction n; clear n; simpl in |- *.
trivial.
intros n ih.
 rewrite ih.
trivial.
Qed.

Lemma max_n_Sn : forall n : nat, max n (S n) = S n.
simple induction n; clear n; simpl in |- *.
trivial.
intros n ih.
 rewrite ih.
trivial.
Qed.

Lemma max_n_O : forall n : nat, max n 0 = n.
intros n; elim n; clear n.
trivial.
intros n ih.
trivial.
Qed.


Require Import ZArith Lia Syntax Semantics.

Inductive aexpr :=
  | Cst : Z -> aexpr
  | Add : aexpr -> aexpr -> aexpr
  | Var : nat -> aexpr.

Inductive imp :=
  | Imp_Seq   : imp -> imp -> imp
  | Imp_Aff   : nat -> aexpr -> imp
  | Imp_While : aexpr -> imp -> imp.

Fixpoint eval (a : aexpr) (s : store) : Z :=
  match a with
  | Cst v => v
  | Add e1 e2 => eval e1 s + eval e2 s
  | Var x => s x
  end.

Inductive imp_exec : store -> imp -> store -> Prop :=
  | iexec_seq  : forall s1 s2 s3 p1 p2,
    imp_exec s1 p1 s2 ->
    imp_exec s2 p2 s3 ->
    imp_exec s1 (Imp_Seq p1 p2) s3
  | iexec_loop : forall s1 s2 s3 c p,
    eval c s1 <> 0%Z ->
    imp_exec s1 p s2 ->
    imp_exec s2 (Imp_While c p) s3 ->
    imp_exec s1 (Imp_While c p) s3
  | iexec_loop_done : forall s c p,
    eval c s = 0%Z ->
    imp_exec s (Imp_While c p) s.

Fixpoint compile_cst_pos (n : nat) : program :=
  match n with
  | O => Done
  | S m =>
    Seq Incr (compile_cst_pos m)
  end.

Fixpoint compile_cst_neg (n : nat) : program :=
  match n with
  | O => Done
  | S m =>
    Seq Decr (compile_cst_neg m)
  end.

Definition compile_cst (v : Z) : program :=
  if (0 <=? v)%Z then compile_cst_pos (Z.abs_nat v) else compile_cst_neg (Z.abs_nat v).

Definition Zneg (n : nat) : Z := - Z.of_nat n.

Definition Zpos (n : nat) := Z.of_nat n.

Lemma Zpos_abs :
  forall n, n = Z.abs_nat (Zpos n).
Proof.
  induction n; intros.
  + cbn; reflexivity.
  + cbn; destruct n; lia.
Qed.

Lemma Zneg_abs :
  forall n, n = Z.abs_nat (Zneg n).
Proof.
  induction n; intros.
  + cbn; reflexivity.
  + cbn; destruct n; lia.
Qed.

Lemma Zpos_succ :
  forall n, Zpos (S n) = (1 + Zpos n)%Z.
Proof.
  induction n; auto.
  rewrite IHn.
  unfold Zpos.
  repeat rewrite Nat2Z.inj_succ.
  lia.
Qed.

Lemma Zneg_pred :
  forall n, Zneg (S n) = (Zneg n - 1)%Z.
Proof.
  induction n; auto.
  rewrite IHn.
  unfold Zneg.
  repeat rewrite Nat2Z.inj_succ.
  lia.
Qed.

Lemma eval_succ :
  forall z s, (eval (Cst (1 + z)) s = 1 + eval (Cst z) s)%Z.
Proof.
  reflexivity.
Qed.

Lemma eval_pred :
  forall z s, (eval (Cst (z - 1)) s = eval (Cst z) s - 1)%Z.
Proof.
  reflexivity.
Qed.

Lemma eval_cst :
  forall v s s', eval (Cst v) s = eval (Cst v) s'.
Proof.
  reflexivity.
Qed.

Lemma get_val_incr :
  forall s, (1 + get_val s)%Z = get_val (incr s).
Proof.
  intros [ ].
  unfold incr.
  unfold get_val, store_incr, store_update.
  rewrite (Nat.eqb_refl).
  lia.
Qed.

Lemma get_val_decr :
  forall s, (get_val s - 1)%Z = get_val (decr s).
Proof.
  intros [ ].
  unfold decr, get_val, store_decr, store_update.
  rewrite (Nat.eqb_refl).
  lia.
Qed.

Lemma compile_cst_pos_correct :
  forall n s s',
  s -< compile_cst_pos n >-> s' ->
  (get_val s + eval (Cst (Zpos n)) (get_store s))%Z = get_val s'.
Proof.
  induction n; intros.
  - inversion_clear H.
    rewrite <- Z.add_comm.
    reflexivity.
  - cbn in H.
    inversion_clear H.
    inversion_clear H0.
    subst.
    pose proof (IHn _ _ H1).
    rewrite Zpos_succ, eval_succ, <- H.
    replace (get_val (incr s)) with (1 + get_val s)%Z by apply get_val_incr.
    replace (eval (Cst (Zpos n)) (get_store (incr s))) with (eval (Cst (Zpos n)) (get_store s)) by reflexivity.
    lia.
Qed.

Lemma compile_cst_neg_correct :
  forall n s s',
  s -< compile_cst_neg n >-> s' ->
  (get_val s + eval (Cst (Zneg n)) (get_store s))%Z = get_val s'.
Proof.
  induction n; intros.
  - inversion_clear H.
    subst.
    rewrite <- Z.add_comm.
    reflexivity.
  - cbn in H.
    inversion_clear H.
    inversion_clear H0.
    subst.
    pose proof (IHn _ _ H1).
    rewrite Zneg_pred, eval_pred, <- H.
    replace (get_val (decr s)) with (get_val s - 1)%Z by apply get_val_decr.
    replace (eval (Cst (Zneg n)) (get_store (decr s))) with (eval (Cst (Zneg n)) (get_store s)) by reflexivity.
    lia.
Qed.

Lemma compile_cst_correct :
  forall v s,
  state0 -< compile_cst v >-> s ->
  eval (Cst v) (get_store state0) = get_val s.
Proof.
  intros.
  destruct v.
  + now inversion_clear H.
  + cbn in H.
    rewrite <- (compile_cst_pos_correct _ _ _ H).
    simpl.
    unfold Zpos.
    now rewrite positive_nat_Z.
  + cbn in H.
    rewrite <- (compile_cst_neg_correct _ _ _ H).
    simpl.
    unfold Zneg.
    now rewrite positive_nat_Z.
Qed.


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

Definition vertex := nat.
Definition edge := prod vertex vertex.
Record graph := Graph
{
  v_list : list vertex;
  e_list : list edge
}.

Definition cover := list edge.

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

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

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

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

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

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

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

Definition incl_b {X : Type} f (l m : list X) := forallb (fun x => elem f x m) l.

Definition is_cover_b (es : cover) (g : graph) :=
andb
(incl_b (fun e1 e2 => match (e1,e2) with ((x1,y1),(x2,y2)) => andb (eqb x1 x2) (eqb y1 y2) end)
 es (e_list g))
(forallb (fun v => existsb (incident_b v) es) (v_list g)).

Theorem trivial_cover : forall c : cover,  is_cover c empty -> c = empty_cover.
Proof.
intros c [H1 H2].
compute in H1.
induction c.
- reflexivity.
- pose (H1 a).
pose (f (or_introl eq_refl)).
inversion f0.
Qed.

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

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

Fixpoint min_vc (g : graph) : nat :=
let covers := filter (fun c => is_cover_b c g) (all_subset (e_list g)) in
min (map (fun c => length c) covers) 5000.

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

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


Require Export List.

Inductive ltree (A : Type) : Type :=
  lnode: A -> list (ltree A) ->  ltree A .

Section correct_ltree_ind.
Variables (A : Type) (P : ltree A ->  Prop) (Q : list (ltree A) ->  Prop).
Hypotheses
   (H : forall (a : A) (l : list (ltree A)), Q l ->  P (lnode A a l))
   (H0 : Q nil)
   (H1 : forall (t : ltree A),
         P t -> forall (l : list (ltree A)), Q l ->  Q (cons t l)).

Fixpoint ltree_ind2 (t : ltree A) : P t :=
 match t as x return P x with
    lnode _ a l =>
      H a l ((fix l_ind (l' : list (ltree A)) : Q l' :=
                     match l' as x return Q x with
                        nil => H0
                       | cons t1 tl => H1 t1 (ltree_ind2 t1) tl (l_ind tl)
                     end) l)
 end.

End correct_ltree_ind.

Section correct_list_ltree_ind.
Variables (A : Type) (P : ltree A ->  Prop) (Q : list (ltree A) ->  Prop).
Hypotheses
   (H : forall (a : A) (l : list (ltree A)), Q l ->  P (lnode A a l))
   (H0 : Q nil)
   (H1 : forall (t : ltree A),
         P t -> forall (l : list (ltree A)), Q l ->  Q (cons t l)).

Fixpoint list_ltree_ind2 (l : list (ltree A)) : Q l :=
 match l as x return Q x with
   | nil => H0
   | t :: tl => H1 t (ltree_ind2 A P Q H H0 H1 t) tl (list_ltree_ind2 tl)
 end.

End correct_list_ltree_ind.


Add LoadPath "." as OPAT.
Require Import OPAT.aula3 OPAT.aula8 OPAT.aula9 OPAT.aula10 OPAT.doit6.

(** **** Exercise: 2 stars (filter_even_gt7)  *)
(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)
Fixpoint gt7b (n:nat) : bool :=
  match n with
  | 0 => false
  | 8 => true
  | S n' => gt7b n'
  end.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter evenb (filter gt7b l).

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

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

(** **** Exercise: 3 stars (partition)  *)
(** Use [filter] to write a Coq function [partition]:

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

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

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

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

(** **** Exercise: 3 stars (map_rev)  *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Lemma distr_map : forall {X Y: Type} (f : X -> Y) (l1 l2 : list X),
    map f (l1 ++ l2) = map f l1 ++ map f l2.
Proof.
  intros X Y f l1 l2. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l. induction l as [ | n l' IHl'].
  -reflexivity.
  -simpl. rewrite distr_map. simpl. rewrite IHl'. reflexivity.
Qed.

(** [] *)

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

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

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

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

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

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

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

(** Prove the correctness of [fold_length]. *)

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

(** **** Exercise: 3 stars (fold_map)  *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

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

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


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq path fintype bigop.

(** * Rewriting *)
(** In this file we prove a few lemmas
   that simplify work with rewriting. *)
Section RewriteFacilities.

  Lemma diseq:
    forall {X : Type} (p : X -> Prop) (x y : X),
      ~ p x -> p y -> x <> y.
  Proof. intros ? ? ? ? NP P EQ; subst; auto. Qed.

  Lemma eqprop_to_eqbool {X : eqType} {a b : X}: a = b -> a == b.
  Proof. by intros; apply/eqP. Qed.

  Lemma eqbool_true {X : eqType} {a b : X}: a == b -> a == b = true.
  Proof. by move =>/eqP EQ; subst b; rewrite eq_refl. Qed.

  Lemma eqbool_false {X : eqType} {a b : X}: a != b -> a == b = false.
  Proof. by apply negbTE. Qed.

  Lemma eqbool_to_eqprop {X : eqType} {a b : X}: a == b -> a = b.
  Proof. by intros; apply/eqP. Qed.

  Lemma neqprop_to_neqbool {X : eqType} {a b : X}: a <> b -> a != b.
  Proof. by intros; apply/eqP. Qed.

  Lemma neqbool_to_neqprop {X : eqType} {a b : X}: a != b -> a <> b.
  Proof. by intros; apply/eqP. Qed.

  Lemma neq_sym {X : eqType} {a b : X}:
    a != b -> b != a.
  Proof.
    intros NEQ; apply/eqP; intros EQ;
      subst b; move: NEQ => /eqP NEQ; auto. Qed.

  Lemma neq_antirefl {X : eqType} {a : X}:
    (a != a) = false.
  Proof. by apply/eqP. Qed.

  Lemma option_inj_eq {X : eqType} {a b : X}:
    a == b -> Some a == Some b.
  Proof. by move => /eqP EQ; apply/eqP; rewrite EQ. Qed.

  Lemma option_inj_neq {X : eqType} {a b : X}:
    a != b -> Some a != Some b.
  Proof.
    by move => /eqP NEQ;
     apply/eqP; intros CONTR;
       apply: NEQ; inversion_clear CONTR. Qed.

  (** Example *)
  (* As a motivation for this file, we consider the following example. *)
  Section Example.

    (* Let X  be an arbitrary type ... *)
    Context {X : eqType}.

    (* ... f be an arbitrary function [bool -> bool] ... *)
    Variable f : bool -> bool.

    (* ... p be an arbitrary predicate on X ... *)
    Variable p : X -> Prop.

    (* ... and let a and b be two elements of X such that ... *)
    Variables a b : X.

    (* ... p holds for a and doesn't hold for b. *)
    Hypothesis H_pa : p a.
    Hypothesis H_npb : ~ p b.

    (* The following examples are commented out
       to expose the insides of the proofs. *)

    (*
    (* Simplifying some relatively sophisticated
       expressions can be quite tedious. *)
    [Goal f ((a == b) && f false) = f false.]
    [Proof.]
      (* Things like [simpl/compute] make no sense here. *)
      (* One can use [replace] to generate a new goal. *)
      [replace (a == b) with false; last first.]
      (* However, this leads to a "loss of focus". Moreover,
         the resulting goal is not so trivial to prove. *)
      [{ apply/eqP; rewrite eq_sym eqbF_neg.]
      [    by apply/eqP; intros EQ; subst b; apply H_npb. }]
      [  by rewrite Bool.andb_false_l.]
    [Abort.]
     *)

    (*
    (* The second attempt. *)
    [Goal f ((a == b) && f false) = f false.]
      (* With the lemmas above one can compose multiple
         transformations in a single rewrite. *)
      [  by rewrite (eqbool_false (neq_sym (neqprop_to_neqbool (diseq _ _ _ H_npb H_pa))))]
      [        Bool.andb_false_l.]
    [Qed.]
    *)

  End Example.

End RewriteFacilities.


Require Import Recdef Lia.

From Typonomikon Require Import BinaryPos.

Inductive Z : Type :=
| Pos  : Pos -> Z
| Zero : Z
| Neg  : Pos -> Z.

Function inv (k : Z) : Z :=
match k with
| Pos p => Neg p
| Zero   => Zero
| Neg p => Pos p
end.

Function succ (k : Z) : Z :=
match k with
| Pos p     => Pos (BinaryPos.succ p)
| Zero      => Pos I'
| Neg I'    => Zero
| Neg p     => Neg (BinaryPos.pred p)
end.

Function pred (k : Z) : Z :=
match k with
| Pos I'    => Zero
| Pos p     => Pos (BinaryPos.pred p)
| Zero      => Neg I'
| Neg p     => Neg (BinaryPos.succ p)
end.

(* TODO
Function add (k1 k2 : Z) : Z :=
match k1, k2 with
| Zero   , _       => k2
| _      , Zero    => k1
| Pos k1', Pos k2' => Pos (BinaryPos.add k1' k2')
| Pos k1', Neg k2' =>
  match BinaryPos.compare k1' k2' with
  | Lt => Neg (BinaryPos.sub k2' k1')
  | Eq => Zero
  | Gt => Pos (BinaryPos.sub k1' k2')
  end
| Neg k1', Pos k2' =>
  match BinaryPos.compare k1' k2' with
  | Lt => Pos (BinaryPos.sub k2' k1')
  | Eq => Zero
  | Gt => Neg (BinaryPos.sub k1' k2')
  end
| Neg k1', Neg k2' => Neg (1 + k1' + k2')
end.

Definition size (k : Z) : nat :=
match k with
| Zero => 0
| Pos k' => 1 + k'
| Neg k' => 1 + k'
end.

Function add' (k1 k2 : Z) {measure size k1} : Z :=
match k1 with
| Zero        => k2
| Pos 0       => succ k2
| Pos (S k1') => succ (add' (Pos k1') k2)
| Neg 0       => pred k2
| Neg (S k1') => pred (add' (Neg k1') k2)
end.
Proof.
  - intros; cbn; lia.
  - intros; cbn; lia.
Defined.

Definition sub (k1 k2 : Z) :=
  add k1 (inv k2).

Function mul (k1 k2 : Z) : Z :=
match k1, k2 with
| Zero   , _       => Zero
| _      , Zero    => Zero
| Pos k1', Pos k2' => Pos (S k1' * S k2' - 1)
| Pos k1', Neg k2' => Neg (S k1' * S k2' - 1)
| Neg k1', Pos k2' => Neg (S k1' * S k2' - 1)
| Neg k1', Neg k2' => Pos (S k1' * S k2' - 1)
end.

Function mul' (k1 k2 : Z) {measure size k1} : Z :=
match k1 with
| Zero      => Zero
| Pos 0     => k2
| Pos (S n) => add' k2 (mul' (Pos n) k2)
| Neg 0     => inv k2
| Neg (S n) => add' (inv k2) (mul' (Neg n) k2)
end.
Proof.
  - intros; cbn; lia.
  - intros; cbn; lia.
Defined.

Function min (k1 k2 : Z) : Z :=
match k1, k2 with
| Neg n1, Neg n2 => Neg (Nat.max n1 n2)
| Neg n1, _      => Neg n1
| _     , Neg n2 => Neg n2
| Zero  , _      => Zero
| _     , Zero   => Zero
| Pos n1, Pos n2 => Pos (Nat.min n1 n2)
end.

Function max (k1 k2 : Z) : Z :=
match k1, k2 with
| Pos n1, Pos n2 => Pos (Nat.max n1 n2)
| Pos _ , _      => k1
| _     , Pos _  => k2
| Zero  , _      => Zero
| _     , Zero   => Zero
| Neg n1, Neg n2 => Neg (Nat.min n1 n2)
end.

Compute add (Pos 5) (Pos 6).
Compute add (Pos 5) (Neg 2).
Compute add (Pos 2) (Neg 3).
Compute add (Neg 2) (Pos 5).
Compute add (Neg 2) (Pos 3).

Compute mul (Neg 1) (Pos 1).
Compute mul (Neg 1) (Neg 1).

Compute min (Pos 5) (Pos 6).
Compute min (Pos 5) (Neg 5).
Compute min (Neg 5) (Neg 6).

Lemma inv_inv :
  forall k : Z,
    inv (inv k) = k.
Proof.
  destruct k; reflexivity.
Qed.

Lemma inv_succ :
  forall k : Z,
    inv (succ k) = pred (inv k).
Proof.
  intros k; functional induction (succ k); cbn; reflexivity.
Qed.

Lemma inv_pred :
  forall k : Z,
    inv (pred k) = succ (inv k).
Proof.
  intros k; functional induction (pred k); cbn; reflexivity.
Qed.

Lemma succ_pred :
  forall k : Z,
    succ (pred k) = k.
Proof.
  intros k; functional induction (pred k); cbn; reflexivity.
Qed.

Lemma pred_succ :
  forall k : Z,
    pred (succ k) = k.
Proof.
  intros k; functional induction (succ k); cbn; reflexivity.
Qed.

Lemma add_Zero_l :
  forall k : Z,
    add Zero k = k.
Proof.
  reflexivity.
Qed.

Lemma add_Zero_r :
  forall k : Z,
    add k Zero = k.
Proof.
  destruct k; reflexivity.
Qed.

Lemma add_comm :
  forall k1 k2 : Z,
    add k1 k2 = add k2 k1.
Proof.
  intros k1 k2; functional induction (add k1 k2)
  ; cbn; rewrite ?add_Zero_r, 1?PeanoNat.Nat.compare_antisym, ?e1; cbn
  ; f_equal; reflexivity + lia.
Qed.

Lemma add_inv :
  forall k1 k2 : Z,
    add (inv k1) (inv k2) = inv (add k1 k2).
Proof.
  intros k1 k2; functional induction (add k1 k2)
  ; cbn; rewrite ?add_Zero_r, ?e1
  ; f_equal; reflexivity + lia.
Qed.

Lemma add_assoc :
  forall k1 k2 k3 : Z,
    add (add k1 k2) k3 = add k1 (add k2 k3).
Proof.
  intros k1 k2 k3; functional induction (add k1 k2)
  ; rewrite ?add_Zero_l; try reflexivity.
Admitted.

Lemma add'_inv :
  forall k1 k2 : Z,
    add' (inv k1) (inv k2) = inv (add' k1 k2).
Proof.
  intros k1 k2; functional induction (add' k1 k2)
  ; cbn; rewrite ?add'_Zero_r.
  - reflexivity.
  - rewrite inv_succ; reflexivity.
  - rewrite add'_equation, inv_succ, <- IHz; cbn; reflexivity.
  - rewrite inv_pred; reflexivity.
  - rewrite add'_equation, inv_pred, <- IHz; cbn; reflexivity.
Qed.

Lemma inv_add' :
  forall k1 k2 : Z,
    inv (add' k1 k2) = add' (inv k1) (inv k2).
Proof.
  intros k1 k2; rewrite add'_inv; reflexivity.
Qed.

Lemma add'_Zero_l :
  forall k : Z,
    add' Zero k = k.
Proof.
  reflexivity.
Qed.

Lemma add'_Zero_r :
  forall k : Z,
    add' k Zero = k.
Proof.
  destruct k as [n | | n]; cycle 1.
  - reflexivity.
  - induction n as [| n']; cbn.
    + reflexivity.
    + rewrite add'_equation, IHn'; cbn; reflexivity.
  - induction n as [| n']; cbn.
    + reflexivity.
    + rewrite add'_equation, IHn'; cbn; reflexivity.
Qed.

Lemma add'_Pos_r :
  forall (k : Z) (n : nat),
    add' k (Pos n)
      =
    match n with
    | 0    => succ k
    | S n' => succ (add' k (Pos n'))
    end.
Proof.
  intros [m | | m] n; cbn; cycle 1.
  - destruct n; reflexivity.
  - induction m as [| m']; destruct n as [| n']; cbn.
    + reflexivity.
    + destruct n'; reflexivity.
    + rewrite add'_equation, IHm'. destruct m'; reflexivity.
    + rewrite !(add'_equation (Neg (S m'))), IHm', pred_succ, succ_pred; reflexivity.
  - induction m as [| m']; destruct n as [| n']; cbn.
    + reflexivity.
    + reflexivity.
    + rewrite add'_equation, IHm'; cbn; reflexivity.
    + rewrite !(add'_equation (Pos (S m'))), IHm'; reflexivity.
Qed.

Lemma add'_Neg_r :
  forall (k : Z) (n : nat),
    add' k (Neg n)
      =
    match n with
    | 0    => pred k
    | S n' => pred (add' k (Neg n'))
    end.
Proof.
  intros k n.
  rewrite <- inv_inv, inv_add' at 1; cbn.
  rewrite add'_Pos_r.
  destruct n.
  - rewrite inv_succ, inv_inv; reflexivity.
  - rewrite inv_succ, inv_add', inv_inv; cbn; reflexivity.
Qed.

Lemma add'_succ_l :
  forall k1 k2 : Z,
    add' (succ k1) k2 = succ (add' k1 k2).
Proof.
  intros k1 k2; functional induction (succ k1); cbn.
  - rewrite add'_equation; reflexivity.
  - reflexivity.
  - rewrite succ_pred; reflexivity.
  - rewrite (add'_equation (Neg (S n))), succ_pred; reflexivity.
Qed.

Lemma add'_pred_l :
  forall k1 k2 : Z,
    add' (pred k1) k2 = pred (add' k1 k2).
Proof.
  intros k1 k2; functional induction (pred k1); cbn.
  - rewrite pred_succ; reflexivity.
  - rewrite (add'_equation (Pos (S n))), pred_succ; reflexivity.
  - reflexivity.
  - rewrite add'_equation; reflexivity.
Qed.

Lemma add'_comm :
  forall k1 k2 : Z,
    add' k1 k2 = add' k2 k1.
Proof.
  intros k1 k2; functional induction (add' k1 k2).
  - rewrite add'_Zero_r; reflexivity.
  - rewrite add'_Pos_r; reflexivity.
  - rewrite IHz, (add'_Pos_r k2 (S k1')); reflexivity.
  - rewrite add'_Neg_r; reflexivity.
  - rewrite IHz, (add'_Neg_r k2 (S k1')); reflexivity.
Qed.

Lemma add'_assoc :
  forall k1 k2 k3 : Z,
    add' (add' k1 k2) k3 = add' k1 (add' k2 k3).
Proof.
  intros k1 k2 k3; functional induction (add' k1 k2); cbn.
  - reflexivity.
  - rewrite add'_succ_l; reflexivity.
  - rewrite add'_succ_l, IHz, (add'_equation (Pos (S k1'))); reflexivity.
  - rewrite add'_pred_l; reflexivity.
  - rewrite add'_pred_l, IHz, (add'_equation (Neg (S k1'))); reflexivity.
Qed.

Lemma sub_diag :
  forall k : Z,
    add' k (inv k) = Zero.
Proof.
  intros [n | | n]; cbn; cycle 1.
  - reflexivity.
  - induction n as [| n']; cbn in *.
    + reflexivity.
    + rewrite add'_equation, add'_Pos_r, IHn', pred_succ; reflexivity.
  - induction n as [| n']; cbn in *.
    + reflexivity.
    + rewrite add'_equation, add'_Neg_r, IHn', succ_pred; reflexivity.
Qed.

Lemma mul_Zero_r :
  forall k : Z,
    mul k Zero = Zero.
Proof.
  destruct k; reflexivity.
Qed.

Lemma mul_comm :
  forall k1 k2 : Z,
    mul k1 k2 = mul k2 k1.
Proof.
  intros k1 k2; functional induction (mul k1 k2)
  ; cbn; rewrite ?mul_Zero_r
  ; f_equal; reflexivity + lia.
Qed.

Lemma mul_assoc :
  forall k1 k2 k3 : Z,
    mul (mul k1 k2) k3 = mul k1 (mul k2 k3).
Proof.
  intros k1 k2 k3; functional induction (mul k1 k2)
  ; cbn; rewrite ?mul_Zero_r
  ; try reflexivity
  ; destruct k3 as [k3' | | k3']
  ; cbn; rewrite ?mult_n_Sm
  ; f_equal; try reflexivity.
  all: cbn; rewrite <- ?mult_n_Sm, PeanoNat.Nat.sub_0_r.
Abort.

Lemma inv_mul'_r :
  forall k1 k2 : Z,
    inv (mul' k1 k2) = mul' k1 (inv k2).
Proof.
  intros k1 k2. functional induction (mul' k1 k2); cbn.
  1-2: reflexivity.
  - rewrite inv_add', IHz, (mul'_equation (Pos (S n))); reflexivity.
  - reflexivity.
  - rewrite inv_add', IHz, (mul'_equation (Neg (S n))); reflexivity.
Qed.

Lemma mul'_Zero_r :
  forall k : Z,
    mul' k Zero = Zero.
Proof.
  destruct k as [n | | n]; cbn; cycle 1.
  - reflexivity.
  - induction n as [| n']; cbn.
    + reflexivity.
    + rewrite mul'_equation, IHn'; cbn; reflexivity.
  - induction n as [| n']; cbn.
    + reflexivity.
    + rewrite mul'_equation, IHn'; cbn; reflexivity.
Qed.

Lemma mul'_Pos_r :
  forall (k : Z) (n : nat),
    mul' k (Pos n)
      =
    match n with
    | 0    => k
    | S n' => add' k (mul' k (Pos n'))
    end.
Proof.
  intros [m | | m] n; cycle 1.
  - destruct n; reflexivity.
  - induction m as [| m'].
    + rewrite mul'_equation. destruct n; reflexivity.
    + rewrite mul'_equation, IHm'. unfold inv. destruct n as [| n'].
      * reflexivity.
      * rewrite (mul'_equation (Neg (S m'))); unfold inv.
        rewrite (add'_equation (Neg (S n'))), (add'_equation (Neg (S m'))); f_equal.
        rewrite <- !add'_assoc, (add'_comm (Neg n') (Neg m')).
        reflexivity.
  - induction m as [| m'].
    + rewrite mul'_equation. destruct n; reflexivity.
    + rewrite mul'_equation, IHm'. destruct n as [| n'].
      * reflexivity.
      * rewrite (mul'_equation (Pos (S m'))); unfold inv.
        rewrite (add'_equation (Pos (S n'))), (add'_equation (Pos (S m'))); f_equal.
        rewrite <- !add'_assoc, (add'_comm (Pos n') (Pos m')).
        reflexivity.
Qed.

Lemma mul'_Neg_r :
  forall (k : Z) (n : nat),
    mul' k (Neg n)
      =
    match n with
    | 0    => inv k
    | S n' => add' (inv k) (mul' k (Neg n'))
    end.
Proof.
  intros k n.
  rewrite <- inv_inv, inv_mul'_r at 1; cbn.
  rewrite mul'_Pos_r.
  destruct n as [| n']; cbn.
  - reflexivity.
  - rewrite inv_add', inv_mul'_r; cbn; reflexivity.
Qed.

Lemma mul'_comm :
  forall k1 k2 : Z,
    mul' k1 k2 = mul' k2 k1.
Proof.
  intros k1 k2; functional induction (mul' k1 k2)
  ; cbn; rewrite ?mul'_Zero_r.
  - reflexivity.
  - rewrite mul'_Pos_r; reflexivity.
  - rewrite mul'_Pos_r, IHz; reflexivity.
  - rewrite mul'_Neg_r; reflexivity.
  - rewrite mul'_Neg_r, IHz; reflexivity.
Qed.

Lemma mul'_succ_l :
  forall k1 k2 : Z,
    mul' (succ k1) k2 = add' k2 (mul' k1 k2).
Proof.
  intros k1 k2.
  functional induction (succ k1); cbn.
  - rewrite mul'_equation; reflexivity.
  - rewrite add'_Zero_r; reflexivity.
  - rewrite sub_diag; reflexivity.
  - rewrite (mul'_equation (Neg (S n))), <- add'_assoc, sub_diag; cbn; reflexivity.
Qed.

Lemma mul'_pred_l :
  forall k1 k2 : Z,
    mul' (pred k1) k2 = add' (inv k2) (mul' k1 k2).
Proof.
  intros k1 k2.
  functional induction (pred k1); cbn.
  - rewrite add'_comm, sub_diag; reflexivity.
  - rewrite (mul'_equation (Pos (S n))), <- add'_assoc, (add'_comm (inv _)), sub_diag; cbn.
    reflexivity.
  - rewrite add'_Zero_r; reflexivity.
  - rewrite mul'_equation. reflexivity.
Qed.

Lemma mul'_add'_l :
  forall k1 k2 k3 : Z,
    mul' (add' k1 k2) k3 = add' (mul' k1 k3) (mul' k2 k3).
Proof.
  intros k1 k2 k3.
  functional induction (add' k1 k2); cbn.
  - reflexivity.
  - rewrite mul'_succ_l; reflexivity.
  - rewrite mul'_succ_l, (mul'_equation (Pos (S k1'))), add'_assoc, IHz; reflexivity.
  - rewrite mul'_pred_l; reflexivity.
  - rewrite mul'_pred_l, (mul'_equation (Neg (S k1'))), add'_assoc, IHz; reflexivity.
Qed.

Lemma mul'_assoc :
  forall k1 k2 k3 : Z,
    mul' (mul' k1 k2) k3 = mul' k1 (mul' k2 k3).
Proof.
  intros k1 k2 k3; functional induction (mul' k1 k2); cbn.
  1-2: reflexivity.
  - rewrite (mul'_equation (Pos (S n))), mul'_add'_l, IHz; reflexivity.
  - rewrite mul'_comm, <- inv_mul'_r, mul'_comm; reflexivity.
  - rewrite (mul'_equation (Neg (S n))), (mul'_comm k2), inv_mul'_r, (mul'_comm _ (inv _)),
            mul'_add'_l, (mul'_comm (inv _)), IHz, (mul'_comm k2 k3).
    reflexivity.
Qed.

Lemma min_comm :
  forall k1 k2 : Z,
    min k1 k2 = min k2 k1.
Proof.
  intros k1 k2; functional induction (min k1 k2)
  ; cbn; f_equal; try (reflexivity + lia).
  - destruct k2; cbn; reflexivity + contradiction.
  - destruct k1; cbn; reflexivity + contradiction.
  - destruct k2; cbn; reflexivity + contradiction.
  - destruct k1; cbn; reflexivity + contradiction.
Qed.

Lemma min_inv :
  forall k1 k2 : Z,
    min (inv k1) (inv k2) = inv (max k1 k2).
Proof.
  intros k1 k2; functional induction (max k1 k2); cbn; f_equal.
  - destruct k2; cbn in *; reflexivity + contradiction.
  - destruct k1; cbn in *; reflexivity + contradiction.
  - destruct k2; cbn in *; reflexivity + contradiction.
  - destruct k1; cbn in *; reflexivity + contradiction.
Qed.

Lemma inv_min :
  forall k1 k2 : Z,
    inv (min k1 k2) = max (inv k1) (inv k2).
Proof.
  intros k1 k2.
  rewrite <- inv_inv, <- min_inv, !inv_inv.
  reflexivity.
Qed.
*)


Fixpoint fact n :=
  match n with
    | O    => 1
    | S n' => n * fact n'
  end.

Definition v := fact 5.
Eval compute in v.


Set Implicit Arguments.

Require Import Coq.Lists.SetoidList.

Definition equiv_2 A B p1 p2 := forall (a : A) (b : B), p1 a b <-> p2 a b.

Lemma equiv_2_trans : forall A B a b c, @equiv_2 A B a b -> equiv_2 b c -> equiv_2 a c.
  unfold equiv_2; intros; split; intros.
  eapply H0; eapply H; eauto.
  eapply H; eapply H0; eauto.
Qed.

Lemma InA_eq_In_iff : forall elt (ls : list elt) (x : elt), InA eq x ls <-> List.In x ls.
  induction ls; simpl; intros.
  intuition.
  eapply InA_nil in H; eauto.
  split; intros.
  inversion H; subst.
  eauto.
  right.
  eapply IHls.
  eauto.
  destruct H.
  subst.
  econstructor 1.
  eauto.
  econstructor 2.
  eapply IHls.
  eauto.
Qed.

Lemma InA_weaken :
  forall A (P : A -> A -> Prop) (x : A) (ls : list A),
    InA P x ls ->
    forall (P' : A -> A -> Prop) x',
      (forall y, P x y -> P' x' y) ->
      InA P' x' ls.
  induction 1; simpl; intuition.
Qed.

Lemma equiv_InA : forall elt (eq1 eq2 : elt -> elt -> Prop), equiv_2 eq1 eq2 -> equiv_2 (InA eq1) (InA eq2).
  unfold equiv_2; split; intros; eapply InA_weaken; eauto; intros; eapply H; eauto.
Qed.

Lemma In_InA : forall A (x : A) ls,
  List.In x ls
  -> InA eq x ls.
  intros; eapply InA_eq_In_iff; eauto.
Qed.

Lemma InA_In : forall A (x : A) ls,
  InA eq x ls ->
  List.In x ls.
  intros; eapply InA_eq_In_iff; eauto.
Qed.

Local Hint Constructors List.NoDup NoDupA.

Lemma NoDupA_NoDup : forall A ls,
  @NoDupA A eq ls
  -> List.NoDup ls.
  induction 1; intuition auto using In_InA.
Qed.

Lemma NoDup_NoDupA : forall A ls,
  List.NoDup ls ->
  @NoDupA A eq ls.
  induction 1; intuition auto using InA_In.
Qed.


(*|
################################################
Local ``Inductive`` definitions and ``Theorems``
################################################

:Link: https://stackoverflow.com/q/36235244
|*)

(*|
Question
********

I'm using a couple of ``Inductive`` definitions as counter examples in
some proofs. I would however like to encapsulate these definitions by
enclosing them in a ``Section``. Regular ``Definitions`` can be hidden
using ``Let``, but is this also possible for ``Inductive``
definitions? And how about ``Theorem``\ s?

Let me give the actual thing I'm trying to achieve, as I may be going
about it totally the wrong way in the first place. I want to formalize
all the proofs and exercises of the excellent book "Logics of Time and
Computation" by Robert Goldblatt into Coq.

For starters we take classical logic as that is what the book does as
well.
|*)

Require Import Classical_Prop.
Require Import Classical_Pred_Type.

(*|
Next we define identifiers the same way it is done in Software
Foundations.
|*)

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

(*| Definition of the syntax. |*)

Inductive modal : Type :=
| Bottom : modal
| V : id -> modal
| Imp : modal -> modal -> modal
| Box : modal -> modal.

Definition Not (f : modal) : modal := Imp f Bottom.

(*| Definition of the semantics using Kripke frames. |*)

(* Inspired by: www.cs.vu.nl/~tcs/mt/dewind.ps.gz *)
Record frame : Type :=
  { Worlds : Type
  ; WorldsExist : exists w : Worlds, True
  ; Rel : Worlds -> Worlds -> Prop }.

Record kripke : Type :=
  { Frame : frame
  ; Label : (Worlds Frame) -> id -> Prop }.

Fixpoint satisfies (M : kripke) (x : Worlds (Frame M)) (f : modal) : Prop :=
  match f with
  | Bottom => False
  | V v => Label M x v
  | Imp f1 f2 => satisfies M x f1 -> satisfies M x f2
  | Box f => forall y : Worlds (Frame M), Rel (Frame M) x y -> satisfies M y f
  end.

(*| The first lemma relates the modal ``Not`` to the one of Coq. |*)

Lemma satisfies_Not : forall M x f, satisfies M x (Not f) = ~ satisfies M x f.
Proof. auto. Qed.

(*| Next we lift the semantics to complete models. |*)

Definition M_satisfies (M : kripke) (f : modal) : Prop :=
  forall w : Worlds (Frame M), satisfies M w f.

(*| And we show what it means for the ``Not`` connective. |*)

Lemma M_satisfies_Not : forall M f, M_satisfies M (Not f) -> ~ M_satisfies M f.
Proof.
  unfold M_satisfies.
  intros M f Hn Hcontra.
  destruct (WorldsExist (Frame M)).
  specialize (Hn x). clear H.
  rewrite satisfies_Not in Hn.
  specialize (Hcontra x). auto.
Qed.

(*|
Here comes the thing. The reverse of the above lemma does not hold and
I want to show this by a counter example, exhibiting a model for which
it doesn't hold.
|*)

Inductive Wcounter : Set := x1 : Wcounter | x2 : Wcounter | x3 : Wcounter.

Lemma Wcounter_not_empty : exists w : Wcounter, True.
Proof. exists x1. constructor. Qed.

Inductive Rcounter (x : Wcounter) (y : Wcounter) : Prop :=
| E1 : x = x1 -> y = x2 -> Rcounter x y
| E2 : x = x2 -> y = x3 -> Rcounter x y.

Definition Lcounter : Wcounter -> id -> Prop :=
  fun x i => match x with
             | x1 => match i with | Id 0 => True | _ => False end
             | x2 => match i with | Id 1 => True | _ => False end
             | x3 => match i with | Id 0 => True | _ => False end
             end.

Definition Fcounter : frame := Build_frame Wcounter Wcounter_not_empty Rcounter.

Definition Kcounter : kripke := Build_kripke Fcounter Lcounter.

(*|
Next an ``Ltac`` that relieves me from typing verbose ``assert``\ s.
|*)

Ltac counter_example H Hc :=
  match type of H with
  | ?P -> ~ ?Q => assert (Hc: Q)
  | ?P -> (?Q -> False) => assert (Hc: Q)
  | ?P -> ?Q => assert (Hc: ~Q)
  end.

(*|
Finally I use this counter example to prove the following ``Lemma``.
|*)

Lemma M_not_satisfies_Not :
  ~ forall M f, ~ M_satisfies M f -> M_satisfies M (Not f).
Proof.
  apply ex_not_not_all. exists Kcounter.
  apply ex_not_not_all. exists (V (Id 0)).
  unfold M_satisfies. simpl.
  intro Hcontra. unfold not in Hcontra.
  counter_example Hcontra Hn2.
  - apply ex_not_not_all. exists x1. simpl. auto.
  - apply Hn2. apply Hcontra. apply ex_not_not_all; exists x2. simpl. auto.
Qed.

(*|
Preferably I would have used the ``remember`` tactic to define the
counter example inside the proof, but I don't think it can be used for
the ``Inductive`` definitions. All the definitions relating to the
counter example are exported as part of my theory, which I prefer not
to do. It is only used in the proof of ``M_not_satisfies_Not``.
Actually I would not even want to export this ``Lemma`` either as it
is not very useful. I only put it there to argue that
``M_satisfies_Not`` can not be an equivalence.
|*)

(*|
Answer
******

``Section`` doesn't hide definitions, use ``Module`` instead. For
example put the counter example in a module.

.. code-block:: coq

    Module CounterExample.
      Import Definitions.
      Inductive Wcounter : Set := x1 | x2 | x3.
      ...
      Lemma M_not_satisfies_Not : ...
    End CounterExample.

At this stage, only ``CounterExample`` is defined at the top level.

If you don't want that either, then you could just put the definitions
in one ``.v`` file and the counter example in another file that
imports the definitions. Actually, the way it works is that ``.v``
files are turned into individual modules.
|*)


(** Exercise 5.1 **)

Lemma id_P : forall P:Prop, P->P.
Proof.
  intros P H; assumption.
Qed.

Lemma id_PP : forall P:Prop, (P->P)->(P->P).
Proof.
  intros P H; assumption.
Qed.

Lemma imp_trans :
  forall P Q R:Prop, (P->Q)->(Q->R)->P->R.
Proof.
  intros P Q R PQH QRH PH.
  apply QRH, PQH.
  assumption.
Qed.

Lemma imp_perm :
  forall P Q R:Prop, (P->Q->R)->(Q->P->R).
Proof.
  intros P Q R PQRH QH PH.
  apply PQRH; assumption.
Qed.

Lemma ignore_Q :
  forall P Q R:Prop, (P->R)->P->Q->R.
Proof.
  intros P Q R PRH PH QH.
  apply PRH.
  assumption.
Qed.

Lemma delta_imp :
  forall P Q:Prop, (P->P->Q)->P->Q.
Proof.
  intros P Q PPQH PH.
  apply PPQH; assumption.
Qed.

Lemma delta_impR :
  forall P Q:Prop, (P->Q)->(P->P->Q).
Proof.
  intros P Q PQH PH PH2.
  apply PQH.
  assumption.
Qed.

Lemma diamond :
  forall P Q R T:Prop,
  (P->Q)->(P->R)->(Q->R->T)->P->T.
Proof.
  intros P Q R T PQH PRH QRTH PH.
  apply QRTH.
  apply PQH.
  assumption.
  apply PRH.
  assumption.
Qed.

Lemma weak_peirce :
forall P Q:Prop, ((((P->Q)->P)->P)->Q)->Q.
Proof.
  intros P Q H1.
  apply H1.
  intros H2.
  apply H2.
  intros PH.
  apply H1.
  intros H3.
  assumption.
Qed.

(** Exercise 5.2 **)

(** ALREADY DONE THAT WAY... **)

(** Exercise 5.3 **)

Lemma Ex_5_3_1: ~False.
Proof.
  intro H.
  exact H.
Qed.
(* Essentially P->P *)

Lemma Ex_5_3_2: forall P:Prop, ~~~P->~P.
Proof.
  unfold not.
  intros P H1 p.
  apply H1.
  intro H2.
  apply H2.
  assumption.
Qed.
(* Essentially (((P->Q)->Q)->Q)->P->Q *)

Lemma Ex_5_3_3:
  forall P Q:Prop, ~~~P->P->Q.
Proof.
  intros P Q H p.
  assert (~P).
  apply Ex_5_3_2; assumption.
  elim H0; assumption.
Qed.

Lemma Ex_5_3_4:
  forall P Q:Prop, (P->Q)->~Q->~P.
Proof.
  unfold not.
  intros p q H1 H2 H3.
  apply H2, H1, H3.
Qed.
(* Essentially (P->Q)->(Q->R)->P->R *)

Lemma Ex_5_3_5:
  forall P Q R:Prop, (P->Q)->(P->~Q)->P->R.
Proof.
  intros P Q R H1 H2 H3.
  elim H2.
  assumption.
  apply H1; assumption.
Qed.

(** Exercise 5.4 **)

Definition dyslexic_imp :=
  forall P Q:Prop, (P->Q)->(Q->P).

Definition dyslexic_contrap :=
  forall P Q:Prop, (P->Q)->(~P->~Q).

Theorem dyslexic_imp_implies_false:
  dyslexic_imp -> False.
Proof.
  unfold dyslexic_imp.
  intro H.
  assert ((False->~False)->~False->False) as H1.
  apply H.
  apply H1.
  intro H2.
  elim H2.
  intro H2.
  assumption.
Qed.

Theorem dyslexic_contrap_implies_flase:
  dyslexic_contrap -> False.
Proof.
  unfold dyslexic_contrap.
  intro H.
  assert
    ((False->~False)->~False->~~False) as H1.
  apply H.
  apply H1.
  intro H2; elim H2.
  intro H2; assumption.
  intro H2; assumption.
Qed.

(** Exercise 5.5 **)

Theorem Ex_5_5:
  forall (A:Set)(a b c d:A),
  a=c \/ b=c \/ c=c \/ d=c.
Proof.
  intros A a b c d.
  right; right; left.
  reflexivity.
Qed.

(** Exercise 5.6 **)

Theorem Ex_5_6_a:
  forall A B C:Prop, A/\(B/\C)->(A/\B)/\C.
Proof.
  intros A B C H.
  repeat split; apply H.
Qed.

Theorem Ex_5_6_b:
  forall A B C D:Prop,
  (A->B)/\(C->D)/\A/\C -> B/\D.
Proof.
  intros A B C D H.
  elim H.
  split.
  (* It's not very nice to use auto names *)
  apply H0.
  apply H.
  repeat apply H1.
Qed.

Theorem Ex_5_6_c: forall A:Prop, ~(A/\~A).
Proof.
  intros A H.
  repeat apply H.
Qed.

Theorem Ex_5_6_d:
  forall A B C:Prop, A\/(B\/C)->(A\/B)\/C.
Proof.
  intros A B C H.
  elim H.
  intro H1; repeat left; assumption.
  intro H1; elim H1.
  intro H2; left; right; assumption.
  intro H2; repeat right; assumption.
Qed.

Theorem Ex_5_6_e:
  forall A:Prop, ~~(A\/~A).
Proof.
  unfold not.
  intros A H.
  elim H.
  right.
  intro H1.
  apply H.
  left.
  assumption.
Qed.

Theorem Ex_5_6_f:
  forall A B:Prop, (A\/B)/\~A -> B.
Proof.
  intros A B H.
  elim H.
  intros H1 H2.
  elim H1.
  intro H3.
  contradiction.
  intro H3.
  assumption.
Qed.

(** Exercise 5.7 **)

Definition peirce :=
  forall P Q:Prop, ((P->Q)->P)->P.

Definition classic :=
  forall P:Prop, ~~P->P.

Definition excluded_middle :=
  forall P:Prop, P\/~P.

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

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

Lemma peirce_implies_classic:
  peirce -> classic.
Proof.
  unfold peirce, classic.
  intro H.
  assert (forall P:Prop,
          ((P->False)->P)->P) as H1.
  intro P.
  apply H.
  intros P H2.
  apply H1.
  intro H3.
  contradiction.
Qed.

Lemma nn_excluded_middle:
  forall P:Prop, ~~(P\/~P).
Proof.
  intros P H.
  assert (~P) as H1.
  intro H2.
  apply H.
  left; assumption.
  assert (~~P).
  intro H2.
  apply H.
  right; assumption.
  contradiction.
Qed.

Lemma classic_implies_excluded_middle:
  classic -> excluded_middle.
Proof.
  unfold classic, excluded_middle.
  intros H P.
  assert (~~(P\/~P)) as H1.
  apply nn_excluded_middle.
  apply H; assumption.
Qed.

Lemma excluded_middle_implies_dmnan:
  excluded_middle -> de_morgan_not_and_not.
Proof.
  unfold excluded_middle, de_morgan_not_and_not.
  intros H P Q.
  assert (P\/~P) as H1.
  apply H.
  assert (Q\/~Q) as H2.
  apply H.
  elim H1.
  elim H2.
  intros; left; assumption.
  intros; left; assumption.
  elim H2.
  intros; right; assumption.
  intros H3 H4 H5.
  assert (~P/\~Q).
  split; assumption.
  contradiction.
Qed.

Lemma modus_tollens:
  forall P Q:Prop, (P->Q)->(~Q->~P).
Proof.
  intros P Q H1 H2 H3.
  assert Q as H4.
  apply H1, H3.
  contradiction.
Qed.

Lemma dmnan_implies_implies_to_or:
  de_morgan_not_and_not -> implies_to_or.
Proof.
  unfold de_morgan_not_and_not, implies_to_or.
  intros H P Q.
  intro H1.
  apply H.
  intro H2.
  assert (~Q->~P) as H3.
  apply modus_tollens; assumption.
  assert (~P); apply H3.
  apply H2.
  apply H2.
  assert (~~P) as H4.
  apply H2.
  contradiction.
Qed.

Lemma implies_to_or_implies_peirce:
  implies_to_or -> peirce.
Proof.
  unfold implies_to_or, peirce.
  intros H1 P Q.
  assert (~P\/P) as H2.
  apply H1; intro H3; assumption.
  elim H2.
  intros H4 H5.
  apply H5; intro H6; contradiction.
  intros H7 H8; assumption.
Qed.

Lemma five_circ_impl_implies_equiv:
  forall P Q R S T:Prop,
  (P->Q)/\(Q->R)/\(R->S)/\(S->T)/\(T->P) ->
  (P<->Q)/\(Q<->R)/\(R<->S)/\(S<->T).
Proof.
  intros P Q R S T H.
  repeat split.
  apply H. intro H'; do 4 apply H; assumption.
  apply H. intro H'; do 4 apply H; assumption.
  apply H. intro H'; do 4 apply H; assumption.
  apply H. intro H'; do 4 apply H; assumption.
Qed.

Theorem classical_axioms_equiv:
  (peirce <-> classic) /\
  (classic <-> excluded_middle) /\
  (excluded_middle <-> de_morgan_not_and_not) /\
  (de_morgan_not_and_not <-> implies_to_or).
Proof.
  apply five_circ_impl_implies_equiv.
  repeat split.
  apply peirce_implies_classic.
  apply classic_implies_excluded_middle.
  apply excluded_middle_implies_dmnan.
  apply dmnan_implies_implies_to_or.
  apply implies_to_or_implies_peirce.
Qed.

(** Exercise 5.8 **)

(* repeat idtac succeeds doing nothing and
   repeat fail fails when first tried *)

(** Exercise 5.9 **)

Section ex_5_9.

  Hypothesis A:Set.
  Hypothesis P Q:A->Prop.

  Lemma ex_5_9_a:
    (exists x:A, P x \/ Q x) ->
    (ex P) \/ (ex Q).
  Proof.
    intro H1.
    elim H1.
    intros H2 H3.
    elim H3.
    intro H4; left; exists H2; apply H4.
    intro H5; right; exists H2; apply H5.
  Qed.

  Lemma ex_5_9_b:
    (ex P)\/(ex Q) -> exists x:A, P x \/ Q x.
  Proof.
    intro H1.
    elim H1.
    intro H2; elim H2; intros H3 H4; exists H3.
    left; assumption.
    intro H2; elim H2; intros H3 H4; exists H3.
    right; assumption.
  Qed.

  Lemma ex_5_9_c:
    (exists  x:A, (forall R:A -> Prop, R x)) ->
    2 = 3.
  Proof.
    intro H1.
    elim H1.
    intros H2 H3.
    assert False as H4.
    apply H3 with (R := fun (x:A) => False).
    elim H4.
  Qed.

  Lemma ex_5_9_d:
    (forall x:A, P x) -> ~(exists y:A, ~P y).
  Proof.
    intros H1 H2.
    elim H2.
    intros H3 H4.
    apply H4, H1.
  Qed.

End ex_5_9.

(** Exercise 5.10 **)

Require Import Arith.

Theorem plus_permute2:
  forall n m p:nat, n+m+p = n+p+m.
Proof.
  intros.
  assert (n+(m+p) = n+m+p) as H0.
  apply plus_assoc.
  assert (n+(p+m) = n+p+m) as H1.
  apply plus_assoc.
  rewrite <-H0, <-H1.
  assert (m + p = p + m) as H2.
  apply plus_comm.
  rewrite H2.
  reflexivity.
Qed.

(** Exercise 5.11 **)

Theorem eq_trans:
  forall (A:Type)(x y z:A),
  x = y -> y = z -> x = z.
Proof.
  intros A x y z H0 H1.
  Check eq_ind.
  apply eq_ind with
    (x := y)(y := x)(P := fun a:A => a = z).
  assumption.
  symmetry; assumption.
Qed.

Theorem eq_trans_2:
  forall (A:Type)(x y z:A),
  x = y -> y = z -> x = z.
Proof.
  intros A x y z H0 H1.
  rewrite H0; assumption.
Qed.

(** Exercise 5.12 **)

Definition my_True: Prop :=
  forall P:Prop, P->P.

Definition my_False: Prop :=
  forall P:Prop, P.

Theorem my_I: my_True.
Proof.
  intros P p.
  assumption.
Qed.

Theorem my_False_ind:
  forall P:Prop, my_False -> P.
Proof.
  intros P H.
  apply H.
Qed.

Check (fun (P:Prop)(p:P) => p).

Check (fun (P:Prop)(mf:my_False) => mf P).

(** Exercise 5.13 **)

Definition my_not (P:Prop) := P -> my_False.

Lemma Ex_5_13_1: my_not my_False.
Proof.
  intro H.
  exact H.
Qed.

Lemma Ex_5_13_2:
  forall P:Prop,
  my_not (my_not (my_not P)) -> my_not P.
Proof.
  unfold my_not.
  intros P H1 p.
  apply H1.
  intro H2.
  apply H2.
  assumption.
Qed.

Lemma Ex_5_13_3:
  forall P Q:Prop,
  my_not (my_not (my_not P)) -> P -> Q.
Proof.
  intros P Q H p.
  assert (my_not P).
  apply Ex_5_13_2; assumption.
  (* new ending *)
  assert (my_False) as H1.
  apply H0; assumption.
  apply H1.
Qed.

Lemma Ex_5_13_4:
  forall P Q:Prop,
  (P->Q) -> (my_not Q) -> (my_not P).
Proof.
  unfold my_not.
  intros p q H1 H2 H3.
  apply H2, H1, H3.
Qed.

Lemma Ex_5_13_5:
  forall P Q R:Prop,
  (P->Q)->(P->(my_not Q))->P->R.
Proof.
  intros P Q R H1 H2 H3.
  (* new ending *)
  assert Q as H4.
  apply H1; assumption.
  assert (my_not Q) as H5.
  apply H2; assumption.
  assert (my_False) as H6.
  apply H5, H4.
  apply H6.
Qed.

(** Exercise 5.14 **)

(* Given *)

Section leibniz.
  Set Implicit Arguments.
  Unset Strict Implicit.
  Variable A : Set.

  Definition leibniz (a b:A) : Prop :=
    forall P:A -> Prop, P a -> P b.

  Require Import Relations.

  Theorem leibniz_sym: symmetric A leibniz.
  Proof.
    unfold symmetric, leibniz.
    intros x y H Q.
    apply H.
    trivial.
  Qed.

  (* to prove *)

  Theorem leibniz_refl: reflexive A leibniz.
  Proof.
    unfold reflexive, leibniz.
    intros x P.
    trivial.
  Qed.

  Theorem leibniz_trans: transitive A leibniz.
  Proof.
    unfold transitive, leibniz.
    intros x y z H1 H2 P H3.
    apply H2, H1; assumption.
  Qed.

  Theorem leibniz_equiv: equiv A leibniz.
  Proof.
    unfold equiv.
    repeat split.
    apply leibniz_refl.
    apply leibniz_trans.
    apply leibniz_sym.
  Qed.

  Theorem leibniz_least_reflexive:
    forall R:relation A,
    reflexive A R -> inclusion A leibniz R.
  Proof.
    unfold relation, reflexive, inclusion,
           leibniz.
    intros R H1 x y H2.
    apply H2, H1.
  Qed.

  Theorem leibniz_eq:
    forall a b:A, leibniz a b -> a = b.
  Proof.
    unfold leibniz.
    intros a b H.
    apply H; reflexivity.
  Qed.

  Theorem leibniz_ind:
    forall (x:A)(P:A->Prop),
    P x -> forall y:A, leibniz x y -> P y.
  Proof.
    unfold leibniz.
    intros x P H1 y H2.
    apply H2; assumption.
  Qed.

  Unset Implicit Arguments.

End leibniz.

(** Exercise 5.15 **)

(* Definitions given *)

Definition my_and (P Q:Prop) :=
  forall R:Prop, (P->Q->R)->R.

Definition my_or (P Q:Prop) :=
  forall R:Prop, (P->R)->(Q->R)->R.

Definition my_ex (A:Set)(P:A->Prop) :=
  forall R:Prop, (forall x:A, P x -> R)->R.

(* To prove *)

Lemma ex_5_15_1:
  forall P Q:Prop, my_and P Q -> P.
Proof.
  unfold my_and.
  intros P Q H.
  apply H.
  intros p q; assumption.
Qed.

Lemma ex_5_15_2:
  forall P Q:Prop, my_and P Q -> Q.
Proof.
  unfold my_and.
  intros P Q H.
  apply H.
  intros p q; assumption.
Qed.

Lemma ex_5_15_3:
  forall P Q R:Prop,
  (P->Q->R) -> my_and P Q -> R.
Proof.
  unfold my_and.
  intros P Q R H1 H2.
  apply H2; assumption.
Qed.

Lemma ex_5_15_4:
  forall P Q:Prop, P -> my_or P Q.
Proof.
  unfold my_or.
  intros P Q p R.
  intros H1 H2.
  apply H1; assumption.
Qed.

Lemma ex_5_15_5:
  forall P Q:Prop, Q -> my_or P Q.
Proof.
  unfold my_or.
  intros P Q q R.
  intros H1 H2.
  apply H2; assumption.
Qed.

Lemma ex_5_15_6:
  forall P Q R:Prop,
  (P->R) -> (Q->R) -> my_or P Q -> R.
Proof.
  unfold my_or.
  intros P Q R H1 H2 H3.
  apply H3; assumption.
Qed.

Lemma ex_5_15_7:
  forall P:Prop, my_or P my_False -> P.
Proof.
  unfold my_or, my_False.
  intros P H1.
  apply H1; trivial.
  intros H2.
  apply H2.
Qed.

Lemma ex_5_15_8:
  forall P Q:Prop, my_or P Q -> my_or Q P.
Proof.
  unfold my_or.
  intros P Q H1 R H2 H3.
  apply H1; assumption.
Qed.

Lemma ex_5_15_9:
  forall (A:Set)(P:A->Prop)(a:A),
  P a -> my_ex A P.
Proof.
  unfold my_ex.
  intros A P a H1 R H2.
  apply H2 with (x := a), H1.
Qed.

Lemma ex_5_15_10:
  forall (A:Set)(P:A->Prop),
  my_not (my_ex A P) ->
  forall a:A, my_not (P a).
Proof.
  unfold my_ex, my_not.
  intros A P H1 a H2.
  apply H1.
  intros R H3.
  apply H3 with (x := a).
  assumption.
Qed.

(** Exercise 5.16 **)

(* Given *)

Definition my_le (n p:nat) :=
  forall P:nat -> Prop,
  P n -> (forall q:nat, P q -> P (S q)) -> P p.

(* To prove *)

Lemma my_le_n:
  forall n:nat, my_le n n.
Proof.
  unfold my_le.
  intros n P H1 _; assumption.
Qed.

Lemma my_le_S:
  forall n p:nat, my_le n p -> my_le n (S p).
Proof.
  unfold my_le.
  intros n p H1 P H2 H3.
  apply H3, H1.
  assumption.
  exact H3.
Qed.

Lemma my_le_le:
  forall n p:nat, my_le n p -> n <= p.
Proof.
  unfold my_le.
  intros n p H1.
  apply H1.
  apply le_n.
  apply le_S.
Qed.