Require Import Unicode.Utf8 ssreflect.
Require Import GuardedLF.
Require Import Logic.FunctionalExtensionality.

(* This is a relatively simple theory of typed CBPV λ-calculus with
recursive types; every type is made to be an algebra for the later
modality. *)

Axiom mode : ◻.
Axiom pos : mode.
Axiom neg : mode.

Axiom tp : mode → ◻.
Axiom tm : tp pos → Type.

Axiom bool : tp pos.
Axiom one : tp pos.
Axiom arr : tp pos → tp neg → tp neg.
Axiom prod : ∀ {μ}, tp μ → tp μ → tp μ.
Axiom coprod : tp pos → tp pos → tp pos.
Axiom rec : (tp neg → tp neg) → tp neg.
Axiom F : tp pos → tp neg.
Axiom U : tp neg → tp pos.

Notation "[ A ]" := (tm A).
Notation "⟪ A ⟫" := [ U A ].

Axiom bind : ∀ {A B}, [U (F A)] → ([A] → [U B]) → [U B].
Axiom ret : ∀ {A}, [A] → [U (F A)].
Notation "ret: e" := (ret e) (at level 100).

Infix "⇒" := arr (right associativity, at level 60).
Infix "&" := (@prod neg) (right associativity, at level 60).
Infix "⊗" := (@prod pos) (right associativity, at level 60).
Infix "⊕" := coprod (right associativity, at level 60).
Notation "rec: X ; B" := (rec (λ X, B)) (at level 100).

Axiom θ : ∀ {A}, ▶ [U A] → [U A].
Definition δ {A} (e : [U A]) : [U A] := θ (next e).

Notation "θ: e" := (θ e) (at level 100).
Notation "δ: e" := (δ e) (at level 100).
Notation "θ[ A ]" := (@θ A).
Notation "δ[ A ]" := (@δ A).

Axiom def_arr : ∀ {A B}, ([A] → [U B]) ≅ [U (A ⇒ B)].
Axiom def_prod_neg : ∀ {A B}, (product ⟪A⟫ ⟪B⟫) ≅ ⟪ A & B ⟫.
Axiom def_prod_pos : ∀ {A B}, (product [A] [B]) ≅ [A ⊗ B].
Axiom def_coprod : ∀ {A B}, (sum [A] [B]) ≅ [A ⊕ B].
Axiom def_rec : ∀ {H}, ▶ [U (H (rec H))] ≅ [U (rec H)].
Axiom def_one : True ≅ [one].

Notation lam := (intro def_arr).
Notation app := (elim def_arr).
Notation "lam: x ; e" := (lam (λ x, e)) (at level 100).
Infix "@" := app (left associativity, at level 50).

Notation fold := (intro def_rec).
Notation unfold := (elim def_rec).
Notation "fold: e" := (fold e) (at level 100).
Notation "unfold: e" := (unfold e) (at level 100).

Notation "pair-" := (intro def_prod_neg).
Notation "split-" := (elim def_prod_neg).
Notation "⟨ e , e' ⟩-" := (pair- (Build_product e  e')).
Notation "fst-: e" := (π1 (split- e)) (at level 100).
Notation "snd-: e" := (π2 (split- e)) (at level 100).

Notation "pair+" := (intro def_prod_pos).
Notation "split+" := (elim def_prod_pos).
Notation "⟨ e , e' ⟩+" := (pair+ (Build_product e  e')).
Notation "fst+: e" := (π1 (split+ e)) (at level 100).
Notation "snd+: e" := (π2 (split+ e)) (at level 100).

Notation "bind: x ← e ; k" := (bind e (λ x, k)) (at level 100).

Definition θ_arr_rhs {A B} (e : ▶ [U (A ⇒ B)]) : [U (A ⇒ B)] :=
  lam: x;
  θ: (λ f, f @ x) <$> e.

Definition θ_prod_rhs {A B} (e : ▶ [U (A & B)]) : [U (A & B)] :=
  ⟨ θ: (λ x, fst-: x) <$> e, θ: (λ x, snd-: x) <$> e ⟩-.

Definition θ_rec_rhs {H} (e : ▶ [U (rec H)]) : [U (rec H)] :=
  fold: (θ ∘ unfold) <$> e.

Axiom bind_ret : ∀ {A B} {x : [A]} {k : [A] → [U B]}, bind (ret x) k = k x.
Axiom θ_bind : ∀ {A B x k}, bind (θ[F A] x) k = θ[B] ((λ z, bind z k) <$> x).
Axiom θ_arr : ∀ {A B}, θ[A ⇒ B] = θ_arr_rhs.
Axiom θ_prod : ∀ {A B}, θ[A & B] = θ_prod_rhs.
Axiom θ_rec : ∀ {F}, θ[rec F] = θ_rec_rhs.

Axiom tt : [bool].
Axiom ff : [bool].
Axiom case : ∀ {A}, [bool] → [U A] → [U A] → [U A].

Notation "case: b 'with' 'tt' ⇒ t | 'ff' ⇒ f 'end'" := (case b t f) (at level 100).
Notation "case[ A ]: b 'with' 'tt' ⇒ t | 'ff' ⇒ f 'end'" := (@case A b t f) (at level 100).

Axiom case_tt : ∀ {A} t f, case[A]: tt with tt ⇒ t | ff ⇒ f end = t.
Axiom case_ff : ∀ {A} t f, case[A]: tt with tt ⇒ t | ff ⇒ f end = f.

Definition bits := rec: X; F (bool ⊗ U X).
Definition cons : ⟪ bool ⇒ U bits ⇒ bits ⟫ :=
  lam: x; lam: xs;
  fold: next: ret: ⟨x,xs⟩+.

Definition head : ⟪ U bits ⇒ F bool ⟫ :=
  lam: xs;
  bind: u ← θ: unfold: xs;
  ret: fst+: u.

Definition tail : ⟪ U bits ⇒ bits ⟫ :=
  lam: xs;
  bind: u ← θ: unfold: xs;
  snd+: u.

Ltac crush :=
  repeat
    (autorewrite with crush;
     autounfold with crush;
     simpl).

Hint Unfold θ_prod_rhs θ_rec_rhs θ_arr_rhs Later.map δ : crush.
Hint Rewrite @beta @θ_prod @θ_arr @θ_rec @Later.ap_compute @bind_ret @θ_bind : crush.

Goal ∀ x xs, head @ (cons @ x @ xs) = δ: ret x.
  move=> x xs.
  rewrite /head /cons.
  by crush.
Qed.

Goal ∀ x xs, tail @ (tail @ (cons @ x @ (cons @ x @ xs))) = δ: δ: xs.
  move=> x xs.
  rewrite /bits /tail /cons.
  by crush.
Qed.

Definition zeroes : ⟪ bits ⟫ :=
  fix: xs; cons @ ff @ θ: xs.

Lemma head_zeroes : head @ zeroes = δ: ret: ff.
  rewrite /head /zeroes /cons loeb_unfold.
  by crush.
Qed.

Lemma tail_cons : ∀ x xs, tail @ (cons @ x @ xs) = δ: xs.
  move=> x xs.
  rewrite /tail /cons /bits.
  by crush.
Qed.

Lemma tail_zeroes : tail @ zeroes = δ: δ: zeroes.
  rewrite /zeroes.
  rewrite {1} loeb_unfold.
  by rewrite tail_cons.
Qed.

Lemma tail_strict : ∀ xs, (tail @ δ: xs) = δ: tail @ xs.
  move=> xs.
  rewrite /tail /bits.
  by crush.
Qed.

Lemma head_strict : ∀ xs, (head @ δ: xs) = δ: head @ xs.
  move=> xs.
  rewrite /head /bits.
  by crush.
Qed.

Goal head @ (tail @ (tail @ zeroes)) = δ: δ: δ: δ: δ: ret ff.
  do 2 rewrite tail_zeroes ? tail_strict.
  rewrite ? head_strict.
  by rewrite head_zeroes.
Qed.

Definition bot {A} : ⟪ A ⟫ := fix: x; θ: x.

Goal 1 ⊩ (δ: δ: ret: tt) = bot.
  move=> z.
  rewrite /bot loeb_unfold -/bot /δ.
  f_equal.
  apply: Later.from_eq; move: z.
  apply: Later.pmap => z.
  rewrite /bot loeb_unfold -/bot /δ.
  f_equal.
  apply: Later.from_eq; move: z.
  by apply: Later.pmap.
Qed.

Fixpoint rep {A} (n : nat) (f : A → A) (x : A) : A :=
  match n with
  | 0 => x
  | S n => f (rep n f x)
  end.

Definition conat : tp neg := rec: X; F (one ⊕ U X).

Notation ax := (intro def_one I).

Definition ze : ⟪conat⟫ :=
  fold: next: ret: intro def_coprod (inl ax).

Definition su (n : ⟪conat⟫) : ⟪conat⟫ :=
  fold: next: ret: intro def_coprod (inr n).

Inductive wp_F {A : tp pos} (Φ : [A] → Prop) (H : ⟪F A⟫ → Prop) : ⟪F A⟫ → Prop :=
| wp_ret : ∀ e v, e = ret v → Φ v → wp_F Φ H e
| wp_step : ∀ e e', (e = δ: e') → H e' → wp_F Φ H e.

(* Weakest precondition *)
Definition wp {A : tp pos} (Φ : [A] → Prop) : ⟪F A⟫ → Prop :=
  fix: wp'; wp_F Φ (λ e, ⟨▷⟩ (wp' ⊛ next: e)).

Lemma wp_unfold {A : tp pos} {Φ : [A] → Prop} {e : ⟪F A⟫} : wp Φ e = wp_F Φ (fun e => ▷ (wp Φ e)) e.
Proof.
  rewrite /wp {1} loeb_unfold /Later.map.
  do ? f_equal; extensionality e'; f_equal.
  by rewrite Later.ap_compute Later.dlater_compute.
Qed.

Goal wp (λ v, v = tt) (head @ (cons @ tt @ zeroes)).
  rewrite wp_unfold; apply: wp_step.
  - by rewrite /head /cons; crush.
  - apply: pnext.
    rewrite wp_unfold.
    by apply: wp_ret.
Qed.

(* Only partial correctness ;-) *)
Goal wp (λ v, v = tt) bot.
  apply: ploeb => L.
  rewrite wp_unfold; apply: wp_step; eauto.
  by rewrite /bot {1} loeb_unfold.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require bedrock2.Syntax.
Require bedrock2.Semantics.
Require bedrock2.WeakestPrecondition.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Array bedrock2.Scalars.
Require Import coqutil.Map.Interface.
Require Import coqutil.Word.Interface.
Require Import Crypto.Language.API.
Import ListNotations. Local Open Scope Z_scope.
Import API.Compilers.

(*** This file contains the setup for the bedrock2 backend; the type
  system, the parameter class, and some shorthand notations. ***)

(* Notations for commonly-used types in the fiat-crypto language *)
Module Import Notations.
  Notation base_range := (base.type.type_base base.type.zrange).
  Notation base_nat := (base.type.type_base base.type.nat).
  Notation base_Z := (base.type.type_base base.type.Z).
  Notation base_listZ := (base.type.list base_Z).
  Notation base_range2 := (base.type.prod base_range base_range).
  Notation base_ZZ := (base.type.prod base_Z base_Z).

  Notation type_range := (type.base base_range).
  Notation type_nat := (type.base base_nat).
  Notation type_Z := (type.base base_Z).
  Notation type_listZ := (type.base base_listZ).
  Notation type_range2 := (type.base base_range2).
  Notation type_ZZ := (type.base base_ZZ).
End Notations.

Class parameters
  {width: Z} {BW: Bitwidth.Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}
  {locals: map.map String.string word}
  {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}
  {ext_spec: bedrock2.Semantics.ExtSpec}
  {varname_gen : nat -> String.string}
  {error : Syntax.expr.expr} := parameters_sentinel : unit.

Section WithParameters.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters
     width BW word mem locals env ext_spec varname_gen error}.
  Local Notation parameters := (ltac:(let t := type of parameters_sentinel in exact t)) (only parsing).
  Class ok {parameters_sentinel : parameters} :=
    {
      (* semantics_ok : Semantics.parameters_ok semantics *)
      word_ok :> word.ok word;
      mem_ok :> map.ok mem;
      locals_ok :> map.ok locals;
      env_ok :> map.ok env;
      ext_spec_ok :> Semantics.ext_spec.ok ext_spec;

      varname_gen_unique :
        forall i j : nat, varname_gen i = varname_gen j <-> i = j;
    }.

  Context {ok : ok}.
  Lemma word_size_in_bytes_pos : 0 < Memory.bytes_per_word width.
  Proof. destruct Bitwidth.width_cases as [H|H]; rewrite H; cbv; trivial. Qed.
  Lemma width_0mod_8 : width mod 8 = 0.
  Proof. destruct Bitwidth.width_cases as [H|H]; rewrite H; cbv; trivial. Qed.
