Set Warnings "-notation-overridden".
From mathcomp Require Import all_ssreflect boolp.
Set Warnings "notation-overridden".
From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Crypt Require Import ChoiceAsOrd chUniverse.
From Crypt Require Import SubDistr.

(*so that Next Obligation doesnt introduce variables by itself:*)
Obligation Tactic := try (Tactics.program_simpl ; fail) ; simpl.

(*
In this file we pack pairs of free probabilistic computations into a
(order enriched) relative monad instance (see ord_relativeMonad).

Some informations about free monads:

The unary Free monad can be parametrized by a collection of operations S
and arities for those operations (somth of type S -> choiceType).
Concretely S could be the collection {(sample_bollean p) | p in [01]}, ie
one Bernouilli sampling operation for each probability p. In this case
the arity predicate (ar : S -> choiceType) would map each operation to bool
(or rather the choiceType instance for bool).
Indeed we expect the environment to either return true or false after
a Bernouilli sampling operation has been issued to it.

We take S = { X: chUniverse & SDistr X }, that is, each subdistribution
sampling from a choiceType present in chUniverse (a small universe of choiceTypes)
is considered as being part of our probabilistic signature (S,P)
where P : S -> choiceType is the first projection.

NOTE regarding ancient design:

Note that before we were specifying a probabilistic operation with
an ITree like event type
Inductive probE : Type -> Type :=
  |Bern : unit_interval R -> probE bool
  |Poisson : (λ : unit_interval R) → probE nat.
The parameter of the inductive is supposed to be the type of the valued
returned by the environment after an operation has been issued. The
parameters of the constructors are supposed to represent the information
we would like to pass when we issue an operation. For instance when
sampling uniformly a boolean we need to provide a probability p : [O,1].
We were using this last way of specifying sampling operations generically
and we were translating this signature
internally into a collection of operations S and an
arity predicate ar : S -> choiceType
*)

Section Extensionality_for_ordfunctors.
  (*work in progress*)

  (*the following relies on proof irrelevance (see file axioms)*)
  (*/!\ also need the arrow map*)
  Lemma functor_ext : forall (C D : ord_category) (F G : ord_functor C D),
  (forall A : C, F A = G A) -> F = G.
  Proof.
    intros C D F G H.  apply boolp.funext in H.
    destruct F as [F F2 F3 F4 F5]. destruct G as [G G2 G3 G4 G5].
    simpl in H.
    move: F2 F3 F4 F5 G2 G3 G4 G5.
    rewrite !H. intuition. assert (FG2 : F2 = G2).
  Abort.

End Extensionality_for_ordfunctors.

Section RelativeFreeMonad.
  (*This section defines a unary free monad relative to choice_incl.
   In this section the free relative monad is parametrized by an arbitrary
   set S of operations. In subsequent sections this set S is an actual set of
   probabilistic operations. *)

  (* A signature where S is the type of operations and P describes the
     arity of each operations *)
  Context (S : Type) (P : S  -> choiceType).

  Inductive rFreeF (A : choiceType) : Type :=
  | retrFree : A -> rFreeF A
  | ropr     : forall s, (P s -> rFreeF A) -> rFreeF A.

  Arguments ropr [A] _ _.

  Fixpoint bindrFree {A B : choiceType} (c : rFreeF A)
  (k : TypeCat ⦅ choice_incl A ; rFreeF B ⦆ )
  : rFreeF B :=
    match c with
    | retrFree a => k a
    | ropr s ar  => ropr s (fun p => bindrFree (ar p) k)
    end.

  Definition callrFree (s : S) : rFreeF (P s) := ropr s (fun k => retrFree _ k).

  Program Definition rFree : ord_relativeMonad choice_incl :=
    @mkOrdRelativeMonad ord_choiceType TypeCat choice_incl rFreeF _ _ _ _ _ _.
  Next Obligation. constructor. assumption. Defined.
  Next Obligation.
    intros A B. intros ff mm. exact (bindrFree mm ff).
  Defined.
  Next Obligation.
    cbv ; intuition. f_equal. apply funext. move=> a. eapply H.
  Qed.
  Next Obligation.
    intro A. apply funext.
    intro c. elim: c.
      simpl. reflexivity.
    intros s ar IH. simpl. f_equal. apply funext.
    assumption.
  Qed.
  Next Obligation.
    intros.
    apply funext. intro c. induction c.
      simpl. reflexivity.
    simpl. f_equal. apply funext. intro p.
    eapply H.
  Qed.

End RelativeFreeMonad.

Section Unary_free_prob_monad.

  (* the type of probabilistic operations*)
  Definition P_OP  := { X : chUniverse & SDistr X }.

  (* the arities for operations in OPP*)
  Definition P_AR : P_OP -> choiceType :=
    fun op => chElement ( projT1 op ).

  Definition rFreePr := rFree P_OP P_AR.

End Unary_free_prob_monad.

Section Pairs_of_probabilistic_computations.
  (*We want to obtain a product of relative monads, the product of rFreePr
  with itself. We use the support for product of relative
  monads provided by the dm4all devlopment .*)

  Definition rFreeProb_squ_fromProd :=
    product_rmon rFreePr rFreePr.

  (*alias for retro compatibility*)
  Definition rFreeProb_squ := rFreeProb_squ_fromProd.

End Pairs_of_probabilistic_computations.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

 *)

Require Export nuprl_props.
Require Export choice.
Require Export cvterm.

Lemma tequality_iff_mkc_tequality {o} :
  forall lib (A B : @CTerm o),
    type lib (mkc_tequality A B) <=> tequality lib A B.
Proof.
  introv.
  split; intro k.

  - unfold type, tequality in k; exrepnd.
    inversion k0; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    exists eqa; auto.

  - unfold tequality in k; exrepnd.
    exists (@true_per o).
    apply CL_teq; unfold per_teq.
    fold (@nuprl o).
    exists A B A B eq; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprl_refl in k0; auto.
    apply nuprl_sym in k0; apply nuprl_refl in k0; auto.
Qed.

Lemma tequality_mkc_tequality {o} :
  forall lib (A B C D : @CTerm o),
    tequality lib (mkc_tequality A B) (mkc_tequality C D)
    <=> (tequality lib A C # tequality lib B D # tequality lib A B).
Proof.
  introv.
  split; intro k.

  - unfold tequality in k; exrepnd.
    inversion k0; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    dands; exists eqa; auto.

  - unfold tequality in k; exrepnd.
    exists (@true_per o).
    apply CL_teq; unfold per_teq.
    fold (@nuprl o).

    assert (eq1 <=2=> eq)
      as eqs1
        by (apply nuprl_refl in k1; apply nuprl_refl in k2;
            generalize (nuprl_uniquely_valued lib A eq1 eq); intro k;
            repeat (autodimp k hyp)).

    assert (eq0 <=2=> eq)
      as eqs2
        by (apply nuprl_sym in k2; apply nuprl_refl in k3; apply nuprl_refl in k2;
            generalize (nuprl_uniquely_valued lib B eq0 eq); intro k;
            repeat (autodimp k hyp)).

    exists A B C D eq; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply @nuprl_ext with (eq1 := eq1); auto.
    apply @nuprl_ext with (eq1 := eq0); auto.
Qed.

Lemma mkc_tequality_equality_in_uni {o} :
  forall lib (A B C D : @CTerm o) i,
    tequalityi lib i (mkc_tequality A B) (mkc_tequality C D)
    <=> (tequalityi lib i A C # tequalityi lib i B D # tequalityi lib i A B).
Proof.
  introv.
  split; intro k.

  - unfold tequalityi, equality in k; exrepnd.
    inversion k1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    inversion h2; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    dands; exists eq; sp; allrw; exists eqa0; auto.

  - unfold tequalityi, equality in k; exrepnd.
    generalize (nuprl_uniquely_valued lib (mkc_uni i) eq0 eq k1 k3); intro eqs1.
    generalize (nuprl_uniquely_valued lib (mkc_uni i) eq1 eq k0 k3); intro eqs2.
    clear k0 k1.
    rw eqs1 in k4; clear eqs1.
    rw eqs2 in k5; clear eqs2.
    exists eq; dands; auto.
    inversion k3; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    fold (@nuprli o lib j0) in h2, h3, h4.
    rw h0; exists (@true_per o).
    dup h2 as na1; apply nuprli_refl in na1.
    dup h4 as na2; apply nuprli_refl in na2.
    generalize (nuprli_uniquely_valued lib j0 j0 A A eqa1 eqa na1 na2); clear na1 na2; intro eqs1.
    dup h3 as nb1; apply nuprli_refl in nb1.
    dup h4 as nb2; apply nuprli_sym in nb2; apply nuprli_refl in nb2.
    generalize (nuprli_uniquely_valued lib j0 j0 B B eqa0 eqa nb1 nb2); clear nb1 nb2; intro eqs2.
    apply CL_teq; fold (@nuprli o lib j0).
    exists A B C D eqa; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprli_ext with (eq1 := eqa1); auto.
    apply nuprli_ext with (eq1 := eqa0); auto.
Qed.

Lemma equality_in_mkc_tequality {o} :
  forall lib (a b A B : @CTerm o),
    equality lib a b (mkc_tequality A B) <=> tequality lib A B.
Proof.
  introv; split; intro k.

  - apply inhabited_implies_tequality in k.
    rw @tequality_iff_mkc_tequality in k; auto.

  - exists (@true_per o); dands; auto; try (complete (unfold true_per; auto)).
    unfold tequality in k; exrepnd.
    apply CL_teq.
    exists A B A B eq; fold (@nuprl o); sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprl_refl in k0; auto.
    apply nuprl_sym in k0; apply nuprl_refl in k0; auto.
Qed.


From Coq Require Import
     Morphisms
     Setoid
     RelationClasses
     Arith
     Lia
     List.

From ExtLib Require Import
     Monad
     Traversable
     Data.List.

From ITree Require Import
     ITree
     ITreeFacts
     Traces.

Import ListNotations.
Import ITreeNotations.
Import MonadNotation.
Open Scope monad_scope.

(* * Idea * *)
(* An environment is an transition system over state space and action space. An deterministic environment has type "State * Action -> State" and an agent policy has type "State -> Action". Now represent an environment as an itree and agent policy as effect. *)

(* * Example * *)
(* One-demension road with cliff. State space has type "nat" and there is a cliff at position "4". Action space is "{Left, Right}". If the car reach position "4" it will crash. A safe environment should not let this happen while any decision the agent makes. *)

Definition StateT := nat.

Inductive ActionT : Type :=
| Left
| Right.

(* There are only three effects. Read current state, read the action generated by agent with current state, update current state. Each step an agent goes in an environment will cause these three effects. *)

Inductive rlE : Type -> Type :=
| InputA : rlE ActionT
| InputS: rlE StateT
| OutputS : StateT -> rlE unit.

(* An enviornment has type "itree rlE unit", which says it can cause all effects in rlE and return nothing(the only output of an environment is exported by "OutputS"). It should first read current state and the action maked by agent, then write a new state. *)

Definition trigger_inr1 {D E : Type -> Type} : E ~> itree (D +' E)
  := fun _ e => ITree.trigger (inr1 e).
Arguments trigger_inr1 {D E} [T].

Definition unsafe_env : itree rlE unit :=
  (rec-fix env_ _ :=
     state <- trigger_inr1 InputS ;; (* read current state *)
           action <- ITree.trigger (inr1 InputA) ;; (* read action from agent *)
           match (state, action) with
           | (0, Left) => ITree.trigger (inr1 (OutputS 0)) ;; env_ tt
           | (S s, Left) => ITree.trigger (inr1 (OutputS s)) ;; env_ tt
           | (s, Right) => ITree.trigger (inr1 (OutputS (S s))) ;; env_ tt
           end
  ) tt.

Definition safe_env_body : StateT -> ActionT -> StateT :=
  fun state action =>
    match state with
    | 0 =>
      match action with
      | Left => 0
      | Right => S state
      end
    | S (2 as s) =>
      match action with
      | Left => 2
      | Right => 3
      end
    | S s =>
      match action with
      | Left => s
      | Right => S state
      end
    end.

(* A trace of a reinforcement environment looks like "{s <- InputS ;; a <- InputA ;; tt <- OutputS s'}*": "s" represents the current state, "a" represents the action generated by the agent, "s'" indicates the next state, which is the output of an environment. A RL trace has to follow the consistency requirement: the adjacent "s'" and "s" should be equal. i.e. in "s1 <- InputS ;; a1 <- InputA ;; tt <- OutputS s1' ;; a2 <- InputS ;; a2 <- InputA ;; tt <- OutputS s2'...", "s1' = s2".  *)

Notation "[ e , a ] t" := (TEventResponse e a t) (at level 80, right associativity).
Notation "[< e >]" := (TEventEnd e) (at level 80, right associativity).

Definition StepRecord : Type := StateT * ActionT * StateT.

Definition ret_rl_trace (x : StepRecord) : @trace rlE unit :=
  match x with
    (s, a, s') => [InputS, s] [InputA, a] [< OutputS s'>]
  end.
Definition bind_rl_trace (x : StepRecord) (tr: @trace rlE unit) : @trace rlE unit :=
  match x with
    (s, a, s') => [InputS, s] [InputA, a] [OutputS s', tt] tr
  end.

Definition step_adjacent (x1 x2: StepRecord) : Prop :=
  match x1, x2 with
    (s1, a1, s1'), (s2, a2, s2') => s1' = s2
  end.

Inductive is_rltrace : @trace rlE unit -> Prop :=
| ret_is_rltrace : forall x, is_rltrace (ret_rl_trace x)
| bind_ret_is_rltrace: forall x1 x2,
    step_adjacent x1 x2 ->
    is_rltrace (bind_rl_trace x1 (ret_rl_trace x2))
| bind_bind_is_rltrace: forall x1 x2 tr,
    step_adjacent x1 x2 ->
    is_rltrace (bind_rl_trace x2 tr) ->
    is_rltrace (bind_rl_trace x1 (bind_rl_trace x2 tr)).

(* An inductive invariant of an environment says: within one step "(s,a,s')", if "s" <= 3, forall "a", "s'" <=3. *)

Print Eqdep.EqdepTheory.inj_pair2.

Ltac inj_event_pair :=
  match goal with
  | [H : existT _ _ _ = existT _ _ _ |- _] => (apply (Eqdep.EqdepTheory.inj_pair2 Type) in H; subst)
  end.

Ltac clear_id :=
  match goal with
  | [H : ?a = ?a |- _] => clear H
  end.

Section Proper.
  Local Open Scope signature_scope.

  Global Instance proper_is_trace {E R} : Proper ((@eutt E R R eq) ==> eq ==> iff) is_trace.
  Proof.
    intros t t' Ht tr tr' Htr. subst tr'.
    apply trace_eq_iff_eutt in Ht.
    unfold trace_eq in Ht.
    intuition.
  Qed.

End Proper.

Ltac inj_event_pair_all := repeat (try inj_event_pair; idtac).
Ltac auto_is_trace_H H := unfold observe in H; cbn in H.
Ltac inv_is_trace H := auto_is_trace_H H; inversion H; try inj_event_pair_all; try clear_id; try clear H.

Lemma inv_vis_inputS : forall k s (tr: @trace rlE unit), is_trace (Vis InputS k) ([InputS, s] tr) -> is_trace (k s) tr.
Proof. intros. inv_is_trace H. auto. Qed.

Lemma inv_vis_inputA : forall k a (tr: @trace rlE unit), is_trace (Vis InputA k) ([InputA, a] tr) -> is_trace (k a) tr.
Proof. intros. inv_is_trace H. auto. Qed.

Lemma inv_vis_outputS : forall k s s' (tr: @trace rlE unit), is_trace (Vis (OutputS s) k) ([OutputS s', tt] tr) ->
                                                             s = s' ->
                                                             is_trace (k tt) tr.
Proof. intros. inv_is_trace H. auto. Qed.

Lemma inv_vis_outputS_2 : forall (k: unit -> itree rlE unit) s s' , is_trace (Vis (OutputS s) k) ([<OutputS s'>]) ->
                                                                    s = s'.
