Definition treeDecomposition {D T:Type} (mapLeaf:T->D) (mergeBranches:D->D->D) :=
forall d:D, { tt:Tree T & d = treeReduce mapLeaf mergeBranches tt }.
+Fixpoint reduceTree {T}(unit:T)(merge:T -> T -> T)(tt:Tree ??T) : T :=
+ match tt with
+ | T_Leaf None => unit
+ | T_Leaf (Some x) => x
+ | T_Branch b1 b2 => merge (reduceTree unit merge b1) (reduceTree unit merge b2)
+ end.
+
Lemma tree_dec_eq :
forall {Q}(t1 t2:Tree ??Q),
(forall q1 q2:Q, sumbool (q1=q2) (not (q1=q2))) ->
Defined.
(*******************************************************************************)
+(* Tree Flags *)
+
+(* TreeFlags is effectively a tree of booleans whose shape matches that of another tree *)
+Inductive TreeFlags {T:Type} : Tree T -> Type :=
+| tf_leaf_true : forall x, TreeFlags (T_Leaf x)
+| tf_leaf_false : forall x, TreeFlags (T_Leaf x)
+| tf_branch : forall b1 b2, TreeFlags b1 -> TreeFlags b2 -> TreeFlags (b1,,b2).
+
+(* If flags are calculated using a local condition, this will build the flags *)
+Fixpoint mkFlags {T}(f:T -> bool)(t:Tree T) : TreeFlags t :=
+ match t as T return TreeFlags T with
+ | T_Leaf x => if f x then tf_leaf_true x else tf_leaf_false x
+ | T_Branch b1 b2 => tf_branch _ _ (mkFlags f b1) (mkFlags f b2)
+ end.
+
+(* takeT and dropT are not exact inverses! *)
+
+(* drop replaces each leaf where the flag is set with a [] *)
+Fixpoint dropT {T}{Σ:Tree ??T}(tf:TreeFlags Σ) : Tree ??T :=
+ match tf with
+ | tf_leaf_true x => []
+ | tf_leaf_false x => Σ
+ | tf_branch b1 b2 tb1 tb2 => (dropT tb1),,(dropT tb2)
+ end.
+
+(* takeT returns only those leaves for which the flag is set; all others are omitted entirely from the tree *)
+Fixpoint takeT {T}{Σ:Tree T}(tf:TreeFlags Σ) : ??(Tree T) :=
+ match tf with
+ | tf_leaf_true x => Some Σ
+ | tf_leaf_false x => None
+ | tf_branch b1 b2 tb1 tb2 =>
+ match takeT tb1 with
+ | None => takeT tb2
+ | Some b1' => match takeT tb2 with
+ | None => Some b1'
+ | Some b2' => Some (b1',,b2')
+ end
+ end
+ end.
+
+(* lift a function T->bool to a function (option T)->bool by yielding (None |-> b) *)
+Definition liftBoolFunc {T}(b:bool)(f:T -> bool) : ??T -> bool :=
+ fun t =>
+ match t with
+ | None => b
+ | Some x => f x
+ end.
+
+(*******************************************************************************)
(* Length-Indexed Lists *)
Inductive vec (A:Type) : nat -> Type :=
Definition map2 {A}{B}(f:A->B)(t:A*A) : (B*B) := ((f (fst t)), (f (snd t))).
+(* boolean "not" *)
+Definition bnot (b:bool) : bool := if b then false else true.
(* string stuff *)
Variable eol : string.
reflexivity.
Qed.
+(* adapted from Adam Chlipala's posting to the coq-club list (thanks!) *)
+Definition openVec A n (v: vec A (S n)) : exists a, exists v0, v = a:::v0 :=
+ match v in vec _ N return match N return vec A N -> Prop with
+ | O => fun _ => True
+ | S n => fun v => exists a, exists v0, v = a:::v0
+ end v with
+ | vec_nil => I
+ | a:::v0 => ex_intro _ a (ex_intro _ v0 (refl_equal _))
+ end.
+
+Definition nilVec A (v: vec A O) : v = vec_nil :=
+ match v in vec _ N return match N return vec A N -> Prop with
+ | O => fun v => v = vec_nil
+ | S n => fun v => True
+ end v with
+ | vec_nil => refl_equal _
+ | a:::v0 => I
+ end.
+
Lemma fst_zip : forall T Q n (v1:vec T n)(v2:vec Q n), vec_map (@fst _ _) (vec_zip v1 v2) = v1.
- admit.
- Defined.
+ intros.
+ induction n.
+ set (nilVec _ v1) as v1'.
+ set (nilVec _ v2) as v2'.
+ subst.
+ simpl.
+ reflexivity.
+ set (openVec _ _ v1) as v1'.
+ set (openVec _ _ v2) as v2'.
+ destruct v1'.
+ destruct v2'.
+ destruct H.
+ destruct H0.
+ subst.
+ simpl.
+ rewrite IHn.
+ reflexivity.
+ Qed.
Lemma snd_zip : forall T Q n (v1:vec T n)(v2:vec Q n), vec_map (@snd _ _) (vec_zip v1 v2) = v2.
- admit.
- Defined.
-
+ intros.
+ induction n.
+ set (nilVec _ v1) as v1'.
+ set (nilVec _ v2) as v2'.
+ subst.
+ simpl.
+ reflexivity.
+ set (openVec _ _ v1) as v1'.
+ set (openVec _ _ v2) as v2'.
+ destruct v1'.
+ destruct v2'.
+ destruct H.
+ destruct H0.
+ subst.
+ simpl.
+ rewrite IHn.
+ reflexivity.
+ Qed.
Fixpoint mapM {M}{mon:Monad M}{T}(ml:list (M T)) : M (list T) :=
match ml with