End WithParameters.

Module rep.
  Section rep.
    Context
      {width BW word mem locals env ext_spec varname_gen error}
     `{parameters_sentinel : @parameters
       width BW word mem locals env ext_spec varname_gen error}.
    Local Notation parameters := (ltac:(let t := type of parameters_sentinel in exact t)) (only parsing).

    Class rep {parameters_sentinel : parameters} (t : base.type) :=
      { ltype : Type; (* type for LHS of assignment *)
        rtype : Type; (* type for RHS of assignment *)
        size : Type; (* amount of space taken in memory, if applicable *)
        rtype_of_ltype : ltype -> rtype;
        dummy_ltype : ltype;
        make_error : rtype;
        dummy_size : size;
        varname_set : ltype -> PropSet.set string;
        equiv : base.interp t -> rtype -> size -> locals -> mem -> Prop }.

    (* store a list in local variables; each element of the list is
       represented as a separate variable *)
    Instance listZ_local {zrep : rep base_Z} : rep base_listZ :=
      { ltype := list ltype;
        rtype := list rtype;
        size := size;
        rtype_of_ltype := map rtype_of_ltype;
        dummy_ltype := nil;
        make_error := [make_error];
        dummy_size := dummy_size;
        varname_set :=
          fold_right
            (fun x s =>
               PropSet.union (varname_set x) s) PropSet.empty_set;
        equiv :=
          fun (x : list Z) (y : list rtype) sz locals _ =>
            Forall2 (fun a b => equiv a b sz locals map.empty) x y
      }.

    (* store a list in memory; the list is represented by one Z, which
         is the location of the head of the list *)
    Instance listZ_mem {zrep : rep base_Z} : rep base_listZ :=
      { ltype := ltype;
        rtype := rtype;
        size := Syntax.access_size;
        rtype_of_ltype := rtype_of_ltype;
        dummy_ltype := dummy_ltype;
        make_error := make_error;
        dummy_size := Syntax.access_size.one;
        varname_set := varname_set;
        equiv :=
          fun (x : list Z) (y : rtype) sz locals =>
            Lift1Prop.ex1
              (fun start : word =>
                 Lift1Prop.ex1
                   (fun ws : list word =>
                      let bytes :=
                          Z.of_nat (Memory.bytes_per (width:=width) sz) in
                      sep (map:=mem)
                          (sep
                             (emp (map word.unsigned ws = x /\
                                   Forall
                                     (fun z =>
                                        (0 <= z < 2 ^ (bytes * 8))%Z)
                                     x))
                             (fun mem : mem =>
                                equiv (word.unsigned start) y
                                      (dummy_size (rep:=zrep))
                                      locals mem))
                          (array (truncated_scalar sz)
                                 (word.of_Z bytes) start
                                 (map word.unsigned ws))))
      }.

    Instance Z : rep base_Z :=
      { ltype := String.string;
        rtype := Syntax.expr.expr;
        size := unit;
        rtype_of_ltype := Syntax.expr.var;
        dummy_ltype := varname_gen 0%nat;
        make_error := error;
        dummy_size := tt;
        varname_set := PropSet.singleton_set;
        equiv :=
          fun (x : Z) (y : Syntax.expr.expr) _ locals =>
            Lift1Prop.ex1
              (fun w : word =>
                 emp (word.unsigned w = x /\
                      WeakestPrecondition.dexpr
                        map.empty locals y w))
      }.
  End rep.
End rep.

Section defs.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters
     width BW word mem locals env ext_spec varname_gen error}.
  Local Notation parameters := (ltac:(let t := type of parameters_sentinel in exact t)) (only parsing).
  Context
          (* list representation -- could be local or in-memory *)
          {listZ : rep.rep base_listZ}.
  Existing Instance rep.Z.

  (* Types that appear in the bedrock2 expressions on the left-hand-side of
     assignments (or in return values). For example, if we want to assign three
     integers, we need three strings.

     Functions can't appear on the left-hand-side, so we return garbage output
     (the unit type). *)
  Fixpoint base_ltype (t : base.type) : Type :=
    match t with
    | base.type.prod a b => base_ltype a * base_ltype b
    | base_listZ => rep.ltype (rep:=listZ)
    | _ => rep.ltype (rep:=rep.Z)
    end.
  Definition ltype (t : type.type base.type) : Type :=
    match t with
    | type.base t => base_ltype t
    | type.arrow s d => unit (* garbage *)
    end.

  (* Types that appear in the bedrock2 expressions on the right-hand-side of
       assignments. For example, if we want to assign three integers, we need
       three [Syntax.expr.expr]s. *)
  Fixpoint base_rtype (t : base.type) : Type :=
    match t with
    | base.type.prod a b => base_rtype a * base_rtype b
    | base_listZ => rep.rtype (rep:=listZ)
    | _ => rep.rtype (rep:=rep.Z)
    end.
  Fixpoint rtype (t : type.type base.type) : Type :=
    match t with
    | type.base a => base_rtype a
    | type.arrow a b => rtype a -> rtype b
    end.

  (* error creation *)
  Fixpoint base_make_error t : base_rtype t :=
    match t with
    | base.type.prod a b => (base_make_error a, base_make_error b)
    | base_listZ => rep.make_error
    |  _ => rep.make_error
    end.
  Fixpoint make_error t : rtype t :=
    match t with
    | type.base a => base_make_error a
    | type.arrow a b => fun _ => make_error b
    end.

  (* These should only be used to fill holes in unreachable cases;
     nothing about them should need to be proven *)
  Fixpoint dummy_base_ltype (t : base.type) : base_ltype t :=
    match t with
    | base.type.prod a b => (dummy_base_ltype a, dummy_base_ltype b)
    | base_listZ => rep.dummy_ltype
    | _ => rep.dummy_ltype
    end.
  Definition dummy_ltype (t : API.type) : ltype t :=
    match t with
    | type.base a => dummy_base_ltype a
    | type.arrow a b => tt
    end.

  (* convert ltypes to rtypes (used for renaming variables) - the opposite
     direction is not permitted *)
  Fixpoint base_rtype_of_ltype {t} : base_ltype t -> base_rtype t :=
    match t with
    | base.type.prod a b =>
      fun x => (base_rtype_of_ltype (fst x),
                base_rtype_of_ltype (snd x))
    | base_listZ => rep.rtype_of_ltype
    | _ => Syntax.expr.var
    end.
  Fixpoint rtype_of_ltype t
    : ltype t -> rtype t :=
    match t as t0 return ltype t0 -> rtype t0 with
    | type.base b => base_rtype_of_ltype
    | type.arrow a b =>
      (* garbage; not a valid ltype *)
      fun (_:unit) =>
        fun (x : rtype a) =>
          rtype_of_ltype b (dummy_ltype b)
    end.

  Fixpoint base_access_sizes t :=
    match t with
    | base.type.prod a b =>
      (base_access_sizes a * base_access_sizes b)%type
    | base_listZ => rep.size (rep:=listZ)
    | _ => rep.size (rep:=rep.Z)
    end.
  Definition access_sizes t :=
    match t with
    | type.base b => base_access_sizes b
    | _ => unit
    end.

  Fixpoint base_dummy_access_sizes t : base_access_sizes t :=
    match t with
    | base.type.prod a b =>
      (base_dummy_access_sizes a, base_dummy_access_sizes b)
    | base_listZ => rep.dummy_size
    | _ => rep.dummy_size
    end.
  Definition dummy_access_sizes t : access_sizes t :=
    match t with
    | type.base b => base_dummy_access_sizes b
    | _ => tt
    end.
  Fixpoint dummy_access_sizes_args t :
    type.for_each_lhs_of_arrow access_sizes t :=
    match t with
    | type.base _ => tt
    | type.arrow s d =>
      (dummy_access_sizes s, dummy_access_sizes_args d)
    end.

  Definition baseonly (f : base.type -> Type) t : Type :=
    match t with
    | type.base b => f b
    | type.arrow _ _ => unit
    end.

  (* Types for partitioning return values into list and non-list *)
  Section ListOnlyListExcl.
    Fixpoint base_listonly (T : Type) t : Type :=
      match t with
      | base.type.prod a b =>
        (base_listonly T a * base_listonly T b)
      | base_listZ => T
      | _ => unit
      end.
    Fixpoint base_listexcl (f : base.type -> Type) t : Type :=
      match t with
      | base.type.prod a b =>
        base_listexcl f a * base_listexcl f b
      | base_listZ => unit
      | _ => f t
      end.
    Definition listonly T := baseonly (base_listonly T).
    Definition listexcl f := baseonly (base_listexcl f).

    Definition list_lengths (t : API.type) :=
      listonly nat t.
    Definition listonly_base_ltype t :=
      base_listonly (base_ltype base_listZ) t.
    Definition listexcl_base_ltype t :=
      base_listexcl base_ltype t.
    Definition listonly_base_rtype t :=
      base_listonly (base_rtype base_listZ) t.
    Definition listexcl_base_rtype t :=
      base_listexcl base_rtype t.

    Fixpoint map_listonly {A B t} (f : A -> B)
      : base_listonly A t -> base_listonly B t :=
      match t as t0 return
            base_listonly A t0 -> base_listonly B t0 with
      | base.type.prod a b =>
        fun x =>
          (map_listonly f (fst x), map_listonly f (snd x))
      | base_listZ => f
      | _ => fun _ => tt
      end.
    Fixpoint map_listexcl {t}
             {f g : base.type -> Type}
             (F : forall t, f t -> g t)
      : base_listexcl f t -> base_listexcl g t :=
      match t as t0 return
            base_listexcl f t0 -> base_listexcl g t0 with
      | base.type.prod a b =>
        fun x =>
          (map_listexcl F (fst x), map_listexcl F (snd x))
      | base_listZ => fun _ => tt
      | _ => F _
      end.
  End ListOnlyListExcl.
End defs.


(* Assume insertion: inserting Assume instructions *)
(* A pass of the dynamic optimizer *)
(* To insert an assume, you need a guard (what to speculate on) *)
(* And you need a label where there is a framestate, that you want to copy the metadata of *)
(* And the Assume is inserted next to that Framestate instruction *)

Require Export List.
Require Export Coqlib.
Require Export Maps.
Require Export specIR.
Require Import Coq.MSets.MSetPositive.
Require Export def_regs.

(** * Guard checking  *)
(* To ensure that the Assume does not intriduce bugs, *)
(* We check that the guard can evaluate without errors *)
Definition check_reg (r:reg) (def:regset) : bool :=
  PositiveSet.mem r def.

Definition check_op (o:op) (def:regset) : bool :=
  match o with
  | Reg r => check_reg r def
  | Cst _ => true
  end.

Definition check_expr (e:expr) (def:regset): bool :=
  match e with
  | Binexpr _ o1 o2 => andb (check_op o1 def) (check_op o2 def)
  | Unexpr _ o => check_op o def
  end.

(* making sure that the guard can evaluate, given a set of defined registers *)
Fixpoint check_guard (guard:list expr) (def:regset): bool :=
  match guard with
  | nil => true
  | e::guard' =>
    andb (check_expr e def) (check_guard guard' def)
  end.

(** * The optimization that inserts Assume directly after the Framestate *)

(* Verify that the assume can be inserted: no code between assume and Framestate *)
Definition validator (v:version) (fs_lbl: label) (guard:list expr) (params: list reg): res unit :=
  match ((ver_code v)#fs_lbl) with
  | Some (Framestate _ _ _ next) =>
    do abs <- try_op (defined_regs_analysis (ver_code v) params (ver_entry v)) "Def_regs analysis failed";
      do def_regs <- OK(def_absstate_get fs_lbl abs);
      match def_regs with
      | DefFlatRegset.Inj def =>
        match (check_guard guard def) with
        | true => OK tt
        | false => Error "The guard might evaluate to an error"
        end
      | DefFlatRegset.Top => Error "The analysis couldn't get the exact set of defined registers: TOP"
      | DefFlatRegset.Bot => Error "The analysis couldn't get the exact set of defined registers: BOT"
      end
  | _ => Error "Not pointing to a valid Framestate"
  end.

(* Returns the version where the Assume has been inserted *)
Definition insert_assume_version (v:version) (fid:fun_id) (guard:list expr) (fsl:label) (params:list reg): res version :=
  do code <- OK(ver_code v);
    do freshlbl <- OK (fresh_label (Pos.succ fsl) code);
    do _ <- validator v fsl guard params; (* validating that the assume can be inserted *)
    match code # fsl with
    | Some (Framestate tgt vm sl next) =>
      do instr <- try_op (code # next) "Next Label is not used in the function";
        do update_fs <- OK (code # fsl <- (Framestate tgt vm sl freshlbl));
        do new_code <- OK (update_fs # freshlbl <- (Assume guard tgt vm sl next));
        (* in the new assume, the deopt target, the varmap and the synth list are copied from the framestate *)
        OK (mk_version new_code (ver_entry v))
    | _ => Error "Not pointing to a valid Framestate"
    end.

(* The optimization pass *)
Definition insert_assume (fid: fun_id) (guard:list expr) (fs_lbl: label) (p:program): res program :=
  do f <- try_op (find_function fid p) "Function to optimize not found";
    do v <- OK(current_version f); (* the optimized code if it exists, the base version otherwise *)
    do newv <- insert_assume_version v fid guard fs_lbl (fn_params f);
    do new_program <- OK (set_version p fid newv);
    OK (new_program).

Definition safe_insert_assume (p:program) (fid:fun_id) (guard:list expr) (fs_lbl: label): program :=
  safe_res (insert_assume fid guard fs_lbl) p.


Require Export Fiat.QueryStructure.Specification.Representation.QueryStructureNotations
        Fiat.QueryStructure.Specification.Operations.Query.
Require Import Coq.Lists.List
        Coq.Arith.Compare_dec
        Coq.Bool.Bool
        Coq.Strings.String
        Coq.Strings.Ascii
        Fiat.Common.BoolFacts
        Fiat.Common.List.PermutationFacts
        Fiat.Common.List.ListMorphisms
        Fiat.Common.Tactics.CacheStringConstant
        Fiat.QueryStructure.Specification.Operations.FlattenCompList
        Fiat.Common.Ensembles.EnsembleListEquivalence
        Fiat.QueryStructure.Implementation.Operations.General.QueryRefinements
        Fiat.Common.IterateBoundedIndex
        Fiat.Common.List.ListFacts
        Fiat.Common.LogicFacts
        Fiat.Common.DecideableEnsembles
        Fiat.QueryStructure.Specification.Constraints.tupleAgree
        Fiat.QueryStructure.Specification.Operations.Mutate
        Fiat.QueryStructure.Implementation.Constraints.ConstraintChecksRefinements
        Fiat.QueryStructure.Automation.Common.

Ltac dec_tauto :=
  clear; intuition eauto;
  eapply Tuple_Agree_eq_dec;
  match goal with
  | [ |- ?E = true ] => case_eq E; intuition idtac; [ exfalso ]
  end;
  match goal with
  | [ H : _ |- _ ] => apply Tuple_Agree_eq_dec' in H; solve [ eauto ]
  end.

Lemma query_eq_true_iff {A}
      (q_eq : Query_eq A)
  : forall (a a' : A), ?[ A_eq_dec a a'] = true <-> a = a'.
Proof.
  intros; destruct (A_eq_dec a a'); split; intros; try congruence.
Qed.

Ltac prove_decidability_for_functional_dependencies :=
  simpl; econstructor; intros;
  (*repeat setoid_rewrite <- (@query_eq_true_iff _ _); *)
  try setoid_rewrite <- eq_nat_dec_bool_true_iff;
  try setoid_rewrite <- eq_N_dec_bool_true_iff;
  try setoid_rewrite <- eq_Z_dec_bool_true_iff;
  try setoid_rewrite <- string_dec_bool_true_iff;
  try setoid_rewrite <- ascii_dec_bool_true_iff;
  setoid_rewrite and_True;
  repeat progress (
           try setoid_rewrite <- andb_true_iff;
           try setoid_rewrite not_true_iff_false;
           try setoid_rewrite <- negb_true_iff);
  rewrite bool_equiv_true;
  reflexivity.

Hint Extern 100 (DecideableEnsemble _) => prove_decidability_for_functional_dependencies : typeclass_instances.

Tactic Notation "refine" "existence" "check" "into" "query" :=
  match goal with
    |- context[{b | decides b
                            (exists tup : @IndexedTuple ?heading,
                                (@GetUnConstrRelation ?qs_schema ?qs ?tbl tup /\ @?P tup))}]
    =>
    let H1 := fresh in
    let H2 := fresh in
    makeEvar (Ensemble (@Tuple heading))
             ltac:(fun P' => assert (Same_set (@IndexedTuple heading) (fun t => P' (indexedElement t)) P) as H1;
                   [unfold Same_set, Included, Ensembles.In;
                     split; [intros x H; pattern (indexedElement x);
                             match goal with
                               |- ?P'' (indexedElement x) => unify P' P'';
                                 simpl; eauto
                             end
                            | eauto]
                   |
                   assert (DecideableEnsemble P') as H2;
                     [ simpl; eauto with typeclass_instances (* Discharge DecideableEnsemble w/ intances. *)
                     | setoid_rewrite (@refine_constraint_check_into_query' qs_schema tbl qs P P' H2 H1); clear H1 H2 ] ]) end.

Ltac funDepToQuery :=
  match goal with
  | |-
    context [{b : _ |
              decides b
                      (forall tup' : @IndexedElement ?T,
                          GetUnConstrRelation (QSSchema := ?qsSchema) ?or ?Ridx _ ->
                          @FunctionalDependency_P ?heading ?attrlist1 ?attrlist2 ?n _)}] =>
    let H' := fresh in
    let H'' := fresh in
    let refine_fundep := fresh in
    assert
      ((forall (tup' : @IndexedElement T),
           GetUnConstrRelation or Ridx tup' ->
           @FunctionalDependency_P heading attrlist1 attrlist2 n (indexedElement tup')) <->
       (forall tup' : @IndexedElement T,
           ~
             (GetUnConstrRelation or Ridx tup' /\
              @tupleAgree heading n (indexedElement tup') attrlist2 /\
              ~ @tupleAgree heading n (indexedElement tup') attrlist1)))
      as H' by (unfold FunctionalDependency_P; dec_tauto);
      assert
        (DecideableEnsemble
           (fun x : T =>
              @tupleAgree_computational heading n x attrlist2 /\
              ~ @tupleAgree_computational heading n x attrlist1))
      as H''
        by (subst_all;
            FunctionalDependencyAutomation.prove_decidability_for_functional_dependencies);
      (let refine_fundep :=
           eval simpl in
       ( (@refine_functional_dependency_check_into_query qsSchema Ridx n attrlist2
                                                         attrlist1 or H'' H')) in
           setoid_rewrite refine_fundep; clear H'' H')
  end.

Ltac fundepToQuery :=
  match goal with
  | [ |- context[Pick
                   (fun b => decides
                               b
                               (forall tup' : @IndexedRawTuple ?sch,
                                   GetUnConstrRelation (QSSchema := ?qs_schema) ?or ?Ridx _
                                   -> @FunctionalDependency_P ?heading ?attrlist1 ?attrlist2 ?n _))] ] =>
    let H' := fresh in
    let H'' := fresh in
    let refine_fundep := fresh in
    assert ((forall tup' : IndexedRawTuple,
                GetUnConstrRelation or Ridx tup'
                -> @FunctionalDependency_P heading attrlist1 attrlist2 n (indexedElement tup'))
            <-> (forall tup' : IndexedRawTuple,
                    ~ (GetUnConstrRelation or Ridx tup'
                       /\ @tupleAgree sch n (indexedElement tup') attrlist2
                       /\ ~ @tupleAgree sch n (indexedElement tup') attrlist1))) as H'
        by (unfold FunctionalDependency_P; dec_tauto);
      assert (DecideableEnsemble (fun x : RawTuple =>
                                    @tupleAgree_computational sch n x attrlist2 /\
                                    ~ @tupleAgree_computational sch n x attrlist1)) as H''
        by (subst_all;
            prove_decidability_for_functional_dependencies);
      let refine_fundep := eval simpl in (@refine_functional_dependency_check_into_query qs_schema Ridx n attrlist2 attrlist1 or H'' H') in
          (* as refine_fundep; simpl in refine_fundep;
        fold_heading_hyps_in refine_fundep; fold_string_hyps_in refine_fundep; *)
          setoid_rewrite refine_fundep; clear H'' H'
  | [ |- context[Pick
                   (fun b => decides
                               b
                               (forall tup' : @IndexedRawTuple ?sch,
                                   GetUnConstrRelation ?or ?Ridx _
                                   -> @FunctionalDependency_P ?heading ?attrlist1 ?attrlist2 _ ?n ))] ] =>
    let H' := fresh in
    let H'' := fresh in
    let refine_fundep := fresh in
    assert ((forall tup' : IndexedTuple,
                GetUnConstrRelation or Ridx tup'
                -> @FunctionalDependency_P heading attrlist1 attrlist2 (indexedElement tup') n)
            <-> (forall tup' : IndexedTuple,
                    ~ (GetUnConstrRelation or Ridx tup'
                       /\ @tupleAgree sch (indexedElement tup') n attrlist2
                       /\ ~ @tupleAgree sch (indexedElement tup') n attrlist1))) as H'
        by (unfold FunctionalDependency_P; dec_tauto);
      assert (DecideableEnsemble (fun x : Tuple =>
                                    @tupleAgree_computational sch x n attrlist2 /\
                                    ~ @tupleAgree_computational sch x n attrlist1)) as H''
        by prove_decidability_for_functional_dependencies;
      let refine_fundep := eval simpl in
      (@refine_functional_dependency_check_into_query' _ _ n attrlist2 attrlist1 or H'' H') in
          (*simpl in refine_fundep; setoid_rewrite refine_fundep; *) clear H'' H'
  end; try simplify with monad laws; pose_string_hyps; pose_heading_hyps.


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.sepalg.
Require Import VST.msl.sepalg_generators.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.cross_split.

Definition compareR {A} {JA: Join A}{SA: Sep_alg A}{AG: ageable A} : relation A
   := comparable.
Definition extendR  {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A} : relation A := join_sub.

Lemma valid_rel_compare {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : valid_rel compareR.
Proof.
  split; hnf; intros.

  apply comparable_common_unit in H0.
  destruct H0 as [w [? ?]].
  destruct (age1_join2  _ H1 H)
    as [u [v [? [? ?]]]].
  destruct (age1_join _ H0 H3)
    as [u' [v' [? [? ?]]]].
  assert (u' = v').
  unfold age in *; congruence.
  subst v'.
  exists u'; auto.
  assert (x = v).
  unfold age in *; congruence.
  subst v.
  apply common_unit_comparable.
  exists u; auto.

  apply comparable_common_unit in H.
  destruct H as [w [? ?]].
  destruct (unage_join2 _ H H0)
    as [u [v [? [? ?]]]].
  destruct (unage_join _ H1 H3)
    as [u' [v' [? [? ?]]]].
  exists v'; auto.
  apply common_unit_comparable.
  destruct (join_ex_units u) as [uu Huu].
  red in Huu.
  exists uu; split.
  destruct (join_assoc Huu H2) as [q [? ?]].
  assert (q = z).
  eapply join_eq; eauto.
  subst q; auto.
  destruct (join_assoc Huu H5) as [q [? ?]].
  assert (q = v').
  eapply join_eq; eauto.
  subst q.
  auto.
Qed.

Lemma valid_rel_extend {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : valid_rel extendR.
Proof.
  intros; split; hnf; intros.
  destruct H0 as [w ?].
  destruct (age1_join2 _ H0 H)
    as [u [v [? [? ?]]]].
  exists u; auto.
  exists v; auto.

  destruct H.
  destruct (unage_join _ H H0)
    as [u [v [? [? ?]]]].
  exists v; auto.
  exists u; auto.
Qed.

Definition compareM {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : modality
  := exist _ compareR valid_rel_compare.
Definition extendM {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : modality
  := exist _ extendR valid_rel_extend.

(* Definitions of the BI connectives. *)
Obligation Tactic := unfold hereditary; intros; try solve [intuition].

Program Definition emp {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : pred A := identity.
Next Obligation.
  repeat intro.
  destruct (unage_join _ H1 H) as [a0' [b' [? [? ?]]]].
  apply H0 in H2. subst b'. unfold age in H3, H4. congruence.
Qed.

Program Definition sepcon {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (p q:pred A) : pred A := fun x:A =>
  exists y:A, exists z:A, join y z x /\ p y /\ q z.
Next Obligation.
  destruct H0 as [y [z [? [? ?]]]].
  destruct (age1_join2 _ H0 H) as [w [v [? [? ?]]]].
  exists w; exists v; split; auto.
  split.
  apply pred_hereditary with y; auto.
  apply pred_hereditary with z; auto.
Qed.

Program Definition wand {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (p q:pred A) : pred A := fun x =>
  forall x' y z, necR x x' -> join x' y z -> p y -> q z.
Next Obligation.
  apply H0 with x' y; auto.
  apply rt_trans with a'; auto.
  apply rt_step; auto.
Qed.

Notation "P '*' Q" := (sepcon P Q) : pred.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : pred.
Notation "'%' e"  := (box extendM e)(at level 30, right associativity): pred.

Lemma extendM_refl {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: reflexive _ extendM.
Proof.
intros; intro; simpl; apply join_sub_refl.
Qed.

Lemma compareM_refl {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : reflexive _ compareM.
Proof.
intros; intro; simpl.
apply comparable_refl.
Qed.

Hint Resolve @extendM_refl.
Hint Resolve @compareM_refl.

(* Rules for the BI connectives *)

Lemma wand_sepcon_adjoint {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P Q R:pred A),
  ((P * Q) |-- R) = (P |-- (Q -* R)).
Proof.
  intros. apply prop_ext.
  split; intros.
  hnf; intros; simpl; intros.
  apply H.
  exists x'; exists y.
  intuition.
  apply pred_nec_hereditary with a; auto.
  hnf; intros.
  hnf in H.
  unfold wand in H; simpl in H.
  destruct H0 as [w [v [? [? ?]]]].
  eapply H; eauto.
Qed.

Lemma sepcon_assoc {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P Q R:pred A),
  ((P * Q) * R = P * (Q * R))%pred.
Proof.
  pose proof I.
  intros; apply pred_ext; hnf; intros.
  destruct H0 as [x [y [? [? ?]]]].
  destruct H1 as [z [w [? [? ?]]]].
  destruct (join_assoc H1 H0) as [q [? ?]].
  exists z; exists q; intuition.
  exists w; exists y; intuition.
  destruct H0 as [x [y [? [? ?]]]].
  destruct H2 as [z [w [? [? ?]]]].
  apply join_comm in H0.
  apply join_comm in H2.
  destruct (join_assoc H2 H0) as [q [? ?]].
  exists q; exists w; intuition.
  exists x; exists z; intuition.
Qed.

Lemma sepcon_comm {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P Q:pred A),
  (P * Q = Q * P)%pred.
Proof.
  pose proof I.
  intros; apply pred_ext; hnf; intros.
  destruct H0 as [x [y [? [? ?]]]].
  exists y; exists x; intuition; apply join_comm; auto.
  destruct H0 as [x [y [? [? ?]]]].
  exists y; exists x; intuition; apply join_comm; auto.
Qed.

Lemma split_sepcon {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P Q R S:pred A),
  P |-- Q ->
  R |-- S ->
  (P * R) |-- (Q * S).
Proof.
  intros; hnf; intros.
  destruct H1 as [x [y [? [? ?]]]].
  exists x; exists y; intuition.
Qed.

Lemma sepcon_cut {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P Q R S:pred A),
  P |-- (Q -* R) ->
  S |-- Q ->
  (P * S) |-- R.
Proof.
  intros.
  rewrite wand_sepcon_adjoint.
  hnf; intros.
  simpl; intros.
  eapply H; eauto.
Qed.

Lemma emp_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P:pred A),
  (emp * P = P)%pred.
Proof.
  intros; apply pred_ext; hnf; intros.
  destruct H as [x [y [? [? ?]]]].
  simpl in H0.
  replace a with y; auto.
  destruct (join_ex_identities a) as [u [Hu [? Hj]]].
  exists u; exists a. split; auto.
  specialize (Hu _ _ Hj); subst; auto.
Qed.

Lemma sepcon_emp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}  : forall (P:pred A),
  (P * emp = P)%pred.
Proof.
  intros.
  rewrite sepcon_comm.
  apply emp_sepcon.
Qed.

(*Lemma emp_sepcon : forall {A} `{Age_alg A} (P:pred A), emp * P = P.
Proof. exact @emp_sepcon. Qed.
Lemma sepcon_emp : forall {A} `{Age_alg A} (P:pred A), P * emp = P.
Proof. exact @sepcon_emp. Qed.
*)

Lemma later_wand {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} : forall P Q,
  (|>(P -* Q) = |>P -* |>Q)%pred.
Proof.
  pose proof I.
  intros.
  repeat rewrite later_age.
  apply pred_ext; hnf; intros.
  simpl; intros.
  simpl in H0.
  case_eq (age1 a); intros.
  specialize ( H0 a0 H5).
  apply nec_refl_or_later in H1.
  destruct H1; subst.
  destruct (age1_join2 _ H2 H4) as [w [v [? [? ?]]]].
  eapply H0; eauto.
  replace a0 with w; auto.
  congruence.
  assert (necR a0 x').
  eapply age_later_nec; eauto.
  destruct (age1_join2 _ H2 H4) as [w [v [? [? ?]]]].
  apply H0 with w v; auto.
  apply rt_trans with x'; auto.
  apply rt_step; auto.
  apply nec_refl_or_later in H1; destruct H1; subst.
  destruct (age1_join2 _  H2 H4) as [w [v [? [? ?]]]].
  hnf in H6.
  rewrite H5 in H6; discriminate.
  clear -H1 H5.
  elimtype False.
  revert H5; induction H1; auto.
  intros.
  unfold age in H.
  rewrite H in H5; discriminate.

  simpl; intros.
  simpl in H0.
  destruct (valid_rel_nec).
  destruct (H6 _ _ H2 _ H1).
  destruct (unage_join _ H3 H7) as [w [v [? [? ?]]]].
  apply H0 with x w v; auto.
  intros.
  replace a'0 with y; auto.
  congruence.
Qed.

Lemma later_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall P Q,
  (|>(P * Q) = |>P * |>Q)%pred.
Proof.
  pose (H:=True).
  intros.
  repeat rewrite later_age.
  apply pred_ext; hnf; intros.
  simpl in H0.
  case_eq (age1 a); intros.
  destruct (H0 a0) as [w [v [? [? ?]]]]; auto.
  destruct (unage_join2 _ H2 H1) as [w' [v' [? [? ?]]]].
  exists w'; exists v'; intuition.
  simpl; intros.
  replace a' with w; auto.
  unfold age in *; congruence.
  simpl; intros.
  replace a' with v; auto.
  unfold age in *; congruence.
  destruct (join_ex_units a).
  exists x; exists a.
  intuition.
  hnf; intros.
  red in u.
  simpl in H2.
  destruct (age1_join _ u H2) as [s [t [? [? ?]]]].
  unfold age in H5.
  rewrite H1 in H5; discriminate.
  hnf; intros.
  simpl in H2.
  unfold age in H2.
  rewrite H1 in H2; discriminate.

  destruct H0 as [w [v [? [? ?]]]].
  hnf; intros.
  simpl in H3.
  destruct (age1_join2 _ H0 H3) as [w' [v' [? [? ?]]]].
  exists w'; exists v'; intuition.
Qed.

Lemma FF_sepcon : forall {A}{JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (P:pred A),
  (FF * P = FF)%pred.
Proof.
  intros. apply pred_ext; repeat intro.
  destruct H as [? [? [? [? ?]]]].  elim H0.
  elim H.
Qed.

Lemma sepcon_derives {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall p q p' q', (p |-- p') -> (q |-- q') -> (p * q |-- p' * q').
Proof.
intros.
do 2 intro.
destruct H1 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; repeat split ;auto.
Qed.

Lemma exp_sepcon1 {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall T (P: T ->  pred A) Q,  (exp P * Q = exp (fun x => P x * Q))%pred.
Proof.
intros.
apply pred_ext; intros ? ?.
destruct H as [w1 [w2 [? [[x ?] ?]]]].
exists x; exists w1; exists w2; split; auto.
destruct H as [x [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; auto.
split; auto.
exists x; auto.
Qed.

Lemma exp_sepcon2 {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall T (P: pred A) (Q: T -> pred A),  (P * exp Q = exp (fun x => P * Q x))%pred.
Proof.
intros.
apply pred_ext; intros ? ?.
destruct H as [w1 [w2 [? [? [x ?]]]]].
exists x; exists w1; exists w2; split; auto.
destruct H as [x [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; auto.
split; auto.
exists x; auto.
Qed.

Lemma extend_later {A}  {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall P, (%|>P = |>%P)%pred.
Proof.
  intros; rewrite later_commute; auto.
Qed.

Lemma extend_later' {A}{JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}: forall P, boxy extendM P -> boxy extendM (|> P).
Proof.
intros. unfold boxy in *. rewrite later_commute. rewrite H. auto.
Qed.
Hint Resolve @extend_later'.

Lemma age_sepcon {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} :
      forall P Q, (box ageM (P * Q) = box ageM P * box ageM Q)%pred.
Proof.
  pose proof I.
  intros.
  apply pred_ext; hnf; intros.
  hnf in H0.
  case_eq (age1 a); intros.
  destruct (H0 a0) as [u [v [? [? ?]]]]; auto.
  red.
  destruct (unage_join2 _ H2 H1) as [x [y [? [? ?]]]].
  exists x; exists y.
  intuition.
  hnf; intros.
  replace a' with u; auto.
  unfold age in *; congruence.
  hnf; intros.
  replace a' with v; auto.
  unfold age in *; congruence.
  destruct (join_ex_units a).
  exists x; exists a.
  intuition.
  hnf; intros.
  red in u.
  destruct (age1_join _ u H2)
    as [p [q [? [? ?]]]]; auto.
  unfold age in *.
  rewrite H1 in H4; discriminate.
  hnf; intros.
  simpl in *.
  unfold age in *.
  rewrite H1 in H2; discriminate.

  destruct H0 as [u [v [? [? ?]]]].
  hnf; intros.
  destruct (age1_join2 _ H0 H3)
    as [p [q [? [? ?]]]]; auto.
  exists p; exists q; intuition.
Qed.

Lemma age_twin {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall phi1 phi2 n phi1',
  comparable phi1 phi2 ->
  ageN n phi1 = Some phi1' ->
  exists phi2', ageN n phi2 = Some phi2' /\ comparable phi1' phi2'.
Proof.
intros until n; revert n phi1 phi2.
induction n; intros.
exists phi2.
split; trivial.
inversion H0.
subst phi1'.
trivial.
unfold ageN in H0.
simpl in H0.
revert H0; case_eq (age1 phi1); intros; try discriminate.
rename a into phi.
assert (exists ophi2, age phi2 ophi2 /\ comparable phi ophi2).
destruct (comparable_common_unit H) as [e [? ?]].
destruct (age1_join _ (join_comm H2) H0) as [eo [phi1'a [eof [? ?]]]].
destruct (age1_join _ H3 H4) as [phi2' [phi2'a [eof' [? ?]]]].
unfold age in H7. rewrite H6 in H7. symmetry in H7; inv H7.
rewrite H5 in H0. inv H0.
exists phi2'. split; auto.
apply common_unit_comparable; exists eo; split; auto.
destruct H2 as [ophi2 [? ?]].
specialize (IHn _ _ _ H3 H1).
destruct IHn as [phi2' [? ?]].
exists phi2'.
split; trivial.
unfold ageN.
simpl.
rewrite H2.
trivial.
Qed.

Lemma ageN_different {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall n phi phi', ageN (S n) phi = Some phi' ->
    ~ comparable phi phi'.
Proof.
   intros.
   intro.
   generalize (age_noetherian' phi); intros [k [[? [? ?]] H4]].
   assert (k <= n \/ k > n)%nat by omega.
   destruct H3.
   replace (S n) with (k + (S n - k))%nat in H by omega.
   destruct (ageN_compose' _ _ _ _ H) as [b [? ?]].
   rewrite H1 in H5; inv H5.
   replace (S n - k)%nat with (S (n-k))%nat in H6 by omega.
   unfold ageN in H6; simpl in H6. rewrite H2 in H6; inv H6.
   replace k with (S n + (k - S n))%nat in H1 by omega.
   destruct (ageN_compose' _ _ _ _ H1) as [c [? ?]].
   rewrite H in H5; inv H5.
   destruct (age_twin phi c _ _ H0 H1) as [b [? ?]].
   replace (S n + (k - S n))%nat with ((k - S n) + S n)%nat in H5 by omega.
   destruct (ageN_compose' _ _ _ _ H5) as [d [? ?]].
   rewrite H6 in H8; inv H8.
   clear - H9 H2.
   unfold ageN in H9; simpl  in H9; rewrite H2 in H9; inv H9.
Qed.

Lemma necR_comparable{A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall w w', necR w w' -> comparable w w' -> w=w'.
Proof.
intros.
rewrite necR_evolve in H.
destruct H as [n H].
destruct n.
inv H; auto.
contradiction (ageN_different _ _ _ H); auto.
Qed.

Lemma sepcon_andp_prop {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q R, (P * (!!Q && R) = !!Q && (P * R))%pred.
Proof.
intros.
apply pred_ext; intros w ?.
destruct H as [w1 [w2 [? [? [? ?]]]]].
split. apply H1.
exists w1; exists w2; split; [|split]; auto.
destruct H.
destruct H0 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
Qed.

Lemma TT_sepcon_TT {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: (TT * TT = TT)%pred.
Proof.
intros.
apply pred_ext; intros w ?; auto.
destruct (join_ex_units w).
exists x; exists w; split; auto.
Qed.

Lemma join_exactly {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall w1 w2 w3, join w1 w2 w3 ->  (exactly w1 * exactly w2 = exactly w3)%pred.
Proof.
pose proof I.
intros.
unfold exactly.
apply pred_ext; intros w ?; simpl in *.
destruct H1 as [? [? [? [? ?]]]].
destruct (nec_join H0 H2) as [a [b [? [? ?]]]].
assert (x0=a).
 eapply necR_linear'; eauto.
  transitivity (level x).
  symmetry; apply comparable_fashionR. eapply join_comparable2; eauto.
  apply comparable_fashionR. eapply join_comparable2; eauto.
subst x0.
generalize (join_eq H4 H1); clear H4; intro; subst.
auto.
eapply nec_join2; eauto.
Qed.

Lemma extend_sepcon_andp {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q R, boxy extendM Q -> P * (Q && R) |-- Q && (P * R).
Proof.
intros.
intros ?w [?w [?w [? [? [? ?]]]]].
split.
rewrite <- H in H2.
eapply H2.
exists w0.
apply join_comm; auto.
exists w0; exists w1; auto.
Qed.
Arguments extend_sepcon_andp : clear implicits.

Lemma distrib_sepcon_andp {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q R, P * (Q && R) |-- (P * Q) && (P * R).
Proof.
intros. intros w [w1 [w2 [? [? ?]]]].
destruct H1.
split; exists w1; exists w2; split; auto.
Qed.

Lemma modus_wand {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q,  P * (P -* Q) |-- Q.
Proof.
intros.
intros w  [?w [?w [? [? ?]]]].
eapply H1; eauto.
Qed.

Lemma extend_sepcon {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall {Q R: pred A}, boxy extendM Q ->  Q * R |-- Q.
Proof.
intros.
intros w [w1 [w2 [? [? _]]]].
rewrite <- H in H1. eapply H1; eauto.
simpl; eauto.
exists w2; auto.
Qed.

Definition precise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} (P: pred A) : Prop :=
     forall w w1 w2, P w1 -> P w2 -> join_sub w1 w -> join_sub w2 w -> w1=w2.

Definition precise2  {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} (P: pred A) : Prop :=
     forall Q R, (P * (Q && R) = (P * Q) && (P * R))%pred.

Lemma precise_eq {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{AG: ageable A}{XA: Age_alg A}: precise =
                 fun P : pred A => forall Q R, (P * (Q && R) = (P * Q) && (P * R))%pred.
Proof.
extensionality P.
unfold precise.
apply prop_ext; split; intros.
apply pred_ext; unfold derives; intros; rename a into w.
destruct H0 as [phi1 [phi2 [? [? [? ?]]]]].
split; exists phi1; exists phi2; auto.
destruct H0 as [[phi1a [phi2a [? [? ?]]]] [phi1b [phi2b [? [? ?]]]]].
specialize (H w _ _ H1 H4).
spec H.
econstructor; eauto.
spec H.
econstructor; eauto.
subst phi1b.
generalize (join_canc (join_comm H0) (join_comm H3)).
intro; subst phi2b.
exists phi1a; exists phi2a; split; auto.
split; auto.
split; auto.
rename w1 into w1a.
rename w2 into w1b.
destruct H2 as [w2a ?].
destruct H3 as [w2b ?].
assert (((P * exactly w2a) && (P * exactly w2b)) w)%pred.
split; do 2 econstructor; repeat split;
try solve [simpl; apply necR_refl].
eassumption. auto. eassumption. auto.
rewrite <- H in H4.
destruct H4 as [w1 [w2 [? [? [? ?]]]]].
simpl in H6,H7.
rewrite (necR_comparable _ _ H6) in H2.
rewrite (necR_comparable _ _ H7) in H3.
eapply join_canc; eauto.
apply comparable_trans with w.
apply join_comparable with w1b; auto.
apply comparable_sym; apply join_comparable with w1; auto.
apply comparable_trans with w.
apply join_comparable with w1a; auto.
apply comparable_sym; apply join_comparable with w1; auto.
Qed.

Lemma derives_precise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q, (P |-- Q) -> precise Q -> precise P.
Proof.
intros; intro; intros; eauto.
Qed.

Lemma precise_emp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: precise emp.
Proof.
repeat intro.
eapply join_sub_same_identity with (a := w1)(c := w); auto.
apply identity_unit'; auto.
eapply join_sub_unit_for; eauto.
apply identity_unit'; auto.
Qed.

Definition superprecise {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} (P: pred A) :=
   forall w1 w2, P w1 -> P w2 -> comparable w1 w2 -> w1=w2.

Lemma superprecise_exactly {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall w, superprecise (exactly w).
Proof.
unfold superprecise; intros.
hnf in H,H0.
eapply necR_linear'; eauto.
apply comparable_fashionR; auto.
Qed.
Hint Resolve @superprecise_exactly.

Lemma superprecise_precise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}: forall (P: pred A) , superprecise P -> precise P.
Proof.
  pose proof I.
  unfold precise. unfold superprecise.
  intros.
  assert (comparable w1 w2). assert (comparable w1 w) by apply (join_sub_comparable H3).
  assert (comparable w w2).
    apply comparable_sym; destruct H4; eapply join_comparable; eauto.
    apply (comparable_trans H5 H6).
  apply (H0 _ _ H1 H2 H5).
Qed.

(* EXistential Magic Wand *)

Program Definition ewand {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A} (P Q: pred A) : pred A :=
  fun w => exists w1, exists w2, join w1 w w2 /\ P w1 /\ Q w2.
Next Obligation.
destruct H0 as [w1 [w2 [? [? ?]]]].
apply join_comm in H0; eapply age1_join in H0; eauto.
destruct H0 as [w1' [w3' [? [? ?]]]].
exists w1'; exists w3'; split; auto.
split;   eapply pred_nec_hereditary; try eassumption.
constructor 1; auto.
constructor 1; auto.
Qed.

Lemma later_ewand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall P Q,
  (|>(ewand P Q) = ewand (|>P) (|>Q))%pred.
Proof.
intros.
apply pred_ext.
intros w ?.
case_eq (age1 w); intros.
destruct (H a (t_step _ _ _ _ H0)) as [a1 [a2 [? [? ?]]]].
destruct (unage_join _ (join_comm H1) H0) as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; split; [|split]; auto.
hnf; intros.
apply pred_nec_hereditary with a1; auto.
eapply age_later_nec; eauto.
hnf; intros.
apply pred_nec_hereditary with a2; auto.
eapply age_later_nec; eauto.
exists (core w), w.
split; [|split].
apply core_unit.
hnf; intros.
assert (age1 (core w) = None).
apply age1_None_joins with w; auto.
exists w; apply join_comm; apply core_unit.
unfold laterM in H1. simpl in H1.
unfold laterR in H1.
apply clos_trans_t1n in H1. inv H1; rewrite H3 in H2; inv H2.
intros w' ?.
hnf in H1. apply clos_trans_t1n in H1.
inv H1; rewrite H2 in H0; inv H0.

intros w [w1 [w2 [? [? ?]]]].
intros w' ?.
hnf in H2. apply clos_trans_t1n in H2.
revert w1 w2 H H0 H1; induction H2; intros.
destruct (age1_join _ (join_comm H0) H) as [w1' [w2' [? [? ?]]]].
exists w1'; exists w2'; split; auto.
split.
eapply H1. hnf; apply clos_t1n_trans. constructor 1; auto.
eapply H2. hnf; apply clos_t1n_trans. constructor 1; auto.
destruct (age1_join _ (join_comm H0) H) as [w1' [w2' [? [? ?]]]].
apply (IHclos_trans_1n _ _ (join_comm H4)); auto; eapply pred_hereditary; eauto.
Qed.

(* Notation "P '-o' Q" := (ewand P Q) (at level 60, right associativity). *)

Lemma emp_ewand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
      forall P, ewand emp P = P.
Proof.
intros.
apply pred_ext; intros w ?.
destruct H as [w1 [w2 [? [? ?]]]].
replace w with w2; auto.
eapply join_eq; eauto.
eapply identity_unit; eauto.
destruct (join_ex_identities w) as [e [He [? Hj]]].
exists e; exists w.
split; auto.
specialize (He _ _ Hj); subst; auto.
Qed.

Lemma pry_apart {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall G P Q, superprecise G -> P = ewand G (G * P) ->
                       (P * Q) && (G * TT) |-- (P * G * (ewand G Q)).
Proof.
 pose proof I. intros.
intros w [? ?].
destruct H2 as [w2 [w3 [? [? Hq]]]].
destruct H3 as [w4 [w5 [? [? _]]]].
rewrite H1 in H4.
destruct H4 as [wa [wb [? [? ?]]]].
assert (wa = w4). apply H0; auto.
apply comparable_trans with w2. apply join_comparable2 with wb; auto.
apply comparable_trans with w. apply join_comparable with w3; auto.
apply comparable_sym. apply join_comparable with w5; auto.
subst wa; clear H6.
destruct H7 as [w4' [w2' [? [? ?]]]].
assert (w4' = w4). apply H0; auto.
apply comparable_trans with wb. eapply join_comparable; eauto.
apply comparable_sym.  eapply join_comparable; eauto.
subst w4'; clear H7.
assert (w2' = w2). eapply join_canc; try apply join_comm; eauto.
subst w2'; clear H6.
destruct (CrA _ _ _ _ _ H2 H3) as [[[[w24 w25] w34] w35] [? [? [? ?]]]].
assert (identity w24).
  destruct (join_assoc (join_comm H9) H4) as [f [? ?]].
  destruct (join_assoc (join_comm H6) (join_comm H11)) as [g [? ?]].
  eapply join_self; eauto.
assert (w34=w4). eapply join_eq; [eapply identity_unit; eauto | auto ].
subst w34.
assert (w25 = w2). eapply join_eq; [eapply identity_unit; eauto | auto ].
subst w25.
clear H11 H9 H6 w24.
destruct (join_assoc (join_comm H10) (join_comm H3)) as [h [? ?]].
generalize (join_eq H6 (join_comm H4)); clear H6; intro; subst h.
destruct (join_assoc (join_comm H4) (join_comm H9)) as [h [? ?]].
generalize (join_eq H6 H7); clear H6; intro; subst h.
clear H11.
exists wb; exists w35.
split. apply join_comm; auto.
split; auto.
exists w2; exists w4; split; auto.
unfold ewand.
exists w4; exists w3; split; auto.
Qed.

Definition wk_split {A} {JA: Join A} :=
      forall a b c d e : A, join a b c -> join d e c -> joins a d -> join_sub d b.

Lemma crosssplit_wkSplit {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{DA: Disj_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
    wk_split.
Proof.
unfold wk_split; intros.
destruct (CrA _ _ _ _ _ H H0) as [[[[ad ae] bd] be] [myH1 [myH2 [myH3 myH4]]]].
destruct H1 as [x H_x].
assert (exists X, join ad X be) as [X HX].
2:{   exists X.
               destruct (join_assoc (join_comm HX) (join_comm myH2)) as [y [myH5 myH6]].
               assert (y=d) by apply (join_eq myH5 myH3).  subst y.
               apply (join_comm myH6).
}
destruct (join_assoc (join_comm myH1) H_x) as [y [myH5 myH6]].
destruct (join_assoc (join_comm myH3) (join_comm myH5)) as [? [Had ?]].
apply join_self in Had.
pose proof (Had _ _ myH1); subst.
destruct (join_assoc (join_comm myH1) myH4) as [? [Hbe ?]].
specialize (Had _ _ Hbe); subst; eauto.
Qed.

Lemma wk_pry_apart {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall G P Q, wk_split -> superprecise G -> P = ewand G (G * P) ->
                       (P * Q) && (G * TT) |-- (P * G * (ewand G Q)).
Proof.
intros.
intros w [? ?]. unfold ewand.
destruct H2 as [w2 [w3 [? [? Hq]]]].
destruct H3 as [w4 [w5 [? [? _]]]].
rewrite H1 in H4.
destruct H4 as [wa [wb [? [? ?]]]].
assert (wa = w4). apply H0; auto.
apply comparable_trans with w2. eapply join_comparable2; eauto.
apply comparable_trans with w. eapply join_comparable; eauto.
apply comparable_sym.  eapply join_comparable; eauto.
subst wa; clear H6.
destruct H7 as [w4' [w2' [? [? ?]]]].
assert (w4' = w4). apply H0; auto.
apply comparable_trans with wb. eapply join_comparable; eauto.
apply comparable_sym.  eapply join_comparable; eauto.
subst w4'; clear H7.
assert (w2' = w2). eapply join_canc; try apply join_comm; eauto.
subst w2'; clear H6.
assert (exists y, join w2 y w5).
    destruct (H _ _ _ _ _ H2 H3 (join_joins (join_comm H4))).
    destruct (join_assoc H6 (join_comm H2)) as [y [myH1 myH2]].
    assert (y=w5) by apply (join_canc  (join_comm myH2) (join_comm H3)). subst y.
    exists x. apply (join_comm myH1).
exists wb.
destruct H6 as [y w2_y_w5].
               destruct (join_assoc w2_y_w5 (join_comm H3)) as [x [myH1 myH2]].
               destruct (join_assoc  (join_comm myH1) (join_comm myH2)) as [z [myH3 myH4]].
                                        assert (w5=z) by apply  (join_canc (join_comm H3) (join_comm myH4)). subst w5.
                                        assert (w3=x) by apply (join_canc (join_comm H2) (join_comm myH2)).  subst w3.
                                        destruct (join_assoc myH3 (join_comm myH4)) as [u [myH5 myH6]].
                                        assert (wb=u) by apply (join_eq H4 (join_comm myH5)). subst wb.
               exists y. split. apply (join_comm myH6).
               split. exists w2. exists w4. split. apply (join_comm H4). split; assumption.
               exists w4. exists x; split. apply (join_comm myH1). split; assumption.
Qed.

Lemma ewand_overlap {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
    forall (P Q: pred A),
       superprecise Q ->
       ewand TT (P * Q) * Q |-- ewand TT (P * Q).
Proof.
intros P Q PrecQ.
intros w [w1 [w2 [? [? ?]]]].
destruct H0 as [w5 [w6 [? [_ ?]]]].
destruct H2 as [w3 [w4 [? [? ?]]]].
generalize (PrecQ  _ _ H4 H1); clear H4; intro.
spec H4.
apply comparable_trans with w6.
apply join_comparable with w3; apply join_comm; auto.
apply comparable_trans with w1.
apply comparable_sym; apply join_comparable with w5; apply join_comm; auto.
eapply join_comparable2; eauto.
subst w4.
destruct (CrA _ _ _ _ _ H0 H2) as [[[[a b] c] d] [? [? [? ?]]]].
destruct (join_assoc H5 H) as [f [? ?]].
destruct (join_assoc H7 (join_comm H8)) as [g [? ?]].
generalize (join_self' H10); intro.
subst g.
assert (identity d).
eapply unit_identity; eauto.
assert (b=w2).
eapply join_canc; eauto.
subst b.
assert (f=w2).
eapply join_eq; eauto.
subst f.
clear H11 H10 H7.
assert (c=w1).
 specialize ( H12 c w1). apply H12. auto.
subst c.
clear H9 H5.
destruct (join_assoc H6 H2) as [h [? ?]].
generalize (join_eq H5 H); clear H5; intro; subst h.
exists a; exists w6; split; auto.
split; auto.
exists w3; exists w2; split; auto.
Qed.

Lemma ewand_derives {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P P' Q Q',  P |-- P' -> Q |-- Q' -> ewand P Q |-- ewand P' Q'.
Proof.
intros.
intros w ?.
destruct H1 as [?w [?w [? [? ?]]]].
exists w0; exists w1; split; auto.
Qed.

Lemma ewand_sepcon {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}: forall P Q R,
      (ewand (P * Q) R = ewand P (ewand Q R))%pred.
Proof.
intros; apply pred_ext; intros w ?.
destruct H as [w1 [w2 [? [? ?]]]].
destruct H0 as [w3 [w4 [? [? ?]]]].
exists w3.
destruct (join_assoc (join_comm H0) H) as [wf [? ?]].
exists wf.
split; [|split]; auto.
exists w4. exists w2. split; auto.
destruct H as [w1 [w2 [? [? ?]]]].
destruct H1 as [w3 [w4 [? [? ?]]]].
destruct (join_assoc (join_comm H) (join_comm H1)) as [wf [? ?]].
exists wf. exists w4. split; [|split]; auto.
exists w1; exists w3; split; auto.
Qed.

Lemma ewand_sepcon_assoc {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
  Trip_alg A ->
  forall P Q R: pred A,
      (forall w1 w2 w3, join w1 w2 w3 -> P w3 -> P w1) ->
      (forall w w', comparable w w' -> P w -> R w' -> joins w w') ->
      (ewand TT P) && (ewand TT R) |-- emp ->
     (ewand P (Q * R) = (ewand P Q * R))%pred.
Proof.
intros TRIPLE P Q R ?H Hjoins ?H.
apply pred_ext; intros w ?.
destruct H1 as [w1 [w2 [? [? ?]]]].
destruct H3 as [w3 [w4 [? [? ?]]]].
destruct (CrA _ _ _ _ _ H1 H3) as [[[[? ?] ?] ?] [? [? [? ?]]]].
generalize (H _ _ _ (join_comm H6) H2); intro.
assert (emp a0).
apply H0.
split.
2:{ do 2 econstructor; (split; [|split]). 3: eauto. eauto. auto. }
exists a; exists w1; split; [|split]; eauto.
apply join_unit2_e in H6; auto.
subst a.
apply join_unit1_e in H9; auto.
subst a2.
exists a1; exists w4; split; [|split]; auto.
do 2 econstructor; eauto.
(*****)
destruct H1 as [w1 [wR [? [? ?]]]].
destruct H2 as [wP [wQ [? [? ?]]]].
apply join_comm in H2.
specialize (Hjoins wP wR).
spec Hjoins.
apply comparable_trans with w1; eapply join_comparable2; eauto.
destruct Hjoins as [w6 ?]; auto.
destruct (TRIPLE _ _ _ _ _ _ H1 (join_comm H6) H2) as [wQR ?].
exists wP. exists wQR.
split; [|split]; auto.
destruct (join_assoc H1 j) as [wf [? ?]].
generalize (join_eq H6 (join_comm H7)); clear H6; intros; subst w6.
destruct (join_assoc H7 (join_comm H8)) as [wg [? ?]].
generalize (join_eq H2 (join_comm H6)); clear H6; intros; subst wg.
do 2 econstructor; eauto.
Qed.

Lemma ewand_sepcon2 {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}{DA: Disj_alg A}{CrA: Cross_alg A}{AG: ageable A}{XA: Age_alg A}:
      forall
          R (SP: superprecise R)
          P (H: P = ewand R (R * P))
          Q,
          ewand P (Q * R) |-- ewand P Q * R.
Proof.
intros.
intros w ?.
destruct H0 as [w1 [w34 [? [? [w3 [w4 [? [? ?]]]]]]]].
generalize (crosssplit_wkSplit  _ _ _ _ _ H0 (join_comm H2)); unfold wk_split; intro.
spec H5.
rewrite H in H1.
destruct H1 as [wa [wb [? [? ?]]]].
generalize (SP _ _ H6 H4); clear H4; intro.
spec H4.
apply comparable_trans with w34. apply comparable_trans with w1.
eapply join_comparable2; eauto. eapply join_comparable; eauto.
apply comparable_sym; eapply join_comparable; eauto.
subst wa.
destruct H7 as [wx [wy [? [? ?]]]].
generalize (SP _ _ H7 H6); clear H7; intro.
spec H7.
apply comparable_trans with wb.  eapply join_comparable; eauto.
apply comparable_sym; eapply join_comparable; eauto.
subst wx.
generalize (join_canc (join_comm H1) (join_comm H4)); clear H4; intro.
subst wy.
econstructor; eauto.
destruct H5 as [w5 ?].
exists w5; exists w4; split; [|split]; auto.
exists w1; exists w3; split; [|split]; auto.
destruct (join_assoc H5 (join_comm H0)) as [wf [? ?]].
generalize (join_canc (join_comm H7) H2); clear H7; intro.
subst wf.
auto.
Qed.

Lemma sepcon_andp_prop2 {A} {JA: Join A}{PA: Perm_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall P Q R,  (P * (!!Q && R) = !!Q && (P * R))%pred.
Proof.
intros.
apply pred_ext; intros w ?.
destruct H as [w1 [w2 [? [? [? ?]]]]].
split. apply H1.
exists w1; exists w2; split; [|split]; auto.
destruct H.
destruct H0 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
Qed.

Lemma sepcon_andp_prop1 {A}{JA: Join A}{PA: Perm_alg A}{agA: ageable A}{AgeA: Age_alg A}:
   forall (P: Prop) (Q R: pred A) , ((!! P && Q) * R = !! P && (Q * R))%pred.
Proof.
 intros. rewrite (sepcon_comm). rewrite sepcon_andp_prop2. rewrite sepcon_comm; auto.
Qed.

Lemma distrib_orp_sepcon {A : Type}{JA : Join A}{PA : Perm_alg A}{agA : ageable A}
    {AgeA : Age_alg A}:
  forall (P Q R : pred A), ((P || Q) * R = P * R || Q * R)%pred.
Proof.
 intros. apply pred_ext.
  intros w [w1 [w2 [? [[?|?] ?]]]]; [left|right]; exists w1; exists w2; repeat split; auto.
 intros ? [?|?];  destruct H as [w1 [w2 [? [? ?]]]]; exists w1; exists w2; repeat split; auto.
  left; auto. right; auto.
Qed.

Lemma distrib_orp_sepcon2{A : Type}{JA : Join A}{PA : Perm_alg A}{agA : ageable A}
    {AgeA : Age_alg A}:
  forall (P Q R : pred A),
     (R * (P || Q) = R * P || R * Q)%pred.
Proof.
intros. rewrite !(sepcon_comm R). apply distrib_orp_sepcon.
Qed.

Lemma ewand_conflict {T}{agT:ageable T}{JT: Join T}{PT: Perm_alg T}{ST: Sep_alg T}{AT: Age_alg T}:
       forall P Q R, sepcon P Q |-- FF -> andp P (ewand Q R) |-- FF.
Proof.
 intros. intros w [? [w1 [w2 [? [? ?]]]]].
 specialize (H w2). apply H. exists w; exists w1; repeat split; auto.
Qed.

Lemma ewand_TT_sepcon {T}{agT:ageable T}{JT: Join T}{PT: Perm_alg T}{ST: Sep_alg T}{AT: Age_alg T}:
      forall P Q R,
(P * Q && ewand R (!!True))%pred |-- (P && ewand R (!!True) * (Q && ewand R (!!True)))%pred.
Proof.
intros.
intros w [[w1 [w2 [? [? ?]]]] [w3 [w4 [? [? ?]]]]].
exists w1; exists w2; repeat split; auto.
destruct (join_assoc (join_comm H) (join_comm H2)) as [f [? ?]].
exists w3; exists f; repeat split; auto.
destruct (join_assoc H (join_comm H2)) as [g [? ?]].
exists w3; exists g; repeat split; auto.
Qed.


Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import Compatibility.
Require Import SimThread.

Require Import ReorderStep.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive reorder_fence (or1 ow1:Ordering.t): forall (i2:Instr.t), Prop :=
| reorder_fence_load
    r2 l2 o2
    (ORDR1: Ordering.le or1 Ordering.acqrel)
    (ORDW1: Ordering.le ow1 Ordering.relaxed)
    (ORD2: Ordering.le o2 Ordering.plain \/ Ordering.le Ordering.acqrel o2):
    reorder_fence or1 ow1 (Instr.load r2 l2 o2)
| reorder_fence_store
    l2 v2 o2
    (ORDR1: Ordering.le or1 Ordering.acqrel)
    (ORDW1: Ordering.le ow1 Ordering.relaxed):
    reorder_fence or1 ow1 (Instr.store l2 v2 o2)
| reorder_fence_update
    r2 l2 rmw2 or2 ow2
    (ORDR1: Ordering.le or1 Ordering.acqrel)
    (ORDW1: Ordering.le ow1 Ordering.relaxed)
    (ORDR2: Ordering.le or2 Ordering.plain \/ Ordering.le Ordering.acqrel or2):
    reorder_fence or1 ow1 (Instr.update r2 l2 rmw2 or2 ow2)
.

Inductive sim_fence: forall (st_src:(Language.state lang)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                       (st_tgt:(Language.state lang)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_fence_intro
    or1 ow1 i2 rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    lc2_src sc2_src
    (REORDER: reorder_fence or1 ow1 i2)
    (FENCE: Local.fence_step lc1_src sc1_src or1 ow1 lc2_src sc2_src)
    (LOCAL: sim_local SimPromises.bot lc2_src lc1_tgt):
    sim_fence
      (State.mk rs [Stmt.instr i2; Stmt.instr (Instr.fence or1 ow1)]) lc1_src sc1_src mem1_src
      (State.mk rs [Stmt.instr i2]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_fence_step
      st1_src lc1_src sc0_src mem0_src
      st1_tgt lc1_tgt sc0_tgt mem0_tgt
      (SIM: sim_fence st1_src lc1_src sc0_src mem0_src
                      st1_tgt lc1_tgt sc0_tgt mem0_tgt):
  forall sc1_src sc1_tgt
    mem1_src mem1_tgt
    (SC: TimeMap.le sc1_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (SC_FUTURE_SRC: TimeMap.le sc0_src sc1_src)
    (SC_FUTURE_TGT: TimeMap.le sc0_tgt sc1_tgt)
    (MEM_FUTURE_SRC: Memory.future_weak mem0_src mem1_src)
    (MEM_FUTURE_TGT: Memory.future_weak mem0_tgt mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt),
    _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_fence)
                     st1_src lc1_src sc1_src mem1_src
                     st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii. right.
  exploit future_fence_step; try apply FENCE; eauto; i.
  { inv REORDER; etrans; eauto. }
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv REORDER); ss.
  - (* promise *)
    exploit sim_local_promise; eauto.
    { eapply Local.fence_step_future; eauto. }
    i. des.
    exploit reorder_fence_promise; try apply x0; try apply STEP_SRC; eauto.
    { inv REORDER; ss. }
    i. des.
    esplits; try apply SC; eauto; ss.
    + econs 2. econs 1. econs; eauto.
    + eauto.
    + right. econs; eauto.
  - (* load *)
    guardH ORD2.
    exploit sim_local_read; try exact LOCAL0; try apply SC; eauto; try refl; viewtac.
    { eapply Local.fence_step_future; eauto. }
    i. des.
    exploit reorder_fence_read; try apply x0; try apply STEP_SRC; eauto; try by viewtac. i. des.
    esplits.
    + ss.
    + econs 2; [|econs 1]. econs.
      * econs. econs 2. econs; [|econs 2]; eauto. econs. econs.
      * eauto.
    + econs 2. econs 2. econs; [|econs 5]; eauto. econs. econs.
    + auto.
    + etrans; eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
  - (* update-load *)
    guardH ORDR2.
    exploit sim_local_read; try exact LOCAL0; try apply SC; eauto; try refl; viewtac.
    { eapply Local.fence_step_future; eauto. }
    i. des.
    exploit reorder_fence_read; try apply x0; try apply STEP_SRC; eauto; try by viewtac. i. des.
    esplits.
    + ss.
    + econs 2; [|econs 1]. econs.
      * econs. econs 2. econs; [|econs 2]; eauto. econs. econs. eauto.
      * eauto.
    + econs 2. econs 2. econs; [|econs 5]; eauto. econs. econs.
    + auto.
    + etrans; eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
  - (* store *)
    hexploit sim_local_write_bot; try exact LOCAL1; try apply SC; eauto; try refl; viewtac.
    { eapply Local.fence_step_future; eauto. }
    i. des.
    exploit reorder_fence_write; try apply x0; try apply STEP_SRC; eauto; try by viewtac. i. des.
    esplits.
    + ss.
    + econs 2; [|econs 1]. econs.
      * econs. econs 2. econs; [|econs 3]; eauto. econs. econs.
      * eauto.
    + econs 2. econs 2. econs; [|econs 5]; eauto. econs. econs.
    + auto.
    + etrans; eauto.
    + etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
  - (* update *)
    guardH ORDR2.
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read; try exact LOCAL1; try apply SC; eauto; try refl; viewtac.
    { eapply Local.fence_step_future; eauto. }
    i. des.
    exploit reorder_fence_read; try apply x0; try apply STEP_SRC; eauto; try by viewtac. i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.fence_step_future; eauto. i. des.
    generalize LOCAL3. i. rewrite LOCAL0 in LOCAL3.
    generalize SC0. i. rewrite SC in SC1.
    hexploit sim_local_write_bot; try exact LOCAL2; try apply SC1; eauto; try refl; viewtac. i. des.
    exploit reorder_fence_write; try apply STEP2; try apply STEP_SRC0; eauto; try by viewtac. i. des.
    esplits.
    + ss.
    + econs 2; [|econs 1]. econs.
      * econs. econs 2. econs; [|econs 4]; eauto. econs. econs. eauto.
      * eauto.
    + econs 2. econs 2. econs; [|econs 5]; eauto. econs. econs.
    + auto.
    + etrans; eauto.
    + etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
Qed.

Lemma sim_fence_sim_thread:
  sim_fence <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - right. inv TERMINAL_TGT. inv PR; ss.
  - eapply SimPromises.cap; eauto.
    inv PR. inv FENCE. apply LOCAL.
  - right. esplits; eauto.
    inv PR. inversion FENCE. subst lc2_src. inversion LOCAL. ss.
    apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  - exploit sim_fence_step; try apply PR; try apply SC; eauto. i. des; eauto.
    + right. esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + right. esplits; eauto.
Qed.


Require Import Ascii FunctionApp List Program.Basics String.
Import ListNotations.

Section ui.

  Inductive uiInput :=
  | uiConsoleIn : string -> uiInput
  | uiDecrypted : string -> uiInput.

  Inductive uiOutput :=
  | uiConsoleOut : string -> uiOutput
  | uiEncrypt : string -> uiOutput
  | uiNoop : uiOutput.

  Fixpoint split (sep : ascii) (s : string) : list string :=
    match s with
      | EmptyString => nil
      | String c s' =>
        if ascii_dec c sep then EmptyString :: split sep s'
        else match split sep s' with
               | nil => [String c EmptyString]
               | w :: ws => String c w :: ws
             end
    end.

  Definition newline := "010"%char.

  Definition dump (pws : list (string * string)) : string :=
    fold_right append ""%string
               (map (fun p => (fst p ++ " " ++ snd p ++ String newline "")%string) pws).

  Fixpoint load (s : string) : list (string * string) :=
    flat_map (fun l => match split " " l with
                         | account :: password :: nil => [(account, password)]
                         | _ => nil
                       end)
             (split newline s).

  Definition uiState := list (string * string).

  Open Scope string_scope.

  Definition ui (pws : uiState) (i : uiInput) : (uiOutput * uiState) :=
    match i with
      | uiConsoleIn s =>
        match split " " s with
          | comm :: ls =>
            match string_dec comm "get", ls with
              | left _, account :: nil =>
                match
                  find (fun p => if string_dec account (fst p)
                                 then true else false) pws
                with
                  | None =>
                    (uiConsoleOut "account not found", pws)
                  | Some (_, password) =>
                    (uiConsoleOut password, pws)
                end
              | _, _ =>
                match string_dec comm "set", ls with
                  | left _,  account :: password :: nil =>
                    let pws' :=
                        (account, password)
                          :: filter (fun p => if string_dec account (fst p)
                                              then false else true) pws
                    in (uiEncrypt (dump pws'), pws')

                  | _, _ =>
                    (uiConsoleOut "unrecognized command", pws)
                end
            end
          | _ => (uiConsoleOut "unrecognized command", pws)
        end
      | uiDecrypted s =>
        (uiNoop, load s)
    end.

  Definition uiStateInit : uiState := nil.

End ui.

Section net.

  Inductive netInput :=
  | netReceived : string -> netInput
  | netEncrypted : string -> netInput.

  Inductive netOutput :=
  | netDecrypt : string -> netOutput
  | netSend : string -> netOutput.

  Definition net (i : netInput) :=
    match i with
      | netReceived s => netDecrypt s
      | netEncrypted s => netSend s
    end.

End net.

Section pwMgr.

  Context (world : Type).
  Context (consoleOut : string -> action world).
  Context (send : string -> action world).

  Inductive pwMgrInput :=
  | pwMgrConsoleIn : string -> pwMgrInput
  | pwMgrReceived : string -> pwMgrInput.

  Definition uiOutputDec (out : uiOutput) : {s | out = uiConsoleOut s} + {s | out = uiEncrypt s} + {out = uiNoop}.
    destruct out.
    - left; left; eexists; eauto.
    - left; right; eexists; eauto.
    - right; eauto.
  Defined.

  Definition netOutputDec (out : netOutput) : {s | out = netDecrypt s} + {s | out = netSend s}.
    destruct out.
    - left; eexists; eauto.
    - right; eexists; eauto.
  Defined.

  Ltac unfold_all :=
    repeat match goal with
             | H := _ |- _ => unfold H in *; clear H
           end.

  Lemma ui_ConsoleIn_not_Noop st s : fst (ui st (uiConsoleIn s)) <> uiNoop.
  Proof.
    intros H.
    unfold ui in *.
    destruct (split " ") as [ | comm ls].
    { simpl in *; discriminate. }
    {
      destruct (string_dec comm "get").
      {
        destruct ls.
        { destruct (string_dec comm "set"); simpl in *; discriminate. }
        destruct ls.
        { destruct (find (fun p => if string_dec s0 (fst p) then true else false) st); try destruct p; simpl in *; discriminate. }
        destruct (string_dec comm "set").
        { destruct ls; simpl in *; discriminate. }
        simpl; discriminate.
      }
      {
        destruct (string_dec comm "set").
        {
          destruct ls.
          { simpl in *; discriminate. }
          destruct ls.
          { simpl in *; discriminate. }
          { destruct ls; simpl in *; discriminate. }
        }
        { simpl in *; discriminate. }
      }
    }
  Qed.

  CoFixpoint pwMgrLoop (ui_st : uiState) : process pwMgrInput world.
  refine
    (Step (fun i =>
             match i with
               | pwMgrConsoleIn s =>
                 let r := ui ui_st (uiConsoleIn s) in
                 let a := fst r in
                 let ui_st' := snd r in
                 match uiOutputDec a with
                   | inleft (inl (exist s _)) => (consoleOut s, pwMgrLoop ui_st')
                   | inleft (inr (exist s _)) =>
                     (* TODO: crypto *)
                     let a := net (netEncrypted s) in
                     match netOutputDec a with
                       | inr (exist s _) => (send s, pwMgrLoop ui_st')
                       | _ => _
                     end
                   | _ => _
                 end
               | pwMgrReceived s =>
                 let a := net (netReceived s) in
                 match netOutputDec a with
                   | inl (exist s _) =>
                     (* TODO: crypto *)
                     let (_, ui_st') := ui ui_st (uiDecrypted s) in (id, pwMgrLoop ui_st')
                   | _ => _
                 end
             end)).
  - unfold_all.
    simpl in s3.
    destruct s3; discriminate.
  - unfold_all.
    simpl.
    contradict e; eapply ui_ConsoleIn_not_Noop.
  - unfold_all.
    simpl in s0.
    destruct s0; discriminate.
  Defined.

  Definition pwMgr := pwMgrLoop uiStateInit.

End pwMgr.

Require Import ExtrOcamlBasic ExtrOcamlString.
Extraction "ExamplePwMgr2" pwMgr.


Require Import ZArith String List Bool.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Data.Map.FMapAList.
Require Import ExtLib.Data.Strings.
Require Import ExtLib.ExtLib.
Require Import ExtLib.Programming.Show.
Require Import CoqCompile.Lambda.
Require Import CoqCompile.CpsK CoqCompile.CpsKExamples.
Require Import CoqCompile.LLVM.
Require Import CoqCompile.Parse.
Require Import CoqCompile.TraceMonad.
Require Import CoqCompile.Compile.

Set Implicit Arguments.
Set Strict Implicit.

Module CompileTest.
  Definition identity : string := "(define ident (lambda (x) ident))"%string.

  Definition e_ident : Lambda.exp :=
    Eval compute in
      match Parse.parse_topdecls identity with
        | inl _ => Lambda.Var_e (Env.wrapVar ""%string)
        | inr o => o
      end.

  Definition hello_world := "
(define __ (lambda (_) __))

(define ret (lambdas (monad x)
  (match monad
     ((Build_Monad ret0 bind0) (@ ret0 __ x)))))

(define bind (lambdas (monad x x0)
  (match monad
     ((Build_Monad ret0 bind0) (@ bind0 __ x __ x0)))))

(define monoid_plus (lambda (m)
  (match m
     ((Build_Monoid monoid_plus0 monoid_unit0) monoid_plus0))))

(define monoid_unit (lambda (m)
  (match m
     ((Build_Monoid monoid_plus0 monoid_unit0) monoid_unit0))))

(define inject (lambda (injection) injection))

(define chr_newline `(Ascii ,`(False) ,`(True) ,`(False) ,`(True) ,`(False)
  ,`(False) ,`(False) ,`(False)))

