From Hammer Require Import Hammer.

From hahn Require Import HahnBase HahnList HahnSets HahnRelationsBasic.
From hahn Require Import HahnEquational HahnRewrite HahnMaxElt.
Require Import NPeano Omega Setoid.

Set Implicit Arguments.

Definition min_elt A (r: relation A) (a : A) :=
forall b (REL: r b a), False.

Definition wmin_elt A (r: relation A) (a : A) :=
forall b (REL: r b a), a = b.

Section BasicProperties.

Variable A : Type.
Variables r r' r'' : relation A.
Variable a : A.

Lemma min_transp : min_elt r⁻¹ ≡₁ max_elt r.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_transp".
split; unfold min_elt, max_elt, transp, set_subset; ins; desf.
Qed.

Lemma max_transp : max_elt r⁻¹ ≡₁ min_elt r.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.max_transp".
split; unfold min_elt, max_elt, transp, set_subset; ins; desf.
Qed.

Lemma set_subset_min_elt (S: r' ⊆ r) : min_elt r ⊆₁ min_elt r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.set_subset_min_elt". unfold min_elt, inclusion, set_subset in *; intuition; eauto. Qed.

Lemma set_subset_wmin_elt (S: r' ⊆ r) : wmin_elt r ⊆₁ wmin_elt r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.set_subset_wmin_elt". unfold wmin_elt, inclusion, set_subset in *; intuition; eauto. Qed.

Lemma set_equiv_min_elt (S: r ≡ r') : min_elt r ≡₁ min_elt r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.set_equiv_min_elt". unfold min_elt, same_relation, set_equiv, set_subset in *; intuition; eauto. Qed.

Lemma set_equiv_wmin_elt (S: r ≡ r') : wmin_elt r ≡₁ wmin_elt r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.set_equiv_wmin_elt". unfold wmin_elt, same_relation, set_equiv in *; intuition; eauto. Qed.

Lemma min_elt_weaken : min_elt r a -> wmin_elt r a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_elt_weaken".
red; ins; exfalso; eauto.
Qed.

Lemma min_elt_union : min_elt r a -> min_elt r' a -> min_elt (r +++ r') a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_elt_union".
unfold union; red; ins; desf; eauto.
Qed.

Lemma wmin_elt_union : wmin_elt r a -> wmin_elt r' a -> wmin_elt (r +++ r') a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_union".
unfold union; red; ins; desf; eauto.
Qed.

Lemma min_elt_t : min_elt r a -> min_elt (r⁺) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_elt_t".
red; ins; apply clos_trans_t1n in REL; induction REL; eauto.
Qed.

Lemma wmin_elt_rt : wmin_elt r a -> wmin_elt (r＊) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_rt".
red; ins; apply clos_rt_rt1n in REL; induction REL; intuition; desf; eauto.
Qed.

Lemma wmin_elt_t : wmin_elt r a -> wmin_elt (r⁺) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_t".
by red; ins; eapply wmin_elt_rt, inclusion_t_rt.
Qed.

Lemma wmin_elt_eqv (f: A -> Prop) : wmin_elt (eqv_rel f) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_eqv".
unfold eqv_rel; red; ins; desf.
Qed.

Lemma wmin_elt_restr_eq B (f: A -> B) :
wmin_elt r a -> wmin_elt (restr_eq_rel f r) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_restr_eq".
unfold restr_eq_rel in *; red; ins; desf; eauto.
Qed.

Lemma min_elt_restr_eq B (f: A -> B) :
min_elt r a -> min_elt (restr_eq_rel f r) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_elt_restr_eq".
unfold restr_eq_rel in *; red; ins; desf; eauto.
Qed.

Lemma wmin_elt_r :
wmin_elt r a -> wmin_elt (r^?) a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_r".
unfold clos_refl; red; ins; desf; eauto.
Qed.

Lemma min_elt_seq1 : min_elt r' a -> min_elt (r ⨾ r') a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_elt_seq1".
unfold seq; red; ins; desf; apply H in REL0; desf; eauto.
Qed.

Lemma wmin_elt_seq2 : wmin_elt r a -> wmin_elt r' a -> wmin_elt (r ⨾ r') a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_seq2".
unfold seq; red; ins; desf; apply H0 in REL0; desf; eauto.
Qed.

Lemma wmin_elt_seq1 : min_elt r' a -> wmin_elt (r ⨾ r') a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_seq1".
unfold seq; red; ins; desf; apply H in REL0; desf; eauto.
Qed.

Lemma min_elt_seq2 : min_elt r a -> wmin_elt r' a -> min_elt (r ⨾ r') a.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.min_elt_seq2".
unfold seq; red; ins; desf; apply H0 in REL0; desf; eauto.
Qed.

End BasicProperties.

Hint Immediate min_elt_weaken : hahn.
Hint Resolve wmin_elt_union min_elt_union : hahn.
Hint Resolve wmin_elt_t wmin_elt_r wmin_elt_rt min_elt_t : hahn.
Hint Resolve min_elt_restr_eq wmin_elt_restr_eq : hahn.
Hint Resolve min_elt_seq1 min_elt_seq2 wmin_elt_seq1 wmin_elt_seq2 : hahn.

Section MoreProperties.

Variable A : Type.
Implicit Type r : relation A.

