Require Export refocusing_lang_cs.

Module Type RED_SEM_CS (R : RED_LANG_CS).

  Parameter dec : R.term -> R.context -> R.decomp -> Prop.

  (** A redex in context will only ever be reduced to itself *)
  Axiom dec_redex_self : forall (r : R.redex) (c : R.context), dec (R.redex_to_term r) c (R.d_red r c).

  Axiom decompose : forall t : R.term, (exists v:R.value, t = R.value_to_term v) \/
      (exists r:R.redex, exists c:R.context, R.plug (R.redex_to_term r) c = t).

  (** dec is left inverse of plug *)
  Axiom dec_correct : forall t c d, dec t c d -> R.decomp_to_term d = R.plug t c.

  Axiom dec_plug : forall c c0 t d, dec (R.plug t c) c0 d -> dec t (R.compose c c0) d.
  Axiom dec_plug_rev : forall c c0 t d, dec t (R.compose c c0) d -> dec (R.plug t c) c0 d.

  Inductive decempty : R.term -> R.decomp -> Prop :=
  | d_intro : forall (t : R.term) (d : R.decomp) (DEC : dec t R.empty d), decempty t d.

  Inductive iter : R.decomp -> R.value -> Prop :=
  | i_val : forall (v : R.value), iter (R.d_val v) v
  | i_red : forall (r : R.redex) (t : R.term) (c c0 : R.context) (d : R.decomp) (v : R.value)
              (CONTR : R.contract r c = Some (t, c0))
              (D_EM  : decempty (R.plug t c0) d)
              (R_IT  : iter d v),
              iter (R.d_red r c) v.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (d : R.decomp) (v : R.value)
                (D_EM : decempty t d)
                (ITER : iter d v),
                eval t v.

End RED_SEM_CS.

Module Type RED_REF_SEM_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 => R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  (** A decomposition function specified in terms of the atomic functions above *)
  Inductive dec : R.term -> R.context -> R.decomp -> Prop :=
  | d_dec  : forall (t : R.term) (c : R.context) (r : R.redex)
               (DT  : dec_term t = R.in_red r),
               dec t c (R.d_red r c)
  | d_v    : forall (t : R.term) (c : R.context) (v : R.value) (d : R.decomp)
               (DT  : dec_term t = R.in_val v)
               (R_C : decctx v c d),
               dec t c d
  | d_term : forall (t t0 : R.term) (c : R.context) (ec : R.elem_context) (d : R.decomp)
               (DT  : dec_term t = R.in_term t0 ec)
               (R_T : dec t0 (ec :: c) d),
               dec t c d
  with decctx : R.value -> R.context -> R.decomp -> Prop :=
  | dc_end  : forall (v : R.value), decctx v R.empty (R.d_val v)
  | dc_dec  : forall (v : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
                (DC  : dec_context ec v = R.in_red r),
                decctx v (ec :: c) (R.d_red r c)
  | dc_val  : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (d : R.decomp)
                (DC  : dec_context ec v = R.in_val v0)
                (R_C : decctx v0 c d),
                decctx v (ec :: c) d
  | dc_term : forall (v : R.value) (ec ec0 : R.elem_context) (c : R.context) (t : R.term) (d : R.decomp)
                (DC  : dec_context ec v = R.in_term t ec0)
                (R_T : dec t (ec0 :: c) d),
                decctx v (ec :: c) d.

  Axiom dec_val_self : forall v c d, dec (R.value_to_term v) c d <-> decctx v c d.
  Declare Module RS : RED_SEM_CS R with Definition dec := dec.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

End RED_REF_SEM_CS.

Module Type PE_REF_SEM (R : RED_LANG_CS).

  Declare Module Red_Sem : RED_REF_SEM_CS R.

  Axiom dec_context_not_val : forall v v0 ec, ~(Red_Sem.dec_context ec v = R.in_val v0).
  Axiom dec_term_value : forall v, Red_Sem.dec_term (R.value_to_term v) = R.in_val v.

End PE_REF_SEM.

Module Type RED_PROP (R : RED_LANG_CS) (RS : RED_REF_SEM_CS(R)).

  Axiom dec_is_function : forall t d d0, RS.RS.decempty t d -> RS.RS.decempty t d0 -> d = d0.
  Axiom iter_is_function : forall d v v0, RS.RS.iter d v -> RS.RS.iter d v0 -> v = v0.
  Axiom eval_is_function : forall t v v0, RS.RS.eval t v -> RS.RS.eval t v0 -> v = v0.
  Axiom dec_correct : forall t c d, RS.RS.dec t c d -> R.decomp_to_term d = R.plug t c.
  Axiom dec_total : forall t, exists d, RS.RS.decempty t d.
  Axiom unique_decomposition : forall t:R.term, (exists v:R.value, t = R.value_to_term v) \/
      (exists r:R.redex, exists c:R.context, R.plug (R.redex_to_term r) c = t /\
	  forall (r0:R.redex) c0, (R.plug (R.redex_to_term r0) c0 = t -> r=r0 /\ c= c0)).

End RED_PROP.

Module Type PRE_ABSTRACT_MACHINE_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  (** A decomposition function specified in terms of the atomic functions above *)
  Inductive dec : R.term -> R.context -> R.decomp -> Prop :=
  | d_dec  : forall (t : R.term) (c : R.context) (r : R.redex)
                 (DT  : dec_term t = R.in_red r),
                 dec t c (R.d_red r c)
  | d_v    : forall (t : R.term) (c : R.context) (v : R.value) (d : R.decomp)
                 (DT  : dec_term t = R.in_val v)
                 (R_C : decctx v c d),
                 dec t c d
  | d_term : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (d : R.decomp)
                 (DT  : dec_term t = R.in_term t0 ec)
                 (R_T : dec t0 (ec :: c) d),
                 dec t c d
  with decctx : R.value -> R.context -> R.decomp -> Prop :=
  | dc_end  : forall (v : R.value), decctx v R.empty (R.d_val v)
  | dc_dec  : forall (v : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
                (DC  : dec_context ec v = R.in_red r),
                decctx v (ec :: c) (R.d_red r c)
  | dc_val  : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (d : R.decomp)
                (DC  : dec_context ec v = R.in_val v0)
                (R_C : decctx v0 c d),
                decctx v (ec :: c) d
  | dc_term : forall (v : R.value) (ec ec0 : R.elem_context) (c : R.context) (t : R.term) (d : R.decomp)
                (DC  : dec_context ec v = R.in_term t ec0)
                (R_T : dec t (ec0 :: c) d),
                decctx v (ec :: c) d.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Inductive iter : R.decomp -> R.value -> Prop :=
  | i_val : forall (v : R.value), iter (R.d_val v) v
  | i_red : forall (r : R.redex) (t : R.term) (c c0 : R.context) (d : R.decomp) (v : R.value)
              (CONTR  : R.contract r c = Some (t, c0))
              (DEC    : dec t c0 d)
              (R_ITER : iter d v),
              iter (R.d_red r c) v.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (d : R.decomp) (v : R.value)
                (DEC  : dec t R.empty d)
                (ITER : iter d v),
                eval t v.

End PRE_ABSTRACT_MACHINE_CS.

Module Type STAGED_ABSTRACT_MACHINE_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive dec : R.term -> R.context -> R.value -> Prop :=
  | d_dec  : forall (t : R.term) (c : R.context) (r : R.redex) (v : R.value)
               (DT   : dec_term t = R.in_red r)
               (R_IT : iter (R.d_red r c) v),
               dec t c v
  | d_v    : forall (t : R.term) (c : R.context) (v v0 : R.value)
               (DT   : dec_term t = R.in_val v)
               (R_C  : decctx v c v0),
               dec t c v0
  | d_many : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v : R.value)
               (DT   : dec_term t = R.in_term t0 ec)
               (R_T  : dec t0 (ec :: c) v),
               dec t c v
  with decctx : R.value -> R.context -> R.value -> Prop :=
  | dc_end  : forall (v v0 : R.value)
               (IT_V : iter (R.d_val v) v0),
               decctx v R.empty v0
  | dc_dec  : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context) (r : R.redex)
               (DC   : dec_context ec v = R.in_red r)
               (R_IT : iter (R.d_red r c) v0),
               decctx v (ec :: c) v0
  | dc_val  : forall (v v0 v1 : R.value) (ec : R.elem_context) (c : R.context)
               (DC   : dec_context ec v = R.in_val v0)
               (R_C  : decctx v0 c v1),
               decctx v (ec :: c) v1
  | dc_term : forall (v v0 : R.value) (t : R.term) (ec ec0 : R.elem_context) (c : R.context)
               (DC   : dec_context ec v = R.in_term t ec0)
               (R_T  : dec t (ec0 :: c) v0),
               decctx v (ec :: c) v0
  with iter : R.decomp -> R.value -> Prop :=
  | i_val : forall (v : R.value), iter (R.d_val v) v
  | i_red : forall (r : R.redex) (c c0 : R.context) (t : R.term) (v : R.value)
               (CONTR: R.contract r c = Some (t, c0))
               (R_T  : dec t c0 v),
               iter (R.d_red r c) v.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop
  with iter_Ind := Induction for iter Sort Prop.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (v : R.value), dec t R.empty v -> eval t v.

End STAGED_ABSTRACT_MACHINE_CS.

Module Type EVAL_APPLY_MACHINE_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive dec : R.term -> R.context -> R.value -> Prop :=
  | d_d_r  : forall (t t0 : R.term) (c c0 : R.context) (r : R.redex) (v : R.value)
               (DT    : dec_term t = R.in_red r)
               (CONTR : R.contract r c = Some (t0, c0))
               (R_T   : dec t0 c0 v),
               dec t c v
  | d_v    : forall (t : R.term) (c : R.context) (v v0 : R.value)
               (DT    : dec_term t = R.in_val v)
               (R_C   : decctx v c v0),
               dec t c v0
  | d_term : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v : R.value)
               (DT    : dec_term t = R.in_term t0 ec)
               (R_T   : dec t0 (ec :: c) v),
               dec t c v
  with decctx : R.value -> R.context -> R.value -> Prop :=
  | dc_end : forall (v : R.value), decctx v R.empty v
  | dc_red : forall (v v0 : R.value) (ec : R.elem_context) (c c0 : R.context) (r : R.redex) (t : R.term)
               (DC    : dec_context ec v = R.in_red r)
               (CONTR : R.contract r c = Some (t, c0))
               (R_T   : dec t c0 v0),
               decctx v (ec :: c) v0
  | dc_rec : forall (v v0 v1 : R.value) (ec : R.elem_context) (c : R.context)
               (DC    : dec_context ec v = R.in_val v0)
               (R_C   : decctx v0 c v1),
               decctx v (ec :: c) v1
  | dc_trm : forall (v v0 : R.value) (ec ec0 : R.elem_context) (c : R.context) (t : R.term)
               (DC    : dec_context ec v = R.in_term t ec0)
               (R_T   : dec t (ec0 :: c) v0),
               decctx v (ec :: c) v0.

  Scheme dec_Ind := Induction for dec Sort Prop
  with decctx_Ind := Induction for decctx Sort Prop.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (v : R.value), dec t R.empty v -> eval t v.

End EVAL_APPLY_MACHINE_CS.

Module Type PROPER_EA_MACHINE_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive configuration : Set :=
  | c_init  : R.term -> configuration
  | c_eval  : R.term -> R.context -> configuration
  | c_apply : R.context -> R.value -> configuration
  | c_final : R.value -> configuration.

  Reserved Notation " a → b " (at level 40, no associativity).

  Inductive transition : configuration -> configuration -> Prop :=
  | t_init : forall (t : R.term), transition (c_init t) (c_eval t R.empty)
  | t_red  : forall (t t0 : R.term) (c c0 : R.context) (r : R.redex)
               (DT    : dec_term t = R.in_red r)
               (CONTR : R.contract r c = Some (t0, c0)),
               (c_eval t c) → (c_eval t0 c0)
  | t_val  : forall (t : R.term) (v : R.value) (c : R.context)
      	       (DT    : dec_term t = R.in_val v),
               (c_eval t c) → (c_apply c v)
  | t_term : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context)
               (DT    : dec_term t = R.in_term t0 ec),
               (c_eval t c) → (c_eval t0 (ec :: c))
  | t_cfin : forall (v : R.value),
               (c_apply R.empty v) → (c_final v)
  | t_cred : forall (v : R.value) (t : R.term) (ec : R.elem_context) (c c0 : R.context) (r : R.redex)
               (DC    : dec_context ec v = R.in_red r)
               (CONTR : R.contract r c = Some (t, c0)),
               (c_apply (ec :: c) v) → (c_eval t c0)
  | t_cval : forall (v v0 : R.value) (ec : R.elem_context) (c : R.context)
               (DC    : dec_context ec v = R.in_val v0),
               (c_apply (ec :: c) v) → (c_apply c v0)
  | t_cterm: forall (v : R.value) (t : R.term) (ec ec0 : R.elem_context) (c : R.context)
               (DC    : dec_context ec v = R.in_term t ec0),
               (c_apply (ec :: c) v) → (c_eval t (ec0 :: c))
  where " a → b " := (transition a b).

  Declare Module AM : ABSTRACT_MACHINE
    with Definition term := R.term
    with Definition value := R.value
    with Definition configuration := configuration
    with Definition transition := transition
    with Definition c_init := c_init
    with Definition c_final := c_final.

