Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* LL: TODO: Add proof obligation that the result paths be prefix free? *)
Class CoArbitrary (A : Type) : Type :=
{
coarbitrary : A -> positive;
coarbReverse : positive -> option A;
coarbCorrect : forall a, coarbReverse (coarbitrary a) = Some a
}.
Instance coArbPos : CoArbitrary positive.
Instance coqArbNat : CoArbitrary nat.
Local Open Scope positive.
Fixpoint posToPathAux (p : positive) : SplitPath :=
match p with
| xH => []
| xI p' => posToPathAux p' ++ [Left; Right]
| xO p' => posToPathAux p' ++ [Left; Left ]
end.
Definition posToPath (p : positive) : SplitPath := posToPathAux p ++ [Right].
Fixpoint pathToPosAux (p : SplitPath) (f : positive -> positive)
: option positive :=
match p with
| [Right] => Some (f xH)
| Left :: Right :: p' => pathToPosAux p' (fun p => xI (f p))
| Left :: Left  :: p' => pathToPosAux p' (fun p => xO (f p))
| _ => None
end.
Definition pathToPos p := pathToPosAux p (fun x => x).
(* Eval compute in (pathToPos (posToPath 1)). Eval compute in (pathToPos (posToPath 2)). Eval compute in (pathToPos (posToPath 3)). Eval compute in (pathToPos (posToPath 4)). Eval compute in (pathToPos (posToPath 5)). Eval compute in (pathToPos (posToPath 6)). Eval compute in (pathToPos (posToPath 7)). Eval compute in (pathToPos (posToPath 8)). Eval compute in (pathToPos (posToPath 9)). *)
Definition list_ind' (A : Type) (P : list A -> Prop) :
P [] -> (forall (a : A), P [a]) ->
(forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
forall (l : list A), P l :=
fun H0 H1 H2 =>
fix aux (l : list A) : P l :=
match l with
| []  => H0
| [x] => H1 x
| a :: b :: l' => H2 a b l' (aux l')
end.
induction l using list_ind'; intros.
+ simpl in *; inversion H; subst.
exists f; intros.
split; auto.
+ simpl in H; destruct a; inversion H.
+ pose proof IHl p; clear IHl.
destruct a; destruct b; simpl in *.
-  pose proof (H0 (fun p0 => xO (f p0))); clear H0.
apply H1 in H; clear H1.
assumption.
-  pose proof (H0 (fun p0 => xI (f p0))); clear H0.
apply H1 in H; clear H1.
assumption.
- inversion H.
- inversion H.
Qed.
induction p; unfold posToPath, pathToPos in *; simpl in *.
- apply aux1 in IHp.
inversion IHp as [f' Hyp]; clear IHp.
rewrite <- app_assoc; simpl.
pose proof Hyp [Left; Right; Right] as H; clear Hyp.
inversion H as [H0 H1]; clear H.
rewrite H0; clear H0.
simpl; subst; auto.
- apply aux1 in IHp.
inversion IHp as [f' Hyp]; clear IHp.
rewrite <- app_assoc; simpl.
pose proof Hyp [Left; Left; Right] as H; clear Hyp.
inversion H as [H0 H1]; clear H.
rewrite H0; clear H0.
simpl; subst; auto.
- auto.
Qed.
Fixpoint lengthSplit {A : Type} (l l' : list A) : option (list A * list A) :=
match l, l' with
| [], x => Some ([], x)
| _::xs, y::ys =>
option_map (fun (p : list A * list A) =>
let (l1,l2) := p in (y::l1, l2)) (lengthSplit xs ys)
| _, _ => None
end.
induction l as [ | x xs IHxs].
+ intros; exists ([], l'); auto.
+ intros l' LE; destruct l' as [ | b bs] eqn:LEq.
- inversion LE.
- pose proof IHxs bs as IH; clear IHxs.
assert (LE' : le (length xs) (length bs))
by (simpl in *; omega). (* Overkill? :) *)
clear LE.
apply IH in LE'; clear IH.
inversion LE' as [pair Split]; clear LE'.
destruct pair as [l1 l2] eqn:Pair.
simpl.
rewrite Split.
exists (b :: l1, l2).
simpl.
auto.
Qed.
induction l.
+ intros l' l1 l2 Hyp; simpl in Hyp; inversion_clear Hyp; auto.
+ intros l' l1 l2 Hyp.
simpl in Hyp.
destruct l' as [ | y ys] eqn:L'.
- inversion Hyp.
- destruct l1 eqn:L1.
* destruct (lengthSplit l ys); simpl in *.
+ destruct p; congruence.
+ congruence.
* pose proof IHl ys l0 l2; clear IHl.
destruct (lengthSplit l ys) eqn:LenSplit; simpl in *.
+ inversion Hyp. destruct p. inversion H1. subst.
rewrite H; auto.
+ inversion Hyp.
Qed.
induction l as [ | x xs IHxs].
+ intros; simpl in H; inversion H; auto.
+ intros l' l1 l2 Split.
simpl in Split.
destruct l'.
- inversion Split.
- destruct l1.
* destruct (lengthSplit xs l').
+ simpl in *. destruct p. inversion Split.
+ simpl in *. inversion Split.
* simpl in *.
destruct (lengthSplit xs l') eqn:LenSplit.
+ simpl in *. destruct p. inversion Split; subst; clear Split.
pose proof (IHxs l' l1 l2 LenSplit) as Hyp; clear IHxs.
auto.
+ simpl in *. inversion Split.
Qed.
induction p.
+ inversion IHp as [n Hyp]; clear IHp.
simpl.
exists (S n).
rewrite app_length.
rewrite Hyp.
simpl.
omega.
+ inversion IHp as [n Hyp]; clear IHp.
simpl.
exists (S n).
rewrite app_length.
rewrite Hyp.
simpl.
omega.
+ exists (O).
simpl.
auto.
Qed.
induction l using list_ind'.
+ intros. exists f. auto.
+ intros. simpl in *. omega.
+ intros l' l'' lApp f n p Len Valid.
destruct n.
- simpl in Len. congruence.
- simpl in Len; assert (length l = (2 * n)%nat) by omega.
destruct a eqn:A; destruct b eqn:B; simpl in *.
* unfold pathToPos in Valid. simpl in Valid.
pose proof (IHl l' l'' lApp (fun p => xO (f p)) n p H Valid) as Hyp; clear IHl H.
inversion Hyp as [f' HF]; clear Hyp.
exists f'.
auto.
* unfold pathToPos in Valid. simpl in Valid.
pose proof (IHl l' l'' lApp (fun p => xI (f p)) n p H Valid) as Hyp; clear IHl H.
inversion Hyp as [f' HF]; clear Hyp.
exists f'.
auto.
* inversion Valid.
* inversion Valid.
Qed.
destruct l1.
+ intros. exfalso; apply H; auto.
+ intros.
destruct s.
- auto.
- simpl in H1.
destruct (l1 ++ l2) eqn:Contra.
* destruct l1; destruct l2; try solve [unfold not; exfalso; auto];
simpl in *; congruence.
* congruence.
Qed.
induction l1.
+ intros.
destruct l2.
- unfold not in H0. exfalso; apply H0; auto.
- simpl in H; inversion H.
+ intros l2 l3 l4 EqDec Len Neq.
destruct l2 as [ | b l2 ].
- simpl in Len. congruence.
- destruct (EqDec a b).
* subst. simpl in Len.
inversion Len as [ Len']; clear Len.
simpl.
pose proof (IHl1 l2 l3 l4 EqDec Len') as Contra; clear IHl1.
assert (l1 <> l2) by (unfold not; intros; congruence).
apply Contra in H.
unfold not in *.
intros.
apply H.
inversion H0.
auto.
* unfold not; intros.
inversion H.
congruence.
Qed.

Lemma PosToPathPrefixFreeAux : forall (x y : positive), (x <> y) ->
le (length (posToPathAux y)) (length(posToPathAux x)) ->
PrefixFree [posToPath x;
posToPath y].