(* $Id: Subsig.v,v 1.2 1999/10/05 10:35:42 boulme Exp $ *)
(* Subtyping on records... *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export OTheoryList.
Require Export Sigtel.

Section Subsig.

Variable A : Set.

Let Esig := Esig A.
Let sigtel_rect := sigtel_rect (A:=A).

Inductive subsig :
forall l1 l2 : list A,
contO (eq (A:=A)) l1 l2 -> sigtel l1 -> sigtel l2 -> Type :=
  | subsig_E :
      forall (l : list A) (s : sigtel l),
      subsig (contO_nil (eq (A:=A)) l) s Esig
  | subsig_C :
      forall (a : A) (l1 l2 : list A) (T : Type) (f : T -> sigtel l1)
        (g : T -> sigtel l2) (H : contO (eq (A:=A)) l1 l2),
      (forall x : T, subsig H (f x) (g x)) ->
      subsig (contO_cons (refl_equal a) H) (Csig a f) (Csig a g)
  | subsig_lift :
      forall (a : A) (l1 l2 : list A) (T : Type) (f : T -> sigtel l1)
        (s : sigtel l2) (H : contO (eq (A:=A)) l1 l2),
      (forall x : T, subsig H (f x) s) ->
      subsig (contO_lift a H) (Csig a f) s
  | subsig_swap :
      forall (a1 a2 : A) (l1 l2 : list A) (T1 T2 : Type)
        (f : T1 -> T2 -> sigtel l1) (g : T2 -> T1 -> sigtel l2)
        (H : contO (eq (A:=A)) l1 l2),
      (forall (x : T1) (y : T2), subsig H (f x y) (g y x)) ->
      subsig (contO_swap a1 a2 H)
        (Csig a1 (fun x : T1 => Csig a2 (fun y : T2 => f x y)))
        (Csig a2 (fun y : T2 => Csig a1 (fun x : T1 => g y x)))
  | subsig_trans :
      forall (l1 l2 l3 : list A) (s1 : sigtel l1) (s2 : sigtel l2)
        (s3 : sigtel l3) (H1 : contO (eq (A:=A)) l1 l2)
        (H2 : contO (eq (A:=A)) l2 l3),
      subsig H1 s1 s2 -> subsig H2 s2 s3 -> subsig (contO_trans H1 H2) s1 s3.
Hint Resolve subsig_E subsig_C subsig_lift subsig_swap: sigtel.

Definition coerce_impltel :
  forall (l1 l2 : list A) (s1 : sigtel l1) (s2 : sigtel l2)
    (H : contO (eq (A:=A)) l1 l2), subsig H s1 s2 -> impltel s1 -> impltel s2.

fix 6; intros l1 l2 s1 s2 H0 H; case H; clear H H0 s2 s1 l2 l1; simpl in |- *;
 auto with sigtel.
intros a l1 l2 T f g Hc H i; case i; intros x i';
 apply Build_dpairT with (dprojT1 := x);
 exact (coerce_impltel _ _ _ _ _ (H x) i').
intros a l1 l2 T f s Hc H i; case i; intros x i';
 exact (coerce_impltel _ _ _ _ _ (H x) i').
intros a1 a2 l1 l2 T1 T2 f g Hc H i; case i; intros x j; case j; intros y k;
 apply Build_dpairT with (dprojT1 := y);
 apply Build_dpairT with (dprojT1 := x);
 exact (coerce_impltel _ _ _ _ _ (H x y) k).
intros l1 l2 l3 s1 s2 s3 H1 H2 H3 H4 i;
 exact (coerce_impltel _ _ _ _ _ H4 (coerce_impltel _ _ _ _ _ H3 i)).
Defined.

Lemma subsig_refl :
 forall (l : list A) (s : sigtel l),
 subsig (contO_refl (refl_equal (A:=A)) l) s s.
  intros l s; pattern l, s in |- *; apply sigtel_rect; simpl in |- *;
   auto with sigtel.
Defined.
Hint Resolve subsig_refl: sigtel.

Transparent eq_rec eq_rec_r sym_eq f_equal trans_eq.


Inductive presub :
forall l1 l2 : list A,
prefix (eq (A:=A)) l1 l2 -> sigtel l1 -> sigtel l2 -> Type :=
  | presub_E :
      forall (l : list A) (s : sigtel l),
      presub (prefix_nil (eq (A:=A)) l) s Esig
  | presub_C :
      forall (a : A) (l1 l2 : list A) (T : Type) (f : T -> sigtel l1)
        (g : T -> sigtel l2) (H : prefix (eq (A:=A)) l1 l2),
      (forall x : T, presub H (f x) (g x)) ->
      presub (prefix_cons (refl_equal a) H) (Csig a f) (Csig a g).
Hint Resolve presub_E presub_C: sigtel.
 

Lemma presub_subsig :
 forall (l1 l2 : list A) (s1 : sigtel l1) (s2 : sigtel l2)
   (H : prefix (eq (A:=A)) l1 l2), presub H s1 s2 -> subsig H s1 s2.
  fix 6; intros l1 l2 s1 s2 H1 H2; case H2; simpl in |- *; intros;
   apply subsig_E || apply subsig_C; auto.
Defined.

Lemma presub_refl :
 forall (l : list A) (s : sigtel l),
 presub (prefix_refl (refl_equal (A:=A)) l) s s.
Proof.
  intros l s; pattern l, s in |- *; apply sigtel_rect; simpl in |- *;
   auto with sigtel.
Defined.
Hint Resolve presub_subsig presub_refl: sigtel.

Lemma presub_Csig_invT_r :
 forall
   (P : forall (a : A) (l1 l2 : list A),
        prefix (eq (A:=A)) l1 (a :: l2) ->
        sigtel l1 -> forall T : Type, (T -> sigtel l2) -> Type) 
   (l2 : list A) (a : A) (T : Type) (g : T -> sigtel l2),
 (forall (l1 : list A) (f : T -> sigtel l1) (H : prefix (eq (A:=A)) l1 l2),
  (forall x : T, presub H (f x) (g x)) ->
  P a (a :: l1) l2 (prefix_cons (refl_equal a) H) (Csig a f) T g) ->
 forall (l1 : list A) (s1 : sigtel l1) (H : prefix (eq (A:=A)) l1 (a :: l2)),
 presub H s1 (Csig a g) -> P a l1 l2 H s1 T g.
Proof.
  intros P l2 a T g H1 l1 s1 H2 H3; generalize H1.
 change
   ((fun l1 l2 : list A =>
     match
       l2
       return
         (forall (H : prefix (eq (A:=A)) l1 l2) (s1 : sigtel l1)
            (s2 : sigtel l2), presub H s1 s2 -> Type)
     with
     | nil => fun _ _ _ _ => True
     | a :: l2 =>
         fun H' s1 s2 _ =>
         (forall (l0 : list A) (f : dom s2 -> sigtel l0)
            (H : prefix (eq (A:=A)) l0 l2),
          (forall x : dom s2, presub H (f x) (fun_ x)) ->
          P a (a :: l0) l2 (prefix_cons (refl_equal a) H) 
            (Csig a f) (dom s2) (fun_ (f:=s2))) ->
         P a l1 l2 H' s1 (dom s2) (fun_ (f:=s2))
     end) _ _ _ _ _ H3) in |- *; apply presub_rect; 
  simpl in |- *; auto.
Defined.

Lemma presub_trans :
 forall (l1 l2 l3 : list A) (s1 : sigtel l1) (s2 : sigtel l2)
   (s3 : sigtel l3) (H1 : prefix (eq (A:=A)) l1 l2)
   (H2 : prefix (eq (A:=A)) l2 l3),
 presub H1 s1 s2 ->
 presub H2 s2 s3 -> presub (prefix_trans (trans_eq (A:=A)) H1 H2) s1 s3.
Proof.
  intros l1 l2 l3 s1 s2 s3 H1 H2 H3 H4; generalize l1 s1 H1 H3; elim H4;
   clear H4 H3 H2 H1 s3 s2 s1 l3 l2 l1; simpl in |- *; 
   auto with sigtel.
  intros a l1 l2 T f g H1 H2 HR l3 s3 H4 H5; generalize l2 g H1 H2 HR;
   inversion H5 using presub_Csig_invT_r; simpl in |- *; 
   auto with sigtel.
Defined.



Definition flatsig :
  forall (l1 l2 : list A) (s1 : sigtel l1),
  (impltel s1 -> sigtel l2) -> sigtel (l1 ++ l2).
  intros l1 l2 s1; generalize l2; pattern l1, s1 in |- *; apply sigtel_rect;
   clear s1 l2 l1; simpl in |- *; auto with sigtel.
  intros a l1 T f HR l2 g; simpl in |- *;
   refine (Csig a (fun x : T => HR x l2 _)); eauto with sigtel.
Defined.


Lemma presub_flatsig :
 forall (l1 l2 : list A) (s1 : sigtel l1) (f : impltel s1 -> sigtel l2),
 presub (prefix_flat (refl_equal (A:=A)) l1 l2) (flatsig f) s1.
Proof.
  intros l1 l2 s1; pattern l1, s1 in |- *; apply sigtel_rect; simpl in |- *;
   auto with sigtel.
Defined.
Hint Resolve presub_flatsig: sigtel.

Lemma flatsig_constant :
 forall (l1 l2 : list A) (s1 : sigtel l1) (s2 : sigtel l2),
 subsig (contO_flat_const (refl_equal (A:=A)) l1 l2)
   (flatsig (fun _ : impltel s1 => s2)) s2.
Proof.
  intros l1 l2 s1; generalize l2; pattern l1, s1 in |- *; apply sigtel_rect;
   clear l2 s1 l1; simpl in |- *; auto with sigtel.
Defined.
Hint Resolve flatsig_constant: sigtel.

Lemma subsig_flatsig_coerce :
 forall (l1 l2 : list A) (s1 : sigtel l1) (s2 : sigtel l2)
   (H1 : contO (eq (A:=A)) l2 l1) (H : subsig H1 s2 s1) 
   (l3 : list A) (f : impltel s1 -> sigtel l3),
 subsig (contO_flat_coerc (refl_equal (A:=A)) l3 H1)
   (flatsig (fun i => f (coerce_impltel H i))) (flatsig (fun i => f i)).
Proof.
  simple induction H; clear H H1 s2 s1 l2 l1; simpl in |- *; auto with sigtel.
(* C *)
    intros a l1 l2 T f g Hc H HR l3 F; apply subsig_C; intro x;
     apply HR with (f0 := fun i : impltel (g x) => F (Cimpl a i)).
(* Swap *)
    intros a1 a2 l1 l2 T1 T2 f g Hc H HR l3 F;
     apply
      subsig_swap
       with
         (f := fun (x : T1) (y : T2) =>
               flatsig
                 (fun i : impltel (f x y) =>
                  F
                    (Cimpl a2
                       (f:=fun y : T2 => Csig a1 (fun x : T1 => g y x))
                       (Cimpl a1 (f:=fun x : T1 => g y x)
                          (coerce_impltel (H x y) i)))))
         (g := fun (y : T2) (x : T1) =>
               flatsig
                 (fun e : impltel (g y x) =>
                  F
                    (Cimpl a2
                       (f:=fun y : T2 => Csig a1 (fun x : T1 => g y x))
                       (Cimpl a1 (f:=fun x : T1 => g y x) e)))); 
     auto.
    intros x y;
     apply
      HR
       with
         (f0 := fun i : impltel (g y x) =>
                F
                  (Cimpl a2 (f:=fun y : T2 => Csig a1 (fun x : T1 => g y x))
                     (Cimpl a1 (f:=fun x : T1 => g y x) i))). 
(* Trans *)  
    intros l1 l2 l3 s1 s2 s3 H1c H2c H1 HR1 H2 HR2 l4 F;
     apply
      subsig_trans
       with (s2 := flatsig (fun i : impltel s2 => F (coerce_impltel H2 i)));
     auto;
     apply HR1 with (f := fun i : impltel s2 => F (coerce_impltel H2 i)).
Defined.
Hint Resolve subsig_flatsig_coerce: sigtel.

Lemma subsig_flatsig :
 forall (l1 l2 l3 : list A) (s : sigtel l1) (f : impltel s -> sigtel l2)
   (g : impltel s -> sigtel l3) (H : contO (eq (A:=A)) l2 l3),
 (forall i : impltel s, subsig H (f i) (g i)) ->
 subsig (contO_flat (refl_equal (A:=A)) l1 H) (flatsig f) (flatsig g).
  intros l1 l2 l3 s; generalize l2 l3; pattern l1, s in |- *;
   apply sigtel_rect; simpl in |- *; auto with sigtel.
Defined.
Hint Resolve subsig_flatsig: sigtel.

Lemma subsig_flatsig_ext_r :
 forall (l1 l2 : list A) (s : sigtel l1) (f : impltel s -> sigtel l2),
 subsig
   (contO_flat (refl_equal (A:=A)) l1 (contO_refl (refl_equal (A:=A)) l2))
   (flatsig f) (flatsig (fun i => f i)).
  auto with sigtel.
Defined.

Lemma subtel_Csig_flatsig :
 forall (l1 : list A) (s : sigtel l1) (a : A) (l2 l3 : list A) 
   (T : Type) (f : T -> impltel s -> sigtel l2) (g : T -> sigtel l3)
   (H : contO (eq (A:=A)) (l1 ++ l2) l3),
 (forall x : T, subsig H (flatsig (fun i => f x i)) (g x)) ->
 subsig (contO_app_cons (refl_equal (A:=A)) a H)
   (flatsig (fun i => Csig a (fun x => f x i))) (Csig a g).
Proof.
  intros l1 s; pattern l1, s in |- *; apply sigtel_rect; simpl in |- *;
   auto with sigtel; clear s l1.
  intros a1 l1 T h H a2 l2 l3 T' f g Hc H1;
   refine
    (subsig_trans
       (s2:=Csig a2
              (fun y : T' =>
               Csig a1
                 (fun x : T =>
                  flatsig (fun i : impltel (h x) => f y (Cimpl a1 i))))) _ _);
   auto with sigtel;
   refine
    (subsig_trans
       (s2:=Csig a1
              (fun x : T =>
               Csig a2
                 (fun y : T' =>
                  flatsig (fun i : impltel (h x) => f y (Cimpl a1 i))))) _ _).
   apply subsig_C; intros x;
    apply H with (f := fun (y : T') (i : impltel (h x)) => f y (Cimpl a1 i));
    auto with sigtel.
   apply
    subsig_swap
     with
       (g := fun (y : T') (x : T) =>
             flatsig (fun i : impltel (h x) => f y (Cimpl a1 i)))
       (f := fun (x : T) (y : T') =>
             flatsig (fun i : impltel (h x) => f y (Cimpl a1 i)));
    auto with sigtel.
Defined.

Let contO_length' := contO_length (R:=eq (A:=A)).
Hint Resolve contO_length': sigtel.

Require Import Arith.
Require Import EqAxioms.

Lemma subsig_sym :
 forall (l1 l2 : list A) (s1 : sigtel l1) (s2 : sigtel l2)
   (H1 : contO (eq (A:=A)) l1 l2) (H2 : length l1 = length l2),
 subsig H1 s1 s2 -> subsig (contO_sym (sym_eq (A:=A)) H1 H2) s2 s1.
  intros l1 l2 s1 s2 H1 H2 H; generalize H2; elim H;
   clear H2 H H1 s2 s1 l2 l1; simpl in |- *; auto with sigtel.
  intros l s; pattern l, s in |- *; apply sigtel_rect; simpl in |- *;
   auto with sigtel; intros a l' T f HR H; discriminate H. 
  intros a l1 l2 T f s H1 H2 HR H; absurd (length l2 <= length l1);
   auto with sigtel.
  rewrite <- H; auto with arith.
  intros l1 l2 l3 s1 s2 s3 H1c H2c H1 HR1 H2 HR2 H3.
    generalize
     (eq_ind (length l1)
        (fun n : nat => n <= length l2 -> length l1 = length l2)
        (fun H0 : length l1 <= length l2 =>
         le_antisym (length l1) (length l2) H0 (contO_length H1c))
        (length l3) H3 (contO_length H2c)).
    intros H4; apply subsig_trans with (s2 := s2); auto.
Defined.

End Subsig.

Hint Resolve subsig_E subsig_C subsig_lift subsig_swap: sigtel.
Hint Resolve presub_E presub_C presub_subsig presub_refl: sigtel.
Hint Resolve subsig_refl: sigtel.
Hint Resolve presub_flatsig: sigtel.
Hint Resolve subsig_flatsig_coerce subsig_flatsig flatsig_constant: sigtel.













