(************************************************************
 * Core of source/target/combined language definitions      *
 *   Defines: pre-types (typ), pre-terms (trm),             *
 *            substitution for free/bound vars (open/subst) *
 *            pre-contexts (ctx), plug, ctx_open, ctx_subst *
 * from Ahmed & Blume ICFP 2011                             *
 * William J. Bowman, Phillip Mates & James T. Perconti     *
 ************************************************************)

Require Export LibLN.
Require Import EqNat.
Implicit Type x : var.
Implicit Type X : var.

(* flag for convenience later *)
Inductive lang : Set := source : lang | target : lang.

Definition beq_lang l1 l2 :=
  match (l1, l2) with
  | (source, source) => true
  | (target, target) => true
  | (_, _) => false
  end.

Definition inc_if_eq (l1 l2 : lang) : nat -> nat :=
  if beq_lang l1 l2 then S else id.

(*** Syntax of pre-types ***)

Inductive typ : Set :=
  (* Source types *)
  | s_typ_bool : typ                (* bool *)
  | s_typ_arrow : typ -> typ -> typ (* s -> s *)

  (* Target types *)
  | t_typ_bvar : nat -> typ         (* N *)
  | t_typ_fvar : var -> typ         (* X *)
  | t_typ_bool : typ                (* bool *)
  | t_typ_pair : typ -> typ -> typ  (* t x t *)
  | t_typ_arrow : typ -> typ -> typ (* forall . t -> t *)

  (* error case *)
  | typ_bad : typ.

(*** Syntax of pre-terms ***)

Inductive trm : Set :=
  (* source values *)
  | s_trm_bvar : nat -> trm             (* n *)
  | s_trm_fvar : var -> trm             (* x *)
  | s_trm_true : trm                    (* tt *)
  | s_trm_false : trm                   (* ff *)
  | s_trm_abs : typ -> trm -> trm       (* lambda : s . e *)
  (* source non-values *)
  | s_trm_if : trm -> trm -> trm -> trm (* if e e e *)
  | s_trm_app : trm -> trm -> trm       (* e e *)

  (* target values *)
  | t_trm_bvar  : nat -> trm               (* n *)
  | t_trm_fvar  : var -> trm               (* x *)
  | t_trm_true  : trm                      (* tt *)
  | t_trm_false : trm                      (* ff *)
  | t_trm_pair  : trm -> trm -> trm        (* (u, u) *)
  | t_trm_abs   : typ -> trm -> trm        (* Lambda . lambda : t . m *)
  (* target non-values *)
  | t_trm_if    : trm -> trm -> trm -> trm (* if u m m *)
  | t_trm_let_fst : trm -> trm -> trm      (* let  = fst u in m *)
  | t_trm_let_snd : trm -> trm -> trm      (* let  = snd u in m *)
  | t_trm_app   : trm -> typ -> trm -> trm (* u [t] u *)

  (* Boundary Terms *)
  | s_trm_st : trm -> typ -> trm         (* (s) ST m *)
  | t_trm_ts : trm -> typ -> trm -> trm  (* let  = TS (s) e in m *)

  (* error case *)
  | trm_bad.

(*** Substitution for (type and term) bvars ***)

