Require Import Setoid.
Require Import Morphisms.

Set Implicit Arguments.
Require List.

Inductive nelist (A : Type) : Type :=
  | nebase (e : A)
  | necons (e : A) (l : nelist A).

Fixpoint length {A} (l : nelist A) :=
  match l with
    | nebase _ ⇒ 1
    | necons _ l´ ⇒ S (length l´)
  end.

Fixpoint nelist2list {A} (l : nelist A) : list A :=
  match l with
    | nebase e ⇒ cons e nil
    | necons e l´ ⇒ cons e (nelist2list l´)
  end.


Fixpoint map {A B : Type} (f : A → B) l :=
  match l with
    | nebase e ⇒ nebase (f e)
    | necons e l´ ⇒ necons (f e) (map f l´)
  end.

Definition fold_left {A B : Type} (f : A → B → A) :=
fix fold_left (l : nelist B) (a0 : A) {struct l} : A :=
  match l with
  | nebase e ⇒ f a0 e
  | necons b t ⇒ fold_left t (f a0 b)
  end.

Definition fold_right {A B : Type} (f : B → A → A) (a0 : A) :=
  fix fold_right (l : nelist B) : A :=
  match l with
  | nebase b ⇒ f b a0
  | necons b t ⇒ f b (fold_right t)
  end.

Fixpoint combine {A B : Type} (l : nelist A) (l´ : nelist B) {struct l} : nelist (A × B) :=
  match l, l´ with
    | nebase a, nebase b ⇒ nebase (a, b)
    | nebase a, necons b lb ⇒ nebase (a, b)
    | necons a la, nebase b ⇒ nebase (a, b)
    | necons a la, necons b lb ⇒ necons (a, b) (combine la lb)
  end.

Definition alls {A B} c (l : nelist A) : nelist B := map (fun _ ⇒ c) l.

Fixpoint In {A : Type} (x : A) (l : nelist A): Prop :=
  match l with
    | nebase e ⇒ x = e
    | necons e l´ ⇒ x = e ∨ In x l´
  end.

Inductive Forall {A : Type} (P : A → Prop) : nelist A → Prop :=
  | Forall_nil : ∀ x : A, P x → Forall P (nebase x)
  | Forall_cons : ∀ (x : A) (l : nelist A), P x → Forall P l → Forall P (necons x l).

Inductive Forall2 {A B : Type} (R : A → B → Prop) : nelist A → nelist B → Prop :=
  | Forall2_nil : ∀ x y, R x y → Forall2 R (nebase x) (nebase y)
  | Forall2_cons : ∀ x y l l´, R x y → Forall2 R l l´ → Forall2 R (necons x l) (necons y l´).

Inductive Exists {A : Type} (P : A → Prop) : nelist A → Prop :=
  | Exists_base : ∀ x, P x → Exists P (nebase x)
  | Exists_cons_hd : ∀ x l, P x → Exists P (necons x l)
  | Exists_cons_tl : ∀ x l, Exists P l → Exists P (necons x l).

Inductive NoDup {A : Type} : nelist A → Prop :=
    NoDup_base : ∀ x, NoDup (nebase x)
  | NoDup_cons : ∀ x l, ¬In x l → NoDup l → NoDup (necons x l).

Ltac inv H := inversion H; subst; clear H.

Lemma in_necons_spec:
  ∀ T xs x (y: T),
    In x (necons y xs) ↔ y = x ∨ In x xs.
Proof.
  induction xs; [firstorder|].
  split; intro H.
  - change (x = y ∨ In x (necons e xs)) in H.
    destruct H; [symmetry in H; now auto|].
    apply IHxs in H.
    destruct H; [subst e|]; simpl; now auto.
  - destruct H.
    subst y; simpl; now auto.
    apply IHxs in H.
    destruct H; [symmetry in H|]; simpl; now auto.
Qed.

Lemma diff_length_nebase_necons : ∀ {A B} (a : A) (b : B) l, length (nebase a) ≠ length (necons b l).
Proof. intros A B a b [? | ? ?]; simpl; discriminate. Qed.

Lemma nelist2list_non_empty : ∀ A (l : nelist A), nelist2list l ≠ nil.
Proof. intros A [e | e l]; simpl; discriminate. Qed.

Lemma nelist2list_In : ∀ {A} (x : A) l, List.In x (nelist2list l) ↔ In x l.
Proof. intros A x l. induction l; simpl; try rewrite IHl; intuition. Qed.

Lemma map_compat {A B : Type} : Proper ((eq ==> eq) ==> eq ==> eq) (@map A B).
Proof. intros f g Hfg l l´ Hl. subst l´. induction l; simpl; f_equal; auto. Qed.

Lemma map_compose:
  ∀ A B C (f: A → B)(g: B → C) xs,
    map g (map f xs) = map (fun x ⇒ g (f x)) xs.
Proof.
  intros until xs.
  induction xs as [|x xs IH]; simpl; congruence.
Qed.

Definition injective {A B} (f : A → B) := ∀ x y, f x = f y → x = y.

Lemma map_In : ∀ {A B : Type} (f : A → B), injective f →
  ∀ l x, In (f x) (map f l) ↔ In x l.
Proof.
intros A B f Hf l x. induction l as [e | e l]; simpl.
+ split; intro Hin; inversion Hin; trivial; now apply Hf.
+ rewrite IHl. firstorder. subst. tauto.
Qed.

Lemma map_eq_nebase : ∀ {A B : Type} (f : A → B) l y, map f l = nebase y ↔ ∃ x, l = nebase x ∧ f x = y.
Proof.
intros A B f l y. destruct l; simpl; split; intro H; decompose [ex and] H || inversion_clear H; subst; eauto.
- inversion H1. now subst.
- discriminate.
Qed.

