Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import compcert.common.AST. (* For ident. *)
Require Import liblayers.compcertx.ErrorMonad.
Require Import liblayers.lib.OptionMonad.
Require Import liblayers.lib.Decision.
Require Import liblayers.logic.PseudoJoin.
Require Import liblayers.logic.OptionOrders.
Require Import liblayers.logic.PTrees.
Require Import liblayers.logic.PTreeModules.
Require Export liblayers.logic.Layers.
Require Export liblayers.logic.Primitives.
Require Import liblayers.logic.GlobalVars.

(** * Construction of layers *)

Definition ptree_layer {layerdata} primsem V (D: layerdata) :=
  (PTree.t (res (primsem D)) * PTree.t (res V))%type.

Section PTREE_LAYER_INSTANCES.
  Context {layerdata simrel} `{Hprim: Primitives layerdata simrel}.
  Context {V: Type}.
  Local Existing Instance ptree_mapsto.

  Definition ptree_layer_conflict i :=
    MSG "duplicate symbol in layer: " :: CTX i :: nil.

  (** ** Querying functions *)

  (** The functions [ptree_layer_primitive] and [ptree_layer_globvar]
    retreive the primitive semantics or global variable definition
    associated with an identifier in a given layer. Because we want
    them to be monotonic, we need to distinguish between two kinds of
    failures.

    Consider [ptree_layer_primitive]. If the layer does not associate
    a primitive semantics to identifier [i], which is to say it is
    undefined at [i], or it is defined a a variable definition, then
    [ptree_layer_primitive] return [OK None]. We can interpret this
    as a successful determination that there is no primitive semantics
    at [i]. On the other hand, is the layer maps [i] to [anything]
    (the special "overdefined" value), then all bets are off: a
    smaller layer may very well contain a primitive
    definition. Consequently, [ptree_layer_primitive] returns [Error]
    to indicate failure to make any determination at all.

    The same principle applies for [ptree_layer_globvar]. *)

  Definition ptree_layer_primitive {D} i (L: ptree_layer primsem V D) :=
    option_res_flip ((fst L) ! i).

  Definition ptree_layer_globalvar {D} i (L: ptree_layer primsem V D) :=
    option_res_flip ((snd L) ! i).

  Local Instance ptree_layer_sim_op:
    Sim simrel (ptree_layer primsem V) :=
    {
      simRR D1 D2 R :=
        (ptree_rel (option_le (res_le (sim R))) *
         ptree_rel (option_le (res_le eq)))%rel
    }.

  Local Existing Instance cat_sim_cat.

  Local Instance ptree_layer_rg_sim_prf:
    CategorySim layerdata simrel (ptree_layer primsem V).
  Proof.
    split; simpl; try typeclasses eauto.
    - rauto.
  Qed.

  Existing Instance ptree_emptyset.
  Existing Instance ptree_oplus.
  Existing Instance ptree_mapsto.

  Local Instance ptree_prim_oplus D: Oplus (option (res (primsem D))) :=
    {
      oplus p1 p2 :=
        match p1, p2 with
          | _, None => p1
          | None, _ => p2
          | Some (Error msg), _ => Some (Error msg)
          | _, Some (Error msg) => Some (Error msg)
          | Some (OK σ1), Some (OK σ2) => Some (OK (σ1 ⊕ σ2))
        end
    }.

  Context {gv_ops: GlobalVarsOps V}.

  Local Instance ptree_layer_ops:
    LayerOps ident primsem V (ptree_layer primsem V) :=
    {
      layer_empty D := {| emptyset := (PTree.empty _, PTree.empty _) |};
      layer_oplus D := {| oplus L1 L2 := (fst L1 ⊕ fst L2, snd L1 ⊕ snd L2) |};
      layer_mapsto_primitive D := {| mapsto i σ := (i ↦ OK σ, ∅) |};
      layer_mapsto_globalvar D := {| mapsto i τ := (∅, i ↦ OK τ) |};
      get_layer_primitive := @ptree_layer_primitive;
      get_layer_globalvar := @ptree_layer_globalvar;
      layers_disjoint D1 D2 L1 L2 :=
        ptree_disjoint (fst L1) (fst L2) /\
        ptree_disjoint (snd L1) (snd L2);
      layer_wf D L :=
        True
    }.
  Proof.
  * intros.
    unfold ptree_layer_primitive.
    refine (_
              (ptree_forall_decision_strong
                 (fun _ def => P (option_res_flip (Some def)))
                 (P (OK None))
                 _ _ (fst L))).
    apply decide_rewrite.
    split.
    + intros J i.
      generalize (J i).
      destruct ((fst L) ! i); simpl; monad_norm; auto.
    + intros J i.
      generalize (J i).
      destruct ((fst L) ! i); simpl; monad_norm; auto.
  * intros D P DP M.
    refine (_
              (ptree_forall_decision
                 (fun i _ => ptree_layer_primitive i M = OK None \/ P i)
                 _ (fst M))).
    + apply decide_rewrite.
      unfold ptree_layer_primitive.
      unfold ptree_forall.
      split.
      - intros J i.
        destruct ((fst M) ! i) eqn:HM; try (compute; congruence).
        rewrite <- HM.
        intro.
        destruct (J _ _ HM); try contradiction.
        assumption.
      - intros.
        destruct (decide (option_res_flip (fst M) ! i = OK None)); auto.
  * intros.
    unfold ptree_layer_globalvar.
    refine (_
              (ptree_forall_decision_strong
                 (fun _ def => P (option_res_flip (Some def)))
                 (P (OK None))
                 _ _ (snd L))).
    apply decide_rewrite.
    split.
    + intros J i.
      generalize (J i).
      destruct ((snd L) ! i); simpl; monad_norm; auto.
    + intros J i.
      generalize (J i).
      destruct ((snd L) ! i); simpl; monad_norm; auto.
  * intros D P DP M.
    refine (_
              (ptree_forall_decision
                 (fun i _ => ptree_layer_globalvar i M = OK None \/ P i)
                 _ (snd M))).
    + apply decide_rewrite.
      unfold ptree_layer_globalvar.
      unfold ptree_forall.
      split.
      - intros J i.
        destruct ((snd M) ! i) eqn:HM; try (compute; congruence).
        rewrite <- HM.
        intro.
        destruct (J _ _ HM); try contradiction.
        assumption.
      - intros.
        destruct (decide (option_res_flip (snd M) ! i = OK None)); auto.
  Defined.

  Arguments fmap : simpl never.

  Global Instance ptree_layer_primitive_monotonic:
    Monotonic
      (@ptree_layer_primitive)
      (forallr R, - ==> sim R ++> res_le (option_le (sim R))).
  Proof.
    unfold ptree_layer_primitive.
    intros D1 D2 R i L1 L2 HL.
    solve_monotonic.
  Qed.

  Global Instance ptree_layer_globalvar_monotonic:
    Monotonic
      (@ptree_layer_globalvar)
      (forallr R, - ==> sim R ++> res_le (option_le eq)).
  Proof.
    unfold ptree_layer_globalvar.
    intros D1 D2 R i L1 L2 HL.
    solve_monotonic.
  Qed.

  Local Opaque PTree.combine.

  (** Note: because we have to define our own instance of [Oplus] here
    to be used with ptrees, rather than use [prim_oplus], we don't
    benefit from the [SimJoin] proof in [Primitives]. *)

  Local Instance:
    SimJoin layerdata simrel (ptree_layer primsem V).
  Proof.
    split.
    - split; simpl.
      + intros i.
        rewrite !PTree.gcombine by reflexivity.
        destruct ((fst x) ! i) as [[|]|]; repeat constructor;
        destruct ((fst y) ! i) as [[|]|]; repeat constructor.
        * eapply hlub_ub_l; eauto.
        * reflexivity.
      + intros i.
        rewrite !PTree.gcombine by reflexivity.
        exact (oplus_le_left ((snd x) ! i) ((snd y) ! i)).
    - split; simpl.
      + intros i.
        rewrite !PTree.gcombine by reflexivity.
        destruct ((fst x) ! i) as [[|]|]; repeat constructor;
        destruct ((fst y) ! i) as [[|]|]; repeat constructor.
        * eapply hlub_ub_r; eauto.
        * reflexivity.
      + intros i.
        rewrite !PTree.gcombine by reflexivity.
        rewrite option_res_globalvar_oplus_comm.
        exact (oplus_le_left ((snd y) ! i) ((snd x) ! i)).
    - intros v' e t Hx Hy; simpl.
      split; simpl.
      + intros i.
        rewrite !PTree.gcombine by reflexivity.
        destruct Hx as [Hx _]; specialize (Hx i).
        destruct Hy as [Hy _]; specialize (Hy i).
        revert Hx Hy.
        generalize ((fst x) ! i), ((fst y) ! i), ((fst t) ! i).
        clear x y t.
        intros x y t Hx Hy.
        destruct Hx as [t | _ _ [x t Hx | msg x]].
        * destruct y; assumption.
        * inversion Hy; clear Hy; subst; repeat constructor; eauto.
          inversion H1; clear H1; subst; repeat constructor; eauto.
          eapply hlub_intro; eauto.
        * destruct x; inversion Hy; repeat constructor.
          destruct x; repeat constructor.
      + intros i.
        rewrite !PTree.gcombine by reflexivity.
        destruct Hx as [_ Hx]; specialize (Hx i).
        destruct Hy as [_ Hy]; specialize (Hy i).
        apply option_res_globalvar_lub; auto.
  Qed.

  Global Instance ptree_layer_lb D1 D2 R:
    LowerBound (A := ptree_layer primsem V D1) (simRR D1 D2 R) (∅, ∅).
  Proof.
    intros L2.
    constructor; apply lower_bound.
  Qed.

  Lemma option_fold {A} (o: option A):
    match o with
      | Some x => Some x
      | None => None
    end = o.
  Proof.
    destruct o; reflexivity.
  Qed.

  Local Instance ptree_layer_prf:
    Layers ident primsem V (ptree_layer primsem V).
  Proof.
    split.
    * typeclasses eauto.
    * typeclasses eauto.
    * typeclasses eauto.

    * intros.
      simpl.
      solve_monotonic.

    * intros D i.
      simpl.
      unfold ptree_layer_primitive; simpl.
      rewrite PTree.gempty.
      reflexivity.
    * intros D i σ.
      simpl.
      unfold ptree_layer_primitive; simpl.
      rewrite PTree.gss.
      reflexivity.
    * intros D i j σ Hij.
      simpl.
      unfold ptree_layer_primitive; simpl.
      rewrite PTree.gso by assumption.
      rewrite PTree.gempty.
      reflexivity.
    * intros D i j τ.
      simpl.
      unfold ptree_layer_primitive; simpl.
      rewrite PTree.gempty.
      reflexivity.
    * intros D i L1 L2.
      simpl.
      unfold ptree_layer_primitive; simpl.
      rewrite PTree.gcombine by reflexivity.
      destruct ((fst L1) ! i) as [[σ1|]|];
      destruct ((fst L2) ! i) as [[σ2|]|];
      simpl;
      monad_norm;
      simpl;
      solve_monotonic.
    * typeclasses eauto.

    * intros D i.
      simpl.
      unfold ptree_layer_globalvar.
      rewrite PTree.gempty.
      reflexivity.
    * simpl.
      intros D i τ.
      unfold ptree_layer_globalvar; simpl.
      rewrite PTree.gss.
      reflexivity.
    * simpl.
      intros D i j τ Hij.
      unfold ptree_layer_globalvar; simpl.
      rewrite PTree.gso by assumption.
      rewrite PTree.gempty.
      reflexivity.
    * simpl.
      intros D i j τ.
      unfold ptree_layer_globalvar; simpl.
      rewrite PTree.gempty.
      reflexivity.
    * simpl.
      intros D i L1 L2.
      unfold ptree_layer_globalvar; simpl.
      rewrite PTree.gcombine by reflexivity.
      destruct ((snd L1) ! i) as [[τ1|]|];
      destruct ((snd L2) ! i) as [[τ2|]|];
      simpl;
      monad_norm;
      simpl;
      solve_monotonic.
    * typeclasses eauto.

    * intros D1 D2 L.
      split; intros i xi; simpl; rewrite PTree.gempty; discriminate.
    * intros D1 D2 L1 L2; simpl; destruct 1; eauto using ptree_disjoint_sym.
    * intros D1 D2 L1 L21 L22. simpl.
      destruct 1.
      destruct 1.
      auto using ptree_disjoint_combine.
    * intros D1 D2 i1 i2 σ1 σ2 H.
      simpl.
      unfold ptree_disjoint, ptree_forall.
      split; intros i a.
      + repeat rewrite PTree.gsspec.
        destruct (Coqlib.peq i i1); try (rewrite PTree.gempty; congruence).
        destruct (Coqlib.peq i i2); try (rewrite PTree.gempty; congruence).
        congruence.
      + rewrite PTree.gempty; congruence.
    * intros D1 D2 i1 i2 σ1 σ2 H.
      simpl.
      unfold ptree_disjoint, ptree_forall.
      split; intros i a.
      + intros _. apply PTree.gempty.
      + rewrite PTree.gempty. congruence.
    * intros D1 D2 i1 i2 σ1 σ2 H.
      simpl.
      unfold ptree_disjoint, ptree_forall.
      split; intros i a.
      + rewrite PTree.gempty; congruence.
      + repeat rewrite PTree.gsspec.
        destruct (Coqlib.peq i i1); try (rewrite PTree.gempty; congruence).
        destruct (Coqlib.peq i i2); try (rewrite PTree.gempty; congruence).
        congruence.

    * intros D D' R [Lp Lv] [L1p L1v] [L2p L2v] [HLL2p HLL2v] [Hp Hv].
      Local Opaque option_res_oplus_op.
      constructor; simpl in *.
      + intros i.
        specialize (Hp i).
        specialize (HLL2p i); simpl in *.
        destruct (Lp ! i) as [σ|]; repeat constructor.
        specialize (HLL2p σ eq_refl).
        rewrite PTree.gcombine in Hp by reflexivity.
        rewrite HLL2p in Hp.
        destruct (L1p ! i) as [[|]|];
        assumption.
      + intros i.
        specialize (Hv i).
        specialize (HLL2v i); simpl in *.
        destruct (Lv ! i) as [τ|]; repeat constructor.
        specialize (HLL2v τ eq_refl).
        rewrite PTree.gcombine in Hv by reflexivity.
        rewrite HLL2v in Hv.
        destruct (L1v ! i) as [[|]|];
        assumption.
    * intros i D L1 L2 [Ldisj _].
      simpl in *.
      specialize (Ldisj i).
      unfold ptree_layer_primitive.
      simpl in *.
      rewrite !PTree.gcombine by reflexivity.
      destruct ((fst L1) ! i).
      + specialize (Ldisj _ eq_refl).
        rewrite Ldisj.
        destruct r; eauto.
      + destruct ((fst L2) ! i); eauto.
    * intros i D L1 L2 [_ Ldisj].
      simpl in *.
      specialize (Ldisj i).
      unfold ptree_layer_globalvar.
      simpl in *.
      rewrite !PTree.gcombine by reflexivity.
      destruct ((snd L1) ! i).
      + specialize (Ldisj _ eq_refl).
        rewrite Ldisj.
        autorewrite with option_res_globalvar.
        auto.
      + autorewrite with option_res_globalvar.
        auto.

    * tauto.
  Qed.

  (** * Additional properties *)

  Lemma ptree_layer_pointwise_sim D1 D2 (R: simrel D1 D2) L1 L2:
    (forall i, res_le (option_le (sim R))
                      (get_layer_primitive i L1)
                      (get_layer_primitive i L2)) ->
    (forall i, res_le (option_le eq)
                      (get_layer_globalvar i L1)
                      (get_layer_globalvar i L2)) ->
    sim R L1 L2.
  Proof.
    intros Hp Hv.
    destruct L1 as [L1p L1v], L2 as [L2p L2v].
    simpl in *.
    unfold ptree_layer_primitive, ptree_layer_globalvar in *.
    constructor; simpl in *;
    intros i; apply option_res_le_flip; auto.
  Qed.

  Lemma ptree_layer_sim_pointwise D1 D2 R L1 L2:
    simRR D1 D2 R L1 L2 ->
    (forall i, res_le (option_le (sim R))
                      (get_layer_primitive i L1)
                      (get_layer_primitive i L2)) /\
    (forall i, res_le (option_le eq)
                      (get_layer_globalvar i L1)
                      (get_layer_globalvar i L2)).
  Proof.
    intros H.
    destruct H as [Hp Hv].
    split; intros i; apply option_res_le_flip; eauto.
  Qed.
End PTREE_LAYER_INSTANCES.

(** Now, we can forget how [ptree_layer] is defined, and only access
  it through the interfaces above. This is necessary, to avoid
  instances from [PTree.v] to sneak in when using [ptree_layer]s.
  But it makes sense anyway. *)
Global Opaque ptree_layer.
Global Opaque ptree_layer_ops.


Require Import RuntimeDefinitions.
Require Import AppendixE.

Definition mem_range := (NatMap.add 1 (enclave_address_and_data (address 3 0) 0) (NatMap.add 3 (enclave_address_and_data (address 2 0) 0) (NatMap.add 5 (enclave_address_and_data (address 0 0) 0) (NatMap.empty enclave_memory_range_value)))).
Definition E := enclave_state_value (enclave_ID_active 3) mem_range.
Definition D0 := (NatMap.add 0 (data_value 0) (NatMap.add 1 (data_value 0) (NatMap.add 2 (data_value 0) (NatMap.add 3 (data_value 0) (NatMap.empty data))))).
Definition D1 := (NatMap.add 0 (data_value 0) (NatMap.add 1 (data_value 1) (NatMap.add 2 (data_value 0) (NatMap.add 3 (data_value 0) (NatMap.empty data))))).
Definition mu := (NatMap.add 0 D0 (NatMap.add 1 D1 (NatMap.add 2 D1 (NatMap.add 3 D0 (NatMap.empty data_block))))).

(* Enclave Creation *)
(* PASS *)
Compute (enclave_creation E mu 2 (address 0 0) 4).
Compute (enclave_creation E mu 2 (address 0 0) 5).
Compute (enclave_creation E mu 2 (address 1 2) 3).
Compute (enclave_creation E mu 2 (address 0 0) 0).
Compute (enclave_creation E mu 2 (address 1 1) 0).
(* FAIL *)
Compute (enclave_creation E mu 2 (address 0 0) 6).
Compute (enclave_creation E mu 3 (address 3 0) 4).
Compute (enclave_creation E mu 2 (address 1 2) 4).

(* Active Enclave Update *)
(* PASS *)
Compute (active_enclave_update E enclave_ID_inactive).
Compute (active_enclave_update E (enclave_ID_active 1)).
(* FAIL *)
Compute (active_enclave_update E (enclave_ID_active 2)).

(* Enclave Elimination *)
Compute (enclave_elimination (enclave_state_value (enclave_ID_inactive)
  (NatMap.add 1 (enclave_address_and_data (address 0 0) 5) (NatMap.empty enclave_memory_range_value))) (1)).
Compute (enclave_elimination (enclave_state_value (enclave_ID_inactive)
  (NatMap.add 2 (enclave_address_and_data (address 0 0) 3)
  (NatMap.add 3 (enclave_address_and_data (address 0 0) 7)
  (NatMap.add 4 (enclave_address_and_data (address 0 0) 11) (NatMap.empty enclave_memory_range_value))))) (1)).
Compute (enclave_elimination (enclave_state_value (enclave_ID_inactive)
  (NatMap.add 2 (enclave_address_and_data (address 0 0) 3)
  (NatMap.add 3 (enclave_address_and_data (address 0 0) 7)
  (NatMap.add 4 (enclave_address_and_data (address 0 0) 11) (NatMap.empty enclave_memory_range_value))))) (4)).


Require Import Coq.Sets.Ensembles.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Prod.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretationDefinitions.
Require Import Fiat.Common.
Require Import Fiat.Common.Instances.
Require Import Fiat.Common.BoolFacts.

Set Implicit Arguments.

Lemma simplify_bool_expr a b (Himpl : is_true a -> is_true b)
  : (a || (b && negb a))%bool = b.
Proof.
  destruct a, b; try reflexivity; simpl; symmetry; apply Himpl; reflexivity.
Qed.

Lemma simplify_bool_expr' a b (Himpl : is_true a -> is_true b)
  : (a || (b && negb a))%bool -> b.
Proof. rewrite simplify_bool_expr by assumption; trivial. Qed.

Section aidata.
  Context {Char : Type} {T T0 T1}
          {fpldata : grammar_fixedpoint_lattice_data T}
          {fpldata0 : grammar_fixedpoint_lattice_data T0}
          {fpldata1 : grammar_fixedpoint_lattice_data T1}.

  Definition prod_on_terminal
             (on_terminal0 : (Char -> bool) -> lattice_for T0)
             (on_terminal1 : (Char -> bool) -> lattice_for T1)
    : (Char -> bool) -> lattice_for (lattice_for T0 * lattice_for T1)
    := fun P => constant (on_terminal0 P, on_terminal1 P).

  Definition prod_on_nil_production
             (on_nil_production0 : lattice_for T0)
             (on_nil_production1 : lattice_for T1)
    : lattice_for (lattice_for T0 * lattice_for T1)
    := constant (on_nil_production0, on_nil_production1).

  Definition prod_precombine_production_dep
             (precombine_production0 : T0 -> T0 -> lattice_for T0)
             (precombine_production1 : lattice_for T0 -> lattice_for T0 -> T1 -> T1 -> lattice_for T1)
    : (lattice_for T0 * lattice_for T1) -> (lattice_for T0 * lattice_for T1) -> lattice_for (lattice_for T0 * lattice_for T1)
    := fun x y => constant (lattice_for_combine_production precombine_production0 (fst x) (fst y),
                            lattice_for_combine_production (precombine_production1 (fst x) (fst y)) (snd x) (snd y)).

  Definition prod_precombine_production_nondep
             (precombine_production0 : T0 -> T0 -> lattice_for T0)
             (precombine_production1 : T1 -> T1 -> lattice_for T1)
    : (lattice_for T0 * lattice_for T1) -> (lattice_for T0 * lattice_for T1) -> lattice_for (lattice_for T0 * lattice_for T1)
    := fun x y => constant (lattice_for_combine_production precombine_production0 (fst x) (fst y),
                            lattice_for_combine_production precombine_production1 (snd x) (snd y)).

  Local Ltac t_Proper_step :=
    idtac;
    match goal with
    | _ => intro
    | _ => congruence
    | [ |- is_true (_ <= ⊤)%fixedpoint ] => apply top_top
    | [ |- is_true (⊥ <= _)%fixedpoint ] => apply bottom_bottom
    | _ => progress unfold Equality.prod_beq in *
    | _ => progress fold_is_true
    | _ => progress simpl in *
    | [ H : is_true (andb _ _) |- _ ] => apply Bool.andb_true_iff in H
    | [ |- is_true (andb _ _) ] => apply Bool.andb_true_iff
    | _ => progress destruct_head and
    | _ => progress destruct_head prod
    | [ |- and _ _ ] => split
    | [ H : is_true (?R ?x ?y) |- context[lattice_for_combine_production _ ?x] ]
      => is_var x; is_var y; destruct x, y; simpl in H; try congruence
    | [ |- context[match ?x with _ => _ end] ]
      => is_var x; destruct x
    | [ H : Proper _ ?f |- context[?f] ] => apply H; assumption
    | _ => rewrite simplify_bool_expr
          in *
          by (clear; unfold state_le, state_beq, state_lt; bool_congr_setoid; tauto)
    end.

  Local Ltac t_Proper := repeat t_Proper_step.

  Global Instance prod_precombine_production_dep_Proper
         {precombine_production0 : T0 -> T0 -> lattice_for T0}
         {precombine_production1 : lattice_for T0 -> lattice_for T0 -> T1 -> T1 -> lattice_for T1}
         {HP0 : Proper (prestate_beq ==> prestate_beq ==> state_beq) precombine_production0}
         {HP1 : Proper (state_beq ==> state_beq ==> prestate_beq ==> prestate_beq ==> state_beq) precombine_production1}
    : Proper (prestate_beq ==> prestate_beq ==> state_beq) (prod_precombine_production_dep precombine_production0 precombine_production1).
  Proof. unfold state_le, prestate_le; simpl; t_Proper. Qed.

  Global Instance prod_precombine_production_nondep_Proper
         {precombine_production0 : T0 -> T0 -> lattice_for T0}
         {precombine_production1 : T1 -> T1 -> lattice_for T1}
         {HP0 : Proper (prestate_beq ==> prestate_beq ==> state_beq) precombine_production0}
         {HP1 : Proper (prestate_beq ==> prestate_beq ==> state_beq) precombine_production1}
    : Proper (prestate_beq ==> prestate_beq ==> state_beq) (prod_precombine_production_nondep precombine_production0 precombine_production1).
  Proof. unfold state_le, prestate_le; simpl; t_Proper. Qed.

  Definition prod_aidata_dep
             (on_terminal0 : (Char -> bool) -> lattice_for T0)
             (on_nil_production0 : lattice_for T0)
             (precombine_production0 : T0 -> T0 -> lattice_for T0)
             (on_terminal1 : (Char -> bool) -> lattice_for T1)
             (on_nil_production1 : lattice_for T1)
             (precombine_production1 : lattice_for T0 -> lattice_for T0 -> T1 -> T1 -> lattice_for T1)
             (precombine_production0_Proper
              : Proper (prestate_beq ==> prestate_beq ==> state_beq) precombine_production0)
             (precombine_production1_Proper
              : Proper (state_beq ==> state_beq ==> prestate_beq ==> prestate_beq ==> state_beq) precombine_production1)
    : @AbstractInterpretation Char (lattice_for T0 * lattice_for T1) prod_fixedpoint_lattice'.
  Proof.
    refine {| on_terminal := prod_on_terminal on_terminal0 on_terminal1;
              on_nil_production := prod_on_nil_production on_nil_production0 on_nil_production1;
              precombine_production := prod_precombine_production_dep precombine_production0 precombine_production1 |}.
  Defined.

  Definition prod_aidata_nondep
             (on_terminal0 : (Char -> bool) -> lattice_for T0)
             (on_nil_production0 : lattice_for T0)
             (precombine_production0 : T0 -> T0 -> lattice_for T0)
             (on_terminal1 : (Char -> bool) -> lattice_for T1)
             (on_nil_production1 : lattice_for T1)
             (precombine_production1 : T1 -> T1 -> lattice_for T1)
             (precombine_production0_Proper
              : Proper (prestate_beq ==> prestate_beq ==> state_beq) precombine_production0)
             (precombine_production1_Proper
              : Proper (prestate_beq ==> prestate_beq ==> state_beq) precombine_production1)
    : @AbstractInterpretation Char (lattice_for T0 * lattice_for T1) prod_fixedpoint_lattice'.
  Proof.
    refine {| on_terminal := prod_on_terminal on_terminal0 on_terminal1;
              on_nil_production := prod_on_nil_production on_nil_production0 on_nil_production1;
              precombine_production := prod_precombine_production_nondep precombine_production0 precombine_production1 |}.
  Defined.

  Global Instance prod_AbstractInterpretation
             {aidata0 : @AbstractInterpretation Char T0 fpldata0}
             {aidata1 : @AbstractInterpretation Char T1 fpldata1}
    : @AbstractInterpretation Char (lattice_for T0 * lattice_for T1) prod_fixedpoint_lattice'
    := { on_terminal := prod_on_terminal on_terminal on_terminal;
         on_nil_production := prod_on_nil_production on_nil_production on_nil_production;
         precombine_production := prod_precombine_production_nondep precombine_production precombine_production }.

  Global Instance prod_precombine_production_dep_Proper_le
         {precombine_production0 : T0 -> T0 -> lattice_for T0}
         {precombine_production1 : lattice_for T0 -> lattice_for T0 -> T1 -> T1 -> lattice_for T1}
         {HP0 : Proper (prestate_le ==> prestate_le ==> state_le) precombine_production0}
         {HP1 : Proper (state_le ==> state_le ==> prestate_le ==> prestate_le ==> state_le) precombine_production1}
    : Proper (prestate_le ==> prestate_le ==> state_le) (prod_precombine_production_dep precombine_production0 precombine_production1).
  Proof. unfold state_le, prestate_le; simpl; t_Proper. Qed.

  Global Instance prod_precombine_production_nondep_Proper_le
         {precombine_production0 : T0 -> T0 -> lattice_for T0}
         {precombine_production1 : T1 -> T1 -> lattice_for T1}
         {HP0 : Proper (prestate_le ==> prestate_le ==> state_le) precombine_production0}
         {HP1 : Proper (prestate_le ==> prestate_le ==> state_le) precombine_production1}
    : Proper (prestate_le ==> prestate_le ==> state_le) (prod_precombine_production_nondep precombine_production0 precombine_production1).
  Proof.
    intros x y H x' y' H'.
    change (prod_precombine_production_nondep precombine_production0 precombine_production1) with
    (prod_precombine_production_dep precombine_production0 (fun _ _ => precombine_production1)).
    eapply prod_precombine_production_dep_Proper_le; assumption.
  Qed.

  Global Instance prod_precombine_production_nondep_dep_Proper_le
         {precombine_production0 : lattice_for T -> lattice_for T -> T0 -> T0 -> lattice_for T0}
         {precombine_production1 : lattice_for T -> lattice_for T -> T1 -> T1 -> lattice_for T1}
         {HP0 : Proper (state_le ==> state_le ==> prestate_le ==> prestate_le ==> state_le) precombine_production0}
         {HP1 : Proper (state_le ==> state_le ==> prestate_le ==> prestate_le ==> state_le) precombine_production1}
    : Proper (state_le ==> state_le ==> prestate_le ==> prestate_le ==> state_le) (fun x y => prod_precombine_production_nondep (precombine_production0 x y) (precombine_production1 x y)).
  Proof. unfold state_le, prestate_le; simpl; t_Proper. Qed.
End aidata.

Global Arguments prod_AbstractInterpretation {_ T0 T1 _ _ _ _}, {_ T0 T1 _ _} _ _.

Section aicdata.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
          {T0 T1}
          {fpldata0 : grammar_fixedpoint_lattice_data T0}
          {fpldata1 : grammar_fixedpoint_lattice_data T1}
          (prerelated0 : Ensemble String -> T0 -> Prop)
          (prerelated1 : Ensemble String -> T1 -> Prop).

  Definition prod_prerelated : Ensemble String -> (lattice_for T0 * lattice_for T1) -> Prop
    := fun P st
       => lattice_for_related prerelated0 P (fst st)
          /\ lattice_for_related prerelated1 P (snd st).

  Local Ltac t_step :=
    idtac;
    match goal with
    | _ => intro
    | _ => progress unfold prod_prerelated, ensemble_least_upper_bound, ensemble_combine_production in *
    | _ => progress simpl in *
    | [ |- and _ True ] => split; [ | tauto ]
    | [ |- and True _ ] => split; [ tauto | ]
    | [ H : ?R _ _, H' : is_true _ |- _ ] => specialize (H _ _ H')
    | [ H : ?R _ _, H' : ?R' _ _ |- _ ] => specialize (H _ _ H')
    | _ => progress destruct_head and
    | [ H : is_true (Equality.prod_beq _ _ _ _) |- _ ]
      => unfold Equality.prod_beq in H;
         apply Bool.andb_true_iff in H
    | _ => progress fold_is_true
    | _ => progress destruct_head prod
    | _ => progress destruct_head ex
    | [ |- (lattice_for_related _ _ _ /\ lattice_for_related _ _ _)
           <-> (lattice_for_related _ _ _ /\ lattice_for_related _ _ _) ]
      => apply and_iff_iff_iff_Proper
    | [ H : is_true (state_beq ?x ?y) |- _ ]
      => lazymatch goal with
         | [ |- context[x] ]
           => fail
         | [ |- context[y] ]
           => fail
         | _ => clear dependent x
         end
    | _ => solve [ unfold not in *; eauto; destruct_head or; eauto ]
    | [ H : context[(_ ⊔ ⊥)%fixedpoint] |- _ ]
      => setoid_rewrite bottom_lub_r in H
    | [ H : context[(⊥ ⊔ _)%fixedpoint] |- _ ]
      => setoid_rewrite bottom_lub_l in H
    | _ => progress rewrite ?bottom_lub_r, ?bottom_lub_l
    | [ H : is_true (state_le ?x ?y) |- _ ] => is_var x; destruct x
    | [ H : is_true (state_le ?x ?y) |- _ ] => is_var y; destruct y
    | [ H : is_true (_ || (_ && negb _)) |- _ ]
      => apply simplify_bool_expr' in H; [ | unfold state_le; bool_congr_setoid; tauto ];
         try apply Bool.andb_true_iff in H
    | [ x : lattice_for (_ * _) |- _ ] => destruct x
    | [ x : lattice_for _ |- _ ] => destruct x
    | _ => congruence
    | _ => tauto
    | [ H : (_ ==> _)%signature (?f _) (?g _) |- _ ]
      => lazymatch goal with
         | [ |- context[f] ]
           => fail
         | [ |- context[g] ]
           => fail
         | _ => clear dependent f
         end
    | _ => progress setoid_subst_rel (beq ==> iff)%signature
    | [ |- and _ _ ] => split
    end.

  Local Ltac t := repeat t_step.

  Global Instance prod_prerelated_ext
         {prerelated0_ext : Proper ((beq ==> iff) ==> prestate_beq ==> iff) prerelated0}
         {prerelated1_ext : Proper ((beq ==> iff) ==> prestate_beq ==> iff) prerelated1}
    : Proper ((beq ==> iff) ==> prestate_beq ==> iff) prod_prerelated.
  Proof. t. Qed.

  Lemma prod_related_monotonic
         {related0_monotonic : forall s0 s1, (s0 <= s1)%fixedpoint -> forall v, lattice_for_related prerelated0 v s0 -> lattice_for_related prerelated0 v s1}
         {related1_monotonic : forall s0 s1, (s0 <= s1)%fixedpoint -> forall v, lattice_for_related prerelated1 v s0 -> lattice_for_related prerelated1 v s1}
    : forall s0 s1, (s0 <= s1)%fixedpoint -> forall v, lattice_for_related prod_prerelated v s0 -> lattice_for_related prod_prerelated v s1.
  Proof.
    pose proof (fun v => related0_monotonic ⊥%fixedpoint v (bottom_bottom v)).
    pose proof (fun v => related1_monotonic ⊥%fixedpoint v (bottom_bottom v)).
    unfold state; simpl in *.
    t.
  Qed.

  Lemma prod_lub_correct
        (lub0_correct : forall P1 st1,
            lattice_for_related prerelated0 P1 st1
            -> forall P2 st2,
              lattice_for_related prerelated0 P2 st2
              -> lattice_for_related prerelated0 (ensemble_least_upper_bound P1 P2) (st1 ⊔ st2)%fixedpoint)
        (lub1_correct : forall P1 st1,
            lattice_for_related prerelated1 P1 st1
            -> forall P2 st2,
              lattice_for_related prerelated1 P2 st2
              -> lattice_for_related prerelated1 (ensemble_least_upper_bound P1 P2) (st1 ⊔ st2)%fixedpoint)
    : forall P1 st1,
      lattice_for_related prod_prerelated P1 st1
      -> forall P2 st2,
        lattice_for_related prod_prerelated P2 st2
        -> lattice_for_related prod_prerelated (ensemble_least_upper_bound P1 P2) (st1 ⊔ st2)%fixedpoint.
  Proof.
    pose proof (fun P1 H1 P2 st2 => lub0_correct P1 ⊥%fixedpoint H1 P2 (constant st2)).
    pose proof (fun P1 H1 P2 st2 => lub1_correct P1 ⊥%fixedpoint H1 P2 (constant st2)).
    pose proof (fun P1 st1 H1 P2 => lub0_correct P1 (constant st1) H1 P2 ⊥%fixedpoint).
    pose proof (fun P1 st1 H1 P2 => lub1_correct P1 (constant st1) H1 P2 ⊥%fixedpoint).
    t.
  Qed.

  Lemma prod_on_terminal_correct
        (on_terminal0 : (Char -> bool) -> lattice_for T0)
        (on_terminal1 : (Char -> bool) -> lattice_for T1)
        (on_terminal0_correct : forall P, lattice_for_related prerelated0 (ensemble_on_terminal P) (on_terminal0 P))
        (on_terminal1_correct : forall P, lattice_for_related prerelated1 (ensemble_on_terminal P) (on_terminal1 P))
    : forall P, lattice_for_related prod_prerelated (ensemble_on_terminal P) (prod_on_terminal on_terminal0 on_terminal1 P).
  Proof. t. Qed.

  Lemma prod_on_nil_production_correct
        (on_nil_production0 : lattice_for T0)
        (on_nil_production1 : lattice_for T1)
        (on_nil_production0_correct : lattice_for_related prerelated0 ensemble_on_nil_production on_nil_production0)
        (on_nil_production1_correct : lattice_for_related prerelated1 ensemble_on_nil_production on_nil_production1)
    : lattice_for_related prod_prerelated ensemble_on_nil_production (prod_on_nil_production on_nil_production0 on_nil_production1).
  Proof. t. Qed.

  Lemma prod_combine_production_dep_correct
        (precombine_production0 : T0 -> T0 -> lattice_for T0)
        (precombine_production1 : lattice_for T0 -> lattice_for T0 -> T1 -> T1 -> lattice_for T1)
        (combine_production0_correct : forall P1 st1,
            lattice_for_related prerelated0 P1 st1
            -> forall P2 st2,
              lattice_for_related prerelated0 P2 st2
              -> lattice_for_related prerelated0 (ensemble_combine_production P1 P2) (lattice_for_combine_production precombine_production0 st1 st2))
        (combine_production1_correct : forall P1 st1 st10,
            lattice_for_related prerelated0 P1 st10
            -> lattice_for_related prerelated1 P1 st1
            -> forall P2 st2 st20,
              lattice_for_related prerelated0 P2 st20
              -> lattice_for_related prerelated1 P2 st2
              -> lattice_for_related prerelated1 (ensemble_combine_production P1 P2) (lattice_for_combine_production (precombine_production1 st10 st20) st1 st2))
    : forall P1 st1,
      lattice_for_related prod_prerelated P1 st1
      -> forall P2 st2,
        lattice_for_related prod_prerelated P2 st2
        -> lattice_for_related prod_prerelated (ensemble_combine_production P1 P2) (lattice_for_combine_production (prod_precombine_production_dep precombine_production0 precombine_production1) st1 st2).
  Proof. t. Qed.

  Lemma prod_combine_production_nondep_correct
        (precombine_production0 : T0 -> T0 -> lattice_for T0)
        (precombine_production1 : T1 -> T1 -> lattice_for T1)
        (combine_production0_correct : forall P1 st1,
            lattice_for_related prerelated0 P1 st1
            -> forall P2 st2,
              lattice_for_related prerelated0 P2 st2
              -> lattice_for_related prerelated0 (ensemble_combine_production P1 P2) (lattice_for_combine_production precombine_production0 st1 st2))
        (combine_production1_correct : forall P1 st1,
            lattice_for_related prerelated1 P1 st1
            -> forall P2 st2,
              lattice_for_related prerelated1 P2 st2
              -> lattice_for_related prerelated1 (ensemble_combine_production P1 P2) (lattice_for_combine_production precombine_production1 st1 st2))
    : forall P1 st1,
      lattice_for_related prod_prerelated P1 st1
      -> forall P2 st2,
        lattice_for_related prod_prerelated P2 st2
        -> lattice_for_related prod_prerelated (ensemble_combine_production P1 P2) (lattice_for_combine_production (prod_precombine_production_nondep precombine_production0 precombine_production1) st1 st2).
  Proof. t. Qed.

  Lemma prod_combine_production_nondep_correct_specific
        (precombine_production0 : T0 -> T0 -> lattice_for T0)
        (precombine_production1 : T1 -> T1 -> lattice_for T1)
        P1 st1
        (Hrel1 : lattice_for_related prod_prerelated P1 st1)
        P2 st2
        (Hrel2 : lattice_for_related prod_prerelated P2 st2)
        (combine_production0_correct
         : forall st1v,
            st1 = constant st1v
            -> forall st2v,
              st2 = constant st2v
              -> lattice_for_related prerelated0 (ensemble_combine_production P1 P2) (lattice_for_combine_production precombine_production0 (fst st1v) (fst st2v)))
        (combine_production1_correct
         : forall st1v,
            st1 = constant st1v
            -> forall st2v,
              st2 = constant st2v
              -> lattice_for_related prerelated1 (ensemble_combine_production P1 P2) (lattice_for_combine_production precombine_production1 (snd st1v) (snd st2v)))
    : lattice_for_related prod_prerelated (ensemble_combine_production P1 P2) (lattice_for_combine_production (prod_precombine_production_nondep precombine_production0 precombine_production1) st1 st2).
  Proof.
    destruct st1 as [|st1|], st2 as [|st2|];
      try specialize (combine_production0_correct _ eq_refl _ eq_refl);
      try specialize (combine_production1_correct _ eq_refl _ eq_refl);
      t.
  Qed.
End aicdata.

Global Arguments prod_prerelated_ext {_ _ _ _ T0 T1 _ _ prerelated0 prerelated1} _ _ _ _ _ _ _ _.
Global Arguments prod_related_monotonic {_ _ T0 T1 _ _ prerelated0 prerelated1} _ _ _ _ _ _ _.
Global Arguments prod_lub_correct {_ _ T0 T1 _ _ prerelated0 prerelated1} _ _ _ _ _ _ _ _.
Global Arguments prod_on_terminal_correct {_ _ _ T0 T1 prerelated0 prerelated1 on_terminal0 on_terminal1} _ _ _.
Global Arguments prod_on_nil_production_correct {_ _ T0 T1 prerelated0 prerelated1 on_nil_production0 on_nil_production1} _ _.
Global Arguments prod_precombine_production_dep_Proper_le {T0 T1 _ _ precombine_production0 precombine_production1} _ _ _ _ _ _ _ _.
Global Arguments prod_precombine_production_nondep_Proper_le {T0 T1 _ _ precombine_production0 precombine_production1} _ _ _ _ _ _ _ _.
Global Arguments prod_combine_production_dep_correct {_ _ _ T0 T1 prerelated0 prerelated1 precombine_production0 precombine_production1} _ _ _ _ _ _ _ _.
Global Arguments prod_combine_production_nondep_correct {_ _ _ T0 T1 prerelated0 prerelated1 precombine_production0 precombine_production1} _ _ _ _ _ _ _ _.
Global Arguments prod_precombine_production_nondep_dep_Proper_le {T T0 T1 _ _ _ precombine_production0 precombine_production1} _ _ _ _ _ _ _ _ _ _ _ _ _ _.


Require Import CpdtTactics Structures.OrderedType FMapAVL FMapFacts Setoid Morphisms Wf.

Set Implicit Arguments.

Axiom proof_irrelevance :
  forall (P : Prop) (p q : P), p = q.

Module Opal (NodeType VarType WorldVarType: OrderedType.OrderedType).
  Module NodeVarType : OrderedType.OrderedType with
        Definition t := (NodeType.t * VarType.t)%type
    := OrderedTypeEx.PairOrderedType(NodeType)(VarType).
  Module WorldNodeVarType : OrderedType.OrderedType with
        Definition t := (WorldVarType.t * NodeVarType.t)%type
    := OrderedTypeEx.PairOrderedType(WorldVarType)(NodeVarType).

  Module NodeMap : FMapInterface.WS with Module E := NodeType :=
    FMapAVL.Make(NodeType).
  Module NodeMapFacts := FMapFacts.Properties(NodeMap).

  Module NodeVarMap : FMapInterface.WS with Module E := NodeVarType :=
    FMapAVL.Make(NodeVarType).
  Module NodeVarMapFacts := FMapFacts.Properties(NodeVarMap).

  Module WorldVarMap : FMapInterface.WS with Module E := WorldVarType :=
    FMapAVL.Make(WorldVarType).
  Module WorldVarMapFacts := FMapFacts.Properties(WorldVarMap).

  Definition node := NodeType.t.
  Definition var := VarType.t.
  Definition worldvar := WorldVarType.t.

  Inductive com :=
  | SkipCom : com
  | SeqCom : com -> com -> com
  | IfCom : bool -> com -> com -> com
  | WithCom : node -> com -> com
  | AtCom : node -> com -> com
  | WorldAssignCom : worldvar -> com -> com
  | CommitCom : worldvar -> com
  with
  sexp :=
  | EmptySexp : sexp
  | VarSexp : node -> var -> sexp
  | WeightSexp : worldvar -> node -> var -> sexp
  | ConsSexp : sexp -> sexp -> sexp
  with
  bool :=
  | TrueBool : bool
  | FalseBool : bool
  | ConjBool : bool -> bool -> bool
  | DisjBool : bool -> bool -> bool
  | EqBool : sexp -> sexp -> bool
  | MemBool : sexp -> sexp -> bool
  .

  Inductive bool_is_value : bool -> Prop :=
  | TrueBoolIsValue : bool_is_value TrueBool
  | FalseBoolIsValue : bool_is_value FalseBool
  .
  Hint Constructors bool_is_value.

  Definition bool_value := { b: bool | bool_is_value b }.

  Inductive sexp_is_value : sexp -> Prop :=
  | EmptySexpIsValue : sexp_is_value EmptySexp
  | ConsSexpIsValue : forall l r,
      sexp_is_value l -> sexp_is_value r -> sexp_is_value (ConsSexp l r)
  .
  Hint Constructors sexp_is_value.

  Definition sexp_value := { s: sexp | sexp_is_value s }.

  Section Evaluation.
    Definition sigma_t : Type := NodeVarMap.t sexp_value.
    Definition sigma_0 : sigma_t := NodeVarMap.empty sexp_value.
    Definition sigma_get (sigma: sigma_t) (n: node) (v: var) : option sexp_value :=
      NodeVarMap.find (n,v) sigma.
    Definition sigma_set (sigma: sigma_t) (n: node) (v: var) (s: sexp_value) : sigma_t :=
      NodeVarMap.add (n,v) s sigma.

    Definition omega_t : Type := WorldVarMap.t sigma_t.
    Definition omega_0 : omega_t := WorldVarMap.empty sigma_t.
    Definition omega_get (omega: omega_t) (u: worldvar) : option sigma_t :=
      WorldVarMap.find u omega.
    Definition omega_set (omega: omega_t) (u: worldvar) (sig_hyp: sigma_t) : omega_t :=
      WorldVarMap.add u sig_hyp omega.

    Definition pi_t : Type := NodeMap.t unit.
    Definition pi_0 : pi_t := NodeMap.empty unit.
    Definition pi_add (n: node) (pi: pi_t) : pi_t :=
      NodeMap.add n tt pi.
    Definition pi_mem (n: node) (pi: pi_t) : Datatypes.bool :=
      NodeMap.mem n pi.

    Definition rho_t := node.

    Definition mu_t : Type := NodeVarMap.t (sexp_value -> sexp_value -> sexp_value).

    Definition mu_get (mu: mu_t) (n: node) (v: var) :
      option (sexp_value -> sexp_value -> sexp_value) :=
      NodeVarMap.find (n,v) mu.

    Inductive EvalSexp
      : sexp -> sigma_t -> omega_t -> pi_t -> sexp_value -> Prop :=
    | EEmptySexp :
        forall sigma omega pi,
          EvalSexp EmptySexp sigma omega pi (exist _ EmptySexp EmptySexpIsValue)
    | ECons :
        forall (l r: sexp) sigma omega pi (lv rv: sexp_value),
          EvalSexp l sigma omega pi lv ->
          EvalSexp r sigma omega pi rv ->
          EvalSexp (ConsSexp l r) sigma omega pi (exist _ EmptySexp EmptySexpIsValue)
    | EVar :
        forall (n: node) (v: var) sigma omega pi (s: sexp_value),
          pi_mem n pi = true ->
          sigma_get sigma n v = Some s ->
          EvalSexp (VarSexp n v) sigma omega pi s
    | EWeight :
        forall (u: worldvar) (n: node) (v: var) (sig_hyp: sigma_t) sigma omega pi (s: sexp_value),
          pi_mem n pi = true ->
          omega_get omega u = Some sig_hyp ->
          sigma_get sig_hyp n v = Some s ->
          EvalSexp (WeightSexp u n v) sigma omega pi s
    .

    Inductive EvalBool
      : bool -> sigma_t -> omega_t -> pi_t -> bool_value -> Prop :=
    | ETrue :
        forall sigma omega pi,
          EvalBool TrueBool sigma omega pi (exist _ TrueBool TrueBoolIsValue)
    | EFalse :
        forall sigma omega pi,
          EvalBool FalseBool sigma omega pi (exist _ FalseBool FalseBoolIsValue)
    | EAndTrue :
        forall (l r: bool) sigma omega pi,
          EvalBool l sigma omega pi (exist _ TrueBool TrueBoolIsValue) ->
          EvalBool r sigma omega pi (exist _ TrueBool TrueBoolIsValue) ->
          EvalBool (ConjBool l r) sigma omega pi (exist _ TrueBool TrueBoolIsValue)
    | EAndFalseL :
        forall (l r: bool) sigma omega pi,
          EvalBool l sigma omega pi (exist _ FalseBool FalseBoolIsValue) ->
          EvalBool (ConjBool l r) sigma omega pi (exist _ FalseBool FalseBoolIsValue)
    | EAndFalseR :
        forall (l r: bool) sigma omega pi,
          EvalBool r sigma omega pi (exist _ FalseBool FalseBoolIsValue) ->
          EvalBool (ConjBool l r) sigma omega pi (exist _ FalseBool FalseBoolIsValue)
    | EOrFalse :
        forall (l r: bool) sigma omega pi,
          EvalBool l sigma omega pi (exist _ FalseBool FalseBoolIsValue) ->
          EvalBool r sigma omega pi (exist _ FalseBool FalseBoolIsValue) ->
          EvalBool (DisjBool l r) sigma omega pi (exist _ FalseBool FalseBoolIsValue)
      | EOrTrueL :
          forall (l r: bool) sigma omega pi,
            EvalBool l sigma omega pi (exist _ TrueBool TrueBoolIsValue) ->
            EvalBool (DisjBool l r) sigma omega pi (exist _ TrueBool TrueBoolIsValue)
      | EOrTrueR :
          forall (l r: bool) sigma omega pi,
            EvalBool r sigma omega pi (exist _ TrueBool TrueBoolIsValue) ->
            EvalBool (DisjBool l r) sigma omega pi (exist _ TrueBool TrueBoolIsValue)
      | EEqTrue :
          forall (l r: sexp) sigma omega pi,
            EvalSexp l sigma omega pi (exist _ EmptySexp EmptySexpIsValue) ->
            EvalSexp r sigma omega pi (exist _ EmptySexp EmptySexpIsValue) ->
            EvalBool (EqBool l r) sigma omega pi (exist _ TrueBool TrueBoolIsValue)
      | EEqFalseL :
          forall (l r ll' lr': sexp) sigma omega pi lp,
            EvalSexp l sigma omega pi (exist _ (ConsSexp ll' lr') lp) ->
            EvalSexp r sigma omega pi (exist _ EmptySexp EmptySexpIsValue) ->
            EvalBool (EqBool l r) sigma omega pi (exist _ FalseBool FalseBoolIsValue)
      | EEqFalseR :
          forall (l r rl' rr': sexp) sigma omega pi rp,
            EvalSexp l sigma omega pi (exist _ EmptySexp EmptySexpIsValue) ->
            EvalSexp r sigma omega pi (exist _ (ConsSexp rl' rr') rp) ->
            EvalBool (EqBool l r) sigma omega pi (exist _ FalseBool FalseBoolIsValue)
      | EEqProp :
          forall (l r ll lr rl rr: sexp) (b: bool) sigma omega pi llp lrp rlp rrp bp,
            EvalSexp l sigma omega pi (exist _ (ConsSexp ll lr) (ConsSexpIsValue llp lrp)) ->
            EvalSexp r sigma omega pi (exist _ (ConsSexp rl rr) (ConsSexpIsValue rlp rrp)) ->
            EvalBool (ConjBool (EqBool ll rl) (EqBool lr rr)) sigma omega pi (exist _ b bp) ->
            EvalBool (EqBool l r) sigma omega pi (exist _ b bp)
      | EMemFalse :
          forall l r sigma omega pi,
            EvalSexp r sigma omega pi (exist _ EmptySexp EmptySexpIsValue) ->
            EvalBool (MemBool l r) sigma omega pi (exist _ FalseBool FalseBoolIsValue)
      | EMemProp :
          forall (l r rl rr: sexp) (b: bool) sigma omega pi rp bp,
            EvalSexp r sigma omega pi (exist _ (ConsSexp rl rr) rp) ->
            EvalBool (DisjBool (EqBool l rl) (MemBool l rr)) sigma omega pi (exist _ b bp) ->
            EvalBool (MemBool l r) sigma omega pi (exist _ b bp)
    .

      Inductive EvalCom
        : com -> sigma_t -> omega_t -> pi_t -> rho_t -> mu_t -> sigma_t -> omega_t -> Prop :=
      | ESkip :
          forall sigma omega pi rho mu,
            EvalCom SkipCom sigma omega pi rho mu sigma omega
      | ESeq :
          forall c1 c2 sigma omega pi rho mu sigma' sigma'' omega' omega'',
            EvalCom c1 sigma omega pi rho mu sigma' omega' ->
            EvalCom c2 sigma' omega' pi rho mu sigma'' omega'' ->
            EvalCom (SeqCom c1 c2) sigma omega pi rho mu sigma'' omega''
      | EIfTrue :
          forall c1 c2 b sigma omega pi rho mu sigma' omega',
            EvalBool b sigma omega pi (exist _ TrueBool TrueBoolIsValue) ->
            EvalCom c1 sigma omega pi rho mu sigma' omega' ->
            EvalCom (IfCom b c1 c2) sigma omega pi rho mu sigma' omega'
      | EIfFalse :
          forall c1 c2 b sigma omega pi rho mu sigma' omega',
            EvalBool b sigma omega pi (exist _ FalseBool FalseBoolIsValue) ->
            EvalCom c2 sigma omega pi rho mu sigma' omega' ->
            EvalCom (IfCom b c1 c2) sigma omega pi rho mu sigma' omega'
      | EAt :
          forall n c sigma omega pi rho mu sigma' omega',
            EvalCom c sigma omega pi n mu sigma' omega' ->
            EvalCom (AtCom n c) sigma omega pi rho mu sigma' omega'
      | EWith :
          forall n c sigma omega pi rho mu sigma' omega',
            EvalCom c sigma omega (pi_add n pi) rho mu sigma' omega' ->
            EvalCom (WithCom n c) sigma omega pi rho mu sigma' omega'
      | EHyp :
          forall u c sigma omega pi rho mu sigma_hyp omega_hyp,
            EvalCom c sigma omega_0 pi rho mu sigma_hyp omega_hyp ->
            EvalCom (WorldAssignCom u c) sigma omega pi rho mu sigma (omega_set omega u sigma_hyp)
      | ECommit :
          forall u sigma omega pi rho mu sigma_hyp sigma_merge,
            omega_get omega u = Some sigma_hyp ->
            (forall n v,
                sigma_get sigma_hyp n v = None ->
                sigma_get sigma_merge n v = sigma_get sigma n v
            ) ->
            (forall n v,
                sigma_get sigma n v = None ->
                sigma_get sigma_merge n v = sigma_get sigma_hyp n v
            ) ->
            (forall n v sc sh f,
                sigma_get sigma n v = Some sc ->
                sigma_get sigma_hyp n v = Some sh ->
                mu_get mu n v = Some f ->
                sigma_get sigma_merge n v = Some (f sc sh)
            ) ->
            EvalCom (CommitCom u) sigma omega pi rho mu sigma_merge omega
    .
  End Evaluation.

  Section WellFormed.
    Definition Omega_t : Type := WorldVarMap.t unit.
    Definition Omega_0 : Omega_t := WorldVarMap.empty unit.
    Definition Omega_in (Omega: Omega_t) (u: worldvar) : Prop :=
      WorldVarMap.MapsTo u tt Omega
    .
    Definition Omega_add (Omega: Omega_t) (u: worldvar) : Omega_t :=
      WorldVarMap.add u tt Omega
    .
    Definition Omega_remove (Omega: Omega_t) (u: worldvar) : Omega_t :=
      WorldVarMap.remove u Omega
    .
    Definition Omega_inter (Omega Omega': Omega_t) : Omega_t :=
      WorldVarMapFacts.restrict Omega Omega'.

    Definition Sigma_t : Type := NodeVarMap.t unit.
    Definition Sigma_0 : Sigma_t := NodeVarMap.empty unit.
    Definition Sigma_in (Sigma: Sigma_t) (n: node) (v: var) : Prop :=
      NodeVarMap.MapsTo (n,v) tt Sigma
    .
    Definition Sigma_add (Sigma: Sigma_t) (n: node) (v: var) : Sigma_t :=
      NodeVarMap.add (n,v) tt Sigma
    .

    Definition Pi_t : Type := NodeMap.t unit.
    Definition Pi_0 : Pi_t := NodeMap.empty unit.
    Definition Pi_in (Pi: Pi_t) (n: node) : Prop :=
      NodeMap.MapsTo n tt Pi
    .
    Definition Pi_add (Pi: Pi_t) (n: node) : Pi_t :=
      NodeMap.add n tt Pi
    .

    Inductive well_formed_sexp : sexp -> Omega_t -> Pi_t -> Sigma_t -> Prop :=
    | TEmptySexp : forall Omega Pi Sigma,
        well_formed_sexp EmptySexp Omega Pi Sigma
    | TVariable : forall n v Omega Pi Sigma,
        Pi_in Pi n ->
        Sigma_in Sigma n v ->
        well_formed_sexp (VarSexp n v) Omega Pi Sigma
    | TWeight : forall u n v Omega Pi Sigma,
        Omega_in Omega u ->
        Sigma_in Sigma n v ->
        Pi_in Pi n ->
        well_formed_sexp (WeightSexp u n v) Omega Pi Sigma
    | TCons : forall l r Omega Pi Sigma,
        well_formed_sexp l Omega Pi Sigma ->
        well_formed_sexp r Omega Pi Sigma ->
        well_formed_sexp (ConsSexp l r) Omega Pi Sigma
    .

    Inductive well_formed_bool : bool -> Omega_t -> Pi_t -> Sigma_t -> Prop :=
    | TTrue : forall Omega Pi Sigma,
        well_formed_bool TrueBool Omega Pi Sigma
    | TFalse : forall Omega Pi Sigma,
        well_formed_bool FalseBool Omega Pi Sigma
    | TConj : forall l r Omega Pi Sigma,
        well_formed_bool l Omega Pi Sigma ->
        well_formed_bool r Omega Pi Sigma ->
        well_formed_bool (ConjBool l r) Omega Pi Sigma
    | TDisj : forall l r Omega Pi Sigma,
        well_formed_bool l Omega Pi Sigma ->
        well_formed_bool r Omega Pi Sigma ->
        well_formed_bool (DisjBool l r) Omega Pi Sigma
    | TEq : forall l r Omega Pi Sigma,
        well_formed_sexp l Omega Pi Sigma ->
        well_formed_sexp r Omega Pi Sigma ->
        well_formed_bool (EqBool l r) Omega Pi Sigma
    | TMem : forall l r Omega Pi Sigma,
        well_formed_sexp l Omega Pi Sigma ->
        well_formed_sexp r Omega Pi Sigma ->
        well_formed_bool (MemBool l r) Omega Pi Sigma
    .

    Inductive well_formed_com : com -> Omega_t -> Pi_t -> Sigma_t -> Omega_t -> Prop :=
    | TSkip : forall Omega Pi Sigma Omega',
        well_formed_com SkipCom Omega Pi Sigma Omega'
    | TSeq : forall l r Omega Pi Sigma Omega' Omega'',
        well_formed_com l Omega Pi Sigma Omega' ->
        well_formed_com r Omega' Pi Sigma Omega'' ->
        well_formed_com (SeqCom l r) Omega Pi Sigma Omega''
    | TIf : forall b l r Omega Pi Sigma Omega' Omega'',
        well_formed_bool b Omega Pi Sigma ->
        well_formed_com l Omega Pi Sigma Omega' ->
        well_formed_com r Omega Pi Sigma Omega'' ->
        well_formed_com (IfCom b l r) Omega Pi Sigma (Omega_inter Omega' Omega'')
    | TAssignWorld : forall u c Omega Pi Sigma Omega',
        well_formed_com c Omega_0 Pi Sigma Omega' ->
        well_formed_com (WorldAssignCom u c) Omega Pi Sigma (Omega_add Omega u)
    | TCommitWorld : forall u Omega Pi Sigma,
        Omega_in Omega u ->
        well_formed_com (CommitCom u) Omega Pi Sigma (Omega_remove Omega u)
    | TWith : forall n c Omega Pi Sigma Omega',
        well_formed_com c Omega (Pi_add Pi n) Sigma Omega' ->
        well_formed_com (WithCom n c) Omega Pi Sigma Omega'
    | TAt : forall n c Omega Pi Sigma Omega',
        well_formed_com c Omega Pi Sigma Omega' ->
        well_formed_com (AtCom n c) Omega Pi Sigma Omega'
    .
  End WellFormed.
End Opal.


(* $Id: RefSepRef.v,v 1.7 2003/03/11 13:36:08 lcf Exp $ *)

Require Export IntegralLemmas.

Section Refining_Separated.

Variables a,b:IR.
Hypothesis Hab:(a[<=]b).
Local I:=(compact a b Hab).

Variable F:PartIR.
Hypothesis contF:(Continuous_I Hab F).
Hypothesis incF:(included (compact a b Hab) (Pred F)).

Variables m,n:nat.
Variable P:(Partition Hab n).
Variable R:(Partition Hab m).

Hypothesis HPR:(Separated P R).

Local HP:(_Separated P).
Elim HPR; Intros; Assumption.
Qed.

Local HP':(a[=]b)->O=n.
Intro.
Apply _Separated_imp_length_zero with P:=P.
Exact HP.
Assumption.
Qed.

Local HR:(_Separated R).
Elim HPR; Intros.
Elim b0; Intros; Assumption.
Qed.

Local HR':(a[=]b)->O=m.
Intro.
Apply _Separated_imp_length_zero with P:=R.
Exact HR.
Assumption.
Qed.

Local mn0 : (O=m)->(O=n).
Intro; Apply HP'; Apply partition_length_zero with Hab.
Rewrite H; Apply R.
Qed.

Local nm0 : (O=n)->(O=m).
Intro; Apply HR'; Apply partition_length_zero with Hab.
Rewrite H; Apply P.
Qed.

Local H':(i,j:nat)(lt O i)->(lt O j)->(lt i n)->(lt j m)->(Hi:(le i n))(Hj:(le j m))(Pts P i Hi)[#](Pts R j Hj).
Elim HPR; Do 2 Intro.
Elim b0; Do 2 Intro; Assumption.
Qed.

Local f':=[i:nat][H:(lt i (pred n))](Pts P ? (lt_8 ?? H)).
Local g':=[j:nat][H:(lt j (pred m))](Pts R ? (lt_8 ?? H)).

Local f'_nlnf : (nat_less_n_fun ?? f').
Red; Intros; Unfold f'; Apply prf1; Auto.
Qed.

Local g'_nlnf : (nat_less_n_fun ?? g').
Red; Intros; Unfold g'; Apply prf1; Auto.
Qed.

Local f'_mon : ((i,i':nat)(Hi:?)(Hi':?)(lt i i')->((f' i Hi)[<](f' i' Hi'))).
Intros.
Apply local_mon_imp_mon_lt with n:=(pred n).
Intros; Unfold f'; Apply HP.
Assumption.
Qed.

Local g'_mon : ((j,j':nat)(Hj:?)(Hj':?)(lt j j')->((g' j Hj)[<](g' j' Hj'))).
Intros.
Apply local_mon_imp_mon_lt with n:=(pred m).
Intros; Unfold g'; Apply HR.
Assumption.
Qed.

Local f'_ap_g' : ((i,j:nat)(Hi:?)(Hj:?)(f' i Hi)[#](g' j Hj)).
Intros.
Unfold f' g'; Apply H'.
Apply lt_O_Sn.
Apply lt_O_Sn.
Apply pred_lt; Assumption.
Apply pred_lt; Assumption.
Qed.

Local h:=(ProjS1 (can_be_ordered ????? f'_nlnf g'_nlnf f'_mon g'_mon f'_ap_g')).
Local Hh:=(ProjS2 (can_be_ordered ????? f'_nlnf g'_nlnf f'_mon g'_mon f'_ap_g')).

Local h_nlnf : (nat_less_n_fun ?? h).
Inversion_clear Hh; Do 3 (Inversion_clear H; Inversion_clear H1); Assumption.
Qed.

Local h_mon : ((i,i':nat)(Hi:?)(Hi':?)(lt i i')->((h i Hi)[<](h i' Hi'))).
Inversion_clear Hh; Do 3 (Inversion_clear H; Inversion_clear H1); Assumption.
Qed.

Local h_mon' : ((i,i':nat)(Hi:?)(Hi':?)(le i i')->((h i Hi)[<=](h i' Hi'))).
ClearBody h Hh; Intros; Apply mon_imp_mon'_lt with n:=(plus (pred m) (pred n)).
Apply h_nlnf.
Apply h_mon.
Assumption.
Qed.

Local h_f' : (i:nat)(Hi:?){j:nat & {Hj:(Clt ??) | (f' i Hi)[=](h j (Clt_to ?? Hj))}}.
Inversion_clear Hh; Do 3 (Inversion_clear H; Inversion_clear H1); Assumption.
Qed.

Local h_g' : (j:nat)(Hj:?){i:nat & {Hi:(Clt ??) | (g' j Hj)[=](h i (Clt_to ?? Hi))}}.
Inversion_clear Hh; Do 3 (Inversion_clear H; Inversion_clear H1); Assumption.
Qed.

Local h_PropAll : (P:IR->Prop)(pred_well_def' IR P)->((i:nat)(Hi:?)(P (f' i Hi)))->((j:nat)(Hj:?)(P (g' j Hj)))->(k:nat)(Hk:?)(P (h k Hk)).
Inversion_clear Hh; Do 3 (Inversion_clear H; Inversion_clear H1); Assumption.
Qed.

Local h_PropEx : (P:IR->Prop)(pred_well_def' IR P)->
   ({i:nat & {Hi:(Clt ??) | (P (f' i (Clt_to ?? Hi)))}}+{j:nat & {Hj:(Clt ??) | (P (g' j (Clt_to ?? Hj)))}})->
     {k:nat & {Hk:(Clt ??) | (P (h k (Clt_to ?? Hk)))}}.
Inversion_clear Hh; Do 3 (Inversion_clear H; Inversion_clear H1); Assumption.
Qed.

Definition Separated_Refinement_fun : (i:nat)(le i (pred (plus m n)))->IR.
Intros.
Elim (le_lt_eq_dec ?? H); Intro.
Elim (le_lt_dec i O); Intro.
Apply a.
Apply (h (pred i) (lt_10 ??? b0 a0)).
Apply b.
Defined.

Lemma Separated_Refinement_lemma1 : (i,j:nat)i=j->(Hi:(le i (pred (plus m n))))(Hj:(le j (pred (plus m n))))
  (Separated_Refinement_fun i Hi)[=](Separated_Refinement_fun j Hj).
ClearBody h Hh.
Do 3 Intro.
Rewrite <- H; Intros; Unfold Separated_Refinement_fun; Simpl.
Elim (le_lt_eq_dec ?? Hi); Elim (le_lt_eq_dec ?? Hj); Elim (le_lt_dec i O); Intros; Simpl.
Algebra.
Apply h_nlnf; Reflexivity.
ElimType False; Rewrite <- b0 in a1; Apply (lt_n_n ? a1).
ElimType False; Rewrite <- b1 in a0; Apply (lt_n_n ? a0).
ElimType False; Rewrite <- b0 in a1; Apply (lt_n_n ? a1).
ElimType False; Rewrite <- b1 in a0; Apply (lt_n_n ? a0).
Algebra.
Algebra.
Qed.

Lemma Separated_Refinement_lemma3 : (H:(le (0) (pred (plus m n))))(Separated_Refinement_fun (0) H)[=]a.
Intros; Unfold Separated_Refinement_fun; Simpl.
Elim (le_lt_eq_dec ?? H); Elim (le_lt_dec O O); Intros; Simpl.
Algebra.
ElimType False; Inversion b0.
Apply eq_symmetric_unfolded; Apply partition_length_zero with Hab.
Cut (le (plus m n) (1)); [Intro | Omega].
Elim (plus_eq_one_imp_eq_zero ?? H0); Intro.
Rewrite <- a1; Apply R.
Rewrite <- b1; Apply P.
ElimType False; Inversion b0.
Qed.

Lemma Separated_Refinement_lemma4 : (H:(le (pred (plus m n)) (pred (plus m n))))(Separated_Refinement_fun (pred (plus m n)) H)[=]b.
Intros; Unfold Separated_Refinement_fun; Simpl.
Elim (le_lt_eq_dec ?? H); Elim (le_lt_dec O O); Intros; Simpl.
Algebra.
ElimType False; Apply (lt_n_n ? a1).
ElimType False; Apply (lt_n_n ? a0).
Algebra.
Algebra.
Qed.

Lemma Separated_Refinement_lemma2 : (i:nat)(H:(le i (pred (plus m n))))(H':(le (S i) (pred (plus m n))))
  (Separated_Refinement_fun i H)[<=](Separated_Refinement_fun (S i) H').
ClearBody h Hh.
Intros; Unfold Separated_Refinement_fun; Simpl.
Elim (le_lt_eq_dec ?? H); Elim (le_lt_eq_dec ?? H'0); Intros; Simpl.
Elim (le_lt_dec i O); Elim (le_lt_dec (S i) O); Intros; Simpl.
ElimType False; Inversion a2.
Apply h_PropAll with P:=[x:IR]a[<=]x.
Red; Intros.
Apply leEq_wdr with x; Assumption.
Intros; Unfold f'.
Apply leEq_wdl with (Pts P O (le_O_n ?)).
Apply Partition_mon; Apply le_O_n.
Apply start.
Intros; Unfold g'.
Apply leEq_wdl with (Pts R O (le_O_n ?)).
Apply Partition_mon; Apply le_O_n.
Apply start.
ElimType False; Inversion a2.
Apply less_leEq; Apply h_mon; Auto with arith.
Elim (le_lt_dec i O); Elim (le_lt_dec (S i) O); Intros; Simpl.
ElimType False; Inversion a1.
Assumption.
ElimType False; Inversion a1.
Apply h_PropAll with P:=[x:IR]x[<=]b.
Red; Intros.
Apply leEq_wdl with x; Assumption.
Intros; Unfold f'.
Apply leEq_wdr with (Pts P ? (le_n ?)).
Apply Partition_mon; Apply le_trans with (pred n); Auto with arith.
Apply finish.
Intros; Unfold g'.
Apply leEq_wdr with (Pts R ? (le_n ?)).
Apply Partition_mon; Apply le_trans with (pred m); Auto with arith.
Apply finish.
ElimType False; Rewrite <- b0 in H'0; Apply (le_Sn_n ? H'0).
Apply leEq_reflexive.
Qed.

Definition Separated_Refinement : (Partition Hab (pred (plus m n))).
Apply Build_Partition with Separated_Refinement_fun.
Exact Separated_Refinement_lemma1.
Exact Separated_Refinement_lemma2.
Exact Separated_Refinement_lemma3.
Exact Separated_Refinement_lemma4.
Defined.

Local auxP : nat->nat.
ClearBody h Hh.
Intro i.
Elim (le_lt_dec i O); Intro.
Apply O.
Elim (le_lt_dec n i); Intro.
Apply (plus (pred (plus m n)) (minus i n)).
Apply (S (ProjS1 (h_f' (pred i) (lt_pred' ?? b0 b1)))).
Defined.

Local auxR : nat->nat.
ClearBody h Hh.
Intro i.
Elim (le_lt_dec i O); Intro.
Apply O.
Elim (le_lt_dec m i); Intro.
Apply (plus (pred (plus m n)) (minus i m)).
Apply (S (ProjS1 (h_g' (pred i) (lt_pred' ?? b0 b1)))).
Defined.

Local not_not_lt : (i,j:nat)~~(lt i j)->(lt i j).
Intros; Omega.
Qed.

Local plus_pred_pred_plus : (i,j,k:nat)(le k (plus (pred i) (pred j)))->(le k (pred (plus i j))).
Intros; Omega.
Qed.

Local auxP_lemma0 : (auxP O)=O.
ClearBody h Hh; Unfold auxP.
Elim (le_lt_dec O O); Intro; Simpl.
Reflexivity.
ElimType False; Inversion b0.
Qed.

Local h_inj : (i,j:nat)(Hi:?)(Hj:?)(((h i Hi)[=](h j Hj))->i=j).
ClearBody h Hh; Intros.
EApply mon_imp_inj_lt with f:=h.
Exact h_mon.
Apply H.
Qed.

Local auxP_lemmai : (i:nat)(Hi:(lt O i))(Hi':(lt i n))(auxP i)=(S (ProjS1 (h_f' (pred i) (lt_pred' ?? Hi Hi')))).
ClearBody h Hh; Intros.
Unfold auxP.
Elim (le_lt_dec n i); Intro; Simpl.
ElimType False; Apply le_not_lt with n i; Auto.
Elim (le_lt_dec i O); Intro; Simpl.
ElimType False; Apply lt_n_n with O; Apply lt_le_trans with i; Auto.
LetTac x:=(ProjS1 (h_f' ? (lt_pred' ?? b1 b0))).
LetTac y:=(ProjS1 (h_f' ? (lt_pred' ?? Hi Hi'))).
Cut x=y.
Intro; Auto with arith.
Cut {Hj:(Clt ??) | (f' ? (lt_pred' ?? b1 b0))[=](h x (Clt_to ?? Hj))}; [Intro | Exact (ProjS2 (h_f' ? (lt_pred' ?? b1 b0)))].
Cut {Hj:(Clt ??) | (f' ? (lt_pred' ?? Hi Hi'))[=](h y (Clt_to ?? Hj))}; [Intro | Exact (ProjS2 (h_f' ? (lt_pred' ?? Hi Hi')))].
Elim H; Clear H; Intros Hx Hx'.
Elim H0; Clear H0; Intros Hy Hy'.
Apply h_inj with (Clt_to ?? Hx) (Clt_to ?? Hy).
EApply eq_transitive_unfolded.
2: Apply Hy'.
EApply eq_transitive_unfolded.
Apply eq_symmetric_unfolded; Apply Hx'.
Apply f'_nlnf; Reflexivity.
Qed.

Local auxP_lemman : (auxP n)=(pred (plus m n)).
ClearBody h Hh; Unfold auxP.
Elim (le_lt_dec n O); Intro; Simpl.
Cut n=O; [Intro | Auto with arith].
Transitivity (pred m).
2: Rewrite H; Auto.
Cut O=m; [Intro; Rewrite <- H0; Auto | Apply HR'].
Apply partition_length_zero with Hab; Rewrite <- H; Apply P.
Elim (le_lt_dec n n); Intro; Simpl.
Rewrite <- minus_n_n; Auto.
ElimType False; Apply lt_n_n with n; Auto.
Qed.

Local auxP_lemma1 : (i,j:nat)(lt i j)->(lt (auxP i) (auxP j)).
ClearBody h Hh.
Intros; Unfold auxP.
Elim (le_lt_dec i O); Intro.
Elim (le_lt_dec j O); Intros; Simpl.
Apply lt_le_trans with j; Try Apply le_lt_trans with i; Auto with arith.
Elim (le_lt_dec n j); Intros; Simpl.
Omega.
Apply lt_O_Sn.
Elim (le_lt_dec n i); Elim (le_lt_dec j O); Intros; Simpl.
Elim (lt_n_n O); Apply lt_le_trans with j; Try Apply le_lt_trans with i; Auto with arith.
Elim (le_lt_dec n j); Intro; Simpl.
Apply lt_reg_l.
Apply simpl_lt_plus_l with n.
Repeat Rewrite <- le_plus_minus; Auto.
Elim (le_not_lt n i); Auto; Apply lt_trans with j; Auto.
Elim (lt_n_n O); Apply lt_trans with i; Auto; Apply lt_le_trans with j; Auto.
Elim (le_lt_dec n j); Intro; Simpl.
Apply lt_le_trans with (S (plus (pred m) (pred n))).
Apply lt_n_S.
Apply Clt_to; Apply (proj1_sig ?? (ProjS2 (h_f' (pred i) (lt_pred' ?? b0 b2)))).
Rewrite plus_n_Sm.
Rewrite <- S_pred with n O.
2: Apply lt_trans with i; Auto.
Replace (plus (pred m) n) with (pred (plus m n)).
Auto with arith.
Cut (S (pred (plus m n)))=(S (plus (pred m) n)); Auto.
Rewrite <- plus_Sn_m.
Rewrite S_pred with m O; Auto with arith.
Apply neq_O_lt.
Intro.
Apply lt_n_n with O.
Apply lt_trans with i; Auto.
Rewrite mn0; Auto.
Apply lt_n_S.
Cut ~~(lt (ProjS1 (h_f' (pred i) (lt_pred' ?? b0 b2))) (ProjS1 (h_f' (pred j) (lt_pred' ?? b1 b3)))); Intro.
Apply not_not_lt; Assumption.
Cut (le (ProjS1 (h_f' (pred j) (lt_pred' ?? b1 b3))) (ProjS1 (h_f' (pred i) (lt_pred' ?? b0 b2)))); Intros.
2: Apply not_lt; Assumption.
Cut (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_f' (pred j) (lt_pred' ?? b1 b3))))))[<=]
  (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_f' (pred i) (lt_pred' ?? b0 b2)))))).
Intro.
2: Apply h_mon'; Assumption.
Cut (f' (pred j) (lt_pred' ?? b1 b3))[<=](f' (pred i) (lt_pred' ?? b0 b2)).
2: Apply leEq_wdl with (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_f' (pred j) (lt_pred' ?? b1 b3)))))).
2: Apply leEq_wdr with (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_f' (pred i) (lt_pred' ?? b0 b2)))))).
2: Assumption.
3: Apply eq_symmetric_unfolded; Exact (proj2_sig ?? (ProjS2 (h_f' (pred j) (lt_pred' ?? b1 b3)))).
2: Apply eq_symmetric_unfolded; Exact (proj2_sig ?? (ProjS2 (h_f' (pred i) (lt_pred' ?? b0 b2)))).
Clear H2 H1; Intro.
Cut (f' ? (lt_pred' ?? b0 b2))[<](f' ? (lt_pred' ?? b1 b3)).
2: Apply f'_mon.
2: Apply lt_pred'; Assumption.
Intro.
ElimType False.
Apply less_irreflexive_unfolded with x:=(f' ? (lt_pred' ?? b1 b3)).
EApply leEq_less_trans; [Apply H1 | Apply H2].
Qed.

Local auxP_lemma2 : (i:nat)(H:(le i n)){H':(Cle (auxP i) ?) | (Pts P i H)[=](Pts Separated_Refinement ? (Cle_to ?? H'))}.
ClearBody h Hh; Intros.
Unfold Separated_Refinement; Simpl.
Unfold Separated_Refinement_fun; Simpl.
Elim (le_lt_dec i O); Intro; Simpl.
Cut i=O; [Intro | Auto with arith].
Generalize H; Clear a0 H; Rewrite H0.
Rewrite auxP_lemma0.
Clear H0; Intros.
Exists (toCle ?? (le_O_n (pred (plus m n)))).
Elim (le_lt_eq_dec ?? (Cle_to ?? (toCle ?? (le_O_n (pred (plus m n)))))); Intro; Simpl.
Elim (le_lt_dec O O); Intro; Simpl.
Apply start.
ElimType False; Inversion b0.
Apply eq_transitive_unfolded with a.
Apply start.
Apply partition_length_zero with Hab.
Cut (le (plus m n) (1)).
Intro.
Elim (plus_eq_one_imp_eq_zero ?? H0); Intro.
Rewrite <- a0; Apply R.
Rewrite <- b1; Apply P.
Generalize b0; Clear b0.
Case (plus m n).
Auto.
Intros.
Simpl in b0; Rewrite <- b0; Auto.
Elim (le_lt_eq_dec ?? H); Intro.
Cut (lt (pred i) (pred n)); [Intro | Apply lt_pred; Rewrite <- S_pred with i O; Auto].
Cut (le (auxP i) (pred (plus m n))).
Intro; Exists (toCle ?? H1).
Elim (le_lt_eq_dec ?? (Cle_to ?? (toCle ?? H1))); Intro; Simpl.
Elim (le_lt_dec (auxP i) O); Intro; Simpl.
Cut (auxP i)=O; [Intro | Auto with arith].
Rewrite <- auxP_lemma0 in H2.
Cut (lt (auxP O) (auxP i)); [Intro | Apply auxP_lemma1; Assumption].
ElimType False; Rewrite H2 in H3; Apply (lt_n_n ? H3).
Generalize b1 a1; Clear b1 a1.
Rewrite (auxP_lemmai i b0 a0); Intros.
Simpl.
Elim (ProjS2 (h_f' ? (lt_pred' i n b0 a0))); Intros.
EApply eq_transitive_unfolded.
2: EApply eq_transitive_unfolded.
2: Apply p.
Unfold f'.
Apply prf1; Apply S_pred with O; Auto.
Apply h_nlnf; Reflexivity.
Rewrite <- auxP_lemman in b1.
Cut i=n.
Intro; ElimType False; Rewrite H2 in a0; Apply (lt_n_n ? a0).
Apply nat_mon_imp_inj with h:=auxP.
Apply auxP_lemma1.
Assumption.
Unfold auxP.
Elim (le_lt_dec i O); Intro; Simpl.
Apply le_O_n.
Elim (le_lt_dec n i); Intro; Simpl.
Elim (lt_n_n n); Apply le_lt_trans with i; Auto.
Apply plus_pred_pred_plus.
Elim (ProjS2 (h_f' ? (lt_pred' i n b1 b2))); Intros.
Change (lt (ProjS1 (h_f' ? (lt_pred' ?? b1 b2))) (plus (pred m) (pred n))).
Apply Clt_to; Assumption.
Generalize H; Clear H; Rewrite b1; Intro.
Rewrite auxP_lemman.
Exists (toCle ?? (le_n (pred (plus m n)))).
Elim (le_lt_eq_dec ?? (Cle_to ?? (toCle ?? (le_n (pred (plus m n)))))); Intro; Simpl.
ElimType False; Apply (lt_n_n ? a0).
Apply finish.
Qed.

Lemma Separated_Refinement_lft : (Refinement P Separated_Refinement).
ClearBody h Hh.
Clear auxR.
Exists auxP; Repeat Split.
Exact auxP_lemman.
Intros; Apply auxP_lemma1; Assumption.
Exact auxP_lemma2.
Qed.

Local auxR_lemma0 : (auxR O)=O.
ClearBody h Hh; Unfold auxR.
Elim (le_lt_dec O O); Intro; Simpl.
Reflexivity.
ElimType False; Inversion b0.
Qed.

Local auxR_lemmai : (i:nat)(Hi:(lt O i))(Hi':(lt i m))(auxR i)=(S (ProjS1 (h_g' (pred i) (lt_pred' ?? Hi Hi')))).
ClearBody h Hh; Intros.
Unfold auxR.
Elim (le_lt_dec m i); Intro; Simpl.
ElimType False; Apply le_not_lt with m i; Auto.
Elim (le_lt_dec i O); Intro; Simpl.
ElimType False; Apply lt_n_n with O; Apply lt_le_trans with i; Auto.
LetTac x:=(ProjS1 (h_g' ? (lt_pred' ?? b1 b0))).
LetTac y:=(ProjS1 (h_g' ? (lt_pred' ?? Hi Hi'))).
Cut x=y.
Intro; Auto with arith.
Cut {Hj:(Clt ??) | (g' ? (lt_pred' ?? b1 b0))[=](h x (Clt_to ?? Hj))}; [Intro | Exact (ProjS2 (h_g' ? (lt_pred' ?? b1 b0)))].
Cut {Hj:(Clt ??) | (g' ? (lt_pred' ?? Hi Hi'))[=](h y (Clt_to ?? Hj))}; [Intro | Exact (ProjS2 (h_g' ? (lt_pred' ?? Hi Hi')))].
Elim H; Clear H; Intros Hx Hx'.
Elim H0; Clear H0; Intros Hy Hy'.
Apply h_inj with (Clt_to ?? Hx) (Clt_to ?? Hy).
EApply eq_transitive_unfolded.
2: Apply Hy'.
EApply eq_transitive_unfolded.
Apply eq_symmetric_unfolded; Apply Hx'.
Apply g'_nlnf; Reflexivity.
Qed.

Local auxR_lemmam : (auxR m)=(pred (plus m n)).
ClearBody h Hh; Unfold auxR.
Elim (le_lt_dec m O); Intro; Simpl.
Cut m=O; [Intro | Auto with arith].
Transitivity (pred m).
Rewrite H; Auto.
Cut O=n; [Intro; Rewrite <- H0; Auto | Apply HP'].
Apply partition_length_zero with Hab; Rewrite <- H; Apply R.
Elim (le_lt_dec m m); Intro; Simpl.
Rewrite <- minus_n_n; Auto.
Elim (lt_n_n ? b1).
Qed.

Local auxR_lemma1 : (i,j:nat)(lt i j)->(lt (auxR i) (auxR j)).
ClearBody h Hh.
Intros; Unfold auxR.
Elim (le_lt_dec i O); Intro.
Elim (le_lt_dec j O); Intros; Simpl.
Apply le_lt_trans with i; Try Apply lt_le_trans with j; Auto with arith.
Elim (le_lt_dec m j); Intros; Simpl.
Omega.
Apply lt_O_Sn.
Elim (le_lt_dec m i); Elim (le_lt_dec j O); Intros; Simpl.
Elim (lt_n_n O); Apply le_lt_trans with i; Try Apply lt_le_trans with j; Auto with arith.
Elim (le_lt_dec m j); Intro; Simpl.
Apply lt_reg_l.
Apply simpl_lt_plus_l with m.
Repeat Rewrite <- le_plus_minus; Auto.
Elim (le_not_lt m i); Auto; Apply lt_trans with j; Auto.
Elim (lt_n_n O); Apply lt_trans with i; Auto; Apply lt_le_trans with j; Auto.
Elim (le_lt_dec m j); Intro; Simpl.
LetTac H0:=nm0; LetTac H1:=mn0; Apply lt_le_trans with (S (plus (pred m) (pred n))).
Apply lt_n_S.
Apply Clt_to; Apply (proj1_sig ?? (ProjS2 (h_g' (pred i) (lt_pred' ?? b0 b2)))).
Rewrite <- plus_Sn_m.
Rewrite <- S_pred with m O.
2: Apply lt_trans with i; Auto.
Replace (plus m (pred n)) with (pred (plus m n)).
Auto with arith.
Cut (S (pred (plus m n)))=(S (plus m (pred n))); Auto.
Rewrite plus_n_Sm.
Rewrite <- S_pred with n O; Auto with arith.
Symmetry; Apply S_pred with O.
Apply lt_le_trans with m; Auto with arith.
Apply lt_trans with i; Auto.
Apply neq_O_lt.
Intro.
Apply lt_n_n with O.
Apply lt_trans with i; Auto.
Rewrite nm0; Auto.
Apply lt_n_S.
Cut ~~(lt (ProjS1 (h_g' (pred i) (lt_pred' ?? b0 b2))) (ProjS1 (h_g' (pred j) (lt_pred' ?? b1 b3)))); Intro.
Apply not_not_lt; Assumption.
Cut (le (ProjS1 (h_g' (pred j) (lt_pred' ?? b1 b3))) (ProjS1 (h_g' (pred i) (lt_pred' ?? b0 b2)))); Intros.
2: Apply not_lt; Assumption.
Cut (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_g' (pred j) (lt_pred' ?? b1 b3))))))[<=]
  (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_g' (pred i) (lt_pred' ?? b0 b2)))))).
Intro.
2: Apply h_mon'; Assumption.
Cut (g' (pred j) (lt_pred' ?? b1 b3))[<=](g' (pred i) (lt_pred' ?? b0 b2)).
2: Apply leEq_wdl with (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_g' (pred j) (lt_pred' ?? b1 b3)))))).
2: Apply leEq_wdr with (h ? (Clt_to ?? (proj1_sig ?? (ProjS2 (h_g' (pred i) (lt_pred' ?? b0 b2)))))).
2: Assumption.
3: Apply eq_symmetric_unfolded; Exact (proj2_sig ?? (ProjS2 (h_g' (pred j) (lt_pred' ?? b1 b3)))).
2: Apply eq_symmetric_unfolded; Exact (proj2_sig ?? (ProjS2 (h_g' (pred i) (lt_pred' ?? b0 b2)))).
Clear H2 H1; Intro.
Cut (g' ? (lt_pred' ?? b0 b2))[<](g' ? (lt_pred' ?? b1 b3)).
2: Apply g'_mon.
2: Apply lt_pred'; Assumption.
Intro.
ElimType False.
Apply less_irreflexive_unfolded with x:=(g' ? (lt_pred' ?? b1 b3)).
EApply leEq_less_trans; [Apply H1 | Apply H2].
Qed.

Local auxR_lemma2 : (j:nat)(H:(le j m)){H':(Cle (auxR j) ?) | (Pts R j H)[=](Pts Separated_Refinement ? (Cle_to ?? H'))}.
ClearBody h Hh; Intros.
Unfold Separated_Refinement; Simpl.
Unfold Separated_Refinement_fun; Simpl.
Elim (le_lt_dec j O); Intro; Simpl.
Cut j=O; [Intro | Auto with arith].
Generalize H; Clear a0 H; Rewrite H0.
Rewrite auxR_lemma0.
Clear H0; Intros.
Exists (toCle ?? (le_O_n (pred (plus m n)))).
Elim (le_lt_eq_dec ?? (Cle_to ?? (toCle ?? (le_O_n (pred (plus m n)))))); Intro; Simpl.
Elim (le_lt_dec O O); Intro; Simpl.
Apply start.
ElimType False; Inversion b0.
Apply eq_transitive_unfolded with a.
Apply start.
Apply partition_length_zero with Hab.
Cut (le (plus m n) (1)).
Intros.
Elim (plus_eq_one_imp_eq_zero ?? H0); Intro.
Rewrite <- a0; Apply R.
Rewrite <- b1; Apply P.
Generalize b0; Clear b0.
Case (plus m n).
Auto.
Intros.
Simpl in b0; Rewrite <- b0; Auto.
Elim (le_lt_eq_dec ?? H); Intro.
Cut (lt (pred j) (pred m)); [Intro | Red; Rewrite <- S_pred with j O; Auto; Apply le_2; Auto].
Cut (le (auxR j) (pred (plus m n))).
Intro; Exists (toCle ?? H1).
Elim (le_lt_eq_dec ?? (Cle_to ?? (toCle ?? H1))); Intro; Simpl.
Elim (le_lt_dec (auxR j) O); Intro; Simpl.
Cut (auxR j)=O; [Intro | Auto with arith].
Rewrite <- auxR_lemma0 in H2.
Cut (lt (auxR O) (auxR j)); [Intro | Apply auxR_lemma1; Assumption].
ElimType False; Rewrite H2 in H3; Apply (lt_n_n ? H3).
Generalize b1 a1; Clear b1 a1.
Rewrite (auxR_lemmai j b0 a0); Intros.
Simpl.
Elim (ProjS2 (h_g' ? (lt_pred' ?? b0 a0))); Intros.
EApply eq_transitive_unfolded.
2: EApply eq_transitive_unfolded.
2: Apply p.
Unfold g'.
Apply prf1; Apply S_pred with O; Auto.
Apply h_nlnf; Reflexivity.
Rewrite <- auxR_lemmam in b1.
Cut j=m.
Intro; ElimType False; Rewrite H2 in a0; Apply (lt_n_n ? a0).
Apply nat_mon_imp_inj with h:=auxR.
Apply auxR_lemma1.
Assumption.
Unfold auxR.
Elim (le_lt_dec j O); Intro; Simpl.
Apply le_O_n.
Elim (le_lt_dec m j); Intro; Simpl.
Rewrite inj_minus_aux.
Rewrite <- plus_n_O; Auto with arith.
Apply lt_not_le; Auto.
Apply plus_pred_pred_plus.
Elim (ProjS2 (h_g' ? (lt_pred' ?? b1 b2))); Intros.
Change (lt (ProjS1 (h_g' ? (lt_pred' ?? b1 b2))) (plus (pred m) (pred n))).
Apply Clt_to; Assumption.
Generalize H; Clear H; Rewrite b1; Intro.
Rewrite auxR_lemmam.
Exists (toCle ?? (le_n (pred (plus m n)))).
Elim (le_lt_eq_dec ?? (Cle_to ?? (toCle ?? (le_n (pred (plus m n)))))); Intro; Simpl.
ElimType False; Apply (lt_n_n ? a0).
Apply finish.
Qed.

Lemma Separated_Refinement_rht : (Refinement R Separated_Refinement).
ClearBody h Hh.
Exists auxR; Repeat Split.
Exact auxR_lemmam.
Intros; Apply auxR_lemma1; Assumption.
Exact auxR_lemma2.
Qed.

End Refining_Separated.