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.

Lemma pathBeginsLeft : forall l1 l2 f x, l1 <> [] -> l2 <> [] ->
pathToPosAux (l1 ++ l2) f = Some x ->
head l1 = Some Left.