Require Import FcEtt.imports.

Require Export FcEtt.ett_ott.
Require Export FcEtt.utils.

(**************** Ext_Wf ****************)

Module Type ext_wf_sig.

Axiom ctx_wff_mutual :
  (forall G0 a A, Typing G0 a A -> Ctx G0) /\
  (forall G0 phi,   PropWff G0 phi -> Ctx G0) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 -> Ctx G0) /\
  (forall G0 D A B T,   DefEq G0 D A B T -> Ctx G0) /\
  (forall G0, Ctx G0 -> True).

Axiom lc_mutual :
  (forall G0 a A, Typing G0 a A -> lc_tm a /\ lc_tm A) /\
  (forall G0 phi,   PropWff G0 phi -> lc_constraint phi) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p1 /\ lc_constraint p2) /\
  (forall G0 D A B T,   DefEq G0 D A B T -> lc_tm A /\ lc_tm B /\ lc_tm T) /\
  (forall G0, Ctx G0 -> forall x s , binds x s G0 -> lc_sort s).

Axiom Typing_lc  : forall G0 a A, Typing G0 a A -> lc_tm a /\ lc_tm A.
Axiom PropWff_lc : forall G0 phi,   PropWff G0 phi -> lc_constraint phi.
Axiom Iso_lc : forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p1 /\ lc_constraint p2.
Axiom DefEq_lc : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm A /\ lc_tm B /\ lc_tm T.

Axiom Typing_lc1 : forall G0 a A, Typing G0 a A -> lc_tm a.
Axiom Typing_lc2 : forall G0 a A, Typing G0 a A -> lc_tm A.

Axiom Iso_lc1 : forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p1.
Axiom Iso_lc2 : forall G0 D p1 p2, Iso G0 D p1 p2 -> lc_constraint p2.

Axiom DefEq_lc1 : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm A.
Axiom DefEq_lc2 : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm B.
Axiom DefEq_lc3 : forall G0 D A B T,   DefEq G0 D A B T -> lc_tm T.

Axiom Ctx_lc : forall G0, Ctx G0 -> forall x s , binds x s G0 -> lc_sort s.

Axiom Ctx_uniq : forall G, Ctx G -> uniq G.

Axiom Toplevel_lc : forall c s, binds c s toplevel -> lc_sig_sort s.

(* Axiom Path_lc : forall T a, Path T a -> lc_tm a.

Axiom DataTy_lc : forall A, DataTy A a_Star -> lc_tm A. *)

Axiom Value_lc : forall A, Value A -> lc_tm A.

Axiom CoercedValue_lc : forall A, CoercedValue A -> lc_tm A.

End ext_wf_sig.

(**************** EXT Weak ****************)

Module Type ext_weak_sig.

Include ext_wf_sig.

Axiom weaken_available_mutual:
  (forall G1  a A,   Typing G1 a A -> True) /\
  (forall G1  phi,   PropWff G1 phi -> True) /\
  (forall G1 D p1 p2, Iso G1 D p1 p2 -> forall D', D [<=] D' -> Iso G1 D' p1 p2) /\
  (forall G1 D A B T,   DefEq G1 D A B T -> forall D', D [<=] D' -> DefEq G1 D' A B T) /\
  (forall G1 ,       Ctx G1 -> True).

Axiom respects_atoms_eq_mutual :
  (forall G a A,     Typing  G a A       -> True) /\
  (forall G phi,     PropWff G phi       -> True) /\
  (forall G D p1 p2, Iso G D p1 p2 -> forall D', D [=] D' -> Iso G D' p1 p2) /\
  (forall G D A B T,   DefEq G D A B T  -> forall D', D [=] D' -> DefEq G D' A B T) /\
  (forall G,           Ctx G           -> True).

Axiom remove_available_mutual:
  (forall G1  a A,   Typing G1 a A -> True) /\
  (forall G1  phi,   PropWff G1 phi -> True) /\
  (forall G1 D p1 p2, Iso G1 D p1 p2 ->
                   Iso G1 (AtomSetImpl.inter D (dom G1)) p1 p2) /\
  (forall G1 D A B T,   DefEq G1 D A B T ->
                   DefEq G1 (AtomSetImpl.inter D (dom G1)) A B T) /\
  (forall G1 ,       Ctx G1 -> True).

Axiom DefEq_weaken_available :
  forall G D A B T, DefEq G D A B T -> DefEq G (dom G) A B T.

Axiom Iso_weaken_available :
  forall G D A B, Iso G D A B -> Iso G (dom G) A B.

Axiom typing_weakening_mutual:
  (forall G0 a A,   Typing G0 a A ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> Typing (F ++ E ++ G) a A) /\
  (forall G0 phi,   PropWff G0 phi ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> PropWff (F ++ E ++ G) phi) /\
  (forall G0 D p1 p2, Iso G0 D p1 p2 ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> Iso (F ++ E ++ G) D p1 p2) /\
  (forall G0 D A B T,   DefEq G0 D A B T ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> DefEq (F ++ E ++ G) D A B T) /\
  (forall G0,       Ctx G0 ->
     forall E F G, (G0 = F ++ G) -> Ctx (F ++ E ++ G) -> Ctx (F ++ E ++ G)).

Definition Typing_weakening  := first  typing_weakening_mutual.
Definition PropWff_weakening := second typing_weakening_mutual.
Definition Iso_weakening     := third  typing_weakening_mutual.
Definition DefEq_weakening   := fourth typing_weakening_mutual.

End ext_weak_sig.

(**************** Ext Substitution ****************)

Module Type ext_subst_sig.
Include ext_weak_sig.

Axiom Ctx_strengthen : forall G1 G2, Ctx (G2 ++ G1) -> Ctx G1.

Axiom binds_to_PropWff: forall G0 A B T c,
    Ctx G0 ->
    binds c (Co (Eq A B T)) G0 -> PropWff G0 (Eq A B T).

Axiom tm_subst_tm_tm_dom_invariance: forall x a F,
    dom F = dom (map (tm_subst_tm_sort a x) F).

Axiom tm_subst_fresh_1 :
forall G a A a0 x s,
  Typing G a A -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x A = A.

Axiom tm_subst_fresh_2 :
forall G a A a0 x s,
  Typing G a A -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x a = a.

Axiom tm_subst_co_fresh_1 :
forall G a A a0 c s,
  Typing G a A -> Ctx ((c ~ s) ++ G) -> co_subst_co_tm a0 c A = A.

Axiom tm_substitution_mutual :  (forall G0 b B (H : Typing G0 b B),
      forall G a A, Typing G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      Typing (map (tm_subst_tm_sort a x) F ++ G)
                             (tm_subst_tm_tm a x b)
                             (tm_subst_tm_tm a x B)) /\
    (forall G0 phi (H : PropWff G0 phi),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                        PropWff (map (tm_subst_tm_sort a x) F ++ G)
                                (tm_subst_tm_constraint a x phi)) /\
    (forall G0 D p1 p2 (H : Iso G0 D p1 p2),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                Iso (map (tm_subst_tm_sort a x) F ++ G) D
                    (tm_subst_tm_constraint a x p1)
                    (tm_subst_tm_constraint a x p2)) /\
    (forall G0 D A B T (H : DefEq G0 D A B T),
       forall G a A0, Typing G a A0 ->
                 forall F x, G0 = (F ++ (x ~ Tm A0) ++ G) ->
                        DefEq (map (tm_subst_tm_sort a x) F ++ G) D
                              (tm_subst_tm_tm a x A)
                              (tm_subst_tm_tm a x B) (tm_subst_tm_tm a x T)) /\
    (forall G0 (H : Ctx G0),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                        Ctx (map (tm_subst_tm_sort a x) F ++ G)).

Axiom Typing_tm_subst : forall G x A b B (H : Typing ((x ~ Tm A) ++ G) b B),
  forall a, Typing G a A ->
       Typing G (tm_subst_tm_tm a x b) (tm_subst_tm_tm a x B).

Axiom co_substitution_mutual :
    (forall G0 b B (H : Typing G0 b B),
        forall G D A1 A2 T F c ,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
          -> DefEq G D A1 A2 T
          -> Typing (map (co_subst_co_sort g_Triv c) F ++ G) (co_subst_co_tm g_Triv c b) (co_subst_co_tm g_Triv c B)) /\
    (forall G0 phi (H : PropWff G0 phi),
        forall G D A1 A2 T F c,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
          -> DefEq G D A1 A2 T
          -> PropWff (map (co_subst_co_sort g_Triv c) F ++ G) (co_subst_co_constraint g_Triv c phi)) /\
    (forall G0 D0 p1 p2 (H : Iso G0 D0 p1 p2),
          forall G D A1 A2 T F c,
            G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
            -> DefEq G D A1 A2 T
            -> Iso (map (co_subst_co_sort g_Triv c) F ++ G) (union D (remove c D0))
                    (co_subst_co_constraint g_Triv c p1)
                    (co_subst_co_constraint g_Triv c p2)) /\
    (forall G0 D0 A B T (H : DefEq G0 D0 A B T),
        forall G D F c A1 A2 T1,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T1) ) ++ G)
          -> DefEq G D A1 A2 T1
          -> DefEq (map (co_subst_co_sort g_Triv c) F ++ G) (union D (remove c D0))
                  (co_subst_co_tm g_Triv c A) (co_subst_co_tm g_Triv c B)
                  (co_subst_co_tm g_Triv c T)) /\
    (forall G0 (H : Ctx G0),
        forall G D F c A1 A2 T,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T) ) ++ G)
          -> DefEq G D A1 A2 T
          -> Ctx (map (co_subst_co_sort g_Triv c) F ++ G)).

Axiom Typing_co_subst:
   forall G D c a1 a2 A b B (H : Typing (c ~ (Co (Eq a1 a2 A)) ++ G) b B),
     DefEq G D a1 a2 A ->
     Typing G (co_subst_co_tm g_Triv c b) (co_subst_co_tm g_Triv c B).

Axiom Typing_swap : forall x1 x G a A B,
      x1 `notin` fv_tm_tm_tm a \u fv_tm_tm_tm B
    -> x `notin` dom G \u {{ x1 }}
    -> Typing ([(x1, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x1))
             (open_tm_wrt_tm B (a_Var_f x1))
    -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x))
             (open_tm_wrt_tm B (a_Var_f x)).

Axiom E_Pi_exists : forall x (G : context) (rho : relflag) (A B : tm),
      x `notin` dom G \u fv_tm_tm_tm B
      -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star
      -> Typing G A a_Star -> Typing G (a_Pi rho A B) a_Star.

Axiom E_Abs_exists :  forall x (G : context) (rho : relflag) (a A B : tm),
    x `notin` fv_tm_tm_tm a \u fv_tm_tm_tm B
    -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x))
    -> Typing G A a_Star
    -> RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x))
    -> Typing G (a_UAbs rho a) (a_Pi rho A B).

End ext_subst_sig.

(**************** Ext invert ****************)

Module Type ext_invert_sig.
  Include ext_subst_sig.

(* ---------- inversion lemmas ---------------- *)

Axiom binds_to_Typing: forall G T A, Ctx G -> binds T (Tm A) G -> Typing G A a_Star.

(*Axiom invert_a_Const : forall G T A,
    Typing G (a_Const T) A ->
    exists B, DataTy B a_Star /\ DefEq G (dom G) A B  a_Star
         /\ binds T (Cs B) toplevel.
*)
Axiom invert_a_Pi: forall G rho A0 A B0,
    Typing G (a_Pi rho A0 B0) A ->
    DefEq G (dom G) A a_Star a_Star /\ (exists L, forall x, x `notin` L -> Typing ([(x, Tm A0)] ++ G) (open_tm_wrt_tm B0 (a_Var_f x)) a_Star) /\ Typing G A0 a_Star.

Axiom invert_a_CPi: forall G phi A B0,
    Typing G (a_CPi phi B0) A ->
      DefEq G (dom G) A a_Star a_Star /\ (exists L, forall c, c `notin` L -> Typing ([(c, Co phi)] ++ G) (open_tm_wrt_co B0 (g_Var_f c) ) a_Star) /\ PropWff G phi.

Axiom invert_a_App_Rel : forall G a b C,
    Typing G (a_App a Rel b) C ->
    exists A B, Typing G a (a_Pi Rel A B) /\
           Typing G b A /\
           DefEq G (dom G) C (open_tm_wrt_tm B b) a_Star.

Axiom invert_a_App_Irrel : forall G a b C,
    Typing G (a_App a Irrel b) C ->
    exists A B b0, Typing G a (a_Pi Irrel A B) /\
              Typing G b0 A /\
              DefEq G (dom G) C (open_tm_wrt_tm B b0) a_Star.

Axiom invert_a_CApp : forall G a g A,
    Typing G (a_CApp a g) A ->
    g = g_Triv /\
    exists a1 b1 A1 B, Typing G a (a_CPi (Eq a1 b1 A1) B) /\
             DefEq G (dom G) a1 b1 A1 /\
             DefEq G (dom G) A (open_tm_wrt_co B g_Triv) a_Star.

Axiom invert_a_UAbs:
  forall G rho A b0,
    Typing G (a_UAbs rho b0) A
    -> exists A1 B1, DefEq G (dom G) A (a_Pi rho A1 B1) a_Star
               /\ (exists L, forall x, x `notin` L ->
                            Typing ([(x, Tm A1)] ++ G)
                                   (open_tm_wrt_tm b0 (a_Var_f x))
                                   (open_tm_wrt_tm B1 (a_Var_f x))
                            /\ Typing ([(x, Tm A1)] ++ G)
                                     (open_tm_wrt_tm B1 (a_Var_f x)) a_Star
                            /\ RhoCheck rho x (open_tm_wrt_tm b0 (a_Var_f x)))
               /\ Typing G A1 a_Star.

Axiom invert_a_UCAbs: forall G A b0,
    Typing G (a_UCAbs b0) A ->
    exists a b T B1, PropWff G (Eq a b T)
                /\ DefEq G (dom G) A (a_CPi (Eq a b T) B1) a_Star /\
                (exists L, forall c, c `notin` L ->
                           Typing ([(c, Co (Eq a b T))] ++ G)
                                  (open_tm_wrt_co b0 (g_Var_f c))
                                  (open_tm_wrt_co B1 (g_Var_f c)) /\
                           Typing ([(c, Co (Eq a b T))] ++ G)
                                  (open_tm_wrt_co B1 (g_Var_f c)) a_Star).

