(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file implements bsets as functions into Prop. *)
From prelude Require Export prelude.

Record bset (A : Type) : Type := mkBSet { bset_car : A → bool }.
Arguments mkBSet {_} _.
Arguments bset_car {_} _ _.
Instance bset_top {A} : Top (bset A) := mkBSet (λ _, true).
Instance bset_empty {A} : Empty (bset A) := mkBSet (λ _, false).
Instance bset_singleton {A} `{∀ x y : A, Decision (x = y)} :
  Singleton A (bset A) := λ x, mkBSet (λ y, bool_decide (y = x)).
Instance bset_elem_of {A} : ElemOf A (bset A) := λ x X, bset_car X x.
Instance bset_union {A} : Union (bset A) := λ X1 X2,
  mkBSet (λ x, bset_car X1 x || bset_car X2 x).
Instance bset_intersection {A} : Intersection (bset A) := λ X1 X2,
  mkBSet (λ x, bset_car X1 x && bset_car X2 x).
Instance bset_difference {A} : Difference (bset A) := λ X1 X2,
  mkBSet (λ x, bset_car X1 x && negb (bset_car X2 x)).
Instance bset_collection {A} `{∀ x y : A, Decision (x = y)} :
  Collection A (bset A).
Proof.
  split; [split| |].
  - by intros x ?.
  - by intros x y; rewrite <-(bool_decide_spec (x = y)).
  - split. apply orb_prop_elim. apply orb_prop_intro.
  - split. apply andb_prop_elim. apply andb_prop_intro.
  - intros X Y x; unfold elem_of, bset_elem_of; simpl.
    destruct (bset_car X x), (bset_car Y x); simpl; tauto.
Qed.
Instance bset_elem_of_dec {A} x (X : bset A) : Decision (x ∈ X) := _.

Typeclasses Opaque bset_elem_of.
Global Opaque bset_empty bset_singleton bset_union
  bset_intersection bset_difference.


Require Import Ctl.BinaryRelations.
Require Import Ctl.Paths.

Class transition {A} (R: relation A) :=
  {trans_serial: serial_witness R}.

(* Note: none of the CTL formulas explicitly use the transition instance, but they do
   make recursive entailment assertions which implicitly pass the transition instance
   forward.

   Ultimately, the transition instance is only used by the theorems in Properties.v.
   It is nonetheless important that a transition instance be mandated for entailments.
   Otherwise, the path-quantifying formulas would lose their current meaning.
 *)
Definition tprop state :=
  forall R: relation state,
    transition R ->
    state ->
    Prop.

Declare Scope tprop_scope.
(* Delimit Scope tprop_scope with tprop. *)
Bind Scope tprop_scope with tprop.
Open Scope tprop_scope.

Definition tentails {state} (R: relation state) {t: transition R}
  (s: state) (P: tprop state) :=
  P R t s.
Notation "R @ s ⊨ P" := (tentails R s P)   (at level 69, format "R  @ s  ⊨  P") : tprop_scope.
Notation "R @ s ⊭ P" := (~ tentails R s P) (at level 69, format "R  @ s  ⊭  P") : tprop_scope.

Section StateProps.

Context {state: Type}.

Definition ttop : tprop state :=
  fun _ _ _ => True.

Definition tbot : tprop state :=
  fun _ _ _ => False.

Definition tconj (P Q: tprop state): tprop state :=
  fun R _ s => R @s ⊨ P /\ R @s ⊨ Q.

Definition tdisj (P Q: tprop state): tprop state :=
  fun R _ s => R @s ⊨ P \/ R @s ⊨ Q.

Definition timpl (P Q: tprop state): tprop state :=
  fun R _ s => R @s ⊨ P -> R @s ⊨ Q.

Definition tbiimpl (P Q: tprop state): tprop state :=
  fun R _ s => R @s ⊨ P <-> R @s ⊨ Q.

Definition tnot (P: tprop state): tprop state :=
  fun R _ s => R @s ⊭ P.

Definition tlift (P: state -> Prop): tprop state :=
  fun _ _ s => P s.

End StateProps.

Notation "⊤"      := (ttop) : tprop_scope.
Notation "⊥"      := (tbot) : tprop_scope.
Notation "P ∧ Q"  := (tconj P Q)   (at level 45, right associativity) : tprop_scope.
Notation "P ∨ Q"  := (tdisj P Q)   (at level 55, right associativity) : tprop_scope.
Notation "P ⟶ Q" := (timpl P Q)   (at level 68,  right associativity) : tprop_scope.
Notation "P ⟷ Q" := (tbiimpl P Q) (at level 65,  right associativity) : tprop_scope.
Notation "¬ P"    := (tnot P)      (at level 40, format "¬ P") : tprop_scope.
Notation "⟨ P ⟩"   := (tlift P)     (format "⟨ P ⟩"): tprop_scope.

Section PathProps.

Context {state: Type}.

Definition AX (P: tprop state) : tprop state :=
  fun R _ s => forall s', R s s' -> R @s' ⊨ P.

Definition EX (P: tprop state) : tprop state :=
  fun R _ s => exists s', R s s' /\ R @s' ⊨ P.

Definition AG (P: tprop state) : tprop state :=
  fun R _ s => forall (p: path R s) s', in_path s' p -> R @s' ⊨ P.

Definition EG (P: tprop state) : tprop state :=
  fun R _ s => exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P.

Definition AF (P: tprop state) : tprop state :=
  fun R _ s => forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P.

Definition EF (P: tprop state) : tprop state :=
  fun R _ s => exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P.

Definition AU (P Q: tprop state) : tprop state :=
  fun R _ s => forall p: path R s, exists sQ i,
    in_path_at sQ i p /\
    (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
    R @sQ ⊨ Q.

Definition EU (P Q: tprop state) : tprop state :=
  fun R _ s => exists (p: path R s) sQ i,
    in_path_at sQ i p /\
    (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
    R @sQ ⊨ Q.

Definition AW {state} (P Q: tprop state) : tprop state :=
  fun R _ s => forall p: path R s,
    (forall s', in_path s' p -> R @s' ⊨ P ∧ ¬Q) \/
    (exists sQ i,
      in_path_at sQ i p /\
      (forall sP, in_path_before sP i p -> R @sP ⊨ P) /\
      R @sQ ⊨ Q).

End PathProps.

Notation "A[ P 'U' Q ]" := (AU P Q) (at level 40, format "A[ P  'U'  Q ]") : tprop_scope.
Notation "E[ P 'U' Q ]" := (EU P Q) (at level 40, format "E[ P  'U'  Q ]") : tprop_scope.
Notation "A[ P 'W' Q ]" := (AW P Q) (at level 40, format "A[ P  'W'  Q ]") : tprop_scope.

Global Opaque tentails.
Global Opaque ttop.
Global Opaque tbot.
Global Opaque tconj.
Global Opaque tdisj.
Global Opaque timpl.
Global Opaque tbiimpl.
Global Opaque AX.
Global Opaque EX.
Global Opaque AF.
Global Opaque EF.
Global Opaque AU.
Global Opaque EU.
Global Opaque AW.

Close Scope tprop_scope.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal64.

Set Printing Depth 1000.
Definition lfind_eval  z:=
negb (even (len z)).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) Nil)))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))))).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons Zero Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Nil).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons Zero (Cons Zero Nil)))).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))).

Compute lfind_eval  (Cons (Succ Zero) Nil).

Compute lfind_eval  (Nil).


Require Import Reals Psatz Omega.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop.
From discprob.measure Require Export sets sigma_algebra.
From stdpp Require Import tactics.

Record dynkin_class (A: Type) :=
  mkDynkin {
      dynkin_sets:> (A → Prop) → Prop;
      dynkin_proper : Proper (@eq_prop A ==> iff) dynkin_sets;
      dynkin_full : dynkin_sets (λ _, True);
      dynkin_closed_set_minus :
        ∀ P Q, dynkin_sets P → dynkin_sets Q → Q ⊆ P → dynkin_sets (set_minus P Q);
      dynkin_closed_unions :
        ∀ Ps : nat → (A → Prop), (∀ i, dynkin_sets (Ps i)) →
                                 (∀ i, Ps i ⊆ Ps (S i)) → dynkin_sets (unionF Ps)
    }.

Record pi_system (A: Type) :=
  mkPiSystem {
      pi_sets:> (A → Prop) → Prop;
      pi_proper : Proper (@eq_prop A ==> iff) pi_sets;
      pi_closed_pair_intersect P Q: pi_sets P → pi_sets Q → pi_sets (P ∩ Q)
    }.

Global Instance dynkin_class_proper {A: Type} X : Proper (@eq_prop A ==> iff) (@dynkin_sets A X).
Proof. apply dynkin_proper. Qed.

