Require Import Bool.Bool.
Require Import Lists.List.
Require Export Hash.

Parameter redex_amount : nat.

Inductive stp : Type :=
| tpVar : Z -> stp
| base : Z -> stp
| tpAll : stp -> stp
| tpArr : stp -> stp -> stp
| prop : stp.

Fixpoint stp_eq_dec (h1 h2:stp) : { h1 = h2 } + { h1 <> h2 }.
  destruct h1 as [n1|r1|a1|m1 m2|p1]; destruct h2 as [n2|r2|a2|w1 w2|p2]; try (right; discriminate).
  - destruct (Z.eq_dec n1 n2).
    + left. congruence.
    + right. congruence.
  - destruct (Z.eq_dec r1 r2).
    + left. congruence.
    + right. congruence.
  - destruct (stp_eq_dec a1 a2).
    + left. congruence.
    + right. congruence.
  - destruct (stp_eq_dec m1 w1).
    + destruct (stp_eq_dec m2 w2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - intuition.
  Defined.

Inductive trm : Type :=
| DB : Z -> trm
| TmH : hashval -> trm
| Prim : Z -> trm
| Ap : trm -> trm -> trm
| Lam : stp -> trm -> trm
| Imp : trm -> trm -> trm
| All : stp -> trm -> trm
| TTpAp : trm -> stp -> trm
| TTpLam : trm -> trm
| TTpAll : trm -> trm.

Fixpoint trm_eq_dec (h1 h2:trm) : { h1 = h2 } + { h1 <> h2 }.
  destruct h1 as [n1|r1|a1|m1 m2|p1 p2|k1 k2|x1 x2|y1 y2|e1|t1]; destruct h2 as [n2|r2|a2|w1 w2|d1 d2|f1 f2|b1 b2|l1 l2|e2|t2]; try (right; discriminate).
  - destruct (Z.eq_dec n1 n2).
    + left. congruence.
    + right. congruence.
  - destruct (hashval_eq_dec r1 r2).
    + left. congruence.
    + right. congruence.
  - destruct (Z.eq_dec a1 a2).
    + left. congruence.
    + right. congruence.
  - destruct (trm_eq_dec m1 w1).
    + destruct (trm_eq_dec m2 w2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (stp_eq_dec p1 d1).
    + destruct (trm_eq_dec p2 d2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (trm_eq_dec k1 f1).
    + destruct (trm_eq_dec k2 f2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (stp_eq_dec x1 b1).
    + destruct (trm_eq_dec x2 b2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (trm_eq_dec y1 l1).
    + destruct (stp_eq_dec y2 l2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (trm_eq_dec e1 e2).
    + left. congruence.
    + right. congruence.
  - destruct (trm_eq_dec t1 t2).
    + left. congruence.
    + right. congruence.
  Defined.

Inductive pf : Type :=
| Known : hashval -> pf
| Hyp : Z -> pf
| PrAp : pf -> pf -> pf
| TmAp : pf -> trm -> pf
| TpAp : pf -> stp -> pf
| PrLa : trm -> pf -> pf
| TmLa : stp -> pf -> pf
| TpLa : pf -> pf.

Fixpoint pf_eq_dec (h1 h2:pf) : { h1 = h2 } + { h1 <> h2 }.
  destruct h1 as [n1|r1|m1 m2|p1 p2|k1 k2|x1 x2|y1 y2|e1]; destruct h2 as [n2|r2|w1 w2|d1 d2|f1 f2|b1 b2|l1 l2|e2]; try (right; discriminate).
  - destruct (hashval_eq_dec n1 n2).
    + left. congruence.
    + right. congruence.
  - destruct (Z.eq_dec r1 r2).
    + left. congruence.
    + right. congruence.
  - destruct (pf_eq_dec m1 w1).
    + destruct (pf_eq_dec m2 w2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (pf_eq_dec p1 d1).
    + destruct (trm_eq_dec p2 d2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (pf_eq_dec k1 f1).
    + destruct (stp_eq_dec k2 f2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (trm_eq_dec x1 b1).
    + destruct (pf_eq_dec x2 b2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (stp_eq_dec y1 l1).
    + destruct (pf_eq_dec y2 l2).
      * left. congruence.
      * right. congruence.
    + right. congruence.
  - destruct (pf_eq_dec e1 e2).
    + left. congruence.
    + right. congruence.
Defined.

Definition gsign : Type := list (hashval * stp * (option trm)) * list (hashval * trm).

(* Utils *)

Definition first (x : hashval * stp * option trm) : hashval :=
match x with
  | (a, b, c) => a
end.

Fixpoint findsnd2 (k : list (hashval * trm )) (h : hashval) : option trm :=
  match (find (fun x : hashval * trm => hasheq h (fst x)) k) with
    | Some (_, t) => Some t
    | None => None
  end.

Fixpoint findsnd3 (o : list (hashval * stp * (option trm))) (h : hashval) : option stp :=
  match o with
    | nil => None
    | (x, t, _)::l => if hashval_eq_dec x h then Some t else findsnd3 l h
  end.

Fixpoint findthird (k : list (hashval * stp * option trm )) (h : hashval) (def : trm) : trm :=
  match find (fun x : hashval * stp * option trm => hasheq h (first x)) k with
    | Some (_, _, Some t) => t
    | Some (_, _, None) => def
    | None => def
  end.

(* Lift *)

Fixpoint upstp (t : stp) (i : Z) (j : Z) : stp :=
match t with
  | tpVar k => if (k <? i)%Z then tpVar k else tpVar (k + j)
  | tpArr t1 t2 => tpArr (upstp t1 i j) (upstp t2 i j)
  | tpAll t1 => tpAll (upstp t1 (i + 1) j)
  | _ => t
end.

Fixpoint upstp_trm (t : trm) (i : Z) (j : Z) : trm :=
match t with
  | Ap t1 t2 => Ap (upstp_trm t1 i j) (upstp_trm t2 i j)
  | Lam a1 t1 => Lam (upstp a1 i j) (upstp_trm t1 i j)
  | Imp t1 t2 => Imp (upstp_trm t1 i j) (upstp_trm t2 i j)
  | All b t1 => All (upstp b i j) (upstp_trm t1 i j)
  | TTpAp t1 b => TTpAp (upstp_trm t1 i j) (upstp b i j)
  | TTpLam t1 => TTpLam (upstp_trm t1 (i + 1) j)
  | TTpAll t1 => TTpAll (upstp_trm t1 (i + 1) j)
  | _ => t
end.

Fixpoint uptrm (t : trm) (i : Z) (j : Z) : trm :=
match t with
  | DB k => if (k <? i)%Z then DB k else DB (k + j)
  | Ap t1 t2 => Ap (uptrm t1 i j) (uptrm t2 i j)
  | Lam a1 t1 => Lam a1 (uptrm t1 (i + 1) j)
  | Imp t1 t2 => Imp (uptrm t1 i j) (uptrm t2 i j)
  | All b t1 => All b (uptrm t1 (i + 1) j)
  | TTpAp t1 b => TTpAp (uptrm t1 i j) b
  | TTpLam t1 => TTpLam (uptrm t1 i j)
  | TTpAll t1 => TTpAll (uptrm t1 i j)
  | _ => t
end.

(* Subst *)

Fixpoint subst_stpstp (a : stp) (j : Z) (b : stp) : stp :=
match a with
  | tpVar i => if (j =? i)%Z then
                if (j =? 0)%Z then
                  b
                else
                  upstp b 0 j
              else
                (if (j <? i)%Z then
                   tpVar (i - 1)
                 else
                   tpVar i)
  | tpAll t1 => tpAll (subst_stpstp t1 (j + 1) b)
  | tpArr t1 t2 => tpArr (subst_stpstp t1 j b) (subst_stpstp t2 j b)
  | _ => a
end.

Fixpoint subst_trmstp (t : trm) (j : Z) (s : stp) : trm :=
match t with
  | Ap t1 t2 => Ap (subst_trmstp t1 j s) (subst_trmstp t2 j s)
  | Lam a1 t1 => Lam (subst_stpstp a1 j s) (subst_trmstp t1 j s)
  | Imp t1 t2 => Imp (subst_trmstp t1 j s) (subst_trmstp t2 j s)
  | All b t1 => All (subst_stpstp b j s) (subst_trmstp t1 j s)
  | TTpAp t1 b => TTpAp (subst_trmstp t1 j s) (subst_stpstp b j s)
  | TTpLam t1 => TTpLam (subst_trmstp t1 (j + 1) s)
  | TTpAll t1 => TTpAll (subst_trmstp t1 (j + 1) s)
  | _ => t
end.

Fixpoint subst_trmtrm (t : trm) (j : Z) (s : trm) : trm :=
match t with
  | DB k => if (k =? j)%Z then
             uptrm s 0 j
           else
             (if (j <? k)%Z then
               DB (k - 1)
             else
               DB k)
  | Ap t1 t2 => Ap (subst_trmtrm t1 j s) (subst_trmtrm t2 j s)
  | Lam a1 t1 => Lam a1 (subst_trmtrm t1 (j + 1) s)
  | Imp t1 t2 => Imp (subst_trmtrm t1 j s) (subst_trmtrm t2 j s)
  | All b t1 => All b (subst_trmtrm t1 (j + 1) s)
  | TTpAp t1 b => TTpAp (subst_trmtrm t1 j s) b
  | TTpLam t1 => TTpLam (subst_trmtrm t1 j s)
  | TTpAll t1 => TTpAll (subst_trmtrm t1 j s)
  | _ => t
end.

(* Free vars *)

Fixpoint free_trm_trm (t : trm) (i : Z) : bool :=
match t with
  | DB j => (i =? j)%Z
  | Ap m1 m2 => free_trm_trm m1 i || free_trm_trm m2 i
  | Lam a m1 => free_trm_trm m1 (i + 1)
  | Imp m1 m2 => free_trm_trm m1 i || free_trm_trm m2 i
  | All a m1 => free_trm_trm m1 (i + 1)
  | _ => false
end.

Fixpoint free_stp_stp (t : stp) (i : Z) : bool :=
match t with
  | tpVar j => (i =? j)%Z
  | tpArr a1 a2 => free_stp_stp a1 i || free_stp_stp a2 i
  | tpAll a => free_stp_stp a (i + 1)
  | _ => false
end.

Fixpoint free_stp_trm (t : trm) (i : Z) : bool :=
match t with
  | Ap m1 m2 => free_stp_trm m1 i || free_stp_trm m2 i
  | Lam a m1 => free_stp_stp a i || free_stp_trm m1 i
  | Imp m1 m2 => free_stp_trm m1 i || free_stp_trm m2 i
  | All a m1 => free_stp_stp a i || free_stp_trm m1 i
  | TTpAp m1 a => free_stp_stp a i || free_stp_trm m1 i
  | TTpLam m1 => free_stp_trm m1 (i + 1)
  | TTpAll m1 => free_stp_trm m1 (i + 1)
  | _ => false
end.

(* Normalization *)

Fixpoint beta_eta_norm1 (t1 : trm) : trm * bool :=
match t1 with
  | Ap m1 m2 => let (t1, r1) := beta_eta_norm1 m1 in
               let (t2, r2) := beta_eta_norm1 m2 in
               match t1 with
                 | Lam a m => (subst_trmtrm m 0 t2, false)
                 | _ => (Ap t1 t2, r1 && r2)
               end
  | Lam a m1 => let (t1, r1) := beta_eta_norm1 m1 in
               match t1 with
                 | Ap m (DB 0) => if free_trm_trm m 0 then (uptrm m 0 (-1), false) else (Lam a t1, r1)
                 | _ => (Lam a t1, r1)
               end
  | TTpAp m1 a => let (t1, r1) := beta_eta_norm1 m1 in
                 match t1 with
                   | TTpLam m => (subst_trmstp m 0 a, false)
                   | _ => (TTpAp t1 a, r1)
                 end
  | TTpLam m1 =>  let (t1, r1) := beta_eta_norm1 m1 in
                 match t1 with
                   | TTpAp m (tpVar 0) => if free_stp_trm m 0 then (TTpLam t1, r1) else (upstp_trm m 0 (-1), false)
                   | _ => (TTpLam t1, r1)
                 end
  | Imp m1 m2 => let (t1, r1) := beta_eta_norm1 m1 in
                let (t2, r2) := beta_eta_norm1 m2 in
                (Imp t1 t2, r1 && r2)
  | All a m1 => let (t1, r1) := beta_eta_norm1 m1 in
               (All a t1, r1)
  | TTpAll m1 => let (t1, r1) := beta_eta_norm1 m1 in
               (TTpAll t1, r1)
  | _ => (t1, true)
end.

Fixpoint beta_eta_norm (t1 : trm) (count : nat) : trm * bool :=
match count with
  | O => (t1, false)
  | S n1 => match beta_eta_norm1 t1 with
             | (s, false) => beta_eta_norm s n1
             | a => a
           end
end.

Fixpoint is_norm (m:trm) : bool :=
  match m with
  | Ap (Lam _ _) _  => false
  | TTpAp (TTpLam _) _ => false
  | Lam a (Ap f (DB 0)) => (free_trm_trm f 0)
  | TTpLam (TTpAp f (tpVar 0)) => (free_stp_trm f 0)
  | Ap m1 m2  => is_norm m1 && is_norm m2
  | Lam a m1  => is_norm m1
  | Imp m1 m2  => is_norm m1 && is_norm m2
  | All a m1  => is_norm m1
  | TTpAp m1 a => is_norm m1
  | TTpLam m1 => is_norm m1
  | TTpAll m1 => is_norm m1
  | _ => true
end.

Fixpoint delta_norm1 (t1 : trm) (sg : gsign) : trm :=
match t1 with
  | TmH h => findthird (fst sg) h t1
  | Ap m1 m2 => Ap (delta_norm1 m1 sg) (delta_norm1 m2 sg)
  | Lam a m1 => Lam a (delta_norm1 m1 sg)
  | Imp m1 m2 => Imp (delta_norm1 m1 sg) (delta_norm1 m2 sg)
  | All a m1 => All a (delta_norm1 m1 sg)
  | TTpAp m1 a => TTpAp (delta_norm1 m1 sg) a
  | TTpLam m1 => TTpLam (delta_norm1 m1 sg)
  | TTpAll m1 => TTpAll (delta_norm1 m1 sg)
  | _ => t1
end.

Fixpoint has_delta_red (t1 : trm) : bool :=
match t1 with
  | TmH h => true
  | Ap m1 m2 => has_delta_red m1 || has_delta_red m2
  | Lam a m1 => has_delta_red m1
  | Imp m1 m2 => has_delta_red m1 || has_delta_red m2
  | All a m1 => has_delta_red m1
  | TTpAp m1 a => has_delta_red m1
  | TTpLam m1 => has_delta_red m1
  | TTpAll m1 => has_delta_red m1
  | _ => false
end.

Fixpoint delta_norm (t1 : trm) (sg : gsign) (count : nat) : trm :=
match count with
  | O => t1
  | S n1 => let t2 := delta_norm1 t1 sg in
    if has_delta_red t2 then delta_norm t2 sg n1 else t2
end.

Fixpoint beta_eta_delta_norm (t : trm) (sg : gsign) : option trm :=
let (s, res) := beta_eta_norm (delta_norm t sg (length (fst sg))) redex_amount in
if res then Some s else None.

(* Correctness *)

Inductive crt_stp : Z -> bool -> Z -> stp -> Prop :=
| tp_all : forall (v : Z) (t : stp) (bt : Z), crt_stp (v + 1) false bt t -> crt_stp v false bt (tpAll t)
| tp_smpl : forall (v : Z) (t : stp)  (bt : Z), crt_stp v true bt t -> crt_stp v false bt t
| stp_arr : forall (v : Z) (t1 : stp) (t2 : stp)  (bt : Z), crt_stp v true bt t1 -> crt_stp v true bt t2 -> crt_stp v true bt (tpArr t1 t2)
| stp_var : forall (v : Z) (n : Z) (bt : Z), (Z.lt n v) -> crt_stp v true bt (tpVar n)
| stp_prop : forall (v : Z) (bt : Z), crt_stp v true bt prop
| stp_base : forall (v : Z) (n : Z) (bt : Z), (Z.lt n bt) -> crt_stp v true bt (base n).

Axiom tp_all_rev : forall (v : Z) (t : stp) (bt : Z), crt_stp v false bt (tpAll t) -> crt_stp (v + 1) false bt t.
Axiom tp_smpl_rev1 : forall (v : Z) (t1 : stp) (t2 : stp) (bt : Z), crt_stp v false bt (tpArr t1 t2) -> crt_stp v true bt (tpArr t1 t2).
Axiom tp_smpl_rev2 : forall (v : Z) (n : Z) (bt : Z), crt_stp v false bt (base n) -> crt_stp v true bt (base n).
Axiom tp_smpl_rev3 : forall (v : Z) (n : Z) (bt : Z), crt_stp v false bt (tpVar n) -> crt_stp v true bt (tpVar n).
Axiom stp_arr_rev1 : forall (v : Z) (t1 : stp) (t2 : stp) (bt : Z), crt_stp v true bt (tpArr t1 t2) -> crt_stp v true bt t1.
Axiom stp_arr_rev2 : forall (v : Z) (t1 : stp) (t2 : stp) (bt : Z), crt_stp v true bt (tpArr t1 t2) -> crt_stp v true bt t2.
Axiom stp_var_rev : forall (v : Z) (n : Z) (bt : Z), crt_stp v true bt (tpVar n) -> (Z.lt n v).
Axiom stp_base_rev : forall (v : Z) (n : Z) (bt : Z), crt_stp v true bt (base n) -> (Z.lt n bt).
Axiom tp_not_stp : forall (v : Z) (t : stp) (bt : Z), ~ crt_stp v true bt (tpAll t).

Inductive crt_trm : Z -> bool -> list stp -> gsign -> list stp -> trm -> stp -> Prop :=
| trm_db : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign) (i : Z) (t : stp),
             nth_error ctx (Z.to_nat i) = Some t -> crt_trm v true ctx sgn thy (DB i) t
| trm_tmh : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(h : hashval)(t : stp),
              findsnd3 (fst sgn) h = Some t -> crt_trm v true ctx sgn thy (TmH h) t
| trm_prm : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(i : Z) (t : stp),
              nth_error thy (Z.to_nat i) = Some t -> crt_trm v true ctx sgn thy (Prim i) t
| trm_ap : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(a : stp)(b : stp)(s : trm)(t : trm),
             crt_trm v true ctx sgn thy s (tpArr a b) -> crt_trm v true ctx sgn thy t a -> crt_trm v true ctx sgn thy (Ap s t) b
| trm_lam : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(a : stp)(b : stp)(s : trm),
             crt_stp v true (Z.of_nat (length thy)) a -> crt_trm v true (a::ctx) sgn thy s b -> crt_trm v true ctx sgn thy (Lam a s) (tpArr a b)
| trm_imp : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(t : trm),
             crt_trm v true ctx sgn thy s prop -> crt_trm v true ctx sgn thy t prop -> crt_trm v true ctx sgn thy (Imp s t) prop
| trm_all : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(a : stp),
             crt_stp v true (Z.of_nat (length thy)) a -> crt_trm v true (a::ctx) sgn thy s prop -> crt_trm v true ctx sgn thy (All a s) prop
| trm_tap : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(a : stp)(b : stp),
             crt_stp v true (Z.of_nat (length thy)) b -> crt_trm v true ctx sgn thy s (tpAll a) -> crt_trm v true ctx sgn thy (TTpAp s b) (subst_stpstp a 0 b)
| trm_tlam : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(a : stp),
             crt_trm (v + 1) true (map (fun x:stp => upstp x 0 1) ctx) sgn thy s a -> crt_trm v true ctx sgn thy (TTpLam s) (tpAll a)
| trm_simpl : forall (v : Z)(thy : list stp)(sgn : gsign)(s : trm),
             crt_trm v true nil sgn thy s prop -> crt_trm v false nil sgn thy s prop
| trm_tall : forall (v : Z)(thy : list stp)(sgn : gsign)(s : trm),
             crt_trm (v + 1) false nil sgn thy s prop -> crt_trm v false nil sgn thy (TTpAll s) prop.

Axiom trm_db_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign) (i : Z) (t : stp),
   crt_trm v true ctx sgn thy (DB i) t -> nth_error ctx (Z.to_nat i) = Some t.

Axiom trm_tmh_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(h : hashval)(t : stp),
   crt_trm v true ctx sgn thy (TmH h) t -> findsnd3 (fst sgn) h = Some t.

Axiom trm_prm_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(i : Z) (t : stp),
  crt_trm v true ctx sgn thy (Prim i) t -> nth_error thy (Z.to_nat i) = Some t.

Axiom trm_ap_rev : forall (v : Z) (ctx : list stp)(thy : list stp)(sgn : gsign)(b : stp)(s : trm)(t : trm),
  crt_trm v true ctx sgn thy (Ap s t) b -> exists (a : stp), crt_trm v true ctx sgn thy s (tpArr a b) /\ crt_trm v true ctx sgn thy t a.

Axiom trm_lam_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(a : stp)(t : stp)(s : trm),
  crt_trm v true ctx sgn thy (Lam a s) t -> exists (b : stp), t = tpArr a b /\ crt_stp v true (Z.of_nat (length thy)) a /\ crt_trm v true (a::ctx) sgn thy s b.

Axiom trm_imp_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(t : trm)(t1 : stp),
  crt_trm v true ctx sgn thy (Imp s t) t1 -> t1 = prop /\ crt_trm v true ctx sgn thy s prop /\ crt_trm v true ctx sgn thy t prop.

Axiom trm_tap_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(t : stp)(b : stp),
  crt_trm v true ctx sgn thy (TTpAp s b) t -> exists (a : stp), t = (subst_stpstp a 0 b) /\ crt_stp v true (Z.of_nat (length thy)) b /\ crt_trm v true ctx sgn thy s (tpAll a).
Axiom trm_all_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(a : stp) (t:stp),
   crt_trm v true ctx sgn thy (All a s) t -> t = prop /\ crt_stp v true (Z.of_nat (length thy)) a /\ crt_trm v true (a::ctx) sgn thy s prop.

Axiom trm_tlam_rev : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign)(s : trm)(t : stp),
   crt_trm v true ctx sgn thy (TTpLam s) t -> exists (a : stp), t = tpAll a /\ crt_trm (v + 1) true (map (fun x:stp => upstp x 0 1) ctx) sgn thy s a.

Definition isnotTTpAll (t : trm) :=
match t with
  | TTpAll _ => False
  | _ => True
end.

Axiom trm_simpl_rev : forall (v : Z)(thy : list stp)(sgn : gsign)(s : trm)(t:stp),
   crt_trm v false nil sgn thy s t -> isnotTTpAll s -> crt_trm v true nil sgn thy s prop.

Axiom trm_not_ptrm : forall (v : Z)(ctx : list stp)(thy : list stp)(sgn : gsign) (s : trm) (t : stp),
   crt_trm v true ctx sgn thy (TTpAll s) t -> False.

Axiom trm_tall_rev : forall (v : Z)(thy : list stp)(sgn : gsign)(s : trm)(t:stp),
   crt_trm v false nil sgn thy (TTpAll s) t -> t = prop /\ crt_trm (v + 1) false nil sgn thy s prop.

Inductive crt_pf : Z -> list stp -> list trm -> gsign -> list stp -> pf -> trm -> Prop :=
| pf_known : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(h : hashval)(s : trm)(t : trm),
  findsnd2 (snd sgn) h = Some s -> beta_eta_delta_norm s sgn = Some t -> crt_pf v ctx phi sgn thy (Known h) t
| pf_hyp : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(i : Z)(t : trm),
  nth_error phi (Z.to_nat i) = Some t -> crt_pf v ctx phi sgn thy (Hyp i) t
| pf_prap : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(e : pf)(s : trm)(t : trm),
  crt_pf v ctx phi sgn thy d (Imp s t) -> crt_pf v ctx phi sgn thy e s -> crt_pf v ctx phi sgn thy (PrAp d e) t
| pf_tmap : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(s : trm)(t : trm)(a : stp)(q : trm),
  crt_pf v ctx phi sgn thy d (All a s) -> crt_trm v true ctx sgn thy t a -> Some q = beta_eta_delta_norm (subst_trmtrm s 0 (delta_norm t sgn (length (fst sgn)))) sgn -> crt_pf v ctx phi sgn thy (TmAp d t) q
| pf_stpap : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(s : trm)(q :trm)(a : stp),
  crt_pf v ctx phi sgn thy d (TTpAll s) -> crt_stp v true (Z.of_nat (length thy)) a -> subst_trmstp s 0 a = q -> crt_pf v ctx phi sgn thy (TpAp d a) q
| pf_tmlam : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(s : trm)(t : trm)(q : trm)(q2 : trm),
  crt_trm v true ctx sgn thy s prop -> Some q = beta_eta_delta_norm s sgn -> crt_pf v ctx (q::phi) sgn thy d t -> q2 = Imp q t -> crt_pf v ctx phi sgn thy (PrLa s d) q2
| pf_tplam : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(s : trm)(a : stp)(q : trm),
  crt_stp v true (Z.of_nat (length thy)) a -> crt_pf v (a::ctx) (map (fun x:trm => uptrm x 0 1) phi) sgn thy d s -> q = (All a s) -> crt_pf v ctx phi sgn thy (TmLa a d) q
| pf_all: forall (v : Z)(thy : list stp)(sgn : gsign)(d : pf)(s : trm)(q : trm),
  crt_pf (v + 1) nil nil sgn thy d s -> q = TTpAll s -> crt_pf v nil nil sgn thy (TpLa d) q.

Axiom pf_known_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(h : hashval)(t : trm),
  crt_pf v ctx phi sgn thy (Known h) t -> exists (s : trm), findsnd2 (snd sgn) h = Some s /\ beta_eta_delta_norm s sgn = Some t.

Axiom pf_hyp_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(i : Z)(t : trm),
  crt_pf v ctx phi sgn thy (Hyp i) t -> nth_error phi (Z.to_nat i) = Some t.

Axiom pf_prap_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(e : pf)(t : trm),
  crt_pf v ctx phi sgn thy (PrAp d e) t -> exists (s : trm), crt_pf v ctx phi sgn thy d (Imp s t) /\ crt_pf v ctx phi sgn thy e s.

Axiom pf_tmap_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(t : trm)(q : trm),
crt_pf v ctx phi sgn thy (TmAp d t) q -> exists (s : trm) (a : stp),
crt_pf v ctx phi sgn thy d (All a s) /\ crt_trm v true ctx sgn thy t a /\ Some q = beta_eta_delta_norm (subst_trmtrm s 0 (delta_norm t sgn (length (fst sgn)))) sgn.

Axiom pf_stpap_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(q :trm)(a : stp),
crt_pf v ctx phi sgn thy (TpAp d a) q -> exists (s : trm),
                                          crt_pf v ctx phi sgn thy d (TTpAll s) /\ crt_stp v true (Z.of_nat (length thy)) a /\ subst_trmstp s 0 a = q.

Axiom pf_tmlam_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(s : trm)(q2 : trm),
  crt_pf v ctx phi sgn thy (PrLa s d) q2 -> exists (t : trm) (q : trm),
  crt_trm v true ctx sgn thy s prop /\ Some q = beta_eta_delta_norm s sgn /\ crt_pf v ctx (q::phi) sgn thy d t /\ q2 = Imp q t.

Axiom pf_tplam_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(a : stp)(q : trm),
crt_pf v ctx phi sgn thy (TmLa a d) q -> exists (s : trm),
  crt_stp v true (Z.of_nat (length thy)) a /\ crt_pf v (a::ctx) (map (fun x:trm => uptrm x 0 1) phi) sgn thy d s /\ q = (All a s).

Axiom pf_all_rev : forall (v : Z)(ctx : list stp)(phi : list trm)(thy : list stp)(sgn : gsign)(d : pf)(q : trm),
crt_pf v ctx phi sgn thy (TpLa d) q -> exists (s : trm), crt_pf (v + 1) ctx phi sgn thy d s /\ q = TTpAll s /\ ctx = nil /\ phi = nil.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.
Require Import List.
Require Import NArith.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import cpo.
Require Import profinite.

(**  * Flat pointed domains

     Every enumerable type can be turned into a flat profinite domain.
     These are useful for representing base types.
  *)

Module enumtype.
  Record enumtype :=
  Enumtype
  { carrier :> Type
  ; enumtype_set : N -> option carrier
  ; enumtype_complete : forall x, exists n, enumtype_set n = Some x
  ; enumtype_dec : forall x y:carrier, {x=y}+{x<>y}
  }.

  Definition eq_mixin (X:enumtype) : Eq.mixin_of (carrier X) :=
    Eq.Mixin (carrier X) (@eq _)
    (@Logic.refl_equal _) (@Logic.eq_sym _) (@Logic.eq_trans _).

  Definition preord_mixin (X:enumtype) : Preord.mixin_of (carrier X) :=
    Preord.Mixin (carrier X) (@eq _) (@Logic.refl_equal _) (@Logic.eq_trans _).

  Canonical Structure setoid (X:enumtype) : Eq.type :=
    Eq.Pack X (eq_mixin X).
  Canonical Structure ord (X:enumtype) : preord :=
    Preord.Pack X (preord_mixin X).

  Lemma order_discrete (X:enumtype) (x y:X) : x ≤ y -> x = y.
  Proof (fun H => H).

  Lemma strong_eq (X:enumtype) (x y:X) : x ≈ y -> x = y.
  Proof (fun H => H).

  Program Definition enumtype_effective X : effective_order (ord X) :=
    EffectiveOrder (ord X) (enumtype_dec X) (enumtype_set X) _.
  Next Obligation.
    intros.
    destruct (enumtype_complete X x) as [n ?]. exists n.
    rewrite H. auto.
  Qed.

  Lemma enumtype_has_normals (X:enumtype) :
    has_normals (ord X) (enumtype_effective X) true.
  Proof.
    repeat intro. exists X0.
    split. hnf; auto.
    split; auto.
    repeat intro. exists z.
    split. red; simpl; intros.
    apply H in H0.
    apply finsubset_elem in H0. destruct H0; auto.
    intros. hnf in H1. destruct H1. eauto.
    apply finsubset_elem.
    intros. hnf in H1. subst x. destruct H0; auto.
    hnf in Hinh0.
    destruct Hinh0.
    apply H in H0.
    apply finsubset_elem in H0.
    destruct H0. hnf in H1. subst x.
    split; auto.
    intros. hnf in H2. subst z. destruct H1; auto.
  Qed.

  Definition enumtype_plotkin (X:enumtype) : plotkin_order true (ord X) :=
    norm_plt (ord X) (enumtype_effective X) true (@enumtype_has_normals X).
End enumtype.

Notation enumtype := enumtype.enumtype.
Notation Enumtype := enumtype.Enumtype.

Canonical Structure enumtype.setoid.
Canonical Structure enumtype.ord.
Coercion enumtype.carrier : enumtype >-> Sortclass.

Canonical Structure flat (X:enumtype) : ∂PLT :=
    PLT.Ob true (enumtype.carrier X)
      (PLT.Class _ _
        (enumtype.preord_mixin X)
        (enumtype.enumtype_effective X)
        (enumtype.enumtype_plotkin X)).

Program Definition flat_elem (Y:enumtype) (y:Y) : PLT.unit true → flat Y :=
  PLT.Hom true (PLT.unit true) (flat Y) (single (tt,y)) _ _.
Next Obligation.
  intros. destruct x'. destruct x.
  apply single_axiom in H1.
  apply single_axiom.
  destruct H1. destruct H1. simpl in *.
  split; split; simpl; auto.
  rewrite H0; auto.
  hnf in H0. subst y'. hnf in H3. hnf. auto.
Qed.
Next Obligation.
  repeat intro. exists y.
  split. repeat intro.
  apply H in H0. apply erel_image_elem in H0.
  apply single_axiom in H0.
  destruct H0 as [[??][??]]; auto.
  apply erel_image_elem.
  apply single_axiom. destruct x. auto.
Qed.

Lemma flat_elem_inj Y : forall y1 y2,
  flat_elem Y y1 ≈ flat_elem Y y2 -> y1 = y2.
Proof.
  intros. destruct H.
  assert ((tt,y1) ∈ PLT.hom_rel (flat_elem Y y2)).
  apply H. apply single_axiom. auto.
  simpl in H1. apply single_axiom in H1.
  destruct H1 as [[??][??]]; auto.
Qed.

Arguments flat_elem [Y] y.

Section flat_cases.
  Variable X:enumtype.
  Variables (A B:∂PLT).
  Variable f : X -> (A → B).

  Program Definition insert_index (x:X) : Preord.hom (A×B)%cat_ob ((A×flat X)×B)%cat_ob :=
    Preord.Hom (A×B)%cat_ob ((A×flat X)×B)%cat_ob (fun ab => ((fst ab, x), snd ab)) _.
  Next Obligation.
    intros x [??] [??] [??]; simpl in *; auto.
    split; simpl; auto. split; auto.
  Qed.

  Program Definition map_indexes : Preord.hom (flat X) (eset ((PLT.ord A×flat X)×PLT.ord B)%cat_ob) :=
    Preord.Hom (flat X) (eset ((A× flat X)×B)%cat_ob)
      (fun x => image (insert_index x) (PLT.hom_rel (f x))) _.
  Next Obligation.
    intros. hnf in H. subst a. auto.
  Qed.

  Definition flat_cases_rel : erel (PLT.ord A×flat X)%cat_ob (PLT.ord B) :=
    union (image map_indexes (enumtype.enumtype_set X : eset (flat X))).

  Lemma flat_cases_rel_elem : forall x a b,
    ((a,b) ∈ PLT.hom_rel (f x) <-> (a,x,b) ∈ flat_cases_rel).
  Proof.
    intros. unfold flat_cases_rel.
    rewrite union_axiom.
    intuition.
    exists (map_indexes x).
    split. apply image_axiom1.
    destruct (enumtype.enumtype_complete X x) as [n ?].
    exists n. rewrite H0. auto.
    unfold map_indexes. simpl.
    apply image_axiom1'.
    exists (a,b). split; auto.
    destruct H as [Q [??]].
    apply image_axiom2 in H. destruct H as [y [??]].
    rewrite H1 in H0.
    simpl in H0.
    apply image_axiom2 in H0.
    destruct H0 as [?[??]].
    simpl in H2.
    destruct H2 as [??].
    destruct H2 as [??]. simpl in *.
    destruct H2. simpl in *. hnf in H5. subst y.
    destruct x0. revert H0.
    apply PLT.hom_order.
    destruct H3 as [[??]?]; auto.
    destruct H3 as [[??]?]; auto.
  Qed.

  Program Definition flat_cases : A ⊗ flat X → B :=
    PLT.Hom true (PLT.prod A (flat X)) B flat_cases_rel _ _.
  Next Obligation.
    intros.
    destruct x. destruct x'.
    rewrite <- (flat_cases_rel_elem) in H1.
    rewrite <- flat_cases_rel_elem.
    destruct H. simpl in *. hnf in H2. subst c2.
    revert H1. apply PLT.hom_order; auto.
  Qed.
  Next Obligation.
    repeat intro.
    destruct x as [a x].
    destruct (PLT.hom_directed _ _ _ (f x) a M); auto.
    red; simpl; intros. apply H in H0.
    apply erel_image_elem in H0.
    apply erel_image_elem.
    apply (flat_cases_rel_elem x a a0). auto.
    destruct H0.
    apply erel_image_elem in H1.
    exists x0. split; auto.
    apply erel_image_elem.
    apply (flat_cases_rel_elem x a x0). auto.
  Qed.

  Lemma flat_cases_elem C x h :
    flat_cases ∘ 《h, flat_elem x ∘ PLT.terminate true C》 ≈ f x ∘ h.
  Proof.
    split; intros a H. destruct a.
    apply PLT.compose_hom_rel in H.
    apply PLT.compose_hom_rel.
    destruct H as [q [??]].
    destruct q.
    apply (flat_cases_rel_elem) in H0.
    rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c c1 c2) in H. destruct H.
    exists c1. split; auto.
    apply PLT.compose_hom_rel in H1.
    destruct H1 as [?[??]]. destruct x0.
    simpl in H2.
    apply single_axiom in H2.
    destruct H2 as [[??][??]]. simpl in *.
    hnf in H3. subst c2. auto.
    destruct a.
    apply PLT.compose_hom_rel in H.
    apply PLT.compose_hom_rel.
    destruct H as [q [??]].
    exists (q,x). split.
    apply pair_rel_elem. split; auto.
    apply PLT.compose_hom_rel.
    exists tt. split; auto.
    simpl. apply eprod_elem.
    split. apply eff_complete. apply single_axiom; auto.
    simpl. apply single_axiom.
    auto.
    apply (flat_cases_rel_elem).
    auto.
  Qed.
End flat_cases.
Arguments flat_cases [X A B] f.

Lemma flat_cases_univ (X:enumtype) (A B:∂PLT) (f:X -> A → B) q :
  (forall x, f x ≈ q ∘ 《 id, flat_elem x ∘ PLT.terminate _ _》) ->
  flat_cases f ≈ q.
Proof.
  intros. split; repeat intro.
  destruct a as [[a x] b].
  destruct (H x).
  simpl in H0.
  apply (flat_cases_rel_elem _ _ _ f x a b) in H0.
  apply H1 in H0.
  apply PLT.compose_hom_rel in H0.
  destruct H0 as [[a' x'] [??]].
  apply (PLT.pair_hom_rel _ _ _ _ _ _ a a' x') in H0.
  destruct H0. simpl in H0. apply ident_elem in H0.
  apply PLT.compose_hom_rel in H4.
  destruct H4 as [?[??]]. simpl in H5.
  apply single_axiom in H5.
  revert H3. apply PLT.hom_order.
  split; simpl; auto.
  destruct H5 as [[??][??]]; auto.
  auto.

  destruct a as [[a x] b].
  destruct (H x).
  simpl. apply flat_cases_rel_elem.
  apply H2.
  apply PLT.compose_hom_rel.
  exists (a,x). split; auto.
  apply PLT.pair_hom_rel.
  split; simpl. apply ident_elem; auto.
  apply PLT.compose_hom_rel.
  exists tt. split; auto.
  simpl. apply eprod_elem.
  split. apply eff_complete. apply single_axiom. auto.
  simpl. apply single_axiom; auto.
Qed.

Lemma flat_cases_commute : forall (X : enumtype) (A B C : ∂PLT)
  (f : X -> A → B) (g:C → A) (h:C → flat X),
  flat_cases f ∘ 《 g, h 》 ≈ flat_cases (fun x => f x ∘ g) ∘ 《 id, h 》.
Proof.
  intros.
  transitivity (flat_cases f ∘ PLT.pair_map g id ∘ 《id,h》).
  rewrite <- (cat_assoc ∂PLT).
  rewrite <- (PLT.pair_map_pair true).
  rewrite (cat_ident1 ∂PLT).
  rewrite (cat_ident2 ∂PLT).
  auto.
  apply cat_respects; auto.
  symmetry. apply flat_cases_univ.
  intros.
  rewrite <- (cat_assoc ∂PLT).
  rewrite <- (PLT.pair_map_pair true).
  rewrite (cat_ident1 ∂PLT).
  rewrite (cat_ident2 ∂PLT).
  rewrite flat_cases_elem. auto.
Qed.

Lemma flat_cases_eq (X:enumtype) (A B:∂PLT) (f g : X -> A → B) :
  (forall x, f x ≈ g x) ->
  flat_cases f ≈ flat_cases g.
Proof.
  intros.
  apply flat_cases_univ; intros.
  rewrite flat_cases_elem.
  rewrite (cat_ident1 ∂PLT).
  apply H.
Qed.

Definition boolset : N -> option bool :=
  fun n => match n with N0 => Some true | _ => Some false end.

Program Definition enumbool : enumtype :=
  Enumtype bool boolset _ _.
Next Obligation.
  intros. destruct x.
  exists N0. simpl. auto.
  exists 1%N. simpl; auto.
Qed.
Next Obligation.
  decide equality.
Qed.

Canonical Structure enumbool.


(** * VminusStatics: SSA, Preservation and Progress *)

Require Import Arith.
Require Import List.
Import ListNotations.

Require Import Vminus.Classes.
Require Import Vminus.Util.
Require Import Vminus.Env.
Require Import Vminus.Vminus.
Require Import Vminus.CFG.

Require Import Vminus.Dom.
Require Import Vminus.VminusOpSem.

Module MakeStatics (Cfg: CFG).
Import Cfg.

(** * SSA Invariants: Typing CFGs*)

(** The only ways in which a Vminus program can "go wrong" are by
    accessing a local variable that hasn't been defined or jumping to a label
    that isn't in the CFG.  Therefore, its "typing" constraints ensure that each
    instruction only mentions local identifiers that are in scope according to
    the domination structure of the control-flow graph and that all mentioned
    labels are associated with blocks defined in the CFG.

    These properties are partly enforced by the "syntactic" well-formedness
    constraints imposed by the CFG interface (see CFG.v), which ensure that
    labels and instruction identifiers are unique.

    To enforce the scoping property, we formalize the notion of "dominance" in
    the control flow graph.  The module interface [Dom.Spec] defines dominance
    for arbitrary graphs.  Here, we instantiate the general theory with a
    suitable graph instance for our CFGs.

*)

Module Typing.
(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * GRAPH instance for dominance calculation *)

(** We need to define an graph instance that captures all the edges of our CFGs.

    - vertices in the graph are just program points

    - program points _within_ a single block have "fallthrough" edges determined
      by incrementing the program counter

    - a block [b1] terminated by a branch to [b2] induces an edge from [b1] to
  [b2] in the CFG.  *)

  (** Graph edge relation *)

  Inductive succ_pc (g:Cfg.t) : pc -> pc -> Prop :=
  | succ_pc_S : forall p,
      succ_pc g p (incr_pc p)
  | succ_pc_J : forall p l i,
      insn_at_pc g p i ->
      In l (insn_lbls i) ->
      succ_pc g p (block_entry l).

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * GRAPH instance for dominance calculation *)

(** Graph of program points *)

  Module PcGraph <: GRAPH.
    Definition t := Cfg.t.
    Definition V := pc.
    Definition entry g := block_entry (entry_block g).
    Definition Succ := succ_pc.
    Definition Mem := wf_pc.
  End PcGraph.

(** Instantiate the dominance spec for this graph *)

  Module Export Dom := Dom.Spec PcGraph.

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Defining SSA scoping *)

(** We can now use the dominance properties of the CFG to define scoping
    for well-formed SSA programs. We first need some auxliary predicates: *)

(** The command at the given [pc] defines uid. *)

  Definition def_at_pc (g:Cfg.t) (p:pc) (uid:uid) : Prop :=
    exists c, insn_at_pc g p (uid, c) /\ defs_uid (uid, c).

  (** The [uid] has a definition that strictly dominates the pc [p]. *)

  Definition uid_sdom_pc (g:Cfg.t) (uid:uid) (p:pc) : Prop :=
    exists p', def_at_pc g p' uid /\ SDom g p' p.

(**  ------------------------------------------------------------------------- *)
(* ----------------------------------------------------------------- *)
(** *** Uses are dominated by their definitions *)

  (** All uses of a [uid] must be strictly dominated by
      their definitions. However, we have to treat [phi] instructions
      specially, since the "uses" of identifiers on the right-hand side of
      are conditioned on control flow.

      The right-hand-side of a phi node can safely refer to the identifier defined
      by the phi node itself.  For example, consider this snippet of code:
 [[
      entry:
        br blk

      blk:
        %x = phi [%entry: 0] [%blk: %x]
        br blk
 ]]

      For non-phi instructions, we simply require:
  *)

  Definition wf_use (g:Cfg.t) (i:insn) (p:pc) : Prop :=
    ~is_phi i -> forall uid, In (val_uid uid) (insn_uses i) -> uid_sdom_pc g uid p.

(**  ------------------------------------------------------------------------- *)
  (** *** Well-formed phi nodes *)

  (**  Consider [ %x = phi [lbl1:v1, ...,lbln:vn] ].  This is well formed
       when every predecessor block with terminator program point p'
       has a label associated with value v.  Moreover, if v is a uid then
       the definition of the uid strictly dominates p' (i.e. the terminator
       of the predecessor).
  *)

  Definition wf_phi_args (g:Cfg.t) (i:insn) (p:pc) : Prop :=
    forall pred, succ_pc g pred (entry_of_pc p) ->
      (exists v, In (lbl_of pred, v) (insn_phis i)) /\
      (forall uid, In (lbl_of pred, val_uid uid) (insn_phis i) ->
          uid_sdom_pc g uid pred).

  (** Moreover, we require that fore every labeled value appearing in the
      right-hand side, there is a predecessor block with that label. *)

  Definition wf_phi_pred (g:Cfg.t) (i:insn) (p:pc) : Prop :=
    forall l v, In (l, v) (insn_phis i) ->
      (exists pred, succ_pc g pred (entry_of_pc p) /\ lbl_of pred = l).

  Definition wf_phi (g:Cfg.t) (i:insn) (p:pc) : Prop :=
    is_phi i -> wf_phi_args g i p
             /\ wf_phi_pred g i p
             /\ insn_phis i <> [].

  (**  ------------------------------------------------------------------------- *)
  (** *** Well-formed terminators *)

  (** All jump targets must be legal block labels. *)

  Definition wf_lbl (g:Cfg.t) (i:insn) : Prop :=
    forall l, In l (insn_lbls i) -> wf_pc g (block_entry l).

  (**  ------------------------------------------------------------------------- *)
  (** *** Reachability *)

  (** We further require that all program points in a well-formed control-flow
   graph be reachable from the entry point. Without this proviso, an program point
   that is not reachable is trivially dominated by _every_ program point.  This
   requirement isn't strictly necessary, and might require us to remove dead blocks
   that become unreachable due to program transformations, but it also simplifies
   some pathological cases when reasoning about optimizations.
  *)

  Definition reachable (g:Cfg.t) (p:pc) : Prop :=
    exists path, Path g (block_entry (entry_block g)) p path.

  (**  ------------------------------------------------------------------------- *)
  (** *** Well-formed instructions *)

  (** We package all of the requirements into a single predicate that says when
  an instruction is well formed at a particular program point -- it is simply
  the conjunction of all the above properties. *)

  Inductive wf_insn (g:Cfg.t) : insn -> pc -> Prop :=
  | wf_insn_intro : forall i p
      (Huse: wf_use g i p)
      (Hlbl: wf_lbl g i)
      (Hphi: wf_phi g i p)
      (Hreach: reachable g p),
      wf_insn g i p.

  (**  ------------------------------------------------------------------------- *)
  (** *** Well-formed programs *)

  (** Finally, we spell out the requirements for a full control-flow graph to
   meet the SSA invariants:

     - the CFG is syntactically well formed (no duplicated labels or ids);
     - every instruction is well-formed;
     - every program point that claims to be a terminator does indeed have
       a terminator instruction; and,
     - there are no predecessors of the entry block
   *)

  Inductive wf_prog (g:Cfg.t) : Prop :=
  | wf_prog_intro : forall
      (Hwfcfg : wf_cfg g)
      (Hwfis : forall p i, insn_at_pc g p i -> wf_insn g i p)
      (Hwftmn : forall p' i, tmn_pc g p' -> insn_at_pc g p' i -> is_tmn i)
      (Hwfentry : forall p, ~ succ_pc g p (block_entry (entry_block g))),
      wf_prog g.

End Typing.

(**  ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Type Safety *)

(** We prove type safety for Vminus by setting up the usual _preservation_
    and _progress_ theorems.  *)

Module OpsemCorrect.
  Module Import V := Make (Cfg).
  Import Typing Opsem.

  (**  ------------------------------------------------------------------------- *)
  (** *** Dominance relation *)

  (** First, we formulate a lemma that packages the dominance information into a
   more convenient form: if [pc1] steps to [pc2], then any [uid'] that strictly
   dominates [pc2] also dominates [pc1].  (So long as [uid'] doesn't reside
   at [pc1].) *)

  Lemma uid_sdom_step : forall g uid' uid pc1 pc2 c,
    wf_prog g ->
    uid' <> uid ->
    wf_pc g pc2 ->
    succ_pc g pc1 pc2 ->
    insn_at_pc g pc1 (uid, c) ->
    uid_sdom_pc g uid' pc2 ->
    uid_sdom_pc g uid' pc1.
  Proof.
    unfold uid_sdom_pc.
    intros g uid' uid pc1 pc2 c Hwff Hneq Hpc Hsucc Hi [pc' [Hdef Hdom]].
    exists pc'. split. assumption.
    split. contradict Hneq. subst pc'.
    inversion Hwff.
    destruct Hdef as [? [? ?]]; eapply eq_pc_uid; eauto.
    inversion Hwff; eapply dom_step; eauto.
  Qed.

  (**  ------------------------------------------------------------------------- *)
  (** *** Well-formed states *)

  (** We have to extend well-formedness definitions to include all components of
  the Vminus state. *)

  (** The local environment is well-formed at a given program point [p] when it
  contains a binding for every [uid] whose definition strictly dominates [p].
  This is the property that ensures "scope safety" for the SSA program.
  *)

  Definition wf_loc (g:Cfg.t) (p:pc) (loc:loc) : Prop :=
  forall uid, uid_sdom_pc g uid p -> exists n, loc uid = Some n.

  (** We also need a predicate that indicates when the program counter is at
  the entry. *)

  Definition at_entry (g:Cfg.t) (p:pc) : Prop :=
    entry_of_pc p = block_entry (entry_block g).

  (** A Vminus state is well formed when all of its components are.  We need to
  maintain the invariant that the [ppc] component does indeed correspond to
  a predecessor block (unless the program is at the entry, which has no predecessors).
  Similarly, the [ploc] previous local environment must be well-formed with the
  program counter as it exited the predecessor block.
  *)

  Inductive wf_state (g:Cfg.t) : state -> Prop :=
  | wf_state_intro : forall st
      (Hwfpc: wf_pc g st.(st_pc))
      (Hwfloc: wf_loc g st.(st_pc) st.(st_loc))
      (Hwfppc: at_entry g st.(st_pc) \/
                 succ_pc g st.(st_ppc) (entry_of_pc st.(st_pc)))
      (Hwfploc: at_entry g st.(st_pc) \/
                  wf_loc g st.(st_ppc) st.(st_ploc)),
      wf_state g st.

  (**  ------------------------------------------------------------------------- *)
  (** *** Initial state is well formed *)

  Lemma wf_init_state :
    forall g m, wf_prog g ->
    wf_state g (init_state g m).
  Proof.
    intros g m Hprog. inversion Hprog.
    apply wf_entry in Hwfcfg.
    econstructor. auto.
    red. simpl. intros. red in H. destruct H as [? [? [? ?]]].
    red in H1. contradict H0.
    cut (In x [block_entry (entry_block g)]). simpl. intuition.
    eapply H1. econstructor. auto.
    left. unfold init_state, at_entry, entry_of_pc. auto.
    left. unfold init_state, at_entry, entry_of_pc. auto.
  Qed.

  (**  ------------------------------------------------------------------------- *)
  (** *** Progress helper lemmas. *)

  (** There are no phi nodes in the entry block. *)

  Lemma at_entry_not_phi : forall g st i,
    wf_prog g ->
    at_entry g st.(st_pc) ->
    insn_at_pc g st.(st_pc) i ->
    ~ is_phi i.
   Proof.
     intros g st i Hprog Hentry Hinsn.
     destruct Hprog as [_ ? _ ?].

     specialize (Hwfis _ _ Hinsn). inversion Hwfis; subst.
     intro Hphi2. specialize (Hphi Hphi2). destruct Hphi as [H0 [H1 H2]].
     destruct (insn_phis i) eqn:His. contradiction H2; auto.
     assert (In p (insn_phis i)) as Hin. rewrite His. left; auto.
     destruct p. apply H1 in Hin. destruct Hin as [pred [Hpred Ht0]].
     specialize (Hwfentry pred). contradict Hwfentry.
     rewrite <- Hentry; auto.
   Qed.

   (**  ------------------------------------------------------------------------- *)
   (** *** Progress helper lemmas. *)

   (** In a well-formed program with well-formed locals, evaluating the values
       used by a non-phi instruction is never undefined. (This is basically
       the consequence of identifiers being "in scope".
   *)

  Lemma eval_val__wf_loc : forall g pc loc i v,
    wf_prog g ->
    wf_loc g pc loc ->
    ~is_phi i ->
    insn_at_pc g pc i ->
    In v (insn_uses i) ->
    exists n, eval_val loc v = Some n.
  Proof.
    intros ? ? ? ? v Hwff Hwfloc Hnotphi Hi ?.
    destruct v as [uid | n].
    simpl. inversion Hwff as [_ ? _]. apply Hwfis in Hi.
    destruct Hi as [? ? Huse].
    destruct (is_phi_decidable i).
    - contradiction.
    specialize (Huse Hnotphi uid).
    lapply Huse; auto.
    simpl; eauto.
  Qed.

  (**  ------------------------------------------------------------------------- *)
  (** ** Final State *)

  (** A Vminus program halts when the program reaches the [tmn_ret] instruction. *)

  Definition FinalState (g:Cfg.t) (s:state) : Prop :=
    exists uid, insn_at_pc g s.(st_pc) (uid, cmd_tmn tmn_ret).

  (**  ------------------------------------------------------------------------- *)
  (** ** Progress *)

  (** The statement of progress is exactly as expected.  For any well-formed
  program in a well-formed state, either the program has finished, or the
  program can take a step. *)

  Lemma progress : forall g s,
    wf_prog g -> wf_state g s ->
    FinalState g s \/ exists s', step g s s'.
  Proof.
    intros g s Hwff Hwfs.
    inversion Hwfs as [? Hwfpc]; subst. inversion Hwff.
    pose proof (wf_pc_insn g Hwfcfg _ Hwfpc) as [[i c] Hi].
    rename s into j. set (s:=j) in *. destruct j.
    destruct c.

    - (* Case "cmd_bop". *)
    eelim (eval_val__wf_loc) with (v:=v) (loc:=st_loc0); eauto; simpl; auto.
    eelim (eval_val__wf_loc) with (v:=v0) (loc:=st_loc0); eauto; simpl; auto.
    intros n1 Heqn1 n2 Heqn2.
    right. eexists. eapply step_bop; eauto. unfold eval_bop.
    rewrite Heqn1, Heqn2. reflexivity.

    - (* Case "cmd_phi". *)
    right. specialize (Hwfis _ _ Hi). inversion Hwfis; subst.

    destruct Hwfppc as [|Hwfppc].
    exfalso; eapply at_entry_not_phi; eauto. simpl; trivial.
    destruct Hwfploc as [|Hwfploc].
    exfalso; eapply at_entry_not_phi; eauto. simpl; trivial.

    destruct (Hphi I) as [Hphi2 _]. clear Hphi.
    specialize (Hphi2 st_ppc0 Hwfppc). destruct Hphi2 as [[v Hin] Hdom].

    cut (exists v, assoc Lbl.eq_dec (lbl_of st_ppc0) l = Some v). intros [v' Hv].
    cut (exists n, eval_val st_ploc0 v' = Some n). intros [n Hn].
    eexists. eapply step_phi. eauto. unfold eval_phi.
    rewrite Hv. rewrite Hn. reflexivity.

    destruct v' as [i' | n']. simpl in *. apply Hwfploc. apply Hdom.
    eapply assoc_in. apply Hv. simpl; eauto.
    eapply in_assoc_some. apply Hin.

    - (* Case "cmd_tmn". *)
    destruct t0.
    * (*  SCase "tmn_jmp". *)
      right. eexists. eapply step_tmn. eauto. reflexivity.

    * (* SCase "tmn_cbr". *)
      cut (exists n, eval_val st_loc0 v = Some n). intros [n Heqn].
      right. eexists. eapply step_tmn. eauto. simpl. rewrite Heqn. reflexivity.
      eapply eval_val__wf_loc; eauto; simpl; auto.

    * (* SCase "tmn_ret". *)
      left. unfold FinalState. eexists. eauto.

    - (* Case "cmd_load". *)
    right. eexists. apply step_load. eauto.

    - (* Case "cmd_store". *)
    right. cut (exists n1, eval_val st_loc0 v = Some n1).
    intros [n1 Heqn1]. eexists. eapply step_store. eauto. eauto.
    eapply eval_val__wf_loc; eauto; simpl; auto.
  Qed.

  (** *** Some first steps towards preservation. *)

  Lemma wf_pc_incr : forall g p i,
    wf_prog g ->
    wf_pc g p ->
    insn_at_pc g p i ->
    ~ is_tmn i ->
    wf_pc g (incr_pc p).
  Proof.
    intros. inversion H.
    apply (wf_pc_tmn g Hwfcfg) in H0 as [pt [Ht Hle]].
    eapply wf_pc_le_tmn; eauto.
    inversion Hle; subst. destruct H0.
    contradict H2. eapply Hwftmn; eauto.
    constructor; auto with arith.
  Qed.

  Lemma eval_tmn_in_lbls : forall l loc t uid,
    Some l = eval_tmn loc t -> In l (insn_lbls (uid, cmd_tmn t)).
  Proof.
    intros.
    destruct t0; simpl in *.
    inversion H; auto.
    destruct (eval_val loc v). injection H.
      destruct n; eauto.
      discriminate H. discriminate H.
  Qed.

  (** *** More preservation helpers*)

  Lemma not_def_sdom_step : forall g p1 p2 i uid,
    wf_prog g ->
    wf_pc g p2 ->
    insn_at_pc g p1 i ->
    ~ defs_uid i ->
    succ_pc g p1 p2 ->
    uid_sdom_pc g uid p2 ->
    uid_sdom_pc g uid p1.
  Proof.
    destruct i; intros. inversion H4 as [? [[? [? Ht]] ?]].
    eapply uid_sdom_step; [ apply H | idtac | apply H0
                            | apply H3 | apply H1 | apply H4].
    contradict Ht. subst t0. assert (x = p1).
    inversion H; eapply uid_at_pc_inj; try red; eauto. subst x.
    replace (uid, x0) with (uid, c); trivial.
    inversion H; eapply insn_at_pc_func; eauto.
  Qed.

  Lemma wf_loc_succ : forall g p1 p2 loc uid n c,
   wf_prog g ->
   wf_pc g p2 ->
   insn_at_pc g p1 (uid, c) ->
   succ_pc g p1 p2 ->
   wf_loc g p1 loc ->
   wf_loc g p2 (update loc uid (Some n)).
  Proof.
    intros. red; intros. destruct (Uid.eq_dec uid0 uid). subst.
    rewrite Locals.update_eq; eauto. reflexivity.
    rewrite Locals.update_neq; eauto. apply H3.
    eapply uid_sdom_step; eauto.
  Qed.

  (** ** Preservation *)

  Lemma preservation : forall g s s',
    wf_prog g ->
    wf_state g s -> step g s s' -> wf_state g s'.
  Proof.
    intros g _ s' Hwff [s Hwfpc Hwfloc] Hstep.
    inversion Hstep; subst; simpl in *;
      rename pc into pc0.

    - (* Case "step_bop". *)
    assert (wf_pc g (incr_pc pc0)) as Hwfpc' by (eapply wf_pc_incr; eauto).
    constructor; simpl; try solve [destruct pc0; auto].
    eapply wf_loc_succ; eauto. constructor.

    - (* Case "step_phi". *)
    assert (wf_pc g (incr_pc pc0)) as Hwfpc' by (eapply wf_pc_incr; eauto).
    constructor; simpl; try solve [destruct pc0; auto].
    eapply wf_loc_succ; eauto. constructor.

    - (* Case "step_tmn". *)
    assert (wf_pc g (l', 0)) as Hwfpc'.
      inversion Hwff as [_ Hwfi _]. specialize (Hwfi _ _ H).
      inversion Hwfi. red in Hlbl. apply Hlbl.
      eauto. eapply eval_tmn_in_lbls. eauto.

    assert (succ_pc g pc0 (l', 0)) as Hsucc.
      econstructor. eauto. eapply eval_tmn_in_lbls. eauto.
    constructor; simpl; eauto. red; intros. apply Hwfloc.
    eapply not_def_sdom_step; eauto.

    - (* Case "step_load". *)
    assert (wf_pc g (incr_pc pc0)) as Hwfpc' by (eapply wf_pc_incr; eauto).
    constructor; simpl; try solve [destruct pc0; auto].
    eapply wf_loc_succ; eauto. constructor.

    - (* Case "step_store". *)
    assert (wf_pc g (incr_pc pc0)) as Hwfpc' by (eapply wf_pc_incr; eauto).
    constructor; simpl; try solve [destruct pc0; auto].
    red; intros. apply Hwfloc. eapply not_def_sdom_step; eauto. constructor.
  Qed.

End OpsemCorrect.

End MakeStatics.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions sub.