(* Double colimits *)

Require Import HoTT HoTT.HIT.Colimits.

Axiom todo : forall A, A.

(** Note: this definition works well when the vertices of [G1] and [G2] are sets.
    We shall add the assumption that they are separately when needed. *)
Definition graph_prod (G1 G2 : graph) : graph :=
  {| graph0 := G1 * G2 ;
     graph1 := (fun u v => (fst u = fst v) * G2 (snd u) (snd v)  + (snd u = snd v) * G1 (fst u) (fst v))
  |}.

Section HIT_colimit_graph.
(** As an example we define the diagram for the construction of HITS.
    We will probably move this section elsewhere. *)

Inductive coeq_graph_vertex := coeq_graph_source | coeq_graph_target.

Inductive coeq_graph_edge := coeq_graph_edge_l | coeq_graph_edge_r.

Definition coeq_graph : graph :=
  {| graph0 := coeq_graph_vertex ;
     graph1 := (fun u v => match u, v with
                           | coeq_graph_source, coeq_graph_target => coeq_graph_edge
                           | _, _ => Empty
                           end)
  |}.

(* [n] is successor of [m]. *)
Fixpoint is_succ (m n : nat) {struct m} : Type :=
  match m, n with
  | 0, S 0 => Unit
  | m' .+1, n' .+1 => is_succ m' n'
  | _, _ => Empty
  end.

Fixpoint succ_is_succ (m : nat) : is_succ m (S m) :=
  match m with
  | 0 => tt
  | S m' => succ_is_succ m'
  end.

Definition telescope_graph : graph :=
  {| graph0 := nat ;
     graph1 := is_succ
  |}.

Definition hit_graph := graph_prod coeq_graph telescope_graph.

Definition truncated_telescope_graph (n : nat) : graph :=
  {| graph0 := { k : nat & k <= n } ;
     graph1 := (fun i j => is_succ i.1 j.1)
  |}.

End HIT_colimit_graph.

Section HIT_colimit_diagram.

Definition HIT_graph_truncated (n : nat) := graph_prod coeq_graph (truncated_telescope_graph n).

Lemma nat_lt_leq {m n : nat} : m < n -> m <= n.
Proof.
  apply todo.
Defined.

Lemma nat_lt_leqS {m n : nat} : m < n -> S m <= n.
  apply todo.
Defined.

(** This structure expresses an intermediate stage of the construction.
    It contains a truncated version of the entire diagram, and commutativity of the squares. *)
Structure HIT_diagram_truncated (n : nat) := {
  hdt_diagram : diagram (HIT_graph_truncated n) ;
  hdt_left_commute :
    forall (k : nat) (k_leq_n : k < n),
      let v1 := (coeq_graph_source, (k; nat_lt_leq k_leq_n)) in
      let v2 := (coeq_graph_target, (k; nat_lt_leq k_leq_n)) in
      let v3 := (coeq_graph_source, (S k; nat_lt_leqS k_leq_n)) in
      let v4 := (coeq_graph_target, (S k; nat_lt_leqS k_leq_n)) in
      let l_k := hdt_diagram _f (inr (idpath, coeq_graph_edge_l) : HIT_graph_truncated n v1 v2) in
      let l_Sk := hdt_diagram _f (inr (idpath, coeq_graph_edge_l) : HIT_graph_truncated n v3 v4) in
      let up_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v1 v3) in
      let down_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v2 v4) in
      down_k o l_k = l_Sk o up_k ;
  hdt_right_commute :
    forall (k : nat) (k_leq_n : k < n),
      let v1 := (coeq_graph_source, (k; nat_lt_leq k_leq_n)) in
      let v2 := (coeq_graph_target, (k; nat_lt_leq k_leq_n)) in
      let v3 := (coeq_graph_source, (S k; nat_lt_leqS k_leq_n)) in
      let v4 := (coeq_graph_target, (S k; nat_lt_leqS k_leq_n)) in
      let r_k := hdt_diagram _f (inr (idpath, coeq_graph_edge_r) : HIT_graph_truncated n v1 v2) in
      let r_Sk := hdt_diagram _f (inr (idpath, coeq_graph_edge_r) : HIT_graph_truncated n v3 v4) in
      let up_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v1 v3) in
      let down_k := hdt_diagram _f (inl (idpath, (succ_is_succ k)) : HIT_graph_truncated n v2 v4) in
      down_k o r_k = r_Sk o up_k
}.
End HIT_colimit_diagram.


Require Import String.
Require Import NPeano.
Require Import PeanoNat.
Require Import Coq.Strings.Ascii.
Require FMapWeakList.
Require Export Coq.Structures.OrderedTypeEx.
Require Import Lists.List.
Import ListNotations.
Require Import JaSyntax.
Require Import Jafun.

Require Export FMapAVL.
Require Export Coq.Structures.OrderedTypeEx.

Module StrMap := FMapAVL.Make(String_as_OT).

Inductive JFIVarType : Set :=
| JFILoc
| JFIObj.

Inductive JFITermEnvItem : Type :=
| JFIEnvLoc (l : Loc)
| JFIEnvObj (o : Obj).

Definition JFITermEnv : Type := StrMap.t JFITermEnvItem.

Inductive JFITerm : Set :=
| JFITrue
| JFIFalse
| JFIAnd (t1 : JFITerm) (t2 : JFITerm)
| JFIOr (t1 : JFITerm) (t2 : JFITerm)
| JFIExists (type : JFIVarType) (name : string) (t : JFITerm)
| JFIForall (type : JFIVarType) (name : string) (t : JFITerm)
| JFIHoare (t1 : JFITerm) (e : JFExpr) (t2 : JFITerm)
| JFISep (t1 : JFITerm) (t2 : JFITerm)
| JFIWand (t1 : JFITerm) (t2 : JFITerm)
| JFIEq (type : JFIVarType) (var1 : string) (var2 : string)
| JFIPointsTo (loc : string) (obj : string).

Definition JFEval : JFExpr -> Heap -> list Heap -> Heap -> Prop :=
  fun e h0 hs hn => True.