End PROPER_EA_MACHINE_CS.

Module Type PUSH_ENTER_MACHINE_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.
  Axiom dec_term_value : forall (v : R.value), dec_term (R.value_to_term v) = R.in_val v.
  Axiom dec_context_not_val : forall v v0 ec, ~(dec_context ec v = R.in_val v0).

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive dec : R.term -> R.context -> R.value -> Prop :=
  | dec_r    : forall (t t0 : R.term) (c c0 : R.context) (r : R.redex) (v : R.value)
                 (DT    : dec_term t = R.in_red r)
                 (CONTR : R.contract r c = Some (t0, c0))
                 (R_T   : dec t0 c0 v),
                 dec t c v
  | dec_val  : forall (t : R.term) (v : R.value)
                 (DT    : dec_term t = R.in_val v),
                 dec t R.empty v
  | dec_v_t  : forall (t t0 : R.term) (ec ec0 : R.elem_context) (c : R.context) (v v0 : R.value)
                 (DT    : dec_term t = R.in_val v)
                 (DC    : dec_context ec v = R.in_term t0 ec0)
                 (R_T   : dec t0 (ec0 :: c) v0),
                 dec t (ec :: c) v0
  | dec_red  : forall (t t0 : R.term) (ec : R.elem_context) (c c0 : R.context) (v v0 : R.value) (r : R.redex)
                 (DT    : dec_term t = R.in_val v)
                 (DC    : dec_context ec v = R.in_red r)
                 (CONTR : R.contract r c = Some (t0, c0))
                 (R_T   : dec t0 c0 v0),
                 dec t (ec :: c) v0
  | dec_rec  : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context) (v : R.value)
                 (DT    : dec_term t = R.in_term t0 ec)
                 (R_T   : dec t0 (ec :: c) v),
                 dec t c v.

  Scheme dec_Ind := Induction for dec Sort Prop.

  Inductive eval : R.term -> R.value -> Prop :=
  | e_intro : forall (t : R.term) (v : R.value), dec t R.empty v -> eval t v.

End PUSH_ENTER_MACHINE_CS.

Module Type PROPER_PE_MACHINE_CS (R : RED_LANG_CS).

  (** Functions specifying atomic steps of induction on terms and contexts -- needed to avoid explicit induction on terms and contexts in construction of the AM *)
  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.
  Axiom dec_term_value : forall (v : R.value), dec_term (R.value_to_term v) = R.in_val v.
  Axiom dec_context_not_val : forall v v0 ec, ~(dec_context ec v = R.in_val v0).

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t0 c0 => R.atom_plug t0 c0 = t
  end.
  Axiom dec_context_correct : forall c v, match dec_context c v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) c
    | R.in_val v0 =>  R.value_to_term v0 = R.atom_plug (R.value_to_term v) c
    | R.in_term t c0 => R.atom_plug t c0 = R.atom_plug (R.value_to_term v) c
  end.

  Inductive configuration : Set :=
  | c_init  : R.term -> configuration
  | c_eval  : R.term -> R.context -> configuration
  | c_final : R.value -> configuration.

  Reserved Notation " a → b " (at level 40, no associativity).

  Inductive transition : configuration -> configuration -> Prop :=
  | t_init : forall (t : R.term),
               c_init t → c_eval t R.empty
  | t_red  : forall (t t0 : R.term) (c c0 : R.context) (r : R.redex)
               (DT    : dec_term t = R.in_red r)
               (CONTR : R.contract r c = Some (t0, c0)),
               c_eval t c → c_eval t0 c0
  | t_cval : forall (t : R.term) (v : R.value)
               (DT    : dec_term t = R.in_val v),
               c_eval t R.empty → c_final v
  | t_cred : forall (t t0 : R.term) (v : R.value) (ec : R.elem_context) (c c0 : R.context) (r : R.redex)
               (DT    : dec_term t = R.in_val v)
               (DC    : dec_context ec v = R.in_red r)
               (CONTR : R.contract r c = Some (t0, c0)),
               c_eval t (ec :: c) → c_eval t0 c0
  | t_crec : forall (t t0 : R.term) (v : R.value) (ec ec0 : R.elem_context) (c : R.context)
               (DT    : dec_term t = R.in_val v)
               (DC    : dec_context ec v = R.in_term t0 ec0),
               c_eval t (ec :: c) → c_eval t0 (ec0 :: c)
  | t_rec  : forall (t t0 : R.term) (ec : R.elem_context) (c : R.context)
               (DT    : dec_term t = R.in_term t0 ec),
               c_eval t c → c_eval t0 (ec :: c)
  where " a →  b " := (transition a b).

  Declare Module AM : ABSTRACT_MACHINE
    with Definition term := R.term
    with Definition value := R.value
    with Definition configuration := configuration
    with Definition transition := transition
    with Definition c_init := c_init
    with Definition c_final := c_final.

End PROPER_PE_MACHINE_CS.


Require Import Coq.Lists.List.
Require Import Logic.LogicGenerator.Utils.
Require Import Logic.LogicGenerator.ConfigLang.

Import ListNotations.

Definition how_connectives :=
  [ primitive_connective andp;
    primitive_connective orp;
    primitive_connective falsep;
    primitive_connective sepcon;
    primitive_connective wand;
    primitive_connective emp;
    primitive_connective impp;
    primitive_connective iffp;
    FROM_falsep_impp_TO_negp;
    FROM_falsep_impp_TO_truep;
    FROM_impp_TO_multi_imp;
    FROM_andp_TO_iter_andp;
    FROM_sepcon_TO_iter_sepcon;
    FROM_empty_set_TO_empty_context ].

Definition how_judgements :=
  [ primitive_judgement provable;
    FROM_provable_TO_derivable;
    FROM_provable_TO_derivable1;
    FROM_provable_TO_logic_equiv ].

Definition transparent_names :=
  [ expr : parameter;
    sepcon : parameter;
    emp : parameter ].

Definition primitive_rule_classes :=
  [ provability_OF_impp;
    provability_OF_andp;
    provability_OF_orp;
    provability_OF_falsep;
    provability_OF_truep;
    provability_OF_iffp;
    provability_OF_negp;
    provability_OF_iter_andp;
    provability_OF_sepcon_rule;
    provability_OF_wand_rule;
    provability_OF_emp_rule;
    provability_OF_iter_sepcon;
    provability_OF_sepcon_orp_rule;
    provability_OF_sepcon_falsep_rule;
    provability_OF_sepcon_rule_AS_weak;
    derivitive_OF_basic_setting;
    derivitive_OF_finite_derivation;
    derivitive_OF_impp;
    derivitive_OF_andp;
    derivitive_OF_orp;
    derivitive_OF_falsep;
    derivitive_OF_truep;
    derivitive_OF_iffp;
    derivitive_OF_negp ].


(* Verification RUP clauses using backward resolution chains *)

Require Export SolverInterface.
Require Import SatProver.
Require Import MSets.MSetPositive.
Import PositiveSet.
Require Export CnfSpec.
Require Import Bool.
Require Import PArith.BinPos.

Local Open Scope positive.
Local Open Scope list_scope.

Coercion Is_true: bool >-> Sortclass.
Local Open Scope lazy_bool_scope.

Fixpoint sat_bool (c: clause) (m: model): bool :=
  match c with
  | nil => false
  | l::c' => eqb (m (ident l)) (is_pos l) ||| sat_bool c' m
  end.

Lemma sat_bool_spec c m: if (sat_bool c m) then (sat c m) else ~(sat c m).
Proof.
  induction c; simpl.
  + intuition.
  + generalize (eqb_true_iff (m (ident a)) (is_pos a)); destruct (eqb (m (ident a)) (is_pos a)); [ tauto |].
    intros; destruct (sat_bool c m); intuition.
Qed.

Record cclause : Type :=
  { pos: PositiveSet.t ; neg: PositiveSet.t }.

Definition csat (c: cclause) (m: model): Prop :=
  exists x, if (m x) then In x (pos c) else In x (neg c).

Definition empty := {| pos:=empty ; neg:=empty |}.

Lemma empty_correct m: ~(csat empty m).
Proof.
  unfold not, csat, empty; simpl.
  destruct 1 as [x H].
  destruct (m x); eapply empty_spec; eauto.
Qed.

Definition isEmpty (c: cclause): bool :=
  is_empty (pos c) &&& is_empty (neg c).

Lemma isEmpty_correct c: isEmpty c = true -> forall m, ~csat c m.
Proof.
  unfold isEmpty, csat; simpl.
  rewrite lazy_andb_bool.
  rewrite !is_empty_spec.
  unfold Empty.
  intros H m. destruct 1 as [x H2].
  destruct (m x); intuition eauto.
Qed.

Definition add (l:literal) (c: cclause): cclause :=
  if is_pos l then
    {| pos:=add (ident l) (pos c) ; neg := neg  c|}
  else
    {| pos:= pos c ; neg := add (ident l) (neg c) |}.

Lemma add_correct_1 l c m:
   csat c m -> csat (add l c) m.
Proof.
  unfold csat, add; simpl.
  destruct 1 as [x H].
  constructor 1 with (x:=x).
  destruct (is_pos l); destruct (m x); simpl; try rewrite add_spec; intuition.
Qed.

Lemma add_correct_2 l c m:
   (m (ident l))=(is_pos l) -> csat (add l c) m.
Proof.
  unfold csat, add; intro H; rewrite <- H.
  constructor 1 with (x:=ident l).
  destruct (m (ident l)); simpl; try rewrite add_spec; intuition.
Qed.

Definition top: cclause :=
  add {| is_pos:= true; ident := xH |} (add {| is_pos:= false; ident := xH |} empty).

Local Hint Resolve add_correct_1 add_correct_2.

Lemma top_correct m: csat top m.
Proof.
  unfold top; assert (H: exists b, m xH = b); try eauto.
  destruct H as [b H]; destruct b; eauto.
Qed.

Fixpoint mkClauseRec (c: clause) (acc: cclause): cclause :=
  match c with
  | nil => acc
  | l::c' => mkClauseRec c' (add l acc)
  end.

Lemma mkClauseRec_correct c:
  forall acc m, sat c m \/ csat acc m -> csat (mkClauseRec c acc) m.
Proof.
  unfold sat; induction c; simpl; intuition auto.
Qed.

Definition mkClause c := mkClauseRec c empty.

Lemma mkClause_correct c m: sat c m -> csat (mkClause c) m.
Proof.
  intros; apply mkClauseRec_correct; intuition.
Qed.

Local Hint Resolve mkClause_correct.

Lemma sat_odef_1 l c (m: model):
  m (ident l) = is_pos l -> List.In l c -> sat c m.
Proof.
  intro H; induction c; simpl; intuition (subst; auto).
Qed.

Local Hint Resolve sat_odef_1.

Lemma sat_odef_2 c m:
  sat c m -> exists l, List.In l c /\ m (ident l) = is_pos l.
Proof.
  intro H; induction c; simpl in * |-; intuition.
  + eapply ex_intro; intuition (simpl; eauto).
  + destruct H as [l [H H1]]; eapply ex_intro; intuition (simpl; eauto).
Qed.

Definition In (l: literal) (c: cclause): Prop :=
  if is_pos l then In (ident l) (pos c) else In (ident l) (neg c).

Lemma csat_odef_1 l c (m: model):
  m (ident l) = is_pos l -> In l c -> csat c m.
Proof.
  intro H; unfold In; rewrite <- H.
  intros; constructor 1 with (x:=ident l); auto.
Qed.

Local Hint Resolve csat_odef_1.

Lemma csat_odef_2 c m:
  csat c m -> exists l, In l c /\ m (ident l) = is_pos l.
Proof.
  intro H; destruct H as [x H].
  unfold In.
  constructor 1 with (x:={| ident := x; is_pos := m x |}). simpl.
  intuition.
Qed.

Lemma not_csat c m: csat c m -> (forall l, ~In l c) -> False.
Proof.
  intros H H0.
  destruct (csat_odef_2 c m H) as [l H1].
  firstorder.
