(*
Lemma traversal_free_b_dim a b b' (h : b -> b') (x:  T a) :
  dimIT _ _ _ (traversal_coalg b x) = dimIT _ _ _ (traversal_coalg b' x).
Proof.
unfold traversal_coalg.
do 2 rewrite free_applicative.
simpl.
change (map (liftT h) (traverse (t:=T) (b:=b) (F:=NatPlusApplicative)
  (fun y : a => (dimIT a b) b (impure b y)) x) =
traverse (t:=T) (b:=b') (F:=NatPlusApplicative)
  (fun y : a => (dimIT a b') b' (impure b' y)) x).
rewrite (@free_traversal_b a b b' h).
reflexivity.
Qed.

Lemma traversal_free_b_pos a b b' (h : b -> b') (x:  T a) :
  eq_rect _ _ (pos (traversal_coalg b x)) _ (traversal_free_b_dim h x) = pos (traversal_coalg b' x).
Proof.
apply to_list_eq.
unfold traversal_coalg.
change (posIT _ _ _ (traverse (t:=T) (b:=b) (F:=KSApplicative a b) (impure b) x) =
        posIT _ _ _ (traverse (t:=T) (b:=b') (F:=KSApplicative a b') (impure b') x)).
do 2 rewrite free_applicative.
change (map (liftT h) (traverse (t:=T) (b:=b) (F:=ConstListApplicative a)
  (fun y : a => (posIT a b) b (impure b y)) x) =
traverse (t:=T) (b:=b') (F:=ConstListApplicative a)
  (fun y : a => (posIT a b') b' (impure b' y)) x).
rewrite (@free_traversal_b a b b' h).
reflexivity.
Qed.
*)
Definition traversal_is_coalg : KleeneCoalg (fun a => a) T.Record FinContainerSpec := finContainerSpec
{ shape : Type
; card : shape -> nat
}.Record FinContainerSpec := finContainerSpec
{ shape : Type
; card : shape -> nat
}.Record FinContainerSpec := finContainerSpec
{ shape : Type
; card : shape -> nat
}.Record FinContainerSpec := finContainerSpec
{ shape : Type
; card : shape -> nat
}.Definition finContainer (a:Type) := {x : shape spec & Vector (card x) a}.Definition finContainer_traverse a b (F : Applicative) (f : a -> F b) (x : finContainer a) : F (finContainer b) :=
  let (s, v) := x in map (existT _ s) (traverse f v).

(* Specifications: *)
Lemma finContainer_free_applicative a b (F G : Applicative) (eta : IdiomaticTransformation F G) (f : a -> F b) (x : finContainer a) : eta _ (finContainer_traverse f x) = finContainer_traverse (fun y => eta _ (f y)) x.
Lemma finContainer_traverse_identity a (x : finContainer a) : finContainer_traverse (F:=IdApplicative) (fun y => y) x = x.
Lemma finContainer_traverse_compose a b c (F G : Applicative) (f : a -> F b) (g : b -> G c) (x : finContainer a) : finContainer_traverse (F:=ComposeApplicative F G) (fun y => map g (f y)) x = map (finContainer_traverse g) (finContainer_traverse f x).