Definition intersection_dynkin {A: Type} (I: Type) (U: I → dynkin_class A) : dynkin_class A.
  refine {| dynkin_sets := λ x, ∀ i, (U i) x |}.
  - abstract (intros X X' Heq; split => H i; [ rewrite -Heq | rewrite Heq ]; auto).
  - abstract (intros; by apply dynkin_full).
  - abstract (intros; by apply dynkin_closed_set_minus).
  - abstract (intros; by apply dynkin_closed_unions).
Defined.

Definition minimal_dynkin {A: Type} (F: (A → Prop) → Prop) : dynkin_class A :=
  intersection_dynkin { F' : dynkin_class A | le_prop F F' } sval.

Lemma minimal_dynkin_ub {A: Type} (F : (A → Prop) → Prop) :
  le_prop F (minimal_dynkin F).
Proof.
  intros i HF (F'&Hle) => //=. by apply Hle.
Qed.

Lemma minimal_dynkin_lub {A: Type} (F : (A → Prop) → Prop) (F': dynkin_class A) :
  le_prop F F' → le_prop (minimal_dynkin F) F'.
Proof.
  intros Hle X. rewrite /minimal_dynkin/intersection_dynkin => //=.
  intros H. specialize (H (exist _ F' Hle)). apply H.
Qed.

Definition sigma_to_dynkin {A: Type} (F : sigma_algebra A) : dynkin_class A.
Proof.
  refine {| dynkin_sets := F |}; auto.
  intros. by apply sigma_closed_set_minus.
Defined.

Lemma mdp_closed_pair_intersections {A: Type} (pi: pi_system A) P1 P2 :
  minimal_dynkin pi P1 → minimal_dynkin pi P2 → minimal_dynkin pi (P1 ∩ P2).
Proof.
  intros Hin1 Hin2.
  set (D1 := λ U, ∀ V, pi V →  minimal_dynkin pi (U ∩ V)).
  assert (H1full: D1 (λ _, True)).
  { rewrite /D1 => V HV. apply minimal_dynkin_ub. eapply pi_proper; eauto.
    by rewrite left_id. }
  assert (H1closed: ∀ U V, D1 U → D1 V → V ⊆ U → D1 (set_minus U V)).
  { rewrite /D1 => U V HU HV Hsub V' HV'.
    assert (set_minus U V ∩ V' ≡ set_minus (U ∩ V') (V ∩ V')) as ->.
    { firstorder. }
    apply dynkin_closed_set_minus; eauto. firstorder.
  }
  assert (H1union:
        ∀ Ps : nat → (A → Prop), (∀ i, D1 (Ps i)) →
                                 (∀ i, Ps i ⊆ Ps (S i)) → D1 (unionF Ps)).
  { rewrite /D1 => Ps HPs Hmono V HV.
    assert (unionF Ps ∩ V ≡ unionF (λ n, Ps n ∩ V)) as ->.
    { firstorder. }
    apply dynkin_closed_unions; eauto.
    firstorder.
  }
  assert (H1proper: Proper (@eq_prop A ==> iff) D1).
  { rewrite /D1. intros ?? Heq. setoid_rewrite Heq. done. }
  set (D1' := mkDynkin _ D1 H1proper H1full H1closed H1union).
  assert (le_prop pi D1').
  { intros U HpU V HpV. apply minimal_dynkin_ub. apply pi_closed_pair_intersect; auto. }
  assert (Hle: le_prop (minimal_dynkin pi) D1').
  { apply minimal_dynkin_lub. auto. }

  set (D2 := λ U, ∀ V, (minimal_dynkin pi) V →  minimal_dynkin pi (U ∩ V)).
  assert (H2full: D2 (λ _, True)).
  { rewrite /D2 => V HV. eapply dynkin_proper; eauto.
    by rewrite left_id. }
  assert (H2closed: ∀ U V, D2 U → D2 V → V ⊆ U → D2 (set_minus U V)).
  { rewrite /D2 => U V HU HV Hsub V' HV'.
    assert (set_minus U V ∩ V' ≡ set_minus (U ∩ V') (V ∩ V')) as ->.
    { firstorder. }
    apply dynkin_closed_set_minus; eauto. firstorder.
  }
  assert (H2union:
        ∀ Ps : nat → (A → Prop), (∀ i, D2 (Ps i)) →
                                 (∀ i, Ps i ⊆ Ps (S i)) → D2 (unionF Ps)).
  { rewrite /D2 => Ps HPs Hmono V HV.
    assert (unionF Ps ∩ V ≡ unionF (λ n, Ps n ∩ V)) as ->.
    { firstorder. }
    apply dynkin_closed_unions; eauto.
    firstorder.
  }
  assert (H2proper: Proper (@eq_prop A ==> iff) D2).
  { rewrite /D2. intros ?? Heq. setoid_rewrite Heq. done. }
  set (D2' := mkDynkin _ D2 H2proper H2full H2closed H2union).
  assert (le_prop pi D2').
  { intros U HpU V HpV. apply Hle in HpV.
    rewrite /D1'//=/D1 in HpV.
    rewrite comm. apply HpV. auto.
  }
  assert (Hle2: le_prop (minimal_dynkin pi) D2').
  { apply minimal_dynkin_lub. auto. }

  apply Hle2 in Hin1. rewrite //=/D2 in Hin1. apply Hin1.
  done.
Qed.

Lemma dynkin_closed_complements {A: Type} (F: dynkin_class A) U :
  F U → F (compl U).
Proof.
  intros HF.
  assert (compl U ≡ set_minus (λ _, True) U) as -> by firstorder.
  apply dynkin_closed_set_minus; auto.
  - apply dynkin_full.
  - firstorder.
Qed.

Lemma mdp_closed_pair_union {A: Type} (pi: pi_system A) U V:
  minimal_dynkin pi U → minimal_dynkin pi V →
  minimal_dynkin pi (U ∪ V).
Proof.
  intros HU HV.
  rewrite -(compl_involutive (U ∪ V)).
  apply dynkin_closed_complements.
  rewrite compl_union. by apply mdp_closed_pair_intersections; apply dynkin_closed_complements.
Qed.

Lemma mdp_closed_finite_union {A: Type} (pi: pi_system A) Us j:
  (∀ i, minimal_dynkin pi (Us i)) →
  minimal_dynkin pi (λ x, (∃ i, (i <= j)%nat ∧ Us i x)).
Proof.
  induction j => Hin.
  - eapply dynkin_proper; last eapply (Hin O).
     intros x; split.
     * intros (i&Hle&HUs). inversion Hle; subst. eauto.
     * intros. exists O; split; eauto.
  - assert ((λ x, ∃ i : nat, (i <= S j)%nat ∧ Us i x) ≡
            (λ x, ∃ i, (i <= j)%nat ∧ Us i x) ∪ Us (S j)) as ->.
    { intros x; split.
      * intros (i&Hle&HUs). inversion Hle; subst; firstorder.
      * firstorder.
    }
    apply mdp_closed_pair_union; eauto.
Qed.

Lemma mdp_closed_unions {A: Type} (pi: pi_system A) (Us: nat → A → Prop):
  (∀ i, minimal_dynkin pi (Us i)) →
  minimal_dynkin pi (unionF Us).
Proof.
  intros HUs.
  set (Vs := λ j : nat, (λ x, ∃ i, (i <= j)%nat ∧ Us i x)).
  assert (unionF Us ≡ unionF Vs) as ->.
  { intros x. split.
    - intros (i&Hin). exists i. firstorder.
    - intros (i&Hin). destruct Hin as (j&Hle&Hj).
      exists j. auto.
  }
  apply dynkin_closed_unions.
  - intros. apply mdp_closed_finite_union. eauto.
  - intros i x (j&Hle&Hin). exists j. split; auto.
Qed.

Definition mdp_to_sigma {A: Type} (pi: pi_system A) : sigma_algebra A.
  refine {| sigma_sets := minimal_dynkin pi |}.
  - apply dynkin_full.
  - apply dynkin_closed_complements.
  - apply mdp_closed_unions.
Defined.

Lemma pi_sigma_equiv_dynkin {A: Type} (pi: pi_system A):
  eq_prop (minimal_sigma pi) (minimal_dynkin pi).
Proof.
  apply le_prop_antisym; last first.
  -  transitivity (sigma_to_dynkin (minimal_sigma pi)); last reflexivity.
     apply minimal_dynkin_lub.
     apply minimal_sigma_ub.
  - replace (dynkin_sets _ (minimal_dynkin pi)) with (sigma_sets _ (mdp_to_sigma pi)) by auto.
    apply minimal_sigma_lub.
    apply minimal_dynkin_ub.
Qed.

Definition is_pi_system {A: Type} F :=
      Proper (@eq_prop A ==> iff) F ∧
      (∀ P Q, F P → F Q → F (P ∩ Q)).

Lemma pi_of_is_pi_system {A: Type} F (His: @is_pi_system A F) : pi_system A.
Proof. refine {| pi_sets := F |}; destruct His; auto. Defined.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)
(* begin hide *)
(** Coq Library *)
From Coq Require Import
    Floats
    PrimInt63
    Decimal
    DecimalString
    Strings.Ascii
    Strings.String
    ZArith.BinInt.
(* end hide *)

(** [parse_int] parse a signed integer present in [s] or returns 0 *)

Definition parse_int s : Z :=
  let value := NilEmpty.int_of_string s in
  match value with
  | None => 0
  | Some z => Z.of_int z
  end.

(** [parse_bool] parses a bool value from [s] or return false *)
Definition parse_bool s : bool :=
  if eqb "true"%string s then true
  else if eqb "false"%string s then true
  else false. (* error reporting *)

(** [split_dot] splits [s] in two substrings delimited by a '.'. [pending] is used as an accumulator during recursion. *)

Fixpoint split_dot (pending : string) (s : string) :=
    match s with
    | EmptyString => pair EmptyString EmptyString
    | String "." tail => pair pending tail
    | String head tail => split_dot (pending ++ (String head EmptyString)) tail
    end.

(** [parse_decimal] parses a decimal value from [s] *)

Definition parse_decimal s : decimal :=
  let values := split_dot "" s in
  let value_a := NilEmpty.int_of_string (fst values) in
  let value_b := NilEmpty.uint_of_string (snd values) in
    match value_a, value_b with
      | None, _ => Decimal (Pos Decimal.zero) Decimal.zero
      | Some x, Some y => Decimal x y
      | Some x, None => Decimal x Decimal.zero
    end.

(** [parse_float] parses a float value from [s] *)

Fixpoint build_decimal_part (f: float) (n:nat) : float :=
  match n with
  | 0 => f
  | S n => build_decimal_part (f/10) n
  end.

Definition build_float (i : Z) (d: uint) : float :=
  of_uint63 (Uint63.of_Z i) +
  build_decimal_part
    (of_uint63 (Uint63.of_Z (Z.of_uint d)))
    (nb_digits d).

Definition parse_float s : float :=
  let values := split_dot "" s in
  let value_a := NilEmpty.int_of_string (fst values) in
  let value_b := NilEmpty.uint_of_string (snd values) in
    match value_a, value_b with
      | None, _ => PrimFloat.zero

      | Some x, Some y =>
        let x_z := Z.of_int x in
          match x_z with
          | Z0 => build_float Z.zero y

          | Zpos x => build_float x_z y

          | Zneg x => - build_float (- x_z) y
        end

      | Some x, None => build_float (Z.of_int x) Decimal.zero

    end.

Compute parse_float ".01".
Compute parse_float "1.01".
Compute parse_float "1.0112121".
Compute parse_float "-1.0112121".


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file collects facts on proof irrelevant types/propositions. *)
From stdpp Require Export base.
Set Default Proof Using "Type".

Hint Extern 200 (ProofIrrel _) => progress (lazy beta) : typeclass_instances.

Instance True_pi: ProofIrrel True.
Proof. intros [] []; reflexivity. Qed.
Instance False_pi: ProofIrrel False.
Proof. intros []. Qed.
Instance and_pi (A B : Prop) :
  ProofIrrel A → ProofIrrel B → ProofIrrel (A ∧ B).
Proof. intros ?? [??] [??]. f_equal; trivial. Qed.
Instance prod_pi (A B : Type) :
  ProofIrrel A → ProofIrrel B → ProofIrrel (A * B).
Proof. intros ?? [??] [??]. f_equal; trivial. Qed.
Instance eq_pi {A} (x : A) `{∀ z, Decision (x = z)} (y : A) :
  ProofIrrel (x = y).
Proof.
  set (f z (H : x = z) :=
    match decide (x = z) return x = z with
    | left H => H | right H' => False_rect _ (H' H)
    end).
  assert (∀ z (H : x = z),
    eq_trans (eq_sym (f x (eq_refl x))) (f z H) = H) as help.
  { intros ? []. destruct (f x eq_refl); tauto. }
  intros p q. rewrite <-(help _ p), <-(help _ q).
  unfold f at 2 4. destruct (decide _). reflexivity. exfalso; tauto.
Qed.
Instance Is_true_pi (b : bool) : ProofIrrel (Is_true b).
Proof. destruct b; simpl; apply _. Qed.
Lemma sig_eq_pi `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
  (x y : sig P) : x = y ↔ `x = `y.
Proof.
  split; [intros <-; reflexivity|].
  destruct x as [x Hx], y as [y Hy]; simpl; intros; subst.
  f_equal. apply proof_irrel.
Qed.
Lemma exists_proj1_pi `(P : A → Prop) `{∀ x, ProofIrrel (P x)}
  (x : sig P) p : `x ↾ p = x.
Proof. apply (sig_eq_pi _); reflexivity. Qed.


From iris.bi Require Export bi.
From iris.proofmode Require Import tactics.
From iris.prelude Require Import options.
Import bi.

(** Least and greatest fixpoint of a monotone function, defined entirely inside
    the logic.  *)
Class BiMonoPred {PROP : bi} {A : ofe} (F : (A → PROP) → (A → PROP)) := {
  bi_mono_pred Φ Ψ : ⊢ <pers> (∀ x, Φ x -∗ Ψ x) → ∀ x, F Φ x -∗ F Ψ x;
  bi_mono_pred_ne Φ : NonExpansive Φ → NonExpansive (F Φ)
}.
Global Arguments bi_mono_pred {_ _ _ _} _ _.
Local Existing Instance bi_mono_pred_ne.

Definition bi_least_fixpoint {PROP : bi} {A : ofe}
    (F : (A → PROP) → (A → PROP)) (x : A) : PROP :=
  tc_opaque (∀ Φ : A -n> PROP, <pers> (∀ x, F Φ x -∗ Φ x) → Φ x)%I.
Global Arguments bi_least_fixpoint : simpl never.

Definition bi_greatest_fixpoint {PROP : bi} {A : ofe}
    (F : (A → PROP) → (A → PROP)) (x : A) : PROP :=
  tc_opaque (∃ Φ : A -n> PROP, <pers> (∀ x, Φ x -∗ F Φ x) ∧ Φ x)%I.
Global Arguments bi_greatest_fixpoint : simpl never.

Global Instance least_fixpoint_ne {PROP : bi} {A : ofe} n :
  Proper (pointwise_relation (A → PROP) (pointwise_relation A (dist n)) ==>
          dist n ==> dist n) bi_least_fixpoint.
Proof. solve_proper. Qed.
Global Instance least_fixpoint_proper {PROP : bi} {A : ofe} :
  Proper (pointwise_relation (A → PROP) (pointwise_relation A (≡)) ==>
          (≡) ==> (≡)) bi_least_fixpoint.
Proof. solve_proper. Qed.

Section least.
  Context {PROP : bi} {A : ofe} (F : (A → PROP) → (A → PROP)) `{!BiMonoPred F}.

  Lemma least_fixpoint_unfold_2 x : F (bi_least_fixpoint F) x ⊢ bi_least_fixpoint F x.
  Proof using Type*.
    rewrite /bi_least_fixpoint /=. iIntros "HF" (Φ) "#Hincl".
    iApply "Hincl". iApply (bi_mono_pred _ Φ with "[#]"); last done.
    iIntros "!>" (y) "Hy". iApply ("Hy" with "[# //]").
  Qed.

  Lemma least_fixpoint_unfold_1 x :
    bi_least_fixpoint F x ⊢ F (bi_least_fixpoint F) x.
  Proof using Type*.
    iIntros "HF". iApply ("HF" $! (OfeMor (F (bi_least_fixpoint F))) with "[#]").
    iIntros "!>" (y) "Hy /=". iApply (bi_mono_pred with "[#]"); last done.
    iIntros "!>" (z) "?". by iApply least_fixpoint_unfold_2.
  Qed.

  Corollary least_fixpoint_unfold x :
    bi_least_fixpoint F x ≡ F (bi_least_fixpoint F) x.
  Proof using Type*.
    apply (anti_symm _); auto using least_fixpoint_unfold_1, least_fixpoint_unfold_2.
  Qed.

  Lemma least_fixpoint_ind (Φ : A → PROP) `{!NonExpansive Φ} :
    □ (∀ y, F Φ y -∗ Φ y) -∗ ∀ x, bi_least_fixpoint F x -∗ Φ x.
  Proof.
    iIntros "#HΦ" (x) "HF". by iApply ("HF" $! (OfeMor Φ) with "[#]").
  Qed.

  Lemma least_fixpoint_strong_ind (Φ : A → PROP) `{!NonExpansive Φ} :
    □ (∀ y, F (λ x, Φ x ∧ bi_least_fixpoint F x) y -∗ Φ y) -∗
    ∀ x, bi_least_fixpoint F x -∗ Φ x.
  Proof using Type*.
    trans (∀ x, bi_least_fixpoint F x -∗ Φ x ∧ bi_least_fixpoint F x)%I.
    { iIntros "#HΦ". iApply (least_fixpoint_ind with "[]"); first solve_proper.
      iIntros "!>" (y) "H". iSplit; first by iApply "HΦ".
      iApply least_fixpoint_unfold_2. iApply (bi_mono_pred with "[#] H").
      by iIntros "!> * [_ ?]". }
    by setoid_rewrite and_elim_l.
  Qed.
End least.

Lemma greatest_fixpoint_ne_outer {PROP : bi} {A : ofe}
    (F1 : (A → PROP) → (A → PROP)) (F2 : (A → PROP) → (A → PROP)):
  (∀ Φ x n, F1 Φ x ≡{n}≡ F2 Φ x) → ∀ x1 x2 n,
  x1 ≡{n}≡ x2 → bi_greatest_fixpoint F1 x1 ≡{n}≡ bi_greatest_fixpoint F2 x2.
Proof.
  intros HF x1 x2 n Hx. rewrite /bi_greatest_fixpoint /=.
  do 3 f_equiv; last solve_proper. repeat f_equiv. apply HF.
Qed.

Global Instance greatest_fixpoint_ne {PROP : bi} {A : ofe} n :
  Proper (pointwise_relation (A → PROP) (pointwise_relation A (dist n)) ==>
          dist n ==> dist n) bi_greatest_fixpoint.
Proof. solve_proper. Qed.
Global Instance greatest_fixpoint_proper {PROP : bi} {A : ofe} :
  Proper (pointwise_relation (A → PROP) (pointwise_relation A (≡)) ==>
          (≡) ==> (≡)) bi_greatest_fixpoint.
Proof. solve_proper. Qed.

Section greatest.
  Context {PROP : bi} {A : ofe} (F : (A → PROP) → (A → PROP)) `{!BiMonoPred F}.

  Lemma greatest_fixpoint_unfold_1 x :
    bi_greatest_fixpoint F x ⊢ F (bi_greatest_fixpoint F) x.
  Proof using Type*.
    iDestruct 1 as (Φ) "[#Hincl HΦ]".
    iApply (bi_mono_pred Φ (bi_greatest_fixpoint F) with "[#]").
    - iIntros "!>" (y) "Hy". iExists Φ. auto.
    - by iApply "Hincl".
  Qed.

  Lemma greatest_fixpoint_unfold_2 x :
    F (bi_greatest_fixpoint F) x ⊢ bi_greatest_fixpoint F x.
  Proof using Type*.
    iIntros "HF". iExists (OfeMor (F (bi_greatest_fixpoint F))).
    iSplit; last done. iIntros "!>" (y) "Hy /=". iApply (bi_mono_pred with "[#] Hy").
    iIntros "!>" (z) "?". by iApply greatest_fixpoint_unfold_1.
  Qed.

  Corollary greatest_fixpoint_unfold x :
    bi_greatest_fixpoint F x ≡ F (bi_greatest_fixpoint F) x.
  Proof using Type*.
    apply (anti_symm _); auto using greatest_fixpoint_unfold_1, greatest_fixpoint_unfold_2.
  Qed.

  Lemma greatest_fixpoint_coind (Φ : A → PROP) `{!NonExpansive Φ} :
    □ (∀ y, Φ y -∗ F Φ y) -∗ ∀ x, Φ x -∗ bi_greatest_fixpoint F x.
  Proof. iIntros "#HΦ" (x) "Hx". iExists (OfeMor Φ). auto. Qed.
End greatest.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Omega.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From libs Require Import edone bcase fset base modular_hilbert sltype.
Require Import CTL_def dags demo hilbert relaxed_pruning.
Import IC.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Implicit Types (C D L : clause) (S : {fset clause}).

(** * Completeness of the Hilbert system *)

(** ** Pruning refutations to Hilbert Refutations *)

Section RefPred.
  Variable (F : {fset sform}).
  Hypothesis (sfc_F : sf_closed F).

  Local Notation S0 := (S0 F).
  Local Notation U := (U F).
  Local Notation xaf := (fun L => [af L]).

  Definition href C := prv ([af C] ---> Bot).

  Lemma refI1n s C : prv ([af C] ---> s) -> href (s^- |` C).
  Proof.
    move => H. rewrite /href. rewrite -> andU,H,bigA1,axAC.
    rule axAcase. exact: axContra.
  Qed.

  Lemma refE1n s C : href (s^- |` C) -> prv ([af C] ---> s).
  Proof.
    move => H. rewrite /href in H. rewrite -> andU,bigA1 in H.
    Intro. ApplyH axDN. Intro. ApplyH H. by ApplyH axAI.
  Qed.

  Ltac Lbase_aux := move => D; rewrite !inE; (try case/orP) =>/eqP->.
  Ltac Lbase1 := Lbase_aux; by rewrite /= ?fsubUset ?fsub1 ?powersetE ?fsubUset ?fsub1 ?inE ?ssub_refl.
  Ltac Lbase3 := Lbase_aux; rewrite /weight /= ?fsumU !fsum1 /= /sltype.f_weight /= -?(plusE,minusE);
                 apply/leP; omega.
  Ltac Lbase4 := move => L; Lbase_aux; by rewrite /sltype.supp /= ?suppCU ?suppC1 /=; bcase.

  (** The lemma below is simple but tedious to prove. The recursive structure is
  provided in [sltype.v] (Lemma [supp_aux]) such that it can be shared between
  all formula types for which Hilbert system and support have been defined. *)

  Lemma base0P C : C \in U ->
     prv ([af C] ---> \or_(L <- base [fset D in U | literalC D] C) [af L]).
  Proof with try solve [Lbase1|Lbase3|Lbase4].
    apply: (@supp_aux _ ssub) => /= {C} ; last by move => ?; exact: sf_ssub.
    - move => [[|p|s t|s|s t|s t] [|]] //=; try exact: decomp_lit.
      - apply: (decomp_ab [fset [fset s^-]; [fset t^+]])...
        + simpl. rewrite -[fImp s t]/(s ---> t). rewrite -> (axIO s t).
          rule axOE.
          * rewrite -> af1n. apply: (bigOI xaf). by rewrite !inE eqxx.
          * rewrite -> (af1p t) at 1. apply: (bigOI xaf). by rewrite !inE eqxx.
      - apply: (decomp_ab [fset [fset s^+; t^-]])...
        + rewrite -[interp _]/(~~: (s ---> t)). rewrite -> dmI.
          rewrite -> (af1p s),(af1n t), <- andU at 1.
          apply: (bigOI xaf). by rewrite inE.
      - apply: (decomp_ab [fset [fset t^+; fAX (fAR s t)^+]; [fset t^+;s^+]])...
        + simpl. rewrite -> axAReq,axAODr at 1. rule axOE.
          * rewrite -> (af1p t),(af1p s),<- andU at 1.
            apply: (bigOI xaf). by rewrite !inE eqxx.
          * rewrite -> (af1p t),(af1p (AX (AR s t))),<- andU at 1.
            apply: (bigOI xaf). by rewrite !inE eqxx.
      - apply: (decomp_ab [fset [fset s^-; fAX (fAR s t)^-]; [fset t^-]])...
        + rewrite -[interp _]/(~~: AR s t). rewrite -> dmAR,axEUeq at 1. rule axOE.
          * rewrite -> (af1n t). apply: (bigOI xaf). by rewrite !inE eqxx.
          * rewrite <- dmAR, <- dmAX. rewrite -> (af1n s), (af1n (AX (AR s t))), <- andU at 1.
            apply: (bigOI xaf). by rewrite !inE eqxx.
      - apply: (decomp_ab [fset [fset s^+; fAX (fAU s t)^+]; [fset t^+]])...
        + simpl. rewrite -> axAUeq at 1. rule axOE.
          * rewrite -> (af1p t) at 1. apply: (bigOI xaf). by rewrite !inE eqxx.
          * rewrite -> (af1p s),(af1p (AX (AU s t))),<- andU at 1.
            apply: (bigOI xaf). by rewrite !inE eqxx.
      - apply: (decomp_ab [fset [fset t^-; fAX (fAU s t)^-]; [fset t^-;s^-]])...
        + rewrite -[interp _]/(~~: AU s t). rewrite -> dmAU, axERu, axAODr.
          rewrite <- dmAU, <- dmAX. rewrite /=. rule axOE.
          * rewrite -> af1n, af1n, <- andU. apply: (bigOI xaf). by rewrite !inE eqxx.
          * rewrite -> af1n, af1n, <- andU. apply: (bigOI xaf). by rewrite !inE eqxx.
  Qed.

  Lemma ax_lcons C : ~~ lcons C -> prv ([af C] ---> Bot).
  Proof.
    rewrite negb_and -has_predC negbK.
    case/orP => [inC|/hasP [[[] //= p [|] //]]].
    - rewrite -> (bigAE _ inC). exact: axI.
    - rewrite negbK => pP pN.
      rewrite -> (axA2 [af C]). rewrite -> (bigAE _ pP) at 2.
      rewrite -> (bigAE _ pN). simpl. rule axAcase. exact: axI.
   Qed.

  Lemma ax_Req C L : C \in Req L -> prv ([af L] ---> EX [af C]).
  Proof.
    rewrite !inE. case/predU1P => [->|].
    - rewrite -> box_request. do 2 Intro. ApplyH ax_serial. Rev.
      ApplyH axN. Rev. apply: rNorm. exact: axContra.
    - case/fimsetP => s. rewrite inE.
      move: s => [[|?|? ?|s|? ?|? ?] [|]] /andP [//=] inL _ ->.
      rewrite -> andU,(axA2 [af L]). rewrite <- af1n.
      rewrite -> (bigAE _ inL),box_request at 1.
      rewrite /=. rule axAcase. rewrite <- (axDN s) at 1. exact: axDBD.
  Qed.

  Lemma ax_ReqR C D : D \in Req C -> href D -> href C.
  Proof. move/ax_Req => H rD. rewrite /href in rD *. rewrite -> H, rD. exact: axDF. Qed.

  Section EventualityRefutations.
  Variable S : {fset clause}.
  Hypothesis sub_S : S `<=` S0.
  Hypothesis coref_S : coref F href S.

  Lemma baseP C : C \in U ->
     prv ([af C] ---> \or_(L <- base S C) [af L]).
  Proof.
    move => inU. rewrite -> base0P => //.
    apply: bigOE => L /sepP [/sepP [L1 L2] L3].
    case: (boolP (L \in S)) => LS; first by apply: (bigOI xaf); rewrite inE LS.
    case: (boolP (lcons L)) => LL; last by rewrite -> (ax_lcons LL); exact: axBE.
    have H : L \in S0 `\` S by rewrite !inE LS L1 L2.
    Intro. ApplyH axBE. Rev. exact: (coref_S H).
  Qed.

  Lemma coref_supp C : C \in U -> ~~ suppS S C -> href C.
  Proof.
    move => inU sD. rewrite /href. rewrite -> baseP => //. apply: bigOE => D.
    case/sepP => D1 D2. apply: contraN sD. by apply/hasP; exists D.
  Qed.

  Lemma unfulfilledAU_refute s t L : L \in S -> (fAX (fAU s t)^+ \in L) ->
    ~~ fulfillsAU S S0 s t L -> mprv ([af L] ---> Bot).
  Proof.
    move => H1 H2 H3.
    pose I : {fset clause} := [fset X in S | ~~ fulfillsAU S S0 s t X].
    pose u : form := \or_(D <- I) [af D].
    rewrite /= in I u.
    suff sf : prv (u ---> ~~: fAX (fAU s t)).
    { Intro. ApplyH sf; Rev.
      - apply: (bigOI xaf). by rewrite inE H1.
      - rewrite ->(bigAE _ H2). exact: axI. }

    have HI C : C \in I -> exists2 D : clause,
                              D \in Req C & base S (s^+ |` D) `<=` I /\ ~~ suppS S (t^+ |` D).
    { rewrite inE => /andP [L1' L3'].
      rewrite /fulfillsAU fulfillsAUE inE (subP sub_S _ L1') /= in L3'.
      case/allPn : L3' => D DReq.
      rewrite negb_or => /andP [HS /hasPn HS'].
      exists D => //. split => //. apply/subP => X.
      rewrite !inE => /andP [inS sXC].
      move: (HS' _ (subP sub_S _ inS)). by rewrite inS sXC. }

    rewrite -> (axDNI (fAU s t)), dmAU. apply: EXR_ind.
    apply: bigOE => X XinD.
      case: (HI _ XinD) => C inReq [base1 base2].
      have XinU : X \in U. apply: (SsubU sub_S). by case/sepP : XinD.
      move/(subP sub_S) : H1. rewrite inE => /and3P [H1 _ _].
      rewrite -> (ax_Req inReq). apply: rEXn. ApplyH axAI.
      - have inU : t^+ |` C \in U.
          rewrite powersetU (ReqU sfc_F XinU inReq) powersetE fsub1 andbT.
          apply: Fsub H2 H1 => //. by rewrite /= !inE ssub_refl.
        apply: rAIL. rewrite -> (af1p t), <- andU, fsetUC. exact: coref_supp.
      - rewrite {1}/Or. apply: rAIL. rewrite -> modular_hilbert.axDN, (af1p s), <- andU, fsetUC.
        rewrite -> baseP. apply: or_sub. exact/subP.
        rewrite powersetU (ReqU sfc_F XinU inReq) powersetE fsub1 /= andbT.
        apply: Fsub H2 H1 => //. by rewrite /= !inE ssub_refl.
  Qed.

  Lemma unfulfilledAR_refute s t C : C \in S -> fAX (fAR s t)^- \in C ->
     ~~ fulfillsAR S S0 s t C -> prv ([af C] ---> Bot).
  Proof.
    move: C => C0 H1 H2 H3.
    have inF : fAX (fAR s t)^- \in F.
      apply: Fsub (ssub_refl _) H2 _ => //. move/(subP sub_S) : H1. by case/sepP.
    pose I : {fset clause} := [fset D in S | ~~ fulfillsAR S S0 s t D].
    pose u : form := \or_(D<-I) [af D].
    rewrite /= in I u.

    have C0u: prv ([af C0] ---> u) by apply: (bigOI xaf); rewrite inE H1.
    have C0x: prv ([af C0] ---> ~~: AX (AR s t)) by rewrite -> (bigAE _ H2); exact: axI.
    suff sf: prv (u ---> fAX (fAR s t)) by Intro; ApplyH C0x; ApplyH sf; ApplyH C0u.

    have I1 C : C \in I -> (exists2 D : clause, D \in Req C & ~~ suppS S D)
                        \/ base S (s^- |` R C) `<=` I /\ ~~ suppS S (t^- |` R C).
    { rewrite inE => /andP [HL1 HL3].
      rewrite /fulfillsAR fulfillsARE inE !negb_and negb_or (subP sub_S _ HL1) /= in HL3.
      case/orP : HL3 => [L1|/andP[L1 L2]];[left;exact/allPn|right].
      split => //. apply/subP => X /sepP. rewrite !inE suppCU suppC1 => [[inS] /andP [sX sR]].
      rewrite inS /=. apply: contraNN L2 => rnk. apply/hasP; exists X => //.
      + exact: (subP sub_S).
      + by rewrite !suppCU !suppC1 !sX sR. }

    apply: AXR_ind. apply: bigOE => L LinD.
    have LinU : L \in U. apply: (SsubU sub_S). move: L LinD. apply/subP. exact: subsep.
    move/I1 : (LinD) => [[E E1 E2]|[L1 L2]].
    - suff W: prv ([af L] ---> Bot) by rewrite -> W; exact: axBE.
      apply: ax_ReqR (E1) _. apply: coref_supp E2. exact: ReqU E1.
    - rewrite -> box_request. apply: rNorm. apply: rAI.
      + apply: refE1n. apply: coref_supp => //.
        rewrite powersetU RinU // andbT  powersetE fsub1. by case/and3P :(sfc_F (sfc_F inF)).
      + rewrite /Or. apply: rAIL => /=. rewrite -> af1n, <- andU. rewrite fsetUC.
        rewrite -> baseP; first (apply: or_sub; exact/subP).
        rewrite powersetU RinU // andbT  powersetE fsub1. by case/and3P :(sfc_F (sfc_F inF)).
  Qed.

  End EventualityRefutations.

  Lemma href_translation C : ref F C -> href C.
  Proof.
    elim => {C}; eauto using coref_supp,ax_ReqR.
    - move => S C sub0 _ coS inS. case/hasP => [[[]//[]// s t [|] //]] inC.
      exact: unfulfilledAR_refute.
    - move => S C sub0 _ coS inS. case/hasP => [[[]//[]// s t [|] //]] inC.
      exact: unfulfilledAU_refute.
  Qed.
End RefPred.

(** ** Informative Completeness and Corollaries *)

Theorem informative_completeness s :
     ( prv (~~: s) )
  +  (exists2 M : fmodel, #|M| <= f_size s * 2^(4 * f_size s + 2) & exists (w:M), eval s w).
Proof.
  pose F := ssub (s^+).
  have sfc_F := @sfc_ssub (s^+).
  have inU : [fset s^+] \in U F by rewrite powersetE fsub1 ssub_refl.
  case (ref_compl sfc_F (ssub_refl _) inU) => H;[left|right].
  - move/(href_translation sfc_F) : H. rewrite /href. by rewrite <- af1p.
  - move: H => [M M1 [w Hw]]. exists M; last by exists w; apply: (Hw _ (fset11 _)).
    apply: leq_trans M1 _. rewrite addn2 expnS mulnA [_*2]mulnC leq_mul ?size_ssub //.
    by rewrite leq_exp2l // addn1 ltnS -[4]/(2*2) -mulnA leq_mul2l size_ssub.
Qed.

Corollary fin_completeness s : (forall (M:fmodel) (w:M), eval s w) -> prv s.
Proof.
  move => valid_s.
  case: (informative_completeness (~~: s)) => [|[M] _ [w] /=];
    [by rewrite -> modular_hilbert.axDN|by firstorder].
Qed.

Corollary prv_dec s : decidable (prv s).
Proof.
  case: (informative_completeness (~~: s)) => H;[left|right].
  - by rule axDN.
  - move => prv_s. case: H => M _ [w]. apply. exact: (@soundness _ prv_s M).
Qed.

Corollary sat_dec s : decidable (exists (M:cmodel) (w:M), eval s w).
Proof.
  case: (informative_completeness s) => H;[right|left].
  - case => M [w] Hw. exact: (@soundness _ H M).
  - case: H => M _ [w] ?. by exists M; exists w.
Qed.

Corollary valid_dec s : decidable (forall (M:cmodel) (w:M), eval s w).
Proof.
  case (sat_dec (fImp s fF)) => /= H;[by firstorder|left => M w].
  by case (modelP s w); firstorder.
Qed.

Corollary small_models s :
  (exists (M:cmodel) (w:M), eval s w) ->
  (exists2 M : fmodel, #|M| <= f_size s * 2^(4 * f_size s + 2) & exists (w:M), eval s w).
Proof.
  move => [M] [w] w_s. case: (informative_completeness s) => //. by move/soundness/(_ M w w_s).
Qed.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.uni.jitter.schedule.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

(* In this file, we define properties about the platform in jitter-aware schedules. *)
Module Platform.

  Import Job SporadicTaskset UniprocessorScheduleWithJitter Priority.

  Section Properties.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_jitter: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any jitter-aware uniprocessor schedule. *)
    Variable arr_seq: arrival_sequence Job.
    Variable sched: schedule Job.

    (* First, we define properties related to execution. *)
    Section Execution.

      (* We say that a scheduler is work-conserving iff whenever a job j
         is backlogged, the processor is always busy with another job.
         (Note that the definition of backlogged depends on the jitter.) *)
      Definition work_conserving :=
        forall j t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost job_jitter sched j t ->
          exists j_other, scheduled_at sched j_other t.

    End Execution.

    (* Next, we define properties related to FP scheduling. *)
    Section FP.

      (* We say that an FP policy...*)
      Variable higher_eq_priority: FP_policy sporadic_task.

      (* ...is respected by the schedule iff a scheduled task has
         higher (or same) priority than (as) any backlogged task.
         (Note that the definition of backlogged depends on the jitter.) *)
      Definition respects_FP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost job_jitter sched j t ->
          scheduled_at sched j_hp t ->
          higher_eq_priority (job_task j_hp) (job_task j).

    End FP.

    (* Next, we define properties related to JLFP policies. *)
    Section JLFP.

      (* We say that a JLFP policy ...*)
      Variable higher_eq_priority: JLFP_policy Job.

      (* ... is respected by the scheduler iff a scheduled job has
         higher (or same) priority than (as) any backlogged job.
         (Note that the definition of backlogged depends on the jitter.) *)
      Definition respects_JLFP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost job_jitter sched j t ->
          scheduled_at sched j_hp t ->
          higher_eq_priority j_hp j.

    End JLFP.

    (* Next, we define properties related to JLDP policies. *)
    Section JLDP.

      (* We say that a JLFP/JLDP policy ...*)
      Variable higher_eq_priority: JLDP_policy Job.

      (* ... is respected by the scheduler iff at any time t, a scheduled job
         has higher (or same) priority than (as) any backlogged job.
         (Note that the definition of backlogged depends on the jitter.) *)
      Definition respects_JLDP_policy :=
        forall j j_hp t,
          arrives_in arr_seq j ->
          backlogged job_arrival job_cost job_jitter sched j t ->
          scheduled_at sched j_hp t ->
          higher_eq_priority t j_hp j.

    End JLDP.

  End Properties.

End Platform.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e171m19_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e285m9_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e150m5_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e190m11_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e285m9_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e130m5_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(* ******************************************************************************* *)
(** Algebra map as pseudotransformation
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.

Definition var
           {C : bicat}
           (F S : psfunctor C C)
  : pstrans
      (@comp_psfunctor
         (total_bicat (disp_alg_bicat F)) C C
         S (pr1_psfunctor (disp_alg_bicat F)))
      (@comp_psfunctor
         (total_bicat (disp_alg_bicat F)) C C
         S (pr1_psfunctor (disp_alg_bicat F)))
  := id₁ _.

Definition alg_map_data
           {C : bicat}
           (F : psfunctor C C)
  : pstrans_data
      (@comp_psfunctor
         (total_bicat (disp_alg_bicat F)) C C
         F (pr1_psfunctor (disp_alg_bicat F)))
      (@comp_psfunctor
         (total_bicat (disp_alg_bicat F)) C C
         (id_psfunctor C) (pr1_psfunctor (disp_alg_bicat F))).
Proof.
  use make_pstrans_data.
  - intros X ; cbn in *.
    exact (pr2 X).
  - intros X Y f ; cbn in *.
    exact (pr2 f).
Defined.

Definition alg_map_data_is_pstrans
           {C : bicat}
           (F : psfunctor C C)
  : is_pstrans (alg_map_data F).
Proof.
  repeat split ; cbn.
  - intros X Y f g α.
    apply α.
  - intros.
    rewrite !id2_left, lwhisker_id2, psfunctor_id2.
    rewrite !id2_left, !id2_right.
    reflexivity.
  - intros.
    rewrite !id2_left, lwhisker_id2, psfunctor_id2.
    rewrite !id2_left, !id2_right.
    reflexivity.
Qed.

Definition alg_map
           {C : bicat}
           (F : psfunctor C C)
  : pstrans
      (@comp_psfunctor
         (total_bicat (disp_alg_bicat F)) C C
         F (pr1_psfunctor (disp_alg_bicat F)))
      (@comp_psfunctor
         (total_bicat (disp_alg_bicat F)) C C
         (id_psfunctor C) (pr1_psfunctor (disp_alg_bicat F))).
Proof.
  use make_pstrans.
  - exact (alg_map_data F).
  - exact (alg_map_data_is_pstrans F).
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e152m17_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Export XR_Rmult_assoc.
Require Export XR_Rinv_r.
Require Export XR_Rmult_1_r.

Local Open Scope R_scope.

Lemma Rinv_r_simpl_l : forall r1 r2, r1 <> R0 -> r2 * r1 * / r1 = r2.
Proof.
  intros x y h.
  rewrite Rmult_assoc.
  rewrite Rinv_r.
  {
rewrite Rmult_1_r.
reflexivity.
}
{ exact h. }
Qed.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Progress.

Lemma open_tt_var_rev: forall A B (X:atom),
    X \notin fv_tt A \u fv_tt B ->
    open_tt A X = open_tt B X ->
    A = B.
Proof with auto.
  unfold open_tt.
  generalize 0.
  intros n A B.
  generalize dependent n.
  generalize dependent B.
  induction A;induction B;intros;simpl in *;try solve [inversion H0|destruct (n0==n);subst;inversion H0]...
  -
    destruct (n1==n);destruct (n1==n0);subst...
    inversion H0.
    inversion H0.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite <- H2 in H.
    solve_notin_self X.
  -
    destruct (n0==n);subst...
    inversion H0.
    rewrite  H2 in H.
    solve_notin_self X.
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA1 in H2...
    apply IHA2 in H3...
    subst...
  -
    inversion H0.
    apply IHA in H2...
    subst...
  -
    inversion H0.
    apply IHA in H3...
    subst...
Qed.

Lemma binds_split: forall E X U,
    binds X (bind_sub U) E ->
    exists E1 E2,
      E = E1 ++ X~(bind_sub U) ++ E2.
Proof with auto.
  induction E;intros...
  analyze_binds H.
  destruct a.
  analyze_binds H.
  -
    exists nil.
    exists E...
  -
    apply IHE in BindsTac...
    destruct_hypos.
    rewrite H.
    exists ((a,b)::x).
    exists x0...
Qed.

Lemma binds_split_lb: forall E X U,
    binds X (bind_sub_lb U) E ->
    exists E1 E2,
      E = E1 ++ X~(bind_sub_lb U) ++ E2.
Proof with auto.
  induction E;intros...
  analyze_binds H.
  destruct a.
  analyze_binds H.
  -
    exists nil.
    exists E...
  -
    apply IHE in BindsTac...
    destruct_hypos.
    rewrite H.
    exists ((a,b)::x).
    exists x0...
Qed.

Inductive sub_tvar_chain : env -> env -> atom -> atom -> Prop :=
| sub_tvar_refl: forall E U X,
    wf_env E -> binds X (bind_sub U) E ->
    sub_tvar_chain E (X ~ bind_sub U) X X
(* | sub_tvar_refl_lb: forall E U X,
    wf_env E -> binds X (bind_sub_lb U) E ->
    sub_tvar_chain E (X ~ bind_sub_lb U) X X *)
| sub_tvar_cons: forall E1 E2 W (X1 X2 X3:atom),
    wf_env (E1 ++ X1 ~ bind_sub X2 ++ E2) ->
    sub_tvar_chain (E1 ++ X1 ~ bind_sub X2 ++ E2) W X2 X3 ->
    sub_tvar_chain
      (E1 ++ X1 ~ bind_sub X2 ++ E2)
      (X1 ~ bind_sub X2 ++ W) X1 X3
(* | sub_tvar_cons_right: forall E1 E2 W (X1 X2 X3:atom),
    wf_env (E1 ++ X3 ~ bind_sub_lb X2 ++ E2) ->
    sub_tvar_chain (E1 ++ X3 ~ bind_sub_lb X2 ++ E2) W X1 X2 ->
    sub_tvar_chain
      (E1 ++ X3 ~ bind_sub_lb X2 ++ E2)
      (X3 ~ bind_sub_lb X2 ++ W) X1 X3. *).

Inductive sub_tvar_chain_lb : env -> env  -> atom -> atom -> Prop :=
| sub_tvar_refl_lb: forall E U X,
    wf_env E -> binds X (bind_sub_lb U) E ->
    sub_tvar_chain_lb E (X ~ bind_sub_lb U) X X
| sub_tvar_cons_lb: forall E1 E2 W (X1 X2 X3:atom),
    wf_env (E1 ++ X3 ~ bind_sub_lb X2 ++ E2) ->
    sub_tvar_chain_lb (E1 ++ X3 ~ bind_sub_lb X2 ++ E2) W X1 X2 ->
    sub_tvar_chain_lb
      (E1 ++ X3 ~ bind_sub_lb X2 ++ E2)
      (X3 ~ bind_sub_lb X2 ++ W) X1 X3.

Lemma sub_tvar_chain_subset: forall E W X Y,
  sub_tvar_chain E W X Y ->
  forall K V, binds K V W -> binds K V E.
Proof with auto.
  intros. induction H.
  - inversion H0. { inversion H2;subst... }
    inversion H2.
  (* - inversion H0. { inversion H2;subst... }
    inversion H2. *)
  - destruct H0...
    inversion H0...
  (* - destruct H0...
    inversion H0... *)
Qed.

Lemma sub_tvar_chain_subset_lb: forall E W X Y,
  sub_tvar_chain_lb E W X Y ->
  forall K V, binds K V W -> binds K V E.
Proof with auto.
  intros. induction H.
  - inversion H0. { inversion H2;subst... }
    inversion H2.
  - destruct H0...
    inversion H0...
Qed.

Lemma sub_tvar_chain_strengthening: forall Z U W E2 X Y,
  sub_tvar_chain (Z ~ U ++ E2) W X Y ->
  Z \notin dom W ->
  sub_tvar_chain (E2) W X Y.
Proof with auto.
  intros. dependent induction H.
  - apply sub_tvar_refl with (U:=U0)...
    { apply wf_env_cons in H... }
    { destruct H0... inversion H0. subst.
      exfalso. apply H1. simpl... }
  (* - apply sub_tvar_refl_lb with (U:=U0)...
    { apply wf_env_cons in H... }
    { destruct H0... inversion H0. subst.
      exfalso. apply H1. simpl... } *)
  - destruct E1.
    { inversion x;subst. exfalso.
      apply H1. simpl... }
    { inversion x;subst.
      specialize (IHsub_tvar_chain Z U (E1 ++ X1 ~ bind_sub X2 ++ E0) JMeq_refl).
      eapply sub_tvar_cons...
      rewrite <- app_comm_cons  in H.
      rewrite cons_app_one in H. apply wf_env_cons in H...
    }
  (* - destruct E1.
    { inversion x;subst. exfalso.
      apply H1. simpl... }
    { inversion x;subst.
      specialize (IHsub_tvar_chain Z U (E1 ++ X3 ~ bind_sub_lb X2 ++ E0) JMeq_refl).
      eapply sub_tvar_cons_right...
      rewrite <- app_comm_cons  in H.
      rewrite cons_app_one in H. apply wf_env_cons in H...
    }  *)
Qed.

Lemma sub_tvar_chain_strengthening_lb: forall Z U W E2 X Y,
  sub_tvar_chain_lb (Z ~ U ++ E2) W X Y ->
  Z \notin dom W ->
  sub_tvar_chain_lb (E2) W X Y.
Proof with auto.
  intros. dependent induction H.
  - apply sub_tvar_refl_lb with (U:=U0)...
    { apply wf_env_cons in H... }
    { destruct H0... inversion H0. subst.
      exfalso. apply H1. simpl... }
  - destruct E1.
    { inversion x;subst. exfalso.
      apply H1. simpl... }
    { inversion x;subst.
      specialize (IHsub_tvar_chain_lb Z U (E1 ++ X3 ~ bind_sub_lb X2 ++ E0) JMeq_refl).
      eapply sub_tvar_cons_lb...
      rewrite <- app_comm_cons  in H.
      rewrite cons_app_one in H. apply wf_env_cons in H...
    }
Qed.

Lemma binds_uniq: forall E X A B,
    wf_env E ->
    binds X ( A) E ->
    binds X ( B) E ->
    A = B.
Proof with auto.
  induction E;intros...
  analyze_binds H0.
  destruct a.
  analyze_binds_uniq H0.
  -
    apply uniq_from_wf_env...
  -
    analyze_binds_uniq H1...
  -
    analyze_binds_uniq H1...
    apply IHE with (X:=X)...
    dependent destruction H...
Qed.

Lemma sub_tvar_inv:forall E U (X:atom),
    sub E U X ->
    (exists Y, U = typ_fvar Y) \/
    (exists G, binds X (bind_sub_lb G) E /\ sub E U G) \/  U = typ_bot.
Proof with auto.
  intros.
  dependent induction H...
  - left. exists X...
  - left. exists X0...
  - right. left. exists U...
Qed.

Lemma sub_tvar_inv2: forall E U (X:atom),
    sub E X U ->
    (exists Y, U = typ_fvar Y) \/
    (exists G, binds X (bind_sub G) E /\ sub E G U) \/
    U = typ_top.
Proof with auto.
  intros.
  dependent induction H...
  - left. exists X...
  - right. left. exists U...
  - left. exists X0...
Qed.

(* Lemma sub_tvar_next_fvar: forall (X X0:atom) E1 E2 U,
   wf_env (E1 ++ [(X, bind_sub U)] ++ E2) ->
   sub (E1 ++ [(X, bind_sub U)] ++ E2) X X0 ->
   X <> X0 ->
   (exists Y, U = typ_fvar Y) \/
   (exists G, binds X0 (bind_sub_lb G) (E1 ++ [(X, bind_sub U)] ++ E2) ).
   (* /\ sub (E1 ++ [(X, bind_sub U)] ++ E2)  U G). *)
Proof with auto.
  intros. dependent destruction H0.
  - exfalso...
  - destruct (sub_tvar_inv H1) as [[X' Et]|G].
    + subst U0.
      assert (binds X (bind_sub U) (E1 ++ [(X, bind_sub U)] ++ E2)) by auto.
      pose proof binds_uniq _ _ _ H H0 H3. subst U. left.
      exists X'...
    + destruct_hypos. right. exists x...
  - destruct (sub_tvar_inv2 H1) as [[X' Et]|[G|G]].
    + subst U0.
      assert (binds X (bind_sub U) (E1 ++ [(X, bind_sub U)] ++ E2)) by auto.
      pose proof binds_uniq _ _ _ H H0 H3. subst U. left.
      exists X'...

  right. exists U0...
Qed. *)

(* TODO add mode *)

Lemma suba_sub_tvar_chain: forall E (X1 X2:atom),
    sub E X1 X2 ->
    (exists W, sub_tvar_chain E W X1 X2) \/
    (exists W, sub_tvar_chain_lb E W X1 X2) \/
    (exists U1 U2, binds X1 (bind_sub U1) E /\ binds X2 (bind_sub_lb U2) E) \/
    (sub E typ_top X2) \/ (sub E X1 typ_bot).
Proof with auto.
  intros.
  dependent induction H...
  - inversion H0;subst.
    + left. exists (X2 ~ bind_sub U).
      apply sub_tvar_refl with (U:=U)...
    + right. left. exists (X2 ~ bind_sub_lb U).
      apply sub_tvar_refl_lb with (U:=U)...
  - pose proof sub_regular H0. destruct_hypos.
    pose proof binds_split _ _ _ H.
    destruct H4 as [E1 [E2 H4]].
    pose proof sub_tvar_inv  H0. destruct H5 as [[X' H5]|[H5|H5]].
    + subst U.
      specialize (IHsub X' X2 eq_refl eq_refl).
      destruct IHsub as [[W IHsub]|[[W IHsub]|[[U1 [U2 [IHsub1 IHsub2]]]|[IHsub|IHsub]]]].
      * subst E. left. exists (X1 ~ bind_sub X' ++ W).
        eapply sub_tvar_cons with (E2:=E2) (X2:=X')...
      * right. right. left. exists X'.
        inversion IHsub;subst.
        { exists U... }
        { exists X3... split... rewrite H7 in *... }
      * right. right. left. exists X', U2...
      * right. right. right. left...
      * right. right. right. right... apply sa_trans_tvar with (U:=X')...
    + destruct H5 as [G]. destruct_hypos.
      right. right. left. exists U, G...
    + subst U. right. right. right. right...
      apply sa_trans_tvar with (U:=typ_bot)...

  - pose proof sub_regular H0. destruct_hypos.
    pose proof binds_split_lb _ _ _ H.
    destruct H4 as [E1 [E2 H4]].
    pose proof sub_tvar_inv2 H0. destruct H5 as [[X' H5]|[H5|H5]].
    + subst U.
      specialize (IHsub X1 X' eq_refl eq_refl).
      destruct IHsub as [[W IHsub]|[[W IHsub]|[[U1 [U2 [IHsub1 IHsub2]]]|[IHsub|IHsub]]]].
      * right. right.
        inversion IHsub;subst.
        { left. exists U, X'... }
        { left. exists X3, X'... split... rewrite H7 in *... }
      * subst E. right. left. exists (X2 ~ bind_sub_lb X' ++ W).
        eapply sub_tvar_cons_lb with (E2:=E2) (X2:=X')...
      * right. right. left. exists U1, X'...
      * right. right. right. left. apply sub_transitivity with (Q:=X')...
        eapply sa_trans_tvar_lb with (U:=X')...
      * right. right. right. right...
    + destruct H5 as [G]. destruct_hypos.
      right. right. left. exists G, U...
    + subst. right. right. right. left. apply sa_trans_tvar_lb with (U:=typ_top)...
Qed.

Inductive sub_env: env -> env -> Prop :=
| sub_env_nil : forall E, sub_env E empty
| sub_env_cons_some : forall E W K V,
    sub_env E W ->
    sub_env (K ~ V ++ E) (K ~ V ++ W)
| sub_env_cons_none : forall E W K V,
    sub_env E W ->
    sub_env (K ~ V ++ E) W.

Lemma sub_env_app: forall E1 E2 W,
    sub_env E2 W ->
    sub_env (E1 ++ E2) W.
Proof. intros E1.
  induction E1;intros...
  - apply H.
  - simpl. rewrite cons_app_one.
    destruct a. apply sub_env_cons_none.
    apply IHE1. auto.
Qed.

Lemma WF_from_binds_typ_strong:
forall (x : atom) (U : typ) (E1 E2 : env),
  wf_env (E1 ++ [(x, bind_sub U)] ++ E2) ->
  WF E2 U.
Proof with auto.
intros.
dependent induction H.
-
  destruct E1;inversion x.
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
Qed.

Lemma sub_env_clos: forall E W,
  sub_env E W ->
  forall X, X `in` dom W -> X `in` dom E.
Proof with auto.
  intros E W H.
  induction H;intros;simpl in*...
  - apply empty_iff in H. exfalso...
  - rewrite KeySetProperties.add_union_singleton in *.
    apply union_iff. apply union_iff in H0.
    destruct H0...
Qed.

Lemma sub_env_cut_head:
  forall  E2 X1 X2 T1 T2 W,
  X1 <> X2 ->
  sub_env (X1 ~ T1 ++ E2) (X2 ~ T2 ++ W) ->
  sub_env E2 (X2 ~ T2 ++ W).
Proof with auto.
  intros.
  inversion H0;subst...
  exfalso...
Qed.

Lemma sub_env_cut_heads:
  forall E1 E2 X T W, uniq (E1 ++ X ~ T ++ E2) ->
  sub_env (E1 ++ X ~ T ++ E2) (X ~ T ++ W) ->
  sub_env E2 W.
Proof with auto.
  intros E1. induction E1...
  - intros. inversion H0;subst...
    pose proof sub_env_clos H5.
    apply uniq_cons_2 in H.
    exfalso. apply H. simpl. apply H1. simpl...
  - intros.  destruct a as [X' T'].
    simpl in H0. rewrite cons_app_one in H0.
    apply sub_env_cut_head in H0.
    2:{ apply uniq_cons_2 in H... }
    inversion H;subst.
    apply IHE1 with (X:=X) (T:=T)...
Qed.

Lemma uniq_split_eq: forall (E1 E2 E1' E2':env) (X:atom) (T T':binding),
  uniq (E1 ++ X ~ T ++ E2) ->
  E1 ++ X ~ T ++ E2 = E1' ++ X ~ T' ++ E2' ->
  E1 = E1' /\ T = T' /\ E2 = E2'.
Proof with auto.
  intros E1.
  induction E1;intros.
  - destruct E1'.
    { inversion H0... }
    destruct p. inversion H0;subst.
    apply uniq_cons_2 in H. exfalso...
    rewrite dom_app in H. simpl in H...
  - destruct E1'.
    { inversion H0. destruct a. inversion H2;subst.
      apply uniq_cons_2 in H. exfalso...
      rewrite dom_app in H. simpl in H... }
    inversion H0;subst.
    inversion H;subst.
    specialize (IHE1 _ _ _ _ _ _ H4 H3).
    destruct_hypos;subst...
Qed.

Lemma binds_uniq': forall X U T E1 E2,
  wf_env (E1 ++ [(X, bind_sub T)] ++ E2) ->
  binds X (bind_sub U) (E1 ++ [(X, bind_sub T)] ++ E2) ->
  U = T.
Proof.
  intros.
  assert (binds X (bind_sub T) (E1 ++ [(X, bind_sub T)] ++ E2)) by auto.
  pose proof binds_uniq _ _ _ H H0 H1... inversion H2.
  auto.
Qed.

Lemma sub_tvar_chain_sub_env: forall E W X Y,
  sub_tvar_chain E W X Y ->
  sub_env E W.
Proof with auto.
  intros. dependent induction H;intros...
  - apply binds_split in H0. destruct H0 as [E1 [E2 H0]].
    rewrite H0. apply sub_env_app.
    apply sub_env_cons_some. apply sub_env_nil.
  - pose proof WF_from_binds_typ_strong _ _ _ _ H.
    inversion H1;subst.
    + apply binds_split in H4.
      destruct H4 as [E3 [E4 H5]]. subst E2.
      apply sub_env_app.
      apply sub_env_cons_some.
      apply sub_env_app.
      inversion H0;subst.
      { rewrite <- app_assoc in H3.
        rewrite <- app_assoc in H3. apply binds_uniq' in H3.
        2:{ rewrite !app_assoc... }
        subst U0. apply sub_env_cons_some. apply sub_env_nil. }
      { rewrite <- app_assoc in IHsub_tvar_chain.
        rewrite <- app_assoc in IHsub_tvar_chain.
        replace (E1 ++ (X1, bind_sub X2) :: E3 ++ (X2, bind_sub U) :: E4)
        with ((E1 ++ (X1, bind_sub X2) :: E3) ++ [(X2, bind_sub U)] ++ E4) in H2.
        2:{ rewrite !app_assoc... }
        replace (E0 ++ (X2, bind_sub X4) :: E2) with
        (E0 ++ [(X2, bind_sub X4)] ++ E2) in H2...
        pose proof uniq_from_wf_env H3.
        pose proof uniq_split_eq _ _ _ _ _ _ _ H5 H2.
        destruct_hypos. inversion H7. subst.
        apply sub_env_cons_some.
        apply sub_env_cut_heads in IHsub_tvar_chain...
        apply uniq_from_wf_env... rewrite !app_assoc...
      }
    +
      inversion H0;subst.
      * assert (binds X3 (bind_sub_lb U) (E1 ++ X1 ~ bind_sub X3 ++ E2))...
        pose proof binds_uniq _ _ _ H2 H3 H5.
        inversion H6.
      * assert (binds X2 (bind_sub X4) (E1 ++ X1 ~ bind_sub X2 ++ E2))...
        { simpl in H2. simpl. rewrite <- H2... }
        assert (binds X2 (bind_sub_lb U) (E1 ++ X1 ~ bind_sub X2 ++ E2))...
        simpl in H3. rewrite H2 in H3.
        pose proof binds_uniq _ _ _ H3 H6 H7.
        inversion H8.
Qed.

Lemma sub_tvar_chain_tail_in: forall E W X Y,
  sub_tvar_chain E W X Y ->
  exists W' T, W = W' ++ Y ~ bind_sub T.
Proof with auto.
  intros.
  induction H...
  - exists nil, ( U)...
  - destruct IHsub_tvar_chain as [W' [T IH]].
    exists (X1 ~ bind_sub X2 ++ W'), T.
    rewrite IH...
Qed.

Lemma sub_env_binds: forall E W X T,
  sub_env E W ->
  binds X T W ->
  binds X T E.
Proof with auto.
  intros.
  induction H...
  - inversion H0.
  - destruct H0... inversion H0...
Qed.

Lemma sub_tvar_chain_antisym: forall E W1 W2 X Y,
  sub_tvar_chain E W1 X Y ->
  sub_tvar_chain E W2 Y X ->
  X = Y.
Proof with auto.
  intros.
  inversion H;subst...
  inversion H0;subst...
  destruct (X == Y)...

  assert (exists T, binds Y (bind_sub T) E2).
  {
    pose proof sub_tvar_chain_sub_env H.
    apply sub_env_cut_heads in H6.
    2:{ apply uniq_from_wf_env... }
    pose proof sub_tvar_chain_tail_in H.
    destruct H7 as [W' [T H7]].
    destruct W';inversion H7;subst...
    { exfalso... }
    exists T.
    apply sub_env_binds with (X:=Y) (T:=bind_sub T) in H6...
  }

  assert (exists T, binds X (bind_sub T) E3).
  {
    rewrite !cons_app_one in H3. rewrite <- H3 in H0.
    pose proof sub_tvar_chain_sub_env H0.
    apply sub_env_cut_heads in H7.
    2:{ apply uniq_from_wf_env... }
    pose proof sub_tvar_chain_tail_in H0.
    destruct H8 as [W' [T H8]].
    destruct W';inversion H8;subst...
    { exfalso... }
    exists T.
    apply sub_env_binds with (X:=X) (T:=bind_sub T) in H7...
  }

  destruct H6. destruct H7.
  apply binds_split in H6.
  apply binds_split in H7.
  destruct H6 as [E1a [E1b H6]], H7 as [E2a [E2b H7]].
  rewrite H6, H7 in H3.
  rewrite !cons_app_one in H3. rewrite <-app_assoc in H3.
  rewrite <- app_assoc in H3.
  apply uniq_split_eq in H3.
  2:{ apply uniq_from_wf_env. rewrite !app_assoc.
      rewrite H7 in H4... }
  destruct_hypos. subst.
  apply uniq_from_wf_env in H1.
  rewrite !app_assoc in H1.
  apply uniq_app_2 in H1.
  apply uniq_cons_2 in H1.
  rewrite !dom_app in H1...
  exfalso. apply H1. apply union_iff. right.
  apply union_iff. right. apply union_iff. right.
  apply union_iff. left. apply KeySetFacts.add_iff...
Qed.

(* Dual proof for lower bound *)

Lemma WF_from_binds_typ_strong_lb:
forall (x : atom) (U : typ) (E1 E2 : env),
  wf_env (E1 ++ [(x, bind_sub_lb U)] ++ E2) ->
  WF E2 U.
Proof with auto.
intros.
dependent induction H.
-
  destruct E1;inversion x.
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
-
  destruct E1;inversion x;subst...
  specialize (IHwf_env _ _ _ _ JMeq_refl)...
Qed.

Lemma binds_uniq_lb': forall X U T E1 E2,
  wf_env (E1 ++ [(X, bind_sub_lb T)] ++ E2) ->
  binds X (bind_sub_lb U) (E1 ++ [(X, bind_sub_lb T)] ++ E2) ->
  U = T.
Proof.
  intros.
  assert (binds X (bind_sub_lb T) (E1 ++ [(X, bind_sub_lb T)] ++ E2)) by auto.
  pose proof binds_uniq _ _ _ H H0 H1... inversion H2.
  auto.
Qed.

Lemma sub_tvar_chain_sub_env_lb: forall E W X Y,
  sub_tvar_chain_lb E W X Y ->
  sub_env E W.
Proof with auto.
  intros. dependent induction H;intros...
  - apply binds_split_lb in H0. destruct H0 as [E1 [E2 H0]].
    rewrite H0. apply sub_env_app.
    apply sub_env_cons_some. apply sub_env_nil.
  - pose proof WF_from_binds_typ_strong_lb _ _ _ _ H.
    inversion H1;subst.
    +
      inversion H0;subst.
      * assert (binds X2 (bind_sub U)  (E1 ++ X3 ~ bind_sub_lb X2 ++ E2))...
        pose proof binds_uniq _ _ _ H2 H3 H5.
        inversion H6.
      * assert (binds X2 (bind_sub_lb X4) (E1 ++ X3 ~ bind_sub_lb X2 ++ E2))...
        { simpl in H2. simpl. rewrite <- H2... }
        assert (binds X2 (bind_sub U) (E1 ++ X3 ~ bind_sub_lb X2 ++ E2))...
        simpl in H3. rewrite H2 in H3.
        pose proof binds_uniq _ _ _ H3 H6 H7.
        inversion H8.
    + apply binds_split_lb in H4.
      destruct H4 as [E3 [E4 H5]]. subst E2.
      apply sub_env_app.
      apply sub_env_cons_some.
      apply sub_env_app.
      inversion H0;subst.
      { rewrite <- app_assoc in H3.
        rewrite <- app_assoc in H3. apply binds_uniq_lb' in H3.
        2:{ rewrite !app_assoc... }
        subst U0. apply sub_env_cons_some. apply sub_env_nil. }
      { rewrite <- app_assoc in IHsub_tvar_chain_lb.
        rewrite <- app_assoc in IHsub_tvar_chain_lb.
        replace (E1 ++ (X3, bind_sub_lb X2) :: E3 ++ (X2, bind_sub_lb U) :: E4)
        with ((E1 ++ (X3, bind_sub_lb X2) :: E3) ++ [(X2, bind_sub_lb U)] ++ E4) in H2.
        2:{ rewrite !app_assoc... }
        replace (E0 ++ (X2, bind_sub_lb X4) :: E2) with
        (E0 ++ [(X2, bind_sub_lb X4)] ++ E2) in H2...
        pose proof uniq_from_wf_env H3.
        pose proof uniq_split_eq _ _ _ _ _ _ _ H5 H2.
        destruct_hypos. inversion H7. subst.
        apply sub_env_cons_some.
        apply sub_env_cut_heads in IHsub_tvar_chain_lb...
        apply uniq_from_wf_env... rewrite !app_assoc...
      }
Qed.

Lemma sub_tvar_chain_tail_in_lb: forall E W X Y,
  sub_tvar_chain_lb E W X Y ->
  exists W' T, W = W' ++ X ~ bind_sub_lb T.
Proof with auto.
  intros.
  induction H...
  - exists nil, ( U)...
  - destruct IHsub_tvar_chain_lb as [W' [T IH]].
    exists (X3 ~ bind_sub_lb X2 ++ W'), T.
    rewrite IH...
Qed.

Lemma sub_tvar_chain_antisym_lb: forall E W1 W2 X Y,
  sub_tvar_chain_lb E W1 X Y ->
  sub_tvar_chain_lb E W2 Y X ->
  X = Y.
Proof with auto.
  intros.
  inversion H;subst...
  inversion H0;subst...
  destruct (X == Y)...

  assert (exists T, binds X (bind_sub_lb T) E2).
  {
    pose proof sub_tvar_chain_sub_env_lb H.
    apply sub_env_cut_heads in H6.
    2:{ apply uniq_from_wf_env... }
    pose proof sub_tvar_chain_tail_in_lb H.
    destruct H7 as [W' [T H8]].
    destruct W';inversion H8;subst...
    { exfalso... }
    exists T.
    apply sub_env_binds with (X:=X) (T:=bind_sub_lb T) in H6...
  }

  assert (exists T, binds Y (bind_sub_lb T) E3).
  {
    rewrite !cons_app_one in H3. rewrite <- H3 in H0.
    pose proof sub_tvar_chain_sub_env_lb H0.
    apply sub_env_cut_heads in H7.
    2:{ apply uniq_from_wf_env... }
    pose proof sub_tvar_chain_tail_in_lb H0.
    destruct H8 as [W' [T H8]].
    destruct W';inversion H8;subst...
    { exfalso... }
    exists T.
    apply sub_env_binds with (X:=Y) (T:=bind_sub_lb T) in H7...
  }

  destruct H6. destruct H7.
  apply binds_split_lb in H6.
  apply binds_split_lb in H7.
  destruct H6 as [E1a [E1b H6]], H7 as [E2a [E2b H7]].
  rewrite H6, H7 in H3.
  rewrite !cons_app_one in H3. rewrite <-app_assoc in H3.
  rewrite <- app_assoc in H3.
  apply uniq_split_eq in H3.
  2:{ apply uniq_from_wf_env. rewrite !app_assoc.
      rewrite H7 in H4... }
  destruct_hypos. subst.
  apply uniq_from_wf_env in H1.
  rewrite !app_assoc in H1.
  apply uniq_app_2 in H1.
  apply uniq_cons_2 in H1.
  rewrite !dom_app in H1...
  exfalso. apply H1. apply union_iff. right.
  apply union_iff. right. apply union_iff. right.
  apply union_iff. left. apply KeySetFacts.add_iff...
Qed.