Set Implicit Arguments.
Unset Strict Implicit.

Require Export Sigtel.

Section Mixtel.

(* The set of labels in records *)
Variable A : Set.

Inductive UnitS : Set :=
    unitS : UnitS.

Inductive flag (U : Set) : Set :=
  | Abs : U -> flag U
  | Man : U -> U -> flag U.


Definition abs_of (U : Set) (x : flag U) :=
  match x with
  | Abs p => p
  | Man p _ => p
  end.
   
Fixpoint pre (l : list A) : Set :=
  match l with
  | nil => UnitS
  | a :: m => flag (pre m)
  end.

Fixpoint is_all_man (l : list A) : pre l -> Prop :=
  match l return (pre l -> Prop) with
  | nil => fun _ => True
  | a :: m =>
      fun p => match p with
               | Abs _ => False
               | Man _ d => is_all_man d
               end
  end.

Definition Epre : pre nil := unitS.

Definition Apre (a : A) (l : list A) (d : pre l) : pre (a :: l) := Abs d.

Definition Mpre (a : A) (l : list A) (p1 p2 : pre l) : 
  pre (a :: l) := Man p1 p2.

Record dpair (T : Type) (f : T -> Type) : Type := 
  {dproj1 : T; dproj2 : f dproj1}.

Section Spec. 
Variable T : Type.
Variable U : Set.
Variable F : T -> U -> Type.


Definition option (p : flag U) : Type :=
  match p with
  | Abs _ => unit
  | Man p1 p2 => dpair (fun x : T => F x p2)
  end.

Definition None (p : U) : option (Abs p) := tt.

Definition Some (x : T) (p1 p2 : U) (n : F x p2) : 
  option (Man p1 p2) := Build_dpair (f:=fun x : T => F x p2) n.

Record mix (p : flag U) (a : A) : Type := 
  {mix_spec : forall x : T, F x (abs_of p); mix_val : option p}.  

End Spec.
 
Hint Resolve tt: mixtel.

Fixpoint mixtel (l : list A) : sigtel l -> pre l -> Type :=
  match l return (sigtel l -> pre l -> Type) with
  | nil => fun _ _ => EsigT
  | a :: m => fun s p => mix (fun x : dom s => mixtel (s x)) p a
  end.   

Definition Emix : mixtel (Esig A) Epre := Esig_.

Definition Amix (a : A) (l : list A) (T : Type) (f : T -> sigtel l)
  (p : pre l) (F : forall x : T, mixtel (f x) p) :
  mixtel (Csig a f) (Apre a p) :=
  Build_mix (F:=fun x : T => mixtel (f x)) (p:=Abs p) a F
    (None (fun x : T => mixtel (f x)) p).
        
Definition Mmix (a : A) (l : list A) (T : Type) (f : T -> sigtel l)
  (p1 p2 : pre l) (F : forall x : T, mixtel (f x) p1) 
  (y : T) (n : mixtel (f y) p2) : mixtel (Csig a f) (Mpre a p1 p2) :=
  Build_mix (F:=fun x : T => mixtel (f x)) (p:=Man p1 p2) a F
    (Some (F:=fun x : T => mixtel (f x)) (x:=y) p1 n).

Fixpoint totabs (l : list A) : pre l :=
  match l return (pre l) with
  | nil => unitS
  | a :: m => Abs (totabs m)
  end.

Definition mixtotabs :
  forall (l : list A) (s : sigtel l), mixtel s (totabs l).
  intros l s; pattern l, s in |- *; apply sigtel_rect; simpl in |- *.
  exact Esig_.
  intros; apply Build_mix; simpl in |- *; auto with mixtel.
Defined.

Definition new :
  forall (l : list A) (s : sigtel l) (p : pre l),
  is_all_man p -> mixtel s p -> impltel s.
  intros l s; pattern l, s in |- *; apply sigtel_rect; simpl in |- *.
  intros; exact (Eimpl A).
  intros a l' T f HR p; case p. contradiction. 
  simpl in |- *; intros p1 p2 H m; case m; intros F o; case o; intros x m';
   apply Build_dpairT with (dprojT1 := x); auto.
  apply HR with (p := p2); auto.
Defined.


(**** FUSION *****)

Require Import Bool.

Fixpoint merge_control (l : list A) : pre l -> pre l -> list bool :=
  match l return (pre l -> pre l -> list bool) with
  | nil => fun _ _ => nil
  | a :: l' =>
      fun p1 p2 =>
      match p1 with
      | Abs p11 =>
          match p2 with
          | Abs p21 => false :: merge_control p11 p21 (* ? *)
          | Man p21 p22 => true :: merge_control p11 p22
          end
      | Man p11 p12 => false :: merge_control p12 (abs_of p2)
      end
  end.

Definition headb (l : list bool) :=
  match l with
  | nil => true
  | b :: l => b
  end.