(define show_mon (lambda (showScheme)
  (match showScheme
     ((Build_ShowScheme show_mon0 show_inj0) show_mon0))))

(define show_inj (lambda (showScheme)
  (match showScheme
     ((Build_ShowScheme show_mon0 show_inj0) show_inj0))))

(define runShow (lambdas (m m0) (@ m0 __ (show_inj m) (show_mon m))))

(define show (lambdas (show0 x x0 x1) (@ show0 x __ x0 x1)))

(define empty (lambdas (x m) (monoid_unit m)))

(define cat (lambdas (a b i m) (@ monoid_plus m (@ a __ i m) (@ b __ i m))))

(define injection_ascii_showM (lambdas (v i x) (i v)))

(define show_exact (lambdas (s x x0)
  (match s
     ((EmptyString) (@ empty x x0))
     ((String a s~)
       (@ cat (@ inject (lambdas (x1 _) (injection_ascii_showM x1)) a)
         (lambda (_) (show_exact s~)) x x0)))))

(define _inject_char (lambdas (x x0 x1)
  (@ inject (lambdas (x2 _) (injection_ascii_showM x2)) x __ x0 x1)))

(define ascii_Show (lambdas (a x x0)
  (@ cat (lambda (_)
    (@ cat (lambda (_)
      (_inject_char `(Ascii ,`(True) ,`(True) ,`(True) ,`(False) ,`(False)
        ,`(True) ,`(False) ,`(False)))) (lambda (_) (_inject_char a))))
    (lambda (_)
    (_inject_char `(Ascii ,`(True) ,`(True) ,`(True) ,`(False) ,`(False)
      ,`(True) ,`(False) ,`(False)))) x x0)))

(define iO_bind io_bind)

(define iO_ret io_ret)

(define iO_printChar io_printChar)

(define monad_IO `(Build_Monad ,(lambda (_) iO_ret) ,(lambdas (_ x _)
  (iO_bind x))))

(define showScheme_IO `(Build_ShowScheme ,`(Build_Monoid ,(lambdas (x y)
  (@ bind monad_IO x (lambda (x0) y))) ,(@ ret monad_IO `(Tt)))
  ,iO_printChar))

