Require Import RGref.DSL.DSL.
Require Import RGref.DSL.Concurrency.
Require Import RGref.DSL.Fields.
Require Import TrieberStack. (* Reuse the node implementation *)

(** Elimination Stack
    We'll roughly follow the paper "A Scalable Lock-free Stack Algorithm"
    by Hendler, Shavit, and Yerushalmi, from SPAA'04. *)
Inductive Op : Set := PUSH | POP.
Inductive  ThreadInfo : Set :=
  | mkTI : nat -> Op -> Node -> nat -> ThreadInfo.
Inductive TIFields : Set := id | op | cell | spin.
Instance ti_ft : FieldTyping ThreadInfo TIFields.
Instance ti_id : FieldType ThreadInfo TIFields id nat :=
{ getF := (fun ti => match ti with mkTI i o c s => i end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI v o c s end)
}.
Instance ti_op : FieldType ThreadInfo TIFields op Op :=
{ getF := (fun ti => match ti with mkTI i o c s => o end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI i v c s end)
}.
Instance ti_cell : FieldType ThreadInfo TIFields cell Node :=
{ getF := (fun ti => match ti with mkTI i o c s => c end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI i o v s end)
}.
Instance ti_spin : FieldType ThreadInfo TIFields spin nat :=
{ getF := (fun ti => match ti with mkTI i o c s => s end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI i o c v end)
}.

Section Body.

  Parameter size : nat.
  Parameter mypid : nat.
  Parameter pid_size : mypid < size.

  (* Each thread may only modify its own entry in the location array *)
  Definition SingleCellHavoc {n c:nat} {T:Set} (pf:c < n) : hrel (Array n T) :=
    fun (a a':Array n T) (h h':heap) => forall (i:fin n), i=(of_nat_lt pf) \/ array_read a i = array_read a' i.
  Lemma precise_single_cell_havoc : forall n c T (rch:ImmediateReachability T) (pf:c<n),
                                      precise_rel (@SingleCellHavoc n c T pf).
  Proof.
    intros. compute -[of_nat_lt]. intros.
    induction (H1 i); eauto.
  Qed. (* SingleCellHavoc is local *)
  Hint Resolve @precise_single_cell_havoc.

  Inductive ElimStack : Set :=
  | mkES : option (ref{Node|any}[local_imm,local_imm]) ->
           ref{(Array size (option (ref{ThreadInfo|any}[havoc,local_imm])))|any}[havoc,SingleCellHavoc pid_size] ->
           ref{(Array size nat)|any}[havoc,havoc] ->
           ElimStack.
  Inductive ES_fields : Set := stack | location | collision.
  Instance es_ft : FieldTyping ElimStack ES_fields.
  Instance es_stack : FieldType ElimStack ES_fields stack _ :=
  { getF := fun es => match es with mkES st loc col => st end;
    setF := fun es v => match es with mkES st loc col => mkES v loc col end
  }.
  Instance es_loc : FieldType ElimStack ES_fields location _ :=
  { getF := fun es => match es with mkES st loc col => loc end;
    setF := fun es v => match es with mkES st loc col => mkES st v col end
  }.
  Instance es_col : FieldType ElimStack ES_fields collision _ :=
  { getF := fun es => match es with mkES st loc col => col end;
    setF := fun es v => match es with mkES st loc col => mkES st loc v end
  }.
  Print ImmediateReachability.
  Inductive es_reachability : forall T P R G, ref{T|P}[R,G] -> ElimStack -> Prop :=
  | st_reach : forall st loc col,
                 es_reachability _ _ _ _ st (mkES (Some st) loc col)
  | loc_reach : forall st loc col,
                  es_reachability _ _ _ _ loc (mkES st loc col)
  | col_reach : forall st loc col,
                  es_reachability _ _ _ _ col (mkES st loc col).
  Instance reach_es : ImmediateReachability ElimStack :=
  { imm_reachable_from_in := es_reachability }.
  Print Containment.
  Instance cont_es : Containment ElimStack.
  Admitted. (* TODO *)
  Instance fold_es : rel_fold ElimStack.
  Admitted. (* TODO: This is one of those cases where the result of folding
               isn't necessarily valid; if you weaken guarantees of the
               ES interior pointers, you can't compose the results into
               an ES!  In this case we could parameterize ES by
               relations for the pointer members, and then folding would
               work.  But for recursive strucutures like the M&S queue or
               Heller set, this is important.  Might need to go ahead and
               directly specify a field-specific fold, since we're going
               to access these things field-at-a-time anyways.

               Then in general I could build Allocatable, FullDeref, and
               FieldDeref parameterized typeclasses for different use
               cases, and derive those from instances of rel_fold, Containment,
               etc. as appropriate.  This way I can easily have types
               that for example can be accessed field-at-a-time without
               the ability to be accessed all-at-once (like ElimStack) *)

  (* TODO: More precise rely, guarantee, for arrays, ElimStack. *)
  Definition EliminationStack := ref{ElimStack|any}[havoc,havoc].

  Program Definition alloc_es {Γ} (_:unit) : rgref Γ EliminationStack Γ :=
    locarr <- Alloc (new_array size _ None);
    colarr <- Alloc (new_array size _ 0);
    Alloc (mkES None locarr colarr).

  (* TODO: more precise rely, guarantee, predicate for ThreadInfo operations. *)
  Program Definition TryCollision {Γ} (es:EliminationStack) (him:nat) (p:ref{ThreadInfo|any}[havoc,havoc]) (q:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ bool Γ :=
    match p~>op with
    | PUSH => (*@field_cas_core _ _ _ _ _ _ _ _ (es~>location) mypid _ _ (Some q) None _ *)
              fCAS((es~>location)→him, Some q, Some p) (* WTF? where is 'him' scoped in the original paper??? globally? *)
    | POP => res <- fCAS((es~>location)→him, Some q, None);
             if res
             then (_ <- {[p ~~> cell ]}:= (q ~> cell);
                   _ <- {[(es~>location)~~>mypid]}:= @None _;
                   rgret true)
             else rgret false
    end.

  (* Paper uses a type 'ProcessInfo' which appears to be intended to be 'ThreadInfo' *)
  Program Definition FinishCollision {Γ} (es:EliminationStack) (p:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ unit Γ :=
    match (p ~> op) with
    | POP =>
        (*[ @field_read ThreadInfo _ _ _ _ _ _ _ _ _ p cell _ ti_cell ]:= _*)
        (*[ @field_read ThreadInfo _ _ _ _ _ _ _ _ _ p cell _ _ ]:= _*)
        (*[ @field_read _ _ _ _ _ _ _ _ _ _ p cell _ _ ]:= _*)
        _ <- {[ p ~~> cell ]}:= ( ((es ~> location)~>mypid)~>cell );
        {[ (es~>location)~~>mypid ]}:= @None _
    | _ => rgret tt
    end.

  Program Definition LesOP {Γ} (es:EliminationStack) (p:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ unit Γ.
  Admitted.

  Program Definition TryPerformStackOp {Γ} (es:EliminationStack) (p:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ bool Γ :=
    match (p ~> op) with
    | PUSH => (phead <- (es~>stack);
               _ <- {[ (p~>cell)~~>next ]}:= phead;
               fCAS(es → stack, phead, Some _ ) (* Needs to be &p~>cell, but cell is embedded in ThreadInfo atm. Also need Node fields.
                                                   What should the R,G be for the Node ptr in ThreadInfo? We assign to it here, so
                                                   it can't be local_imm.  Later we set cell field of ThreadInfo to null, so
                                                   it should actually be an option of a ref to a Node.

                                                   OH! Or not... Fig. 3 seems to use EMPTY as value-copying the empty node... Line T11 vs. T15,
                                                   and the ThreadInfo def in Fig. 2 has the Cell inline...
                                                 *)
               )
    | POP => (phead <- es~>stack;
              match phead with
              | None => ( _ <- {[ p ~~> cell ]}:= EMPTY;
                          rgret true)
              | Some hd => (
                    pnext <- hd~>next;
                    IF fCAS(es→stack, phead, pnext)
                    THEN (_ <- {[ p ~~> cell ]}:= phead;
                          rgret true)
                    ELSE (_ <- {[ p ~~> cell ]}:= EMPTY;
                          rgref false)
                    )
               end
    end.

  Program Definition StackOp {Γ} (es:EliminationStack) (pInfo:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ unit Γ :=
    op <- TryPerformStackOp es pInfo;
    if op
    then rgret tt
    else LesOP pInfo.


Require Import POCS.

Require Import OneDiskAPI.
Require Import NbdAPI.
Require Import NbdImpl.

Module nbd := NbdImpl.

Module NBDServer (d : OneDiskAPI).

  Fixpoint read (off:nat) n : proc (bytes (n*blockbytes)) :=
    match n with
    | 0 => Ret bnull
    | S n => b <- d.read off;
              rest <- read (off+1) n;
              Ret (bappend b rest)
    end.

  Fixpoint write (off:nat) (bl : list (bytes blockbytes)) : proc unit :=
    match bl with
    | nil => Ret tt
    | b :: bl' =>
      _ <- d.write off b;
      write (off+1) bl'
    end.

  Theorem read_ok : forall n off, proc_spec (fun (_ : unit) state => {|
      pre := True;
      post := fun r state' => state' = state /\ read_match state off n r;
      recovered := fun _ state' => state' = state
    |}) (read off n) d.recover d.abstr.
  Proof.
    induction n; intros.
    - simpl.
      step_proc.
    - simpl read.

      step_proc.
      step_proc.
      step_proc.

      rewrite bsplit_bappend.
      intuition subst; eauto.
      + destruct (diskGet state off); simpl in *; intuition (subst; eauto).
      + replace (S off) with (off + 1) by lia; auto.
  Qed.

  Theorem write_ok : forall blocks off, proc_spec (fun (_ : unit) state => {|
      pre := True;
      post := fun r state' =>
        r = tt /\ state' = write_upd state off blocks;
      recovered := fun _ state' =>
        exists nwritten,
        state' = write_upd state off (firstn nwritten blocks)
    |}) (write off blocks) d.recover d.abstr.
  Proof.
    induction blocks; intros.
    - simpl.
      step_proc.
      intuition eauto.
      exists 0; simpl; eauto.

    - simpl write.

      step_proc.
      { intuition eauto.
        + exists 0; simpl; auto.
        + exists 1; simpl; auto.
      }
      specialize (IHblocks (off + 1)).
      step_proc.

      + f_equal; lia.

      + intuition.
        exists (S nwritten); simpl.
        f_equal; lia.
  Qed.

  CoFixpoint handle : proc unit :=
    req <- nbd.getRequest;
    match req with
    | Read h off blocks =>
      (* TODO: bounds checks *)
      data <- read off blocks;
      _ <- nbd.sendResponse
        {| rhandle := h; error := ESuccess; data := data; |};
      handle
    | Write h off _ dat =>
      _ <- write off (bsplit_list dat);
      _ <- nbd.sendResponse
        {| rhandle := h; error := ESuccess; data := bnull |};
      handle
    | Flush h =>
      _ <- nbd.sendResponse
        {| rhandle := h; error := ESuccess; data := bnull |};
      handle
    | UnknownOp h =>
      _ <- nbd.sendResponse
        {| rhandle := h; error := EInvalid; data := bnull |};
      handle
    | Disconnect => Ret tt
    end.

  Definition serverLoop : proc unit :=
    _ <- nbd.recover;
    _ <- d.recover;
    handle.

  Definition size : proc nat :=
    d.size.

  Definition init := then_init nbd.init d.init.

End NBDServer.


Require Import ZF ZFpairs ZFsum ZFnats ZFrelations ZFord ZFfix ZFstable.
Require Import ZFlist.
Import ZFrepl.

Section W_theory.

Variable A : set.

Definition path := List A.

Definition tree := power path.

Definition node f :=
  singl Nil ∪ sup A (fun x => replf (f x) (Cons x)).

Lemma text1 X x : ext_fun X (Cons x).
do 2 red; intros; apply couple_morph; auto with *.
Qed.
Lemma text2 f : ext_fun A f -> ext_fun A (fun x => replf (f x) (Cons x)).
do 2 red; intros; apply replf_morph; auto with *.
red; intros; apply couple_morph; trivial.
Qed.
Hint Resolve text1 text2.

Lemma node_def : forall f p,
  ext_fun A f ->
  (p ∈ node f <->
   p == Nil \/ exists2 i, i ∈ A & exists2 p', p' ∈ f i & p == Cons i p').
intros; unfold node.
split; intros.
 apply union2_elim in H0; destruct H0; [left|right].
  apply singl_elim in H0; trivial.

  rewrite sup_ax in H0; auto; destruct H0.
  exists x; trivial.
  rewrite replf_ax in H1; trivial.

 destruct H0; [apply union2_intro1|apply union2_intro2].
  rewrite H0; apply singl_intro.

  destruct H0 as (i,tyi,(p',infi,eqp)).
  rewrite sup_ax; auto.
  exists i; trivial.
  rewrite replf_ax; eauto.
Qed.

Lemma node_tl f i p :
  ext_fun A f ->
  i ∈ A ->
  (Cons i p ∈ node f <-> p ∈ f i).
intros.
rewrite node_def; trivial.
split; intros; eauto with *.
destruct H1 as [abs|(i',tyi,(p',typ',eqp))].
 symmetry in abs; apply discr_mt_pair in abs; contradiction.

 apply couple_injection in eqp; destruct eqp.
 rewrite H2; rewrite (H _ _ H0 H1); trivial.
Qed.

Lemma node_mono f f':
  ext_fun A f ->
  ext_fun A f' ->
  (forall i, i ∈ A -> f i ⊆ f' i) ->
  node f ⊆ node f'.
red; intros.
rewrite node_def in H2|-*; trivial.
destruct H2;[left;trivial|right].
destruct H2 as (i,tyi,(p,typ,eqp)).
exists i; trivial.
exists p; auto.
apply H1; trivial.
Qed.

Lemma node_morph f f' :
  eq_fun A f f' -> node f == node f'.
intros.
assert (e1 := eq_fun_ext _ _ _ H).
assert (e2 := eq_fun_ext _ _ _ (symmetry H)).
apply incl_eq; apply node_mono; trivial; intros.
 rewrite <- (H _ _ H0 (reflexivity _)); reflexivity.
 rewrite <- (H _ _ H0 (reflexivity _)); reflexivity.
Qed.

Lemma node_inv_mono f f' :
  ext_fun A f ->
  ext_fun A f' ->
  node f ⊆ node f' ->
  forall i, i ∈ A -> f i ⊆ f' i.
red; intros.
rewrite <- node_tl in H3; trivial.
apply H1 in H3.
rewrite node_tl in H3; trivial.
Qed.

Lemma node_inj f f' :
  ext_fun A f ->
  ext_fun A f' ->
  node f == node f' ->
  eq_fun A f f'.
red; intros.
apply incl_eq.
 rewrite <- (H0 _ _ H2 H3).
 apply node_inv_mono; trivial.
 rewrite H1; reflexivity.

 rewrite <- (H0 _ _ H2 H3).
 apply node_inv_mono; trivial.
 rewrite H1; reflexivity.
Qed.

Lemma node_typ f :
  ext_fun A f ->
  typ_fun f A tree ->
  node f ∈ tree.
intros.
apply power_intro; intros.
rewrite node_def in H1; trivial.
destruct H1 as [hd|(i,tyi,(p,typ,eqp))].
 rewrite hd; apply Nil_typ.

 rewrite eqp; apply Cons_typ; auto.
 apply power_elim with (2:=typ); auto.
Qed.

Lemma text3 X : ext_fun (cc_arr A X) (fun f => node (cc_app f)).
do 2 red; intros.
apply node_morph.
red; intros; apply cc_app_morph; auto with *.
Qed.
Lemma text4 X f : ext_fun X (cc_app f).
do 2 red; intros; apply cc_app_morph; auto with *.
Qed.
Hint Resolve text3 text4.

(* X a set of trees *)
Definition nodeF X := replf (cc_arr A X) (fun f => node (cc_app f)).

Lemma nodeF_def X t :
  t ∈ nodeF X <-> exists2 f, f ∈ cc_arr A X & t == node (cc_app f).
unfold nodeF.
rewrite replf_ax; auto with *.
Qed.

Instance nodeF_mono : Proper (incl_set ==> incl_set) nodeF.
do 3 red; intros.
rewrite nodeF_def in H0 |- *.
destruct H0.
exists x0; auto.
revert H0; apply cc_prod_covariant; auto with *.
Qed.

Instance nodeF_morph : morph1 nodeF.
Proof Fmono_morph _ nodeF_mono.

Lemma nodeF_typ X : X ⊆ tree -> nodeF X ⊆ tree.
unfold nodeF; red; intros.
rewrite replf_ax in H0; trivial.
destruct H0.
rewrite H1.
apply node_typ; trivial.
red; intros.
apply H.
apply cc_arr_elim with (1:=H0); trivial.
Qed.

Definition trees := Ffix nodeF tree.

(***************************************************************************)

(* No! *)
Definition node x f :=
  sup ts (fun t => replf t (Cons x)).

Lemma node_def : forall x ts p,
  p ∈ node x ts <-> exists2 t, t ∈ ts & exists2 p', p' ∈ t & p == Cons x p'.

Lemma node_inj : forall x x' t t', node x t == node x' t' -> x == x' /\ t == t'.

(* Prefix order on paths *)
Definition leP := exists2 x, x ∈ A & p2 == Cons x p1.
Definition leT t p1 p2 := (p1 ∈ t /\ p2 ∈ t) /\ leP t1 t2.
Lemma leT_node : forall x ts t p1 p2,
  t ∈ ts ->
  leT t p1 p2 ->
  leT (node x ts) (Cons x p1) (Cons x p2).

Lemma node_typ :
  x ∈ A -> ts ⊆ tree -> node x t ∈ tree

Definition nodeF ts := sup A (fun x => replf ts (node x)).

Lemma nodeF_typ : forall ts,
  ts ⊆ tree -> nodeF ts ⊆ tree.

Lemma nodeF_mono : Proper (incl_set ==> incl_set) nodeF.

Lemma nodeF_stable : forall X Y,
  X ⊆ tree ->
  Y ⊆ tree ->
  nodeF (X ∩ Y) == nodeF X ∩ nodeF Y.

Definition trees := Ffix tree nodeF.

 sup ts (fun t => replf A (fun

Definition wftree t := well_founded (leT t).

Definition trees := subset (power tree) wftree.

Lemma node_typ_wf :
  x ∈ A -> ts ∈ tress -> wftree (node x t)

Lemma wft_constr :

Variable F : set -> set.
Hypothesis Fmono : Proper (incl_set ==> incl_set) F.
Hypothesis Fstab : stable F.

Let Fm : morph1 F.
apply Fmono_morph; trivial.
Qed.

Variable Fdom : set -> set.
Hypothesis Fdm : morph1 Fdom.
Hypothesis Fds : forall X x, x ∈ F X -> Fdom x ⊆ A.

Variable Fsub : set -> set -> set.
Hypothesis Fsm : morph2 Fsub.
Hypothesis Fstyp : forall X x i, x ∈ F X -> i ∈ Fdom x -> Fsub x i ∈ X.

(* The construction domain and the constructor *)
Definition Wdom := power (List A).

Definition Wsup x :=
  singl Nil ∪ sup (Fdom x) (fun i => replf (Fsub x i) (fun p => Cons i p)).

Instance Wsup_morph : Proper (eq_set ==> eq_set) Wsup.
do 2 red; intros.
unfold Wsup.
apply union2_morph; auto with *.
apply sup_morph; auto with *.
red; intros.
apply replf_morph_raw; auto.
 apply Fsm; trivial.

 red; intros.
 apply couple_morph; trivial.
Qed.

Lemma wext1 : forall i y,
  ext_fun y (fun p => Cons i p).
do 2 red; intros.
rewrite H0; reflexivity.
Qed.

Lemma wext2 : forall X f,
  ext_fun X (fun y =>
     replf (Fsub f y) (fun p => Cons y p)).
do 2 red; intros.
apply replf_morph_raw; auto.
 rewrite H0; reflexivity.

 red; intros.
 rewrite H0; rewrite H1; reflexivity.
Qed.
Hint Resolve wext1 wext2.

Lemma Wsup_def :
  forall x p,
  (p ∈ Wsup x <->
   p == Nil \/
   exists2 i, i ∈ Fdom x &
   exists2 q, q ∈ Fsub x i &
   p == Cons i q).
intros.
unfold Wsup.
split; intros.
 apply union2_elim in H; destruct H;[left|right].
  apply singl_elim in H; trivial.

  rewrite sup_ax in H; trivial.
  destruct H as (i,?,?); exists i; trivial.
  rewrite replf_ax in H0; trivial.

 destruct H as [eqp|(i,?,(q,?,eqp))]; rewrite eqp; clear eqp.
  apply union2_intro1.
  apply singl_intro.

  apply union2_intro2.
  rewrite sup_ax; trivial.
  exists i; trivial.
  rewrite replf_ax; trivial.
  exists q; auto with *.
Qed.

Lemma Wsup_hd_prop : forall x, Nil ∈ Wsup x.
intros.
unfold Wsup.
apply union2_intro1.
apply singl_intro.
Qed.

Lemma Wsup_tl_prop : forall i l x,
  x ∈ F Wdom ->
  (Cons i l ∈ Wsup x <-> i ∈ Fdom x /\ l ∈ Fsub x i).
intros.
split; intros.
 apply union2_elim in H0; destruct H0.
  apply singl_elim in H0.
  symmetry in H0.
  apply discr_mt_pair in H0; contradiction.

  rewrite sup_ax in H0; trivial.
  destruct H0.
  rewrite replf_ax in H1; trivial.
  destruct H1.
  apply couple_injection in H2; destruct H2.
  rewrite H2; split; trivial.
  rewrite H3; trivial.

 destruct H0.
 unfold Wsup.
 apply union2_intro2.
 rewrite sup_ax; trivial.
 exists i; trivial.
 rewrite replf_ax; trivial.
 exists l; auto with *.
Qed.
(*
Lemma Wsup_inj : forall x x',
  x ∈ F Wdom ->
  x' ∈ F Wdom ->
  Wsup x == Wsup x' -> x == x'.
intros.
assert (fst x == fst x').
 generalize (Wsup_hd_prop (fst x) x); intro.
 generalize (Wsup_hd_prop (fst x) x'); intro.
 apply H3.
 rewrite <- H1.
 apply H2.
 reflexivity.
assert (snd x == snd x').
 specialize cc_eta_eq with (1:=tys _ _ H); intros.
 specialize cc_eta_eq with (1:=tys _ _ H0); intros.
 rewrite H3; rewrite H4.
 apply cc_lam_ext.
  apply Bmorph; trivial.

  red; intros.
  assert (x'0 ∈ A (fst x')).
   rewrite <- H6; rewrite <- H2; trivial.
  assert (cc_app (snd x) x0 ⊆ prodcart (List (sup A A)) A).
   red; intros.
   apply power_elim with (2:=H8).
   apply cc_prod_elim with (1:=tys _ _ H); trivial.
  assert (cc_app (snd x') x'0 ⊆ prodcart (List (sup A A)) A).
   red; intros.
   apply power_elim with (2:=H9); trivial.
   apply cc_prod_elim with (1:=tys _ _ H0); trivial.
  generalize (fun z l => Wsup_tl_prop x0 l z _ H); intros.
  generalize (fun z l => Wsup_tl_prop x'0 l z _ H0); intros.
  apply eq_intro; intros.
   generalize (surj_pair _ _ _ (H8 _ H12)); intro.
   rewrite H13.
   apply H11.
   rewrite <- H6; rewrite <- H1.
   apply <- H10.
   rewrite <- H13; auto.

   generalize (surj_pair _ _ _ (H9 _ H12)); intro.
   rewrite H13.
   apply H10.
   rewrite H1; rewrite H6.
   apply <- H11.
   rewrite <- H13; auto.
apply subset_elim1 in H.
apply subset_elim1 in H0.
rewrite (surj_pair _ _ _ H).
rewrite (surj_pair _ _ _ H0).
rewrite H2; rewrite H3; reflexivity.
Qed.
*)
Lemma Wsup_typ_gen : forall x,
  x ∈ F Wdom ->
  Wsup x ∈ Wdom.
intros.
apply power_intro; intros.
rewrite Wsup_def in H0.
destruct H0 as [eqz|(i,?,(q,?,eqz))]; rewrite eqz; clear z eqz.
 apply Nil_typ.

 assert (q ∈ List A).
  apply power_elim with (2:=H1); auto.
 apply Cons_typ; auto.
 revert H0; apply (Fds Wdom); trivial.
Qed.

(* The type operator on the construction domain *)
Definition Wf X := replf (F X) Wsup.

Lemma wfext1 : forall X, ext_fun (F X) Wsup.
do 2 red; intros.
rewrite H0; reflexivity.
Qed.
Hint Resolve wfext1.

Lemma Wf_intro : forall x X,
  x ∈ F X ->
  Wsup x ∈ Wf X.
intros.
unfold Wf.
rewrite replf_ax; trivial.
exists x; auto with *.
Qed.

Lemma Wf_elim : forall a X,
  a ∈ Wf X ->
  exists2 x, x ∈ F X &
  a == Wsup x.
intros.
unfold Wf in H.
rewrite replf_ax in H; trivial.
Qed.

Lemma Wf_mono : Proper (incl_set ==> incl_set) Wf.
do 3 red; intros.
apply Wf_elim in H0; destruct H0 as (f,?,?).
rewrite H1; apply Wf_intro; trivial.
clear H1; revert f H0.
apply Fmono; trivial.
Qed.
Hint Resolve Wf_mono Fmono_morph.

Lemma Wf_typ : forall X,
  X ⊆ Wdom -> Wf X ⊆ Wdom.
red; intros.
apply Wf_elim in H0; destruct H0 as (x,?,?).
rewrite H1.
apply Wsup_typ_gen; trivial.
clear H1; revert x H0.
apply Fmono; trivial.
Qed.
Hint Resolve Wf_typ.

Lemma Wf_stable : forall X,
  X ⊆ power Wdom ->
  inter (replf X Wf) ⊆ Wf (inter X).
red; intros X Xty z H.
unfold Wf.
assert (forall a, a ∈ X -> z ∈ Wf a).
 intros.
 apply inter_elim with (1:=H).
 rewrite replf_ax.
 2:red;red;intros;apply Fmono_morph; trivial.
 exists a; auto with *.
rewrite replf_ax.
2:red;red;intros;apply Wsup_morph; trivial.
destruct inter_wit with (2:=H).
 apply Fmono_morph; trivial.
assert (z ∈ Wf x); auto.
apply Wf_elim in H2.
destruct H2.
exists x0; auto.
apply Fstab.
apply inter_intro.
 intros.
 rewrite replf_ax in H4.
 2:apply morph_is_ext; trivial.
 destruct H4.
 rewrite H5; clear y H5.
 specialize H0 with (1:=H4).
 apply Wf_elim in H0; destruct H0.
 admit.
(* rewrite H3 in H5; apply Wsup_inj in H5.
  rewrite H5; trivial.

  revert H2; apply W_F_mono.
  red; intros; apply power_elim with (1:=Xty _ H1); trivial.

  revert H0; apply W_F_mono.
  red; intros; apply power_elim with (1:=Xty _ H4); trivial.
*)
 exists (F x).
 rewrite replf_ax.
 2:apply morph_is_ext; trivial.
 exists x; auto with *.
Qed.
Hint Resolve Wf_stable.

(* The fixpoint *)

Definition W := Ffix Wf Wdom.

Lemma Wtyp : W ⊆ Wdom.
apply Ffix_inA.
Qed.

Lemma Wi_W : forall o, isOrd o -> TI Wf o ⊆ W.
apply TI_Ffix; auto.
Qed.

Lemma TI_Wf_elim : forall a o,
  isOrd o ->
  a ∈ TI Wf o ->
  exists2 o', lt o' o &
  exists2 x, x ∈ F (TI Wf o') &
  a == Wsup x.
intros.
apply TI_elim in H0; trivial.
2:apply Fmono_morph; trivial.
destruct H0.
apply Wf_elim in H1.
eauto.
Qed.

Lemma Wsup_typ : forall o x,
  isOrd o ->
  x ∈ F (TI Wf o) ->
  Wsup x ∈ TI Wf (osucc o).
intros.
rewrite TI_mono_succ; auto.
apply Wf_intro; trivial.
Qed.
(*
Lemma W_ind : forall (P:set->Prop),
  Proper (eq_set ==> iff) P ->
  (forall o' x, isOrd o' -> x ∈ W_F (TI Wf o') ->
   (forall i, i ∈ A (fst x) -> P (cc_app (snd x) i)) -> P (Wsup x)) ->
  forall a, a ∈ W -> P a.
intros.
unfold W in H1; rewrite Ffix_def in H1; auto.
destruct H1.
revert a H2.
apply isOrd_ind with (2:=H1); intros.
apply TI_Wf_elim in H5; trivial.
destruct H5 as (o',?,(x',?,?)).
rewrite H7; clear a H7.
apply H0 with o'; trivial.
 apply isOrd_inv with y; trivial.

 intros.
 apply H4 with o'; trivial.
 apply cc_prod_elim with (1:=tys _ _ H6); trivial.
Qed.
*)
(* The closure ordinal of W *)
  Definition W_ord := Ffix_ord Wf Wdom.

  Lemma W_o_o : isOrd W_ord.
apply Ffix_o_o; auto.
Qed.
Hint Resolve W_o_o.

  Lemma W_post : forall a,
   a ∈ W ->
   a ∈ TI Wf W_ord.
apply Ffix_post; eauto.
Qed.

  Lemma W_eqn : W == Wf W.
apply Ffix_eqn; eauto.
Qed.

  Lemma Fix_reached : TI F (osucc W_ord) ⊆ TI F W_ord.

(*
Parameter hd : set -> set.
Parameter tl : set -> set -> set.
Parameter hd_eq : forall x, hd (Wsup x) == fst x.

Parameter Wf_eta : forall X x,
  X ⊆ Wdom ->
  x ∈ Wf X ->
  x == Wsup (couple (hd x) (cc_lam (A (hd x)) (tl x))).

  Definition trad := Fix_rec Wf Wdom
    (fun g x => couple (hd x)
       (cc_lam (A (hd x)) (fun i => g (tl x i)))).

  Lemma trad_ok : forall o,
    isOrd o ->
    forall x,
    x ∈ TI Wf o ->
    trad x ∈ TI W_F o.
intros o oo.
apply isOrd_ind with (2:=oo); intros.
unfold trad.
rewrite Fr_eqn with (o:=y); auto.
2:admit.
apply TI_Wf_elim in H2; trivial.
destruct H2 as (o',?,(x',?,?)).
apply TI_intro with o'; auto.
 apply Fmono_morph; apply W_F_mono.

 assert (x ∈ Wf (TI Wf o')).
  rewrite <- TI_mono_succ; auto.
  2:apply isOrd_inv with y; trivial.
  rewrite H4; apply Wsup_typ; trivial.
  apply isOrd_inv with y; trivial.
 apply Wf_eta in H5.
 2:admit.
 apply couple_intro_sigma.
  admit.

  admit.

  apply cc_prod_intro; intros.
   admit.
   admit.
  apply H1; trivial.
  admit.
Qed.

  Lemma trad_inj : forall o,
    isOrd o ->
    forall x y, x ∈ TI Wf o ->
    y ∈ TI Wf o ->
    trad x == trad y -> x == y.
intros o oo.
apply isOrd_ind with (2:=oo); intros.
unfold trad in H4.
rewrite Fr_eqn with (o:=y) in H4; auto.
2:admit.
rewrite Fr_eqn with (o:=y) in H4; auto.
2:admit.
apply couple_injection in H4; destruct H4.
rewrite (Wf_eta (TI Wf y)).
2:admit.
2:admit.
rewrite (Wf_eta (TI Wf y) y0).
2:admit.
2:admit.
apply Wsup_morph.
apply couple_morph; trivial.
apply cc_lam_ext; intros.
 apply Amorph; trivial.

 red; intros.
 generalize (cc_app_morph _ _ H5 _ _ H7).
 rewrite cc_beta_eq; trivial.
 2:admit.
 rewrite cc_beta_eq; trivial.
 2:admit.
 2:rewrite <- H7; rewrite <- H4; trivial.
 apply H1 with (z:=y).
  admit.
  admit.
  admit.
Qed.
*)

End W_theory.