Fixpoint JFIHeapSatisfies (h : Heap) (t : JFITerm) (env : JFITermEnv) : Prop :=
  match t with
    | JFITrue => True
    | JFIFalse => False
    | JFIAnd t1 t2 => JFIHeapSatisfies h t1 env /\ JFIHeapSatisfies h t2 env
    | JFIOr t1 t2 => JFIHeapSatisfies h t1 env \/ JFIHeapSatisfies h t2 env
    | JFIExists JFILoc name term => exists l : Loc,
        let env1 := StrMap.add name (JFIEnvLoc l) env in JFIHeapSatisfies h term env1
    | JFIExists JFIObj name term => True (* TODO *)
    | JFIForall type name term => True (* TODO *)
    | JFIHoare t1 e t2 =>
        forall h0 hs hn, (JFIHeapSatisfies h0 t1 env) -> (JFEval e h0 hs hn) -> (JFIHeapSatisfies hn t2 env)
    | JFISep t1 t2 => True (* TODO *)
    | JFIWand t1 t2 => True (* TODO *)
    | JFIEq JFILoc loc1 loc2 => True (* TODO *)
    | JFIEq JFIObj obj1 obj2 => True (* TODO *)
    | JFIPointsTo loc obj => True (* TODO *)
  end.

Inductive JFIProof : Set := (* TODO *)
| JFIEmpty.

Definition JFIProofValid : JFIProof -> JFITerm -> Prop := (* TODO *)
  fun p t => True.

Theorem JFISoundness : forall p t h, (JFIProofValid p t) -> (JFIHeapSatisfies h t (StrMap.empty JFIQuantifierVar)).
Proof.
admit. (*TODO*)
Admitted.


Require Import Coq.omega.Omega.
(* Laying out labels, and generally coming up with final "machine code" programs *)

Require Import Coq.NArith.NArith.

Require Import Bedrock.Nomega Bedrock.Word Bedrock.IL Bedrock.LabelMap Bedrock.PropX Bedrock.XCAP Bedrock.Memory.

Set Implicit Arguments.