Lemma map_eq_necons : ∀ {A B : Type} (f : A → B) l y l´,
  map f l = necons y l´ ↔ ∃ x l´´, l = necons x l´´ ∧ f x = y ∧ map f l´´ = l´.
Proof.
intros A B f l y l´. destruct l; simpl; split; intro H; decompose [ex and] H || inversion_clear H; subst; eauto.
- discriminate.
- inversion H0. now subst.
Qed.

Lemma map_length : ∀ {A B : Type} (f : A → B) l, length (map f l) = length l.
Proof. intros A B f l. induction l; simpl; auto. Qed.

Lemma nelist2list_map : ∀ {A B : Type} (f : A → B) l,
  nelist2list (map f l) = List.map f (nelist2list l).
Proof. intros A B f l. induction l; simpl; try rewrite IHl; reflexivity. Qed.

Lemma Forall_forall : ∀ {A : Type} P l, Forall P l ↔ ∀ x : A, In x l → P x.
Proof.
intros A P l. induction l; simpl.
+ split; intro Hin.
  - intros. subst. now inversion_clear Hin.
  - constructor. now apply Hin.
+ split; intro Hin.
  - intros. inversion_clear Hin. rewrite IHl in ×. destruct H; subst; auto.
  - constructor.
    × apply Hin. now left.
    × rewrite IHl. intros. apply Hin. auto.
Qed.

Lemma nelist2list_Forall : ∀ {A} P (l : nelist A), List.Forall P (nelist2list l) ↔ Forall P l.
Proof. intros A P l. rewrite Forall_forall, List.Forall_forall. now setoid_rewrite nelist2list_In. Qed.

Lemma Forall_map : ∀ {A B} (f : A → B) P l, Forall P (map f l) ↔ Forall (fun x ⇒ P (f x)) l.
Proof. intros A B f P l. induction l; split; intro Hl; inv Hl; constructor; try rewrite IHl in *; auto. Qed.

Lemma Forall2_length: ∀ {A B : Type} (R : A → B → Prop) l1 l2,
  Forall2 R l1 l2 → length l1 = length l2.
Proof. intros A B R l1. induction l1; intros [|] Hall; inversion_clear Hall; simpl; auto. Qed.

Lemma Forall2_det : ∀ {A B : Type} (R : A → B → Prop),
  (∀ x y1 y2, R x y1 → R x y2 → y1 = y2) →
  ∀ xs ys1 ys2, Forall2 R xs ys1 → Forall2 R xs ys2 → ys1 = ys2.
Proof.
intros A B R HR xs. induction xs as [x | x xs]; intros ys1 ys2 Hall1 Hall2.
- inv Hall1. inv Hall2. f_equal. eauto.
- inv Hall1. inv Hall2. f_equal; eauto.
Qed.

Lemma Forall2_map_l : ∀ {A B C} (f : A → B) (R : B → C → Prop) l1 l2,
  Forall2 R (map f l1) l2 ↔ Forall2 (fun x y ⇒ R (f x) y) l1 l2.
Proof.
intros A B C f R l1. induction l1; intro l2; split; intro Hl; inv Hl; simpl;
now constructor; trivial; now apply IHl1.
Qed.

Lemma Forall2_map_r : ∀ {A B C} (f : A → C) (R : B → C → Prop) l1 l2,
  Forall2 R l1 (map f l2) ↔ Forall2 (fun x y ⇒ R x (f y)) l1 l2.
Proof.
intros A B C f R l1 l2. revert l1. induction l2; intro l1; split; intro Hl; inv Hl; simpl;
now constructor; trivial; now apply IHl2.
Qed.

Corollary Forall2_map_lr : ∀ {A B C D} (f : A → C) (g : B → D) (R : C → D → Prop) l1 l2,
  Forall2 R (map f l1) (map g l2) ↔ Forall2 (fun x y ⇒ R (f x) (g y)) l1 l2.
Proof. intros. now rewrite Forall2_map_l, Forall2_map_r. Qed.

Lemma Forall2_eq : ∀ {A} l1 l2, Forall2 (@eq A) l1 l2 ↔ l1 = l2.
Proof.
intros A l1 l2. split; intro Heq; subst.
- revert l2 Heq. induction l1; intros l2 Heq; inv Heq; trivial; f_equal; auto.
- induction l2; constructor; auto.
Qed.

Lemma Exists_exists : ∀ {A : Type} P l, Exists P l ↔ ∃ x : A, In x l ∧ P x.
Proof.
intros A P l. induction l; simpl.
× split; intro Hin.
  + ∃ e. inversion_clear Hin. tauto.
  + destruct Hin as [? [? ?]]. subst. now constructor.
× split; intro Hin.
  + inversion_clear Hin.
    - ∃ e. tauto.
    - rewrite IHl in H. destruct H as [x ?]. ∃ x. tauto.
  + destruct Hin as [x [[? | ?] ?]].
    - subst. now constructor 2.
    - constructor 3. rewrite IHl. ∃ x. tauto.
Qed.

Lemma nelist2list_Exists : ∀ {A} P (l : nelist A), List.Exists P (nelist2list l) ↔ Exists P l.
Proof. intros A P l. rewrite Exists_exists, List.Exists_exists. now setoid_rewrite nelist2list_In. Qed.

Lemma nelist2list_NoDup : ∀ {A} (l : nelist A), List.NoDup (nelist2list l) ↔ NoDup l.
Proof.
intros A l. induction l; simpl.
- split; intro Hnodup; inv Hnodup; repeat constructor; intuition.
- split; intro Hnodup; inv Hnodup; repeat constructor;
  now rewrite ?IHl in *; try (rewrite <- nelist2list_In || rewrite nelist2list_In).
Qed.