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

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

Require Import Le Gt Minus Min Bool.

Set Implicit Arguments.

(******************************************************************)
(** * Basics: definition of polymorphic lists and some operations *)
(******************************************************************)

(** The definition of [list] is now in [Init/Datatypes],
    as well as the definitions of [length] and [app] *)

Open Scope list_scope.

Section Lists.

  Variable A : Type.

  (** Head and tail *)

  Definition hd (default:A) (l:list A) :=
    match l with
      | nil => default
      | x :: _ => x
    end.

  Definition hd_error (l:list A) :=
    match l with
      | nil => error
      | x :: _ => value x
    end.

  Definition tl (l:list A) :=
    match l with
      | nil => nil
      | a :: m => m
    end.

  (** The [In] predicate *)
  Fixpoint In (a:A) (l:list A) : Prop :=
    match l with
      | nil => False
      | b :: m => b = a \/ In a m
    end.

End Lists.

(* Keep these notations local to prevent conflicting notations *)
Local Notation "[ ]" := nil : list_scope.
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..) : list_scope.

(** ** Facts about lists *)

Section Facts.

  Variable A : Type.

  (** *** Genereric facts *)

  (** Discrimination *)
  Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
  Proof.
    intros; discriminate.
  Qed.

  (** Destruction *)

  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = []}.
  Proof.
    induction l as [|a tail].
    right; reflexivity.
    left; exists a, tail; reflexivity.
  Qed.

  (** *** Head and tail *)

  Theorem hd_error_nil : hd_error (@nil A) = None.
  Proof.
    simpl; reflexivity.
  Qed.

  Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x.
  Proof.
    intros; simpl; reflexivity.
  Qed.

  (************************)
  (** *** Facts about [In] *)
  (************************)

  (** Characterization of [In] *)

  Theorem in_eq : forall (a:A) (l:list A), In a (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Theorem in_nil : forall a:A, ~ In a [].
  Proof.
    unfold not; intros a H; inversion_clear H.
  Qed.

  Theorem in_split : forall x (l:list A), In x l -> exists l1, exists l2, l = l1++x::l2.
  Proof.
  induction l; simpl; destruct 1.
  subst a; auto.
  exists [], l; auto.
  destruct (IHl H) as (l1,(l2,H0)).
  exists (a::l1), l2; simpl; f_equal; auto.
  Qed.

  (** Inversion *)
  Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
  Proof.
    intros a b l H; inversion_clear H; auto.
  Qed.

  (** Decidability of [In] *)
  Theorem in_dec :
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (a:A) (l:list A), {In a l} + {~ In a l}.
  Proof.
    intro H; induction l as [| a0 l IHl].
    right; apply in_nil.
    destruct (H a0 a); simpl; auto.
    destruct IHl; simpl; auto.
    right; unfold not; intros [Hc1| Hc2]; auto.
  Defined.

  (**************************)
  (** *** Facts about [app] *)
  (**************************)

  (** Discrimination *)
  Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y.
  Proof.
    unfold not.
    destruct x as [| a l]; simpl; intros.
    discriminate H.
    discriminate H.
  Qed.

  (** Concat with [nil] *)
  Theorem app_nil_l : forall l:list A, [] ++ l = l.
  Proof.
    reflexivity.
  Qed.

  Theorem app_nil_r : forall l:list A, l ++ [] = l.
  Proof.
    induction l; simpl; f_equal; auto.
  Qed.

  (* begin hide *)
  (* Deprecated *)
  Theorem app_nil_end : forall (l:list A), l = l ++ [].
  Proof. symmetry; apply app_nil_r. Qed.
  (* end hide *)

  (** [app] is associative *)
  Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
  Proof.
    intros l m n; induction l; simpl; f_equal; auto.
  Qed.

  (* begin hide *)
  (* Deprecated *)
  Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
  Proof.
     auto using app_assoc.
  Qed.
  Hint Resolve app_assoc_reverse.
  (* end hide *)

  (** [app] commutes with [cons] *)
  Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
  Proof.
    auto.
  Qed.

  (** Facts deduced from the result of a concatenation *)

  Theorem app_eq_nil : forall l l':list A, l ++ l' = [] -> l = [] /\ l' = [].
  Proof.
    destruct l as [| x l]; destruct l' as [| y l']; simpl; auto.
    intro; discriminate.
    intros H; discriminate H.
  Qed.

  Theorem app_eq_unit :
    forall (x y:list A) (a:A),
      x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
  Proof.
    destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
      simpl.
    intros a H; discriminate H.
    left; split; auto.
    right; split; auto.
    generalize H.
    generalize (app_nil_r l); intros E.
    rewrite -> E; auto.
    intros.
    injection H.
    intro.
    cut ([] = l ++ a0 :: l0); auto.
    intro.
    generalize (app_cons_not_nil _ _ _ H1); intro.
    elim H2.
  Qed.

  Lemma app_inj_tail :
    forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b.
  Proof.
    induction x as [| x l IHl];
      [ destruct y as [| a l] | destruct y as [| a l0] ];
      simpl; auto.
    intros a b H.
    injection H.
    auto.
    intros a0 b H.
    injection H; intros.
    generalize (app_cons_not_nil _ _ _ H0); destruct 1.
    intros a b H.
    injection H; intros.
    cut ([] = l ++ [a]); auto.
    intro.
    generalize (app_cons_not_nil _ _ _ H2); destruct 1.
    intros a0 b H.
    injection H; intros.
    destruct (IHl l0 a0 b H0).
    split; auto.
    rewrite <- H1; rewrite <- H2; reflexivity.
  Qed.

  (** Compatibility wtih other operations *)

  Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
  Proof.
    induction l; simpl; auto.
  Qed.

  Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m.
  Proof.
    intros l m a.
    elim l; simpl; auto.
    intros a0 y H H0.
    now_show ((a0 = a \/ In a y) \/ In a m).
    elim H0; auto.
    intro H1.
    now_show ((a0 = a \/ In a y) \/ In a m).
    elim (H H1); auto.
  Qed.

  Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m).
  Proof.
    intros l m a.
    elim l; simpl; intro H.
    now_show (In a m).
    elim H; auto; intro H0.
    now_show (In a m).
    elim H0. (* subProof completed *)
    intros y H0 H1.
    now_show (H = a \/ In a (y ++ m)).
    elim H1; auto 4.
    intro H2.
    now_show (H = a \/ In a (y ++ m)).
    elim H2; auto.
  Qed.

  Lemma in_app_iff : forall l l' (a:A), In a (l++l') <-> In a l \/ In a l'.
  Proof.
    split; auto using in_app_or, in_or_app.
  Qed.

  Lemma app_inv_head:
   forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2.
  Proof.
    induction l; simpl; auto; injection 1; auto.
  Qed.

  Lemma app_inv_tail:
    forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2.
  Proof.
    intros l l1 l2; revert l1 l2 l.
    induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2];
     simpl; auto; intros l H.
    absurd (length (x2 :: l2 ++ l) <= length l).
    simpl; rewrite app_length; auto with arith.
    rewrite <- H; auto with arith.
    absurd (length (x1 :: l1 ++ l) <= length l).
    simpl; rewrite app_length; auto with arith.
    rewrite H; auto with arith.
    injection H; clear H; intros; f_equal; eauto.
  Qed.

End Facts.

Hint Resolve app_assoc app_assoc_reverse: datatypes v62.
Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
Hint Immediate app_eq_nil: datatypes v62.
Hint Resolve app_eq_unit app_inj_tail: datatypes v62.
Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.

(*******************************************)
(** * Operations on the elements of a list *)
(*******************************************)

Section Elts.

  Variable A : Type.

  (*****************************)
  (** ** Nth element of a list *)
  (*****************************)

  Fixpoint nth (n:nat) (l:list A) (default:A) {struct l} : A :=
    match n, l with
      | O, x :: l' => x
      | O, other => default
      | S m, [] => default
      | S m, x :: t => nth m t default
    end.

  Fixpoint nth_ok (n:nat) (l:list A) (default:A) {struct l} : bool :=
    match n, l with
      | O, x :: l' => true
      | O, other => false
      | S m, [] => false
      | S m, x :: t => nth_ok m t default
    end.

  Lemma nth_in_or_default :
    forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
  (* Realizer nth_ok. Program_all. *)
  Proof.
    intros n l d; generalize n; induction l; intro n0.
    right; case n0; trivial.
    case n0; simpl.
    auto.
    intro n1; elim (IHl n1); auto.
  Qed.

  Lemma nth_S_cons :
    forall (n:nat) (l:list A) (d a:A),
      In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A :=
    match n, l with
      | O, x :: _ => value x
      | S n, _ :: l => nth_error l n
      | _, _ => error
    end.

  Definition nth_default (default:A) (l:list A) (n:nat) : A :=
    match nth_error l n with
      | Some x => x
      | None => default
    end.

  Lemma nth_default_eq :
    forall n l (d:A), nth_default d l n = nth n l d.
  Proof.
    unfold nth_default; induction n; intros [ | ] ?; simpl; auto.
  Qed.

  Lemma nth_In :
    forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.

  Proof.
    unfold lt; induction n as [| n hn]; simpl.
    destruct l; simpl; [ inversion 2 | auto ].
    destruct l as [| a l hl]; simpl.
    inversion 2.
    intros d ie; right; apply hn; auto with arith.
  Qed.

  Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
  Proof.
    induction l; destruct n; simpl; intros; auto.
    inversion H.
    apply IHl; auto with arith.
  Qed.

  Lemma nth_indep :
    forall l n d d', n < length l -> nth n l d = nth n l d'.
  Proof.
    induction l; simpl; intros; auto.
    inversion H.
    destruct n; simpl; auto with arith.
  Qed.

  Lemma app_nth1 :
    forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
  Proof.
    induction l.
    intros.
    inversion H.
    intros l' d n.
    case n; simpl; auto.
    intros; rewrite IHl; auto with arith.
  Qed.

  Lemma app_nth2 :
    forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
  Proof.
    induction l.
    intros.
    simpl.
    destruct n; auto.
    intros l' d n.
    case n; simpl; auto.
    intros.
    inversion H.
    intros.
    rewrite IHl; auto with arith.
  Qed.

  (*****************)
  (** ** Remove    *)
  (*****************)

  Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.

  Fixpoint remove (x : A) (l : list A) : list A :=
    match l with
      | [] => []
      | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
    end.

  Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l).
  Proof.
    induction l as [|x l]; auto.
    intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx].
    apply IHl.
    unfold not; intro HF; simpl in HF; destruct HF; auto.
    apply (IHl y); assumption.
  Qed.

