(*******************************************************************
 * Construcción Formal de Programas en Teoría de Tipos
 * Trabajo práctico final
 * Hernán Gurmendi
 ******************************************************************)

(*******************************************************************
 * Este archivo especifica el estado.
 *
 ******************************************************************)

Section State.

(** Identificadores de OSs e Hypercalls *)

Parameter os_ident : Set.
Parameter os_ident_eq : forall oi1 oi2 : os_ident, {oi1 = oi2} + {oi1 <> oi2}.

Parameter Hyperv_call: Set.

(* Memoria y direcciones *)

(* Direcciones Virtuales. *)
Parameter vadd: Set.
Parameter vadd_eq : forall va1 va2 : vadd, {va1 = va2} + {va1 <> va2}.

(** Direcciones de Máquina. *)
Parameter madd :  Set.
Parameter madd_eq : forall ma1 ma2 : madd, {ma1 = ma2} + {ma1 <> ma2}.

(** Direcciones Físicas :
Los sitemas operativos utilizan este tipo de direcciones para ver regiones de memoriea
contigua. Estos no ven direcciones de máquina. *)
Parameter padd: Set.
Parameter padd_eq : forall pa1 pa2 : padd, {pa1 = pa2} + {pa1 <> pa2}.

(** Memory values. *)
Parameter value: Set.
Parameter value_eq:forall val1 val2 : value, {val1 = val2} + {val1 <> val2}.

(* Environment *)
Record context : Set :=
  Context
    {(** una dirección virtual es accesible, i.e. no está reserveda
         por el Hypervisor *)
       ctxt_vadd_accessible: vadd -> bool;
     (** guest Oss (Confiable/No Confiable) **)
       ctxt_oss : os_ident -> bool
    }.

Inductive exec_mode : Set :=
  | usr
  | svc.

Inductive os_activity : Set :=
  | running
  | waiting.

Record os : Set :=
  OS
    {
      curr_page : padd;
      hcall     : option Hyperv_call;
    }.

Definition oss_map : Set :=
  os_ident -> option os.

Definition hypervisor_map : Set :=
  os_ident -> option (padd -> option madd).

Inductive content : Set :=
  | RW (v : option value)
  | PT (va_to_ma : vadd -> option madd)
  | Other.

Definition isRW (cntnt : content) : bool :=
  match cntnt with
  | RW _ => true
  | _    => false
  end.

Inductive page_owner : Set :=
  | Hyp
  | Os (osi : os_ident)
  | No_Owner.

Record page : Set :=
  Page
    {
      page_content  : content;
      page_owned_by : page_owner;
    }.

Definition system_memory : Set :=
  madd -> option page.

Record state : Set :=
  State
    {
      active_os     : os_ident;       (* id del os activo *)
      aos_exec_mode : exec_mode;      (* modo de ejecución del os activo *)
      aos_activity  : os_activity;    (* estado de ejecución del os activo *)
      oss           : oss_map;        (* información sobre los oss *)
      hypervisor    : hypervisor_map; (* mapeos de memoria fisica a maquina segun os *)
      memory        : system_memory;  (* memoria de la plataforma *)
    }.

(* Actualiza la memoria m en la dirección de máquina ma por la página p *)
Definition update (m : system_memory) (ma : madd) (p : page) : system_memory :=
  fun (ma' : madd) => if (madd_eq ma ma')
                      then Some p
                      else m ma.

End State.


Require ClassicalEpsilon.
Require Import Reals Psatz.
From stdpp Require Import tactics.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice bigop.
From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import pival_dist pival ival_dist ival ival_pair pidist_singleton idist_pidist_pair extrema.
From discprob.prob Require Import prob countable finite stochastic_order.

Import Lub.

(* This is an inductive characterization of eq_ivd_prob, as is proved later *)
Inductive irrel_ivd : ∀ X, ivdist X → ivdist X → Prop :=
  | irrel_ivd_refl X : ∀ (I: ivdist X), irrel_ivd X I I
  | irrel_ivd_sym X : ∀ I1 I2, irrel_ivd X I1 I2 → irrel_ivd X I2 I1
  | irrel_ivd_trans X : ∀ I1 I2 I3, irrel_ivd X I1 I2 → irrel_ivd X I2 I3 → irrel_ivd X I1 I3
  | irrel_ivd_proper X :
      ∀ I1 I1' I2 I2', eq_ivd I1 I1' → eq_ivd I2 I2' → irrel_ivd X I1 I2 → irrel_ivd X I1' I2'
  | irrel_ivd_irrel X : ∀ {Y} I1 (I0: ivdist Y), irrel_ivd X I1 (x ← I0; I1)
  | irrel_ivd_bind X Y: ∀ (I1 I2: ivdist X) (f1 f2: X → ivdist Y),
      irrel_ivd X I1 I2 →
      (∀ x, irrel_ivd Y (f1 x) (f2 x)) →
      irrel_ivd Y (x ← I1; f1 x) (x ← I2; f2 x).

Arguments irrel_ivd {_}.