Definition labelsOf' (M : LabelMap.t (assert * block)) (acc : (W * ((label -> option W) * (W -> option block))))
  : (label -> option W) * (W -> option block) :=
  snd (LabelMap.fold (fun k (v : assert * block) p => let (_, bl) := v in let '(w, (labels, prog)) := p in
    (natToWord _ 1 ^+ w,
      ((fun k' => if LabelKey.eq_dec k' k then Some w else labels k'),
        (fun w' => if weq w' w then Some bl else prog w'))))
  M acc).

Definition labelsOf (M : LabelMap.t (assert * block)) : (label -> option W) * (W -> option block) :=
  labelsOf' M (wzero _, (fun _ => None, fun _ => None)).

Lemma lt_trans : forall n m o, (n < o)%N -> m = n -> (m < o)%N.
  congruence.
Qed.

Lemma labelsOf'_inj : forall M l1 l2 w w' labels prog,
  let labels' := fst (labelsOf' M (w', (labels, prog))) in
    labels' l1 = Some w
    -> labels' l2 = Some w
    -> (forall l1' l2' w'', labels l1' = Some w'' -> labels l2' = Some w'' -> l1' = l2')
    -> (forall l w'', labels l = Some w'' -> (wordToNat w'' < wordToNat w')%nat)
    -> (wordToN w' + N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
    -> l1 = l2.
  unfold labelsOf'; simpl; intros.
  rewrite LabelMap.fold_1 in *.
  rewrite LabelMap.cardinal_1 in *.
  generalize dependent prog.
  generalize dependent labels.
  generalize dependent w'.
  induction (LabelMap.elements M); simpl; intuition.
  eauto.
  simpl in *.
  eapply IHl; clear IHl; try (apply H || apply H0); simpl; intuition.
  generalize H3; clear.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  intro; eapply lt_trans; eauto.
  replace (Npos (P_of_succ_nat (length l))) with (1 + N_of_nat (length l))%N in *.
  replace (wordToN (NToWord 32 (1 + wordToN w'))) with (1 + wordToN w')%N.
  ring.
  rewrite NToWord_nat.
  assert (1 + wordToN w' < 4294967296)%N.

  Lemma lt_rearrange : forall n p m k,
    (n + (p + m) < k)%N
    -> (p + n < k)%N.
    intros; nomega.
  Qed.

  eapply lt_rearrange; eauto.

  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  repeat rewrite wordToN_nat.
  rewrite nat_of_N_of_nat.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H1.
  rewrite N_of_minus.
  rewrite N_of_plus.
  rewrite N_of_mult.
  change (N_of_nat 1) with 1%N.
  destruct x.
  change (N_of_nat 0) with 0%N.
  rewrite Nmult_0_l.
  clear.
  nomega.
  elimtype False.
  clear H1.

  Lemma contra : forall x b n,
    (n < b)%nat
    -> (S x * b <= n)%nat
    -> False.
    simpl; intros.
    assert (b <= n)%nat.
    generalize dependent (x * b)%nat.
    intros; omega.
    omega.
  Qed.

  eapply contra; [ | eassumption ].
  generalize H; clear; intro.
  rewrite <- Npow2_nat.
  change 1 with (nat_of_N 1) at 1.
  rewrite <- (nat_of_N_of_nat (wordToNat w')).
  rewrite <- nat_of_Nplus.
  apply Nlt_out.
  rewrite wordToN_nat in H.
  apply H.
  clear.
  apply nat_of_N_eq.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))).
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite nat_of_Nplus.
  simpl.
  autorewrite with N; reflexivity.

  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  elimtype False.
  injection H5; clear H5; intro; subst.
  apply H2 in H4; omega.
  elimtype False.
  injection H4; clear H4; intro; subst.
  apply H2 in H5; omega.
  eauto.

  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  injection H4; clear H4; intro; subst.
  generalize H3; clear; intros.
  apply Nlt_out in H3.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))) in H3.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H3.
  rewrite wordToN_nat in H3.
  autorewrite with N in *.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w'')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  change 4294967296%N with (Npow2 32) in *.
  rewrite Npow2_nat in *.
  eapply contra; [ | eassumption ].
  generalize H3; clear; intro.
  generalize dependent (pow2 32).
  intros; omega.

  apply H2 in H4.
  generalize H3 H4; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  generalize H3; clear; intro.
  apply Nlt_out in H3.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l)))) with (nat_of_P (P_of_succ_nat (length l))) in H3.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H3.
  rewrite wordToN_nat in H3.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (pow2 32).
  intros; omega.
Qed.

Theorem labelsOf_inj : forall M l1 l2 w, fst (labelsOf M) l1 = Some w
  -> fst (labelsOf M) l2 = Some w
  -> (N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> l1 = l2.
  intros; eapply labelsOf'_inj; eauto; simpl; intuition; discriminate.
Qed.

Lemma labelsOf'_agree : forall M l pre bl w' labels prog, LabelMap.MapsTo l (pre, bl) M
  -> (forall l w'', labels l = Some w'' -> (wordToNat w'' < wordToNat w')%nat)
  -> (wordToN w' + N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> exists w, fst (labelsOf' M (w', (labels, prog))) l = Some w
    /\ snd (labelsOf' M (w', (labels, prog))) w = Some bl.
  unfold labelsOf'; simpl; intros.
  rewrite LabelMap.fold_1 in *.
  rewrite LabelMap.cardinal_1 in *.
  apply LabelMap.elements_1 in H.
  generalize dependent prog.
  generalize dependent labels.
  generalize dependent w'.
  generalize (LabelMap.elements_3w M).
  induction 1; simpl; intuition.
  inversion H.

  inversion H; clear H; intros; subst.
  hnf in H5; simpl in H5; intuition; subst.
  destruct x; simpl in *; subst.

  exists w'; intuition.

  Lemma labels_keep : forall k v w ls w' labels prog,
    labels k = Some w
    -> ~SetoidList.InA (@LabelMap.eq_key _) (k, v) ls
    -> fst (snd (List.fold_left
      (fun
        (a : word 32 *
          ((LabelKey.t -> option (word 32)) *
            (word 32 -> option block)))
        (p : LabelMap.key * (assert * block)) =>
        let (_, bl0) := snd p in
          let '(w, (labels0, prog0)) := a in
            (WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
              ^+ w,
              (fun k' : LabelKey.t =>
                if LabelFacts.eq_dec k' (fst p) then Some w else labels0 k',
                  fun w'0 : word 32 =>
                    if weq w'0 w then Some bl0 else prog0 w'0))) ls
      (w', (labels, prog))))
     k = Some w.
    induction ls as [ | [ ? [ ] ] ]; simpl; intuition.
    apply IHls; auto.
    destruct (LabelFacts.eq_dec k k0).
    elimtype False; apply H0.
    hnf in e; subst.
    constructor; hnf; auto.
    auto.
  Qed.

  eapply labels_keep; eauto.
  destruct (LabelFacts.eq_dec k k); auto.
  elimtype False; apply n; reflexivity.

  Lemma prog_keep : forall w bl ls w' labels prog,
    prog w = Some bl
    -> w < w'
    -> (wordToN w' + N_of_nat (length ls) < Npow2 32)%N
    -> snd (snd (List.fold_left
      (fun
        (a : word 32 *
          ((LabelKey.t -> option (word 32)) *
            (word 32 -> option block)))
        (p : LabelMap.key * (assert * block)) =>
        let (_, bl0) := snd p in
          let '(w, (labels0, prog0)) := a in
            (WO~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~0~1
              ^+ w,
              (fun k' : LabelKey.t =>
                if LabelFacts.eq_dec k' (fst p) then Some w else labels0 k',
                  fun w'0 : word 32 =>
                    if weq w'0 w then Some bl0 else prog0 w'0))) ls
      (w', (labels, prog))))
     w = Some bl.
    induction ls as [ | [ ? [ ] ] ]; simpl; intuition.
    apply IHls; auto.
    destruct (weq w w').
    subst.
    elimtype False.
    unfold wlt in H0.
    apply Nlt_not_eq in H0; tauto.
    auto.

    generalize H0 H1; clear; intros.
    change 4294967296%N with (Npow2 32) in *.
    destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
    rewrite <- Npow2_nat in *.
    generalize dependent (Npow2 32); intros.
    apply Nlt_out in H1.
    autorewrite with N in *.
    change (nat_of_N (Npos (P_of_succ_nat (length ls)))) with (nat_of_P (P_of_succ_nat (length ls))) in H1.
    rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H1.
    rewrite wordToN_nat in H1.
    autorewrite with N in *.
    unfold wlt in *.
    unfold wplus, wordBin.
    rewrite NToWord_nat.
    repeat rewrite wordToN_nat in *.
    autorewrite with N in *.
    match goal with
      | [ |- context[wordToNat ?N] ] =>
        match N with
          | _~1 => change (wordToNat N) with 1
        end
    end.
    rewrite H2; clear H2.
    destruct x.
    generalize H0; clear.
    intros; nomega.
    elimtype False.
    clear H0.

    Lemma slow : forall x ln w' n,
      (w' + S ln < n)%nat
      -> (S x * n <= 1 + w')%nat
      -> False.
      simpl; intros.
      generalize dependent (x * n); intros; omega.
    Qed.

    eapply slow; eassumption.

    generalize H1; clear; intros.
    change 4294967296%N with (Npow2 32) in *.
    destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
    rewrite <- Npow2_nat in *.
    generalize dependent (Npow2 32); intros.
    unfold wplus, wordBin.
    rewrite NToWord_nat.
    match goal with
      | [ |- context[wordToN ?N] ] =>
        match N with
          | _~1 => change (wordToN N) with 1%N
        end
    end.
    rewrite nat_of_Nplus.
    change (nat_of_N 1) with 1.
    rewrite wordToN_nat.
    autorewrite with N.
    repeat rewrite wordToN_nat in *.
    autorewrite with N in *.
    rewrite H0; clear H0.
    rewrite N_of_minus.
    rewrite N_of_plus.
    rewrite N_of_mult.
    change (N_of_nat 1) with 1%N.
    apply Nlt_out in H1.
    autorewrite with N in *.
    change (nat_of_N (Npos (P_of_succ_nat (length ls)))) with (nat_of_P (P_of_succ_nat (length ls))) in H1.
    rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H1.
    destruct x.
    change (N_of_nat 0) with 0%N.
    apply Nlt_in.
    autorewrite with N.
    change (nat_of_N 1) with 1.
    change (nat_of_N (0 * N_of_nat (pow2 32))) with 0.
    omega.
    elimtype False.
    eapply contra; [ | eassumption ].
    omega.
  Qed.

  apply prog_keep.
  destruct (weq w' w'); tauto.

  generalize H2; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  apply Nlt_out in H2.
  autorewrite with N in H2.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  unfold wlt, wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat in *.
  rewrite wordToN_nat in *.
  autorewrite with N in *.
  rewrite wordToN_nat in *.
  change (nat_of_N 1) with 1.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0.
  rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  apply Nlt_in.
  autorewrite with N.
  destruct x.
  omega.
  elimtype False.
  eapply slow; eauto.

  generalize H2; clear.
  change 4294967296%N with (Npow2 32).
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  eapply lt_trans; eauto.
  apply nat_of_N_eq.
  autorewrite with N.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))).
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ.
  rewrite wordToN_nat.
  autorewrite with N.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  autorewrite with N.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat; autorewrite with N.
  rewrite H0; clear H0.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  destruct x.
  omega.
  elimtype False.
  eapply slow; eauto.
  rewrite wordToN_nat; autorewrite with N; eauto.

  destruct x as [ ? [ ] ]; simpl in *.
  apply IHNoDupA; auto.
  generalize H2; clear.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  repeat rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H0; clear H0.
  repeat rewrite <- Npow2_nat in *.
  generalize dependent (Npow2 32); intros.
  rewrite N_of_minus.
  rewrite N_of_plus.
  rewrite N_of_mult.
  change (N_of_nat 1) with 1%N.
  apply Nlt_out in H2.
  autorewrite with N in H2.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  autorewrite with N.
  destruct x.
  apply Nlt_in.
  autorewrite with N.
  change (nat_of_N 1) with 1.
  change (nat_of_N (N_of_nat 0 * n))%N with 0.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  omega.

  intros.
  repeat match goal with
           | [ _ : context[if ?E then _ else _] |- _ ] => destruct E
           | [ H : LabelKey.eq _ _ |- _ ] => hnf in H; subst
         end; auto.
  injection H; clear H; intro; subst.
  generalize H2; clear; intros.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  rewrite wordToN_nat in H2.
  autorewrite with N in *.
  unfold wplus, wordBin.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite NToWord_nat.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w'')); intuition.
  rewrite H0; clear H0.
  destruct x.
  omega.
  elimtype False.
  change 4294967296%N with (Npow2 32) in *.
  rewrite Npow2_nat in *.
  eapply contra; [ | eassumption ].
  omega.

  apply H3 in H.
  generalize H H2; clear; intros.
  change 4294967296%N with (Npow2 32) in *.
  unfold wplus, wordBin.
  rewrite NToWord_nat.
  match goal with
    | [ |- context[wordToN ?N] ] =>
      match N with
        | _~1 => change (wordToN N) with 1%N
      end
  end.
  rewrite nat_of_Nplus.
  change (nat_of_N 1) with 1.
  rewrite wordToN_nat.
  autorewrite with N.
  destruct (wordToNat_natToWord 32 (1 + wordToNat w')); intuition.
  rewrite H1; clear H1.
  destruct x.
  omega.
  elimtype False.
  eapply contra; [ | eassumption ].
  generalize H2; clear; intro.
  apply Nlt_out in H2.
  autorewrite with N in *.
  change (nat_of_N (Npos (P_of_succ_nat (length l0)))) with (nat_of_P (P_of_succ_nat (length l0))) in H2.
  rewrite Pnat.nat_of_P_o_P_of_succ_nat_eq_succ in H2.
  rewrite wordToN_nat in H2.
  autorewrite with N in *.
  rewrite Npow2_nat in *.
  generalize dependent (pow2 32).
  intros; omega.
Qed.

Theorem labelsOf_agree : forall M l pre bl, LabelMap.MapsTo l (pre, bl) M
  -> (N_of_nat (LabelMap.cardinal M) < Npow2 32)%N
  -> exists w, fst (labelsOf M) l = Some w
    /\ snd (labelsOf M) w = Some bl.
  intros; eapply labelsOf'_agree; intuition eauto; discriminate.
Qed.

(** * Some default word-size memory accessors *)

Theorem wlt_not_refl : forall n (w : word n), w < w -> False.
  unfold wlt; intros; nomega.
Qed.

Hint Immediate wlt_not_refl.

Lemma use_separated : forall (k : W) q,
  (forall n m, (n < 4)%nat -> (m < 4)%nat -> k ^+ $ q ^+ $ n = k ^+ $ m -> False)
  -> (q < 4)%nat
  -> False.
  intros.
  apply H with 0 q; auto.
  word_eq.
Qed.

Lemma use_separated' : forall (k : W) q,
  (forall n m, (n < 4)%nat -> (m < 4)%nat -> k ^+ $ n = k ^+ $ q ^+ $ m -> False)
  -> (q < 4)%nat
  -> False.
  intros.
  apply H with q 0; auto.
  word_eq.
Qed.

Local Hint Extern 1 False => eapply use_separated; [ eassumption | omega ].
Local Hint Extern 1 False => eapply use_separated'; [ eassumption | omega ].
Local Hint Extern 1 False => match goal with
                               | [ H : forall n m : nat, _ |- _ ] => eapply H; [ | | eassumption ]; omega
                             end.

(** * Finally, we can create settings for testing. *)

Section LittleEndianSettings.
  Variable memHigh : W.
  Variable m : module.

(** NOTE: this is little endian *)
  Definition explode_le (v : W) : B * B * B * B :=
    let dw1 := split1 16 16 v in
    let dw2 := split2 16 16 v in
    let b1 := split1 8 8 dw1 in
    let b2 := split2 8 8 dw1 in
    let b3 := split1 8 8 dw2 in
    let b4 := split2 8 8 dw2 in
    (b1,b2,b3,b4).

  Definition implode_le (bs : B * B * B * B) : W :=
    let '(b1,b2,b3,b4) := bs in
    combine (combine b1 b2) (combine b3 b4).

  Theorem implode_explode_le : forall w,
    implode_le (explode_le w) = w.
  Proof.
    unfold implode_le, explode_le.
    intros. repeat rewrite combine_split. reflexivity.
  Qed.

  Theorem explode_implode_le : forall b,
    explode_le (implode_le b) = b.
  Proof.
    unfold implode_le, explode_le.
    intros. destruct b. destruct p. destruct p.
    repeat (rewrite split1_combine || rewrite split2_combine).
    reflexivity.
  Qed.

  Definition leSettings := {|
    implode := implode_le ;
    explode := explode_le ;
    implode_explode := implode_explode_le ;
    explode_implode := explode_implode_le ;
    Labels := fst (labelsOf (Blocks m))
  |}.

  Hypothesis closed : LabelMap.cardinal (Imports m) = 0.
  Hypothesis notTooBig : (N_of_nat (LabelMap.cardinal (Blocks m)) < Npow2 32)%N.
  Hypothesis ok : moduleOk m.

  Theorem safety : forall mn g pre, LabelMap.find (mn, Global g) (Exports m) = Some pre
    -> forall w, Labels leSettings (mn, Global g) = Some w
      -> forall st, interp (specs m leSettings) (pre (leSettings, st))
        -> safe leSettings (snd (labelsOf (Blocks m))) (w, st).
    intros; eapply safety; intuition eauto.
    apply labelsOf_inj with (Blocks m) w0; auto.
    simpl; eapply labelsOf_agree; eauto.
    apply LabelMap.find_2; eauto.
  Qed.
End LittleEndianSettings.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Set Automatic Coercions Import.
Require Import PredomLiftClassical.
Require Import relations.
Require Import strategy.
Require Import stuff.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*Set Printing Width 65.*)

Section Functional.
Variables A B C : cpoType.
Definition FuncType : Type :=
  forall (T : monadType), (A -=> T B) =-> (T C : cpoType).
End Functional.

Section Purity.
Variables A B C : cpoType.

Definition isPure (F : FuncType A B C) : Prop
  := forall (T T' : monadType) (TRacc : TRelAccType T T'),
    ((IdR (X := A) =R=> TRel TRacc (IdR (X := B))) =R=>
       TRel TRacc (IdR (X := C))) (F T) (F T').
End Purity.

Module Domains : DomainParamsType.
  Parameters DA DB DC : cpoType.
End Domains.

Module Import StrategyTree := StrategyTree (Domains).

Definition STree : cppoType := liftCppoType DInf.
Definition Fold := eta << Roll.
Definition Unfold := eta << Unroll.

Definition Ans := Fold << INL _ _.
Definition Que := exp_fun (Fold << INR _ _).

Definition fun2tree (F : FuncType DA DB DC) := F (Cont STree) Que Ans.

Definition Op1 (A B C : cpoType) (f : A =-> B -=> C) (g : A =-> B) : A =-> C := uncurry f << <| Id, g |> .

Lemma Op1_simpl A B C f g a : @Op1 A B C f g a =-= f a (g a).
Proof.
by [].
Qed.

Definition phi (T : monadType) : (DC + DA * (DB -=> DInf _BOT)) =-> (DInf _BOT -=> ((DA -=> T DB) -=> T DC)) -=> ((DA -=> T DB) -=> T DC)
  := [| exp_fun (
          uncurry (@const _ _ (exp_fun (@tval T _ << FST _ _)))
          << SWAP),
        exp_fun (exp_fun (
          Op1
            (@tbind T _ _ <<
              Op1 (SND _ _) (FST _ _ << FST _ _ << FST _ _))
            (exp_fun (
              (Op1
                (uncurry (SND _ _ << FST _ _))
                (uncurry (@const _ _ (SND _ _)) << SWAP)) <<
              <| FST _ _, uncurry (SND _ _ << FST _ _ << FST _ _) |>)
            )))
      |].

Definition phi_inl_simpl (T : monadType) c f h :
  phi T (inl _ c) f h =-= tval T _ c.
by rewrite SUM_fun_simpl.
Qed.

Definition phi_inr_simpl (T : monadType) a k f h :
  phi T (inr _ (a, k)) f h =-= @tbind T _ _ (h a) (Fcont_app ((f : fcont _ _) << k) h).
rewrite /=. rewrite /phi /=.
rewrite SUM_fun_simpl /=.
apply: fmon_eq_compat; first by reflexivity.
by apply: fmon_eq_intro.
Qed.

Definition G (T : monadType) : (DInf _BOT -=> ((DA -=> T DB) -=> T DC)) =->  DInf _BOT -=> ((DA -=> T DB) -=> T DC)
  := CURRY (uncurry (mu1 (phi T << Unroll)) << SWAP).

Lemma G_PBot_simpl (T : monadType) f h : @G T f PBot h =-= PBot.
Proof.
rewrite /=. by rewrite mu1axiom1.
Qed.

Lemma G_Val_simpl (T : monadType) f h d : @G T f (Val d) h =-= phi T (Unroll d) f h.
Proof.
rewrite /=. by rewrite mu1axiom2.
Qed.

Definition tree2funT (T : monadType)
  : exp_cppoType (DInf _BOT) (exp_cppoType (DA -=> T DB) (T DC))
  := fixp (G T).

Lemma tree2funT_eq (T : monadType) :
  tree2funT T =-= G T (@tree2funT T).
Proof.
by apply: fixp_eq.
Qed.

Lemma tree2funT_PBot_simpl (T : monadType) :
  tree2funT T PBot =-= PBot.
Proof.
rewrite /tree2funT fixp_eq. apply: fcont_eq_intro => h.
change (G T (fixp (G T)) PBot h =-= PBot).
by apply: G_PBot_simpl.
Qed.

Lemma tree2funT_Ans_simpl (T : monadType) c h :
  tree2funT T (Ans c) h =-= tval T _ c.
Proof.
rewrite tree2funT_eq /Ans.
rewrite G_Val_simpl.
change (phi T ((Unroll << Roll) (inl _ c)) (tree2funT T) h =-= tval T DC c).
rewrite UR_id. by apply: phi_inl_simpl.
Qed.

Lemma tree2funT_Que_simpl (T : monadType) a k h :
  tree2funT T (Que a k) h =-= tbind T _ _ (h a) (Fcont_app ((tree2funT T : fcont _ _) << k) h).
Proof.
have H := fcont_eq_compat
  (fcont_eq_compat (tree2funT_eq T) (Oeq_refl (Que a k)))
  (Oeq_refl h).
apply (Oeq_trans H).
rewrite G_Val_simpl.
change (phi T ((Unroll << Roll) (inr _ (a, k))) (tree2funT T) h =-= tbind T _ _ (h a) (Fcont_app ((tree2funT T : fcont _ _) << k) h)).
rewrite UR_id. by apply: phi_inr_simpl.
Qed.

Definition treeQuePBot (a : DA) : STree := eta (Roll (inr _ (a, const _ PBot))).

Lemma tree2funT_State_treeQuePBot S a :
  tree2funT (State S) (treeQuePBot a) =-= PBot.
Proof.
rewrite tree2funT_eq /=.
rewrite mu1axiom2.
apply: fmon_eq_intro => h /=.
change ((phi (State S) << (Unroll << Roll)) (inr DC (a, const DB PBot)) (tree2funT _) h =-= PBot).
rewrite UR_id comp_idR.
rewrite phi_inr_simpl.
apply: (Oeq_trans _ (@bindState_bot S _ _ (h a))).
rewrite /bindState. apply: fcont_eq_compat; first by apply: Oeq_refl.
apply: fmon_eq_intro => b.
change (tree2funT (State S) PBot h =-= PBot).
by rewrite tree2funT_PBot_simpl.
Qed.

Definition tree2fun (t : STree) : FuncType DA DB DC.
move => T. by apply: (tree2funT T t).
Defined.

Lemma tree2fun_simpl (t : STree) (T : monadType) :
  @tree2fun t T = tree2funT _ t.
Proof.
by rewrite /tree2fun.
Qed.

(* TODO: move to PredomCore.v *)
Lemma Fcont_app_simpl X Y Z (f : X =-> Y -=> Z) x y : Fcont_app f y x = f x y.
Proof.
by [].
Qed.

Lemma tree2fun_pure (t : STree) : isPure (@tree2fun t).
Proof.
rewrite /isPure. move => T T' TR.
rewrite !tree2fun_simpl.
pose Q : Rel ((STree : cpoType) =-> (DA -=> T DB) -=> T DC) ((STree : cpoType) =-> (DA -=> T' DB) -=> T' DC)
  := fun f f' (*: STree =-> (DA -=> T DB)-=> T DC)*) =>
    forall t, ((@IdR _ =R=>  (TRel TR) DB DB (@IdR _)) =R=>  (TRel TR) DC DC (@IdR _)) (f t) (f' t).
have admQ : admissibleR Q.
  move => c c' H. rewrite /Q => t0.
  apply: admissibleArrR => /=.
  - apply (@Adm _ _ TR). by apply (admissibleIdR).
  - by move => n; apply: H.
suff : Q (tree2funT T) (tree2funT T'); first by [].
apply: {t} fixpR_ind; first by [].
- move => t /=. move => h h' _ /=. by apply: (Str TR).
- move => f f' Hff'. move => t.
  case: (axiom_liftCpo_dec t).
  + move => Heq.
    have Heq1 := (@fcont_eq_compat _ _ (G T f) (G T f) (Oeq_refl _) _ _ (Oeq_sym Heq)).
    have Heq1' := (@fcont_eq_compat _ _ (G T' f') (G T' f') (Oeq_refl _) _ _ (Oeq_sym Heq)).
    apply (axiom_Rel_compat Heq1 Heq1') => {Heq1 Heq1'}.
    move => h h' Hhh'.
    apply: (axiom_Rel_compat (Oeq_sym (@G_PBot_simpl _ f h)) (Oeq_sym (@G_PBot_simpl _ f' h'))).
    by apply: (Str TR).
  + elim => d Hd.
    have Heq1 := (@fcont_eq_compat _ _ (G T f) (G T f) (Oeq_refl _) _ _ (Oeq_sym Hd)).
    have Heq1' := (@fcont_eq_compat _ _ (G T' f') (G T' f') (Oeq_refl _) _ _ (Oeq_sym Hd)).
    apply (axiom_Rel_compat Heq1 Heq1') => {Heq1 Heq1'}.
    move => h h' Hhh'.
    apply: (axiom_Rel_compat (Oeq_sym (@G_Val_simpl _ f h d)) (Oeq_sym (@G_Val_simpl _ f' h' d))).
    elim: (Unroll d) => x.
    * apply: (axiom_Rel_compat (Oeq_sym (@phi_inl_simpl _ _ f h)) (Oeq_sym (@phi_inl_simpl _ _ f' h'))).
      elim: (Acc TR) => [Hval _]. by intuition.
    * elim: x => a k.
      apply: (axiom_Rel_compat (Oeq_sym (@phi_inr_simpl _ a k f h)) (Oeq_sym (@phi_inr_simpl _ a k f' h'))).
      apply: (proj2 (Acc TR)); first by apply Hhh'.
      move => b b' Hbb' /=.
      have Htmp : f' (k b) h' =-= f' (k b') h'.
        apply: fcont_eq_compat; last by [].
        apply: fmon_eq_compat; first by apply Oeq_refl.
        by apply: fmon_eq_compat; first by apply Oeq_refl.
      apply (axiom_Rel_compat (Oeq_refl _) Htmp) => {Htmp}.
      by apply: Hff'.
Qed.

Lemma kleisli_bot_simpl D1 D2 :
  kleisli (PBot : exp_cppoType D1 (liftCppoType D2)) =-=
  (PBot : exp_cppoType (D1 _BOT) (liftCppoType D2)).
Proof.
apply: fcont_eq_intro => x /=.
split => /=; last by apply: leastP.
apply: DLless_cond => d2 H.
elim: (kleisliValVal H ) => {H} /= d1 [_ Hfalse].
by elim: (PBot_incon_eq (Oeq_sym Hfalse)).
Qed.

Theorem tree2fun2tree : forall t, fun2tree (tree2fun t) =-= t.
Proof.
move => t. rewrite /fun2tree tree2fun_simpl.
suff : Fcont_app (Fcont_app (tree2funT (Cont STree)) Que) Ans =-= Id.
  move => H.
  have H1 := (fcont_eq_compat H (Oeq_refl t)) => {H}.
  by rewrite !Fcont_app_simpl in H1.
clear t.
rewrite -kleisli_unit id_min FIXP_simpl.
rewrite /tree2funT.
pose T := Cont STree.
pose Q : Rel
  (DInf _BOT -=> ((DA -=> T DB) -=> T DC))
  (DInf -=> DInf _BOT)
  := fun f f' => Fcont_app (Fcont_app f Que) Ans =-= kleisli f'.
have admQ : admissibleR Q.
  move => c c' H. rewrite /Q.
  change (Fcont_app (Fcont_app (lub c) Que) Ans =-= KLEISLI (lub c')).
  rewrite lub_comp_eq. apply: fcont_eq_intro => x /=.
  apply: lub_eq_compat. apply: fmon_eq_intro => n /=.
  rewrite /Q in H. by rewrite -(H n).
suff : Q (fixp (G T)) (fixp delta); first by [].
apply: fixpR_ind; first by [].
- rewrite /Q. apply: fcont_eq_intro => x /=.
  apply: Oeq_sym. by rewrite kleisli_bot_simpl.
- move => f f' Hff'.
  rewrite /Q. setoid_rewrite delta_simpl. rewrite /=.
  apply: fcont_eq_intro => t /=.
  case: (axiom_liftCpo_dec t). (* non-constructive step! *)
  + move => Heq. rewrite Heq => {Heq t}.
    rewrite mu1axiom1. by rewrite kleisli_bot.
  + elim => d Hd. rewrite Hd => {Hd t}.
    rewrite mu1axiom2 kleisliVal /=.
    case: (Unroll d) => [c | [a k]] /=.
    * by rewrite !SUM_fun_simpl /= kleisliVal.
    * rewrite (fcont_eq_compat (phi_inr_simpl a k f Que) (Oeq_refl Ans)).
      rewrite SUM_fun_simplx. rewrite bindCont_simpl /=.
      rewrite !kleisliVal /=. apply: Val_eq_compat.
      apply: fcont_eq_compat; first by apply: Oeq_refl.
      change
        (INR DC _ (a, Fcont_app (Fcont_app ((f : fcont _ _) << k) Que) Ans) =-=
         INR DC _ (a, kleisli f' << k)).
      apply: fcont_eq_compat => //.
      apply: pair_cpo_eq_compat => //.
      rewrite /Q in Hff'. rewrite -Hff'.
      by apply: fcont_eq_intro => n.
Qed.

Section conversion.
Variable DS : cppoType.
Variable q : DA =-> (DB -=> DS) -=> (DS (*: cpoType*)).
Variable a : DC =-> (DS : cpoType).

Definition conv := Fcont_app (Fcont_app (@tree2funT (Cont DS)) q) a.

Lemma conv_PBot_simpl : conv PBot =-= PBot.
Proof.
rewrite /conv.
change (tree2funT (Cont DS) PBot q a =-= PBot).
by rewrite tree2funT_PBot_simpl.
Qed.

Lemma conv_Ans_simpl c : conv (Ans c) =-= a c.
Proof.
rewrite /conv.
change (tree2funT (Cont DS) (Ans c) q a =-= a c).
by rewrite tree2funT_Ans_simpl.
Qed.

Lemma conv_Que_simpl a1 h h' : ((@IdR _) =R=>  Gr (conv)) h h' -> conv (Que a1 h) =-= q a1 h'.
Proof.
move => Hhh'.
rewrite /conv.
change (tree2funT (Cont DS) (Que a1 h) q a =-= q a1 h').
rewrite tree2funT_Que_simpl.
rewrite bindCont_simpl.
apply: (fcont_eq_compat (Oeq_refl _)).
apply: fcont_eq_intro => b.
have H := Hhh' b b (IdR_refl _) => {Hhh'}.
rewrite /Gr /conv in H.
rewrite -H /=. by apply: Oeq_refl.
Qed.

Definition TRacc1 : TRelAccType (Cont STree) (Cont DS).
exists
  (fun (X X' : cpoType) (R : Rel X X') => fun (H : Cont STree X) (H' : Cont DS X') =>
    forall h h', (R =R=> Gr conv) h h' -> Gr conv (H h) (H' h')).
- split.
  + intros; simpl; intuition.
  + move => X X' Y Y' Q R f f' t t' H H0.
    move => h h' Hhh'. apply: H => x x' Hxx' /=.
    by eapply H0; eauto.
- move => X X' R Hadm. move => c c' /= H.
  move => h h' Hhh'. rewrite /Gr.
  rewrite lub_comp_eq. apply: lub_eq_compat.
  apply: fmon_eq_intro => n. by apply: H.
- move => X X' R /=. move => _ _ _.
  rewrite /Gr. by rewrite conv_PBot_simpl.
Defined.
End conversion.

Lemma fun2tree2fun_Cont (S : cppoType) (F : FuncType DA DB DC) (Hpure : isPure F) :
  @tree2funT (Cont S) (fun2tree F) =-= F (Cont S).
Proof.
rewrite /tree2funT /=.
apply: fcont_eq_intro => q.
apply: fcont_eq_intro => a.
suff H : Gr (conv q a) (F (Cont STree) Que Ans) (F (Cont S) q a).
  rewrite /Gr in H. rewrite -H. rewrite /conv /=. by apply: lub_eq_compat.
rewrite /isPure in Hpure.
have H := Hpure _ _ (TRacc1 q a) => {Hpure}.
apply: H.
- move => a1 a1' H.
  have Eq : q a1 =-= q a1'
    by apply: (fcont_eq_compat (Oeq_refl _)).
  move => h h' Hhh'. rewrite /Gr.
  have Eqh' : q a1 h' =-= q a1' h'
    by apply: (fcont_eq_compat Eq (Oeq_refl _)).
  apply: (Oeq_trans _ Eqh') => {Eq Eqh'}.
  by apply: conv_Que_simpl.
- move => c c' Hcc'. rewrite /Gr -Hcc'.
  by apply: conv_Ans_simpl.
Qed.

Definition Phi (T : monadType) (F : (DA -=> Cont (T DC) DB) =-> Cont (T DC) DC) : (DA -=> T DB) =-> T DC
  := Fcont_app F (@tval T DC) << CCOMP _ _ _ << <| const _ (@tbind T DB DC) , Id |>.

Definition PHI (T : monadType)
  : ((DA -=> Cont (T DC) DB) -=> Cont (T DC) DC) =-> (DA -=> T DB) -=> T DC
  := exp_fun (EV _ _ <<
     <| EV _ _ <<
        <|
         FST _ _,
         CCOMP _ _ _ << <| const _ (@tbind T DB DC), SND _ _ |>
        |>,
        const _ (@tval T DC)
     |>).

Lemma Phi_simpl (T : monadType) F g :
  Phi F g =-= F (tbind T _ _ << g) (tval T _).
Proof.
rewrite /=.
apply: fcont_eq_compat; last by apply: Oeq_refl.
by apply: fcont_eq_intro => a.
Qed.

Lemma PHI_simpl (T : monadType) F g :
  @PHI T F g =-= F (tbind T _ _ << g) (tval T _).
Proof.
by [].
Qed.

Definition TRacc2 (T : monadType) : TRelAccType (Cont (T DC)) T.
exists
  (fun (X X' : cpoType) (R : Rel X X') => fun (H : Cont (T DC) X) (H' : T X') =>
    forall h h', (R =R=> @IdR (T DC)) h h' ->
      (@IdR (T DC) (H h) (tbind T _ _ H' h'))).
- split.
  + intros. rewrite /IdR /=. rewrite taxiom0. by firstorder.
  + move => X X' Y Y' Q R f f' t t' H H0.
    move => h h' Hhh'. rewrite taxiom2 /=. apply: H => x x' Hxx' /=. by apply: H0.
- move => X X' R Hadm. move => c c' /= H.
  move => h h' Hhh'. rewrite lub_comp_eq. apply: lub_eq_compat.
  apply: fmon_eq_intro => n /=. by apply: H.
- move => X X' R /=. move => h h' _. by rewrite taxiom3.
Defined.

Lemma PHI_Cont (T : monadType) (F : FuncType DA DB DC) (Hpure : isPure F) :
  PHI T (F (Cont (T DC))) =-= F T.
Proof.
apply: fcont_eq_intro => g. rewrite PHI_simpl.
rewrite -(taxiom1 (F T g)).
have H := Hpure _ _ (TRacc2 T) => {Hpure}.
apply: H.
- move => a a' Haa'.
  have Eg : g a =-= g a' by apply: (fcont_eq_compat (Oeq_refl _)).
  move => h h' Hhh' /=.
  have Eh : h =-= h'
    by apply: fcont_eq_intro => b; apply: (Hhh' _ _ (Oeq_refl _)).
  by rewrite -Eg -Eh.
- move => c c' H. by rewrite H.
Qed.

Theorem fun2tree2fun (F : FuncType DA DB DC) (Hpure : isPure F) :
  forall (T : monadType), @tree2fun (fun2tree F) T =-= @F T.
Proof.
move => T.
rewrite -[in X in _ =-= X](@PHI_Cont _ F) => //.
rewrite -[in X in _ =-= X](@fun2tree2fun_Cont _ F) => //.
rewrite [in X in _ =-= X](@PHI_Cont _ (tree2fun (fun2tree F))) => //.
by apply: tree2fun_pure.
Qed.


From Undecidability.L.Computability Require Export Fixpoints Decidability Seval.
From Undecidability.L.Functions Require Export Proc Encoding.
Import ARS.ARSNotations L_Notations.
(* * Scott's Theorem *)

Theorem Scott (M : term -> Prop) : M <=1 closed ->
  (forall s t, M s -> closed t -> t == s -> M t) ->
  (exists t1, closed t1 /\ M t1) -> (exists t2, closed t2 /\ ~ M t2) ->
  ~ ldec M.
Proof.
  intros M_cl M_equiv [s1 [cls_s1 Ms1]] [s2 [cls_s2 nMs2]] [u [[cls_u lam_u] Hu]].
  pose (x := lam(u #0 (lam s2) (lam s1) I)).
  destruct (SecondFixedPoint (s := x)) as [t [cls_t H]]. subst x. Lproc.
  eapply eqTrans with (s := u (enc t) (lam s2) (lam s1) I) in H.
  destruct (Hu t) as [[]  [R C]].
  - eapply nMs2, M_equiv; eauto.
    rewrite <- H,R. symmetry. Lrewrite. LsimplRed.
  - eapply C, M_equiv; eauto.
    rewrite <- H,R. Lrewrite. LsimplRed.
  -symmetry. etransitivity. apply eqStep. apply step_Lproc;Lproc. simpl. now rewrite cls_u,cls_s1,cls_s2.
Qed.

(* * Applications of Scott's Theorem *)

Goal ~ ldec (fun x => closed x /\ converges x).
Proof.
  eapply Scott.
  - tauto.
  - intros s t [cls_s [x [Hx lx]]] cls_t t_e_s; split.
    + eassumption.
    + exists x;split;[|Lproc]. now rewrite t_e_s.
  - exists I. repeat split. exists I;split.  reflexivity. Lproc.
  - exists Omega. repeat split. intros [_ [x [Hx lx]]]. inv lx. eapply Omega_diverges. exact Hx.
Qed.

Lemma I_neq_Omega : ~ I == Omega.
Proof.
  intros H. eapply Omega_diverges. rewrite <- H. unfold I. cbv; reflexivity.
Qed.

Lemma C27 : forall t, closed t -> ~ ldec (fun x => closed x /\ x == t).
Proof.
  intros t cls_t H. cut (ldec (fun x : term => closed x /\ x == t)).
  eapply Scott.
  - tauto.
  - intros s t0 [cls_s H0] cls_t0 H1. split. assumption. rewrite H1. assumption.
  - exists t. repeat split. assumption. assumption. reflexivity.
  - destruct H. destruct H. destruct (H0 I) as [[] [? ?]].
    +destruct H2 as [? ?]. exists Omega. split. intros k r. simpl. reflexivity. intros [_ C]. eapply I_neq_Omega. rewrite C. auto.
    +exists I. split. Lproc. auto.
  - eassumption.
Qed.

Lemma C27_proc : forall t, proc t -> ~ ldec (fun x => x == t).
Proof.
  intros t proc_t H. eapply C27; eauto using ldec_conj, ldec_closed; Lproc.
Qed.

Lemma Eq_ldec : ~ ldec (fun x => exists (s t : term), x = enc (s t) /\ s == t).
Proof.
  intros [u [[cls_u lam_u] Hu]].
  pose (t := I).
  eapply (C27_proc (t := t)). Lproc.
  pose (v := (lam(u ((ext (enc (X:=term))) ((ext app) #0 (ext t)))))).
  exists v. split. subst v;Lproc.
  intros s. destruct (Hu (ext (s t))) as [b [eq C]].
  exists b. split.
  +subst v. Lsimpl. eassumption.
  +destruct b.
   *destruct C as [? [? [eq' ?]]]. apply inj_enc in eq'. congruence.
   *intros eq'. apply C. now repeat eexists.
Qed.