Require Import Setoid.

Inductive Empty : Type := .

Definition dot {A B C} (f: B -> C) (g: A -> B) := fun (x: A) => f (g x).

Notation "f $ g" := (dot f g) (at level 75).
Notation "! f" := (f -> Empty) (at level 75).
Notation "p ^" := (eq_sym p) (at level 30).
Notation "f @ g" := (eq_trans f g) (at level 40).

Class Decidable (A : Type) :=
  dec : A + (A -> False).

Class DecidableEq (A : Type) :=
  dec_eq : forall x y: A, Decidable (x = y).
Arguments dec A {_}.

Class isContr (A: Type) := ContrBuilder {
  center : A;
  contr : forall x: A, x = center
}.

Class isHProp (P : Type) :=
  hProp : forall p q : P, p = q.

Class isHSet (X : Type) :=
  hSet : forall (x y : X) (p q : x = y), p = q.

Class EqDec (A : Type) := {
  eqf : A -> A -> bool ;
  eqf_leibniz : forall x y, eqf x y = true <-> x = y
}.

(*   _ : forall x y, reflect (x = y) (eqf x y)
Require Import Bool.
Print reflect.
 *)
Class WeaklyConstant {A B: Type} (f : A -> B) :=
  wconst : forall x y, f x = f y.

Class Collapsible (A : Type) :={
  collapse        : A -> A ;
  wconst_collapse : forall x y: A, collapse x = collapse y
}.

Theorem map_tought_isHProp : forall A B P: Type, forall f: A -> P, forall g: P -> B,
  isHProp P -> WeaklyConstant (g $ f).
Proof.
  intros A B P f g isHProp. unfold WeaklyConstant. intros x y. unfold dot. assert (f x = f y).
  - destruct (isHProp  (f x) (f y)). reflexivity.
  - destruct H. reflexivity.
Qed.

Theorem dec_is_collaps : forall A : Type, Decidable A -> Collapsible A.
Proof.
  intros A eq. destruct eq.
  - exists (fun x => a). intros x y. reflexivity.
  - exists (fun x => x); intros x y.
    exfalso; apply f; assumption.
Qed.

Class PathCollapsible (A : Type) :=
  path_coll : forall (x y : A), Collapsible (x = y).

Theorem eq_dec_is_path_collaps : forall A : Type, DecidableEq A -> PathCollapsible A.
Proof.
  intros A dec x y. apply dec_is_collaps. apply dec.
Qed.

Lemma loop_eq : forall A: Type, forall x y: A, forall p: x = y,
  eq_refl = eq_trans (eq_sym p) p.
Proof.
  intros A x y []. cbn. reflexivity.
Qed.

Lemma loop_eq' : forall A: Type, forall x y: A, forall p: x = y,
  eq_refl = p @ (p ^).
Proof.
  intros A x y []. cbn. reflexivity.
Qed.

Theorem path_collaps_is_hset (A : Type) : PathCollapsible A -> isHSet A.
Proof.
  unfold isHSet, PathCollapsible; intros C x y.
  cut (forall e: x=y, e = eq_trans (eq_sym(collapse(eq_refl x))) (collapse e)).
  - intros H p q.
    rewrite (H q), (H p), (wconst_collapse p q).
    reflexivity.
  - intros []. apply loop_eq.
Qed.

Theorem pathdec_hset (A: Type) : DecidableEq A -> isHSet A.
Proof.
  intros H. apply path_collaps_is_hset. apply eq_dec_is_path_collaps. assumption.
Qed.

Theorem eqDec_pathdec : forall A: Type, EqDec A -> DecidableEq A.
Proof.
  intros A H x y. destruct H. case_eq (eqf0 x y).
  - intro H1. left. apply (eqf_leibniz0 x y). assumption.
  - intro H1. right. intro H2. rewrite <- (eqf_leibniz0 x y) in H2. rewrite H1 in H2.
    discriminate.
Qed.

Definition isLeft {A B: Type} (x : A + B): bool :=
  match x with
  | inl _ => true
  | _ => false
  end.

Theorem pathdec_eqDec : forall A: Type, DecidableEq A -> EqDec A.
Proof.
  intros A H. unfold DecidableEq in H. exists (fun x y => isLeft (H x y)).
  intros x y. split.
  - case_eq (H x y); intros p H1.
    + intros _. assumption.
    + cbn. intro H2. discriminate.
  - intro H1. subst. case_eq (H y y); intros p H1.
    + cbn. reflexivity.
    + contradiction.
Qed.

Theorem dec_eq_hset : forall A: Type, EqDec A -> isHSet A.
Proof.
  intros A H. apply pathdec_hset. apply eqDec_pathdec. assumption.
Qed.

Definition path_contr {A: Type} `{isContr A} (x y: A) : x = y :=
 eq_trans (contr x) (eq_sym (contr y)).

Lemma all_path_eq_in_contr {A: Type} `{isContr A} {x y: A}: forall p q: x = y, p = q.
Proof.
  intros p q. assert (forall e: x = y, e = path_contr x y).
  - intros []. unfold path_contr. unfold contr. destruct H. apply loop_eq'.
  - rewrite (H0 p). rewrite (H0 q). reflexivity.
Qed.

Lemma contr_bottom (A: Type) `{isContr A} (x y: A): isContr (x = y).
Proof.
  exists (path_contr x y).
  intros p. apply all_path_eq_in_contr.
Qed.

Theorem contr_is_hprop (A: Type) `{isContr A} : isHProp A.
Proof.
  unfold isHProp. intros p q. destruct H. rewrite contr0.
  specialize (contr0 p). rewrite contr0. reflexivity.
Qed.

Theorem contr_not_eq_hprop : exists A: Type, isHProp A /\ (! isContr A).
Proof.
  exists Empty. split.
  - unfold isHProp. intros [] _.
  - intros []. destruct center0.
Qed.

Lemma all_path_eq_in_hprop {A: Type} `{isHProp A} {x y: A}: forall p q: x = y, p = q.
Proof.
  intros p q. assert (isHProp (x=y)).
  - apply contr_is_hprop. apply contr_bottom. exists x. intro z. apply H.
  - apply H0.
Qed.

Theorem hprop_def (A: Type) `{isHProp A} (x y: A) : isContr (x = y).
Proof.
  exists (H x y). intro p. apply all_path_eq_in_hprop.
Qed.

Theorem hprop_inv (A: Type) `{isContr A} (x y: A) : isHProp (x = y).
Proof.
  apply contr_is_hprop. apply contr_bottom. assumption.
Qed.

Theorem hprop_is_hset (A: Type) `{isHProp A} : isHSet A.
Proof.
  unfold isHSet. intros x y p q. apply all_path_eq_in_hprop.
Qed.

Theorem hprop_not_eq_hset : exists A: Type, isHSet A /\ !isHProp A.
Proof.
  exists bool. split.
  - apply pathdec_hset. intros x y. unfold Decidable.
    destruct x, y; auto; right; intro H; discriminate.
  - intro H. specialize (H true false). discriminate.
Qed.

Theorem hset_def {A: Type} `{isHSet A} (x y: A) : isHProp (x = y).
Proof.
  unfold isHProp. apply H.
Qed.

Theorem paths_between_paths_are_eq_in_hset {A: Type} `{isHSet A} {x y: A} {a b: x = y}:
 forall p q: a = b, p = q.
Proof.
  intros p q. assert (isContr (p = q)).
  - unfold isHSet in H. apply contr_bottom. apply contr_bottom. exists a. intro c. apply H.
  - destruct H0. assumption.
Qed.

Theorem hset_inv {A: Type} `{isHProp A} (x y: A) : isHSet (x = y).
Proof.
  intros a b p q. assert (isHSet A) by (apply hprop_is_hset; assumption).
  apply paths_between_paths_are_eq_in_hset.
Qed.

Inductive universe_level : Type :=
| minus_two  : universe_level
| S_universe : universe_level -> universe_level.

Definition HPropLevel := S_universe minus_two.

Definition HSetLevel := S_universe HPropLevel.

Fixpoint isNType (n : universe_level) (A : Type) : Type :=
match n with
| minus_two => isContr A
| S_universe n' => forall x y: A, isNType n' (x = y)
end.

Theorem isHProp_def : forall A: Type, isNType HPropLevel A -> isHProp A.
Proof.
  unfold isNType. cbn.
  intros A H p q. destruct (H p q). assumption.
Qed.

Theorem isHProp_def' : forall A: Type, isHProp A -> isNType HPropLevel A.
Proof.
  unfold isNType. cbn.
  intros A H p q. apply hprop_def. assumption.
Qed.

Theorem isHSet_def : forall A: Type, isNType HSetLevel A -> isHSet A.
Proof.
  unfold isNType. cbn.
  intros A H x y p q. destruct (H x y p q). assumption.
Qed.

Theorem isHSet_def' : forall A: Type, isHSet A -> isNType HSetLevel A.
Proof.
  unfold isNType. cbn.
  intros A H x y p q. apply hprop_def. apply hset_def.
Qed.

Theorem NType_incusion : forall A: Type, forall n : universe_level,
  isNType n A -> isNType (S_universe n) A.
Proof.
  intros A n; revert A.
  induction n; intros A H.
  - cbn in *; intros x y.
    apply contr_bottom.
    assumption.
  - simpl in *; intros x y.
    apply IHn.
    apply H.
Qed.

Definition id {A: Type} (x: A) := x.

Definition ap {A B: Type} {x y: A} (f: A -> B) (p: x = y): f x = f y :=
  match p with
  | eq_refl => eq_refl
  end.

Definition transport {A: Type} {x y: A} {P: A -> Type} (path: x = y) (q : P x) : P y :=
match path with
| eq_refl => q
end.

Notation "p *" := (transport p) (at level 20).

Definition apd {A: Type} {x y: A} {P: A -> Type} (f: forall x:A, P x) (p: x = y) :
  (p *) (f x) = f y :=
  match p with
  | eq_refl => eq_refl
  end.

(* ap proofs *)

Theorem ap_distr {A B: Type} {x y z: A} (f: A -> B) (p: x = y) (q: y = z)
  : ap f (p @ q) = (ap f p) @ (ap f q).
Proof.
  destruct p, q. cbn. reflexivity.
Qed.

Theorem ap_inv {A B: Type} {x y: A} (f: A -> B) (p: x = y) : ap f (p ^) = (ap f p) ^.
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem ap_conn {A B C: Type} {x y: A} (f: A -> B) (g: B -> C) (p: x = y)
  : ap g (ap f p) = ap (g $ f) p.
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem ap_id {A B: Type} {x y: A} (p: x = y) : ap id p = p.
Proof.
  destruct p. cbn. reflexivity.
Qed.

(* transport proofs *)

Theorem transport_dist {A: Type} {P: A -> Type} {x y z: A} (p: x = y) (q: y = z) (u: P x)
  : (q *) ((p *) u) = ((p @ q) *) u.
Proof.
  destruct p, q. cbn. reflexivity.
Qed.

Theorem transport_ap {A B: Type} {P: B -> Type} {x y: A} (f: A -> B) (p: x = y) (u: P (f x))
  : transport (P := P $ f) p u = transport (ap f p) u.
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem transport_fun {A: Type} {P Q: A -> Type} {x y: A} (f: forall x, P x -> Q x) (p: x = y)
  (u: P x) : transport (P := Q) p (f x u) = f y (transport (P := P) p u).
Proof.
  destruct p. cbn. reflexivity.
Qed.

Theorem dep_pair_eq : forall (A: Type) (P: A -> Type) (x y: A) (p: P x) (q: P y),
  existT P x p = existT P y q -> exists path: x = y, transport path p = q.
Proof.
  intros A P x y p q H. inversion H.
  exists eq_refl. cbn. trivial.
Qed.

Theorem dep_pair_eq_inv : forall (A: Type) (P: A -> Type) (x y: A) (p: P x) (q: P y),
   (exists e: x = y, transport e p = q) -> existT P x p = existT P y q.
Proof.
  intros A P x y p q (-> & []). cbn. reflexivity.
Qed.

Definition pointwise_paths {A B: Type}  (f g : A -> B)
  := forall x, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 100).

Class IsEquiv {A B : Type} (f : A -> B) := {
  equiv_inv : B -> A ;
  eisretr : (f $ equiv_inv) == id ;
  eissect : (equiv_inv $ f) == id ;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x) ;
}.

Arguments IsEquiv {A B}.

Class IsEquiv' {A B : Type} (f : A -> B) := {
  equiv_inv_A : B -> A ;
  equiv_inv_B : B -> A ;
  equiv_id_A : f $ equiv_inv_A == id ;
  equiv_id_B : equiv_inv_B $ f == id ;
}.

Class IsEquiv'' {A B : Type} (f : A -> B) :=
  contr_equiv : forall y: B, isContr(exists x, f x = y).

Theorem equiv_same (A B: Type) (f: A -> B) `{IsEquiv A B f} : IsEquiv' f.
Proof.
  destruct H. exists equiv_inv0 equiv_inv0; assumption.
Qed.

Theorem equiv_same' (A B: Type) (f: A -> B) `{IsEquiv' A B f} : IsEquiv f.
Proof.
  destruct H.
Abort.

