(* Some operations on lists for telescope theory *)

Set Implicit Arguments.
Unset Strict Implicit.

Require Export TheoryList.

Section OTheoryList.

Variable A : Set.
Variable R : A -> A -> Prop.
Hypothesis R_dec : forall x y : A, {R x y} + {~ R x y}.
Hypothesis R_refl : forall x : A, R x x.
Hypothesis R_trans : forall x y z : A, R x y -> R y z -> R x z.

Inductive contO : list A -> list A -> Set :=
  | contO_nil : forall l : list A, contO l nil
  | contO_cons :
      forall (a1 a2 : A) (l1 l2 : list A),
      R a1 a2 -> contO l1 l2 -> contO (a1 :: l1) (a2 :: l2)
  | contO_lift : forall (a : A) (l m : list A), contO l m -> contO (a :: l) m
  | contO_swap :
      forall (a1 a2 : A) (l1 l2 : list A),
      contO l1 l2 -> contO (a1 :: a2 :: l1) (a2 :: a1 :: l2)
  | contO_trans :
      forall l1 l2 l3 : list A, contO l1 l2 -> contO l2 l3 -> contO l1 l3.
Hint Resolve contO_nil contO_cons contO_lift contO_swap: declists.

Require Import Arith.

Lemma contO_length :
 forall l1 l2 : list A, contO l1 l2 -> length l2 <= length l1.
  intros l1 l2 H; elim H; simpl in |- *; auto with arith.
  intros l1' l2' l3' H1 H2 H3 H4; exact (le_trans _ _ _ H4 H2).
Defined.
Hint Resolve contO_length: declists.

Lemma contO_antisym :
 forall l1 l2 : list A, contO l1 l2 -> contO l2 l1 -> length l1 = length l2.
  intros; apply le_antisym; auto with declists.
Defined.
Hint Resolve contO_antisym: declists.


Lemma contO_refl : forall l : list A, contO l l.
  fix 1; intros l; case l; intros; apply contO_nil || apply contO_cons;
   auto with declists.
Defined.
Hint Resolve contO_refl: declists.


Inductive prefix : list A -> list A -> Set :=
  | prefix_nil : forall l : list A, prefix l nil
  | prefix_cons :
      forall (a1 a2 : A) (l1 l2 : list A),
      R a1 a2 -> prefix l1 l2 -> prefix (a1 :: l1) (a2 :: l2).

Hint Resolve prefix_nil prefix_cons: declists.

Lemma prefix_refl : forall l : list A, prefix l l.
  fix 1; intros l; case l; intros; apply prefix_nil || apply prefix_cons;
   auto with declists.
Defined.
Hint Resolve prefix_refl: declists.

Lemma prefix_trans :
 forall l m n : list A, prefix l m -> prefix m n -> prefix l n.
  fix 5; intros l m n H1 H2; generalize l H1; case H2; simpl in |- *;
   clear H2 H1 l m n; auto with declists.
  intros a2 a3 l2 l3 H1 H2 l H3; inversion_clear H3.
  apply prefix_cons; eauto with declists.
Defined.

Lemma prefix_contO : forall l m : list A, prefix l m -> contO l m.
  fix 3; intros l m H; case H; simpl in |- *; intros;
   apply contO_nil || apply contO_cons; auto with declists.
Defined.
Hint Resolve prefix_contO: declists.

Lemma prefix_flat : forall l m : list A, prefix (l ++ m) l.
  fix 1; intros l m; case l; simpl in |- *; auto with declists.
Defined.
Hint Resolve prefix_flat: declists.

Lemma contO_flat_const : forall l m : list A, contO (l ++ m) m.
  fix 1; intros l; case l; simpl in |- *; auto with declists.
Defined.
Hint Resolve contO_flat_const: declists.

Lemma contO_flat_coerc :
 forall l m n : list A, contO l m -> contO (l ++ n) (m ++ n).
  fix 4; intros l m n H; case H; simpl in |- *; auto with declists.
  intros l1 l2 l3 H1 H2; apply contO_trans with (l2 := l2 ++ n); auto.
Defined. 

Lemma contO_flat :
 forall l m n : list A, contO l m -> contO (n ++ l) (n ++ m).
  fix 3; intros l m n; case n; simpl in |- *; auto with declists.
Defined.

Lemma contO_app_cons :
 forall (a : A) (l1 l2 l3 : list A),
 contO (l1 ++ l2) l3 -> contO (l1 ++ a :: l2) (a :: l3).
  fix 2; intros a l1 l2 l3; case l1; simpl in |- *; clear l1;
   auto with declists.
  intros b l H; apply contO_trans with (l2 := a :: b :: l ++ l2);
   auto with declists.
    apply contO_trans with (l2 := b :: a :: l ++ l2); auto with declists.
Defined.
Hint Resolve contO_flat_coerc contO_flat contO_app_cons: declists.