Lemma seq_min r r' b
(MAX: min_elt r b) (DOM: forall x y, r' x y -> x = b) :
r ⨾ r' ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min".
unfold seq; split; red; ins; desf.
apply DOM in H0; desf; eauto.
Qed.

Lemma seq_min_t r r' b
(MAX: min_elt r b) (DOM: forall x y, r' x y -> x = b) :
r ⁺ ⨾ r'  ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_t".
eauto using seq_min with hahn.
Qed.

Lemma seq_min_rt r r' b
(MAX: min_elt r b) (COD: forall x y, r' x y -> x = b) :
r ＊ ⨾ r' ≡ r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_rt".
rewrite rtE; relsf; rewrite seq_min_t; relsf.
Qed.

Lemma seq_min_r r r' b
(MAX: min_elt r b) (COD: forall x y, r' x y -> x = b) :
r ^? ⨾ r' ≡ r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_r".
rewrite crE; relsf; rewrite seq_min; relsf.
Qed.

Lemma seq_min_eq r b (MAX: min_elt r b) :
r ⨾⦗eq b⦘ ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_eq".
eapply seq_min; unfold eqv_rel; ins; desf; eauto.
Qed.

Lemma seq_min_t_eq r b (MAX: min_elt r b) :
r⁺ ⨾⦗eq b⦘ ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_t_eq".
eauto using seq_min_eq with hahn.
Qed.

Lemma seq_min_rt_eq r b (MAX: min_elt r b) :
r＊ ⨾⦗eq b⦘ ≡ ⦗eq b⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_rt_eq".
rewrite rtE; relsf; rewrite seq_min_t_eq; relsf.
Qed.

Lemma seq_min_r_eq r b (MAX: min_elt r b) :
r^? ⨾⦗eq b⦘ ≡ ⦗eq b⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_r_eq".
rewrite crE; relsf; rewrite seq_min_eq; relsf.
Qed.

Lemma seq_min_singl r a b (MAX: min_elt r a) :
r ⨾ singl_rel a b ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_singl".
unfold singl_rel, seq; split; red; ins; desf; eauto.
Qed.

Lemma seq_min_t_singl r a b (MAX: min_elt r a) :
r⁺ ⨾ singl_rel a b ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_t_singl".
eauto using seq_min_singl with hahn.
Qed.

Lemma seq_min_rt_singl r a b (MAX: min_elt r a) :
r＊ ⨾ singl_rel a b ≡ singl_rel a b.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_rt_singl".
rewrite rtE; relsf; rewrite seq_min_t_singl; relsf.
Qed.

Lemma seq_min_r_singl r a b (MAX: min_elt r a) :
r^? ⨾ singl_rel a b ≡ singl_rel a b.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_min_r_singl".
rewrite crE; relsf; rewrite seq_min_singl; relsf.
Qed.

Lemma seq_eqv_min r :
r ⨾ ⦗min_elt r⦘ ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_eqv_min".
basic_solver.
Qed.

Lemma seq_t_eqv_min r :
r⁺ ⨾ ⦗min_elt r⦘ ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_t_eqv_min".
rewrite ct_end, seqA; seq_rewrite seq_eqv_min; basic_solver.
Qed.

Lemma seq_rt_eqv_min r :
r＊ ⨾ ⦗min_elt r⦘ ≡ ⦗min_elt r⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_rt_eqv_min".
rewrite rtE; relsf; rewrite seq_t_eqv_min; relsf.
Qed.

Lemma seq_r_eqv_min r :
r^? ⨾ ⦗min_elt r⦘ ≡ ⦗min_elt r⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_r_eqv_min".
rewrite crE; relsf; rewrite seq_eqv_min; relsf.
Qed.

Lemma seq_eqv_min_transp r :
⦗min_elt r⦘ ⨾ r⁻¹  ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_eqv_min_transp".
basic_solver.
Qed.

Lemma seq_eqv_min_transp_t r :
⦗min_elt r⦘ ⨾ (r⁻¹)⁺ ≡ ∅₂.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_eqv_min_transp_t".
rewrite ct_begin; seq_rewrite seq_eqv_min_transp; basic_solver.
Qed.

Lemma seq_eqv_min_transp_rt r :
⦗min_elt r⦘ ⨾ (r⁻¹)＊  ≡ ⦗min_elt r⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_eqv_min_transp_rt".
rewrite rtE; relsf; rewrite seq_eqv_min_transp_t; relsf.
Qed.

Lemma seq_eqv_min_transp_r r :
⦗min_elt r⦘ ⨾ (r⁻¹)^?  ≡ ⦗min_elt r⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_eqv_min_transp_r".
rewrite crE; relsf; rewrite seq_eqv_min_transp; relsf.
Qed.

Lemma seq_wmin r r' b
(MAX: wmin_elt r b) (D: forall x y, r' x y -> x = b) :
r⨾ r' ⊆ r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin".
unfold seq; red; ins; desf; eauto.
specialize (D _ _ H0); desf; apply MAX in H; desf.
Qed.

Lemma seq_wmin_t r r' b
(MAX: wmin_elt r b) (D: forall x y, r' x y -> x = b) :
r ⁺⨾ r' ⊆ r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_t".
eauto using seq_wmin with hahn.
Qed.

Lemma seq_wmin_rt r r' b
(MAX: wmin_elt r b) (COD: forall x y, r' x y -> x = b) :
r ＊⨾ r' ≡ r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_rt".
rewrite rtE; split; relsf; rewrite seq_wmin_t; relsf.
Qed.

Lemma seq_wmin_r r r' b
(MAX: wmin_elt r b) (COD: forall x y, r' x y -> x = b) :
r ^?⨾ r' ≡ r'.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_r".
rewrite crE; split; relsf; rewrite seq_wmin; relsf.
Qed.

Lemma seq_wmin_eq r b (MAX: wmin_elt r b) :
r ⨾ ⦗eq b⦘ ⊆ ⦗eq b⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_eq".
eapply seq_wmin; unfold eqv_rel; ins; desf.
Qed.

Lemma seq_wmin_t_eq r b (MAX: wmin_elt r b) :
r ⁺ ⨾ ⦗eq b⦘ ⊆ ⦗eq b⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_t_eq".
eauto using seq_wmin_eq with hahn.
Qed.

Lemma seq_wmin_rt_eq r b (MAX: wmin_elt r b) :
r ＊ ⨾ ⦗eq b⦘ ≡ ⦗eq b⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_rt_eq".
rewrite rtE; split; relsf; rewrite seq_wmin_t_eq; relsf.
Qed.

Lemma seq_wmin_r_eq r b (MAX: wmin_elt r b) :
r ^? ⨾ ⦗eq b⦘ ≡ ⦗eq b⦘.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_r_eq".
rewrite crE; split; relsf; rewrite seq_wmin_eq; relsf.
Qed.

Lemma seq_wmin_singl r a b (MAX: wmin_elt r a) :
r ⨾ singl_rel a b ⊆ singl_rel a b.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_singl".
unfold singl_rel, seq; red; ins; desf; eauto.
apply MAX in H; desf.
Qed.

Lemma seq_wmin_t_singl r a b (MAX: wmin_elt r a) :
r ⁺ ⨾ singl_rel a b ⊆ singl_rel a b.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_t_singl".
eauto using seq_wmin_singl with hahn.
Qed.

Lemma seq_wmin_rt_singl r a b (MAX: wmin_elt r a) :
r ＊ ⨾ singl_rel a b ≡ singl_rel a b.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_rt_singl".
rewrite rtE; split; relsf; rewrite seq_wmin_t_singl; relsf.
Qed.

Lemma seq_wmin_r_singl r a b (MAX: wmin_elt r a) :
r ^? ⨾ singl_rel a b ≡ singl_rel a b.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.seq_wmin_r_singl".
rewrite crE; split; relsf; rewrite seq_wmin_singl; relsf.
Qed.

End MoreProperties.

Hint Unfold min_elt wmin_elt : unfolderDb.

Require Import Morphisms.

Instance min_elt_Proper A : Proper (inclusion --> set_subset) _ := set_subset_min_elt (A:=A).
Instance wmin_elt_Proper A : Proper (inclusion --> set_subset) _ := set_subset_wmin_elt (A:=A).
Instance min_elt_Propere A : Proper (same_relation ==> set_equiv) _ := set_equiv_min_elt (A:=A).
Instance wmin_elt_Propere A : Proper (same_relation ==> set_equiv) _ := set_equiv_wmin_elt (A:=A).

Add Parametric Morphism A : (@min_elt A) with signature
inclusion --> eq ==> Basics.impl as min_elt_mori.
Proof. hammer_hook "HahnMinElt" "HahnMinElt.wmin_elt_Propere".
unfold inclusion, min_elt, Basics.impl; eauto.
Qed.

Add Parametric Morphism A : (@wmin_elt A) with signature
inclusion --> eq ==> Basics.impl as wmin_elt_mori.
Proof.
unfold inclusion, wmin_elt, Basics.impl; eauto.
Qed.

Add Parametric Morphism A : (@min_elt A) with signature
same_relation --> eq ==> iff as min_elt_more.
Proof.
unfold same_relation, inclusion, min_elt; firstorder.
Qed.

Add Parametric Morphism A : (@wmin_elt A) with signature
same_relation --> eq ==> iff as wmin_elt_more.
Proof.
unfold same_relation, inclusion, wmin_elt; firstorder.
Qed.


Require Import FunctionalExtensionality.
Require Import List.
Require Import PeanoNat.
Require Import coqrel.LogicalRelations.
Require Import structures.Lattice.
Require Import structures.Effects.
Require Import lattices.FCD.
Require Import models.IntSpec.

Import ISpec.

(** * Preliminaries *)

Infix "~>" := ISpec.subst (at level 99).

Notation "x >>= f" := (ISpec.bind f x)
  (at level 40, left associativity).

Notation "v <- x ; M" := (x >>= fun v => M)
  (at level 65, right associativity).

Definition assert {E : esig} (P : Prop) : ispec E unit :=
  sup H : P, ISpec.ret tt.

(** * Effect signatures *)

(** ** Ring buffer *)

(** We will use the global parameters [val] for the type of values,
  and [N] for the capacity of the ring buffer. *)

Parameter val : Type.
Parameter N : nat.

(** The signature for the ring buffer includes operations [set], [get]
  to access the element at a given index, and two counters to keep
  track of the index of the first element ([inc1]) and the index of
  the first free position in the buffer ([inc2]). The [inc1], [inc2]
  primitives both increment the corresponding counter and return their
  previous value. *)

Inductive rb_sig : esig :=
  | set (i : nat) (v : val) : rb_sig unit
  | get (i : nat) : rb_sig val
  | inc1 : rb_sig nat
  | inc2 : rb_sig nat.

(** ** Bounded queue *)

(** We will use the ring buffer data structure to implement a bounded
  queue of size [N]. The corresponding operations are self-explanatory. *)

Inductive bq_sig : esig :=
  | enq (v : val) : bq_sig unit
  | deq : bq_sig val.

(** * Layer implementation *)

(** Code implementing an overlay interface with signature [F] on top
  of an underlay with signature [E] can be represented as a morphism
  [E ~> F]. The following example implements a bounded queue in terms
  a ring buffer. *)

Definition M_bq : rb_sig ~> bq_sig :=
  fun _ m =>
    match m with
      | enq v => i <- ISpec.int inc2; ISpec.int (set i v)
      | deq   => i <- ISpec.int inc1; ISpec.int (get i)
    end.

(** * Layer interfaces *)

(** A layer interface with a signature [E] and abstract states in [S]
  gives for each operation in [E] and start state in [S] an
  interaction-free specification of the possible choices of return
  value and next state. *)

Definition CALspec E S :=
  forall ar, E ar -> S -> ispec 0 (ar * S).

(** To formulate the specifications for the ring buffer layer
  interface, we will use the following helper function. *)

Definition update (f : nat -> val) (i : nat) (v : val) : nat -> val :=
  fun j => if Nat.eq_dec i j then v else f j.

(** Then our layer interfaces can be defined as follows. *)

Definition bq_state : Type :=
  list val.

Definition L_bq : CALspec bq_sig bq_state :=
  fun ar m vs =>
    match m with
      | enq v =>
        _ <- assert (length vs < N);
        ISpec.ret (tt, vs ++ v :: nil)
      | deq =>
        match vs with
          | v::vs' => ISpec.ret (v, vs')
          | nil => bot
        end
    end.

Definition rb_state : Type :=
  (nat -> val) * nat * nat.

Definition L_rb : CALspec rb_sig rb_state :=
  fun ar m '(f, c1, c2) =>
    match m with
      | set i v =>
        _ <- assert (E:=0) (i < N);
        ISpec.ret (tt, (update f i v, c1, c2))

      | get i =>
        _ <- assert (E:=0) (i < N);
        ISpec.ret (f i, (f, c1, c2))

      | inc1 =>
        ISpec.ret (c1, (f, (S c1) mod N, c2))

      | inc2 =>
        ISpec.ret (c2, (f, c1, (S c2) mod N))
    end.

(** * Layer interfaces and implementations as morphisms *)

(** ** Keeping track of state *)

(** To interpret layer interfaces as morphisms in our category of
  effect signatures and substitution specifications, we use the
  following signature which adjoins a state in [S] to the operations
  and arities of the signature [E]. This is written [E@S] in the paper
  but since I plan on using [@] for composition I use [E#S] here. *)

Inductive state_sig (E : Type -> Type) (S : Type) : Type -> Type :=
  | st {ar} (m : E ar) (k : S) : state_sig E S (ar * S).

Arguments st {E S ar} m k.

Infix "#" := state_sig (at level 40, left associativity).

(** A layer interface can then be promoted to a morphism as follows. *)

Coercion CALspec_mor {E S} (L : CALspec E S) : (0 ~> E # S) :=
  fun _ '(st m s) => L _ m s.

(** To connect this with layer implementations, we must lift a
  state-free morphism [M : E ~> F] to a corresponding stateful
  morphism [E#S ~> F#S] which passes the state around unchanged. *)

Fixpoint stateful_play {E S A} (k: S) (s: ISpec.play E A): ispec (E#S) (A*S) :=
  match s with
    | ISpec.pret v => FCD.emb (ISpec.pret (v, k))
    | ISpec.pmove m => FCD.emb (ISpec.pmove (st m k))
    | ISpec.pcons m n t =>
      sup x : option S,
      match x with
      | Some k' => FCD.map (ISpec.pcons (st m k) (n, k')) (stateful_play k' t)
      | None => FCD.emb (ISpec.pmove (st m k))
      end
  end.

Instance stateful_play_mor E S A k :
  PosetMorphism (@stateful_play E S A k).
Proof.
  constructor. intros s t Hst. revert k.
  induction Hst; cbn; intro.
  - reflexivity.
  - reflexivity.
  - apply (sup_at None).
    reflexivity.
  - apply sup_lub. intro x. apply (sup_at x). repeat rstep.
    unfold FCD.map. repeat rstep. auto.
Qed.

Definition srun {E S A} (k : S) (x : ispec E A) : ispec (E # S) (prod A S) :=
  FCD.ext (stateful_play k) x.

Definition slift {E F S} (σ : E ~> F) : E#S ~> F#S :=
  fun ar m =>
    match m with st m k => srun k (σ _ m) end.

Notation "x / f" := (ISpec.apply f x).
Infix "@" := ISpec.compose (at level 40, left associativity).

(** Then the behavior of [M : E ~> F] running on top of [L : 0 ~> E#S]
  can be computed as follows. *)

Definition layer {E F S} (M : E ~> F) (L : 0 ~> E#S) : 0 ~> F#S :=
  ISpec.compose (slift M) L.

(** ** Properties *)

Lemma srun_slift {E F S A} (k : S) (x : ispec F A) (σ : E ~> F) :
  srun k x / slift σ = srun k (x / σ).
Proof.
  unfold srun, ISpec.apply.
  rewrite !@FCD.ext_ext by typeclasses eauto. f_equal.
  apply functional_extensionality. intros s.
  induction s; cbn.
  - rewrite !FCD.ext_ana. cbn.
    reflexivity.
  - rewrite !FCD.ext_ana. cbn.
    unfold srun, ISpec.bind.
    rewrite !@FCD.ext_ext by typeclasses eauto. f_equal.
    apply functional_extensionality. intros s.
    induction s; cbn.
    + rewrite FCD.ext_ana. cbn.
      admit. (* rewrite Downset.Sup.mor_bot *)
    + rewrite !FCD.ext_ana. cbn. reflexivity.
    + rewrite Downset.Sup.mor.
      rewrite Downset.Sup.mor_join.
      apply antisymmetry.
      * apply sup_lub. intros [k' | ].
        -- apply join_r. unfold FCD.map.
           rewrite !@FCD.ext_ext; try typeclasses eauto.
           ++ repeat setoid_rewrite FCD.ext_ana. cbn.
Admitted.

Lemma srun_bind {E S A B} (k : S) (f : A -> ispec E B) (x : ispec E A) :
  srun k (ISpec.bind f x) = ISpec.bind (fun '(a, k') => srun k' (f a)) (srun k x).
Admitted.

Lemma srun_int {E S ar} (k : S) (m : E ar) :
  srun k (ISpec.int m) = ISpec.int (st m k).
Admitted.

Lemma assert_true {E} {P : Prop} (H : P) :
  @assert E P = ISpec.ret tt.
Proof.
  unfold assert.
  apply antisymmetry.
  - apply sup_lub. reflexivity.
  - apply (sup_at H). reflexivity.
Qed.

(** ** Rewriting tactic *)

Hint Rewrite
  @bind_ret_l
  @bind_ret_r
  @bind_bind
  @apply_ret
  @apply_bind
  @apply_int_l
  @apply_int_r
  @srun_bind
  @srun_int
  : intm.

Hint Rewrite @assert_true using solve [auto] : intm.

Ltac intm :=
  repeat progress (autorewrite with intm; cbn).

(** ** Example *)

(** The following example shows the effect of running the "deq"
  function as implemented by [M_bq] in terms of the abstract state of
  the underlay [L_rb]. *)

Goal
  forall f,
    srun (f, 2, 5) (ISpec.int deq) / layer M_bq L_rb =
    ISpec.ret (f 2, (f, 3, 5)).
Proof.
  intros f. unfold layer.
  rewrite <- ISpec.apply_assoc. intm.
  rewrite assert_true by admit. intm.
  rewrite Nat.mod_small by admit.
  reflexivity.
Admitted.

(** The next step will be to show that [layer M_bq L_rb] implements
  [L_bq] with a particular simulation relation between the abstract
  states of the overlay and underlay. Stay tuned... *)

(** * Data refinement *)

(** ** Simulation relations as morphisms *)

Definition srel_push {E S1 S2} (R : rel S1 S2) : E#S2 ~> E#S1 :=
  fun _ '(st m k1) =>
    sup {k2 | R k1 k2}, ISpec.int (st m k2) >>= fun '(n, k2') =>
    inf {k1' | R k1' k2'}, ISpec.ret (n, k1').

Definition srel_pull {E S1 S2} (R : rel S1 S2) : E#S1 ~> E#S2 :=
  fun _ '(st m k2) =>
    inf {k1 | R k1 k2}, ISpec.int (st m k1) >>= fun '(n, k1') =>
    sup {k2' | R k1' k2'}, ISpec.ret (n, k2').

Lemma srel_push_pull {E S1 S2} (R : rel S1 S2) (σ : 0 ~> E#S2) (τ : 0 ~> E#S1) :
  srel_push R @ σ [= τ <-> σ [= srel_pull R @ τ.
Proof.
  split.
  - intros H _ [ar m k2]. unfold srel_pull, compose.
    unfold finf. rewrite Upset.Inf.mor. eapply inf_glb. intros [k1 Hk]. intm.
    specialize (H _ (st m k1)). unfold srel_push, compose in H. rewrite <- H.
    unfold fsup. rewrite !Downset.Sup.mor. apply (sup_at (exist _ k2 Hk)). intm.
    destruct (FCD.meet_join_dense (σ _ (st m k2))) as (I & J & c & Hc).
    rewrite Hc. clear.
    rewrite !Upset.Inf.mor. apply inf_glb. intros i. apply (inf_at i).
    rewrite !Downset.Sup.mor. apply sup_lub. intros j. apply (sup_at j).
    destruct (c i j) as [[v k2'] | | ] eqn:Hcij; try tauto.
    setoid_rewrite bind_ret_r.
    unfold finf. rewrite !Upset.Inf.mor. apply inf_glb. intros [k1' Hk']. intm.
    rewrite Downset.Sup.mor. apply (sup_at (exist _ k2' Hk')). intm.
    reflexivity.
  - admit.
Admitted.

(** ** Correctness of [M_bq] *)

(** To express the relationship between the ring buffer and the
  corresponding bounded queue, we use the following auxiliary
  functions. [slice] reads a slice of the ring buffer and returns a
  list of elements. *)

Fixpoint slice (f : nat -> val) (i : nat) (n : nat) : list val :=
  match n with
    | O => nil
    | S n' => f i :: slice f (S i mod N) n'
  end.

(** Then we can define the simulation relation as follows. *)

Inductive rb_bq : rb_state -> bq_state -> Prop :=
  bq_rb_intro f c1 c2 n q :
    c1 < N ->
    n <= N ->
    q = slice f c1 n ->
    c2 = (c1 + n) mod N ->
    rb_bq (f, c1, c2) q.

(** This allows us to establish the correctness of [M_bq] as the
  following refinement property. *)

Lemma slice_length f c1 n :
  length (slice f c1 n) = n.
Proof.
  revert c1. induction n; cbn; auto.
Qed.

Lemma assert_l {E A} (P : Prop) (x y : ispec E A) :
  (P -> x [= y) ->
  _ <- assert P; x [= y.
Proof.
  intros H. unfold assert.
  rewrite Downset.Sup.mor. apply sup_lub. intros HP.
  intm. auto.
Qed.

Lemma assert_r {E A} (P : Prop) (x y : ispec E A) :
  x [= y -> P ->
  x [= _ <- assert P; y.
Proof.
  intros Hxy HP.
  rewrite assert_true; intm; auto.
Qed.

Lemma bq_rb_correct :
  L_bq [= srel_pull rb_bq @ slift M_bq @ L_rb.
Proof.
  intros _ [ar m q]. unfold compose, srel_pull, finf. cbn.
  rewrite !Upset.Inf.mor. apply inf_glb. intros [[[f c1] c2] H]. intm.
  inversion H; clear H; subst.
  destruct m; intm.
  - (* enq *)
    apply assert_l. intros HN.
    rewrite assert_true. 2: eapply Nat.mod_upper_bound; admit. intm.
    unfold fsup. rewrite !Downset.Sup.mor. eapply (sup_at (exist _ _ _)). intm.
    reflexivity.
    Unshelve. cbn.
    rewrite slice_length in HN.
    apply bq_rb_intro with (n := S n); auto.
    + revert c1 H3.
      induction n; cbn; intros.
      * rewrite Nat.add_0_r.
        rewrite Nat.mod_small by auto.
        f_equal. unfold update. destruct Nat.eq_dec; congruence.
      * rewrite IHn; auto.
        -- unfold update at 2.
           destruct Nat.eq_dec. admit. cbn. f_equal. f_equal.
           ++ f_equal. rewrite Nat.add_mod_idemp_l by admit. f_equal.
              induction c1; cbn in *; auto.
           ++ f_equal. f_equal. rewrite Nat.add_mod_idemp_l by admit. f_equal.
              induction c1; cbn in *; auto.
        -- apply Le.le_Sn_le; auto.
        -- apply Nat.mod_upper_bound. admit.
    + change (S ?x) with (1 + x).
      rewrite Nat.add_mod_idemp_r by admit. f_equal.
      induction c1; cbn in *; auto.
  - (* deq *)
    destruct n; cbn; auto using bot_lb.
    unfold fsup. rewrite !Downset.Sup.mor.
    eapply (sup_at (exist _ _ _)). intm. reflexivity.
    Unshelve. cbn. apply bq_rb_intro with (n := n); eauto.
    + apply Nat.mod_upper_bound. admit.
    + apply Le.le_Sn_le. auto.
    + rewrite Nat.add_mod_idemp_l by admit. f_equal.
      induction c1; cbn in *; auto.
Admitted.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import KanExt.Local
        KanExt.LocalFacts.HomToCones
        KanExt.LocalFacts.ConesToHom
        KanExt.LocalFacts.Uniqueness.
From Categories Require Import Cat.Cat.

Local Open Scope functor_scope.

(** Given I : C ≃ D for C and D categories we have KanExt (p ∘ I) (F ∘ I) if
    we have KanExt p F. *)
Section KanExt_From_Isomorphic_Cat.
  Context {C D : Category}
          (I : (C ≃≃ D ::> Cat)%isomorphism)
          {D' : Category}
          (p : D –≻ D')
          {E : Category}
          (F : D –≻ E)
  .

  Section LoKan_Cone_Conv.
    Context (Cn : LoKan_Cone p F).

    Program Definition LoKan_Cone_Conv :
      LoKan_Cone (p ∘ (iso_morphism I)) (F ∘ (iso_morphism I))
      :=
        {|
          cone_apex := Cn;
          cone_edge :=
            (
              (
                (cone_edge Cn) ∘_h (NatTrans_id (iso_morphism I))
              )
                ∘ (NatTrans_Functor_assoc_sym _ _ _)
            )%nattrans
        |}
    .

  End LoKan_Cone_Conv.

  Section LoKan_Cone_Conv_back.
    Context (Cn : LoKan_Cone (p ∘ (iso_morphism I)) (F ∘ (iso_morphism I))).

    Program Definition LoKan_Cone_Conv_back :
      LoKan_Cone p F
      :=
        {|
          cone_apex := Cn;
          cone_edge :=
            (
              (IsoCat_NatTrans I F)
                ∘ (
                  (
                    (NatTrans_Functor_assoc _ _ _)
                      ∘ (
                        (Cn ∘ (NatTrans_Functor_assoc _ _ _))
                          ∘_h NatTrans_id (I ⁻¹)%morphism
                      )
                  )
                    ∘ (NatTrans_Functor_assoc_sym _ _ _)
                )
                ∘ IsoCat_NatTrans_back I (Cn ∘ p))%nattrans
        |}
    .

  End LoKan_Cone_Conv_back.

  Section LoKan_Cone_Moprh_to_Conv_back_and_forth.
    Context (Cn : LoKan_Cone (p ∘ (iso_morphism I)) (F ∘ (iso_morphism I))).

    Program Definition LoKan_Cone_Moprh_to_Conv_back_and_forth :
      LoKan_Cone_Morph Cn (LoKan_Cone_Conv (LoKan_Cone_Conv_back Cn))
      :=
        {|
          cone_morph := NatTrans_id Cn
        |}
    .

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn.
      Functor_Simplify.
      simpl_ids.
      match goal with
        [|- _ = ((match ?e with _ => _ end)
                  ∘ _ ∘ (match ?e with _ => _ end))%morphism] =>
        generalize e
      end.
      intros e.
      set (z := ((I ⁻¹ _o) (((iso_morphism I) _o) x))%object%morphism) in *.
      clearbody z.
      cut (x = z).
      intros H.
      destruct H.
      match goal with
        [|- _ = (?A ∘ _ ∘ ?B)%morphism] =>
        cutrewrite (A = id);
          [cutrewrite (B = id)|]; try (apply JMeq_eq; destruct e; trivial)
      end.
      {
        auto.
      }
      {
        cbn_rewrite <- (f_equal (fun u => (u _o x)%object) (left_inverse I)).
        cbn_rewrite <- (f_equal (fun u => (u _o z)%object) (left_inverse I)).
        apply f_equal; trivial.
      }
    Qed.

  End LoKan_Cone_Moprh_to_Conv_back_and_forth.

  Section LoKan_Cone_Moprh_from_Conv_forth_and_back.
    Context (Cn : LoKan_Cone p F).

    Program Definition LoKan_Cone_Moprh_from_Conv_forth_and_back :
      LoKan_Cone_Morph (LoKan_Cone_Conv_back (LoKan_Cone_Conv Cn)) Cn
      :=
        {|
          cone_morph := NatTrans_id Cn
        |}
    .

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify.
      extensionality x.
      cbn.
      Functor_Simplify.
      simpl_ids.
      match goal with
        [|- ((match ?e with _ => _ end)
              ∘ _ ∘ (match ?e with _ => _ end))%morphism = _] =>
        destruct e
      end.
      auto.
    Qed.

  End LoKan_Cone_Moprh_from_Conv_forth_and_back.

  Section LoKan_Cone_Morph_Conv.
    Context {Cn Cn' : LoKan_Cone p F} (h : LoKan_Cone_Morph Cn Cn').

    Program Definition LoKan_Cone_Morph_Conv :
      LoKan_Cone_Morph (LoKan_Cone_Conv Cn) (LoKan_Cone_Conv Cn')
      :=
        {|
          cone_morph := h
        |}
    .

    Next Obligation.
      apply NatTrans_eq_simplify.
      FunExt; cbn.
      Functor_Simplify.
      simpl_ids.
      cbn_rewrite (f_equal (fun x => Trans x) (cone_morph_com h)).
      auto.
    Qed.

  End LoKan_Cone_Morph_Conv.

  Section LoKan_Cone_Morph_Conv_back.
    Context {Cn Cn' : LoKan_Cone (p ∘ (iso_morphism I)) (F ∘ (iso_morphism I))}
            (h : LoKan_Cone_Morph Cn Cn')
    .

    Program Definition LoKan_Cone_Morph_Conv_back :
      LoKan_Cone_Morph (LoKan_Cone_Conv_back Cn) (LoKan_Cone_Conv_back Cn')
      :=
        {|
          cone_morph := h
        |}
    .

    Next Obligation.
      apply NatTrans_eq_simplify.
      FunExt; cbn.
      cbn_rewrite (f_equal (fun x => Trans x) (cone_morph_com h)).
      Functor_Simplify.
      simpl_ids.
      match goal with
        [|-
         ((match ?e with _ => _ end)
            ∘ _ ∘ (match ?e with _ => _ end))%morphism =
         (((match ?e with _ => _ end)
             ∘ _ ∘ (match ?e with _ => _ end)) ∘ _)%morphism
        ] =>
        generalize e
      end.
      intros e.
      repeat rewrite assoc.
      match goal with
        [|-
         (?A1 ∘ ?B1 ∘ ?C1 ∘ ?D1)%morphism =
         (?A2 ∘ ?B2 ∘ ?C2 ∘ ?D2)%morphism
        ] =>
        cutrewrite ((C1 ∘ D1)%morphism = (C2 ∘ D2)%morphism); trivial
      end.
      destruct e; auto.
    Qed.

  End LoKan_Cone_Morph_Conv_back.

  Context (L : Local_Right_KanExt p F).

  Program Definition KanExt_From_Isomorphic_Cat :
    Local_Right_KanExt (p ∘ (iso_morphism I)) (F ∘ (iso_morphism I)) :=
    {|
      LRKE := (LoKan_Cone_Conv L);
      LRKE_morph_ex :=
        fun Cn =>
          LoKan_Cone_Morph_compose
            _
            _
            (LoKan_Cone_Moprh_to_Conv_back_and_forth Cn)
            (LoKan_Cone_Morph_Conv (LRKE_morph_ex L (LoKan_Cone_Conv_back Cn)))
    |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x.
    set (H :=
           f_equal
             (fun w => Trans w x)
             (LRKE_morph_unique
                L
                (LoKan_Cone_Conv_back Cn)
                (
                  LoKan_Cone_Morph_compose
                    _
                    _
                    (LoKan_Cone_Morph_Conv_back h)
                    (LoKan_Cone_Moprh_from_Conv_forth_and_back _)
                )
                (
                  LoKan_Cone_Morph_compose
                    _
                    _
                    (LoKan_Cone_Morph_Conv_back h')
                    (LoKan_Cone_Moprh_from_Conv_forth_and_back _)
                )
             )
        ).
    cbn in H.
    auto.
  Qed.

End KanExt_From_Isomorphic_Cat.


Require Import TLA.
Require Import Rules.
Require Import Arith.
Require Import ZArith.
Require Import Omega.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Memory.
Require Import Command.
Require Import Rules.

Module Total (Params : MemParams).
  Module MEMORY := Memory (Params).
  Module COMMAND := Command (MEMORY.FROMMEM).
  Print MEMORY.BASIC.St.
  Print COMMAND.BASIC.St.
  Definition castSt1 (st : MEMORY.BASIC.St) : COMMAND.BASIC.St :=
    match st with
    | {|  MEMORY.BASIC.ready := ready;
          MEMORY.BASIC.status := status;
          MEMORY.BASIC.memory := memory;
          MEMORY.BASIC.output := output |} =>
            {|
              COMMAND.BASIC.ready := ready;
              COMMAND.BASIC.status := status;
              COMMAND.BASIC.memory := memory;
              COMMAND.BASIC.output := output |}
    end.

  Definition castSt2 (st : COMMAND.BASIC.St) : MEMORY.BASIC.St :=
    match st with
    | {|  COMMAND.BASIC.ready := ready;
          COMMAND.BASIC.status := status;
          COMMAND.BASIC.memory := memory;
          COMMAND.BASIC.output := output |} =>
            {|
              MEMORY.BASIC.ready := ready;
              MEMORY.BASIC.status := status;
              MEMORY.BASIC.memory := memory;
              MEMORY.BASIC.output := output |}
    end.
  Lemma castStInv1 : forall st, st = castSt2 (castSt1 st).
  Proof.
    intros st. destruct st; auto.
  Qed.

  Lemma castStInv2 : forall st, st = castSt1 (castSt2 st).
  Proof.
    intros st. destruct st; auto.
  Qed.

  Definition sameSt (st1 : MEMORY.BASIC.St) (st2 : COMMAND.BASIC.St) : Prop :=
    castSt1 st1 = st2.

  Definition sameStAlt : forall st1 st2, sameSt st1 st2 <-> st1 = castSt2 (st2).
  Proof.
    intros st1 st2. unfold sameSt.
    destruct st1, st2. split; intros H; inversion H; auto.
  Qed.

  Inductive St : Type := Make_St : forall st1 st2,
    sameSt (MEMORY.refinement_mapping st1) (COMMAND.refinement_mapping st2) -> St.

  Definition p1 (st : St) : MEMORY.St :=
    match st with
    | Make_St m _ _ => m
    end.

  Definition p2 (st : St) : COMMAND.St :=
    match st with
    | Make_St _ m _ => m
    end.

  Definition Spec : Expr St := (map p1 MEMORY.Spec) `/\ (map p2 COMMAND.Spec).

End Total.


(* Type constructors are split into several groups depending on how
   many arguments need to be applied for the overall type to be
   well formed. We keep primitive types like Read, Write and Ref fully
   applied to make the mechanisation easier. In the full language the
   ability to partially apply these could be recovered using
   type synonyms. *)
Require Export Iron.Language.SystemF2Cap.Kind.

(********************************************************************)
(* Type Constructors. *)
Inductive tycon0 : Type :=
 | TyConFun    : tycon0
 | TyConUnit   : tycon0
 | TyConBool   : tycon0
 | TyConNat    : tycon0.
Hint Constructors tycon0.

Fixpoint kindOfTyCon0 (tc : tycon0) :=
 match tc with
 | TyConFun     => KFun KData (KFun KEffect (KFun KData KData))
 | TyConUnit    => KData
 | TyConBool    => KData
 | TyConNat     => KData
 end.

Fixpoint tycon0_beq tc1 tc2 :=
 match tc1, tc2 with
 | TyConFun,    TyConFun    => true
 | TyConUnit,   TyConUnit   => true
 | TyConBool,   TyConBool   => true
 | TyConNat,    TyConNat    => true
 | _,           _           => false
 end.

(********************************************************************)
(* Type constructors with at least one applied argument. *)
Inductive tycon1 : Type :=
 | TyConRead   : tycon1
 | TyConWrite  : tycon1
 | TyConAlloc  : tycon1.

Fixpoint kindOfTyCon1 (tc : tycon1) :=
 match tc with
 | TyConRead    => KFun KRegion KEffect
 | TyConWrite   => KFun KRegion KEffect
 | TyConAlloc   => KFun KRegion KEffect
 end.

Fixpoint tycon1_beq tc1 tc2 :=
 match tc1, tc2 with
 | TyConRead,   TyConRead   => true
 | TyConWrite,  TyConWrite  => true
 | TyConAlloc,  TyConAlloc  => true
 | _,           _           => false
 end.

Definition isEffectTyCon_b (tc : tycon1) :=
 match tc with
 | TyConRead     => true
 | TyConWrite    => true
 | TyConAlloc    => true
 end.

(********************************************************************)
(* Type constructors with at least two applied arguments. *)
Inductive tycon2 : Type :=
 | TyConRef    : tycon2
 | TyConSusp   : tycon2.
Hint Constructors tycon2.

Fixpoint kindOfTyCon2 (tc : tycon2) :=
 match tc with
 | TyConRef      => KFun KRegion (KFun KData KData)
 | TyConSusp     => KFun KEffect (KFun KData KData)
 end.

Fixpoint tycon2_beq tc1 tc2 :=
 match tc1, tc2 with
 | TyConRef,     TyConRef  => true
 | TyConSusp,    TyConSusp => true
 | _,            _         => false
 end.


Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.fintype Ssreflect.finfun Ssreflect.seq Ssreflect.tuple.
Require Import x86proved.charge.ilogic.

(* Importing this file really only makes sense if you also import ilogic, so we
   force that. *)
Require Export x86proved.charge.ilogic x86proved.charge.bilogic.

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

Require Import Coq.Logic.FunctionalExtensionality.

(* This should not be here, //Jesper *)

Section ILogicSSReflect.
  Context {A} `{ILogic A}.

  Lemma lpropandT P : true /\\ P -|- P.
  Proof. rewrite /lpropand. split; [by apply lexistsL | by apply lexistsR]. Qed.

  Lemma lpropandF P : false /\\ P -|- lfalse.
  Proof. rewrite /lpropand. split; [by apply lexistsL | done]. Qed.

End ILogicSSReflect.

(* Tactics for doing forward reasoning from a hypothesis. *)
Lemma lforwardR {Frm} `{IL: ILogic Frm} P Q R:
  Q |-- R -> P |-- Q -> P |-- R.
Proof. intros; etransitivity; eassumption. Qed.
Tactic Notation "lforwardR" hyp(H) := eapply lforwardR in H; last first.

Lemma lforwardL {Frm} `{IL: ILogic Frm} P Q R:
  P |-- Q -> Q |-- R -> P |-- R.
Proof. intros; etransitivity; eassumption. Qed.
Tactic Notation "lforwardL" hyp(H) := eapply lforwardL in H; last first.

(* This tactic is a ilogic version of [move:]. Can it be done easier? *)
Ltac lrevert x :=
  move: x;
  match goal with
  | |- ?P -> _ |-- ?G =>
      move=> x;
      transitivity (P ->> G);
      [clear x | apply lpropimplL; [exact x|reflexivity] ]
  | |- forall a, _ |-- @?G a =>
      move=> x;
      transitivity (lforall G);
      [clear x | apply lforallL with x; reflexivity ]
  end.


Require Import Coq.Structures.Equalities.
Require Import algebra.

Inductive Cfg (T : Set) : Set :=
| Null : Cfg T
| One : T -> Cfg T
| Append : Cfg T -> Cfg T -> Cfg T.

Module Type CfgTypeParam.
  Parameter T : Set.
End CfgTypeParam.

Module Type CfgTyp <: Typ.
  Parameter T : Set.
  Definition t := Cfg T.
End CfgTyp.

(* Module CfgTyp (P : CfgTypeParam) <: Typ. *)
(*   Definition t := Cfg P.T. *)
(* End CfgTyp. *)

Module CfgMagma (P : CfgTyp) <: Magma P.
  Definition r := Append P.T.
End CfgMagma.

Module CfgIdentity (P : CfgTyp) <: Identity P.
  Definition i := Null P.T.
End CfgIdentity.

Module CfgAbelianMonoid (P : CfgTyp).
  Module PCM := CfgMagma P.
  Module PCI := CfgIdentity P.
  Module AM := AbelianMonoid P PCM PCI.
  Include P.
  Include PCM.
  Include PCI.
  Include AM.
End CfgAbelianMonoid.

Set Implicit Arguments.
Unset Strict Implicit.

Arguments Null [T].
Arguments One [T] _.
Arguments Append [T] _ _.

Notation "c ++ d" := (Append c d).

Inductive In {T : Set} (t : T) : Cfg T -> Prop :=
| InOne : In t (One t)
| InAppend : forall c d : Cfg T, In t c -> In t (c ++ d). (* defined only left pattern becase configuration is commutative *)

Hint Constructors In.

Module CfgLemmas (P : CfgTyp).

  Module C := CfgAbelianMonoid P.
  Import C.

  Lemma isolate1 : forall s (a : T),
                     In a s ->
                     exists s1, s = s1 ++ One a.
  Proof.
    intros s a P.
    induction P.
    - exists Null.
      rewrite left_identity.
      auto.
    - destruct IHP as [t H].
      exists (d ++ t).
      rewrite H.
      rewrite commutative.
      rewrite associative.
      auto.
  Qed.

  Lemma isolate2 : forall s (a : T),
                     (exists s1, s = s1 ++ One a) ->
                     In a s.
  Proof.
    intros s a P.
    destruct P as [t P].
    rewrite P.
    rewrite commutative.
    auto.
  Qed.

  Lemma Nonempty : forall (a : T) s1 s2,
                     In a (s1 ++ s2) <-> In a s1 \/ In a s2.
  Proof.
    intros a s1 s2.
    split; intros P.
    - inversion P; subst.
      left; auto.
    - destruct P as [P1 | P2].
      + auto.
      + rewrite commutative.
        auto.
  Qed.

  Goal forall s s1 s2 (a b : T),
         s = s1 ++ One a /\
         s = s2 ++ One b /\
         a <> b ->
         exists s3, s = s3 ++ One a ++ One b.
  Proof.
    intros s s1 s2 a b.
    intros P.
    destruct P as [P1 P'].
    destruct P' as [P2 P3].
    assert (In a s2 \/ In a (One b)).
    - eapply Nonempty.
      rewrite <- P2.
      eapply isolate2.
      exists s1; auto.
    - destruct H as [H | H].
      + assert (exists s3, s2 = s3 ++ One a).
        * apply isolate1; auto.
        * destruct H0 as [s3 H0].
          exists s3.
          rewrite P2.
          rewrite H0.
          rewrite associative.
          auto.
      + inversion H.
        contradiction.
  Qed.
End CfgLemmas.

(* - 次のゼミの準備ということもあるが、Structured Reasoning About Actor Systems の Athena による形式化を読んで、(理解するために) Coq で書きなおしてみている *)
(* - Actario の進捗はない *)
(*   - Configuration の定義はこれでいいのか (メッセージは必ず送られた順に起こる) <- 保証されない方向？ *)
(*   - アクターシステムの性質を記述するための言語 (ロジック、LTL とか) をどうするか (アクターシステムの性質記述に向いているものとは) <- PT-LTL (LTL の過去版 (Distributed 版は PT-DTL, Agha, Monitoring Oriented Programming)) *)
(*   - 分散システムをアクターで作る例から考えて、こういう性質を記述するためにこういう言語にしよう、とか証明を簡潔に記述していくための補題を作ろう、みたいな感じでやったら考えやすいのでは、SSReflect みたいに。 *)

(* - bounded buffer problem *)

(* - ABCL (メッセージの順番は保存される) *)
(* mpi *)

(* # JSSST *)

(* 1. Coq によるケーススタディを与える *)
(* 2. 型については、Agha は型と言っている、というだけでよいのでは。 *)
(* 3. 形式化は誰にとって嬉しいか？を明確にする *)
(* 4. pi計算をCoqで書いた他のものと比べてどういいのか *)

(* こっちは説明だけはちゃんと書こう。あとは Actario に注力しよう *)

(* # AGERE *)

(* Actario のほうは、Configuration の保たれる性質 *)


Require Import GHC.Base.

From Coq Require Import
     Relation_Definitions
     ssrfun
.

Class FunctorE (F : Set -> Set) :=
  { fmapE {A B : Set} : (A -> B) -> F A -> F B ;
    fmapE_id : forall {A : Set}, @fmapE A A id =1 id ;
    fmapE_comp : forall {A B C : Set} (g : B -> C) (f : A -> B),
        fmapE (g ∘ f) =1 fmapE g ∘ fmapE f
  }.

Definition id1 {F : Set -> Set} : forall (A : Set), F A -> F A := fun _ x => x.

Definition comp1 {F G H : Set -> Set}
           (g : forall X, G X -> H X) (f : forall X, F X -> G X) :
  forall X, F X -> H X :=
  fun _ x => g _ (f _ x).

Class Functor1 (E : (Set -> Set) -> Set -> Set) :=
  { fmap1 {F G : Set -> Set} {A : Set} :
      (forall (X : Set), F X -> G X) -> E F A -> E G A;
    fmap1_id : forall {F : Set -> Set} {A : Set}, @fmap1 F F A id1 =1 id;
    fmap1_comp : forall {F G H : Set -> Set} {A : Set}
                    (g : forall X, G X -> H X) (f : forall X, F X -> G X),
        @fmap1 _ _ A (comp1 g f) =1 fmap1 g ∘ fmap1 f
  }.

(** Do I need the functor laws for proofs? *)
Class FunctorRel {F : Set -> Set}
      (R : (forall (A : Set), relation (F A)) -> forall (A : Set), relation (F A)) :=
  { fmapRel {A : Set} {a b : F A} {P Q : forall (A : Set), relation (F A)} :
      (forall {A : Set}(a b : F A), P _ a b -> Q _ a b) -> R P _ a b -> R Q _ a b
  }.

Arguments FunctorRel F R.


Lemma bottom_play_won_by {p} {all_moves : play bottom}
 : play_won_by p all_moves <-> p = player_O.
Proof.
  unfold play_won_by, play_won_by_P, play_won_by_O, top.
  case: p => //.
Qed.


Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types.
Require Import Metrics.Mappings.
Require Import Metrics.Complete_UltraMetric.
Require Import Categories.Category.Main.
Require Import Categories.Functor.Main.
Require Import MCat.MCat.

Section MFunc.
  Context {L : MLattice} (M M' : MCat L).

  (** A locally non-expansive functor is one whose arrow map
is non-expansive. *)
  Record LocallyNonExpansive : Type :=
    {
      LNE_FO : M → M';
      LNE_FA : ∀ {a b},
          NonExpansive
            (MC_Hom M a b)
            (MC_Hom M' (LNE_FO a) (LNE_FO b));
      LNE_F_id :
        ∀ a, LNE_FA (@MC_id _ M a) = @MC_id _ M' (LNE_FO a);
      LNE_F_compose :
        ∀ a b c (f : MC_Hom M a b) (g : MC_Hom M b c),
          LNE_FA (MC_compose M (f, g)) =
          MC_compose M' (LNE_FA f, LNE_FA g);
      LNE_Func :> Functor M M' :=
        {|
          FO := LNE_FO;
          FA := @LNE_FA;
          F_id := LNE_F_id;
          F_compose := LNE_F_compose
        |}
    }.

    (** A locally contractive functor is one whose arrow map
is contractive. *)
  Record LocallyContractive : Type :=
    {
      LCN_FO : M → M';
      LCN_ContrRate : ContrRate L;
      LCN_FA : ∀ {a b},
          Controlled_Contractive
            LCN_ContrRate
            (MC_Hom M a b)
            (MC_Hom M' (LCN_FO a) (LCN_FO b));
      LCN_F_id :
        ∀ a, LCN_FA (@MC_id _ M a) = @MC_id _ M' (LCN_FO a);
      LCN_F_compose :
        ∀ a b c (f : MC_Hom M a b) (g : MC_Hom M b c),
          LCN_FA (MC_compose M (f, g)) =
          MC_compose M' (LCN_FA f, LCN_FA g);
      LCN_Func :> Functor M M' :=
        {|
          FO := LCN_FO;
          FA := @LCN_FA;
          F_id := LCN_F_id;
          F_compose := LCN_F_compose
        |}
    }.

End MFunc.

(** The result of composition of a locally contractive functor and a locally
non-expansive functor is locally contractive. *)
Section LContr_LNE_Comp.
  Context
    {L : MLattice}
    {M M' M'' : MCat L}
    (F : LocallyContractive M M')
    (G : LocallyNonExpansive M' M'')
  .

  Program Definition LContr_LNE_Comp : LocallyContractive M M'' :=
    {|
      LCN_FO := ((G ∘ F)%functor _o)%object;
      LCN_ContrRate := LCN_ContrRate _ _ F;
      LCN_FA :=
        fun a b =>
        Contractive_Controlled_Contractive
          (
            NonExp_Contr_Contr
              (Controlled_Contractive_Contractive (@LCN_FA _ _ _ F a b))
              (@LNE_FA _ _ _ G (LCN_FO _ _ F a) (LCN_FO _ _ F b))
          );
      LCN_F_id := F_id (G ∘ F)%functor;
      LCN_F_compose := @F_compose _ _ (G ∘ F)%functor
    |}.

  (** Checking that the underlying functor of LContr_LNE_Comp is the composition of
individual functors. *)
  Goal (LContr_LNE_Comp = (G ∘ F)%functor :> Functor _ _).
    reflexivity.
  Abort.

End LContr_LNE_Comp.

(** The result of composition of a locally non-expansive functor and a locally
contractive functor is locally contractive. *)
Section LNE_LContr_Comp.
  Context
    {L : MLattice}
    {M M' M'' : MCat L}
    (F : LocallyNonExpansive M M')
    (G :  LocallyContractive M' M'')
  .

  Program Definition LNE_LContr_Comp : LocallyContractive M M'' :=
    {|
      LCN_FO := ((G ∘ F)%functor _o)%object;
      LCN_ContrRate := LCN_ContrRate _ _ G;
      LCN_FA :=
        fun a b =>
        Contractive_Controlled_Contractive
          (
            Contr_NonExp_Contr
              (@LNE_FA _ _ _ F a b)
              (Controlled_Contractive_Contractive (@LCN_FA _ _ _ G (@LNE_FO _ _ _ F a) (@LNE_FO _ _ _ F b)))
          );
      LCN_F_id := F_id (G ∘ F)%functor;
      LCN_F_compose := @F_compose _ _ (G ∘ F)%functor
    |}.

  (** Checking that the underlying functor of LNE_LContr_Comp is the composition of
individual functors. *)
  Goal (LNE_LContr_Comp = (G ∘ F)%functor :> Functor _ _).
    reflexivity.
  Abort.

End LNE_LContr_Comp.


(*******************************************************************************)
(* Chapter 7.2: Representable Structure                                        *)
(*******************************************************************************)

Generalizable All Variables.
Require Import Notations.
Require Import Categories_ch1_3.
Require Import Functors_ch1_4.
Require Import Isomorphisms_ch1_5.
Require Import EpicMonic_ch2_1.
Require Import ProductCategories_ch1_6_1.
Require Import OppositeCategories_ch1_6_2.
Require Import Enrichment_ch2_8.
Require Import Subcategories_ch7_1.
Require Import NaturalTransformations_ch7_4.
Require Import NaturalIsomorphisms_ch7_5.
Require Import MonoidalCategories_ch7_8.
Require Import Coherence_ch7_8.
Require Import BinoidalCategories.
Require Import PreMonoidalCategories.
Require Import MonoidalCategories_ch7_8.

Section RepresentableStructure.
  Context `(ec:ECategory(mn:=mn)(V:=V)).

  Definition hom_contravariant {a:ec}{d e:ec}(f:EI~~{V}~~>(d~~>e)) := #(pmon_cancell _)⁻¹ >>> (f ⋉ (_ ~~> a)) >>> ecomp.
  Definition hom_covariant     {a:ec}{d e:ec}(f:EI~~{V}~~>(d~~>e)) := #(pmon_cancelr _)⁻¹ >>> ((a ~~> d) ⋊ f) >>> ecomp.

  Lemma hom_covariant_distributes     {a b c:ec}{x}(f:a~~{ec}~~>b)(g:b~~{ec}~~>c)
     : hom_covariant (f >>> g) ~~ (hom_covariant (a:=x) f) >>> (hom_covariant g).
     set (f >>> g) as fg; simpl in fg; unfold fg; clear fg.
     unfold hom_covariant.
     repeat setoid_rewrite associativity.
     apply comp_respects; try reflexivity.
     set (@ecomp_is_functorial) as qq.
     repeat setoid_rewrite associativity in qq.
     apply qq.
     Qed.

  (*
  Lemma hom_swap {a b c d:ec}(f:a~~{ec}~~>b)(g:c~~{ec}~~>d)
     : hom_covariant f >>> hom_contravariant g ~~ hom_contravariant g >>> hom_covariant f.
     etransitivity.
     unfold hom_covariant.
     unfold hom_contravariant.
     Defined.

  Definition YonedaBiFunctor_fmor (a b:ec⁽ºᑭ⁾ ×× ec)(f:a~~{ec⁽ºᑭ⁾ ×× ec}~~>b)
        : ((fst_obj _ _ a)~~>(snd_obj _ _ a))~~{V}~~>((fst_obj _ _ b)~~>(snd_obj _ _ b)).
    destruct a as [a1 a2].
    destruct b as [b1 b2].
    case f as [f1 f2]; intros.
    exact ( hom_contravariant (a:=a2) f1 >>> hom_covariant (a:=b1) f2 ).
    Defined.

  Definition YonedaBiFunctor : Functor (ec⁽ºᑭ⁾ ×× ec) V (fun a => (fst_obj _ _ a)~~>(snd_obj _ _ a)).
    refine {| fmor := fun a b f => YonedaBiFunctor_fmor a b f |}.
    abstract (intros; destruct a; destruct b; destruct f;
              destruct f';
              destruct H;
              repeat (apply comp_respects; try reflexivity); simpl;
              [ apply (@fmor_respects _ _ _ _ _ _ (fun x => (bin_obj x _))); auto
              | apply (fmor_respects ((o1 ~~> o0) ⋊-)); auto ]).
    abstract (
      destruct a; unfold YonedaBiFunctor_fmor;
      unfold hom_covariant;
      unfold hom_contravariant;
      etransitivity; simpl;
      [ apply comp_respects; setoid_rewrite associativity; simpl;
        [ etransitivity; [ apply comp_respects; [ reflexivity | apply eleft_identity ] | apply iso_comp2 ]
        | etransitivity; [ apply comp_respects; [ reflexivity | apply eright_identity ] | apply iso_comp2 ]
        ]
      | apply left_identity ]
      ).
    abstract (destruct a; destruct b; destruct c;
              destruct f;
              destruct g; unfold YonedaBiFunctor_fmor;
              setoid_rewrite juggle3;
              setoid_rewrite hom_swap;
              setoid_rewrite <- juggle3;
              setoid_rewrite <- hom_contravariant_distributes;
              setoid_rewrite <- hom_covariant_distributes;
              simpl;
              apply comp_respects;
              reflexivity).
    Defined.

  Definition HomFunctorºᑭ (X:ec) : Functor ec⁽ºᑭ⁾ V (fun a => a~~>X) := func_rlecnac X >>>> YonedaBiFunctor.
  *)

  Definition HomFunctor   (X:ec) : Functor ec     V (ehom X).
    refine {| fmor := @hom_covariant X |}.
    intros.
      unfold hom_covariant.
      apply comp_respects; try reflexivity.
      apply comp_respects; try reflexivity.
      apply fmor_respects; auto.
    intros.
      unfold hom_covariant.
      apply (epic _ (iso_epic ((pmon_cancelr) (X ~~> a)))).
      setoid_rewrite <- associativity.
      setoid_rewrite <- associativity.
      setoid_rewrite iso_comp1.
      setoid_rewrite left_identity.
      setoid_rewrite right_identity.
      apply (@eright_identity).
    intros.
      symmetry.
      apply hom_covariant_distributes.
      Defined.

  (*
  Lemma undo_homfunctor `(f:a~~{ec}~~>b) : f ~~ eid _ >>> (HomFunctor a \ f).
    simpl.
    setoid_rewrite <- associativity.
    unfold hom_contravariant.
    repeat setoid_rewrite <- associativity.
    setoid_rewrite juggle1.
    setoid_rewrite eleft_identity.
    repeat setoid_rewrite <- associativity.
    setoid_rewrite juggle1.
    setoid_rewrite iso_comp1.
    setoid_rewrite right_identity.
    unfold hom_covariant.
    repeat setoid_rewrite <- associativity.
    set (ni_commutes (@pmon_cancelr _ _ _ _ _ _ mn) (eid a)) as qq.
    simpl in qq.
    apply iso_shift_right' in qq.
    apply symmetry in qq.
    setoid_rewrite <- associativity in qq.
    apply iso_shift_left' in qq.
    apply symmetry in qq.
    setoid_rewrite qq.
    setoid_rewrite associativity.
    setoid_rewrite juggle3.
    setoid_rewrite (centralmor_first(CentralMorphism:=eid_central(ECategory:=ec) a)).
    repeat setoid_rewrite associativity.
    setoid_rewrite eleft_identity.
    set (ni_commutes (@pmon_cancell _ _ _ _ _ _ mn) f) as qqq.
    simpl in qqq.
    setoid_rewrite <- qqq.
    setoid_rewrite <- associativity.
    set (coincide pmon_triangle) as qqqq.
    setoid_rewrite qqqq.
    setoid_rewrite iso_comp1.
    setoid_rewrite left_identity.
    set (@eqv_equivalence) as qmt.
    apply qmt.
    Qed.
    *)

End RepresentableStructure.
Opaque HomFunctor.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Key_Properties
        Subtyping_inversion
        Deterministic.

Require Import List. Import ListNotations.
Require Import Arith Omega.
Require Import Coq.Strings.String.

Lemma TypedReduce_trans : forall v v1 v2 A B,
    TypedReduce v A v1 -> ord B -> TypedReduce v1 B v2 -> TypedReduce v B v2.
Proof.
  introv Red1 Ord Red2.
  gen B v2.
  induction* Red1;
    introv Ord Red2.
  - (* v1 = v_topv v *)
    remember (v_topv v).
    induction* Red2;
      try solve [inversion Heqv0];
      try solve [inversion Ord].
  - (* v1 = v_absv A e D *)
    remember (v_absv A e D).
    induction* Red2;
      try solve [inversion Heqv];
      try solve [inversion Ord].
    inverts* Heqv.
    constructor*.
    auto_sub.
  - (* and *)
    inverts* Red2;
      try solve [inverts* Ord].
Qed.

Lemma consistent_afterTR : forall v A B C v1 v2, Vtyping v C -> TypedReduce v A v1 -> TypedReduce v B v2 -> consistencySpec v1 v2.
Proof.
  intros v A B C v1 v2 Typ Red1 Red2.
  unfold consistencySpec.
  intros D v1' v2' Ord Red1' Red2'.
  lets Lc: typing_regular_1_val Typ.
  forwards*: TypedReduce_trans Red1 Red1'.
  forwards*: TypedReduce_trans Red2 Red2'.
  forwards*: TypedReduce_unique H H0.
Qed.

Lemma TypedReduce_preservation: forall v A v',
    TypedReduce v A v'-> forall B, Vtyping v B -> sub B A -> Vtyping v' A.
Proof.
  introv Red.
  induction Red; introv Typ Sub;
    lets Lc  : typing_regular_1_val Typ;
    try solve [constructor*].
  - Case "topv".
    eapply Vtyp_topv.
    eauto.
  - Case "absv".
    inverts Typ.
    apply~ Vtyp_absv.
    auto_sub.
  - Case "mergel".
    inverts Typ.
    lets: TypedReduce_sub Red.
    lets: principal_type_checks H3.
    forwards*: IHRed.
  - Case "merger".
    inverts Typ.
    lets: TypedReduce_sub Red.
    lets: principal_type_checks H4.
    forwards*: IHRed.
  - Case "merge_and".
    assert (sub B0 A) by auto_sub.
    assert (sub B0 B) by auto_sub.
    forwards*: IHRed1.
    forwards*: IHRed2.
    constructor*.
    lets* Con: consistent_afterTR Typ Red1 Red2.
Qed.

Theorem preservation : forall e e' A,
    Etyping nil e A ->
    step e e' ->
    Etyping nil e' A.
Proof.
  introv Typ. gen e'.
  lets Typ' : Typ.
  inductions Typ;
    try solve [introv J; inverts* J].
  - Case "typing_app".
    introv J.
    inverts* J.
    (* e_absv A0 . e : B0->D  v *)
    inverts Typ2.
    inverts H4.
    eapply Etyp_anno.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    remember nil as G.
    rewrite_env(nil++G).
    sapply* Etyping_subst.
    subst.
    inverts Typ1.
    forwards*: TypedReduce_preservation H3.
    auto.
  - Case "typing_merge".
    introv J.
    inverts J.
    + forwards*: IHTyp1.
    + forwards*: IHTyp2.
    + inverts Typ1.
      inverts Typ2.
      constructor*.
      constructor*.
      forwards*: disjoint_val_consistent.
  - Case "typing_anno".
    introv J.
    inverts* J.
    + SCase "e:A".
      inverts Typ.
      forwards*: TypedReduce_preservation H3 H4.
  - Case "typing_fix".
    introv J.
    inverts* J.
    pick_fresh x.
    rewrite* (@subst_exp_intro x).
    remember nil as G.
    rewrite_env(nil++G).
    sapply* Etyping_subst.
Qed.

Lemma TypedReduce_progress: forall v A B,
    Vtyping v A -> sub A B -> exists v', TypedReduce v B v'.
Proof.
  introv Typ Sub.
  gen A B.
  induction v; try solve [inverts* Val];
    intros.
  - Case "e_top".
    inverts Typ.
    induction B; inverts* Sub.
    destruct~ IHB1 as [v1 Tyr1].
    destruct~ IHB2 as [v2 Tyr2].
    exists*.
  - Case "e_lit".
    inverts Typ.
    induction B; inverts* Sub.
    destruct~ IHB1 as [v1 Tyr1].
    destruct~ IHB2 as [v2 Tyr2].
    exists*.
  - Case "v_topv".
    inverts Typ.
    induction B; inverts* Sub.
    destruct~ IHB1 as [v1 Tyr1].
    destruct~ IHB2 as [v2 Tyr2].
    exists*.
  - Case "e_absv".
    lets S: principal_type_sub Typ.
    lets T: principal_type_checks Typ.
    simpl in S. simpl in T.
    lets S2: sub_transtivity S Sub.
    induction B0; inverts* S2.
    + SCase "t_and".
      destruct~ IHB0_1 as [v1 Tyr1].
      auto_sub.
      destruct~ IHB0_2 as [v2 Tyr2].
      auto_sub.
      exists*.
  - Case "e_merge".
    lets Typ' : Typ.
    inverts* Typ.
    + SCase "consistent merge".
      lets Lc  : typing_regular_1_val H1.
      lets Lc2  : typing_regular_1_val H2.
      induction B.
      * SSCase "B:=Int".
        inverts Sub.
        lets* [? ?]: IHv1 H5.
        lets* [? ?]: IHv2 H5.
      * SSCase "B:=Top".
        assert (sub A0 t_top) by auto.
        lets* [? ?]: IHv1 H1 H.
      * SSCase "B:=Arrow".
        inverts Sub.
        lets* [? ?]: IHv1 H1 H5.
        lets* [? ?]: IHv2 H2 H5.
      * SSCase "B:=B1&B2".
        lets* [vb1' Tyrb1] : IHB1.
        auto_sub.
        lets* [vb2' Tyrb2] : IHB2.
        auto_sub.
Qed.

Theorem progress : forall e A,
    Etyping nil e A ->
    (exists v, e = (e_val v)) \/ exists e', step e e'.
Proof.
  introv Typ. lets Typ': Typ.
  inductions Typ;
      lets Lc  : typing_regular_1_exp Typ';
      try solve [left*];
      try solve [right*].
  - Case "var".
    invert H0.
  - Case "app".
    right.
    destruct~ IHTyp2 as [Val1 | [e1' Red2]].
    destruct~ IHTyp1 as [Val2 | [e2' Red1]].
    inverts* Typ2;
      try solve [
      lets (v1' & Eqn): Val1;
      inverts* Eqn ].
    + SCase "e_app (e_absv _ _) v2".
      inverts Val2.
      inverts H0.
      inverts Typ1.
      lets* (v2' & Tyr): TypedReduce_progress H4 H6.
    + SCase "e_app v1 e2".
      destruct Val1.
      subst.
      inverts Lc.
      inverts* H1.
    + SCase "e_app e1 e2".
      forwards*: typing_regular_1_exp Typ1.
  - Case "merge".
    forwards*: typing_regular_1_exp Typ1.
    forwards*: typing_regular_1_exp Typ2.
    destruct~ IHTyp1 as [ (v1' & Val1) | [t1' Red1]];
      destruct~ IHTyp2 as [ (v2' & Val2) | [t2' Red2]];
      subst.
    + SCase "v1 v2".
      right.
      inverts* Typ1.
      inverts* Typ2.
    + SCase "e_merge v1 e2".
      inverts* Typ1.
    + SCase "e_merge e1 v2".
      inverts* Typ2.
    + SCase "e_merge e1 e2".
      inverts* Typ2.
  - Case "anno".
    right.
    destruct~ IHTyp as [ (v' & Val) | [t' Red]].
    + SCase "e_anno v A".
      subst.
      inverts* Typ.
      lets* (v1' & Tyr) : TypedReduce_progress H3 H.
    + SCase "e_anno e A".
      forwards*: Step_anno Red.
Qed.

Theorem preservation_multi_step : forall e e' A,
    nil |= e ~: A ->
    e ->* e' ->
    nil |= e' ~: A.
Proof.
  introv Typ Red.
  induction* Red.
  lets*: preservation Typ H.
Qed.

Theorem type_safety : forall e e' A,
    nil |= e ~: A ->
    e ->* e' ->
    (exists v, e' = (e_val v)) \/ exists e'', step e e''.
Proof.
  introv Typ Red.
  induction Red.
  lets*: progress Typ.
  lets*: preservation Typ H.
Qed.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language Subtyping Auxiliaries Notations Deterministic Automations.

Lemma typing_check_merge_distro :
  forall (v : trm) (A B : typ),
    typing nil nil check_mode v (typ_and A B) ->
    (typing nil nil check_mode v A) /\ (typing nil nil check_mode v B).
Proof.
  intros. split.
  - eapply typing_sub_check.
    eapply H. apply sub_and_l. eapply sub_reflexivity.
  - eapply typing_sub_check.
    eapply H. apply sub_and_r. eapply sub_reflexivity.
Qed.

Lemma sub_type_and_distro :
  forall (A B C : typ),
    ordinary C ->
    sub (typ_and A B) C ->
    sub A C \/ sub B C.
Proof.
  intros.
  dependent induction H0; eauto.
  inversion H.
Qed.

Theorem tred_preservation :
  forall (v v' : trm) (A: typ),
    value v ->
    typing nil nil check_mode v A ->
    typedred v A v' ->
    typing nil nil infer_mode v' A.
Proof.
  intros v v' A Hv Htyp Hred.
  dependent induction Hred.
  - eapply typing_anno; eauto.
  - eapply typing_anno; eauto.
  - apply typing_anno; eauto 3.
    dependent destruction Htyp.
    inversion H0.
    dependent destruction Htyp.
    eapply typing_sub_check; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp.
    inversion H0.
    dependent destruction Htyp.
    + apply IHHred; eauto 3.
      eapply typing_sub.
      eapply Htyp1.
      eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
    + apply IHHred; eauto 3.
      eapply typing_sub.
      eapply Htyp1.
      eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
  - dependent destruction Hv.
    dependent destruction Htyp.
    inversion H0.
    dependent destruction Htyp.
    + apply IHHred; eauto 3.
      eapply typing_sub.
      apply Htyp2.
      eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
    + apply IHHred; eauto 3.
      eapply typing_sub.
      apply Htyp2.
      eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
  - eapply typing_merge_value.
    + eapply tred_value; eauto.
    + eapply tred_value; eauto.
    + eapply IHHred1. assumption.
      eapply typing_check_merge_distro in Htyp. destruct Htyp.
      assumption.
    + eapply IHHred2. assumption.
      eapply typing_check_merge_distro in Htyp. destruct Htyp.
      assumption.
    + dependent destruction Htyp.
      * dependent destruction H0; try solve [inversion Hv].
      * inversion Hv.
      * eapply tred_consistency; eauto.
Qed.

Lemma papp_preservation_infer:
  forall (v vl e : trm) (A B : typ) (S : arg),
    value v -> value vl ->
    papp v vl e ->
    typing nil nil infer_mode vl A ->
    typing nil (cons A S) infer_mode v (typ_arrow A B) ->
    typing nil S infer_mode e B.
Proof.
  intros v vl e A B S Hv Hvl Hp Htyp1 Htyp2.
  dependent induction Htyp1.
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
  - inversion Hvl.
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
    + clear IHHtyp1. clear IHHtyp2.
      dependent destruction H.
      admit.
    + admit.
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
    + admit.
    + admit.
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
Admitted.

Lemma papp_preservation_check :
  forall (v vl e : trm) (A B : typ),
    value v -> value vl ->
    papp v vl e ->
    typing nil nil check_mode v (typ_arrow A B) ->
    typing nil nil infer_mode vl A ->
    typing nil nil check_mode e B.
Proof.
  intros v vl e A B Hv Hvl Hp Htyp1 Htyp2.
  dependent induction Htyp1.
  - eapply pvalue_cannot_be_value in H0; eauto 3. inversion H0.
  - inversion Hv.
  - dependent induction Htyp2; try solve [inversion Hv | inversion Hvl].
    + clear IHHtyp1. clear IHHtyp2.
      dependent destruction H0.
      dependent destruction Hp.
Admitted.

Lemma appsub_typing :
  forall (v : trm) (A B : typ) (S : arg),
    value v ->
    typing nil nil infer_mode v A ->
    appsub S A B ->
    typing nil S infer_mode v B.
Proof.
  intros v A B S Hval Htyp Has.
  dependent destruction Htyp; try solve [inversion Hval].
  - dependent destruction H.
    eapply typing_anno; eauto.
  - dependent destruction Has.
    + eapply typing_merge; eauto.
    + eapply typing_merge_pick.
      assert (Htyp: typing nil S infer_mode (trm_merge e1 e2) (typ_and A B0)).
      admit. eapply Htyp. eapply as_and_l; eauto.
    + eapply typing_merge_pick.
      assert (Htyp: typing nil S infer_mode (trm_merge e1 e2) (typ_and A B0)).
      admit. eapply Htyp. eapply as_and_r; eauto.
  - dependent destruction Has.
    + eapply typing_merge_value; eauto.
    + eapply typing_merge_pick.
      assert (Htyp: typing nil S infer_mode (trm_merge v1 v2) (typ_and A B0)).
      admit. eapply Htyp. eapply as_and_l; eauto.
    + eapply typing_merge_pick.
      assert (Htyp: typing nil S infer_mode (trm_merge v1 v2) (typ_and A B0)).
      admit. eapply Htyp. eapply as_and_r; eauto.
Admitted.

Theorem preservation :
  forall (e e' : trm) (A : typ) (dir : mode) (S : arg),
    typing nil S dir e A ->
    step e e' ->
    typing nil S dir e' A.
Proof.
  intros e e' A dir S Htyp Hred.
  generalize dependent e'.
  dependent induction Htyp; intros; try solve [inversion Hred].
  - dependent destruction Hred.
    eapply typing_anno; eauto.
  - dependent destruction H0.
    + dependent destruction Hred.
      eapply typing_sub; eauto.
    + dependent destruction Hred.
  - dependent destruction Hred; eauto.
    assert (Htyp2: typing nil nil infer_mode v' A).
    eapply tred_preservation; eauto.
    eapply appsub_typing; eauto.
    eapply tred_value; eauto.
  - dependent destruction Hred.
    + eapply papp_preservation_infer with (v:=e1) (vl:=e2); eauto.
    + eapply typing_app1; eauto.
    + eapply typing_app1; eauto.
  - dependent destruction Hred.
    + eapply papp_preservation_check with (v:=e1) (vl:=e2); eauto.
    + eapply typing_app2; eauto.
    + eapply typing_app2; eauto.
  - assert (Htyp2: typing nil nil infer_mode e' B).
    eapply IHHtyp; eauto.
    eapply typing_sub; eauto.
  - dependent destruction Hred.
    + eapply typing_merge; eauto.
    + eapply typing_merge; eauto.
  - assert (Hval: value (trm_merge v1 v2)).
    constructor; eauto.
    apply value_cannot_step_further with (e:=e') in Hval.
    destruct Hval. assumption.
  - assert (Htyp2: typing nil S infer_mode e' B).
    eapply IHHtyp; eauto.
    dependent destruction Hred.
    + eapply typing_merge_pick; eauto.
    + eapply typing_merge_pick; eauto.
Qed.

Lemma value_check_merge :
  forall (v : trm) (A B : typ),
    value v -> typing nil nil check_mode v (typ_and A B) ->
    typing nil nil check_mode v A /\
    typing nil nil check_mode v B.
Proof.
  intros v A B Hv Htyp.
  split.
  eapply typing_sub_check. eapply Htyp.
  eapply sub_and_l. eapply sub_reflexivity.
  eapply typing_sub_check. eapply Htyp.
  eapply sub_and_r. eapply sub_reflexivity.
Qed.

Lemma toplike_cannot_subtype_int :
  forall (A : typ),
    toplike A -> sub A typ_int -> False.
Proof.
  intros.
  dependent induction H; try solve [inversion H0].
  dependent destruction H1.
  eapply IHtoplike1; eauto.
  eapply IHtoplike2; eauto.
Qed.

Lemma abs_cannot_check_by_int :
  forall (A : typ) (e : trm),
    typing nil nil check_mode (trm_abs A e) typ_int -> False.
Proof.
  intros.
  dependent induction H.
  - inversion H.
  - dependent destruction H.
    dependent destruction H0.
Qed.

Theorem tred_progress :
  forall (v : trm) (A : typ),
    value v -> typing nil nil check_mode v A ->
    exists v', typedred v A v'.
Proof.
  intros v A Hv Htyp.
  dependent induction A.
  - dependent induction Hv.
    + dependent induction H.
      * dependent destruction Htyp.
        inversion H.
        dependent destruction Htyp. dependent destruction H.
        dependent destruction Htyp.
        eapply toplike_cannot_subtype_int in H; eauto. contradiction.
        dependent destruction Htyp.
        (* how A plays a role in system *)
        admit.
      * dependent destruction Htyp.
        inversion H0.
        dependent destruction Htyp. dependent destruction H.
        assert (Hcontra: typing nil nil check_mode (trm_abs A0 e) typ_int).
        eapply typing_sub_check; eauto.
        eapply abs_cannot_check_by_int in Hcontra. contradiction.
    + dependent destruction Htyp.
      * inversion H.
      * dependent destruction Htyp.
        dependent destruction H0.
        (* case 1 *)
        assert (exists v', typedred v1 typ_int v').
        eapply IHHv1.
        eapply typing_sub; eauto.
        destruct H1. exists x. eapply tred_merge_l; eauto.
        (* case 2 *)
        assert (exists v', typedred v2 typ_int v').
        eapply IHHv2.
        eapply typing_sub; eauto.
        destruct H1. exists x. eapply tred_merge_r; eauto.
        (* the same *)
        dependent destruction H2.
        (* case 1 *)
        assert (exists v', typedred v1 typ_int v').
        eapply IHHv1.
        eapply typing_sub; eauto.
        destruct H3. exists x. eapply tred_merge_l; eauto.
        (* case 2 *)
        assert (exists v', typedred v2 typ_int v').
        eapply IHHv2.
        eapply typing_sub; eauto.
        destruct H3. exists x. eapply tred_merge_r; eauto.
  - exists (trm_anno (trm_nat 1) typ_top); eauto.
  - clear IHA1. clear IHA2.
    dependent induction Hv.
    + dependent induction H.
      * dependent destruction Htyp. inversion H0.
        dependent destruction Htyp. dependent destruction H.
        assert (Hchk: typing nil nil check_mode (trm_nat n) (typ_arrow A1 A2)).
        eapply typing_sub_check; eauto.
        dependent destruction Hchk.
        (* case 1 *)
        exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)).
        eapply tred_top; eauto.
        (* case 2 *)
        dependent destruction Hchk.
        dependent destruction H1.
         exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)).
         eapply tred_top; eauto. constructor. eapply toplike_sub_top; eauto.
      * dependent destruction Htyp. inversion H0.
        dependent destruction Htyp. dependent destruction H.
        dependent induction H0.
        (* case 1 *)
        exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)).
        eapply tred_top; eauto. constructor. eapply toplike_sub_top; eauto.
        (* case 2 *)
        exists (trm_anno (trm_abs A0 e) (typ_arrow A1 A2)).
        eapply tred_arrow_anno; eauto.
        admit.
        (* case 3 *)
        dependent destruction Htyp.
        dependent destruction H.
        exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)).
        eapply tred_top; eauto. eapply toplike_sub_toplike. eapply H. eapply H0.
        dependent destruction Htyp. dependent destruction H1.
        admit.
        (* case 4 *)
        dependent destruction Htyp.
        dependent destruction H.
        exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)).
        eapply tred_top; eauto. eapply toplike_sub_toplike. eapply H1. eapply H0.
        dependent destruction Htyp. dependent destruction H1.
        admit.
    + dependent destruction Htyp.
      * exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)). eapply tred_top; eauto.
      * dependent destruction Htyp.
        (* case 1 *)
        dependent destruction H0.
        exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)). eapply tred_top; eauto.
        assert (Htred1: exists v', typedred v1 (typ_arrow A1 A2) v').
        eapply IHHv1; eauto. destruct Htred1.
        exists x. eapply tred_merge_l; eauto.
        assert (Htred2: exists v', typedred v2 (typ_arrow A1 A2) v').
        eapply IHHv2; eauto. destruct Htred2.
        exists x. eapply tred_merge_r; eauto.
        (* case 2 *)
        dependent destruction H2.
        exists (trm_anno (trm_nat 1) (typ_arrow A1 A2)). eapply tred_top; eauto.
        constructor. eapply toplike_sub_top; eauto.
        assert (Htred1: exists v', typedred v1 (typ_arrow A1 A2) v').
        eapply IHHv1; eauto. destruct Htred1.
        exists x. eapply tred_merge_l; eauto.
        assert (Htred2: exists v', typedred v2 (typ_arrow A1 A2) v').
        eapply IHHv2; eauto. destruct Htred2.
        exists x. eapply tred_merge_r; eauto.
  (* case 2 *)
  - assert (exists v', typedred v A1 v').
    eapply IHA1; eauto 3.
    eapply value_check_merge in Htyp.
    destruct Htyp. assumption. assumption.
    assert (exists v', typedred v A2 v').
    eapply IHA2; eauto 3.
    eapply value_check_merge in Htyp.
    destruct Htyp. assumption. assumption.
    destruct H. destruct H0.
    exists (trm_merge x x0). eapply tred_and; eauto.
Admitted.

Theorem progress :
  forall (e : trm) (A : typ) (S : arg) (dir : mode),
    typing nil nil dir e A ->
    value e \/ (exists e', step e e') \/
    (exists (e' : trm) (A : typ), e = (trm_abs A e')).
Proof.
  intros e A S dir Htyp.
  dependent induction Htyp.
  - right. left. exists (trm_anno (trm_nat n) typ_int).
    apply step_int_anno.
  - inversion H0.
  - right. right.
    exists e. exists A. reflexivity.
  - dependent induction H0.
    + right. left.
      exists (trm_anno (trm_nat n) typ_int).
      eapply step_int_anno.
    + right. right.
      exists e. exists A0. reflexivity.
  - dependent destruction H.
    assert (IHHtyp1: value e \/ (exists e' : trm, step e e') \/ (exists (e' : trm) (A : typ), e = trm_abs A e')).
    eapply IHHtyp; eauto.
    destruct IHHtyp1.
    + right. left.
      assert (Htred: exists e', typedred e A e').
      eapply tred_progress; eauto.
      destruct Htred.
      exists x. eapply step_anno_value; eauto.
    + destruct H.
      * right. left.
        destruct H.
        exists (trm_anno x A).
        eapply step_anno; eauto.
        intro Hval. dependent destruction Hval.
        admit.
      * destruct H. destruct H.
        left. eapply value_anno. rewrite H.
        eapply pvalue_abs.
  - right. left.
    admit.
  - right. left.
    destruct IHHtyp1; eauto.
    + admit.
    + destruct H.
      * destruct H.
        exists (trm_app e1 x). eapply step_app_v; eauto.
        admit.
      * admit.
  - destruct IHHtyp; eauto.
Admitted.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.arrival_sequence prosa.classic.model.arrival.basic.job
               prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.implementation.task prosa.classic.implementation.job.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq div.

Module ConcreteArrivalSequence.

  Import Job ArrivalSequence ConcreteTask ConcreteJob SporadicTaskset TaskArrival.

  Section PeriodicArrivals.

    Variable ts: concrete_taskset.

    (* At any time t, we release Some job of tsk if t is a multiple of the period,
       otherwise we release None. *)
    Definition add_job (arr_time: time) (tsk: concrete_task) :=
      if task_period tsk %| arr_time  then
        Some (Build_concrete_job (arr_time %/ task_period tsk) arr_time
                                 (task_cost tsk) (task_deadline tsk) tsk)
      else
        None.

    (* The arrival sequence at any time t is simply the partial map of add_job. *)
    Definition periodic_arrival_sequence (t: time) := pmap (add_job t) ts.

  End PeriodicArrivals.

  Section Proofs.

    (* Let ts be any concrete task set with valid parameters. *)
    Variable ts: concrete_taskset.
    Hypothesis H_valid_task_parameters:
      valid_sporadic_taskset task_cost task_period task_deadline ts.

    (* Regarding the periodic arrival sequence built from ts, we prove that...*)
    Let arr_seq := periodic_arrival_sequence ts.

    (* ... arrival times are consistent, ... *)
    Theorem periodic_arrivals_are_consistent:
      arrival_times_are_consistent job_arrival arr_seq.
    Proof.
      move => j t ARRj.
      rewrite /arrives_at mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ... every job comes from the task set, ... *)
    Theorem periodic_arrivals_all_jobs_from_taskset:
      forall j,
        arrives_in arr_seq j ->
        job_task j \in ts.
    Proof.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj.
      move: ARRj => /mapP ARRj; destruct ARRj as [tsk IN SOME].
      by unfold add_job in *; desf.
    Qed.

    (* ..., jobs have valid parameters, ... *)
    Theorem periodic_arrivals_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.
    Proof.
      rename H_valid_task_parameters into PARAMS.
      unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
      move => j [t ARRj].
      rewrite mem_pmap in ARRj; move: ARRj => /mapP [tsk IN SOME].
      unfold add_job in SOME; desf.
      specialize (PARAMS tsk IN); des.
      unfold valid_sporadic_job, valid_realtime_job, job_cost_positive.
      by repeat split; try (by done); apply leqnn.
    Qed.

    (* ... job arrivals satisfy the sporadic task model, ... *)
    Theorem periodic_arrivals_are_sporadic:
      sporadic_task_model task_period job_arrival job_task arr_seq.
    Proof.
      move => j j' /eqP DIFF [arr ARR] [arr' ARR'] SAMEtsk LE.
      rewrite eqE /= /job_eqdef negb_and /= SAMEtsk eq_refl orbF in DIFF.
      rewrite 2!mem_pmap in ARR ARR'.
      move: ARR ARR' => /mapP [tsk_j INj SOMEj] /mapP [tsk_j' INj' SOMEj'].
      unfold add_job in SOMEj, SOMEj'; desf; simpl in *;
      move: Heq0 Heq => /dvdnP [k DIV] /dvdnP [k' DIV'].
      {
        rewrite DIV DIV' -mulSnr.
        rewrite leq_eqVlt in LE; move: LE => /orP [/eqP EQ | LESS].
        {
          exfalso; move: DIFF => /negP DIFF; apply DIFF.
          by subst; rewrite EQ !eq_refl.
        }
        subst; rewrite leq_mul2r; apply/orP; right.
        by rewrite ltn_mul2r in LESS; move: LESS => /andP [_ LT].
      }
    Qed.

    (* ... and the arrival sequence has no duplicate jobs. *)
    Theorem periodic_arrivals_is_a_set:
      arrival_sequence_is_a_set arr_seq.
    Proof.
      intros t.
      unfold arr_seq, periodic_arrival_sequence.
      apply (pmap_uniq) with (g := job_task); last by destruct ts.
      by unfold add_job, ocancel; intro tsk; desf.
    Qed.

  End Proofs.

End ConcreteArrivalSequence.


Require Export Red.

Inductive val_app_type := val_app.
Ltac work :=
  repeat intro;
  repeat
    (match goal with
    | H : val (tapp texf _) |- _ => apply vexf in H; contradict H
    | H : val _ |- _ => apply vreal in H
    | H : val _ |- _ =>
     try solve [(exfalso; dependent destruction H)];
      pose proof (val_func H);
      pose proof (val_arg H);
      check H val_app
    | H : tlit _ = tlit _ |- _ =>
      invcs H
    | H : _ + _ |- _ => destruct H
     end ||
         destruct_exists ||
         subst);
  uncheck_all val_app;
  cleanPS tauto.

Definition vprod { A B } p :
  val p -> { l : _ & { r | p = (tapp (tapp (@tmkprod A B) l) r) /\ val l /\ val r } }.
  dependent destruction p; intros H.
  dependent destruction p1; try (solve [exfalso; dependent destruction H]).
  dependent destruction p1_1; try (solve [exfalso; dependent destruction H]).
  work; eauto.
Defined.

Definition vsum { A B } s :
  val s -> { l | s = tapp (@tleft A B) l /\ val l } + { r | s = tapp tright r /\ val r }.
  dependent destruction s; intros H.
  dependent destruction s1; try (solve [exfalso; dependent destruction H]);
    work; eauto.
Defined.

Ltac dd1 := let x := fresh in intros x; dependent destruction x.

Fixpoint type_size (x : type) : nat :=
  match x with
  | tytop => 1
  | tybot => 1
  | tyreal => 1
  | tysum A B => 1 + type_size A + type_size B
  | typrod A B => 1 + type_size A + type_size B
  | tyarr A B => 1 + type_size A + type_size B
  end.

Require Import Omega.

Ltac discharge_type_eq :=
  repeat (Apply (f_equal type_size)); simpl in *; omega.

Definition val_dec X (tm : term X) : { val tm } + { ~ (val tm) }.
  induction tm; eauto; [].
  destruct IHtm1, IHtm2; try (right; intuition idtac; work; solve [eauto]); eauto; [].
  dependent destruction tm1; eauto; try (right; solve [dd1]); [].
  dependent destruction tm1_1; work; eauto;
    (right;
     repeat destruct_exists;
     subst;
     solve [dd1]).
Defined.

Definition red_not_val A x y : red x y -> ~ @val A x.
  intros H;
    dependent induction H;
    work; try tauto; repeat destruct_exists; congruence.
Defined.

Definition val_not_red A x y : @val A x -> ~ red x y.
  intros X H;
    dependent induction H;
    work; try tauto; repeat destruct_exists; congruence.
Defined.

Definition eval A x : { y | red x y } + { @val A x }.
  Ltac red_it := left; repeat destruct_exists; repeat econstructor; solve [eauto].
  dependent induction x;
    repeat
      match goal with
      | H : { _ | _ } + { _ } |- _ => destruct H as [[]|]
      end;
    eauto;
    try red_it; [].
  dependent destruction x1; eauto; try red_it; work.
  + dependent destruction x1_1; eauto; work; try red_it; [].
    dependent destruction x1_1_1; try red_it; work; [].
    dependent destruction x1_1_2; dependent destruction x1_1_2_1; work; red_it.
  + dependent destruction x2; dependent destruction x2_1; work; [].
    dependent destruction x2_1_1; work; [].
    red_it.
  + dependent destruction x2; dependent destruction x2_1; work; [].
    dependent destruction x2_1_1; work; [].
    red_it.
Defined.

Inductive hasZ : forall { x }, term x -> Prop :=
| direct_Z A B : hasZ (@tZ A B)
| left_Z A B l r : hasZ l -> hasZ (@tapp A B l r)
| right_Z A B l r : hasZ r -> hasZ (@tapp A B l r).

Hint Constructors hasZ.

Definition eval_to { T } x y := (transitive_closure red x y /\ @val T y).

Hint Unfold eval_to.

Definition halt { T } (x : term T) := exists y, eval_to x y.

Arguments halt { T } x /.

Fixpoint rel { ty : type } : term ty -> Prop :=
  match ty with
  | tytop => halt
  | tybot => halt
  | tyreal => halt
  | tysum _ _ => fun x => (exists l, eval_to x (tapp tleft l) /\ rel l) \/
                      (exists r, eval_to x (tapp tright r) /\ rel r)
  | typrod _ _ => fun x => exists l r, eval_to x (tapp (tapp tmkprod l) r) /\ rel l /\ rel r
  | _ ~> _ => fun f => exists f', eval_to f f' /\ (forall x, rel x -> val x -> rel (tapp f' x))
  end.

Arguments rel ty _ : simpl never.

Definition rel_top t : @halt tytop t -> rel t := ltac:(ii).

Definition rel_bot t : @halt tybot t -> rel t := ltac:(ii).

Definition rel_real t : @halt tyreal t -> rel t := ltac:(ii).

Definition rel_sum A B t :
  ((exists l, eval_to t (tapp tleft l) /\ @rel A l) \/
   (exists r, eval_to t (tapp tright r) /\ @rel B r)) -> rel t :=
  ltac:(compute; tauto).

Definition rel_prod A B t :
  (exists l r, eval_to t (tapp (tapp tmkprod l) r) /\
          @rel A l /\
          @rel B r) -> rel t := ltac:(ii).

Definition rel_arr A B t :
  (exists t', @eval_to (A ~> B) t t' /\
         (forall x, rel x -> val x -> rel (tapp t' x))) -> rel t :=
  ltac:(compute; ii).

Definition top_rel t : rel t -> @halt tytop t := ltac:(ii).

Definition bot_rel t : rel t -> @halt tybot t := ltac:(ii).

Definition real_rel t : rel t -> @halt tyreal t := ltac:(ii).

Definition sum_rel A B t :
  rel t -> ((exists l, eval_to t (tapp tleft l) /\ @rel A l) \/
           (exists r, eval_to t (tapp tright r) /\ @rel B r)) :=
  ltac:(ii).

Definition prod_rel A B t :
  rel t -> (exists l r, eval_to t (tapp (tapp tmkprod l) r) /\
                  @rel A l /\
                  @rel B r) := ltac:(ii).

Definition arr_rel A B t : rel t ->
  (exists t', @eval_to (A ~> B) t t' /\
         (forall x, rel x -> val x -> rel (tapp t' x))) :=
  ltac:(compute; ii).

Ltac unfold_rel :=
  repeat
    (try
       match goal with
       | H : @rel tytop _ |- _ =>
         apply top_rel in H; ii
       | H : @rel tybot _ |- _ =>
         apply bot_rel in H; ii
       | H : @rel tyreal _ |- _ =>
         apply real_rel in H; ii
       | H : @rel (tysum _ _) _ |- _ =>
         apply sum_rel in H; repeat (destruct_exists || ii)
       | H : @rel (typrod _ _) _ |- _ =>
         apply prod_rel in H; repeat (destruct_exists || ii)
       | H : @rel (tyarr _ _) _ |- _ =>
         apply arr_rel in H; repeat (destruct_exists || ii)
       end;
     try (apply rel_top; ii);
     try (apply rel_bot; ii);
     try (apply rel_real; ii);
     try (apply rel_sum; repeat (destruct_exists || ii));
     try (apply rel_prod; repeat (destruct_exists || ii));
     try (apply rel_arr; repeat (destruct_exists || ii))).

Definition rel_halt t te : @rel t te -> halt te :=
  ltac:(destruct t; ii; unfold_rel; simpl in *; eauto 6).

Definition transitive_closure_appf { A B } f f' x :
  transitive_closure red f f' ->
  transitive_closure red (@tapp A B f x) (tapp f' x) :=
  ltac:(induction 1; eauto).

Definition transitive_closure_appx { A B } f x x' :
  val f ->
  transitive_closure red x x' ->
  transitive_closure red (@tapp A B f x) (tapp f x') :=
  ltac:(induction 2; eauto).

Definition hasZ_dec { A } x : { @hasZ A x } + { ~ hasZ x } :=
  ltac:(
    dependent induction x;
      repeat
        match goal with
        | H : { _ } + { _ } |- _ => destruct H
        end;
      eauto; right; ii; dependent destruction H; eauto; discharge_type_eq).

Definition type_eq_dec (x y : type) : { x = y } + { x <> y } := ltac:(decide equality).

Definition app_eq_func { A B } fl fr xl xr : @tapp A B fl xl = tapp fr xr -> fl = fr.
  intros H; invcs H.
  repeat Apply (Eqdep_dec.inj_pair2_eq_dec _ type_eq_dec); tauto.
Defined.

Definition app_eq_arg { A B } fl fr xl xr : @tapp A B fl xl = @tapp A B fr xr -> xl = xr.
  intros H; invcs H.
  repeat Apply (Eqdep_dec.inj_pair2_eq_dec _ type_eq_dec); tauto.
Defined.

Ltac Deduct t :=
  match goal with
  | H : _ |- _ => pose proof H; apply t in H
  end.

Definition app_eq { A B } fl fr xl xr : @tapp A B fl xl = tapp fr xr ->
                                        fl = fr /\ xl = xr :=
  ltac:(ii; Deduct (@app_eq_arg A B); Deduct (@app_eq_func A B); ii).

Definition term_eq_dec
           (rdec : forall l r : R, { l = r } + { l <> r })
           A (x : term A) (y : term A)
  : { x = y } + { x <> y }.
  Ltac ric := right; ii; congruence.
  dependent induction x; ii; dependent destruction y; eauto; try ric;
    try discharge_type_eq.
  + destruct (type_eq_dec A A0); subst.
     ++ destruct (IHx1 y1), (IHx2 y2); subst; eauto;
          right; ii;
        repeat Apply @app_eq; ii; subst; try tauto.
     ++ right; intros H; inversion H; tauto.
  + destruct (rdec r r0); [left|right]; congruence.
Defined.

Definition red_det { t x x' x'' } : @red t x x' -> red x x'' -> x' = x''.
  induction 1;
    let H := fresh in intros H; dependent destruction H; ii;
                        match goal with
                        | H : red ?x _ |- _ =>
                          try (assert (val x) by eauto; Apply val_not_red; ii)
                        end.
  f_equal; solve [eauto].
  EApply (val_not_red _ f); exfalso; solve [eauto].
  f_equal; solve [eauto].
Defined.

Definition halt_red_back t x y : @red t x y -> halt y -> halt x :=
  ltac:(unfold halt, eval_to; ii; destruct_exists; ii; eauto).

Hint Resolve halt_red_back.

Ltac break_hasZ :=
  repeat
    match goal with
    | H : hasZ (tapp _ _) |- _ => dependent destruction H
    | H : hasZ (tlit _) |- _ => dependent destruction H
    end;
  try
    match goal with
    | H : hasZ _ |- _ => solve[dependent destruction H; discharge_type_eq]
    end;
  try discharge_type_eq.

Definition hasY_red_back t x y : @red t x y -> hasZ y -> hasZ x :=
  ltac:(intros H; dependent induction H; ii; break_hasZ; eauto).

Hint Resolve hasY_red_back.

Hint Unfold eval_to.

Definition rel_red_back t : forall x y, @red t x y -> rel y -> rel x :=
  ltac:(induction t;
          intros H;
          dependent destruction H;
          ii;
          unfold_rel;
          simpl in *;
          repeat destruct_exists;
          unfold eval_to in *;
          ii;
          eauto 8).

Hint Resolve rel_red_back.

Definition red_app_func_det {A B : type} (f f' : term (A ~> B)) (x : term A) y :
    red f f' -> red (tapp f x) y -> y = tapp f' x :=
  ltac:(intros; eapply red_det; [eassumption|solve [eauto]]).

Definition red_app_arg_det {A B : type} (f : term (A ~> B)) (x x' : term A) y :
  val f -> red x x' -> red (tapp f x) y -> y = tapp f x' :=
  ltac:(intros; eapply red_det; [eassumption|solve [eauto]]).

Ltac use_red_det :=
  repeat (
      match goal with
      | L : red ?x ?y, R : red ?x ?z |- _ =>
        pose proof (red_det L R); subst; clear R
      end).

Definition halt_red_preserve t x y : @red t x y -> halt x -> halt y.
  intros R H.
  destruct H as [? [H (*bug: using [] will not work*)]]; destruct H;
    simpl in *; use_red_det; eauto; [].
  Apply red_not_val; tauto.
Defined.

Definition red_trans_val { t x y z } :
  @red t x y ->
  transitive_closure red x z ->
  val z ->
  transitive_closure red y z.
  destruct 2; ii; use_red_det; eauto.
  Apply red_not_val; tauto.
Defined.

Ltac use_red_trans_val :=
  repeat (
      match goal with
      | L : red ?x ?y, R : transitive_closure red ?x ?z |- _ =>
        let H := fresh in
        assert (val z) as H by eauto;
        pose proof (red_trans_val L R H); clear R
      end).

Definition rel_red_preserve t : forall x y, @red t x y -> rel x -> rel y.
  induction t; ii; unfold_rel; unfold eval_to in *; eauto using halt_red_preserve.
  left; econstructor; ii; eauto; []; use_red_trans_val; tauto.
  right; econstructor; ii; eauto; []; use_red_trans_val; tauto.
  do 2 econstructor; ii; eauto; []; use_red_trans_val; tauto.
  econstructor; ii; use_red_trans_val; eauto.
Defined.

Definition hasZ_trans_back t x y : transitive_closure (@red t) x y -> hasZ y -> hasZ x :=
  ltac:(induction 1; eauto).

Hint Resolve hasZ_trans_back.

Definition rel_trans_preserve t x y :
  transitive_closure (@red t) x y -> rel x -> rel y.
  induction 1; ii; [].
  eapply IHtransitive_closure; ii.
  eapply rel_red_preserve; solve [eauto].
Defined.

Definition rel_trans_back t x y :
  transitive_closure (@red t) x y -> rel y -> rel x :=
  ltac:(induction 1; ii; eauto).

Ltac goal_rel_step :=
  eapply rel_red_back; [solve [eauto]|].

Definition rel_app { A B } f x : rel f -> rel x -> rel (@tapp A B f x).
  ii; Apply arr_rel; destruct_exists; unfold eval_to in *; ii.
  Deduct rel_halt;
    unfold halt, eval_to in *;
    destruct_exists; ii.
  eapply rel_trans_back.
  eapply transitive_closure_transitive.
  eapply transitive_closure_appf; solve [eauto].
  eapply transitive_closure_appx; solve [eauto].
  eapply H3; eauto.
  eapply rel_trans_preserve; eassumption.
Defined.

Hint Resolve rel_app.

Definition rel_lit r : rel (tlit r) := ltac:(compute; eauto).

Hint Resolve rel_lit.

Definition trans_val_eq { t x y } :
  transitive_closure (@red t) x y -> val x -> x = y :=
  ltac:(destruct 1; try Apply red_not_val; tauto).

Ltac use_trans_val_eq_with T :=
  repeat
    match goal with
    | H : transitive_closure red ?x _ |- _ =>
      (let V := fresh in
      assert(V : val x) by T; pose proof (trans_val_eq H V); clear H; subst)
    end.

Ltac use_trans_val_eq := use_trans_val_eq_with eauto.

Definition noZ_split A B f x : ~ hasZ (@tapp A B f x) -> ~ hasZ f /\ ~ hasZ x :=
  ltac:(ii; eauto).

Definition rel_hold t x (_ : ~ hasZ x) : @rel t x.
  induction x;
    try (compute; solve [eauto]);
    repeat (
        try goal_rel_step;
        try (econstructor; ii; [solve [eauto]|solve [eauto]|]);
        unfold_rel;
        unfold eval_to in *;
        simpl in *;
        use_trans_val_eq;
        try Apply noZ_split;
        ii;
        work);
    eauto.
  + eapply rel_trans_back.
    eapply transitive_closure_appf; try eassumption.
    Deduct rel_halt; unfold halt, eval_to in *; destruct_exists; ii.
    eapply rel_trans_back.
    eapply transitive_closure_appx; eauto.
    apply H5; eauto; [].
    eapply rel_trans_preserve; eassumption.
  + left; econstructor; ii; solve [eauto].
  + right; econstructor; ii; solve [eauto].
  + do 2 econstructor; ii; solve [eauto].
  + specialize (H9 _ H5 H7).
    pose proof (rel_halt _ _ H9); unfold halt, eval_to in *; destruct_exists; ii.
    eapply rel_trans_back.
    eapply transitive_closure_appx; eassumption.
    eapply H4; eauto; [].
    eapply rel_trans_preserve; eassumption.
  + exfalso; eauto.
Defined.


Require Export UniMath.CategoryTheory.limits.pullbacks.
Require Export TypeTheory.Csystems.lC0systems.
Require Export TypeTheory.Csystems.lCsystems.

Open Scope cat.

Definition has_canonical_pullbacks (CC : lC0system) :=
  ∏ (X Y : CC) (gt0: ll X > 0) (f : Y --> ft X),
    isPullback
      ((C0emor gt0 f) · f )
      (pX X)
      (pX (f_star gt0 f))
      (q_of_f gt0 f)
      (C0ax5c gt0 f).

Definition lCsystem' := total2 (fun CC => has_canonical_pullbacks CC).

Lemma idftf_is_fft (CC : lC0system) (X Y : CC) (f : Y --> X) : (identity Y) · (ftf f) = f · (pX X).
Proof.
  rewrite (id_left (ftf f)).
  unfold ftf.
  apply idpath.
Defined.

Lemma ftn1_is_ft (CC : lC0system) (X : CC) : ftn 1 X = ft X.
Proof.
  apply idpath.
Defined.

Definition C0emor_inv { CC : lC0system }
           { X Y : CC } ( gt0 : ll X > 0 ) ( f : Y --> ft X ):
  Y --> ft ( f_star gt0 f ) := idtomor _ _ (pathsinv0 (@C0ax5b CC X Y gt0 f )).

Definition idmorcomp (C : precategory) (X Y : C) (p : X=Y) : idtomor Y X (!p) · idtomor X Y p = identity Y.
Proof.
  induction p.
  cbn.
  rewrite id_left.
  apply idpath.
Defined.

Lemma C0emor_cancellation { CC : lC0system }
    { X Y : CC } (gt0 : ll X > 0) (f : Y--> ft X) : (C0emor_inv gt0 f) · (C0emor gt0 f) = identity Y.
Proof.
  unfold C0emor_inv, C0emor, C0ax5b_mor. apply idmorcomp.
Defined.

(*
Theorem canonical_pullbacks_to_Csystem (CC: lC0system) (pb : has_canonical_pullbacks CC) : lCsystem.
Proof.
  use tpair. { exact CC. }
  cbn.
  use tpair.
  - unfold sf_type.
    intros.
    use tpair.
    + rewrite ftn1_is_ft.
      rewrite ft_f_star.
      pose (comm:=idftf_is_fft CC X Y f).
      rewrite <- (C0emor_cancellation gt0 (ftf f)) in comm.
      rewrite <- assoc in comm.
      exact (pr1 (pr1 (pb X Y gt0 (ftf f) Y (C0emor_inv gt0 (ftf f)) f (comm)))).
    + cbn.
      set (p:=C0emor_cancellation gt0 (ftf f)).
      set (q:=(assoc (C0emor_inv gt0 (ftf f)) (C0emor gt0 (ftf f)) (ftf f))).
      set (r:= ft_f_star gt0 (ftf f)).
      set (s:= (internal_paths_rew_r (pr1 CC ⟦ Y, Y ⟧) (C0emor_inv gt0 (ftf f) · C0emor gt0 (ftf f))
                 (identity Y) (λ p0 : pr1 CC ⟦ Y, Y ⟧, p0 · ftf f = f · pX X) (idftf_is_fft CC X Y f) p)).
      cbn in s.
      fail.
*)


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

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

Print Assumptions add.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P Q : Universe, ((wd_ B Q /\ (wd_ P Q /\ (wd_ Q C /\ (wd_ P C /\ (wd_ B C /\ (wd_ A P /\ (col_ B P Q /\ (col_ B Q C /\ col_ A C P)))))))) -> col_ P Q C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e256m4294968273_10limbs.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_2e383m187_7limbs.Synthesis.

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

Print Assumptions add.


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

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

Print Assumptions add.