(* Opening up a type binder occuring in a type *)
Fixpoint open_tt_rec (K : nat) (t' : typ) (t : typ) : typ :=
  match t with
  (* no type variables in source types *)
  | s_typ_bool        => t
  | s_typ_arrow _ _   => t
  (* target types *)
  | t_typ_bvar N      => if beq_nat K N then t' else (t_typ_bvar N)
  | t_typ_fvar X      => t_typ_fvar X
  | t_typ_bool        => t_typ_bool
  | t_typ_pair t1 t2  => t_typ_pair (open_tt_rec K t' t1)
                                    (open_tt_rec K t' t2)
     (* t_typ_arrow is the binding form for type variables *)
  | t_typ_arrow t1 t2 => t_typ_arrow (open_tt_rec (S K) t' t1)
                                     (open_tt_rec (S K) t' t2)
  (* blah *)
  | typ_bad => typ_bad
  end.

(** Opening up a type binder occuring in a term *)
Fixpoint open_te_rec (K : nat) (t' : typ) (e : trm) : trm :=
  match e with
  (* source terms *)
  | s_trm_bvar n      => s_trm_bvar n
  | s_trm_fvar x      => s_trm_fvar x
  | s_trm_true        => s_trm_true
  | s_trm_false       => s_trm_false
  | s_trm_abs s e     => s_trm_abs s (open_te_rec K t' e)
  | s_trm_if e1 e2 e3 => s_trm_if (open_te_rec K t' e1)
                                  (open_te_rec K t' e2)
                                  (open_te_rec K t' e3)
  | s_trm_app e1 e2   => s_trm_app (open_te_rec K t' e1)
                                   (open_te_rec K t' e2)
  | s_trm_st m s      => s_trm_st (open_te_rec K t' m) s
  (* target terms *)
  | t_trm_bvar i      => t_trm_bvar i
  | t_trm_fvar x      => t_trm_fvar x
  | t_trm_true        => t_trm_true
  | t_trm_false       => t_trm_false
  | t_trm_pair u1 u2  => t_trm_pair (open_te_rec K t' u1)
                                    (open_te_rec K t' u2)
     (* t_trm_abs is the only term-level form that binds a type variable *)
  | t_trm_abs t m     => t_trm_abs (open_tt_rec (S K) t' t)
                                   (open_te_rec (S K) t' m)
  | t_trm_if u m1 m2  => t_trm_if (open_te_rec K t' u)
                                  (open_te_rec K t' m1)
                                  (open_te_rec K t' m2)
  | t_trm_let_fst u m => t_trm_let_fst (open_te_rec K t' u)
                                       (open_te_rec K t' m)
  | t_trm_let_snd u m => t_trm_let_snd (open_te_rec K t' u)
                                       (open_te_rec K t' m)
  | t_trm_app m1 t m2 => t_trm_app (open_te_rec K t' m1)
                                   (open_tt_rec K t' t)
                                   (open_te_rec K t' m2)
  | t_trm_ts e s m    => t_trm_ts (open_te_rec K t' e) s (open_te_rec K t' m)
  (* blah *)
  | trm_bad => trm_bad
  end.

(** Opening up a term binder appearing in a term *)
Fixpoint open_ee_rec (l : lang) (k : nat) (e' : trm) (e : trm) : trm :=
  match e with
  (* source terms *)
  | s_trm_bvar i      => if andb (beq_lang l source) (beq_nat k i)
                         then e'
                         else (s_trm_bvar i)
  | s_trm_fvar x      => s_trm_fvar x
  | s_trm_true        => s_trm_true
  | s_trm_false       => s_trm_false
  | s_trm_abs s e     => s_trm_abs s
                                   (open_ee_rec l (inc_if_eq l source k) e' e)
  | s_trm_if e1 e2 e3 => s_trm_if (open_ee_rec l k e' e1)
                                  (open_ee_rec l k e' e2)
                                  (open_ee_rec l k e' e3)
  | s_trm_app e1 e2   => s_trm_app (open_ee_rec l k e' e1)
                                   (open_ee_rec l k e' e2)
  | s_trm_st m s      => s_trm_st (open_ee_rec l k e' m) s
  (* target terms *)
  | t_trm_bvar i      => if andb (beq_lang l target) (beq_nat k i)
                         then e'
                         else t_trm_bvar i
  | t_trm_fvar x      => t_trm_fvar x
  | t_trm_true        => t_trm_true
  | t_trm_false       => t_trm_false
  | t_trm_pair u1 u2  => t_trm_pair (open_ee_rec l k e' u1)
                                    (open_ee_rec l k e' u2)
  | t_trm_abs t m     => t_trm_abs t (open_ee_rec l (inc_if_eq l target k) e' m)
  | t_trm_if u m1 m2  => t_trm_if (open_ee_rec l k e' u)
                                  (open_ee_rec l k e' m1)
                                  (open_ee_rec l k e' m2)
  | t_trm_let_fst u m => t_trm_let_fst (open_ee_rec l k e' u)
                                       (open_ee_rec l
                                         (inc_if_eq l target k) e' m)
  | t_trm_let_snd u m => t_trm_let_snd (open_ee_rec l k e' u)
                                       (open_ee_rec l
                                         (inc_if_eq l target k) e' m)
  | t_trm_app m1 t m2 => t_trm_app (open_ee_rec l k e' m1)
                                   t
                                   (open_ee_rec l k e' m2)
  | t_trm_ts e s m    => t_trm_ts (open_ee_rec l k e' e)
                                  s
                                  (open_ee_rec l (inc_if_eq l target k) e' m)
  (* blah *)
  | trm_bad => trm_bad
  end.

Notation "< t { t' / K }>" := (open_tt_rec K t' t).
Notation "< e { t / K }>" := (open_te_rec K t e).
Notation "< e [ e' / k ]>" := (open_ee_rec target k e' e).

Notation open_tt := (fun t t' => open_tt_rec 0 t' t). (* t [t' / 0] *)
Notation open_te := (fun e t' => open_te_rec 0 t' e). (* e [t' / 0] *)
Notation s_open_ee := (fun e e' => open_ee_rec source 0 e' e). (* e [e' / 0] *)
Notation t_open_ee := (fun e m' => open_ee_rec target 0 m' e). (* e [m' / 0] *)

Notation open_tt_var := (fun t X => open_tt t (t_typ_fvar X)).
Notation open_te_var := (fun e X => open_te e (t_typ_fvar X)).
Notation s_open_ee_var := (fun e x => s_open_ee e (s_trm_fvar x)).
Notation t_open_ee_var := (fun e x => t_open_ee e (t_trm_fvar x)).

(*** Environments and Substitutions ***)

(* an env_type is a set of type variables with their kinds *)
Definition env_type := LibEnv.env unit. (* Delta *)
Definition star := tt. (* base kind '*' that all types share *)

(* an env_term is a set of term variables with their types *)
Definition env_term := LibEnv.env typ.  (* Gamma *)

(* a subst_type is a mapping (substitution) from type variables to types *)
Definition subst_type := LibEnv.env typ. (* delta *)

(* a subst_term is a mapping (substitution) from term variables to terms *)
Definition subst_term := LibEnv.env trm. (* gamma *)

(** apply a subst_type in a type *)
Fixpoint subst_tt (d : subst_type) (t : typ) :=
  match t with
  (* no type variables in source types *)
  | s_typ_bool        => t
  | s_typ_arrow _ _   => t
  (* target types *)
  | t_typ_bvar N      => t_typ_bvar N
  | t_typ_fvar X      => match get X d with None => t_typ_fvar X
                           | Some t => t end
  | t_typ_bool        => t_typ_bool
  | t_typ_pair t1 t2  => t_typ_pair (subst_tt d t1) (subst_tt d t2)
  | t_typ_arrow t1 t2 => t_typ_arrow (subst_tt d t1) (subst_tt d t2)
  (* blah *)
  | typ_bad => typ_bad
  end.

(** apply a subst_type in a term *)
Fixpoint subst_te (d : subst_type) (e : trm) :=
  match e with
    | s_trm_bvar n      => s_trm_bvar n
    | s_trm_fvar x      => s_trm_fvar x
    | s_trm_true        => s_trm_true
    | s_trm_false       => s_trm_false
    | s_trm_abs s e     => s_trm_abs s (subst_te d e)
    | s_trm_if e1 e2 e3 => s_trm_if (subst_te d e1)
                                    (subst_te d e2)
                                    (subst_te d e3)
    | s_trm_app e1 e2   => s_trm_app (subst_te d e1) (subst_te d e2)
    | s_trm_st m s      => s_trm_st (subst_te d m) s

    | t_trm_bvar n      => t_trm_bvar n
    | t_trm_fvar x      => t_trm_fvar x
    | t_trm_true        => t_trm_true
    | t_trm_false       => t_trm_false
    | t_trm_pair u1 u2  => t_trm_pair (subst_te d u1) (subst_te d u2)
    | t_trm_abs t m     => t_trm_abs (subst_tt d t) (subst_te d m)
    | t_trm_if u m1 m2  => t_trm_if (subst_te d u)
                                    (subst_te d m1)
                                    (subst_te d m2)
    | t_trm_let_fst u m => t_trm_let_fst (subst_te d u) (subst_te d m)
    | t_trm_let_snd u m => t_trm_let_snd (subst_te d u) (subst_te d m)
    | t_trm_app m1 t m2 => t_trm_app (subst_te d m1)
                                     (subst_tt d t)
                                     (subst_te d m2)
    | t_trm_ts e s m    => t_trm_ts (subst_te d e) s (subst_te d m)
    | trm_bad => trm_bad
  end.

(** apply a subst_term in a term *)
(* This definition only allows us to apply single-language substitutions.
   Since envs are not tagged with the language of the vars in their domains,
   we have to be careful about which language variables are in. *)
Fixpoint subst_ee (l : lang) (g : subst_term) (e : trm) :=
  match e with
    | s_trm_bvar n      => s_trm_bvar n
    | s_trm_fvar x      => if beq_lang l source
                           then match get x g with
                                  | Some v => v
                                  | None => s_trm_fvar x end
                           else s_trm_fvar x
    | s_trm_true        => s_trm_true
    | s_trm_false       => s_trm_false
    | s_trm_abs s e     => s_trm_abs s (subst_ee l g e)
    | s_trm_if e1 e2 e3 => s_trm_if (subst_ee l g e1)
                                    (subst_ee l g e2)
                                    (subst_ee l g e3)
    | s_trm_app e1 e2   => s_trm_app (subst_ee l g e1) (subst_ee l g e2)
    | s_trm_st m s      => s_trm_st (subst_ee l g m) s

    | t_trm_bvar n      => t_trm_bvar n
    | t_trm_fvar x      => if beq_lang l target
                           then match get x g with
                             | Some v => v
                             | None => t_trm_fvar x end
                           else t_trm_fvar x
    | t_trm_true        => t_trm_true
    | t_trm_false       => t_trm_false
    | t_trm_pair u1 u2  => t_trm_pair (subst_ee l g u1) (subst_ee l g u2)
    | t_trm_abs t m     => t_trm_abs t (subst_ee l g m)
    | t_trm_if u m1 m2  => t_trm_if (subst_ee l g u)
                                    (subst_ee l g m1)
                                    (subst_ee l g m2)
    | t_trm_let_fst u m => t_trm_let_fst (subst_ee l g u) (subst_ee l g m)
    | t_trm_let_snd u m => t_trm_let_snd (subst_ee l g u) (subst_ee l g m)
    | t_trm_app m1 t m2 => t_trm_app (subst_ee l g m1) t (subst_ee l g m2)
    | t_trm_ts e s m    => t_trm_ts (subst_ee l g e) s (subst_ee l g m)
    | trm_bad => trm_bad
  end.

Notation s_subst_ee := (subst_ee source).
Notation t_subst_ee := (subst_ee target).

Notation "tt[ t' / X ] t" := (subst_tt (X ~ t') t) (at level 75).
Notation "te[ t' / X ] m" := (subst_te (X ~ t') m) (at level 75).

(*** Contexts ***)

Inductive ctx : Set :=
  (* Source *)
  (* evaluation and general contexts *)
  | s_ctx_hole : ctx                          (* [] *)
  | s_ctx_if : ctx -> trm -> trm -> ctx       (* if E e e *)
  | s_ctx_app1 : ctx -> trm -> ctx            (* E e *)
  | s_ctx_app2 : trm -> ctx -> ctx            (* v E / e C *)
  (* general contexts only *)
  | s_ctx_abs : typ -> ctx -> ctx             (* lambda : s . C *)
  | s_ctx_if_true : trm -> ctx -> trm -> ctx  (* if e C e *)
  | s_ctx_if_false : trm -> trm -> ctx -> ctx (* if e e C *)

  (* Target *)
  (* evaluation, value, term contexts *)
  | t_ctx_hole : ctx                          (* [] *)
  (* value and term contexts *)
  | t_ctx_pair_left : ctx -> trm -> ctx       (* (Cval, u) *)
  | t_ctx_pair_right : trm -> ctx -> ctx      (* (u, Cval) *)
  | t_ctx_abs : typ -> ctx -> ctx             (* Lambda . lambda : t . C *)
  (* term contexts *)
  | t_ctx_if : ctx -> trm -> trm -> ctx       (* if Cval m m *)
  | t_ctx_if_true : trm -> ctx -> trm -> ctx  (* if m C m *)
  | t_ctx_if_false : trm -> trm -> ctx -> ctx (* if m m C *)
  | t_ctx_let_fst : ctx -> trm -> ctx         (* let  = fst Cval in m *)
  | t_ctx_let_fst_k : trm -> ctx -> ctx       (* let  = fst m in C *)
  | t_ctx_let_snd : ctx -> trm -> ctx         (* let  = snd Cval in m *)
  | t_ctx_let_snd_k : trm -> ctx -> ctx       (* let  = snd Cval in m *)
  | t_ctx_app1 : ctx -> typ -> trm -> ctx     (* Cval t v *)
  | t_ctx_app2 : trm -> typ -> ctx -> ctx     (* v t Cval *)

  (* Boundaries *)
  (* evaluation and general contexts *)
  | s_ctx_st : ctx -> typ -> ctx              (* s ST E *)
  | t_ctx_ts : ctx -> typ -> trm -> ctx       (* let  = (TS s E) in m *)
  (* general contexts only *)
  | t_ctx_ts_k : trm -> typ -> ctx -> ctx     (* let  = (TS s e) in C *).

(* Fill a context with a term *)
Fixpoint plug (C : ctx) (e : trm) : trm :=
  match C with
  | s_ctx_hole              => e
  | s_ctx_if C' e2 e3       => s_trm_if (plug C' e) e2 e3
  | s_ctx_app1 C' e'        => s_trm_app (plug C' e) e'
  | s_ctx_app2 e' C'        => s_trm_app e' (plug C' e)
  | s_ctx_abs s C'          => s_trm_abs s (plug C' e)
  | s_ctx_if_true e1 C' e3  => s_trm_if e1 (plug C' e) e3
  | s_ctx_if_false e1 e2 C' => s_trm_if e1 e2 (plug C' e)
  | s_ctx_st C' s           => s_trm_st (plug C' e) s

  | t_ctx_hole              => e
  | t_ctx_pair_left C' m'   => t_trm_pair (plug C' e) m'
  | t_ctx_pair_right m' C'  => t_trm_pair m' (plug C' e)
  | t_ctx_abs t C'          => t_trm_abs t (plug C' e)
  | t_ctx_if C' m2 m3       => t_trm_if (plug C' e) m2 m3
  | t_ctx_if_true m1 C' m2  => t_trm_if m1 (plug C' e) m2
  | t_ctx_if_false m1 m2 C' => t_trm_if m1 m2 (plug C' e)
  | t_ctx_let_fst C' m'     => t_trm_let_fst (plug C' e) m'
  | t_ctx_let_fst_k m' C'   => t_trm_let_fst m' (plug C' e)
  | t_ctx_let_snd C' m'     => t_trm_let_snd (plug C' e) m'
  | t_ctx_let_snd_k m' C'   => t_trm_let_snd m' (plug C' e)
  | t_ctx_app1 C' t m1      => t_trm_app (plug C' e) t m1
  | t_ctx_app2 m1 t C'      => t_trm_app m1 t (plug C' e)
  | t_ctx_ts C' s m'        => t_trm_ts (plug C' e) s m'
  | t_ctx_ts_k e' s C'      => t_trm_ts e' s (plug C' e)
  end.

(** Opening for contexts *)
Fixpoint ctx_open_te_rec (K : nat) (t' : typ) (C : ctx) {struct C} : ctx :=
  match C with
  (* source contexts *)
  | s_ctx_hole             => s_ctx_hole
  | s_ctx_if C e2 e3       => s_ctx_if (ctx_open_te_rec K t' C)
                                       (open_te_rec K t' e2)
                                       (open_te_rec K t' e3)
  | s_ctx_app1 C e         => s_ctx_app1 (ctx_open_te_rec K t' C)
                                         (open_te_rec K t' e)
  | s_ctx_app2 e C         => s_ctx_app2 (open_te_rec K t' e)
                                         (ctx_open_te_rec K t' C)
  | s_ctx_abs s C          => s_ctx_abs s (ctx_open_te_rec K t' C)
  | s_ctx_if_true e1 C e3  => s_ctx_if_true (open_te_rec K t' e1)
                                            (ctx_open_te_rec K t' C)
                                            (open_te_rec K t' e3)
  | s_ctx_if_false e1 e2 C => s_ctx_if_false (open_te_rec K t' e1)
                                             (open_te_rec K t' e2)
                                             (ctx_open_te_rec K t' C)
  | s_ctx_st C s           => s_ctx_st (ctx_open_te_rec K t' C) s
  (* target contexts *)
  | t_ctx_hole             => t_ctx_hole
  | t_ctx_pair_left C m    => t_ctx_pair_left (ctx_open_te_rec K t' C)
                                              (open_te_rec K t' m)
  | t_ctx_pair_right m C   => t_ctx_pair_right (open_te_rec K t' m)
                                               (ctx_open_te_rec K t' C)
     (* only binding form for type variables *)
  | t_ctx_abs t C          => t_ctx_abs (open_tt_rec (S K) t' t)
                                        (ctx_open_te_rec (S K) t' C)
  | t_ctx_if C m1 m2       => t_ctx_if (ctx_open_te_rec K t' C)
                                       (open_te_rec K t' m1)
                                       (open_te_rec K t' m2)
  | t_ctx_if_true m1 C m2  => t_ctx_if_true (open_te_rec K t' m1)
                                            (ctx_open_te_rec K t' C)
                                            (open_te_rec K t' m2)
  | t_ctx_if_false m1 m2 C => t_ctx_if_false (open_te_rec K t' m1)
                                             (open_te_rec K t' m2)
                                             (ctx_open_te_rec K t' C)
  | t_ctx_let_fst C m      => t_ctx_let_fst (ctx_open_te_rec K t' C)
                                            (open_te_rec K t' m)
  | t_ctx_let_fst_k m C    => t_ctx_let_fst_k (open_te_rec K t' m)
                                              (ctx_open_te_rec K t' C)
  | t_ctx_let_snd C m      => t_ctx_let_snd (ctx_open_te_rec K t' C)
                                            (open_te_rec K t' m)
  | t_ctx_let_snd_k m C    => t_ctx_let_snd_k (open_te_rec K t' m)
                                              (ctx_open_te_rec K t' C)
  | t_ctx_app1 C t m       => t_ctx_app1 (ctx_open_te_rec K t' C)
                                         (open_tt_rec K t' t)
                                         (open_te_rec K t' m)
  | t_ctx_app2 m t C       => t_ctx_app2 (open_te_rec K t' m)
                                         (open_tt_rec K t' t)
                                         (ctx_open_te_rec K t' C)
  | t_ctx_ts C s m         => t_ctx_ts (ctx_open_te_rec K t' C)
                                       s
                                       (open_te_rec K t' m)
  | t_ctx_ts_k e s C       => t_ctx_ts_k (open_te_rec K t' e)
                                         s
                                         (ctx_open_te_rec K t' C)
  end.

Fixpoint ctx_open_ee_rec (l : lang) (K : nat) (e' : trm) (C : ctx) : ctx :=
  match C with
  (* source contexts *)
  | s_ctx_hole             => s_ctx_hole
  | s_ctx_if C e2 e3       => s_ctx_if (ctx_open_ee_rec l K e' C)
                                       (open_ee_rec l K e' e2)
                                       (open_ee_rec l K e' e3)
  | s_ctx_app1 C e         => s_ctx_app1 (ctx_open_ee_rec l K e' C)
                                         (open_ee_rec l K e' e)
  | s_ctx_app2 e C         => s_ctx_app2 (open_ee_rec l K e' e)
                                         (ctx_open_ee_rec l K e' C)
  | s_ctx_abs s C          => s_ctx_abs s
                                        (ctx_open_ee_rec l
                                          (inc_if_eq l source K) e' C)
  | s_ctx_if_true e1 C e3  => s_ctx_if_true (open_ee_rec l K e' e1)
                                            (ctx_open_ee_rec l K e' C)
                                            (open_ee_rec l K e' e3)
  | s_ctx_if_false e1 e2 C => s_ctx_if_false (open_ee_rec l K e' e1)
                                             (open_ee_rec l K e' e2)
                                             (ctx_open_ee_rec l K e' C)
  | s_ctx_st C s           => s_ctx_st (ctx_open_ee_rec l K e' C) s
  (* target contexts *)
  | t_ctx_hole             => t_ctx_hole
  | t_ctx_pair_left C m    => t_ctx_pair_left (ctx_open_ee_rec l K e' C)
                                              (open_ee_rec l K e' m)
  | t_ctx_pair_right m C   => t_ctx_pair_right (open_ee_rec l K e' m)
                                               (ctx_open_ee_rec l K e' C)
  | t_ctx_abs t C          => t_ctx_abs t
                                        (ctx_open_ee_rec l
                                          (inc_if_eq l target K) e' C)
  | t_ctx_if C m1 m2       => t_ctx_if (ctx_open_ee_rec l K e' C)
                                       (open_ee_rec l K e' m1)
                                       (open_ee_rec l K e' m2)
  | t_ctx_if_true m1 C m2  => t_ctx_if_true (open_ee_rec l K e' m1)
                                            (ctx_open_ee_rec l K e' C)
                                            (open_ee_rec l K e' m2)
  | t_ctx_if_false m1 m2 C => t_ctx_if_false (open_ee_rec l K e' m1)
                                             (open_ee_rec l K e' m2)
                                             (ctx_open_ee_rec l K e' C)
  | t_ctx_let_fst C m      => t_ctx_let_fst (ctx_open_ee_rec l K e' C)
                                            (open_ee_rec l
                                              (inc_if_eq l target K) e' m)
  | t_ctx_let_fst_k m C    => t_ctx_let_fst_k (open_ee_rec l K e' m)
                                              (ctx_open_ee_rec l
                                                (inc_if_eq l target K) e' C)
  | t_ctx_let_snd C m      => t_ctx_let_snd (ctx_open_ee_rec l K e' C)
                                            (open_ee_rec l
                                              (inc_if_eq l target K) e' m)
  | t_ctx_let_snd_k m C    => t_ctx_let_snd_k (open_ee_rec l K e' m)
                                              (ctx_open_ee_rec l
                                                (inc_if_eq l target K) e' C)
  | t_ctx_app1 C t m       => t_ctx_app1 (ctx_open_ee_rec l K e' C) t
                                         (open_ee_rec l K e' m)
  | t_ctx_app2 m t C       => t_ctx_app2 (open_ee_rec l K e' m) t
                                         (ctx_open_ee_rec l K e' C)
  | t_ctx_ts C s m         => t_ctx_ts (ctx_open_ee_rec l K e' C)
                                       s
                                       (open_ee_rec l
                                         (inc_if_eq l target K) e' m)
  | t_ctx_ts_k e s C       => t_ctx_ts_k (open_ee_rec l K e' e)
                                         s
                                         (ctx_open_ee_rec l
                                           (inc_if_eq l target K) e' C)
  end.

Notation ctx_open_te := (fun C t' => ctx_open_te_rec 0 t' C).
Notation s_ctx_open_ee := (fun C e' => ctx_open_ee_rec source 0 e' C).
Notation t_ctx_open_ee := (fun C m' => ctx_open_ee_rec target 0 m' C).

Notation ctx_open_te_var := (fun C X => ctx_open_te C (t_typ_fvar X)).
Notation s_ctx_open_ee_var := (fun C x => s_ctx_open_ee C (s_trm_fvar x)).
Notation t_ctx_open_ee_var := (fun C x => t_ctx_open_ee C (t_trm_fvar x)).

(** subst for contexts *)

Fixpoint ctx_subst_te (d : subst_type) (C : ctx) :=
  match C with
  (* source contexts *)
  | s_ctx_hole             => s_ctx_hole
  | s_ctx_if C e2 e3       => s_ctx_if (ctx_subst_te d C)
                                       (subst_te d e2)
                                       (subst_te d e3)
  | s_ctx_app1 C e         => s_ctx_app1 (ctx_subst_te d C) (subst_te d e)
  | s_ctx_app2 e C         => s_ctx_app2 (subst_te d e) (ctx_subst_te d C)
  | s_ctx_abs s C          => s_ctx_abs s (ctx_subst_te d C)
  | s_ctx_if_true e1 C e3  => s_ctx_if_true (subst_te d e1)
                                            (ctx_subst_te d C)
                                            (subst_te d e3)
  | s_ctx_if_false e1 e2 C => s_ctx_if_false (subst_te d e1)
                                             (subst_te d e2)
                                             (ctx_subst_te d C)
  | s_ctx_st C s           => s_ctx_st (ctx_subst_te d C) s
  (* target contexts *)
  | t_ctx_hole             => t_ctx_hole
  | t_ctx_pair_left C m    => t_ctx_pair_left (ctx_subst_te d C) (subst_te d m)
  | t_ctx_pair_right m C   => t_ctx_pair_right (subst_te d m) (ctx_subst_te d C)
  | t_ctx_abs t C          => t_ctx_abs (subst_tt d t) (ctx_subst_te d C)
  | t_ctx_if C m1 m2       => t_ctx_if (ctx_subst_te d C)
                                       (subst_te d m1)
                                       (subst_te d m2)
  | t_ctx_if_true m1 C m2  => t_ctx_if_true (subst_te d m1)
                                            (ctx_subst_te d C)
                                            (subst_te d m2)
  | t_ctx_if_false m1 m2 C => t_ctx_if_false (subst_te d m1)
                                             (subst_te d m2)
                                             (ctx_subst_te d C)
  | t_ctx_let_fst C m      => t_ctx_let_fst (ctx_subst_te d C) (subst_te d m)
  | t_ctx_let_fst_k m C    => t_ctx_let_fst_k (subst_te d m) (ctx_subst_te d C)
  | t_ctx_let_snd C m      => t_ctx_let_snd (ctx_subst_te d C) (subst_te d m)
  | t_ctx_let_snd_k m C    => t_ctx_let_snd_k (subst_te d m) (ctx_subst_te d C)
  | t_ctx_app1 C t m       => t_ctx_app1 (ctx_subst_te d C)
                                         (subst_tt d t)
                                         (subst_te d m)
  | t_ctx_app2 m t C       => t_ctx_app2 (subst_te d m)
                                         (subst_tt d t)
                                         (ctx_subst_te d C)
  | t_ctx_ts C s m         => t_ctx_ts (ctx_subst_te d C) s (subst_te d m)
  | t_ctx_ts_k e s C       => t_ctx_ts_k (subst_te d e) s (ctx_subst_te d C)
  end.

Fixpoint ctx_subst_ee (l : lang) (g : subst_term) (C : ctx) :=
  match C with
  (* source contexts *)
  | s_ctx_hole             => s_ctx_hole
  | s_ctx_if C e2 e3       => s_ctx_if (ctx_subst_ee l g C)
                                       (subst_ee l g e2)
                                       (subst_ee l g e3)
  | s_ctx_app1 C e         => s_ctx_app1 (ctx_subst_ee l g C) (subst_ee l g e)
  | s_ctx_app2 e C         => s_ctx_app2 (subst_ee l g e) (ctx_subst_ee l g C)
  | s_ctx_abs s C          => s_ctx_abs s (ctx_subst_ee l g C)
  | s_ctx_if_true e1 C e3  => s_ctx_if_true (subst_ee l g e1)
                                            (ctx_subst_ee l g C)
                                            (subst_ee l g e3)
  | s_ctx_if_false e1 e2 C => s_ctx_if_false (subst_ee l g e1)
                                             (subst_ee l g e2)
                                             (ctx_subst_ee l g C)
  | s_ctx_st C s           => s_ctx_st (ctx_subst_ee l g C) s
  (* target contexts *)
  | t_ctx_hole             => t_ctx_hole
  | t_ctx_pair_left C m    => t_ctx_pair_left (ctx_subst_ee l g C)
                                              (subst_ee l g m)
  | t_ctx_pair_right m C   => t_ctx_pair_right (subst_ee l g m)
                                               (ctx_subst_ee l g C)
  | t_ctx_abs t C          => t_ctx_abs t (ctx_subst_ee l g C)
  | t_ctx_if C m1 m2       => t_ctx_if (ctx_subst_ee l g C)
                                       (subst_ee l g m1)
                                       (subst_ee l g m2)
  | t_ctx_if_true m1 C m2  => t_ctx_if_true (subst_ee l g m1)
                                            (ctx_subst_ee l g C)
                                            (subst_ee l g m2)
  | t_ctx_if_false m1 m2 C => t_ctx_if_false (subst_ee l g m1)
                                             (subst_ee l g m2)
                                             (ctx_subst_ee l g C)
  | t_ctx_let_fst C m      => t_ctx_let_fst (ctx_subst_ee l g C)
                                            (subst_ee l g m)
  | t_ctx_let_fst_k m C    => t_ctx_let_fst_k (subst_ee l g m)
                                              (ctx_subst_ee l g C)
  | t_ctx_let_snd C m      => t_ctx_let_snd (ctx_subst_ee l g C)
                                            (subst_ee l g m)
  | t_ctx_let_snd_k m C    => t_ctx_let_snd_k (subst_ee l g m)
                                              (ctx_subst_ee l g C)
  | t_ctx_app1 C t m       => t_ctx_app1 (ctx_subst_ee l g C) t
                                         (subst_ee l g m)
  | t_ctx_app2 m t C       => t_ctx_app2 (subst_ee l g m) t
                                         (ctx_subst_ee l g C)
  | t_ctx_ts C s m         => t_ctx_ts (ctx_subst_ee l g C)
                                       s
                                       (subst_ee l g m)
  | t_ctx_ts_k e s C       => t_ctx_ts_k (subst_ee l g e)
                                         s
                                         (ctx_subst_ee l g C)
  end.

Notation s_ctx_subst_ee := (ctx_subst_ee source).
Notation t_ctx_subst_ee := (ctx_subst_ee target).


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustTraceProperty.
Require Import RobustSafetyPreservation.
Require Import UcoRobustPreservation.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section RobustSafetyCriterion.

   Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  Variable T_evs S_evs : Events.
  Variable T_end S_end : Endstates.

  Local Definition trace__S := @trace S_evs S_end.
  Local Definition finpref__S := @finpref S_evs S_end.
  Local Definition trace__T := @trace T_evs T_end.
  Local Definition finpref__T := @finpref T_evs T_end.

  Local Definition prop__S := prop trace__S.
  Local Definition Safety__S := @Safety S_evs S_end.
  Local Definition prop__T := prop trace__T.
  Local Definition Safety__T := @Safety T_evs T_end.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Local Definition Cl_τRP := Cl_τRP compilation_chain
                                    Source_Semantics Target_Semantics
                                    τ'.

  Local Definition σRP := σRP compilation_chain
                              Source_Semantics Target_Semantics
                              σ'.

  Definition tilde_RSC :=
    forall P C__T (t : trace__T) (m : finpref__T),
      prefix m t ->  sem__T (plug__T (P ↓) C__T) t ->
      (exists C__S t' s, rel s t' /\ prefix m t' /\ sem__S (plug__S P C__S) s).

  Theorem tilde_RSC_σRSP : tilde_RSC <-> (forall P (π__T : prop__T), Safety__T π__T -> σRP P π__T).
  Proof.
    have G2 : Galois_snd τ' σ' by firstorder.
    split.
    - move => Htilde P π HSafety. setoid_rewrite contra_σRP.
      move => [C__T [t [Hsemt Hnot_t]]].
      destruct (HSafety t Hnot_t) as [m [Hpref_m_t m_witness]].
      destruct (Htilde P C__T t m) as [C__S [t' [s [Hrel_s_t' [Hpref_m_t' Hsem_s]]]]]; auto.
      exists C__S, s. split; auto => Hσs.
      have Ht0 : π t'.
      { apply: G2; auto. now exists s. }
        by apply: (m_witness t').
    - move => H_RSP P C__T t m Hpref_m_t Hsemt.
      have HSafetyπ : Safety__T (fun t' => ~ prefix m t').
      { move => t'. rewrite -dne => prefix_m_t'.
        now exists m. }
      move : (H_RSP P (fun t' => ~ prefix m t') HSafetyπ).
      setoid_rewrite contra_σRP => Himp. destruct Himp as [C__S [s [Hsem_s Hσ]]].
      now exists C__T, t.
      have : ~ (fun s': trace__S => s' = s) ⊆ (σ' (not ∘ prefix m)) by firstorder.
      rewrite -rel_adjunction_law not_forall_ex_not. move => [t' Ht'].
      move/not_imp: Ht' => [Ht' HHt'].
      exists C__S, t', s. repeat (split; auto).
      destruct Ht' as [s' [Heq Hs']]. by subst.
        by apply: NNPP.
  Qed.

  Theorem tilde_RSC_Cl_τRTP : tilde_RSC <-> (forall P (π__S : prop__S), Cl_τRP P π__S).
  Proof.
    setoid_rewrite <- (uco_adjuncts _ _ _ safety_uco rel_adjunction_law).
    by rewrite tilde_RSC_σRSP -Safety_Cl_prop.
  Qed.

End RobustSafetyCriterion.


From iris.base_logic.lib Require Import invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Import notation proofmode.
From iris_examples.concurrent_stacks Require Import specs.
From iris.prelude Require Import options.

(** Stack 1: No helping, bag spec. *)

Definition new_stack : val := λ: "_", ref NONEV.
Definition push : val :=
  rec: "push" "s" "v" :=
    let: "tail" := ! "s" in
    let: "new" := SOME (ref ("v", "tail")) in
    if: CAS "s" "tail" "new" then #() else "push" "s" "v".
Definition pop : val :=
  rec: "pop" "s" :=
    match: !"s" with
      NONE => NONEV
    | SOME "l" =>
      let: "pair" := !"l" in
      if: CAS "s" (SOME "l") (Snd "pair")
      then SOME (Fst "pair")
      else "pop" "s"
    end.

Section stacks.
  Context `{!heapGS Σ} (N : namespace).
  Implicit Types l : loc.

  Definition oloc_to_val (ol: option loc) : val :=
    match ol with
    | None => NONEV
    | Some loc => SOMEV (#loc)
    end.
  Local Instance oloc_to_val_inj : Inj (=) (=) oloc_to_val.
  Proof. intros [|][|]; simpl; congruence. Qed.

  Definition is_list_pre (P : val → iProp Σ) (F : option loc -d> iPropO Σ) :
     option loc -d> iPropO Σ := λ v, match v with
     | None => True
     | Some l => ∃ (h : val) (t : option loc), l ↦□ (h, oloc_to_val t)%V ∗ P h ∗ ▷ F t
     end%I.

  Local Instance is_list_contr (P : val → iProp Σ) : Contractive (is_list_pre P).
  Proof.
    rewrite /is_list_pre => n f f' Hf v.
    repeat (f_contractive || f_equiv).
    apply Hf.
  Qed.

  Definition is_list_def (P : val -> iProp Σ) := fixpoint (is_list_pre P).
  Definition is_list_aux P : seal (@is_list_def P). Proof. by eexists. Qed.
  Definition is_list P := unseal (is_list_aux P).
  Definition is_list_eq P : @is_list P = @is_list_def P := seal_eq (is_list_aux P).

  Lemma is_list_unfold (P : val → iProp Σ) v :
    is_list P v ⊣⊢ is_list_pre P (is_list P) v.
  Proof.
    rewrite is_list_eq. apply (fixpoint_unfold (is_list_pre P)).
  Qed.

  Lemma is_list_dup (P : val → iProp Σ) v :
    is_list P v -∗ is_list P v ∗ match v with
      | None => True
      | Some l => ∃ h t, l ↦□ (h, oloc_to_val t)%V
      end.
  Proof.
    iIntros "Hstack". iDestruct (is_list_unfold with "Hstack") as "Hstack".
    destruct v as [l|].
    - iDestruct "Hstack" as (h t) "(#Hl & ? & ?)".
      rewrite (is_list_unfold _ (Some _)). iSplitL; iExists _, _; by iFrame.
    - rewrite is_list_unfold; iSplitR; eauto.
  Qed.

  Definition stack_inv P v :=
    (∃ l ol', ⌜v = #l⌝ ∗ l ↦ oloc_to_val ol' ∗ is_list P ol')%I.

  Definition is_stack (P : val → iProp Σ) v :=
    inv N (stack_inv P v).

  Theorem new_stack_spec P :
    {{{ True }}} new_stack #() {{{ s, RET s; is_stack P s }}}.
  Proof.
    iIntros (ϕ) "_ Hpost".
    wp_lam.
    wp_alloc ℓ as "Hl".
    iMod (inv_alloc N ⊤ (stack_inv P #ℓ) with "[Hl]") as "Hinv".
    { iNext; iExists ℓ, None; iFrame;
      by iSplit; last (iApply is_list_unfold). }
    by iApply "Hpost".
  Qed.

  Theorem push_spec P s v :
    {{{ is_stack P s ∗ P v }}} push s v {{{ RET #(); True }}}.
  Proof.
    iIntros (Φ) "[#Hstack HP] HΦ".
    iLöb as "IH".
    wp_lam. wp_let. wp_bind (Load _).
    iInv N as (ℓ v') "(>% & Hl & Hlist)" "Hclose"; subst.
    wp_load.
    iMod ("Hclose" with "[Hl Hlist]") as "_".
    { iNext; iExists _, _; by iFrame. }
    iModIntro. wp_let. wp_alloc ℓ' as "Hl'". wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as (ℓ'' v'') "(>% & >Hl & Hlist)" "Hclose"; simplify_eq.
    destruct (decide (v' = v'')) as [->|Hne].
    - wp_cmpxchg_suc. { destruct v''; left; done. }
      iMod (mapsto_persist with "Hl'") as "Hl'".
      iMod ("Hclose" with "[HP Hl Hl' Hlist]") as "_".
      { iNext; iExists _, (Some ℓ'); iFrame; iSplit; first done;
        rewrite (is_list_unfold _ (Some _)) /=. eauto with iFrame. }
      iModIntro.
      wp_pures.
      by iApply "HΦ".
    - wp_cmpxchg_fail.
      { destruct v', v''; simpl; congruence. }
      { destruct v''; left; done. }
      iMod ("Hclose" with "[Hl Hlist]") as "_".
      { iNext; iExists _, _; by iFrame. }
      iModIntro.
      wp_pures.
      iApply ("IH" with "HP HΦ").
  Qed.

  Theorem pop_spec P s :
    {{{ is_stack P s }}} pop s {{{ ov, RET ov; ⌜ov = NONEV⌝ ∨ ∃ v, ⌜ov = SOMEV v⌝ ∗ P v }}}.
  Proof.
    iIntros (Φ) "#Hstack HΦ".
    iLöb as "IH".
    wp_lam. wp_bind (Load _).
    iInv N as (ℓ v') "(>% & Hl & Hlist)" "Hclose"; subst.
    iDestruct (is_list_dup with "Hlist") as "[Hlist Hlist2]".
    wp_load.
    iMod ("Hclose" with "[Hl Hlist]") as "_".
    { iNext; iExists _, _; by iFrame. }
    iModIntro.
    destruct v' as [l|]; last first.
    - wp_match.
      iApply "HΦ"; by iLeft.
    - wp_match. wp_bind (Load _).
      iInv N as (ℓ' v') "(>% & Hl' & Hlist)" "Hclose". simplify_eq.
      iDestruct "Hlist2" as (??) "Hl".
      wp_load.
      iMod ("Hclose" with "[Hl' Hlist]") as "_".
      { iNext; iExists _, _; by iFrame. }
      iModIntro.
      wp_pures. wp_bind (CmpXchg _ _ _).
      iInv N as (ℓ'' v'') "(>% & Hl' & Hlist)" "Hclose". simplify_eq.
      destruct (decide (v'' = (Some l))) as [-> |].
      * rewrite is_list_unfold.
        iDestruct "Hlist" as (h' t') "(Hl'' & HP & Hlist) /=".
        wp_cmpxchg_suc.
        iDestruct (mapsto_agree with "Hl'' Hl") as %[= <- <-%oloc_to_val_inj].
        iMod ("Hclose" with "[Hl' Hlist]") as "_".
        { iNext; iExists ℓ'', _; by iFrame. }
        iModIntro.
        wp_pures.
        iApply ("HΦ" with "[HP]"); iRight; iExists _; by iFrame.
      * wp_cmpxchg_fail. { destruct v''; simpl; congruence. }
        iMod ("Hclose" with "[Hl' Hlist]") as "_".
        { iNext; iExists ℓ'', _; by iFrame. }
        iModIntro.
        wp_pures.
        iApply ("IH" with "HΦ").
  Qed.
End stacks.

Program Definition spec {Σ} N `{heapGS Σ} : concurrent_bag Σ :=
  {| is_bag := is_stack N; new_bag := new_stack; bag_push := push; bag_pop := pop |} .
Solve Obligations of spec with eauto using pop_spec, push_spec, new_stack_spec.


(*
 - Displayed prebicategories
   - Operations
   - Data projections
   - Laws
   - Law projections
 - Total prebicategories
From UniMath/Bicategories/DisplayedBicats/DispBicat.v
*)

Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

(** Operations on prebicategories **)

Section disp_prebicat.

Context {C : prebicat}. (* <- This is the main difference with the original file *)

Local Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60).
Local Notation "f' <==[ x ] g'" := (disp_2cells x g' f') (at level 60, only parsing).

Definition disp_prebicat_ops' (D : disp_prebicat_1_id_comp_cells C) : UU
  :=   (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        f' ==>[id2 _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        id_disp x ;; f' ==>[lunitor _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        f' ;; id_disp y ==>[runitor _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        id_disp x ;; f' <==[linvunitor _] f')
     × (∏ (a b : C) (f : C⟦a,b⟧) (x : D a) (y : D b) (f' : x -->[f] y),
        f' ;; id_disp y <==[rinvunitor _] f')
     × (∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧)
          (w : D a) (x : D b) (y : D c) (z : D d)
          (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z),
        (ff ;; gg) ;; hh ==>[rassociator _ _ _] ff ;; (gg ;; hh))
     × (∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : C⟦c,d⟧)
          (w : D a) (x : D b) (y : D c) (z : D d)
          (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z),
        ff ;; (gg ;; hh) ==>[lassociator _ _ _] (ff ;; gg) ;; hh)
     × (∏ (a b : C) (f g h : C⟦a,b⟧) (r : f ==> g) (s : g ==> h)
          (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y),
        ff ==>[r] gg  →  gg ==>[s] hh  →  ff ==>[r • s] hh)
     × (∏ (a b c : C) (f : C⟦a,b⟧) (g1 g2 : C⟦b,c⟧)
          (r : g1 ==> g2) (x : D a) (y : D b) (z : D c)
          (ff : x -->[f] y) (gg1 : y -->[g1] z) (gg2 : y -->[g2] z),
        gg1 ==>[r] gg2  →  ff ;; gg1  ==>[f ◃ r] ff ;; gg2)
     × (∏ (a b c : C) (f1 f2 : C⟦a,b⟧) (g : C⟦b,c⟧)
          (r : f1 ==> f2) (x : D a) (y : D b) (z : D c)
          (ff1 : x -->[f1] y) (ff2 : x -->[f2] y) (gg : y -->[g] z),
        ff1 ==>[r] ff2 → ff1 ;; gg ==>[r ▹ g] ff2 ;; gg).

Definition disp_prebicat_data : UU
  := ∑ D : disp_prebicat_1_id_comp_cells C, disp_prebicat_ops' D.

Coercion disp_prebicat_ob_mor_cells_1_id_comp_from_disp_prebicat_data
         (D : disp_prebicat_data)
  : disp_prebicat_1_id_comp_cells C
  := pr1 D.

Coercion disp_prebicat_ops_from_disp_prebicat_data (D : disp_prebicat_data)
  : disp_prebicat_ops' D
  := pr2 D.

(** Data projections **)

Section disp_prebicat_ops_projections.

Context {D : disp_prebicat_data}.

Definition disp_id2 {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : f' ==>[id2 _] f'
  := pr1 (pr2 D) a b f x y f'.

Definition disp_lunitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : id_disp x ;; f' ==>[lunitor _] f'
  := pr1 (pr2 (pr2 D)) a b f x y f'.

Definition disp_runitor {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : f' ;; id_disp y ==>[runitor _] f'
  := pr1 (pr2 (pr2 (pr2 D))) _ _ f _ _ f'.

Definition disp_linvunitor
           {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : id_disp x ;; f' <==[linvunitor _] f'
  := pr1 (pr2 (pr2 (pr2 (pr2 D)))) _ _ f _ _ f'.

Definition disp_rinvunitor
           {a b : C} {f : C⟦a,b⟧} {x : D a} {y : D b} (f' : x -->[f] y)
  : f' ;; id_disp y <==[rinvunitor _] f'
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 D))))) _ _ f _ _ f'.

Definition disp_rassociator
           {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧}
       {w : D a} {x : D b} {y : D c} {z : D d}
       (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z)
  : (ff ;; gg) ;; hh ==>[rassociator _ _ _] ff ;; (gg ;; hh)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))) _ _ _ _ _ _ _ w _ _ _ ff gg hh.

Definition disp_lassociator
           {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧} {h : C⟦c,d⟧}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z)
  : ff ;; (gg ;; hh) ==>[lassociator _ _ _] (ff ;; gg) ;; hh
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))) _ _ _ _ _ _ _ w _ _ _ ff gg hh.

Definition disp_vcomp2
           {a b : C} {f g h : C⟦a,b⟧}
           {r : f ==> g} {s : g ==> h}
           {x : D a} {y : D b}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y}
  : ff ==>[r] gg  →  gg ==>[s] hh  →  ff ==>[r • s] hh
  := λ rr ss,  pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))
                   _ _ _ _ _ _ _ _ _ _ _ _ rr ss.

Definition disp_lwhisker
           {a b c : C} {f : C⟦a,b⟧} {g1 g2 : C⟦b,c⟧}
           {r : g1 ==> g2}
           {x : D a} {y : D b} {z : D c}
           (ff : x -->[f] y) {gg1 : y -->[g1] z} {gg2 : y -->[g2] z}
  : gg1 ==>[r] gg2  →  ff ;; gg1  ==>[f ◃ r] ff ;; gg2
  := λ rr, pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))
               _ _ _ _ _ _ _ _ _ _ _ _ _ rr.

Definition disp_rwhisker
           {a b c : C} {f1 f2 : C⟦a,b⟧} {g : C⟦b,c⟧}
           {r : f1 ==> f2}
           {x : D a} {y : D b} {z : D c}
           {ff1 : x -->[f1] y} {ff2 : x -->[f2] y} (gg : y -->[g] z)
  : ff1 ==>[r] ff2 → ff1 ;; gg ==>[r ▹ g] ff2 ;; gg
  := λ rr, pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))
               _ _ _ _ _ _ _ _ _ _ _ _ _ rr.

End disp_prebicat_ops_projections.

Local Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60).
Local Notation "ff ◃◃ rr" := (disp_lwhisker ff rr) (at level 60).
Local Notation "rr ▹▹ gg" := (disp_rwhisker gg rr) (at level 60).

(** Displayed laws **)
Section disp_prebicat_laws.

Context (D : disp_prebicat_data).

Definition disp_id2_left_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     disp_id2 _ •• ηη = transportb (λ α, _ ==>[α] _) (id2_left _) ηη.

Definition disp_id2_right_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     ηη •• disp_id2 _ = transportb (λ α, _ ==>[α] _) (id2_right _) ηη.

Definition disp_vassocr_law : UU
  := ∏ (a b : C) (f g h k : C⟦a,b⟧) (η : f ==> g) (φ : g ==> h) (ψ : h ==> k)
       (x : D a) (y : D b)
       (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y) (kk : x -->[k] y)
       (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk),
     ηη •• (φφ •• ψψ) =
     transportb (λ α, _ ==>[α] _) (vassocr _ _ _) ((ηη •• φφ) •• ψψ).

Definition disp_lwhisker_id2_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧)
       (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z),
     ff ◃◃ disp_id2 gg =
     transportb (λ α, _ ==>[α] _) (lwhisker_id2 _ _) (disp_id2 (ff ;; gg)).

Definition disp_id2_rwhisker_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧)
       (x : D a) (y : D b) (z : D c) (ff : x -->[f] y) (gg : y -->[g] z),
     disp_id2 ff ▹▹ gg =
     transportb (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 (ff ;; gg)).

Definition disp_lwhisker_vcomp_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g h i : C⟦b,c⟧)
      (η : g ==> h) (φ : h ==> i)
      (x : D a) (y : D b) (z : D c) (ff : x -->[f] y)
      (gg : y -->[g] z) (hh : y -->[h] z) (ii : y -->[i] z)
      (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii),
     (ff ◃◃ ηη) •• (ff ◃◃ φφ) =
     transportb (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) (ff ◃◃ (ηη •• φφ)).

Definition disp_rwhisker_vcomp_law : UU
  := ∏ (a b c : C) (f g h : C⟦a,b⟧) (i : C⟦b,c⟧) (η : f ==> g) (φ : g ==> h)
       (x : D a) (y : D b) (z : D c)
       (ff : x -->[f] y) (gg : x -->[g] y) (hh : x -->[h] y)
       (ii : y -->[i] z)
       (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh),
     (ηη ▹▹ ii) •• (φφ ▹▹ ii) =
     transportb (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη •• φφ) ▹▹ ii).

Definition disp_vcomp_lunitor_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     (id_disp _ ◃◃ ηη) •• disp_lunitor gg =
     transportb (λ α, _ ==>[α] _) (vcomp_lunitor _ _ _) (disp_lunitor ff •• ηη).

Definition disp_vcomp_runitor_law : UU
  := ∏ (a b : C) (f g : C⟦a,b⟧) (η : f ==> g)
       (x : D a) (y : D b) (ff : x -->[f] y) (gg : x -->[g] y)
       (ηη : ff ==>[η] gg),
     (ηη ▹▹ id_disp _) •• disp_runitor gg =
     transportb (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) (disp_runitor ff •• ηη).

Definition disp_lwhisker_lwhisker_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h i : c --> d) (η : h ==> i)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z)
       (ηη : hh ==>[η] ii),
     ff ◃◃ (gg ◃◃ ηη) •• disp_lassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (lwhisker_lwhisker _ _ _)
                (disp_lassociator _ _ _ •• (ff ;; gg ◃◃ ηη)).

Definition disp_rwhisker_lwhisker_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g h : C⟦b,c⟧) (i : c --> d) (η : g ==> h)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y) (hh : x -->[h] y) (ii : y -->[i] z)
       (ηη : gg ==>[η] hh),
     (ff ◃◃ (ηη ▹▹ ii)) •• disp_lassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (rwhisker_lwhisker _ _ _)
                (disp_lassociator _ _ _ •• ((ff ◃◃ ηη) ▹▹ ii)).

Definition disp_rwhisker_rwhisker_law : UU
  := ∏ (a b c d : C) (f g : C⟦a,b⟧) (h : C⟦b,c⟧) (i : c --> d) (η : f ==> g)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z)
       (ηη : ff ==>[η] gg),
     disp_lassociator _ _ _ •• ((ηη ▹▹ hh) ▹▹ ii) =
     transportb (λ α, _ ==>[α] _) (rwhisker_rwhisker _ _ _)
                ((ηη ▹▹ hh ;; ii) •• disp_lassociator _ _ _).

Definition disp_vcomp_whisker_law : UU
  := ∏ (a b c : C) (f g : C⟦a,b⟧) (h i : C⟦b,c⟧)
       (η : f ==> g) (φ : h ==> i)
       (x : D a) (y : D b) (z : D c)
       (ff : x -->[f] y) (gg : x -->[g] y)
       (hh : y -->[h] z) (ii : y -->[i] z)
       (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii),
     (ηη ▹▹ hh) •• (gg ◃◃ φφ) =
     transportb (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ff ◃◃ φφ) •• (ηη ▹▹ ii)).

Definition disp_lunitor_linvunitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_lunitor ff •• disp_linvunitor _ =
     transportb (λ α, _ ==>[α] _) (lunitor_linvunitor _) (disp_id2 (id_disp _ ;; ff)).

Definition disp_linvunitor_lunitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_linvunitor ff •• disp_lunitor _ =
     transportb (λ α, _ ==>[α] _) (linvunitor_lunitor _) (disp_id2 _).

Definition disp_runitor_rinvunitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_runitor ff •• disp_rinvunitor _ =
     transportb (λ α, _ ==>[α] _) (runitor_rinvunitor _) (disp_id2 _).

Definition disp_rinvunitor_runitor_law : UU
  := ∏ (a b : C) (f : C⟦a,b⟧)
       (x : D a) (y : D b) (ff : x -->[f] y),
     disp_rinvunitor ff •• disp_runitor _ =
     transportb (λ α, _ ==>[α] _) (rinvunitor_runitor _) (disp_id2 _).

Definition disp_lassociator_rassociator_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y)
       (hh : y -->[h] z),
     disp_lassociator ff gg hh •• disp_rassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (lassociator_rassociator _ _ _ ) (disp_id2  _).

Definition disp_rassociator_lassociator_law : UU
  := ∏ (a b c d : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d)
       (w : D a) (x : D b) (y : D c) (z : D d)
       (ff : w -->[f] x) (gg : x -->[g] y)
       (hh : y -->[h] z),
     disp_rassociator ff gg hh •• disp_lassociator _ _ _ =
     transportb (λ α, _ ==>[α] _) (rassociator_lassociator _ _ _ ) (disp_id2 _).

Definition disp_runitor_rwhisker_law : UU
  := ∏ (a b c : C) (f : C⟦a,b⟧) (g : C⟦b,c⟧)
       (x : D a) (y : D b) (z : D c)
       (ff : x -->[f] y) (gg : y -->[g] z),
     disp_lassociator _ _ _ •• (disp_runitor ff ▹▹ gg) =
     transportb (λ α, _ ==>[α] _) (runitor_rwhisker _ _) (ff ◃◃ disp_lunitor gg).

Definition disp_lassociator_lassociator_law : UU
  := ∏ (a b c d e: C) (f : C⟦a,b⟧) (g : C⟦b,c⟧) (h : c --> d) (i : C⟦d,e⟧)
       (v : D a) (w : D b) (x : D c) (y : D d) (z : D e)
       (ff : v -->[f] w) (gg : w -->[g] x)
       (hh : x -->[h] y) (ii : y -->[i] z),

     (ff ◃◃ disp_lassociator gg hh ii) •• disp_lassociator _ _ _ ••
     (disp_lassociator _ _ _ ▹▹ ii) =
     transportb (λ α, _ ==>[α] _) (lassociator_lassociator _ _ _ _)
                (disp_lassociator ff gg _ •• disp_lassociator _ _ _).

Definition disp_prebicat_laws : UU
  :=   disp_id2_left_law
     × disp_id2_right_law
     × disp_vassocr_law
     × disp_lwhisker_id2_law
     × disp_id2_rwhisker_law
     × disp_lwhisker_vcomp_law
     × disp_rwhisker_vcomp_law
     × disp_vcomp_lunitor_law
     × disp_vcomp_runitor_law
     × disp_lwhisker_lwhisker_law
     × disp_rwhisker_lwhisker_law
     × disp_rwhisker_rwhisker_law
     × disp_vcomp_whisker_law
     × disp_lunitor_linvunitor_law
     × disp_linvunitor_lunitor_law
     × disp_runitor_rinvunitor_law
     × disp_rinvunitor_runitor_law
     × disp_lassociator_rassociator_law
     × disp_rassociator_lassociator_law
     × disp_runitor_rwhisker_law
     × disp_lassociator_lassociator_law.

End disp_prebicat_laws.

(** Laws projections **)

Definition disp_prebicat : UU
  := ∑ D : disp_prebicat_data, disp_prebicat_laws D.

Coercion disp_prebicat_data_from_disp_prebicat (D : disp_prebicat)
  : disp_prebicat_data
  := pr1 D.

Section disp_prebicat_law_projections.

Context {D : disp_prebicat}.

Definition disp_id2_left {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : disp_id2 _ •• ηη = transportb (λ α, _ ==>[α] _) (id2_left _) ηη
  := pr1 (pr2 D) _ _ _ _ _ x y ff gg ηη.

Definition disp_id2_right {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : ηη •• disp_id2 _ = transportb (λ α, _ ==>[α] _) (id2_right _) ηη
  := pr1 (pr2 (pr2 D)) _ _ _ _ _ _ _ _ _ ηη.

Definition disp_vassocr {a b : C} {f g h k : C⟦a,b⟧}
           {η : f ==> g} {φ : g ==> h} {ψ : h ==> k}
           {x : D a} {y : D b}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk)
  : ηη •• (φφ •• ψψ) =
    transportb (λ α, _ ==>[α] _) (vassocr _ _ _) ((ηη •• φφ) •• ψψ)
  := pr1 (pr2 (pr2 (pr2 D))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ ψψ .

Definition disp_vassocr' {a b : C} {f g h k : C⟦a,b⟧}
           {η : f ==> g} {φ : g ==> h} {ψ : h ==> k}
           {x : D a} {y : D b}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {kk : x -->[k] y}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh) (ψψ : hh ==>[ψ] kk)
  : transportf (λ α, _ ==>[α] _) (vassocr _ _ _) (ηη •• (φφ •• ψψ)) =
    ((ηη •• φφ) •• ψψ).
Proof.
  use (transportf_transpose_left (P := λ x' : f ==> k, ff ==>[x'] kk)).
  apply disp_vassocr.
Defined.

Definition disp_lwhisker_id2 {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z)
  : ff ◃◃ disp_id2 gg =
    transportb (λ α, _ ==>[α] _) (lwhisker_id2 _ _) (disp_id2 (ff ;; gg))
  := pr1 (pr2 (pr2 (pr2 (pr2 D)))) _ _ _ _ _ _ _ _ ff gg.

Definition disp_id2_rwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c}
           (ff : x -->[f] y) (gg : y -->[g] z)
  : disp_id2 ff ▹▹ gg =
    transportb (λ α, _ ==>[α] _) (id2_rwhisker _ _) (disp_id2 (ff ;; gg))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 D))))) _ _ _ _ _ _ _ _ ff gg.

Definition disp_lwhisker_vcomp {a b c : C} {f : C⟦a,b⟧} {g h i : C⟦b,c⟧}
           {η : g ==> h} {φ : h ==> i}
           {x : D a} {y : D b} {z : D c} {ff : x -->[f] y}
           {gg : y -->[g] z} {hh : y -->[h] z} {ii : y -->[i] z}
           (ηη : gg ==>[η] hh) (φφ : hh ==>[φ] ii)
  : (ff ◃◃ ηη) •• (ff ◃◃ φφ) =
    transportb (λ α, _ ==>[α] _) (lwhisker_vcomp _ _ _) (ff ◃◃ (ηη •• φφ))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ.

Definition disp_rwhisker_vcomp {a b c : C} {f g h : C⟦a,b⟧} {i : C⟦b,c⟧}
           {η : f ==> g} {φ : g ==> h}
           {x : D a} {y : D b} {z : D c}
           {ff : x -->[f] y} {gg : x -->[g] y} {hh : x -->[h] y} {ii : y -->[i] z}
           (ηη : ff ==>[η] gg) (φφ : gg ==>[φ] hh)
  : (ηη ▹▹ ii) •• (φφ ▹▹ ii) =
    transportb (λ α, _ ==>[α] _) (rwhisker_vcomp _ _ _) ((ηη •• φφ) ▹▹ ii)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))
         _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ.

Definition disp_vcomp_lunitor {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : (id_disp _ ◃◃ ηη) •• disp_lunitor gg =
    transportb (λ α, _ ==>[α] _) (vcomp_lunitor _ _ _) (disp_lunitor ff •• ηη)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))) _ _ _ _ _ _ _ _ _  ηη.

Definition disp_vcomp_runitor {a b : C} {f g : C⟦a,b⟧} {η : f ==> g}
           {x : D a} {y : D b} {ff : x -->[f] y} {gg : x -->[g] y}
           (ηη : ff ==>[η] gg)
  : (ηη ▹▹ id_disp _) •• disp_runitor gg =
    transportb (λ α, _ ==>[α] _) (vcomp_runitor _ _ _) (disp_runitor ff •• ηη)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))) _ _ _ _ _ _ _ _ _  ηη.

Definition disp_lwhisker_lwhisker {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {h i : c --> d} {η : h ==> i}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y) {hh : y -->[h] z} {ii : y -->[i] z}
           (ηη : hh ==>[η] ii)
  : ff ◃◃ (gg ◃◃ ηη) •• disp_lassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (lwhisker_lwhisker _ _ _)
               (disp_lassociator _ _ _ •• (ff ;; gg ◃◃ ηη))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))
         _ _ _ _ _ _ _ _ _  _ _ _ _ _ _ _ _ ηη.

Definition disp_rwhisker_lwhisker {a b c d : C} {f : C⟦a,b⟧} {g h : C⟦b,c⟧}
           {i : c --> d} {η : g ==> h}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) {gg : x -->[g] y} {hh : x -->[h] y} (ii : y -->[i] z)
           (ηη : gg ==>[η] hh)
  : (ff ◃◃ (ηη ▹▹ ii)) •• disp_lassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (rwhisker_lwhisker _ _ _)
               (disp_lassociator _ _ _ •• ((ff ◃◃ ηη) ▹▹ ii))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))
         _ _ _ _ _ _ _ _ _  _ _ _ _ _ _ _ _ ηη.

Definition disp_rwhisker_rwhisker {a b c d : C} {f g : C⟦a,b⟧} {h : C⟦b,c⟧}
           (i : c --> d) (η : f ==> g)
           {w : D a} {x : D b} {y : D c} {z : D d}
           {ff : w -->[f] x} {gg : w -->[g] x} (hh : x -->[h] y) (ii : y -->[i] z)
           (ηη : ff ==>[η] gg)
  : disp_lassociator _ _ _ •• ((ηη ▹▹ hh) ▹▹ ii) =
    transportb (λ α, _ ==>[α] _) (rwhisker_rwhisker _ _ _)
               ((ηη ▹▹ hh ;; ii) •• disp_lassociator _ _ _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))
         _ _ _ _ _ _ _ _ _  _ _ _ _ _ _ _ _ ηη.

Definition disp_vcomp_whisker {a b c : C} {f g : C⟦a,b⟧} {h i : C⟦b,c⟧}
           (η : f ==> g) (φ : h ==> i)
           (x : D a) (y : D b) (z : D c)
           (ff : x -->[f] y) (gg : x -->[g] y) (hh : y -->[h] z) (ii : y -->[i] z)
           (ηη : ff ==>[η] gg) (φφ : hh ==>[φ] ii)
  : (ηη ▹▹ hh) •• (gg ◃◃ φφ) =
    transportb (λ α, _ ==>[α] _) (vcomp_whisker _ _) ((ff ◃◃ φφ) •• (ηη ▹▹ ii))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ηη φφ.

Definition disp_lunitor_linvunitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_lunitor ff •• disp_linvunitor _ =
    transportb (λ α, _ ==>[α] _) (lunitor_linvunitor _) (disp_id2 (id_disp _ ;; ff))
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))
         _ _ _ _ _ ff.

Definition disp_linvunitor_lunitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_linvunitor ff •• disp_lunitor _ =
    transportb (λ α, _ ==>[α] _) (linvunitor_lunitor _) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))) _ _ _ _ _ ff.

Definition disp_runitor_rinvunitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_runitor ff •• disp_rinvunitor _ =
    transportb (λ α, _ ==>[α] _) (runitor_rinvunitor _) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))) _ _ _ _ _ ff.

Definition disp_rinvunitor_runitor {a b : C} {f : C⟦a,b⟧}
           {x : D a} {y : D b} (ff : x -->[f] y)
  : disp_rinvunitor ff •• disp_runitor _ =
    transportb (λ α, _ ==>[α] _) (rinvunitor_runitor _) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))) _ _ _ _ _ ff.

Definition disp_lassociator_rassociator {a b c d : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {h : c --> d} {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y) (hh : y -->[h] z)
  : disp_lassociator ff gg hh •• disp_rassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (lassociator_rassociator _ _ _ ) (disp_id2  _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ ff gg hh.

Definition disp_rassociator_lassociator
           {a b c d : C} (f : C⟦a,b⟧) {g : C⟦b,c⟧} {h : c --> d}
           {w : D a} {x : D b} {y : D c} {z : D d}
           (ff : w -->[f] x) (gg : x -->[g] y)
           (hh : y -->[h] z)
  : disp_rassociator ff gg hh •• disp_lassociator _ _ _ =
    transportb (λ α, _ ==>[α] _) (rassociator_lassociator _ _ _ ) (disp_id2 _)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D)))))))))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ ff gg hh.

Definition disp_runitor_rwhisker {a b c : C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {x : D a} {y : D b} {z : D c} (ff : x -->[f] y) (gg : y -->[g] z)
  : disp_lassociator _ _ _ •• (disp_runitor ff ▹▹ gg) =
    transportb (λ α, _ ==>[α] _) (runitor_rwhisker _ _) (ff ◃◃ disp_lunitor gg)
  := pr1 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))))
         _ _ _ _ _ _ _ _ ff gg.

Definition disp_lassociator_lassociator {a b c d e: C} {f : C⟦a,b⟧} {g : C⟦b,c⟧}
           {h : c --> d} {i : C⟦d,e⟧}
           {v : D a} {w : D b} {x : D c} {y : D d} {z : D e}
           (ff : v -->[f] w) (gg : w -->[g] x) (hh : x -->[h] y) (ii : y -->[i] z)
  : (ff ◃◃ disp_lassociator gg hh ii) •• disp_lassociator _ _ _ ••
    (disp_lassociator _ _ _ ▹▹ ii) =
    transportb (λ α, _ ==>[α] _) (lassociator_lassociator _ _ _ _)
               (disp_lassociator ff gg _ •• disp_lassociator _ _ _)
  := pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2
            (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 (pr2 D))))))))))))))))))))
         _ _ _ _ _ _ _ _ _ _ _ _ _ _ ff gg hh ii.

End disp_prebicat_law_projections.

(** Total prebicategory of a displayed prebicategory **)

Section total_prebicat.

Variable D : disp_prebicat.

Definition total_prebicat_1_data : precategory_data
  := total_category_ob_mor D ,, total_category_id_comp D.

Definition total_prebicat_cell_struct : prebicat_2cell_struct (total_category_ob_mor D)
  := λ a b f g, ∑ η : pr1 f ==> pr1 g, pr2 f ==>[η] pr2 g.

Definition total_prebicat_1_id_comp_cells : prebicat_1_id_comp_cells
  := (total_prebicat_1_data,, total_prebicat_cell_struct).

Definition total_prebicat_2_id_comp_struct
  : prebicat_2_id_comp_struct total_prebicat_1_id_comp_cells.
Proof.
  repeat split; cbn; unfold total_prebicat_cell_struct.
  - intros. exists (id2 _). exact (disp_id2 _).
  - intros. exists (lunitor _). exact (disp_lunitor _).
  - intros. exists (runitor _). exact (disp_runitor _).
  - intros. exists (linvunitor _). exact (disp_linvunitor _).
  - intros. exists (rinvunitor _). exact (disp_rinvunitor _).
  - intros. exists (rassociator _ _ _).
    exact (disp_rassociator _ _ _).
  - intros. exists (lassociator _ _ _).
    exact (disp_lassociator _ _ _).
  - intros a b f g h r s. exists (pr1 r • pr1 s).
    exact (pr2 r •• pr2 s).
  - intros a b d f g1 g2 r. exists (pr1 f ◃ pr1 r).
    exact (pr2 f ◃◃ pr2 r).
  - intros a b c f1 f2 g r. exists (pr1 r ▹ pr1 g).
    exact (pr2 r ▹▹ pr2 g).
Defined.

Definition total_prebicat_data : prebicat_data
  := _ ,, total_prebicat_2_id_comp_struct.

Lemma total_prebicat_laws : prebicat_laws total_prebicat_data.
Proof.
  repeat split; intros.
  - use total2_paths_b.
    + apply id2_left.
    + apply disp_id2_left.
  - use total2_paths_b.
    + apply id2_right.
    + apply disp_id2_right.
  - use total2_paths_b.
    + apply vassocr.
    + apply disp_vassocr.
  - use total2_paths_b.
    + apply lwhisker_id2.
    + apply disp_lwhisker_id2.
  - use total2_paths_b.
    + apply id2_rwhisker.
    + apply disp_id2_rwhisker.
  - use total2_paths_b.
    + apply lwhisker_vcomp.
    + apply disp_lwhisker_vcomp.
  - use total2_paths_b.
    + apply rwhisker_vcomp.
    + apply disp_rwhisker_vcomp.
  - use total2_paths_b.
    + apply vcomp_lunitor.
    + apply disp_vcomp_lunitor.
  - use total2_paths_b.
    + apply vcomp_runitor.
    + apply disp_vcomp_runitor.
  - use total2_paths_b.
    + apply lwhisker_lwhisker.
    + apply disp_lwhisker_lwhisker.
  - use total2_paths_b.
    + apply rwhisker_lwhisker.
    + apply disp_rwhisker_lwhisker.
  - use total2_paths_b.
    + apply rwhisker_rwhisker.
    + apply disp_rwhisker_rwhisker.
  - use total2_paths_b.
    + apply vcomp_whisker.
    + apply disp_vcomp_whisker.
  - use total2_paths_b.
    + apply lunitor_linvunitor.
    + apply disp_lunitor_linvunitor.
  - use total2_paths_b.
    + apply linvunitor_lunitor.
    + apply disp_linvunitor_lunitor.
  - use total2_paths_b.
    + apply runitor_rinvunitor.
    + apply disp_runitor_rinvunitor.
  - use total2_paths_b.
    + apply rinvunitor_runitor.
    + apply disp_rinvunitor_runitor.
  - use total2_paths_b.
    + apply lassociator_rassociator.
    + apply disp_lassociator_rassociator.
  - use total2_paths_b.
    + apply rassociator_lassociator.
    + apply disp_rassociator_lassociator.
  - use total2_paths_b.
    + apply runitor_rwhisker.
    + apply disp_runitor_rwhisker.
  - use total2_paths_b.
    + apply lassociator_lassociator.
    + apply disp_lassociator_lassociator.
Defined.

Definition total_prebicat : prebicat := _ ,, total_prebicat_laws.

End total_prebicat.

End disp_prebicat.

Arguments disp_prebicat_1_id_comp_cells _ : clear implicits.
Arguments disp_prebicat_data _ : clear implicits.
Arguments disp_prebicat _ : clear implicits.
Arguments disp_bicat _ : clear implicits.

(** Notations **)
Module Notations.

Export Bicat.Notations.

Notation "f' ==>[ x ] g'" := (disp_2cells x f' g') (at level 60).
Notation "f' <==[ x ] g'" := (disp_2cells x g' f') (at level 60, only parsing).
Notation "rr •• ss" := (disp_vcomp2 rr ss) (at level 60).
Notation "ff ◃◃ rr" := (disp_lwhisker ff rr) (at level 60).
Notation "rr ▹▹ gg" := (disp_rwhisker gg rr) (at level 60).

End Notations.


(** This is a very simple arithmetic and boolean language that
 ** can be useful for testing.
 **)
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.Map.FMapPositive.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.CTypes.CTypeUnify.
Require Import MirrorCore.CTypes.TSymOneOf.

Set Implicit Arguments.
Set Strict Implicit.

Inductive typ' : nat -> Type :=
| tyNat : typ' 0
| tyBool : typ' 0.

Definition typ'_dec n (a : typ' n) : forall b : typ' n, {a = b} + {a <> b}.
refine
  match a as a in typ' n return forall b : typ' n, {a = b} + {a <> b} with
  | tyNat => fun b =>
               match b as b in typ' 0 return {tyNat = b} + {tyNat <> b} with
               | tyNat => left eq_refl
               | _ => right _
               end
  | tyBool => fun b =>
               match b as b in typ' 0 return {_ = b} + {_ <> b} with
               | tyBool => left eq_refl
               | _ => right _
               end
  end; try (intro H; inversion H).
Defined.

Instance TSym_typ' : TSym typ' :=
{ symbolD n s :=
    match s with
    | tyNat => nat
    | tyBool => bool
    end
; symbol_dec := typ'_dec }.

Definition typ := ctyp typ'.

Global Instance RType_typ : RType typ := RType_ctyp _ _.
Global Instance RTypeOk_typ : @RTypeOk _ RType_typ := RTypeOk_ctyp _ _.

Inductive func :=
| Lt | Plus | N : nat -> func | Eq : typ -> func
| Ex : typ -> func | All : typ -> func
| And | Or | Impl.

Definition func_unify (a b : func) (s : pmap typ) : option (pmap typ) :=
  match a , b with
  | Lt , Lt
  | Plus , Plus
  | N _ , N _
  | And , And
  | Or , Or
  | Impl , Impl => Some s
  | Eq t , Eq t'
  | Ex t , Ex t'
  | All t , All t' =>
    (* danger, this is a hack. but proably ok *)
    match ctype_unify _ 1 t t' s  with
    | Some (s', _) => Some s'
    | _ => None
    end
  | _ , _ => None
  end.

Local Notation "! x" := (@tyBase0 _ x) (at level 0).

Definition typeof_func (f : func) : option typ :=
  Some match f with
       | Lt => tyArr !tyNat (tyArr !tyNat !tyBool)
       | Plus => tyArr !tyNat (tyArr !tyNat !tyNat)
       | N _ => !tyNat
       | Eq t => tyArr t (tyArr t tyProp)
       | And | Or | Impl => tyArr tyProp (tyArr tyProp tyProp)
       | Ex t | All t => tyArr (tyArr t tyProp) tyProp
       end.

Definition funcD (f : func)
: match typeof_func f with
  | None => unit
  | Some t => typD t
  end :=
  match f as f return match typeof_func f with
                      | None => unit
                      | Some t => typD t
                      end
  with
    | Lt => NPeano.Nat.ltb
    | Plus => plus
    | N n => n
    | Eq t => @eq _
    | And => and
    | Or => or
    | Impl => fun (P Q : Prop) => P -> Q
    | All t => fun P => forall x : typD t, P x
    | Ex t => fun P => exists x : typD t, P x
  end.

Let RelDec_eq_typ : RelDec (@eq typ) := RelDec_Rty _.
Local Existing Instance RelDec_eq_typ.

Instance RelDec_eq_func : RelDec (@eq func) :=
{ rel_dec := fun (a b : func) =>
               match a , b with
                 | Plus , Plus => true
                 | Lt , Lt => true
                 | N a , N b => a ?[ eq ] b
                 | Eq a , Eq b => a ?[ eq ] b
                 | And , And
                 | Impl , Impl
                 | Or , Or => true
                 | All a , All b
                 | Ex a , Ex b => a ?[ eq ] b
                 | _ , _ => false
               end
}.

Instance RelDecCorrect_eq_func : RelDec_Correct RelDec_eq_func.
Proof.
  constructor.
  destruct x; destruct y; simpl;
  try solve [ tauto
            | split; congruence
            | rewrite rel_dec_correct; split; congruence
            ].
Qed.

Instance RSym_func : RSym func :=
{ typeof_sym := typeof_func
; symD := funcD
; sym_eqb := fun a b => Some (a ?[ eq ] b)
}.

Instance RSymOk_func : RSymOk RSym_func.
{ constructor.
  intros. simpl. consider (a ?[ eq ] b); auto. }
Qed.


(* File: Disjunct.v  (last edited on 27/10/2000) (c) Klaus Weich  *)

From IPC Require Export In_NGamma.

Definition a_ai_disj (a : atoms) (ai : atomic_imps) :=
  forall i : Int,
  LOOKUP unit i a tt -> forall bs : nf_list, LOOKUP nf_list i ai bs -> False.

Definition a_goal_disj (a : atoms) (goal : Int) :=
  LOOKUP unit goal a tt -> False.

Lemma disjs_insert_ai :
 forall (i : Int) (b : normal_form) (a : atoms) (ai ai' : atomic_imps),
 a_ai_disj a ai ->
 (forall d : unit, ~ LOOKUP unit i a d) ->
 EQUIV_INS nf_list i (cons b) nf_nil ai ai' -> a_ai_disj a ai'.
intros i b a ai ai'.
elim a; clear a; intros a avl_a.
elim ai; clear ai; intros ai avl_ai.
elim ai'; clear ai'; intros ai' avl_ai'.
unfold a_ai_disj in |- *.
simpl in |- *.
intros a_ai_disj0 not_lookup_i equiv_ins j lookup_j bs lookup_bs.
elim (equal_dec j i).
intros equal_ji.
apply (not_lookup_i tt).
 rewrite <- (equal_eq j i); assumption.
intros not_equal_ji.
apply a_ai_disj0 with j bs; clear a_ai_disj0; try assumption.
inversion_clear equiv_ins.
apply H2; assumption.
Qed.

Lemma disjs_delete_ai :
 forall (i : Int) (a a' : atoms) (ai ai' : atomic_imps),
 a_ai_disj a ai ->
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 EQUIV_DEL nf_list i ai ai' -> a_ai_disj a' ai'.
intros i a a' ai ai'.
elim a; clear a; intros a avl_a.
elim a'; clear a'; intros a' avl_a'.
elim ai; clear ai; intros ai avl_ai.
elim ai'; clear ai'; intros ai' avl_ai'.
unfold a_ai_disj in |- *.
simpl in |- *.
intros a_ai_disj0 equiv_ins equiv_del i0 lookup_j bs0 lookup_bs0.
elim (equal_dec i0 i).
intro equal_i.
inversion_clear equiv_del.
apply H with i0 bs0; assumption.

intros not_equal_i.
apply a_ai_disj0 with i0 bs0.
inversion_clear equiv_ins.
apply H2; assumption.
inversion_clear equiv_del.
apply H1; assumption.
Qed.

Lemma goal_disj_insert_a :
 forall (i goal : Int) (a a' : atoms),
 a_goal_disj a goal ->
 (Equal goal i -> False) ->
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' -> a_goal_disj a' goal.
intros i goal a a'.
elim a; clear a; intros a avl_a.
elim a'; clear a'; intros a' avl_a'.
unfold a_goal_disj in |- *.
simpl in |- *.
intros a_goal_disj0 not_equal equiv_ins lookup.
apply a_goal_disj0.
inversion_clear equiv_ins.
apply H2; assumption.
Qed.

Lemma disjs_insert_a :
 forall (i : Int) (a a' : atoms) (ai : atomic_imps),
 a_ai_disj a ai ->
 EQUIV_INS unit i (fun _ : unit => tt) tt a a' ->
 (forall bs : nf_list, ~ LOOKUP nf_list i ai bs) -> a_ai_disj a' ai.
intros i a a' ai.
elim a; clear a; intros a avl_a.
elim a'; clear a'; intros a' avl_a'.
elim ai; clear ai; intros ai avl_ai.
unfold a_ai_disj in |- *.
simpl in |- *.
intros a_ai_disj0 equiv_ins not_lookup_bs i0 lookup_j bs0 lookup_bs0.
elim (equal_dec i0 i).
intro equal_i.
apply (not_lookup_bs bs0).
 rewrite <- (equal_eq i0 i); assumption.

intros not_equal_i.
apply a_ai_disj0 with i0 bs0.
inversion_clear equiv_ins.
apply H2; assumption.
assumption.
Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal7.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (n0:natural) (y:lst) (IHy:@eq natural (len (qreva (Cons n x) y)) (plus (len (Cons n x)) (len y))):@eq natural (len (qreva x (Cons n (Cons n0 y))))
  (Succ (plus (len x) (Succ (len y)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_smallclam_lf_goal7_theorem0_54_plus_comm/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (n0:natural) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x n0 y.
QuickChick collect_data.
Success.


(** * Functoriality of the construction of adjunctions *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Identity Functor.Composition.Core.
Require Import Category.Dual.
Require Import FunctorCategory.Core.
Require Import Category.Sigma.OnObjects Category.Prod.
Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.Dual.
Require Import Adjoint.Functorial.Parts Adjoint.Functorial.Laws.
Require Import HoTT.Types.Prod.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope natural_transformation_scope.
Local Open Scope morphism_scope.
Local Open Scope category_scope.

Section left.
  (** ** Non-dependent functor for left adjoints *)
  (** We'd need Π types (dependent functors) to include functoriality
      on the categories. *)
  Section nondep.
    Context `{Funext}.
    Variables C D : PreCategory.

    Definition left_functor_nondep
    : Functor (sigT_obj (D -> C) (fun G => { F : Functor C D & F -| G }))
              (sigT_obj ((C -> D)^op * (D -> C)) (fun FG => fst FG -| snd FG))
      := Build_Functor
           (sigT_obj (D -> C) (fun G => { F : Functor C D & F -| G }))
           (sigT_obj ((C -> D)^op * (D -> C)) (fun FG => fst FG -| snd FG))
           (fun GFA => ((GFA.2.1, GFA.1); GFA.2.2))
           (fun GFA G'F'A' m => (left_morphism_of_nondep GFA.2.2 G'F'A'.2.2 m, m))
           (fun s d d' m1 m2 => path_prod' (left_composition_of_nondep _ _ _ _ _) 1)
           (fun x => path_prod' (left_identity_of_nondep _) 1).
  End nondep.
End left.

Section right.
  (** ** Non-dependent functor for right adjoints *)
  (** We'd need Π types (dependent functors) to include functoriality
      on the categories. *)
  Section nondep.
    Context `{Funext}.
    Variables C D : PreCategory.

    (** TODO: Is there a nice way to write this functor as a
              composition of the above with some dualization functors?
              (I suspect there is.) *)
    Definition right_functor_nondep
    : Functor (sigT_obj (C -> D) (fun F => { G : Functor D C & F -| G }))
              (sigT_obj ((C -> D) * (D -> C)^op) (fun FG => fst FG -| snd FG))
      := Build_Functor
           (sigT_obj (C -> D) (fun F => { G : Functor D C & F -| G }))
           (sigT_obj ((C -> D) * (D -> C)^op) (fun FG => fst FG -| snd FG))
           (fun GFA => ((GFA.1, GFA.2.1); GFA.2.2))
           (fun GFA G'F'A' m => (m, right_morphism_of_nondep G'F'A'.2.2 GFA.2.2 m))
           (fun s d d' m1 m2 => path_prod' 1 (right_composition_of_nondep _ _ _ _ _))
           (fun x => path_prod' 1 (right_identity_of_nondep _)).
  End nondep.
End right.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal7.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (n0:natural) (y:lst) (IHy:@eq natural (len (qreva (Cons n x) y)) (plus (len (Cons n x)) (len y))):@eq natural (len (qreva x (Cons n (Cons n0 y))))
  (Succ (plus (len x) (Succ (len y)))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal7_theorem0_54_plus_comm/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (n0:natural) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"n0:" ++ "(" ++ show n0 ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x n0 y.
QuickChick collect_data.
Success.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Require Import VerdiRaft.CommonDefinitions.

Section LeaderLogsLogMatching.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition leaderLogs_entries_match_host (net : network) : Prop :=
    forall h h' t ll,
      In (t, ll) (leaderLogs (fst (nwState net h'))) ->
      entries_match (log (snd (nwState net h))) ll.

  Class leaderLogs_entries_match_interface : Prop :=
    {
      leaderLogs_entries_match_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          leaderLogs_entries_match_host net
    }.
End LeaderLogsLogMatching.


Require Export prosa.analysis.facts.preemption.job.limited.

(** Furthermore, we assume the task model with floating non-preemptive regions. *)
Require Import prosa.model.task.preemption.floating_nonpreemptive.
Require Import prosa.model.preemption.limited_preemptive.

(** * Platform for Floating Non-Preemptive Regions Model *)
(** In this section, we prove that instantiation of functions
    [job_preemptable and task_max_nonpreemptive_segment] to the model
    with floating non-preemptive regions indeed defines a valid
    preemption model with bounded non-preemptive regions. *)
Section FloatingNonPreemptiveRegionsModel.

  (** Consider any type of tasks ... *)
  Context {Task : TaskType}.
  Context `{TaskCost Task}.

  (**  ... and any type of jobs associated with these tasks. *)
  Context {Job : JobType}.
  Context `{JobTask Job Task}.
  Context `{JobArrival Job}.
  Context `{JobCost Job}.

  (** In addition, we assume the existence of a function mapping a
      task to its maximal non-preemptive segment ... *)
  Context `{TaskMaxNonpreemptiveSegment Task}.

  (** .. and the existence of functions mapping a
      job to the sequence of its preemption points. *)
  Context `{JobPreemptionPoints Job}.

  (** Consider any arrival sequence. *)
  Variable arr_seq : arrival_sequence Job.

  (** Next, consider any ideal uni-processor preemption-aware schedule
      of this arrival sequence ... *)
  Variable sched : schedule (ideal.processor_state Job).
  Hypothesis H_preemption_aware_schedule:
    schedule_respects_preemption_model arr_seq sched.

  (** ... where jobs do not execute before their arrival or after completion. *)
  Hypothesis H_jobs_must_arrive_to_execute : jobs_must_arrive_to_execute sched.
  Hypothesis H_completed_jobs_dont_execute : completed_jobs_dont_execute sched.

  (** Next, we assume that preemption points are defined by the model
      with floating non-preemptive regions. *)
  Hypothesis H_valid_model_with_floating_nonpreemptive_regions:
    valid_model_with_floating_nonpreemptive_regions arr_seq.

  (** Then, we prove that the [job_preemptable and
      task_max_nonpreemptive_segment] functions define
      a model with bounded non-preemptive regions. *)
  Lemma floating_preemption_points_model_is_model_with_bounded_nonpreemptive_regions:
    model_with_bounded_nonpreemptive_segments arr_seq.
  Proof.
    intros j ARR.
    move: (H_valid_model_with_floating_nonpreemptive_regions) => LIM; move: LIM (LIM) => [LIM L] [[BEG [END NDEC]] MAX].
    case: (posnP (job_cost j)) => [ZERO|POS].
    - split.
      rewrite /job_respects_max_nonpreemptive_segment /job_max_nonpreemptive_segment
              /lengths_of_segments /parameter.job_preemption_points; rewrite ZERO; simpl.
      rewrite /job_preemptable /limited_preemptions_model; erewrite zero_in_preemption_points; eauto 2.
      + move => progr; rewrite ZERO leqn0; move => /andP [_ /eqP LE].
        exists 0; rewrite LE; split; first by apply/andP; split.
          by eapply zero_in_preemption_points; eauto 2.
    - split; last (move => progr /andP [_ LE]; destruct (progr \in job_preemption_points j) eqn:NotIN).
      + by apply MAX.
      + exists progr; split; first apply/andP; first split; rewrite ?leq_addr; by done.
      + move: NotIN => /eqP; rewrite eqbF_neg; move => NotIN.
        edestruct (work_belongs_to_some_nonpreemptive_segment arr_seq) as [x [SIZE2 N]]; eauto 2. move: N => /andP [N1 N2].
        set ptl := nth 0 (job_preemption_points j) x.
        set ptr := nth 0 (job_preemption_points j) x.+1.
        exists ptr; split; first last.
        * by unfold job_preemptable, limited_preemptions_model; apply mem_nth.
        * apply/andP; split; first by apply ltnW.
          apply leq_trans with (ptl + (job_max_nonpreemptive_segment j - ε) + 1); first last.
          -- rewrite addn1 ltn_add2r; apply N1.
          -- unfold job_max_nonpreemptive_segment.
             rewrite -addnA -leq_subLR -(leq_add2r 1).
             rewrite [in X in _ <= X]addnC -leq_subLR.
             rewrite !subn1 !addn1 prednK.
             { rewrite -[_.+1.-1]pred_Sn. rewrite /lengths_of_segments.
               erewrite job_parameters_max_np_to_job_limited; eauto.
                 by apply distance_between_neighboring_elements_le_max_distance_in_seq. }
             { rewrite /lengths_of_segments; erewrite job_parameters_max_np_to_job_limited; eauto.
               apply max_distance_in_nontrivial_seq_is_positive; first by eauto 2.
               exists 0, (job_cost j); repeat split.
               - by eapply zero_in_preemption_points; eauto.
               - by eapply job_cost_in_nonpreemptive_points; eauto.
               - by apply/eqP; rewrite eq_sym -lt0n; apply POS.
             }
  Qed.

  (** Which together with lemma [valid_fixed_preemption_points_model]
      gives us the fact that functions [job_preemptable and
      task_max_nonpreemptive_segment] define a valid preemption model
      with bounded non-preemptive regions. *)
  Corollary floating_preemption_points_model_is_valid_model_with_bounded_nonpreemptive_regions:
    valid_model_with_bounded_nonpreemptive_segments arr_seq sched.
  Proof.
    split.
    - apply valid_fixed_preemption_points_model_lemma; auto.
        by apply H_valid_model_with_floating_nonpreemptive_regions.
    - apply floating_preemption_points_model_is_model_with_bounded_nonpreemptive_regions.
  Qed.

End FloatingNonPreemptiveRegionsModel.

(** We add the above lemma into a "Hint Database" basic_facts, so Coq will be able to apply them automatically. *)
Hint Resolve
     valid_fixed_preemption_points_model_lemma
     floating_preemption_points_model_is_model_with_bounded_nonpreemptive_regions
     floating_preemption_points_model_is_valid_model_with_bounded_nonpreemptive_regions : basic_facts.


Require Export nat_neq_bool.

Theorem rewrite_iff : forall (P Q : Prop), (P <-> Q) -> (P = Q).
Proof.
  intros.
  (* rewrite <- H. --doesn't work, reports Error: Library Coq.Setoids.Setoid has to be required first.*)
Abort.

Definition map : forall (X Y : Type) (M : X -> Y) (f : X -> X), Y -> Y.
Proof.
(*It looks so easy, but actually I cannot prove it*)
Abort.

Theorem rewrite_iff : forall (P : Prop -> Prop) (x y : Prop), (x <-> y) -> (P x <-> P y).
Proof.
  intros.
  destruct H.
  unfold iff.
  split.
Abort.

(*显然存在一个函数f：nat -> bool,也存在一个函数：bool -> nat,但可以证明nat = bool，所以可证下述命题*)
Theorem not_iff_eq_Set : (forall (P Q : Set), (P -> Q) -> (Q -> P) -> P = Q) -> False.
Proof.
  intros.
  specialize (H nat bool).
  assert (nat -> bool) as nat_bool.
    intros Xnat.
    apply (fun n:nat => match n with
                        | 0 => true
                        | _ => false
                        end).
    exact Xnat.
  assert (bool -> nat) as bool_nat.
    intros Xbool.
    exact ((fun b:bool => match b with
                         | true  => 0
                         | false => 1
                         end) Xbool).
  assert (nat = bool) as nat_eq_bool.
    apply (H nat_bool bool_nat).
  apply nat_neq_bool.
  exact nat_eq_bool.
Qed.
(*对于命题，要定义一个有两个元素的真，这样*)
Inductive True2 : Prop :=
 | One : True2
 | Two : True2.

Lemma True_has_one : forall (t0 t1 : True), t0 = t1.
Proof.
  intros.
  destruct t0. destruct t1.
  reflexivity.
Qed.

Lemma not_True2_has_one : (forall (t0 t1 : True2), t0 = t1) -> False.
Proof.
  intros.
  specialize (H One Two).
  inversion H.
Abort.

Lemma True_neq_True2 : True = True2 -> False.
Proof.
Abort.

Theorem iff_eq : forall (P Q : Prop), (P -> Q) -> (Q -> P) -> P = Q.
Proof.
Abort.


From Rupicola.Examples Require Import IPChecksum.Impl.

#[global]
Instance spec_of_ip_checksum : spec_of "ip_checksum" :=
  fnspec! "ip_checksum" data_ptr wlen / (data : list byte) R ~> chk,
    { requires tr mem :=
        wlen = word.of_Z (Z.of_nat (length data)) /\
        Z.of_nat (Datatypes.length data) < 2 ^ 32 /\
        (listarray_value AccessByte data_ptr data * R)%sep mem;
      ensures tr' mem' :=
        tr' = tr /\
        chk = ip_checksum_impl data /\
        (listarray_value AccessByte data_ptr data * R)%sep mem' }.

Import LoopCompiler.
Import UnsizedListArrayCompiler.

#[local] Hint Unfold ip_checksum_upd : compiler_cleanup.
#[local] Hint Extern 10 => cbn; nia : compiler_side_conditions.

Lemma odd_sub_pos z:
  0 <= z -> Z.odd z = true -> 0 <= z - 1.
Proof. destruct (Z.eq_dec z 0) as [-> | ]; simpl; lia. Qed.

#[local] Hint Resolve odd_sub_pos : lia.
#[global]
Hint Rewrite Z2Nat.id using eauto with lia : compiler_side_conditions.

Derive ip_checksum_br2fn SuchThat
       (defn! "ip_checksum" ("data", "len") ~> "chk16"
         { ip_checksum_br2fn },
         implements ip_checksum_impl)
       As ip_checksum_br2fn_ok.
Proof.
  Time compile.
Time Qed.

Definition ip_checksum_cbytes := Eval vm_compute in
  list_byte_of_string (ToCString.c_module [("ip_checksum",ip_checksum_br2fn)]).


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 D P Q : Universe, ((wd_ A B /\ (wd_ C D /\ (wd_ B P /\ (wd_ A P /\ (wd_ P Q /\ (col_ A C D /\ col_ B C D)))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ (mult (Succ lv0) lv1))) (plus (mult lv1 (Succ lv0)) (Succ lv0))).
Admitted.
QuickChick conj15synthconj4.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Relations.Relation_Definitions.
Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Syntax.Value.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Poulet4.Utils.Utils.
Require Import ProD3.core.Coqlib.
Require Import ProD3.core.SvalRefine.
Require Import ProD3.core.AssertionLang.
Require Import ProD3.core.AssertionNotations.
Require Import ProD3.core.Hoare.
Require Import ProD3.core.ExtPred.
Require Import Poulet4.P4light.Syntax.SyntaxUtil.
Require Import Hammer.Plugin.Hammer.

Section Implies.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).
Notation Lval := ValueLvalue.

Notation ident := (String.string).
Notation path := (list ident).
Notation Expression := (@Expression tags_t).

Context {target : @Target tags_t Expression}.

Definition mem_simplify_aux (a : mem_assertion) '((p, sv) : path * Sval) : option (Sval * Sval) :=
  match AList.get a p with
  | Some sv' => Some (sv, sv')
  | None => None
  end.

Lemma mem_simplify_aux_sound : forall a psv svp,
  mem_simplify_aux a psv = Some svp ->
  uncurry sval_refine svp ->
  forall m, mem_denote a m -> mem_satisfies_unit m psv.
Proof.
  intros.
  destruct psv as [p sv].
  unfold mem_simplify_aux in *.
  destruct (AList.get a p) eqn:H_get; inv H.
  eapply mem_denote_get in H_get; eauto.
  unfold mem_satisfies_unit in *.
  destruct (PathMap.get p m); only 2 : inv H_get.
  eapply sval_refine_trans; eauto.
Qed.

Definition mem_implies_simplify (a a' : mem_assertion) : option (list (Sval * Sval)) :=
  lift_option (map (mem_simplify_aux a) a').

Lemma mem_implies_simplify_sound : forall a a' svps,
  mem_implies_simplify a a' = Some svps ->
  Forall (uncurry sval_refine) svps ->
  forall m, mem_denote a m -> mem_denote a' m.
Proof.
  intros.
  unfold mem_implies_simplify in *.
  apply lift_option_inv in H.
  unfold mem_denote, mem_satisfies.
  rewrite fold_right_and_True in *.
  list_simplify.
  apply mem_simplify_aux_sound with a (Znth i svps).
  - list_simplify.
    (* list_solve cannot perform this simplification because the implicit type mem_unit and (path * Sval)
      are not converted automatically. *)
    rewrite Znth_map in H12 by auto. list_solve.
  - list_solve.
  - auto.
Qed.

Definition ext_implies (a a' : ext_assertion) : Prop :=
  forall es, ext_denote a es -> ext_denote a' es.

Global Add Parametric Morphism : ext_implies with
  signature ext_assertion_equiv ==> ext_assertion_equiv ==> iff as ext_implies_mor.
Proof.
  intros. unfold ext_implies.
  rewrite H, H0.
  reflexivity.
Qed.

Lemma ext_implies_refl : forall (a : ext_assertion),
  ext_implies a a.
Proof. unfold ext_implies; auto. Qed.

Lemma ext_implies_nil : forall a, ext_implies a [].
Proof. repeat intro. red. red. easy. Qed.

Lemma ext_implies_cons : forall (a c : ext_assertion) b,
  ext_implies a (b :: c) <-> (ext_implies a [b] /\ ext_implies a c).
Proof.
  intros. unfold ext_implies, ext_denote. split; intros.
  - split; intros; apply H in H0; red in H0; simpl in H0; red; simpl; destruct H0; auto.
  - destruct H. specialize (H _ H0). specialize (H1 _ H0). clear H0.
    unfold ext_satisfies in *. simpl in *. destruct H. split; auto.
Qed.

Lemma ext_implies_prop_intro : forall pre (P : Prop),
  P ->
  ext_implies pre [ExtPred.prop P].
Proof.
  intros.
  sauto.
Qed.

Lemma ext_cons_implies : forall a (b c : ext_assertion),
  (ext_implies [a] c \/ ext_implies b c) -> ext_implies (a :: b) c.
Proof.
  intros. destruct H; unfold ext_implies, ext_denote in *; intros; apply H.
  - destruct H0. unfold ext_satisfies. simpl. auto.
  - destruct H0. auto.
Qed.

Lemma ext_implies_singleton : forall (p : path) (eo1 eo2 : extern_object),
  eo1 = eo2 ->
  ext_implies [ExtPred.singleton p eo1] [ExtPred.singleton p eo2].
Proof.
  intros; subst; apply ext_implies_refl.
Qed.

Lemma implies_simplify : forall pre_mem pre_ext post_mem post_ext svps,
  mem_implies_simplify pre_mem post_mem = Some svps ->
  Forall (uncurry sval_refine) svps ->
  ext_implies pre_ext post_ext ->
  implies (MEM pre_mem (EXT pre_ext)) (MEM post_mem (EXT post_ext)).
Proof.
  unfold implies; intros.
  destruct st as [m es].
  destruct H2; split.
  - eapply mem_implies_simplify_sound; eauto.
  - apply H1. auto.
Qed.

Lemma arg_implies_simplify : forall pre_arg pre_mem pre_ext post_arg post_mem post_ext svps,
  Forall2 sval_refine post_arg pre_arg ->
  mem_implies_simplify pre_mem post_mem = Some svps ->
  Forall (uncurry sval_refine) svps ->
  ext_implies pre_ext post_ext ->
  arg_implies (ARG pre_arg (MEM pre_mem (EXT pre_ext))) (ARG post_arg (MEM post_mem (EXT post_ext))).
Proof.
  unfold arg_implies; intros.
  destruct H3.
  split. 2 : { eapply implies_simplify; eauto. }
  eapply Forall2_trans. 1 : { unfold rel_trans. apply sval_refine_trans. }
  all : eauto.
Qed.

Lemma ret_implies_simplify : forall pre_ret pre_mem pre_ext post_ret post_mem post_ext svps,
  sval_refine post_ret pre_ret ->
  mem_implies_simplify pre_mem post_mem = Some svps ->
  Forall (uncurry sval_refine) svps ->
  ext_implies pre_ext post_ext ->
  ret_implies (RET pre_ret (MEM pre_mem (EXT pre_ext))) (RET post_ret (MEM post_mem (EXT post_ext))).
Proof.
  unfold ret_implies; intros.
  destruct H3.
  split. 2 : { eapply implies_simplify; eauto. }
  clear -H H3. unfold ret_denote, ret_satisfies in *.
  intros sv' H0. specialize (H3 sv' H0).
  eapply sval_refine_trans; eauto.
Qed.

Lemma arg_ret_implies_simplify : forall pre_arg pre_ret pre_mem pre_ext post_arg post_ret post_mem post_ext svps,
  Forall2 sval_refine post_arg pre_arg ->
  sval_refine post_ret pre_ret ->
  mem_implies_simplify pre_mem post_mem = Some svps ->
  Forall (uncurry sval_refine) svps ->
  ext_implies pre_ext post_ext ->
  arg_ret_implies
    (ARG_RET pre_arg pre_ret (MEM pre_mem (EXT pre_ext)))
    (ARG_RET post_arg post_ret (MEM post_mem (EXT post_ext))).
Proof.
  unfold arg_ret_implies; intros.
  destruct H4.
  split. 2 : { eapply ret_implies_simplify; eauto. }
  eapply Forall2_trans. 1 : { unfold rel_trans. apply sval_refine_trans. }
  all : eauto.
Qed.

End Implies.

Ltac simpl_single_ext_implies :=
  first [
    apply (@id (ext_implies [] _));
    fail "No remaining assumptions"
  | apply (@id (ext_implies (_ :: _) _));
    apply ext_cons_implies;
    first [
      left;
      first [
        apply ext_implies_refl
      | lazymatch goal with
        | |- ext_implies [ExtPred.singleton ?p1 ?o1] [ExtPred.singleton ?p2 ?o2] =>
            simple apply ext_implies_singleton;
            try reflexivity
        end
      ]
    | right; simpl_single_ext_implies
    ]
  ].

Ltac simpl_ext_implies :=
  first [
    apply (@id (ext_implies _ []));
    apply ext_implies_nil
  | apply (@id (ext_implies _ (_ :: _)));
    apply ext_implies_cons; split;
    [ try simpl_single_ext_implies
    | simpl_ext_implies
    ]
  ].
  (* lazymatch goal with
  |
  repeat match goal with
    | |- ext_implies _ [] => apply ext_implies_nil
    | |- ext_implies _ (_ :: _ :: _) => apply ext_implies_cons; split
    | |- ext_implies _ [_] =>
        try reflexivity_simpl_ext_implies;
        try (let es := fresh "es" in
             let H := fresh "H" in
             unfold ext_implies, ext_denote, ext_satisfies;
             intros es H;
             simpl in H |- *;
             intuition; easy)
  end. *)

Section SIMPL_EXT_IMPLIES_TEST.

  Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.

  Notation Expression := (@Expression tags_t).

  Context {target : @Target tags_t Expression}.

  Variable P Q R S: ext_pred.

  Goal ext_implies [P; Q; R; S] [].
  Proof. simpl_ext_implies. Qed.

  (* Rearrange order doesn't matter *)
  Goal ext_implies [P; Q; R; S] [R; S; Q; P].
  Proof. simpl_ext_implies. Qed.

  (* It will leave unsolved goals *)
  Goal ext_implies [P; Q; S] [R; S; Q].
  Proof. simpl_ext_implies. Abort.

  (* If we have additional rules, the tactic can solve the goal *)
  (* Goal (forall es, P es -> R es) -> ext_implies [P; Q; S] [R; S; Q].
  Proof. intros. simpl_ext_implies. Qed. *)

End SIMPL_EXT_IMPLIES_TEST.