Axiom invert_a_Var :
  forall G x A, Typing G (a_Var_f x) A -> exists A', binds x (Tm A') G /\ DefEq G (dom G) A A' a_Star.

Axiom invert_a_Star: forall A G, Typing G a_Star A -> DefEq G (dom G) A a_Star a_Star.

Axiom invert_a_Fam : forall G F A,
    Typing G (a_Fam F) A ->
    exists a B, DefEq G (dom G) A B a_Star /\
           binds F (Ax a B) toplevel /\ Typing nil B a_Star.

(* ---------- context conversion -------------- *)
(* Terms still type check even after varying the context *)

Inductive context_DefEq : available_props -> context -> context -> Prop :=
| Nul_Eqcontext: forall D, context_DefEq D nil nil
| Factor_Eqcontext_tm: forall G1 G2 D A A' x,
    context_DefEq D G1 G2 ->
    DefEq G1 D A A' a_Star ->
    DefEq G2 D A A' a_Star ->
    context_DefEq D ([(x, Tm A)] ++ G1) ([(x, Tm A')] ++ G2)
| Factor_Eqcontext_co: forall D G1 G2 Phi1 Phi2 c,
    context_DefEq D G1 G2 ->
    Iso G1 D Phi1 Phi2 ->
    Iso G2 D Phi1 Phi2 ->
    context_DefEq D ([(c, Co Phi1)] ++ G1) ([(c, Co Phi2)] ++ G2).

Axiom refl_context_defeq: forall G D, Ctx G -> context_DefEq D G G.

Axiom context_DefEq_weaken_available :
  forall D G1 G2, context_DefEq D G1 G2 -> context_DefEq (dom G1) G1 G2.

Axiom context_DefEq_typing:
  (forall G1  a A, Typing G1 a A -> forall D G2, Ctx G2 -> context_DefEq D G1 G2 -> Typing G2 a A).

(* ---------------- regularity lemmas ------------------- *)

Axiom Typing_regularity: forall e A G, Typing G e A -> Typing G A a_Star.

Axiom DefEq_regularity :
  forall G D A B T, DefEq G D A B T -> PropWff G (Eq A B T).

Axiom Iso_regularity :
  forall G D phi1 phi2, Iso G D phi1 phi2 -> PropWff G phi1 /\ PropWff G phi2.

Axiom PropWff_regularity :
  forall G A B T, PropWff G (Eq A B T) ->  Typing G A T /\ Typing  G B T.

(* ------- smart constructors --------- *)

Axiom DefEq_conv : forall G D a b A B, DefEq G D a b A -> DefEq G (dom G) A B a_Star -> DefEq G D a b B.

Axiom refl_iso: forall G D phi, PropWff G phi -> Iso G D phi phi.

Axiom sym_iso: forall G D phi1 phi2, Iso G D phi1 phi2 -> Iso G D phi2 phi1.

Axiom trans_iso : forall G D phi1 phi2 phi3, Iso G D phi1 phi2 -> Iso G D phi2 phi3 -> Iso G D phi1 phi3.

Axiom iso_cong : forall G D A A' B B' T T', DefEq G D A A' T -> DefEq G D B B' T -> DefEq G D T T' a_Star ->
                     Iso G D (Eq A B T) (Eq A' B' T').

Axiom E_PiCong2 :  ∀ (L : atoms) (G : context) (D : available_props) rho (A1 B1 A2 B2 : tm),
    DefEq G D A1 A2 a_Star
    → (∀ x : atom,
          x `notin` L
          → DefEq ([(x, Tm A1)] ++ G) D (open_tm_wrt_tm B1 (a_Var_f x))
                  (open_tm_wrt_tm B2 (a_Var_f x)) a_Star)
    → DefEq G D (a_Pi rho A1 B1) (a_Pi rho A2 B2) a_Star.

Axiom E_CPiCong2  : ∀ (L : atoms) (G : context) (D : available_props) (phi1 : constraint)
                      (A : tm) (phi2 : constraint) (B : tm),
    Iso G D phi1 phi2
    → (∀ c : atom,
          c `notin` L
              → DefEq ([(c, Co phi1)] ++ G) D (open_tm_wrt_co A (g_Var_f c))
                      (open_tm_wrt_co B (g_Var_f c)) a_Star)
    → DefEq G D (a_CPi phi1 A) (a_CPi phi2 B) a_Star.

Axiom E_Pi2 : forall L G rho A B,
    (∀ x : atom, x `notin` L → Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star) ->
    Typing G (a_Pi rho A B) a_Star.

Axiom E_Abs2 : ∀ (L : atoms) (G : context) (rho : relflag) (a A B : tm),
    (∀ x : atom,
        x `notin` L → Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x)) (open_tm_wrt_tm B (a_Var_f x)))
    → (∀ x : atom, x `notin` L → RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)))
    → Typing G (a_UAbs rho a) (a_Pi rho A B).

Axiom E_Conv2 : ∀ (G : context) (a B A : tm),
    Typing G a A → DefEq G (dom G) A B a_Star →
    Typing G a B.

Axiom E_CPi2 :  ∀ (L : atoms) (G : context) (phi : constraint) (B : tm),
    (∀ c : atom, c `notin` L → Typing ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star) ->
    Typing G (a_CPi phi B) a_Star.

Axiom E_CAbs2 : ∀ (L : atoms) (G : context) (a : tm) (phi : constraint) (B : tm),
       (∀ c : atom,
        c `notin` L → Typing ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co B (g_Var_f c)))
       → Typing G (a_UCAbs a) (a_CPi phi B).

Axiom E_AbsCong2
     : ∀ (L : atoms) (G : context) (D : available_props) (rho : relflag) (b1 b2 A1 B : tm),
       (∀ x : atom,
        x `notin` L
        → DefEq ([(x, Tm A1)] ++ G) D (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))
            (open_tm_wrt_tm B (a_Var_f x)))
       → (∀ x : atom, x `notin` L → RhoCheck rho x (open_tm_wrt_tm b1 (a_Var_f x)))
       → (∀ x : atom, x `notin` L → RhoCheck rho x (open_tm_wrt_tm b2 (a_Var_f x)))
       → DefEq G D (a_UAbs rho b1) (a_UAbs rho b2) (a_Pi rho A1 B).

Axiom E_CAbsCong2
     : ∀ (L : atoms) (G : context) (D : available_props) (a b : tm) (phi1 : constraint)
       (B : tm),
       (∀ c : atom,
        c `notin` L
        → DefEq ([(c, Co phi1)] ++ G) D (open_tm_wrt_co a (g_Var_f c)) (open_tm_wrt_co b (g_Var_f c))
                (open_tm_wrt_co B (g_Var_f c))) → DefEq G D (a_UCAbs a) (a_UCAbs b) (a_CPi phi1 B).

End ext_invert_sig.

(**************** FC Wf ****************)

Module Type fc_wf_sig.

Axiom AnnTyping_AnnCtx  : forall G0 a A, AnnTyping G0 a A -> AnnCtx G0.
Axiom AnnPropWff_AnnCtx : forall G0 phi, AnnPropWff G0 phi -> AnnCtx G0.
Axiom AnnIso_AnnCtx     : forall G0 D g p1 p2, AnnIso G0 D g p1 p2 -> AnnCtx G0.
Axiom AnnDefEq_AnnCtx   : forall G0 D g A B,   AnnDefEq G0 D g A B -> AnnCtx G0.

Axiom AnnCtx_uniq : forall G, AnnCtx G -> uniq G.

Axiom AnnTyping_lc  :  forall G0 a A, AnnTyping G0 a A -> lc_tm a /\ lc_tm A.
Axiom AnnPropWff_lc : forall G0 phi, AnnPropWff G0 phi -> lc_constraint phi.
Axiom AnnIso_lc :  forall G0 D g p1 p2, AnnIso G0 D g p1 p2 -> lc_constraint p1 /\ lc_constraint p2 /\ lc_co g.
Axiom AnnDefEq_lc : forall G0 D g A B,  AnnDefEq G0 D g A B -> lc_tm A /\ lc_tm B /\ lc_co g.
Axiom AnnCtx_lc : forall G0, AnnCtx G0 -> forall x s , binds x s G0 -> lc_sort s.

Axiom AnnTyping_lc1 : forall G a A, AnnTyping G a A -> lc_tm a.
Axiom AnnTyping_lc2 : forall G a A, AnnTyping G a A -> lc_tm A.
Axiom AnnIso_lc1 : forall G D g p1 p2, AnnIso G D g p1 p2 -> lc_constraint p1.
Axiom AnnIso_lc2 : forall G D g p1 p2, AnnIso G D g p1 p2 -> lc_constraint p2.
Axiom AnnIso_lc3 : forall G D g p1 p2, AnnIso G D g p1 p2 -> lc_co g.
Axiom AnnDefEq_lc1 : forall G D g A B,  AnnDefEq G D g A B -> lc_tm A.
Axiom AnnDefEq_lc2 : forall G D g A B,  AnnDefEq G D g A B -> lc_tm B.
Axiom AnnDefEq_lc3 : forall G D g A B,  AnnDefEq G D g A B -> lc_co g.

Axiom AnnToplevel_lc : forall c s, binds c s an_toplevel -> lc_sig_sort s.

End fc_wf_sig.

(**************** FC Weakening ****************)

Module Type fc_weak_sig.

Axiom ann_respects_atoms_eq_mutual :
  (forall G a A,       AnnTyping  G a A       -> True) /\
  (forall G phi,       AnnPropWff G phi       -> True) /\
  (forall G D g p1 p2, AnnIso     G D g p1 p2 -> forall D', D [=] D' -> AnnIso   G D' g p1 p2) /\
  (forall G D g A B,   AnnDefEq   G D g A B   -> forall D', D [=] D' -> AnnDefEq G D' g A B) /\
  (forall G,           AnnCtx     G           -> True).

Definition AnnIso_respects_atoms_eq   := third  ann_respects_atoms_eq_mutual.
Definition AnnDefEq_respects_atoms_eq := fourth ann_respects_atoms_eq_mutual.

Axiom ann_strengthen_noncovar:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 -> forall x, not (exists phi, binds x (Co phi) G1) ->
                     AnnIso G1 (remove x D) g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B ->  forall x, not (exists phi, binds x (Co phi) G1) ->
                    AnnDefEq G1 (remove x D) g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).

Axiom AnnDefEq_strengthen_available_tm :
  forall G D g A B, AnnDefEq G D g A B ->  forall x A', binds x (Tm A') G ->
                    forall D', D' [=] remove x D ->
                    AnnDefEq G D' g A B.

Axiom ann_weaken_available_mutual:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 -> forall D', D [<=] D' -> AnnIso G1 D' g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B -> forall D', D [<=] D' -> AnnDefEq G1 D' g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).

Axiom ann_remove_available_mutual:
  (forall G1  a A,   AnnTyping G1 a A -> True) /\
  (forall G1  phi,   AnnPropWff G1 phi -> True) /\
  (forall G1 D g p1 p2, AnnIso G1 D g p1 p2 ->
                   AnnIso G1 (AtomSetImpl.inter D (dom G1)) g p1 p2) /\
  (forall G1 D g A B,   AnnDefEq G1 D g A B ->
                   AnnDefEq G1 (AtomSetImpl.inter D (dom G1)) g A B) /\
  (forall G1 ,       AnnCtx G1 -> True).

Axiom AnnDefEq_weaken_available :
  forall G D g A B, AnnDefEq G D g A B -> AnnDefEq G (dom G) g A B.

Axiom AnnIso_weaken_available :
  forall G D g A B, AnnIso G D g A B -> AnnIso G (dom G) g A B.

Axiom ann_typing_weakening_mutual:
  (forall G0 a A,       AnnTyping  G0 a A       ->
     forall E F G, (G0 = F ++ G) -> AnnCtx (F ++ E ++ G) -> AnnTyping (F ++ E ++ G) a A) /\
  (forall G0 phi,       AnnPropWff G0 phi       ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnPropWff (F ++ E ++ G) phi) /\
  (forall G0 D g p1 p2, AnnIso     G0 D g p1 p2 ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnIso (F ++ E ++ G) D g p1 p2) /\
  (forall G0 D g A B,   AnnDefEq   G0 D g A B   ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnDefEq (F ++ E ++ G) D g A B) /\
  (forall G0,           AnnCtx     G0           ->
     forall E F G, (G0 = F ++ G) ->
        AnnCtx (F ++ E ++ G) -> AnnCtx (F ++ E ++ G)).

Definition AnnTyping_weakening  := first  ann_typing_weakening_mutual.
Definition AnnPropWff_weakening := second ann_typing_weakening_mutual.
Definition AnnIso_weakening     := third  ann_typing_weakening_mutual.
Definition AnnDefEq_weakening   := fourth ann_typing_weakening_mutual.
Definition AnnCtx_weakening     := fifth  ann_typing_weakening_mutual.

End fc_weak_sig.