(define main
  (@ runShow showScheme_IO (lambda (_)
    (@ cat (lambda (_)
      (show_exact `(String ,`(Ascii ,`(False) ,`(False) ,`(False) ,`(True)
        ,`(False) ,`(False) ,`(True) ,`(False)) ,`(String ,`(Ascii ,`(True)
        ,`(False) ,`(False) ,`(False) ,`(False) ,`(True) ,`(False) ,`(False))
        ,`(EmptyString))))) (lambda (_)
      (@ show (lambdas (x _) (ascii_Show x)) chr_newline))))))"%string.

  Definition e_hello : Lambda.exp :=
    Eval vm_compute in
      match Parse.parse_topdecls hello_world with
        | inl _ => Lambda.Var_e (Env.wrapVar ""%string)
        | inr o => o
      end.

(*
  Definition fact :=
  "(define plus (lambdas (n m)
     (match n
       ((O) m)
       ((S p) `(S ,(@ plus p m))))))

   (define mult (lambdas (n m)
     (match n
       ((O) `(O))
       ((S p) (@ plus m (@ mult p m))))))

   (define fact (lambda (n)
     (match n
       ((O) `(S ,`(O)))
       ((S n~) (@ mult n (fact n~))))))"%string.

  Definition e_fact : Lambda.exp :=
    Eval vm_compute in
      match Parse.parse_topdecls fact with
        | inl _ => Lambda.Var_e (Env.wrapVar ""%string)
        | inr o => o
      end.

  Definition broke :=
   "(define __ (lambda (_) __))

(define ret (lambdas (monad x)
  (match monad
     ((Build_Monad ret0 bind0) (@ ret0 __ x)))))

(define bind (lambdas (monad x x0)
  (match monad
     ((Build_Monad ret0 bind0) (@ bind0 __ x __ x0)))))

(define monoid_plus (lambda (m)
  (match m
     ((Build_Monoid monoid_plus0 monoid_unit0) monoid_plus0))))

(define monoid_unit (lambda (m)
  (match m
     ((Build_Monoid monoid_plus0 monoid_unit0) monoid_unit0))))

(define inject (lambda (injection) injection))

(define chr_newline `(Ascii ,`(False) ,`(True) ,`(False) ,`(True) ,`(False)
  ,`(False) ,`(False) ,`(False)))

(define show_mon (lambda (showScheme)
  (match showScheme
     ((Build_ShowScheme show_mon0 show_inj0) show_mon0))))

(define show_inj (lambda (showScheme)
  (match showScheme
     ((Build_ShowScheme show_mon0 show_inj0) show_inj0))))

(define runShow (lambdas (m m0) (@ m0 __ (show_inj m) (show_mon m))))

(define show (lambdas (show0 x x0 x1) (@ show0 x __ x0 x1)))

(define empty (lambdas (x m) (monoid_unit m)))

(define cat (lambdas (a b i m) (@ monoid_plus m (@ a __ i m) (@ b __ i m))))

(define injection_ascii_showM (lambdas (v i x) (i v)))

(define show_exact (lambdas (s x x0)
  (match s
     ((EmptyString) (@ empty x x0))
     ((String a s~)
       (@ cat (@ inject (lambdas (x1 _) (injection_ascii_showM x1)) a)
         (lambda (_) (show_exact s~)) x x0)))))

(define _inject_char (lambdas (x x0 x1)
  (@ inject (lambdas (x2 _) (injection_ascii_showM x2)) x __ x0 x1)))

(define ascii_Show (lambdas (a x x0)
  (@ cat (lambda (_)
    (@ cat (lambda (_)
      (_inject_char `(Ascii ,`(True) ,`(True) ,`(True) ,`(False) ,`(False)
        ,`(True) ,`(False) ,`(False)))) (lambda (_) (_inject_char a))))
    (lambda (_)
    (_inject_char `(Ascii ,`(True) ,`(True) ,`(True) ,`(False) ,`(False)
      ,`(True) ,`(False) ,`(False)))) x x0)))

(define iO_bind io_bind)

(define iO_ret io_ret)

(define iO_printChar io_printChar)

(define monad_IO `(Build_Monad ,(lambda (_) iO_ret) ,(lambdas (_ x _)
  (iO_bind x))))

(define showScheme_IO `(Build_ShowScheme ,`(Build_Monoid ,(lambdas (x y)
  (@ bind monad_IO x (lambda (x0) y))) ,(@ ret monad_IO `(Tt)))
  ,iO_printChar))

(define main
  (@ runShow showScheme_IO (lambda (_)
    (@ cat (lambda (_)
      (show_exact `(String ,`(Ascii ,`(False) ,`(False) ,`(False) ,`(True)
        ,`(False) ,`(False) ,`(True) ,`(False)) ,`(String ,`(Ascii ,`(True)
        ,`(False) ,`(True) ,`(False) ,`(False) ,`(True) ,`(True) ,`(False))
        ,`(String ,`(Ascii ,`(False) ,`(False) ,`(True) ,`(True) ,`(False)
        ,`(True) ,`(True) ,`(False)) ,`(String ,`(Ascii ,`(False) ,`(False)
        ,`(True) ,`(True) ,`(False) ,`(True) ,`(True) ,`(False)) ,`(String
        ,`(Ascii ,`(True) ,`(True) ,`(True) ,`(True) ,`(False) ,`(True)
        ,`(True) ,`(False)) ,`(String ,`(Ascii ,`(False) ,`(False) ,`(False)
        ,`(False) ,`(False) ,`(True) ,`(False) ,`(False)) ,`(String ,`(Ascii
        ,`(True) ,`(True) ,`(True) ,`(False) ,`(True) ,`(True) ,`(True)
        ,`(False)) ,`(String ,`(Ascii ,`(True) ,`(True) ,`(True) ,`(True)
        ,`(False) ,`(True) ,`(True) ,`(False)) ,`(String ,`(Ascii ,`(False)
        ,`(True) ,`(False) ,`(False) ,`(True) ,`(True) ,`(True) ,`(False))
        ,`(String ,`(Ascii ,`(False) ,`(False) ,`(True) ,`(True) ,`(False)
        ,`(True) ,`(True) ,`(False)) ,`(String ,`(Ascii ,`(False) ,`(False)
        ,`(True) ,`(False) ,`(False) ,`(True) ,`(True) ,`(False)) ,`(String
        ,`(Ascii ,`(True) ,`(False) ,`(False) ,`(False) ,`(False) ,`(True)
        ,`(False) ,`(False)) ,`(EmptyString))))))))))))))) (lambda (_)
      (@ show (lambdas (x _) (ascii_Show x)) chr_newline))))))"%string.

  Definition e_broke : Lambda.exp :=
    Eval vm_compute in
      match Parse.parse_topdecls broke with
        | inl _ => Lambda.Var_e (Env.wrapVar ""%string)
        | inr o => o
      end.
*)

  Definition c_hello : CPSK.exp :=
    Eval vm_compute in
      CpsKConvert.CPS_io e_hello.

  Require Import ExtLib.Data.Monads.EitherMonad.

  Definition cc_hello : string + (list CPSK.decl * CPSK.exp) :=
    Eval vm_compute in
      CloConvK.ClosureConvert.cloconv_exp c_hello.

  Definition low_hello : string + Low.program :=
    Eval vm_compute in
      match cc_hello as cc_hello return match cc_hello with
                                          | inl _ => unit
                                          | inr _ => string + Low.program
                                        end
        with
        | inl _ => tt
        | inr (ds, main) =>
          CpsK2Low.cpsk2low (sum string) ds main
      end.
(* Stack overflow
  Eval vm_compute in to_string low_hello.
*)

(*
  Eval vm_compute in
    Compile.lamToCPSIO e_hello.

  Eval vm_compute in
    Compile.lamToClosIO e_hello.

  Eval compute in
    Compile.lamToLowIO e_hello.
*)
(*
  (** TODO: This is stack overflowing **)
  Eval vm_compute in
    match Compile.runM (Compile.topCompile 8 Compile.Opt.O0 false e_fact) with
      | (inl err, t) => (err, t)
      | (inr mod', t) => (to_string mod', t)
    end.
*)
End CompileTest.