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.
intros x y H Leq.
apply FreeCons; [ apply FreeCons ; [ constructor | intros p Contra; inversion Contra] | ].
intros.
inversion H0; subst; clear H0; [ | inversion H2].
unfold posToPath in *; simpl in *; repeat rewrite <- app_assoc in *.
pose proof (lengthSplit1 Leq) as Hyp.
inversion Hyp as [pair Split]; clear Hyp.
destruct pair as [l0 l1].
pose proof (lengthSplit2 Split) as AppHyp.
pose proof (lengthSplit3 Split) as LenHyp.
pose proof (lengthPathEven y) as Hyp; inversion Hyp as [n LenN]; subst; clear Hyp.
assert (XHyp : pathToPosAux (l0 ++ l1 ++ [Right]) (fun x => x) = Some x);
[ rewrite app_assoc; rewrite AppHyp; apply posPathInj | ].
rewrite <- LenHyp in LenN.
pose proof (evenPathAux [Right] LenN XHyp) as Even.
inversion Even as [f' HF]; clear Even.
inversion HF as [HF1 HF2]; clear HF.
rewrite <- AppHyp in H1.
rewrite <- app_assoc in H1.
destruct (list_eq_dec Direction_eq_dec (posToPathAux y) l0).
- subst. apply app_inv_head in H1.
destruct l1.
*  simpl in AppHyp; rewrite app_nil_r in AppHyp.
assert (posToPathAux y ++ [Right] = posToPathAux x ++ [Right])
by (rewrite AppHyp; auto).
assert (posToPath y = posToPath x) by (unfold posToPath; auto).
assert (pathToPos (posToPath y) = pathToPos (posToPath x)) by (rewrite H2; auto).
repeat rewrite posPathInj in H3.
congruence.
* assert (Contra : hd_error (s :: l1) = Some Left).
eapply pathBeginsLeft.
+ unfold not; intros; congruence.
+ instantiate (1 := [Right]); unfold not; intros; congruence.
+ instantiate (1:= x); instantiate (1:=f').
rewrite <- HF2.
apply XHyp.
simpl in Contra. inversion Contra; subst. simpl in H1. congruence.
- eapply listAppNeq.
* apply Direction_eq_dec.
* instantiate (1 := l0). instantiate (1 := posToPathAux y). eauto.
* eassumption.
* eapply H1.
Qed.
intros.
inversion H.
apply FreeCons.
+ apply FreeCons.
- constructor.
- intros. inversion H4.
+ intros.
subst.
eapply H3.
- instantiate (1 := l2); left; auto.
- inversion H4.
* subst. inversion H4. subst. instantiate (1:= p1); instantiate (1 := p2).
auto.
* inversion H0.
- inversion H0.
Qed.

Lemma PosToPathPrefixFree : forall (x y : positive), (x <> y) ->
PrefixFree [posToPath x;
posToPath y].