(******************************)
(** ** Last element of a list *)
(******************************)

  (** [last l d] returns the last element of the list [l],
    or the default value [d] if [l] is empty. *)

  Fixpoint last (l:list A) (d:A) : A :=
  match l with
    | [] => d
    | [a] => a
    | a :: l => last l d
  end.

  (** [removelast l] remove the last element of [l] *)

  Fixpoint removelast (l:list A) : list A :=
    match l with
      | [] =>  []
      | [a] => []
      | a :: l => a :: removelast l
    end.

  Lemma app_removelast_last :
    forall l d, l <> [] -> l = removelast l ++ [last l d].
  Proof.
    induction l.
    destruct 1; auto.
    intros d _.
    destruct l; auto.
    pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
  Qed.

  Lemma exists_last :
    forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}.
  Proof.
    induction l.
    destruct 1; auto.
    intros _.
    destruct l.
    exists [], a; auto.
    destruct IHl as [l' (a',H)]; try discriminate.
    rewrite H.
    exists (a::l'), a'; auto.
  Qed.

  Lemma removelast_app :
    forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    assert (l++l' <> []).
    destruct l.
    simpl; auto.
    simpl; discriminate.
    specialize (IHl l' H).
    destruct (l++l'); [elim H0; auto|f_equal; auto].
  Qed.

  (****************************************)
  (** ** Counting occurences of a element *)
  (****************************************)

  Fixpoint count_occ (l : list A) (x : A) : nat :=
    match l with
      | [] => 0
      | y :: tl =>
	let n := count_occ tl x in
	  if eq_dec y x then S n else n
    end.

  (** Compatibility of count_occ with operations on list *)
  Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0.
  Proof.
    induction l as [|y l].
    simpl; intros; split; [destruct 1 | apply gt_irrefl].
    simpl. intro x; destruct (eq_dec y x) as [Heq|Hneq].
    rewrite Heq; intuition.
    pose (IHl x). intuition.
  Qed.

  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = [].
  Proof.
    split.
    (* Case -> *)
    induction l as [|x l].
    trivial.
    intro H.
    elim (O_S (count_occ l x)).
    apply sym_eq.
    generalize (H x).
    simpl. destruct (eq_dec x x) as [|HF].
    trivial.
    elim HF; reflexivity.
    (* Case <- *)
    intro H; rewrite H; simpl; reflexivity.
  Qed.

  Lemma count_occ_nil : forall (x : A), count_occ [] x = 0.
  Proof.
    intro x; simpl; reflexivity.
  Qed.

  Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y).
  Proof.
    intros l x y H; simpl.
    destruct (eq_dec x y); [reflexivity | contradiction].
  Qed.

  Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y.
  Proof.
    intros l x y H; simpl.
    destruct (eq_dec x y); [contradiction | reflexivity].
  Qed.

End Elts.

(*******************************)
(** * Manipulating whole lists *)
(*******************************)

Section ListOps.

  Variable A : Type.

  (*************************)
  (** ** Reverse           *)
  (*************************)

  Fixpoint rev (l:list A) : list A :=
    match l with
      | [] => []
      | x :: l' => rev l' ++ [x]
    end.

  Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x.
  Proof.
    induction x as [| a l IHl].
    destruct y as [| a l].
    simpl.
    auto.

    simpl.
    rewrite app_nil_r; auto.

    intro y.
    simpl.
    rewrite (IHl y).
    rewrite app_assoc; trivial.
  Qed.

  Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l.
  Proof.
    intros.
    apply (rev_app_distr l [a]); simpl; auto.
  Qed.

  Lemma rev_involutive : forall l:list A, rev (rev l) = l.
  Proof.
    induction l as [| a l IHl].
    simpl; auto.

    simpl.
    rewrite (rev_unit (rev l) a).
    rewrite IHl; auto.
  Qed.

  (** Compatibility with other operations *)

  Lemma in_rev : forall l x, In x l <-> In x (rev l).
  Proof.
    induction l.
    simpl; intuition.
    intros.
    simpl.
    intuition.
    subst.
    apply in_or_app; right; simpl; auto.
    apply in_or_app; left; firstorder.
    destruct (in_app_or _ _ _ H); firstorder.
  Qed.

  Lemma rev_length : forall l, length (rev l) = length l.
  Proof.
    induction l;simpl; auto.
    rewrite app_length.
    rewrite IHl.
    simpl.
    elim (length l); simpl; auto.
  Qed.

  Lemma rev_nth : forall l d n,  n < length l ->
    nth n (rev l) d = nth (length l - S n) l d.
  Proof.
    induction l.
    intros; inversion H.
    intros.
    simpl in H.
    simpl (rev (a :: l)).
    simpl (length (a :: l) - S n).
    inversion H.
    rewrite <- minus_n_n; simpl.
    rewrite <- rev_length.
    rewrite app_nth2; auto.
    rewrite <- minus_n_n; auto.
    rewrite app_nth1; auto.
    rewrite (minus_plus_simpl_l_reverse (length l) n 1).
    replace (1 + length l) with (S (length l)); auto with arith.
    rewrite <- minus_Sn_m; auto with arith.
    apply IHl ; auto with arith.
    rewrite rev_length; auto.
  Qed.

  (**  An alternative tail-recursive definition for reverse *)

  Fixpoint rev_append (l l': list A) : list A :=
    match l with
      | [] => l'
      | a::l => rev_append l (a::l')
    end.

  Definition rev' l : list A := rev_append l [].

  Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'.
  Proof.
    induction l; simpl; auto; intros.
    rewrite <- app_assoc; firstorder.
  Qed.

  Lemma rev_alt : forall l, rev l = rev_append l [].
  Proof.
    intros; rewrite rev_append_rev.
    rewrite app_nil_r; trivial.
  Qed.

(*********************************************)
(** Reverse Induction Principle on Lists  *)
(*********************************************)

  Section Reverse_Induction.

    Lemma rev_list_ind :
      forall P:list A-> Prop,
	P [] ->
	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
	forall l:list A, P (rev l).
    Proof.
      induction l; auto.
    Qed.

    Theorem rev_ind :
      forall P:list A -> Prop,
	P [] ->
	(forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l.
    Proof.
      intros.
      generalize (rev_involutive l).
      intros E; rewrite <- E.
      apply (rev_list_ind P).
      auto.

      simpl.
      intros.
      apply (H0 a (rev l0)).
      auto.
    Qed.

  End Reverse_Induction.

  (***********************************)
  (** ** Decidable equality on lists *)
  (***********************************)

  Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}.

  Lemma list_eq_dec :
    forall l l':list A, {l = l'} + {l <> l'}.
  Proof.
    induction l as [| x l IHl]; destruct l' as [| y l'].
    left; trivial.
    right; apply nil_cons.
    right; unfold not; intro HF; apply (nil_cons (sym_eq HF)).
    destruct (eq_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql'];
      try (right; unfold not; intro HF; injection HF; intros; contradiction).
    rewrite xeqy; rewrite leql'; left; trivial.
  Qed.

End ListOps.

(***************************************************)
(** * Applying functions to the elements of a list *)
(***************************************************)

(************)
(** ** Map  *)
(************)

Section Map.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint map (l:list A) : list B :=
    match l with
      | nil => nil
      | cons a t => cons (f a) (map t)
    end.

  Lemma in_map :
    forall (l:list A) (x:A), In x l -> In (f x) (map l).
  Proof.
    induction l; firstorder (subst; auto).
  Qed.

  Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.
  Proof.
    induction l; firstorder (subst; auto).
  Qed.

  Lemma map_length : forall l, length (map l) = length l.
  Proof.
    induction l; simpl; auto.
  Qed.

  Lemma map_nth : forall l d n,
    nth n (map l) (f d) = f (nth n l d).
  Proof.
    induction l; simpl map; destruct n; firstorder.
  Qed.

  Lemma map_nth_error : forall n l d,
    nth_error l n = Some d -> nth_error (map l) n = Some (f d).
  Proof.
    induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto.
  Qed.

  Lemma map_app : forall l l',
    map (l++l') = (map l)++(map l').
  Proof.
    induction l; simpl; auto.
    intros; rewrite IHl; auto.
  Qed.

  Lemma map_rev : forall l, map (rev l) = rev (map l).
  Proof.
    induction l; simpl; auto.
    rewrite map_app.
    rewrite IHl; auto.
  Qed.

  Lemma map_eq_nil : forall l, map l = [] -> l = [].
  Proof.
    destruct l; simpl; reflexivity || discriminate.
  Qed.

  (** [flat_map] *)

  Definition flat_map (f:A -> list B) :=
    fix flat_map (l:list A) : list B :=
    match l with
      | nil => nil
      | cons x t => (f x)++(flat_map t)
    end.

  Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
    In y (flat_map f l) <-> exists x, In x l /\ In y (f x).
  Proof.
    induction l; simpl; split; intros.
    contradiction.
    destruct H as (x,(H,_)); contradiction.
    destruct (in_app_or _ _ _ H).
    exists a; auto.
    destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)).
    exists x; auto.
    apply in_or_app.
    destruct H as (x,(H0,H1)); destruct H0.
    subst; auto.
    right; destruct (IHl y) as (_,H2); apply H2.
    exists x; auto.
  Qed.

End Map.

Lemma map_id : forall (A :Type) (l : list A),
  map (fun x => x) l = l.
Proof.
  induction l; simpl; auto; rewrite IHl; auto.
Qed.

Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l,
  map g (map f l) = map (fun x => g (f x)) l.
Proof.
  induction l; simpl; auto.
  rewrite IHl; auto.
Qed.

Lemma map_ext :
  forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
Proof.
  induction l; simpl; auto.
  rewrite H; rewrite IHl; auto.
Qed.

(************************************)
(** Left-to-right iterator on lists *)
(************************************)

Section Fold_Left_Recursor.
  Variables A B : Type.
  Variable f : A -> B -> A.

  Fixpoint fold_left (l:list B) (a0:A) : A :=
    match l with
      | nil => a0
      | cons b t => fold_left t (f a0 b)
    end.

  Lemma fold_left_app : forall (l l':list B)(i:A),
    fold_left (l++l') i = fold_left l' (fold_left l i).
  Proof.
    induction l.
    simpl; auto.
    intros.
    simpl.
    auto.
  Qed.

End Fold_Left_Recursor.

Lemma fold_left_length :
  forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
Proof.
  intro A.
  cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l).
  intros.
  exact (H l 0).
  induction l; simpl; auto.
  intros; rewrite IHl.
  simpl; auto with arith.
Qed.

(************************************)
(** Right-to-left iterator on lists *)
(************************************)

Section Fold_Right_Recursor.
  Variables A B : Type.
  Variable f : B -> A -> A.
  Variable a0 : A.

  Fixpoint fold_right (l:list B) : A :=
    match l with
      | nil => a0
      | cons b t => f b (fold_right t)
    end.

End Fold_Right_Recursor.

  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i,
    fold_right f i (l++l') = fold_right f (fold_right f i l') l.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    f_equal; auto.
  Qed.

  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i,
    fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
  Proof.
    induction l.
    simpl; auto.
    intros.
    simpl.
    rewrite fold_right_app; simpl; auto.
  Qed.

  Theorem fold_symmetric :
    forall (A:Type) (f:A -> A -> A),
      (forall x y z:A, f x (f y z) = f (f x y) z) ->
      (forall x y:A, f x y = f y x) ->
      forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l.
  Proof.
    destruct l as [| a l].
    reflexivity.
    simpl.
    rewrite <- H0.
    generalize a0 a.
    induction l as [| a3 l IHl]; simpl.
    trivial.
    intros.
    rewrite H.
    rewrite (H0 a2).
    rewrite <- (H a1).
    rewrite (H0 a1).
    rewrite IHl.
    reflexivity.
  Qed.

  (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
      indexed by elts of [x], sorted in lexicographic order. *)

  Fixpoint list_power (A B:Type)(l:list A) (l':list B) :
    list (list (A * B)) :=
    match l with
      | nil => cons nil nil
      | cons x t =>
	flat_map (fun f:list (A * B) => map (fun y:B => cons (x, y) f) l')
        (list_power t l')
    end.

  (*************************************)
  (** ** Boolean operations over lists *)
  (*************************************)

  Section Bool.
    Variable A : Type.
    Variable f : A -> bool.

  (** find whether a boolean function can be satisfied by an
       elements of the list. *)

    Fixpoint existsb (l:list A) : bool :=
      match l with
	| nil => false
	| a::l => f a || existsb l
      end.

    Lemma existsb_exists :
      forall l, existsb l = true <-> exists x, In x l /\ f x = true.
    Proof.
      induction l; simpl; intuition.
      inversion H.
      firstorder.
      destruct (orb_prop _ _ H1); firstorder.
      firstorder.
      subst.
      rewrite H2; auto.
    Qed.

    Lemma existsb_nth : forall l n d, n < length l ->
      existsb l = false -> f (nth n l d) = false.
    Proof.
      induction l.
      inversion 1.
      simpl; intros.
      destruct (orb_false_elim _ _ H0); clear H0; auto.
      destruct n ; auto.
      rewrite IHl; auto with arith.
    Qed.

    Lemma existsb_app : forall l1 l2,
      existsb (l1++l2) = existsb l1 || existsb l2.
    Proof.
      induction l1; intros l2; simpl.
        solve[auto].
      case (f a); simpl; solve[auto].
    Qed.

  (** find whether a boolean function is satisfied by
    all the elements of a list. *)

    Fixpoint forallb (l:list A) : bool :=
      match l with
	| nil => true
	| a::l => f a && forallb l
      end.

    Lemma forallb_forall :
      forall l, forallb l = true <-> (forall x, In x l -> f x = true).
    Proof.
      induction l; simpl; intuition.
      destruct (andb_prop _ _ H1).
      congruence.
      destruct (andb_prop _ _ H1); auto.
      assert (forallb l = true).
      apply H0; intuition.
      rewrite H1; auto.
    Qed.

    Lemma forallb_app :
      forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2.
    Proof.
      induction l1; simpl.
        solve[auto].
      case (f a); simpl; solve[auto].
    Qed.
  (** [filter] *)

    Fixpoint filter (l:list A) : list A :=
      match l with
	| nil => nil
	| x :: l => if f x then x::(filter l) else filter l
      end.

    Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true.
    Proof.
      induction l; simpl.
      intuition.
      intros.
      case_eq (f a); intros; simpl; intuition congruence.
    Qed.

  (** [find] *)

    Fixpoint find (l:list A) : option A :=
      match l with
	| nil => None
	| x :: tl => if f x then Some x else find tl
      end.

  (** [partition] *)

    Fixpoint partition (l:list A) : list A * list A :=
      match l with
	| nil => (nil, nil)
	| x :: tl => let (g,d) := partition tl in
	  if f x then (x::g,d) else (g,x::d)
      end.

  End Bool.

  (******************************************************)
  (** ** Operations on lists of pairs or lists of lists *)
  (******************************************************)

  Section ListPairs.
    Variables A B : Type.

  (** [split] derives two lists from a list of pairs *)

    Fixpoint split (l:list (A*B)) : list A * list B :=
      match l with
	| nil => (nil, nil)
	| (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
      end.

    Lemma in_split_l : forall (l:list (A*B))(p:A*B),
      In p l -> In (fst p) (fst (split l)).
    Proof.
      induction l; simpl; intros; auto.
      destruct p; destruct a; destruct (split l); simpl in *.
      destruct H.
      injection H; auto.
      right; apply (IHl (a0,b) H).
    Qed.

    Lemma in_split_r : forall (l:list (A*B))(p:A*B),
      In p l -> In (snd p) (snd (split l)).
    Proof.
      induction l; simpl; intros; auto.
      destruct p; destruct a; destruct (split l); simpl in *.
      destruct H.
      injection H; auto.
      right; apply (IHl (a0,b) H).
    Qed.

    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B),
      nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
    Proof.
      induction l.
      destruct n; destruct d; simpl; auto.
      destruct n; destruct d; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
      destruct a; destruct (split l); simpl in *; auto.
      apply IHl.
    Qed.

    Lemma split_length_l : forall (l:list (A*B)),
      length (fst (split l)) = length l.
    Proof.
      induction l; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
    Qed.

    Lemma split_length_r : forall (l:list (A*B)),
      length (snd (split l)) = length l.
    Proof.
      induction l; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
    Qed.

  (** [combine] is the opposite of [split].
      Lists given to [combine] are meant to be of same length.
      If not, [combine] stops on the shorter list *)

    Fixpoint combine (l : list A) (l' : list B) : list (A*B) :=
      match l,l' with
	| x::tl, y::tl' => (x,y)::(combine tl tl')
	| _, _ => nil
      end.

    Lemma split_combine : forall (l: list (A*B)),
      let (l1,l2) := split l in combine l1 l2 = l.
    Proof.
      induction l.
      simpl; auto.
      destruct a; simpl.
      destruct (split l); simpl in *.
      f_equal; auto.
    Qed.

    Lemma combine_split : forall (l:list A)(l':list B), length l = length l' ->
      split (combine l l') = (l,l').
    Proof.
      induction l; destruct l'; simpl; intros; auto; try discriminate.
      injection H; clear H; intros.
      rewrite IHl; auto.
    Qed.

    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B),
      In (x,y) (combine l l') -> In x l.
    Proof.
      induction l.
      simpl; auto.
      destruct l'; simpl; auto; intros.
      contradiction.
      destruct H.
      injection H; auto.
      right; apply IHl with l' y; auto.
    Qed.

    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B),
      In (x,y) (combine l l') -> In y l'.
    Proof.
      induction l.
      simpl; intros; contradiction.
      destruct l'; simpl; auto; intros.
      destruct H.
      injection H; auto.
      right; apply IHl with x; auto.
    Qed.

    Lemma combine_length : forall (l:list A)(l':list B),
      length (combine l l') = min (length l) (length l').
    Proof.
      induction l.
      simpl; auto.
      destruct l'; simpl; auto.
    Qed.

    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B),
      length l = length l' ->
      nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
    Proof.
      induction l; destruct l'; intros; try discriminate.
      destruct n; simpl; auto.
      destruct n; simpl in *; auto.
    Qed.

  (** [list_prod] has the same signature as [combine], but unlike
     [combine], it adds every possible pairs, not only those at the
     same position. *)

    Fixpoint list_prod (l:list A) (l':list B) :
      list (A * B) :=
      match l with
	| nil => nil
	| cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l')
      end.

    Lemma in_prod_aux :
      forall (x:A) (y:B) (l:list B),
	In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
    Proof.
      induction l;
	[ simpl; auto
	  | simpl; destruct 1 as [H1| ];
	    [ left; rewrite H1; trivial | right; auto ] ].
    Qed.

    Lemma in_prod :
      forall (l:list A) (l':list B) (x:A) (y:B),
	In x l -> In y l' -> In (x, y) (list_prod l l').
    Proof.
      induction l;
	[ simpl; tauto
	  | simpl; intros; apply in_or_app; destruct H;
	    [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
    Qed.

    Lemma in_prod_iff :
      forall (l:list A)(l':list B)(x:A)(y:B),
	In (x,y) (list_prod l l') <-> In x l /\ In y l'.
    Proof.
      split; [ | intros; apply in_prod; intuition ].
      induction l; simpl; intros.
      intuition.
      destruct (in_app_or _ _ _ H); clear H.
      destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
      destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
      injection H2; clear H2; intros; subst; intuition.
      intuition.
    Qed.

    Lemma prod_length : forall (l:list A)(l':list B),
      length (list_prod l l') = (length l) * (length l').
    Proof.
      induction l; simpl; auto.
      intros.
      rewrite app_length.
      rewrite map_length.
      auto.
    Qed.

  End ListPairs.

(*****************************************)
(** * Miscellaneous operations on lists  *)
(*****************************************)

(******************************)
(** ** Length order of lists  *)
(******************************)

Section length_order.
  Variable A : Type.

  Definition lel (l m:list A) := length l <= length m.

  Variables a b : A.
  Variables l m n : list A.

  Lemma lel_refl : lel l l.
  Proof.
    unfold lel; auto with arith.
  Qed.

  Lemma lel_trans : lel l m -> lel m n -> lel l n.
  Proof.
    unfold lel; intros.
    now_show (length l <= length n).
    apply le_trans with (length m); auto with arith.
  Qed.

  Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_cons : lel l m -> lel l (b :: m).
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'.
  Proof.
    intro l'; elim l'; auto with arith.
    intros a' y H H0.
    now_show (nil = a' :: y).
    absurd (S (length y) <= 0); auto with arith.
  Qed.
End length_order.

Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
  datatypes v62.

(******************************)
(** ** Set inclusion on list  *)
(******************************)

Section SetIncl.

  Variable A : Type.

  Definition incl (l m:list A) := forall a:A, In a l -> In a m.
  Hint Unfold incl.

  Lemma incl_refl : forall l:list A, incl l l.
  Proof.
    auto.
  Qed.
  Hint Resolve incl_refl.

  Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_tl.

  Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n.
  Proof.
    auto.
  Qed.

  Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_appl.

  Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_appr.

  Lemma incl_cons :
    forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m.
  Proof.
    unfold incl; simpl; intros a l m H H0 a0 H1.
    now_show (In a0 m).
    elim H1.
    now_show (a = a0 -> In a0 m).
    elim H1; auto; intro H2.
    now_show (a = a0 -> In a0 m).
    elim H2; auto. (* solves subgoal *)
    now_show (In a0 l -> In a0 m).
    auto.
  Qed.
  Hint Resolve incl_cons.

  Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n.
  Proof.
    unfold incl; simpl; intros l m n H H0 a H1.
    now_show (In a n).
    elim (in_app_or _ _ _ H1); auto.
  Qed.
  Hint Resolve incl_app.

End SetIncl.

Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
  incl_app: datatypes v62.

(**************************************)
(** * Cutting a list at some position *)
(**************************************)

Section Cutting.

  Variable A : Type.

  Fixpoint firstn (n:nat)(l:list A) : list A :=
    match n with
      | 0 => nil
      | S n => match l with
		 | nil => nil
		 | a::l => a::(firstn n l)
	       end
    end.

  Fixpoint skipn (n:nat)(l:list A) : list A :=
    match n with
      | 0 => l
      | S n => match l with
		 | nil => nil
		 | a::l => skipn n l
	       end
    end.

  Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
  Proof.
    induction n.
    simpl; auto.
    destruct l; simpl; auto.
    f_equal; auto.
  Qed.

  Lemma firstn_length : forall n l, length (firstn n l) = min n (length l).
  Proof.
    induction n; destruct l; simpl; auto.
  Qed.

   Lemma removelast_firstn : forall n l, n < length l ->
     removelast (firstn (S n) l) = firstn n l.
   Proof.
     induction n; destruct l.
     simpl; auto.
     simpl; auto.
     simpl; auto.
     intros.
     simpl in H.
     change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l).
     change (firstn (S n) (a::l)) with (a::firstn n l).
     rewrite removelast_app.
     rewrite IHn; auto with arith.

     clear IHn; destruct l; simpl in *; try discriminate.
     inversion_clear H.
     inversion_clear H0.
   Qed.

   Lemma firstn_removelast : forall n l, n < length l ->
     firstn n (removelast l) = firstn n l.
   Proof.
     induction n; destruct l.
     simpl; auto.
     simpl; auto.
     simpl; auto.
     intros.
     simpl in H.
     change (removelast (a :: l)) with (removelast ((a::nil)++l)).
     rewrite removelast_app.
     simpl; f_equal; auto with arith.
     intro H0; rewrite H0 in H; inversion_clear H; inversion_clear H1.
   Qed.

End Cutting.

(********************************)
(** ** Lists without redundancy *)
(********************************)

Section ReDun.

  Variable A : Type.

  Inductive NoDup : list A -> Prop :=
    | NoDup_nil : NoDup nil
    | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l).

  Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l').
  Proof.
  induction l; simpl.
  inversion_clear 1; auto.
  inversion_clear 1.
  constructor.
  contradict H0.
  apply in_or_app; destruct (in_app_or _ _ _ H0); simpl; tauto.
  apply IHl with a0; auto.
  Qed.

  Lemma NoDup_remove_2 : forall l l' a, NoDup (l++a::l') -> ~In a (l++l').
  Proof.
  induction l; simpl.
  inversion_clear 1; auto.
  inversion_clear 1.
  contradict H0.
  destruct H0.
  subst a0.
  apply in_or_app; right; red; auto.
  destruct (IHl _ _ H1); auto.
  Qed.

End ReDun.

(***********************************)
(** ** Sequence of natural numbers *)
(***********************************)

Section NatSeq.

  (** [seq] computes the sequence of [len] contiguous integers
      that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *)

  Fixpoint seq (start len:nat) : list nat :=
    match len with
      | 0 => nil
      | S len => start :: seq (S start) len
    end.

  Lemma seq_length : forall len start, length (seq start len) = len.
  Proof.
    induction len; simpl; auto.
  Qed.

  Lemma seq_nth : forall len start n d,
    n < len -> nth n (seq start len) d = start+n.
  Proof.
    induction len; intros.
    inversion H.
    simpl seq.
    destruct n; simpl.
    auto with arith.
    rewrite IHlen;simpl; auto with arith.
  Qed.

  Lemma seq_shift : forall len start,
    map S (seq start len) = seq (S start) len.
  Proof.
    induction len; simpl; auto.
    intros.
    rewrite IHlen.
    auto with arith.
  Qed.

End NatSeq.

(** * Existential and universal predicates over lists *)

Inductive Exists {A} (P:A->Prop) : list A -> Prop :=
 | Exists_cons_hd : forall x l, P x -> Exists P (x::l)
 | Exists_cons_tl : forall x l, Exists P l -> Exists P (x::l).
Hint Constructors Exists.

Lemma Exists_exists : forall A P (l:list A),
 Exists P l <-> (exists x, In x l /\ P x).
Proof.
split.
induction 1; firstorder.
induction l; firstorder; subst; auto.
Qed.

Lemma Exists_nil : forall A (P:A->Prop), Exists P nil <-> False.
Proof. split; inversion 1. Qed.

Lemma Exists_cons : forall A (P:A->Prop) x l,
 Exists P (x::l) <-> P x \/ Exists P l.
Proof. split; inversion 1; auto. Qed.

Inductive Forall {A} (P:A->Prop) : list A -> Prop :=
 | Forall_nil : Forall P nil
 | Forall_cons : forall x l, P x -> Forall P l -> Forall P (x::l).
Hint Constructors Forall.

Lemma Forall_forall : forall A P (l:list A),
 Forall P l <-> (forall x, In x l -> P x).
Proof.
split.
induction 1; firstorder; subst; auto.
induction l; firstorder.
Qed.

Lemma Forall_inv : forall A P (a:A) l, Forall P (a :: l) -> P a.
Proof.
intros; inversion H; trivial.
Defined.

Lemma Forall_rect : forall A (P:A->Prop) (Q : list A -> Type),
     Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall P l -> Q l.
Proof.
intros A P Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption.
Defined.

Lemma Forall_impl : forall A (P Q : A -> Prop), (forall a, P a -> Q a) ->
  forall l, Forall P l -> Forall Q l.
Proof.
  intros A P Q Himp l H.
  induction H; firstorder.
Qed.

(** [Forall2]: stating that elements of two lists are pairwise related. *)

Inductive Forall2 A B (R:A->B->Prop) : list A -> list B -> Prop :=
 | Forall2_nil : Forall2 R [] []
 | Forall2_cons : forall x y l l',
    R x y -> Forall2 R l l' -> Forall2 R (x::l) (y::l').
Hint Constructors Forall2.

Theorem Forall2_refl : forall A B (R:A->B->Prop), Forall2 R [] [].
Proof. exact Forall2_nil. Qed.

Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l',
  Forall2 R (l1 ++ l2) l' ->
  exists l1', exists l2', Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l' = l1' ++ l2'.
Proof.
  induction l1; intros.
    exists [], l'; auto.
    simpl in H; inversion H; subst; clear H.
    apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->).
    exists (y::l1'), l2'; simpl; auto.
Qed.

Theorem Forall2_app_inv_r : forall A B (R:A->B->Prop) l1' l2' l,
  Forall2 R l (l1' ++ l2') ->
  exists l1, exists l2, Forall2 R l1 l1' /\ Forall2 R l2 l2' /\ l = l1 ++ l2.
Proof.
  induction l1'; intros.
    exists [], l; auto.
    simpl in H; inversion H; subst; clear H.
    apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->).
    exists (x::l1), l2; simpl; auto.
Qed.

Theorem Forall2_app : forall A B (R:A->B->Prop) l1 l2 l1' l2',
  Forall2 R l1 l1' -> Forall2 R l2 l2' -> Forall2 R (l1 ++ l2) (l1' ++ l2').
Proof.
  intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
Qed.

(** [ForallPairs] : specifies that a certain relation should
    always hold when inspecting all possible pairs of elements of a list. *)

Definition ForallPairs A (R : A -> A -> Prop) l :=
 forall a b, In a l -> In b l -> R a b.

(** [ForallOrdPairs] : we still check a relation over all pairs
     of elements of a list, but now the order of elements matters. *)

Inductive ForallOrdPairs A (R : A -> A -> Prop) : list A -> Prop :=
  | FOP_nil : ForallOrdPairs R nil
  | FOP_cons : forall a l,
     Forall (R a) l -> ForallOrdPairs R l -> ForallOrdPairs R (a::l).
Hint Constructors ForallOrdPairs.

Lemma ForallOrdPairs_In : forall A (R:A->A->Prop) l,
 ForallOrdPairs R l ->
 forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x.
Proof.
 induction 1.
 inversion 1.
 simpl; destruct 1; destruct 1; repeat subst; auto.
 right; left. apply -> Forall_forall; eauto.
 right; right. apply -> Forall_forall; eauto.
Qed.

(** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true
    only when [R] is symmetric and reflexive. *)

Lemma ForallPairs_ForallOrdPairs : forall A (R:A->A->Prop) l,
 ForallPairs R l -> ForallOrdPairs R l.
Proof.
 induction l; auto. intros H.
 constructor.
 apply <- Forall_forall. intros; apply H; simpl; auto.
 apply IHl. red; intros; apply H; simpl; auto.
Qed.

Lemma ForallOrdPairs_ForallPairs : forall A (R:A->A->Prop),
 (forall x, R x x) ->
 (forall x y, R x y -> R y x) ->
 forall l, ForallOrdPairs R l -> ForallPairs R l.
Proof.
 intros A R Refl Sym l Hl x y Hx Hy.
 destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
Qed.

(** * Inversion of predicates over lists based on head symbol *)

Ltac is_list_constr c :=
 match c with
  | nil => idtac
  | (_::_) => idtac
  | _ => fail
 end.

Ltac invlist f :=
 match goal with
  | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | _ => idtac
 end.

(** * Exporting hints and tactics *)

Hint Rewrite
  rev_involutive (* rev (rev l) = l *)
  rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
  map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
  map_length (* length (map f l) = length l *)
  seq_length (* length (seq start len) = len *)
  app_length (* length (l ++ l') = length l + length l' *)
  rev_length (* length (rev l) = length l *)
  app_nil_r (* l ++ nil = l *)
  : list.

Ltac simpl_list := autorewrite with list.
Ltac ssimpl_list := autorewrite with list using simpl.

(* begin hide *)
(* Compatibility notations after the migration of [list] to [Datatypes] *)
Notation list := list (only parsing).
Notation list_rect := list_rect (only parsing).
Notation list_rec := list_rec (only parsing).
Notation list_ind := list_ind (only parsing).
Notation nil := nil (only parsing).
Notation cons := cons (only parsing).
Notation length := length (only parsing).
Notation app := app (only parsing).
(* Compatibility Names *)
Notation tail := tl (only parsing).
Notation head := hd_error (only parsing).
Notation head_nil := hd_error_nil (only parsing).
Notation head_cons := hd_error_cons (only parsing).
Notation ass_app := app_assoc (only parsing).
Notation app_ass := app_assoc_reverse (only parsing).
Notation In_split := in_split (only parsing).
Notation In_rev := in_rev (only parsing).
Notation In_dec := in_dec (only parsing).
Notation distr_rev := rev_app_distr (only parsing).
Notation rev_acc := rev_append (only parsing).
Notation rev_acc_rev := rev_append_rev (only parsing).
Notation AllS := Forall (only parsing). (* was formerly in TheoryList *)

Hint Resolve app_nil_end : datatypes v62.
(* end hide *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Demos for Containers, in particular finite maps                         *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From TLC Require Import LibTactics LibLogic LibReflect LibOption
  LibRelation LibLogic LibOperation LibEpsilon LibMonoid LibSet
  LibContainer LibMap.

Local Open Scope set_scope.

(* ********************************************************************* *)
(** * Introduction *)

(* Assume a type of keys, call it [int] *)

Parameter int : Type.

(** Assume a type of values, called [val], that's inhabited. *)

Parameter val : Type.
Parameter Inhab_val : Inhab val.
#[global]
Existing Instance Inhab_val.

(* ********************************************************************** *)
(** * Basic usage of map operations *)

Module Basic.

(** We can use a map from [int] to [val], and read in that map *)

Definition my_read (m:map int val) (i:int) :=
  m[i].

(** We can also write a value in the map; it does not matter whether
    the key already existed or not. *)

Definition my_write (m:map int val) (i:int) (v:val) :=
  m[i := v].

(** To reason about a read, we can use the lemma [read_update]. *)

Lemma my_read_write : forall (m:map int val) (i j:int) (v:val),
  m[i := v][j] = (If i = j then v else m[j]).
Proof using.
  intros. rewrite read_update. auto.
Qed.

(** Sometimes we need to talk about the domain of a map.
    [dom m] is a [set] of keys, in the sense of LibSet's [set].
    For example, to assert that two maps have the same domain. *)

Definition my_same_dom (m1 m2:map int val) :=
  dom m1 = dom m2.

(** To assert that one key is valid for a domain, we use
    [i \in (dom m)], which is shortened to [i \indom m].
    The latter is a notation for [(x \in (dom m : set _))],
    with the annotation to help the typechecker. *)

Definition my_indom (m:map int val) (i:int) :=
  i \indom m.

(** Similarly, the notation [x \notindom m] is available. *)

(** In an inductive definition, it is commonplace to assert
    that [i] is in the domain of [m] and that [M[i] = v].
    The binds predicate captures the conjunction of these
    two facts. The definition can be unfolded using the
    following rewriting rule. *)

Parameter binds_eq_indom_read : forall A `{Inhab B} (M:map A B) x v,
  (binds M x v) = (x \indom M /\ M[x] = v).

(** Other operations on maps involve:
    - empty map [(\{} : map A B)]. The type annotation is often required.
    - union of maps [m1 \u m2]
    - removal of a set of keys [m \- E]
    - removal of a key [m \-- i], equivalent to [m \- \{i}]
    - map_reduce w.r.t. a function and a monoid, e.g.
      [fold (monoid_make plus zero) f m], which computes
      [f k1 v1 + f k2 v2 + ... + f kn vn + 0].
    - inclusion [m1 \c m2] is not yet defined, but should be soon. *)

(** Lemmas for reasoning about maps can be found in two places:
    in [LibMap.v] and in [LibContainer.v]. The latter contains
    generic lemmas, that are shared by several data structures,
    such as sets and maps. The typeclass mechanism used for the
    sharing is explained next. *)

End Basic.

(* ********************************************************************** *)
(** * Implementation of maps *)

Module Internal.

(** Finite maps are implemented using the typeclasses defined in
    LibContainer. The internal implementation is: *)

Definition map (A B : Type) := A -> option B.

(** The internal definition of [read] in a map is thus a function
    that applies the map to the index. When the result is [None]
    it returns an arbitrary value. *)

Definition read_impl A `{Inhab B} (M:map A B) (k:A) :=
  match M k with
  | None => arbitrary
  | Some v => v
  end.

(** Doing so requires the type [B] to be inhabited. Let's look at
    the error message that we get when trying to work with a map
    on a type that's not inhabited. *)

(* Uncomment below to see the error message, saying that an instance
   for [BagRead int ?B (map int B)]. The message does not say it,
   but it complains in fact that [Inhab B] could not be found.
   We'll understand why the message is like so further on. *)

(*
Definition my_failed_read B (m:map int B) (i:int) :=
  m[i].
*)

(** The notation [m[i]] is defined in [LibContainer.v] as
    [read m i]. *)

Notation "m [ i ]" := (read m i).

(** The operation [read] is a typeclass. It applies to any
    data structure of type [T] on which a read operation can
    be performed using keys of type [A] to extract a value of
    type [B]. *)

Class BagRead A B T := { read : T -> A -> B }.

(** Note that the type of [read] is:
    [forall A B T {I:BagRead A B T}, T -> A -> B].
    In other words, [read] must be applied to an
    "instance" of the typeclass [BagRead], and then
    the result is a read function for that instance.
    We'll see further on what this means. *)

(** The connection between [read_impl] for type [map] and
    the generic [read] operation is performed through an
    instance declaration: *)

#[global]
Instance read_inst : forall A `{IB:Inhab B}, BagRead A B (map A B).
Proof. constructor. applys (@read_impl A B IB). Defined.

(** In the light of this, let's inspect the interpretation of [m[i]].
    It means [@read int val (map int val) read_inst m i]. *)

Definition my_read (m:map int val) (i:int): val :=
  m[i].

(** You can activate [Set Printing All] or menu
    ["Display all level-level contents" from the view menu in CoqIDE]
    to see the low-level interpretation. *)

(*
Print my_read.
*)

(** What happens during type-checking is that [read_inst] gets
    automatically inferred by the typeclass mechanism, based on the
    type of [m]. In other words, before type inference, Coq sees:
    [@read _ _ _ _ m i]. From the type of [m], it deduces
    [@read _ _ (map int val) (_:BagRead _ _ (map int val)) m i].
    From typeclass resolution, it finds out that [read_inst] is the
    instance that could fill in the argument with type
    [BagRead _ _ (map int val)]. *)

(** Now, we can see that the instance inferred is
    [@LibMap.read_inst int val Inhab_val].
    This instance refers to the instance asserting that [val] is
    inhabited. When such an assumption about the result type cannot
    be found, then the [read_inst] instance cannot be synthesized. *)

(** We can investigate the resolution process manually as follows. *)

Lemma test_resolution_1 : BagRead int val (map int val).
Proof using. typeclass. (* short for: [eauto with typeclass_instances.] *) Qed.

Lemma test_resolution_2 : Inhab val.
Proof using. typeclass. Qed.

Lemma test_resolution_3 : forall B, Inhab B.
Proof using. intros. try typeclass. (* resolution fails *) Abort.

Lemma test_resolution_4 : BagRead int val (map int val).
Proof using. (* execute:
   debug eauto with typeclass_instances. *) Abort.

Lemma test_resolution_5 : forall B, BagRead int B (map int B).
Proof using.
  (* execute:

    intros.
    debug eauto with typeclass_instances.
    (* shows that eauto is stuck after [apply read_inst] *)
    apply read_inst.
    debug eauto with typeclass_instances.
    (* shows that eauto is stuck on this subgoal. *)

  *)
Abort.

(** The file [LibContainer.v] contains generic lemmas. For example
    [union_empty_r] asserts that [m \u \{} = m]. This lemma is
    stated for any data structure of type [T] that features an
    empty and a union operation. *)

Class Union_empty_r (T:Type) {BE: BagEmpty T} {BU: BagUnion T} :=
  { union_empty_r : forall X, union empty X = X }.

(** The proof that [map] validates the lemma [union_empty_r] is
    derived from the fact that it validates the lemma [union_empty_l]
    and commutativity of union *)

Global Instance union_empty_r_of_union_empty_l (T:Type) {BE: BagEmpty T} {BU: BagUnion T} :
  Union_empty_l -> Union_comm -> Union_empty_r.
Abort.

(** The proof that [map] validates [union_empty_l] is itself derived
    from another lemma, called [union_empty_l_of_in_union_eq_and_in_empty_eq].
    More details can be found in [LibContainerDemo], but it is not needed
    to understand the full setup to use the lemmas over maps.] *)

(** The point is that [rewrite union_empty_r] is a tactic that rewrites
    [m \u \{} = m] for any data structure [m] over which the statement
    of this equality makes sense. *)

End Internal.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
  induction l1.
  - intros. simpl. f_equal. apply IHl1.
  - intros. reflexivity.
Qed.

Lemma lem2 : forall l, len l = len (append l Nil).
Proof.
  induction l.
  - simpl. f_equal. apply IHl.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (rev x)) (len x).
Proof.
induction x.
  - simpl.  rewrite <- IHx. lfind.
Admitted.


Require Import List.
Require Import Arith.
Import ListNotations.

Section SkipList.
Variable A : Type.

Inductive skip_list : Type :=
  | nil : skip_list
  | cons : A -> skip_list -> skip_list
  | skip : nat -> skip_list -> skip_list.
(* I feel evil after writing this definition *)

Fixpoint list2skip_list (l : list A) : skip_list :=
  match l with
  | [] => nil
  | h :: t => cons h (list2skip_list t)
  end.

Fixpoint skip_list2list (s : skip_list) : list A :=
  match s with
  | nil => []
  | cons h t => h :: skip_list2list t
  | skip n l => skipn n (skip_list2list l)
  end.

Theorem skip_list2list_id : forall (l : list A),
  skip_list2list (list2skip_list l) = l.
Proof.
  induction l.
  - trivial.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

End SkipList.

Definition serializer (A: Type) := A -> list bool.
Definition deserializer (A: Type) := list bool -> option (A * nat).
Definition ser_deser_spec (A: Type) (ser : serializer A) (deser : deserializer A) :=
  forall a : A, forall bools : list bool,
      deser (ser a ++ bools) = Some (a, length (ser a)).

Class Serializer (A : Type) : Type :=
  {
    serialize : A -> list bool;
    deserialize : list bool -> option (A * nat);
    deser_ser_identity : ser_deser_spec A serialize deserialize
  }.

(* I couldn't find a suitable theorem in the coq standard library *)
Theorem skipn_length : forall (A : Type) (l1 l2 : list A),
  skipn (length l1) (l1 ++ l2) = l2.
Proof.
induction l1; intros.
- trivial.
- simpl.
  apply IHl1.
Qed.

Section NatSerializer.

Fixpoint nat_serialize (n : nat) : list bool :=
  match n with
  | O => [false]
  | S n => [true] ++ (nat_serialize n)
  end.

Fixpoint nat_deserialize (bools : list bool) : option (nat * nat) :=
  match bools with
  | true :: bools =>
    match (nat_deserialize bools) with
    | None => None
  (* Remark: n = remaining + 1 here for this specific deser/ser pair *)
    | Some (n, amt) => Some (S n, S amt)
    end
  | false :: bools => Some (O, 1)
  | [] => None
  end.

Theorem nat_ser_deser_identity :
  ser_deser_spec nat nat_serialize nat_deserialize.
Proof.
  unfold ser_deser_spec.
  induction a; intros.
  - trivial.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

End NatSerializer.

Section ListSerializer.
Variable A : Type.
Variable serA : Serializer A.

Fixpoint list_serialize (l : list nat) : list bool :=
  match l with
  | [] => [false]
  | h :: t => [true] ++ list_serialize t
  end.

Definition deser_skip {T} (orig : skip_list bool) (result : option (T * nat)) : option (T * skip_list bool):=
  match result with
  | None => None
  | Some (a, amt) => Some (a, skip bool amt orig)
  end.

Fixpoint list_deserialize' (bools : skip_list bool) :  option (list A * nat) :=
  match deser_skip bools (deserialize (skip_list2list bool bools)) with
  | None => None
  | Some (n, rest) =>
    match (list_deserialize' rest) with
    | None => None
    | Some (tail, amtRest) => Some (n :: tail, 0)
    end
  end.

Definition list_deserialize (bools : list bool) : option (list A * nat) :=
  list_deserialize' (list2skip_list bools).

Definition list_deserialize (bools : list bool) : option (list nat * list bool) :=
  match (nat_deserialize bools) with
  | None => None
  | Some (size, bools) => list_deserialize_elements size bools
  end.
(*end code*)

Theorem list_ser_deser_identity :
  ser_deser_spec_ (list nat) list_serialize list_deserialize.
Proof.
  unfold ser_deser_spec_.
  intros.
  unfold list_serialize, list_deserialize.
  rewrite app_ass.
  rewrite nat_ser_deser_identity.
  induction a as [|h t]. (* TODO was l, now a *)
  - trivial.
  - simpl.
    rewrite app_ass.
    rewrite nat_ser_deser_identity. (* Element ser/deser identity *)
    rewrite IHt.
    reflexivity.
Qed.

End ListSerializer.


(**
Coq/SSReflect/MathComp による定理証明

6.2.1 有限群の型と補題
======

2021_03_07 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import fingroup.

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

(**
## 最初に

``group`` スコープにしておきます。
*)
Open Scope group_scope.

(**
## ``finGroupType`` とはなにか

テキストでは、「``fingroup`` は有限群の基本的な仮定や補題を提供します」
と記載されています。有限群は finite group のことですから、間違いではないのですが、
MathComp の型クラスとして定義されているのは、``finGroupType``
すなわち「有限群型」であることに注意してください。

``fingroup.v``のコメントでは、``finGroupType`` は、
"the structure for finite types with a group law" と記載されています。

有限群型とは、その要素が群の規則を満たす有限型という意味で、
``finType``型クラスを継承して、公理として乗法の結合則や単位元の存在を仮定します。
すなわち、``finType``型クラスのインスタンス型``T``を台として、以下が成り立ちます。

- 二項演算 mulg : T -> T -> T が存在する。
- 元 one : T が存在する。
- 関数 invg : T -> T が存在する。
- mulg は結合律を満たす。
- one は左単位元である。
- invg は対合である（involutive、2回適用するともとにもどる）。
```invg (invg x) = x```
- invg と mulg は逆自己同型（？）である（anti-mophism を満たす）。
```invg (mulg x y) = mulg (invg y) (invg x)```

（``anti-`` は x と y が逆になるということ）
 *)

(**
## 型インスタンスとしての「有限群型」の定義

前節の繰り返しになりますが、
型クラス``finGroupType``のインスタンス型の値は、
有限群の公理を満たすということです。
*)
Section Sect_1.

  Check finGroupType : Type.                (* 型クラス *)

(**
### 群の公理と定理

群 gT の要素 x, y, z の間で群の公理や定理が成り立ちます。
*)
  Variable gT : finGroupType.               (* 有限群 = 型インスタンス *)
  Check gT : finGroupType.

  Variable x y z : gT.                      (* 有限群の要素 *)

  Check mulg x y : gT.                      (* 乗算 *)
  Check x * y : gT.                         (* 乗算（演算子） *)

  Check invg x : gT.                        (* 逆元 *)
  Check x^-1 : gT.                          (* 逆元（演算子） *)

  (* 群の公理 *)
  Goal 1 * x = x. Proof. by rewrite mul1g. Qed.
  Goal x * y * z = x * (y * z). Proof. by rewrite mulgA. Qed.
  Goal x^-1^-1 = x. Proof. by rewrite invgK. Qed.
  Goal (x * y)^-1 = y^-1 * x^-1. Proof. by rewrite invMg. Qed.

  (* 群の定理 *)
  Goal x * 1 = x. Proof. by rewrite mulg1. Qed.
  Goal x * x^-1 = 1. Proof. by rewrite mulgV. Qed.
  Goal x^-1 * x = 1. Proof. by rewrite mulVg. Qed.

(**
参考： mulg において、``FinGroup.base gT`` が gT のカノニカル解です。
（x や y が gT 型であることから、``FinGroup.base gT`` を見つけ出せるます）
*)
  Check @mulg : forall T : baseFinGroupType, T -> T -> T.
  Check @mulg (FinGroup.base gT) x y : FinGroup.base gT.
  Compute FinGroup.sort (FinGroup.base gT). (* gT *)

(**
別に定義した有限群 ``gT'`` と ``gT`` の要素の間の乗算はできません。
*)
  Section Sect_1_2.
    Variable gT' : finGroupType.            (* 別な有限群 *)
    Variable x' y' : gT'.

    Check x' * y' : gT'.
    Fail Check x' * y.
  End Sect_1_2.

(**
## ``group_set_of_baseGroupType gT``
*)

(**
### 集合としての群

テキストの6.2節でもそうですが、
群そのもの（有限集合としての有限群）を扱いたい場合があります。

``gT`` は型インスタンスであり、コアーションで型になることに間違いありません。
*)
  Check FinGroup.sort gT : Type.
  Check gT : Type.                          (* コアーション *)
  Check x : gT.
  Check x \in gT.                           (* このような表記も可能です。 *)

(**
しかし、型と集合はCoqの対象としては別なものです。
*)
(**
## 集合としての群の型（その１）

集合としての群を扱うには次のようにします：

まず、``finGroupType``型クラスのインスタンス型（例：gT）の値を要素とする
有限集合の型は、``{set gT}``で表します。

``{set gT}``のインスタンス（この場合は集合） A, B, C は、次のように定義します：
 *)
  Check {set gT} : predArgType.
  Variable A B C : {set gT}.

(**
``{set gT}`` のインスタンスは、``[set _ : _ | _]`` のかたちでも定義できます。
あとで出てきます。任意のbool述語を併用して集合を定義できます。
*)
    Check [set a : gT | _] : {set gT}.

(**
また、``{set gT}`` は、predArgType で ``\in`` による判定ができます。
 *)
  Check x : gT.                             (* x は gT 型 *)
  Check x \in A : bool.                     (* true または false *)

(**
``mem A`` は、gT 型の変数が集合Aに含まれるか否かを決定する``gT -> bool``型の関数になります。
(``finset`` の ``set_type``の定義を参照のこと)。
*)
  Check mem A : gT -> bool.
  Check mem A x : bool. (* x \in A とだいたい同じ。。。ちょっと苦しい。 *)

(**
しかし、x は A型 でないことに注意してください。そもそも A は型ではありません。
 *)
  Fail Check x : A.
  Fail Check A : Type.

(**
集合としての群の型として、group_set_of_baseGroupType が定義されています。
 *)
  Check group_set_of_baseGroupType : baseFinGroupType -> Type.
  Check gT : baseFinGroupType.
  Check group_set_of_baseGroupType gT : Type.

(**
``group_set_of_baseGroupType gT`` は {set gT} のカノニカル解なので、
（A や B が ``{set gT}``型であることから、``group_set_of_baseGroupType gT``
を見つけ出すことができ）mulg (``*``) を使って集合としての群どうしの積が計算できます。
*)
  Check @mulg : forall T : baseFinGroupType, T -> T -> T.
  Check @mulg (group_set_of_baseGroupType gT) A B : group_set_of_baseGroupType gT.
  Check A * B : {set gT}.
  Check mulg A B : {set gT}.

(**
## 集合としての群の型（その２）

ついで、有限群は``{group A}``で表します。

``{group A}``の実体は、``{set A}``を台として、
以下の条件を追加したものです(``fingroup`` の ``group_type``の定義を参照のこと)。
*)

(**
``{group gT}``のインスタンスは、次のように使って定義します：
*)
  Check {group gT} : predArgType.
  Variable G H : {group gT}.
(**
有限群の公理や定理のうち、集合としての有限群がでてくるものが使えます。
*)

  Goal 1 \in G. Proof. by rewrite group1. Qed.
  Goal x \in G -> x^-1 \in G. Proof. by move/groupVr. Qed.
  Goal x \in G -> y \in G -> x * y \in G. Proof. apply: groupM. Qed.

(**
``{set T}`` と ``{group T}``の定義にはファントムタイプを使っていますが、
これは、``T``の部分に、
finType にカノニカルプロジェクションできる型だけを書けるように制限するためです。
*)
  Check {set bool}.                         (* bool型はよいが、 *)
  Fail Check {set nat}.                     (* nat型はダメ。 *)

(**
Math-Comp Book の 5.10.1 や次の文書も参照してください。

[https://github.com/suharahiromichi/coq/blob/master/math-comp-book/suhara.ch7-phantom_types.v]

*)

(**
## 剰余類 (coset) の定義

MathComp には、関数``rcoset`` と 演算子``A :* x`` のふたつの定義があります。
このふたつは別のものです。
 *)
(**
### ひとつめの定義

関数``rcoset``の定義は、有限群Aのすべての要素に、右からxを掛けたものです。
(A の ``mulg x = λy.(x * y)`` による像の集合といえます。)
*)
  Check rcoset : {set gT} -> gT -> {set gT}.

  Check rcoset A x.
  Check (fun a => mulg a x) @: A.           (* rcoset を展開する。 *)
  Check mulg^~x @: A.                       (* ``^~`` は MathComp 風の表記 *)
  Check [set a * x | a in A].               (* ``@:`` を展開する。 *)
  (* ``@:`` は、finset で定義 *)

(**
### ふたつめの定義

演算子``A :* x``の定義は、有限集合としての有限群Aと``{x}``を掛けたものです。
*)
  Check A :* x.
  Check A * [set x].                    (* ``:*`` を展開する。 *)
  Check mulg A [set x].                 (* ``*`` を展開する。 *)

(**
### ふたつの定義がおなじであることの証明
*)
  Check rcosetE
    : forall (gT : finGroupType) (A : {set gT}) (x : gT), rcoset A x = A :* x.
  Check rcosetP
    : reflect (exists2 a, a \in G & y = a * x) (y \in G :* x).

(**
## 剰余群 (cosets) の定義

MathComp には、関数``rcosets`` があります。
``rcosets A B`` は、有限集合としての有限群Bのすべての要素に、
有限集合としての有限群Aのすべての要素を右から掛けたものです。

関数``rcosets``の定義は、
有限集合としての有限群Bのすべての要素に、
有限集合としての剰余類Aを右から掛けたものです。XXXXX
 *)
  Check rcosets : {set gT} -> {set gT} -> {set {set gT}}.

  Check rcosets A B.
  Check (rcoset A) @: B.                    (* rcosets を展開する。 *)

(**
### ひとつめの定義

rcoset の定義を rcoset のひとつめの定義（``[set a * x | a in A] ``）で展開すると、
つぎのようになります。
*)
  Print rcosets.
  Check [set (rcoset A x) | x in B].        (* ``@:`` を展開する。 *)
  Check [set [set a * x | a in A] | x in B]. (* rcoset を展開する。 *)
(**
これは、次に示すものではありません。
*)
  Check A * B  : {set gT}.

(**
### ふたつめの定義

rcoset の定義を rcoset のふたつめ定義（``A :* x``）で展開すると、
つぎのようになります。
*)
  Check [set (A :* x) | x in B].

(**
### ふたつの定義がおなじであることの証明

ここで、 exists2 の2は、2つの命題を&で結ぶという意味。
*)
  Check rcosetsP
    : reflect (exists2 x, (x \in B) & (C = A :* x)) (C \in rcosets A B).

End Sect_1.

(**
# おまけ

rcosetsP の「ふたつめの定義」に近い定義を示す。
*)
Section Appendix.

  Variable gT : finGroupType.

(**
左が rcosetsP の書き方、右が「ふたつめの定義」の書き方です。
*)
  Check @imsetP
    : forall (aT rT : finType) (f : aT -> rT) (B : mem_pred aT) (C : rT),
      reflect (exists2 x : aT, (in_mem x B) & (C = f x)) (C \in imset f B).

  Lemma test (B C : {set gT}) f :
    reflect (exists2 x, (x \in B) & (C = f x)) (C \in [set f x | x in B]).
  Proof.
      by apply: imsetP.
  Qed.

  Lemma rcosetsP' (A B C : {set gT}) :
    reflect (C \in [set (A :* x) | x in B]) (C \in rcosets A B).
  Proof.
    apply: (iffP idP).
    - move=> H.
        by apply/imsetP/rcosetsP.
    - by move/imsetP/rcosetsP.
  Qed.

End Appendix.

(* END *)


Require Import HoTT.

From GC Require Import equiv_lemmas pointed_lemmas finite_lemmas nat_lemmas trunc_lemmas permutations
                       (* monoidal_1type *)
                       group_complete_1type.

(*Defining the monoidal 1-type of finite sets and isomorphisms*)
Section BSigma.

  (*This type corresponds to the category of finite sets and isomorphisms*)
  Record BSigma :=
    {card_BSigma : nat ; fintype_of_BSigma :> Finite_Types card_BSigma}.
    (* {m : nat & Finite_Types m}. *)
    (* { S : Type & Finite S}. *)
  (* Definition type_of_fin : BSigma -> Type := (fun A => A.2.1). *)
  (* Coercion type_of_fin : BSigma  >-> Sortclass. *)

  Definition issig_BSigma :
    BSigma <~> {A : Type & Finite A}.
  Proof.
    srapply @equiv_adjointify.
    - intros [n A]. exists A. exact _.
    - intros [A [n e]]. exact (Build_BSigma n (A; e)).
    - intros [A [n e]]. simpl.
      apply path_sigma_hprop. reflexivity.
    - intros [n A]. simpl. reflexivity.
  Defined.

  Global Instance istrunc_BSigma : IsTrunc 1 BSigma.
  Proof.
    apply (trunc_equiv' {S : Type & Finite S}).
    - apply equiv_inverse. apply issig_BSigma.
    - apply trunc_sigma'.
      +  intro A. exact _.
      +  intros A B.
         srapply @istrunc_paths_Type.
         apply isset_Finite. exact B.2.
  Defined.

  Definition fin_to_BSigma {n : nat}
    : Finite_Types n -> BSigma
    := Build_BSigma n.

  (*Canonical objects in BSigma*)
  Definition canon_BSigma (n : nat) : BSigma := fin_to_BSigma (canon n).

  Lemma finite_types_eqcard {m n : nat} (A : Finite_Types m) (B : Finite_Types n) :
    A <~> B -> m = n.
  Proof.
    destruct A as [A fA]. destruct B as [B fB]. simpl. intro e.
    strip_truncations.
    apply nat_eq_fin_equiv.
    exact (fB oE e oE (equiv_inverse fA)).
  Qed.

  (* in finite_lemmas: *)
  (* (* Describing the path type of BSigma *) *)
  (* Definition path_BSigma {A B : BSigma} : A <~> B -> A = B. *)
  (* Proof. *)
  (*   refine ((equiv_ap issig_BSigma A B)^-1 o _). *)
  (*   destruct A as [m [A eA]]. destruct B as [n [B eB]]. simpl. *)
  (*   exact (equiv_path_finite_types' (A; finite_finite_type (A; eA)) (B; finite_finite_type (B; eB))). *)
  (* Defined. *)

  (* Definition path_BSigma_inv {A B : BSigma} : A = B -> A <~> B. *)
  (* Proof. *)
  (*   intros []. exact equiv_idmap. *)
  (* Defined. *)

  (* Global Instance isequiv_path_BSigma {A B : BSigma} : IsEquiv (@path_BSigma A B). *)
  (* Proof. *)
  (*   srapply @isequiv_adjointify. *)
  (*   - exact path_BSigma_inv. *)
  (*   - intros []. simpl. *)
  (*     unfold path_BSigma. *)

  (* Definition path_BSigma (A B : BSigma) : *)
  (*   (A <~> B) -> A = B. *)
  (* Proof. *)
  (*   refine (equiv_inverse (equiv_ap issig_BSigma A B) o _). *)
  (*   intro e. *)
  (*   apply equiv_path_finite_types'. exact e. *)
  (* Defined. *)

  (* Definition path_BSigma_id (A : BSigma) : *)
  (*   path_BSigma A A (equiv_idmap) = idpath. *)
  (* Proof. *)
  (*   unfold path_BSigma. *)
  (*   apply moveR_equiv_V. simpl. *)
  (*   apply (moveR_equiv_M). simpl. *)
  (*   apply (moveR_equiv_M). simpl. reflexivity. *)
  (* Defined. *)

  Definition inv_path_BSigma {A B : BSigma}
    : A = B -> A <~> B.
  Proof.
    intros []. exact equiv_idmap.
  Defined.

  Definition equiv_path_BSigma (A B : BSigma) :
    (A <~> B) <~> A = B.
  Proof.
    refine ((equiv_ap issig_BSigma A B)^-1 oE _).
    exact (equiv_path_finite_types' (issig_BSigma A) (issig_BSigma B) ).
  Defined.

  Definition inv_equiv_path_BSigma (A B : BSigma) :
    (equiv_inverse (equiv_path_BSigma A B)) == inv_path_BSigma.
  Proof.
    intros []. reflexivity.
  Defined.

  Definition path_BSigma (A B : BSigma) : A <~> B -> A = B
    := equiv_path_BSigma A B.

  (* Proof. *)
  (*   destruct A as [m A]. destruct B as [n B]. simpl. *)
  (*   intro e. *)
  (*   destruct (finite_types_eqcard A B e). *)
  (*   apply (path_sigma (fun m : nat => Finite_Types m) (m; A) (m;B) idpath). simpl. *)
  (*   apply path_finite_types. *)
  (*   exact e. *)
  (* Defined. *)

  (* Definition isequiv_path_BSigma {A B : BSigma} : IsEquiv (@path_BSigma A B). *)
  (* Proof. *)
  (*   srapply @isequiv_adjointify. *)
  (*   - intros []. exact equiv_idmap. *)
  (*   - intros []. *)
  (*     unfold path_BSigma. *)
  (*     assert (H : (finite_types_eqcard (pr2 A) (pr2 A) equiv_idmap) = idpath). *)
  (*     { apply hset_nat. } destruct H. *)
  (*     destruct . *)

  (* shorter proof than in finite_lemmas *)

  Definition path_BSigma_1 (A : BSigma) :
    path_BSigma _ _ (equiv_idmap A) = idpath.
  Proof.
    unfold path_BSigma. unfold equiv_path_BSigma. ev_equiv.
    apply moveR_equiv_V. unfold equiv_path_finite_types'. ev_equiv.
    apply moveR_equiv_M. simpl.
    apply (moveR_equiv_M (f := equiv_path_universe _ _)). reflexivity.
  Defined.

  Definition path_BSigma_V {A B : BSigma} (e : A <~> B)
    : (path_BSigma _ _ e)^ = path_BSigma _ _ (equiv_inverse e).
  Proof.
    refine (_ @ ap (fun g => path_BSigma B A (equiv_inverse g)) (eissect (@path_BSigma A B) e)).
    generalize (path_BSigma A B e).  intros [].
    simpl. apply inverse.
    refine (_ @ path_BSigma_1 A).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. simpl.  reflexivity.
  Defined.

  Definition pft_to_pbs {m : nat} {A B : Finite_Types m}
    : A = B -> (fin_to_BSigma A) = (fin_to_BSigma B)
    := ap (fin_to_BSigma).
    (* : A = B -> (m;A) = (m;B) :> BSigma *)
    (* := fun p => path_sigma Finite_Types (m; A) (m; B) idpath p. *)

  Definition path_BSigma_fix {m : nat} (A B : Finite_Types m) (e : A <~> B)
    : pft_to_pbs (path_finite_types m A B e)
      = @path_BSigma (fin_to_BSigma A) (fin_to_BSigma B) e.
  Proof.
    refine (_ @ ap (@path_BSigma
                      (fin_to_BSigma _)
                      (fin_to_BSigma _))
              (eissect (path_finite_types m A B) e)).
    generalize (path_finite_types m A B e).
    intros []. simpl.
    refine ((path_BSigma_1 _)^).
  Defined.

  Global Instance isequiv_pft_to_pbs {m : nat} {A B : Finite_Types m}
    : IsEquiv (@pft_to_pbs m A B).
  Proof.
    assert (H : @pft_to_pbs m A B
            = equiv_path_BSigma
                (fin_to_BSigma A) (fin_to_BSigma B)
                oE (equiv_path_finite_types m A B)^-1).
    { apply path_arrow. intros []. ev_equiv.
      apply inverse.
      refine (path_BSigma_1 _). }
    rewrite H.
    apply equiv_isequiv.
  Qed.

  (* (* path_BSigma respects composition *) *)
  Definition path_BSigma_compose {A B C : BSigma} (e1 : A <~> B) (e2 : B <~> C) :
    path_BSigma _ _ (e2 oE e1) = path_BSigma _ _ e1 @ path_BSigma _ _ e2.
  Proof.
    (* path_BSigma e2 @ path_BSigma e1 = path_BSigma (e1 oE e2). *)
  Proof.
    refine
      (ap011 (fun g1 g2 => path_BSigma A C (g2 oE g1))
             (eissect (path_BSigma A B) e1)^ (eissect (path_BSigma B C) e2)^ @ _).
    generalize (path_BSigma _ _ e2). intros [].
    generalize (path_BSigma _ _ e1). intros []. simpl.
    refine (path_BSigma_1 A).
  Qed.

  Definition sum_BSigma : BSigma -> BSigma -> BSigma.
  Proof.
    intros [m A] [n B].
    exact (fin_to_BSigma (sum_finite_types A B)).
  Defined.

  Definition BSigma_id : BSigma := canon_BSigma 0.

  Local Notation "S1 ⊕ S2" := (sum_BSigma S1 S2) (at level 50, no associativity).

  (* (* symmetry *) *)
  (* Definition path_BSigma_twist (a b : nat) : *)
  (*   (@path_BSigma *)
  (*     (sum_BSigma (canon_BSigma a) (canon_BSigma b)) *)
  (*     (sum_BSigma (canon_BSigma b) (canon_BSigma a)) *)
  (*     (equiv_sum_symm (canon_BSigma a) (canon_BSigma b))) *)
  (*   @ *)
  (*     @path_BSigma *)

  (*       (sum_BSigma (canon_BSigma b) (canon_BSigma a)) *)
  (*       (canon_BSigma _) *)
  (*       (equiv_finsum b a) *)
  (*   = *)
  (*   @path_BSigma *)
  (*     (sum_BSigma (canon_BSigma a) (canon_BSigma b)) *)
  (*     (canon_BSigma _) *)
  (*     (equiv_finsum a b) *)
  (*   @ *)
  (*   ap canon_BSigma (nat_plus_comm b a). *)
  (* Proof. *)
  (*   induction a. *)
  (*   - simpl. *)
  (*     induction b. *)
  (*     + simpl. *)
  (*       refine ((path_BSigma_compose _ _ )^ @ _). *)

  (* path_BSigma behaves well with respect to sum *)
  Lemma path_BSigma_sum (A1 A2 B1 B2 : BSigma)
        (e1 : A1 <~> B1) (e2  : A2 <~> B2)
    : path_BSigma (sum_BSigma A1 A2) (sum_BSigma B1 B2) (e1 +E e2)
      = ap011 sum_BSigma (path_BSigma _ _ e1) (path_BSigma _ _ e2).
  Proof.
    rewrite (ap011 equiv_functor_sum'
                   (eissect (equiv_path_BSigma A1 B1) e1)^ (eissect (equiv_path_BSigma A2 B2) e2)^).
    change ((equiv_path_BSigma ?A ?B) ?e) with (path_BSigma A B e).
    destruct (path_BSigma A1 B1 e1). destruct (path_BSigma A2 B2 e2).
    simpl.
    refine (_ @ path_BSigma_1 _).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [a | a]; reflexivity.
  Defined.

  Definition finsum_id (m n : nat) :
    sum_BSigma (canon_BSigma m) (canon_BSigma n) = canon_BSigma (n+m) :=
    path_BSigma (sum_BSigma (canon_BSigma m) (canon_BSigma n)) (canon_BSigma (n+m)) (equiv_finsum m n).

  Definition finsum_id_fix (m n : nat)
    : sum_finite_types (canon m) (canon n) = canon (n + m) :=
    path_finite_types _ (sum_finite_types (canon m) (canon n)) (canon (n+m)) (equiv_finsum m n).

  Definition path_BSigma_blocksum {a b : nat}
             (alpha : canon_BSigma a <~> canon_BSigma a)
             (betta : canon_BSigma b <~> canon_BSigma b)
    : path_BSigma (canon_BSigma (a +' b)) (canon_BSigma (a +' b)) (block_sum alpha betta) =

      (finsum_id a b)^ @ (ap011 sum_BSigma (path_BSigma _ _ alpha) (path_BSigma _ _ betta) @
                                finsum_id a b).
  Proof.
    unfold finsum_id.
    rewrite <- path_BSigma_sum.
    rewrite path_BSigma_V.
    rewrite <- path_BSigma_compose. rewrite <- path_BSigma_compose.
    reflexivity.
  Defined.

  (* rename the following and define them using the previous lemma *)
  Definition natural_path_BSigma_l {S1 S2 S3: BSigma} (e : S1 <~> S2)
    : ap (fun x : BSigma => x ⊕ S3) (path_BSigma _ _ e)
    = path_BSigma (S1 ⊕ S3) (S2 ⊕ S3) (equiv_functor_sum_r (B := S3) e).
  Proof.
    refine (_ @ ap (fun e' => @path_BSigma (S1⊕ S3) (S2 ⊕ S3) (equiv_functor_sum_r e'))
              (eissect (@path_BSigma S1 S2) e)).
    generalize (path_BSigma _ _ e). intros [].
    simpl. apply inverse.
    refine (_ @ path_BSigma_1 (S1 ⊕ S3)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow. intros [s1 | s3]; reflexivity.
  Qed.

  Definition natural_path_BSigma_r {S1 S2 S3: BSigma} (e : S2 <~> S3)
    : ap (fun x : BSigma => S1 ⊕ x) (path_BSigma _ _ e)
      = path_BSigma (S1 ⊕ S2) (S1 ⊕ S3) (equiv_functor_sum_l (A := S1) e).
  Proof.
    refine (_ @ ap (fun e' => @path_BSigma (S1 ⊕ S2) (S1 ⊕ S3) (equiv_functor_sum_l e'))
              (eissect (@path_BSigma S2 S3) e)).
    generalize (path_BSigma _ _ e). intros [].
    simpl. apply inverse.
    refine (_ @ path_BSigma_1 (S1 ⊕ S2)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow. intros [s1 | s2]; reflexivity.
  Qed.

  (*The monoidal structure on BSigma*)

  Definition BSigma_assoc : associative sum_BSigma.
  Proof.
    intros S1 S2 S3.
    apply path_BSigma.
    apply equiv_sum_assoc'.
  Defined.

  Definition BSigma_lid : left_identity_mult sum_BSigma (canon_BSigma 0).
  Proof.
    intro S. apply path_BSigma.
    apply sum_empty_l.
  Defined.

  Definition BSigma_rid : right_identity_mult sum_BSigma (canon_BSigma 0).
  Proof.
    intro S. apply path_BSigma.
    apply sum_empty_r.
  Defined.

  Definition BSigma_symmetric : symmetric sum_BSigma.
  Proof.
    intros S1 S2. apply path_BSigma. apply equiv_sum_symm.
  Defined.

  Definition BSigma_triangle1 : coherence_triangle1 BSigma_assoc BSigma_lid.
  Proof.
    intros S1 S2.
    unfold BSigma_lid.
    refine (natural_path_BSigma_l _ @ _).
    unfold BSigma_assoc.
    refine (_ @ (path_BSigma_compose _ _)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [[[] | s1] | s2]; reflexivity.
  Qed.

  Definition BSigma_triangle2 : coherence_triangle2 BSigma_assoc BSigma_lid BSigma_rid.
  Proof.
    intros S1 S2. unfold BSigma_rid. unfold BSigma_assoc. unfold BSigma_lid. simpl.
    refine (natural_path_BSigma_l _ @ _).
    refine (_ @ whiskerL _ (natural_path_BSigma_r _)^).
    refine (_ @ (path_BSigma_compose  _ _)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [[s1 | []] | s2]; reflexivity.
  Qed.

  Definition BSigma_pentagon : coherence_pentagon BSigma_assoc.
  Proof.
    intros S1 S2 S3 S4.
    refine (natural_path_BSigma_l _  @ _).
    apply moveL_pV.
    refine ((path_BSigma_compose _ _)^ @ _).
    apply moveL_pV.
    refine (whiskerL _ (natural_path_BSigma_r _) @ _).
    refine ((path_BSigma_compose _ _)^ @ _).
    refine (_ @ (path_BSigma_compose _ _)).
    apply (ap (path_BSigma _ _)).
    apply path_equiv. apply path_arrow.
    intros [[[s1 | s2]| s3] | s4]; reflexivity.
  Defined.

  (* The next two lemmas should be moved *)
  Definition isinj_functor_sum {A1 A2 B1 B2 : Type} (f1 f1' : A1 -> B1) (f2 f2': A2 -> B2) :
    functor_sum f1 f2 = functor_sum f1' f2' -> (f1 = f1') * (f2 = f2').
  Proof.
    intro p.
    set (p' := ap10 p).
    apply pair.
    - apply path_arrow. intro a.
      apply (path_sum_inl B2). exact (p' (inl a)).
    - apply path_arrow. intro a.
      apply (path_sum_inr B1). exact (p' (inr a)).
  Defined.

  Definition isinj_equiv_functor_sum_r {A1 A2 B : Type} (e1 e2 : A1 <~> A2) :
    equiv_functor_sum_r (B := B) e1 = equiv_functor_sum_r e2 -> e1 = e2.
  Proof.
    intro p. apply path_equiv.
    refine (fst ((isinj_functor_sum e1 e2 idmap idmap) _)).
    apply (path_equiv^-1 p).
  Defined.

  Definition BSigma_lcancel (S1 S2 : BSigma) (p q : S1 = S2) (T : BSigma) :
    ap (fun x => x ⊕ T) p = ap (fun x => x ⊕ T) q -> p = q.
  Proof.
    intro h.
    apply (equiv_inj (@path_BSigma S1 S2)^-1).
    apply (isinj_equiv_functor_sum_r (B:=T)
                                     ((equiv_path_BSigma _ _)^-1 p) ((equiv_path_BSigma _ _)^-1 q)) .
    apply (equiv_inj (@path_BSigma (S1 ⊕ T) (S2 ⊕ T))).
    refine ((natural_path_BSigma_l _)^ @ _ @ natural_path_BSigma_l _).
    refine (_ @ h @ _);
      apply (ap (ap (fun x : BSigma => x ⊕ T))).
      - apply eisretr.
      - apply inverse. apply eisretr.
  Defined.

  Definition BSigma_moncat : Monoidal_1Type :=
    Build_Monoidal_1Type
      (BuildTruncType 1 BSigma) sum_BSigma (canon_BSigma 0) BSigma_assoc BSigma_lid BSigma_rid
      BSigma_triangle1 BSigma_triangle2 BSigma_pentagon.

  Definition group_completion_BSigma := group_completion BSigma_moncat BSigma_lcancel .

  (* Lemma equiv_toempty (A : Type) : *)
  (*   (A -> Empty) <~> (A <~> Empty). *)
  (* Proof.     *)
  (*   apply equiv_iff_hprop. *)
  (*   - intro f. apply (BuildEquiv A Empty f). apply all_to_empty_isequiv. *)
  (*   - apply equiv_fun. *)
  (* Qed. *)

  Lemma sum_empty_is_empty (A B : Type) :
    A + B <~> Empty -> A <~> Empty.
  Proof.
    intro e.
    apply (BuildEquiv A Empty (fun a => e (inl a)) ). apply all_to_empty_isequiv.
  Defined.

  Definition univalent_group_completion_BSigma :
    Categories.IsCategory group_completion_BSigma.
  Proof.
    apply univalent_monactcat; simpl.
    - intros A B.
      intro p.
      apply path_BSigma. simpl.
      apply (sum_empty_is_empty A B).
      apply ((path_BSigma _ _)^-1 p).
    - intro A.
      apply (trunc_equiv' (Empty <~> A)).
      + apply (equiv_path_BSigma (canon_BSigma 0)).
      + apply (trunc_equiv' (A <~> Empty)).
        * apply equiv_equiv_inverse.
        * exact _.
  Qed.

  (* Now we prove that associativity of sum_BSigma on canonical finite types correspond to*)
  (* associativity of natural numbers. *)
  (* move to better place? *)
  (* Lemma ap_pr1_assoc (A B C : BSigma) *)
  (*   : (ap pr1 (BSigma_assoc A B C))^ = (plus_assoc (pr1 C) (pr1 B) (pr1 A)). *)
  (* Proof. *)
  (*   apply hset_nat. *)
  (* Qed. *)

  Definition equiv_sum_assoc_Fin (j k l : nat)
    : (Fin l + Fin k) + Fin j <~>
       Fin l + (Fin k + Fin j).
  Proof.
    induction j.
    - refine (_ oE sum_empty_r _).
      apply (equiv_functor_sum_l (sum_empty_r _)^-1).
    - simpl.
      refine (_ oE (equiv_functor_sum' IHj (equiv_idmap Unit)) oE _).
      + refine (_ oE equiv_sum_assoc _ _ _).
        apply equiv_functor_sum_l. apply equiv_sum_assoc.
      +
        refine (_ oE (equiv_sum_assoc _ _ _)^-1 ). apply equiv_idmap.
  Defined.

  Definition id_equiv_sum_assoc_Fin (j k l : nat)
    : equiv_sum_assoc (Fin l) (Fin k) (Fin j) = equiv_sum_assoc_Fin j k l.
  Proof.
    induction j.
    - simpl. apply path_equiv. apply path_arrow.
      intros [[x | x] | []]; reflexivity.
    - simpl. rewrite <- IHj.
      apply path_equiv. apply path_arrow.
      intros [[x | x] | [x | []]]; reflexivity.
  Defined.

  Definition sum_canon_BSigma (j k : nat) :
    sum_BSigma (canon_BSigma j) (canon_BSigma k) = canon_BSigma (k + j)%nat.
  Proof.
    srapply @path_BSigma. apply equiv_finsum.
  Defined.

  Definition canon_assoc (a b c : nat)
    : Fin (a + (b + c)) <~> Fin ((a + b) + c ).
  Proof.
    refine (_ oE (equiv_finsum _ _)^-1).
    refine (_ oE (equiv_functor_sum_r (equiv_finsum _ _))^-1).
    refine (_ oE ((equiv_sum_assoc' _ _ _))).
    refine (equiv_finsum _ _ oE _).
    apply (equiv_functor_sum_l (equiv_finsum _ _)).
  Defined.

  (* Definition canon_assoc (a b c : nat) *)
  (*   : Fin ((a + b) + c ) <~> Fin (a + (b + c)). *)
  (* Proof. *)
  (*   refine (_ oE (equiv_finsum _ _)^-1). *)
  (*   refine (_ oE (equiv_functor_sum_l (equiv_finsum _ _))^-1). *)
  (*   refine (_ oE ((equiv_sum_assoc _ _ _))^-1). *)
  (*   refine (equiv_finsum _ _ oE _). *)
  (*   apply (equiv_functor_sum_r (equiv_finsum _ _)). *)
  (* Defined. *)

  Definition equiv_functor_sum_r_compose
    : forall (A A1 A2 B : Type)
             (e1 : A <~> A1)
             (e2 : A1 <~> A2),
      equiv_functor_sum_r (B := B) (e2 oE e1)
      = equiv_functor_sum_r (B:= B) e2 oE equiv_functor_sum_r (B := B) e1.
  Proof.
    intros. apply path_equiv. apply path_arrow.
    intros [x | x]; reflexivity.
  Defined.

  (* move *)
  Definition equiv_finsum_succ (a b : nat)
    : equiv_finsum a (b.+1) = equiv_functor_sum_r (equiv_finsum a b) oE (equiv_sum_assoc' _ _ _)^-1.
  Proof.
    apply path_equiv. apply path_arrow.
    intro x. simpl. apply finsum_succ.
  Defined.

  Definition functor_sum_assoc {A B C A' B' C' : Type} (f : A -> A') (g : B -> B') (h : C -> C')
    : functor_sum (functor_sum f g) h  o (sum_assoc_inv _ _ _) ==
      sum_assoc_inv _ _ _  o (functor_sum f (functor_sum g h)).
  Proof.
    intros [a | [b | c]]; reflexivity.
  Defined.

  Definition functor_sum_idmap (A B: Type)
    : @functor_sum A A B B idmap idmap == idmap.
  Proof.
    intros [a | b]; reflexivity.
  Defined.

  Definition functor_sum_compose {A A1 A2 B B1 B2 : Type}
             (f1 : A -> A1) (f2 : A1 -> A2)
             (g1 : B -> B1) (g2 : B1 -> B2)
    : functor_sum (f2 o f1) (g2 o g1) == functor_sum f2 g2 o functor_sum f1 g1.
  Proof.
    intros [a | b]; reflexivity.
  Defined.

  Definition equiv_functor_sum_r_V (A A' B : Type) (e : A <~> A')
    : equiv_functor_sum_r (B := B) (e^-1) = equiv_inverse (equiv_functor_sum_r e).
  Proof.
    apply path_equiv. reflexivity.
  Defined.

  Definition canon_assoc_succ (a b c : nat)
    : canon_assoc (a.+1) b c
      = equiv_functor_sum_r (canon_assoc a b c).
  Proof.
    unfold canon_assoc. simpl.
    apply emoveR_eV. apply emoveR_eV.
    rewrite equiv_finsum_succ. rewrite equiv_finsum_succ.
    rewrite equiv_finsum_succ.
    repeat rewrite equiv_functor_sum_r_compose.
    repeat rewrite equiv_functor_sum_r_V.
    apply path_equiv. apply path_arrow. intro x. ev_equiv. simpl.
    apply (ap (equiv_functor_sum_r (equiv_finsum c (a + b)))).
    rewrite <- (functor_sum_compose (finsum (b + c) a) (finsum_inv (b + c) a) idmap idmap).
    change (finsum_inv ?x ?y) with ((equiv_finsum x y)^-1).
    change (finsum ?x ?y ?z) with (equiv_finsum x y z).
    rewrite (path_arrow _ _ (eissect (equiv_finsum (b + c) a))).
    rewrite functor_sum_idmap.  simpl.
    rewrite functor_sum_assoc.
    rewrite <- (functor_sum_compose (finsum c b) (finsum_inv c b) idmap (functor_sum idmap idmap)).
    change (finsum_inv c b) with ((equiv_finsum c b)^-1).
    change (finsum c b ?x) with (equiv_finsum c b x).
    rewrite (path_arrow _ _ (eissect (equiv_finsum c b))).
    destruct x as [[x | x] | [x | x]]; reflexivity.
  Defined.

  Definition canon_BSigma_assoc (a b c : nat) :
    canon_BSigma (a + (b + c))%nat = canon_BSigma ((a + b) + c)%nat.
  Proof.
    apply path_BSigma. exact (canon_assoc a b c).
  Defined.

  (* Definition canon_BSigma_succ (a : nat) *)
  (*   : canon_BSigma (a.+1) = sum_BSigma (canon_BSigma a) (canon_BSigma 1). *)
  (* Proof. *)
  (*   apply path_BSigma. apply equiv_functor_sum_l. *)
  (*   simpl. apply equiv_inverse. *)
  (*   apply sum_empty_l. *)
  (* Defined. *)

  (* Definition canon_BSigma_assoc_succ (a b c : nat) *)
  (*   : canon_BSigma_assoc (a.+1) b c *)
  (*     = canon_BSigma_succ _ @ ap (fun x => sum_BSigma x (canon_BSigma 1)) (canon_BSigma_assoc a b c) *)
  (*                         @ (canon_BSigma_succ _)^. *)
  (* Proof. *)
  (*   unfold canon_BSigma_assoc. unfold canon_BSigma_succ. *)
  (*   apply moveR_Vp. apply moveR_Vp. *)
  (*   unfold sum_canon_BSigma.     *)
  (*   repeat rewrite path_BSigma_V. simpl. *)
  (*   rewrite natural_path_BSigma_l. rewrite natural_path_BSigma_l. *)
  (*   rewrite natural_path_BSigma_r. rewrite natural_path_BSigma_r. *)
  (*   rewrite path_BSigma_V.  *)
  (*   repeat rewrite <- path_BSigma_compose. *)
  (*   rewrite natural_path_BSigma_l. repeat rewrite <- path_BSigma_compose. *)

  (*   apply (ap path_BSigma).  *)
  (*   apply path_equiv. apply path_arrow. *)
  (*   intros [x | [x | [x | x]]]; simpl. *)
  (*   - apply (ap inl). *)
  (*     unfold finsum.  *)
  (*   unfold canon_BSigma in x. unfold canon in x.  *)
  (*   simpl in x. *)

  Definition eq_canon_BSigma_assoc (a b c : nat)
    : canon_BSigma_assoc a b c = ap canon_BSigma (plus_assoc a b c)^.
  Proof.
    unfold canon_BSigma_assoc.
    induction a.
    - simpl. unfold canon_assoc.
      refine (_ @ path_BSigma_1 _).
      apply (ap (path_BSigma _ _)).
      apply emoveR_eV.
      refine (_ @ (ecompose_1e _)^).
      apply emoveR_eV.
      apply path_equiv. apply path_arrow.
      intros [[x | x] | []]; reflexivity.
    - rewrite canon_assoc_succ.
      simpl.
      assert (H : forall (m n : nat) (p : m = n),
                 ap canon_BSigma (ap S p)
                 = @path_BSigma (canon_BSigma (m.+1)) (canon_BSigma (n.+1))
                     (equiv_functor_sum_r
                        (B := Unit)
                        ((equiv_path_BSigma (canon_BSigma (m)) (canon_BSigma (n)))^-1
                                      (ap canon_BSigma p)))).
      { intros m n []. simpl.
        apply inverse. refine (_ @ path_BSigma_1 _).
        apply (ap (path_BSigma _ _)). apply path_equiv. simpl. apply path_arrow.
        intros [x|x]; reflexivity. }
      rewrite <- ap_V.
      rewrite H. clear H.
      apply (ap (path_BSigma _ _)). apply (ap equiv_functor_sum_r).
      apply moveL_equiv_V.
      apply IHa.
  Qed.

End BSigma.

Definition add_canon (m n : nat) :
  pMap (Build_pType (Finite_Types n) _) (Build_pType (Finite_Types (n+m)) _).
Proof.
  srapply @Build_pMap.
  - simpl. intro B. exact (sum_finite_types (canon m) B).
  - exact (path_finite_types
             (n+m)
             (sum_finite_types (canon m) (canon n))
             (canon (n+m))
             (equiv_finsum m n)).
Defined.