Definition le_pidist_irrel :=
  λ {X : Type} (Is1 Is2 : pidist X), ∀ I : ivdist X, In (I: ival X) Is1 → ∃ I' : ivdist X, irrel_ivd I I' ∧ In (I': ival X) Is2.

Lemma le_pidist_irrel_refl {X: Type} (Is1: pidist X):
  le_pidist_irrel Is1 Is1.
Proof.
  intros I Hin. exists I; split; eauto. apply irrel_ivd_refl.
Qed.

Lemma irrel_ivd_support_coerce {X} (I1 I2: ivdist X) :
  irrel_ivd I1 I2 →
  ∀ x, (∃ i2, ind I2 i2 = x ∧ val I2 i2 > 0) ↔ (∃ i1, ind I1 i1 = x ∧ val I1 i1 > 0).
Proof.
  induction 1.
  - split; intros; auto.
  - intros. by rewrite (IHirrel_ivd x).
  - intros. by rewrite (IHirrel_ivd2 x).
  - intros.
    rewrite (eq_ival_support_coerce I1 I1'); eauto.
    rewrite (eq_ival_support_coerce I2 I2'); eauto.
  - intros.
    * split.
      ** intros ((i0&i1)&Heq&Hgt). exists i1.
         rewrite //= in Heq Hgt.
         split; auto. specialize (val_nonneg I0 i0); nra.
      ** intros (i1&Heq&Hgt).
         edestruct (ivd_support_idx I0) as (i0&Hgt').
         exists (existT i0 i1); split => //=; nra.
  - intros x. split.
    * intros ((i2&if2)&Hind&Hval).
      rewrite //= in Hind.
      edestruct (IHirrel_ivd (ind I2 i2)) as (HI2&_).
      edestruct (HI2) as (i1&Hindeq&?).
      { eexists.  split; eauto. rewrite //= in Hval. specialize (val_nonneg (f2 (ind I2 i2)) if2).
        nra. }
      edestruct (H1 (ind I2 i2)) as (Hf2&_).
      edestruct Hf2 as (if1&?&?).
      { eexists.  split; eauto. rewrite //= in Hval.
        specialize (val_nonneg I2 i2); nra. }
      unshelve (eexists).
      { exists i1. rewrite Hindeq; exact if1.  }
      split => //=; destruct Hindeq.
      ** rewrite /eq_rect_r//=.
      ** rewrite /eq_rect_r//=. nra.
    * intros ((i2&if2)&Hind&Hval).
      rewrite //= in Hind.
      edestruct (IHirrel_ivd (ind I1 i2)) as (_&HI2).
      edestruct (HI2) as (i1&Hindeq&?).
      { eexists.  split; eauto. rewrite //= in Hval. specialize (val_nonneg (f1 (ind I1 i2)) if2).
        nra. }
      edestruct (H1 (ind I1 i2)) as (_&Hf2).
      edestruct Hf2 as (if1&?&?).
      { eexists.  split; eauto. rewrite //= in Hval.
        specialize (val_nonneg I1 i2); nra. }
      unshelve (eexists).
      { exists i1. rewrite Hindeq; exact if1.  }
      split => //=; destruct Hindeq.
      ** rewrite /eq_rect_r//=.
      ** rewrite /eq_rect_r//=. nra.
Qed.

Lemma le_pidist_irrel_support_coerce_aux {X} (Is1 Is2: pidist X) :
  le_pidist_irrel Is2 Is1 →
  ∀ x, In_psupport x Is2 → In_psupport x Is1.
Proof.
  intros Hle x (I2&i2&Hin2&?&Hval).
  destruct (Hle {| ivd_ival := I2; val_sum1 := all_sum1 Is2 _ Hin2|}) as (I1&Heq&Hin1); eauto.
  exists I1. edestruct (irrel_ivd_support_coerce _ _ Heq) as (i1&?&?).
  { eauto. }
  eexists; split; eauto.
Qed.

Global Instance irrel_ivd_proper_instance : Proper (@eq_ivd X ==> @eq_ivd X ==> iff) (@irrel_ivd X).
Proof.
  intros ? I1 I1' Heq1 I2 I2' Heq2.
  split; intros; eapply irrel_ivd_proper; eauto; try by symmetry.
Qed.

Global Instance irrel_ivd_Transitivite {X}: Transitive (@irrel_ivd X).
Proof. intros ???. apply irrel_ivd_trans. Qed.
Global Instance irrel_ivd_Reflexive {X}: Reflexive (@irrel_ivd X).
Proof. intros ?. apply irrel_ivd_refl. Qed.
Global Instance irrel_ivd_Symmetry {X}: Symmetric (@irrel_ivd X).
Proof. intros ??. apply irrel_ivd_sym. Qed.

Lemma is_Ex_ival_irrel_proper_bind {X Y} f (f1 f2: X → ivdist Y) (I1 I2: ivdist X) v
      (Hirrel_ivd : irrel_ivd I1 I2)
      (Hall_irrel : ∀ x : X, irrel_ivd (f1 x) (f2 x))
      (IHinner : ∀ (x : X) (f : Y → R) (v : R), is_Ex_ival f (f1 x) v ↔ is_Ex_ival f (f2 x) v)
      (IHirrel_ivd : ∀ (f : X → R) (v : R), is_Ex_ival f I1 v ↔ is_Ex_ival f I2 v):
  is_Ex_ival f (ivd_bind _ _ f1 I1) v → is_Ex_ival f (ivd_bind _ _ f2 I2) v.
Proof.
  intros His.
  assert (ex_Ex_ival f (ivd_bind _ _ f1 I1)).
  { eapply is_Ex_ival_ex; eauto. }
  rewrite -(is_Ex_ival_unique _ _ _ His).
  feed pose proof (ex_Ex_ival_bind_post (λ x, Rabs (f x)) I1 f1) as Hex_I1.
  { eapply ex_Ex_ival_to_Rabs, is_Ex_ival_ex. eauto. }
  feed pose proof (ex_Ex_ival_bind_post f I1 f1) as Hex_I1'.
  { eapply is_Ex_ival_ex. eauto. }
  rewrite Ex_ival_bind_post //=.
  assert (ex_Ex_ival f (ivd_bind _ _ f2 I2)).
  {
    apply ex_Ex_ival_from_Rabs, ex_Ex_ival_bind_post_inv; eauto using Rabs_pos, Rle_ge.
    ** intros.
       apply is_Ex_ival_ex, ex_Ex_ival_to_Rabs in His.
       edestruct (irrel_ivd_support_coerce I1 I2) as (Hlr&Hrl); eauto.
       edestruct Hlr as (i1&Heqi1&Hvali1); eauto.
       eapply ex_Ex_ival_bind_inv in His; eauto.
       eapply ex_Ex_ival_is in His as (v'&His).
       rewrite -Heqi1.
       eapply is_Ex_ival_ex. eapply IHinner; eauto.
    ** apply ex_Ex_ival_is in Hex_I1 as (v'&His').
       eapply is_Ex_ival_ex; eapply IHirrel_ivd.
       eapply is_Ex_ival_proper_fun_support; eauto.
       intros x Hsupport => //=.
       symmetry.
       apply is_Ex_ival_unique.
       eapply IHinner.
       eapply Ex_ival_correct. eapply (ex_Ex_ival_bind_inv (λ x, Rabs (f x)) f1 I1); eauto.
       apply ex_Ex_ival_to_Rabs. eapply is_Ex_ival_ex; eauto.
  }
  cut (Ex_ival f (ivd_bind _ _ f2 I2) = (Ex_ival (λ x, Ex_ival f (f1 x)) I1)).
  { intros HEx. rewrite -HEx. apply Ex_ival_correct; eauto. }
  rewrite Ex_ival_bind_post //=.
  apply is_Ex_ival_unique.
  eapply IHirrel_ivd.
  eapply is_Ex_ival_proper_fun_support; last first.
  { eapply Ex_ival_correct. eauto. }
  intros => //=.
  symmetry.
  apply is_Ex_ival_unique.
  eapply IHinner.
  eapply Ex_ival_correct. eapply (ex_Ex_ival_bind_inv f f1 I1); eauto.
Qed.

Lemma is_Ex_ival_irrel_proper {A} f (I I': ivdist A) v :
  irrel_ivd I I' →
  is_Ex_ival f I v ↔
  is_Ex_ival f I' v.
Proof.
  intros irrel_ivd.
  revert v.
  induction irrel_ivd; auto; intros.
  - symmetry.  eapply IHirrel_ivd.
  - rewrite IHirrel_ivd1. auto.
  - rewrite /eq_ivd in H.
    etransitivity; first etransitivity; try eapply IHirrel_ivd.
    { split; apply is_Ex_ival_proper; eauto. by symmetry. }
    { split; apply is_Ex_ival_proper; eauto. by symmetry. }
  - split. apply is_Ex_ival_bind_irrel, val_sum1.
    intros His. cut (ex_Ex_ival f I1).
    { intros Hex. apply Ex_ival_correct in Hex.
      cut (Ex_ival f I1 = v); intros; subst; eauto.
      eapply is_Ex_ival_unique'; last eassumption.
      apply is_Ex_ivd_bind_irrel; eauto.
    }
    apply is_Ex_ival_ex in His.
    unshelve (eapply ex_Ex_ival_bind_inv in His; eauto).
    { exact (sval (ivd_support_idx I0)). }
    destruct (ivd_support_idx _) => //=.
  - split; eapply is_Ex_ival_irrel_proper_bind; eauto; try (intros; by symmetry).
Qed.

Lemma ex_Ex_ival_irrel_proper {A} f (I I': ivdist A) :
  irrel_ivd I I' →
  ex_Ex_ival f I →
  ex_Ex_ival f I'.
Proof.
  intros Hirrel (v&His)%ex_Ex_ival_is.
  eapply is_Ex_ival_ex.
  eapply is_Ex_ival_irrel_proper; eauto.
    by symmetry.
Qed.

Lemma Ex_ival_irrel_proper {A} f (I I': ivdist A) :
  irrel_ivd I I' →
  ex_Ex_ival f I →
  Ex_ival f I = Ex_ival f I'.
Proof.
  intros. symmetry. apply is_Ex_ival_unique.
  eapply is_Ex_ival_irrel_proper; eauto.
  * symmetry. eauto.
  * apply Ex_ival_correct; eauto.
Qed.

Lemma irrel_ivd_to_eq_ivd_prob {X} (I1 I2: ivdist X):
  irrel_ivd I1 I2 →
  eq_ivd_prob I1 I2.
Proof.
  intros Hirrel.
  apply eq_ivd_prob_alt.
  intros x.
  transitivity ((Pr (λ v, v = x) I1)).
  { rewrite /Ex_ival/idx_eq_ind//=. eapply SeriesC_ext; intros.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; nra.
  }
  transitivity ((Pr (λ v, v = x) I2)); last first.
  { rewrite /Ex_ival/idx_eq_ind//=. eapply SeriesC_ext; intros.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; nra.
  }
  apply Ex_ival_irrel_proper; eauto.
  apply ex_Pr.
Qed.

Lemma In_isupport_pr_gt_0 {X: Type} (I: ivdist X) (x: X):
  In_isupport x I →
  0 < Pr (eq ^~ x) I.
Proof.
  rewrite /Pr/Ex_ival => Hin.
  destruct Hin as (i&?&?).
  eapply (Series_strict_pos _ (pickle i)).
  { intros.  rewrite /countable_sum/oapp.
    destruct pickle_inv; try nra.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
    rewrite Rmult_1_l. apply val_nonneg.
  }
  { intros.  rewrite /countable_sum/oapp.
    rewrite pickleK_inv.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
  }
  feed pose proof (ex_Pr (eq^~ x) I).
  apply ex_Ex_ival_is in H1 as (v&?).
  rewrite /is_Ex_ival in H1.
  destruct H1 as (Hex&His).
  eexists. eauto.
Qed.

Lemma pr_gt_0_In_isupport {X: Type} (I: ivdist X) (x: X):
  0 < Pr (eq ^~ x) I →
  In_isupport x I.
Proof.
  rewrite /Pr/Ex_ival => Hin.
  eapply (Series_strict_pos_inv) in Hin as (n&?).
  {
   destruct (pickle_inv (idx I) n) as [i|] eqn:Heq.
   - exists i. rewrite  //=/countable_sum//= Heq //= in H.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
    * rewrite //= in H. split; eauto. nra.
    * rewrite //= in H. nra.
   - rewrite //=/countable_sum//= Heq //= in H ; nra.
  }
  intros n. rewrite /countable_sum. destruct pickle_inv => //=; last nra.
    destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra.
    rewrite Rmult_1_l. apply val_nonneg.
Qed.

(* This is a kind of conditional distribution *)
Lemma ival_slice_proof1 (X : Type) (I : ivdist X) (x : X):
  ∀ i : idx I, (if ClassicalEpsilon.excluded_middle_informative (In_isupport x I)
                then
                 (if ClassicalEpsilon.excluded_middle_informative (ind I i = x) then val I i else 0) /
                 Pr (eq^~ x) I
                else val I i) ≥ 0.
Proof.
  intros i.
  destruct ClassicalEpsilon.excluded_middle_informative; eauto; last apply val_nonneg.
  apply Rle_ge, Rdiv_le_0_compat.
  { destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra.
    apply Rge_le, val_nonneg. }
  { apply In_isupport_pr_gt_0; eauto. }
Qed.

Definition ival_slice {X} (I: ivdist X) (x: X) : ival X.
  refine {| idx := idx I;
            ind := ind I;
            val := λ i,
                   if ClassicalEpsilon.excluded_middle_informative (In_isupport x I) then
                   (if ClassicalEpsilon.excluded_middle_informative (ind I i = x) then
                          val I i
                        else
                          0) / Pr (λ i, i = x) I
                   else
                     val I i|}.
  apply ival_slice_proof1.
Defined.

Lemma ival_slice_proof2 (X : Type) (I : ivdist X) (x : X):
  is_series (countable_sum (val (ival_slice I x))) 1.
Proof.
  rewrite //=. destruct ClassicalEpsilon.excluded_middle_informative; last apply val_sum1.
  replace 1 with (Pr (eq^~ x) I */ Pr (eq^~ x) I); last first.
  { field. apply Rgt_not_eq, In_isupport_pr_gt_0; auto. }
  apply is_seriesC_scal_r.
  rewrite /Pr/Ex_ival.
  apply (is_seriesC_ext _ (λ i0 : idx I, (if is_left (ClassicalEpsilon.excluded_middle_informative (ind I i0 = x))
                          then 1
                          else 0) * val I i0)).
  { intros.  destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra. }

  {
  feed pose proof (ex_Pr (eq^~ x) I) as Hpr.
  apply ex_Ex_ival_is in Hpr as (v&Hpr).
  rewrite /is_Ex_ival in Hpr.
  destruct Hpr as (Hex&His).
  eapply Series_correct; eexists; eauto. }
Qed.

Definition ivdist_slice {X} (I: ivdist X) (x: X) : ivdist X.
Proof.
  exists (ival_slice I x).
  apply ival_slice_proof2.
Defined.

Lemma eq_ivd_prob_Pr_eq {X} (I1 I2: ivdist X) x:
  eq_ivd_prob I1 I2 →
  Pr (eq^~ x) I1 = Pr (eq^~ x) I2.
Proof.
  rewrite /Pr/Ex_ival => Heq.
  unshelve (eapply eq_ivd_prob_alt in Heq); first exact x.
  rewrite /idx_eq_ind in Heq.
  setoid_rewrite Rmult_if_distrib.
  setoid_rewrite Rmult_0_l.
  setoid_rewrite Rmult_1_l.
  eauto.
Qed.

Lemma eq_ivd_prob_In_isupport {X: Type} I1 I2 (x: X):
  eq_ivd_prob I1 I2 →
  In_isupport x I1 →
  In_isupport x I2.
Proof.
  intros Heq Hin%In_isupport_pr_gt_0.
  apply pr_gt_0_In_isupport.
  erewrite <-eq_ivd_prob_Pr_eq; last eassumption.
  eauto.
Qed.

Lemma eq_ivd_prob_to_irrel_ivd {X} (I1 I2: ivdist X):
  eq_ivd_prob I1 I2 →
  irrel_ivd I1 I2.
Proof.
  intros Heq.
  transitivity (x ← I1; _ ← ivdist_slice I2 x; mret x).
  { transitivity (x ← I1; mret x).
    { rewrite ivd_right_id. reflexivity. }
    apply irrel_ivd_bind; first reflexivity.
    intros x. apply irrel_ivd_irrel.
  }
  transitivity (x ← I2; _ ← ivdist_slice I1 x; mret x); last first.
  { symmetry.
    transitivity (x ← I2; mret x).
    { rewrite ivd_right_id. reflexivity. }
    apply irrel_ivd_bind; first reflexivity.
    intros x. apply irrel_ivd_irrel.
  }
  cut (eq_ivd (I1 ≫= (λ x : X, ivdist_slice I2 x ≫= (λ _ : X, mret x)))
    (I2 ≫= (λ x : X, ivdist_slice I1 x ≫= (λ _ : X, mret x)))).
  { intros ->.  reflexivity. }

  apply eq_ival_nondep_inj_surj_suffice.
  apply eq_ival_nondep_inj_surj'_helper.
  unshelve eexists.
  { intros (i1&i2&?). exists i2. exists i1. exact tt. }
  rewrite //=.
  split_and!.
  * intros (i1&i2&[]) (i1'&i2'&[]) _ _ => //=.
    inversion 1; subst. auto.
  * intros (i2&i1&[]).
    unshelve (eexists).
    { exists i1.  exists i2. exact tt. }
    split_and!; eauto => //=.
    repeat  destruct ClassicalEpsilon.excluded_middle_informative; try nra; try congruence.
    ** intros Hgt. eapply Rge_gt_trans; last  eassumption.
       right. rewrite //=.
       cut (Pr (eq^~ (ind I2 i2)) I1 = Pr (eq^~ (ind I1 i1)) I2).
       { intros ->.  nra. }
       rewrite e0; eapply eq_ivd_prob_Pr_eq; eauto.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
       by symmetry.
    ** cut (val I2 i2 = 0).
       { intros ->. nra. }
       destruct (val_nonneg I2 i2); last auto.
       exfalso. eapply n.
       eapply eq_ivd_prob_In_isupport; eauto.
       { by symmetry. }
       eexists; eauto.
  * intros (i1&i2&[]) => //=.
    repeat  destruct ClassicalEpsilon.excluded_middle_informative; try nra; try congruence.
    cut (val I1 i1 = 0).
    { intros ->.  nra. }
    destruct (val_nonneg I1 i1); last auto.
    exfalso. eapply n.
    eapply eq_ivd_prob_In_isupport; eauto.
    eexists; eauto.
  * intros (i1&i2&[]) => //=.
    repeat  destruct ClassicalEpsilon.excluded_middle_informative => //=; try nra; try congruence.
    ** intros Hgt.
       cut (Pr (eq^~ (ind I2 i2)) I1 = Pr (eq^~ (ind I1 i1)) I2).
       { intros ->.  nra. }
       rewrite e0; eapply eq_ivd_prob_Pr_eq; eauto.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
       by symmetry.
    ** intros; exfalso. eapply n. rewrite e.
       eapply eq_ivd_prob_In_isupport; eauto.
    ** cut (val I1 i1 = 0).
       { intros ->. nra. }
       destruct (val_nonneg I1 i1); last auto.
       exfalso. eapply n.
       eapply eq_ivd_prob_In_isupport; eauto.
       eexists; eauto.
Qed.

Lemma irrel_ivd_choice {X} (I1 I1' I2 I2': ivdist X) p Hpf Hpf':
      irrel_ivd I1 I2 →
      irrel_ivd I1' I2' →
      irrel_ivd (ivdplus p Hpf I1 I1') (ivdplus p Hpf' I2 I2').
Proof.
  intros Hirrel1 Hirrel2.
  transitivity (b ← ivdplus p Hpf (mret true) (mret false);
                if (b: bool) then I1 else I1').
  { rewrite ivd_plus_bind ?ivd_left_id. reflexivity. }
  transitivity (b ← ivdplus p Hpf' (mret true) (mret false);
                if (b: bool) then I2 else I2'); last first.
  { rewrite ivd_plus_bind ?ivd_left_id. reflexivity. }
  apply irrel_ivd_bind.
  { cut (eq_ivd (ivdplus p Hpf (mret true) (mret false)) (ivdplus p Hpf' (mret true) (mret false))).
    { intros ->; reflexivity. }
    apply ivdist_plus_proper; reflexivity.
  }
  intros [|]; eauto.
Qed.

Definition irrel_pidist {X: Type} (Is1 Is2: pidist X) :=
  ∀ f, bounded_fun f → Rbar_le (Ex_min f Is2) (Ex_min f Is1).

Lemma irrel_pidist_Ex_max {X: Type} (Is1 Is2: pidist X) :
    irrel_pidist Is1 Is2 → ∀ f, bounded_fun f → Rbar_le (Ex_max f Is1) (Ex_max f Is2).
Proof.
  intros Hirrel f Hb.
  rewrite ?Ex_max_neg_min.
  apply Rbar_opp_le.
  apply Hirrel.
  destruct Hb as (c&?).
  exists c => x. rewrite Rabs_Ropp; eauto.
Qed.

Lemma Ex_max_irrel_pidist {X: Type} (Is1 Is2: pidist X) :
  (∀ f, bounded_fun f → Rbar_le (Ex_max f Is1) (Ex_max f Is2)) →
  irrel_pidist Is1 Is2.
Proof.
  intros Hirrel f Hb.
  specialize (Hirrel (λ x, (- f x))).
  rewrite ?Ex_max_neg_min in Hirrel.
  apply Rbar_opp_le.
  setoid_rewrite Ropp_involutive in Hirrel.
  eapply Hirrel. destruct Hb as (c&?). exists c.
  intros x. rewrite Rabs_Ropp; eauto.
Qed.

Lemma irrel_pidist_refl {X} : ∀ I, @irrel_pidist X I I.
Proof. intros f Hb; reflexivity. Qed.

Lemma irrel_pidist_trans {X} :
   ∀ I1 I2 I3, @irrel_pidist X I1 I2 → @irrel_pidist X I2 I3 → @irrel_pidist X I1 I3.
Proof.
  intros I1 I2 I3 Hi1 Hi2 f Hb.
  specialize (Hi1 f Hb).
  specialize (Hi2 f Hb).
  etransitivity; eauto.
Qed.

Lemma bounded_supp_fun_le_pidist {A} f (Is Is': pidist A):
  le_pidist Is Is' →
  bounded_fun_on f (λ x, In_psupport x Is') →
  bounded_fun_on f (λ x, In_psupport x Is).
Proof.
  intros Hle Hbf.
  eapply bounded_fun_on_anti; try eassumption.
  intros a. eapply le_pidist_support_coerce_aux; eauto.
Qed.

Lemma Ex_min_le_pidist_irrel {X} (f: X → R) Is1 Is2:
  le_pidist_irrel Is1 Is2 →
  Rbar_le (Ex_min f Is2) (Ex_min f Is1).
Proof.
  intros Hle.
  rewrite /Ex_min.
  destruct (Glb_Rbar_correct (Ex_pidist f Is1)) as (Hlb&Hglb).
  apply Hglb. intros r Hex. destruct Hex as (I&Hin&Hex).
  edestruct (Hle {| ivd_ival := I; val_sum1 := all_sum1 Is1 _ Hin |}) as (I2&Heq&Hin2).
  { rewrite //=. }
  { eapply (is_Ex_ival_irrel_proper f) in Heq; last eauto.
    destruct (Glb_Rbar_correct (Ex_pidist f Is2)) as (Hlb2&Hglb2).
    eapply Hlb2. eexists; split; eauto.
    eapply Heq => //=.
  }
Qed.

Lemma Ex_max_le_pidist_irrel {X} (f: X → R) Is1 Is2:
  le_pidist_irrel Is1 Is2 →
  Rbar_le (Ex_max f Is1) (Ex_max f Is2).
Proof.
  rewrite ?Ex_max_neg_min.
  intros Hle.
  apply Rbar_opp_le.
  apply Ex_min_le_pidist_irrel; eauto.
Qed.

Lemma irrel_pidist_proper_irrel {X} :
  ∀ I1 I1' I2 I2', le_pidist_irrel I1' I1 → le_pidist_irrel I2 I2' →
                   @irrel_pidist X I1 I2 → @irrel_pidist X I1' I2'.
Proof.
  intros I1 I1' I2 I2' Hle1 Hle2 Hirrel12.
  intros f Hb.
  etransitivity.
  { apply Ex_min_le_pidist_irrel; eauto. }
  etransitivity.
  { eapply Hirrel12; eauto. }
  { apply Ex_min_le_pidist_irrel; eauto. }
Qed.

Lemma irrel_pidist_bind1 {X Y}: ∀ (I1 I2: pidist X) (f: X → pidist Y),
      @irrel_pidist X I1 I2 →
      @irrel_pidist Y (x ← I1; f x) (x ← I2; f x).
Proof.
  intros I1 I2 f Hirrel.
  intros g Hb.
  rewrite ?Ex_min_bind_post;
    eauto using Ex_min_bounded_is_bounded, ex_Ex_extrema_bounded_fun,
    Ex_min_bounded_fun_finite.
Qed.

Lemma irrel_pidist_bind {X Y}: ∀ (I1 I2: pidist X) (f1 f2: X → pidist Y),
      @irrel_pidist X I1 I2 →
      (∀ x, @irrel_pidist Y (f1 x) (f2 x)) →
      @irrel_pidist Y (x ← I1; f1 x) (x ← I2; f2 x).
Proof.
  intros I1 I2 f1 f2 Hirrel Hirrelfun.
  eapply irrel_pidist_trans.
  { eapply irrel_pidist_bind1; eauto. }
  intros f Hb. eapply Ex_min_bind_le;
    eauto using Ex_min_bounded_is_bounded, ex_Ex_extrema_bounded_fun,
    Ex_min_bounded_fun_finite.
  intros a ?. eapply Hirrelfun; eauto.
Qed.

Lemma irrel_pidist_proper X :
  ∀ (I1 I1' I2 I2': pidist X), le_pidist I1' I1 → le_pidist I2 I2'
                               → irrel_pidist I1 I2 → irrel_pidist I1' I2'.
Proof.
  intros ???? Hle1 Hle2. eapply irrel_pidist_proper_irrel.
  { intros x Hin. edestruct (Hle1 x) as (x'&Heq&Hin'); eauto.
    exists {| ivd_ival := x'; val_sum1 := all_sum1 I1 _ Hin'|}; split; auto.
    eapply irrel_ivd_proper; eauto; last apply irrel_ivd_refl.
    reflexivity.
  }
  { intros x Hin. edestruct (Hle2 x) as (x'&Heq&Hin'); eauto.
    exists {| ivd_ival := x'; val_sum1 := all_sum1 I2' _ Hin'|}; split; auto.
    eapply irrel_ivd_proper; eauto; last apply irrel_ivd_refl.
    reflexivity.
  }
Qed.

Global Instance irrel_pidist_mono_instance : Proper (@le_pidist X --> @le_pidist X ==> Coq.Program.Basics.impl) (@irrel_pidist X).
Proof.
  intros X I1 I1' Heq1 I2 I2' Heq2.
  intros Hirrel. eapply irrel_pidist_proper; eauto.
Qed.

Global Instance irrel_pidist_proper_instance : Proper (@eq_pidist X ==> @eq_pidist X ==> iff) (@irrel_pidist X).
Proof.
  intros X I1 I1' Heq1 I2 I2' Heq2.
  split; intros Hirrel; eapply irrel_pidist_proper; eauto;
    try (setoid_rewrite Heq1; reflexivity);
    try (setoid_rewrite Heq2; reflexivity).
Qed.

Global Instance irrel_pidist_Transitivite {X}: Transitive (@irrel_pidist X).
Proof. intros ???. apply irrel_pidist_trans. Qed.
Global Instance irrel_pidist_Reflexive {X}: Reflexive (@irrel_pidist X).
Proof. intros ?. apply irrel_pidist_refl. Qed.

Record irrel_couplingP {A1 A2} (I1: ivdist A1) (Is2: pidist A2) (P: A1 → A2 → Prop) : Type :=
  { irrel_I : ivdist A1;
    irrel_Is : pidist A2;
    irrel_rel_I : irrel_ivd I1 irrel_I;
    irrel_rel_Is : irrel_pidist irrel_Is Is2;
    irrel_couple_wit :> idist_pidist_couplingP irrel_I irrel_Is P
  }.

Definition lsupport {A1 A2 Is1 Is2 P} (Icouple: irrel_couplingP Is1 Is2 P) (y: A2) :=
  { x : A1 |  ∃ i Hpf, ival.ind Icouple i = (exist _ (x, y) Hpf) ∧ ival.val Icouple i > 0 }.
Definition rsupport {A1 A2 Is1 Is2 P} (Icouple: irrel_couplingP Is1 Is2 P) (x: A1) :=
  { y : A2 |  ∃ i Hpf, ival.ind Icouple i = (exist _ (x, y) Hpf) ∧ ival.val Icouple i > 0 }.

Definition irrel_coupling_propP {A1 A2} (I1: ivdist A1) (Is2: pidist A2) P : Prop :=
  ∃ (ic: irrel_couplingP I1 Is2 P), True.

Lemma ic_wit_to_prop {A1 A2} (I1 : ivdist A1) (Is2: pidist A2) P :
  irrel_couplingP I1 Is2 P →
  irrel_coupling_propP I1 Is2 P.
Proof.
  intros; eexists; eauto.
Qed.

Lemma ic_prop_to_wit {A1 A2} (I1 : ivdist A1) (Is2: pidist A2) P :
  irrel_coupling_propP I1 Is2 P →
  irrel_couplingP I1 Is2 P.
Proof.
  intros (?&_)%ClassicalEpsilon.constructive_indefinite_description; auto.
Qed.

Lemma irrel_pidist_support_coerce {X} (I1 I2: pidist X) :
  irrel_pidist I2 I1 →
  ∀ x, In_psupport x I2 → In_psupport x I1.
Proof.
  intros Hirrel x Hin.
  destruct Hin as (I&i&Hin&Hind&Hval).
  assert (0 < Pr (eq ^~ x) {| ivd_ival := I; val_sum1 := all_sum1 _ _ Hin|}).
  {  eapply In_isupport_pr_gt_0.
     eexists; eauto. }
  assert (Rbar_lt 0 (Pr_max (eq^~ x) I1)) as Hmax.
  {
    apply (Rbar_lt_le_trans _ (Pr_max (eq^~ x) I2)); last first.
    { eapply irrel_pidist_Ex_max; eauto.
      exists 1. intros. destruct (is_left); rewrite Rabs_right; nra.
    }
    apply (Rbar_lt_le_trans _ (Pr (eq^~ x) {| ivd_ival := I; val_sum1 := all_sum1 I2 I Hin |}));
      first done.
    apply Ex_max_spec1' => //=.
    eapply (ex_Pr (eq^~x) {| ivd_ival := I; val_sum1 := all_sum1 I2 I Hin |}).
  }
  assert (∃ I' : ivdist X, In (I': ival X) I1 ∧ 0 < Pr (eq^~x) I') as (I'&Hin'&Hpr').
  {
    apply Classical_Pred_Type.not_all_not_ex. intros Hneg.
    apply Rbar_lt_not_le in Hmax. apply Hmax.
    apply Ex_max_spec2.
    intros r' (I'&Hin'&Heq).
    apply Rbar_not_lt_le. intros Hlt.
    exfalso; eapply (Hneg {| ivd_ival := I'; val_sum1 := all_sum1 _ _ Hin'|}).
    split; first done.
    rewrite /Pr. erewrite is_Ex_ival_unique; last eassumption.
    auto.
  }
  exists I'. apply pr_gt_0_In_isupport in Hpr'.
  destruct Hpr' as (?&?&?). eexists; split_and!; eauto.
Qed.

Lemma irrel_pidist_choice {X} (I1 I1' I2 I2': pidist X) p Hpf Hpf':
      irrel_pidist I1 I2 →
      irrel_pidist I1' I2' →
      irrel_pidist (pidist_plus p Hpf I1 I1') (pidist_plus p Hpf' I2 I2').
Proof.
  intros Hirrel1 Hirrel2.
  transitivity (b ← pidist_plus p Hpf (mret true) (mret false);
                if (b: bool) then I1 else I1').
  { rewrite pidist_plus_bind ?pidist_left_id. reflexivity. }
  transitivity (b ← pidist_plus p Hpf' (mret true) (mret false);
                if (b: bool) then I2 else I2'); last first.
  { rewrite pidist_plus_bind ?pidist_left_id. reflexivity. }
  apply irrel_pidist_bind.
  { cut (eq_pidist (pidist_plus p Hpf (mret true) (mret false))
                   (pidist_plus p Hpf' (mret true) (mret false))).
    { intros ->; reflexivity. }
    apply pidist_plus_proper; reflexivity.
  }
  intros [|]; eauto.
Qed.

Lemma irrel_pidist_irrel {X Y}: ∀ I1 (I0: pidist Y), @irrel_pidist X (x ← I0; I1) I1.
Proof.
  intros. intros f Hbounded.
  rewrite Ex_min_bind_irrel //=; try reflexivity;
    eauto using Ex_min_bounded_is_bounded, ex_Ex_extrema_bounded_fun,
    Ex_min_bounded_fun_finite.
Qed.

Lemma irrel_coupling_proper {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  eq_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Lemma irrel_coupling_mono {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  le_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Lemma irrel_coupling_mono_irrel {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  eq_ivd I1 I2 →
  irrel_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Lemma irrel_coupling_mono_irrel' {A1 A2} (I1 I2 : ivdist A1) (Is1 Is2: pidist A2) P:
  irrel_ivd I1 I2 →
  irrel_pidist Is1 Is2 →
  irrel_couplingP I1 Is1 P →
  irrel_couplingP I2 Is2 P.
Proof.
  intros HeqI HeqIs [I1' Is1' HeqI1 HeqIs1 Hcouple].
  exists I1' Is1'.
  - setoid_rewrite <-HeqI. done.
  - setoid_rewrite <-HeqIs. done.
  - done.
Qed.

Global Instance irrel_coupling_prop_Proper {A1 A2}:
  Proper (@eq_ivd A1 ==> @le_pidist A2 ==> eq ==> impl) irrel_coupling_propP.
Proof.
  intros ?? Heq ?? Hle ?? ->.
  intros H%ic_prop_to_wit.
  apply ic_wit_to_prop.
  eapply irrel_coupling_mono; eauto.
Qed.

Global Instance irrel_coupling_prop_irrel_Proper {A1 A2}:
  Proper (@eq_ivd A1 ==> @irrel_pidist A2 ==> eq ==> impl) irrel_coupling_propP.
Proof.
  intros ?? Heq ?? Hle ?? ->.
  intros H%ic_prop_to_wit.
  apply ic_wit_to_prop.
  eapply irrel_coupling_mono_irrel; eauto.
Qed.

Lemma irrel_coupling_mret {A1 A2} (P: A1 → A2 → Prop) x y:
  P x y →
  irrel_couplingP (mret x) (mret y) P.
Proof.
  intros HP. exists (mret x) (mret y); try reflexivity.
  by apply ip_coupling_mret.
Qed.

Lemma irrel_coupling_prop_mret {A1 A2} (P: A1 → A2 → Prop) x y:
  P x y →
  irrel_coupling_propP (mret x) (mret y) P.
Proof.
  intros; apply ic_wit_to_prop, irrel_coupling_mret; auto.
Qed.

Lemma irrel_coupling_bind {A1 A2 B1 B2} P (f1: A1 → ivdist B1) (f2: A2 → pidist B2)
      I1 Is2 Q (Ic: irrel_couplingP I1 Is2 P):
  (∀ x y, P x y → irrel_couplingP (f1 x) (f2 y) Q) →
  irrel_couplingP (mbind f1 I1) (mbind f2 Is2) Q.
Proof.
  intros Hfc.
  destruct Ic as [I1' Is2' HeqI HeqIs Hcouple].
  destruct Hcouple as [I2' ? [Ic ? ?]%ic_coupling_to_id].
  unshelve (eexists).
  - refine (xy ← Ic; _).
     destruct xy as ((x&y)&HP).
     destruct (Hfc _ _ HP).
     exact irrel_I0.
  - refine (xy ← singleton Ic; _).
    destruct xy as ((x&y)&HP).
    destruct (Hfc x y HP).
    exact irrel_Is0.
  - etransitivity.
    { eapply irrel_ivd_bind.  eauto. reflexivity. }
    etransitivity.
    { eapply irrel_ivd_bind. setoid_rewrite idc_proj1. reflexivity. reflexivity.  }
    setoid_rewrite ivd_assoc. eapply irrel_ivd_bind; first reflexivity.
    intros ((x&y)&HP).
    destruct (Hfc _ _ _) as [? ? ?]. rewrite /irrel_I.
    rewrite /sval.  setoid_rewrite ivd_left_id. done.
  - etransitivity; last first.
    { eapply irrel_pidist_bind.
      - etransitivity; last by eauto. eapply irrel_pidist_proper; first by eauto.
        reflexivity. reflexivity.
      - intros; reflexivity.
    }
    setoid_rewrite idc_proj2. setoid_rewrite singleton_bind.
    setoid_rewrite pidist_assoc.
    eapply irrel_pidist_bind; first reflexivity.
    intros ((x&y)&HP).
    destruct (Hfc _ _ _) as [? ? ?]. rewrite /irrel_I.
    rewrite /sval. setoid_rewrite singleton_mret. setoid_rewrite pidist_left_id.
    eauto.
  - eapply (ip_coupling_bind _ _ _ _ (λ x y, x = y)).
    * apply ip_coupling_singleton.
    * intros ((?&?)&HP1) ((x&y)&HP2).
      inversion 1; subst.
      rewrite //=.
      assert (HP1 = HP2). { apply classical_proof_irrelevance. }
      subst.
      destruct (Hfc x y HP2). eauto.
Qed.

Lemma irrel_coupling_prop_bind {A1 A2 B1 B2} P (f1: A1 → ivdist B1) (f2: A2 → pidist B2)
      I1 Is2 Q (Ic: irrel_coupling_propP I1 Is2 P):
  (∀ x y, P x y → irrel_coupling_propP (f1 x) (f2 y) Q) →
  irrel_coupling_propP (mbind f1 I1) (mbind f2 Is2) Q.
Proof.
  intros; eapply ic_wit_to_prop, irrel_coupling_bind; intros; apply ic_prop_to_wit; eauto.
Qed.

Lemma irrel_coupling_trivial {A1 A2} (I: ivdist A1) (Is: pidist A2):
  irrel_couplingP I Is (λ x y, True).
Proof.
  assert ({ I' : ivdist A2 | In (I': ival A2) Is}) as (I'&Hin).
  { destruct Is as [(Is&Hne) Hall] => //=.
    rewrite //= in Hall.
    apply ClassicalEpsilon.constructive_indefinite_description in Hne as (I'&His).
    exists {| ivd_ival := I'; val_sum1 := Hall _ His |}.
    auto.
  }
  exists (x ← I'; I) (singleton (x ← I; I')).
  { eapply irrel_ivd_irrel. }
  { eapply irrel_pidist_proper_irrel; [| apply le_pidist_irrel_refl | reflexivity ].
    intros I0 Hin'. inversion Hin' as [Heq].
    exists I'; split; auto.
    eapply (irrel_ivd_proper _ (x ← I; I')).
    { rewrite /eq_ivd. rewrite -Heq //=. }
    { reflexivity. }
    symmetry. apply irrel_ivd_irrel.
  }
  exists (x ← I; I').
  { intros ?. eapply In_pidist_le_singleton. eexists; split; first reflexivity.
    rewrite /In/singleton//=. }
  unshelve (eexists).
  { refine (ivd_ival (x ← I; y ← I'; mret _)).
    exists (x, y); done. }
  - setoid_rewrite ival_bind_comm. setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity.
    intros.  setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
  - setoid_rewrite ival_assoc.
    eapply ival_bind_congr; first reflexivity.
    intros.  setoid_rewrite ival_bind_mret_mret. setoid_rewrite ival_right_id. reflexivity.
Qed.

Lemma irrel_coupling_prop_trivial {A1 A2} (I: ivdist A1) (Is: pidist A2):
  irrel_coupling_propP I Is (λ x y, True).
Proof.
  apply ic_wit_to_prop, irrel_coupling_trivial.
Qed.

Lemma irrel_coupling_conseq {A1 A2} (P1 P2: A1 → A2 → Prop) (I: ivdist A1) (Is: pidist A2):
  (∀ x y, P1 x y → P2 x y) →
  irrel_couplingP I Is P1 →
  irrel_couplingP I Is P2.
Proof.
  intros HP Hirrel.
  destruct Hirrel as [I0 Is0 ? ? ?].
  exists I0 Is0; auto.
  eapply ip_coupling_conseq; eauto.
Qed.

Lemma irrel_coupling_plus {A1 A2} p Hpf p' Hpf'
      (P : A1 → A2 → Prop) (Is1 Is1': ivdist A1) (Is2 Is2': pidist A2) :
  p = p' →
  irrel_couplingP Is1 Is2 P →
  irrel_couplingP Is1' Is2' P →
  irrel_couplingP (ivdplus p Hpf Is1 Is1') (pidist_plus p' Hpf' Is2 Is2') P.
Proof.
  intros Hpeq Hic Hic'. subst.
  destruct Hic as [I1i Is2i Hirrel1i Hirrel2i Hwit].
  destruct Hic' as [I1i' Is2i' Hirrel1i' Hirrel2i' Hwit'].
  exists (ivdplus p' Hpf I1i I1i') (pidist_plus p' Hpf' Is2i Is2i').
  { eapply irrel_ivd_choice; eauto. }
  { eapply irrel_pidist_choice; eauto. }
  apply ip_coupling_plus; eauto.
Qed.

Lemma irrel_coupling_bind_condition {A1 B1 B2} (f1: A1 → ivdist B1) (f2: A1 → pidist B2)
      I Is Q x:
  (le_pidist (singleton I) Is ) →
  (irrel_couplingP (f1 x) (f2 x) Q) →
  irrel_couplingP (x ← I; y ← f1 x; mret (x, y))
                  (x ← Is; y ← f2 x; mret (x, y))
                  (λ xy1 xy2, fst xy1 = x → fst xy2 = x → Q (snd xy1) (snd xy2)).
Proof.
  intros Hle Hc.
  eapply (irrel_coupling_bind (λ x y, x = y)).
  { exists I Is; try reflexivity.
    exists I; eauto. apply ival_coupling_refl.
  }
  intros ? y ?; subst.
  destruct (ClassicalEpsilon.excluded_middle_informative (x = y)).
  - intros; subst. eapply irrel_coupling_bind; eauto.
    intros. apply irrel_coupling_mret => ? //=.
  - intros. eapply irrel_coupling_bind.
    * apply irrel_coupling_trivial.
    * intros. apply irrel_coupling_mret => ? //=. intros. congruence.
Qed.

Lemma irrel_coupling_support {X Y} I1 I2 (P: X → Y → Prop):
  ∀ (Ic: irrel_couplingP I1 I2 P),
  irrel_couplingP I1 I2 (λ x y, ∃ Hpf: P x y,  In_isupport x I1 ∧ In_psupport y I2 ∧
                        In_isupport (exist _ (x, y) Hpf) Ic).
Proof.
  intros [? ? Heq1 Heq2 Ic].
  specialize (ip_coupling_support _ _ _ Ic).
  eexists; eauto.
  eapply ip_coupling_conseq; eauto.
  intros x y (Hpf&Hin1&Hin2&?); exists Hpf; repeat split; auto.
  -  edestruct Hin1 as (i&?&?).
     edestruct (irrel_ivd_support_coerce _ _ Heq1) as (Hcoerce&_).
     apply Hcoerce; eauto.
  - eapply irrel_pidist_support_coerce; eauto.
Qed.

Lemma irrel_coupling_support_wit {X Y} I1 I2 (P: X → Y → Prop):
  ∀ (Ic: irrel_couplingP I1 I2 P),
    { xy : X * Y | ∃ Hpf : P (fst xy) (snd xy),
        In_isupport (fst xy) I1 ∧ In_psupport (snd xy) I2 ∧ In_isupport (exist _ xy Hpf) Ic }.
Proof.
  intros [? ? Heq1 Heq2 Ic].
  specialize (ip_coupling_support_wit _ _ _ Ic).
  rewrite //=.
  intros ((x&y)&Hpf).
  exists (x, y).
  destruct Hpf as (Hpf&Hin1&Hin2&?).
  exists Hpf; repeat split; auto.
  -  edestruct Hin1 as (i&?&?).
     edestruct (irrel_ivd_support_coerce _ _ Heq1) as (Hcoerce&_).
     apply Hcoerce; eauto.
  - eapply irrel_pidist_support_coerce; eauto.
Qed.

Lemma rsupport_support_right {X Y} (Ix: ivdist X) (x: X) Is (P: X → Y → Prop)
      (Ic: irrel_couplingP Ix Is P)  (c: rsupport Ic x) :
  In_psupport (proj1_sig c) Is.
Proof.
  destruct c as (y'&ic&HP&Hind&Hgt).
  rewrite //=. destruct Ic as [Ix' Is' Hirrel_ivd Hirrel_pidist Ic].
  eapply irrel_pidist_support_coerce; eauto.
  destruct Ic as [Iy Hle Ic].
  rewrite //= in ic Hind Hgt.
  clear Hirrel_pidist.

  destruct (irrel_ivd_support_coerce _ _ Hirrel_ivd x) as (Hcoerce&_).
  destruct (Hle Iy) as (Iy'&Heq&Hin); first by auto.
  destruct Ic as [Ic Hproj1 Hproj2].
  rewrite //= in ic Hind Hgt.

  symmetry in Hproj2.
  setoid_rewrite Heq in Hproj2.
  destruct Hproj2 as (h1&h2&?&?&Hindic&Hvalic).

  assert (val (x0 ← Ic; mret (sval x0).2) (existT ic tt) > 0) as Hgt'.
  { rewrite //= Rmult_1_r //=. }
  specialize (Hindic (coerce_supp _ _ Hgt')).
  specialize (Hvalic (coerce_supp _ _ Hgt')).
  rewrite //= in Hindic Hvalic.

  exists Iy'.
  exists (sval (h1 (coerce_supp _ _ Hgt'))).
  repeat split; auto.
  - rewrite Hindic Hind //=.
  - rewrite Hvalic //=.
Qed.

Lemma rsupport_post {X Y} (Ix: ivdist X) (x: X) Is (P: X → Y → Prop)
      (Ic: irrel_couplingP Ix Is P)  (c: rsupport Ic x) :
  P x (proj1_sig c).
Proof.
  destruct c as (y&I&i&Hind&?).
  rewrite //=.
Qed.

Transparent pidist_ret.
Lemma rsupport_mret_right {X Y} (Ix: ivdist X) (x: X) (y: Y) (P: X → Y → Prop)
      (Ic: irrel_couplingP Ix (mret y) P)  (c: rsupport Ic x) :
  proj1_sig c = y.
Proof.
  edestruct (rsupport_support_right _ _ _ _ Ic c) as (Iy&iy&Hin&Hind&?).
  subst; rewrite -Hind //=.
  rewrite /In/mret/base.mret//= in Hin.
  subst. destruct iy => //=.
Qed.
Opaque pidist_ret.

Lemma ip_irrel_coupling {A1 A2} (I: ivdist A1) (Is: pidist A2) (P: A1 → A2 → Prop):
  idist_pidist_couplingP I Is P →
  irrel_couplingP I Is P.
Proof.
  intros.
  exists I Is; try reflexivity; eauto.
Qed.

Lemma irrel_bounded_supp_fun {A} f (Is Is': pidist A):
  irrel_pidist Is Is' →
  bounded_fun_on f (λ x, In_psupport x Is') →
  bounded_fun_on f (λ x, In_psupport x Is).
Proof.
  intros Hle Hbf.
  eapply bounded_fun_on_anti; try eassumption.
  eapply irrel_pidist_support_coerce; eauto.
Qed.

Lemma irrel_pidist_bounded_supp_Ex_max {A} f (Is Is': pidist A):
  irrel_pidist Is Is' →
  bounded_fun_on f (λ x, In_psupport x Is') →
  Rbar_le (Ex_max f Is) (Ex_max f Is').
Proof.
  intros Hi Hb1.
  feed pose proof (irrel_bounded_supp_fun f Is Is') as Hb2; eauto.
  assert (bounded_fun_on f (λ x, In_psupport x Is ∨ In_psupport x Is')) as Hb.
  { destruct Hb1 as (c1&?).
    destruct Hb2 as (c2&?).
    exists (Rmax c1 c2).
    intros x [Hin1|Hin2]; rewrite Rmax_Rle; intuition.
  }
  clear Hb1. clear Hb2.
  edestruct (bounded_fun_on_to_bounded f) as (g'&Hb'&Heq); eauto.
  feed pose proof (irrel_pidist_Ex_max Is Is' Hi g' Hb'); eauto.
  erewrite (Ex_max_eq_ext_supp f g' Is'); eauto.
  etransitivity; eauto.
  erewrite (Ex_max_eq_ext_supp f g' Is); eauto; first reflexivity.
Qed.

Lemma Ex_min_irrel_anti {A} f (Is Is': pidist A) :
  irrel_pidist Is Is' →
  bounded_fun f →
  Rbar_le (Ex_min f Is') (Ex_min f Is).
Proof. eauto. Qed.

Lemma irrel_coupling_eq_ex_Ex {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  ex_Ex_ival f I.
Proof.
  intros [Is1_irrel Is2_irrel Hirrel_ivd Hirrel_pidst Ic] Hex.
  assert (idist_pidist_couplingP (x ← Is1_irrel; mret (f x))
                                 (x ← Is2_irrel; mret (g x))
                                 (λ x y, x = y)) as Ic'.
  { eapply ip_coupling_bind; eauto => ???.
    apply ip_coupling_mret; auto. }

  destruct Ic' as [I2 Hmem Ic'].
  apply ival_coupling_eq in Ic'.
  eapply ex_Ex_ival_irrel_proper.
  { symmetry; eauto. }

  rewrite (ex_Ex_ival_fmap id f).
  setoid_rewrite Ic'.
  cut (ex_Ex_extrema id (x ← Is2_irrel; mret (g x))).
  { intros Hex'. edestruct (Hmem I2) as (I2'&Heq'&?); first done.
    rewrite Heq'. eapply Hex'; eauto. }
  rewrite -ex_Ex_extrema_fmap. eauto.
  eapply ex_Ex_extrema_bounded_fun.
  eauto.
Qed.

Lemma irrel_coupling_eq_Ex_min {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  Rbar_le (Ex_min g Is) (Ex_ival f I).
Proof.
  intros Hirrel Hb.
  feed pose proof (irrel_coupling_eq_ex_Ex f g I Is) as Hex; eauto.
  destruct Hirrel as [Is1_irrel Is2_irrel Hirrel_ivd Hirrel_pidst Ic].
  assert (idist_pidist_couplingP (x ← Is1_irrel; mret (f x))
                                 (x ← Is2_irrel; mret (g x))
                                 (λ x y, x = y)) as Ic'.
  { eapply ip_coupling_bind; eauto => ???.
    apply ip_coupling_mret; auto. }

  destruct Ic' as [I2 Hmem Ic'].
  apply ival_coupling_eq in Ic'.

  etransitivity; first apply Ex_min_irrel_anti; eauto.
  erewrite Ex_ival_irrel_proper; eauto.

  transitivity (Ex_min (λ x, Ex_min id (mret (g x))) Is2_irrel).
  { apply Ex_min_le_ext.
    * intros. rewrite Ex_min_mret. reflexivity.
    * eapply ex_Ex_extrema_bounded_fun; eauto.
  }
  assert (ex_Ex_ival f Is1_irrel).
  { eapply ex_Ex_ival_irrel_proper; eauto. }
  etransitivity; first eapply Ex_min_bind_post_aux2; last first.
  - transitivity (Ex_ival (λ x, Ex_ival id (mret (f x))) Is1_irrel); last first.
    { apply Ex_ival_mono.
      * intros. rewrite Ex_ival_mret. reflexivity.
      * setoid_rewrite Ex_ival_mret.
        eapply ex_Ex_ival_irrel_proper; eauto.
      * eapply ex_Ex_ival_irrel_proper; eauto.
    }
    rewrite -Ex_ival_bind_post; last first.
    { rewrite -ex_Ex_ival_fmap. eauto. }
    transitivity (Ex_ival id I2); last first.
    { refl_right. f_equal. symmetry. eapply Ex_ival_proper; eauto.
      rewrite -ex_Ex_ival_fmap. eauto. }

    apply In_pidist_le_singleton in Hmem.
    destruct Hmem as (I2'&Heq22'&?).
    transitivity (Ex_ival id I2'); last first.
    { refl_right. f_equal. symmetry. eapply Ex_ival_proper; eauto.
      eapply ex_Ex_ival_proper; eauto.
      rewrite -ex_Ex_ival_fmap. eauto. }
    apply Ex_min_spec1'; auto.
    eapply ex_Ex_ival_proper; eauto.
    eapply ex_Ex_ival_proper; eauto.
    rewrite -ex_Ex_ival_fmap. eauto.
  - setoid_rewrite Ex_min_mret.
    apply ex_Ex_extrema_bounded_fun; eauto.
  - intros. setoid_rewrite Ex_min_mret. rewrite //=.
  - apply Ex_min_bounded_fun_finite.
    setoid_rewrite Ex_min_mret. eauto.
Qed.

Lemma irrel_coupling_eq_Ex_min' {A1 A2 A3} f g (h : A3 → R) (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun (λ x, h (g x)) →
  Rbar_le (Ex_min (λ x, h (g x)) Is) (Ex_ival (λ x, h (f x)) I).
Proof.
  intros Hic Hb.
  eapply irrel_coupling_eq_Ex_min; eauto.
  eapply irrel_coupling_conseq; eauto.
  rewrite //=. intros x y ->. done.
Qed.

Lemma irrel_coupling_eq_Ex_max {A1 A2} f g (I: ivdist A1) (Is: pidist A2):
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun g →
  Rbar_le (Ex_ival f I) (Ex_max g Is).
Proof.
  intros HIc Hb.
  apply Rbar_opp_le.
  rewrite Ex_max_neg_min Rbar_opp_involutive.
  rewrite /Rbar_opp//=.
  rewrite -Ex_ival_negate.
  apply irrel_coupling_eq_Ex_min; eauto.
  - eapply irrel_coupling_conseq; eauto => x y ?.
    nra.
  - destruct Hb as (c&Hb). exists c; intros x. specialize (Hb x).
    move: Hb. do 2 apply Rabs_case; nra.
Qed.

Lemma irrel_coupling_eq_ex_Ex_supp {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  ex_Ex_ival f I.
Proof.
  intros Hi Hex.
  edestruct (bounded_fun_on_to_bounded g) as (g'&?Hb&Heq); eauto.
  feed pose proof (irrel_coupling_eq_ex_Ex f g' I Is); eauto.
  eapply irrel_coupling_conseq; last first.
  { unshelve (eapply @irrel_coupling_support); last eapply Hi. }
  rewrite //=. intros x y (Hpf&Hin&Hinp&?).
  rewrite -Heq; eauto.
Qed.

Lemma irrel_coupling_eq_Ex_min_supp {A1 A2} f g (I: ivdist A1) (Is: pidist A2) :
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (Ex_min g Is) (Ex_ival f I).
Proof.
  intros Hi Hex.
  edestruct (bounded_fun_on_to_bounded g) as (g'&?Hb&Heq); eauto.
  feed pose proof (irrel_coupling_eq_Ex_min f g' I Is); eauto.
  eapply irrel_coupling_conseq; last first.
  { unshelve (eapply @irrel_coupling_support); last eapply Hi. }
  rewrite //=. intros x y (Hpf&Hin&Hinp&?).
  rewrite -Heq; eauto.
  etransitivity; last eassumption.
  refl_right.
  eapply Ex_min_eq_ext_supp.
  eauto.
Qed.

Lemma irrel_coupling_eq_Ex_max_supp {A1 A2} f g (I: ivdist A1) (Is: pidist A2):
  irrel_couplingP I Is (λ x y, f x = g y) →
  bounded_fun_on g (λ x, In_psupport x Is) →
  Rbar_le (Ex_ival f I) (Ex_max g Is).
Proof.
  intros HIc Hb.
  apply Rbar_opp_le.
  rewrite Ex_max_neg_min Rbar_opp_involutive.
  rewrite /Rbar_opp//=.
  rewrite -Ex_ival_negate.
  apply irrel_coupling_eq_Ex_min_supp; eauto.
  - eapply irrel_coupling_conseq; eauto => x y ?.
    nra.
  - destruct Hb as (c&Hb). exists c; intros x Hin. specialize (Hb x Hin).
    move: Hb. do 2 apply Rabs_case; nra.
Qed.


From Hammer Require Import Hammer.

Require Import Bool.
Require Import Arith.
Require Import NArith.
Require Import Ndec.
Require Import ZArith.
From IntMap Require Import Allmaps.
From TreeAutomata Require Import bases.
From TreeAutomata Require Import defs.
From TreeAutomata Require Import semantics.
From TreeAutomata Require Import refcorrect.
From TreeAutomata Require Import lattice_fixpoint.

Inductive coacc : preDTA -> ad -> ad -> Prop :=
| coacc_id :
forall (d : preDTA) (a : ad) (s : state),
MapGet state d a = Some s -> coacc d a a
| coacc_nxt :
forall (d : preDTA) (a0 a1 a2 : ad) (s1 s2 : state)
(pl : prec_list) (c : ad),
MapGet state d a2 = Some s2 ->
MapGet state d a1 = Some s1 ->
MapGet prec_list s1 c = Some pl ->
prec_occur pl a2 -> coacc d a0 a1 -> coacc d a0 a2.

Definition coacc_transitive_def (d : preDTA) (a0 a1 : ad) : Prop :=
forall a2 : ad, coacc d a0 a1 -> coacc d a2 a0 -> coacc d a2 a1.

Lemma coacc_transitive_0 :
forall (d : preDTA) (a : ad) (s : state),
MapGet state d a = Some s -> coacc_transitive_def d a a.
Proof. hammer_hook "coacc_test" "coacc_test.coacc_transitive_0".
unfold coacc_transitive_def in |- *. intros. exact H1.
Qed.

Lemma coacc_transitive_1 :
forall (d : preDTA) (a0 a1 a2 : ad) (s1 s2 : state)
(pl : prec_list) (c : ad),
MapGet state d a2 = Some s2 ->
MapGet state d a1 = Some s1 ->
MapGet prec_list s1 c = Some pl ->
prec_occur pl a2 ->
coacc d a0 a1 ->
coacc_transitive_def d a0 a1 -> coacc_transitive_def d a0 a2.
Proof. hammer_hook "coacc_test" "coacc_test.coacc_transitive_1".
unfold coacc_transitive_def in |- *. intros. exact (coacc_nxt d a3 a1 a2 s1 s2 pl c H H0 H1 H2 (H4 _ H3 H6)).
Qed.

Lemma coacc_transitive :
forall (d : preDTA) (a0 a1 a2 : ad),
coacc d a0 a1 -> coacc d a1 a2 -> coacc d a0 a2.
Proof. hammer_hook "coacc_test" "coacc_test.coacc_transitive".
intros. exact
(coacc_ind coacc_transitive_def coacc_transitive_0 coacc_transitive_1 d a1
a2 H0 a0 H0 H).
Qed.

Fixpoint map_replace (A : Set) (m : Map A) {struct m} :
ad -> A -> Map A :=
fun (a : ad) (x : A) =>
match m with
| M0 => M0 A
| M1 b y => if N.eqb a b then M1 A b x else M1 A b y
| M2 m n =>
match a with
| N0 => M2 A (map_replace A m N0 x) n
| Npos q =>
match q with
| xH => M2 A m (map_replace A n N0 x)
| xO p => M2 A (map_replace A m (Npos p) x) n
| xI p => M2 A m (map_replace A n (Npos p) x)
end
end
end.

Fixpoint map_or (m0 m1 : Map bool) {struct m1} : Map bool :=
match m0, m1 with
| M0, _ => M0 bool
| _, M0 => M0 bool
| M1 a0 b0, M1 a1 b1 =>
if N.eqb a0 a1 then M1 bool a0 (b0 || b1) else M0 bool
| M1 _ _, M2 _ _ => M0 bool
| M2 _ _, M1 _ _ => M0 bool
| M2 x0 y0, M2 x1 y1 => M2 bool (map_or x0 x1) (map_or y0 y1)
end.

Fixpoint pl_coacc (d : preDTA) (pl : prec_list) {struct pl} :
Map bool :=
match pl with
| prec_empty => map_mini state d
| prec_cons a la ls =>
map_replace bool (map_or (pl_coacc d la) (pl_coacc d ls)) a true
end.

Fixpoint st_coacc (d : preDTA) (s : state) {struct s} :
Map bool :=
match s with
| M0 => map_mini state d
| M1 a pl => pl_coacc d pl
| M2 x y => map_or (st_coacc d x) (st_coacc d y)
end.

Fixpoint predta_coacc_0 (d d' : preDTA) {struct d'} :
Map bool -> Map bool :=
fun m : Map bool =>
match d', m with
| M0, M0 => map_mini state d
| M1 a s, M1 a' b =>
if N.eqb a a' && b then st_coacc d s else map_mini state d
| M2 x y, M2 z t => map_or (predta_coacc_0 d x z) (predta_coacc_0 d y t)
| _, _ => map_mini state d
end.

Definition predta_coacc (d : preDTA) (a : ad) (m : Map bool) :
Map bool := map_replace bool (predta_coacc_0 d d m) a true.

Definition predta_coacc_states (d : preDTA) (a : ad) :
Map bool :=
power (Map bool) (predta_coacc d a) (map_mini state d)
(S (MapCard state d)).

Definition predta_coacc_states_0 (d : preDTA) (a : ad) :
Map bool :=
lazy_power bool eqm_bool (predta_coacc d a) (map_mini state d)
(S (MapCard state d)).

Lemma map_or_mapget_true_l :
forall (m0 m1 : Map bool) (a : ad),
domain_equal bool bool m0 m1 ->
MapGet bool m0 a = Some true ->
MapGet bool (map_or m0 m1) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_or_mapget_true_l".
simple induction m0. intros. inversion H0. simple induction m1.
intros. inversion H. intros. simpl in H. simpl in H0.
elim (bool_is_true_or_false (N.eqb a a3)); intros; rewrite H1 in H0. inversion H0. rewrite <- (Neqb_complete _ _ H1). rewrite <- H. simpl in |- *. rewrite (Neqb_correct a).
simpl in |- *. rewrite (Neqb_correct a). reflexivity. inversion H0.
intros. inversion H1. simple induction m2. intros. inversion H1.
intros. inversion H1. intros. simpl in |- *. elim H3; intros.
induction  a as [| p]. exact (H _ _ H5 H4). induction  p as [p Hrecp| p Hrecp| ]. exact (H0 _ _ H6 H4). exact (H _ _ H5 H4). exact (H0 _ _ H6 H4).
Qed.

Lemma map_or_mapget_true_ld :
forall (d : preDTA) (m0 m1 : Map bool) (a : ad),
ensemble_base state d m0 ->
ensemble_base state d m1 ->
MapGet bool m0 a = Some true ->
MapGet bool (map_or m0 m1) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_or_mapget_true_ld".
intros. exact
(map_or_mapget_true_l m0 m1 a
(domain_equal_transitive bool state bool m0 d m1
(domain_equal_symmetric state bool d m0 H) H0) H1).
Qed.

Lemma map_or_mapget_true_r :
forall (m0 m1 : Map bool) (a : ad),
domain_equal bool bool m0 m1 ->
MapGet bool m0 a = Some true ->
MapGet bool (map_or m1 m0) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_or_mapget_true_r".
simple induction m0. intros. inversion H0. simple induction m1; intros.
inversion H. simpl in H. simpl in H0. rewrite <- H.
elim (bool_is_true_or_false (N.eqb a a3)); intros; rewrite H1 in H0;
inversion H0. rewrite <- (Neqb_complete _ _ H1). simpl in |- *. rewrite (Neqb_correct a). simpl in |- *.
rewrite (Neqb_correct a). elim (bool_is_true_or_false a2); intros; rewrite H2; reflexivity. inversion H1. intros.
induction  m2 as [| a0 a1| m2_1 Hrecm2_1 m2_0 Hrecm2_0]. inversion H1. inversion H1. simpl in |- *.
elim H1; intros. induction  a as [| p]. exact (H _ _ H3 H2).
induction  p as [p Hrecp| p Hrecp| ]. exact (H0 _ _ H4 H2). exact (H _ _ H3 H2).
exact (H0 _ _ H4 H2).
Qed.

Lemma map_or_mapget_true_rd :
forall (d : preDTA) (m0 m1 : Map bool) (a : ad),
ensemble_base state d m0 ->
ensemble_base state d m1 ->
MapGet bool m1 a = Some true ->
MapGet bool (map_or m0 m1) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_or_mapget_true_rd".
intros. exact
(map_or_mapget_true_r m1 m0 a
(domain_equal_transitive bool state bool m1 d m0
(domain_equal_symmetric state bool d m1 H0) H) H1).
Qed.

Lemma map_or_mapget_true_inv :
forall (m0 m1 : Map bool) (a : ad),
MapGet bool (map_or m0 m1) a = Some true ->
MapGet bool m0 a = Some true \/ MapGet bool m1 a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_or_mapget_true_inv".
simple induction m0; intros. induction  m1 as [| a0 a1| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in H. inversion H.
simpl in H. inversion H. simpl in H. inversion H. induction  m1 as [| a2 a3| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in H. inversion H. simpl in H. elim (bool_is_true_or_false (N.eqb a a2)); intros; rewrite H0 in H.
simpl in H. elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H1 in H;
inversion H. rewrite H3. elim (bool_is_true_or_false a0); intros; rewrite H2 in H3; rewrite H2. left. rewrite <- (Neqb_complete _ _ H1). simpl in |- *.
rewrite (Neqb_correct a). reflexivity. elim (bool_is_true_or_false a3); intros; rewrite H4 in H3; rewrite H4.
right. rewrite <- (Neqb_complete _ _ H0). rewrite <- (Neqb_complete _ _ H1). simpl in |- *. rewrite (Neqb_correct a).
reflexivity. inversion H3. inversion H. inversion H.
induction  m2 as [| a0 a1| m2_1 Hrecm2_1 m2_0 Hrecm2_0]. inversion H1. inversion H1. simpl in H1.
induction  a as [| p]. elim (H _ _ H1). intros. left. simpl in |- *. assumption.
intros. right. simpl in |- *. assumption. induction  p as [p Hrecp| p Hrecp| ]. elim (H0 _ _ H1); intros; simpl in |- *. left. assumption. right. assumption.
elim (H _ _ H1); intros; simpl in |- *. left. assumption. right.
assumption. elim (H0 _ _ H1); intros; simpl in |- *. left. assumption.
right. assumption.
Qed.

Lemma map_replace_mapget_ins_true_0 :
forall (m : Map bool) (a : ad) (b : bool),
MapGet bool m a = Some b ->
MapGet bool (map_replace bool m a true) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_mapget_ins_true_0".
simple induction m. intros. inversion H. intros. simpl in H.
elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H0 in H;
inversion H. simpl in |- *. rewrite <- (Neqb_complete _ _ H0). rewrite (Neqb_correct a).
simpl in |- *. rewrite (Neqb_correct a). reflexivity. intros.
induction  a as [| p]; simpl in H1. simpl in |- *. exact (H _ _ H1).
induction  p as [p Hrecp| p Hrecp| ]; simpl in |- *. exact (H0 _ _ H1). exact (H _ _ H1). exact (H0 _ _ H1).
Qed.

Lemma map_replace_mapget_ins_true_1 :
forall (m : Map bool) (a a' : ad),
MapGet bool m a = Some true ->
MapGet bool (map_replace bool m a' true) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_mapget_ins_true_1".
simple induction m. intros. inversion H. intros. simpl in H.
elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H0 in H. inversion H. simpl in |- *. elim (bool_is_true_or_false (N.eqb a' a)); intros; rewrite H1.
simpl in |- *. rewrite H0. reflexivity. simpl in |- *. rewrite H0.
reflexivity. inversion H. intros. induction  a as [| p]; simpl in H1; simpl in |- *. induction  a' as [| p]. simpl in |- *. exact (H _ _ H1).
induction  p as [p Hrecp| p Hrecp| ]. simpl in |- *. exact H1. exact (H _ _ H1). exact H1.
induction  p as [p Hrecp| p Hrecp| ]. induction  a' as [| p0]; simpl in |- *. exact H1. induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]; simpl in |- *. exact (H0 _ _ H1). exact H1. exact (H0 _ _ H1).
induction  a' as [| p0]; simpl in |- *. exact (H _ _ H1). induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]; simpl in |- *. exact H1. exact (H _ _ H1). exact H1. induction  a' as [| p]; simpl in |- *. exact H1. induction  p as [p Hrecp| p Hrecp| ]; simpl in |- *. exact (H0 _ _ H1). exact H1. exact (H0 _ _ H1).
Qed.

Lemma map_replace_mapget_true_inv :
forall (m : Map bool) (a b : ad),
MapGet bool (map_replace bool m a true) b = Some true ->
b = a \/ MapGet bool m b = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_mapget_true_inv".
simple induction m. intros. inversion H. simpl in |- *. intros. elim (bool_is_true_or_false (N.eqb a1 a)); intros; rewrite H0 in H. simpl in H. elim (bool_is_true_or_false (N.eqb a b)); intros; rewrite H1 in H. rewrite H1. left.
rewrite (Neqb_complete _ _ H0). rewrite <- (Neqb_complete _ _ H1). reflexivity. inversion H. simpl in H. elim (bool_is_true_or_false (N.eqb a b)); intros; rewrite H1 in H;
inversion H. rewrite H1. right. reflexivity. intros.
simpl in H1. induction  a as [| p]; simpl in H1. induction  b as [| p]; simpl in |- *; simpl in H1. exact (H _ _ H1). induction  p as [p Hrecp| p Hrecp| ]. right. exact H1.
elim (H _ _ H1). intros. inversion H2. intros. right.
exact H2. right. exact H1. induction  p as [p Hrecp| p Hrecp| ]. induction  b as [| p0].
simpl in |- *. simpl in H1. right. exact H1. simpl in H1.
induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]. elim (H0 _ _ H1). intros. inversion H2.
left. reflexivity. intros. simpl in |- *. right. exact H2. simpl in |- *.
right. exact H1. elim (H0 _ _ H1). intros. inversion H2.
intros. simpl in |- *. right. exact H2. induction  b as [| p0]; simpl in |- *; simpl in H1. elim (H _ _ H1). intros. inversion H2.
right. exact H2. induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]. right. exact H1. elim (H _ _ H1). intros. inversion H2. left. reflexivity.
intros. right. exact H2. right. exact H1. induction  b as [| p].
simpl in H1. simpl in |- *. right. exact H1. induction  p as [p Hrecp| p Hrecp| ]; simpl in |- *; simpl in H1. elim (H0 _ _ H1). intros. inversion H2.
intros. right. exact H2. right. exact H1. left. reflexivity.
Qed.

Lemma map_or_def_ok :
forall m0 m1 : Map bool,
domain_equal bool bool m0 m1 -> domain_equal bool bool m0 (map_or m0 m1).
Proof. hammer_hook "coacc_test" "coacc_test.map_or_def_ok".
simple induction m0. simple induction m1. intros. exact I. intros. inversion H.
intros. inversion H1. simple induction m1. intros. inversion H. intros.
simpl in H. simpl in |- *. rewrite H. rewrite (Neqb_correct a1). simpl in |- *.
reflexivity. intros. inversion H1. simple induction m2. intros. inversion H1.
intros. inversion H1. intros. elim H3. intros. simpl in |- *. split.
exact (H _ H4). exact (H0 _ H5).
Qed.

Lemma map_or_def_ok_d :
forall (d : preDTA) (m0 m1 : Map bool),
ensemble_base state d m0 ->
ensemble_base state d m1 -> ensemble_base state d (map_or m0 m1).
Proof. hammer_hook "coacc_test" "coacc_test.map_or_def_ok_d".
unfold ensemble_base in |- *. intros. apply (domain_equal_transitive state bool bool d m0 (map_or m0 m1)). exact H. apply (map_or_def_ok m0 m1). apply (domain_equal_transitive bool state bool m0 d m1).
exact (domain_equal_symmetric state bool d m0 H). exact H0.
Qed.

Lemma map_replace_def_ok :
forall (A : Set) (m : Map A) (a : ad) (x : A),
domain_equal A A m (map_replace A m a x).
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_def_ok".
intro. simple induction m. intros. exact I. intros. simpl in |- *. elim (bool_is_true_or_false (N.eqb a1 a)); intros; rewrite H.
simpl in |- *. reflexivity. simpl in |- *. reflexivity. intros. simpl in |- *.
induction  a as [| p]. simpl in |- *. split. exact (H N0 x). exact (domain_equal_reflexive A m1). induction  p as [p Hrecp| p Hrecp| ]. split. exact (domain_equal_reflexive A m0). exact (H0 (Npos p) x). split.
exact (H (Npos p) x). exact (domain_equal_reflexive A m1).
split. exact (domain_equal_reflexive A m0). exact (H0 N0 x).
Qed.

Lemma map_replace_def_ok_d :
forall (d : preDTA) (m : Map bool) (a : ad) (x : bool),
ensemble_base state d m -> ensemble_base state d (map_replace bool m a x).
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_def_ok_d".
unfold ensemble_base in |- *. intros. apply
(domain_equal_transitive state bool bool d m (map_replace bool m a x) H).
exact (map_replace_def_ok bool m a x).
Qed.

Lemma pl_coacc_def_ok :
forall (d : preDTA) (pl : prec_list), ensemble_base state d (pl_coacc d pl).
Proof. hammer_hook "coacc_test" "coacc_test.pl_coacc_def_ok".
simple induction pl. simpl in |- *. intros. exact
(map_replace_def_ok_d d (map_or (pl_coacc d p) (pl_coacc d p0)) a true
(map_or_def_ok_d _ _ _ H H0)).
simpl in |- *. exact (map_mini_appartient state d).
Qed.

Lemma st_coacc_def_ok :
forall (d : preDTA) (s : state), ensemble_base state d (st_coacc d s).
Proof. hammer_hook "coacc_test" "coacc_test.st_coacc_def_ok".
simple induction s. simpl in |- *. exact (map_mini_appartient state d). simpl in |- *.
intros. exact (pl_coacc_def_ok d a0). intros. simpl in |- *. exact (map_or_def_ok_d _ _ _ H H0).
Qed.

Lemma predta_coacc_0_def_ok :
forall (d d' : preDTA) (m : Map bool),
ensemble_base state d (predta_coacc_0 d d' m).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_0_def_ok".
simple induction d'. simpl in |- *. intros. induction  m as [| a a0| m1 Hrecm1 m0 Hrecm0];
exact (map_mini_appartient state d). simpl in |- *. intros. induction  m as [| a1 a2| m1 Hrecm1 m0 Hrecm0].
exact (map_mini_appartient state d). elim (bool_is_true_or_false (N.eqb a a1 && a2)); intros; rewrite H. exact (st_coacc_def_ok d a0). exact (map_mini_appartient state d). exact (map_mini_appartient state d). intros. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in |- *.
exact (map_mini_appartient state d). simpl in |- *. exact (map_mini_appartient state d). simpl in |- *. exact (map_or_def_ok_d _ _ _ (H m1_1) (H0 m1_0)).
Qed.

Lemma predta_coacc_def_ok :
forall (d : preDTA) (a : ad) (m : Map bool),
ensemble_base state d (predta_coacc d a m).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_def_ok".
unfold predta_coacc in |- *. intros. exact (map_replace_def_ok_d d _ a true (predta_coacc_0_def_ok d d m)).
Qed.

Definition lemd (d : preDTA) : mRelation bool :=
fun m0 m1 : Map bool =>
ensemble_base state d m0 /\ ensemble_base state d m1 /\ lem m0 m1.

Lemma lemd_reflexive :
forall (d : preDTA) (m : Map bool), ensemble_base state d m -> lemd d m m.
Proof. hammer_hook "coacc_test" "coacc_test.lemd_reflexive".
unfold ensemble_base in |- *. simple induction d. intros. unfold lemd in |- *.
unfold ensemble_base in |- *. induction  m as [| a a0| m1 Hrecm1 m0 Hrecm0]. split. exact I.
split; exact I. inversion H. inversion H. intros.
unfold lemd in |- *. unfold ensemble_base in |- *. induction  m as [| a1 a2| m1 Hrecm1 m0 Hrecm0]. inversion H.
simpl in H. rewrite H. simpl in |- *. split. reflexivity. split.
reflexivity. rewrite (Neqb_correct a1). exact (leb_reflexive a2). inversion H. unfold lemd in |- *. unfold ensemble_base in |- *.
simple induction m1. intros. inversion H1. intros. inversion H1.
intros. elim H3. intros. elim (H _ H4). elim (H0 _ H5).
intros. split; split. exact H4. exact H5. split. exact H4.
exact H5. split. elim H9. intros. exact H11. elim H7.
intros. exact H11.
Qed.

Lemma lemd_antisymmetric :
forall (d : preDTA) (m0 m1 : Map bool),
lemd d m0 m1 -> lemd d m1 m0 -> m0 = m1.
Proof. hammer_hook "coacc_test" "coacc_test.lemd_antisymmetric".
unfold lemd in |- *. unfold ensemble_base in |- *. simple induction d. simple induction m0.
intros. elim H. intros. elim H0. intros. elim H4. intros.
induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. reflexivity. inversion H6. inversion H6.
intros. elim H0. intros. elim H2. intros. decompose [and] H.
induction  m1 as [| a1 a2| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H8. inversion H5. inversion H8.
intros. decompose [and] H1.  inversion H3. intros.
decompose [and] H. decompose [and] H0. induction  m0 as [| a1 a2| m0_1 Hrecm0_1 m0_0 Hrecm0_0].
inversion H1. induction  m1 as [| a3 a4| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H3. simpl in H1.
simpl in H2. rewrite <- H1. rewrite <- H2. simpl in H4.
simpl in H7. rewrite <- H2 in H4. rewrite <- H1 in H4.
rewrite (Neqb_correct a) in H4. rewrite <- H1 in H7.
rewrite <- H2 in H7. rewrite (Neqb_correct a) in H7.
rewrite (leb_antisymmetric _ _ H4 H7). reflexivity.
inversion H2. inversion H1. intros. decompose [and] H1.
decompose [and] H2. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H3. inversion H3.
induction  m2 as [| a a0| m2_1 Hrecm2_1 m2_0 Hrecm2_0]. inversion H4. inversion H9. elim H4. elim H3.
elim H6. intros. rewrite (H m1_1 m2_1). rewrite (H0 m1_0 m2_0). reflexivity. split. exact H12. split. exact H14.
exact H10. split. exact H14. split. exact H12. elim H9.
intros. exact H16. elim H9. intros. split. exact H11.
split. exact H13. exact H7. elim H9. intros. split.
exact H13. split. exact H11. exact H15.
Qed.

Lemma lemd_transitive :
forall (d : preDTA) (m0 m1 m2 : Map bool),
lemd d m0 m1 -> lemd d m1 m2 -> lemd d m0 m2.
Proof. hammer_hook "coacc_test" "coacc_test.lemd_transitive".
simple induction d. unfold lemd in |- *. unfold ensemble_base in |- *. intros.
decompose [and] H. decompose [and] H0. induction  m0 as [| a a0| m0_1 Hrecm0_1 m0_0 Hrecm0_0].
induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. induction  m2 as [| a a0| m2_1 Hrecm2_1 m2_0 Hrecm2_0]. split. exact I. split; exact I.
inversion H6. inversion H7. inversion H2. inversion H2.
inversion H1. inversion H1. unfold lemd in |- *. unfold ensemble_base in |- *.
intros. decompose [and] H. decompose [and] H0. induction  m0 as [| a1 a2| m0_1 Hrecm0_1 m0_0 Hrecm0_0].
inversion H1. induction  m1 as [| a3 a4| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H2. induction  m2 as [| a5 a6| m2_1 Hrecm2_1 m2_0 Hrecm2_0].
inversion H6. simpl in H2. simpl in H1. simpl in H6.
simpl in H4. rewrite <- H2 in H4. rewrite <- H1 in H4.
rewrite (Neqb_correct a) in H4. simpl in H7. rewrite <- H3 in H7. rewrite <- H6 in H7. rewrite (Neqb_correct a) in H7.
rewrite <- H1. rewrite <- H6. split. simpl in |- *. reflexivity.
simpl in |- *. split. reflexivity. rewrite (Neqb_correct a).
exact (leb_transitive _ _ _ H4 H7). inversion H6.
inversion H3. inversion H1. unfold lemd in |- *. unfold ensemble_base in |- *.
intros. decompose [and] H1. decompose [and] H2. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0].
inversion H3. inversion H3. clear Hrecm1_1 Hrecm1_0.
induction  m2 as [| a a0| m2_1 Hrecm2_1 m2_0 Hrecm2_0]. inversion H5. inversion H5. clear Hrecm2_1.
clear Hrecm2_0. intros. induction  m3 as [| a a0| m3_1 Hrecm3_1 m3_0 Hrecm3_0]. inversion H8.
inversion H8. clear Hrecm3_1. clear Hrecm3_0. simpl in |- *.
elim H3. elim H8. elim H6. elim H5. elim H9. intros.
split. split. exact H17. exact H18. split. split. exact H15.
exact H16. split. exact (lem_transitive _ _ _ H13 H7).
exact (lem_transitive _ _ _ H14 H10).
Qed.

Lemma map_or_inc_ld :
forall (d : preDTA) (m m0 m1 : Map bool),
ensemble_base state d m ->
lemd d m0 m1 -> lemd d (map_or m0 m) (map_or m1 m).
Proof. hammer_hook "coacc_test" "coacc_test.map_or_inc_ld".
unfold lemd in |- *. unfold ensemble_base in |- *. simple induction d. intros.
decompose [and] H0. induction  m as [| a a0| m2 Hrecm1 m3 Hrecm0]. induction  m0 as [| a a0| m0_1 Hrecm0_1 m0_0 Hrecm0_0]. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in |- *. split. exact I. split; exact I. inversion H3.
inversion H3. inversion H1. inversion H1. inversion H.
inversion H. intros. decompose [and] H0. induction  m as [| a1 a2| m2 Hrecm1 m3 Hrecm0].
inversion H. induction  m0 as [| a3 a4| m0_1 Hrecm0_1 m0_0 Hrecm0_0]. inversion H1. induction  m1 as [| a5 a6| m1_1 Hrecm1_1 m1_0 Hrecm1_0].
inversion H3. simpl in |- *. simpl in H1. simpl in H3. simpl in H4. simpl in H. rewrite <- H. rewrite <- H3. rewrite <- H1. rewrite (Neqb_correct a). simpl in |- *. rewrite (Neqb_correct a). split. reflexivity. split. reflexivity. rewrite <- H3 in H4. rewrite <- H1 in H4. rewrite (Neqb_correct a) in H4. exact (orb_inc_l a2 _ _ H4). inversion H4.
inversion H1. inversion H. intros. decompose [and] H2.
induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H1. inversion H1. induction  m2 as [| a a0| m2_1 Hrecm2_1 m2_0 Hrecm2_0].
inversion H3. inversion H3. induction  m3 as [| a a0| m3_1 Hrecm3_1 m3_0 Hrecm3_0]. inversion H5.
inversion H5. clear Hrecm3_1 Hrecm3_0 Hrecm2_1 Hrecm2_0 Hrecm1_1 Hrecm1_0. simpl in |- *. elim H5. elim H3. elim H6.
intros. elim H1. intros. elim (H m1_1 m2_1 m3_1).
elim (H0 m1_0 m2_0 m3_0). intros. split. split; assumption.
split. split. elim H17; intros. assumption. elim H15; intros; assumption. elim H15. intros. elim H17. intros.
split; assumption. assumption. split. assumption. split; assumption. assumption. split. assumption. split; assumption.
Qed.

Lemma map_or_inc_rd :
forall (d : preDTA) (m m0 m1 : Map bool),
ensemble_base state d m ->
lemd d m0 m1 -> lemd d (map_or m m0) (map_or m m1).
Proof. hammer_hook "coacc_test" "coacc_test.map_or_inc_rd".
unfold lemd in |- *. unfold ensemble_base in |- *. simple induction d. intros.
decompose [and] H0. induction  m as [| a a0| m2 Hrecm1 m3 Hrecm0]. induction  m0 as [| a a0| m0_1 Hrecm0_1 m0_0 Hrecm0_0]. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in |- *. split. exact I. split; exact I. inversion H3.
inversion H3. inversion H1. inversion H1. inversion H.
inversion H. intros. decompose [and] H0. induction  m as [| a1 a2| m2 Hrecm1 m3 Hrecm0].
inversion H. induction  m0 as [| a3 a4| m0_1 Hrecm0_1 m0_0 Hrecm0_0]. inversion H1. induction  m1 as [| a5 a6| m1_1 Hrecm1_1 m1_0 Hrecm1_0].
inversion H3. simpl in |- *. simpl in H1. simpl in H3. simpl in H4. simpl in H. rewrite <- H. rewrite <- H3. rewrite <- H1. rewrite (Neqb_correct a). simpl in |- *. rewrite (Neqb_correct a). split. reflexivity. split. reflexivity. rewrite <- H3 in H4. rewrite <- H1 in H4. rewrite (Neqb_correct a) in H4. exact (orb_inc_r a2 _ _ H4). inversion H4.
inversion H1. inversion H. intros. decompose [and] H2.
induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H1. inversion H1. induction  m2 as [| a a0| m2_1 Hrecm2_1 m2_0 Hrecm2_0].
inversion H3. inversion H3. induction  m3 as [| a a0| m3_1 Hrecm3_1 m3_0 Hrecm3_0]. inversion H5.
inversion H5. clear Hrecm3_1 Hrecm3_0 Hrecm2_1 Hrecm2_0 Hrecm1_1 Hrecm1_0. simpl in |- *. elim H5. elim H3. elim H6.
intros. elim H1. intros. elim (H m1_1 m2_1 m3_1).
elim (H0 m1_0 m2_0 m3_0). intros. split. split; assumption.
split. split. elim H17; intros. assumption. elim H15; intros; assumption. elim H15. intros. elim H17. intros.
split; assumption. assumption. split. assumption. split; assumption. assumption. split. assumption. split; assumption.
Qed.

Lemma map_or_inc_d :
forall (d : preDTA) (m0 m1 m2 m3 : Map bool),
lemd d m0 m1 -> lemd d m2 m3 -> lemd d (map_or m0 m2) (map_or m1 m3).
Proof. hammer_hook "coacc_test" "coacc_test.map_or_inc_d".
intros. apply (lemd_transitive d (map_or m0 m2) (map_or m1 m2) (map_or m1 m3)). apply (map_or_inc_ld d m2 m0 m1).
unfold lemd in H0. decompose [and] H0. exact H1. exact H.
apply (map_or_inc_rd d m1 m2 m3). unfold lemd in H.
decompose [and] H. exact H3. exact H0.
Qed.

Lemma predta_coacc_0_incr :
forall (d d' : preDTA) (m0 m1 : Map bool),
lemd d' m0 m1 -> lemd d (predta_coacc_0 d d' m0) (predta_coacc_0 d d' m1).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_0_incr".
unfold lemd in |- *. unfold ensemble_base in |- *. simple induction d'. intros.
decompose [and] H. induction  m0 as [| a a0| m0_1 Hrecm0_1 m0_0 Hrecm0_0]. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in |- *.
split. exact (map_mini_appartient state d). split.
exact (map_mini_appartient state d). exact (lem_reflexive (map_mini state d)). inversion H2. inversion H2. induction  m1 as [| a1 a2| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H0. simpl in H3. simpl in |- *. apply (lemd_reflexive d (map_mini state d)). exact (map_mini_appartient state d).
inversion H2. simpl in |- *. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0];
exact (lemd_reflexive d (map_mini state d) (map_mini_appartient state d)). intros.
decompose [and] H. induction  m0 as [| a1 a2| m0_1 Hrecm0_1 m0_0 Hrecm0_0]. induction  m1 as [| a1 a2| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. simpl in |- *.
exact (lemd_reflexive d (map_mini state d) (map_mini_appartient state d)). inversion H0. inversion H0. induction  m1 as [| a3 a4| m1_1 Hrecm1_1 m1_0 Hrecm1_0].
inversion H2. simpl in |- *. simpl in H0. simpl in H2.
simpl in H3.
rewrite <- H0; rewrite <- H2; rewrite <- H0 in H3;
rewrite <- H2 in H3.  rewrite (Neqb_correct a); simpl in |- *.
rewrite (Neqb_correct a) in H3. elim (bool_is_true_or_false a2); intros; rewrite H1;
elim (bool_is_true_or_false a4); intros; rewrite H4.
exact (lemd_reflexive d (st_coacc d a0) (st_coacc_def_ok d a0)). rewrite H4 in H3. rewrite H1 in H3.
inversion H3.
split. exact (map_mini_appartient state d). split. exact (st_coacc_def_ok d a0). elim (map_mini_mini state d). intros. exact (H6 (st_coacc d a0) (st_coacc_def_ok d a0)). exact (lemd_reflexive d (map_mini state d) (map_mini_appartient state d)).
inversion H3. inversion H0. intros. decompose [and] H1.
induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H2. inversion H2. induction  m2 as [| a a0| m2_1 Hrecm2_1 m2_0 Hrecm2_0].
inversion H4. inversion H4. clear Hrecm2_0 Hrecm2_1 Hrecm1_0 Hrecm1_1. elim H5. intros. elim H4. elim H2. intros. simpl in |- *.
elim (H m1_1 m2_1). intros. elim H12. intros. elim (H0 m1_0 m2_0). intros. elim H16. intros. split. exact (map_or_def_ok_d d _ _ H11 H15). split. exact (map_or_def_ok_d _ _ _ H13 H17). elim
(map_or_inc_d d (predta_coacc_0 d m m1_1) (predta_coacc_0 d m m2_1)
(predta_coacc_0 d m0 m1_0) (predta_coacc_0 d m0 m2_0)).
intros. elim H20. intros. exact H22. unfold lemd in |- *.
split. assumption. split; assumption. unfold lemd in |- *.
split. assumption. split; assumption.  split.
assumption. split; assumption. split. assumption.
split; assumption.
Qed.

Lemma map_replace_inc :
forall (m0 m1 : Map bool) (a : ad) (b : bool),
lem m0 m1 -> lem (map_replace bool m0 a b) (map_replace bool m1 a b).
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_inc".
simple induction m0. simple induction m1. intros. exact (lem_reflexive (map_replace bool (M0 bool) a b)). intros. inversion H.
intros. inversion H1. simple induction m1. intros. inversion H.
simpl in |- *. intros. elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H0 in H. elim (bool_is_true_or_false (N.eqb a3 a)); intros; rewrite H1. rewrite (Neqb_complete _ _ H1). rewrite H0. rewrite (Neqb_complete _ _ H0).
exact (lem_reflexive (M1 bool a1 b)). elim (bool_is_true_or_false (N.eqb a3 a1)); intros; rewrite H2.
rewrite <- (Neqb_complete _ _ H0) in H2. rewrite H2 in H1.
inversion H1. rewrite <- (Neqb_complete _ _ H0). simpl in |- *.
rewrite (Neqb_correct a). exact H. elim H. intros.
inversion H1. simple induction m2. intros. inversion H1.
intros. inversion H1. intros. simpl in |- *. elim H3; intros.
induction  a as [| p]. simpl in |- *. split. exact (H m3 N0 b H4).
exact H5. induction  p as [p Hrecp| p Hrecp| ]; simpl in |- *; split. exact H4. exact (H0 m4 (Npos p) b H5). exact (H m3 (Npos p) b H4). exact H5.
exact H4. exact (H0 m4 N0 b H5).
Qed.

Lemma map_replace_inc_d :
forall (d : preDTA) (m0 m1 : Map bool) (a : ad) (b : bool),
lemd d m0 m1 -> lemd d (map_replace bool m0 a b) (map_replace bool m1 a b).
Proof. hammer_hook "coacc_test" "coacc_test.map_replace_inc_d".
unfold lemd in |- *. intros. decompose [and] H. split.
exact (map_replace_def_ok_d d m0 a b H0). split.
exact (map_replace_def_ok_d d m1 a b H2). exact (map_replace_inc m0 m1 a b H3).
Qed.

Lemma predta_coacc_increasing :
forall (d : preDTA) (a : ad),
increasing_app bool (lemd d) (predta_coacc d a).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_increasing".
unfold increasing_app in |- *. unfold predta_coacc in |- *. intros.
exact
(map_replace_inc_d d (predta_coacc_0 d d x) (predta_coacc_0 d d y) a true
(predta_coacc_0_incr d d x y H)).
Qed.

Definition lattice_lemd_bounded_0_def (p : prechain bool) : Prop :=
forall d : preDTA,
chain bool (ensemble_base state d) (lemd d) p ->
chain bool (ensemble_base state d) lem p.

Lemma lattice_lemd_bounded_0 :
forall m : Map bool, lattice_lemd_bounded_0_def (single bool m).
Proof. hammer_hook "coacc_test" "coacc_test.lattice_lemd_bounded_0".
unfold lattice_lemd_bounded_0_def in |- *. intros. inversion H.
exact (chain_single bool m (ensemble_base state d) lem H3).
Qed.

Definition lattice_lemd_bounded_1_def (p : prechain bool) : Prop :=
lattice_lemd_bounded_0_def p ->
forall m : Map bool, lattice_lemd_bounded_0_def (concat bool p m).

Lemma lattice_lemd_bounded_1 :
forall m : Map bool, lattice_lemd_bounded_1_def (single bool m).
Proof. hammer_hook "coacc_test" "coacc_test.lattice_lemd_bounded_1".
unfold lattice_lemd_bounded_1_def in |- *. unfold lattice_lemd_bounded_0_def in |- *. intros. inversion H0.
inversion H7. inversion H9. exact (chain_concat_s bool m m0 (ensemble_base state d) lem H8 H10 H11).
Qed.

Lemma lattice_lemd_bounded_2 :
forall p : prechain bool,
lattice_lemd_bounded_1_def p ->
forall m : Map bool, lattice_lemd_bounded_1_def (concat bool p m).
Proof. hammer_hook "coacc_test" "coacc_test.lattice_lemd_bounded_2".
unfold lattice_lemd_bounded_1_def in |- *. unfold lattice_lemd_bounded_0_def in |- *.
intros. inversion H1. inversion H8. inversion H11. exact
(chain_concat_m bool m m0 p (ensemble_base state d) lem H12 H13 (H0 _ H9)).
Qed.

Lemma lattice_lemd_bounded_3 :
forall (p : prechain bool) (d : preDTA),
chain bool (ensemble_base state d) (lemd d) p ->
chain bool (ensemble_base state d) lem p.
Proof. hammer_hook "coacc_test" "coacc_test.lattice_lemd_bounded_3".
exact
(prechain_ind bool lattice_lemd_bounded_0_def lattice_lemd_bounded_0
(prechain_ind bool lattice_lemd_bounded_1_def lattice_lemd_bounded_1
lattice_lemd_bounded_2)).
Qed.

Lemma lattice_lemd_bounded :
forall (p : prechain bool) (d : preDTA),
sas_chain bool (ensemble_base state d) (lemd d) p ->
sas_chain bool (ensemble_base state d) lem p.
Proof. hammer_hook "coacc_test" "coacc_test.lattice_lemd_bounded".
intros. inversion H. split. exact (lattice_lemd_bounded_3 p d H0). exact H1.
Qed.

Lemma lattice_bounded :
forall d : preDTA,
bounded_sas_chain bool (ensemble_base state d) (lemd d)
(S (MapCard state d)).
Proof. hammer_hook "coacc_test" "coacc_test.lattice_bounded".
unfold bounded_sas_chain in |- *. intros. exact (lattice_bounded state d p (lattice_lemd_bounded p d H)).
Qed.

Lemma pl_coacc_contain_coacc_ads :
forall (d : preDTA) (p : prec_list) (a : ad),
prec_occur p a ->
prec_list_ref_ok p d -> MapGet bool (pl_coacc d p) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.pl_coacc_contain_coacc_ads".
simple induction p. intros. inversion H1. simpl in |- *. elim (H2 _ H1).
intros. elim
(domain_equal_mapget state bool d (map_or (pl_coacc d p0) (pl_coacc d p1))
a0 x
(map_or_def_ok_d _ _ _ (pl_coacc_def_ok d p0) (pl_coacc_def_ok d p1)) H7).
intros. exact (map_replace_mapget_ins_true_0 _ _ _ H8).
simpl in |- *. apply
(map_replace_mapget_ins_true_1 (map_or (pl_coacc d p0) (pl_coacc d p1)) a0
a). apply
(map_or_mapget_true_ld _ _ _ a0 (pl_coacc_def_ok d p0)
(pl_coacc_def_ok d p1)). elim (prec_list_ref_ok_destr _ _ _ _ H2). intros. exact (H _ H7 H8). simpl in |- *. apply
(map_replace_mapget_ins_true_1 (map_or (pl_coacc d p0) (pl_coacc d p1)) a0
a). apply
(map_or_mapget_true_rd _ _ _ a0 (pl_coacc_def_ok d p0)
(pl_coacc_def_ok d p1)).
elim (prec_list_ref_ok_destr _ _ _ _ H2). intros.
exact (H0 _ H7 H9). simpl in |- *. intros. inversion H.
Qed.

Lemma st_coacc_contain_coacc_ads :
forall (d : preDTA) (s : state) (c : ad) (p : prec_list) (a : ad),
state_ref_ok s d ->
MapGet prec_list s c = Some p ->
prec_occur p a -> MapGet bool (st_coacc d s) a = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.st_coacc_contain_coacc_ads".
simple induction s. intros. inversion H0. intros. simpl in H0.
elim (bool_is_true_or_false (N.eqb a c)); intros; rewrite H2 in H0. simpl in |- *. apply (pl_coacc_contain_coacc_ads d a0 a1). inversion H0. exact H1. apply (H a a0). simpl in |- *.
rewrite (Neqb_correct a). reflexivity. inversion H0.
intros. elim (state_ref_ok_M2_destr _ _ _ H1); intros.
simpl in |- *. induction  c as [| p0]. simpl in H2. apply
(map_or_mapget_true_ld _ _ _ a (st_coacc_def_ok d m) (st_coacc_def_ok d m0)).
apply (H _ _ _ H4 H2 H3). induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]. apply
(map_or_mapget_true_rd _ _ _ a (st_coacc_def_ok d m) (st_coacc_def_ok d m0)). exact (H0 _ _ _ H5 H2 H3).
apply
(map_or_mapget_true_ld _ _ _ a (st_coacc_def_ok d m) (st_coacc_def_ok d m0)). apply (H _ _ _ H4 H2 H3).
apply
(map_or_mapget_true_rd _ _ _ a (st_coacc_def_ok d m) (st_coacc_def_ok d m0)). exact (H0 _ _ _ H5 H2 H3).
Qed.

Lemma predta_coacc_0_contain_coacc_ads :
forall (d d' : preDTA) (a : ad) (s : state) (c : ad)
(p : prec_list) (b : ad) (m : Map bool),
preDTA_ref_ok_distinct d' d ->
MapGet state d' a = Some s ->
MapGet prec_list s c = Some p ->
prec_occur p b ->
ensemble_base state d' m ->
MapGet bool m a = Some true ->
MapGet bool (predta_coacc_0 d d' m) b = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_0_contain_coacc_ads".
simple induction d'. intros. inversion H0. simpl in |- *. intros.
induction  m as [| a2 a3| m1 Hrecm1 m0 Hrecm0]. inversion H3. unfold ensemble_base in H3.
simpl in H3. rewrite <- H3. rewrite (Neqb_correct a).
simpl in H4. elim (bool_is_true_or_false (N.eqb a2 a1)); intros; rewrite H5 in H4;
inversion H4. simpl in |- *. apply (st_coacc_contain_coacc_ads d a0 c p b). elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H6 in H0;
inversion H0. rewrite H9 in H. apply (H a s).
simpl in |- *. rewrite (Neqb_correct a). reflexivity. elim (bool_is_true_or_false (N.eqb a a1)); intros; rewrite H6 in H0. inversion H0. exact H1. inversion H0. exact H2.
inversion H3. intros. induction  m1 as [| a0 a1| m1_1 Hrecm1_1 m1_0 Hrecm1_0]. inversion H5.
inversion H5. elim H5. intros. elim (preDTA_ref_ok_distinct_dest _ _ _ H1). intros. simpl in |- *.
induction  a as [| p0]. simpl in H6. simpl in H2. apply
(map_or_mapget_true_ld _ _ _ b (predta_coacc_0_def_ok d m m1_1)
(predta_coacc_0_def_ok d m0 m1_0)). exact (H _ _ _ _ _ _ H9 H2 H3 H4 H7 H6). induction  p0 as [p0 Hrecp0| p0 Hrecp0| ]; simpl in H2; simpl in H6. apply
(map_or_mapget_true_rd _ _ _ b (predta_coacc_0_def_ok d m m1_1)
(predta_coacc_0_def_ok d m0 m1_0)). exact (H0 _ _ _ _ _ _ H10 H2 H3 H4 H8 H6).
exact
(map_or_mapget_true_ld _ _ _ b (predta_coacc_0_def_ok d m m1_1)
(predta_coacc_0_def_ok d m0 m1_0) (H _ _ _ _ _ _ H9 H2 H3 H4 H7 H6)). exact
(map_or_mapget_true_rd _ _ _ b (predta_coacc_0_def_ok d m m1_1)
(predta_coacc_0_def_ok d m0 m1_0) (H0 _ _ _ _ _ _ H10 H2 H3 H4 H8 H6)).
Qed.

Lemma predta_coacc_contain_coacc_ads_0 :
forall (d : preDTA) (a0 a : ad) (s : state) (c : ad)
(p : prec_list) (b : ad) (m : Map bool),
preDTA_ref_ok d ->
MapGet state d a = Some s ->
MapGet prec_list s c = Some p ->
prec_occur p b ->
ensemble_base state d m ->
MapGet bool m a = Some true ->
MapGet bool (predta_coacc d a0 m) b = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_contain_coacc_ads_0".
unfold predta_coacc in |- *. intros. apply (map_replace_mapget_ins_true_1 (predta_coacc_0 d d m) b a0). apply
(fun hyp : preDTA_ref_ok_distinct d d =>
predta_coacc_0_contain_coacc_ads d d a s c p b m hyp H0 H1 H2 H3 H4). elim (preDTA_ref_ok_def d). intros. exact (H5 H).
Qed.

Definition predta_coacc_contain_coacc_ads_def_0 (d : preDTA)
(a0 a1 : ad) : Prop :=
coacc d a0 a1 ->
preDTA_ref_ok d ->
exists n : nat,
MapGet bool (power (Map bool) (predta_coacc d a0) (map_mini state d) n)
a1 = Some true.

Lemma predta_coacc_contain_coacc_ads_1 :
forall (d : preDTA) (a : ad) (s : state),
MapGet state d a = Some s ->
predta_coacc_contain_coacc_ads_def_0 d a a.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_contain_coacc_ads_1".
unfold predta_coacc_contain_coacc_ads_def_0 in |- *. intros.
split with 1. simpl in |- *. unfold predta_coacc in |- *. elim
(domain_equal_mapget state bool d (predta_coacc_0 d d (map_mini state d)) a
s (predta_coacc_0_def_ok d d (map_mini state d)) H). intros. apply
(map_replace_mapget_ins_true_0 (predta_coacc_0 d d (map_mini state d)) a x
H2).
Qed.

Lemma predta_coacc_contain_coacc_ads_2 :
forall (d : preDTA) (a0 a1 a2 : ad) (s1 s2 : state)
(pl : prec_list) (c : ad),
MapGet state d a2 = Some s2 ->
MapGet state d a1 = Some s1 ->
MapGet prec_list s1 c = Some pl ->
prec_occur pl a2 ->
coacc d a0 a1 ->
predta_coacc_contain_coacc_ads_def_0 d a0 a1 ->
predta_coacc_contain_coacc_ads_def_0 d a0 a2.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_contain_coacc_ads_2".
unfold predta_coacc_contain_coacc_ads_def_0 in |- *. intros.
elim (H4 H3 H6). intros. split with (S x). simpl in |- *.
apply
(predta_coacc_contain_coacc_ads_0 d a0 a1 s1 c pl a2
(power (Map bool) (predta_coacc d a0) (map_mini state d) x) H6 H0 H1 H2). apply
(power_def_ok bool (ensemble_base state d) (predta_coacc d a0)
(map_mini state d) x). unfold def_ok_app in |- *. intros. exact (predta_coacc_def_ok d a0 x0).
exact (map_mini_appartient state d). exact H7.
Qed.

Lemma predta_coacc_contain_coacc_ads_3 :
forall (d : preDTA) (a0 a1 : ad),
coacc d a0 a1 ->
preDTA_ref_ok d ->
exists n : nat,
MapGet bool (power (Map bool) (predta_coacc d a0) (map_mini state d) n) a1 =
Some true.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_contain_coacc_ads_3".
intros. exact
(coacc_ind predta_coacc_contain_coacc_ads_def_0
predta_coacc_contain_coacc_ads_1 predta_coacc_contain_coacc_ads_2 d a0
a1 H H H0).
Qed.

Lemma pl_coacc_rev :
forall (d : preDTA) (pl : prec_list) (a : ad),
MapGet bool (pl_coacc d pl) a = Some true -> prec_occur pl a.
Proof. hammer_hook "coacc_test" "coacc_test.pl_coacc_rev".
simple induction pl. simpl in |- *. intros. elim
(map_replace_mapget_true_inv (map_or (pl_coacc d p) (pl_coacc d p0)) _ _ H1). intros. rewrite <- H2.
exact (prec_hd a0 p p0). intros. elim (map_or_mapget_true_inv (pl_coacc d p) (pl_coacc d p0) a0 H2). intros. exact (prec_int0 a a0 p p0 (H _ H3)). intros. exact (prec_int1 a a0 p p0 (H0 _ H3)). intros. simpl in H. cut (true <> false).
intro. elim (H0 (map_mini_mapget_false _ _ _ _ H)). intro.
inversion H0.
Qed.

Lemma st_coacc_rev :
forall (d : preDTA) (s : state) (a : ad),
MapGet bool (st_coacc d s) a = Some true ->
exists c : ad,
(exists p : prec_list,
MapGet prec_list s c = Some p /\ prec_occur p a).
Proof. hammer_hook "coacc_test" "coacc_test.st_coacc_rev".
simple induction s. intros. simpl in H. elim (map_mini_mapget_true _ _ _ H). intros. simpl in H. split with a. split with a0.
simpl in |- *. rewrite (Neqb_correct a). split. reflexivity.
exact (pl_coacc_rev _ _ _ H). intros. simpl in H1.
elim (map_or_mapget_true_inv (st_coacc d m) (st_coacc d m0) a H1). intros. elim (H _ H2). intros. elim H3. intros.
split with (N.double x). split with x0. induction  x as [| p]; simpl in |- *; exact H4. intros. elim (H0 _ H2). intros. elim H3. intros.
split with (Ndouble_plus_one x). split with x0.
induction  x as [| p]; simpl in |- *; exact H4.
Qed.

Lemma predta_coacc_0_rev :
forall (d d' : preDTA) (b : ad) (m : Map bool),
MapGet bool (predta_coacc_0 d d' m) b = Some true ->
ensemble_base state d' m ->
exists a : ad,
(exists s : state,
(exists c : ad,
(exists p : prec_list,
MapGet state d' a = Some s /\
MapGet prec_list s c = Some p /\
prec_occur p b /\ MapGet bool m a = Some true))).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_0_rev".
simple induction d'; intros. induction  m as [| a a0| m1 Hrecm1 m0 Hrecm0]. simpl in H. elim (map_mini_mapget_true _ _ _ H). inversion H0.
inversion H0. induction  m as [| a1 a2| m1 Hrecm1 m0 Hrecm0]. inversion H0. unfold ensemble_base in H0. simpl in H0. rewrite <- H0 in H.
rewrite <- H0. simpl in H. rewrite (Neqb_correct a) in H. elim (bool_is_true_or_false a2); intros; rewrite H1 in H. simpl in H. split with a. split with a0. elim (st_coacc_rev _ _ _ H). intros. elim H2. intros. split with x. split with x0. simpl in |- *. rewrite (Neqb_correct a). rewrite H1. elim H3. intros. split. reflexivity. split. assumption.
split. assumption. reflexivity. simpl in H. elim (map_mini_mapget_true _ _ _ H). inversion H0. induction  m1 as [| a a0| m1_1 Hrecm1_1 m1_0 Hrecm1_0].
inversion H2. inversion H2. clear Hrecm1_0 Hrecm1_1.
unfold ensemble_base in H2. elim H2. intros. simpl in H1.
elim (map_or_mapget_true_inv _ _ _ H1). intros. elim (H _ _ H5 H3). intros. elim H6. intros. elim H7. intros.
elim H8. intros. decompose [and] H9. split with (N.double x). split with x0. split with x1. split with x2. split. induction  x as [| p]; simpl in |- *; exact H10. split. exact H12. split. exact H11. induction  x as [| p]; simpl in |- *; exact H14.
intros. elim (H0 _ _ H5 H4). intros. elim H6. intros.
elim H7. intros. elim H8. intros. decompose [and] H9.
split with (Ndouble_plus_one x). split with x0.
split with x1. split with x2. induction  x as [| p]; simpl in |- *; exact H9.
Qed.

Lemma predta_coacc_rev :
forall (d : preDTA) (a : ad) (m : Map bool) (b : ad),
MapGet bool (predta_coacc d a m) b = Some true ->
ensemble_base state d m ->
(exists a0 : ad,
(exists s : state,
(exists c : ad,
(exists p : prec_list,
MapGet state d a0 = Some s /\
MapGet prec_list s c = Some p /\
prec_occur p b /\ MapGet bool m a0 = Some true)))) \/
a = b.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_rev".
unfold predta_coacc in |- *. intros. elim (map_replace_mapget_true_inv _ _ _ H). intros.
right. symmetry  in |- *. exact H1. intros. left. elim (predta_coacc_0_rev d d b m H1 H0). elim (predta_coacc_0_rev d d b m H1 H0). intros. elim H3.
intros. elim H4. intros. elim H5. intros. decompose [and] H6. split with x0. split with x1. exact H4.
Qed.

Lemma predta_coacc_reverse :
forall (n : nat) (d : preDTA) (a b : ad),
MapGet bool (power (Map bool) (predta_coacc d a) (map_mini state d) n) b =
Some true -> coacc d a b.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_reverse".
simple induction n. simpl in |- *. intros. elim (map_mini_mapget_true _ _ _ H). intros. simpl in H0. elim (predta_coacc_rev d a _ _ H0).
intros. elim H1. intros. elim H2. intros. elim H3. intros.
elim H4. intros. decompose [and] H5. elim
(domain_equal_mapget bool state
(predta_coacc d a
(power (Map bool) (predta_coacc d a) (map_mini state d) n0)) d b true). intros. apply (coacc_nxt d a x b x0 x3 x2 x1 H9 H6 H8 H7). exact (H d a x H10). exact
(domain_equal_symmetric state bool _ _
(predta_coacc_def_ok d a
(power (Map bool) (predta_coacc d a) (map_mini state d) n0))). exact H0. intros. rewrite H1. elim
(domain_equal_mapget bool state
(predta_coacc d a
(power (Map bool) (predta_coacc d a) (map_mini state d) n0)) d b true). intros. exact (coacc_id d b x H2). apply
(domain_equal_symmetric state bool d
(predta_coacc d a
(power (Map bool) (predta_coacc d a) (map_mini state d) n0))).
exact
(predta_coacc_def_ok d a
(power (Map bool) (predta_coacc d a) (map_mini state d) n0)). exact H0.
apply
(power_def_ok bool (ensemble_base state d) (predta_coacc d a)
(map_mini state d) n0). unfold def_ok_app in |- *. intros. exact (predta_coacc_def_ok d a x).
exact (map_mini_appartient state d).
Qed.

Lemma predta_coacc_fix_0 :
forall (d : preDTA) (a : ad),
lower_fix_point bool (ensemble_base state d) (lemd d)
(predta_coacc d a) (predta_coacc_states d a).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_fix_0".
intros. unfold predta_coacc_states in |- *. apply
(iteres_lower_fix_point bool (ensemble_base state d)
(lemd d) (predta_coacc d a) (map_mini state d)
(S (MapCard state d)) (S (MapCard state d))). unfold mini in |- *.
split. exact (map_mini_appartient state d). intros.
split. exact (map_mini_appartient state d). split.
exact H. elim (map_mini_mini state d). intros.
exact (H1 x H). unfold def_ok_app in |- *. intros. exact (predta_coacc_def_ok d a x). exact (predta_coacc_increasing d a). exact (lattice_bounded d). exact (le_n_n _).
Qed.

Lemma predta_coacc_fix_1 :
forall (d : preDTA) (a a0 : ad) (n : nat),
MapGet bool (power (Map bool) (predta_coacc d a) (map_mini state d) n) a0 =
Some true -> MapGet bool (predta_coacc_states d a) a0 = Some true.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_fix_1".
intros. elim
(domain_equal_mapget bool bool
(power (Map bool) (predta_coacc d a) (map_mini state d) n)
(predta_coacc_states d a) a0 true). intros. elim (bool_is_true_or_false x); intros; rewrite H1 in H0.
exact H0. elim (predta_coacc_fix_0 d a); intros.
unfold inf_fix_points in H3. elim
(lem_get_leb (power (Map bool) (predta_coacc d a) (map_mini state d) n)
(predta_coacc_states d a) a0 true false).
elim
(iteres_inf_fps bool (ensemble_base state d) (lemd d)
(predta_coacc d a) (map_mini state d) (predta_coacc_states d a) n). intros. elim H5. intros.
exact H7. unfold mini in |- *. split. exact (map_mini_appartient state d). intros. split. exact (map_mini_appartient state d). split. exact H4. elim (map_mini_mini state d). intros. exact (H6 x0 H4). exact H2. exact (predta_coacc_increasing d a). exact H. exact H0.
apply
(domain_equal_transitive bool state bool
(power (Map bool) (predta_coacc d a) (map_mini state d) n) d
(predta_coacc_states d a)). apply
(domain_equal_symmetric state bool d
(power (Map bool) (predta_coacc d a) (map_mini state d) n)). apply
(power_def_ok bool (ensemble_base state d) (predta_coacc d a)
(map_mini state d) n). unfold def_ok_app in |- *. intros.
exact (predta_coacc_def_ok d a x). exact (map_mini_appartient state d). unfold predta_coacc_states in |- *.
apply
(power_def_ok bool (ensemble_base state d) (predta_coacc d a)
(map_mini state d) (S (MapCard state d))). unfold def_ok_app in |- *. intros. exact (predta_coacc_def_ok d a x). exact (map_mini_appartient state d). exact H.
Qed.

Lemma predta_coacc_fix_2 :
forall (d : preDTA) (a a0 : ad),
MapGet bool (predta_coacc_states d a) a0 = Some true ->
exists n : nat,
MapGet bool (power (Map bool) (predta_coacc d a) (map_mini state d) n) a0 =
Some true.
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_fix_2".
unfold predta_coacc_states in |- *. intros. split with (S (MapCard state d)). exact H.
Qed.

Lemma predta_coacc_fix :
forall (d : preDTA) (a a0 : ad),
preDTA_ref_ok d ->
(MapGet bool (predta_coacc_states d a) a0 = Some true <-> coacc d a a0).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_fix".
intros. split. intros. elim (predta_coacc_fix_2 _ _ _ H0). intros. exact (predta_coacc_reverse x d a a0 H1). intros. elim (predta_coacc_contain_coacc_ads_3 _ _ _ H0). intros. exact (predta_coacc_fix_1 d a a0 x H1). exact H.
Qed.

Lemma predta_coacc_0_fix :
forall (d : preDTA) (a a0 : ad),
preDTA_ref_ok d ->
(MapGet bool (predta_coacc_states_0 d a) a0 = Some true <->
coacc d a a0).
Proof. hammer_hook "coacc_test" "coacc_test.predta_coacc_0_fix".
intros. unfold predta_coacc_states_0 in |- *. rewrite
(lazy_power_eg_power bool eqm_bool (predta_coacc d a)
(map_mini state d) (S (MapCard state d))). exact (predta_coacc_fix d a a0 H). split. exact (eqm_bool_equal a1 b). intros. rewrite H0. exact (equal_eqm_bool b).
Qed.