(**************** FC Substitution ****************)
Module Type fc_subst_sig.

  (*
  Axiom context_fv_mutual :
  (forall G (a : tm) A (H: AnnTyping G a A),
      fv_tm_tm_tm a [<=] dom G /\ fv_co_co_tm a [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G)
  /\
  (forall G phi (H : AnnPropWff G phi),
      fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)
  /\
  (forall G D g p1 p2 (H : AnnIso G D g p1 p2),
      fv_tm_tm_co         g  [<=] dom G /\ fv_co_co_co         g  [<=] dom G /\
      fv_tm_tm_constraint p1 [<=] dom G /\ fv_co_co_constraint p1 [<=] dom G /\
      fv_tm_tm_constraint p2 [<=] dom G /\ fv_co_co_constraint p2 [<=] dom G)
  /\
  (forall G D g A B (H : AnnDefEq G D g A B),
      fv_tm_tm_co g [<=] dom G /\ fv_co_co_co g [<=] dom G /\
      fv_tm_tm_tm A [<=] dom G /\ fv_co_co_tm A [<=] dom G /\
      fv_tm_tm_tm B [<=] dom G /\ fv_co_co_tm B [<=] dom G)
  /\
  (forall G (H : AnnCtx G),
      (forall x A,
          binds x (Tm A)   G ->
          fv_tm_tm_tm         A   [<=] dom G /\ fv_co_co_tm         A   [<=] dom G) /\
      (forall c phi,
          binds c (Co phi) G ->
          fv_tm_tm_constraint phi [<=] dom G /\ fv_co_co_constraint phi [<=] dom G)).

  Definition AnnTyping_context_fv  := @first  _ _ _ _ _ context_fv_mutual.
  Definition AnnPropWff_context_fv := @second _ _ _ _ _ context_fv_mutual.
  Definition AnnIso_context_fv     := @third  _ _ _ _ _ context_fv_mutual.
  Definition AnnDefEq_context_fv   := @fourth _ _ _ _ _ context_fv_mutual.
  Definition AnnCtx_context_fv     := @fifth  _ _ _ _ _ context_fv_mutual.
*)

  Axiom AnnCtx_strengthen : forall G1 G2, AnnCtx (G2 ++ G1) -> AnnCtx G1.

  Axiom binds_to_AnnTyping :
    forall G x A, AnnCtx G -> binds x (Tm A) G -> AnnTyping G A a_Star.

  Axiom binds_to_AnnPropWff: forall G0 a b A c,
      AnnCtx G0 -> binds c (Co (Eq a b A)) G0 -> AnnPropWff G0 (Eq a b A).

  Axiom tm_subst_fresh_1 :
  forall G a A a0 x s,
    AnnTyping G a A -> AnnCtx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x A = A.

  Axiom tm_subst_fresh_2 :
  forall G a A a0 x s,
    AnnTyping G a A -> AnnCtx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x a = a.

  Axiom ann_tm_substitution_mutual :
  (forall G0 b B (H : AnnTyping G0 b B),
      forall G a A, AnnTyping G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      AnnTyping (map (tm_subst_tm_sort a x) F ++ G)
                                (tm_subst_tm_tm a x b)
                                (tm_subst_tm_tm a x B)) /\
  (forall G0 phi (H : AnnPropWff G0 phi),
      forall G a A, AnnTyping G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      AnnPropWff (map (tm_subst_tm_sort a x) F ++ G)
                                 (tm_subst_tm_constraint a x phi)) /\
  (forall G0 D g p1 p2 (H : AnnIso G0 D g p1 p2),
      forall G a A, AnnTyping G a A ->
               forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                      AnnIso (map (tm_subst_tm_sort a x) F ++ G)
                             D
                             (tm_subst_tm_co a x g)
                             (tm_subst_tm_constraint a x p1)
                             (tm_subst_tm_constraint a x p2)) /\
  (forall  G0 D g A B (H : AnnDefEq G0 D g A B),
      forall G a A0, AnnTyping G a A0 ->
                forall F x, G0 = (F ++ (x ~ Tm A0) ++ G) ->
                       AnnDefEq (map (tm_subst_tm_sort a x) F ++ G)
                                D
                                (tm_subst_tm_co a x g)
                                (tm_subst_tm_tm a x A)
                                (tm_subst_tm_tm a x B)) /\
  (forall G0 (H : AnnCtx G0),
  forall G a A, AnnTyping G a A ->
  forall F x, G0 = (F ++ (x ~ Tm A) ++ G) ->
                AnnCtx (map (tm_subst_tm_sort a x) F ++ G)).

  Axiom AnnTyping_tm_subst : forall G x A b B (H : AnnTyping ((x ~ Tm A) ++ G) b B),
    forall a, AnnTyping G a A ->
         AnnTyping G (tm_subst_tm_tm a x b) (tm_subst_tm_tm a x B).

  Axiom AnnTyping_tm_subst_nondep : forall L G a A b B,
      AnnTyping G a A ->
      (forall x, x `notin` L -> AnnTyping ([(x,Tm A)] ++ G) (open_tm_wrt_tm b (a_Var_f x)) B) ->
      AnnTyping G (open_tm_wrt_tm b a) B.

  Axiom AnnTyping_co_subst : forall G x A1 A2 A3 b B
                               (H : AnnTyping ((x ~ Co (Eq A1 A2 A3)) ++ G) b B),
    forall D a, AnnDefEq G D a A1 A2 ->
         AnnTyping G (co_subst_co_tm a x b) (co_subst_co_tm a x B).

  Axiom AnnTyping_co_subst_nondep : forall L G D g A1 A2 A3 b B,
      AnnDefEq G D g A1 A2 ->
      (forall x, x `notin` L -> AnnTyping ([(x,Co (Eq A1 A2 A3))] ++ G) (open_tm_wrt_co b (g_Var_f x)) B) ->
      AnnTyping G (open_tm_wrt_co b g) B.

  (* -----  exists forms of the binding constructors ----------- *)

  Axiom An_Pi_exists : forall x G rho A B,
      x `notin` dom G \u fv_tm_tm_tm B
    → AnnTyping ([(x, Tm A)] ++ G)
                (open_tm_wrt_tm B (a_Var_f x)) a_Star
    → AnnTyping G A a_Star
    → AnnTyping G (a_Pi rho A B) a_Star.

  Axiom An_Abs_exists :   forall x (G:context) rho (A a B:tm),
       x \notin dom G \u fv_tm_tm_tm a \u fv_tm_tm_tm B ->
       AnnTyping G A a_Star ->
       AnnTyping  (( x ~ Tm  A) ++ G) (open_tm_wrt_tm a (a_Var_f x))
                  (open_tm_wrt_tm B (a_Var_f x))  ->
       RhoCheck rho x (erase_tm (open_tm_wrt_tm a (a_Var_f x))) ->
        AnnTyping G (a_Abs rho A a) (a_Pi rho A B).

  Axiom An_CPi_exists :  ∀ c (G : context) (phi : constraint) (B : tm),
          c \notin dom G \u fv_co_co_tm B ->
         AnnPropWff G phi
         → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star
         → AnnTyping G (a_CPi phi B) a_Star.

  Axiom An_CAbs_exists :  ∀ c (G : context) (phi : constraint) (a B : tm),
      c \notin dom G \u fv_co_co_tm a \u fv_co_co_tm B ->
         AnnPropWff G phi
         → AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
                (open_tm_wrt_co B (g_Var_f c))
         → AnnTyping G (a_CAbs phi a) (a_CPi phi B).

  Axiom An_CAbs_inversion : ∀ (G : context) (phi : constraint) (a A : tm),
    AnnTyping G (a_CAbs phi a) A ->
      exists B, A = (a_CPi phi B) /\
      forall c, c  `notin` dom G (* \u fv_co_co_tm a \u fv_co_co_tm B *) ->
        AnnPropWff G phi /\
        AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
                  (open_tm_wrt_co B (g_Var_f c)).

  Axiom An_AbsCong_exists : ∀ x1 x2 (G : context) D rho (g1 g2 : co) (A1 b1 A2 b3 b2 B : tm),
      x1 `notin` (dom G \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b2 \u  fv_tm_tm_co g2)
      -> x2 `notin` (dom G \u fv_tm_tm_tm b2 \u fv_tm_tm_tm b3 \u  fv_tm_tm_co g1)
      ->  AnnDefEq G D g1 A1 A2
      → (AnnDefEq ([(x1, Tm A1)] ++ G) D  (open_co_wrt_tm g2 (a_Var_f x1))
                  (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1)))
      → (open_tm_wrt_tm b3 (a_Var_f x2) =
         open_tm_wrt_tm b2 (a_Conv (a_Var_f x2) (g_Sym g1)))
      → AnnTyping G A1 a_Star
      → AnnTyping G A2 a_Star
      → RhoCheck rho x1 (erase_tm (open_tm_wrt_tm b1 (a_Var_f x1)))
      → RhoCheck rho x2 (erase_tm (open_tm_wrt_tm b3 (a_Var_f x2)))
      → AnnTyping G (a_Abs rho A1 b2) B
      → AnnDefEq G D (g_AbsCong rho g1 g2) (a_Abs rho A1 b1) (a_Abs rho A2 b3).

  Axiom An_AbsCong_inversion :
    forall G D rho g1 g2 B1 B2,
      AnnDefEq G D (g_AbsCong rho g1 g2) B1 B2 ->
    exists A1 A2 b1 b2 b3 B,
      B1 = (a_Abs rho A1 b1) /\
      B2 = (a_Abs rho A2 b3) /\
      AnnTyping G A1 a_Star  /\
      AnnTyping G A2 a_Star  /\
      AnnDefEq G D g1 A1 A2  /\
      AnnTyping G (a_Abs rho A1 b2) B /\
      (forall x, x \notin dom G  (* \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b2 \u fv_tm_tm_tm b3 *) ->
          AnnDefEq  (( x ~ Tm A1) ++  G) D (open_co_wrt_tm g2 (a_Var_f x)) (open_tm_wrt_tm b1 (a_Var_f x))  ((open_tm_wrt_tm b2 (a_Var_f x))) /\
          (open_tm_wrt_tm b3 (a_Var_f x)) = (open_tm_wrt_tm b2 (a_Conv (a_Var_f x) (g_Sym g1))) /\
          (RhoCheck rho x  (erase_tm (open_tm_wrt_tm b1 (a_Var_f x)))) /\
          (RhoCheck rho x  (erase_tm (open_tm_wrt_tm b3 (a_Var_f x))))).

  Axiom An_CPiCong_exists : ∀ c1 c2 (G : context) D (g1 g3 : co) (phi1 : constraint)
       (B1 : tm) (phi2 : constraint) (B3 B2 : tm),
    AnnIso G D g1 phi1 phi2
    -> c1 `notin` D \u fv_co_co_tm B2 \u fv_co_co_tm B1 \u fv_co_co_co g3
    -> c2 `notin` fv_co_co_co g1 \u fv_co_co_tm B2 \u fv_co_co_tm B3
    → (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
                (open_tm_wrt_co B1 (g_Var_f c1)) (open_tm_wrt_co B2 (g_Var_f c1)))
    → (open_tm_wrt_co B3 (g_Var_f c2) =
       open_tm_wrt_co B2 (g_Cast (g_Var_f c2) (g_Sym g1)))
    → AnnTyping G (a_CPi phi1 B1) a_Star
    → AnnTyping G (a_CPi phi2 B3) a_Star
    -> AnnTyping G (a_CPi phi1 B2) a_Star
    → AnnDefEq G D (g_CPiCong g1 g3) (a_CPi phi1 B1)
               (a_CPi phi2 B3).

  Axiom An_CPiCong_inversion :  ∀ (G : context) D (g1 g3 : co) (A1 A2 : tm),
    AnnDefEq G D (g_CPiCong g1 g3) A1 A2 ->
      exists phi1 phi2 B1 B2 B3,
        A1 = (a_CPi phi1 B1) /\
        A2 = (a_CPi phi2 B3) /\
        AnnIso G D g1 phi1 phi2 /\
        AnnTyping G (a_CPi phi1 B1) a_Star /\
        AnnTyping G (a_CPi phi2 B3) a_Star /\
        AnnTyping G (a_CPi phi1 B2) a_Star /\
        (forall c, c `notin` dom G (* \u D \u fv_co_co_tm B2 \u fv_co_co_tm B1
             \u fv_co_co_co g3 \u
                fv_co_co_co g1 \u fv_co_co_tm B3 *) →
          (AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c))
          (open_tm_wrt_co B1 (g_Var_f c)) (open_tm_wrt_co B2 (g_Var_f c))) /\
          (open_tm_wrt_co B3 (g_Var_f c) = open_tm_wrt_co B2 (g_Cast (g_Var_f c) (g_Sym g1)))).

  Axiom An_PiCong_exists : forall x1 x2 (G:context) D rho
                             (g1 g2 : co) (A1 B1 A2 B3 B2 : tm),
      x1 `notin` (dom G \u fv_tm_tm_tm B1 \u fv_tm_tm_tm B2 \u  fv_tm_tm_co g2)
      -> x2 `notin` (dom G \u fv_tm_tm_tm B2 \u fv_tm_tm_tm B3 \u  fv_tm_tm_co g1)
      ->  AnnDefEq G D g1 A1 A2
      → AnnDefEq ([(x1, Tm A1)] ++ G) D (open_co_wrt_tm g2 (a_Var_f x1))
                 (open_tm_wrt_tm B1 (a_Var_f x1)) (open_tm_wrt_tm B2 (a_Var_f x1))
      → (open_tm_wrt_tm B3 (a_Var_f x2) =
         open_tm_wrt_tm B2 (a_Conv (a_Var_f x2) (g_Sym g1)))
      → AnnTyping G (a_Pi rho A1 B1) a_Star
      → AnnTyping G (a_Pi rho A2 B3) a_Star
      → AnnTyping G (a_Pi rho A1 B2) a_Star
      → AnnDefEq G D (g_PiCong rho g1 g2) (a_Pi rho A1 B1) (a_Pi rho A2 B3).

  Axiom An_PiCong_inversion : forall (G:context) (D:available_props) (rho:relflag) (g1 g2:co) (C1 C2 :tm),
    AnnDefEq G D (g_PiCong rho g1 g2) C1 C2 ->
      exists A1 B1 A2 B2 B3,
      C1 = (a_Pi rho A1 B1) /\
      C2 = (a_Pi rho A2 B3) /\
      AnnTyping G (a_Pi rho A1 B1) a_Star /\
      AnnTyping G (a_Pi rho A2 B3) a_Star /\
      AnnTyping G (a_Pi rho A1 B2) a_Star /\
      AnnDefEq G D g1 A1 A2 /\
      (forall x , x \notin dom G  ->
            AnnDefEq  ((x ~ Tm  A1) ++ G) D (open_co_wrt_tm g2 (a_Var_f x)) (open_tm_wrt_tm B1 (a_Var_f x)) ((open_tm_wrt_tm B2 (a_Var_f x)))  /\
            (open_tm_wrt_tm B3 (a_Var_f x)  = (open_tm_wrt_tm  B2 (a_Conv (a_Var_f x) (g_Sym g1))))).

  Axiom An_CAbsCong_exists :
  forall c1 c2 (G : context) (D : available_props) (g1 g3 g4 : co)
    (phi1 : constraint) (a1 : tm) (phi2 : constraint) (a3 a2 B1 B2 B: tm),
    AnnIso G D g1 phi1 phi2
    -> c1 `notin` D \u fv_co_co_tm a2 \u fv_co_co_tm a1 \u fv_co_co_co g3
    -> c2 `notin` fv_co_co_co g1 \u fv_co_co_tm a2 \u fv_co_co_tm a3
    → (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
                (open_tm_wrt_co a1 (g_Var_f c1)) (open_tm_wrt_co a2 (g_Var_f c1)))
    → (open_tm_wrt_co a3 (g_Var_f c2) =
       open_tm_wrt_co a2 (g_Cast (g_Var_f c2) (g_Sym g1)))
    → AnnTyping G (a_CAbs phi1 a1) (a_CPi phi1 B1)
    → AnnTyping G (a_CAbs phi2 a3) (a_CPi phi2 B2)
    → AnnDefEq G (dom G) g4 (a_CPi phi1 B1) (a_CPi phi2 B2)
    -> AnnTyping G (a_CAbs phi1 a2) B
    → AnnDefEq G D (g_CAbsCong g1 g3 g4) (a_CAbs phi1 a1) (a_CAbs phi2 a3).

  Axiom An_CAbsCong_inversion :
  forall (G : context) (D : available_props) (g1 g3 g4 : co) A1 A2,
    AnnDefEq G D (g_CAbsCong g1 g3 g4) A1 A2
    -> exists phi1 phi2 a1 a2 a3 B1 B2 B,
      A1 = (a_CAbs phi1 a1) /\
      A2 = (a_CAbs phi2 a3) /\
      AnnIso G D g1 phi1 phi2 /\
      AnnTyping G (a_CAbs phi1 a1) (a_CPi phi1 B1) /\
      AnnTyping G (a_CAbs phi2 a3) (a_CPi phi2 B2) /\
      AnnTyping G (a_CAbs phi1 a2) B /\
      AnnDefEq G (dom G) g4 (a_CPi phi1 B1) (a_CPi phi2 B2) /\
 forall c1,
      c1`notin` dom G (* \u D \u fv_co_co_tm a2 \u fv_co_co_tm a1 \u fv_co_co_co g3
                  \u fv_co_co_co g1 \u fv_co_co_tm a3 *)
    → (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
                (open_tm_wrt_co a1 (g_Var_f c1)) (open_tm_wrt_co a2 (g_Var_f c1))) /\
      (open_tm_wrt_co a3 (g_Var_f c1) =
       open_tm_wrt_co a2 (g_Cast (g_Var_f c1) (g_Sym g1))).

  (* -----  inversion lemmas for some typing judgments (with maximal co-finite quantification) ----------- *)

  Axiom An_Pi_inversion :
    ∀ (G:context) rho A B T,
      AnnTyping G (a_Pi rho A B) T ->
      T = a_Star /\
      AnnTyping G A a_Star /\
      ∀ x, x \notin dom G -> AnnTyping (( x ~ Tm  A) ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star.

  Axiom An_Abs_inversion :
    ∀ (G:context) rho (a:tm) A A1,
    AnnTyping G (a_Abs rho A a) A1 ->
    (exists B, A1 = a_Pi rho A B /\
    AnnTyping G A a_Star /\
    ∀ x, x \notin dom G ->
      RhoCheck rho x (erase_tm (open_tm_wrt_tm a (a_Var_f x))) /\
      AnnTyping (( x ~ Tm  A) ++ G)
                (open_tm_wrt_tm a (a_Var_f x))
                (open_tm_wrt_tm B (a_Var_f x))).

  Axiom An_CPi_inversion :
    ∀ (G:context) (phi : constraint) (B T : tm),
      AnnTyping G (a_CPi phi B) T ->
      T = a_Star /\
      AnnPropWff G phi /\
      ∀ c, c \notin dom G -> AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co B (g_Var_f c)) a_Star.

  (* -------------- name swapping ------------------------ *)

  Axiom AnnTyping_tm_swap : forall c c0 B G a A,
    c `notin` fv_tm_tm_tm A ->
    c `notin` fv_tm_tm_tm a ->
    c0 `notin` dom G \u {{ c }} ->
    AnnTyping ([(c, Tm B)] ++ G) (open_tm_wrt_tm a (a_Var_f c))
         (open_tm_wrt_tm A (a_Var_f c)) ->
    AnnTyping ([(c0, Tm B)] ++ G) (open_tm_wrt_tm a (a_Var_f c0))
                  (open_tm_wrt_tm A (a_Var_f c0)).

  Axiom AnnDefEq_tm_swap : forall x1 x G A1 D g2 b1 b2,
   x1 `notin` fv_tm_tm_co g2 \u fv_tm_tm_tm b1 \u fv_tm_tm_tm b2
  -> x `notin` dom G \u {{ x1 }}
  -> AnnDefEq ([(x1, Tm A1)] ++ G) D  (open_co_wrt_tm g2 (a_Var_f x1))
             (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1))
  -> AnnDefEq ([(x, Tm A1)] ++ G) D  (open_co_wrt_tm g2 (a_Var_f x))
             (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x)).

 Axiom AnnTyping_co_swap : forall c c0 phi G a A,
    c `notin` fv_co_co_tm A ->
    c `notin` fv_co_co_tm a ->
    c0 `notin` dom G \u {{ c }} ->
    AnnTyping ([(c, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c))
         (open_tm_wrt_co A (g_Var_f c)) ->
    AnnTyping ([(c0, Co phi)] ++ G) (open_tm_wrt_co a (g_Var_f c0))
                  (open_tm_wrt_co A (g_Var_f c0)).

  Axiom AnnDefEq_co_swap : forall c1 c phi1 G D g3 B1 B2,
    c1 `notin` D \u fv_co_co_tm B1 \u fv_co_co_tm B2 \u fv_co_co_co g3 ->
    c `notin` dom G \u {{ c1 }} ->
    (AnnDefEq ([(c1, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c1))
              (open_tm_wrt_co B1 (g_Var_f c1)) (open_tm_wrt_co B2 (g_Var_f c1)))
    -> (AnnDefEq ([(c, Co phi1)] ++ G) D (open_co_wrt_co g3 (g_Var_f c))
              (open_tm_wrt_co B1 (g_Var_f c)) (open_tm_wrt_co B2 (g_Var_f c))).

  Create HintDb smart_cons_exists discriminated.
  Hint Resolve An_Pi_exists An_Abs_exists An_CPi_exists An_CAbs_exists An_AbsCong_exists An_CPiCong_exists An_CAbsCong_exists : smart_cons_exists.

End fc_subst_sig.

(**************** FC Uniqueness ****************)
Module Type fc_unique_sig.

Axiom AnnTyping_unique :
    forall G a A1, AnnTyping G a A1 -> forall {A2}, AnnTyping G a A2 -> A1 = A2.
Axiom AnnIso_unique  :
  forall G D g p1 p2, AnnIso G D g p1 p2 ->
                 forall {q1 q2}, AnnIso G D g q1 q2 -> p1 = q1 /\ p2 = q2.
Axiom AnnDefEq_unique    :
  forall G D g a b,
      AnnDefEq G D g a b -> forall {a1 b1}, AnnDefEq G D g a1 b1 -> a = a1 /\ b = b1.

End fc_unique_sig.


(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import boolp reals distr.
(* ------- *) Require Import inhabited notations.

Require Import Eqdep_dec.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GRing.Theory Num.Theory.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Declare Scope syn_scope.
Declare Scope xsyn_scope.
Declare Scope vsyn_scope.
Declare Scope mem_scope.

Delimit Scope syn_scope with S.
Delimit Scope xsyn_scope with X.
Delimit Scope vsyn_scope with V.
Delimit Scope mem_scope with M.

(* -------------------------------------------------------------------- *)
Parameter R : realType.

Canonical real_ihbType := Eval hnf in IhbType R 0.

Notation Distr T := {distr T / R}.

(* -------------------------------------------------------------------- *)
Section MemType.
Variable (mident : eqType).

Record memType_ : Type := mkMem {
  mheap    :> choiceType;
  mget_    :  mheap -> forall (T : ihbType), mident -> T;
  mset_    :  mheap -> forall (T : ihbType), mident -> T -> mheap;
  mget_eq_  : forall T m x v, @mget_ (@mset_ m T x v) T x = v;
  mget_neq_ : forall T U m x y v, (T <> U \/ x != y) ->
                @mget_ (@mset_ m T x v) U y = @mget_ m U y;
}.

Section GetSet.
Variable (M : memType_) (T : ihbType).

Definition mget (m : M) (x : mident) :=
  nosimpl (@mget_ M m T x).

Definition mset (m : M) (x : mident) (v : T) :=
  nosimpl (@mset_ M m T x v).

End GetSet.

Variable (M : memType_) (T U : ihbType).

Lemma mget_eq (m : M) (x : mident) (v : T) : mget T (mset m x v) x = v.
Proof. by unlock mget mset; apply/mget_eq_. Qed.

Lemma mget_neq (m : M) (x y : mident) (v : T) : (T <> U \/ x != y) ->
  mget U (mset m x v) y = mget U m y.
Proof. by unlock mget mset; apply/mget_neq_. Qed.

Definition memType_of of phant mident := memType_.
End MemType.

Notation memType T := (memType_of (Phant T)).

(* -------------------------------------------------------------------- *)
(* Expressions and probabilistic expressions *)

Section Vars.
Context {ident : eqType}.

Inductive vars_r (T : ihbType) :=
| Var of ident.

Definition vars_of of phant ident := vars_r.
End Vars.

Notation vars_ ident := (vars_of (Phant ident)).

(* -------------------------------------------------------------------- *)
Section Syntax.
Context {ident : eqType} {mem : memType ident}.

Local Notation vars := (vars_ ident).

Definition vname {T} (v : vars T) :=
  let: Var name := v in name.

Definition vtype {T} (v : vars T) := T.

Inductive expr_ : Type -> Type :=
| var_  {T}   of vars T : expr_ T
| cst_  {T}   of T : expr_ T
| prp_        of pred mem : expr_ bool
| app_  {T U} of expr_ (T -> U) & expr_ T : expr_ U.

Notation bexpr   := (expr_ bool).
Notation dexpr T := (expr_ (Distr T)).

(* -------------------------------------------------------------------- *)
Bind Scope syn_scope with expr_.

(* -------------------------------------------------------------------- *)
Section VarsEqType.
Variables (T : ihbType) (I : eqType).

Definition vars_eq (x y : vars_ I T) :=
  let: Var x := x in let: Var y := y in x == y.

Lemma vars_eqP (x y : vars_ I T) : reflect (x = y) (vars_eq x y).
Proof.
by case: x y => [x] [y]; apply: (iffP idP) => /= [/eqP->|[->]].
Qed.

Definition vars_eqMixin := EqMixin vars_eqP.
Canonical vars_eqType := EqType (vars_ I T) vars_eqMixin.
End VarsEqType.

Canonical tvars_eqType (I : eqType) := Eval hnf in @tag_eqType
  (EqType ihbType (comparableMixin (fun x y => pselect (x = y))))
  (vars_eqType^~ I).

(* -------------------------------------------------------------------- *)
Lemma eq_vars {t u : ihbType} (x : vars t) (y : vars u) :
      (Tagged vars y = Tagged vars x)
  <-> (vtype x = vtype y /\ vname x == vname y).
Proof. split.
+ case: x y => [x] [y]; rewrite /vtype /= => /(@eqP (tvars_eqType ident)).
  rewrite -tag_eqE /tag_eq /= => /andP[/eqP] /= ->.
  by rewrite tagged_asE => /eqP[->]; rewrite eqxx.
+ by case: x y => [x] [y]; rewrite /vtype /= => -[-> /eqP->].
Qed.

(* -------------------------------------------------------------------- *)
(* Commands *)

Inductive cmd_ : Type :=
| abort
| skip
| assign {t} of vars t & expr_ t
| random {t} of vars t & dexpr t
| cond       of bexpr & cmd_ & cmd_
| while      of bexpr & cmd_
| seqc       of cmd_ & cmd_.

Bind Scope syn_scope with cmd_.
End Syntax.

(* -------------------------------------------------------------------- *)
Notation "'If' e 'then' c1 'else' c2"
  := (cond e%X c1%S c2%S) : syn_scope.

Notation "'IfT' e 'then' c1"
  := (cond e%X c1%S skip) : syn_scope.

Notation "'While' e 'Do' c"
  := (while e%X c%S) : syn_scope.

Notation "x <<- e"
  := (assign x%V e%X) : syn_scope.

Notation "x <$- d"
  := (random x%V d%X) : syn_scope.

Notation "c1 ;; c2"
  := (seqc c1%S c2%S) : syn_scope.

Local Open Scope syn_scope.

(* -------------------------------------------------------------------- *)
Arguments expr_ : clear implicits.
Arguments cmd_  : clear implicits.

(* -------------------------------------------------------------------- *)
Parameter ident : countType.

Notation sident := (Countable.sort ident).

(* -------------------------------------------------------------------- *)
Section CoreMem.

Inductive coremem :=
  CoreMem (m : forall {T : ihbType}, ident -> T).

Definition coremem_get := (fun m => let: CoreMem m := m in m).

Coercion coremem_get : coremem >-> Funclass.

Definition coremem_set := nosimpl (fun (m : coremem) {T : ihbType} x v =>
  CoreMem (fun U y =>
    if pselect (T = U) is left eq then
      if x == y then ecast _ _ eq v else m U y
    else coremem_get m U y)).

Lemma get_set_eq {T : ihbType} (m : coremem) (x : ident) (v : T) :
  (coremem_set m x v) T x = v.
Proof.
rewrite /coremem_get /=; case: (pselect _) => // eq; rewrite eqxx.
suff ->: eq = erefl T by done.
by apply/UIP_dec=> {}x y; apply/pselect.
Qed.

Lemma get_set_nex {T U : ihbType} (m : coremem) (x y : ident) (v : T) :
  x != y -> (coremem_set m x v) U y = m U y.
Proof.
move=> ne_xy; rewrite /coremem_set /coremem_get /=.
by case: pselect => //; rewrite (negbTE ne_xy).
Qed.

Lemma get_set_net {T U : ihbType} (m : coremem) (x y: ident) (v : T) :
  T <> U -> (coremem_set m x v) U y = m U y.
Proof. by rewrite /coremem_set /coremem_get; case: pselect. Qed.

Lemma get_set_ne {T U : ihbType} (m : coremem) (x y : ident) (v : T) :
  (T <> U \/ x !=y) -> (coremem_set m x v) U y = m U y.
Proof. by move=> [/get_set_net |/get_set_nex] ->. Qed.

Lemma coremem_comparable : comparable coremem.
Proof. by move=> m1 m2; apply/pselect. Qed.

Definition coremem_eqMixin := comparableMixin coremem_comparable.
Canonical  coremem_eqType  := Eval hnf in EqType coremem coremem_eqMixin.

Axiom coremem_choice : choiceMixin coremem.
Canonical coremem_choiceType := Eval hnf in ChoiceType coremem coremem_choice.

End CoreMem.

Arguments coremem : clear implicits.

(* -------------------------------------------------------------------- *)
Definition cmem : memType ident := locked {|
  mheap     := [choiceType of coremem];
  mget_     := coremem_get;
  mset_     := coremem_set;
  mget_eq_  := @get_set_eq;
  mget_neq_ := @get_set_ne;
|}.

Notation dmem := (Distr cmem).

(* -------------------------------------------------------------------- *)
Inductive side : predArgType := SLeft | SRight.

Coercion bool_of_side (s : side) :=
  match s with SLeft => false | SRight => true end.

Definition side_of_bool (b : bool) :=
  if b then SRight else SLeft.

Lemma side_of_boolK : cancel bool_of_side side_of_bool.
Proof. by case. Qed.

Definition side_eqMixin := CanEqMixin side_of_boolK.
Canonical  side_eqType := Eval hnf in EqType side side_eqMixin.
Definition side_choiceMixin := CanChoiceMixin side_of_boolK.
Canonical  side_choiceType := Eval hnf in ChoiceType side side_choiceMixin.
Definition side_countMixin := CanCountMixin side_of_boolK.
Canonical  side_countType := Eval hnf in CountType side side_countMixin.
Definition side_finMixin := CanFinMixin side_of_boolK.
Canonical  side_finType := Eval hnf in FinType side side_finMixin.

Notation "''1'" := SLeft.
Notation "''2'" := SRight.

Definition mselect {T : Type} (s : side) (m : T * T) :=
  match s with
  | '1 => m.1
  | '2 => m.2
  end.

Notation "m # s" := (mselect s m) (at level 2, format "m # s") : mem_scope.

(* -------------------------------------------------------------------- *)
Lemma side2 {A : Type} s (x : A * A) : ((fst, snd)#s x = x#s)%M.
Proof. by case: s. Qed.

Lemma side_app {A B : Type} (f : A -> B) s (x y : A) :
  (f (x, y)#s = (f x, f y)#s)%M.
Proof. by case: s. Qed.

(* -------------------------------------------------------------------- *)
Notation rident := (sident * side)%type.

Definition coremem2 := (mheap cmem * mheap cmem)%type.

Definition coremem2_get (m : coremem2) T xs :=
  mget T (m#(xs.2))%M xs.1.

Definition coremem2_set (m : coremem2) (T : ihbType) xs (v : T) :=
  match xs.2 return coremem2 with
  | '1 => (mset m.1 xs.1 v, m.2)
  | '2 => (m.1, mset m.2 xs.1 v)
  end.

Coercion coremem2_get : coremem2 >-> Funclass.

Set Printing Coercions.

Lemma get_set2_eq {T} m x v : (@coremem2_set m T x v) T x = v.
Proof. by case: m x => m1 m2 [x []] /=; apply mget_eq. Qed.

Lemma get_set2_ne {T U} m x y v :
  (T <> U \/ x != y) -> (@coremem2_set m T x v) U y = m U y.
Proof.
case: m x y => m1 m2 [x []] [y []] //= h; apply mget_neq => /=;
  by (elim: h => h; [left | right; apply: contra h => /eqP->]).
Qed.

Canonical coremem2_choiceType := Eval hnf in [choiceType of coremem2].

(* -------------------------------------------------------------------- *)
Definition rmem : memType rident := nosimpl {|
  mheap     := [choiceType of coremem2];
  mget_     := coremem2_get;
  mset_     := coremem2_set;
  mget_eq_  := @get_set2_eq;
  mget_neq_ := @get_set2_ne;
|}.

(* -------------------------------------------------------------------- *)
Notation vars    := (vars_ sident).
Notation expr    := (expr_ _ cmem).
Notation cmd     := (cmd_  _ cmem).
Notation bexpr   := (expr bool).
Notation dexpr T := (expr (Distr T)).
Notation prp     := (@prp_ _ cmem).

(* -------------------------------------------------------------------- *)
Notation app2_ f x1 x2 := (app_ (app_ f x1) x2).

Reserved Notation "x =b y" (at level 70, no associativity).
Reserved Notation "x =i y" (at level 70, no associativity).

Definition beq (x y : bool) : bool := x == y.
Definition ieq (x y : int ) : bool := x == y.

Notation "c %:S"    := (@cst_ _ _ _ c) (at level 2, format "c %:S").
Notation "e1 =b e2" := (app2_ (cst_ beq) e1 e2)   : xsyn_scope.
Notation "e1 =i e2" := (app2_ (cst_ ieq) e1 e2)   : xsyn_scope.
Notation "e1 || e2" := (app2_ (cst_ orb  ) e1 e2) : xsyn_scope.
Notation "e1 && e2" := (app2_ (cst_ andb ) e1 e2) : xsyn_scope.
Notation "~~ e"     := (app_ (cst_ negb) e)       : xsyn_scope.
Notation "e1 + e2"  := (app2_ (cst_ +%R) e1 e2)   : xsyn_scope.
Notation "e1 * e2"  := (app2_ (cst_ *%R) e1 e2)   : xsyn_scope.
Notation "e1 :: e2" := (app2_ (cst_ cons) e1 e2)  : xsyn_scope.
Notation "` x"      := (@var_ _ _ _ x%V)          : xsyn_scope.

(* -------------------------------------------------------------------- *)
Section SynInject.
Context {I1 I2 : eqType} {mem1 : memType I1} {mem2:memType I2}
        (h : I1 -> I2) (mh : mem2 -> mem1).

Local Notation vars1 := (vars_ I1).
Local Notation vars2 := (vars_ I2).
Local Notation expr1 := (@expr_ I1 mem1).
Local Notation expr2 := (@expr_ I2 mem2).
Local Notation cmd1  := (cmd_  I1 mem1).
Local Notation cmd2  := (cmd_  I2 mem2).

Definition ivar {T : ihbType} (x : vars1 T) : vars2 T :=
  let: Var x := x in Var T (h x).

Definition iprop (p : pred mem1) : pred mem2 :=
  fun m => p (mh m).

Fixpoint iexpr {T : Type} (e : expr1 T) : expr2 T :=
  match e with
  | var_ _   x     => var_ (ivar x)
  | cst_ _   c     => cst_ c
  | prp_     p     => prp_ (iprop p)
  | app_ _ _ e1 e2 => app_ (iexpr e1) (iexpr e2)
  end.

Fixpoint icmd (c : cmd1) : cmd2 :=
  match c with
  | abort => abort
  | skip  => skip

  | x <<- e =>
      ivar x <<- iexpr e

  | x <$- e =>
      ivar x <$- iexpr e

  | If e then c1 else c2 =>
      If iexpr e then icmd c1 else icmd c2

  | While e Do c =>
      While iexpr e Do icmd c

  | seqc c1 c2 =>
      seqc (icmd c1) (icmd c2)
  end.
End SynInject.

(* -------------------------------------------------------------------- *)
Notation rvars := (vars_ rident).
Notation rexpr := (expr_ _ rmem).
Notation rcmd  := (cmd_  _ rmem).

Implicit Types (s : side).

Notation   irvar  s := (@ivar  _ _ (fun x => (x, s))) (only parsing).
Definition irexpr s := (@iexpr _ _ cmem rmem (fun x : ident => (x, s)) (fun m=> (m#s)%M)).
Definition ircmd  s := (@icmd  _ _ cmem rmem (fun x : ident => (x, s)) (fun m=> (m#s)%M)).

Reserved Notation "x # s" (at level 2, format "x # s").

Notation "x # s" := (ivar (pair^~ s) x) : vsyn_scope.
Notation "e # s" := (irexpr s e) : xsyn_scope.
Notation "c # s" := (ircmd s c) : syn_scope.
Notation rmem1 m := (m.1 : mem).
Notation rmem2 m := (m.2 : mem).
Notation rprp    := (@prp_ _ rmem).

(* -------------------------------------------------------------------- *)
Notation assn  := (pred cmem).
Notation dassn := (pred dmem).
Notation rassn := (pred rmem).


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import Bounds.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Local stack slots of integer type.
- Saved values of integer callee-save registers used by the function.
- Local stack slots of float type.
- Saved values of float callee-save registers used by the function.
- Space for the stack-allocated data declared in Cminor
- Return address.

The [frame_env] compilation environment records the positions of
the boundaries between these areas of the activation record.
*)

Definition fe_ofs_arg := 0.

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
(*  fe_ofs_link: Z; *)
(*  fe_ofs_retaddr: Z; *)
  fe_ofs_int_local: Z;
  fe_ofs_int_callee_save: Z;
  fe_num_int_callee_save: Z;
  fe_ofs_float_local: Z;
  fe_ofs_float_callee_save: Z;
  fe_num_float_callee_save: Z;
  fe_stack_data: Z
}.

(** Computation of the frame environment from the bounds of the current
  function. *)

Parameter is_strong_align : unit -> bool. (* whether to align stack by 8 or 16 *)

Definition strong_align : Z := if is_strong_align tt then 16 else 8.

Lemma strong_align_pos: strong_align > 0.
Proof.
  unfold strong_align. destruct (is_strong_align tt); omega.
Qed.

Definition make_env (b: bounds) :=
  let olink := 4 * b.(bound_outgoing) in  (* back link -- CANCELLED *)
  let oil := olink (* + 4 *) in              (* integer locals *)
  let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *)
  let oendi := oics + 4 * b.(bound_int_callee_save) in
  let ofl := align oendi 8 in             (* float locals *)
  let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *)
  let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *)
  let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
  let sz := align (oretaddr + 4) strong_align - 4  in
  mk_frame_env sz (* olink *) (* oretaddr *)
                  oil oics b.(bound_int_callee_save)
                  ofl ofcs b.(bound_float_callee_save)
                  ostkdata.

(** Separation property *)

Remark frame_env_separated:
  forall b,
  let fe := make_env b in
  0 <= fe_ofs_arg
  /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= (* fe.(fe_ofs_link)
  /\ fe.(fe_ofs_link) + 4 <= *) fe.(fe_ofs_int_local)
  /\ fe.(fe_ofs_int_local) + 4 * b.(bound_int_local) <= fe.(fe_ofs_int_callee_save)
  /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_local)
  /\ fe.(fe_ofs_float_local) + 8 * b.(bound_float_local) <= fe.(fe_ofs_float_callee_save)
  /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data)
  /\ fe.(fe_stack_data) + b.(bound_stack_data) <= (* fe.(fe_ofs_retaddr)
  /\ fe.(fe_ofs_retaddr) + 4 <= *) fe.(fe_size).
Proof.
  intros.
  generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
  generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 4 (refl_equal _)).
  generalize (align_le (align (fe.(fe_stack_data) + b.(bound_stack_data)) 4 + 4) _ strong_align_pos) .
  unfold fe, make_env, fe_size, (* fe_ofs_link, *) (* fe_ofs_retaddr, *)
    fe_ofs_int_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data, fe_ofs_arg.
  intros.
  generalize (bound_int_local_pos b); intro;
  generalize (bound_float_local_pos b); intro;
  generalize (bound_int_callee_save_pos b); intro;
  generalize (bound_float_callee_save_pos b); intro;
  generalize (bound_outgoing_pos b); intro;
  generalize (bound_stack_data_pos b); intro.
  omega.
Qed.

(** Alignment property *)

Lemma align_strong_align: (8 | strong_align).
Proof.
  unfold strong_align. destruct (is_strong_align tt).
   exists 2; reflexivity.
  exists 1; reflexivity.
Qed.

Remark frame_env_aligned:
  forall b,
  let fe := make_env b in
  (* (4 | fe.(fe_ofs_link))
  /\ *) (4 | fe.(fe_ofs_int_local))
  /\ (4 | fe.(fe_ofs_int_callee_save))
  /\ (8 | fe.(fe_ofs_float_local))
  /\ (8 | fe.(fe_ofs_float_callee_save))
(*  /\ (4 | fe.(fe_ofs_retaddr)) *)
  /\ (8 | fe.(fe_stack_data))
  /\ (4 | fe.(fe_size))
  /\ (strong_align | fe.(fe_size) + 4) (* to cope with the return address *)
.
Proof.
  intros.
  unfold fe, make_env, fe_size, (* fe_ofs_link, *) (* fe_ofs_retaddr, *)
    fe_ofs_int_local, fe_ofs_int_callee_save,
    fe_num_int_callee_save,
    fe_ofs_float_local, fe_ofs_float_callee_save, fe_num_float_callee_save,
    fe_stack_data.
  set (x1 := 4 * bound_outgoing b).
  assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
  set (x2 := x1 (* + 4 *)).
  assert (4 | x2). unfold x2; auto. (* apply Zdivide_plus_r; auto. exists 1; auto. *)
  set (x3 := x2 + 4 * bound_int_local b).
  assert (4 | x3). unfold x2; apply Zdivide_plus_r; auto. exists (bound_int_local b); ring.
  set (x4 := x3 + 4 * bound_int_callee_save b).
  set (x5 := align x4 8).
  assert (8 | x5). unfold x5. apply align_divides. omega.
  set (x6 := x5 + 8 * bound_float_local b).
  assert (8 | x6). unfold x6. apply Zdivide_plus_r; auto. exists (bound_float_local b); ring.
  set (x7 := x6 + 8 * bound_float_callee_save b).
  assert (8 | x7).
    unfold x7. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
  set (x8 := align (x7 + bound_stack_data b) 4).
  assert (4 | x8). apply align_divides. omega.
  replace (align (x8 + 4) strong_align - 4 + 4) with (align (x8 + 4) strong_align) by ring.
  generalize (align_divides (x8 + 4) _ strong_align_pos).
  intro.
  assert (4 | 8) by (exists 2; reflexivity).
  generalize (align_strong_align).
  intro.
  assert (4 | strong_align) by eauto using Zdivide_trans.
  assert (4 | align (x8 + 4) strong_align) by eauto using Zdivide_trans.
  assert (4 | align (x8 + 4) strong_align - 4).
   eapply Zdivide_plus_r.
   assumption.
   exists (-1); reflexivity.
  tauto.
Qed.
(*  set (x9 := x8 + 4).
  assert (4 | x9). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto.
  tauto.
Qed.
*)

Extract Constant is_strong_align => "fun _ -> false".


From Undecidability Require Import TM.Util.Prelim TM.Util.Relations TM.Util.TM_facts.

Set Default Proof Using "Type".

(* * Tapes-Lift *)

(* Select the [m] elements of [V], of that their index is in [I] *)
Definition select (m n: nat) (X: Type) (I : Vector.t (Fin.t n) m) (V : Vector.t X n) : Vector.t X m :=
  Vector.map (Vector.nth V) I.

Corollary select_nth m n X (I : Vector.t (Fin.t n) m) (V : Vector.t X n) (k : Fin.t m) :
  (select I V) [@ k] = V [@ (I [@ k])].
Proof. now apply Vector.nth_map. Qed.

(* Relational tapes-lift *)
Section LiftTapes_Rel.

  Variable (sig : finType) (F : Type).
  Variable m n : nat.

  Variable I : Vector.t (Fin.t n) m.

  Definition not_index (i : Fin.t n) : Prop :=
    ~ Vector.In i I.

  Variable (R : pRel sig F m).

  Definition LiftTapes_select_Rel : pRel sig F n :=
    fun t '(y, t') => R (select I t) (y, select I t').

  Definition LiftTapes_eq_Rel : pRel sig F n :=
    ignoreParam (fun t t' => forall i : Fin.t n, not_index i -> t'[@i] = t[@i]).

  Definition LiftTapes_Rel := LiftTapes_select_Rel ∩ LiftTapes_eq_Rel.

  Variable T : tRel sig m.

  Definition LiftTapes_T : tRel sig n :=
    fun t k => T (select I t) k.

End LiftTapes_Rel.

Arguments not_index : simpl never.
Arguments LiftTapes_select_Rel {sig F m n} I R x y /.
Arguments LiftTapes_eq_Rel {sig F m n} I x y /.
Arguments LiftTapes_Rel {sig F m n } I R x y /.
Arguments LiftTapes_T {sig m n} I T x y /.

Lemma vector_hd_nth (X : Type) (n : nat) (xs : Vector.t X (S n)) : Vector.hd xs = xs[@Fin0].
Proof. now destruct_vector. Qed.

Lemma vector_tl_nth (X : Type) (n : nat) (i : Fin.t (S n)) (xs : Vector.t X (S (S n))) : (Vector.tl xs)[@i] = xs[@Fin.FS i].
Proof. now destruct_vector. Qed.

Section Fill.

  Fixpoint lookup_index_vector {m n : nat} (I : Vector.t (Fin.t n) m) : Fin.t n -> option (Fin.t m) :=
    match I with
    | Vector.nil _ => fun (i : Fin.t n) => None
    | Vector.cons _ i' m' I' =>
      fun (i : Fin.t n) =>
        if Fin.eqb i i' then Some Fin0
        else match lookup_index_vector I' i with
             | Some j => Some (Fin.FS j)
             | None => None
             end
    end.

  Lemma Some_inj (X : Type) (x y : X) :
    Some x = Some y -> x = y.
  Proof. congruence. Qed.

  Lemma lookup_index_vector_Some (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) (j : Fin.t m) :
    dupfree I ->
    I[@j] = i ->
    lookup_index_vector I i = Some j.
  Proof.
    induction 1 as [ | m i' I' H1 H2 IH]; intros Heq; cbn in *.
    - contradict (fin_destruct_O j).
    - destruct (Fin.eqb i i') eqn:Eqb; cbn in *.
      + f_equal. apply Fin.eqb_eq in Eqb as ->.
        pose proof (fin_destruct_S j) as [(j'&->) | ->]; cbn in *.
        * exfalso. contradict H1. eapply vect_nth_In; eauto.
        * reflexivity.
      + destruct (lookup_index_vector I' i) as [j' | ] eqn:El.
        * pose proof (fin_destruct_S j) as [(j''&->) | ->]; cbn in *.
          -- specialize IH with (1 := Heq). apply Some_inj in IH as ->. reflexivity.
          -- subst. enough (Fin.eqb i i = true) by congruence. now apply Fin.eqb_eq.
        * exfalso. pose proof (fin_destruct_S j) as [(j''&->) | ->]; cbn in *.
          -- specialize IH with (1 := Heq). congruence.
          -- subst. enough (Fin.eqb i i = true) by congruence. now apply Fin.eqb_eq.
  Qed.

  Lemma lookup_index_vector_Some' (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) (j : Fin.t m) :
    lookup_index_vector I i = Some j ->
    I[@j] = i.
  Proof.
    revert i j. induction I as [ | i' n' I' IH ]; intros i j Hj.
    - destruct_fin j.
    - pose proof (fin_destruct_S j) as [(j'&->) | ->]; cbn in *.
      + destruct (Fin.eqb i i'); inv Hj.
        destruct (lookup_index_vector I' i) as [ j'' | ] eqn:Ej''.
        * apply Some_inj in H0. apply Fin.FS_inj in H0 as ->. now apply IH.
        * congruence.
      + destruct (Fin.eqb i i') eqn:Ei'.
        * now apply Fin.eqb_eq in Ei'.
        * destruct (lookup_index_vector I' i) as [ j'' | ] eqn:Ej''.
          -- congruence.
          -- congruence.
  Qed.

  Lemma lookup_index_vector_None (m n : nat) (I : Vector.t (Fin.t n) m) (i : Fin.t n) :
    (~ Vector.In i I) ->
    lookup_index_vector I i = None.
  Proof.
    intros HNotIn.
    destruct (lookup_index_vector I i) eqn:E; auto.
    exfalso. apply lookup_index_vector_Some' in E.
    contradict HNotIn. eapply vect_nth_In; eauto.
  Qed.

  Variable X : Type.

  (* Replace the elements of [init] of which the index is in [I] with the element in [V] of that index. *)
  Definition fill {m n : nat} (I : Vector.t (Fin.t n) m) (init : Vector.t X n) (V : Vector.t X m) : Vector.t X n :=
    tabulate (fun i => match lookup_index_vector I i with
                    | Some j => V[@j]
                    | None => init[@i]
                    end).

  Section Test.
    Variable (a b x y z : X).

    (* The following goals should hold by computation *)
    Goal fill [|Fin0; Fin1|] [|x;y;z|] [|a;b|] = [|a;b;z|].
    Proof. cbn. reflexivity. Qed.

    Goal fill [|Fin2; Fin1|] [|x;y;z|] [|a;b|] = [|x;b;a|].
    Proof. cbn. reflexivity. Qed.

    Goal fill [|Fin1; Fin0|] [|x;y;z|] [|a;b|] = [|b;a;z|]. (* [a] and [b] are swapped, [z] is unchanged. *)
    Proof. cbn. reflexivity. Qed.

    (* This didn't hold (by computation) for the old version with replacement *)
    Goal forall (ss : Vector.t X 3), fill [|Fin0; Fin1|] ss [|a;b|] = [|a;b; ss[@Fin2]|].
    Proof. intros. cbn. reflexivity. Qed.

  End Test.

  Variable m n : nat.
  Implicit Types (i : Fin.t n) (j : Fin.t m).
  Implicit Types (I : Vector.t (Fin.t n) m) (init : Vector.t X n) (V : Vector.t X m).

  Lemma fill_correct_nth I init V i j :
    dupfree I ->
    I[@j] = i ->
    (fill I init V)[@i] = V[@j].
  Proof.
    intros HDup Heq.
    unfold fill. simpl_vector.
    erewrite lookup_index_vector_Some; eauto.
  Qed.

  Lemma fill_not_index I init V (i : Fin.t n) :
    not_index I i ->
    (fill I init V)[@i] = init[@i].
  Proof.
    intros HNotIn. unfold not_index in HNotIn.
    unfold fill. simpl_vector.
    erewrite lookup_index_vector_None; eauto.
  Qed.

  Definition fill_default I (def : X) V :=
    fill I (Vector.const def n) V.

  Corollary fill_default_not_index I V def i :
    not_index I i ->
    (fill_default I def V)[@i] = def.
  Proof. intros. unfold fill_default. rewrite fill_not_index; auto. apply Vector.const_nth. Qed.

End Fill.

Section loop_map.
  Variable A B : Type.
  Variable (f : A -> A) (h : A -> bool) (g : A -> B).
  Hypothesis step_map_comp : forall a, g (f a) = g a.

  Lemma loop_map k a1 a2 :
    loop f h a1 k = Some a2 ->
    g a2 = g a1.
  Proof using step_map_comp.
    revert a1 a2. induction k as [ | k' IH]; intros; cbn in *.
    - destruct (h a1); now inv H.
    - destruct (h a1).
      + now inv H.
      + apply IH in H. now rewrite step_map_comp in H.
  Qed.

End loop_map.

Section LiftNM.

  Variable sig : finType.

  Variable m n : nat.

  Variable F : finType.

  Variable pM : pTM sig F m.

  Variable I : Vector.t ((Fin.t n)) m.
  Variable I_dupfree : dupfree I.

  Definition LiftTapes_trans :=
    fun '(q, sym ) =>
      let (q', act) := trans (m := projT1 pM) (q, select I sym) in
      (q', fill_default I (None, Nmove) act).

  Definition LiftTapes_TM : TM sig n :=
    {|
      trans := LiftTapes_trans;
      start := start (projT1 pM);
      halt := halt (m := projT1 pM);
    |}.

  Definition LiftTapes : pTM sig F n := (LiftTapes_TM; projT2 pM).

  Definition selectConf : mconfig sig (state LiftTapes_TM) n -> mconfig sig (state (projT1 pM)) m :=
    fun c => mk_mconfig (cstate c) (select I (ctapes c)).

  Lemma current_chars_select (t : tapes sig n) :
    current_chars (select I t) = select I (current_chars t).
  Proof. unfold current_chars, select. apply Vector.eq_nth_iff; intros i ? <-. now simpl_tape. Qed.

  Lemma doAct_select (t : tapes sig n) act :
    doAct_multi (select I t) act = select I (doAct_multi t (fill_default I (None, Nmove) act)).
  Proof using I_dupfree.
    unfold doAct_multi, select. apply Vector.eq_nth_iff; intros i ? <-. simpl_tape.
    unfold fill_default. f_equal. symmetry. now apply fill_correct_nth.
  Qed.

  Lemma LiftTapes_comp_step (c1 : mconfig sig (state (projT1 pM)) n) :
    step (M := projT1 pM) (selectConf c1) = selectConf (step (M := LiftTapes_TM) c1).
  Proof using I_dupfree.
    unfold selectConf. unfold step; cbn.
    destruct c1 as [q t] eqn:E1.
    unfold step in *. cbn -[current_chars doAct_multi] in *.
    rewrite current_chars_select.
    destruct (trans (q, select I (current_chars t))) as (q', act) eqn:E; cbn.
    f_equal. apply doAct_select.
  Qed.

  Lemma LiftTapes_lift (c1 c2 : mconfig sig (state LiftTapes_TM) n) (k : nat) :
    loopM (M := LiftTapes_TM) c1 k = Some c2 ->
    loopM (M := projT1 pM) (selectConf c1) k = Some (selectConf c2).
  Proof using I_dupfree.
    intros HLoop.
    eapply loop_lift with (f := step (M := LiftTapes_TM)) (h := haltConf (M := LiftTapes_TM)).
    - cbn. auto.
    - intros ? _. now apply LiftTapes_comp_step.
    - apply HLoop.
  Qed.

  Lemma LiftTapes_comp_eq (c1 c2 : mconfig sig (state LiftTapes_TM) n) (i : Fin.t n) :
    not_index I i ->
    step (M := LiftTapes_TM) c1 = c2 ->
    (ctapes c2)[@i] = (ctapes c1)[@i].
  Proof.
    intros HI H. unfold LiftTapes_TM in *.
    destruct c1 as [state1 tapes1] eqn:E1, c2 as [state2 tapes2] eqn:E2.
    unfold step, select in *. cbn in *.
    destruct (trans (state1, select I (current_chars tapes1))) as (q, act) eqn:E3.
    inv H. erewrite Vector.nth_map2; eauto. now rewrite fill_default_not_index.
  Qed.

  Lemma LiftTapes_eq (c1 c2 : mconfig sig (state LiftTapes_TM) n) (k : nat) (i : Fin.t n) :
    not_index I i ->
    loopM (M := LiftTapes_TM) c1 k = Some c2 ->
    (ctapes c2)[@i] = (ctapes c1)[@i].
  Proof.
    intros Hi HLoop. unfold loopM in HLoop.
    eapply loop_map with (g := fun c => (ctapes c)[@i]); eauto.
    intros. now apply LiftTapes_comp_eq.
  Qed.

  Lemma LiftTapes_Realise (R : Rel (tapes sig m) (F * tapes sig m)) :
    pM ⊨ R ->
    LiftTapes ⊨ LiftTapes_Rel I R.
  Proof using I_dupfree.
    intros H. split.
    - apply (H (select I t) k (selectConf outc)).
      now apply (@LiftTapes_lift (initc LiftTapes_TM t) outc k).
    - hnf. intros i HI. now apply (@LiftTapes_eq (initc LiftTapes_TM t) outc k i HI).
  Qed.

  Lemma LiftTapes_unlift (k : nat)
        (c1 : mconfig sig (state (LiftTapes_TM)) n)
        (c2 : mconfig sig (state (LiftTapes_TM)) m) :
    loopM (M := projT1 pM) (selectConf c1) k = Some c2 ->
    exists c2' : mconfig sig (state (LiftTapes_TM)) n,
      loopM (M := LiftTapes_TM) c1 k = Some c2' /\
      c2 = selectConf c2'.
  Proof using I_dupfree.
    intros HLoop. unfold loopM in *. cbn in *.
    apply loop_unlift with (lift:=selectConf) (f:=step (M:=LiftTapes_TM)) (h:=haltConf (M:=LiftTapes_TM)) in HLoop as (c'&HLoop&->).
    - exists c'. split; auto.
    - auto.
    - intros ? _. apply LiftTapes_comp_step.
  Qed.

  Lemma LiftTapes_Terminates T :
    projT1 pM ↓ T ->
    projT1 LiftTapes ↓ LiftTapes_T I T.
  Proof using I_dupfree.
    intros H initTapes k Term. hnf in *.
    specialize (H (select I initTapes) k Term) as (outc&H).
    pose proof (@LiftTapes_unlift k (initc LiftTapes_TM initTapes) outc H) as (X&X'&->). eauto.
  Qed.

  Lemma LiftTapes_RealiseIn R k :
    pM ⊨c(k) R ->
    LiftTapes ⊨c(k) LiftTapes_Rel I R.
  Proof using I_dupfree.
    intros (H1&H2) % Realise_total. apply Realise_total. split.
    - now apply LiftTapes_Realise.
    - eapply TerminatesIn_monotone.
      + apply LiftTapes_Terminates; eauto.
      + firstorder.
  Qed.

End LiftNM.

Arguments LiftTapes : simpl never.
Notation "pM @ ts" := (LiftTapes pM ts) (at level 41, only parsing).

(* * Tactic Support *)

(* TODO: Some of this is probably deprecated, e.g. the [app_tapes] stuff *)

Lemma smpl_dupfree_helper1 (n : nat) :
  dupfree [|Fin.F1 (n := n)|].
Proof. vector_dupfree. Qed.

Lemma smpl_dupfree_helper2 (n : nat) :
  dupfree [|Fin.FS (Fin.F1 (n := n))|].
Proof. vector_dupfree. Qed.

Ltac smpl_dupfree :=
  once lazymatch goal with
  | [ |- dupfree [|Fin.F1 |] ] => apply smpl_dupfree_helper1
  | [ |- dupfree [|Fin.FS |] ] => apply smpl_dupfree_helper2
  | [ |- dupfree _ ] => now vector_dupfree (* fallback tactic *)
  end.

Ltac smpl_TM_LiftN :=
  once lazymatch goal with
  | [ |- LiftTapes _ _ ⊨ _] =>
    apply LiftTapes_Realise; [ smpl_dupfree | ]
  | [ |- LiftTapes _ _ ⊨c(_) _] => apply LiftTapes_RealiseIn; [ smpl_dupfree | ]
  | [ |- projT1 (LiftTapes _ _) ↓ _] => apply LiftTapes_Terminates; [ smpl_dupfree | ]
  end.
Smpl Add smpl_TM_LiftN : TM_Correct.

Ltac is_num_const n :=
  once lazymatch n with
  | O => idtac
  | S ?n => is_num_const n
  | _ => fail "Not a number"
  end.

(*
Section Test_Is_Num_Const.
  Variable n : nat.
  Eval cbn in ltac:(is_num_const 42).
  Fail Eval cbn in ltac:(is_num_const n).
  Fail Eval cbn in ltac:(is_num_const (S n)).
End Test_Is_Num_Const.
*)

(* This tactical executes [t 0], ..., [t (n-1)]. *)
Ltac do_n_times n t :=
  match n with
  | O => idtac
  | (S ?n') =>
    t 0;
    do_n_times n' ltac:(fun i => let next := constr:(S i) in t next)
  end.
(*
Eval cbn in ltac:(do_n_times 42 ltac:(fun a => idtac a)).
*)

(* This similiar tactical executes [t Fin0], ..., [t Fin_(n-1)]. *)
Ltac do_n_times_fin_rect n m t :=
  once lazymatch n with
  | O => idtac
  | S ?n' =>
    let m' := eval hnf in (pred m) in
    let one := eval cbv in (@Fin.F1 _ : Fin.t m) in
    t one;
    do_n_times_fin_rect n' m' ltac:(fun i => let next := eval hnf in (Fin.FS i) in t next)
  end.

Ltac do_n_times_fin n t := do_n_times_fin_rect n n t.

(*
Eval cbn in ltac:(do_n_times_fin 3 ltac:(fun a => idtac a)).
Eval cbn in ltac:(do_n_times_fin 3 ltac:(fun a => let x := eval simpl in (a : Fin.t 3) in idtac x)).
*)

(* Check whether a vector (syntactically) contains an element *)
Ltac vector_contains a vect :=
  once lazymatch vect with
  | @Vector.nil ?A => fail "Vector doesn't contain" a
  | @Vector.cons ?A a ?n ?vect' => idtac
  | @Vector.cons ?A ?b ?n ?vect' => vector_contains a vect'
  | _ => fail "No vector" vect
  end.

(* Fail Check ltac:(vector_contains 42 (@Vector.nil nat); idtac "yes!"). *)
(* Check ltac:(vector_contains 42 [|4;8;15;16;23;42|]; idtac "yes!"). *)

(*
 * The tactic [simpl_not_in_vector] tries to specialise hypothesises of the form
 * [H : forall i : Fin.t n, not_index [F1; ...; Fk] i -> _]
 * with [i := Fin0], ..., [i := Fin(n-1)] to new assumptions [H_0].
 *)

Lemma splitAllFin k' n (P : Fin.t (k'+n) -> Prop):
  (forall i, P i) -> (forall (i : Fin.t k'), P (Fin.L n i)) /\ (forall (i : Fin.t n), P (Fin.R k' i)).
Proof.
  easy.
Qed.

Fixpoint not_indexb {n} (v : list (Fin.t n)) (i : Fin.t n) {struct v}: bool :=
match v with
  []%list => true
| (i'::v)%list => if Fin.eqb i' i then false else not_indexb v i
end.

Lemma not_index_reflect n m (v : Vector.t _ m) (i : Fin.t n):
  not_index v i <-> not_indexb (Vector.to_list v) i = true.
Proof.
  unfold Vector.to_list. induction v;cbn. easy.
  specialize (Fin.eqb_eq _ h i) as H'.
  destruct Fin.eqb. { destruct H' as [->]. 2:easy. split. 2:easy. destruct 1. constructor. }
  rewrite <- IHv. cbv;intuition. apply H3. now constructor. apply H3.
  inversion H4;subst. now specialize (H2 eq_refl). apply Eqdep_dec.inj_pair2_eq_dec in H8;subst. easy.
  decide equality.
Qed.

Arguments not_indexb : simpl nomatch.

Lemma not_index_reflect_helper n m (v : Vector.t _ m) (P : Fin.t n -> Prop):
(forall i : Fin.t n, not_index v i  -> P i)
-> (forall i : Fin.t n, if not_indexb (Vector.to_list v) i then P i else True).
Proof.
  intros H i. specialize (H i). setoid_rewrite not_index_reflect in H. destruct not_indexb;now eauto.
Qed.

Lemma not_index_reflect_helper2 n' (l : list _) (P : Fin.t n' -> Prop):
(forall i : Fin.t n', if not_indexb l i then P i else True)
-> (forall i : Fin.t n', not_index (Vector.of_list l) i  -> P i).
Proof.
  intros H i. specialize (H i). setoid_rewrite not_index_reflect.
  rewrite VectorSpec.to_list_of_list_opp. destruct not_indexb;now eauto.
Qed.

Local Definition _Flag_DisableWarning := Lock unit.

Local Definition _flag_DisableWarning : _Flag_DisableWarning := tt.

Ltac simpl_not_in_vector_one :=
  let moveCnstLeft :=
    let rec loop k n :=
      lazymatch n with
        S ?n => loop uconstr:(S k) n
      | _ => uconstr:(k + n)
      end
    in loop 0
    in
  once lazymatch goal with
  | [ H : forall i : Fin.t ?n, not_index ?vect i -> _ |- _ ] =>
    specialize (not_index_reflect_helper H);clear H;intros H;
    let n' := moveCnstLeft n in
    change n with n' in H at 1;
    let tmp := fresh "tmp" in
    apply splitAllFin in H as [tmp H];
    cbn [not_indexb Vector.to_list Fin.R Vector.caseS Fin.eqb Vector.nth] in H;
    let helper i :=
      let H' := fresh H "_0" in
      assert (H':= tmp i);
      cbn in H';
      once lazymatch type of H' with
        | if (if Nat.eqb ?k ?k then false else true) then _ else True =>
        fail 1000 "arguments for not_indexb should have been set to [simpl nomatch]";clear H'
        | if not_indexb (?i::_)%list ?i then _ else True => clear H'
        | ?i = ?j => idtac
        | True => clear H'
        | ?G => idtac "simpl_not_in_vector_one is not intended for this kind of non-ground tape index" G
      end
    in
    once lazymatch type of tmp with
      forall i : Fin.t ?n, _ =>
        do_n_times_fin n helper;clear tmp
    end;
    match type of H with
    | forall i : Fin.t 0, _ => clear H
    | forall u, if _ then _ else _ =>
          specialize (not_index_reflect_helper2 H);clear H;intros H;cbn [Vector.of_list] in H
    | forall i : Fin.t _, _[@ _] = _[@ _] => idtac
    | ?t => match goal with
            | H : _Flag_DisableWarning |- _ => idtac
            | |- _ =>  idtac "unexpected case in simpl_not_in_vector_one" t
            end
    end
  end.

Ltac simpl_not_in_vector := repeat simpl_not_in_vector_one.

(* (* Test *) *)
(* Goal True. *)
(*   assert (forall i : Fin.t 10, not_index [|Fin8; Fin1; Fin2; Fin3|] i -> i = i) as HInj by firstorder. *)
(*   simpl_not_in_vector_one. *)
(*   Fail Check HInj. *)
(*   Show Proof. *)
(*   Check (HInj_0 : Fin0 = Fin0). *)
(*   Check (HInj_1 : Fin4 = Fin4). *)
(*   Check (HInj_2 : Fin5 = Fin5). *)
(*   Check (HInj_3 : Fin6 = Fin6). *)
(*   Check (HInj_4 : Fin7 = Fin7). *)
(*   Check (HInj_5 : Fin9 = Fin9). *)
(* Abort. *)

Ltac simpl_not_in := repeat simpl_not_in_vector.


From Coq Require Import ZArith.ZArith MSets.MSetPositive FSets.FMapPositive
     Strings.String Strings.Ascii Bool.Bool Lists.List Strings.HexString.
From Crypto.Util Require Import
     ListUtil
     Strings.String Strings.Decimal Strings.Show
     ZRange.Operations ZRange.Show
     OptionList Bool.Equality.
Require Import Crypto.Util.Option.

Require Import Crypto.Util.ZRange.

From Crypto Require Import IR Stringification.Language AbstractInterpretation.ZRange.

Import ListNotations.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope zrange_scope.
Local Open Scope Z_scope.

Import IR.Compilers.ToString.
Import Stringification.Language.Compilers.
Import Stringification.Language.Compilers.Options.
Import Stringification.Language.Compilers.ToString.
Import Stringification.Language.Compilers.ToString.int.Notations.

Module Zig.
  Definition comment_module_header_block := List.map (fun line => "// " ++ line)%string.
  Definition comment_block := List.map (fun line => "// " ++ line)%string.

  (* Zig natively supports any integer size between 0 and 4096 bits.
     So, we never need to define our own types. *)
  Definition int_type_to_string_opt_typedef {skip_typedefs : skip_typedefs_opt} {language_naming_conventions : language_naming_conventions_opt} (typedef_private : bool) (prefix : string) (t : ToString.int.type) (typedef : option string) : string :=
    match (if skip_typedefs then None else typedef) with
    | None => (if int.is_unsigned t then "u" else "i") ++ Decimal.Z.to_string (ToString.int.bitwidth_of t)
    | Some typedef => format_typedef_name prefix typedef_private typedef
    end.
  Definition int_type_to_string {language_naming_conventions : language_naming_conventions_opt} (t : ToString.int.type) : string :=
    int_type_to_string_opt_typedef (skip_typedefs:=true) false "" t None.

  Definition primitive_type_to_string_opt_typedef
             {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt}
             (all_private : bool)
             (prefix : string) (t : IR.type.primitive)
             (r : option ToString.int.type) (typedef : option string) : string :=
    match t with
    | IR.type.Zptr => "*"
    | IR.type.Z => ""
    end ++ match r with
           | Some int_t => int_type_to_string_opt_typedef all_private prefix int_t typedef
           | None => "ℤ" (* blackboard bold Z for unbounded integers (which don't actually exist, and thus will error) *)
           end.
  Definition primitive_type_to_string {language_naming_conventions : language_naming_conventions_opt} (t : IR.type.primitive)
             (r : option ToString.int.type) : string :=
    primitive_type_to_string_opt_typedef (skip_typedefs:=true) false "" t r None.

  Definition primitive_array_type_to_string
             {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt}
             (all_private : bool)
             (prefix : string) (t : IR.type.primitive)
             (r : option ToString.int.type) (len : nat) (typedef : option string) : string :=
    match (if skip_typedefs then None else typedef) with
    | Some typedef => format_typedef_name prefix all_private typedef
    | None => "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]" ++
                  primitive_type_to_string t r
    end.

  Definition make_typedef
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             (prefix : string) (private : bool)
             (typedef : typedef_info)
    : list string
    := let '(name, (ty, array_len), description) := name_and_type_and_describe_typedef prefix private typedef in
       ((comment_block description)
          ++ [(if private then "const " else "pub const ")
                ++ name ++ " = " ++
                let ty_string := match ty with
                                 | Some ty => int_type_to_string ty
                                 | None => "ℤ" (* blackboard bold Z for unbounded integers (which don't actually exist, and thus will error) *)
                                 end in
                match array_len with
                | None (* just an integer *) => ty_string
                | Some None (* unknown array length *) => "*" ++ ty_string
                | Some (Some len) => "[" ++ Decimal.Z.to_string (Z.of_nat len) ++ "]" ++ ty_string
                end
                ++ ";"]%string)%list.

  Definition header
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             {package_namev : package_name_opt}
             {class_namev : class_name_opt}
             {output_options : output_options_opt}
             (machine_wordsize : Z) (internal_private : bool) (private : bool) (prefix : string) (infos : ToString.ident_infos)
             (typedef_map : list typedef_info)
    : list string
    := (["";
         "const std = @import(""std"");";
         "const mode = @import(""builtin"").mode; // Checked arithmetic is disabled in non-debug modes to avoid side channels";
         "";
         "inline fn cast(comptime DestType: type, target: anytype) DestType {";
         "    @setEvalBranchQuota(10000);";
         "    if (@typeInfo(@TypeOf(target)) == .Int) {";
         "        const dest = @typeInfo(DestType).Int;";
         "        const source = @typeInfo(@TypeOf(target)).Int;";
         "        if (dest.bits < source.bits) {";
         "            return @bitCast(DestType, @truncate(std.meta.Int(source.signedness, dest.bits), target));";
         "        } else {";
         "            return @bitCast(DestType, @as(std.meta.Int(source.signedness, dest.bits), target));";
         "        }";
         "    }";
         "    return @as(DestType, target);";
         "}"]
          ++ (if skip_typedefs
              then []
              else List.flat_map
                     (fun td_name =>
                        match List.find (fun '(name, _, _, _) => (td_name =? name)%string) typedef_map with
                        | Some td_info => [""] ++ make_typedef prefix private td_info
                        | None => ["@compilerError(""Could not find typedef info for '" ++ td_name ++ "'"");"]%string
                        end%list)
                     (typedefs_used infos)))%list.

  (* Integer literal to string *)
  Definition int_literal_to_string (prefix : string) (t : IR.type.primitive) (v : BinInt.Z) : string :=
    match t with
    | IR.type.Z => HexString.of_Z v (* Zig can automatically figure out the size of integer literals *)
    | IR.type.Zptr => "@compilerError(""literal address " ++ HexString.of_Z v ++ """);"
    end.

  Import IR.Notations.

  Fixpoint arith_to_string
           {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool)
           (prefix : string) {t} (e : IR.arith_expr t) : string
    := let special_name_ty name ty := ToString.format_special_function_name_ty internal_private prefix name ty in
       let special_name name bw := ToString.format_special_function_name internal_private prefix name false(*unsigned*) bw in
       match e with
       (* integer literals *)
       | (IR.literal v @@@ _) => int_literal_to_string prefix IR.type.Z v
       (* array dereference *)
       | (IR.List_nth n @@@ IR.Var _ v) => "(" ++ v ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "])"
       (* (de)referencing *)
       | (IR.Addr @@@ IR.Var _ v) => "&" ++ v
       | (IR.Dereference @@@ e) => "( " ++ arith_to_string internal_private prefix e ++ ".* )"
       (* bitwise operations *)
       | (IR.Z_shiftr offset @@@ e) =>
         "(" ++ arith_to_string internal_private prefix e ++ " >> " ++ Decimal.Z.to_string offset ++ ")"
       | (IR.Z_shiftl offset @@@ e) =>
         "(" ++ arith_to_string internal_private prefix e ++ " << " ++ Decimal.Z.to_string offset ++ ")"
       | (IR.Z_land @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " & " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lor @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " | " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lxor @@@ (e1, e2)) =>
         "(" ++ arith_to_string internal_private prefix e1 ++ " ^ " ++ arith_to_string internal_private prefix e2 ++ ")"
       | (IR.Z_lnot _ @@@ e) => "(~" ++ arith_to_string internal_private prefix e ++ ")"
       (* arithmetic operations *)
       | (IR.Z_add @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " + " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_mul @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " * " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_sub @@@ (x1, x2)) =>
         "(" ++ arith_to_string internal_private prefix x1 ++ " - " ++ arith_to_string internal_private prefix x2 ++ ")"
       | (IR.Z_bneg @@@ e) => "(~" ++ arith_to_string internal_private prefix e ++ ")"
       | (IR.Z_mul_split lg2s @@@ args) =>
         special_name "mulx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_add_with_get_carry lg2s @@@ args) =>
         special_name "addcarryx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_sub_with_get_borrow lg2s @@@ args) =>
         special_name "subborrowx" lg2s ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_zselect ty @@@ args) =>
         special_name_ty "cmovznz" ty ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_value_barrier ty @@@ args) =>
         special_name_ty "value_barrier" ty ++ "(" ++ arith_to_string internal_private prefix args ++ ")"
       | (IR.Z_static_cast int_t @@@ e) =>
         "cast(" ++ primitive_type_to_string IR.type.Z (Some int_t) ++ ", " ++ arith_to_string internal_private prefix e ++ ")"
       | IR.Var _ v => v
       | IR.Pair A B a b => arith_to_string internal_private prefix a ++ ", " ++ arith_to_string internal_private prefix b
       | (IR.Z_add_modulo @@@ (x1, x2, x3)) => "@compilerError(""addmodulo"");"
       | (IR.List_nth _ @@@ _)
       | (IR.Addr @@@ _)
       | (IR.Z_add @@@ _)
       | (IR.Z_mul @@@ _)
       | (IR.Z_sub @@@ _)
       | (IR.Z_land @@@ _)
       | (IR.Z_lor @@@ _)
       | (IR.Z_lxor @@@ _)
       | (IR.Z_add_modulo @@@ _) => "@compilerError(""bad_arg"");"
       | IR.TT => "@compilerError(""tt"");"
       end%string%Cexpr.

  Definition stmt_to_string
             {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool)
             (prefix : string) (e : IR.stmt) : string :=
    match e with
    | IR.Call val => arith_to_string internal_private prefix val ++ ";"
    | IR.Assign true t sz name val =>
      (* local non-mutable declaration with initialization *)
      "const " ++ name ++ " = " ++ arith_to_string internal_private prefix val ++ ";"
    | IR.Assign false _ sz name val =>
    (* code : name ++ " = " ++ arith_to_string internal_private prefix val ++ ";" *)
      "@compilerError(""trying to assign value to non-mutable variable"");"
    | IR.AssignZPtr name sz val =>
      name ++ ".* = " ++ arith_to_string internal_private prefix val ++ ";"
    | IR.DeclareVar t sz name =>
      "var " ++ name ++ ": " ++ primitive_type_to_string t sz ++ " = undefined;"
    | IR.Comment lines _ =>
      String.concat String.NewLine (comment_block (ToString.preprocess_comment_block lines))
    | IR.AssignNth name n val =>
      name ++ "[" ++ Decimal.Z.to_string (Z.of_nat n) ++ "] = " ++ arith_to_string internal_private prefix val ++ ";"
    end.

  Definition to_strings {language_naming_conventions : language_naming_conventions_opt} (internal_private : bool) (prefix : string) (e : IR.expr) : list string :=
    List.map (stmt_to_string internal_private prefix) e.

  Import Rewriter.Language.Language.Compilers Crypto.Language.API.Compilers IR.OfPHOAS.
  Local Notation tZ := (base.type.type_base base.type.Z).

  Inductive Mode := In | Out.

  Fixpoint to_base_arg_list {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (all_private : bool) (prefix : string) (mode : Mode) {t} : ToString.OfPHOAS.base_var_data t -> list string :=
    match t return base_var_data t -> _ with
    | tZ =>
      let typ := match mode with In => IR.type.Z | Out => IR.type.Zptr end in
      fun '(n, is_ptr, r, typedef) => [n ++ ": " ++ primitive_type_to_string_opt_typedef all_private prefix typ r typedef]
    | base.type.prod A B =>
      fun '(va, vb) => (to_base_arg_list internal_private all_private prefix mode va ++ to_base_arg_list internal_private all_private prefix mode vb)%list
    | base.type.list tZ =>
      fun '(n, r, len, typedef) =>
        let modifier := match mode with
                        | In => (* arrays for inputs are immutable *) ""
                        | Out => (* arrays for outputs are mutable *) "*"
                        end in
        [ n ++ ": " ++ modifier ++ primitive_array_type_to_string all_private prefix IR.type.Z r len typedef ]
    | base.type.list _ => fun _ => ["@compilerError(""complex list"");"]
    | base.type.option _ => fun _ => ["@compilerError(""option"");"]
    | base.type.unit => fun _ => ["@compilerError(""unit"");"]
    | base.type.type_base t => fun _ => ["@compilerError(""" ++ show t ++ """);"]%string
    end%string.

  Definition to_arg_list {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (all_private : bool) (prefix : string) (mode : Mode) {t} : var_data t -> list string :=
    match t return var_data t -> _ with
    | type.base t => to_base_arg_list internal_private all_private prefix mode
    | type.arrow _ _ => fun _ => ["@compilerError(""arrow"");"]
    end%string.

  Fixpoint to_arg_list_for_each_lhs_of_arrow {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (all_private : bool) (prefix : string) {t} : type.for_each_lhs_of_arrow var_data t -> list string
    := match t return type.for_each_lhs_of_arrow var_data t -> _ with
       | type.base t => fun _ => nil
       | type.arrow s d
         => fun '(x, xs)
            => to_arg_list internal_private all_private prefix In x ++ to_arg_list_for_each_lhs_of_arrow internal_private all_private prefix xs
       end%list.

  (** * Language-specific numeric conversions to be passed to the PHOAS -> IR translation *)

  Definition Zig_bin_op_natural_output
    : IR.Z_binop -> ToString.int.type * ToString.int.type -> ToString.int.type
    := fun idc '(t1, t2)
       => ToString.int.union t1 t2.

  Definition Zig_bin_op_casts
    : IR.Z_binop -> option ToString.int.type -> ToString.int.type * ToString.int.type -> option ToString.int.type * (option ToString.int.type * option ToString.int.type)
    := fun idc desired_type '(t1, t2)
       => match desired_type with
          | Some desired_type
            => let ct := ToString.int.union t1 t2 in
               let desired_type' := Some (ToString.int.union ct desired_type) in
               (Some desired_type,
                (get_Zcast_up_if_needed desired_type' (Some t1),
                 get_Zcast_up_if_needed desired_type' (Some t2)))
          | None => (None, (None, None))
          end.

  Definition Zig_un_op_casts
    : IR.Z_unop -> option ToString.int.type -> ToString.int.type -> option ToString.int.type * option ToString.int.type
    := fun idc desired_type t
       => match idc with
          | IR.Z_shiftr offset
            =>
            let t' := ToString.int.union_zrange r[0~>2^offset]%zrange t in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type (Some t'),
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed (Some t') (Some t))
          | IR.Z_shiftl offset
            =>
            let rpre_out := match desired_type with
                            | Some rout => Some (ToString.int.union_zrange r[0~>2^offset] (ToString.int.unsigned_counterpart_of rout))
                            | None => Some (ToString.int.of_zrange_relaxed r[0~>2^offset]%zrange)
                            end in
            ((** We cast the result down to the specified type, if needed *)
              get_Zcast_down_if_needed desired_type rpre_out,
              (** We cast the argument up to a large enough type *)
              get_Zcast_up_if_needed rpre_out (Some t))
          | IR.Z_lnot ty
            => (
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_value_barrier ty
            => (
              get_Zcast_down_if_needed desired_type (Some ty),
              (** always cast to the width of the type, unless we are already exactly that type (which the machinery in IR handles *)
              Some ty)
          | IR.Z_bneg
            => ((* bneg is !, i.e., takes the argument to 1 if its not zero, and to zero if it is zero; so we don't ever need to cast *)
              None, None)
          end.

  Local Instance ZigLanguageCasts : LanguageCasts :=
    {| bin_op_natural_output := Zig_bin_op_natural_output
       ; bin_op_casts := Zig_bin_op_casts
       ; un_op_casts := Zig_un_op_casts
       ; upcast_on_assignment := true
       ; upcast_on_funcall := true
       ; explicit_pointer_variables := false
    |}.

  Definition to_function_lines {language_naming_conventions : language_naming_conventions_opt} {skip_typedefs : skip_typedefs_opt} (internal_private : bool) (private : bool) (all_private : bool) (inline : bool) (prefix : string) (name : string)
             {t}
             (f : type.for_each_lhs_of_arrow var_data t * var_data (type.base (type.final_codomain t)) * IR.expr)
    : list string :=
    let '(args, rets, body) := f in
    ((if private || inline then "inline fn " else "pub fn ") ++ name ++
      "(" ++ String.concat ", " (to_arg_list internal_private all_private prefix Out rets ++ to_arg_list_for_each_lhs_of_arrow internal_private all_private prefix args) ++
      ") void {")%string :: (["    @setRuntimeSafety(mode == .Debug);"; ""]%string)%list ++ (List.map (fun s => "    " ++ s)%string (to_strings internal_private prefix body)) ++ ["}"%string]%list.

  (** In Zig, there is no munging of return arguments (they remain
      passed by pointers), so all variables are live *)
  Local Instance : consider_retargs_live_opt := fun _ _ _ => true.
  Local Instance : rename_dead_opt := fun s => s.
  (** No need to lift declarations to the top *)
  Local Instance : lift_declarations_opt := false.

  Definition ToFunctionLines
             {absint_opts : AbstractInterpretation.Options}
             {relax_zrange : relax_zrange_opt}
             {language_naming_conventions : language_naming_conventions_opt}
             {documentation_options : documentation_options_opt}
             {output_options : output_options_opt}
             (machine_wordsize : Z)
             (do_bounds_check : bool) (internal_private : bool) (private : bool) (all_private : bool) (inline : bool) (prefix : string) (name : string)
             {t}
             (e : API.Expr t)
             (comment : type.for_each_lhs_of_arrow var_data t -> var_data (type.base (type.final_codomain t)) -> list string)
             (name_list : option (list string))
             (inbounds : type.for_each_lhs_of_arrow Compilers.ZRange.type.option.interp t)
             (outbounds : Compilers.ZRange.type.base.option.interp (type.final_codomain t))
             (intypedefs : type.for_each_lhs_of_arrow var_typedef_data t)
             (outtypedefs : base_var_typedef_data (type.final_codomain t))
    : (list string * ToString.ident_infos) + string :=
    match ExprOfPHOAS do_bounds_check e name_list inbounds intypedefs outtypedefs with
    | inl (indata, outdata, f) =>
      inl (((List.map (fun s => if (String.length s =? 0)%nat then "///" else ("/// " ++ s))%string (comment indata outdata))
              ++ match input_bounds_to_string indata inbounds with
                 | nil => nil
                 | ls => ["/// Input Bounds:"] ++ List.map (fun v => "///   " ++ v)%string ls
                 end
              ++ match bound_to_string outdata outbounds with
                 | nil => nil
                 | ls => ["/// Output Bounds:"] ++ List.map (fun v => "///   " ++ v)%string ls
                 end
              ++ to_function_lines internal_private private all_private inline prefix name (indata, outdata, f))%list%string,
           IR.ident_infos.collect_all_infos f intypedefs outtypedefs)
    | inr nil =>
      inr ("Unknown internal error in converting " ++ name ++ " to Zig")%string
    | inr [err] =>
      inr ("Error in converting " ++ name ++ " to Zig:" ++ String.NewLine ++ err)%string
    | inr errs =>
      inr ("Errors in converting " ++ name ++ " to Zig:" ++ String.NewLine ++ String.concat String.NewLine errs)%string
    end.

  Definition OutputZigAPI : ToString.OutputLanguageAPI :=
    {| ToString.comment_block := comment_block;
       ToString.comment_file_header_block := comment_module_header_block;
       ToString.ToFunctionLines := @ToFunctionLines;
       ToString.header := @header;
       ToString.footer := fun _ _ _ _ _ _ _ _ _ => [];
       ToString.strip_special_infos machine_wordsize infos := infos |}.

End Zig.