Qed.

Definition xsClause b s := List.map (fun x => {| is_pos := b; ident := x |}) (elements s).

Definition xClause c := (xsClause true (pos c)) ++ (xsClause false (neg c)).

Require Import SetoidList.

Lemma xClause_correct_In_1 c l: In l c -> List.In l (xClause c).
Proof.
  unfold xClause. intros H.
  apply List.in_or_app.
  unfold xsClause. unfold In in H.
  destruct l as [b x]; simpl in * |-.
  destruct b; (
  rewrite <- elements_spec1 in H;
  rewrite InA_alt in H;
  destruct H as [y [H H0]]; rewrite <- H in H0; clear y H);
  [ constructor 1 | constructor 2 ]; apply List.in_map; auto.
Qed.

Local Hint Resolve E.eq_equiv.

Lemma xClause_correct_In_2 c l: List.In l (xClause c) -> In l c.
Proof.
  unfold xClause, xsClause. intros H.
  destruct (List.in_app_or _ _ _ H) as [H0 | H0]; clear H;
  rewrite in_map_iff in H0;
  destruct H0 as [x [H1 H2]]; unfold In; subst; simpl;
  rewrite <- elements_spec1;
  apply In_InA; auto.
Qed.
Local Hint Resolve xClause_correct_In_2 xClause_correct_In_1.

Lemma csat_dec: forall c m, (csat c m) \/ ~(csat c m).
Proof.
  intros c m; generalize (sat_bool_spec (xClause c) m).
  destruct (sat_bool (xClause c) m).
  + constructor 1.
   destruct (sat_odef_2 _ _ H) as [l [H1 H2]].
    eauto.
  + constructor 2.
    intro X.
    destruct (csat_odef_2 _ _ X) as [l [X1 X2]].
    intuition eauto.
Qed.

Local Open Scope impure_scope.

(* computes the "pseudo-cardinal" of a set
  - return false, if the set is empty
  - return true, if the set has one elementUnsatProverLib.v
  - fails, otherwise.

NB: the set is assumed to be canonical (all empty subtrees are only Leaf nodes).
*)

Definition pcard_msg : pstring := "Rup.pcard".

Fixpoint pcard (s: PositiveSet.t): ?? bool :=
 match s with
 | Leaf => RET false
 | Node Leaf true Leaf => RET true
 | Node Leaf false r => pcard r
 | Node l false Leaf => pcard l
 | _ => FAILWITH pcard_msg
 end.

Local Ltac mysimpl := simpl in * |- *; wlp_simplify; subst; congruence || eauto.
Local Hint Resolve f_equal.

Lemma pcard_correct s: WHEN pcard s ~> b THEN
   if b then
      exists x, PositiveSet.In x s /\ forall x', PositiveSet.In x' s -> x' = x
   else
      forall x, ~PositiveSet.In x s.
Proof.
  unfold PositiveSet.In; induction s as [| l Hl b r Hr].
  - mysimpl.
  - generalize Hl, Hr; clear Hl Hr.
    refine (match l, b, r with
            | Leaf, true, Leaf => _
            | Leaf, false, r' => _
            | l', false, Leaf => _
            | _, _, _ => _
            end); mysimpl.
  + constructor 1 with (x:=1); intuition.
    destruct x'; congruence || auto.
  + destruct exta.
    * destruct H as [x H].
      constructor 1 with (x:=x~1); intuition.
      destruct x'; congruence || auto.
    * destruct x; congruence.
  + destruct exta.
    * destruct H as [x H].
      constructor 1 with (x:=x~0); intuition.
      destruct x'; congruence || auto.
    * destruct x; congruence || eauto.
Qed.
Global Opaque pcard.
Local Hint Resolve pcard_correct: wlp.

Definition cpcard_msg : string := "Rup.cpcard".

Definition cpcard (c: cclause): ?? bool :=
  DO p <~ pcard (pos c);;
  DO n <~ pcard (neg c);;
  match p, n with
  | false, false => RET false
  | true, true => FAILWITH cpcard_msg
  | _, _ => RET true
  end.

Lemma cpcard_correct_aux c: WHEN cpcard c ~> b THEN
   if b then exists l, In l c /\ forall l', In l' c -> l' = l
        else forall m, ~csat c m.
Proof.
  unfold In, cpcard; wlp_simplify.
  * destruct H as [x H].
    constructor 1 with (x:={| is_pos:=true; ident:= x|}); simpl.
    intuition.
    destruct l' as [ b l']; simpl in * |- *. destruct b; firstorder.
  * destruct H0 as [x H0].
    constructor 1 with (x:={| is_pos:=false; ident:= x|}); simpl.
    intuition.
    destruct l' as [ b l']; simpl in * |- *. destruct b; firstorder.
  * eapply not_csat; eauto.
    unfold In. intro l; destruct (is_pos l); firstorder.
Qed.
Global Opaque cpcard.

Definition swap c :=
   {| pos := neg c; neg := pos c |}.

Extraction Inline swap.

Definition negl (l: literal): literal :=
  {| is_pos := negb (is_pos l); ident := ident l |}.

Lemma cpcard_swap0 c l l': In l c -> In l' (swap c) ->
   WHEN cpcard c ~> b THEN b = true -> negl l' = l.