Fixpoint merge_prex (l : list A) : pre l -> pre l -> list bool -> pre l :=
  match l return (pre l -> pre l -> list bool -> pre l) with
  | nil => fun _ _ m => unitS
  | a :: l' =>
      fun p1 p2 m =>
      match p1 with
      | Abs p11 =>
          match p2 with
          | Abs p21 => Apre a (merge_prex p11 p21 (tail m))
          | Man p21 p22 =>
              if headb m
              then
               Mpre a (merge_prex p11 p21 (tail m))
                 (merge_prex p11 p22 (tail m))
              else Apre a (merge_prex p11 p21 (tail m))
          end
      | Man p11 p12 =>
          (fun p =>
           Mpre a (merge_prex p11 p (tail m)) (merge_prex p12 p (tail m)))
            (abs_of p2)
      end
  end.

Definition merge_mixx :
  forall (l : list A) (s : sigtel l) (p1 p2 : pre l) (m : list bool),
  mixtel s p1 -> mixtel s p2 -> mixtel s (merge_prex p1 p2 m).
  intros l s; pattern l, s in |- *; apply sigtel_rect; simpl in |- *.
    auto.
    clear s l; intros a l T f HR p1 p2 m; case p1; simpl in |- *.
    intros p'1 H1; case H1; simpl in |- *; intros F1 o1.
        case p2; simpl in |- *.
           intros p'2 H2; case H2; simpl in |- *; intros F2 o2;
            apply Build_mix; simpl in |- *; auto. 
           intros p'21 p'22 H2; case H2; simpl in |- *; intros F2 o2;
            case (headb m); simpl in |- *; apply Build_mix; 
            simpl in |- *; auto.
           case o2; intros x n; apply Build_dpair with (dproj1 := x); auto.
    intros p'11 p'12 H1 H2; case H1; generalize (mix_spec H2); intros H F1 o1;
     apply Build_mix; simpl in |- *; auto.
       case o1; intros x v; apply Build_dpair with (dproj1 := x); auto.
Defined.


Definition merge_pre (l : list A) (p1 p2 : pre l) :=
  merge_prex p1 p2 (merge_control p1 p2).

Definition merge_mix (l : list A) (s : sigtel l) (p1 p2 : pre l)
  (m1 : mixtel s p1) (m2 : mixtel s p2) : mixtel s (merge_pre p1 p2) :=
  merge_mixx (merge_control p1 p2) m1 m2.

Require Import Subsig.

Definition lift_pre :
  forall (l1 l2 : list A) (H : contO (eq (A:=A)) l1 l2), pre l2 -> pre l1.
  fix 3; intros l1 l2 H; case H; simpl in |- *; clear H l2 l1.
    intros; apply totabs.
    intros a1 a2 l1 l2 H Hc p; case p.
      intros p'; exact (Abs (lift_pre _ _ Hc p')).
      intros p1 p2; exact (Man (lift_pre _ _ Hc p1) (lift_pre _ _ Hc p2)).
    intros a l m H p; apply Abs; eauto.
    intros a1 a2 l1 l2 Hc p1; apply Abs; case p1.
      intros p; apply Abs; case p.  eauto.
          intros p''1 p''2; clear p''2; eauto.
      intros p'1 p'2; apply Man.
        case p'1. eauto. intros p''1 p''2; clear p''2; eauto.
        case p'2. eauto. intros p''1 p''2; clear p''2; eauto.
    eauto.
Defined.

Definition lift_mix :
  forall (l1 l2 : list A) (H : contO (eq (A:=A)) l1 l2) 
    (s1 : sigtel l1) (s2 : sigtel l2),
  subsig H s1 s2 ->
  forall p : pre l2, mixtel s2 p -> mixtel s1 (lift_pre H p).
   intros l1 l2 Hc s1 s2 H; elim H; clear H s2 s1 Hc l2 l1; simpl in |- *;
    auto.
     intros; apply mixtotabs.
     intros a l1 l2 T f g Hc H HR p; case p; simpl in |- *.
       intros d H'; case H'; intros F o; apply Build_mix; simpl in |- *; auto.
       intros p1 p2 H'; case H'; intros F o; apply Build_mix; simpl in |- *;
        auto; case o; intros x v; apply Build_dpair with (dproj1 := x); 
        auto.
     intros; apply Build_mix; simpl in |- *; auto with mixtel.
     intros a1 a2 l1 l2 T1 T2 f g Hc H HR p; case p; simpl in |- *.
      intros p1 H0; apply Build_mix; simpl in |- *; auto with mixtel;
       intros x; apply Build_mix; simpl in |- *; auto with mixtel; 
       case H0; intros F o; intros y; generalize (F y); 
       case p1; simpl in |- *. 
         intros p2 H1; case H1; auto.
         intros p1' p2' H1; case H1; auto.
      intros p1 p2 H0; apply Build_mix; simpl in |- *; auto with mixtel;
       intros x; apply Build_mix; simpl in |- *; auto with mixtel; 
       case H0; intros F o.
       intros y; generalize (F y); case p1; simpl in |- *. 
         intros p' H1; case H1; auto.
         intros p1' p2' H1; case H1; auto.
       case o; intros y H1; apply Build_dpair with (dproj1 := y);
        generalize H1; case p2; simpl in |- *.
         intros p' H2; case H2; auto.
         intros p'1 p'2 H2; case H2; auto.
Defined.


End Mixtel.