Proof. intros. inv_is_trace H. inversion H2. auto. Qed.

Lemma inv_vis_triggerS : forall k s (tr: @trace rlE unit), is_trace (ITree.bind (ITree.trigger InputS) k) ([InputS, s] tr) <-> is_trace (k s) tr.
Proof.
  split; intros.
  - repeat setoid_rewrite bind_trigger in H. inv_is_trace H. auto.
  - unfold is_trace, observe. cbn. constructor. auto.
Qed.

Lemma inv_vis_triggerA : forall k a (tr: @trace rlE unit), is_trace (ITree.bind (ITree.trigger InputA) k) ([InputA, a] tr) <-> is_trace (k a) tr.
Proof.
  split; intros.
  - repeat setoid_rewrite bind_trigger in H. inv_is_trace H. auto.
  - unfold is_trace, observe. cbn. constructor. auto.
Qed.

Lemma inv_vis_triggerSoutputS : forall k s s' (tr: @trace rlE unit),
    is_trace (ITree.trigger (OutputS s);; k tt) ([OutputS s', tt] tr) <-> s = s' /\ is_trace (k tt) tr.
Proof.
  split; intros.
  - repeat setoid_rewrite bind_trigger in H. inv_is_trace H. split; auto. inversion H2; auto.
  - destruct H. unfold is_trace, observe. cbn. rewrite H. constructor. auto.
Qed.

Lemma inv_vis_triggerSoutputSEnd : forall (t : itree rlE unit) s s',
    is_trace (ITree.trigger (OutputS s);; t) ([<OutputS s'>]) <-> s = s'.
Proof.
  split; intros.
  - repeat setoid_rewrite bind_trigger in H. inv_is_trace H. inversion H2; auto.
  - destruct H. unfold is_trace, observe. cbn. constructor.
Qed.

Definition env_generator (f: StateT -> ActionT -> StateT) : itree rlE unit :=
  (rec-fix env_ _ :=
     state <- trigger_inr1 InputS ;; (* read current state *)
           action <- trigger_inr1 InputA ;; (* read action from agent *)
           trigger_inr1 (OutputS (f state action)) ;; (* write new state *)
           env_ tt
  ) tt.

Definition step_generator (f: StateT -> ActionT -> StateT) : itree rlE unit :=
  state <- ITree.trigger InputS ;; (* read current state *)
        action <- ITree.trigger InputA ;; (* read action from agent *)
        ITree.trigger (OutputS (f state action)) ;; (* write new state *)
        Ret tt.

Lemma is_trace_bodyf : forall (s s': StateT) (a: ActionT) bodyf,
    is_trace (step_generator bodyf) (ret_rl_trace (s, a, s')) <->
    bodyf s a = s'.
Proof.
  split; intros.
  - unfold step_generator in H. cbn in H.
    rewrite inv_vis_triggerS in H.
    rewrite inv_vis_triggerA in H.
    rewrite inv_vis_triggerSoutputSEnd in H.
    auto.
  - unfold step_generator. cbn.
    rewrite inv_vis_triggerS.
    rewrite inv_vis_triggerA.
    rewrite inv_vis_triggerSoutputSEnd.
    auto.
Qed.

Lemma is_trace_rec_nil : forall (s s': StateT) (a: ActionT) bodyf,
    is_trace (env_generator bodyf) (ret_rl_trace (s, a, s')) <->
    is_trace (step_generator bodyf) (ret_rl_trace (s, a, s')).
Proof.
  split; intros.
  - setoid_rewrite rec_as_interp in H.
    match goal with
    | H: context [recursive ?b] |- _ => remember b as body in H
    end.
    repeat setoid_rewrite interp_bind in H.
    repeat setoid_rewrite interp_trigger in H.
    cbn in H.
    rewrite inv_vis_triggerS in H.
    rewrite inv_vis_triggerA in H.
    rewrite inv_vis_triggerSoutputSEnd in H.
    rewrite is_trace_bodyf. auto.
  - rewrite is_trace_bodyf in H.
    unfold env_generator. cbn.
    setoid_rewrite rec_as_interp.
    match goal with
    | H: _ |- context [recursive ?b] => remember b as body in H
    end.
    repeat setoid_rewrite interp_bind.
    repeat setoid_rewrite interp_trigger.
    cbn.
    rewrite inv_vis_triggerS.
    rewrite inv_vis_triggerA.
    rewrite inv_vis_triggerSoutputSEnd.
    auto.
Qed.

Definition safe_env : itree rlE unit := env_generator safe_env_body.

Lemma safe_inductive_invariant : forall (s s': StateT) (a: ActionT),
    safe_env_body s a = s' -> s <= 3 -> s' <= 3.
Proof.
  unfold safe_env_body.
  intros.
  repeat match goal with
         | H : context [match s with _ => _ end] |- _ => destruct s
         | H : context [match a with _ => _ end] |- _ => destruct a
         | _ => subst; auto; lia
         end.
Qed.

Lemma is_trace_rl_split: forall s a s' tr bodyf,
    is_trace (env_generator bodyf) (bind_rl_trace (s, a, s') tr) ->
    (is_trace (env_generator bodyf) tr) /\
    is_trace (env_generator bodyf) (ret_rl_trace (s, a, s')).
Proof.
  intros. cbn in H. unfold env_generator in H.
  setoid_rewrite rec_as_interp in H.
  match goal with
  | H: context [recursive ?b] |- _ => remember b as body in H
  end.
  repeat setoid_rewrite interp_bind in H.
  repeat setoid_rewrite interp_trigger in H.
  cbn in H.
  rewrite inv_vis_triggerS in H.
  rewrite inv_vis_triggerA in H.
  rewrite inv_vis_triggerSoutputS in H.
  destruct H. split.
  - unfold safe_env. unfold env_generator.
    unfold rec_fix.
    rewrite <- Heqbody.
    auto.
  - unfold safe_env.
    rewrite is_trace_rec_nil.
    rewrite is_trace_bodyf.
    auto.
Qed.

(* We can say, if an agent start form position less equal than 3, and the environment satisfies the inductive invariant, the trace of environment will not reach the position 4. *)

Inductive trace_init : (StateT -> Prop) -> @trace rlE unit -> Prop :=
| ret_trace_init :
    forall (s s': StateT) (a: ActionT) (phi: StateT -> Prop),
      phi s -> trace_init phi (ret_rl_trace (s, a, s'))
| bind_trace_init :
    forall (s s': StateT) (a: ActionT) (phi: StateT -> Prop) tr,
      phi s -> trace_init phi (bind_rl_trace (s, a, s') tr).

Inductive trace_end : (StateT -> Prop) -> @trace rlE unit -> Prop :=
| ret_trace_end :
    forall (s s': StateT) (a: ActionT) (phi: StateT -> Prop),
      phi s' -> trace_end phi (ret_rl_trace (s, a, s'))
| bind_trace_end :
    forall (s s': StateT) (a: ActionT) (phi: StateT -> Prop) tr,
      trace_end phi tr -> trace_end phi (bind_rl_trace (s, a, s') tr).

Lemma inv_trace_init_ret : forall phi s a s',
    trace_init phi (ret_rl_trace (s, a, s')) <-> phi s.
Proof.
  split; intros.
  - inv_is_trace H. auto.
  - constructor. auto.
Qed.

Lemma inv_trace_end_ret : forall phi s a s',
    trace_end phi (ret_rl_trace (s, a, s')) <-> phi s'.
Proof.
  split; intros.
  - inv_is_trace H. auto.
  - constructor. auto.
Qed.

Lemma inv_trace_init_bind : forall phi s a s' tr,
    trace_init phi (bind_rl_trace (s, a, s') tr) <->
    phi s.
Proof.
  split; intros.
  - inv_is_trace H. auto.
  - constructor. auto.
Qed.

Lemma inv_trace_end_bind : forall phi s a s' tr,
    trace_end phi (bind_rl_trace (s, a, s') tr) <->
    trace_end phi tr.
Proof.
  split; intros.
  - inv_is_trace H. auto.
  - constructor. auto.
Qed.

(* The following safe lemma can be proved by the inductive invariant. *)

Lemma safe: forall (tr: @trace rlE unit),
    is_rltrace tr ->
    trace_init (fun s => s <= 3) tr ->
    trace_end (fun s' => s' = 4) tr ->
    not (is_trace safe_env tr).
Proof.
  unfold not.
  intros. cbn in H0. unfold safe_env in H2.
  induction H.
  - destruct x, p.
    rewrite is_trace_rec_nil in H2.
    rewrite is_trace_bodyf in H2.
    rewrite inv_trace_init_ret in H0.
    rewrite inv_trace_end_ret in H1.
    apply safe_inductive_invariant in H2; auto.
    subst. lia.
  - destruct x1, x2, p, p0.
    rewrite inv_trace_init_bind in H0.
    rewrite inv_trace_end_bind in H1.
    rewrite inv_trace_end_ret in H1.
    inversion H. clear H.
    apply is_trace_rl_split in H2.
    destruct H2.
    rewrite is_trace_rec_nil in H.
    rewrite is_trace_rec_nil in H2.
    rewrite is_trace_bodyf in H.
    rewrite is_trace_bodyf in H2.
    apply safe_inductive_invariant in H2; auto. subst.
    apply safe_inductive_invariant in H; auto. lia.
  - destruct x1, x2, p, p0.
    rewrite inv_trace_init_bind in H0.
    rewrite inv_trace_end_bind in H1.
    rewrite inv_trace_end_bind in H1.
    inversion H. clear H. subst.
    apply is_trace_rl_split in H2.
    rewrite is_trace_rec_nil in H2.
    rewrite is_trace_bodyf in H2.
    destruct H2.
    apply IHis_rltrace; clear IHis_rltrace; auto.
    * rewrite inv_trace_init_bind. apply safe_inductive_invariant in H2; auto.
    * rewrite inv_trace_end_bind. auto.
Qed.


(** Experiments for the "composable monads" project. *)
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import Coq.Lists.Streams.
Require Import Coq.Strings.String.

Import ListNotations.
Local Open Scope string_scope.

Set Implicit Arguments.

Module Monad.
  Record t := New {
    S : Type;
    E : Type }.
End Monad.

Module Result.
  Inductive t (A B C : Type) : Type :=
  | Val : A -> t A B C
  | Err : B -> t A B C
  | Mon : C -> t A B C.

  Arguments Val {A B C} _.
  Arguments Err {A B C} _.
  Arguments Mon {A B C} _.
End Result.

Module M.
  Inductive t (m : Monad.t) (A : Type) : Type :=
  | New : (Monad.S m -> Result.t A (Monad.E m) (t m A) * Monad.S m) -> t m A.

  Definition open (m : Monad.t) A (x : t m A)
    : Monad.S m -> Result.t A (Monad.E m) (t m A) * Monad.S m :=
    match x with
    | New x' => x'
    end.
End M.

Module Id.
  Definition m : Monad.t :=
    Monad.New unit Empty_set.
End Id.

Definition ret {m : Monad.t} A (x : A) : M.t m A :=
  M.New (fun s => (Result.Val x, s)).

Fixpoint bind {m : Monad.t} A B (x : M.t m A) (f : A -> M.t m B) : M.t m B :=
  M.New (fun s =>
    match M.open x s with
    | (Result.Val x, s) => (Result.Mon (f x), s)
    | (Result.Err e, s) => (Result.Err e, s)
    | (Result.Mon x, s) => (Result.Mon (bind x f), s)
    end).

Definition seq {m : Monad.t} A B (x : M.t m A) (f : M.t m B) : M.t m B :=
  bind x (fun _ => f).

Fixpoint run {m : Monad.t} A (x : M.t m A) (s : Monad.S m)
  : (A + Monad.E m) * Monad.S m :=
  match M.open x s with
  | (Result.Val x, s) => (inl x, s)
  | (Result.Err e, s) => (inr e, s)
  | (Result.Mon x, s) => run x s
  end.

Definition combine (m1 m2 : Monad.t) : Monad.t :=
  Monad.New (Monad.S m1 * Monad.S m2) (Monad.E m1 + Monad.E m2).

Infix "++" := combine.

Fixpoint combine_id (m : Monad.t) A (x : M.t (Id.m ++ m) A) : M.t m A :=
  M.New (fun s =>
    match M.open x (tt, s) with
    | (Result.Val x, (_, s)) => (Result.Val x, s)
    | (Result.Err (inr e), (_, s)) => (Result.Err e, s)
    | (Result.Err (inl e), _) => match e with end
    | (Result.Mon x, (_, s)) => (Result.Mon (combine_id x), s)
    end).

Fixpoint combine_commut (m1 m2 : Monad.t) A (x : M.t (m1 ++ m2) A)
  : M.t (m2 ++ m1) A :=
  M.New (m := m2 ++ m1) (fun s =>
    let (s2, s1) := s in
    match M.open x (s1, s2) with
    | (Result.Val x, (s1, s2)) => (Result.Val x, (s2, s1))
    | (Result.Err e, (s1, s2)) =>
      (Result.Err (match e with
      | inl e1 => inr e1
      | inr e2 => inl e2
      end), (s2, s1))
    | (Result.Mon x', (s1, s2)) => (Result.Mon (combine_commut x'), (s2, s1))
    end).

Fixpoint combine_assoc_left (m1 m2 m3 : Monad.t) A (x : M.t ((m1 ++ m2) ++ m3) A)
  : M.t (m1 ++ (m2 ++ m3)) A :=
  M.New (m := m1 ++ (m2 ++ m3)) (fun s =>
    match s with
    | (s1, (s2, s3)) =>
      match M.open x ((s1, s2), s3) with
      | (Result.Val x, ((s1, s2), s3)) => (Result.Val x, (s1, (s2, s3)))
      | (Result.Err e, ((s1, s2), s3)) =>
        let e := match e with
          | inl (inl e1) => inl e1
          | inl (inr e2) => inr (inl e2)
          | inr e3 => inr (inr e3)
          end in
        (Result.Err e, (s1, (s2, s3)))
      | (Result.Mon x, ((s1, s2), s3)) => (Result.Mon (combine_assoc_left x), (s1, (s2, s3)))
      end
    end).

Fixpoint combine_assoc_right (m1 m2 m3 : Monad.t) A (x : M.t (m1 ++ (m2 ++ m3)) A)
  : M.t ((m1 ++ m2) ++ m3) A :=
  M.New (m := (m1 ++ m2) ++ m3) (fun s =>
    match s with
    | ((s1, s2), s3) =>
      match M.open x (s1, (s2, s3)) with
      | (Result.Val x, (s1, (s2, s3))) => (Result.Val x, ((s1, s2), s3))
      | (Result.Err e, (s1, (s2, s3))) =>
        let e := match e with
          | inl e1 => inl (inl e1)
          | inr (inl e2) => inl (inr e2)
          | inr (inr e3) => inr e3
          end in
        (Result.Err e, ((s1, s2), s3))
      | (Result.Mon x, (s1, (s2, s3))) => (Result.Mon (combine_assoc_right x), ((s1, s2), s3))
      end
    end).

Fixpoint lift {m m' : Monad.t} A (x : M.t m' A) : M.t (m ++ m') A :=
  M.New (m := m ++ m') (fun s =>
    let (s1, s2) := s in
    match M.open x s2 with
    | (Result.Val x, s2) => (Result.Val x, (s1, s2))
    | (Result.Err e, s2) => (Result.Err (inr e), (s1, s2))
    | (Result.Mon x, s2) => (Result.Mon (lift x), (s1, s2))
    end).

Module Option.
  Definition m : Monad.t :=
    Monad.New unit unit.

  Definition none {A} : M.t m A :=
    M.New (m := m) (fun _ => (Result.Err tt, tt)).

  Definition run {A} (x : M.t m A) : option A :=
    match run x tt with
    | (inl x, _) => Some x
    | _ => None
    end.
End Option.

Module Error.
  Definition m (E : Type) : Monad.t :=
    Monad.New unit E.

  Definition raise {E A} (e : E) : M.t (m E) A :=
    M.New (m := m E) (fun _ => (Result.Err e, tt)).
End Error.

Module Print.
  Definition m (A : Type) : Monad.t :=
    Monad.New (list A) Empty_set.

  Definition print {A} (x : A) : M.t (m A) unit :=
    M.New (m := m A) (fun s =>
      (Result.Val tt, x :: s)).
End Print.

Module State.
  Definition m (S : Type) : Monad.t :=
    Monad.New S Empty_set.

  Definition read {S : Type} : M.t (m S) S :=
    M.New (m := m S) (fun s => (Result.Val s, s)).

  Definition write {S : Type} (x : S) : M.t (m S) unit :=
    M.New (m := m S) (fun _ => (Result.Val tt, x)).
End State.

Module Loop.
  Definition m : Monad.t :=
    Monad.New nat unit.
End Loop.

Fixpoint local_run {m m' : Monad.t} A (x : M.t (m ++ m') A) (s_m : Monad.S m)
  : M.t (Error.m (Monad.E m) ++ m') A :=
  M.New (m := Error.m (Monad.E m) ++ m') (fun s =>
    let (_, s_m') := s in
    match M.open x (s_m, s_m') with
    | (r, (s_m, s_m')) =>
      let r := match r with
        | Result.Val x => Result.Val x
        | Result.Err e => Result.Err e
        | Result.Mon x => Result.Mon (local_run x s_m)
        end in
      (r, (tt, s_m'))
    end).

(** Breaks *)
Module Breaker.
  Definition m : Monad.t :=
    Monad.New bool Empty_set.

  Definition break : M.t m unit :=
    M.New (m := m) (fun _ => (Result.Val tt, true)).

  Fixpoint local_run {m' : Monad.t} {A} (x : M.t (m ++ m') A)
    : M.t m' (A + M.t (m ++ m') A) :=
    M.New (m := m') (fun i =>
      match M.open x (false, i) with
      | (r, (true, o)) =>
        (Result.Val (inr (M.New (m := m ++ m') (fun i =>
          (r, (false, snd i))))), o)
      | (Result.Val x, (false, o)) => (Result.Val (inl x), o)
      | (Result.Err e, (false, o)) =>
        match e with
        | inl e_break => match e_break with end
        | inr e_m => (Result.Err e_m, o)
        end
      | (Result.Mon x, (false, o)) => (Result.Mon (local_run x), o)
      end).

  Fixpoint local_run_n {m' : Monad.t} {A} (x : M.t (m ++ m') A)
    (a : M.t m' unit) (n : nat) : M.t m' (A + M.t (m ++ m') A) :=
    match n with
    | 0 => ret (inr x)
    | Datatypes.S n' => bind (local_run x) (fun x =>
      match x with
      | inl x => ret (inl x)
      | inr x => seq a (local_run_n x a n')
      end)
    end.

  Fixpoint local_run_terminate {m' : Monad.t} {A}
    (x : M.t (m ++ m') A) (a : M.t m' unit) : M.t m' A :=
    M.New (m := m') (fun i =>
      match M.open x (false, i) with
      | (Result.Val x, (_, o)) => (Result.Val x, o)
      | (Result.Err e, (_, o)) =>
        match e with
        | inl e_break => match e_break with end
        | inr e_m => (Result.Err e_m, o)
        end
      | (Result.Mon x, (_, o)) => (Result.Mon (seq a (local_run_terminate x a)), o)
      end).
End Breaker.

(** Coroutines *)
Definition Waiter (m : Monad.t) (A B : Type) : Monad.t :=
  Breaker ++ State ((A -> M.t m B) * bool).

Module Coroutine.
  Definition t {m : Monad.t} (A B T : Type) := M.t (Waiter m A B ++ m) T.

  Definition break_if_not_fresh {m : Monad.t} A B : t A B unit :=
    combine_commut (gret (
      bind (m := Waiter m A B) (gret (read _)) (fun f_fresh =>
        let (_, fresh) := f_fresh in
        if fresh then
          ret tt
        else
          combine_commut (gret break)))).

  Definition use_and_consume {m : Monad.t} A B (a : A) : t A B B :=
    combine_assoc_right (gret (combine_commut (
      bind (m := m ++ State _) (gret (read _)) (fun f_fresh : _ * _ =>
        let (f, _) := f_fresh in
        seq (gret (write (f, false)))
          (combine_commut (gret (f a))))))).

  Definition yield {m : Monad.t} A B (a : A) : t A B B :=
    seq (break_if_not_fresh _ _) (use_and_consume _ a).

  (*Definition I_of_O {m : Monad.t} A B (o : @O (Waiter m A B)) : option (@I (Waiter m A B)) :=
    match o with
    | ((f, fresh), break) =>
      if break then
        None
      else
        Some (f, fresh)
    end.*)

  (*Definition inject_new_f {m : Monad.t} A B (f : A -> M.t m B) : M.t (State ((A -> M.t m B) * bool)) unit :=
    write (f, true).*)

  (*Definition force {m : Monad.t} A B T (x : t A B T) (f : A -> M.t m B) : M.t (T + t A B T) :=
    local_run (m' := m) (local_run_with_break x) (fun o => o) (f, true).

  Definition force {m : Monad.t} A B T (x : t A B T) (f : A -> M.t m B) : M.t (T + t A B T) :=
    sum_id (local_run_with_break x (I_of_O (B := _)) (f, true)).

  Definition force_n {m : Monad.t} A B T (x : t A B T) (n : nat) (f : A -> M.t m B) : M.t (T + t A B T) :=
    sum_id (local_run_with_break_n x (I_of_O (B := _)) (f, true) n).

  Definition terminate {m : Monad.t} A B T (x : t A B T) (f : A -> M.t m B) : M.t T :=
    sum_id (local_run_with_break_terminate x (I_of_O (B := _)) (f, true)).
End Coroutine.

Fixpoint iter_list {m : Monad.t} A (l : list A) : Coroutine.t A unit unit :=
  match l with
  | nil => ret tt
  | x :: l' => seq (Coroutine.yield _ x) (iter_list l')
  end.

Definition test_it {m : Monad.t} := iter_list [1; 5; 7; 2].

Definition test1 := Coroutine.terminate test_it (fun x => print x).
Compute run test1 (fun o => o) nil.

Definition test2 n := seq
  (Coroutine.force_n test_it n (fun x => print x))
  (ret tt).
Definition test2_run n := run (test2 n) (fun o => o) nil.
Compute test2_run 0.
Compute test2_run 1.
Compute test2_run 2.
Compute test2_run 3.
Compute test2_run 4.
Compute test2_run 5.

Definition test3 := Coroutine.terminate test_it (fun x =>
  if eq_nat_dec x 7 then
    gret (m := Print nat) (raise _ "x is equal to 7")
  else
    combine_commut (gret (m := Error.m string) (print x))).

Compute run test3 (fun o => o) (nil, tt).

(** Cooperative threads *)
Definition Breaker : Monad.t := {
  I := Stream bool;
  E := Empty_set;
  O := Stream bool * bool; (* if we did a break *)
  O_of_I := fun s => (s, false)}.

Definition break : M.t Breaker unit :=
  M.New (fun s =>
    (inl (inl tt), (Streams.tl s, Streams.hd s))).

Fixpoint join_aux {m : Monad.t} A B (x : M.t (Breaker ++ m) A) :=
  fix aux (y : M.t (Breaker ++ m) B) (left_first : bool) : M.t (Breaker ++ m) (A * B):=
    if left_first then
      M.New (fun i =>
        match (M.open x) i with
        | (inl xe, o) =>
          match xe with
          | inl x => (inr (bind y (fun y => ret (x, y))), o)
          | inr e => (inl (inr e), o)
          end
        | (inr x, ((s, breaking), o)) =>
          if breaking then
            (inr (join_aux _ x y false), ((s, false), o))
          else
            (inr (join_aux _ x y true), ((s, false), o))
        end)
    else
      M.New (fun i =>
        match (M.open y) i with
        | (inl ye, o) =>
          match ye with
          | inl y => (inr (bind x (fun x => ret (x, y))), o)
          | inr e => (inl (inr e), o)
          end
        | (inr y, ((s, breaking), o)) =>
          if breaking then
            (inr (aux y true), ((s, false), o))
          else
            (inr (aux y false), ((s, false), o))
        end).

Definition join {m : Monad.t} A B (x : M.t (Breaker ++ m) A) (y : M.t (Breaker ++ m) B)
  : M.t (Breaker ++ m) (A * B) :=
  join_aux x y true.

(* join (print 12; break; print 13) (print 23; break; print 0) *)
Definition test4 := join
  (seq (gret (print 12)) (seq (combine_commut (gret break)) (gret (print 13))))
  (seq (gret (print 23)) (seq (combine_commut (gret break)) (gret (print 0)))).

Definition test4_run s :=
  run test4 (fun o => let (sb, o) := o in (fst sb, o)) (s, nil).

Compute test4_run (Streams.const false).
Compute test4_run (Streams.const true).*)

(*Fixpoint local_run_with_break {m m' : Monad.t} A
  (x : M.t (m ++ m') A) (I_of_O : @O m -> option (@I m)) (i_m : @I m)
  : M.t (Error.m (Monad.E m) ++ m') (A + M.t (m ++ m') A) :=
  M.New (m := Error.m (Monad.E m) ++ m') (fun i =>
    let (_, i_m') := i in
    match M.open x (i_m, i_m') with
    | (inl xe, (o_m, o_m')) =>
      let o := (tt, o_m') in
      match xe with
      | inl x => (inl (inl (inl x)), o)
      | inr (inl e_m) => (inl (inr (inl e_m)), o)
      | inr (inr e_m') => (inl (inr (inr e_m')), o)
      end
    | (inr x, (o_m, o_m')) =>
      let o := (tt, o_m') in
      match I_of_O o_m with
      | Some i'_m => (inr (local_run_with_break x I_of_O i'_m), o)
      | None => (inl (inl (inr x)), o)
      end
    end).

Fixpoint local_run_with_break_n {m m' : Monad.t} A
  (x : M.t (m ++ m') A) (I_of_O : @O m -> option (@I m)) (i_m : @I m) (n : nat)
  : M.t (Error.m (Monad.E m) ++ m') (A + M.t (m ++ m') A) :=
  match n with
  | 0 => ret (inr x)
  | S n' => bind (local_run_with_break x I_of_O i_m) (fun x =>
    match x with
    | inl r => ret (inl r)
    | inr x => local_run_with_break_n x I_of_O i_m n'
    end)
  end.

Definition local_run_with_break_terminate {m m' : Monad.t} A
  (x : M.t (m ++ m') A) (I_of_O : @O m -> option (@I m)) (i_m : @I m)
  : M.t (Error.m (Monad.E m) ++ m') A :=
  let fix aux (x : M.t (m ++ m') A) (i'_m : @I m) : M.t (Error.m (Monad.E m) ++ m') A :=
    M.New (m := Error.m (Monad.E m) ++ m') (fun i =>
      let (_, i_m') := i in
      match (M.open x) (i'_m, i_m') with
      | (inl xe, (o_m, o_m')) =>
        let o := (tt, o_m') in
        match xe with
        | inl x => (inl (inl x), o)
        | inr (inl e_m) => (inl (inr (inl e_m)), o)
        | inr (inr e_m') => (inl (inr (inr e_m')), o)
        end
      | (inr x, (o_m, o_m')) =>
        let o := (tt, o_m') in
        match I_of_O o_m with
        | Some i'_m => (inr (aux x i'_m), o)
        | None => (inr (aux x i_m), o)
        end
      end) in
  aux x i_m.*)


Require Import ssreflect ssrfun ssrbool finfun fintype ssrnat eqtype seq tuple.
Require Import bitsrep bitsops bitsprops bitsopsprops.
Require Import SPred septac spec safe basic program macros call.
Require Import instr monad reader writer procstate procstatemonad mem exn eval
               monadinst ioaction bitsrep bitsops eval step instrcodec pointsto cursor.
Require Import program programassem reg instrsyntax instrrules.
Require Import spectac iltac triple.

(* ATBR *)
Require Import ATBR.DecideKleeneAlgebra.
Require Import ATBR.DKA_Definitions.

Require Import interfaceATBR.
Require Import regexpsyntax.

Local Open Scope regex_scope.
Open Scope char_scope.

(**********************************)
(* Floating point regexp          *)
(**********************************)

Definition alphabet: seq DWORD :=
cat [seq (# c) | c <- iota (Ascii.nat_of_ascii "0") 10 ]
    [:: #(Ascii.nat_of_ascii "-")
      ; #(Ascii.nat_of_ascii "+")
      ; #(Ascii.nat_of_ascii "e")
      ; #(Ascii.nat_of_ascii ".")].

(* ^[-+]?[0-9]*\.?[0-9]+([e][-+]?[0-9]+)?$ *)
(*=FP *)
Definition FP: regex :=
  [[ "-" , "+"]]? '
  [{ "0" , "9" }]* ' $"." ? '
  [{ "0" , "9" }]+ '
  ($"e" ' [[ "-" , "+"]]? ' [{ "0" , "9" }]+)?.
(*=End *)

(**********************************)
(* Examples:                      *)
(**********************************)

(*=FP_code*)
Definition FP_x86 (acc rej: DWORD): program :=
    X_to_x86 FP alphabet acc rej.
(*=End*)

(*
Definition code_zero: program := code rO [:: #1 ; #2 ; #3 ] #42 #24.
Definition bytes_zero := assemble #x"C0000000" code_zero.
(* Compute (bytesToHex bytes_zero). *)

Definition code_var1: program := code $"1" [:: #1 ; #2 ; #3 ] #42 #24.
Definition bytes_var1 := assemble #x"C0000000" code_var1.
(* Compute (bytesToHex bytes_var1). *)
*)

Local Close Scope regex_scope.


Require Import SimrelDefinition.
Require Import SimrelCategory.

(** ** Invariants *)

(** The simulation diagrams by themselves do not require an invariant
  to hold. However, in many places, we need an invariant to hold for
  the simulation to work. To express this requirement, we leverage our
  simulation relation infrastructure by encoding the invariant I(s) as
  a relation {(s, s) | I(s)}, and by showing that this invariant is in
  fact a [SimulationRelation]. This invariant combines [data_inv], and
  inject-neutral properties.

  Equipped with this new relation [inv], we can deploy our simulation
  infrastructure on [inv ∘ R ∘ inv]. Then the derived simulation
  relation keeps track of the invariant for both machines, and the
  simulation of primitive calls can be established as long as the two
  primitives are related by [R], and preserve invariants. *)

Section INVARIANT.
  Context `{Hmem: BaseMemoryModel}.

  (** *** Definition *)

  Definition inv_world :=
    sig (fun x => forall b, block_is_global b -> Pos.lt b x).

  Inductive inv_match_mem D: inv_world -> mwd D -> mwd D -> Prop :=
    inv_match_mem_intro (m: mem) (d: D):
      forall Hinv: data_inv d,
      forall Hnb: forall b, block_is_global b -> Mem.valid_block m b,
      forall Hmwf: Mem.inject_neutral (Mem.nextblock m) m,
      forall Hdwf: data_inject (Mem.flat_inj (Mem.nextblock m)) d d,
        inv_match_mem D (exist _ (Mem.nextblock m) Hnb) (m, d) (m, d).

  Inductive inv_match_mem' D: inv_world -> mwd D -> mwd D -> Prop :=
    inv_match_mem_intro' (m: mem) (d: D):
      forall Hinv: data_inv d,
      forall Hnb: forall b, block_is_global b -> Mem.valid_block m b,
      forall Hmwf: Mem.inject_neutral (Mem.nextblock m) m,
      forall Hdwf: data_inject (Mem.flat_inj (Mem.nextblock m)) d d,
      forall w,
      forall Hw: proj1_sig w = Mem.nextblock m,
        inv_match_mem' D w (m, d) (m, d).

  Lemma imm_eq:
    forall D w m1 m2,
      inv_match_mem' D w m1 m2 ->
      inv_match_mem D w m1 m2.
  Proof.
    inversion 1. subst.
    destruct w. simpl in *. subst. constructor; auto.
  Qed.

  Program Definition inv_ops D: simrel_components D D :=
    {|
      simrel_world := inv_world;
      simrel_acc := {| le := (Pos.le @@ (@proj1_sig _ _))%rel |};
      simrel_new_glbl := nil;
      simrel_undef_matches_values_bool := false;
      simrel_undef_matches_block p b := False;
      match_mem := inv_match_mem D;
      simrel_meminj x := let (b, _) := x in Mem.flat_inj b
    |}.

  Local Instance: forall A P, Measure (@proj1_sig A P).

  (** *** Properties *)

  Global Instance match_mem_inv_eq D p:
    Related (match_mem (inv_ops D) p) eq subrel.
  Proof.
    intros m m' H.
    destruct H.
    reflexivity.
  Qed.

  Global Instance match_val_inv_eq D p:
    Related (match_val (inv_ops D) p) eq subrel.
  Proof.
    intros v1 v2 Hv.
    destruct Hv; try constructor; try now (discriminate H || destruct H).
    inversion  H; subst.
    destruct p.
    simpl in H1.
    unfold Mem.flat_inj in H1.
    destruct plt; try discriminate.
    inversion H1; subst.
    rewrite Ptrofs.add_zero.
    reflexivity.
  Qed.

  Global Instance match_vals_inv_eq D p:
    Related (list_rel (match_val (inv_ops D) p)) eq subrel.
  Proof.
    intros vs1 vs2 Hvs.
    induction Hvs; try constructor.
    f_equal; eauto.
    eapply match_val_inv_eq; eauto.
  Qed.

  Global Instance match_memval_inv_eq D p:
    Related (match_memval (inv_ops D) p) eq subrel.
  Proof.
    intros v1 v2 Hv.
    destruct Hv; try constructor; try now (discriminate H || destruct H).
    f_equal; rauto.
  Qed.

  Global Instance match_memvals_inv_eq D p:
    Related (list_rel (match_memval (inv_ops D) p)) eq subrel.
  Proof.
    intros vs1 vs2 Hvs.
    induction Hvs; try constructor.
    f_equal; eauto.
    eapply match_memval_inv_eq; eauto.
  Qed.

  Lemma inv_inject_neutral_match_val D p v:
    Val.inject (Mem.flat_inj (proj1_sig p)) v v <->
    match_val (inv_ops D) p v v.
  Proof.
    destruct p.
    simpl.
    split; intros Hv;
    inversion Hv; clear Hv; try constructor.
    {
      pattern ofs1 at 2.
      rewrite H3.
      constructor.
      assumption.
    }
    subst.
    inversion H1.
    rewrite H4 at 1.
    econstructor; eauto.
  Qed.

  Lemma inv_inject_neutral_match_vals D p l:
    Val.inject_list (Mem.flat_inj (proj1_sig p)) l l <->
    list_rel (match_val (inv_ops D) p) l l .
  Proof.
    destruct p.
    simpl.
    split; intros Hl; induction l; inversion Hl; subst; constructor; auto.
    + rewrite <- inv_inject_neutral_match_val. simpl. assumption.
    + rewrite <- inv_inject_neutral_match_val in *. simpl in *. assumption.
  Qed.

  Lemma inv_inject_neutral_match_memval D p v:
    memval_inject (Mem.flat_inj (proj1_sig p)) v v <->
    match_memval (inv_ops D) p v v.
  Proof.
    destruct p.
    simpl.
    split; intros Hv;
    inversion Hv; clear Hv; try constructor.
    - apply inv_inject_neutral_match_val.
      assumption.
    - apply inv_inject_neutral_match_val in H1.
      assumption.
  Qed.

  Lemma inv_inject_neutral_match_memvals D p vs:
    list_forall2 (memval_inject (Mem.flat_inj (proj1_sig p))) vs vs <->
    list_rel (match_memval (inv_ops D) p) vs vs.
  Proof.
    generalize (eq_refl vs).
    generalize vs at 2 4 6.
    revert vs.
    intros vs1 vs2 Hvseq.
    split.
    {
      intro Hvs.
      revert Hvseq.
      induction Hvs.
      - constructor.
      - intros Heq.
        constructor.
        + inversion Heq.
          eapply inv_inject_neutral_match_memval.
          congruence.
        + eapply IHHvs.
          congruence.
    }
    intro Hvs.
    revert Hvseq.
    induction Hvs.
    - constructor.
    - intros Heq.
      constructor.
      + inversion Heq.
        apply inv_inject_neutral_match_memval with (D := D).
        congruence.
      + eapply IHHvs.
        congruence.
  Qed.

  Lemma inv_match_val_inject_neutral D p thr v1 v2:
    match_val (inv_ops D) p v1 v2 ->
    proj1_sig p = thr ->
    Val.inject (Mem.flat_inj thr) v1 v2.
  Proof.
    intros Hv Hthr; subst.
    destruct p; simpl in *.
    inversion Hv; subst; try now constructor.
    inversion H; subst.
    econstructor; eauto.
  Qed.

  Lemma inv_match_memval_inject_neutral D p thr v1 v2:
    match_memval (inv_ops D) p v1 v2 ->
    proj1_sig p = thr ->
    memval_inject (Mem.flat_inj thr) v1 v2.
  Proof.
    intros Hv Hthr; subst.
    destruct p; simpl in *.
    inversion Hv; subst; constructor.
    eapply inv_match_val_inject_neutral; eauto.
  Qed.

  Lemma inv_match_memvals_inject_neutral D p thr v1 v2:
    list_rel (match_memval (inv_ops D) p) v1 v2 ->
    proj1_sig p = thr ->
    list_forall2 (memval_inject (Mem.flat_inj thr)) v1 v2.
  Proof.
    intros Hv Hthr.
    induction Hv; constructor; eauto.
    eapply inv_match_memval_inject_neutral; eauto.
  Qed.

  (** *** Initial states *)

  (** To prove that initial memories satisfy the invariant, we first
    characterize the construction of initial memories with abstract
    data. *)

  Section WITHDATA.
    Context {D: layerdata}.

    Lemma store_zeros_with_data:
      forall m b o n (d: D),
        store_zeros (m, d) b o n =
        match store_zeros m b o n with
          | Some m' => Some (m', d)
          | None => None
        end.
    Proof.
      intros.
      functional induction (store_zeros m b o n); intros.
      * rewrite store_zeros_equation.
        rewrite e.
        reflexivity.
      * rewrite <- IHo0; clear IHo0.
        rewrite store_zeros_equation.
        rewrite e.
        lift_unfold.
        rewrite e0.
        reflexivity.
      * rewrite store_zeros_equation.
        rewrite e.
        lift_unfold.
        rewrite e0.
        reflexivity.
    Qed.

    Lemma store_init_data_with_data:
      forall {F V: Type} (ge: _ F V) m b p a (d: D),
        Genv.store_init_data ge (m, d) b p a =
        match Genv.store_init_data ge m b p a with
          | Some m' => Some (m', d)
          | None => None
        end.
    Proof.
      intros.
      destruct a; simpl; try reflexivity.
      destruct (Genv.find_symbol ge i); reflexivity.
    Qed.

    Lemma store_init_data_list_with_data:
      forall {F V: Type} (ge: _ F V) l m b p (d: D),
        Genv.store_init_data_list ge (m, d) b p l =
        match Genv.store_init_data_list ge m b p l with
          | Some m' => Some (m', d)
          | None => None
        end.
    Proof.
      induction l; simpl; try reflexivity.
      intros.
      rewrite store_init_data_with_data.
      destruct (Genv.store_init_data ge m b p a); try reflexivity.
      eauto.
    Qed.

    Lemma alloc_global_with_data:
      forall {F V} (ge: _ F V),
        forall m ig (d: D),
          Genv.alloc_global ge (m, d) ig =
          match Genv.alloc_global ge m ig with
            | Some m' => Some (m', d)
            | None => None
          end.
    Proof.
      unfold Genv.alloc_global. intros.
      destruct ig as [? [ [ | ] | ]].
      * (* function *)
        lift_unfold.
        destruct (Mem.alloc m 0 1).
        reflexivity.
      * (* variable *)
        lift_unfold.
        destruct (Mem.alloc m 0 (init_data_list_size (gvar_init v))).
        unfold set; simpl.
        rewrite store_zeros_with_data.
        destruct (store_zeros m0 b 0 (init_data_list_size (gvar_init v))); try reflexivity.
        rewrite store_init_data_list_with_data.
        destruct (Genv.store_init_data_list ge m1 b 0 (gvar_init v)); reflexivity.
      * (* none *)
        lift_unfold.
        destruct (Mem.alloc m 0 0); reflexivity.
    Qed.

    Lemma alloc_globals_with_data:
      forall {F V} (ge: _ F V),
        forall l m (d: D),
          Genv.alloc_globals ge (m, d) l =
          match Genv.alloc_globals ge m l with
            | Some m' => Some (m', d)
            | None => None
          end.
    Proof.
      induction l; simpl; try reflexivity.
      intros.
      rewrite alloc_global_with_data.
      destruct (Genv.alloc_global ge m a); try reflexivity.
      eauto.
    Qed.

    Theorem init_mem_with_data:
      forall {F V} (p: _ F V),
        Genv.init_mem (mem := mwd D) p =
        match Genv.init_mem (mem := mem) p with
          | Some m' => Some (m', init_data)
          | None => None
        end.
    Proof.
      intros.
      unfold Genv.init_mem.
      simpl.
      apply alloc_globals_with_data.
    Qed.
  End WITHDATA.

(** XXX: mettre au bon endroit. *)
Instance:
  Related Pos.lt Pos.le subrel.
Proof.
  intros x y Hxy.
  apply Pos.le_lteq.
  eauto.
Qed.

  Global Instance inv_prf D:
    SimulationRelation (inv_ops D).
  Proof.
    split.
    - (* carrier preorder *)
      split; simpl; typeclasses eauto.
    - (* simrel_undef_matches_block increases with carrier *)
      simpl. solve_monotonic.
    - (* match_block increases with carrier *)
      simpl; unfold RelCompFun.
      intros p1 p2 Hp.
      destruct p1 as [p1 Hp1].
      destruct p2 as [p2 Hp2].
      red in Hp.
      simpl in Hp.
      red.
      intro b.
      unfold Mem.flat_inj.
      destruct (plt b p1); destruct (plt b p2); try now repeat constructor.
      xomega.
    - (* undef_matches_values implies undef_matches_block *)
      discriminate.
    - (* undef_matches_block implies undef_matches_values *)
      simpl; tauto.
    - (* undef_match_block for non-injective match_block *)
      simpl.
      destruct p.
      inversion 2 as [? K0].
      inversion 1 as [? K1].
      simpl in K0, K1.
      unfold Mem.flat_inj in K0.
      destruct (plt _ _); try discriminate.
      inversion K0; clear K0; subst.
      unfold Mem.flat_inj in K1.
      destruct (plt _ _); try discriminate.
      inversion K1; clear K1; subst.
      congruence.
    - (* undef_match_block for non weakly valid pointers *)
      simpl.
      destruct p.
      inversion 1; subst.
      inversion 2 as [? ? ? ? K]; subst.
      simpl in K.
      unfold Mem.flat_inj in K.
      destruct (plt _ _); try discriminate.
      inversion K; clear K; subst.
      rewrite Ptrofs.add_zero.
      congruence.
    - (* undef_match_block for invalid pointers *)
      simpl.
      destruct p.
      inversion 1; subst.
      inversion 2 as [? ? ? ? K]; subst.
      simpl in K.
      unfold Mem.flat_inj in K.
      destruct (plt _ _); try discriminate.
      inversion K; clear K; subst.
      rewrite Ptrofs.add_zero.
      congruence.

    - (* global blocks related to themselves *)
      intros [thr Hthr] b Hb.
      red.
      unfold match_block_sameofs.
      simpl.
      apply Hthr in Hb.
      unfold Mem.flat_inj.
      destruct (plt b thr); congruence.

    - (* [Genv.init_mem] *)
      intros.
      intros p1 p2 Hp.
      assert
        ((option_le ((rexists w, match_mem (simrel_id (D:=D)) w) /\
                     (req glob_threshold @@ Mem.nextblock)))
           (Genv.init_mem p1)
           (Genv.init_mem p2)) as Hm.
      {
        eapply genv_init_mem_simrel_withnextblock; eauto.
        + apply SimrelCategory.simrel_id_init_mem.
        + intros x y [H _].
          exists tt.
          assumption.
      }
      pose proof (@init_mem_with_data D F V p1).
      destruct (Genv.init_mem (mem:=mwd D) p1) as [m1|] eqn:Hinit_mem; [|constructor].
      destruct (Genv.init_mem (mem:=mem) p1) as [m|] eqn:Hm1'; try discriminate.
      inversion Hm as [ | xm1 xm2 Hmeq]; clear Hm; subst.
      constructor.
      destruct Hmeq as [[[] Hmeq] Hmnb].
      simpl in Hmeq; subst.
      inversion H; clear H; subst.
      assert (Hw: forall b, block_is_global b -> (b < Mem.nextblock m)%positive).
      {
        intros b Hb.
        red in Hmnb.
        lift_unfold.
        destruct Hmnb.
        exact Hb.
      }
      exists (exist _ _ Hw).
      simpl.
      constructor.
      + apply init_data_inv.
      + eapply InitMem.Genv.initmem_inject_neutral; eauto.
      + red in Hmnb.
        lift_unfold.
        destruct Hmnb.
        eapply init_data_inject.

    - (* [Mem.alloc] *)
      intros _ _ _ [m d Hinv Hnb Hwf] ofs sz.
      lift_unfold.
      destruct (Mem.alloc m ofs sz) as [m' b] eqn:Hm'.
      assert (Mem.nextblock m < Mem.nextblock m')%positive as Hnb_lt.
      {
        erewrite (Mem.nextblock_alloc m _ _ m') by eassumption.
        xomega.
      }
      assert (Hnb': (forall b, block_is_global b -> Mem.valid_block m' b)%positive).
      {
        intros b0 H.
        apply Hnb in H.
        unfold Mem.valid_block in * |- * .
        xomega.
      }
      exists (exist _ _ Hnb').
      split.
      + simpl; unfold RelCompFun; simpl.
        red; simpl.
        xomega.
      + split; [ constructor | ] ; simpl.
        * assumption.
        * eapply Mem.alloc_inject_neutral; eauto.
          eapply Mem.inject_neutral_incr; eauto.
          xomega.
        * revert Hdwf.
          solve_monotonic.
        * erewrite (Mem.alloc_result _ _ _ _ b) by eassumption.
          unfold match_block_sameofs.
          simpl.
          unfold Mem.flat_inj.
          destruct (plt _ _); intuition xomega.

    - (* [Mem.free] *)
      intros p m1 m2 Hm [[b1 lo1] hi1] [[b2 lo2] hi2] Hb.
      inversion Hm; subst.
      inversion Hb; subst.
      inversion H0; subst.
      simpl in H1.
      generalize H1. intros H1_.
      unfold Mem.flat_inj in H1.
      destruct (plt _ _); try discriminate.
      inversion H1; clear H1; subst.
      rewrite Z.add_0_r in  * |- * .
      simpl in *.
      lift_unfold.
      pose proof (Mem.nextblock_free m b2 lo1 (lo1 + sz)) as Hbnf.
      destruct (Mem.free _ _ _ _) as [m'|] eqn:Hm'; constructor.
      exists (exist _ (Mem.nextblock m) Hnb).
      split.
      {
        red.
        simpl.
        reflexivity.
      }
      change (set fst m' (m, d)) with (m', d).
      clear H0 Hb.
      revert Hnb Hm.
      unfold Mem.valid_block.
      erewrite <- Mem.nextblock_free by eassumption.
      inversion 1; subst.
      constructor.
      + assumption.
      + eapply Mem.free_inject_neutral.
        * eassumption.
        * congruence.
        * congruence.
      + revert Hdwf; solve_monotonic.

    - (* [Mem.load] *)
      intros p chunk m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb.
      inversion Hm; subst.
      inversion Hb; subst.
      simpl in *.
      lift_unfold.
      generalize H0. intro H0_.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _); try discriminate.
      inversion H0; clear H0; subst.
      rewrite Z.add_0_r in * |- * .
      destruct (Mem.load chunk m b2 ofs1) as [v|] eqn:Hv; constructor.
      eapply inv_inject_neutral_match_val.
      eapply Mem.load_inject_neutral; eauto.

    - (* [Mem.store] *)
      intros p chunk m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb v1 v2 Hv.
      inversion Hm; subst.
      inversion Hb; subst.
      pose proof (match_val_inv_eq D _ v1 v2 Hv).
      subst.
      eapply inv_match_val_inject_neutral in Hv; eauto.
      simpl in *.
      lift_unfold.
      generalize H0. intro H0_.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _); try discriminate.
      inversion H0; clear H0; subst.
      rewrite Z.add_0_r in * |- * .
      destruct (Mem.store chunk m b2 ofs1 v2) as [m'|] eqn:Hm'; constructor.
      exists (exist _ (Mem.nextblock m) Hnb).
      split.
      {
        red.
        simpl.
        reflexivity.
      }
      clear Hm Hb.
      revert Hnb Hv.
      unfold Mem.valid_block.
      erewrite <- Mem.nextblock_store by eassumption.
      intros Hnb Hv.
      constructor.
      + assumption.
      + eapply Mem.store_inject_neutral.
        * eassumption.
        * erewrite Mem.nextblock_store; eauto.
        * erewrite Mem.nextblock_store; eauto.
        * assumption.
      + simpl.
        exploit Mem.nextblock_store; eauto.
        congruence.

    - (* [Mem.loadbytes] *)
      intros p m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb len.
      inversion Hm; subst.
      inversion Hb; subst.
      simpl in *.
      generalize H0. intro H0_.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _) as [ H | ] ; try discriminate.
      inversion H0; clear H0; subst.
      rewrite Z.add_0_r in * |- * .
      lift_unfold.
      destruct (Mem.loadbytes m b2 ofs1 len) as [v|] eqn:Hv; constructor.
      pose proof (Mem.loadbytes_inject_neutral m Hmwf _ _ _ _ Hv H) as Hvwf.
      clear Hv.
      eapply inv_inject_neutral_match_memvals.
      assumption.

    - (* [Mem.storebytes] *)
      intros p m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb vs1 vs2 Hvs.
      inversion Hm; subst.
      inversion Hb; subst.
      pose proof (match_memvals_inv_eq D _ vs1 vs2 Hvs).
      subst; simpl in *.
      generalize H0. intro H0_.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _) ; try discriminate.
      inversion H0; clear H0; subst.
      rewrite Z.add_0_r in * |- * .
      lift_unfold.
      destruct (Mem.storebytes m b2 ofs1 vs2) as [m'|] eqn:Hm'; constructor.
      exists (exist _ (Mem.nextblock m) Hnb).
      split.
      {
        red.
        simpl.
        reflexivity.
      }
      clear Hm Hb.
      revert Hnb Hvs.
      unfold Mem.valid_block.
      erewrite <- Mem.nextblock_storebytes by eassumption.
      intros Hnb Hvs.
      constructor.
      + assumption.
      + eapply Mem.storebytes_inject_neutral.
        * eassumption.
        * eapply inv_match_memvals_inject_neutral; eauto.
        * erewrite Mem.nextblock_storebytes; eauto.
        * erewrite Mem.nextblock_storebytes; eauto.
      + exploit Mem.nextblock_storebytes; eauto.
        simpl.
        congruence.

    - (* [Mem.perm] *)
      intros p m1 m2 Hm [b1 ofs1] [b2 ofs2] Hb k perm.
      inversion Hm; subst.
      inversion Hb; subst.
      simpl in H0.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _); try discriminate.
      inversion H0; clear H0; subst.
      rewrite Z.add_0_r.
      reflexivity.

    - (* [Mem.valid_block] *)
      intros p m1 m2 Hm b1 b2 Hb.
      inversion Hm; subst.
      inversion Hb; subst.
      simpl in H.
      simpl in *.
      unfold Mem.flat_inj in H.
      destruct (plt _ _); intuition congruence.

    - (* [Mem.different_pointers_inject] *)
      intros p m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2 H H0 H1 H2 H3 H4.
      destruct p.
      simpl in H3, H4.
      unfold Mem.flat_inj in H3, H4.
      destruct (plt b1 _); try discriminate.
      inversion H3; clear H3; subst.
      destruct (plt b2 _); try discriminate.
      inversion H4; clear H4; subst.
      tauto.

    - (* [Mem.weak_valid_pointer_inject_val] *)
      inversion 1; subst.
      inversion 2 as [? ? ? ? K]; subst.
      simpl in K.
      unfold Mem.flat_inj in K.
      destruct (plt _ _); try discriminate.
      inversion K; clear K; subst.
      rewrite Ptrofs.add_zero.
      assumption.

    - (* weak_valid_pointer_address_inject_weak *)
      intros p m1 m2 b1 b2 delta H H0.
      inversion H; clear H; subst.
      simpl in H0.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _); try discriminate.
      inversion H0; clear H0; subst.
      exists 0.
      intros ofs1 H.
      rewrite Ptrofs.add_zero.
      omega.

    - (* [Mem.address_inject] *)
      intros p m1 m2 b1 ofs1 b2 delta pe H H0 H1.
      simpl in H1.
      destruct p.
      unfold Mem.flat_inj in H1.
      destruct (plt _ _); try discriminate.
      inversion H1; clear H1; subst.
      rewrite Ptrofs.add_zero.
      omega.

    - (* [Mem.aligned_area_inject] *)
      intros p m m' b ofs al sz b' delta H H0 H1 H2 H3 H4 H5.
      simpl in H5.
      destruct p.
      unfold Mem.flat_inj in H5.
      destruct (plt _ _); try discriminate.
      inversion H5; clear H5; subst.
      rewrite Z.add_0_r.
      assumption.

    - (* [Mem.disjoint_or_equal_inject] *)
      intros p m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz H H0 H1 H2 H3 H4 H5.
      simpl in H0.
      destruct p.
      unfold Mem.flat_inj in H0.
      destruct (plt _ _); try discriminate.
      inversion H0; clear H0; subst.
      simpl in H1.
      unfold Mem.flat_inj in H1.
      destruct (plt _ _); try discriminate.
      inversion H1; clear H1; subst.
      intuition omega.
  Qed.

  Definition inv {D}: simrel D D :=
    {|
      simrel_ops := inv_ops D
    |}.
End INVARIANT.

Section EQUIVALENCE.

  Context `{Hmem: BaseMemoryModel}.

  Definition max_worlds D (p: simrel_world (simrel_compose (inv (D:=D)) inv)) : simrel_world (D2:=D) inv.
  Proof.
    destruct p as (p1 & p2).
    destruct p1, p2.
    exists (Pmax x x0).
    destruct (Pos.max_spec x x0) as [[A B]|[A B]]; rewrite B; auto.
  Defined.

  Lemma simrel_compose_inv_inv (D: layerdata) :
    simrel_equiv (simrel_compose inv inv) (inv (D := D)).
  Proof.
    exists {| simrel_equiv_fw := max_worlds D;
         simrel_equiv_bw := fun x => (x,x) |}.
    econstructor; simpl; eauto.
    - repeat rstep. unfold max_worlds.
      destruct H. destruct x,y; simpl in *.
      destruct i, i1; simpl in *.
      destruct i0, i2; simpl in *.
      red in H.
      red in H0. simpl in *.
      apply Pos.max_le_compat; auto.
    - repeat rstep.
    - intros.
      intros [(b' & ? & ?)|?]; auto.
    - intros p b [].
    - intros [p12 p23].
      simpl. destruct p12, p23.
      intros (m1,d1) (m3,d3) ((m2,d2) & A & B); inv A; inv B.
      apply imm_eq. constructor; auto.
      simpl. apply Pos.max_id.
    - intros p (m1,d1) (m2,d2) A. exists (m1,d1).
      inv A; split; econstructor; eauto.
    - destruct p as ((p1,l1),(p2,l2)). simpl.
      unfold compose_meminj.
      unfold Mem.flat_inj.
      intros.
      destruct (plt b p1); try constructor; auto.
      destruct (plt b p2); try constructor; auto.
      rewrite pred_dec_true; auto. constructor; auto.
      apply Pos.max_lt_iff; auto.
    - intros p b. destruct p; simpl.
      unfold compose_meminj.
      unfold Mem.flat_inj.
      destruct (plt b x) eqn:P; try constructor; auto.
      rewrite P. constructor; reflexivity.
    - destruct w.
      unfold max_worlds; split; red; simpl.
      destruct i, i0; simpl.
      apply Pos.le_max_l.
      destruct i, i0; simpl.
      apply Pos.le_max_r.
    - intro. red. destruct w; simpl.
      rewrite Pos.max_id. reflexivity.
  Qed.

End EQUIVALENCE.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ A Bprime /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O Aprime Cprime /\ col_ O B Cprime)))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** ** Presentation of towers through the length function

by Vladimir Voevodsky, started on Jan. 22, 2015, most material migrated from
lBsystems_carriers.v

*)

Unset Automatic Introduction.

Require Export lBsystems.prelim.

(** To uu0a.v *)

Lemma iscontrpathsfrom { T : UU } ( A : T ) :
  iscontr ( total2 ( fun X : T => A = X ) ) .
Proof .
  intros .
  split with ( tpair _ A ( idpath A ) ) .
  intro t .
  destruct t as [ t e ] .
  destruct e .
  apply idpath .

Defined.

(** We formalize the sequences of types ...->B_{n+1}->B_n->...->B_0

as one type B with a length function ll and an endomorphism ft. *)

Definition ltower_str_data ( T : UU ) :=  dirprod ( T -> nat ) ( T -> T ) .

Definition ltower_str ( T : UU ) :=
  total2 ( fun str :ltower_str_data T =>
             dirprod
               ( forall X : T , ( pr1 str ) ( pr2 str X ) = pr1 str X - 1 )
               ( forall ( X : T ) ( e : pr1 str X = 0 ) , pr2 str X = X ) ) .

Definition ltower := total2 ( fun T : UU => ltower_str T ) .

Definition ltower_constr { T : UU } ( ll : T -> nat ) ( ft : T -> T )
           ( ll_ft_eq : forall X : T , ll ( ft X ) = ll X - 1 )
           ( ll0_eq : forall ( X : T ) ( e : ll X = 0 ) , ft X = X ) : ltower .
Proof .
  intros .
  split with T .

  split with ( dirprodpair ll ft ) .

  exact ( dirprodpair ll_ft_eq ll0_eq ) .

Defined.

(** The type ltower is constructively equivalent to the type of pretowers defined as follows:

Definition pretowerfam := ( fun T : nat -> UU => forall n : nat , T ( S n  ) -> T n ) .
Definition pretower := total2 pretowerfam .

See pretowers.v

*)

Definition ltower_data_pr1 : ltower -> UU := pr1 .
Coercion ltower_data_pr1 : ltower >-> UU .

Definition ll { X : ltower } : X -> nat := pr1 ( pr1 ( pr2 X ) ) .

Definition ft { X : ltower } : X -> X := pr2 ( pr1 ( pr2 X ) ) .

Definition ftn { X : ltower } ( n : nat ) : X -> X := iteration ( @ft X ) n .

Definition ll_ft { T : ltower } ( X : T ) : ll ( ft X ) = ll X - 1 :=
  pr1 ( pr2 ( pr2 T ) ) X .

Definition ftX_eq_X { T : ltower } { X : T } ( e : ll X = 0 ) : ft X = X :=
  pr2 ( pr2 ( pr2 T ) ) X e .

(** Some useful lemmas about ltower *)

Lemma ll_ftn { BB : ltower } ( n : nat ) ( X : BB ) : ll ( ftn n X ) = ll X - n .
Proof.
  intros BB n .
  induction n as [ | n IHn ] .
  intro . rewrite natminuseqn . apply idpath .
  intro . change ( ftn ( S n ) X ) with ( ft ( ftn n X ) ) .  rewrite ( ll_ft _ ) .
  rewrite ( IHn X ) .  rewrite ( natminusassoc _ _ _ ) .  rewrite ( natpluscomm n 1 ) .
  apply idpath .
Defined .

Lemma ftn_ft { BB : ltower } ( n : nat ) ( X : BB ) :
  ftn n ( ft X ) = ftn ( 1 + n ) X .
Proof .
  intros . induction n as [ | n IHn ] .
  apply idpath .
  apply ( maponpaths ( @ft BB ) IHn ) .
Defined.

Lemma ftn_ftn { BB : ltower } ( m n : nat ) ( X : BB ) :
  ftn m ( ftn n X ) = ftn ( m + n ) X .
Proof.
  intros .  induction m as [ | m IHm ] .
  exact ( idpath _ ) .
  apply ( maponpaths ft ) .
  exact IHm .
Defined.

Lemma lltowergehll { BB : ltower } { X1 X2 : BB } ( gt : ll X2 > ll X1 ) :
  ll ( ft X2 ) >= ll X1 .
Proof.
  intros. rewrite ( ll_ft X2 ) . apply ( natgthtominus1geh gt ) .
Defined .

Lemma llgehll { BB : ltower } { X1 X2 : BB } ( gt : ll X2 > ll ( ft X1 ) ) :
  ll X2 >= ll X1 .
Proof.
  intros. rewrite ( ll_ft X1 ) in gt . apply ( natgthminus1togeh gt ) .
Defined .

Lemma ll_ft_gtn { T : ltower } { X : T } { n : nat } ( gtsn : ll X >= S n ) : ll ( ft X ) >= n .
Proof.
  intros.
  rewrite ll_ft .
  assert ( int := natgehandminusr _ _ 1 gtsn ) .
  change ( S n - 1 ) with ( n - 0 ) in int .
  rewrite natminuseqn in int .
  apply int .

Defined.

Lemma S_ll_ft { T : ltower } { X : T } ( gt0 : ll X > 0 ) : 1 + ll ( ft X ) = ll X .
Proof.
  intros .
  rewrite ll_ft .
  rewrite natpluscomm .
  apply ( minusplusnmm _ _ ( gth0_to_geh1 gt0 ) ) .

Defined.

Definition ftnX_eq_X { T : ltower } ( n : nat ) { X : T } ( eq : ll X = 0 ) : ftn n X = X .
Proof.
  intros until n . induction n as [ | n IHn ] .
  intros .  apply idpath .

  intros .
  rewrite <- ftn_ft .
  assert ( int : ftn n ( ft X ) = ft X ) .
  apply IHn .
  rewrite ll_ft .
  rewrite eq . apply idpath .
  rewrite int .
  apply ftX_eq_X .
  apply eq .

Defined.

(* **** The predicate isover and its properties *)

Definition isover { BB : ltower } ( X A : BB ) := ( A = ftn ( ll X - ll A ) X ) .

Lemma isover_geh { BB : ltower } { X A : BB } ( is : isover X A ) :
  ll X >= ll A .
Proof.
  intros . unfold isover in is .
  assert ( int : ll A = ll ( ftn (ll X - ll A) X ) ) . exact ( maponpaths ll is ) .

  rewrite int . rewrite ll_ftn . exact ( natminuslehn _ _ ) .

Defined.

Lemma isover_XX { BB : ltower } ( X : BB ) : isover X X .
Proof.
  intros . unfold isover . rewrite natminusnn . apply idpath .

Defined.

Lemma isover_trans { BB : ltower } { X A A' : BB } :
  isover X A -> isover A A' -> isover X A' .
Proof.
  intros BB X A A' .  unfold isover in * .
  set ( llA := ll A ) . set ( llA' := ll A' ) .
  intro is1 . intro is2 .
  assert ( gte1 := isover_geh is1 ) .
  assert ( gte2 := isover_geh is2 ) .
  rewrite is2 . rewrite is1 .
  rewrite ftn_ftn .
  assert (int : (llA - llA' + (ll X - llA)) = (ll X - llA')) .
  rewrite natpluscomm .
  exact ( ! ( natminusinter gte1 gte2 ) ) .

  rewrite int .
  apply idpath .

Defined.

Lemma isover_X_ftX { BB : ltower } ( X : BB ) : isover X ( ft X ) .
Proof.
  intros .
  unfold isover .
  destruct ( natgehchoice _ _ ( natgehn0 ( ll X ) ) )  as [ gt | eq ] .
  rewrite ll_ft .
  assert ( eq : ll X - ( ll X - 1 ) = 1 ) . refine ( natminusmmk _ ) .
  exact ( natgthtogehsn _ _ gt ) .

  rewrite eq .
  apply idpath .

  rewrite eq .
  simpl .
  exact ( ftX_eq_X eq ) .

Defined.

Lemma isover_X_ftnX { BB : ltower } ( X : BB ) ( n : nat ) : isover X ( ftn n X ) .
Proof .
  intros .
  induction n as [ | n IHn ] .
  exact ( isover_XX _ ) .

  exact ( isover_trans IHn ( isover_X_ftX _ ) ) .

Defined.

Lemma isover_X_ftA { BB : ltower } { X A : BB }
      ( is : isover X A ) : isover X ( ft A ) .
Proof.
  intros. exact ( isover_trans is ( isover_X_ftX _ ) ) .

Defined.

Lemma isover_ft { BB : ltower } { X A : BB }
      ( is : isover X A ) ( gt : ll X > ll A ) : isover ( ft X ) A .
Proof.
  intros. unfold isover in * .
  rewrite ftn_ft . rewrite ll_ft . rewrite <- lB_2014_12_07_l1 .
  exact is .

  exact gt .

Defined.

Lemma isover_ftn { BB : ltower } { n : nat } { X A : BB }
      ( is : isover X A ) ( gte : ll X - ll A >= n ) : isover ( ftn n X ) A .
Proof.
  intros BB n. induction n as [ | n IHn ] .
  intros .  exact is .

  intros . simpl .
  refine ( isover_ft _ _ ) .
  refine ( IHn _ _ _ _ ) .
  exact is .

  exact ( istransnatgeh _ _ _ gte ( natgehsnn n ) ) .

  rewrite ll_ftn .
  refine ( natgthleftminus _ _ _ _ ) .
  assert ( int := natgehgthtrans _ _ _ gte ( natgthsnn n ) ) .
  rewrite natpluscomm .
  exact ( natgthrightplus _ _ _ int ) .

Defined .

Lemma isover_choice { BB : ltower } { X A : BB }
      ( is : isover X A ) : coprod ( isover ( ft X ) A ) ( A = X ) .
Proof .
  intros .
  destruct ( natgehchoice _ _ ( isover_geh is ) ) as [ gt | eq ] .
  exact ( ii1 ( isover_ft is gt ) ) .

  unfold isover in is .
  rewrite eq in is .
  rewrite natminusnn in is .
  exact ( ii2 is ) .

Defined.

(** **** The predicate isabove and its properties *)

Definition isabove { BB : ltower } ( X A : BB ) :=
  dirprod ( ll X > ll A ) ( isover X A ) .

Definition isabove_constr { BB : ltower } { X A : BB }
           ( gt : ll X > ll A ) ( isov : isover X A ) : isabove X A :=
  tpair _ gt isov .

Definition isabove_gth { BB : ltower } { X A : BB } ( is : isabove X A ) :
  ll X > ll A := pr1 is .

Lemma isabove_gt0 { BB : ltower } { X A : BB } ( is : isabove X A ) : ll X > 0 .
Proof .
  intros .
  exact ( natgthgehtrans _ _ _ ( isabove_gth is ) ( natgehn0 _ ) ) .

Defined.

Definition isabove_to_isover { BB : ltower } { X A : BB } :
  isabove X A -> isover X A := pr2 .
Coercion isabove_to_isover : isabove >-> isover .

Lemma isabove_X_ftX { BB : ltower } ( X : BB ) ( gt0 : ll X > 0 ) : isabove X ( ft X ) .
Proof .
  intros .
  refine ( isabove_constr _ _ ) .
  rewrite ll_ft .
  exact ( natgthnnmius1 gt0 ) .

  exact ( isover_X_ftX _ ) .

Defined.

Lemma isabove_X_ftnX { BB : ltower } { X : BB } { n : nat } ( gt0' : n > 0 ) ( gt0 : ll X > 0 ) :
  isabove X ( ftn n X ) .
Proof.
  intros .
  induction n as [ | n IHn ] .
  destruct ( negnatgthnn _ gt0' ) .

  refine ( isabove_constr _ _ ) .
  rewrite ll_ftn .
  apply natminuslthn .
  exact gt0 .

  exact gt0'.

  apply isover_X_ftnX .

Defined.

Lemma isabove_X_ftA { BB : ltower } { X A : BB }
      ( is : isabove X A ) : isabove X ( ft A ) .
Proof .
  intros . refine ( isabove_constr _ _ ) .
  rewrite ll_ft .
  exact ( natgthgehtrans _ _ _ ( isabove_gth is ) ( natminuslehn _ 1 ) ) .

  exact (isover_X_ftA is ) .

Defined.

Lemma isabove_X_ftA' { BB : ltower } { X A : BB }
      ( is : isover X A ) ( gt0 : ll A > 0 ) : isabove X ( ft A ) .
Proof .
  intros . refine ( isabove_constr _ _ ) .
  rewrite ll_ft .
  refine ( natgehgthtrans _ _ _ ( isover_geh is ) _ ) .
  exact ( natgthnnmius1 gt0 ) .

  exact ( isover_X_ftA is ) .

Defined.

Lemma isabove_trans { BB : ltower } { X A A' : BB } :
  isabove X A -> isabove A A' -> isabove X A' .
Proof.
  intros BB X A A' is is' . refine ( isabove_constr _ _ ) .
  exact ( istransnatgth _ _ _ ( isabove_gth is ) ( isabove_gth is' ) ) .

  exact ( isover_trans is is' ) .

Defined.

Lemma isabov_trans { BB : ltower } { X A A' : BB } :
  isabove X A -> isover A A' -> isabove X A' .
Proof.
  intros BB X A A' is is' . refine ( isabove_constr _ _ ) .
  exact ( natgthgehtrans _ _ _ ( isabove_gth is ) ( isover_geh is' ) ) .

  exact ( isover_trans is is' ) .

Defined.

Lemma isovab_trans { BB : ltower } { X A A' : BB } :
  isover X A -> isabove A A' -> isabove X A' .
Proof.
  intros BB X A A' is is' . refine ( isabove_constr _ _ ) .
  exact ( natgehgthtrans _ _ _ ( isover_geh is ) ( isabove_gth is' ) ) .

  exact ( isover_trans is is' ) .

Defined.

Lemma isover_ft' { BB : ltower } { X A : BB } ( is : isabove X A ) :
  isover ( ft X ) A .
Proof .
  intros . exact ( isover_ft is ( isabove_gth is ) ) .

Defined.

Lemma isabove_ft_inv { BB : ltower } { X A : BB } ( is : isabove ( ft X ) A ) :
  isabove X A .
Proof .
  intros . exact ( isovab_trans ( isover_X_ftX _ ) is ) .

Defined.

Lemma ovab_choice { BB : ltower } { X A : BB } ( isov : isover X A ) :
  coprod ( isabove X A ) ( X = A ) .
Proof .
  intros .
  destruct ( natgehchoice _ _ ( isover_geh isov ) ) as [ gth | eq ] .
  exact ( ii1 ( tpair _ gth isov ) ) .

  unfold isover in isov .
  rewrite eq in isov .
  rewrite natminusnn in isov .
  exact ( ii2 ( ! isov ) ) .

Defined.

Lemma isabove_choice { BB : ltower } { X A : BB } ( isab : isabove X A ) :
  coprod ( isabove ( ft X ) A ) ( A = ft X ) .
Proof.
  intros .
  assert ( isov := isover_ft' isab ) .
  assert ( gte : ll ( ft X ) >= ll A ) .
  exact ( lltowergehll ( isabove_gth isab ) ) .

  destruct ( natgehchoice _ _ gte ) as [ gt | eq ] .
  exact ( ii1 ( isabove_constr gt isov ) ) .

  unfold isover in isov .
  rewrite eq in isov .
  rewrite natminusnn in isov .
  exact ( ii2 isov ) .

Defined.

Lemma isabove_choice_n { BB : ltower } ( n : nat ) { X A : BB } ( isab : isabove X A ) :
  coprod ( isabove ( ftn n X ) A ) ( isover A ( ftn n X ) ) .
Proof .
  intros BB n . induction n as [ | n IHn ] .
  intros .
  exact ( ii1 isab ) .

  intros .
  assert ( int := IHn X A isab ) .
  destruct int as [ isab' | isov ] .
  destruct ( isabove_choice isab' ) as [ isab'' | iseq ] .
  exact ( ii1 isab'' ) .

  refine ( ii2 _ ) .
  unfold isover .
  rewrite iseq .
  rewrite natminusnn .
  apply idpath .

  exact ( ii2 ( isover_X_ftA isov ) ) .

Defined.

(** *** Functions between l-towers that are monotone relative to the predicate isover *)

(** **** The basic definitions *)

Definition isovmonot { T1 T2 : ltower } ( f : T1 -> T2 ) :=
  forall ( X Y : T1 ) , isover X Y -> isover ( f X ) ( f Y ) .

Definition ovmonot_fun ( T1 T2 : ltower ) :=
  total2 ( fun f : T1 -> T2 => isovmonot f ) .

Definition ovmonot_fun_constr { T1 T2 : ltower }
           ( f : T1 -> T2 ) ( is : forall ( X Y : T1 ) , isover X Y -> isover ( f X ) ( f Y ) ) :
  ovmonot_fun T1 T2 := tpair _ f is .

Definition ovmonot_fun_pr1 ( T1 T2 : ltower ) : ovmonot_fun T1 T2 -> ( T1 -> T2 ) := pr1 .
Coercion ovmonot_fun_pr1 : ovmonot_fun >-> Funclass .

(** **** Composition of over-monotone functions is over-monotone *)

Definition isovmonot_funcomp { T1 T2 T3 : ltower } { f : T1 -> T2 } { g : T2 -> T3 }
           ( isf : isovmonot f ) ( isg : isovmonot g ) : isovmonot ( funcomp f g ) .
Proof .
  intros . unfold isovmonot .
  intros X Y is .
  apply isg .
  apply isf .
  apply is .

Defined.

Definition ovmonot_funcomp { T1 T2 T3 : ltower } ( f : ovmonot_fun T1 T2 ) ( g : ovmonot_fun T2 T3 ) :
  ovmonot_fun T1 T3 :=
  ovmonot_fun_constr ( funcomp f g ) ( isovmonot_funcomp ( pr2 f ) ( pr2 g ) ) .

(** **** The ll-monot property of over-monotone functions *)

Definition isllmonot { T1 T2 : ltower } ( f : T1 -> T2 ) : UU :=
  forall ( X Y : T1 ) , ll ( f X ) - ll ( f Y ) = ll X - ll Y .

Lemma isllmonot_funcomp { T1 T2 T3 : ltower } { f : T1 -> T2 } { g : T2 -> T3 }
      ( isf : isllmonot f ) ( isg : isllmonot g ) : isllmonot ( funcomp f g ) .
Proof.
  intros.
  unfold isllmonot.
  intros X Y .
  assert ( int1 : ll ( g ( f X ) ) - ll ( g ( f Y ) ) = ll ( f X ) - ll ( f Y ) ) .
  apply isg .

  assert ( int2 : ll ( f X ) - ll ( f Y ) = ll X - ll Y ) .
  apply isf .

  exact ( int1 @ int2 ) .

Defined.

Lemma ft_f_X { T1 T2 : ltower } ( f : T1 -> T2 ) ( is1 : isovmonot f ) ( is2 : isllmonot f )
      { X : T1 } ( gt0 : ll X > 0 ) : ft ( f X ) = f ( ft X ) .
Proof.
  intros.
  assert ( isov := isover_X_ftX X ) .
  assert ( isov' := is1 _ _ isov ) .
  unfold isover in isov' .
  change _ with ( f ( ft X ) = ftn ( ll ( f X ) - ll ( f ( ft X ) ) ) ( f X ) ) in isov' .
  rewrite is2 in isov' .
  rewrite ll_ft in isov' .
  rewrite natminusmmk in isov' .
  exact ( ! isov' ) .

  apply ( @natgthminus1togeh 1 _ gt0 ) .

Defined.

(** **** The based functions - the functions that take objects of length zero to objects of length zero *)

Definition isbased { T1 T2 : ltower } ( f : T1 -> T2 ) : UU :=
  forall ( X : T1 ) ( eq0 : ll X = 0 ) , ll ( f X ) = 0 .

Lemma isbased_funcomp { T1 T2 T3 : ltower } { f : T1 -> T2 } { g : T2 -> T3 }
      ( isf : isbased f ) ( isg : isbased g ) : isbased ( funcomp f g ) .
Proof.
  intros. unfold isbased. intros X0 eq0 . unfold funcomp.
  apply isg .
  apply isf .
  exact eq0 .

Defined.

(** **** Morphisms of l-towers - l-tower functions. *)

Definition isltower_fun { T1 T2 : ltower } ( f : T1 -> T2 ) : UU :=
  dirprod ( isovmonot f )
          ( dirprod ( isllmonot f ) ( isbased f ) ) .

Definition ltower_fun ( T1 T2 : ltower ) :=
  total2 ( fun f : T1 -> T2 => isltower_fun f ) .

Definition ltower_fun_to_ovmonot_fun ( T1 T2 : ltower ) ( f : ltower_fun T1 T2 ) :
  ovmonot_fun T1 T2 := ovmonot_fun_constr _ ( pr1 ( pr2 f ) ) .
Coercion ltower_fun_to_ovmonot_fun : ltower_fun >-> ovmonot_fun .

Definition isovmonot_pr { T1 T2 : ltower } ( f : ltower_fun T1 T2 ) : isovmonot f :=
  pr1 ( pr2 f ) .

Definition isllmonot_pr { T1 T2 : ltower } ( f : ltower_fun T1 T2 ) : isllmonot f :=
  pr1 ( pr2 ( pr2 f ) ) .

Definition isbased_pr { T1 T2 : ltower } ( f : ltower_fun T1 T2 ) : isbased f :=
  pr2 ( pr2 ( pr2 f ) ) .

Definition ltower_fun_constr { T1 T2 : ltower } { f : T1 -> T2 }
           ( is1 : isovmonot f ) ( is2 : isllmonot f ) ( is3 : isbased f ) :
  ltower_fun T1 T2 :=
  tpair _ f ( dirprodpair is1 ( dirprodpair is2 is3 ) ) .

Definition ltower_funcomp { T1 T2 T3 : ltower } ( f : ltower_fun T1 T2 ) ( g : ltower_fun T2 T3 ) :
  ltower_fun T1 T3 .
Proof.
  intros.
  refine ( ltower_fun_constr _ _ _ ) .
  apply ( funcomp f g ) .

  apply ( isovmonot_funcomp ( isovmonot_pr f ) ( isovmonot_pr g ) ) .

  apply ( isllmonot_funcomp ( isllmonot_pr f ) ( isllmonot_pr g ) ) .

  apply ( isbased_funcomp ( isbased_pr f ) ( isbased_pr g ) ) .

Defined.

Definition ltower_idfun ( T : ltower ) : ltower_fun T T .
Proof.
  intros.
  refine ( ltower_fun_constr _ _ _ ) .
  apply idfun .

  unfold isovmonot .
  intros X Y isov . apply isov .

  unfold isllmonot .
  intros .
  apply idpath .

  unfold isbased .
  intros X eq .
  apply eq .

Defined.

(** *** Pointed ltowers

A pointed ltower is an ltower such that the type of its elements of length 0 is contractible.

 *)

Definition ispointed_type ( T : ltower ) :=
  iscontr ( total2 ( fun X : T => ll X = 0 ) ) .

Definition pltower := total2 ( fun T : ltower => ispointed_type T ) .

Definition pltower_constr { T : ltower } ( is : ispointed_type T ) : pltower := tpair _ _ is .

Definition pltower_pr1 : pltower -> ltower := pr1 .
Coercion pltower_pr1 : pltower >-> ltower .

Definition ispointed ( T : pltower ) : ispointed_type T := pr2 T .

Definition pltower_to_ltower { T : pltower } ( X : T ) : pltower_pr1 T := X .

Definition cntr ( T : pltower ) : T :=
  pr1 ( pr1 ( pr2 T ) ) .

Definition ll_cntr ( T : pltower ) : ll ( cntr T ) = 0 :=
  pr2 ( pr1 ( pr2 T ) ) .

Definition ft_cntr ( T : pltower ) : ft ( cntr T ) = cntr T .
Proof .
  intros .
  apply ftX_eq_X .
  apply ll_cntr .

Defined.

Lemma isoverll0 { T : pltower }
      { X1 : T } ( eq0 : ll X1 = 0 )
      ( X2 : T ) : isover X2 X1 .
Proof .
  intros . set ( is := pr2 T ) .
  unfold isover .
  assert ( eq0' : ll ( ftn ( ll X2 - ll X1 ) X2 ) = 0 ) .
  rewrite ll_ftn .
  rewrite eq0 . rewrite natminuseqn.
  exact ( natminusnn _ ) .

  assert ( eq : tpair ( fun X : T => ll X = 0 ) _ eq0 = tpair ( fun X : T => ll X = 0 ) _ eq0' ) .
  exact ( proofirrelevancecontr is _ _ ) .

  exact ( maponpaths ( @pr1 _ ( fun X : T => ll X = 0 ) ) eq ) .

Defined.

Definition isover_cntr { T : pltower } ( X : T ) : isover X ( cntr T ) :=
  isoverll0 ( ll_cntr T ) X .

Lemma noparts_ispointed { T : pltower }
      { X Y : T } ( eqX : ll X = 0 ) ( eqY : ll Y = 0 ) : X = Y .
Proof .
  intros . set ( is := pr2 T ) .
  set ( int := proofirrelevancecontr is ( tpair _ _ eqX ) ( tpair _ _ eqY ) ) .
  apply ( maponpaths pr1 int ) .

Defined.

Definition ll_ltower_fun { T1 : pltower } { T2 : ltower } ( f : ltower_fun T1 T2 ) ( X : T1 ) :
  ll ( f X ) = ll X .
Proof.
  intros.
  rewrite <- natminuseqn .
  rewrite <- ( ll_cntr T1 ) .
  rewrite <- ( natminuseqn ( ll ( f X ) ) ) .
  assert ( eq := isbased_pr f _ ( ll_cntr T1 ) ) .
  rewrite <- eq .
  exact ( isllmonot_pr f _ _ ) .

Defined.

Lemma ft_ltower_fun { T1 : pltower } { T2 : ltower } ( f : ltower_fun T1 T2 ) ( X : T1 ) :
  ft ( f X ) = f ( ft X ) .
Proof.
  intros.
  assert ( isov : isover ( f X ) ( f ( ft X ) ) ) .
  apply ( isovmonot_pr f _ _ ( isover_X_ftX X ) ) .
  unfold isover in isov .
  rewrite ( ll_ltower_fun f ) in isov .
  rewrite ( ll_ltower_fun f ) in isov .
  rewrite ll_ft in isov .
  destruct ( natgehchoice _ _ ( natgehn0 ( ll X ) ) ) as [ gt0 | eq0 ] .

  assert ( eq1 : ll X - ( ll X - 1 ) = 1 ) .
  apply natminusmmk .
  apply ( @natgthminus1togeh 1 _ gt0 ) .

  rewrite eq1 in isov .
  exact ( ! isov ) .

  assert ( eq : ft X = X ) .  apply ( ftX_eq_X eq0 ) .

  rewrite eq.
  assert ( eq0' : ll ( f X ) = 0 ) . apply ( isbased_pr f _ eq0 ) .

  apply ( ftX_eq_X eq0' ) .

Defined.

(* End of the file ltowers.v *)


Require Import Category.Lib.

From Equations Require Import Equations.
Set Equations With UIP.

Set Transparent Obligations.

Section Ty.

Inductive Ty : Type :=
  | TyUnit  : Ty
  | TyPair  : Ty → Ty → Ty
  | TyArrow : Ty → Ty → Ty.

Derive NoConfusion NoConfusionHom Subterm EqDec for Ty.

End Ty.

Declare Scope Ty_scope.
Bind Scope Ty_scope with Ty.
Delimit Scope Ty_scope with ty.

Infix "⟶" := TyArrow (at level 51, right associativity) : Ty_scope.
Infix "×"  := TyPair  (at level 41, right associativity) : Ty_scope.


(* Change from Comp to finitely supported distribution, carried by a list of pairs *)

Add LoadPath "~/fcf/src".
Add LoadPath "./Dist".
Require Import FCF.EqDec.
Require Import CpdtTactics.
Require Import List.
Require Import FCF.Rat.
Require Import FCF.Fold.

Require Import Coq.Lists.ListSet.
Require Import SetLems.
Require Import PIOA.
Require Import Dist.
Require Import Program.
Require Import Bool.

Section PIOARel.

  Definition refinement {L : Set} (P1 P2 : @PIOA L) := forall acts, exists acts',
        (f <- (run P1 acts); ret (traceOf P1 f)) ~~ (f <- (run P2 acts'); ret (traceOf P2 f)).

  Lemma refinement_refl : forall {L  : Set} (P : @PIOA L), refinement P P.
    unfold refinement.
    intros.
    exists acts.
    unfold distEquiv; crush.
  Qed.

  Lemma refinement_trans : forall {L : Set} (P Q R : @PIOA L), refinement P Q -> refinement Q R -> refinement P R.
    intros.
    unfold refinement in *.
    intro.
    destruct (H acts).
    destruct (H0 x).
    exists x0.
    rewrite H1.
    crush.
  Qed.

  Add Parametric Relation {L : Set} : (@PIOA L) refinement
  reflexivity proved by refinement_refl
  transitivity proved by refinement_trans
                           as refine_rel.

(* Without convex combination. *)
Section SyncSim.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).
  Context (c : act_lab P1 -> act_lab P2).

  Record SyncSimR (R : Dist (Frag P1) -> Dist (Frag P2) -> Prop) :=
    {
      sync_obs : (forall e1 e2, R e1 e2 -> (f <- e1; ret (traceOf P1 f)) ~~ (f <- e2; ret (traceOf P2 f)));
      sync_startcond: (R (ret (FragStart _ (start P1))) (ret (FragStart _ (start  P2))));
      sync_stepcond:
        (forall gamma a, R (run P1 gamma) (run P2 (map c gamma)) -> R (appAction P1 a (run P1 gamma))
                                                      (appAction P2 (c a) (run P2 (map c gamma))))}.

  Lemma SyncSimObs : forall R (xs : list (act_lab P1)) a, SyncSimR R ->
                                   R (run P1 xs) (run P2 (map c xs)) ->
                                   R (run P1 (a :: xs)) (run P2 ((c a) :: (map c xs))).
    intros.
    rewrite run_cons.
    rewrite run_cons.
    apply (sync_stepcond _ H).
    auto.
  Qed.

  Lemma SyncSymInd : forall R (xs : list (act_lab P1)), SyncSimR R -> R (run P1 xs) (run P2 (map c xs)).
    intros.
    induction xs.
    simpl.
    unfold run.
    unfold appList.
    apply (sync_startcond _ H).
    simpl.
    apply SyncSimObs.
    apply H.
    auto.
  Qed.

  Lemma SyncSimSound : forall R, SyncSimR R -> refinement P1 P2.
    intros.
    unfold refinement.
    intros; exists (map c acts).
    apply (sync_obs _ H).
    apply SyncSymInd.
    auto.
  Qed.

End SyncSim.

  Section CompSymm.
    Context {L : Set}.
    Context (P1 P2 : @PIOA L).

    Lemma symm_comp_ins : forall l, comp_ins P1 P2 l = comp_ins P2 P1 l.
    unfold comp_ins.
    crush.
    rewrite orb_comm.
    rewrite (orb_comm (pO P2 l) (pO P1 l)).
    crush.
    Qed.

    Lemma symm_comp_outs : forall l, comp_outs P1 P2 l = comp_outs P2 P1 l.
      unfold comp_outs; crush.
      rewrite orb_comm.
      rewrite (orb_comm (pI P2 l) (pI P1 l)).
      crush.
    Qed.

    Lemma symm_comp_hiddens : forall l, comp_hiddens P1 P2 l = comp_hiddens P2 P1 l.
    unfold comp_hiddens; crush.
    rewrite (orb_comm (pH P1 l)).
    destruct (pH P2 l); crush.
    destruct (pH P1 l); crush.
    rewrite orb_comm.
    rewrite andb_comm.
    rewrite (andb_comm (pI P1 l)).
    crush.
    Qed.

    Definition symm_lab_corr (l : act_lab (P1 |+| P2)) : act_lab (P2 |+| P1).
      unfold act_lab in *; simpl in *; unfold action in *; simpl in *.
      destruct l; econstructor; instantiate (1 := x).
      rewrite <- symm_comp_ins.
      rewrite <- symm_comp_outs.
      rewrite <- symm_comp_hiddens.
      apply e.
    Defined.

    Fixpoint symm_fragCorr (xs : Frag (P2 |+| P1)) : Frag (P1  |+| P2) :=
      match xs with
      | FragStart _ (p2,p1) => FragStart (compPIOA P1 P2) (p1,p2)
      | FragStep _ l (p2,p1) f =>
        FragStep (compPIOA P1 P2) l (p1,p2) (symm_fragCorr f)
      end.

    Lemma symm_refine : refinement (P1 |+| P2) (P2 |+| P1).
    apply (SyncSimSound _ _ symm_lab_corr (fun x y => x ~~ (y0 <- y; ret symm_fragCorr y0))).
    assert (forall x, traceOf (P1 |+| P2) (symm_fragCorr x) = traceOf (P2 |+| P1) x).
    induction x; simpl; destruct p; crush.
    unfold ext_action; simpl.
    rewrite <- symm_comp_ins.
    rewrite <- symm_comp_outs.
    crush.
    crush.

    econstructor.
    intros.
    rewrite (distBind_cong_l _ _ _ H0).
    rewrite bindAssoc.
    apply distBind_cong_r; intros.
    rewrite bind_ret.
    rewrite H.
    unfold distEquiv; crush.
    simpl.
    rewrite bind_ret.
    simpl.
    unfold comp_start; simpl.
    unfold distEquiv; crush.

    intros.
    unfold appAction.
    rewrite (distBind_cong_l _ _ _ H0).
    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    rewrite bind_ret.
    simpl.
    unfold comp_trans; simpl.
    destruct a; simpl.
    assert (forall x, lastState (P2 |+| P1) x = (fun p => (snd p, fst p)) (lastState (P1 |+| P2) (symm_fragCorr x))).
    induction x1; destruct p; crush.
    rewrite H2; simpl.
    destruct (lastState (P1 |+| P2) (symm_fragCorr x)); simpl.

    destruct (trans P1 p x0); destruct (trans P2 p0 x0).
    assert ((x0 <- d; y <- d0; ret (x0, y)) ~~ (y <- d0; x0 <- d; ret (x0, y))).
    apply bind_symm; intros; unfold distEquiv; crush.
    rewrite (distBind_cong_l _ _ _ H3).
    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.

    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.

    repeat rewrite bindAssoc.
    apply distBind_cong_r; intros.
    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.

    repeat rewrite bind_ret.
    simpl; unfold distEquiv; crush.
    Qed.

End CompSymm.

Section CompAssoc.
  Context {L : Set}.
  Context (P1 P2 P3 : @PIOA L).

    Lemma assocRefR : refinement (P1 |+| (P2 |+| P3)) ((P1 |+| P2) |+| P3).
      admit.
    Admitted.

    Lemma assocRefL : refinement ((P1 |+| P2) |+| P3) (P1 |+| (P2 |+| P3)).
      admit.
    Admitted.

End CompAssoc.

(* Without convex combination. *)
Section SimPIOA.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).
  Context (c : list (act_lab P1) -> (act_lab P1) -> list (act_lab P2)).

  Fixpoint runC (acts : list (act_lab P1)) : list (act_lab P2) :=
    match acts with
    | nil => nil
    | a :: acts' =>
      (c acts' a) ++ (runC acts')
    end.

  Record SimR (R : Dist (Frag P1) -> Dist (Frag P2) -> Prop) :=
    {
      obs : (forall e1 e2, R e1 e2 -> (f <- e1; ret (traceOf P1 f)) ~~ (f <- e2; ret (traceOf P2 f)));
      startcond: (R (ret (FragStart _ (start P1))) (ret (FragStart _ (start  P2))));
      stepcond:
    (forall gamma a, R (run P1 gamma) (run P2 (runC gamma)) -> R (appAction P1 a (run P1 gamma)) (appList P2 (run P2 (runC gamma)) (c gamma a)))}.

  Lemma simInd : forall R (xs : list (act_lab P1)) a, SimR R ->
                                   R (run P1 xs) (run P2 (runC xs)) ->
                                   R (run P1 (a :: xs)) (run P2 ((c xs a) ++ (runC xs))).
    intros.
    rewrite run_cons.
    rewrite run_app.
    apply (stepcond _ H).
    auto.
  Qed.

  Lemma simInv : forall R xs, SimR R -> R (run P1 xs) (run P2 (runC xs)).
    intros.
    induction xs.
    simpl.
    unfold run.
    unfold appList.
    apply (startcond _ H).
    simpl.
    apply simInd.
    apply H.
    auto.
  Qed.

  Lemma simSound : forall R, SimR R -> refinement P1 P2.
    intros.
    unfold refinement.
    intros; exists (runC acts).
    apply (obs _ H).
    apply simInv.
    auto.
  Qed.

End SimPIOA.

Section ImplPIOA.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).

  Definition implement := forall (P : PIOA),
      refinement (compPIOA P1 P) (compPIOA P2 P).

End ImplPIOA.

Section CompImpl.
  Context {L : Set}.
  Context (P1 P2 P3 : @PIOA L).

  Lemma implrefl :
    implement P1 P1.
    intros; unfold implement; intros.
    reflexivity.
  Qed.

  Lemma impltrans :
    implement P1 P2 -> implement P2 P3 -> implement P1 P3.
    intros; unfold implement in *; intros.
    rewrite (H P).
    apply H0.
  Qed.

  Lemma implementcomp :
    implement P1 P2 -> implement (compPIOA P1 P3) (compPIOA P2 P3).
    intros.
    unfold implement in *.
    intros.
    rewrite (assocRefL P1 P3 P).
    rewrite (H (compPIOA P3 P)).
    rewrite assocRefR.
    reflexivity.
  Qed.

End CompImpl.

Definition option_lift {A B} (P : A -> B -> Prop) (x : option A) (y : option B) :=
  (x = None /\ y = None) \/
  (exists c1 c2,
      x = Some c1 /\ y = Some c2 /\ P c1 c2).

Section SimplImplement.
  Context {L : Set}.
  Context (P1 P2 : @PIOA L).
  Context (lab_eq1 : pI P1 = pI P2).
  Context (lab_eq2 : pO P1 = pO P2).
  Context (lab_eq3 : pH P1 = pH P2).
  Context (st_corr : pQ P1 -> pQ P2).
  Context (start_corr : st_corr (start P1) = start P2).
  Context (trans_corr :
             forall s l,
               option_lift (fun d1 d2 => (x <- d1; ret (st_corr x)) ~~ d2) (trans P1 s l) (trans P2 (st_corr s) l)
               ).

  Definition simpl_lab_corr : forall P, act_lab (P1 |+| P) -> act_lab (P2 |+| P).
    intros.
    destruct H.
    econstructor.
    unfold action in *; simpl in *; unfold comp_ins, comp_hiddens, comp_outs in *.
  repeat rewrite lab_eq1 in e.
  repeat rewrite lab_eq2 in e.
  repeat rewrite lab_eq3 in e.
  apply e.
  Defined.

  Fixpoint simpl_actlist_corr (P : PIOA) (al : list (act_lab (P1 |+| P))) :=
    map (simpl_lab_corr P) al.

  Definition simpl_frag_corr (P : PIOA) (f : Frag (P1 |+| P)) : Frag (P2 |+| P).
    induction f.
    apply FragStart.
    simpl in p.
    simpl.
    split.
    apply (st_corr (fst p)).
    apply (snd p).

    apply FragStep.
    apply l.
    simpl in *.
    apply (st_corr (fst p), snd p).
    apply IHf.
  Defined.

  Lemma simpl_frag_corr_correct (P : PIOA) (f : Frag (P1 |+| P)) :
    traceOf _ (simpl_frag_corr _ f) = traceOf _ f.
  induction f.
  simpl; unfold distEquiv; crush.
  simpl.
  rewrite IHf.
  unfold ext_action; simpl; unfold comp_ins, comp_outs.
  rewrite lab_eq1.
  rewrite lab_eq2.
  auto.
  Qed.

  Definition simpl_simR : forall P, Dist (Frag (P1 |+| P)) -> Dist (Frag (P2 |+| P)) -> Prop :=
    fun _ e1 e2 =>
      (x <- e1; ret (simpl_frag_corr _ x)) ~~ e2.

  Lemma simpl_sim : forall P, SyncSimR (P1 |+| P) (P2 |+| P) (simpl_lab_corr P) (simpl_simR P).
  intros; constructor.
  intros.
  unfold simpl_simR in H.
  symmetry in H.
  rewrite (distBind_cong_l _ _ _ H).
  rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret; simpl.
  rewrite simpl_frag_corr_correct.
  unfold distEquiv; crush.
  unfold simpl_simR; simpl.
  rewrite bind_ret.
  simpl.
  unfold comp_start; simpl.
  rewrite start_corr.
  unfold distEquiv; crush.
  intros.
  unfold simpl_simR in *.
  unfold appAction.
  symmetry; symmetry in H.
  rewrite (distBind_cong_l _ _ _ H).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret.
  simpl.
  unfold comp_trans; simpl.
  assert (forall x, lastState (P2 |+| P) (simpl_frag_corr P x) =
          ((st_corr (fst (lastState _ x)), snd (lastState _ x)))).
  induction x0; crush.
  rewrite H1; simpl.
  destruct (lastState (P1 |+| P) x); simpl.
  destruct a; simpl.
  unfold option_lift in trans_corr.
  destruct (trans_corr p x0).
  destruct H2.
  rewrite H2, H3.
  destruct (trans P p0 x0).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros; repeat rewrite bind_ret; simpl.
  unfold distEquiv; crush.
  rewrite bind_ret; unfold distEquiv; crush.
  destruct H2.
  destruct H2.
  destruct H2.
  destruct H3.
  rewrite H2, H3.
  destruct (trans P p0 x0).
  repeat rewrite bindAssoc.
  symmetry in H4.
  rewrite (distBind_cong_l _ _ _ H4).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  rewrite bind_ret; repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  repeat rewrite bind_ret.
  simpl.
  unfold distEquiv; crush.
  rewrite bindAssoc.
  symmetry in H4.
  rewrite (distBind_cong_l _ _ _ H4).
  repeat rewrite bindAssoc.
  apply distBind_cong_r; intros.
  repeat rewrite bind_ret; simpl.
  unfold distEquiv; crush.
Qed.

  Lemma simpl_implement : implement P1 P2.
    unfold implement.
    intros.
    eapply SyncSimSound.
    apply simpl_sim.
  Qed.

End SimplImplement.

  Add Parametric Relation {L : Set} : (@PIOA L) implement
  reflexivity proved by implrefl
  transitivity proved by impltrans
                           as implement_rel.

Section SimplImplLabExt.
  Context (L L' : Set).
  Context (Lsur : L' -> option L).
  Context (Linj : L -> L').
  Context (Linv : forall x, Some x = Lsur (Linj x)).
 Context (Linv2 : (forall l l', Some l = Lsur l' -> Linj l = l')).
  Context (P1 P2 : @PIOA L).

  Definition act_lab_corr_lab_ext (f : act_lab P1 -> act_lab P2) : act_lab (lab_ext L L' P1 Lsur) -> act_lab (lab_ext L L' P2 Lsur).
    intros.
    destruct H.
    unfold action in e; simpl in e.
    destruct (Lsur x).
    cut (act_lab P2 -> act_lab (lab_ext L L' P2 Lsur)).
    intro.
    apply H; apply f.
    econstructor.
    apply e.

    intro.
    destruct H.
    econstructor.
    instantiate (1 := Linj x0).
    unfold action; simpl.
    rewrite <- Linv.
    apply e0.
    crush.
 Defined.

 Definition lab_ext_frag_corr : forall P, Frag (lab_ext L L' P Lsur) -> Frag P.
 intros.
 induction H.
 apply FragStart.
 apply p.
 destruct (Lsur l).
 apply FragStep.
 apply l0.
 apply p.
 apply IHFrag.
 apply IHFrag.
 Defined.

 Lemma lab_ext_traceOf_corr : forall P f,
     map Linj (traceOf P (lab_ext_frag_corr _ f)) = (traceOf (lab_ext L L' P Lsur) f).
 intros.
 induction f.
 simpl.
 crush.
 simpl.
 unfold ext_action.
 simpl.

 rewrite <- IHf.
 remember (Lsur l) as y; destruct y.
 simpl.
 unfold ext_action; simpl.
 destruct (pI P l0 || pO P l0).
 rewrite map_cons.
 simpl.
 rewrite (Linv2 _ _ Heqy).
 auto.

 auto.
 simpl.
 auto.
 Qed.

 Definition sync_R_lab_ext (R : Dist (Frag P1) -> Dist (Frag P2) -> Prop) : Dist (Frag (lab_ext L L' P1 Lsur)) -> Dist (Frag (lab_ext  L L' P2 Lsur)) -> Prop :=
   fun d1 d2 =>
     R (x <- d1; ret (lab_ext_frag_corr _ x)) (y <- d2; ret (lab_ext_frag_corr _ y)).

 End SimplImplLabExt.

End PIOARel.