Record Equiv A B := {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Notation "A <~> B" := (Equiv A B) (at level 120).

Check (fun x => equiv_inv (equiv_fun x)).

Theorem hprop_from_hset_eq (A: Type) `{isHSet A} (P: A -> Prop) (f: A -> A)
  (H0: forall x, x = f x <~> P x) (x: A) : isHProp (P x).
Proof.
  intros p q. specialize (H0 x). destruct H0. destruct equiv_isequiv0.
  unfold pointwise_paths in *. assert (id p = id q).
  - rewrite <- eisretr0. rewrite <- (eisretr0 q). unfold dot.


Require Import Base.
Require Import Circuit.
Import Circuit_Tactics.
Require Import List.
Import ListNotations.
Open Scope list_scope.

Require Import Omega.

Require Import PeanoNat.

Existing Instance event_eq_dec.
Existing Instance latch_eq_dec.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

(** * Definition of desynchronization marked graph *)
Section Desynchronization.

  Context (even odd : Set).
  Context `{Heven : eq_dec even} `{Hodd : eq_dec odd}.

  Variable c : circuit even odd.
  Variable init_st : state (latch even odd).

  Inductive desync_place : event (latch even odd) bool -> event (latch even odd) bool -> Set :=
  | latch_fall (l : latch even odd) : desync_place (Rise l) (Fall l)
  | latch_rise (l : latch even odd) : desync_place (Fall l) (Rise l)
  | neighbor_fall : forall l l', neighbor c l l' -> desync_place (Rise l) (Fall l')
  | neighbor_rise : forall l l', neighbor c l l' -> desync_place (Fall l') (Rise l).

  Definition desynchronization : marked_graph (event (latch even odd) bool) :=
    {| place := desync_place
     ; init_marking := fun t1 t2 p => match p with
                                      | latch_rise (Even _) => 1
                                      | latch_fall (Odd _) => 1
                                      | neighbor_fall _ _ _ => 1
                                      | _ => 0
                                      end
    |}.

(** * Specialized is_enabled constraint *)
Inductive is_enabled_desync : event (latch even odd) bool -> marking desynchronization -> Prop :=
| latch_fall_enbled l (m : marking desynchronization) :
    0 < m _ _ (latch_fall l) ->
    (forall l0 (pf : neighbor c l0 l), 0 < m _ _ (neighbor_fall l0 l pf)) ->
    is_enabled_desync (Fall l) m
| latch_rise_enabled l (m : marking desynchronization) :
    0 < m _ _ (latch_rise l) ->
    (forall l' (pf : neighbor c l l'), 0 < m _ _ (neighbor_rise l l' pf)) ->
    is_enabled_desync (Rise l) m
.

Lemma desync_is_enabled_equiv : forall e m,
    is_enabled_desync e m -> is_enabled desynchronization e m.
Proof.
  destruct e as [[O | E] v];
    intros m; inversion 1; subst;
    intros e0 p;
    simpl in p;
    dependent destruction p;
    auto.
Qed.

Lemma is_enabled_desync_equiv : forall e m,
    is_enabled desynchronization e m ->
    is_enabled_desync e m.
Proof.
  intros e m Henabled.
  unfold is_enabled in *.
  destruct e as [[O | E] [|]];
    constructor; intros; apply Henabled; eexists; try (econstructor; eauto; fail).
Qed.

End Desynchronization.

Arguments desynchronization {even odd}.

  Lemma exists_not_forall : forall A (P : A -> Prop),
    (exists x, ~P x) ->
    ~ forall x, P x.
  Proof.
    intros A P [x H] contr.
    specialize (contr x).
    contradiction.
  Qed.

(** * Definition of circuit that demonstrates counterexample *)

(** Pipeline SRC <-> A -> B -> C <-> SNK *)
Section EnvPipeline.

  Inductive even := A | C.
  Inductive odd := SRC | B | SNK.

  Definition eEven : even -> latch even odd := Even.
  Coercion eEven : even >-> latch.
  Definition eOdd : odd -> latch even odd := Odd.
  Coercion eOdd : odd >-> latch.

  Instance even_eq_dec : eq_dec even.
  Proof.
    split. intros [ | ] [ | ];
      try (left; reflexivity); try (right; discriminate).
  Defined.
  Instance odd_eq_dec : eq_dec odd.
  Proof.
    split. intros [ ] [ ];
      try (left; reflexivity); try (right; discriminate).
  Defined.

  (** The pipeline increments the value received at every stage *)
  Definition inc_value (v : value) : value :=
    match v with
    | Num n => Num (1+n)
(*    | Bit0 => Bit1
    | Bit1 => Bit0*)
    | X => Num 0
    end.
  Lemma inc_value_inj : forall v1 v2,
    inc_value v1 = inc_value v2 ->
    v1 = v2.
  Proof.
    intros [x | ] [y | ] Heq; auto; simpl in *;
      inversion Heq; auto.
  Qed.

  Program Definition c : circuit even odd :=
    {| even_odd_neighbors := (A,SRC) :: (A,B) :: (C,SNK) :: nil
     ; odd_even_neighbors := (SRC,A) :: (B,C) :: (SNK,C) :: nil
     ; next_state_e := fun e =>
        match e with
        | A => fun st => st (existT _ SRC _)
        | C => fun st => inc_value (st (existT _ B _))
        end
     ; next_state_o := fun o =>
        match o with
        | SRC => fun st => inc_value (st (existT _ A _))
        | B => fun st   => inc_value (st (existT _ A _))
        | SNK => fun st => Num 0
        end
     |}.
  Definition st0 : state (latch even odd) := fun l => X.

  (** ** Lemmas about the behavior of each latch *)

  Lemma sync_A : forall n,
    sync_eval c st0 n A = match n with
                          | 0 => X
                          | S n' => Num n'
                          end.
  Proof.
    induction n; auto.
    * simpl; unfold odd_state; simpl; unfold even_state; simpl.
      unfold eEven in IHn.
      rewrite IHn.
      unfold inc_value.
      destruct n; auto.
  Qed.

  Lemma sync_B : forall n,
    sync_eval c st0 (S n) B = inc_value (sync_eval c st0 n A).
  Proof.
    induction n; auto.
  Qed.

  Lemma sync_C : forall n, n > 0 ->
    sync_eval c st0 n C = inc_value (sync_eval c st0 n B).
  Proof.
    induction n; intros Hn; auto.
    find_contradiction.
  Qed.

  Lemma sync_neq : forall n, sync_eval c st0 n C <> sync_eval c st0 (S n) C.
  Proof.
    induction n; auto.
    * simpl. discriminate.
    * repeat (rewrite sync_C; [ | omega]).
      repeat rewrite sync_B.
      repeat rewrite sync_A.

      intros H.
      repeat apply inc_value_inj in H.
      destruct n; [discriminate | ].
      inversion H. omega.
  Qed.

  (** ** Counterexample trace *)
  Definition counter_trace : trace (latch even odd) bool :=
    t_empty ▶ Fall SNK ▶ Rise C
            ▶ Fall B
            ▶ Fall C
            ▶ Rise SNK ▶ Fall SNK ▶ Rise C
            ▶ Rise B
            ▶ Fall C
(** The trace illustrated in the figure continues as follows *)
(*
            ▶ Rise SRC ▶ Fall SRC ▶ Rise A
            ▶ Fall B
            ▶ Fall A
            ▶ Rise SRC ▶ Fall SRC ▶ Rise A
            ▶ Rise B
            ▶ Fall A
            ▶ Fall B
            ▶ Rise SNK ▶ Fall SNK ▶ Rise C
            ▶ Rise SRC ▶ Fall SRC ▶ Rise A
            ▶ Fall C
            ▶ Fall A.
*).

  (** The counterexample is consistent with the desynchronization protocol. *)
  Lemma counter_trace_well_formed : exists m,
    [ desynchronization c ]⊢ counter_trace ↓ m.
  Proof.
    eexists.
    unfold counter_trace.

    repeat (try (econstructor; [ | reflexivity | ])); try (econstructor; fail);
    apply desync_is_enabled_equiv; constructor; auto; intros;
    inversion_neighbors;
       try (repeat (unfold fire at 1; simpl; auto); fail).
  Qed.

  (** The counterexample results in C having the value C_1 instead of C_2. *)
 Lemma counter_eval :
    ⟨c,st0⟩⊢ counter_trace ↓ C ↦{Opaque}
        sync_eval c st0 1 C.
  Proof.
    unfold counter_trace. unfold eEven. unfold eOdd.
    repeat async_constructor; reflexivity.
  Qed.

  (** ** Proof that desynchronization is violated *)
  Theorem desynchronization_not_flow_equivalent2 :
    ~ flow_equivalence (desynchronization c) c st0.
  Proof.
    unfold flow_equivalence.
    apply exists_not_forall.
    exists C.
    apply exists_not_forall.
    exists counter_trace.
    apply exists_not_forall.
    exists (sync_eval c st0 1 C).
    apply exists_not_forall.
    exists (counter_trace_well_formed).
    apply exists_not_forall.
    exists counter_eval.

    replace (num_events (Fall C) counter_trace) with 2 by reflexivity.
    apply sync_neq.
  Qed.

End EnvPipeline.


Require Import StateType SmallStepRelations Divergence.
Require Import Classical_Prop Coq.Logic.Epsilon.
Set Implicit Arguments.

Lemma three_possibilities S `{StateType S} (σ:S)
: (exists σ', star2 step σ nil σ' /\ normal2 step σ')
  \/ (exists σ', star2 step σ nil σ' /\ activated σ')
  \/ diverges σ.
Proof.
  destruct (classic (exists σ' : S, star2 step σ nil σ' /\ normal2 step σ')); eauto; right.
  destruct (classic (exists σ' : S, star2 step σ nil σ' /\ activated σ')); eauto; right.
  eapply neither_diverges; eauto.
Qed.

Require Import Coq.Logic.ClassicalDescription.

Lemma three_possibilities_strong S `{StateType S} (σ:S)
: { σ' : S | star2 step σ nil σ' /\ normal2 step σ' }
  + { σ' : S & { p : star2 step σ nil σ' &
                     { ext : extern & { σ'' : S | step σ' (EvtExtern ext) σ'' } } } }
  + diverges σ.
Proof.
  destruct (excluded_middle_informative (exists σ' : S, star2 step σ nil σ' /\ normal2 step σ')); eauto.
  - eapply constructive_indefinite_description in e. eauto.
  - destruct (excluded_middle_informative (exists σ' : S, star2 step σ nil σ' /\ activated σ')).
    + eapply constructive_indefinite_description in e.
      left; right. destruct e. eexists x; eauto. dcr; eauto.
      eapply constructive_indefinite_description in H1. destruct H1.
      eapply constructive_indefinite_description in e. destruct e.
      eauto.
    + right. revert σ n n0. cofix f.
      intros. destruct (@step_dec _ H σ).
      * inv H0; dcr.
        destruct x.
        -- exfalso. eapply n0; eexists σ; split; eauto using star2_refl.
           do 2 eexists; eauto.
        -- econstructor. eauto. eapply f; intro; dcr.
           ++ eapply n; eexists; split; eauto. eapply star2_silent; eauto.
           ++ eapply n0; eexists; split; eauto. eapply star2_silent; eauto.
      * exfalso. eapply n; eexists σ; split; eauto using star2_refl.
Qed.


Require Import Bool Arith List CpdtTactics.
Set Implicit Arguments.

Module Relational.

(* Defines a tuple of length 'n'. Zach's defition, not used. *)
Inductive tuplen (T: Set) : nat -> Set :=
| tnnil : tuplen T 0
| tncons : T -> forall l, tuplen T l -> tuplen T (S l).

(* Defines a relation of length 'n' re-using the tuplen definition. Zach's definition, not used. *)
Definition relation_n (T: Set) (r n: nat) : Set :=
  tuplen (tuplen T r) n.

(* Defines a relation of arbitrary length tuples. Zach's definition, not used. *)
Definition relation (T: Set) (r: nat) : Set :=
  list (tuplen T r).

(* Defines a list of length 'n' using refined types.
   According to Zach, might make proofs harder.
   Zach's definition, not used. *)
Definition length_refined_lists (T: Set) (l: list T) (n: nat) : Set :=
  { l | @length T l = n }.

(* KM: What does this define, again? *)
Inductive nattuplen : nat -> Set :=
| ntnnil : nattuplen 0
| ntncons : nat -> forall l, nattuplen l -> nattuplen (S l).

(* Tuple, defined as a list of natural numbers. *)
Inductive tuple : Set :=
  | tnil : tuple
  | tcons : nat -> tuple -> tuple.

Eval simpl in tcons 1 tnil.

(* Relation defined as a list of tuples. *)
Inductive Relation : Set :=
| rnil : Relation
| rcons : tuple -> Relation -> Relation.

Eval simpl in rcons (tcons 1 tnil) rnil.
Eval simpl in rcons (tcons 1 tnil) (rcons (tcons 2 tnil) rnil).

(* Attribute reference takes a natural number (unnamed index for that attribute). *)
Inductive AttrRef : Set :=
 | Unnamed : nat -> AttrRef.

(* Ways to construct natural expressions. *)
Inductive NExp : Set :=
 | NConst : nat -> NExp
 | AConst : AttrRef -> NExp.

(* Natural binary operations: takes two naturals. *)
Inductive nbinop : Set :=
 | Eq.

(* Boolean binary operations: takes two booleans. *)
Inductive bbinop : Set :=
  | And
  | Or.

(* Predicates:
   pred := bool
         | nbinop nat nat
         | bbinop pred pred *)
(* KM: Why does nbinop constructor take two NExp instead of two nat? *)
Inductive Pred : Set :=
  | BConst : bool -> Pred
  | NBinop : nbinop -> NExp -> NExp -> Pred
  | BBinop : bbinop -> Pred -> Pred -> Pred.

Eval simpl in BConst true.
Eval simpl in BConst false.
Eval simpl in BBinop And (BConst true) (BConst true).
Eval simpl in BBinop Or (NBinop Eq (AConst (Unnamed 0)) (NConst 3)) (NBinop Eq (NConst 2) (AConst (Unnamed 4))).

(* Returns the element (nat) in the given position (index) of the given tuple.
   Returns None if the index is invalid (e.g., out of bounds.) *)
Fixpoint attrLookupHelper (t : tuple) (pos : nat) : option nat :=
 match t with
   | tnil => None
   | tcons attr rem =>
       if (beq_nat pos 0)
       then (Some attr)
       else attrLookupHelper rem (pos-1)
end.

(* Returns the element (nat) in the given attribute reference (position) of the given tuple.
   Returns None if the index is invalid.
   @See attrLookupHelper. *)
Definition attrLookup (t : tuple) (a : AttrRef) : option nat :=
 match a with
     | Unnamed pos => attrLookupHelper t pos
end.

Eval simpl in attrLookup (tcons 10 (tcons 20 tnil)) (Unnamed 1).
Eval simpl in attrLookup tnil (Unnamed 0).
Eval simpl in attrLookup (tcons 10 (tcons 20 (tcons 30 tnil))) (Unnamed 3).

(* Evaluates an expression that returns a nat with the given tuple.
   Tuple is required since the expression might be an attribute refrence.
   If there is a violation, None is returned. *)
Definition evalNExp (e : NExp) (t : tuple) : option nat :=
  match e with
  | NConst n => Some n
  | AConst aref => attrLookup t aref
end.

(* KM: I remember Zach putting this, but I don't rememeber why. *)
(* check it out : http://compcert.inria.fr/doc/html/Compiler.html *)

(* Evaluates the predicate (which returns a boolean) with the given tuple.
   If there is a violation, None is returned. *)
Fixpoint evalPred (p : Pred) (t : tuple) : option bool :=
  match p with
   | BConst b => Some b
   | NBinop op e1 e2 => let r1 := evalNExp e1 t in
                        match r1 with
                          | None => None
                          | Some n1 =>
                            let r2 := evalNExp e2 t in
                            match r2 with
                             | None => None
                             | Some n2 =>
                              match op with
                                 | Eq => Some (beq_nat n1 n2)
                              end
                           end
                        end
  | BBinop op p1 p2 => let r1 := evalPred p1 t in
                       match r1 with
                         | None => None
                         | Some b1 =>
                            let r2 := evalPred p2 t in
                            match r2 with
                              | None => None
                              | Some b2 =>
                                 match op with
                                   | And => Some (andb b1 b2)
                                   | Or => Some (orb b1 b2)
                                 end
                            end
                     end
   end.

Eval simpl in evalPred (NBinop Eq (NConst 3) (AConst (Unnamed 1))) (tcons 3 (tcons 3 tnil)).

(* Our initial implementation for select with the helper function.
   Is there any reason to keep this (since we are using Zach's non-tail recursive version)?
   Note: the loops in IMP will be defined tail recursive. *)
Fixpoint selectHelper (src : Relation) (p : Pred) (res : Relation) : option Relation :=
  match src with
    | rnil => Some res
    | rcons t rem => let pres := evalPred p t in
                       match pres with
                         | None => None
                         | Some b => if b then selectHelper rem p (rcons t res)
                                          else selectHelper rem p res
                       end
 end.

Definition select (r : Relation) (p : Pred) : option Relation :=
 selectHelper r p rnil.

(* Alternative select implementation, non tail recursive.
   Given a relation and a predicate, returns a relation where the result only contains the tuples, which evaluated to true wrt to the predicate, in the original relation.
   If there is a violation, returns None. *)
Fixpoint select' (r: Relation) (p: Pred) : option Relation :=
  match r with
    | rnil => Some rnil
    | rcons t r' =>
      match select' r' p with
        | None => None
        | Some r'' =>
          match evalPred p t with
            | None => None
            | Some true => Some (rcons t r'')
            | Some false => Some r''
          end
      end
  end.

Eval simpl in rcons (tcons 1 (tcons 2 tnil)) (rcons (tcons 1 (tcons 3 tnil)) rnil).
Eval compute in select (rcons (tcons 1 (tcons 2 tnil)) (rcons (tcons 1 (tcons 3 tnil)) rnil)) (NBinop Eq (NConst 1) (AConst (Unnamed 0))).
Eval compute in select (rcons (tcons 1 (tcons 2 tnil)) (rcons (tcons 1 (tcons 3 tnil)) rnil)) (NBinop Eq (NConst 2) (AConst (Unnamed 1))).

(* Returns the number of tuples in a relation. *)
Fixpoint rlength (r : Relation) : nat :=
  match r with
   | rnil => 0
   | rcons t rem => 1 + (rlength rem)
end.

(* KM: Why do we need this again?
   I believe it is defining a new command 'inv' as a combination of three commands and Zach uses that in the proof, but I don't know. *)
Ltac inv H := inversion H; subst; clear H.

Lemma ConsLength : forall rel1 rel2 t, rlength (rcons t rel1) <= rlength (rcons t rel2) -> rlength rel1 <= rlength rel2.
Proof.
  crush.
Qed.
Lemma ConsLength' : forall rel1 rel2 t, rlength rel1 <= rlength rel2 -> rlength (rcons t rel1) <= rlength (rcons t rel2).
Proof.
  crush.
Qed.
Lemma SucCons : forall rel t, rlength (rcons t rel) = S (rlength rel).
Proof.
crush.
Qed.
Lemma SucCons' : forall rel t, S (rlength rel) = rlength (rcons t rel).
Proof.
crush.
Qed.
Lemma MoveSuc : forall rel1 rel2 rel1', rlength rel1 <= S (rlength rel2) -> match rel1 with
                                                                           | rnil => rlength rel1 <= rlength rel2
                                                                           | _ => S (rlength rel1') = rlength rel1 -> rlength rel1' <= rlength rel2
                                                                          end.
Proof.
intros.
destruct rel1 eqn:?.
crush.
crush.
Qed.

Lemma MoveSuc' : forall rel1 rel2, match rel1 with
                                              | rnil => rlength rel1 <= rlength rel2
                                              | _ => exists rel1', S (rlength rel1') = rlength rel1 /\ rlength rel1' <= rlength rel2
                                            end ->  rlength rel1 <= S (rlength rel2).
Proof.
intros.
destruct rel1 eqn:?.
crush.
crush.
Qed.
 Lemma ConsLengthTrans : forall rel1 rel2 rel3 t, rel1 = rcons t rel3 /\ rlength rel1 <= rlength rel2 -> rlength rel3 <= rlength rel2.
Proof.
crush.
Qed.

(* Zach's magical proof. *)
Theorem select'_decreasing :
  forall rel pred sel,
  select' rel pred = Some sel ->
  rlength sel <= rlength rel.
Proof.
  induction rel; intros.
  inv H; auto.

  remember H as H'; clear HeqH'. (* make a copy of H to keep it around *)
  simpl in H'.
  destruct (select' rel pred) eqn:?; try discriminate.
  destruct (evalPred pred t) eqn:?; try discriminate.
  destruct b; inv H'; simpl.
  Check le_n_S.
  apply le_n_S. eapply IHrel; eauto.  (* somehow avoided getting r0 and r mixed up *)
  specialize (IHrel pred sel). (* fill in pred and sel *)
  apply IHrel in Heqo. omega. (* tactic for inequalities on nats *)
Qed.

(*
Lemma cons_preserving :
    forall t,
    select' (rcons t rel) pred = Some sel -> rlength sel <= rlength rel
*)

(*
Lemma cons_select :
    forall rel pred t sel,
    (select' rel pred = Some sel) \/
    (exists rel2, rel = (rcons t rel2) /\ select' rel2 pred = Some sel) ->
    select' (rcons t rel) pred = Some sel.
Proof.
intros.
crush.
admit.
*)

Theorem select'_decreasing' :
  forall rel pred sel,
  select' rel pred = Some sel ->
  rlength sel <= rlength rel.
Proof.
  induction rel.
  intros; crush.

  intros.

  specialize IHrel with pred sel.
  inversion H. destruct (select' rel pred) eqn:?. destruct (evalPred pred t) eqn:?.
  destruct b.
  simpl in H.

  assert (Some r = Some sel).
  rewrite <- Heqo.

  unfold select' in H. simpl in H.

auto.
 in H.
  rewrite

  destruct H.
  compute in H.
  rewrite

  crush.

  inversion H1.

  inversion H.
  remember H as H'. clear HeqH'.
  inversion H.
  destruct (select' rel pred) eqn:?. (* eqn:? preserves the matched r'' relational *)
  destruct (evalPred pred t) eqn:?.
  destruct b. (* cases of pred true false *)
  (* b=true case *)
  inversion H1.
  apply ConsLength'.
  apply IHrel with pred.
  assumption.

  (*b = false case*)
  inversion H1.
  rewrite SucCons.
  apply MoveSuc'.
  destruct sel eqn:?.
  crush.
  exists r0.
  split.
  crush.
  apply ConsLengthTrans with r t0.
  split.
  assumption.
  apply IHrel with pred.
  assumption.

  (* evalPred => None case *)
  discriminate.

  (* select' => None case *)
  discriminate.
Qed.


From Coq Require Export Ensembles.

(** An abstract domain **)
Class AbstractDomain (ConcreteType AbstractType: Type) :=
{
  bot : AbstractType;
  top : AbstractType;
  join : AbstractType -> AbstractType -> AbstractType;

  gamma : AbstractType -> Ensemble ConcreteType;
  in_dom c a := Ensembles.In _ (gamma a) c;
  le a1 a2 := forall x, in_dom x a1 -> in_dom x a2;

  gamma_top : forall x, in_dom x top;
  gamma_bot : forall x, ~ in_dom x bot;
  join_sound_l : forall a1 a2, le a1 (join a1 a2);
  join_sound_r : forall a1 a2, le a2 (join a1 a2);
}.

(** Some simple facts about abstract domains **)
Section AbstractDomainTheorems.

  Context {ConcreteType AbstractType: Type}
          {ad: AbstractDomain ConcreteType AbstractType}.

  Theorem le_refl :
    forall a, le a a.
  Proof.
    unfold le.
    auto.
  Qed.

  Theorem le_trans :
    forall a1 a2, le a1 a2 -> forall a3, le a2 a3 -> le a1 a3.
  Proof.
    intros.
    unfold le in *.
    auto.
  Qed.

  Theorem le_join_l :
    forall a1 a2, le a1 a2 -> forall a3, le a1 (join a2 a3).
  Proof.
    eauto using le_trans, join_sound_l.
  Qed.

  Theorem le_join_r :
    forall a1 a2, le a1 a2 -> forall a3, le a1 (join a3 a2).
  Proof.
    eauto using le_trans, join_sound_r.
  Qed.

  Theorem le_bot :
    forall a, le bot a.
  Proof.
    unfold le.
    intros.
    apply gamma_bot in H.
    inversion H.
  Qed.

End AbstractDomainTheorems.


Require Export Definitions.

Theorem couple x y (x_ : M x) (y_ : M y) :
    x ∈ (Pairing x y) /\ y ∈ (Pairing x y).
Proof.
  split.
  + apply (pairing x y x x_).
    by apply or_introl.
  + apply (pairing x y y y_).
    by apply or_intror.
Qed.

Theorem pairing_refl X Y (X_ : M X) (Y_ : M Y):
    (Pairing X Y) = (Pairing Y X).
Proof.
  apply equal.
  intros i.
  split => [H | H].
  + assert (i_ : M i)  by (by exists (Pairing X Y)).
    apply (pairing X Y i i_) in H.
    apply (pairing Y X i i_).
    by apply or_comm.
  + assert (i_ : M i)  by (by exists (Pairing Y X)).
    apply (pairing X Y i i_).
    apply (pairing Y X i i_) in H.
    by apply or_comm.
Qed.

Theorem in_single x X (x_ : M x) (X_ : M X):
  x ∈ (Single X) <-> x = X.
Proof.
  split => [H | H].
  + apply (pairing X X x x_) in H.
    by apply (@or_elim (x = X)) in H.
  + rewrite H.
    by apply single.
Qed.

Theorem single_single :
  forall x y, M x -> M y -> ((Single x) = (Single y)) <-> (x = y).
Proof.
  intros x y x_ y_.
  split => [H | H].
  + specialize (single x x_) as x_xx.
    rewrite H in x_xx.
    by apply (in_single x y x_ y_) in x_xx.
  + by rewrite H.
Qed.

Theorem pairing_single x y X (x_ : M x) (y_ : M y) (X_ : M X):
    (Pairing x y) = (Single X) <-> x = X /\ y = X.
Proof.
  split => [H | H].
  + specialize (couple x y x_ y_) as H0.
    rewrite H in H0.
    induction H0 as [x_X y_X].
    apply (in_single x X x_ X_) in x_X.
    by apply (in_single y X y_ X_) in y_X.
  + induction H as [xX yX].
    by subst x y.
Qed.

Theorem single_pairing X x y (X_ : M X) (x_ : M x) (y_ : M y) :
    (Single X) = (Pairing x y) -> x = X /\ y = X.
Proof.
  intro H.
  symmetry in H.
  by apply (pairing_single x y X x_ y_ X_) in H.
Qed.

Theorem pairing_pairing x y X Y (x_ : M x) (y_ : M y) (X_ : M X) (Y_ : M Y) :
  (Pairing x y) = (Pairing X Y) <-> (x = X /\ y = Y) \/ (x = Y /\ y = X).
Proof.
  split => [H | H].
  + specialize (couple x y x_ y_) as H1.
    specialize (couple X Y X_ Y_) as H2.
    move: H1; rewrite H; intro H1.
    move: H2; rewrite <- H; clear H; intro H2.
    induction H1 as [x_XY y_XY].
    induction H2 as [X_xy Y_xy].
    apply (pairing X Y x x_) in x_XY.
    apply (pairing X Y y y_) in y_XY.
    apply (pairing x y X X_) in X_xy.
    apply (pairing x y Y Y_) in Y_xy.
    induction x_XY as [xX | xY].
    - subst X.
      induction y_XY as [yX | yY].
      * subst y.
        induction Y_xy as [Yx | Yx].
          subst Y.
          by apply or_introl.
          subst Y.
          by apply or_introl.
      * subst Y.
        by apply or_introl.
    - subst Y.
      induction y_XY as [yX | yx].
      * subst X.
        by apply or_intror.
      * subst y.
        apply (@or_elim (X = x)) in X_xy.
        subst X.
        by apply or_introl.
  + induction H as [H | H].
    - induction H as [xX yY].
      by subst X Y.
    - induction H as [xY yX].
      subst X Y.
      by apply pairing_refl.
Qed.

Theorem op x y i (x_ : M x) (y_ : M y) (i_ : M i):
  i ∈ <|x,y|> <-> i = (Single x) \/ i = (Pairing x y).
Proof.
  by rewrite pairing.
Qed.

Theorem OP_eq x y X Y (x_ : M x) (y_ : M y) (X_ : M X) (Y_ : M Y) :
    (<|x,y|>) = (<|X,Y|>) <-> x = X /\ y = Y.
Proof.
  assert (xx_ : M (Single x)) by (by apply (pairing_set x x)).
  assert (xy_ : M (Pairing x y)) by (by apply (pairing_set x y)).
  assert (XX_ : M (Single X)) by (by apply (pairing_set X X)).
  assert (XY_ : M (Pairing X Y)) by (by apply (pairing_set X Y)).
  specialize (couple (Single x) (Pairing x y) xx_ xy_) as H1.
  specialize (couple (Single X) (Pairing X Y) XX_ XY_) as H2.
  induction H1 as [x_xOPy xy_xOPy].
  induction H2 as [X_XOPY XY_XOPY].
  unfold OP.
  split => [H | H].
  + rewrite H in x_xOPy.
    rewrite H in xy_xOPy.
    rewrite <- H in XY_XOPY.
    clear H.
    clear X_XOPY.
    apply  (pairing (Single x) (Pairing x y) (Pairing X Y)  XY_) in XY_XOPY.
    apply (pairing (Single X) (Pairing X Y) (Single x) xx_) in x_xOPy.
    apply (pairing (Single X) (Pairing X Y) (Pairing x y) xy_) in xy_xOPy.
    case (ExcludedMiddle (x = y)) as [xy | notxy].
    - subst y.
      induction xy_xOPy as [x_X | x_XY].
      * apply (single_single x X x_ X_) in x_X.
        apply (conj x_X).
        subst X.
        apply (@or_elim ((Pairing x Y) = (Single x)))in XY_XOPY.
        apply (pairing_single x Y x x_ Y_ x_) in XY_XOPY.
        symmetry.
        apply XY_XOPY.
      * apply (single_pairing x X Y x_ X_ Y_ ) in x_XY.
        induction x_XY as [Xx Yx].
        by symmetry in Yx.
    - induction xy_xOPy as [xy_X | xy_XY].
      * apply (pairing_single x y X x_ y_ X_) in xy_X.
        induction xy_X.
        subst y.
        case (notxy H).
      * apply (pairing_pairing x y X Y x_ y_ X_ Y_) in xy_XY.
        induction xy_XY as [H | H].
          by induction H as [R L].
          induction H as [xY yX].
          subst X Y.
          induction x_xOPy as [x_y | x_yx].
            apply (single_single x y x_ y_) in x_y.
            apply (conj x_y).
            by symmetry.
            apply (single_pairing x y x x_ y_ x_) in x_yx.
            induction x_yx as [y_x _].
            by subst y.
 + induction H as [xX yY].
   by subst X Y.
Qed.

Theorem op_set X Y (X_ : M X) (Y_ : M Y) :
  M <|X,Y|>.
Proof.
  apply pairing_set.
  by apply pairing_set.
  by apply pairing_set.
Qed.

Theorem cap_comm x y :
  x ∩ y = y ∩ x.
Admitted.

Theorem cup_comm x y :
  x ∪ y = y ∪ x.
Admitted.

Theorem cap_assoc x y z :
  (x ∩ y) ∩ z = x ∪ (y ∪ z).
Admitted.

Theorem cup_assoc x y z :
  (x ∪ y) ∪ z = x ∪ (y ∪ z) .
Admitted.

Theorem union_pairing x y (x_ : M x) (y_ : M y):
  x ∪ y = ⊔ (Pairing x y).
Proof.
  apply equal => i.
  split => [H | H].
  + assert (i_ : M i) by (by exists (x ∪ y)) .
    apply cup in H.
    apply union.
    induction H as [ix | iy].
    - exists x.
      apply (conj ix).
      apply (pairing x y x).
      done.
      by apply or_introl.
    - exists y.
      apply (conj iy).
      apply (pairing x y y).
      done.
      by apply or_intror.
  + apply union in H.
    induction H as[u].
    induction H as [iu u_xy].
    apply pairing in u_xy.
    apply cup.
    induction u_xy as [ux | uy].
    - subst u.
      by apply or_introl.
    - subst u.
      by apply or_intror.
    - by exists (Pairing x y).
Qed.

Theorem caps_pairing x y (x_ : M x) (y_ : M y) :
  x ∩ y = ⊓ (Pairing x y).
Proof.
  apply equal => i.
  split => [H | H].
  + assert (i_ : M i) by (by exists (x ∩ y)).
    apply cap in H.
    induction H as [ix iy].
    apply caps.
    done.
    intros u Hu.
    apply pairing in Hu.
    induction Hu as [ux | uy].
    - by subst u.
    - by subst u.
    - by exists (Pairing x y).
  + assert (i_ : M i) by (by exists (⊓ (Pairing x y))).
    move : H.
    rewrite caps.
    intro.
    apply cap.
    split.
    - apply (H x).
      apply pairing.
      done.
      by apply or_introl.
    - apply (H y).
      apply pairing.
      done.
      by apply or_intror.
    - done.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Subtyping_inversion
        rules_inf2
        dunfield.

Require Import Omega.

Lemma open_dexp_eqn_aux :
                forall ee1 ee2 x n,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp_rec n (de_var_f x) ee1 = open_dexp_wrt_dexp_rec n (de_var_f x) ee2
       -> ee1 = ee2.
Proof.
  apply_mutual_ind dexp_mutind;
  apply_mutual_ind dexp_mutind;
  default_simp;
  try solve [eapply_first_hyp; eauto].
  omega.
Qed.

Lemma open_dexp_eqn : forall x ee1 ee2,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp ee1 (de_var_f x) = open_dexp_wrt_dexp ee2 (de_var_f x)
       -> ee1 = ee2.
Proof.
  intros x ee1 ee2 H H0 H1.
  unfold open_dexp_wrt_dexp in H1.
  pose proof open_dexp_eqn_aux.
  eauto.
Qed.

Lemma subtyping_completeness : forall A B,
    isub A B -> sub A B.
Proof.
  intros A B H.
  induction* H.
Qed.

(* completeness of typing with respect to the type system in ICFP 2016 *)
Theorem typing_completeness : forall G ee A e,
    ITyping G ee A e -> Etyping G e A /\ |e| = ee.
Proof with auto.
  intros G ee A e Typ.
  induction Typ...
  -
    split.
    eapply Etyp_abs.
    intros.
    forwards* [? ?]: H1 H2.
    auto_sub.
    auto_sub.
    simpl.
    pick fresh x for (union L (union (fv_dexp (|e|)) (fv_dexp ee))).
    forwards* [? ?]: H1.
    rewrite erasure_open in H3.
    simpl in H3.
    forwards*: open_dexp_eqn H3.
    congruence.
  -
    lets [HT1 Era1]: IHTyp1.
    lets [HT2 Era2]: IHTyp2.
    split*.
    simpl.
    congruence.
  -
    lets [HT1 Era1]: IHTyp1.
    lets [HT2 Era2]: IHTyp2.
    simpl.
    split...
    congruence.
  -
    destruct IHTyp.
    apply subtyping_completeness in H.
    split*.
Qed.


Require Import Preamble Preorder Poset Dcpo Sierpinski.

Set Primitive Projections.

Arguments proj1_sig {A P}.
Notation sval := proj1_sig.

(* Using the partial map classifier, via de Jong and Escardo. *)
Record L (A : Type) :=
  {defd : Σ;
   run :> defd → A}.

Arguments defd [A] _.
Arguments run [A] _.

Lemma L_ext : ∀ A (m n : L A) (p : defd m ≤ defd n) (q : defd n ≤ defd m), (∀ x, m x = n (p x)) → m = n.
Proof.
  move=> A [dm rm] [dn rn] //= p q h.
  have Q: dm = dn by apply: propext.
  dependent destruction Q.
  rewrite (_ : rm = rn) //.
  apply: funext => z.
  by rewrite (h z) (_ : p z = z).
Qed.

Section Lift.
  Context (A : Dcpo.type).

  Definition L_lt (m n : L A) : Prop :=
    ∀ z : defd m, ∃ z' : defd n, m z ≤ n z'.

  Lemma L_ltR : ∀ m, L_lt m m.
  Proof.
    move=> m zm.
    by exists zm.
  Qed.

  Lemma L_ltT : ∀ m n o, L_lt m n → L_lt n o → L_lt m o.
  Proof.
    move=> m n o mn no=> zm.
    case: (mn zm)=> zn mn'.
    case: (no zn)=> zo no'.
    exists zo.
    apply: ltT.
    - by apply: mn'.
    - by [].
  Qed.

  HB.instance Definition L_preorder_axioms := PreorderOfType.Build (L A) L_lt L_ltR L_ltT.

  Lemma L_ltE (m n : L A) : m ≤ n → n ≤ m → m = n.
  Proof.
    move=> mn nm.
    apply: L_ext.
    - move=> zm.
      by case: (mn zm).
    - move=> zn.
      by case: (nm zn).
    - move=> zmn zm.
      case: (mn zm)=>zn ?.
      case: (nm zn)=>zm'?.
      apply: ltE.
      + by rewrite (_ : zmn zm = zn)//=.
      + rewrite (_ : zmn zm = zn)//.
        by rewrite (_ : zm = zm').
  Qed.

  HB.instance Definition L_poset_axioms := PosetOfPreorder.Build (L A) L_ltE.

  Lemma L_lt_pi1 {m n : L A} : m ≤ n → defd m → defd n.
  Proof.
    move=> mn zm.
    by case: (mn zm).
  Qed.

  Lemma L_lt_pi2 {m n : L A} : m ≤ n → ∀ z z', m z ≤ n z'.
  Proof.
    move=> mn z z'.
    case: (mn z)=> zn.
    by rewrite (_ : zn = z').
  Qed.

  Section Lub.
    Context (F : Family (L A)) (dirF : is_directed F).

    Lemma directed_defd_fam : is_directed (push_fam (λ x : L A, defd x) F).
    Proof.
      split.
      - by case: (nonempty _ dirF).
      - move=> //= i j.
        case: (predirected _ dirF i j) => k [ik jk].
        exists k; split; move=>zFi.
        + by apply: (L_lt_pi1 ik).
        + by apply: (L_lt_pi1 jk).
    Qed.

    Section Candidate.
      Context (H : dlub (push_fam (λ x : L A, defd x) F) directed_defd_fam).

      Definition candidate_dlub_fam : Family A.
      Proof.
        unshelve esplit.
        - exact: ({i : fam_ix F | defd (F i)}).
        - move=> i.
          exact: F (sval i) (svalP i).
      Defined.

      Lemma candidate_dlub_fam_directed : is_directed candidate_dlub_fam.
      Proof.
        split.
        - move: H.
          apply: Σ_lub_elim=>//= i z.
          unshelve esplit=>//.
          by exists i.
        - move=> i j.
          case: (predirected _ dirF (sval i) (sval j))=> k [ik jk].
          unshelve esplit.
          + by exists k; case: (ik (svalP i)).
          + by split=>//=; apply: L_lt_pi2.
      Qed.

      Definition candidate_dlub : A.
      Proof. by apply: dlub candidate_dlub_fam_directed. Defined.

    End Candidate.

    Definition L_dlub : L A.
    Proof.
      unshelve esplit.
      - by apply: dlub directed_defd_fam.
      - by apply: candidate_dlub.
    Defined.

    Lemma L_dlub_is_lub : is_lub F L_dlub.
    Proof.
      split.
      - move=> i zi.
        unshelve esplit.
        + apply: Σ_lub_intro=>//.
          by exact: zi.
        + rewrite /L_dlub//=.
          rewrite /candidate_dlub//=.
          apply: ltT'.
          apply: lub_is_ub=>//.
          * by exists i.
          * rewrite /candidate_dlub_fam//=.
            by rewrite (_ :  (svalP (exist (λ i0 : fam_ix F, defd (F i0)) i zi)) = zi)//=.
      - move=>//= x xub.
        move/[dup]; apply: Σ_lub_elim=>//.
        move=> //= i zi z'.
        case: (xub i zi)=> zx h.
        exists zx.
        apply: lub_univ=>//=.
        move=> j.
        rewrite /candidate_dlub_fam//=.
        case: (xub (sval j) (svalP j))=> zx' h'.
        by rewrite (_ : zx = zx')//=.
    Qed.

    Lemma L_ltHasDLub : ∃ m : L A, is_lub F m.
    Proof. exists L_dlub; by apply: L_dlub_is_lub. Qed.

    Lemma L_dlub_rw : ∀ m : L A, is_lub F m → m = L_dlub.
    Proof. move=> m ?; by apply/lub_unique/L_dlub_is_lub. Qed.
  End Lub.

  Definition L_bot : L A.
  Proof. by exists False. Defined.

  Lemma L_bot_is_bot : is_bottom L_bot.
  Proof. by move=>?//=; case. Qed.

  Lemma L_has_bot : ∃ x : L A, is_bottom x.
  Proof. by exists L_bot; apply: L_bot_is_bot. Qed.

  HB.instance Definition L_dcpo_axioms := DcpoOfPoset.Build (L A) L_ltHasDLub.
  HB.instance Definition L_pointed_poset_axioms := PointedPosetOfPoset.Build (L A) L_has_bot.
End Lift.

Section Functor.

  Context {A B : Dcpo.type} (f : A → B) (fcont : is_continuous f).

  Definition fmap : L A → L B.
  Proof. by move=> x; exists (defd x) => z; apply/f/x. Defined.

  Lemma fmap_cont : is_continuous fmap.
  Proof.
    move=>/= F dirF x xlub; split.
    - move=> /= i; move=> zi.
      case: (lub_is_ub _ _ xlub i zi)=> zx h.
      exists zx.
      rewrite /fmap//=.
      by apply: cont_mono=>//.
    - move=> /= y yub.
      rewrite (L_dlub_rw _ _ _ x xlub).
      move/[dup]; apply: Σ_lub_elim=>//.
      move=> //= i zi z'.
      case: (yub i zi)=> zy h.
      exists zy.
      apply: lub_univ.
      + apply: fcont=>//.
        by apply: candidate_dlub_fam_directed.
      + move=> //= j.
        case: (yub (sval j) (svalP j))=> zy' h'.
        by rewrite (_ : zy = zy').
  Qed.

  (* TODO: fmap strict *)
End Functor.

Section Alg.
  Context (D : Dcppo.type).

  Definition alg_fam (x : L D) : Family D.
  Proof.
    exists (sum (defd x) True); case.
    + apply: x.
    + move=> _; exact: ⊥.
  Defined.

  Lemma alg_fam_dir (x : L D) : is_directed (alg_fam x).
  Proof.
    split.
    + by split=>//=; right.
    + case=> [z|[]]; case=> [z' | []];
      (unshelve esplit; first by (left + right)); split; try by [].
      by rewrite (_ : z = z').
  Qed.

  Definition alg : L D → D.
  Proof. by move=>x; apply/dlub/alg_fam_dir. Defined.

  Lemma alg_cont : is_continuous alg.
  Proof.
    move=>/= F dirF x xlub.
    rewrite /alg.
    split.
    - move=>/= i.
      apply: above_lub=>//.
      case=>// di//=.
      case: (lub_is_ub _ _ xlub i di)=> zx h.
      apply: ltT.
      + by apply: h.
      + by apply: (lub_is_ub (alg_fam x) (dlub (alg_fam x) (alg_fam_dir x)) _ (inl zx)).

    - move=> z zub /=.
      rewrite (L_dlub_rw _ _ _ x xlub).
      apply: above_lub=>//.
      case=>// /[dup]; apply: Σ_lub_elim=>//= i di u.
      rewrite /candidate_dlub.
      apply: lub_univ=>//.
      move=> //= j.
      apply: ltT'.
      + by apply: zub (sval j).
      + simpl.
        apply: ltT'.
        * apply: lub_is_ub=>//=.
          left.
          apply: svalP j.
        * by [].
  Qed.
End Alg.

Section Unit.
  Context {A : Dcpo.type}.
  Definition unit : A → L A.
  Proof. move=> a; exists ⊤ => _; exact: a. Defined.

  Lemma unit_cont : is_continuous unit.
  Proof.
    move=> F dirF x xlub; split.
    - move=> //=i; rewrite /unit; move=> //= zi.
      unshelve esplit=>//.
      apply: ltT'.
      + by apply: lub_is_ub xlub i.
      + by [].
    - move=> //= y.
      case: (nonempty F dirF)=> i z.
      move=> yub.
      case: (yub i)=> //=.
      + by rewrite Σ_top_rw.
      + move=> _ zy h zx.
        exists zy.
        rewrite /unit//=.
        apply: lub_univ.
        * by apply: xlub.
        * move=> j.
          case: (yub j)=> zy' //= h'.
          by rewrite (_ : zy = zy').
  Qed.
End Unit.

Section Monad.

  Definition bind {A B : Dcpo.type} (f : A -> L B) : L A -> L B :=
    alg _ \o (fmap f).

  Lemma bind_continuous {A B : Dcpo.type} (f : A → L B) (fcont : is_continuous f) : is_continuous (bind f).
  Proof.
    apply: cmp_cont.
    - apply: cont_mono.
      by apply: fmap_cont.
    - by apply: fmap_cont.
    - by apply: alg_cont.
  Qed.
End Monad.

Section UniversalProperty.

  Context (A : Dcpo.type) (C : Dcppo.type) (f : A → C) (fcont : is_continuous f).

  Definition univ_map : L A → C := alg _ \o fmap f.

  Lemma univ_map_cont : is_continuous univ_map.
  Proof.
    apply: cmp_cont.
    - by apply/cont_mono/fmap_cont.
    - by apply: fmap_cont.
    - by apply: alg_cont.
  Qed.

  Lemma univ_map_strict : univ_map ⊥ = ⊥.
  Proof.
    rewrite /univ_map /alg /fmap /=.
    apply: lub_unique=>//.
    rewrite /alg_fam /=.
    split=>//.
    case=> [+ |[]]//=.
    rewrite (_ : ⊥ = L_bot _) //.
    by apply/bottom_is_unique/L_bot_is_bot.
  Qed.

  Lemma univ_map_compute : ∀ x, univ_map (unit x) = f x.
  Proof.
    move=> x.
    rewrite /univ_map /unit /fmap /alg /=.
    apply: lub_unique=>//.
    split; first by case.
    move=> c cub.
    apply: ltT'.
    - by apply: cub; left; rewrite Σ_top_rw.
    - by [].
  Qed.

  Definition is_univ_map (h : L A → C) := is_continuous h ∧ (h ⊥ = ⊥) ∧ ∀ x, h (unit x) = f x.

  (** In order to prove that there is at most one map satisfying
  [is_univ_map], we are going to use the continuity of candidate
  universal maps with respect to the following directed family. *)
  Section Fam.
    Context (x : L A).
    Local Definition fam : Family (L A).
    Proof.
      exists (sum (defd x) True); case.
      - by move=>?; apply/unit/x.
      - move=> _; exact: ⊥.
    Defined.

    Local Lemma fam_dir : is_directed fam.
    Proof.
      split.
      - by split=>//; right.
      - case=> [z|[]]; case=> [z'|[]]; (unshelve esplit; first by (left + right)); split=>//.
        by rewrite (_ : z = z').
    Qed.

    Local Lemma fam_lub : is_lub fam x.
    Proof.
      split.
      - case=> [z|[]] //=.
        move=> z'.
        by exists z.
      - move=>/=y yub.
        move=> z.
        have u : (⊤ : Σ) by rewrite Σ_top_rw.
        case: (yub (inl z) u)=> z' //= h.
        by exists z'.
    Qed.
  End Fam.

  Lemma univ_map_unique : ∀ h h', is_univ_map h → is_univ_map h' → h = h'.
  Proof.
    move=> h h' [hcont [hstr hfac]] [h'cont [h'str h'fac]].
    apply: funext=>x.
    apply: lub_unique.
    - apply/hcont/fam_lub/fam_dir.
    - rewrite (_ : push_fam h (fam x) = push_fam h' (fam x)).
      + rewrite /push_fam; congr Build_Family.
        apply: funext; case=> [z|[]] /=.
        * by rewrite hfac h'fac.
        * by rewrite hstr h'str.
      + apply/h'cont/fam_lub/fam_dir.
  Qed.

  Lemma univ_map_is_univ_map : is_univ_map univ_map.
  Proof.
    split; [|split].
    - apply: univ_map_cont.
    - apply: univ_map_strict.
    - apply: univ_map_compute.
  Qed.

  Lemma universal_property : exists! f, is_univ_map f.
  Proof.
    exists univ_map.
    split.
    - apply: univ_map_is_univ_map.
    - by move=> ?; apply/univ_map_unique/univ_map_is_univ_map.
  Qed.
End UniversalProperty.


Require Import Coq.Reals.Rdefinitions.
Require Import ExtLib.Data.Fun.
Require Import Coq.Lists.List.
Require Import Coq.Reals.Reals.
Require Import Coq.micromega.Psatz.
Require Import ExtLib.Structures.Applicative.
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Logics.ILEmbed.
Require Import ChargeCore.Tactics.Tactics.
Require Import SLogic.Lifting.
Require Import SLogic.Logic.
Require Import SLogic.LTLNotation.
Require Import SLogic.Instances.
Require Import SLogic.BasicProofRules.
Require Import SLogic.Tactics.
Require Import SLogic.BoundingFunctions.

Section Robustness.

  Variable state : Type.
  (* Input cost - this quantifies the disturbance. *)
  Variable IC : StateVal state R.
  (* Output cost - this quantifies the deviation
     from the nominal behavior. *)
  Variable OC : StateVal state R.
  (* The StateVal tracking time. *)
  Variable t : StateVal state R.

  Record disturbance : Type :=
    { d : R;
      td : R }.

  Record dist_state : Type :=
  { ds : list disturbance }.

  Local Open Scope LTL_scope.

  Definition dist (gamma : R -> R)
    : StateVal state disturbance :=
    `Build_disturbance (`gamma (`Rabs IC)) t.

  Definition init_dist (gamma : R -> R)
    : StateProp (dist_state * state) :=
    (fst#ds) `= snd#(dist gamma) `:: pure List.nil.

  Definition acc_dist (gamma : R -> R)
    : ActionProp (dist_state * state) :=
    (fst#ds)! `= (snd#(dist gamma))! `:: !fst#ds.

  Definition max_R : list R -> R :=
    fold_right Rmax 0%R.

  Definition flip {A B C} (f : A -> StateVal B C)
    : StateVal B (A -> C) :=
    fun b a => f a b.

  Definition bounded (mu : R -> R -> R) (rho : R)
    : StateProp (dist_state * state) :=
    snd#OC `<=
    `max_R
    (lift2 (@map disturbance R)
           (flip (fun p =>
                    (`mu (pure p.(d))
                      (snd#t `- (pure p.(td)))%R)))
           fst#ds)
    `+ (pure rho).

  (* The bounds on the functions (K, KL, KLD) are
     meaningless unless the time [StateVal] is
     reasonable. *)
  Definition sensible_time : TraceProp state :=
    [pure R0 `<= !t] //\\ [][!t `<= t!].

  Definition mu_gamma_rho_robust
             ( mu : R -> R -> R) (gamma : R -> R) (rho : R)
    : TraceProp (dist_state * state) :=
    [!(init_dist gamma)] //\\
    [][acc_dist gamma //\\ !(bounded mu rho)].

  (* This is the definition of robustness from the
     Tabuada paper. The property sensible_time
     appear explicitly in our definition of [robust],
     while in the Tabuada paper, this appear in the
     model of cyber-physical systems. *)
  Definition robust : TraceProp state :=
    sensible_time //\\
    Exists gamma : R -> R,   embed (K_fun gamma) //\\
    Exists mu : R -> R -> R, embed (KLD_fun mu)  //\\
    Exists rho : R,          embed (0 <= rho)%R  //\\
      TExists dist_state ,
         mu_gamma_rho_robust mu gamma rho.

  (* Now we write a definition of robustness that is
     equivalent to the Tabuada one, but easier to
     work with. *)

  (* For the equivalent definition of robustness,
     we only need to store a single pair of disturbance
     and time rather than a list of pairs. *)

  Definition dist2 (mu : R -> R -> R) (gamma : R -> R)
    : StateVal state R :=
    `mu (`gamma (`Rabs IC)) `R0.

  Definition init_dist2 (mu : R -> R -> R) (gamma : R -> R)
    : StateProp (disturbance * state) :=
    fst#d `= snd#(dist2 mu gamma) //\\
    fst#td `= snd#t.

  (* I don't think we actually need to store the value
     of td here. We should look into removing it. *)
  Definition acc_dist2 (mu : R -> R -> R) (gamma : R -> R)
    : ActionProp (disturbance * state) :=
    let prev := `mu (!(fst#d)) (((snd#t)! `- !(snd#t))) in
    let new := snd#(dist2 mu gamma)! in
    (new `<= prev -->>
       ((fst#d)! `= prev //\\ (fst#td)! `= !(fst#td))) //\\
    (prev `< new -->>
       ((fst#d)! `= new //\\ (fst#td)! `= !(snd#t))).

  Definition bounded2 (rho : R)
    : StateProp (disturbance * state) :=
    snd#OC `<= fst#d `+ `rho.

  Definition mu_gamma_rho_robust2
             ( mu : R -> R -> R) (gamma : R -> R) (rho : R)
    : TraceProp (disturbance * state) :=
    [!(init_dist2 mu gamma)] //\\
    [][acc_dist2 mu gamma //\\ !(bounded2 rho)].

  Definition robust2 : TraceProp state :=
    sensible_time //\\
    Exists gamma : R -> R,   embed (K_fun gamma) //\\
    Exists mu : R -> R -> R, embed (KLD_fun mu)  //\\
    Exists rho : R,          embed (0 <= rho)%R  //\\
      TExists disturbance ,
          mu_gamma_rho_robust2 mu gamma rho.

  Definition IndInv (mu : R -> R -> R) (gamma : R -> R)
    : StateProp (list disturbance * disturbance * state) :=
    lift2 (@List.Forall _)
      (flip (fun p => pure 0 `<= pure p.(d) //\\
                      pure 0 `<= pure p.(td) //\\
                      pure p.(td) `<= snd#t)%R)
      (snd#(dist gamma) `:: fst#fst) //\\
    fst#snd#d `=
    lift1 max_R
    (lift2 (@map disturbance R)
           (flip (fun p =>
                    (`mu (pure p.(d))
                      (snd#t `- (pure p.(td)))%R)))
           (snd#(dist gamma) `:: fst#fst)).

  Lemma max_R_bound :
    forall b,
      (b <= 0)%R ->
      forall l,
        List.Forall (Rle b) l ->
        (b <= max_R l)%R.
  Proof.
    induction l.
    { auto. }
    { simpl. intros. inversion H0.
      unfold Rmax. destruct_ite; auto. }
  Qed.

  Lemma max_R_strict_increasing :
    forall f,
      strict_increasing_bound f R0 ->
      f R0 = R0 ->
      forall l,
        List.Forall (Rle R0) l ->
        f (max_R l) = max_R (map f l).
  Proof.
    induction l.
    { auto. }
    { simpl in *. intros. inversion H1.
      rewrite <- IHl; auto.
      unfold strict_increasing_bound in H.
      unfold Rmax. repeat destruct_ite; try reflexivity.
      { destruct r.
        { specialize (H a (max_R l)). psatzl R. }
        { subst. reflexivity. } }
      { destruct r; auto.
        specialize (H (max_R l) a).
        apply max_R_bound in H5; psatzl R. } }
  Qed.

  (* TODO: Move *)
  Lemma map_ext_strong :
    forall (A B : Type) (f g : A -> B) (l : list A),
      (forall a : A, List.In a l -> f a = g a) ->
      map f l = map g l.
  Proof.
    induction l.
    { auto. }
    { simpl. intros.
      rewrite H; [ rewrite IHl; [ reflexivity | ] | ].
      { intros. apply H; auto. }
      { auto. } }
  Qed.

  Theorem robust2_robust :
    robust2 |-- robust.
  Proof.
    unfold robust2, robust.
    repeat rewrite landC with (P:=sensible_time).
    repeat (repeat rewrite landexistsD;
            apply lexists_lentails_m; red; intros;
            repeat rewrite landA;
            charge_revert; apply embedPropL; intros;
            charge_intros; charge_split;
            [ apply embedPropR; assumption | ]).
    repeat rewrite landC with (Q:=sensible_time).
    repeat rewrite trace_prop_land_texists.
    match goal with
    |- TExists _ , ?P |-- _ =>
    rewrite (add_history P snd#(dist a))
    end.
    rewrite texists_texists.
    eapply refinement_mapping
    with (f:=fun st => Build_dist_state
                         (List.cons (dist a (snd st))
                                    (fst (fst st)))).
    unfold sensible_time, mu_gamma_rho_robust,
    mu_gamma_rho_robust2. simpl CoFunctor.cofmap.
    rewrite_focusT.
    charge_split; [ charge_assumption | charge_split ].
    { reason_action_tac.
      Local Transparent ILInsts.ILFun_Ops ILInsts.ILPre_Ops.
      unfold focusA, focusS. simpl.
      destruct pre_st as [[pre_hist [pre_d pre_t]] pre_st].
      intros. compute. compute in H6. congruence. }
    { charge_assert ([][!(IndInv a0 a)]).
      { eapply discrete_induction.
        { clear_not_always. repeat rewrite always_and.
          charge_assumption. }
        { reason_action_tac.
          Local Transparent ILInsts.ILFun_Ops
                ILInsts.ILPre_Ops.
          Local Opaque Rabs Rle.
          unfold focusA, focusS. simpl.
          destruct pre_st
            as [[pre_hist [pre_d pre_t]] pre_st].
          destruct post_st
            as [[post_hist [post_d post_t]] post_st].
          unfold pre, IndInv, max_R, init_dist2. simpl.
          intros. rewrite H6. compute. compute in *.
          split.
          { constructor; [ | constructor ].
            split.
            { apply K_fun_pos;
              [assumption | apply Rabs_pos]. }
            { psatzl R. } }
          { destruct H4. rewrite H4.
            rewrite Rplus_opp_r.
            destruct_ite.
            { destruct r; [ | congruence ].
              pose proof (KLD_fun_pos
                            _ H0 (a (Rabs (IC pre_st))) R0)
                as HKLD.
              pose proof (K_fun_pos _ H (Rabs (IC pre_st)))
                as HK.
              pose proof (Rabs_pos (IC pre_st)).
              specialize_arith_hyp HK.
              specialize_arith_hyp HKLD.
              psatzl R. }
            { reflexivity. } } }
        { charge_clear. apply always_tauto.
          rewrite next_starts_pre. repeat rewrite curry.
          repeat rewrite starts_impl. apply starts_tauto.
          unfold focusA, focusS. simpl. intros pre_st post_st.
          destruct pre_st
            as [[pre_hist [pre_d pre_t]] pre_st].
          destruct post_st
            as [[post_hist [post_d post_t]] post_st].
          unfold pre, post. simpl. intros.
          unfold acc_dist2, IndInv, PreFun.compose,
          _liftn, flip, Rmax, pre, post in *.
          split.
          { simpl in *. intuition. subst. inversion H7.
            constructor.
            { split.
              { compute; apply K_fun_pos;
                [assumption | apply Rabs_pos]. }
              { compute in *. psatzl R. } }
            { constructor.
              { compute; split.
                { apply K_fun_pos;
                  [assumption | apply Rabs_pos]. }
                { compute in *; psatzl R. } }
              { eapply Forall_impl. 2: apply H11.
                simpl. intros. psatzl R. } } }
          { cbv beta iota zeta delta
            - [ max_R map KLD_fun K_fun L_fun ] in *.
            intuition.
            assert (0 <= a (Rabs (IC pre_st)))%R
              as Ha.
            { apply K_fun_pos;
              [assumption | apply Rabs_pos]. }
            pose (f:=(fun x =>
                          a0 x
                             (t post_st + - t pre_st)%R)).
            assert (strict_increasing_bound f R0)
              as Hincr.
            { apply KLD_fun_increasing_nonneg; auto;
              psatzl R. }
            assert (f R0 = R0) as HfR0.
            { apply KLD_fun_0; auto; psatzl R. }
            destruct (Rle_dec
                        (dist2 a0 a post_st)
                        (a0 pre_d (t post_st - t pre_st)))%R.
            { intuition. subst.
              pose proof (max_R_strict_increasing f)
                as Hmax_R_f. subst f.
              rewrite Hmax_R_f; auto; rewrite Hmax_R_f in r;
              auto; clear Hmax_R_f.
              { rewrite map_map in *. simpl in *.
                unfold dist2 in *.
                repeat rewrite Rplus_opp_r in *.
                match goal with
                | [ |- _ = Rmax ?e1 ?e2 ] =>
                  rewrite (Rmax_right e1 e2)
                end.
                { f_equal.
                  { unfold KLD_fun in *. intuition.
                    specialize (H4 _ Ha).
                    intuition congruence. }
                  { f_equal. apply map_ext_strong. intros.
                    inversion H7.
                    rewrite Forall_forall in H11.
                    specialize (H11 _ H3). destruct a2.
                    unfold KLD_fun in *. intuition.
                    specialize (H13 d0 H8). intuition.
                    rewrite <- H18; try psatzl R. f_equal.
                    psatzl R. } }
                { cbv beta iota zeta delta
                  - [ max_R Rmax map KLD_fun K_fun L_fun ]
                    in r.
                  eapply Rle_trans; eauto. right.
                  f_equal.
                  { unfold KLD_fun in *. intuition.
                    specialize (H4 _ Ha).
                    intuition congruence. }
                  { f_equal. apply map_ext_strong. intros.
                    inversion H7.
                    rewrite Forall_forall in H11.
                    specialize (H11 _ H3). destruct a2.
                    unfold KLD_fun in *. intuition.
                    specialize (H13 d0 H8). intuition.
                    rewrite <- H18; try psatzl R. f_equal.
                    psatzl R. } } }
              { apply Forall_forall. intros.
                apply in_map_iff in H3. destruct H3.
                destruct H3.
                rewrite Forall_forall in H7.
                specialize (H7 x0 H4). subst.
                destruct x0.
                apply KLD_fun_pos; auto; psatzl R. }
              { apply Forall_forall. intros.
                apply in_map_iff in H3. destruct H3.
                destruct H3.
                rewrite Forall_forall in H7.
                specialize (H7 x0 H4). subst.
                destruct x0.
                apply KLD_fun_pos; auto; psatzl R. }
              { apply Forall_forall. intros.
                apply in_map_iff in H3. destruct H3.
                destruct H3.
                rewrite Forall_forall in H7.
                specialize (H7 x0 H4). subst.
                destruct x0.
                apply KLD_fun_pos; auto; psatzl R. } }
            { compute in n. specialize_arith_hyp H10.
              intuition. subst. simpl. rewrite Rmax_left.
              { rewrite Rplus_opp_r. reflexivity. }
              { rewrite Rplus_opp_r. apply Rnot_le_lt in n.
                left. eapply Rle_lt_trans; eauto. right.
                pose proof (max_R_strict_increasing f)
                as Hmax_R_f. subst f.
                rewrite Hmax_R_f; auto; clear Hmax_R_f.
                { rewrite map_map. simpl in *.
                f_equal.
                { unfold KLD_fun in *. intuition.
                  specialize (H4 _ Ha).
                  destruct H4. rewrite <- H4.
                  { f_equal. psatzl R. }
                  { psatzl R. }
                  { psatzl R. } }
                { f_equal. apply map_ext_strong. intros.
                  inversion H7.
                  rewrite Forall_forall in H11.
                  specialize (H11 _ H3). destruct a2.
                  unfold KLD_fun in *. intuition.
                  specialize (H13 d0 H10). intuition.
                  rewrite <- H18; try psatzl R. f_equal.
                  psatzl R. } }
                { apply Forall_forall. intros.
                  apply in_map_iff in H3. destruct H3.
                  destruct H3.
                  rewrite Forall_forall in H7.
                  specialize (H7 x0 H4). subst.
                  destruct x0.
                  apply KLD_fun_pos;
                    auto; psatzl R. } } } } } }
      { charge_intros. clear_not_always.
        repeat rewrite always_and. charge_revert.
        rewrite <- always_impl. apply always_tauto.
        repeat rewrite curry. reason_action_tac.
        unfold focusA. simpl.
        destruct pre_st
          as [[pre_hist [pre_d pre_t]] pre_st].
        destruct post_st
          as [[post_hist [post_d post_t]] post_st].
        unfold pre, post. simpl. intros.
        split.
        { unfold acc_dist. simpl. subst. reflexivity. }
        { unfold bounded, bounded2, IndInv in *.
          cbv beta iota zeta delta
          - [ max_R Rmax map KLD_fun K_fun L_fun ] in *.
          psatzl R. } } }
  Qed.

  Theorem robust2_no_texists :
    forall P,
      P |-- sensible_time ->
      (exists gamma mu rho,
          K_fun gamma /\ KLD_fun mu /\ (0 <= rho)%R /\
          focusT snd P //\\ [!(init_dist2 mu gamma)]
          //\\ [][acc_dist2 mu gamma] |--
          [][!(bounded2 rho)]) ->
      P |-- robust2.
  Proof.
    intros P Ht H. unfold robust2.
    destruct H
      as [gamma [mu [rho [Hmu [Hgamma [Hrho Hrobust]]]]]].
    charge_split; [ assumption | ].
    apply lexistsR with (x:=gamma);
      charge_split; [ apply embedPropR; assumption | ].
    apply lexistsR with (x:=mu);
      charge_split; [ apply embedPropR; assumption | ].
    apply lexistsR with (x:=rho);
      charge_split; [ apply embedPropR; assumption | ].
  Admitted.

End Robustness.


(** * monoid: typed structures, from ordered monoids to residuated Kleene allegories *)

(** We define here all (typed) structures ranging from partially
   ordered monoids to residuated Kleene allegories *)

Require Export lattice.

(** * Monoid operations *)

(** The following class packages an ordered typed monoid (i.e., a
   category enriched over a partial order) together with all kinds of
   operations it can come with: iterations, converse, residuals. We
   use dummy values when working in structures lacking some
   operations.

   Like for [lattice.ops], we use a Class but we mainly exploit
   Canonical structures inference mechanism. *)

Universe M.

Class ops := mk_ops {
  ob: Type@{M};                     (** objects of the category *)
  mor: ob -> ob -> lattice.ops; (** morphisms (each homset is a partially ordered structure) *)
  dot: forall n m p, mor n m -> mor m p -> mor n p; (** composition  *)
  one: forall n, mor n n;                           (** identity *)
  itr: forall n, mor n n -> mor n n;                (** strict iteration (transitive closure) *)
  str: forall n, mor n n -> mor n n;                (** Kleene star (reflexive transitive closure) *)
  cnv: forall n m, mor n m -> mor m n;              (** converse (transposed relation) *)
  ldv: forall n m p, mor n m -> mor n p -> mor m p; (** left residual/factor/division  *)
  rdv: forall n m p, mor m n -> mor p n -> mor p m  (** right residual/factor/division *)
}.
Coercion mor: ops >-> Funclass.
Arguments ob : clear implicits.

(** Hints for simpl *)
Arguments mor {ops} n m / : simpl nomatch.
Arguments dot {ops} n m p (x y)%ra / : simpl nomatch.
Arguments one {ops} n / : simpl nomatch.
Arguments itr {ops} n (x)%ra / : simpl nomatch.
Arguments str {ops} n (x)%ra / : simpl nomatch.
Arguments cnv {ops} n m (x)%ra / : simpl nomatch.
Arguments ldv {ops} n m p (x y)%ra / : simpl nomatch.
Arguments rdv {ops} n m p (x y)%ra / : simpl nomatch.

(** Notations (note that "+" and "∩" are just specialisations of the
   notations "⊔" and "⊓", when these operations actually come
   from a monoid) *)

(**
   ∩ : \cap (company-coq) or INTERSECTION (0x2229)

   ⋅ : \cdot (company coq) or DOT OPERATOR (0x22c5)
*)

Notation "x ⋅ y" := (dot _ _ _ x y) (left associativity, at level 25, format "x ⋅ y"): ra_terms.
Notation "x + y" := (@cup (mor _ _) x y) (left associativity, at level 50): ra_terms.
Notation "x ∩ y" := (@cap (mor _ _) x y) (left associativity, at level 40): ra_terms.
Notation "1" := (one _): ra_terms.
Notation zer n m := (@bot (mor n m)).
Notation top' n m := (@top (mor n m)) (only parsing).
Notation "0" := (zer _ _): ra_terms.
Notation "x °"  := (cnv _ _ x) (left associativity, at level 5, format "x °"): ra_terms.
Notation "x ^+" := (itr _ x)   (left associativity, at level 5, format "x ^+"): ra_terms.
Notation "x ^*" := (str _ x)   (left associativity, at level 5, format "x ^*"): ra_terms.
Notation "x -o y" := (ldv _ _ _ x y) (right associativity, at level 60): ra_terms.
Notation "y o- x" := (rdv _ _ _ x y) (left associativity, at level 61): ra_terms.

(** Like for [lattice.ops], we declare most projections as Opaque for
   typeclass resolution, to save on compilation time. *)
#[export] Typeclasses Opaque (* ob mor *) dot one str cnv ldv rdv.

Set Implicit Arguments.
Unset Strict Implicit.

(** * Monoid laws (axioms) *)

(** [laws l X] provides the laws corresponding to the various
   operations of [X], provided these operations belong to the level
   [l]. For instance, the specification of Kleene star ([str]) is
   available only if the level contains [STR].

   Note that [l] indirectly specifies which lattice operations are
   available on each homset, via the field [lattice_laws]. We add
   additional properties when needed (e.g., [dotplsx_]: composition
   ([dot]) distribute over sums ([pls]), provided there are sums)

   The partially ordered categorical structure (leq,weq,dot,one) is
   always present.

   Like for [lattices.laws], some axioms end with an underscore,
   either because they can be strengthened to an equality (e.g.,
   [cnvdot_]), or because they become derivable in presence of other
   axiomes (e.g., [dotx1_]), or both (e.g., [dotplsx_]).

   Unlike for operations ([ops]), laws are actually inferred by
   typeclass resolution. *)

Class laws (l: level) (X: ops) := {
  lattice_laws:>       forall n m, lattice.laws l (X n m);
  (** po-monoid laws *)
  dotA:                forall n m p q (x: X n m) y (z: X p q), x⋅(y⋅z) ≡ (x⋅y)⋅z;
  dot1x:               forall n m (x: X n m), 1⋅x ≡ x;
  dotx1_:              CNV ≪ l \/ forall n m (x: X m n), x⋅1 ≡ x;
  dot_leq_:            DIV ≪ l \/ forall n m p, Proper (leq ==> leq ==> leq) (dot n m p);
  (** slo-monoid laws (distribution of ⋅ over + and 0) *)
  dotplsx_  `{CUP ≪ l}: DIV ≪ l \/ forall n m p (x y: X n m) (z: X m p), (x+y)⋅z ≦ x⋅z+y⋅z;
  dotxpls_  `{CUP ≪ l}: DIV ≪ l \/ CNV ≪ l \/ forall n m p (x y: X m n) (z: X p m), z⋅(x+y) ≦ z⋅x+z⋅y;
  dot0x_    `{BOT ≪ l}: DIV ≪ l \/ forall n m p (x: X m p), 0⋅x ≦ zer n p;
  dotx0_    `{BOT ≪ l}: DIV ≪ l \/ CNV ≪ l \/ forall n m p (x: X p m), x⋅0 ≦ zer p n;
  (** converse laws *)
  cnvdot_   `{CNV ≪ l}: forall n m p (x: X n m) (y: X m p), (x⋅y)° ≦ y°⋅x°;
  cnv_invol `{CNV ≪ l}: forall n m (x: X n m), x°° ≡ x;
  cnv_leq   `{CNV ≪ l}:>forall n m, Proper (leq ==> leq) (cnv n m);
  cnv_ext_  `{CNV ≪ l}: CAP ≪ l \/ forall n m (x: X n m), x ≦ x⋅x°⋅x;
  (** star laws *)
  str_refl  `{STR ≪ l}: forall n (x: X n n), 1 ≦ x^*;
  str_cons  `{STR ≪ l}: forall n (x: X n n), x⋅x^* ≦ x^*;
  str_ind_l `{STR ≪ l}: forall n m (x: X n n) (z: X n m), x⋅z ≦ z -> x^*⋅z ≦ z;
  str_ind_r_`{STR ≪ l}: DIV ≪ l \/ CNV ≪ l \/ forall n m (x: X n n) (z: X m n), z⋅x ≦ z -> z⋅x^* ≦ z;
  itr_str_l `{STR ≪ l}: forall n (x: X n n), x^+ ≡ x⋅x^*;
  (** modularity law *)
  capdotx   `{AL ≪ l}: forall n m p (x: X n m) (y: X m p) (z: X n p), (x⋅y) ∩ z ≦ x⋅(y ∩ (x°⋅z));
  (** left and right residuals *)
  ldv_spec  `{DIV ≪ l}: forall n m p (x: X n m) (y: X n p) z, z ≦ x -o y <-> x⋅z ≦ y;
  rdv_spec  `{DIV ≪ l}: forall n m p (x: X m n) (y: X p n) z, z ≦ y o- x <-> z⋅x ≦ y
}.

(** * Basic properties *)

#[export] Instance dot_leq `{laws}: forall n m p, Proper (leq ==> leq ==> leq) (dot n m p).
Proof.
  destruct dot_leq_. 2: assumption.
  intros n m p x x' Hx y y' Hy.
  rewrite <-rdv_spec, Hx, rdv_spec.
  rewrite <-ldv_spec, Hy, ldv_spec.
  reflexivity.
Qed.

#[export] Instance dot_weq `{laws} n m p: Proper (weq ==> weq ==> weq) (dot n m p) := op_leq_weq_2.

(** ** Basic properties of the converse operation *)

#[export] Instance cnv_weq `{laws} `{CNV ≪ l} n m: Proper (weq ==> weq) (cnv n m) := op_leq_weq_1.

Lemma cnv_leq_iff `{laws} `{CNV ≪ l} n m (x y: X n m): x° ≦ y° <-> x ≦ y.
Proof. split. intro E. apply cnv_leq in E. now rewrite 2cnv_invol in E. apply cnv_leq. Qed.
Lemma cnv_leq_iff' `{laws} `{CNV ≪ l} n m (x: X n m) y: x ≦ y° <-> x° ≦ y.
Proof. now rewrite <- cnv_leq_iff, cnv_invol. Qed.

Lemma cnv_weq_iff `{laws} `{CNV ≪ l} n m (x y: X n m): x° ≡ y° <-> x ≡ y.
Proof. now rewrite 2weq_spec, 2cnv_leq_iff. Qed.
Lemma cnv_weq_iff' `{laws} `{CNV ≪ l} n m (x: X n m) y: x ≡ y° <-> x° ≡ y.
Proof. now rewrite <-cnv_weq_iff, cnv_invol. Qed.

(** simple tactic to move converse from one side to the other of an (in)equation *)
Ltac cnv_switch := first [
  rewrite cnv_leq_iff |
  rewrite cnv_leq_iff' |
  rewrite <-cnv_leq_iff' |
  rewrite <-cnv_leq_iff |
  rewrite cnv_weq_iff |
  rewrite cnv_weq_iff' |
  rewrite <-cnv_weq_iff' |
  rewrite <-cnv_weq_iff ].

Lemma cnvdot `{laws} `{CNV ≪ l} n m p (x: X n m) (y: X m p): (x⋅y)° ≡ y°⋅x°.
Proof. apply antisym. apply cnvdot_. cnv_switch. now rewrite cnvdot_, 2cnv_invol. Qed.

Lemma cnv1 `{laws} `{CNV ≪ l} n: (one n)° ≡ 1.
Proof. rewrite <- (dot1x (1°)). cnv_switch. now rewrite cnvdot, cnv_invol, dot1x. Qed.

Lemma cnvpls `{laws} `{CNV+CUP ≪ l} n m (x y: X n m): (x+y)° ≡ x°+y°.
Proof.
  apply antisym.
  cnv_switch. apply leq_cupx; cnv_switch; lattice.
  apply leq_cupx; cnv_switch; lattice.
Qed.

Lemma cnvcap `{laws} `{AL ≪ l} n m (x y: X n m): (x ∩ y)° ≡ x° ∩ y°.
Proof.
  apply antisym.
  apply leq_xcap; apply cnv_leq; lattice.
  cnv_switch. apply leq_xcap; cnv_switch; lattice.
Qed.

Lemma cnv0 `{laws} `{CNV+BOT ≪ l} n m: (zer n m)° ≡ 0.
Proof. apply antisym; [cnv_switch|]; apply leq_bx. Qed.

Lemma cnvtop `{laws} `{CNV+TOP ≪ l} n m: (top: X n m)° ≡ top.
Proof. apply antisym; [|cnv_switch]; apply leq_xt. Qed.

Lemma cnvneg `{laws} `{CNV+BL ≪ l} n m (x: X n m): (neg x)° ≡ neg (x°).
Proof.
  apply neg_unique.
  rewrite <-cnvpls, cupC, cupneg. now rewrite cnvtop.
  rewrite <-cnvcap, capC, capneg. now rewrite cnv0.
Qed.

(** ** Basic properties of composition *)

Lemma dotx1 `{laws} n m (x: X m n): x⋅1 ≡ x.
Proof. destruct dotx1_; trivial. cnv_switch. now rewrite cnvdot, cnv1, dot1x. Qed.

Lemma dotplsx `{laws} `{CUP ≪ l} n m p (x y: X n m) (z: X m p): (x+y)⋅z ≡ x⋅z+y⋅z.
Proof.
  apply antisym. 2: apply leq_cupx; apply dot_leq; lattice.
  destruct dotplsx_ as [Hl|E]. 2: apply E.
  rewrite <-rdv_spec. apply leq_cupx; rewrite rdv_spec; lattice.
Qed.

Lemma dotxpls `{laws} `{CUP ≪ l} n m p (x y: X m n) (z: X p m): z⋅(x+y) ≡ z⋅x+z⋅y.
Proof.
  apply antisym. 2: apply leq_cupx; apply dot_leq; lattice.
  destruct dotxpls_ as [Hl|[Hl|E]].
   rewrite <-ldv_spec. apply leq_cupx; rewrite ldv_spec; lattice.
   cnv_switch. rewrite cnvpls,3cnvdot,cnvpls. apply weq_leq, dotplsx.
  apply E.
Qed.

Lemma dot0x `{laws} `{BOT ≪ l} n m p (x: X m p): 0⋅x ≡ zer n p.
Proof.
  apply antisym. 2: apply leq_bx.
  destruct dot0x_ as [Hl|E]. 2: apply E.
  rewrite <-rdv_spec. apply leq_bx.
Qed.

Lemma dotx0 `{laws} `{BOT ≪ l} n m p (x: X p m): x⋅0 ≡ zer p n.
Proof.
  apply antisym. 2: apply leq_bx.
  destruct dotx0_ as [Hl|[Hl|E]].
   rewrite <-ldv_spec. apply leq_bx.
   cnv_switch. rewrite cnvdot,2cnv0. apply weq_leq, dot0x.
  apply E.
Qed.

Lemma dotxcap `{laws} `{CAP ≪ l} n m p (x: X n m) (y z: X m p):
  x ⋅ (y ∩ z) ≦ (x⋅y) ∩ (x⋅z).
Proof. apply leq_xcap; apply dot_leq; lattice. Qed.

Lemma cnv_ext `{laws} `{CNV ≪ l} n m (x: X n m): x ≦ x⋅x°⋅x.
Proof.
  destruct cnv_ext_; trivial.
  transitivity ((x⋅1) ∩ x). rewrite dotx1. lattice.
  rewrite capdotx, <-dotA. apply dot_leq; lattice.
Qed.

Lemma capxdot `{laws} `{AL ≪ l} n m p (x: X m n) (y: X p m) (z: X p n):
  (y⋅x) ∩ z ≦ (y ∩ (z⋅x°))⋅x.
Proof. cnv_switch. now rewrite cnvdot, 2cnvcap, 2cnvdot, capdotx. Qed.

(** ** Basic properties of left division *)

(** only those properties that are required to derive [str_ind_r] out
   of divisions, see module [factor] for other properties *)

Lemma ldv_cancel `{laws} `{DIV ≪ l} n m p (x: X n m) (y: X n p): x⋅(x -o y) ≦ y.
Proof. now rewrite <-ldv_spec. Qed.

Lemma ldv_trans `{laws} `{DIV ≪ l} n m p q (x: X n m) (y: X n p) (z: X n q):
  (x -o y)⋅(y -o z) ≦ x -o z.
Proof. now rewrite ldv_spec, dotA, 2ldv_cancel. Qed.

Lemma leq_ldv `{laws} `{DIV ≪ l} n m (x y: X n m): x ≦ y <-> 1 ≦ x -o y.
Proof. now rewrite ldv_spec, dotx1. Qed.

Lemma ldv_xx `{laws} `{DIV ≪ l} n m (x: X n m): 1 ≦ x -o x.
Proof. now rewrite <-leq_ldv. Qed.

#[export] Instance ldv_leq `{laws} `{DIV ≪ l} n m p: Proper (leq --> leq ++> leq) (ldv n m p).
Proof. intros x x' Hx y y' Hy. now rewrite ldv_spec, <-Hx, <-Hy, <-ldv_spec. Qed.

#[export] Instance ldv_weq `{laws} `{DIV ≪ l} n m p: Proper (weq ==> weq ==> weq) (ldv n m p).
Proof. simpl. setoid_rewrite weq_spec. split; apply ldv_leq; tauto. Qed.

Lemma cnvldv `{laws} `{CNV+DIV ≪ l} n m p (x: X n m) (y: X n p): (x -o y)° ≡ y° o- x°.
Proof.
  apply from_below. intro z.
  cnv_switch. rewrite ldv_spec.
  cnv_switch. rewrite cnvdot, cnv_invol.
  now rewrite rdv_spec.
Qed.

(** ** Schroeder rules  *)
Lemma Schroeder_  `{laws} `{BL+CNV ≪ l} n m p (x : X n m) (y : X m p) (z : X n p):
  x°⋅!z ≦ !y -> x⋅y ≦ z.
Proof.
  intro E. apply leq_cap_neg in E. rewrite negneg in E.
  apply leq_cap_neg. now rewrite capdotx, capC, E, dotx0.
Qed.

Lemma Schroeder_l `{laws} `{BL+CNV ≪ l} n m p (x : X n m) (y : X m p) (z : X n p):
  x⋅y ≦ z <-> x°⋅!z ≦ !y.
Proof.
  split. 2: apply Schroeder_. intro.
  apply Schroeder_. now rewrite 2negneg, cnv_invol.
Qed.

(** ** Basic properties of Kleene star *)
(** (more properties in [kleene]) *)

Lemma str_ext `{laws} `{STR ≪ l} n (x: X n n): x ≦ x^*.
Proof. now rewrite <-str_cons, <-str_refl, dotx1. Qed.

Lemma str_ind_l' `{laws} `{STR ≪ l} n m (x: X n n) (y z: X n m): y ≦ z -> x⋅z ≦ z -> x^*⋅y ≦ z.
Proof. intro E. rewrite E. apply str_ind_l. Qed.

Lemma str_ind_l1 `{laws} `{STR ≪ l} n (x z: X n n): 1 ≦ z -> x⋅z ≦ z -> x^* ≦ z.
Proof. rewrite <-(dotx1 (x^*)). apply str_ind_l'. Qed.

#[export] Instance str_leq `{laws} `{STR ≪ l} n: Proper (leq ==> leq) (str n).
Proof.
  intros x y E. apply str_ind_l1. apply str_refl.
  rewrite E. apply str_cons.
Qed.

#[export] Instance str_weq `{laws} `{STR ≪ l} n: Proper (weq ==> weq) (str n) := op_leq_weq_1.

Lemma str_snoc `{laws} `{STR ≪ l} n (x: X n n): x^*⋅x ≦ x^*.
Proof. apply str_ind_l'. apply str_ext. apply str_cons. Qed.

Lemma str_unfold_l `{laws} `{KA ≪ l} n (x: X n n): x^* ≡ 1+x⋅x^*.
Proof.
  apply antisym. apply str_ind_l1. lattice.
  rewrite dotxpls. apply leq_cupx. rewrite <-str_refl. lattice.
  rewrite <-str_cons at 2. lattice.
  rewrite str_cons, (str_refl x). lattice.
Qed.

Lemma str_itr `{laws} `{KA ≪ l} n (x: X n n): x^* ≡ 1+x^+.
Proof. rewrite itr_str_l. apply str_unfold_l. Qed.

Lemma cnvstr_ `{laws} `{CNV+STR ≪ l} n (x: X n n): x^*° ≦ x°^*.
Proof.
  cnv_switch. apply str_ind_l1. now rewrite <-str_refl, cnv1.
  cnv_switch. rewrite cnvdot, cnv_invol. apply str_snoc.
Qed.

Lemma str_ldv_ `{laws} `{STR+DIV ≪ l} n m (x: X m n): (x -o x)^* ≦ x -o x.
Proof. apply str_ind_l1. apply ldv_xx. apply ldv_trans. Qed.

Lemma str_ind_r `{laws} `{STR ≪ l} n m (x: X n n) (z: X m n): z⋅x ≦ z -> z⋅x^* ≦ z.
Proof.
  destruct str_ind_r_ as [Hl|[Hl|?]]. 3: auto.
  - rewrite <-2ldv_spec. intro E. apply str_leq in E. rewrite E. apply str_ldv_.
  - intros. cnv_switch. rewrite cnvdot, cnvstr_.
    apply str_ind_l; cnv_switch; now rewrite cnvdot, 2cnv_invol.
Qed.

Lemma itr_move `{laws} `{STR ≪ l} n (x: X n n): x ⋅ x^* ≡ x^* ⋅ x.
Proof.
  apply antisym.
   rewrite <-dot1x, (str_refl x), dotA. apply str_ind_r. now rewrite str_snoc at 1.
   apply str_ind_l'. now rewrite <-str_refl, dotx1. now rewrite str_cons at 1.
Qed.

Lemma itr_str_r `{laws} `{STR ≪ l} n (x: X n n): x^+ ≡ x^* ⋅ x.
Proof. rewrite itr_str_l. apply itr_move. Qed.

(** * Subtyping / weakening *)

(** laws that hold at any level [h] hold for all level [k ≪ h]  *)
Lemma lower_laws {h k} {X} {H: laws h X} {le: k ≪ h}: laws k X.
Proof.
  constructor; [ intros; apply lower_lattice_laws | .. ];
    try solve [ apply H | intro; apply H; eauto using lower_trans ].
  right. apply dotx1.
  right. apply dot_leq.
  intro H'. right. intros. apply weq_leq. apply (lower_trans _ _ _ H') in le. apply dotplsx.
  intro H'. right. right. intros. apply weq_leq. apply (lower_trans _ _ _ H') in le. apply dotxpls.
  intro H'. right. intros. apply weq_leq. apply (lower_trans _ _ _ H') in le. apply dot0x.
  intro H'. right. right. intros. apply weq_leq. apply (lower_trans _ _ _ H') in le. apply dotx0.
  intro H'. right. intros. apply (lower_trans _ _ _ H') in le. apply cnv_ext.
  intro H'. right. right. apply (lower_trans _ _ _ H') in le. apply str_ind_r.
Qed.

(** * Reasoning by duality *)

(** dual monoid operations: we reverse all arrows (or morphisms), swap
   the arguments of [dot], and swap left and right residuals.

   Note that this corresponds to categorical duality, not to be
   confused with lattice duality, as defined in [lattice.dual]. *)
Definition dual (X: ops) := {|
  ob := ob X;
  mor n m := X m n;
  dot n m p x y := y⋅x;
  one := one;
  cnv n m := cnv m n;
  itr := itr;
  str := str;
  ldv := rdv;
  rdv := ldv
|}.
Notation "X ^op" := (dual X) (at level 1): ra_scope.

(** laws on a given structure can be transferred to the dual one *)
Lemma dual_laws l X (L: laws l X): laws l X^op.
Proof.
  constructor; simpl; repeat right; intros.
   apply lattice_laws.
   symmetry. apply dotA.
   apply dotx1.
   apply dot1x.
   now apply dot_leq.
   apply weq_leq, dotxpls.
   apply weq_leq, dotplsx.
   apply weq_leq, dotx0.
   apply weq_leq, dot0x.
   apply weq_leq, cnvdot.
   apply cnv_invol.
   now apply cnv_leq.
   rewrite dotA. apply cnv_ext.
   apply str_refl.
   apply str_snoc.
   now apply str_ind_r.
   now apply str_ind_l.
   apply itr_str_r.
   apply capxdot.
   apply rdv_spec.
   apply ldv_spec.
Qed.

(** this gives us a tactic to prove properties by categorical duality *)
Lemma dualize {h} {P: ops -> Prop} (L: forall l X, laws l X -> h ≪ l -> P X)
  {l X} {H: laws l X} {Hl:h ≪ l}: P X^op.
Proof. eapply L. apply dual_laws, H. assumption. Qed.

Ltac dual x := apply (dualize x).

(** the following are examples of the benefits of such dualities *)
#[export] Instance rdv_leq `{laws} `{DIV ≪ l} n m p: Proper (leq --> leq ++> leq) (rdv n m p).
Proof. dual @ldv_leq. Qed.

#[export] Instance rdv_weq `{laws} `{DIV ≪ l} n m p: Proper (weq ==> weq ==> weq) (rdv n m p).
Proof. dual @ldv_weq. Qed.

Lemma cnvrdv `{laws} `{CNV+DIV ≪ l} n m p (x: X m n) (y: X p n): (y o- x)° ≡ x° -o y°.
Proof. dual @cnvldv. Qed.

Lemma dotcapx `{laws} `{CAP ≪ l} n m p (x: X m n) (y z: X p m): (y ∩ z) ⋅ x ≦ (y⋅x) ∩ (z⋅x).
Proof. dual @dotxcap. Qed.

Lemma Schroeder_r `{laws} `{BL+CNV ≪ l} n m p (x : X n m) (y : X m p) (z : X n p):
  x⋅y ≦ z <-> !z⋅y° ≦ !x.
Proof. dual @Schroeder_l. Qed.

(** * Functors (i.e., monoid morphisms) *)

Class functor l {X Y: ops} (f': ob X -> ob Y) (f: forall {n m}, X n m -> Y (f' n) (f' m)) := {
  fn_morphism:>     forall n m, morphism l (@f n m);
  fn_dot:           forall n m p (x: X n m) (y: X m p), f (x⋅y) ≡ f x ⋅ f y;
  fn_one:           forall n, f (one n) ≡ 1;
  fn_itr `{STR ≪ l}: forall n (x: X n n), f (x^+) ≡ (f x)^+;
  fn_str `{STR ≪ l}: forall n (x: X n n), f (x^*) ≡ (f x)^*;
  fn_cnv `{CNV ≪ l}: forall n m (x: X n m), f (x°) ≡ (f x)°;
  fn_ldv `{DIV ≪ l}: forall n m p (x: X n m) (y: X n p), f (x -o y) ≡ f x -o f y;
  fn_rdv `{DIV ≪ l}: forall n m p (x: X m n) (y: X p n), f (y o- x) ≡ f y o- f x
}.

(** generating a structure by faithful embedding *)

Lemma laws_of_faithful_functor {h l X Y} {L: laws h Y} {Hl: l ≪ h} f' f:
  @functor l X Y f' f ->
  (forall n m x y, f n m x ≦ f n m y -> x ≦ y) ->
  (forall n m x y, f n m x ≡ f n m y -> x ≡ y) ->
  laws l X.
  intros Hf Hleq Hweq.
  assert (Hleq_iff: forall n m x y, f n m x ≦ f n m y <-> x ≦ y).
   split. apply Hleq. apply fn_leq.
  assert (Hweq_iff: forall n m x y, f n m x ≡ f n m y <-> x ≡ y).
   split. apply Hweq. apply fn_weq.
  assert (L' := @lower_laws _ _ _ L Hl).
  constructor; repeat right; intro_vars.
   apply (laws_of_injective_morphism (f n m)); auto using fn_morphism.
   rewrite <-Hweq_iff, 4fn_dot. apply dotA.
   rewrite <-Hweq_iff, fn_dot, fn_one. apply dot1x.
   rewrite <-Hweq_iff, fn_dot, fn_one. apply dotx1.
   repeat intro. apply Hleq. rewrite 2fn_dot. now apply dot_leq; apply Hleq_iff.
   apply Hleq. now rewrite fn_cup, 3fn_dot, fn_cup, dotplsx.
   apply Hleq. now rewrite fn_cup, 3fn_dot, fn_cup, dotxpls.
   apply Hleq. now rewrite fn_dot, 2fn_bot, dot0x.
   apply Hleq. now rewrite fn_dot, 2fn_bot, dotx0.
   intro. apply Hleq. now rewrite fn_cnv, 2fn_dot, 2fn_cnv, cnvdot.
   intro. rewrite <-Hweq_iff, 2fn_cnv. apply cnv_invol.
   repeat intro. apply Hleq. rewrite 2fn_cnv. now apply cnv_leq; apply Hleq_iff.
   apply Hleq. rewrite 2fn_dot,fn_cnv. apply cnv_ext.
   intro. apply Hleq. rewrite fn_one, fn_str. apply str_refl.
   intro. apply Hleq. rewrite fn_str, fn_dot, fn_str. apply str_cons.
   intro. rewrite <-2Hleq_iff, 2fn_dot, fn_str. apply str_ind_l.
   rewrite <-2Hleq_iff, 2fn_dot, fn_str. apply str_ind_r.
   intro. apply Hweq. rewrite fn_itr, fn_dot, fn_str. apply itr_str_l.
   intro. apply Hleq. rewrite fn_cap,2fn_dot,fn_cap,fn_dot,fn_cnv. apply capdotx.
   intro. rewrite <-2Hleq_iff, fn_dot, fn_ldv. apply ldv_spec.
   intro. rewrite <-2Hleq_iff, fn_dot, fn_rdv. apply rdv_spec.
Qed.

(** injection from Booleans into monoids (actually a functor, although we don't need it) *)
Definition ofbool {X: ops} {n} (a: bool): X n n := if a then 1 else 0.
Global Arguments ofbool {_ _} !_ /.
(* does not respect the uniform inheritance condition *)
(* Coercion ofbool: bool >-> car. *)

(** ML modules *)
(* loading this one here explicitly enforces the dependency for proper compilation *)
Declare ML Module "coq-relation-algebra.common".
Declare ML Module "coq-relation-algebra.fold".

(** tricks for reification  *)
Lemma catch_weq `{L: laws} n m (x y: X n m):
  (let L:=L in x <=[false]= y) -> x ≡ y.
Proof. trivial. Defined.
Lemma catch_leq `{L: laws} n m (x y: X n m):
  (let L:=L in x <=[true]= y) -> x ≦ y.
Proof. trivial. Defined.

Ltac catch_rel := apply catch_weq || apply catch_leq.