(* General utility file, should break up into smaller modules, e.g. maps, Sets,
etc. *)
Require Export Unicode.Utf8.
Require Export JRWTactics.
Require Export CpdtTactics.
Require Export List.
Require Export EqNat Arith.Peano_dec.

Require Import Basics EqNat Logic.Decidable.
Require Import Logic.ProofIrrelevance.
Require Import Compare_dec.
Require Export set.
Export ListNotations.

Ltac induce h := (prep_induction h; induction h; intros; subst).
Ltac invert h := (inversion h; subst; clear h).

Infix "∈" := In (at level 30).
Notation "x ∉ y" := (¬ In x y) (at level 30).

Definition Map a b := list (a * b).

Lemma wrap : forall A B (f:A -> B), f = fun a:A => f a. auto. Qed.

Notation " a ⊆ b " := (subset a b) (at level 30).
Definition rel (A : Type) := A → A → Prop.
Definition relation (A B : Type) := A → B → Prop.
Definition equiv {A B} := ∀ (a a':A) (b b':B) (ra : rel A) (rb : rel B)
  (e : relation A B), e a b → ra a a' → rb b b' → e a' b'.

Lemma in_comm {a} : ∀ l l' (x:a) , In x (l ++ l') <-> In x (l' ++ l).
split; intros; rewrite in_app_iff; rewrite or_comm; rewrite <- in_app_iff;
assumption. Qed.

Lemma not_impl : ∀ p q : Prop, ¬ q → (p → q) → ¬ p.
unfold not. intros. apply H. apply H0. assumption. Qed.

Definition fmap_option {a b} : (a → b) → option a → option b := λ f o,
  match o with
  | Some m => Some (f m)
  | None => None
  end.

Definition seq_option {a b} : option (a → b) → option a → option b := λ f o,
  match f, o with
    | Some g, Some a => Some (g a)
    | _, _ => None
  end.

Fixpoint concat {a} (l: list (list a)) : list a := match l with
  | nil => nil
  | cons h t =>  h ++ concat t
  end.

Notation "f <$> x" := (fmap_option f x) (at level 30).
Notation "f <*> x" := (seq_option f x) (at level 40).

(* We use index of element in a list to imlement and reason about conversion
   between standard terms and deBruijn terms *)
Fixpoint indexofhelper {a} (l:list a) (n:nat) (p:a → bool) := match l with
  | [] => None
  | x::xs => if p x then Some n else indexofhelper xs (S n) p
  end.

Definition indexof {a} (p:a → bool) (l:list a) : option nat :=
  indexofhelper l 0 p.

Definition indexofn (n:nat) (l:list nat) : option nat := indexof (beq_nat n) l.

Lemma indexofh_length {a} : ∀ p l n m, @indexofhelper a l m p = Some n → n < m + length l.
induction l; intros. inversion H. simpl. unfold indexof in H. unfold
indexofhelper in H. destruct (p a0). inversion H. subst. unfold lt. rewrite <-
Plus.plus_Snm_nSm. apply Plus.le_plus_l. rewrite <- Plus.plus_Snm_nSm.
apply IHl. assumption. Qed.

Lemma indexof_length {a} : ∀ p l n, @indexof a p l = Some n → n < length l.
intros. unfold indexof in H. apply indexofh_length in H. auto. Qed.

Lemma indexofn_inh : ∀ x xs n m, indexofhelper xs m (beq_nat x) = Some n → In x xs.
induction xs; intros. inversion H. unfold indexofn in H. unfold indexofhelper in H.
destruct (beq_nat x a) eqn:be. simpl. apply beq_nat_true in be. subst. auto.
apply IHxs in H. simpl. auto. Qed.

Lemma indexofn_in : ∀ x xs n, indexofn x xs = Some n → In x xs.
intros. unfold indexofn in H. unfold indexof in H. apply indexofn_inh in H.
assumption. Qed.

Lemma in_indexofnh : ∀ x xs m, In x xs → ∃ n, indexofhelper xs m (beq_nat x) = Some n.
induction xs; intros. inversion H. inversion H. subst. exists m. unfold
indexofn. unfold indexof. unfold indexofhelper. rewrite <- beq_nat_refl. auto.
apply IHxs with (m:=S m) in H0. destruct H0. simpl. destruct (beq_nat x a)
eqn:bn. exists m. reflexivity. exists x0. auto. Qed.

Lemma in_indexofn : ∀ x xs, In x xs → ∃ n, indexofn x xs = Some n.
intros. apply in_indexofnh with (m:=0) in H. destruct H. exists x0. auto. Qed.

Lemma add_n_m_n0 : ∀ m n, m + n = m → n = 0.
intros. induction m.
- simpl in H. assumption.
- simpl in H. inversion H. apply IHm in H1. assumption.
Qed.
Lemma filter_app {A} : ∀ xs ys (p:A → bool), filter p xs ++ filter p ys = filter p (xs ++ ys).
intros. induction xs. reflexivity. simpl. destruct (p a). simpl.
rewrite <- IHxs. reflexivity. apply IHxs. Qed.

Lemma or_imp : forall a b c : Prop, (a \/ b -> c) <-> (a -> c) /\ (b -> c).
intros. split; intros. split; intros.  apply or_introl with (B:=b) in H0. apply H in H0.
assumption. apply or_intror with (A:=a) in H0. apply H in H0. assumption.
destruct H. destruct H0. apply H in H0. assumption.  apply H1 in H0. assumption.
Qed.

Lemma cons_neq {A} : ∀ (x:A) xs, xs <> x::xs.
intros. induction xs. unfold not. intros. inversion H. unfold not. intros.
inversion H. apply IHxs in H2. auto. Qed.

Lemma app_eq_l {A} : ∀ a b c : list A, a ++ b = a ++ c → b = c.
intros. induction a. rewrite app_nil_l in H. rewrite app_nil_l in H. assumption.
inversion H. apply IHa; assumption. Qed.

Lemma app_eq_r {A} : ∀ b a c : list A, a ++ b = c ++ b → a = c.
intros b. induction b; intros. rewrite app_nil_r in H. rewrite app_nil_r in H.
assumption. assert (b = nil ++ b). reflexivity. rewrite H0 in H. rewrite
app_comm_cons in H. rewrite app_assoc in H. rewrite app_assoc in H. apply IHb in
H. apply app_inj_tail in H. destruct H. assumption. Qed.

Definition subset' {A} (l m : list A) : Prop := forall a, In a l -> In a m.

Definition forall_and {A} : forall (x y:A -> Prop), (forall a:A, x a /\ y a) <-> (forall
a:A, x a) /\ (forall a:A, y a).
intros. split;  intros. split; intros; specialize H with a; destruct H; assumption.
destruct H.  specialize H with a. specialize H0 with a. split; assumption. Qed.

Definition forall_or {A} : forall (x y z:A -> Prop), (forall a:A, x a \/ y a -> z a) <-> (forall
a:A, x a -> z a) /\ (forall a:A, y a -> z a).
intros. split;  intros. split; intros. apply or_introl with (B:=y a) in H0.
apply H in H0. assumption. apply or_intror with (A:=x a) in H0. apply H in H0.
assumption. destruct H. destruct H0. apply H in H0. assumption. apply H1 in H0.
assumption. Qed.

Fixpoint forevery {a} (l:list a) (p : a → Prop) : Prop := match l with
  | cons x xs => p x ∧ forevery xs p
  | nil => True
  end.

Lemma forevery_in {A} : ∀ l p, forevery l p → ∀ x:A, In x l → p x.
induction l; intros.
- inversion H0.
- simpl in H. destruct H. inversion H0. subst. assumption. apply IHl;
  assumption. Qed.

Lemma in_forevery {A} : ∀ l (p:A→Prop), (∀ x:A, In x l → p x) → forevery l p.
induction l; intros.
- simpl. auto.
- simpl. split. simpl in H. apply H. auto. apply IHl. intros. apply H. simpl.
  auto. Qed.

Lemma for_in_iff {A} : ∀ l p, forevery l p ↔ (∀ x :A, In x l → p x).
intros. split. apply forevery_in. apply in_forevery. Qed.

Inductive related_lists {a b} (r : a → b → list a → list b → Prop) : list a → list b → Prop :=
  | rel_nil : related_lists r nil nil
  | rel_cons : ∀ x xs y ys, r x y xs ys → related_lists r xs ys → related_lists r (x::xs) (y::ys).

Lemma forevery_map {A B} : ∀ (f:A→B) xs p, forevery (map f xs) p = forevery xs (compose p f).
intros. induction xs. simpl. auto. simpl. f_equal. assumption. Qed.

Definition domain {a b} (m : Map a b) : list a := map (@fst a b) m.
Definition codomain {a b} (m : Map a b) : list b := map (@snd a b) m.

Definition isfresh (l: list nat) (n : nat) : Prop := ¬ In n l.
Axiom fresh : ∀ (l:list nat), {n | isfresh l n}.
Definition fresh' (x: nat) (Φ : list nat) :=
  ∃ p, fresh Φ = exist (isfresh Φ) x p.

Definition homotopy {A B} (f g : A→B) := ∀ x, f x = g x.
Notation "f ~ g" := (homotopy f g) (at level 60).

Lemma map_homo {A B} : ∀ (f g:A→B), f ~ g → map f ~ map g.
unfold homotopy. intros. induction x. auto. simpl. rewrite H. rewrite IHx. auto.
Qed.

Inductive unique {a} : list a → Prop :=
  | unil : unique nil
  | ucons : ∀ x xs, ¬ In x xs → unique xs → unique (cons x xs).
(*
Lemma indexofhelper_nth : ∀ xs x n m, unique xs →
  indexofhelper xs m (beq_nat x) = Some (m+n)
                ↔
      nth_error xs n = Some x.
induction xs. split; intros; auto. crush. apply nth_error_In in H0. inversion H0.
split; intros. simpl in H0. destruct (beq_nat x a) eqn:xa. inversion H0. symmetry
in H2. apply add_n_m_n0 in H2. subst. simpl. apply beq_nat_true in xa. subst.
reflexivity. inversion H. subst.
*)

Definition fmap {A B C} (f : B -> C) : A * B -> A * C  := fun x => match x with
  | (a, b) => (a, f b) end.

Definition forevery_codomain {a b} (m:Map a b) (p : b → Prop) : Prop := forevery
  m (λ x, match x with (k,v) => p v end).

Lemma snd_fmap {A} : (λ x:A*nat, pred (snd (fmap S x))) ~ (λ x:A*nat, snd x).
intros. unfold homotopy. intros. destruct x. reflexivity. Qed.

Lemma domain_fmap : forall A B C (f:B->C) (xs:Map A B),  domain (map
(fmap f) xs) = domain xs.
intros. induction xs. crush. crush. Qed.

Lemma domain_inf {a b} : ∀ xs (y:a) (m m':b) ys, domain (xs ++ (y,m) :: ys) =
                                   domain (xs ++ (y,m') :: ys).
intros. unfold domain. rewrite map_app. simpl. rewrite map_app. simpl.
reflexivity. Qed.

Lemma domain_inf' {a b} : ∀ xs zs (y:a) (m m':b) ys, domain (xs ++ zs ++ (y,m) :: ys) =
                                   domain (xs ++ zs ++ (y,m') :: ys).
intros. unfold domain. rewrite map_app. assert (di:=@domain_inf a). unfold
domain in di at 1. rewrite di with (m':=m'). unfold domain. rewrite <- map_app.
reflexivity. Qed.

Lemma in_inf {a} : ∀ (x:a) xs ys, In x (xs ++ x :: ys).
intros. apply in_or_app. apply or_intror. simpl. auto. Qed.

Lemma inf_indomain {a b} : ∀ (k:a) (v:b) ys zs, In k (domain (ys ++ (k,v) :: zs)).
intros. subst. unfold domain. rewrite map_app. apply
in_or_app. apply or_intror. simpl. auto. Qed.

Lemma forevery_app : forall a (xs ys:list a) p, forevery (xs ++ ys) p <->
  forevery xs p ∧ forevery ys p.
  intros. induction xs. simpl. split. auto. intros. destruct H. auto. simpl.
  split. intros. destruct H. apply IHxs in H0. destruct H0. split. auto. auto.
  intros. rewrite and_assoc in H. destruct H. rewrite <- IHxs in H0. auto. Qed.

Lemma subset'_cons {A} : forall (x : A) (l m : list A),
  subset' (x::l) m -> subset' l m.
intros.  unfold subset' in H. unfold In at 1 in H. setoid_rewrite or_imp in H.
apply forall_and in H. destruct H. assumption. Qed.

Lemma subset_eq : forall A (l m : list A), subset' l m <-> subset l m.
intros. induction l. split. intros. unfold subset. auto. intros. unfold subset'.
intros. inversion H0. split; intros. assert (In a (a::l)). unfold In. left.
reflexivity. apply H in H0. unfold subset. split. assumption.
assert (subset' l m). apply subset'_cons in H. assumption. rewrite IHl in H1.
assumption. unfold subset'. unfold subset in H. destruct H. rewrite <- IHl in
H0. unfold In at 1. setoid_rewrite or_imp. rewrite forall_and. split. intros.
rewrite <- H1. assumption. assumption. Qed.

Lemma subset_nil : forall A ms, subset (@nil A) ms.
intros. unfold subset. auto. Qed.

Lemma subset_map {A B} : ∀ xs ys (f:A→B), xs ⊆ ys → map f xs ⊆ map f ys.
intros xs. induction xs; intros. apply subset_nil. intros. simpl in H. simpl.
split. destruct H. apply in_map. assumption. apply IHxs. destruct H. assumption.
Qed.

Lemma subset_nil2 : forall A ms, subset ms (@nil A) -> ms = nil.
intros. rewrite <- subset_eq in H. unfold subset' in H. induction ms.
reflexivity. simpl in H. specialize H with a. destruct H. left. reflexivity.
Qed.

Fixpoint remove (x : nat) (l : list nat) := match l with
  | nil => nil
  | cons y ys => if eq_nat_dec x y then remove x ys else y::remove x ys
  end.

Lemma remove_in : forall (n : nat) ns, ~ In n (remove n ns).
intros. induction ns. auto. unfold remove. destruct (eq_nat_dec n a).
assumption. fold remove. unfold In. unfold not. rewrite not_or_iff. split.
intros. symmetry in H. apply n0 in H. assumption. assumption. Qed.

Lemma remove_app : forall (n : nat) ns ms, remove n (ns ++ ms) = remove n ns ++
remove n ms.
intros. induction ns. auto. simpl. rewrite IHns. destruct (eq_nat_dec n a).
auto.  apply app_comm_cons. Qed.

Lemma remove_idem : forall (n : nat) ns, remove n (remove n ns) = remove n ns.
intros. induction ns. simpl. auto. simpl. destruct (eq_nat_dec n a). assumption.
simpl. destruct (eq_nat_dec n a). apply n0 in e.  inversion e. rewrite IHns.
reflexivity. Qed.

Lemma eq_nat_dec_refl : forall m, eq_nat_dec m m = left eq_refl.
intros. induction m. auto. simpl. rewrite IHm. simpl. reflexivity. Qed.

Lemma eq_dec_refl : forall A (m:A) (eq : ∀ a b:A, {a = b} + {a <> b}) , eq m m = left eq_refl.
intros. destruct (eq m m). assert (∀ p q : m = m, p = q). apply
proof_irrelevance. specialize H with e eq_refl. rewrite H. reflexivity. crush.
Qed.

Lemma eq_nat_dec_neq : forall m n (p : m <> n), eq_nat_dec m n = right p.
intros. destruct (eq_nat_dec m n). unfold not in p. subst. assert (n = n).
reflexivity.  apply p in H. inversion H. assert (p = n0). rewrite
proof_irrelevance with (P := m <> n) (p1 := p) (p2 := n0). reflexivity. subst.
reflexivity. Qed.

Lemma eq_dec_neq : forall A (m n:A) (eq : ∀ a b:A, {a = b} + {a <> b}) (p : m <> n), eq m n = right p.
intros. destruct (eq m n). unfold not in p. subst. assert (n = n).
reflexivity.  apply p in H. inversion H. assert (p = n0). rewrite
proof_irrelevance with (P := m <> n) (p1 := p) (p2 := n0). reflexivity. subst.
reflexivity. Qed.

Lemma remove_dup : forall (n m : nat) ns, remove n (remove m ns) = remove m
(remove n ns).
intros. induction ns. auto. simpl. destruct (eq_nat_dec m a). destruct
(eq_nat_dec n a). rewrite e. rewrite e0. reflexivity. rewrite IHns. rewrite e.
simpl. rewrite eq_nat_dec_refl. reflexivity. destruct (eq_nat_dec n a). rewrite
e. simpl. rewrite eq_nat_dec_refl. rewrite <- e. rewrite IHns. reflexivity.
simpl. destruct (eq_nat_dec n a). apply n1 in e. inversion e. destruct
(eq_nat_dec m a). apply n0 in e. inversion e. rewrite IHns. reflexivity. Qed.

Lemma or_false : forall p : Prop, p \/ False <-> p. intros. split; intros.
destruct H. assumption. inversion H. apply or_introl.  assumption. Qed.

Lemma remove_not_in : forall (n v : nat) ns, n <> v -> (In n (remove v ns) <-> In n ns).
intros. induction ns.  split; intros; inversion H0. split; intros; simpl. simpl
in H0. destruct (eq_nat_dec v a). apply IHns in H0. right. assumption. simpl in
H0. destruct H0. left; assumption. apply IHns in H0. right. assumption. destruct
(eq_nat_dec v a). rewrite IHns. simpl in H0. destruct H0. rewrite H0 in e.
symmetry in e. apply H in e. inversion e. assumption. simpl. simpl in H0.
destruct H0. left. assumption. right. rewrite <- IHns in H0. assumption. Qed.

Lemma subset_tail : forall (xs ys:list nat), subset xs (tl ys) -> subset xs ys.
intros. induction xs. auto. simpl in H. simpl. destruct H. split. destruct ys.
auto. simpl in H. apply in_cons. assumption. apply IHxs in H0. assumption. Qed.

Lemma noteq_comm {A} : forall (m n : A), m <> n -> n <> m.
intros. auto. Qed.

Lemma beq_nat_comm : forall m n, beq_nat n m = beq_nat m n.
intros. destruct (eq_nat_dec m n).  rewrite e. reflexivity. assert (n <> m).
apply noteq_comm in n0. assumption. apply
beq_nat_false_iff in n0. apply beq_nat_false_iff in H. rewrite n0. rewrite H.
reflexivity. Qed.

Lemma let_inline : forall A (b c:A) f, f (let a := b in c) -> let a := b in (f c).
auto. Qed.

Lemma subset_singleton : forall (x y : nat) xs, subset (x::xs) (y::nil) -> x = y.
intros. inversion H. destruct H0. symmetry. assumption. inversion H0. Qed.

Lemma subset_cons {A} : forall (x : A) a l, subset a l -> subset a (x::l). intros.
induction a. auto. inversion H. split. apply in_cons. assumption.
apply IHa in H1. assumption. Qed.

Lemma subset_app_weaken {A} : ∀ xs ys zs : list A, xs ⊆ ys → xs ⊆ (zs ++ ys).
induction zs. auto. intros. simpl. apply subset_cons. apply IHzs. auto. Qed.

Lemma cons_subset {A} : forall (x: A) xs ys, subset xs ys -> subset (x::xs) (x::ys).
intros. unfold subset. simpl. split. left. reflexivity. apply subset_cons.
assumption. Qed.

Lemma subset_remove : forall n ns, subset (remove n ns) ns.
intros. induction ns. apply subset_nil. unfold remove. destruct (eq_nat_dec n
a). fold remove. apply subset_cons. assumption. fold remove. apply cons_subset.
assumption. Qed.

Lemma subset_in_cons : forall (n:nat) ns ms, ~In n ns -> subset ns (n::ms) -> subset ns ms.
intros.  rewrite <- subset_eq. rewrite <- subset_eq in H0. unfold subset' in
H0. unfold In in H0 at 2. unfold subset'. intros. specialize H0 with a.
destruct (eq_nat_dec n a). rewrite <- e in H1. unfold not in H. apply H in H1.
inversion H1. apply H0 in H1. destruct H1. apply n0 in H1. inversion H1.
assumption. Qed.

Lemma symmetry : forall p q : Prop, p = q <-> q = p. intros. split; intros;
symmetry in H; assumption. Qed.

Lemma neq_sym {a} : ∀ x y:a, x <> y → y <> x.
unfold not. intros. symmetry in H0. apply H. assumption.
Qed.

Lemma subset_remove_cons : forall a v vs, subset a (v::vs) <-> subset (remove v a) vs.
intros. split; intros. rewrite <- subset_eq. rewrite <- subset_eq in H. unfold subset' in H.
unfold subset'. simpl in H. intros. specialize H with a0. destruct (eq_nat_dec
a0 v). rewrite e in H. rewrite e in H0. apply remove_in in H0. inversion H0.
assert (a0 <> v). assumption.  apply remove_not_in with (ns:=a) in n. rewrite n
in H0. apply H in H0. destruct H0. symmetry in H0. apply H1 in H0. inversion H0.
assumption.  rewrite <- subset_eq in H. unfold subset' in H. induction a. apply
subset_nil.  simpl. split. simpl in H. destruct (eq_nat_dec v a). left.
assumption. simpl in H. specialize H with a. assert (a = a).  reflexivity. apply
or_introl with (B:=In a (remove v a0)) in H0. apply H in H0. right. assumption.
simpl in H.  destruct (eq_nat_dec v a). apply IHa in H. assumption. simpl in H.
rewrite forall_or in H. destruct H. apply IHa in H0. assumption.
Qed.

Lemma truand : forall a:Prop, True /\ a -> a.
intros. destruct H. auto. Qed.

Lemma app_subset_and {A} : forall xs ys zs: list A, subset (xs ++ ys) zs <-> (subset xs zs /\ subset ys zs).
intros.
induction xs. simpl.
split. intros. auto. intros. destruct H. assumption.
split; intros.
unfold subset in H. destruct H. apply IHxs in H0. destruct H0.
split.
unfold subset. split. assumption. assumption. assumption.
destruct H.
rewrite <- app_comm_cons. unfold subset. split.
unfold subset in H. destruct H. assumption.
apply IHxs.
split. unfold subset in H. destruct H. assumption. assumption.
Qed.

Lemma subset_id {A} : forall xs:list A, subset xs xs.
intros. induction xs. unfold subset. auto. unfold subset. split. unfold In.
auto. apply subset_cons. auto. Qed.

Lemma subset_app_id {A} : forall xs ys zs:list A, subset ys zs -> subset (xs ++ ys) (xs ++ zs) .
intros. induction xs. simpl. assumption. unfold subset. simpl. split. left.
reflexivity. apply subset_cons. assumption. Qed.

Lemma subset_app {A} : forall xs ys zs:list A, subset xs ys -> subset xs (ys ++ zs).
intros. rewrite <- subset_eq. rewrite <- subset_eq in H. unfold subset'. intros. rewrite
in_app_iff.  left. apply H in H0.  assumption. Qed.

Lemma cons_app {A}: forall (x:A) xs, x :: xs = x::nil ++ xs.
intros. rewrite app_nil_l. reflexivity. Qed.

Lemma subset_comm1 {A} : forall xs ys zs:list A, subset (xs ++ ys) zs -> subset (ys ++ xs) zs.
intros. apply app_subset_and. apply and_comm. apply app_subset_and. assumption.
Qed.

Lemma subset_comm2 {A} : forall xs ys zs:list A, subset xs (ys ++ zs) -> subset xs (zs ++ ys).
intros. induction xs. auto. simpl. split. simpl in H. destruct H. apply
in_app_or in H. apply or_comm in H. apply in_or_app in H. assumption. simpl in
H. destruct H. apply IHxs in H0. assumption. Qed.

Lemma subset_trans {A}: forall xs ys zs:list A, subset xs ys -> subset ys zs -> subset xs zs.
intros. induction xs. unfold subset. auto. split. destruct H. rewrite <- subset_eq
in H0. unfold subset' in H0. apply H0 in H. assumption. simpl in H. destruct H.
apply IHxs in H1. assumption. Qed.

Definition set_equiv {A} (xs ys : list A) : Prop := subset xs ys /\ subset ys xs.

Lemma subset_swap {A} : forall (n v : A) vs, set_equiv (n::v::vs) (v::n::vs).
intros. unfold set_equiv. simpl. split; split. right. left. reflexivity. split.
left. reflexivity. repeat (apply subset_cons). apply subset_id. right. left.
reflexivity. split. left. reflexivity. repeat (apply subset_cons). apply
subset_id. Qed.

Definition lookup {a} (x:nat) (l:Map nat a) : option a :=
  match find (λ p, beq_nat x (fst p)) l with
    | None => None
    | Some (k,v) => Some v
  end.

Lemma lookup_head {a} : ∀ x (v:a) h, lookup x ((x,v)::h) = Some v.
intros. unfold lookup. unfold find. simpl. rewrite <- beq_nat_refl. reflexivity.
Qed.

Lemma lookup_head' {a} : ∀ x y (v:a) h, x <> y → lookup x ((y,v)::h) = lookup x h.
intros. unfold lookup. unfold find. simpl. rewrite <- PeanoNat.Nat.eqb_neq in H.
rewrite H. reflexivity. Qed.

Lemma lookup_app' {A} : ∀ x (h h':Map nat A),
  lookup x (h ++ h') = lookup x h ∨ lookup x (h ++ h') = lookup x h'.
intros. induction h. simpl. right. reflexivity.  simpl. unfold lookup. destruct
a. simpl. destruct (eq_nat_dec x n). subst. rewrite <- beq_nat_refl. left.
reflexivity. rewrite <- beq_nat_false_iff in n0. rewrite n0. assumption. Qed.

Lemma lookup_app {A} : ∀ x h h' (a:A), lookup x (h ++ h') = Some a ↔
  lookup x h = Some a ∨ (lookup x h = None ∧ lookup x h' = Some a).
split; intros. induction h. right. split; auto. destruct a0. destruct (eq_nat_dec x n).
subst. unfold lookup. simpl. rewrite <- beq_nat_refl. left. simpl in H. unfold
lookup in H. simpl in H. rewrite <- beq_nat_refl in H. assumption. unfold
lookup. simpl. rewrite <- beq_nat_false_iff in n0. rewrite n0. apply IHh. unfold
lookup in H. simpl in H. rewrite n0 in H. assumption. destruct H. induction h.
inversion H. destruct a0. destruct (eq_nat_dec x n). subst. unfold lookup.
simpl. rewrite <- beq_nat_refl. unfold lookup in H. simpl in H. rewrite <-
beq_nat_refl in H. assumption. unfold lookup. simpl. rewrite <-
beq_nat_false_iff in n0. rewrite n0. unfold lookup in H. simpl in H. rewrite n0
in H. apply IHh. assumption. induction h. simpl. destruct H. assumption.
destruct H. destruct a0.  unfold lookup in H. simpl. simpl in H. destruct
(eq_nat_dec x n). subst. rewrite <- beq_nat_refl in H. inversion H. rewrite <-
beq_nat_false_iff in n0. rewrite n0 in H. unfold lookup. simpl. rewrite n0.
apply IHh. split; auto. Qed.

Lemma unique_toinf {A} : ∀ (a : A) bs cs, unique (bs ++ a :: cs) →
  unique (a :: bs ++ cs).
intros. prep_induction bs. induction bs; intros; simpl in *. assumption.
inversion H. subst. apply IHbs in H3. inversion H3. subst. rewrite in_app_iff in
H2. simpl in H2. apply not_or in H2. destruct H2. apply not_or in H1. destruct
H1. apply ucons. simpl. unfold not. intros. destruct H6. symmetry in H6. apply
H1. assumption. apply H4. assumption. apply ucons. rewrite in_app_iff. unfold
not. intros. destruct H6. apply H0. assumption. apply H2. assumption.
assumption. Qed.

Lemma unique_toinf' {A} : ∀ (a : A) bs cs, unique (a :: bs ++ cs) →
  unique (bs ++ a :: cs).
intros. induction bs; simpl in *. assumption.  inversion H. subst. inversion H3.
subst. simpl in H2. apply not_or in H2. destruct H2. specialize (IHbs (ucons _ _ H1
H5)). apply ucons. rewrite in_app_iff. unfold not. intros. destruct H2. rewrite
in_app_iff in H4. apply not_or in H4. destruct H4. apply H4. assumption. simpl
in H2. destruct H2. apply H0. symmetry. assumption. rewrite in_app_iff in H4.
apply not_or in H4. destruct H4. apply H6. assumption. assumption. Qed.

Lemma unique_app {A} : ∀ (a b:list A), unique (a ++ b) → unique (b ++ a).
intros. prep_induction a. induction a; intros.  rewrite app_nil_r. assumption.
simpl in *. inversion H. subst.  apply unique_toinf' in H. apply IHa in H. simpl
in *. apply unique_toinf' in H. assumption. Qed.

Definition lookup_total {B} : ∀ (m : Map nat B) a, In a (domain m) →
  {b | lookup a m = Some b}.
induction m; simpl; intros. inversion H. unfold lookup. destruct a. simpl.
destruct (beq_nat a0 n) eqn:Heqe. exists b. reflexivity. apply IHm. intuition.
simpl in H0. subst. rewrite <- beq_nat_refl in Heqe. inversion Heqe. Defined.

Definition lookup_codomain {B} : ∀ (m : Map nat B) a b, lookup a m = Some b → In b (codomain m).
intros. induction m. inversion H. simpl. unfold lookup in H. simpl in H.
destruct a0. simpl in H. destruct (beq_nat a n). simpl. inversion H. subst.
auto. apply IHm in H. auto. Defined.

Definition flip {A B C} (f : A → B → C) : B → A → C := fun b a => f a b.

Definition in_domain_lookup {B} := @lookup_total B.

Lemma lookup_domain {b} : ∀ (m : Map nat b) k v, lookup k m = Some v →
  In k (domain m).
intros. induction m. inversion H. unfold lookup in H. simpl in H. destruct a.
simpl in H. destruct (beq_nat k n) eqn:Heqe. inversion H. subst. simpl. apply
or_introl. apply beq_nat_true in Heqe. symmetry in Heqe. assumption. apply IHm
in H. simpl. apply or_intror. assumption. Qed.

Definition tosig {A} : ∀ p:A → Prop, {x | p x} → ∃ x, p x.
intros. destruct X. exists x. assumption. Qed.

Lemma subset_domain_map {b} : ∀ l (m : Map nat b), subset l (domain m) → forevery l (λ k,
  ∃ v, lookup k m = Some v).
intros. induction l. crush. simpl in H. destruct H. apply IHl in H0. simpl.
split. Focus 2. assumption. apply tosig. apply in_domain_lookup. assumption. Qed.

Lemma forevery_codomain_lookup {b} : ∀ (m : Map nat b) p l v, forevery_codomain m p →
  lookup l m = Some v → p v.
intros. induction m. inversion H0. destruct a. destruct (eq_nat_dec l n). subst.
unfold lookup in H0.  simpl in H0.  rewrite <- beq_nat_refl in H0. inversion H0.
subst. unfold forevery_codomain in H.  simpl in H. crush. unfold lookup in H0.
simpl in H0. rewrite <- beq_nat_false_iff in n0. rewrite n0 in H0. unfold
forevery_codomain in H.  simpl in H.  destruct H. apply IHm in H1. assumption.
assumption. Qed.

Lemma forevery_inf {a} : ∀ (xs ys:list a) (y:a) p, forevery (xs ++ y :: ys) p →
  p y.
intros. apply forevery_app in H. crush. Qed.

Lemma forevery_impl {a} : ∀ xs (p p':a→Prop), (∀ a, p a → p' a) → forevery xs p →
  forevery xs p'.
intros. induction xs. crush. crush. Qed.

Definition max (m n : nat) : nat := match le_gt_dec m n with
  | left _ => m
  | right _ => n
  end.

Definition maximum : list nat → nat := fold_right max 0.

Definition replace {K V} (eq : K → K → bool) (k : K) (v : V) :
  Map K V → Map K V := map (λ e, match e with | (k', v') => if eq k k' then
    (k', v) else e end).

Lemma unique_inf {a b} : ∀ xs ys xs' ys' (k:a) (v
v':b), unique (domain (xs ++ (k,v) :: ys)) →
  xs ++ (k,v) :: ys = xs' ++ (k,v') :: ys' → xs = xs' ∧ v = v' ∧ ys = ys'.
intros.  generalize dependent xs'. generalize dependent ys'. induction xs.
intros; induction xs'. inversion H0. subst. auto. inversion H0.  subst. simpl in H.
inversion H; subst. assert (In k (domain (xs' ++ (k,v') :: ys'))). apply
inf_indomain. apply H3 in H1. inversion H1. simpl in H. destruct a0. inversion H. subst.
specialize (IHxs H3). intros. inversion H0. destruct xs'. inversion H0. subst.
inversion H; subst. assert (In k (domain (xs ++ (k,v) :: ys))). apply
inf_indomain. apply H6 in H1. inversion H1. inversion H4; subst. specialize
(IHxs ys' xs' H6). split. f_equal. destruct IHxs; auto. destruct IHxs. destruct
H5. split; auto. Qed.

Lemma unique_domain_app {A} : ∀ (h h':Map nat A), unique (domain (h ++ h')) ↔
unique (domain (h' ++ h)). intros. unfold domain. rewrite map_app. rewrite
map_app. split; intros; apply unique_app; assumption. Qed.

Lemma domain_app {A} : ∀ (h h':Map nat A), domain (h ++ h') = domain h ++ domain
h'. intros. unfold domain. rewrite map_app. reflexivity. Qed.

Lemma unique_domain_lookup {b} : ∀ xs k (v:b), unique (domain xs) →
  (∃ ys zs, xs = ys++(k,v)::zs) → lookup k xs = Some v.
intros. induction xs. simpl. destruct H0. destruct H0. apply app_cons_not_nil in H0. inversion H0.
destruct H0. destruct H0. destruct x. inversion H0.  subst. unfold lookup.
simpl.  rewrite <- beq_nat_refl. reflexivity. unfold lookup. simpl. destruct a.
inversion H. subst. inversion H0. subst. unfold domain in H3. rewrite map_app in
H3. rewrite in_app_iff in H3. apply or_imp in H3. destruct H3. simpl in H2.
apply or_imp in H2. destruct H2. assert (k <> n). assumption.  rewrite <-
beq_nat_false_iff in H5. simpl.  rewrite H5. apply IHxs. assumption. exists x,
x0. reflexivity. Qed.

Lemma lookup_inf {A} : ∀ x (a:A) h h', unique (domain (h ++ (x, a) :: h')) →
  lookup x (h ++ (x, a) :: h') = Some a.
intros. apply unique_domain_lookup. assumption. exists h, h'. reflexivity. Qed.

Lemma in_domain_pair {B} : ∀ (a:nat) (b:B) h, In (a, b) h → In a (domain h).
intros. induction h. inversion H. destruct a0. simpl. destruct (eq_nat_dec n a).
apply or_introl. assumption. apply or_intror. simpl in H. destruct H. inversion
H. subst. specialize (n0 eq_refl). inversion n0. apply IHh. assumption. Qed.

Lemma lookup_inpair {A} : ∀ x h, unique (domain h) →
  (∀ a:A, In (x,a) h ↔ lookup x h = Some a).
intros. split; prep_induction h; induction h; intros. inversion H0. destruct a.
destruct (eq_nat_dec x n).  subst. unfold lookup. simpl. rewrite <-
beq_nat_refl. simpl in H0. destruct H0.  inversion H0. subst. reflexivity.
inversion H. subst. apply in_domain_pair in H0. apply H3 in H0. inversion H0.
unfold lookup. simpl. assert (n0':=n0). rewrite <- beq_nat_false_iff in n0.
rewrite n0. apply IHh. inversion H. assumption. unfold In in H0. destruct H0.
inversion H0. subst. specialize (n0' eq_refl). inversion n0'. assumption. simpl.
inversion H0. destruct a. inversion H. subst. simpl in *. destruct (eq_nat_dec x
n). subst. unfold lookup in H0. simpl in H0. rewrite <- beq_nat_refl in H0.
inversion H0. subst. apply or_introl. reflexivity. apply or_intror. unfold
lookup in H0. rewrite <- beq_nat_false_iff in n0. simpl in H0.  rewrite n0 in
H0. apply IHh. assumption. assumption. Qed.

Lemma lookup_e_inf {a} : ∀ k (v:a) h, lookup k h = Some v → ∃ h1 h2, h = h1 ++ (k,v) :: h2.
intros. induction h. inversion H. unfold lookup in H. simpl in H. destruct a0.
simpl in H. destruct (beq_nat k n) eqn:bkn. inversion H. subst. apply
beq_nat_true in bkn. subst. exists [], h.  reflexivity. apply IHh in H. destruct
H. destruct H. subst. exists ((n, a0) :: x), x0. reflexivity. Qed.

Definition eq_dec (a :Type) := ∀ x y : a, {x = y} + {x ≠ y}.

Lemma neq_inf {A} : ∀ (x y:A) xs ys, x ≠ y → In y (xs ++ x :: ys) ↔ In y (xs ++ ys).
intros. induction xs; split; intros. simpl. simpl in H0. destruct H0. apply H in
H0. inversion H0. assumption. simpl. simpl in H0. apply or_intror. assumption.
simpl in H0. destruct H0. subst. simpl. apply or_introl. reflexivity. simpl. apply
or_intror. rewrite <- IHxs. assumption. simpl. simpl in H0. destruct H0. auto.
rewrite IHxs. auto. Qed.

Lemma lu_eq_iff {A} : ∀ x y h h', (∀ a:A, lookup x h = Some a ↔ lookup y h' = Some a)
  ↔ lookup x h = lookup y h'.
intros. split; intros. destruct (lookup x h) eqn:lua. destruct  (lookup y h').
specialize (H a). symmetry. rewrite <- H. reflexivity. specialize (H a).
symmetry. rewrite <- H. reflexivity. destruct (lookup y h'). specialize (H a).
rewrite H. reflexivity. reflexivity. rewrite H. split; intro; assumption. Qed.

Lemma lookup_not_inf {A} : ∀ (a:A) x y h h', x ≠ y → lookup x (h ++ (y, a) :: h') =
  lookup x (h ++ h').
intros. induction h. simpl. unfold lookup. simpl. destruct (beq_nat x y)
eqn:bxy.  apply beq_nat_true in bxy. apply H in bxy. inversion bxy. reflexivity.
simpl. unfold lookup. simpl. destruct a0. simpl in *. destruct (beq_nat x n)
eqn:bxn. reflexivity. assumption. Qed.

Lemma lookup_app_unique {A} : ∀ x (h h' : Map nat A),
  unique (domain (h ++ h')) →
  lookup x (h ++ h') = lookup x (h' ++ h).
intros. prep_induction h. induction h; intros. rewrite app_nil_r. rewrite
app_nil_l. reflexivity. simpl in *. inversion H. subst. destruct a. simpl in *.
destruct (eq_nat_dec x n). subst.  unfold lookup at 1. simpl. rewrite <-
beq_nat_refl.  rewrite lookup_inf. reflexivity. unfold domain. rewrite map_app.
apply unique_app. simpl. rewrite <- map_app. assumption. symmetry. rewrite <-
beq_nat_false_iff in n0. unfold lookup at 2. simpl. rewrite n0.  unfold lookup
in IHh. rewrite  IHh.  apply lookup_not_inf. apply beq_nat_false_iff.
assumption. assumption. Qed.

Lemma replace_not_in {a} : ∀ xs l (c:a), ¬In l (domain xs) → replace beq_nat l c xs = xs.
intros. induction xs. auto. destruct a0. destruct (eq_nat_dec l n). subst. simpl
in H. apply or_imp in H. destruct H. specialize (H eq_refl). inversion H. simpl.
rewrite <- beq_nat_false_iff in n0. rewrite n0. simpl in H. unfold not in H. rewrite or_imp in H.
destruct H. apply IHxs in H0. rewrite H0. reflexivity. Qed.

Lemma replace_domain {k a} : ∀ h (l:k) eq (v:a), domain h = domain (replace eq l v h).
induction h. simpl. auto. intros. destruct a0. simpl. destruct (eq l k0); simpl.
erewrite IHh. reflexivity. erewrite IHh. reflexivity. Qed.

Lemma replace_inf {a} : ∀ xs l (c c':a) ys,
  unique (domain (xs ++ (l,c) :: ys)) →
  replace beq_nat l c' (xs ++ (l,c) :: ys) = xs ++ (l,c') :: ys.
intros. induction xs. simpl. rewrite <- beq_nat_refl. simpl in H. inversion H.
subst. rename c into C. apply replace_not_in with (c:=c') in H2. rewrite H2.
reflexivity. simpl. destruct a0. destruct (eq_nat_dec l n). subst. inversion H.
subst. specialize (H2 (inf_indomain n c xs ys)). inversion H2.  rewrite <-
beq_nat_false_iff in n0. rewrite n0. inversion H; subst. apply IHxs in H3.
rewrite H3. reflexivity. Qed.

(*
Lemma replace_lookup  {a} : ∀ h l (c v:a), lookup l h = Some c →
  lookup l (replace beq_nat l v h) = Some v.
intros. induce h.
- inversion H.
- simpl. destruct a0. destruct (beq_nat l n) eqn:ln. unfold lookup. unfold
  find. simpl. rewrite ln. reflexivity. unfold lookup in H. simpl. inversion H.
  unfold lookup. unfold find. simpl. rewrite ln.  unfold lookup in IHh. unfold
  find in IHh. simpl in *. apply IHh.  apply beq_nat_true in ln. subst. unfold
  lookup. unfo.
*)

Lemma lookup_replace {A} : ∀ h l (v:A) c,
  lookup l h = Some c →
  lookup l (replace beq_nat l v h) = Some v.
induction h; intros. inversion H. simpl. destruct a. unfold lookup in *. unfold
find in *. simpl in *. destruct (beq_nat l n) eqn:ln. invert H. simpl in *.
rewrite ln. reflexivity. simpl. rewrite ln.  apply (IHh l v c). assumption.
Qed.

Lemma lookup_replace' {A} : ∀ h l (v:A) c k,
  lookup l h = Some c →
  l <> k →
  lookup l (replace beq_nat k v h) = Some c.
induction h; intros. inversion H. simpl. destruct a. unfold lookup in *. unfold
find in *. simpl in *. destruct (beq_nat l n) eqn:ln. invert H. simpl in *.
destruct (beq_nat k n) eqn:kn. apply beq_nat_true in ln. apply beq_nat_true in
kn. rewrite <- ln in kn. symmetry in kn. apply H0 in kn. inversion kn. simpl in
*. rewrite ln. reflexivity. destruct (beq_nat k n) eqn:kn. simpl. rewrite ln.
apply (IHh l v c k). assumption. assumption. simpl. rewrite ln. apply (IHh l v c
k). assumption. assumption.
Qed.

Lemma skipn_3_skipn {a} : ∀ n (x y z:a) p l, skipn n p = x::y::z::l → skipn (3+n) p = l.
induction n; intros. simpl. simpl in H. invert H. reflexivity. simpl. simpl in
H. simpl in IHn. destruct p. invert H.  apply IHn in H. assumption. Qed.

Lemma in_notin_neq {a} : ∀ (x y:a) l, x ∈ l → y ∉ l → x <> y.
induction l; intros. inversion H. inversion H. subst. unfold not in H0. unfold
not. intros. subst. apply H0. assumption. apply IHl. assumption. unfold not.
intros. unfold not in H0. simpl in H0. apply H0. apply or_intror. assumption.
Qed.

Lemma prod_assoc : ∀ a b c, (a * b) * c → a * (b * c).
crush. Qed.

Lemma prod_assoc' : ∀ a b c, a * (b * c) → (a * b) * c.
crush. Qed.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import ZArith Reals.
From Flocq Require Import Raux.

Require Import Xreal.
Require Import Basic.
Require Import Generic.
Require Import Generic_proof.
Require Import Sig.

Module Type Radix.
  Parameter val : radix.
End Radix.

Module Radix2 <: Radix.
  Definition val := radix2.
End Radix2.

Module Radix10 <: Radix.
  Definition val := Build_radix 10 (refl_equal _).
End Radix10.

Module GenericFloat (Rad : Radix) <: FloatOps.

  Definition radix := Rad.val.
  Definition even_radix := match radix_val radix with Zpos (xO _) => true | _ => false end.
  Definition even_radix_correct := refl_equal even_radix.
  Definition type := float radix.
  Definition toF := fun x : float radix => x.
  Definition toX := fun x : float radix => FtoX x.
  Definition fromF := fun x : float radix => x.
  Definition precision := positive.
  Definition sfactor := Z.
  Definition prec := fun x : positive => x.
  Definition ZtoS := fun x : Z => x.
  Definition StoZ := fun x : Z => x.
  Definition PtoP := fun x : positive => x.
  Definition incr_prec := Pplus.
  Definition zero := @Fzero radix.
  Definition nan := @Fnan radix.
  Definition mag := @Fmag radix.
  Definition cmp := @Fcmp radix.
  Definition min := @Fmin radix.
  Definition max := @Fmax radix.
  Definition round := @Fround radix.
  Definition neg := @Fneg radix.
  Definition abs := @Fabs radix.
  Definition scale := @Fscale radix.
  Definition scale2 := @Fscale2 radix.
  Definition add_exact := @Fadd_exact radix.
  Definition sub_exact := @Fsub_exact radix.
  Definition mul_exact := @Fmul_exact radix.
  Definition add := @Fadd radix.
  Definition sub := @Fsub radix.
  Definition mul := @Fmul radix.
  Definition div := @Fdiv radix.
  Definition sqrt := @Fsqrt radix.
  Definition nearbyint := @Fnearbyint_exact radix.
  Definition toF_correct := fun x => refl_equal (@FtoX radix x).
  Definition zero_correct := refl_equal (Xreal R0).
  Definition nan_correct := refl_equal Xnan.
  Definition cmp_correct := @Fcmp_correct radix.
  Definition min_correct := @Fmin_correct radix.
  Definition max_correct := @Fmax_correct radix.
  Definition neg_correct := @Fneg_correct radix.
  Definition abs_correct := @Fabs_correct radix.
  Definition scale_correct := @Fscale_correct radix.
  Definition scale2_correct := @Fscale2_correct radix.
  Definition add_exact_correct := @Fadd_exact_correct radix.
  Definition sub_exact_correct := @Fsub_exact_correct radix.
  Definition mul_exact_correct := @Fmul_exact_correct radix.
  Definition add_correct := @Fadd_correct radix.
  Definition sub_correct := @Fsub_correct radix.
  Definition mul_correct := @Fmul_correct radix.
  Definition div_correct := @Fdiv_correct radix.
  Definition sqrt_correct := @Fsqrt_correct radix.
  Definition nearbyint_correct := @Fnearbyint_exact_correct radix.

  Definition fromZ n : float radix := match n with Zpos p => Float false p Z0 | Zneg p => Float true p Z0 | Z0 => Fzero end.

  Lemma fromZ_correct : forall n, FtoX (toF (fromZ n)) = Xreal (IZR n).
  Proof.
    intros. case n ; split.
  Qed.

  Definition real (f : float radix) := match f with Fnan => false | _ => true end.

  Lemma real_correct :
    forall f, real f = match toX f with Xnan => false | _ => true end.
  Proof.
  intros f.
  now case f.
  Qed.

End GenericFloat.


(*
 * Vectors and Fin (also from Anders)
 * Thanks to James Wilcox for the missing gaps that I needed!
 * https://gist.github.com/wilcoxjay/10cc817d20ad7148899c3725a1ebf06e
 *)
Require Import Ornamental.Ornaments.

Require Import Coq.Vectors.Fin.
Require Import Coq.Vectors.Vector.

(* needed for this equivalence *)
Require Import Coq.Logic.FunctionalExtensionality.

(*
 * First we need to preprocess to use eliminators, so we can repair later:
 *)
Preprocess Module VectorDef as VectorDef' { opaque
  (* no need: *)
  Coq.Init.Datatypes Coq.Init.Logic Coq.Init.Peano Coq.Init.Nat
  Coq.Classes.RelationClasses Coq.Relations.Relation_Definitions Coq.Classes.Morphisms
  Coq.Arith.PeanoNat Coq.Classes.Morphisms_Prop Coq.Program.Basics
  (* needs n-induction: *)
  VectorDef.rectS VectorDef.caseS' VectorDef.rect2
  VectorDef.last VectorDef.nth VectorDef.nth_order VectorDef.replace VectorDef.replace_order
  VectorDef.shiftout VectorDef.shiftrepeat VectorDef.trunc VectorDef.rev_append
  VectorDef.rev VectorDef.map2 VectorDef.fold_right2 VectorDef.fold_left2
}.

(*
 * PUMPKIN Pi still gets annoyed about implicit parameters sometimes, so for now we make
 * T and n explicit.
 *)
Definition A (T : Type) (n : nat) := VectorDef'.t T n.

Definition B (T : Type) (n : nat) := Fin.t n -> T.

(* --- Configuration --- *)

Definition dep_constr_A_0 :=
  VectorDef'.nil.

Definition dep_constr_A_1 (T : Type) (t : T) (n : nat) (a : A T n) : A T (S n) :=
  VectorDef'.cons T t n a.

Program Definition dep_constr_B_0 (T : Type) : B T 0.
Proof.
  unfold B. intros f. apply Fin.case0. apply f.
Defined.

Definition dep_constr_B_1 (T : Type) (t : T) (n : nat) (b : B T n) : B T (S n) :=
  fun f =>
  match f with
  | Fin.F1 => fun _ => t
  | Fin.FS f' => fun b' => b' f'
  end b.

Definition eta_A (T : Type) (n : nat) (a : A T n) : A T n := a.
Definition eta_B (T : Type) (n : nat) (b : B T n) : B T n := b.

(* TODO for practicality, might need this instead, unsure: *)
(*Definition eta_A (n m : nat) (H : n = m) (a : A n) : A m := eq_rect m A a n H.*)
(* and eta B might need to use the tail/hd properties. we'll see *)

Definition dep_elim_A : forall (T : Type) (P : forall n : nat, A T n -> Type) (f0 : P 0 (dep_constr_A_0 T))
  (f1 : forall (t : T) (n : nat) (v : A T n), P n v -> P (S n) (dep_constr_A_1 T t n v))
  (n : nat) (v : A T n), P n v
:=  VectorDef'.t_rect.

Definition hd (T : Type) n (b : B T (S n)) : T :=
  b Fin.F1.

Definition tl (T : Type) n (b : B T (S n)) : B T n :=
  fun f => b (Fin.FS f).

Lemma eta_dep_constr_B_0:
  forall (T : Type) (b : B T 0),
    dep_constr_B_0 T = b.
Proof.
  intros T b.
  apply functional_extensionality_dep_good.
  intros f.
  apply Fin.case0.
  apply f.
Defined.

Lemma eta_dep_constr_B_1:
  forall (T : Type) (n : nat) (b : B T (S n)),
    dep_constr_B_1 T (hd T n b) n (tl T n b) = b.
Proof.
  intros T n b.
  apply functional_extensionality_dep_good.
  intros f.
  revert b.
  refine (
    match f with
    | Fin.F1 => _
    | Fin.FS _ => _
    end
  ); reflexivity.
Defined.

Program Definition dep_elim_B (T : Type) (P : forall n : nat, B T n -> Type) (f0 : P 0 (dep_constr_B_0 T))
  (f1 : forall (t : T) (n : nat) (f : B T n), P n f -> P (S n) (dep_constr_B_1 T t n f))
  (n : nat) (b : B T n)
: P n b.
Proof.
  induction n.
  - replace b with (@dep_constr_B_0 T) by (apply eta_dep_constr_B_0). auto.
  - replace b with (dep_constr_B_1 T (hd T n b) n (tl T n b)) by (apply eta_dep_constr_B_1). auto.
Defined.

(*
 * iota over A is of course trivial:
 *)
Lemma iota_A_0 :
 forall (T : Type) (P : forall (n : nat), A T n -> Type)
   (f0 : P 0 (dep_constr_A_0 T))
   (f1 : forall (t : T) (n : nat) (f : A T n), P n f -> P (S n) (dep_constr_A_1 T t n f))
   (Q : P 0 (dep_constr_A_0 T) -> Type),
   Q (dep_elim_A T P f0 f1 0 (dep_constr_A_0 T)) ->
   Q f0.
Proof.
  intros. auto.
Defined.

Lemma iota_A_1 :
 forall (T : Type) (P : forall (n : nat), A T n -> Type)
   (f0 : P 0 (dep_constr_A_0 T))
   (f1 : forall (t : T) (n : nat) (f : A T n), P n f -> P (S n) (dep_constr_A_1 T t n f))
   (t : T) (n : nat) (f : A T n) (Q : P (S n) (dep_constr_A_1 T t n f) -> Type),
   Q (dep_elim_A T P f0 f1 (S n) (dep_constr_A_1 T t n f)) ->
   Q (f1 t n f (dep_elim_A T P f0 f1 n f)).
Proof.
  intros. auto.
Defined.

(*
 * Needed for iota_B_0:
 *)
Lemma eta_refl_B_0:
  forall (T : Type), eta_dep_constr_B_0 T (dep_constr_B_0 T) = eq_refl.
Proof.
  intros. unfold eta_dep_constr_B_0.
  symmetry. eapply eq_trans.
  - symmetry. apply functional_extensionality_dep_good_refl.
  - f_equal. extensionality f.
    apply Fin.case0. apply f.
Defined.

Lemma iota_B_0 :
 forall (T : Type) (P : forall (n : nat), B T n -> Type)
   (f0 : P 0 (dep_constr_B_0 T))
   (f1 : forall (t : T) (n : nat) (f : B T n), P n f -> P (S n) (dep_constr_B_1 T t n f))
   (Q : P 0 (dep_constr_B_0 T) -> Type),
   Q (dep_elim_B T P f0 f1 0 (dep_constr_B_0 T)) ->
   Q f0.
Proof.
  intros. simpl in X. rewrite eta_refl_B_0 in X. apply X.
Defined.

(*
 * Needed for iota_B_1:
 *)
Lemma eta_refl_B_1:
  forall (T : Type) (n : nat) (t : T) (b : B T n),
    eta_dep_constr_B_1 T n (dep_constr_B_1 T t n b) = eq_refl.
Proof.
  intros. unfold eta_dep_constr_B_1. unfold hd. unfold tl. simpl.
  symmetry. eapply eq_trans.
  - symmetry. apply functional_extensionality_dep_good_refl.
  - f_equal. extensionality f.
    revert b.
    refine (
    match f with
    | Fin.F1 => _
    | Fin.FS _ => _
    end); auto.
Defined.

Lemma iota_B_1 :
 forall (T : Type) (P : forall (n : nat), B T n -> Type)
   (f0 : P 0 (dep_constr_B_0 T))
   (f1 : forall (t : T) (n : nat) (f : B T n), P n f -> P (S n) (dep_constr_B_1 T t n f))
   (t : T) (n : nat) (b : B T n) (Q : P (S n) (dep_constr_B_1 T t n b) -> Type),
   Q (dep_elim_B T P f0 f1 (S n) (dep_constr_B_1 T t n b)) ->
   Q (f1 t n b (dep_elim_B T P f0 f1 n b)).
Proof.
  intros. simpl in X. unfold hd in X. unfold tl in X. simpl in X.
  rewrite eta_refl_B_1 in X. apply X.
Defined.

(* --- Induced equivalence --- *)

(*
 * These should form their own equivalence:
 *)
Definition f (T : Type) (n : nat) (a : A T n) : B T n :=
  dep_elim_A
    T
    (fun n _ => B T n)
    (dep_constr_B_0 T)
    (fun t n b IH => dep_constr_B_1 T t n IH)
    n
    a.

Definition g (T : Type) (n : nat) (b : B T n) : A T n :=
  dep_elim_B
    T
    (fun n _ => A T n)
    (dep_constr_A_0 T)
    (fun t n b IH => dep_constr_A_1 T t n IH)
    n
    b.

(*
 * This could be much easier, but I want to make a point of doing this algorithmically!
 *)
Lemma section (T : Type) (n : nat) (a : A T n) : g T n (f T n a) = a.
Proof.
  apply dep_elim_A with (v := a); unfold f; unfold g; intros.
  - unfold dep_constr_A_0 at 1. unfold dep_constr_A_0 at 1.
    apply (iota_B_0 T (fun n _ => A T n) (dep_constr_A_0 T) (fun t n b IH => dep_constr_A_1 T t n IH)).
    unfold dep_constr_B_0 at 1.
    apply (iota_A_0 T (fun n _ => B T n) (dep_constr_B_0 T) (fun t n a IH => dep_constr_B_1 T t n IH)).
    reflexivity.
  - unfold dep_constr_A_1 at 1. unfold dep_constr_A_1 at 1.
    replace (dep_constr_A_1 T t n0 v) with (dep_constr_A_1 T t n0 (g T n0 (f T n0 v))).
    + unfold g. unfold f.
      apply (iota_B_1 T (fun n _ => A T n) (dep_constr_A_0 T) (fun t n b IH => dep_constr_A_1 T t n IH) t n0).
      apply (iota_A_1 T (fun n _ => B T n) (dep_constr_B_0 T) (fun t n a IH => dep_constr_B_1 T t n IH)).
      reflexivity.
    + unfold g. unfold f. rewrite H. reflexivity.
Defined.

(*
 * The point being that this direction should mirror this exactly, despite iota actually mattering here.
 *)
Lemma retraction (T : Type) (n : nat) (b : B T n) : f T n (g T n b) = b.
Proof.
  apply dep_elim_B with (b := b); unfold f; unfold g; intros.
  - unfold dep_constr_B_0 at 1. unfold dep_constr_B_0 at 1.
    apply (iota_A_0 T (fun n _ => B T n) (dep_constr_B_0 T) (fun t n a IH => dep_constr_B_1 T t n IH)).
    unfold dep_constr_A_0 at 1.
    apply (iota_B_0 T (fun n _ => A T n) (dep_constr_A_0 T) (fun t n b IH => dep_constr_A_1 T t n IH)).
    reflexivity.
  - unfold dep_constr_B_1 at 1. unfold dep_constr_B_1 at 1.
    replace (dep_constr_B_1 T t n0 f0) with (dep_constr_B_1 T t n0 (f T n0 (g T n0 f0))).
    + unfold f. unfold g.
      apply (iota_A_1 T (fun n _ => B T n) (dep_constr_B_0 T) (fun t n a IH => dep_constr_B_1 T t n IH) t n0).
      apply (iota_B_1 T (fun n _ => A T n) (dep_constr_A_0 T) (fun t n a IH => dep_constr_A_1 T t n IH)).
      reflexivity.
    + unfold f. unfold g. rewrite H. reflexivity.
Defined.

Print retraction.

(* hahaha holy shit *)

(* --- Saving the equivalence --- *)

Save equivalence A B { promote = f; forget = g }.

(*
 * We explicitly refer to VectorDef' here to work around the combination of
 * universe bugs and lack of unification heuristics.
 *)
Configure Lift A B {
  constrs_a = dep_constr_A_0 dep_constr_A_1;
  constrs_b = dep_constr_B_0 dep_constr_B_1;
  elim_a = VectorDef'.t_rect;
  elim_b = dep_elim_B;
  eta_a = eta_A;
  eta_b = eta_B;
  iota_a = iota_A_0 iota_A_1;
  iota_b = iota_B_0 iota_B_1
}.

(* --- Repair --- *)

(*
 * Functions (provided preprocess worked) are easy, since we don't need iota.
 * But we still need to make dep_constr_A_1 explicit because, yes, lack of unification heuristics
 * makes things that dire, though I think that is fixable to some degree).
 *
 * To do that, we use "Replace Convertible" from PUMPKIN PATCH, but this won't
 * build without PUMPKIN PATCH, so TODO expose this inside of PUMPKIN Pi.
 * This at least proves that the problem is unification heuristics here,
 * and that the solution is at least in some cases really not hard.
 *)
Require Import Patcher.Patch.
Module Over_A.

Replace Convertible dep_constr_A_1 in VectorDef'.caseS as caseS.
Replace Convertible dep_constr_A_1 caseS in VectorDef'.hd as hd.
Replace Convertible caseS in VectorDef'.tl as tl.
Replace Convertible dep_constr_A_1 in VectorDef'.const as const.
Replace Convertible dep_constr_A_1 in VectorDef'.shiftin as shiftin.
Replace Convertible dep_constr_A_1 in VectorDef'.take as take.
Replace Convertible dep_constr_A_1 in VectorDef'.append as append.
Replace Convertible dep_constr_A_1 in VectorDef'.rev_append_tail as rev_append_tail.
Replace Convertible dep_constr_A_1 in VectorDef'.map as map.
Replace Convertible dep_constr_A_1 in VectorDef'.fold_left as fold_left.
Replace Convertible dep_constr_A_1 in VectorDef'.fold_right as fold_right.

(* TODO universe bugs prevent us from lifting Forall, Exists, In, and so on. *)

End Over_A.

Set DEVOID lift type.
Repair Module A B in Over_A as Over_B { opaque nat_rect VectorDef'.Coq_Arith_PeanoNat_Nat_nle_succ_0 VectorDef'.Coq_Arith_Le_le_S_n False_rect VectorDef'.Coq_Arith_PeanoNat_Nat_add VectorDef'.Coq_Arith_Plus_tail_plus }.

(*
 * The configuration for this took an expert proof engineer (James Wilcox) well under
 * an hour to write, and then repair was free. I think my head would explode
 * trying to write these functons by hand, so for me this is a smiley face
 * in that it saves the development time I'd be too afraid to even attempt.
 * I consulted Twitter, and it took the same proof engineer (notably) over an
 * hour (75 minutes) to do manually, plus it was reportedly very much
 * not fun: https://twitter.com/TaliaRinger/status/1370576188310048770
 *
 * Reference: https://gist.github.com/wilcoxjay/9ddedb32d3b7659826dbcb96f70beae8
 *)

(*
 * TODO some proofs (with iota, will be annoying), some stuff with matrices
 *)


(** Common useful definitions **)
(* (C) M. Bodin - see LICENSE.txt *)

From Coq Require Import Lia.
From mathcomp Require Import ssreflect ssrnat ssrbool seq eqtype.
From compcert Require Integers.
From Wasm Require Export pickability.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Structures **)

Lemma Z_eqP : Equality.axiom Coqlib.zeq.
Proof.
  move=> x y. case: Coqlib.zeq; by [ left | right ].
Qed.

Definition Z_eqMixin := EqMixin Z_eqP.

Canonical Structure Z_eqType := EqType BinNums.Z Z_eqMixin.

Lemma Pos_eqP : Equality.axiom BinPosDef.Pos.eqb.
Proof.
  move=> x y. apply: Bool.iff_reflect. by rewrite BinPos.Pos.eqb_eq.
Qed.

Definition Pos_eqMixin := EqMixin Pos_eqP.

Canonical Structure Pos_eqType := EqType BinNums.positive Pos_eqMixin.

(** * Equalities **)

(** Similar to [set (name := term)], but introduce an equality instead of a local definition. **)
Ltac set_eq name term :=
  set (name := term);
  have: name = term; [
      reflexivity
    | clearbody name ].

(** Try to rewrite the goal such that [lia] has more chance to deal with it. **)
Ltac lias_simpl :=
  intros;
  repeat lazymatch goal with
  | |- ~ _ => intro
  | |- is_true (~~ _) => apply/negP
  | |- context C [subn] => rewrite /subn /subn_rec
  | |- context C [addn] => rewrite /addn /addn_rec
  | |- is_true (leq _ _) => apply/leP
  | |- is_true (@eq_op nat_eqType _ _) => rewrite -eqnE; apply/eqnP
  | |- is_true (@eq_op Z_eqType _ _) => apply/Z_eqP
  | |- is_true (@eq_op Pos_eqType _ _) => apply/Pos_eqP
  | |- context C [BinNums.Zpos (BinPos.Pos.of_succ_nat ?n)] =>
    rewrite -> (Znat.Zpos_P_of_succ_nat n);
    rewrite <- (Znat.Nat2Z.inj_succ n)
  | |- _ /\ _ => split
  | |- is_true (_ && _) => apply/andP; split
  | |- _ <-> _ => split; intros
  | H: context C [subn] |- _ => unfold subn, subn_rec in H
  | H: context C [addn] |- _ => unfold addn, addn_rec in H
  | H: is_true (~~ _) |- _ => move/negP: H => H
  | H: _ /\ _ |- _ => move: H; intros [? ?]
  | H: _ <-> _ |- _ => move: H; intros [? ?]
  | H: is_true (_ && _) |- _ => move/andP: H; intros [? ?]
  | H: ~ (is_true (leq ?a ?b)) |- _ =>
    let L := fresh H in
    have L: (~ a <= b)%coq_nat;
    [ move=> ?; apply: H; apply/leP; by lia | clear H ]
  | H: context C [is_true (leq _ _)] |- _ => move: H => /leP H
  | H: context C [is_true (@eq_op nat_eqType _ _)] |- _ => move: H; rewrite -eqnE => /eqnP H
  | H: context C [is_true (@eq_op Z_eqType _ _)] |- _ => move: H => /Z_eqP H
  | H: context C [is_true (@eq_op Pos_eqType _ _)] |- _ => move: H => /Pos_eqP H
  | H: context C [BinNums.Zpos (BinPos.Pos.of_succ_nat ?n)] |- _ =>
    rewrite -> (Znat.Zpos_P_of_succ_nat n) in H;
    rewrite <- (Znat.Nat2Z.inj_succ n) in H
  (* The following cases have a higher chance of failing, and should be kept after this comment. *)
  | |- ?x = false => apply/negP; intro
  | H: context C [?x = false] |- _ => move: H => /negP H
  | |- ?x = true => fold (is_true x)
  | H: context C [?x = true] |- _ => fold (is_true x) in H
  end;
  repeat rewrite <- PeanoNat.Nat.add_1_l in *;
  try unfold Logic.not in *;
  try by [].

(** An extension of [lia] that just tries to rewrite things in the way [lia] that expects. **)
Ltac lias :=
  lias_simpl;
  let unfold_head _ :=
    let rec aux f :=
      lazymatch f with
      | ?g _ => aux g
      | _ => unfold f
      end in
    lazymatch goal with
    | |- ?f => aux f
    end in
  let rec aux _ :=
    solve [ lia
          | nia
          | unfold_head tt; aux tt
          | apply: Bool.eq_true_iff_eq; lias_simpl; aux tt ] in
  aux tt || (simpl; lias_simpl; aux tt).

(** Rewrite an arithmetic equality. **)
Ltac rewrite_by E :=
  let R := fresh "R" in
  have R: E;
    [ by [ auto | lias ]
    | rewrite {} R ].

Ltac remove_bools_options :=
  repeat lazymatch goal with
  | H: is_true (_ && _ ) |- _ =>
    move/andP in H; destruct H
  | H: (_ && _) = true |- _ =>
    move/andP in H; destruct H
  | H: is_true (_ == _) |- _ =>
    move/eqP in H
  | H: is_true (_ || _) |- _=>
    move/orP in H; destruct H
  | H: Some _ = Some _ |- _ =>
    inversion H; subst; clear H
  | H: option_map _ _ = _ |- _ =>
    unfold option_map in H
  | H: match ?exp with
       | Some _ => _
       | None => _
       end = _
    |- _ =>
    let Hoption := fresh "Hoption" in
    destruct exp eqn:Hoption; try by []
  | H: is_true match ?exp with
       | Some _ => _
       | None => _
       end
    |- _ =>
    let Hoption := fresh "Hoption" in
    destruct exp eqn:Hoption; try by []
  end.

(** A useful lemma to link the results of [Scheme Equality] to [Equality.axiom]. **)
Lemma eq_dec_Equality_axiom : forall t (eq_dec : forall x y : t, {x = y} + {x <> y}),
  let eqb v1 v2 := is_left (eq_dec v1 v2) in
  Equality.axiom eqb.
Proof.
  move=> t eq_dec eqb x y. rewrite /eqb. case: (eq_dec x y).
  - move=> E. by apply/ReflectT.
  - move=> E. by apply/ReflectF.
Qed.

(** A useful lemma for the converse: getting a [_ep_dec] from an [Equality.axiom]. **)
Definition Equality_axiom_eq_dec t (eqb : t -> t -> bool) (A : Equality.axiom eqb) :
    forall x y : t, {x = y} + {x <> y}.
Proof.
  move=> x y. move: (A x y). case E: (eqb x y); inversion 1; by [ left | right ].
Defined.

Ltac decidable_equality_step :=
  first [
      by apply: eq_comparable
    | apply: List.list_eq_dec
    | apply: Coqlib.option_eq
    | apply: PeanoNat.Nat.eq_dec
    | by eauto
    | intros; apply: decP; by (exact _ || eauto)
    | decide equality ].

(** Solve a goal of the form [forall a1 a2, {a1 = a2} + {a1 <> a2}]. **)
Ltac decidable_equality :=
  repeat decidable_equality_step.

(** A lemma to move from [BoolSpec] to [reflect] predicates. **)
Lemma BoolSpec_reflect : forall P b,
  BoolSpec P (~P) b ->
  reflect P b.
Proof.
  move=> P b. case: b => S.
  - apply: ReflectT. by inversion S.
  - apply: ReflectF. by inversion S.
Qed.

(** And conversely. **)
Lemma reflect_BoolSpec : forall P b,
  reflect P b ->
  BoolSpec P (~P) b.
Proof.
  move=> P b. by case; [ apply: BoolSpecT | apply: BoolSpecF ].
Qed.

Import ZArith.BinInt.

Lemma gtb_spec0 : forall x y, reflect (x > y)%Z (x >? y)%Z.
Proof.
  move=> x y. apply: Bool.iff_reflect. rewrite Z.gtb_lt. by lias.
Qed.

Lemma geb_spec0 : forall x y, reflect (x >= y)%Z (x >=? y)%Z.
Proof.
  move=> x y. apply: Bool.iff_reflect. rewrite Z.geb_le. by lias.
Qed.

Definition curry A B C (f : A -> B -> C) (ab : A * B) :=
  let: (a, b) := ab in
  f a b.

Definition uncurry A B C (f : A * B -> C) a b := f (a, b).

Lemma curry_uncurry : forall A B C (f : A * B -> C) ab,
  curry (uncurry f) ab = f ab.
Proof. by move=> A B C f [a b]. Qed.

Lemma uncurry_curry : forall A B C (f : A -> B -> C) a b,
  uncurry (curry f) a b = f a b.
Proof. by []. Qed.

(** * Lemmas about lists. **)

Lemma List_In_in_mem : forall (A : eqType) e (l : seq A),
  e \in l <-> List.In e l.
Proof.
  induction l.
  - by [].
  - rewrite in_cons /= -IHl. split.
    + move/orP => [E|I]; [ left | right => // ]. symmetry. by apply/eqP.
    + move=> [E|I]; apply/orP; [ left | right => // ]. by apply/eqP.
Qed.

Lemma inP: forall {X:eqType} (x:X) l,
  reflect (List.In x l) (x \in l).
Proof.
  move => X x l. eapply equivP.
  - by apply idP.
  - by apply List_In_in_mem.
Defined.

Lemma filter_notin : forall (A : eqType) a (l : seq A) p,
  a \notin l ->
  filter p l = filter (fun b => (b != a) && p b) l.
Proof.
  move=> A a l p N. apply: eq_in_filter => x I.
  rewrite is_true_bool. split.
  - move=> P. apply/andP. split => //. apply/eqP => ?. subst. by move/negP: N.
  - by move/andP => [? ?].
Qed.

Lemma filter_out_zlt : forall (a : nat) l,
  (Z.of_nat a) \notin l ->
  [seq x <- l | Coqlib.zlt x (Z.of_nat a)]
  = [seq x <- l | Coqlib.zlt x (Z.pos (Pos.of_succ_nat a))].
Proof.
  move=> a l N. rewrite (filter_notin _ N). apply: eq_in_filter.
  move=> x I. rewrite Znat.Zpos_P_of_succ_nat -Znat.Nat2Z.inj_succ.
  case_eq (x == Z.of_nat a) => /eqP.
  - move=> E. subst. exfalso. by move/negP: N.
  - move=> D. by destruct Coqlib.zlt as [L|L], Coqlib.zlt as [L'|L'] => //; exfalso; lias.
Qed.

Lemma filter_for_all : forall A p (l : seq A),
  all p l ->
  filter p l = l.
Proof. move=> A p l F. by apply/all_filterP. Qed.

Lemma list_all_forall : forall A p (l : seq A),
  all p l <-> forall a, List.In a l -> p a.
Proof.
  move=> A p. elim => /=.
  - by split.
  - move=> a l IH. split.
    + move/andP => [P F] e [?|I].
      * by subst.
      * move: F. rewrite {} IH => AP. by apply: AP.
    + move=> F. apply/andP. rewrite IH. split.
      * apply: F. by left.
      * move=> e I. apply: F. by right.
Qed.

Lemma filter_none : forall A p (l : seq A),
  all (fun b => ~~ p b) l ->
  filter p l = [::].
Proof.
  move=> A p. elim.
  - by [].
  - move=> a l IH /= /andP [N F]. destruct p => //. by rewrite IH.
Qed.

Lemma filter_and : forall A p1 p2 (l : seq A),
  filter (fun a => p1 a && p2 a) l
  = filter p1 (filter p2 l).
Proof.
  move=> A p1 p2. elim.
  - by [].
  - move=> a l E /=. destruct p2 => /=; destruct p1 => //=. by rewrite E.
Qed.

Lemma firstn_is_take_n: forall {X:Type} (l:seq X) n,
    List.firstn n l = take n l.
Proof.
  move => + + n. induction n.
  - symmetry. by apply take0.
  - move => X l. destruct l => //=. by f_equal.
Qed.

(** If [List.nth_error] succeeds, then the list can be split into three parts. **)
Lemma split3: forall {X:Type} (l:seq X) n v,
    n < size l ->
    List.nth_error l n = Some v ->
    l = take n l ++ [::v] ++ drop (n+1) l.
Proof.
  move => X.
  elim => //= a l IH n v.
  elim: n => [_ [H]|n IH2 Ha Hb].
  - by rewrite /= H drop0.
  - by rewrite /= -(IH _ _ Ha Hb).
Qed.

Lemma rev_move: forall {X:Type} (l1 l2:seq X),
  rev l1 = l2 -> l1 = rev l2.
Proof.
  move => X l1 l2 HRev. rewrite -HRev. symmetry. by apply: revK.
Qed.

Lemma rev0 : forall A, rev [::] = ([::] : seq A).
Proof. reflexivity. Qed.

Lemma seq_nth_eq : forall A (d : A) l1 l2,
  seq.size l1 = seq.size l2 ->
  (forall n, n < seq.size l1 -> seq.nth d l1 n = seq.nth d l2 n) ->
  l1 = l2.
Proof.
  move=> A d. elim.
  - by case.
  - move=> e1 l1 IH. case => //= e2 l2 E F. f_equal.
    + fold (nth d (e1 :: l1) 0). by rewrite F.
    + apply: IH.
      * by lias.
      * move=> n I. have I': n.+1 < (size l1).+1; first by lias.
        by apply F in I'.
Qed.

Lemma nil_rcons : forall A l (a : A),
  [::] <> rcons l a.
Proof. move=> A. by case. Qed.

Fixpoint last_error {A} (l : list A) : option A :=
  match l with
  | [::] => None
  | [::x] => Some x
  | _ :: l' => last_error l'
  end.

Lemma last_error_rcons : forall A l (a : A),
  last_error (rcons l a) = Some a.
Proof.
  move=> A. elim; first by [].
  move=> e l IH a /=. rewrite IH.
  move: (@nil_rcons _ l a). by destruct rcons.
Qed.

Lemma rcons_last_error : forall A l (a : A),
  last_error l = Some a ->
  exists l', l = rcons l' a.
Proof.
  move=> A l. induction l using last_ind; first by [].
  move=> a. rewrite last_error_rcons. case=> ?. subst. by eexists.
Qed.

Lemma last_error_nil : forall A (l : list A),
  last_error l = None <-> l = [::].
Proof.
  move=> A. case => //= a l.
  induction l using last_ind; first by [].
  split=> //. rewrite last_error_rcons. by destruct rcons.
Qed.

Lemma last_error_last : forall A l (a : A),
  last_error l = Some a ->
  exists e l', l = e :: l' /\ a = last e l'.
Proof.
  move=> A. case=> // e l' a E.
  exists e. exists l'. split => //.
  move: (rcons_last_error E) => [l'' E'].
  by rewrite -(last_cons e) E' last_rcons.
Qed.

Lemma all2_swap : forall A B (f : A -> B -> bool) l1 l2,
  all2 f l1 l2 = all2 (fun x y => f y x) l2 l1.
Proof.
  move=> A B f. elim.
  - by case.
  - move=> a1 l1 IH. case=> //= a2 l2. by rewrite IH.
Qed.

Lemma all2_eq : forall A B (f1 f2 : A -> B -> bool) l1 l2,
  (forall a b, f1 a b = f2 a b) ->
  all2 f1 l1 l2 = all2 f2 l1 l2.
Proof.
  move=> A B f1 f2. elim.
  - by case.
  - move=> a1 l1 IH. case=> //= a2 l2 E. by rewrite E IH.
Qed.

Lemma all2_size: forall {X Y:Type} (f:X -> Y -> bool) l1 l2,
    all2 f l1 l2 ->
    size l1 = size l2.
Proof.
  move => X Y f. induction l1; destruct l2 => //=.
  move => H. remove_bools_options.
  f_equal.
  by apply IHl1.
Qed.

Lemma map_all2 : forall A (B : eqType) (f : A -> B) l,
  all2 (fun a1 a2 => f a1 == a2) l (map f l).
Proof.
  move=> A B f. elim => //=.
  move=> a1 l1 IH. by apply/andP.
Qed.

Lemma all2_map_left : forall A (B : eqType) (f : A -> B) l1 l2,
  all2 (fun a1 a2 => f a1 == a2) l1 l2 ->
  map f l1 = l2.
Proof.
  move=> A B f. elim.
  - by case.
  - move=> a1 l1 IH. case=> //= a2 l2 /andP [E F]. f_equal.
    + by move/eqP: E.
    + by apply: IH.
Qed.

Lemma all2_map_right : forall A (B : eqType) (f : A -> B) l1 l2,
  all2 (fun a1 a2 => a1 == f a2) l1 l2 ->
  l1 = map f l2.
Proof.
  move=> > F. symmetry. apply: all2_map_left. rewrite all2_swap.
  by erewrite all2_eq; first apply: F.
Qed.

Lemma all2_mapP : forall A (B : eqType) (f : A -> B) l1 l2,
  reflect (map f l1 = l2) (all2 (fun a1 a2 => f a1 == a2) l1 l2).
Proof.
  move=> >. apply: Bool.iff_reflect. split.
  - move=> ?. subst. by rewrite map_all2.
  - by apply: all2_map_left.
Qed.

Lemma cat0_inv : forall T (s1 s2 : seq T),
  s1 ++ s2 = [::] ->
  s1 = [::] /\ s2 = [::].
Proof.
  move=> T s1 s2 E.
  move: (size_cat s1 s2). rewrite {} E => /=. case s1.
  - case s2 => E.
    + done.
    + move => ? A. inversion A.
  - move => ? ? A. inversion A.
Qed.

Lemma maxn_nat_max : forall n m,
  maxn n m = Nat.max n m.
Proof.
  move=> n m. rewrite /maxn. case E: (n < m).
  - rewrite Max.max_r => //. by lias.
  - rewrite -> Max.max_l => //. have: (~ n < m)%coq_nat; last by lias.
    move: E => /negP E I. apply: E. by lias.
Qed.

Lemma maxn_congruence_l : forall a b c,
  a <= b ->
  maxn a c <= maxn b c.
Proof.
  move=> a b c I. rewrite /maxn. case I': (b < c).
  - have E: a < c; first by lias. by rewrite E.
  - case: (a < c) => //. by lias.
Qed.

Lemma maxn_congruence_r : forall a b c,
  a <= b ->
  maxn c a <= maxn c b.
Proof.
  move=> a b c I. rewrite (maxnC c a) (maxnC c b). by apply: maxn_congruence_l.
Qed.

(** * An equivalent to [List.Forall], but in [Type] instead of [Prop]. **)

Module TProp.

Inductive Forall (A : Type) (P : A -> Type) : seq A -> Type :=
  | Forall_nil : Forall P nil
  | Forall_cons : forall e l, P e -> Forall P l -> Forall P (e :: l)
  .

Fixpoint max A l (F : Forall (fun (_ : A) => nat) l) : nat :=
  match F with
  | Forall_nil => 0
  | Forall_cons _ _ n F => maxn n (max F)
  end.

Fixpoint sum A l (F : Forall (fun (_ : A) => nat) l) : nat :=
  match F with
  | Forall_nil => 0
  | Forall_cons _ _ n F => n + (sum F)
  end.

Fixpoint map A P Q (f : forall a, P a -> Q a) (l : seq A) (F : Forall P l) : Forall Q l :=
  match F with
  | Forall_nil => Forall_nil _
  | Forall_cons _ _ p F => Forall_cons (f _ p) (map f F)
  end.

Fixpoint to_list A B (l : list A) (F : Forall (fun _ => B) l) :=
  match F with
  | Forall_nil => [::]
  | Forall_cons _ _ p F => p :: to_list F
  end.

Fixpoint from_list A (l : list A) : Forall (fun _ => A) l :=
  match l with
  | [::] => Forall_nil _
  | e :: l => Forall_cons e (from_list l)
  end.

Definition Concat A P (l1 l2 : list A) (F1 : Forall P l1) (F2 : Forall P l2) : Forall P (l1 ++ l2).
Proof.
  induction l1 => /=.
  - by apply: F2.
  - inversion F1; subst. apply: Forall_cons => //. by apply: IHl1.
Defined.

Lemma Forall_forall : forall A (P : A -> Prop) l,
  Forall P l ->
  forall e, List.In e l -> P e.
Proof.
  move=> A P l. elim {l}.
  - by [].
  - move=> e l Pe F IH e' /=. case.
    + move=> E. by subst.
    + by apply: IH.
Qed.

Lemma forall_Forall : forall A (P : A -> Prop) l,
  (forall e, List.In e l -> P e) ->
  Forall P l.
Proof.
  move=> A P. elim.
  - move=> _. by apply: Forall_nil.
  - move=> e l IH H. apply: Forall_cons.
    + apply: H. by left.
    + apply: IH => e' I. apply: H. by right.
Defined.

Lemma Forall_List_Forall : forall A (P : A -> Prop) l,
  Forall P l ->
  List.Forall P l.
Proof.
  move=> > F. apply List.Forall_forall. by apply: Forall_forall F.
Qed.

Lemma List_Forall_Forall : forall A (P : A -> Prop) l,
  List.Forall P l ->
  Forall P l.
Proof.
  move=> > F. apply: forall_Forall. by apply List.Forall_forall.
Defined.

Lemma Forall_cat A (P : A -> Prop) (l1 l2 : list A) (F1 : Forall P l1) (F2 : Forall P l2)
  : Forall P (l1 ++ l2).
Proof.
  induction F1 => //. by apply: Forall_cons.
Defined.

Lemma Forall_catrev A (P : A -> Prop) : forall (l1 l2 : list A),
  Forall P l1 -> Forall P l2 -> Forall P (rev l1 ++ l2).
Proof.
  move=> l1 + F1. induction F1 => // l2 F2.
  rewrite rev_cons -cats1 -catA. apply: IHF1. by apply: Forall_cons.
Defined.

Lemma Forall_rev A (P : A -> Prop) (l : list A) (F : Forall P l) : Forall P (rev l).
Proof.
  rewrite -(cats0 (rev l)). apply: Forall_catrev => //. by apply: Forall_nil.
Defined.

(* FIXME: There are too many opaque things there: I’m afraid that this is not provable.
Lemma Forall_catrevE : forall A (P : A -> Prop) l1 l2 (F1 : Forall P l1) (F2 : Forall P l2),
  Forall_catrev F1 F2 = Forall_cat (Forall_rev F1) F2.
Proof.
  move=> A P l1 + F1. induction F1 => l2 F2.
  - rewrite/Forall_rev /eq_rect => /=.
Qed.
*)

Lemma max_to_list A (l : seq A) (F : Forall _ l) :
  max F = foldr maxn 0 (to_list F).
Proof.
  elim F.
  - done.
  - move=> a l' p f E /=. by rewrite E.
Qed.

Lemma sum_to_list A (l : seq A) (F : Forall _ l) :
  sum F = foldr addn 0 (to_list F).
Proof.
  elim F.
  - done.
  - move=> a l' p f E /=. by rewrite E.
Qed.

Lemma to_list_size A B (l : seq A) (F : Forall (fun _ : A => B) l) :
  size (to_list F) = size l.
Proof.
  elim F.
  - done.
  - move=> a l' b F' E /=. by rewrite E.
Qed.

Lemma Forall_forall_eq_dec : forall A l1 l2,
  Forall (fun x : A => forall y, {x = y} + {x <> y}) l1 ->
  {l1 = l2} + {l1 <> l2}.
Proof.
  move=> A l1 + F. elim F.
  - by elim; [ left | right ].
  - clear. move=> e1 l1 C F IH. case; first by right.
    move=> e2 l2. destruct (C e2); last by right; inversion 1.
    destruct (IH l2); last by right; inversion 1.
    left. by subst.
Defined.

End TProp.

(** * Stronger Induction Principles **)

(** Try to fold an expression everywhere.
  More robust than [fold e in *]. **)
Ltac efold e :=
  repeat match goal with H : _ |- _ => progress fold e in H end;
  fold e.

(** Given a goal of the form [{C a1 … an = C a1' … an'} + {C a1 … an <> C a1' … an'}],
  replaces it with the goals [{a1 = a1'} + {a1 <> a1'}], …, [{an = an'} + {an <> an'}]. **)
Ltac decide_equality_injection :=
  lazymatch goal with
  | |- {?c1 = ?c2} + {_} =>
    let rec aux c1 c2 next :=
      lazymatch constr:((c1, c2)) with
      | (?c, ?c) => next tt
      | (?c1 ?a1, ?c2 ?a2) =>
        let H := fresh "decide" in
        assert (H : {a1 = a2} + {a1 <> a2});
          [| aux c1 c2 ltac:(fun _ =>
               destruct H as [H|H];
                 [ rewrite H; next tt
                 | right; by inversion 1 ]) ]
      end in
    aux c1 c2 ltac:(fun _ => by left)
  end.

(** Similar than [decidable_equality], but based on another induction principle.
  It will make use of hypotheses based on [TProp.Forall]. **)
Ltac decidable_equality_using rect :=
  let x := fresh "x" in
  let y := fresh "y" in
  move=> x; induction x using rect => y; destruct y;
    first [ by right; discriminate
          | decide_equality_injection;
            first [ by apply: TProp.Forall_forall_eq_dec
                  | decidable_equality ] ].

(** Given an induction principle, return the number of cases of the type. **)
Ltac count_cases rect :=
  let rec count_args rectf :=
    lazymatch rectf with
    | forall a, False => constr:(0)
    | _ -> ?rectf' =>
      let r := count_args rectf' in
      constr:(r.+1)
    end in
  lazymatch type of rect with
  | forall P : ?t -> Type, @?rectf P =>
    let r := constr:(rectf (fun _ : t => False)) in
    let r := eval simpl in r in
    count_args r
  end.

(** Returns a boolean depending on whether [t] and [t'] are reducible to one each other. **)
Ltac is_reducible t t' :=
  match t with
  | _ => let r := constr:((fun (_ : t = t') => true) (ltac:(reflexivity))) in
         eval simpl in r
  | _ => constr:(false)
  end.

(** Given an induction principle, return the type of a stronger induction principle.
  The projection is there to focus the induction principle on a different type (e.g. [list t]
  instead of [t]): possible values are [@id], [list], and [option]. **)
Ltac rect'_type_projection proj rect :=
  let fold_type t ta :=
    (* Try to fold [t] in [ta]. *)
    match tt with
    | _ => eval fold t in ta
    | _ => constr:(ta)
    end in
  let added_hyp t ta :=
    lazymatch ta with
    | list t => constr:(@TProp.Forall t)
    | option t => constr:(fun P (o : ta) => forall a : t, o = Some a -> P a)
    | _ => constr:(fun (_ : t -> Type) (_ : ta) => True)
    end in
  let add_hyp t ta P a r :=
    let h := added_hyp t ta in
    let h := constr:(h P a) in
    let h := eval simpl in h in
    lazymatch h with
    | True => r
    | _ => constr:(h -> r)
    end in
  let set_hyp t ta P a r :=
    let r := add_hyp t ta P a r in
    exact r in
  let update_hyp t hyp :=
    lazymatch hyp with
    | fun P => P _ => constr:(hyp)
    | fun P => forall a1 : ?t1, P (?C a1) =>
      let t1 :=  fold_type t t1 in
      constr:(fun P : t -> Type => forall a1 : t1,
        ltac:(set_hyp t t1 P a1 (P (C a1))))
    | fun P => forall (a1 : ?t1) (a2 : ?t2), P (?C a1 a2) =>
      let t1 :=  fold_type t t1 in
      let t2 :=  fold_type t t2 in
      constr:(fun P : t -> Type => forall (a1 : t1) (a2 : t2),
        ltac:(set_hyp t t1 P a1
          ltac:(add_hyp t t2 P a2 (P (C a1 a2)))))
    | fun P => forall (a1 : ?t1) (a2 : ?t2) (a3 : ?t3), P (?C a1 a2 a3) =>
      let t1 :=  fold_type t t1 in
      let t2 :=  fold_type t t2 in
      let t3 :=  fold_type t t3 in
      constr:(fun P : t -> Type => forall (a1 : t1) (a2 : t2) (a3 : t3),
        ltac:(set_hyp t t1 P a1
          ltac:(add_hyp t t2 P a2
            ltac:(add_hyp t t3 P a3 (P (C a1 a2 a3))))))
    | fun P => forall (a1 : ?t1) (a2 : ?t2) (a3 : ?t3) (a4 : ?t4), P (?C a1 a2 a3 a4) =>
      let t1 :=  fold_type t t1 in
      let t2 :=  fold_type t t2 in
      let t3 :=  fold_type t t3 in
      let t4 :=  fold_type t t4 in
      constr:(fun P : t -> Type => forall (a1 : t1) (a2 : t2) (a3 : t3) (a4 : t4),
        ltac:(set_hyp t t1 P a1
          ltac:(add_hyp t t2 P a2
            ltac:(add_hyp t t3 P a3
              ltac:(add_hyp t t4 P a4 (P (C a1 a2 a3 a4)))))))
    | fun P => forall (a1 : ?t1) (a2 : ?t2) (a3 : ?t3) (a4 : ?t4) (a5 : ?t5), P (?C a1 a2 a3 a4 a5) =>
      let t1 :=  fold_type t t1 in
      let t2 :=  fold_type t t2 in
      let t3 :=  fold_type t t3 in
      let t4 :=  fold_type t t4 in
      let t5 :=  fold_type t t5 in
      constr:(fun P : t -> Type => forall (a1 : t1) (a2 : t2) (a3 : t3) (a4 : t4) (a5 : t5),
        ltac:(set_hyp t t1 P a1
          ltac:(add_hyp t t2 P a2
            ltac:(add_hyp t t3 P a3
              ltac:(add_hyp t t4 P a4
                ltac:(add_hyp t t4 P a4 (P (C a1 a2 a3 a4 a5))))))))
    | fun P => forall (a1 : ?t1) (a2 : ?t2) (a3 : ?t3) (a4 : ?t4) (a5 : ?t5) (a6 : ?t6), P (?C a1 a2 a3 a4 a5 a6) =>
      let t1 :=  fold_type t t1 in
      let t2 :=  fold_type t t2 in
      let t3 :=  fold_type t t3 in
      let t4 :=  fold_type t t4 in
      let t5 :=  fold_type t t5 in
      let t6 :=  fold_type t t6 in
      constr:(fun P : t -> Type => forall (a1 : t1) (a2 : t2) (a3 : t3) (a4 : t4) (a5 : t5) (a6 : t6),
        ltac:(set_hyp t t1 P a1
          ltac:(add_hyp t t2 P a2
            ltac:(add_hyp t t3 P a3
              ltac:(add_hyp t t4 P a4
                ltac:(add_hyp t t5 P a5
                  ltac:(add_hyp t t6 P a6 (P (C a1 a2 a3 a4 a5 a6)))))))))
    end in
  let conclusion t rectf :=
    lazymatch rectf with
    | fun P => forall a : t, P a =>
      lazymatch proj with
      | @id => constr:(rectf)
      | list => constr:(fun P => forall l : list t, TProp.Forall P l)
      | option => constr:(fun P => forall (o : option t) (a : t), o = Some a -> P a)
      end
    end in
  let rec map_hyps t rectf :=
    lazymatch rectf with
    | fun P => @?hyp P -> @?rectf' P =>
      let r := update_hyp t hyp in
      let r' := map_hyps t rectf' in
      constr:(fun P => r P -> r' P)
    | fun P => forall a : ?t', P a =>
      (* The type [t'] might not be syntactically [t], but should be convertible. *)
      let rectf' := constr:(fun P => forall a : t, P a) in
      conclusion t rectf'
    end in
  lazymatch type of rect with
  | forall P : ?t -> Type, @?rectf P =>
    let r := map_hyps t rectf in
    let r := constr:(forall P, r P) in
    eval simpl in r
  end.

(** The main instantiation. **)
Ltac rect'_type rect := rect'_type_projection @id rect.

(** Instantiation for lists. **)
Ltac rect'_type_list rect := rect'_type_projection list rect.

(** Instantiation for option types. **)
Ltac rect'_type_option rect := rect'_type_projection option rect.

(** Prove a goal whose type matches the type generated by [rect'_type] with the same parameter. **)
Ltac rect'_build_projection proj rect :=
  let t :=
    lazymatch type of rect with
    | forall P : ?t -> Type, _ => t
    end in
  let g := rect'_type_projection proj rect in
  refine (_ : g);
  let P := fresh "P" in
  intro P;
  repeat (
    try fold t;
    lazymatch goal with
    | |- forall a : t, P a => idtac
    | |- forall l : list t, TProp.Forall P l =>
      let l := fresh "l" in
      let a := fresh "a" in
      intro l; induction l as [| a l ];
      [ solve [ apply TProp.Forall_nil ]
      | apply TProp.Forall_cons; [ generalize a | assumption ] ]
    | |- forall (o : option t) (a : t), o = Some a -> P a =>
      let o := fresh "o" in
      let a := fresh "a" in
      intros o a; destruct o;
        let E := fresh "E" in
        intro E; inversion E;
        generalize a
    | |- _ -> _ => intro
    end);
  let rect := fresh "rect" in
  fix rect 1;
  let rect_list := fresh "rect_list" in
  refine (
    let rect_list :=
      fix rect_list es : TProp.Forall P es :=
        match es with
        | [::] => TProp.Forall_nil _
        | e :: l => TProp.Forall_cons (rect e) (rect_list l)
        end in _);
  let do_it := clear rect rect_list; auto in
  let use_hyps :=
    try fold t;
    intros;
    try fold t in *;
    repeat match goal with
    | a : t |- _ =>
      lazymatch goal with
      | H : P a |- _ => fail
      | _ => move: (rect a) => ?
      end
    | l : list t |- _ =>
      lazymatch goal with
      | H : TProp.Forall P l |- _ => fail
      | _ => move: (rect_list l) => ?
      end
    | o : option t |- _ => destruct o
    end in
  case; try solve [ do_it | use_hyps; do_it ].

(** The main instantiation. **)
Ltac rect'_build rect := rect'_build_projection @id rect.

(** Instantiation for lists. **)
Ltac rect'_build_list rect := rect'_build_projection list rect.

(** Instantiation for option types. **)
Ltac rect'_build_option rect := rect'_build_projection option rect.

(** * Lemmas about pickability. **)

Lemma list_search_prefix_pickable : forall A (P : seq A -> Prop),
  comparable A ->
  (forall l, decidable (P l)) ->
  forall l l', pickable (fun lf => l' = l ++ lf /\ P lf).
Proof.
  move=> A + C + l. elim l.
  - move=> P D l'. case (D l') => d.
    + left. by exists l'.
    + right. move=> [lf [E nd]]. by subst.
  - move {l} => a l IH P D l'. case l'.
    + right. by move => [lf [E _]].
    + move {l'} => a' l'. case (C a a') => E.
      * subst. case (IH _ D l').
        -- move=> E. left. destruct E as (lf&E'&p). exists lf. by rewrite E'.
        -- move=> nE. right. move=> [lf [E p]]. apply: nE. exists lf. by inversion E.
      * right. move=> [lf [E' _]]. inversion E'. by apply: E.
Defined.

Lemma list_search_suffix_pickable : forall A (P : seq A -> Prop),
  comparable A ->
  (forall l, decidable (P l)) ->
  forall l l', pickable (fun ls => l' = ls ++ l /\ P ls).
Proof.
  move=> A P C D l l'.
  have Dr: forall l, decidable (P (rev l)).
  { clear - D. move=> l. by apply: D. }
  case (list_search_prefix_pickable C Dr (rev l) (rev l')) => E.
  - left. destruct E as (lf&E&p). exists (rev lf). split => //.
    by rewrite -(revK l') E rev_cat revK.
  - right. move=> [ls [El' p]]. apply: E. exists (rev ls).
    by rewrite revK El' rev_cat.
Defined.

Lemma list_split_pickable2_gen : forall A (P : seq A -> seq A -> Prop) l,
  (forall l1 l2, l = l1 ++ l2 -> decidable (P l1 l2)) ->
  pickable2 (fun l1 l2 => l = l1 ++ l2 /\ P l1 l2).
Proof.
  move=> A + l. elim l.
  - move=> P D. case (D [::] [::]) => // Y.
    + left. by exists ([::], [::]).
    + right. move=> [l1 [l2 [E p]]]. symmetry in E. move: (cat0_inv E) => [? ?]. by subst.
  - move {l} => a l IH P D.
    have Da: forall l1 l2, l = l1 ++ l2 -> decidable (P (a :: l1) l2).
    { clear - D. move=> l1 l2 ?. apply: D. by subst. }
    have Pa: pickable2 (fun l1 l2 => a :: l = l1 ++ l2 /\ P l1 l2 /\ l1 <> [::]).
    {
      have Pa: pickable2 (fun l1 l2 => a :: l = (a :: l1) ++ l2 /\ P (a :: l1) l2).
      {
        apply: pickable2_equiv; last by apply (IH _ Da). move=> l1 l2. split.
        - move=> [E p]. by subst.
        - move=> [E p]. by inversion E.
      }
      case Pa.
      - move=> [[l1 l2] [E p]]. left. exists (a :: l1, l2). by split.
      - move=> Ex. right. move=> [l1 [l2 [E [p d]]]].
        apply: Ex. destruct l1 as [|a' l1] => //. inversion E.
        exists l1. exists l2. by subst.
    }
    case Pa.
    + move=> [[l1 l2] [E [p d]]]. left. by exists (l1, l2).
    + move=> nE. case (D [::] (a :: l)) => //.
      * left. exists ([::], a :: l). by split.
      * move=> np. right. move=> [l1 [l2 [E p]]]. apply: nE.
        exists l1. exists l2. repeat split => //. move=> ?. subst. simpl in E. by subst.
Defined.

Lemma list_split_pickable2 : forall A (P : seq A -> seq A -> Prop),
  (forall l1 l2, decidable (P l1 l2)) ->
  forall l, pickable2 (fun l1 l2 => l = l1 ++ l2 /\ P l1 l2).
Proof.
  move=> A P D l. by apply: list_split_pickable2_gen.
Defined.

Lemma list_search_split_pickable2 : forall A (P : seq A -> seq A -> Prop),
  comparable A ->
  (forall l1 l2, decidable (P l1 l2)) ->
  forall l l', pickable2 (fun l1 l2 => l' = l1 ++ l ++ l2 /\ P l1 l2).
Proof.
  move=> A P C D l l'.
  move: (list_split_pickable2 (P := fun l1 l2 => exists l2', l2 = l ++ l2' /\ P l1 l2')) => D'.
  apply: (pickable2_convert (f := fun '(l1, l2) => (l1, drop (size l) l2))); last apply: (D' _ l').
  - move=> l1 l2 [E1 [l2' [E2 p]]]. subst. rewrite drop_cat.
    rewrite_by ((size l < size l) = false). rewrite_by (size l - size l = 0). by rewrite drop0.
  - move=> l1 l2 [E p]. exists l1. exists (l ++ l2). repeat split => //. by exists l2.
  - move=> l1 l2. apply pickable_decidable. by apply: list_search_prefix_pickable.
Defined.

Lemma list_split_pickable3_gen : forall A (P : seq A -> seq A -> seq A -> Prop) l,
  (forall l1 l2 l3, l = l1 ++ l2 ++ l3 -> decidable (P l1 l2 l3)) ->
  pickable3 (fun l1 l2 l3 => l = l1 ++ l2 ++ l3 /\ P l1 l2 l3).
Proof.
  move=> A P l D.
  have D1: forall l23 l1, l = l1 ++ l23 -> pickable2 (fun l2 l3 => l23 = l2 ++ l3 /\ P l1 l2 l3).
  { move=> l23 l1 E. apply: list_split_pickable2_gen. move=> ? ? E'. subst. by apply D. }
  have: pickable2 (fun l1 l23 => l = l1 ++ l23 /\ exists l2 l3, l23 = l2 ++ l3 /\ P l1 l2 l3).
  { apply: list_split_pickable2_gen. move=> l1 l23 E. by convert_pickable (D1 _ _ E). }
  case.
  - move=> [[l1 l23] [E1 H]]. left. case (D1 _ _ E1).
    + move=> [[l2 l3] [E2 p]]. exists (l1, l2, l3). by subst.
    + move=> Ex. exfalso. apply: Ex. move: H => [l2 [l3 [E2 p]]]. exists l2. by exists l3.
  - move=> Ex. right. move=> [l1 [l2 [l3 [E p]]]]. apply: Ex. exists l1. exists (l2 ++ l3).
    split => //. by repeat eexists.
Defined.

Lemma list_split_pickable3 : forall A (P : seq A -> seq A -> seq A -> Prop),
  (forall l1 l2 l3, decidable (P l1 l2 l3)) ->
  forall l, pickable3 (fun l1 l2 l3 => l = l1 ++ l2 ++ l3 /\ P l1 l2 l3).
Proof.
  move=> A P D l. by apply: list_split_pickable3_gen.
Defined.

(** * Miscellaneous **)

(** Calls [cont1] or [cont2] depending on whether [x] is a variable or not.
  This tactic assumes that neither [cont1] nor [cont2] fail. **)
Ltac is_variable x cont1 cont2 :=
  match tt with
  | _ =>
    (* Sorry for the hack.
      Only a variable be cleared.
      Local definitions are not considered variables by this tactic. *)
    (exfalso; clear - x; assert_fails clearbody x; fail 1) || cont2
  | _ => cont1
  end.


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism
Terminal Dual Initial Product CoProduct Exponential CCC IPL STLC Functor
NaturalTransformation Adjunction ParamKleisliTriple Monad Presheaf Yoneda IndexedCategories ComparisonK EilenbergMoore.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import JMeq.

Set Universe Polymorphism.

Arguments fmap {_} {_} _ {_} {_} _.
Arguments fobj {_} {_} _ _.
Arguments Compose_Functors {_} {_} {_} _ _.
Arguments NaturalTransformation {_} {_} _ _.
Arguments trans {_} {_} {_} {_} _ _.
Arguments Compose_NaturalTransformations {_ _ _ _ _ } _ _.
Arguments Compose_NaturalTransformations_H {_ _ _ _ _ } _ _.

Arguments eta {_ _} _.
Arguments mu  {_ _} _.

Arguments unit {_ _ _ _} _.
Arguments counit {_ _ _ _} _.

Definition KT: ∏ {C D: Category} (F: Functor C D) (G: Functor D C) (A: Adjunction F G),
                let M   := adj_mon F G A in
                let EMC := EilenbergMooreCategory M in Functor D EMC.
Proof. intros.
       unshelve econstructor.
       - intro X.
         exists (fobj G X).
         exists (fmap G (trans (counit A) X)).
         split.
         + now rewrite (@ob2 _ _ _ _ A).
         + cbn in *.
           rewrite <- !preserve_comp. f_equal.
           specialize (@comm_diag _ _ _ _ (counit A) _ _ (trans (counit A) X)); intro H.
           cbn in *. unfold id in *. now rewrite <- H.
       - intros X Y f.
         exists (fmap G f).
         cbn in *.
         rewrite <- !preserve_comp. f_equal.
         specialize (@comm_diag _ _ _ _ (counit A) _ _ f); intro H.
         cbn in *. unfold id in *. now rewrite <- H.
       - repeat intro. now subst.
       - intro X.
         apply eqTAM. cbn in *.
         now rewrite preserve_id.
       - intros X Y Z g f.
         apply eqTAM.
         cbn in *.
         now rewrite preserve_comp.
Defined.

Lemma commKT: ∏ {C D: Category} (F: Functor C D) (G: Functor D C) (A: Adjunction F G),
               let M   := (adj_mon F G A) in
               let EMC := (EilenbergMooreCategory M) in
                 (Compose_Functors (KT F G A) (GT M)) = G /\ (Compose_Functors F (KT F G A)) = (FT M).
Proof. intros C D F G A M EMC; split.
       - apply F_split.
         + easy.
         + apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep, eq_existT_uncurried.
           cbn. unfold eq_rect.
           exists eq_refl. easy.
       - apply F_split.
         + cbn. unfold id in *.
           extensionality a.
           apply f_equal.
           apply eqTA; easy.
         + assert (H: fobj (Compose_Functors F (KT F G A)) = fobj (FT M)).
           cbn. unfold id in *.
           extensionality a.
           apply f_equal.
           apply eqTA; easy.

           apply eq_dep_id_JMeq.
           apply EqdepFacts.eq_sigT_iff_eq_dep.
           apply eq_existT_uncurried.

           assert ((∏ a b : obj,
           arrow b a -> arrow (fobj (Compose_Functors F (KT F G A)) b)
            (fobj (Compose_Functors F (KT F G A)) a)) =
            (∏ a b : obj, arrow b a -> arrow (fobj (FT M) b) (fobj (FT M) a)) ).
           { now rewrite H. }

           exists H0.
           unfold eq_rect.
           assert (H0 = eq_refl).
           { specialize (UIP_refl _
               (∏ a b : obj, arrow b a -> arrow (fobj (FT M) b) (fobj (FT M) a))); intros.
             now specialize (H1 H0).
           }
           rewrite H1.
           cbn.

           extensionality x.
           extensionality y.
           extensionality f.
           now apply subset_eq_compat.
Qed.

Arguments fmap {_} {_} _ _ _ _.
Arguments fobj {_} {_} _ _.

(** sameness of Functors, inspired by Amin Timany *)
Lemma F_split2: forall
               (C D  : Category)
               (F G  : Functor C D)
               (ObjEq: (fobj F) = (fobj G)),
               ((fun a b =>
                   match ObjEq in _ = V return ((arrow b a) -> (arrow (V b) (V a))) with
                    | eq_refl => (fmap F a b)
                   end) = fmap G) -> F = G.
Proof.
    destruct F; destruct G; simpl; intros; subst; f_equal.
    now destruct (proof_irrelevance _ fmapP0 fmapP).
    now destruct (proof_irrelevance _ preserve_id0 preserve_id).
    now destruct (proof_irrelevance _ preserve_comp0 preserve_comp).
Defined.

Lemma K_unique: forall
               {C D    : Category}
               (F      : Functor C D)
               (G      : Functor D C)
               (A1     : Adjunction F G),
               let M   := (adj_mon F G A1) in
               let EMC := (EilenbergMooreCategory M) in
               let A2  := (mon_emadj M) in
                 forall R : Functor D EMC, Compose_Functors R (GT M) = G /\
                                           Compose_Functors F R = (FT M) -> (KT F G A1) = R.
Proof. intros C D F G A1 M CK A2 R H.
       assert (H1: (Compose_Functors (KT F G A1) (GT M)) = G /\ (Compose_Functors F (KT F G A1)) = (FT M)).
       specialize (commKT F G A1); intros cKT. apply cKT.
       destruct H as (Ha, Hb).
       destruct H1 as (H1a, H1b).
       assert (fobj (KT F G A1) = fobj R).
       { extensionality a.
         apply EMOeq.
         split.
         + simpl.
           rewrite <- H1b in Hb.
           assert (H2: fobj (Compose_Functors F R) = fobj (Compose_Functors F (KT F G A1))).
           rewrite Hb. easy.
           rewrite <- H1a in Ha.
           assert (H3: fobj (Compose_Functors R (GT M)) = fobj (Compose_Functors (KT F G A1) (GT M))).
           rewrite Ha. easy.
           cbn in H3.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H3) as H3';
           cbv beta in H3'.
           specialize (H3' a).
           rewrite <- H3'.
           reflexivity.
         + apply eq_dep_id_JMeq.
           apply EqdepFacts.eq_sigT_iff_eq_dep.
           apply eq_existT_uncurried.
           simpl.
           assert (fobj G a = projT1 (fobj R a)).
           {
           rewrite <- H1b in Hb.
           assert (H2: fobj (Compose_Functors F R) = fobj (Compose_Functors F (KT F G A1))).
           rewrite Hb. easy.
           rewrite <- H1a in Ha.
           assert (H3: fobj (Compose_Functors R (GT M)) = fobj (Compose_Functors (KT F G A1) (GT M))).
           rewrite Ha. easy.
           cbn in H3.
           pose proof (fun x => eq_ind_r (fun f => f x = _ x ) eq_refl H3) as H3';
           cbv beta in H3'.
           specialize (H3' a).
           rewrite <- H3'.
           reflexivity.
           }
           cbn in *.
           unfold eq_rect.
           destruct (fobj R a).
           simpl.
           simpl in H.
           subst.
           exists eq_refl.
           destruct t as (f, (tob1, tob2)).
           simpl in *.

           destruct A1 as ((unit, obun), (counit, obcoun), ob1, ob2).
           simpl in *.
           rewrite <- ob2 in tob1.
           admit.
       }
       apply F_split2 with (ObjEq := H).
       extensionality a.
       extensionality b.
       extensionality f.
       apply eqTAM.
       f_equal.
       destruct R.
       simpl in *.
       subst fobj.
       rewrite sig_eta.
       Search exist.
       apply subset_eq_compat.
       simpl.
       destruct G.
       simpl in *.
Admitted.