Proof.
  intros; generalize (cpcard_correct_aux c); mysimpl.
  destruct H2 as [l0 H2]. intuition.
  assert (X: l=l0). auto. subst.
  apply H4.
  clear H4 H3 H1; unfold swap, negl, In in * |- *.
  simpl in * |- *.
  destruct (is_pos l'); auto.
Qed.

Lemma cpcard_correct c: WHEN cpcard c ~> b THEN
  if b then
     forall m, (csat c m) -> ~(csat (swap c) m)
  else
     forall m, ~(csat c m).
Proof.
  intros b; destruct b; intro H1.
  + intros m H; destruct (csat_odef_2 _ _ H) as [l H0]; clear H. destruct H0 as [H H0].
  intro H'. destruct (csat_odef_2 _ _ H') as [l' H2]; clear H'.
  destruct H2 as [H3 H4].
  destruct (cpcard_swap0 _ _ _ H H3 _ H1); intuition.
  unfold negl in * |-; subst. simpl in * |-.
  rewrite H0 in H4. destruct (is_pos l'); simpl in * |-; discriminate.
 + intros m H; destruct (cpcard_correct_aux _ _ H1 m). auto.
Qed.

Local Hint Resolve cpcard_correct: wlp.

Definition diff c1 c2 :=
    {| pos := diff (pos c1) (pos c2);
       neg := diff (neg c1) (neg c2)
     |}.

Lemma diff_In c1 c2 l: In l c1 -> ~(In l c2) -> In l (diff c1 c2).
Proof.
  unfold diff, In.
  destruct (is_pos l); simpl; try rewrite diff_spec; auto.
Qed.

Lemma diff_csat c1 c2 m: csat c1 m -> ~(csat c2 m) -> csat (diff c1 c2) m.
Proof.
  intros H1 H2; destruct (csat_odef_2 c1 m H1) as [l H]. intuition.
  eapply csat_odef_1; eauto.
  eapply diff_In; eauto.
Qed.

Definition union c1 c2 :=
    {| pos := union (pos c1) (pos c2);
       neg := union (neg c1) (neg c2)
     |}.

Lemma union_In c1 c2 l: In l (union c1 c2) -> In l c1 \/ In l c2.
Proof.
  unfold union, In.
  destruct (is_pos l); simpl; try rewrite union_spec; intuition.
Qed.

Lemma union_ncsat c1 c2 m: ~(csat c1 m) -> ~(csat c2 m) -> ~(csat (union c1 c2) m).
Proof.
  intros H1 H2 H3; destruct (csat_odef_2 _ _ H3) as [l H]; clear H3.
  generalize (union_In c1 c2 l); intuition eauto.
Qed.

Local Open Scope list_scope.

(* implementation of "witness" clauses *)

Record wclause {mod: model -> Prop}: Type := {
  id: clause_id;
  rep: cclause ;
  rep_sat: forall m, mod m -> csat rep m
}.
Arguments wclause: clear implicits.

Definition rup_msg :string := "Rup.rup_checker".

(* checking of "Backward Resolution Chains" *)
Fixpoint brc_check {mod: model -> Prop} (f: list (wclause mod)) (c: cclause): ?? unit :=
  match f with
  | nil => FAILWITH "Rup.rup_checker"
  | c'::f' =>
    let c0 := diff (rep c') c in
    DO b <~ cpcard c0 ;;
    if b then
      brc_check f' (union c (swap c0))
    else
      RET tt
 end.

Local Hint Resolve diff_csat rep_sat.

Lemma brc_check_correct_aux mod (f:list (wclause mod)) m: forall c, mod m -> WHEN brc_check f c ~> _ THEN ~~(csat c m).
Proof.
  induction f as [| c' f' IHf']; mysimpl.
  apply H1.
  eapply union_ncsat; eauto.
Qed.
Global Opaque brc_check.

Section brc_check_correct.

Local Hint Resolve brc_check_correct_aux: wlp.

Lemma csat_double_neg c m: ~~(csat c m) -> csat c m.
Proof.
  case (csat_dec c m); intuition.
Qed.

Local Hint Resolve csat_double_neg.

Lemma brc_check_correct mod (f:list (wclause mod)) c m: mod m -> WHEN brc_check f c ~> _ THEN csat c m.
Proof.
  mysimpl.
Qed.

End brc_check_correct.

(* rup learning *)
Program Definition learn {mod: model -> Prop} (f: list (wclause mod)) (cid: clause_id) (c: cclause) : ?? wclause mod
 := mk_annot (brc_check f c);; RET {| id:= cid; rep := c |}.
Obligation 1.
  eapply brc_check_correct; eauto.
Qed.

Record rupLCF {C} := {
  rup_learn: (list C) -> clause_id -> cclause -> ?? C;
  get_id: C -> clause_id
}.
Arguments rupLCF: clear implicits.

(*
(* This part was used for a RUP-only checker. This needs to be generalized for the RAT-checker *)
Definition destruct_lid (lid: list clause_id) : clause_id * list clause_id :=
  match lid with
  | nil => (default_clause_id, nil)
  | cid::lid' => (cid, lid')
  end.

(* initial list of wclauses *)
Program Fixpoint mkInit_r (f: cnf) (lid: list clause_id) (mod: model -> Prop | forall m, mod m -> sats f m) (acc: list (wclause mod))
  : list (wclause mod) :=
  match f with
  | nil => acc
  | c::f' =>
     let (cid, lid') := destruct_lid lid in
     mkInit_r f' lid' mod ({| id:=cid; rep := mkClause c |}::acc)
  end.
Obligation 1.
   simpl in * |- *. firstorder.
Qed.
Obligation 2.
  simpl in * |- *. firstorder.
Qed.

Program Definition mkInit (f: cnf) (lid: list clause_id): list (wclause (sats f)) := mkInit_r f lid (sats f) nil.
Global Opaque mkInit_obligation_1.

Local Hint Resolve rep_sat.
Global Opaque rep_sat.

(* input for the solver *)
Definition mkInput (f: cnf) (lid: list clause_id): (rupLCF (wclause (sats f))) * (list (wclause (sats f))) :=
  ({| rup_learn := learn (mod:=(sats f));
      get_id := id |}, (mkInit f lid)).

Lemma certifies_unsat (f : cnf) (c: wclause (sats f)): isEmpty (rep c) = true -> isUnsat f.
Proof.
  intros; apply isUnsat_proof; generalize (isEmpty_correct (rep c)). intuition eauto.
Qed.
*)


Require Export
  Ty
  Exp
  Sub
  Sem
  Eval
  Norm
  Coq.micromega.Lia.

From Equations Require Import Equations.
Set Equations With UIP.

Generalizable All Variables.

Import ListNotations.

Section CEK.

Inductive Closed : Ty → Type :=
  | Closure {Γ u} : Exp Γ u → Env Γ → Closed u
  | Clapp {u v} : Closed (u ⟶ v) → Closed u → Closed v
  | Clif {u} : Closed TyBool → Closed u → Closed u → Closed u
  | Clpair {u v} : Closed u → Closed v → Closed (TyPair u v)
  | Clfst {u v} : Closed (TyPair u v) → Closed u
  | Clsnd {u v} : Closed (TyPair u v) → Closed v
  | Clseq {u v} : Closed u → Closed v → Closed v
  | Cllet {u v} : Closed u → Closed (u ⟶ v) → Closed v

with Env : Env → Type :=
  | Nil : Env []
  | Add {Γ u} : Closed u → Env Γ → Env (u :: Γ).

Derive Signature NoConfusion for Closed.
Derive Signature NoConfusion for Env.

Notation "c ∙ e" := (Add c e) (at level 50).

Inductive Redex : Ty → Type :=
  | Return {τ} : Value τ → Redex τ
  | Branch {Γ τ} : Exp Γ TyBool → Exp Γ τ → Exp Γ τ → Env Γ → Redex τ
  | MkPair {Γ τ1 τ2} : Exp Γ τ1 → Exp Γ τ2 → Env Γ → Redex (TyPair τ1 τ2)
  | GetFst {Γ τ1 τ2} : Exp Γ (TyPair τ1 τ2) → Env Γ → Redex τ1
  | GetSnd {Γ τ1 τ2} : Exp Γ (TyPair τ1 τ2) → Env Γ → Redex τ2
  | Progn {Γ τ1 τ2} : Exp Γ τ1 → Exp Γ τ2 → Env Γ → Redex τ2
  | Bind {Γ τ ty} : Exp Γ ty → Exp (ty :: Γ) τ → Env Γ → Redex τ
  | Lookup {Γ τ} : Var Γ τ → Env Γ → Redex τ
  | App {Γ dom cod} : Exp Γ (dom ⟶ cod) → Exp Γ dom → Env Γ → Redex cod
  | Beta {Γ dom cod} : Exp (dom :: Γ) cod → Env Γ → Value dom → Redex cod

with Value : Ty → Type :=
  | Val {τ} (c : Closed τ) : IsValue c → Value τ

with IsValue : ∀ {τ}, Closed τ → Prop :=
  | IsVal {Γ τ} {e : Exp Γ τ} {ρ} : ValueP e → IsValue (Closure e ρ).

Derive Signature NoConfusion Subterm for Redex.
Derive Signature NoConfusion Subterm for Value.

Equations lookup `(se : Env Γ) `(v : Var Γ τ) : Closed τ :=
  lookup (Add x _)   ZV    := x;
  lookup (Add _ xs) (SV v) := lookup xs v.

Equations contract {u} (r : Redex u) : Closed u :=
  contract (Return (Val v _))        := v;
  contract (Branch b t e env)        := Clif (Closure b env) (Closure t env) (Closure e env);
  contract (MkPair x y env)          := Clpair (Closure x env) (Closure y env);
  contract (GetFst p env)            := Clfst (Closure p env);
  contract (GetSnd p env)            := Clsnd (Closure p env);
  contract (Progn e1 e2 env)         := Clseq (Closure e1 env) (Closure e2 env);
  contract (Bind x body env)         := Cllet (Closure x env) (Closure (LAM body) env);
  contract (Lookup i env)            := lookup env i;
  contract (App f x env)             := Clapp (Closure f env) (Closure x env);
  contract (Beta body env (Val c _)) := Closure body (c ∙ env).

Inductive EvalContext : Ty → Ty → Type :=
  | MT {u} : EvalContext u u
  | ARG {u v w} : Closed u → EvalContext v w → EvalContext (u ⟶ v) w
  | FN {Γ a b c} : Exp (a :: Γ) b → Env Γ → EvalContext b c → EvalContext a c.

Derive Signature NoConfusion for EvalContext.

Equations plug {u v} (c : EvalContext u v) (t : Closed u) : Closed v :=
  plug MT f             := f;
  plug (ARG x ctx) f    := plug ctx (Clapp f x);
  plug (FN f env ctx) x := plug ctx (Clapp (Closure (LAM f) env) x).

Equations fromRedex {u} (r : Redex u) : Closed u :=
  fromRedex (Return (Val v _))        := v;
  fromRedex (Branch b t e env)        := Closure (If b t e) env;
  fromRedex (MkPair x y env)          := Closure (Pair x y) env;
  fromRedex (GetFst p env)            := Closure (Fst p) env;
  fromRedex (GetSnd p env)            := Closure (Snd p) env;
  fromRedex (Progn e1 e2 env)         := Closure (Seq e1 e2) env;
  fromRedex (Bind x body env)         := Closure (Let x body) env;
  fromRedex (Lookup x env)            := Closure (VAR x) env;
  fromRedex (App f arg env)           := Closure (APP f arg) env;
  fromRedex (Beta body env (Val c _)) := Clapp (Closure (LAM body) env) c.

Inductive Decomposition : ∀ {u}, Closed u → Type :=
  | DVal {Γ u v} (body : Exp (u :: Γ) v) (env : Env Γ) :
    Decomposition (Closure (LAM body) env)
  | RedexxContext {u v} (r : Redex u) (ctx : EvalContext u v) :
    Decomposition (plug ctx (fromRedex r)).

Equations decompose' {u v} (ctx : EvalContext u v) (c : Closed u) :
  Decomposition (plug ctx c) := {
  decompose' ctx (Closure (Constant x) env) :=
    RedexxContext (Return (Val (Closure (Constant x) env) _)) ctx;

  decompose' ctx (Closure EUnit env)  :=
    RedexxContext (Return (Val (Closure EUnit env) _)) ctx;
  decompose' ctx (Closure ETrue env)  :=
    RedexxContext (Return (Val (Closure ETrue env) _)) ctx;
  decompose' ctx (Closure EFalse env) :=
    RedexxContext (Return (Val (Closure EFalse env) _)) ctx;

  decompose' ctx (Closure (If b t e) env) :=
    RedexxContext (Branch b t e env) ctx;

  decompose' ctx (Closure (Pair x y) env) :=
    RedexxContext (MkPair x y env) ctx;
  decompose' ctx (Closure (Fst p) env)    :=
    RedexxContext (GetFst p env) ctx;
  decompose' ctx (Closure (Snd p) env)    :=
    RedexxContext (GetSnd p env) ctx;

  decompose' ctx (Closure (Seq e1 e2) env) :=
    RedexxContext (Progn e1 e2 env) ctx;

  decompose' ctx (Closure (Let x body) env) :=
    RedexxContext (Bind x body env) ctx;

  decompose' ctx (Closure (VAR i) env) :=
    RedexxContext (Lookup i env) ctx;
  decompose' ctx (Closure (LAM body) env) :=
    decompose'_aux ctx body env;
  decompose' ctx (Closure (APP f x) env) :=
    RedexxContext (App f x env) ctx;

  decompose' ctx (Clapp f x) :=
    decompose' (ARG x ctx) f;

  decompose' ctx (Clif t b e) := _;
  decompose' ctx (Clpair x y) := _;
  decompose' ctx (Clfst p) :=  _;
  decompose' ctx (Clsnd p) := _;
  decompose' ctx (Clseq e1 e2) := _;
  decompose' ctx (Cllet x body) := _
}

where decompose'_aux {a b w Γ}
     (ctx : EvalContext (a ⟶ b) w)
     (body : a :: Γ ⊢ b)
     (env : Env Γ) :
  Decomposition (plug ctx (Closure (LAM body) env)) := {
  decompose'_aux MT body env := DVal body env;
  decompose'_aux (ARG arg ctx) body env :=
    decompose' (FN body env ctx) arg;
  decompose'_aux (FN x env2 ctx) body env :=
    RedexxContext (Beta x env2 (Val (Closure (LAM body) env) _)) ctx
}.

Definition decompose {u} (c : Closed u) : Decomposition c :=
  decompose' MT c.

Equations headReduce {u} (c : Closed u) : Closed u :=
  headReduce c with decompose c := {
      headReduce ?(Closure (λ body) env) (Val body env) :=
        Closure (LAM body) env;
      headReduce ?(plug ctx (fromRedex redex)) (Redex×Context redex ctx) :=
        plug ctx (contract redex)
  }.

End CEK.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
From Coq Require Import micromega.Lia.
From Coq Require Import Lists.List.
From Coq Require Import Reals.Reals.
Require Coq.derive.Derive.

Import ListNotations.

From ATL Require Import ATL Common Reshape Tactics LetLifting Div GenPushout
     CommonTactics Normalize.

Definition pipeline {X} `{TensorElem X}
           n (f : list X) :=
  tlet buf := GEN [ i < n ] f _[i] in
        GEN [ i < n ] (|[ 0 <=? i-1 ]| buf _[i-1]) <+> buf _[i].
Hint Unfold pipeline : examples.

Section Pipeline.
  Variables (f : list R) (n : Z) (m k : nat).
  Derive pipeline_sched SuchThat
         (consistent f (m,tt) ->
          (1 < n)%Z ->
          0 < k ->
          pipeline n f = pipeline_sched) As pipeline_correct.
  Proof.
    reschedule.

    inline let_binding.

    rw @get_gen_some.
    rw @get_gen_some.

    wrapid^ @flatten_trunc_tile_id around (GEN [ _ < _ ] _) with k.

    inline tile.

    rw<- @gp_iverson.
    rw @ll_get.
    rw @ll_iverson_.

    rw @get_gen_some.

    rw @lbind_helper for (fun x => |[ _ * Z.of_nat k + _ <? n]| x).

    rw @ll_gen.

    done.
  Qed.
End Pipeline.
Hint Unfold pipeline_sched : examples.

(* Breadth First
 * Compute and store every required point in blurx before evaluating any points
 * in out; lots of parallelism but little locality *)
Definition blurtwostage {X} `{TensorElem X}
           N M (v : list (list X)) : list (list X) :=
  tlet blurx' :=
    GEN [ y < Z.of_nat (N + 2) ]
        GEN [ x < Z.of_nat M ]
        (|[ (0<=?y-1) && (y-1<? Z.of_nat N) ]|
        (|[ 0 <=? x - 1 ]| v _[ y-1; x - 1]) <+>
        v _[ y-1; x] <+>
        (|[ x + 1 <? Z.of_nat M ]| v _[ y-1; x + 1]))
    in
      GEN [ y < Z.of_nat N ]
      GEN [ x < Z.of_nat M ]
      (blurx' _[ y; x] <+>
       blurx' _[ y+1; x] <+>
       blurx' _[ y+2; x]).
Hint Unfold blurtwostage : examples.

Section two_to_part.
  Variables (X : Set) (H : TensorElem X) (N M : nat)
            (v : list (list X)) (s : @shape X _).
  Derive blurtwostage_partition SuchThat
         (2 < M ->
          0 < N ->
      consistent v (N,(M,s)) ->
      blurtwostage N M v = blurtwostage_partition) As twostagepart.
  Proof.
    reschedule.

    rw^ Nat2Z.inj_add. simpl.

    rw^ @split_gen upto (Z.of_nat N + 2)%Z at 1%Z.

    rw^ @split_genr upto (Z.of_nat N + 2)%Z at (Z.of_nat N + 1)%Z.

    etransitivity.
    apply tlet_eq_bound.
    apply concat_eq_r.
    rw^ split_gen upto (Z.of_nat M) at 1%Z.
    rw^ @split_genr upto (Z.of_nat M) at (Z.of_nat M - 1)%Z.
    reflexivity.

    simpl_guard.

    done.
  Qed.
End two_to_part.
Hint Unfold blurtwostage_partition : examples.
(* Total Fusion
 * Compute each pixel independently to maximize locality but perform many
 * redundant computations *)

Definition blurimmediate_isolate {X} `{TensorElem X}
           n m (l : list (list X)) :=
    (GEN [ y < 1 ]
   GEN [ x2 < Z.of_nat m ]
   (|[ 0 <=? y - 1 ]| (|[ 0 <=? x2 - 1 ]| l _[ y - 1; x2 - 1]) <+> l _[ y - 1; x2] <+>
                      (|[ x2 + 1 <? Z.of_nat m ]| l _[ y - 1; x2 + 1])) <+>
   ((|[ 0 <=? x2 - 1 ]| l _[ y; x2 - 1]) <+> l _[ y; x2] <+>
    (|[ x2 + 1 <? Z.of_nat m ]| l _[ y; x2 + 1])) <+>
   ((|[ 0 <=? x2 - 1 ]| l _[ y + 1; x2 - 1]) <+> l _[ y + 1; x2] <+>
    (|[ x2 + 1 <? Z.of_nat m ]| l _[ y + 1; x2 + 1]))) <++>
  transpose
    (transpose
       (GEN [ 1 <= i < Z.of_nat (n - 1) ]
        GEN [ x2 < 1 ]
        (|[ 0 <=? x2 - 1 ]| l _[ i - 1; x2 - 1]) <+> l _[ i - 1; x2] <+>
        l _[ i - 1; x2 + 1] <+>
        ((|[ 0 <=? x2 - 1 ]| l _[ i; x2 - 1]) <+> l _[ i; x2] <+> l _[ i; x2 + 1]) <+>
        ((|[ 0 <=? x2 - 1 ]| l _[ i + 1; x2 - 1]) <+> l _[ i + 1; x2] <+>
         l _[ i + 1; x2 + 1])) <++>
     transpose
       (GEN [ 1 <= i < Z.of_nat (n - 1) ]
        GEN [ 1 <= x2 < Z.of_nat (m - 1) ]
        l _[ i - 1; x2 - 1] <+> l _[ i - 1; x2] <+> l _[ i - 1; x2 + 1] <+>
        (l _[ i; x2 - 1] <+> l _[ i; x2] <+> l _[ i; x2 + 1]) <+>
        (l _[ i + 1; x2 - 1] <+> l _[ i + 1; x2] <+> l _[ i + 1; x2 + 1])) <++>
     transpose
       (GEN [ 1 <= i < Z.of_nat (n - 1) ]
        GEN [ Z.of_nat m - 1 <= x2 < Z.of_nat m ]
        l _[ i - 1; x2 - 1] <+> l _[ i - 1; x2] <+>
        (|[ x2 + 1 <? Z.of_nat m ]| l _[ i - 1; x2 + 1]) <+>
        (l _[ i; x2 - 1] <+> l _[ i; x2] <+>
         (|[ x2 + 1 <? Z.of_nat m ]| l _[ i; x2 + 1])) <+>
        (l _[ i + 1; x2 - 1] <+> l _[ i + 1; x2]) <+>
        (|[ x2 + 1 <? Z.of_nat m ]| l _[ i + 1; x2 + 1]))) <++>
  (GEN [ Z.of_nat n - 1 <= y < Z.of_nat n ]
   GEN [ x2 < Z.of_nat m ]
   (|[ 0 <=? x2 - 1 ]| l _[ y - 1; x2 - 1]) <+> l _[ y - 1; x2] <+>
   (|[ x2 + 1 <? Z.of_nat m ]| l _[ y - 1; x2 + 1]) <+>
   ((|[ 0 <=? x2 - 1 ]| l _[ y; x2 - 1]) <+> l _[ y; x2] <+>
    (|[ x2 + 1 <? Z.of_nat m ]| l _[ y; x2 + 1])) <+>
   (|[ y + 1 <? Z.of_nat n ]| (|[ 0 <=? x2 - 1 ]| l _[ y + 1; x2 - 1]) <+>
                              l _[ y + 1; x2] <+>
                              (|[ x2 + 1 <? Z.of_nat m ]| l _[ y + 1; x2 + 1]))).
Hint Unfold blurimmediate_isolate : examples.

Definition blurimmediate_partition {X} `{TensorElem X}
           n m (v : list (list X)) : list (list X) :=
 (GEN [ y < 1 ]
      GEN [ x2 < Z.of_nat m ]
      (|[0<=?y-1]|
       ((|[0<=?x2-1]| v _[y-1;x2-1]) <+> v _[y-1;x2] <+> (|[x2+1<?Z.of_nat m]| v _[y-1;x2+1]))) <+>
 ((|[ 0 <=? x2 - 1 ]| v _[ y; x2 - 1]) <+> v _[ y; x2] <+>
  (|[ x2 + 1 <? Z.of_nat m ]| v _[ y; x2 + 1])) <+>
 ((|[ 0 <=? x2 - 1 ]| v _[ y + 1; x2 - 1]) <+> v _[ y + 1; x2] <+>
  (|[ x2 + 1 <? Z.of_nat m ]| v _[ y + 1; x2 + 1])))
<++>
(GEN [ 1 <= y < Z.of_nat (n - 1) ]

     (GEN [ x2 < 1 ]
      ((|[ 0<=?x2-1 ]| v _[y-1;x2-1]) <+> v _[ y - 1; x2]
         <+> (v _[ y - 1; x2 + 1]))
      <+> ((|[ 0<=?x2-1 ]| v _[y;x2-1]) <+> v _[ y; x2]
             <+> (v _[ y; x2 + 1])) <+>
      ((|[ 0<=?x2-1 ]| v _[y+1;x2-1]) <+> v _[ y + 1; x2]
         <+> (v _[ y + 1; x2 + 1])))
     <++>
      (GEN [ 1 <= x2 < Z.of_nat (m-1) ]
      ((v _[ y - 1; x2 - 1])
         <+> v _[ y - 1; x2]
         <+> (v _[ y - 1; x2 + 1]))
      <+> ((v _[ y; x2 - 1])
             <+> v _[ y; x2]
             <+> (v _[ y; x2 + 1])) <+>
      ((v _[ y + 1; x2 - 1])
         <+> v _[ y + 1; x2]
         <+> (v _[ y + 1; x2 + 1])))
      <++>
      (GEN [ Z.of_nat m - 1 <= x2 < Z.of_nat m ]
      ((v _[ y - 1; x2 - 1])
         <+> v _[ y - 1; x2] <+> (|[x2+1<?Z.of_nat m]| v _[y-1;x2+1]))
      <+> ((v _[ y; x2 - 1])
             <+> v _[ y; x2] <+> (|[x2+1<?Z.of_nat m]| v _[y;x2+1])) <+>
      ((v _[ y + 1; x2 - 1])
         <+> v _[ y + 1; x2]) <+> (|[x2+1<?Z.of_nat m]| v _[y+1;x2+1]))

)
<++>
(GEN [ Z.of_nat n - 1 <= y < Z.of_nat n ]
 GEN [ x2 < Z.of_nat m ]
 (|[ 0 <=? x2 - 1 ]| v _[ y - 1; x2 - 1]) <+> v _[ y - 1; x2] <+>
 (|[ x2 + 1 <? Z.of_nat m ]| v _[ y - 1; x2 + 1]) <+>
 ((|[ 0 <=? x2 - 1 ]| v _[ y; x2 - 1]) <+> v _[ y; x2] <+>
  (|[ x2 + 1 <? Z.of_nat m ]| v _[ y; x2 + 1])) <+>
(|[y+1<?Z.of_nat n]|
       ((|[0<=?x2-1]| v _[y+1;x2-1]) <+> v _[y+1;x2] <+> (|[x2+1<?Z.of_nat m]| v _[y+1;x2+1]))))
 .
Hint Unfold blurimmediate_partition : examples.

Definition fusion_no_boundary {X} `{TensorElem X}
  n m v :=
  GEN [ 1 <= i < Z.of_nat (n - 1) ]
  GEN [ 1 <= x2 < Z.of_nat (m - 1) ]
  v _[ i - 1; x2 - 1] <+> v _[ i - 1; x2] <+>
  v _[ i - 1; x2 + 1] <+>
  (v _[ i; x2 - 1] <+> v _[ i; x2] <+>
   v _[ i; x2 + 1]) <+>
  (v _[ i + 1; x2 - 1] <+> v _[ i + 1; x2] <+>
     v _[ i + 1; x2 + 1]).
Hint Unfold fusion_no_boundary : examples.

Definition tile_no_boundary {X} `{TensorElem X}
           n_k m_k n m l :=
  flatten_trunc (n - 1 - 1)
    ((GEN [ i < (Z.of_nat (n - 1) - 1) / Z.of_nat n_k ]
      transpose
        (flatten_trunc (m - 1 - 1)
           ((GEN [ i0 < Z.of_nat (m - 1 - 1) / Z.of_nat m_k ]
             (tlet x2
              := GEN [ i1 < Z.of_nat (n_k + 2) ]
              GEN [ i2 < Z.of_nat m_k ]
              l _[ i * Z.of_nat n_k + i1; i0 * Z.of_nat m_k + i2] <+>
              l _[ i * Z.of_nat n_k + i1; i0 * Z.of_nat m_k + i2 + 1] <+>
              l _[ i * Z.of_nat n_k + i1; i0 * Z.of_nat m_k + i2 + 2]
              in transpose
                   (GEN [ i1 < Z.of_nat n_k ]
                    GEN [ i2 < Z.of_nat m_k ]
                    x2 _[ i1; i2] <+> x2 _[ i1 + 1; i2] <+> x2 _[ i1 + 2; i2]))) <++>
            (GEN [ Z.of_nat (m - 1 - 1) / Z.of_nat m_k <= i0 <
              Z.of_nat (m - 1 - 1) / Z.of_nat m_k +
              (Z.of_nat (m - 1 - 1) mod Z.of_nat m_k) // (Z.of_nat m_k) ]
             GEN [ i1 < Z.of_nat m_k ]
             GEN [ n' < Z.of_nat n_k ]
             (|[ i0 * Z.of_nat m_k + i1 <? Z.of_nat (m - 1 - 1) ]|
               (|[ i * Z.of_nat n_k + n' <? Z.of_nat (n - 1) - 1 ]|
                 l _[ 1 + (i * Z.of_nat n_k + n') - 1;
                 1 + (i0 * Z.of_nat m_k + i1) - 1] <+>
                 l _[ 1 + (i * Z.of_nat n_k + n') - 1; 1 + (i0 * Z.of_nat m_k + i1)] <+>
                 l _[ 1 + (i * Z.of_nat n_k + n') - 1;
                 1 + (i0 * Z.of_nat m_k + i1) + 1] <+>
                 (l _[ 1 + (i * Z.of_nat n_k + n');
                  1 + (i0 * Z.of_nat m_k + i1) - 1] <+>
                  l _[ 1 + (i * Z.of_nat n_k + n'); 1 + (i0 * Z.of_nat m_k + i1)] <+>
                  l _[ 1 + (i * Z.of_nat n_k + n');
                  1 + (i0 * Z.of_nat m_k + i1) + 1]) <+>
                 (l _[ 1 + (i * Z.of_nat n_k + n') + 1;
                  1 + (i0 * Z.of_nat m_k + i1) - 1] <+>
                  l _[ 1 + (i * Z.of_nat n_k + n') + 1;
                  1 + (i0 * Z.of_nat m_k + i1)] <+>
                  l _[ 1 + (i * Z.of_nat n_k + n') + 1;
                  1 + (i0 * Z.of_nat m_k + i1) + 1]))))))) <++>
     (GEN [ (Z.of_nat (n - 1) - 1) / Z.of_nat n_k <= i <
       (Z.of_nat (n - 1) - 1) / Z.of_nat n_k +
       ((Z.of_nat (n - 1) - 1) mod Z.of_nat n_k) // (Z.of_nat n_k) ]
      transpose
        (flatten_trunc (m - 1 - 1)
           (GEN [ i0 < Z.of_nat (m - 1 - 1) / Z.of_nat m_k +
                       (Z.of_nat (m - 1 - 1) mod Z.of_nat m_k) // (Z.of_nat m_k) ]
            GEN [ i1 < Z.of_nat m_k ]
            GEN [ n' < Z.of_nat n_k ]
            (|[ i0 * Z.of_nat m_k + i1 <? Z.of_nat (m - 1 - 1) ]|
              (|[ i * Z.of_nat n_k + n' <? Z.of_nat (n - 1) - 1 ]|
                l _[ 1 + (i * Z.of_nat n_k + n') - 1;
                1 + (i0 * Z.of_nat m_k + i1) - 1] <+>
                l _[ 1 + (i * Z.of_nat n_k + n') - 1; 1 + (i0 * Z.of_nat m_k + i1)] <+>
                l _[ 1 + (i * Z.of_nat n_k + n') - 1;
                1 + (i0 * Z.of_nat m_k + i1) + 1] <+>
                (l _[ 1 + (i * Z.of_nat n_k + n'); 1 + (i0 * Z.of_nat m_k + i1) - 1] <+>
                 l _[ 1 + (i * Z.of_nat n_k + n'); 1 + (i0 * Z.of_nat m_k + i1)] <+>
                 l _[ 1 + (i * Z.of_nat n_k + n'); 1 + (i0 * Z.of_nat m_k + i1) + 1]) <+>
                (l _[ 1 + (i * Z.of_nat n_k + n') + 1;
                 1 + (i0 * Z.of_nat m_k + i1) - 1] <+>
                 l _[ 1 + (i * Z.of_nat n_k + n') + 1; 1 + (i0 * Z.of_nat m_k + i1)] <+>
                 l _[ 1 + (i * Z.of_nat n_k + n') + 1;
                        1 + (i0 * Z.of_nat m_k + i1) + 1]))))))).
Hint Unfold tile_no_boundary : examples.

Section total_tiled.
  Variables (X : Set) (H : TensorElem X)
            (v : list (list X)) (s : @shape X _) (n m n_k m_k : nat).
  Derive blur_tiles_guarded SuchThat
      (2 < n ->
      2 < m ->
      1 < n_k ->
      1 < m_k ->
      consistent v (n,(m,s)) ->
      blurimmediate_partition n m v = blur_tiles_guarded) As total_tiled.
  Proof.
    reschedule.

    wrapid^ @transpose_transpose_id around
                                    (GEN [ 1 <= _ < (Z.of_nat (n-1)) ] _).
    rw @distrib_gen_concat.
    rw @distrib_gen_concat.

    wrapid @flatten_trunc_tile_id around
           (GEN [ _ <= _ < Z.of_nat (n-1) ] GEN [ 1 <= _ < Z.of_nat (m-1)] _)
      with n_k.

    rw^ Z2Nat.inj_sub.
    rewrite Nat2Z.id.
    replace (Z.to_nat 1) with 1 by reflexivity.

    inline tile.
    rw @get_genr_some.
    rw @gp_genr_iverson.
    wrapid @transpose_transpose_id around (GEN [ _ < Z.of_nat n_k ] _).
    rw @unfold_inner_transpose.
    rw^ @consistent_length.
    rw^ Z2Nat.inj_sub.
    rewrite Nat2Z.id.
    replace (Z.to_nat 1) with 1 by reflexivity.
    rw @get_gen_some.
    rw @get_genr_some.
    wrapid @flatten_trunc_tile_id around (GEN [ _ < Z.of_nat (m -1 -1)] _)
      with m_k.
    inline tile.
    rw @get_gen_some.
    rw^ @gp_gen_iverson.

    repeat rw^ (Z.add_comm 1%Z).
    repeat rw^ Z.add_simpl_r.
    remember ((x1::xs1)::xs) as l.

    rw^ ceil_floor_mod.
    rw^ (ceil_floor_mod (Z.of_nat (m-1-1))).

    rw^ @split_gen_plus.
    rw^ @split_gen_plus.

    simpl_guard.
    simpl_guard.

    rw @lbind_helper for
       (fun x =>
          x
            <+> ((_ _[_*Z.of_nat n_k + _ +1; _*Z.of_nat m_k + _]) <+> _ <+> _)
            <+> _).
    rw @ll_gen.
    rw @ll_gen.

    wrapid^ @transpose_transpose_id around (GEN [ _ < Z.of_nat m_k ] _).
    rw^ @tlet_f_bound_body.
    rw unfold_transpose around (GEN [ _ < _ ] _).
    rw @get_gen_some.
    rw @get_gen_some.
    rw @transpose_get_get.

    wrapid^ @trunc_r_pad_r_id around (GEN [ _ < Z.of_nat n_k ] _)
      with 2.
    rw^ @tlet_f_bound_body.
    inline pad_r.
    rw^ @get_gen_some.
    inline trunc_r.
    rw @get_gen_some.
    rw @lbind_helper for (fun x => |[ _ <? Z.of_nat n_k ]| x).
    rw @ll_gen.
    rw @let_let_flip.
    rw @get_gen_some.
    rw @gp_iverson.

    rw @lbind_helper for
       (fun x  => (|[ _ <? Z.of_nat n_k]| _)
                    <+> x
                    <+> (_ <+> _ <+> _)).
    rw @ll_gen.
    rw @ll_gen.
    wrapid^ @transpose_transpose_id around
                                    (GEN [ _ < Z.of_nat m_k ] GEN [ _ < _ ] _).
    rw^ @tlet_f_bound_body.
    rw unfold_transpose around (GEN [ _ < _ ] _).
    rw @get_gen_some.
    rw @get_gen_some.
    rw @transpose_get_get.

    wrapid^ @trunc_l_pad_l_id around
                              (GEN [ _ < Z.of_nat n_k]
                                   GEN [ _ < Z.of_nat m_k ] _) with 1.
    rw^ @tlet_f_bound_body.
    inline pad_l.
    rw^ @get_gen_some.
    inline trunc_l.
    rw minus_plus.
    rw @get_gen_some. simpl.
    rw^ Z.add_sub_assoc.
    rw^ Zplus_minus.
    rw^ Z.sub_add.

    wrapid @trunc_r_pad_r_id around (GEN [ _ < Z.of_nat (n_k+1) ]
                                    |[ 1 <=? _ ]| GEN [ _ < Z.of_nat m_k ] _)
      with 1.
    rw^ @tlet_f_bound_body.
    inline pad_r.
    rw^ @get_gen_some.
    inline trunc_r.
    rw @get_gen_some.
    rw^ @lbind_helper for (fun x => |[ 1 <=? _ ]| x).
    rw @ll_iverson_.
    rw @ll_gen.
    rw @let_let_flip.
    rewrite <- Nat.add_assoc. simpl.
    rw^ Z.sub_add.
    rw^ @let_let_same.
    rw @get_gen_some.
    rw @gp_iverson.
    rw @lbind_helper for
       (fun x => (|[ _ ]| _)
                   <+> (|[ _ <? (Z.of_nat (n_k+1)) ]| _)
                   <+> x).
    rw @ll_gen.
    rw @ll_gen.
    wrapid^ @transpose_transpose_id around
                                    (GEN [ _ < Z.of_nat m_k ] _).
    rw^ @tlet_f_bound_body.
    rw unfold_transpose around (GEN [ _ < _ ] _).
    rw^ @get_gen_some.
    rw^ @get_gen_some.
    rw @transpose_get_get.

    repeat rw^<- (Zplus_assoc 1%Z 1%Z).
    simpl.
    rw^ @gen_trunc upto n_k at 2.
    rw^ @tlet_f_bound_body.
    rw^ Z.add_sub_assoc. simpl.
    rw^ Z.sub_add.
    inline trunc_l. simpl.
    rw @get_gen_some.
    rw minus_plus. simpl.
    rw^ @let_let_same.

    simpl_guard.
    simpl_guard.

    wrapid @transpose_transpose_id around (GEN [ _ < Z.of_nat m_k ] _).
    rw @unfold_inner_transpose.
    rw^ @consistent_length.
    rw @get_gen_some.
    rw @get_gen_some.

    done.
  Qed.
End total_tiled.
Hint Unfold blur_tiles_guarded : examples.

Section fuse_twostage.
  Variables (X : Set) (H : TensorElem X)
            (v : list (list X)) (m n k : nat) (s : @shape X _).
  Derive blurimmediate SuchThat
         (0 < k -> 0 < m -> 0 < n -> consistent v (n,(m,s)) ->
          blurtwostage n m v = blurimmediate) As twostage_immediate.
  Proof.
    reschedule.

    inline let_binding.

    rw @get_gen_some.
    rw @get_gen_some.
    rw @get_gen_some.
    rw @get_gen_some.
    rw @get_gen_some.
    rw @get_gen_some.

    rw^ Z.add_simpl_r.
    rw^<- Z.add_sub_assoc.
    simpl.

    simpl_guard.

    done.
  Qed.
End fuse_twostage.
Hint Unfold blurimmediate : examples.

Arguments blur_tiles_guarded {X H}.
Arguments blurimmediate {X H}.
Arguments blurtwostage_partition {X H}.

Goal forall v n m n_k m_k,
    blur_tiles_guarded v n m n_k m_k =
(GEN [ i < 1 ]
 GEN [ i0 < Z.of_nat m ]
 (|[ 0 <=? i - 1 ]| v _[ i - 1; i0 - 1] <+> v _[ i - 1; i0] <+> v _[ i - 1; i0 + 1]) <+>
 ((|[ 0 <=? i0 - 1 ]| v _[ i; i0 - 1]) <+> v _[ i; i0] <+>
  (|[ i0 + 1 <? Z.of_nat m ]| v _[ i; i0 + 1])) <+>
 ((|[ 0 <=? i0 - 1 ]| v _[ i + 1; i0 - 1]) <+> v _[ i + 1; i0] <+>
  (|[ i0 + 1 <? Z.of_nat m ]| v _[ i + 1; i0 + 1]))) <++>
transpose
  (transpose
     (GEN [ 1 <= i < Z.of_nat (n - 1) ]
      GEN [ x2 < 1 ]
      (|[ 0 <=? x2 - 1 ]| v _[ i - 1; x2 - 1]) <+> v _[ i - 1; x2] <+>
      v _[ i - 1; x2 + 1] <+>
      ((|[ 0 <=? x2 - 1 ]| v _[ i; x2 - 1]) <+> v _[ i; x2] <+> v _[ i; x2 + 1]) <+>
      ((|[ 0 <=? x2 - 1 ]| v _[ i + 1; x2 - 1]) <+> v _[ i + 1; x2] <+>
       v _[ i + 1; x2 + 1])) <++>
   transpose
     (flatten_trunc (n - 1 - 1)
        ((GEN [ i < (Z.of_nat (n - 1) - 1) / Z.of_nat n_k ]
          transpose
            (flatten_trunc (m - 1 - 1)
               ((GEN [ i0 < Z.of_nat (m - 1 - 1) / Z.of_nat m_k ]
                 (tlet x2
                  := GEN [ i1 < Z.of_nat (n_k + 2) ]
                  GEN [ i2 < Z.of_nat m_k ]
                  v _[ i * Z.of_nat n_k + i1; i0 * Z.of_nat m_k + i2] <+>
                  v _[ i * Z.of_nat n_k + i1; i0 * Z.of_nat m_k + i2 + 1] <+>
                  v _[ i * Z.of_nat n_k + i1; i0 * Z.of_nat m_k + i2 + 2]
                  in transpose
                       (GEN [ i1 < Z.of_nat n_k ]
                        GEN [ i2 < Z.of_nat m_k ]
                        x2 _[ i1; i2] <+> x2 _[ i1 + 1; i2] <+> x2 _[ i1 + 2; i2]))) <++>
                (GEN [ Z.of_nat (m - 1 - 1) / Z.of_nat m_k <= i0 <
                  Z.of_nat (m - 1 - 1) / Z.of_nat m_k +
                  (Z.of_nat (m - 1 - 1) mod Z.of_nat m_k) // (Z.of_nat m_k) ]
                 GEN [ i1 < Z.of_nat m_k ]
                 GEN [ i2 < Z.of_nat n_k ]
                 (|[ i0 * Z.of_nat m_k + i1 <? Z.of_nat (m - 1 - 1) ]|
                   v _[ i * Z.of_nat n_k + i2; i0 * Z.of_nat m_k + i1] <+>
                   v _[ i * Z.of_nat n_k + i2; i0 * Z.of_nat m_k + i1 + 1] <+>
                   v _[ i * Z.of_nat n_k + i2; i0 * Z.of_nat m_k + i1 + 2] <+>
                   (v _[ i * Z.of_nat n_k + i2 + 1; i0 * Z.of_nat m_k + i1] <+>
                    v _[ i * Z.of_nat n_k + i2 + 1; i0 * Z.of_nat m_k + i1 + 1] <+>
                    v _[ i * Z.of_nat n_k + i2 + 1; i0 * Z.of_nat m_k + i1 + 2]) <+>
                   (v _[ i * Z.of_nat n_k + i2 + 2; i0 * Z.of_nat m_k + i1] <+>
                    v _[ i * Z.of_nat n_k + i2 + 2; i0 * Z.of_nat m_k + i1 + 1] <+>
                    v _[ i * Z.of_nat n_k + i2 + 2; i0 * Z.of_nat m_k + i1 + 2])))))) <++>
         (GEN [ (Z.of_nat (n - 1) - 1) / Z.of_nat n_k <= i <
           (Z.of_nat (n - 1) - 1) / Z.of_nat n_k +
           ((Z.of_nat (n - 1) - 1) mod Z.of_nat n_k) // (Z.of_nat n_k) ]
          transpose
            (flatten_trunc (m - 1 - 1)
               (GEN [ i0 < Z.of_nat (m - 1 - 1) / Z.of_nat m_k +
                           (Z.of_nat (m - 1 - 1) mod Z.of_nat m_k) // (Z.of_nat m_k) ]
                GEN [ i1 < Z.of_nat m_k ]
                GEN [ i2 < Z.of_nat n_k ]
                (|[ i0 * Z.of_nat m_k + i1 <? Z.of_nat (m - 1 - 1) ]|
                  (|[ i * Z.of_nat n_k + i2 <? Z.of_nat (n - 1) - 1 ]|
                    v _[ i * Z.of_nat n_k + i2; i0 * Z.of_nat m_k + i1] <+>
                    v _[ i * Z.of_nat n_k + i2; i0 * Z.of_nat m_k + i1 + 1] <+>
                    v _[ i * Z.of_nat n_k + i2; i0 * Z.of_nat m_k + i1 + 2] <+>
                    (v _[ i * Z.of_nat n_k + i2 + 1; i0 * Z.of_nat m_k + i1] <+>
                     v _[ i * Z.of_nat n_k + i2 + 1; i0 * Z.of_nat m_k + i1 + 1] <+>
                     v _[ i * Z.of_nat n_k + i2 + 1; i0 * Z.of_nat m_k + i1 + 2]) <+>
                    (v _[ i * Z.of_nat n_k + i2 + 2; i0 * Z.of_nat m_k + i1] <+>
                     v _[ i * Z.of_nat n_k + i2 + 2; i0 * Z.of_nat m_k + i1 + 1] <+>
                     v _[ i * Z.of_nat n_k + i2 + 2; i0 * Z.of_nat m_k + i1 + 2])))))))) <++>
   transpose
     (GEN [ 1 <= i < Z.of_nat (n - 1) ]
      GEN [ Z.of_nat m - 1 <= x2 < Z.of_nat m ]
      v _[ i - 1; x2 - 1] <+> v _[ i - 1; x2] <+>
      (|[ x2 + 1 <? Z.of_nat m ]| v _[ i - 1; x2 + 1]) <+>
      (v _[ i; x2 - 1] <+> v _[ i; x2] <+>
       (|[ x2 + 1 <? Z.of_nat m ]| v _[ i; x2 + 1])) <+>
      (v _[ i + 1; x2 - 1] <+> v _[ i + 1; x2]) <+>
      (|[ x2 + 1 <? Z.of_nat m ]| v _[ i + 1; x2 + 1]))) <++>
(GEN [ Z.of_nat n - 1 <= i < Z.of_nat n ]
 GEN [ i0 < Z.of_nat m ]
 (|[ 0 <=? i0 - 1 ]| v _[ i - 1; i0 - 1]) <+> v _[ i - 1; i0] <+>
 (|[ i0 + 1 <? Z.of_nat m ]| v _[ i - 1; i0 + 1]) <+>
 ((|[ 0 <=? i0 - 1 ]| v _[ i; i0 - 1]) <+> v _[ i; i0] <+>
  (|[ i0 + 1 <? Z.of_nat m ]| v _[ i; i0 + 1])) <+>
 (|[ i + 1 <? Z.of_nat n ]| v _[ i + 1; i0 - 1] <+> v _[ i + 1; i0] <+>
                            v _[ i + 1; i0 + 1])).
Proof. reflexivity. Qed.

Goal forall f n k, pipeline_sched f n k =
flatten_trunc (Z.to_nat n)
  (GEN [ i < n // (Z.of_nat k) ]
   (tlet x
    := GEN [ i0 < Z.of_nat k ]
    (|[ 0 <=? i * Z.of_nat k + i0 - 1 ]| f _[ i * Z.of_nat k + i0 - 1]) <+>
    f _[ i * Z.of_nat k + i0]
    in GEN [ n' < Z.of_nat k ]
           (|[ i * Z.of_nat k + n' <? n ]| x _[ n']))).
Proof. reflexivity. Qed.

Goal forall v m n,
    blurimmediate v m n =
    GEN [ i < Z.of_nat n ]
        GEN [ i0 < Z.of_nat m ]
        (|[ 0 <=? i - 1 ]|
         (|[ 0 <=? i0 - 1 ]| v _[ i - 1; i0 - 1]) <+> v _[ i - 1; i0] <+>
         (|[ i0 + 1 <? Z.of_nat m ]| v _[ i - 1; i0 + 1])) <+>
        ((|[ 0 <=? i0 - 1 ]| v _[ i; i0 - 1]) <+> v _[ i; i0] <+>
           (|[ i0 + 1 <? Z.of_nat m ]| v _[ i; i0 + 1])) <+>
        (|[ i + 1 <? Z.of_nat n ]|
         (|[ 0 <=? i0 - 1 ]| v _[ i + 1; i0 - 1]) <+>
                             v _[ i + 1; i0] <+>
                             (|[ i0 + 1 <? Z.of_nat m ]| v _[ i + 1; i0 + 1])).
Proof. reflexivity. Qed.

Goal forall v M N,
    blurtwostage_partition N M v =
tlet blurx'
:= (GEN [ i < 1 ]
    GEN [ i0 < Z.of_nat M ]
    (|[ 0 <=? i - 1 ]| v _[ i - 1; i0 - 1] <+> v _[ i - 1; i0] <+>
                       v _[ i - 1; i0 + 1])) <++>
   ((GEN [ 1 <= i < Z.of_nat N + 1 ]
     (GEN [ i0 < 1 ]
      (|[ 0 <=? i0 - 1 ]| v _[ i - 1; i0 - 1]) <+> v _[ i - 1; i0] <+>
      v _[ i - 1; i0 + 1]) <++>
     ((GEN [ 1 <= i0 < Z.of_nat M - 1 ]
       v _[ i - 1; i0 - 1] <+> v _[ i - 1; i0] <+> v _[ i - 1; i0 + 1]) <++>
      (GEN [ Z.of_nat M - 1 <= i0 < Z.of_nat M ]
       v _[ i - 1; i0 - 1] <+> v _[ i - 1; i0] <+>
       (|[ i0 + 1 <? Z.of_nat M ]| v _[ i - 1; i0 + 1])))) <++>
    (GEN [ Z.of_nat N + 1 <= i < Z.of_nat N + 2 ]
     GEN [ i0 < Z.of_nat M ]
     (|[ i - 1 <? Z.of_nat N ]| v _[ i - 1; i0 - 1] <+> v _[ i - 1; i0] <+>
                                v _[ i - 1; i0 + 1])))
in GEN [ y < Z.of_nat N ]
GEN [ x < Z.of_nat M ]
blurx' _[ y; x] <+> blurx' _[ y + 1; x] <+> blurx' _[ y + 2; x]
.
Proof. reflexivity. Qed.


Require Import Category.Lib.
Require Import Category.Theory.
Require Import Category.Functor.Opposite.

Require Import Core.Basics.
Require Import Core.HVec.
Require Import Institutions.
Require Import EVT.Basics.
Require Import Institutions.Machine.
Require Import Institutions.LTL.
Require Import Institutions.InsEVT.

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

Definition MacEVT2LTL_Sig : Sig[MacEVT] ⟶ Sig[LTL.LTL].
  unshelve refine {|
    fobj := λ Σ : Sig[MacEVT], {| LTL.base := base (evt_sig Σ) ; LTL.vars := vars (evt_sig Σ) |} : Sig[LTL.LTL] ;
    fmap := λ A B σ, _ ;
  |}; cbn in *; repeat intro.
  - unshelve refine {|
      LTL.on_base := _ ;
      LTL.on_vars := _ ;
    |}.
    + exact (on_base (fst σ)).
    + exact (@on_vars _ _ (fst σ)).
  - reflexivity.
  - destruct f, g; reflexivity.
Defined.

Definition MacEVT2LTL_Mod : Mod[MacEVT] ⟹ Mod[LTL.LTL] ◯ MacEVT2LTL_Sig^op.
  unshelve esplit; repeat intro.
  - unshelve esplit; intros.
    + unshelve refine {|
        LTL.base_alg := _ ;
        trace := _ ;
      |}; cbn in *.
      * exact (`1 X).
      * exact (fst (`2 X) :: map snd (snd (`2 X))).
    + exact f.
    + proper.
    + refine (eq_alghom _ _ _ _ _); reflexivity.
    + refine (eq_alghom _ _ _ _ _); reflexivity.
  - unfold LTL.LTLMod_obligation_1. simpl.
    destruct f. cbn. destruct x0, m. cbn.
    repeat f_equal. rewrite map_map, map_map. apply map_ext; intros.
    funext ?. now destruct a.
  - simpl in *. destruct x0 as [A M]. destruct f, M; cbn.
    repeat f_equal. rewrite map_map, map_map. apply map_ext; intros.
    funext ?. now destruct a.
Defined.

Definition EvtLTL_semi : InsSemiMorphism MacEVT LTL.LTL := {|
  μs_sig := MacEVT2LTL_Sig ;
  μs_mod := MacEVT2LTL_Mod ;
|}.

Definition EvtLTL : Institution :=
  Duplex MacEVT LTL.LTL EvtLTL_semi.


(** * A reflective version of [Wf]/[WfRel] proofs *)
(** Because every constructor of [Syntax.wff] stores the syntax tree
    being proven well-formed, a proof that a syntax tree is
    well-formed is quadratic in the size of the syntax tree.  (Tacking
    an extra term on to the head of the syntax tree requires an extra
    constructor of [Syntax.wff], and that constructor stores the
    entirety of the new syntax tree.)

    In practice, this makes proving well-formedness of large trees
    very slow.  To remedy this, we provide an alternative type
    ([reflect_wffT]) that implies [Syntax.wff], but is only linear in
    the size of the syntax tree, with a coefficient less than 1.

    The idea is that, since we already know the syntax-tree arguments
    to the constructors (and, moreover, already fully know the shape
    of the [Syntax.wff] proof, because it will exactly match the shape
    of the syntax tree), the proof doesn't have to store any of that
    information.  It only has to store the genuinely new information
    in [Syntax.wff], namely, that the constants don't depend on the
    [var] argument (i.e., that the constants in the same location in
    the two expressions are equal), and that there are no free nor
    mismatched variables (i.e., that the variables in the same
    location in the two expressions are in the relevant list of
    binders).  We can make the further optimization of storing the
    location in the list of each binder, so that all that's left to
    verify is that the locations line up correctly.

    Since there is no way to assign list locations (De Bruijn indices)
    after the fact (that is, once we have an [exprf var t] rather than
    an [Expr t]), we instead start from an expression where [var] is
    enriched with De Bruijn indices, and talk about [Syntax.wff] of
    that expression stripped of its De Bruijn indices.  Since this
    procedure is only expected to work on concrete syntax trees, we
    will be able to simply check by unification to check that
    stripping the indices results in the term that we started with.

    The interface of this file is that, to prove a [Syntax.Wf] goal,
    you invoke the tactic [reflect_Wf base_type_eq_semidec_is_dec
    op_beq_bl], where:

    - [base_type_eq_semidec_is_dec : forall t1 t2,
       base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2] for
       some [base_type_eq_semidec_transparent : forall t1 t2 :
       base_type_code, option (t1 = t2)], and

    - [op_beq_bl : forall t1 tR x y, prop_of_option (op_beq t1 tR x y)
      -> x = y] for some [op_beq : forall t1 tR, op t1 tR -> op t1 tR
      -> option pointed_Prop] *)

Require Import Coq.Arith.Arith Coq.Logic.Eqdep_dec.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Util.Notations Crypto.Util.Tactics Crypto.Util.Option Crypto.Util.Sigma Crypto.Util.Prod Crypto.Util.Decidable Crypto.Util.ListUtil.
Require Import Crypto.Reflection.Wf.
Require Export Crypto.Util.PartiallyReifiedProp. (* export for the [bool >-> reified_Prop] coercion *)
Require Export Crypto.Util.FixCoqMistakes.

Section language.
  (** To be able to optimize away so much of the [Syntax.wff] proof,
      we must be able to decide a few things: equality of base types,
      and equality of operator codes.  Since we will be casting across
      the equality proofs of base types, we require that this
      semi-decider give transparent proofs.  (This requirement is not
      enforced, but it will block [vm_compute] when trying to use the
      lemma in this file.) *)
  Context (base_type_code : Type)
          (base_type_eq_semidec_transparent : forall t1 t2 : base_type_code, option (t1 = t2))
          (base_type_eq_semidec_is_dec : forall t1 t2, base_type_eq_semidec_transparent t1 t2 = None -> t1 <> t2)
          (op : flat_type base_type_code -> flat_type base_type_code -> Type).
  (** In practice, semi-deciding equality of operators should either
      return [Some trivial] or [None], and not make use of the
      generality of [pointed_Prop].  However, we need to use
      [pointed_Prop] internally because we need to talk about equality
      of things of type [var t], for [var : base_type_code -> Type].
      It does not hurt to allow extra generality in [op_beq]. *)
  Context (op_beq : forall t1 tR, op t1 tR -> op t1 tR -> reified_Prop).
  Context (op_beq_bl : forall t1 tR x y, to_prop (op_beq t1 tR x y) -> x = y).
  Context {var1 var2 : base_type_code -> Type}.

  Local Notation eP := (fun t => var1 (fst t) * var2 (snd t))%type (only parsing).

  (* convenience notations that fill in some arguments used across the section *)
  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Local Notation exprf := (@exprf base_type_code op).
  Local Notation expr := (@expr base_type_code op).

  Local Ltac inversion_base_type_code_step :=
    match goal with
    | [ H : ?x = ?x :> base_type_code |- _ ]
      => assert (H = eq_refl) by eapply UIP_dec, dec_rel_of_semidec_rel, base_type_eq_semidec_is_dec; subst H
    | [ H : ?x = ?y :> base_type_code |- _ ] => subst x || subst y
    end.
  Local Ltac inversion_base_type_code := repeat inversion_base_type_code_step.

  (* lift [base_type_eq_semidec_transparent] across [flat_type] *)
  Fixpoint flat_type_eq_semidec_transparent (t1 t2 : flat_type) : option (t1 = t2)
    := match t1, t2 return option (t1 = t2) with
       | Tbase t1, Tbase t2
         => option_map (@f_equal _ _ Tbase _ _)
                       (base_type_eq_semidec_transparent t1 t2)
       | Tbase _, _ => None
       | Unit, Unit => Some eq_refl
       | Unit, _ => None
       | Prod A B, Prod A' B'
         => match flat_type_eq_semidec_transparent A A', flat_type_eq_semidec_transparent B B' with
           | Some p, Some q => Some (f_equal2 Prod p q)
           | _, _ => None
           end
       | Prod _ _, _ => None
       end.
  Definition type_eq_semidec_transparent (t1 t2 : type) : option (t1 = t2)
    := match t1, t2 return option (t1 = t2) with
       | Arrow A B, Arrow A' B'
         => match flat_type_eq_semidec_transparent A A', flat_type_eq_semidec_transparent B B' with
            | Some p, Some q => Some (f_equal2 (@Arrow base_type_code) p q)
            | _, _ => None
            end
       end.
  Lemma base_type_eq_semidec_transparent_refl t : base_type_eq_semidec_transparent t t = Some eq_refl.
  Proof.
    clear -base_type_eq_semidec_is_dec.
    pose proof (base_type_eq_semidec_is_dec t t).
    destruct (base_type_eq_semidec_transparent t t); intros; try intuition congruence.
    inversion_base_type_code; reflexivity.
  Qed.
  Lemma flat_type_eq_semidec_transparent_refl t : flat_type_eq_semidec_transparent t t = Some eq_refl.
  Proof.
    clear -base_type_eq_semidec_is_dec.
    induction t as [t | | A B IHt]; simpl; try reflexivity.
    { rewrite base_type_eq_semidec_transparent_refl; reflexivity. }
    { rewrite_hyp !*; reflexivity. }
  Qed.
  Lemma type_eq_semidec_transparent_refl t : type_eq_semidec_transparent t t = Some eq_refl.
  Proof.
    clear -base_type_eq_semidec_is_dec.
    destruct t; simpl; rewrite !flat_type_eq_semidec_transparent_refl; reflexivity.
  Qed.

  Definition op_beq' t1 tR t1' tR' (x : op t1 tR) (y : op t1' tR') : reified_Prop
    := match flat_type_eq_semidec_transparent t1 t1', flat_type_eq_semidec_transparent tR tR' with
       | Some p, Some q
         => match p in (_ = t1'), q in (_ = tR') return op t1' tR' -> _ with
           | eq_refl, eq_refl => fun y => op_beq _ _ x y
           end y
       | _, _ => rFalse
       end.

  (** While [Syntax.wff] is parameterized over a list of [sigT (fun t
      => var1 t * var2 t)], it is simpler here to make everything
      heterogenous, rather than trying to mix homogenous and
      heterogenous things.† Thus we parameterize our [reflect_wffT]
      over a list of [sigT (fun t => var1 (fst t) * var2 (snd t))],
      and write a function ([duplicate_type]) that turns the former
      into the latter.

      † This is an instance of the general theme that abstraction
        barriers are important.  Here we enforce the abstraction
        barrier that our input decision procedures are homogenous, but
        all of our internal code is strictly heterogenous.  This
        allows us to contain the conversions between homogenous and
        heterogenous code to a few functions: [op_beq'],
        [eq_type_and_var], [eq_type_and_const], and to the statement
        about [Syntax.wff] itself.  *)

  Definition eq_semidec_and_gen {T} (semidec : forall x y : T, option (x = y))
             (t t' : T) (f g : T -> Type) (R : forall t, f t -> g t -> reified_Prop)
             (x : f t) (x' : g t')
    : reified_Prop
    := match semidec t t' with
       | Some p
         => R _ (eq_rect _ f x _ p) x'
       | None => rFalse
       end.

  (* Here is where we use the generality of [pointed_Prop], to say
     that two things of type [var1] are equal, and two things of type
     [var2] are equal. *)
  Definition eq_type_and_var : sigT eP -> sigT eP -> reified_Prop
    := fun x y => (eq_semidec_and_gen
                  base_type_eq_semidec_transparent _ _ var1 var1 (fun _ => rEq) (fst (projT2 x)) (fst (projT2 y))
                /\ eq_semidec_and_gen
                     base_type_eq_semidec_transparent _ _ var2 var2 (fun _ => rEq) (snd (projT2 x)) (snd (projT2 y)))%reified_prop.

  Definition duplicate_type (ls : list (sigT (fun t => var1 t * var2 t)%type)) : list (sigT eP)
    := List.map (fun v => existT eP (projT1 v, projT1 v) (projT2 v)) ls.

  Lemma duplicate_type_app ls ls'
    : (duplicate_type (ls ++ ls') = duplicate_type ls ++ duplicate_type ls')%list.
  Proof. apply List.map_app. Qed.
  Lemma duplicate_type_length ls
    : List.length (duplicate_type ls) = List.length ls.
  Proof. apply List.map_length. Qed.
  Lemma duplicate_type_in t v ls
    : List.In (existT _ (t, t) v) (duplicate_type ls) -> List.In (existT _ t v) ls.
  Proof.
    unfold duplicate_type; rewrite List.in_map_iff.
    intros [ [? ?] [? ?] ].
    inversion_sigma; inversion_prod; inversion_base_type_code; subst; simpl.
    assumption.
  Qed.
  Lemma duplicate_type_not_in G t t0 v (H : base_type_eq_semidec_transparent t t0 = None)
    : ~List.In (existT _ (t, t0) v) (duplicate_type G).
  Proof.
    apply base_type_eq_semidec_is_dec in H.
    clear -H; intro H'.
    induction G as [|? ? IHG]; simpl in *; destruct H';
      intuition; congruence.
  Qed.

  Definition preflatten_binding_list2 t1 t2 : option (forall (x : interp_flat_type var1 t1) (y : interp_flat_type var2 t2), list (sigT (fun t => var1 t * var2 t)%type))
    := match flat_type_eq_semidec_transparent t1 t2 with
       | Some p
         => Some (fun x y
                 => let x := eq_rect _ (interp_flat_type var1) x _ p in
                   flatten_binding_list x y)
       | None => None
       end.
  Definition flatten_binding_list2 t1 t2 : option (forall (x : interp_flat_type var1 t1) (y : interp_flat_type var2 t2), list (sigT eP))
    := option_map (fun f x y => duplicate_type (f x y)) (preflatten_binding_list2 t1 t2).
  (** This function adds De Bruijn indices to variables *)
  Fixpoint natize_interp_flat_type var t (base : nat) (v : interp_flat_type var t) {struct t}
    : nat * interp_flat_type (fun t : base_type_code => nat * var t)%type t
    := match t return interp_flat_type var t -> nat * interp_flat_type _ t with
       | Prod A B => fun v => let ret := @natize_interp_flat_type _ A base (fst v) in
                          let base := fst ret in
                          let a := snd ret in
                          let ret := @natize_interp_flat_type _ B base (snd v) in
                          let base := fst ret in
                          let b := snd ret in
                          (base, (a, b))
       | Unit => fun v => (base, v)
       | Tbase t => fun v => (S base, (base, v))
       end v.
  Arguments natize_interp_flat_type {var t} _ _.
  Lemma length_natize_interp_flat_type1 {t} (base : nat) (v1 : interp_flat_type var1 t) (v2 : interp_flat_type var2 t)
    : fst (natize_interp_flat_type base v1) = length (flatten_binding_list v1 v2) + base.
  Proof.
    revert base; induction t; simpl; [ reflexivity | reflexivity | ].
    intros; rewrite List.app_length, <- plus_assoc.
    rewrite_hyp <- ?*; reflexivity.
  Qed.
  Lemma length_natize_interp_flat_type2 {t} (base : nat) (v1 : interp_flat_type var1 t) (v2 : interp_flat_type var2 t)
    : fst (natize_interp_flat_type base v2) = length (flatten_binding_list v1 v2) + base.
  Proof.
    revert base; induction t; simpl; [ reflexivity | reflexivity | ].
    intros; rewrite List.app_length, <- plus_assoc.
    rewrite_hyp <- ?*; reflexivity.
  Qed.

  (* This function strips De Bruijn indices from expressions *)
  Fixpoint unnatize_exprf {var t} (base : nat)
           (e : @Syntax.exprf base_type_code op (fun t => nat * var t)%type t)
    : @Syntax.exprf base_type_code op var t
    := match e in @Syntax.exprf _ _ _ t return Syntax.exprf _ _ t with
       | TT => TT
       | Var _ x => Var (snd x)
       | Op _ _ op args => Op op (@unnatize_exprf _ _ base args)
       | LetIn _ ex _ eC
         => LetIn (@unnatize_exprf _ _ base ex)
                  (fun x => let v := natize_interp_flat_type base x in
                            @unnatize_exprf _ _ (fst v) (eC (snd v)))
       | Pair _ x _ y
         => Pair (@unnatize_exprf _ _ base x) (@unnatize_exprf _ _ base y)
       end.
  Definition unnatize_expr {var t} (base : nat)
             (e : @Syntax.expr base_type_code op (fun t => nat * var t)%type t)
    : @Syntax.expr base_type_code op var t
    := match e in @Syntax.expr _ _ _ t return Syntax.expr _ _ t with
       | Abs tx tR f => Abs (fun x : interp_flat_type var tx =>
                               let v := natize_interp_flat_type (t:=tx) base x in
                               @unnatize_exprf _ _ (fst v) (f (snd v)))
       end.

  Fixpoint reflect_wffT (G : list (sigT (fun t => var1 (fst t) * var2 (snd t))%type))
           {t1 t2 : flat_type}
           (e1 : @exprf (fun t => nat * var1 t)%type t1)
           (e2 : @exprf (fun t => nat * var2 t)%type t2)
           {struct e1}
    : reified_Prop
    := match e1, e2 with
       | TT, TT => rTrue
       | TT, _ => rFalse
       | Var t0 x, Var t1 y
         => match beq_nat (fst x) (fst y), List.nth_error G (List.length G - S (fst x)) with
           | true, Some v => eq_type_and_var v (existT _ (t0, t1) (snd x, snd y))
           | _, _ => rFalse
           end
       | Var _ _, _ => rFalse
       | Op t1 tR op args, Op t1' tR' op' args'
         => (@reflect_wffT G t1 t1' args args' /\ op_beq' t1 tR t1' tR' op op')%reified_prop
       | Op _ _ _ _, _ => rFalse
       | LetIn tx ex tC eC, LetIn tx' ex' tC' eC'
         => let p := @reflect_wffT G tx tx' ex ex' in
            match @flatten_binding_list2 tx tx', flat_type_eq_semidec_transparent tC tC' with
           | Some G0, Some _
             => p
                /\ (∀ (x : interp_flat_type var1 tx) (x' : interp_flat_type var2 tx'),
                       @reflect_wffT (G0 x x' ++ G)%list _ _
                                     (eC (snd (natize_interp_flat_type (List.length G) x)))
                                     (eC' (snd (natize_interp_flat_type (List.length G) x'))))
           | _, _ => rFalse
           end
       | LetIn _ _ _ _, _ => rFalse
       | Pair tx ex ty ey, Pair tx' ex' ty' ey'
         => @reflect_wffT G tx tx' ex ex' /\ @reflect_wffT G ty ty' ey ey'
       | Pair _ _ _ _, _ => rFalse
       end%reified_prop.

    Definition reflect_wfT (G : list (sigT (fun t => var1 (fst t) * var2 (snd t))%type))
           {t1 t2 : type}
           (e1 : @expr (fun t => nat * var1 t)%type t1)
           (e2 : @expr (fun t => nat * var2 t)%type t2)
    : reified_Prop
    := match e1, e2 with
       | Abs tx tR f, Abs tx' tR' f'
         => match @flatten_binding_list2 tx tx', flat_type_eq_semidec_transparent tR tR' with
           | Some G0, Some _
             => ∀ (x : interp_flat_type var1 tx) (x' : interp_flat_type var2 tx'),
               @reflect_wffT (G0 x x' ++ G)%list _ _
                             (f (snd (natize_interp_flat_type (List.length G) x)))
                             (f' (snd (natize_interp_flat_type (List.length G) x')))
           | _, _ => rFalse
           end
       end%reified_prop.
End language.

Global Arguments reflect_wffT {_} _ {op} op_beq {var1 var2} G {t1 t2} _ _.
Global Arguments reflect_wfT {_} _ {op} op_beq {var1 var2} G {t1 t2} _ _.
Global Arguments unnatize_exprf {_ _ _ _} _ _.
Global Arguments unnatize_expr {_ _ _ _} _ _.
Global Arguments natize_interp_flat_type {_ _ t} _ _.