Lemma contO_tl_r : forall l m : list A, contO l m -> contO l (tail m).
Proof.
  intros l m H; elim H; simpl in |- *; auto with declists.
  intros; apply contO_trans with (l2 := l2); auto.
Defined.

Lemma contO_app_rr : forall l m r : list A, contO l (m ++ r) -> contO l r.
  intros l m r; elim m; simpl in |- *; auto with declists.
  intros a l' H1 H2; apply H1; exact (contO_tl_r H2). 
Defined.

Fixpoint extractO_pre (l1 l2 : list A) (H : prefix l1 l2) {struct H} :
 list A :=
  match H with
  | prefix_nil l => l
  | prefix_cons a1 a2 l1 l2 H1 H2 => extractO_pre H2
  end.

Fixpoint extractO (l1 l2 : list A) (H : contO l1 l2) {struct H} : 
 list A :=
  match H with
  | contO_nil l => l
  | contO_cons a1 a2 l1 l2 H1 H2 => extractO H2
  | contO_lift a l m H => a :: extractO H
  | contO_swap a1 a2 l1 l2 H => extractO H
  | contO_trans l1 l2 l3 H1 H2 =>
      extractO_pre
        (prefix_trans (prefix_flat (l3 ++ extractO H2) (extractO H1))
           (prefix_flat l3 (extractO H2)))
  end.

Lemma extractO_pre_length :
 forall (l1 l2 : list A) (H : prefix l1 l2),
 length (l2 ++ extractO_pre H) = length l1.
  fix 3; intros l1 l2 H; case H; simpl in |- *; clear H l2 l1; auto.
Defined. 

Require Import ListLength.

Lemma extractO_length :
 forall (l1 l2 : list A) (H : contO l1 l2),
 length (l2 ++ extractO H) = length l1.
  fix 3; intros l1 l2 H; case H; simpl in |- *; clear H l2 l1; auto.
  intros; rewrite length_app_sym; simpl in |- *; rewrite length_app_sym; auto.
  intros; rewrite extractO_pre_length; rewrite length_app_plus;
   rewrite extractO_length; rewrite <- length_app_plus; 
   auto. 
Defined. 

Hypothesis R_sym : forall x y : A, R x y -> R y x.
Lemma prefix_app_extractO :
 forall (l1 l2 : list A) (H : prefix l1 l2), prefix (l2 ++ extractO_pre H) l1.
  fix 3; intros l1 l2 H; case H; simpl in |- *; clear H l2 l1;
   auto with declists.
Defined. 
Hint Resolve prefix_app_extractO: declists.


Lemma contO_app_extractO :
 forall (l1 l2 : list A) (H : contO l1 l2), contO (l2 ++ extractO H) l1. 
  fix 3; intros l1 l2 H; case H; simpl in |- *; clear H l2 l1;
   auto with declists.
  intros l1 l2 l3 H1 H2; apply contO_trans with (l2 := l2 ++ extractO H1);
   auto.
  apply contO_trans with (l2 := (l3 ++ extractO H2) ++ extractO H1);
   auto with declists.
Defined.
Hint Resolve contO_app_extractO: declists.

Lemma contO_sym :
 forall l1 l2 : list A, contO l1 l2 -> length l1 = length l2 -> contO l2 l1.
  intros l1 l2 H; elim H; simpl in |- *; auto with declists arith.
  intros l; case l; simpl in |- *; auto with declists; intros a l' H';
   discriminate H'. 
  intros a l m H' HR H''; absurd (length m <= length l); auto with declists;
   rewrite <- H''; auto with arith.
  intros a1 a2 l1' l2' H1 H2 H3; injection H3; auto with declists.     
  intros l1' l2' l3' H1 H2 H3 H4 H5; cut (length l1' = length l2').
    intros H6; apply contO_trans with (l2 := l2'); auto. rewrite H6 in H5; auto.
    generalize (contO_length H3); rewrite <- H5; intros; apply le_antisym;
     auto with declists.
Defined.

Hint Resolve extractO_length contO_sym: declists.

Lemma contO_extractO_app :
 forall (l1 l2 : list A) (H : contO l1 l2), contO l1 (l2 ++ extractO H).
  intros; auto with declists.
Defined.
 
Lemma contO_extractO :
 forall (l1 l2 : list A) (H : contO l1 l2), contO l1 (extractO H).
  intros l1 l2 H; apply contO_app_rr with (m := l2); auto with declists.
Defined.

Section Comp.

Variable l1 l2 l3 : list A.
Variable H1 : contO l1 l3.
Variable H2 : contO l2 l3.

Lemma comp_1 : contO (l3 ++ extractO H1 ++ extractO H2) l1.
  apply contO_trans with (l2 := l3 ++ extractO H1); auto with declists.
Defined.

Lemma comp_2 : contO (l3 ++ extractO H1 ++ extractO H2) l2.
  apply contO_trans with (l2 := l3 ++ extractO H2); auto with declists.
Defined.

End Comp.

End OTheoryList.


Coercion prefix_contO : prefix >-> contO. 



