(* !!! WARNING: AUTO GENERATED. DO NOT MODIFY !!! *)
Require Import Metalib.Metatheory.
(** syntax *)
Definition i := nat.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_top : typ (*r top *)
 | t_arrow (A:typ) (B:typ) (*r function types *)
 | t_and (A:typ) (B:typ) (*r intersection *).

Inductive dexp : Set :=  (*r expressions *)
 | de_var_b (_:nat) (*r variables *)
 | de_var_f (x:var) (*r variables *)
 | de_top : dexp (*r top *)
 | de_lit (i5:i) (*r lit *)
 | de_abs (ee:dexp) (*r abstractions *)
 | de_app (ee1:dexp) (ee2:dexp) (*r applications *)
 | de_merge (ee1:dexp) (ee2:dexp) (*r merge *)
 | de_fixpoint (ee:dexp) (*r fixpoint *).

Definition ctx : Set := list ( atom * typ ).

Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_top : exp (*r top *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (A:typ) (e:exp) (B:typ) (*r abstractions *)
 | e_fixpoint (e:exp) (A:typ) (*r fixpoint *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_merge (e1:exp) (e2:exp) (*r merge *)
 | e_anno (e:exp) (A:typ) (*r annotation *).

Inductive st : Set :=  (*r input type or projection label *)
 | st_ty (A:typ).

Definition ls : Set := list st.

(* EXPERIMENTAL *)
(** auxiliary functions on the new list types *)
(** library functions *)
(** subrules *)
(** arities *)
(** opening up abstractions *)
Fixpoint open_dexp_wrt_dexp_rec (k:nat) (ee_5:dexp) (ee__6:dexp) {struct ee__6}: dexp :=
  match ee__6 with
  | (de_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => de_var_b nat
        | inleft (right _) => ee_5
        | inright _ => de_var_b (nat - 1)
      end
  | (de_var_f x) => de_var_f x
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
  | (de_app ee1 ee2) => de_app (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_merge ee1 ee2) => de_merge (open_dexp_wrt_dexp_rec k ee_5 ee1) (open_dexp_wrt_dexp_rec k ee_5 ee2)
  | (de_fixpoint ee) => de_fixpoint (open_dexp_wrt_dexp_rec (S k) ee_5 ee)
end.

Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
  match e__6 with
  | (e_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => e_var_b nat
        | inleft (right _) => e_5
        | inright _ => e_var_b (nat - 1)
      end
  | (e_var_f x) => e_var_f x
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (open_exp_wrt_exp_rec (S k) e_5 e) B
  | (e_fixpoint e A) => e_fixpoint (open_exp_wrt_exp_rec (S k) e_5 e) A
  | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_merge e1 e2) => e_merge (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
  | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
end.

Definition open_dexp_wrt_dexp ee_5 ee__6 := open_dexp_wrt_dexp_rec 0 ee__6 ee_5.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_dexp *)
Inductive lc_dexp : dexp -> Prop :=    (* defn lc_dexp *)
 | lc_de_var_f : forall (x:var),
     (lc_dexp (de_var_f x))
 | lc_de_top :
     (lc_dexp de_top)
 | lc_de_lit : forall (i5:i),
     (lc_dexp (de_lit i5))
 | lc_de_abs : forall (ee:dexp),
      ( forall x , lc_dexp  ( open_dexp_wrt_dexp ee (de_var_f x) )  )  ->
     (lc_dexp (de_abs ee))
 | lc_de_app : forall (ee1 ee2:dexp),
     (lc_dexp ee1) ->
     (lc_dexp ee2) ->
     (lc_dexp (de_app ee1 ee2))
 | lc_de_merge : forall (ee1 ee2:dexp),
     (lc_dexp ee1) ->
     (lc_dexp ee2) ->
     (lc_dexp (de_merge ee1 ee2))
 | lc_de_fixpoint : forall (ee:dexp),
      ( forall x , lc_dexp  ( open_dexp_wrt_dexp ee (de_var_f x) )  )  ->
     (lc_dexp (de_fixpoint ee)).

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_top :
     (lc_exp e_top)
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (A:typ) (e:exp) (B:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_abs A e B))
 | lc_e_fixpoint : forall (e:exp) (A:typ),
      ( forall x , lc_exp  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     (lc_exp (e_fixpoint e A))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_merge : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_merge e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A)).
(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | e_top => {}
  | (e_lit i5) => {}
  | (e_abs A e B) => (fv_exp e)
  | (e_fixpoint e A) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_merge e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
end.

Fixpoint fv_dexp (ee_5:dexp) : vars :=
  match ee_5 with
  | (de_var_b nat) => {}
  | (de_var_f x) => {{x}}
  | de_top => {}
  | (de_lit i5) => {}
  | (de_abs ee) => (fv_dexp ee)
  | (de_app ee1 ee2) => (fv_dexp ee1) \u (fv_dexp ee2)
  | (de_merge ee1 ee2) => (fv_dexp ee1) \u (fv_dexp ee2)
  | (de_fixpoint ee) => (fv_dexp ee)
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | e_top => e_top
  | (e_lit i5) => e_lit i5
  | (e_abs A e B) => e_abs A (subst_exp e_5 x5 e) B
  | (e_fixpoint e A) => e_fixpoint (subst_exp e_5 x5 e) A
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_merge e1 e2) => e_merge (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
end.

Fixpoint subst_dexp (ee_5:dexp) (x5:var) (ee__6:dexp) {struct ee__6} : dexp :=
  match ee__6 with
  | (de_var_b nat) => de_var_b nat
  | (de_var_f x) => (if eq_var x x5 then ee_5 else (de_var_f x))
  | de_top => de_top
  | (de_lit i5) => de_lit i5
  | (de_abs ee) => de_abs (subst_dexp ee_5 x5 ee)
  | (de_app ee1 ee2) => de_app (subst_dexp ee_5 x5 ee1) (subst_dexp ee_5 x5 ee2)
  | (de_merge ee1 ee2) => de_merge (subst_dexp ee_5 x5 ee1) (subst_dexp ee_5 x5 ee2)
  | (de_fixpoint ee) => de_fixpoint (subst_dexp ee_5 x5 ee)
end.

(** definitions *)

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | value_unit :
     value e_top
 | value_lit : forall (i5:i),
     value (e_lit i5)
 | value_anno : forall (A:typ) (e:exp) (B:typ),
     lc_exp (e_abs A e B) ->
     value (e_abs A e B)
 | value_merge : forall (v1 v2:exp),
     value v1 ->
     value v2 ->
     value (e_merge v1 v2).

(* defns TopLikeType *)
Inductive topLike : typ -> Prop :=    (* defn topLike *)
 | TL_top :
     topLike t_top
 | TL_and : forall (A B:typ),
     topLike A ->
     topLike B ->
     topLike (t_and A B)
 | TL_arr : forall (A B:typ),
     topLike B ->
     topLike (t_arrow A B).

(* defns OrdinaryType *)
Inductive ord : typ -> Prop :=    (* defn ord *)
 | O_top :
     ord t_top
 | O_int :
     ord t_int
 | O_arrow : forall (A B:typ),
     ord (t_arrow A B).

(* defns Disjoint *)
Inductive disjoint : typ -> typ -> Prop :=    (* defn disjoint *)
 | D_topL : forall (A:typ),
     disjoint t_top A
 | D_topR : forall (A:typ),
     disjoint A t_top
 | D_andL : forall (A1 A2 B:typ),
     disjoint A1 B ->
     disjoint A2 B ->
     disjoint (t_and A1 A2) B
 | D_andR : forall (A B1 B2:typ),
     disjoint A B1 ->
     disjoint A B2 ->
     disjoint A (t_and B1 B2)
 | D_IntArr : forall (A1 A2:typ),
     disjoint t_int (t_arrow A1 A2)
 | D_ArrInt : forall (A1 A2:typ),
     disjoint (t_arrow A1 A2) t_int
 | D_ArrArr : forall (A1 A2 B1 B2:typ),
     disjoint A2 B2 ->
     disjoint (t_arrow A1 A2) (t_arrow B1 B2).

(* defns Subtyping *)
Inductive sub : typ -> typ -> Prop :=    (* defn sub *)
 | S_z :
     sub t_int t_int
 | S_top : forall (A:typ),
     sub A t_top
 | S_toparr : forall (A B1 B2:typ),
     sub t_top B2 ->
     sub A (t_arrow B1 B2)
 | S_arr : forall (A1 A2 B1 B2:typ),
     sub B1 A1 ->
     sub A2 B2 ->
     sub (t_arrow A1 A2) (t_arrow B1 B2)
 | S_andl1 : forall (A1 A2 A3:typ),
     sub A1 A3 ->
     sub (t_and A1 A2) A3
 | S_andl2 : forall (A1 A2 A3:typ),
     sub A2 A3 ->
     sub (t_and A1 A2) A3
 | S_andr : forall (A1 A2 A3:typ),
     sub A1 A2 ->
     sub A1 A3 ->
     sub A1 (t_and A2 A3).

(* defns Semantics *)
Inductive TypedReduce : exp -> typ -> exp -> Prop :=    (* defn TypedReduce *)
 | TReduce_lit : forall (i5:i),
     TypedReduce (e_lit i5) t_int (e_lit i5)
 | TReduce_top : forall (v:exp),
     lc_exp v ->
     TypedReduce v t_top e_top
 | TReduce_toparr : forall (v:exp) (A B:typ),
     lc_exp v ->
     topLike B ->
     TypedReduce v (t_arrow A B) (e_abs t_top e_top B)
 | TReduce_arrow : forall (A:typ) (e:exp) (B C D:typ),
     lc_exp (e_abs A e B) ->
      not ( topLike D )  ->
     sub C A ->
     sub B D ->
     TypedReduce (e_abs A e B)  (t_arrow C D)  (e_abs A e D)
 | TReduce_mergevl : forall (v1 v2:exp) (A:typ) (v1':exp),
     lc_exp v2 ->
     TypedReduce v1 A v1' ->
     ord A ->
     TypedReduce (e_merge v1 v2) A v1'
 | TReduce_mergevr : forall (v1 v2:exp) (A:typ) (v2':exp),
     lc_exp v1 ->
     TypedReduce v2 A v2' ->
     ord A ->
     TypedReduce (e_merge v1 v2) A v2'
 | TReduce_and : forall (v:exp) (A B:typ) (v1 v2:exp),
     TypedReduce v A v1 ->
     TypedReduce v B v2 ->
     TypedReduce v (t_and A B) (e_merge v1 v2)
with step : exp -> exp -> Prop :=    (* defn step *)
 | Step_beta : forall (A:typ) (e:exp) (D:typ) (v v':exp),
     lc_exp (e_abs A e D) ->
     value v ->
     TypedReduce v A v' ->
     step (e_app  ( (e_abs A e D) )  v) (e_anno  (  (open_exp_wrt_exp  e v' )  )  D)
 | Step_annov : forall (v:exp) (A:typ) (v':exp),
     value v ->
     TypedReduce v A v' ->
     step (e_anno v A) v'
 | Step_appl : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_app e1 e2) (e_app e1' e2)
 | Step_appr : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_app v1 e2) (e_app v1 e2')
 | Step_mergel : forall (e1 e2 e1':exp),
     lc_exp e2 ->
     step e1 e1' ->
     step (e_merge e1 e2) (e_merge e1' e2)
 | Step_merger : forall (v1 e2 e2':exp),
     value v1 ->
     step e2 e2' ->
     step (e_merge v1 e2) (e_merge v1 e2')
 | Step_anno : forall (e:exp) (A:typ) (e':exp),
     step e e' ->
     step (e_anno e A) (e_anno e' A)
 | Step_fix : forall (e:exp) (A:typ),
     lc_exp (e_fixpoint e A) ->
     step (e_fixpoint e A)  (open_exp_wrt_exp  e (e_fixpoint e A) ) .

Definition disjointSpec A B :=
  forall C, sub A C -> sub B C -> topLike C.

Definition consistencySpec v1 v2 :=
  forall A v1' v2', TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.

(* defns Typing *)
Inductive Etyping : ctx -> exp -> typ -> Prop :=    (* defn Etyping *)
 | Etyp_top : forall (G:ctx),
      uniq  G  ->
     Etyping G e_top t_top
 | Etyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Etyping G (e_lit i5) t_int
 | Etyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Etyping G (e_var_f x) A
 | Etyp_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (D C B:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  B )  ->
     sub C A ->
     sub B D ->
     Etyping G  ( (e_abs A e D) )  (t_arrow C D)
 | Etyp_app : forall (G:ctx) (e1 e2:exp) (B A:typ),
     Etyping G e2 A ->
     Etyping G e1 (t_arrow A B) ->
     Etyping G (e_app e1 e2) B
 | Etyp_merge : forall (G:ctx) (e1 e2:exp) (A B:typ),
     Etyping G e1 A ->
     Etyping G e2 B ->
      disjointSpec A B  ->
     Etyping G (e_merge e1 e2) (t_and A B)
 | Etyp_anno : forall (G:ctx) (e:exp) (A B:typ),
     Etyping G e B ->
     sub B A ->
     Etyping G  ( (e_anno e A) )  A
 | Etyp_fix : forall (L:vars) (G:ctx) (e:exp) (A:typ),
      ( forall x , x \notin  L  -> Etyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  A )  ->
     Etyping G  ( (e_fixpoint e A) )  A
 | Etyp_mergev : forall (G:ctx) (v1 v2:exp) (A B:typ),
      uniq  G  ->
     value (e_merge v1 v2) ->
     Etyping  nil  v1 A ->
     Etyping  nil  v2 B ->
      consistencySpec v1 v2  ->
     Etyping G (e_merge v1 v2) (t_and A B).

(* defns DValue *)
Inductive DValue : dexp -> Prop :=    (* defn DValue *)
 | DVal_var : forall (x:var),
     DValue (de_var_f x)
 | DVal_top :
     DValue de_top
 | DVal_nat : forall (i5:i),
     DValue (de_lit i5)
 | DVal_abs : forall (ee:dexp),
     lc_dexp (de_abs ee) ->
     DValue (de_abs ee)
 | DVal_merge : forall (vv1 vv2:dexp),
     DValue vv1 ->
     DValue vv2 ->
     DValue (de_merge vv1 vv2).

(* defns DSemantics *)
Inductive DunfieldStep : dexp -> dexp -> Prop :=    (* defn DunfieldStep *)
 | DStep_appl : forall (ee1 ee2 ee1':dexp),
     lc_dexp ee2 ->
     DunfieldStep ee1 ee1' ->
     DunfieldStep (de_app ee1 ee2) (de_app ee1' ee2)
 | DStep_appr : forall (vv1 ee2 ee2':dexp),
     DValue vv1 ->
     DunfieldStep ee2 ee2' ->
     DunfieldStep (de_app vv1 ee2) (de_app vv1 ee2')
 | DStep_beta : forall (ee vv:dexp),
     lc_dexp (de_abs ee) ->
     DValue vv ->
     DunfieldStep (de_app  ( (de_abs ee) )  vv)  (  (open_dexp_wrt_dexp  ee vv )  )
 | DStep_fix : forall (ee:dexp),
     lc_dexp (de_fixpoint ee) ->
     DunfieldStep (de_fixpoint ee)  (open_dexp_wrt_dexp  ee (de_fixpoint ee) )
 | DStep_unmergel : forall (ee1 ee2:dexp),
     lc_dexp ee2 ->
     lc_dexp ee1 ->
     DunfieldStep (de_merge ee1 ee2) ee1
 | DStep_unmerger : forall (ee1 ee2:dexp),
     lc_dexp ee1 ->
     lc_dexp ee2 ->
     DunfieldStep (de_merge ee1 ee2) ee2
 | DStep_mergel : forall (ee1 ee2 ee1':dexp),
     lc_dexp ee2 ->
     DunfieldStep ee1 ee1' ->
     DunfieldStep (de_merge ee1 ee2) (de_merge ee1' ee2)
 | DStep_merger : forall (vv1 ee2 ee2':dexp),
     DValue vv1 ->
     DunfieldStep ee2 ee2' ->
     DunfieldStep (de_merge vv1 ee2) (de_merge vv1 ee2')
 | DStep_split : forall (ee:dexp),
     lc_dexp ee ->
     DunfieldStep ee (de_merge ee ee)
 | DStep_top : forall (ee:dexp),
     lc_dexp ee ->
     DunfieldStep ee de_top
 | DStep_toparr :
     DunfieldStep de_top (de_abs de_top).

(* defns WellformedType *)
Inductive WF : ctx -> typ -> Prop :=    (* defn WF *)
 | Wf_int : forall (G:ctx),
     WF G t_int
 | Wf_top : forall (G:ctx),
     WF G t_top
 | Wf_arr : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
     WF G (t_arrow A B)
 | Wf_and : forall (G:ctx) (A B:typ),
     WF G A ->
     WF G B ->
      disjointSpec A B  ->
     WF G (t_and A B).

(* defns ISubtyping *)
Inductive isub : typ -> typ -> Prop :=    (* defn isub *)
 | IS_z :
     isub t_int t_int
 | IS_top : forall (A:typ),
     isub A t_top
 | IS_arr : forall (A1 A2 B1 B2:typ),
     isub B1 A1 ->
     isub A2 B2 ->
     isub (t_arrow A1 A2) (t_arrow B1 B2)
 | IS_andl1 : forall (A1 A2 A3:typ),
     isub A1 A3 ->
     isub (t_and A1 A2) A3
 | IS_andl2 : forall (A1 A2 A3:typ),
     isub A2 A3 ->
     isub (t_and A1 A2) A3
 | IS_andr : forall (A1 A2 A3:typ),
     isub A1 A2 ->
     isub A1 A3 ->
     isub A1 (t_and A2 A3).

(* defns ITyping *)
Inductive ITyping : ctx -> dexp -> typ -> exp -> Prop :=    (* defn ITyping *)
 | ITyp_top : forall (G:ctx),
      uniq  G  ->
     ITyping G de_top t_top e_top
 | ITyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     ITyping G (de_lit i5) t_int (e_lit i5)
 | ITyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     ITyping G (de_var_f x) A (e_var_f x)
 | ITyp_lam : forall (L:vars) (G:ctx) (ee:dexp) (A B:typ) (e:exp),
     WF G A ->
      ( forall x , x \notin  L  -> ITyping  (cons ( x , A )  G )   ( open_dexp_wrt_dexp ee (de_var_f x) )  B  ( open_exp_wrt_exp e (e_var_f x) )  )  ->
     ITyping G  ( (de_abs ee) )  (t_arrow A B)  ( (e_abs A e B) )
 | ITyp_app : forall (G:ctx) (ee1 ee2:dexp) (B:typ) (e1 e2:exp) (A:typ),
     ITyping G ee1 (t_arrow A B) e1 ->
     ITyping G ee2 A e2 ->
     ITyping G (de_app ee1 ee2) B (e_app e1 e2)
 | ITyp_merge : forall (G:ctx) (ee1 ee2:dexp) (A B:typ) (e1 e2:exp),
     ITyping G ee1 A e1 ->
     ITyping G ee2 B e2 ->
      disjointSpec A B  ->
     ITyping G (de_merge ee1 ee2) (t_and A B) (e_merge e1 e2)
 | ITyp_sub : forall (G:ctx) (ee:dexp) (B:typ) (e:exp) (A:typ),
     ITyping G ee A e ->
     isub A B ->
     ITyping G ee B (e_anno e B).

(** infrastructure *)
Hint Constructors value topLike ord disjoint sub TypedReduce step Etyping DValue DunfieldStep WF isub ITyping lc_dexp lc_exp.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import coqutil.Byte.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Tactics.Tactics.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Scalars.
Require Import bedrock2.Syntax.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Common.Arrays.ByteBounds.
Require Import Crypto.Bedrock.Field.Common.Arrays.MakeAccessSizes.
Require Import Crypto.Bedrock.Field.Common.Arrays.MakeListLengths.
Require Import Crypto.Bedrock.Field.Common.Arrays.MaxBounds.
Require Import Crypto.Bedrock.Field.Common.Names.MakeNames.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Func.
Require Import Crypto.Bedrock.Field.Translation.Func.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Tactics.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.WordByWordMontgomery.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Language.API.
Require Import Coq.Lists.List. (* after SeparationLogic *)

Existing Instances rep.Z rep.listZ_mem.

Import Language.Compilers.
Import Associational Positional.

Require Import Crypto.Util.Notations.
Import Types.Notations ListNotations.
Import QArith_base.
Local Open Scope Z_scope.

Local Coercion Z.of_nat : nat >-> Z.
Local Coercion inject_Z : Z >-> Q.
Local Coercion Z.pos : positive >-> Z.

Declare Scope sep_scope.
Local Delimit Scope sep_scope with sep.
Local Infix "*" := sep : sep_scope.

Ltac apply_correctness_in H :=
  match type of H with
  | context [WordByWordMontgomery.mul] =>
    apply WordByWordMontgomery.mul_correct in H
  | context [WordByWordMontgomery.square] =>
    apply WordByWordMontgomery.square_correct in H
  | context [WordByWordMontgomery.add] =>
    apply WordByWordMontgomery.add_correct in H
  | context [WordByWordMontgomery.sub] =>
    apply WordByWordMontgomery.sub_correct in H
  | context [WordByWordMontgomery.opp] =>
    apply WordByWordMontgomery.opp_correct in H
  | context [WordByWordMontgomery.to_montgomery] =>
    apply WordByWordMontgomery.to_montgomery_correct in H
  | context [WordByWordMontgomery.from_montgomery] =>
    apply WordByWordMontgomery.from_montgomery_correct in H
  | context [WordByWordMontgomery.nonzero] =>
    apply WordByWordMontgomery.nonzero_correct in H
  | context [WordByWordMontgomery.selectznz] =>
    eapply Primitives.selectznz_correct in H
  | context [WordByWordMontgomery.to_bytes] =>
    apply WordByWordMontgomery.to_bytes_correct in H
  | context [WordByWordMontgomery.from_bytes] =>
    apply WordByWordMontgomery.from_bytes_correct in H
  | context [WordByWordMontgomery.encode] =>
    apply WordByWordMontgomery.encode_correct in H
  | context [WordByWordMontgomery.zero] =>
    apply WordByWordMontgomery.zero_correct in H
  | context [WordByWordMontgomery.one] =>
    apply WordByWordMontgomery.one_correct in H
  end.

Section __.
  Context {p : Types.parameters}
          {inname_gen outname_gen : nat -> string}
          (m : Z).
  Local Notation is_correct := (@is_correct p inname_gen outname_gen).
  Local Notation bit_range := {|ZRange.lower := 0; ZRange.upper := 1|}.
  Local Notation n := (WordByWordMontgomery.n m Semantics.width).
  Local Notation n_bytes := (WordByWordMontgomery.n_bytes m).
  Local Notation bounds :=
    (WordByWordMontgomery.bounds m Semantics.width).
  Local Notation prime_bounds :=
    (WordByWordMontgomery.prime_bounds m Semantics.width).
  Local Notation prime_bytes_bounds :=
    (WordByWordMontgomery.prime_bytes_bounds m).
  Local Notation saturated_bounds :=
    (Primitives.saturated_bounds n Semantics.width).
  Local Notation eval :=
    (@WordByWordMontgomery.WordByWordMontgomery.eval Semantics.width n).

  (* Note: annoyingly, prime_boudnds, prime_bytes_bounds and saturated_bounds
     are option types, unlike loose_bounds or tight_bounds, so we have to refer
     to the values they wrap in Some whenever we want to use them with
     list_Z_bounded_by *)
  Local Notation prime_bounds_value :=
    (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
         (prime_upperbound_list m Semantics.width)).
  Local Notation prime_bytes_bounds_value :=
    (map (fun v : Z => Some {| ZRange.lower := 0; ZRange.upper := v |})
         (prime_bytes_upperbound_list m)).
  Local Notation saturated_bounds_value :=
    (Primitives.saturated_bounds_list n Semantics.width).

  Ltac select_access_size b :=
    lazymatch b with
    | Some bounds => constr:(access_size.word)
    | saturated_bounds => constr:(access_size.word)
    | prime_bounds => constr:(access_size.word)
    | prime_bytes_bounds => constr:(access_size.one)
    | ?b => fail "unable to select access size for bound" b
    end.

  Ltac select_length b :=
    lazymatch b with
    | Some bounds => constr:(n)
    | saturated_bounds => constr:(n)
    | prime_bounds => constr:(n)
    | prime_bytes_bounds => constr:(n_bytes)
    | ?b => fail "unable to select array length for bound" b
    end.

  Ltac sizes_from_bounds := map_bounds_listonly select_access_size.
  Ltac lengths_from_bounds := map_bounds_listonly select_length.

  Ltac prove_operation_correctness :=
    intros;
    let Hcorrect :=
        lazymatch goal with H : _ = ErrorT.Success _ |- _ => H end in
    apply_correctness_in Hcorrect; [ | eassumption .. ];
    specialize_to_args Hcorrect;
    postcondition_from_correctness.

  Ltac make_operation out :=
    let inbounds := (eval cbv beta in (Pipeline.arg_bounds_of_pipeline out)) in
    let outbounds := (eval cbv beta in (Pipeline.out_bounds_of_pipeline out)) in
    let t := lazymatch goal with |- operation ?t => t end in
    let insizes := sizes_from_bounds inbounds in
    let outsizes := sizes_from_bounds outbounds in
    let inlengths := lengths_from_bounds inbounds in
    let outlengths := lengths_from_bounds outbounds in
    eapply (Build_operation
              t inbounds insizes outsizes inlengths outlengths)
    with (pipeline_out:=out)
         (check_args_ok:=
            check_args m machine_wordsize (ErrorT.Success tt)
            = ErrorT.Success tt).

  Definition mul
    : operation (type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.mul m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition square
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.square m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition add
    : operation (type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.add m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition sub
    : operation (type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.sub m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition opp
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.opp m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition to_montgomery
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.to_montgomery m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition from_montgomery
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.from_montgomery m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition nonzero
    : operation (type_listZ -> type_Z).
  Proof.
    make_operation (WordByWordMontgomery.nonzero m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition selectznz
    : operation (type_Z -> type_listZ -> type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.selectznz m Semantics.width).
    prove_operation_correctness.
    Unshelve.
    { apply Semantics.width. }
    { apply (inject_Z Semantics.width). }
  Defined.

  Definition to_bytes
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.to_bytes m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition from_bytes
    : operation (type_listZ -> type_listZ).
  Proof.
    make_operation (WordByWordMontgomery.from_bytes m Semantics.width).
    prove_operation_correctness.
  Defined.

  Definition spec_of_mul name : spec_of name :=
    fun functions =>
      forall wx wy px py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := mul in
        let args := (map word.unsigned wx, (map word.unsigned wy, tt)) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: py :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat
                      n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_square name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := square in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_add name : spec_of name :=
    fun functions =>
      forall wx wy px py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := add in
        let args := (map word.unsigned wx, (map word.unsigned wy, tt)) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: py :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_sub name : spec_of name :=
    fun functions =>
      forall wx wy px py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := sub in
        let args := (map word.unsigned wx, (map word.unsigned wy, tt)) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: py :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_opp name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := opp in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_to_montgomery name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := to_montgomery in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat
                      n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_from_montgomery name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := from_montgomery in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat
                      n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_nonzero name : spec_of name :=
    fun functions =>
      forall wx px t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := nonzero in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        Rout m ->
        WeakestPrecondition.call
          functions name t m
          (px :: nil)
          (fun t' m' rets =>
             t = t' /\
             length rets = 1%nat /\
             Rout m' /\
             let out := hd (word.of_Z 0) rets in
             op.(postcondition) args (word.unsigned out)).

  Definition spec_of_selectznz name : spec_of name :=
    fun functions =>
      forall wc wx px wy py pout wold_out t m
             (Rx Ry Rout : Semantics.mem -> Prop),
        let op := selectznz in
        let args := (word.unsigned wc,
                     (map word.unsigned wx, (map word.unsigned wy, tt))) in
        let c := word.unsigned wc in
        ZRange.is_bounded_by_bool c bit_range = true ->
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (Bignum n py wy * Ry)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: wc :: px :: py :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat n pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_to_bytes name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := to_bytes in
        let args := (map word.unsigned wx, tt) in
        op.(precondition) args ->
        (Bignum n px wx * Rx)%sep m ->
        (EncodedBignum n_bytes pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (EncodedBignumSuchThat
                      n_bytes pout wout (op.(postcondition) args))
                   Rout m').

  Definition spec_of_from_bytes name : spec_of name :=
    fun functions =>
      forall wx px pout wold_out t m
             (Rx Rout : Semantics.mem -> Prop),
        let op := from_bytes in
        let args := (map byte.unsigned wx, tt) in
        op.(precondition) args ->
        (EncodedBignum n_bytes px wx * Rx)%sep m ->
        (Bignum n pout wold_out * Rout)%sep m ->
        WeakestPrecondition.call
          functions name t m
          (pout :: px :: nil)
          (fun t' m' rets =>
             t = t' /\
             rets = []%list /\
             exists wout,
               sep (BignumSuchThat
                      n pout wout (op.(postcondition) args))
                   Rout m').

  Hint Unfold mul square add sub opp to_montgomery from_montgomery
       nonzero selectznz to_bytes from_bytes : defs.

  Hint Unfold
       spec_of_mul
       spec_of_square
       spec_of_add
       spec_of_sub
       spec_of_opp
       spec_of_to_montgomery
       spec_of_from_montgomery
       spec_of_nonzero
       spec_of_selectznz
       spec_of_to_bytes
       spec_of_from_bytes : specs.

  Section Proofs.
    Context {ok : Types.ok}.
    Existing Instance semantics_ok.

    Context (inname_gen_varname_gen_ok : disjoint inname_gen varname_gen)
            (outname_gen_varname_gen_ok : disjoint outname_gen varname_gen)
            (outname_gen_inname_gen_ok : disjoint outname_gen inname_gen).
    Context (inname_gen_unique : unique inname_gen)
            (outname_gen_unique : unique outname_gen).

    Lemma relax_to_max_bounds x :
      list_Z_bounded_by bounds x ->
      list_Z_bounded_by (max_bounds n) x.
    Proof.
      apply relax_list_Z_bounded_by. cbn.
      cbv [Primitives.saturated_bounds_list max_bounds list_Z_tighter_than].
      induction n; [ reflexivity | ].
      cbn [repeat FoldBool.fold_andb_map ZRange.lower ZRange.upper max_range].
      apply Bool.andb_true_iff. split; [ | solve [ auto ] ].
      apply Bool.andb_true_iff. split; Z.ltb_to_lt; lia.
    Qed.

    Lemma relax_prime_bounds x :
      list_Z_bounded_by prime_bounds_value x ->
      list_Z_bounded_by bounds x.
    Proof.
      cbv [prime_bounds prime_upperbound_list].
      intros; eapply relax_to_bounded_upperbounds;
        eauto; [ | solve [apply MaxBounds.partition_bounded_by] ].
      apply Forall_repeat. reflexivity.
    Qed.

    Lemma relax_to_byte_bounds x :
      list_Z_bounded_by prime_bytes_bounds_value x ->
      list_Z_bounded_by (byte_bounds n_bytes) x.
    Proof.
      cbv [prime_bytes_bounds prime_bytes_upperbound_list].
      intros; eapply relax_to_bounded_upperbounds;
        eauto using ByteBounds.partition_bounded_by; [ ].
      apply Forall_repeat. reflexivity.
    Qed.

    Lemma length_bounds : length bounds = n.
    Proof. apply repeat_length. Qed.

    Lemma bounded_by_bounds_length x :
      list_Z_bounded_by bounds x -> length x = n.
    Proof.
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      rewrite <-length_bounds. cbn - [bounds]. congruence.
    Qed.

    Lemma length_saturated_bounds_value : length saturated_bounds_value = n.
    Proof. apply repeat_length. Qed.

    Lemma bounded_by_saturated_bounds_length x :
      list_Z_bounded_by saturated_bounds_value x -> length x = n.
    Proof.
      cbv [saturated_bounds max_bounds].
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      rewrite length_saturated_bounds_value in *. lia.
    Qed.

    Lemma bounded_by_prime_bounds_length x :
      list_Z_bounded_by prime_bounds_value x -> length x = n.
    Proof.
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      cbv [prime_bounds prime_upperbound_list] in *.
      rewrite map_length, length_partition in *. lia.
    Qed.

    Lemma bounded_by_prime_bytes_bounds_length x :
      list_Z_bounded_by prime_bytes_bounds_value x -> length x = n_bytes.
    Proof.
      intros. pose proof length_list_Z_bounded_by _ _ ltac:(eassumption).
      cbv [prime_bytes_bounds prime_bytes_upperbound_list] in *.
      rewrite map_length, length_partition in *. lia.
    Qed.

    Lemma bounded_by_byte_bounds_length x :
      list_Z_bounded_by (byte_bounds n_bytes) x -> length x = n_bytes.
    Proof. eapply byte_bounds_range_iff. Qed.

    Lemma valid_bounded_by_prime_bounds x :
      (check_args m Semantics.width (ErrorT.Success tt)
       = ErrorT.Success tt) ->
      WordByWordMontgomery.valid Semantics.width n m x ->
      list_Z_bounded_by prime_bounds_value x.
    Proof.
      intros; apply bounded_by_prime_bounds_of_valid; auto.
    Qed.

    Lemma valid_bounded_by_prime_bytes_bounds x :
      (check_args m Semantics.width (ErrorT.Success tt)
       = ErrorT.Success tt) ->
      WordByWordMontgomery.valid 8 n_bytes m x ->
      list_Z_bounded_by prime_bytes_bounds_value x.
    Proof.
      intros; eapply bounded_by_prime_bytes_bounds_of_bytes_valid; eauto.
    Qed.

    (* TODO: maybe make a generalized prove_bounds tactic that takes a list of
    bounds? *)
    Ltac assert_bounds x :=
      match goal with
      | H: list_Z_bounded_by ?bs x |- _ => idtac
      | _ =>
        assert (WordByWordMontgomery.valid Semantics.width n m x)
               by prove_bounds_direct;
        assert (list_Z_bounded_by prime_bounds_value x)
               by (apply valid_bounded_by_prime_bounds; auto)
      | _ =>
        assert (WordByWordMontgomery.valid 8 n_bytes m x)
               by prove_bounds_direct;
        assert (list_Z_bounded_by prime_bytes_bounds_value x)
               by (apply valid_bounded_by_prime_bytes_bounds; auto)
      | _ => assert (list_Z_bounded_by bounds x) by prove_bounds_direct
      | _ => assert (list_Z_bounded_by prime_bytes_bounds_value x)
          by prove_bounds_direct
      | _ => assert (list_Z_bounded_by (max_bounds n) x) by prove_bounds_direct
      | _ => assert (list_Z_bounded_by (byte_bounds n_bytes) x) by prove_bounds_direct
      | _ => fail "could not determine known bounds of" x
      end.
    (* looks for the following combinations of tighter/looser bounds:
       - prime_bounds/bounds
       - prime_bounds/saturated_bounds
       - prime_bytes_bounds/byte_bounds
    *)
    Ltac prove_bounds :=
      match goal with |- list_Z_bounded_by ?bs ?x => assert_bounds x end;
      match goal with
      | H : list_Z_bounded_by ?b1 ?x |- list_Z_bounded_by ?b2 ?x =>
        first [ unify b1 b2; apply H
              | unify b1 prime_bounds_value; unify b2 bounds;
                apply relax_prime_bounds; apply H
              | unify b1 prime_bounds_value; unify b2 saturated_bounds_value;
                apply relax_to_max_bounds, relax_prime_bounds; apply H
              | unify b1 prime_bytes_bounds_value; unify b2 (byte_bounds n_bytes);
                apply relax_to_byte_bounds; apply H ]
      end.

    (* special for to_bytes, because bounds are not included in the
       postcondition as with all other operations *)
    Ltac assert_to_bytes_bounds :=
      match goal with
      | H : postcondition ?op _ ?e |- _ =>
        unify op to_bytes;
        assert (list_Z_bounded_by (byte_bounds n_bytes) e)
          by (cbn [fst snd postcondition to_bytes] in H;
              rewrite H by prove_bounds;
              apply ByteBounds.partition_bounded_by)
      end.

    Ltac prove_output_length :=
      ssplit;
      match goal with
      | |- length _ = n =>
        apply bounded_by_bounds_length; prove_bounds
      | |- length _ = n =>
        apply bounded_by_saturated_bounds_length; prove_bounds
      | |- length _ = n =>
        apply bounded_by_prime_bounds_length; prove_bounds
      | |- length _ = n_bytes =>
        apply bounded_by_byte_bounds_length; prove_bounds
      | |- length _ = n_bytes =>
        apply bounded_by_prime_bytes_bounds_length; prove_bounds
      | |- n = length _ =>
        symmetry; prove_output_length
      | |- n_bytes = length _ =>
        symmetry; prove_output_length
      | |- tt = tt => reflexivity
      | |- ?x => fail "could not prove output length :" x
      end.

    Ltac setup :=
      autounfold with defs specs;
      begin_proof;
      match goal with
        H1 : precondition _ _, H2 : precondition _ _ -> _ |- _ =>
        specialize (H2 H1); autounfold with defs in H1;
        cbn [precondition] in H1; cleanup
      end;
      try assert_to_bytes_bounds;
      assert_output_length prove_output_length.

    Ltac prove_length :=
      lazymatch goal with
      | H : map _ ?x = ?y |- length ?x = length ?y =>
        rewrite <-H, !map_length; congruence
      | H : length ?x = ?n |- length (map _ ?x) = ?n =>
        rewrite map_length; solve [apply H]
      | H : length (map _ ?x) = ?n |- length ?x = ?n =>
        rewrite map_length in H; solve [apply H]
      | |- length ?x = length ?y =>
        rewrite ?map_length in *; congruence
      | H1 : length ?x = ?n, H2 : map _ ?y = ?x |- length ?y = ?n =>
        rewrite <-H1, <-H2, ?map_length; reflexivity
      | _ => idtac
      end.

    Ltac use_translate_func_correct Rout arg_ptrs out_array_ptrs :=
      apply_translate_func_correct Rout arg_ptrs out_array_ptrs;
      [ post_sufficient;
        cbv [Bignum EncodedBignum] in *; sepsimpl;
        prove_length; canonicalize_arrays; ecancel_assumption
      | .. ].

    Ltac solve_lists_reserved out_array_ptrs :=
      lazymatch out_array_ptrs with
      | [] => sepsimpl; solve [auto]
      | _ =>
        exists_all_placeholders out_array_ptrs;
        cbv [Bignum EncodedBignum] in *; sepsimpl;
        lazymatch goal with
        | |- length _ = _ => prove_length
        | |- WeakestPrecondition.get _ _ _ =>
          eexists; rewrite ?map.get_put_diff by eauto;
          rewrite map.get_put_same; solve [eauto]
        | |- sep _ _ _ => canonicalize_arrays; ecancel_assumption
        end
      end.

    Ltac prove_is_correct Rout :=
      let args := lazymatch goal with
                  | H : postcondition _ ?args _ |- _ => args end in
      let arg_ptrs := get_bedrock2_arglist args in
      let all_ptrs := lazymatch goal with
                      | |- call _ _ _ _ ?in_ptrs _ => in_ptrs end in
      let out_ptrs := get_out_array_ptrs arg_ptrs all_ptrs in
      use_translate_func_correct Rout arg_ptrs out_ptrs;
      solve_translate_func_subgoals prove_bounds prove_output_length;
      [ repeat next_argument; [ .. | reflexivity ];
        cbv [Bignum EncodedBignum] in *; sepsimpl;
        canonicalize_arrays; ecancel_assumption
      | setup_lists_reserved; solve_lists_reserved out_ptrs ].

    Context (check_args_ok :
               check_args m Semantics.width (ErrorT.Success tt)
               = ErrorT.Success tt).

    Lemma mul_correct name :
      is_correct
        (WordByWordMontgomery.mul m Semantics.width)
        mul (spec_of_mul name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma square_correct name :
      is_correct
        (WordByWordMontgomery.square m Semantics.width)
        square (spec_of_square name).
    Proof. setup. prove_is_correct Rout. Qed.

    Lemma add_correct name :
      is_correct
        (WordByWordMontgomery.add m Semantics.width)
        add (spec_of_add name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma sub_correct name :
      is_correct
        (WordByWordMontgomery.sub m Semantics.width)
        sub (spec_of_sub name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma opp_correct name :
      is_correct
        (WordByWordMontgomery.opp m Semantics.width)
        opp (spec_of_opp name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma to_montgomery_correct name :
      is_correct
        (WordByWordMontgomery.to_montgomery m Semantics.width)
        to_montgomery (spec_of_to_montgomery name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma from_montgomery_correct name :
      is_correct
        (WordByWordMontgomery.from_montgomery m Semantics.width)
        from_montgomery (spec_of_from_montgomery name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma nonzero_correct name :
      is_correct
        (WordByWordMontgomery.nonzero m Semantics.width)
        nonzero (spec_of_nonzero name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma selectznz_correct name :
      is_correct
        (WordByWordMontgomery.selectznz m Semantics.width)
        selectznz (spec_of_selectznz name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma to_bytes_correct name :
      is_correct
        (WordByWordMontgomery.to_bytes m Semantics.width)
        to_bytes (spec_of_to_bytes name).
    Proof. setup; prove_is_correct Rout. Qed.

    Lemma from_bytes_correct name :
      is_correct
        (WordByWordMontgomery.from_bytes m Semantics.width)
        from_bytes (spec_of_from_bytes name).
    Proof. setup; prove_is_correct Rout. Qed.
  End Proofs.
End __.
Hint Unfold mul square add sub opp to_montgomery from_montgomery
     nonzero selectznz to_bytes from_bytes : defs.
Hint Unfold
     spec_of_mul
     spec_of_square
     spec_of_add
     spec_of_sub
     spec_of_opp
     spec_of_to_montgomery
     spec_of_from_montgomery
     spec_of_nonzero
     spec_of_selectznz
     spec_of_to_bytes
     spec_of_from_bytes : specs.


Require Import Coq.Numbers.NatInt.NZAddOrder.
Set Default Proof Using "All".
Require Import VST.concurrency.ghosts.
From bst Require Export flows ccm.

(** Flow interface cameras and auxiliary lemmas for inset flows
  (used in the give-up template proof). *)

Section inset_flows.

  Context `{HC: Countable Node}.

  Context `{Countable K}.

  Parameter KS: gset K.

  (** CCM of multisets over keys *)

  Definition K_multiset := nzmap K nat.

  Global Instance K_multiset_ccm : CCM K_multiset := lift_ccm K nat.

  Definition dom_ms (m : K_multiset) := dom (gset K) m.

  Definition inset_flowint := @flowintR Node _ _ K_multiset K_multiset_ccm.

  Implicit Type I: inset_flowint.

  (** Insets, outsets, and keysets of flow interfaces *)

  Definition inset I n := dom_ms (inf I n).

  Definition outset I n := dom_ms (out I n).

  Definition in_inset k I n := k ∈ dom_ms (inf I n).

  Definition in_outset k I n := k ∈ dom_ms (out I n).

  Definition in_outsets k In := ∃ n, in_outset k In n.

  Definition keyset I n := dom_ms (inf I n) ∖ dom_ms (out I n).

  Lemma keyset_def : ∀ k I_n n, k ∈ inset I_n n → ¬ in_outsets k I_n
                                → k ∈ keyset I_n n.
  Proof.
    intros ? ? ? k_in_inset k_not_in_outsets.
    unfold keyset.
    unfold inset in k_in_inset.
    unfold in_outsets in k_not_in_outsets.
    rewrite elem_of_difference.
    naive_solver.
  Qed.

  (* The global invariant ϕ. *)
  Definition keyset_global_inv root I :=
    ✓I
    ∧ (root ∈ domm I)
    ∧ (∀ k n, k ∉ outset I n)
    ∧ (∀ k, k ∈ KS → k ∈ inset I root).

  (** Assorted lemmas about inset flows used in the template proofs *)

  Lemma global_inv_root_fp: ∀ I root, keyset_global_inv root I → root ∈ domm I.
  Proof.
    intros I root Hglob. unfold keyset_global_inv in Hglob.
    destruct Hglob as [H1 [H2 H3]]. done.
  Qed.

  Lemma flowint_step :
    ∀ I I1 I2 k n root,
      keyset_global_inv root I → intJoin I1 I2 I → k ∈ outset I1 n → n ∈ domm I2.
  Proof.
    intros I I1 I2 k n r gInv dI kOut.
    unfold keyset_global_inv in gInv.
    destruct gInv as (vI & rI & cI & _).

    assert (domm I = domm I1 ∪ domm I2) as disj. {
      apply (intJoin_dom _ _ _ dI vI). }

    (* First, prove n ∉ domm I1 *)
    destruct (decide (n ∈ domm I1)).
    - pose proof (intJoin_valid_proj1 I1 I2 I dI vI) as vI1.
      pose proof (intValid_in_dom_not_out I1 n vI1 e).
      unfold outset, dom_ms in kOut.
      rewrite nzmap_elem_of_dom_total in kOut *.
      intros.
      unfold ccmunit, ccm_unit, K_multiset_ccm, lift_ccm, lift_unit in H0.
      rewrite H0 in kOut.
      rewrite nzmap_lookup_empty in kOut.
      contradiction.

    (* Now, prove n ∈ domm I *)
    - assert (n ∈ domm I) as in_Inf_n. {
        pose proof (intJoin_unfold_out I1 I2 I dI vI n).
        destruct (decide (n ∉ domm I)).
        + apply H0 in n1.
          pose proof (cI k n) as not_k_out.
          unfold outset, dom_ms in not_k_out.
          rewrite nzmap_elem_of_dom_total in not_k_out *.
          apply dec_stable in not_k_out.
          unfold outset, dom_ms in kOut.
          rewrite nzmap_elem_of_dom_total in kOut *.
          assert (out I n ! k = (out I1 n + out I2 n)%CCM ! k) by now rewrite n1.
          rewrite lookup_op in H1.
          unfold ccmop, ccm_op in H1.
          unfold K_multiset_ccm,ccmunit,ccm_unit,nat_ccm,nat_unit,nat_op
            in kOut, not_k_out, H1. lia.
        + apply dec_stable in n1. trivial. }

      (* Finally, prove n ∈ domm I2 *)
      rewrite disj in in_Inf_n.
      set_solver.
  Qed.

  Lemma outset_distinct : ∀ I n, ✓ I ∧ (∃ k, k ∈ outset I n) → n ∉ domm I.
  Proof.
    intros.
    destruct H0 as (VI & Out).
    destruct Out as [k Out].

    apply flowint_valid_unfold in VI.
    destruct VI as (disj & _).

    rewrite (@map_disjoint_dom Node (gmap Node) (gset Node)) in disj *.
    unfold outset, dom_ms, nzmap_dom, out in Out.
    rewrite nzmap_elem_of_dom_total in Out *.
    destruct (decide (outR I ! n = ∅)).
    - rewrite e in Out.
      rewrite nzmap_lookup_empty in Out.
      contradiction.
    - rewrite <- nzmap_elem_of_dom_total in n0.
      unfold dom, nzmap_dom in n0.
      unfold domm, dom, flowint_dom.
      set_solver.
  Qed.

  Lemma inset_monotone : ∀ I I1 I2 k n,
      ✓ I → intJoin I1 I2 I → k ∈ inset I n → n ∈ domm I1 → k ∈ inset I1 n.
  Proof.
    intros ? ? ? ? ? VI ID Inset Dom.
    (* rewrite ID in VI. *)
    pose proof (intJoin_unfold_inf_1 I1 I2 _ ID VI n) as Inf1.
    apply Inf1 in Dom.
    assert (Inset1 := Inset).
    unfold inset, dom_ms, nzmap_dom in Inset.
    rewrite nzmap_elem_of_dom in Inset *.
    unfold inf in Dom.
    pose proof (intJoin_valid_proj1 I1 I2 _ ID VI) as VI1.
    pose proof (intJoin_valid_proj2 I1 I2 _ ID VI) as VI2.

    unfold inset, inf, dom_ms.
    rewrite Dom.
    rewrite nzmap_elem_of_dom_total.
    rewrite lookup_op.
    unfold nzmap_total_lookup.
    unfold inf, is_Some in Inset.
    destruct Inset as [x Inset].
    rewrite Inset.
    simpl.

    assert (x <> 0). {
      unfold inset, dom_ms in Inset1.
      rewrite nzmap_elem_of_dom_total in Inset1 *.
      rename Inset1 into xDef.
      unfold inf in xDef.
      unfold nzmap_total_lookup in xDef.
      rewrite Inset in xDef.
      simpl in xDef.
      trivial. }

    unfold ccmop, ccm_op, nat_ccm, nat_op, out.
    unfold ccmunit, nat_unit.
    lia.
    all: apply K_multiset_ccm.
  Qed.

  Lemma flowint_inset_step : ∀ I I1 I2 k n,
      intJoin I1 I2 I → ✓ I → n ∈ domm I2 → k ∈ outset I1 n → k ∈ inset I2 n.
  Proof.
    intros ? ? ? ? ? IJ I12V Out Inset.

    pose proof (intJoin_valid_proj1 I1 I2 I IJ I12V) as I1V.
    pose proof (intJoin_valid_proj2 I1 I2 I IJ I12V) as I2V.

    pose proof (intJoin_unfold_inf_2 I1 I2 _ IJ I12V n Out) as Inf2.

    unfold outset in Inset.
    unfold inset, dom_ms.
    rewrite Inf2.
    unfold out.
    repeat rewrite nzmap_elem_of_dom_total.
    repeat rewrite lookup_op.

    unfold dom_ms, out in Inset.
    repeat (rewrite nzmap_elem_of_dom_total in Inset).
    unfold ccmop, ccm_op, nat_ccm, nat_op.
    unfold ccmop, ccm_op, nat_ccm, nat_op in Inset.
    unfold ccmunit, ccm_unit, nat_unit, K_multiset_ccm, prod_ccm.
    unfold ccmunit, ccm_unit, nat_unit, K_multiset_ccm, prod_ccm in Inset.
    lia.
  Qed.

  Lemma contextualLeq_impl_keyset_global_inv : ∀ I I' root,
      keyset_global_inv root I →
      contextualLeq K_multiset I I' →
      (∀ n, n ∈ domm I' ∖ domm I → inset I' n = ∅) →
      keyset_global_inv root I'.
  Proof.
    intros ? ? ? GI CLeq InfI'.
    unfold contextualLeq in CLeq.
    unfold keyset_global_inv in GI.
    destruct GI as (_ & DomR & OutI & InfI).
    destruct CLeq as (VI & VI' & DS & InfR & OutR).
    unfold keyset_global_inv.
    split; [|split; [|split]].
    - trivial.
    - set_solver.
    - intros.
      destruct (decide (n ∈ domm I')).
      * apply flowint_valid_unfold in VI'.
        destruct VI' as [I'_disj _].
        rewrite (@map_disjoint_dom Node (gmap Node) (gset Node)) in I'_disj *.
        intros.
        assert (outR I' ! n = 0%CCM).
        { assert (¬ (n ∈ dom (gset Node) (outR I'))).
          { unfold domm, dom, flowint_dom in e.
            set_solver.
          }
          rewrite nzmap_elem_of_dom_total in H0 *.
          intros.
          apply dec_stable in H0.
            by rewrite H0.
        }
        unfold outset, dom_ms, nzmap_dom, out.
        rewrite H0. simpl.
        rewrite dom_empty.
        apply not_elem_of_empty.
      * assert (n ∉ domm I) by set_solver.
        pose proof (OutR n n0).
        unfold outset. rewrite <- H1.
        pose proof (OutI k n).
        unfold outset in H2.
        trivial.
    - intros.
      (*destruct H2 as (H2 & _).*)
      specialize (InfI k).
      (*rewrite <- H0 in DomR.*)
      specialize (InfR root DomR).
      unfold inset.
      unfold inset in InfR.
      rewrite <- InfR.
      apply InfI in H0.
      trivial.
  Qed.

  Lemma global_inv_root_ins : ∀ I Ir root k,
      keyset_global_inv root I ∧ (exists I', intJoin Ir I' I) ∧ domm Ir = {[root]} ∧ k ∈ KS
      → k ∈ inset Ir root.
  Proof.
    intros I Ir root k ((Hv & _ & _ & Hl) & [I2 Hincl] & Hdom & kKS).
    specialize (Hl k kKS).
    apply (inset_monotone I Ir I2 k root); try done.
    set_solver.
  Qed.

  Lemma intJoin_out_zero I I1 I2 n :
    intJoin I1 I2 I → ✓ I → n ∉ domm I → out I n = 0%CCM → out I2 n = 0%CCM.
  Proof.
    intros IJ Hvld Hn Hout. apply nzmap_eq. intros k.
    assert (out I n = (out (I1) n) + (out I2 n))%CCM.
    { apply intJoin_unfold_out; try done. }
    assert (out I n ! k = (out (I1) n) ! k + (out I2 n) ! k)%CCM.
    { rewrite H0. by rewrite lookup_op. }
    rewrite Hout in H1. rewrite nzmap_lookup_empty in H1.
    unfold ccmunit,ccm_unit in H1. simpl in H1.
    unfold nat_unit in H1. unfold ccmop, nat_op in H1.
    assert (out I2 n ! k = 0). lia.
    rewrite H2. rewrite nzmap_lookup_empty. unfold ccmunit, ccm_unit.
    simpl. by unfold nat_unit.
  Qed.

End inset_flows.

Arguments inset_flowint _ {_ _} _ {_ _} : assert.
(* Arguments inset _ {_ _} _ {_ _} _ _ : assert. *)
(* Arguments outset _ {_ _} _ {_ _} _ _ : assert. *)
(* Arguments keyset _ {_ _} _ {_ _} _ _ : assert. *)
(* Arguments in_inset _ {_ _} _ {_ _} _ _ _ : assert. *)
(* Arguments in_outset _ {_ _} _ {_ _} _ _ _: assert. *)
(* Arguments in_outsets _ {_ _} _ {_ _} _ _ : assert. *)
(* Arguments keyset_global_inv _ {_ _} _ {_ _} _ _ _ : assert. *)
Arguments K_multiset _ {_ _}: assert.


(* We can reuse the.apa definition of periodic arrival sequence. *)
Require Import rt.util.all.
Require Import rt.model.arrival.basic.arrival_sequence rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.arrival.basic.task_arrival.
Require Import rt.implementation.apa.task rt.implementation.apa.job.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq div.

Module ConcreteArrivalSequence.

  Import Job ArrivalSequence ConcreteTask ConcreteJob SporadicTaskset TaskArrival.

  Section PeriodicArrivals.

    Context {num_cpus: nat}.
    Variable ts: concrete_taskset num_cpus.

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

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

  End PeriodicArrivals.

  Section Proofs.

    Context {num_cpus: nat}.

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

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

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

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

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

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

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

  End Proofs.

End ConcreteArrivalSequence.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable t_IMP_008_ : Universe -> Prop.
Variable t_EXISTS_004_ : Prop.
Variable t_AND_006_ : Universe -> Prop.
Variable tNOTD1_ : Universe -> Prop.
Variable tNEG_PSI0_ : Prop.
Variable tGOAL0_ : Prop.
Variable tD1_ : Universe -> Prop.
Variable goal_ : Prop.
Variable fGOAL0_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ fGOAL0_).
Variable bot02_2 : ((tGOAL0_ /\ fGOAL0_) -> goal_).
Variable ax005_3 : (forall A : Universe, (dom_ A -> t_AND_006_ A)).
Variable ax006_4 : (forall A : Universe, (t_AND_006_ A -> (tD1_ A /\ tNEG_PSI0_))).
Variable ax007_5 : (forall A : Universe, (dom_ A -> t_IMP_008_ A)).
Variable ax008_6 : (forall A : Universe, ((t_IMP_008_ A /\ (tD1_ A /\ tNOTD1_ A)) -> tGOAL0_)).
Variable ax003_7 : (tNEG_PSI0_ -> t_EXISTS_004_).
Variable ax004_8 : (t_EXISTS_004_ -> (exists A : Universe, (dom_ A /\ tNOTD1_ A))).

Theorem d_horn_9 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Undecidability.TM.KOSBTM.KOSBTM.

Require Import Undecidability.Shared.Libs.PSL.Vectors.FinNotation Undecidability.Shared.Libs.PSL.Vectors.Vectors Undecidability.Shared.Libs.PSL.EqDec.

Require Import List Arith Lia Bool.

From Undecidability.Shared.Libs.DLW
  Require Import utils list_bool pos vec subcode sss.

From Undecidability.StackMachines.BSM
  Require Import bsm_defs.

Import ListNotations.
Import VectorNotations2.
Local Open Scope vector.

Set Default Proof Using "Type".

Tactic Notation "rew" "length" := autorewrite with length_db.

Local Notation "e #> x" := (vec_pos e x).
Local Notation "e [ v / x ]" := (vec_change e x v).

Local Notation "P // s -[ k ]-> t" := (sss_steps (@bsm_sss _) P k s t).
Local Notation "P // r -+> s" := (sss_progress(@bsm_sss _)  P r s).
Local Notation "P // s ->> t" := (sss_compute (@bsm_sss _) P s t).

Definition enc_tape (t : tape) : Vector.t (list bool) 4 :=
    [| left t ; match curr t with Some c => [c] | None => [] end ; right t ; [] |]%vector.

Ltac solve_sc :=
  repeat match goal with
          | [ |- (?i, _) <sc (?i, _)] => eexists [], _; split; [reflexivity | cbn; try lia]
          | [ |- (?o + ?i, ?c1) <sc (?i, ?c2) ] => exists (firstn o c2); eexists; split; [ reflexivity | cbn; lia]
          | [ |- (?l, ?c1) <sc (?i, ?c2) ] =>
            let x := fresh "x" in
            let H := fresh "H" in
            evar (x : nat);
            assert (l = x + i); [ ring_simplify; subst x; reflexivity | rewrite H; subst x ]
          end.

Local Hint Extern 0 => solve_sc : core.

Notation CURR := (Fin1 : Fin.t 4).
Notation LEFT := (Fin0 : Fin.t 4).
Notation RIGHT := (Fin2 : Fin.t 4).
Notation ZERO := (Fin3 : Fin.t 4).
Notation CURR_ := 1.
Notation LEFT_ := 0.
Notation RIGHT_ := 2.
Notation ZERO_ := 3.

Notation JMP i := (POP ZERO i i).

Section fixi.

    Variable i : nat.

    Notation END := (23 + i).

    Definition MOVE_L :=
        [
        (* i *)       POP  CURR (8 + i) (5 + i)   ;
        (* i +  1 *)  POP  LEFT (14 + i) (12 + i) ;
        (* i +  2 *)  PUSH CURR  true ;
        (* i +  3 *)  PUSH RIGHT true;
        (* i +  4 *)  JMP  END ;
        (* i +  5 *)  POP  LEFT (17 + i) END ;
        (* i +  6 *)  PUSH CURR true ;
        (* i +  7 *)  JMP END ;
        (* i +  8 *)  POP LEFT (21 + i) (19 + i) ;
        (* i +  9 *)  PUSH CURR true ;
        (* i + 10 *)  PUSH RIGHT false ;
        (* i + 11 *)  JMP END ;
        (* i + 12 *)  PUSH RIGHT true ;
        (* i + 13 *)  JMP END ;
        (* i + 14 *)  PUSH CURR false ;
        (* i + 15 *)  PUSH RIGHT true ;
        (* i + 16 *)  JMP END ;
        (* i + 17 *)  PUSH CURR false ;
        (* i + 18 *)  JMP END ;
        (* i + 19 *)  PUSH RIGHT false ;
        (* i + 20 *)  JMP END ;
        (* i + 21 *)  PUSH CURR false ;
        (* i + 22 *)  PUSH RIGHT false
        ].

    Fact MOVE_L_length : length MOVE_L = 23.
    Proof. reflexivity. Qed.

    Fact MOVE_L_spec t : (i,MOVE_L) // (i, enc_tape t) ->> (END, enc_tape (mv Lmove t)).
    Proof.
      unfold MOVE_L.
      destruct t as [[ [ | l ls] [ [] | ] ] rs].
      - bsm sss POP one with CURR (8 + i) (5 + i) [].
        bsm sss POP empty with LEFT (14 + i) (12 + i).
        bsm sss PUSH with RIGHT true.
        bsm sss POP empty with ZERO END END.
        bsm sss stop.
      - bsm sss POP zero with CURR (8 + i) (5 + i) [].
        bsm sss POP empty with LEFT (21 + i) (19 + i).
        bsm sss PUSH with RIGHT false.
        bsm sss POP empty with ZERO END END.
        bsm sss stop.
      - bsm sss POP empty with CURR (8 + i) (5 + i).
        bsm sss POP empty with LEFT (17 + i) END.
        bsm sss stop.
      - bsm sss POP one with CURR (8 + i) (5 + i) [].
        destruct l.
        + bsm sss POP one with LEFT (14 + i) (12 + i) ls.
          bsm sss PUSH with CURR true.
          bsm sss PUSH with RIGHT true.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
        + bsm sss POP zero with LEFT (14 + i) (12 + i) ls.
          bsm sss PUSH with CURR false.
          bsm sss PUSH with RIGHT true.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
      - bsm sss POP zero with CURR (8 + i) (5 + i) [].
        destruct l.
        + bsm sss POP one with LEFT (21 + i) (19 + i) ls.
          bsm sss PUSH with CURR true.
          bsm sss PUSH with RIGHT false.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
        + bsm sss POP zero with LEFT (21 + i) (19 + i) ls.
          bsm sss PUSH with CURR false.
          bsm sss PUSH with RIGHT false.
          bsm sss stop.
      - bsm sss POP empty with CURR (8 + i) (5 + i).
        destruct l.
        + bsm sss POP one with LEFT (17 + i) END ls.
          bsm sss PUSH with CURR true.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
        + bsm sss POP zero with LEFT (17 + i) END ls.
          bsm sss PUSH with CURR false.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
    Qed.

    Definition MOVE_R :=
        [
        (* i *)       POP  CURR (8 + i) (5 + i)   ;
        (* i +  1 *)  POP  RIGHT (14 + i) (12 + i) ;
        (* i +  2 *)  PUSH CURR  true ;
        (* i +  3 *)  PUSH LEFT true;
        (* i +  4 *)  JMP  END ;
        (* i +  5 *)  POP  RIGHT (17 + i) END ;
        (* i +  6 *)  PUSH CURR true ;
        (* i +  7 *)  JMP END ;
        (* i +  8 *)  POP RIGHT (21 + i) (19 + i) ;
        (* i +  9 *)  PUSH CURR true ;
        (* i + 10 *)  PUSH LEFT false ;
        (* i + 11 *)  JMP END ;
        (* i + 12 *)  PUSH LEFT true ;
        (* i + 13 *)  JMP END ;
        (* i + 14 *)  PUSH CURR false ;
        (* i + 15 *)  PUSH LEFT true ;
        (* i + 16 *)  JMP END ;
        (* i + 17 *)  PUSH CURR false ;
        (* i + 18 *)  JMP END ;
        (* i + 19 *)  PUSH LEFT false ;
        (* i + 20 *)  JMP END ;
        (* i + 21 *)  PUSH CURR false ;
        (* i + 22 *)  PUSH LEFT false
        ].

    Fact MOVE_R_length : length MOVE_R = 23.
    Proof. reflexivity. Qed.

    Fact MOVE_R_spec t : (i,MOVE_R) // (i, enc_tape t) ->> (END, enc_tape (mv Rmove t)).
    Proof.
      unfold MOVE_R.
      destruct t as [[ls c] rs]; destruct rs as [ | r rs], c as [ [] | ].
      - bsm sss POP one with CURR (8 + i) (5 + i) [].
        bsm sss POP empty with RIGHT (14 + i) (12 + i).
        bsm sss PUSH with LEFT true.
        bsm sss POP empty with ZERO END END.
        bsm sss stop.
      - bsm sss POP zero with CURR (8 + i) (5 + i) [].
        bsm sss POP empty with RIGHT (21 + i) (19 + i).
        bsm sss PUSH with LEFT false.
        bsm sss POP empty with ZERO END END.
        bsm sss stop.
      - bsm sss POP empty with CURR (8 + i) (5 + i).
        bsm sss POP empty with RIGHT (17 + i) END.
        bsm sss stop.
      - bsm sss POP one with CURR (8 + i) (5 + i) [].
        destruct r.
        + bsm sss POP one with RIGHT (14 + i) (12 + i) rs.
          bsm sss PUSH with CURR true.
          bsm sss PUSH with LEFT true.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
        + bsm sss POP zero with RIGHT (14 + i) (12 + i) rs.
          bsm sss PUSH with CURR false.
          bsm sss PUSH with LEFT true.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
      - bsm sss POP zero with CURR (8 + i) (5 + i) [].
        destruct r.
        + bsm sss POP one with RIGHT (21 + i) (19 + i) rs.
          bsm sss PUSH with CURR true.
          bsm sss PUSH with LEFT false.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
        + bsm sss POP zero with RIGHT (21 + i) (19 + i) rs.
          bsm sss PUSH with CURR false.
          bsm sss PUSH with LEFT false.
          bsm sss stop.
      - bsm sss POP empty with CURR (8 + i) (5 + i).
        destruct r.
        + bsm sss POP one with RIGHT (17 + i) END rs.
          bsm sss PUSH with CURR true.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
        + bsm sss POP zero with RIGHT (17 + i) END rs.
          bsm sss PUSH with CURR false.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
    Qed.

End fixi.

Section fixM.

    Variable M : KOSBTM.

    Notation δ := (trans M).

    Variable j : nat.

    Notation "! p" := (proj1_sig (Fin.to_nat p)) (at level 1).

    Notation c := 76.

    Local Notation "'if!' x 'is' p 'then' a 'else' b" := (match x with p => a | _ => b end) (at level 0, p pattern).

    Notation END := (j + (1 + num_states M) * c).

    Definition PROG (i : Fin.t (S (num_states M))) :=
      let off := j + c * !i in
      [
         (*      off *)  POP CURR (26 + off) (51 + off) ;
         (*  1 + off *)  PUSH CURR (if! δ (i, Some true) is Some (_, Some false, _) then false else true)
      ] ++
         (*  2 + off *)  match δ (i, Some true) with Some (_, _, Rmove) => MOVE_R (2 + off) | Some (_, _, Lmove) => MOVE_L (2 + off) | _ => repeat (JMP (25 + off)) 23 end ++
      [  (* 25 + off *)  JMP (match δ (i, Some true) with None => END | Some (q', _, _) => (j + c * ! q') end) ;
         (* 26 + off *)  PUSH CURR (if! δ (i, Some false) is Some (_, Some true, _) then true else false) ]
         ++
         (* 27 + off *)  match δ (i, Some false) with Some (_, _, Rmove) => MOVE_R (27 + off) | Some (_, _, Lmove) => MOVE_L (27 + off) | _ => repeat (JMP (50 + off)) 23 end ++
      [  (* 50 + off *)  JMP (match δ (i, Some false) with None => END | Some (q', _, _) => (j + c * ! q') end) ;
         (* 51 + off *)  match δ (i, None) with None => JMP END | Some (_, Some w, _) => PUSH CURR w | Some _ => JMP (52 + off) end ] ++
         (* 52 + off *)  match δ (i, None) with Some (_, _, Rmove) => MOVE_R (52 + off) | Some (_, _, Lmove) => MOVE_L (52 + off) | _ => repeat (JMP (75 + off)) 23 end ++
      [  (* 75 + off *)  JMP (match δ (i, None) with None => END | Some (q', _, _) => (j + c * ! q') end )
      ]
      .

    Fact PROG_length i : length (PROG i) = c.
    Proof. unfold PROG. rewrite app_length.
           destruct (δ (i, Some false)) as [ [[? []] []] | ] eqn:E1;
           destruct (δ (i, Some true)) as [ [[? []] []] | ] eqn:E2;
           destruct (δ (i, None)) as [ [[? []] []] | ]  eqn:E3.
           all:reflexivity.
    Qed.

    Lemma subcode1 i : let off := j  + c * !i in (26 + off, [PUSH CURR (if! δ (i, Some false) is Some (_, Some true, _) then true else false) ]
    ++
    (* 27 + off *)  match δ (i, Some false) with Some (_, _, Rmove) => MOVE_R (27 + off) | Some (_, _, Lmove) => MOVE_L (27 + off) | _ => repeat (JMP (50 + off)) 23 end ++
 [  (* 50 + off *)  JMP (match δ (i, Some false) with None => END | Some (q', _, _) => (j + c * ! q') end) ;
    (* 51 + off *)  match δ (i, None) with None => JMP END | Some (_, Some w, _) => PUSH CURR w | Some _ => JMP (52 + off) end ] ++
    (* 52 + off *)  match δ (i, None) with Some (_, _, Rmove) => MOVE_R (52 + off) | Some (_, _, Lmove) => MOVE_L (52 + off) | _ => repeat (JMP (75 + off)) 23 end ++
 [  (* 75 + off *)  JMP (match δ (i, None) with None => END | Some (q', _, _) => (j + c * ! q') end )
 ]) <sc (off, PROG i).
    Proof.
      intros ?.
      match goal with
      | [ |- (?o + ?i, ?c1) <sc (?i, ?c2) ] => exists (firstn o c2); exists []; split
      end.
      rewrite app_nil_r. 2:rewrite firstn_length, PROG_length. 2:lia.
      enough (firstn 26 (PROG i) = [ POP CURR (26 + off) (51 + off) ;
      (*  1 + off *)  PUSH CURR (if! δ (i, Some true) is Some (_, Some false, _) then false else true)
   ] ++
      (*  2 + off *)  match δ (i, Some true) with Some (_, _, Rmove) => MOVE_R (2 + off) | Some (_, _, Lmove) => MOVE_L (2 + off) | _ => repeat (JMP (25 + off)) 23 end ++
   [  (* 25 + off *)  JMP (match δ (i, Some true) with None => END | Some (q', _, _) => (j + c * ! q') end)]); subst off. rewrite H.
      unfold PROG. now rewrite <- !app_assoc.
      unfold PROG. destruct (δ (i, Some One)) as [ [ [] [] ] | ]; reflexivity.
    Qed.

    Lemma subcode2 i : let off := j + c * !i in (51 + off, [
    (* 51 + off *)  match δ (i, None) with None => JMP END | Some (_, Some w, _) => PUSH CURR w | Some _ => JMP (52 + off) end ] ++
    (* 52 + off *)  match δ (i, None) with Some (_, _, Rmove) => MOVE_R (52 + off) | Some (_, _, Lmove) => MOVE_L (52 + off) | _ => repeat (JMP (75 + off)) 23 end ++
 [  (* 75 + off *)  JMP (match δ (i, None) with None => END | Some (q', _, _) => (j + c * ! q') end )
 ]) <sc (off, PROG i).
    Proof.
      intros ?.
      match goal with
      | [ |- (?o + ?i, ?c1) <sc (?i, ?c2) ] => exists (firstn o c2); exists []; split
      end.
      rewrite app_nil_r. 2:rewrite firstn_length, PROG_length. 2:lia.
      enough (firstn 51 (PROG i) = [ POP CURR (26 + off) (51 + off) ;
      (*  1 + off *)  PUSH CURR (if! δ (i, Some true) is Some (_, Some false, _) then false else true)
   ] ++
      (*  2 + off *)  match δ (i, Some true) with Some (_, _, Rmove) => MOVE_R (2 + off) | Some (_, _, Lmove) => MOVE_L (2 + off) | _ => repeat (JMP (25 + off)) 23 end ++
   [  (* 25 + off *)  JMP (match δ (i, Some true) with None => END | Some (q', _, _) => (j + c * ! q') end) ;
      (* 26 + off *)  PUSH CURR (if! δ (i, Some false) is Some (_, Some true, _) then true else false) ]
      ++
      (* 27 + off *)  match δ (i, Some false) with Some (_, _, Rmove) => MOVE_R (27 + off) | Some (_, _, Lmove) => MOVE_L (27 + off) | _ => repeat (JMP (50 + off)) 23 end ++
   [  (* 50 + off *)  JMP (match δ (i, Some false) with None => END | Some (q', _, _) => (j + c * ! q') end)]); subst off. rewrite H.
      unfold PROG. now rewrite <- !app_assoc.
      unfold PROG. destruct (δ (i, Some One)) as [ [ [] [] ] | ]; destruct (δ (i, Some false)) as [ [ [] [] ] | ]; reflexivity.
    Qed.

    Lemma case_Some_false o {X} (c1 c2 : X) : (if! o is Some false then c1 else c2 = c1 /\ o = Some false)
                            \/ (if! o is Some false then c1 else c2 = c2 /\ o <> Some false).
    Proof using M.
      destruct o as [ [] | ]; firstorder congruence.
    Qed.

    Lemma case_Some_true o {X} (c1 c2 : X) : (if! o is Some true then c1 else c2 = c1 /\ o = Some true)
                            \/ (if! o is Some true then c1 else c2 = c2 /\ o <> Some true).
    Proof using M.
      destruct o as [ [] | ]; firstorder congruence.
    Qed.

    Lemma case_None (o : option bool) {X} (c2 : X) c1 : (if! o is Some w then c1 w else c2 = c2 /\ o = None)
                            \/ (exists w, (if! o is Some w then c1 w else c2) = c1 w /\ o = Some w).
    Proof.
      destruct o as [ [] | ]. right. eauto. right. eauto. eauto.
    Qed.

    Fact PROG_spec (i : Fin.t (S (num_states M))) t :
      (j + c * !i, PROG i) // (j + c * !i, enc_tape t) -+> match δ (i, curr t)
                                                   with None => (END, enc_tape t) |
                                                        Some (q', w, m) => (j + c * !q' , enc_tape (mv m (wr w t)))
                                                   end.
    Proof.
      set (off := j + c * !i).
      destruct t as [[ls [ [] | ]] rs] eqn:Eq_tape.
      - cbn [curr].
        eapply sss_progress_compute_trans. exists 1. split. lia. econstructor. 2:econstructor.
        eapply subcode_sss_step with (P := (off, [POP CURR (26 + off) (51 + off)])). easy.
        eapply in_sss_step with (l := []). cbn; lia.
        econstructor 3. reflexivity.
        unfold PROG.
        (* bsm sss POP one with CURR (26 + off) (51 + off) []. bsm sss stop.  *)
        destruct (δ (i, Some true)) as [ [[q' w] m] | ] eqn:Eq_nxt.
        + edestruct (@case_Some_false w) as [ [H H0] | [H H0]].
          * rewrite H.
            bsm sss PUSH with CURR false.
            destruct m eqn:Eq_mv.
            -- eapply subcode_sss_compute_trans with (P := (2+off, MOVE_L (2 + off))). easy.
               cbn - [plus mult].
               eapply (MOVE_L_spec (2 + off) (ls, Some Zero, rs)).
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. rewrite H0. reflexivity.
            -- eapply subcode_sss_compute_trans with (P := (2+off, MOVE_R (2 + off))). easy.
               cbn - [plus mult].
               eapply (MOVE_R_spec (2 + off) (ls, Some Zero, rs)).
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. rewrite H0. reflexivity.
            -- bsm sss POP empty with ZERO (25 + off) (25 + off).
               bsm sss POP empty with ZERO (j + c * !q') (j + c * !q').
               bsm sss stop. subst; reflexivity.
          * rewrite H. bsm sss PUSH with CURR true.
            destruct m eqn:Eq_mv.
            -- eapply subcode_sss_compute_trans with (P := (2+off, MOVE_L (2 + off))). easy.
               cbn - [plus mult].
               eapply (MOVE_L_spec (2 + off) (ls, Some One, rs)).
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. destruct w as [ [] | ]; try reflexivity. easy.
            -- eapply subcode_sss_compute_trans with (P := (2+off, MOVE_R (2 + off))). easy.
               cbn - [plus mult].
               eapply (MOVE_R_spec (2 + off) (ls, Some One, rs)).
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. destruct w as [ [] | ]; try reflexivity. easy.
            -- bsm sss POP empty with ZERO (25 + off) (25 + off).
               bsm sss POP empty with ZERO (j + c * !q') (j + c * !q').
               bsm sss stop. destruct w as [ [] | ]; try reflexivity. easy.
        + bsm sss PUSH with CURR true.
          bsm sss POP empty with ZERO (25 + off) (25 + off).
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
      - cbn [curr].
        eapply sss_progress_compute_trans. exists 1. split. lia. econstructor. 2:econstructor.
        eapply subcode_sss_step with (P := (off, [POP CURR (26 + off) (51 + off)])). easy.
        eapply in_sss_step with (l := []). cbn; lia.
        econstructor 2. reflexivity.
        unfold PROG.
(*         bsm sss POP zero with CURR (26 + off) (51 + off) []. *)
        eapply subcode_sss_compute_trans; try eapply subcode1. 2:{ bsm sss stop. }
        destruct (δ (i, Some false)) as [ [[q' w] m] | ] eqn:Eq_nxt.
        + edestruct (@case_Some_true w) as [ [] | []].
          * rewrite H. change (j + 76 * !i)  with off.
            bsm sss PUSH with CURR true.
            destruct m eqn:Eq_mv.
            -- eapply subcode_sss_compute_trans with (P := (27+off, MOVE_L (27 + off))). now auto.
               eapply (MOVE_L_spec (27 + off) (ls, Some One, rs)).
               replace (23 + (27 + off)) with (24 + (26 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. rewrite H0. reflexivity.
            -- eapply subcode_sss_compute_trans with (P := (27 +off, MOVE_R (27 + off))). now auto.
               eapply (MOVE_R_spec (27 + off) (ls, Some One, rs)).
               replace (23 + (27 + off)) with (24 + (26 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. rewrite H0. reflexivity.
            -- bsm sss POP empty with ZERO (50 + off) (50 + off).
               replace (50 + off) with (24 + (26 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * !q') (j + c * !q').
               bsm sss stop. subst; reflexivity.
          * rewrite H. change (j + 76 * !i)  with off.
            bsm sss PUSH with CURR false.
            destruct m eqn:Eq_mv.
            -- eapply subcode_sss_compute_trans with (P := (27+off, MOVE_L (27 + off))). replace (27 + off) with (1 + (26 + off)) at 1 by lia. eauto.
               eapply (MOVE_L_spec (27 + off) (ls, Some false, rs)).
               replace (23 + (27 + off)) with (24 + (26 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. destruct w as [ [] | ]; try reflexivity. easy.
            -- eapply subcode_sss_compute_trans with (P := (27 +off, MOVE_R (27 + off))).
               replace (27 + off) with (1 + (26 + off)) at 1 by lia. easy.
               eapply (MOVE_R_spec (27 + off) (ls, Some false, rs)).
               replace (23 + (27 + off)) with (24 + (26 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. destruct w as [ [] | ]; try reflexivity. easy.
            -- bsm sss POP empty with ZERO (50 + off) (50 + off).
               replace (50 + off) with (24 + (26 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * !q') (j + c * !q').
               bsm sss stop. destruct w as [ [] | ]; try reflexivity. easy.
        + change (j + 76 * !i) with off.
          bsm sss PUSH with CURR false.
          bsm sss POP empty with ZERO (50 + off) (50 + off).
          replace (50 + off) with (24 + (26 + off)) by lia.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
      - cbn [curr].
        eapply sss_progress_compute_trans. exists 1. split. lia. econstructor. 2:econstructor.
        eapply subcode_sss_step with (P := (off, [POP CURR (26 + off) (51 + off)])). easy.
        eapply in_sss_step with (l := []). cbn; lia.
        econstructor 1. reflexivity.
        unfold PROG.
        (* bsm sss POP empty with CURR (26 + off) (51 + off). *)
        eapply subcode_sss_compute_trans; try eapply subcode2. 2:{ bsm sss stop. }
        destruct (δ (i, None)) as [ [[q' w] m] | ] eqn:Eq_nxt.
        + edestruct (@case_None w) as [ [] | []].
          * rewrite H. change (j + 76 * !i)  with off.
            bsm sss POP empty with ZERO (52 + off) (52 + off).
            destruct m eqn:Eq_mv.
            -- eapply subcode_sss_compute_trans with (P := (52+off, MOVE_L (52 + off))). now auto.
               eapply (MOVE_L_spec (52 + off) (ls, None, rs)).
               replace (23 + (52 + off)) with (24 + (51 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. rewrite H0. reflexivity.
            -- eapply subcode_sss_compute_trans with (P := (52 +off, MOVE_R (52 + off))). now auto.
               eapply (MOVE_R_spec (52 + off) (ls, None, rs)).
               replace (23 + (52 + off)) with (24 + (51 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
               bsm sss stop. rewrite H0. reflexivity.
            -- replace (52 + off) with (1 + (51 + off)) by lia.
               bsm sss POP empty with ZERO (75 + off) (75 + off).
               replace (75 + off) with (24 + (51 + off)) by lia.
               bsm sss POP empty with ZERO (j + c * !q') (j + c * !q').
               bsm sss stop. subst; reflexivity.
          * destruct w eqn:Eq_w.
            -- change (j + 76 * !i)  with off.
               bsm sss PUSH with CURR b.
               destruct m eqn:Eq_mv.
               ++ eapply subcode_sss_compute_trans with (P := (52+off, MOVE_L (52 + off))). replace (52 + off) with (1 + (51 + off)) at 1 by lia. eauto.
                  eapply (MOVE_L_spec (52 + off) (ls, Some b, rs)).
                  replace (23 + (52 + off)) with (24 + (51 + off)) by lia.
                  bsm sss POP empty with ZERO (j + c * ! q') (j + c * ! q').
                  bsm sss stop.
               ++ eapply subcode_sss_compute_trans with (P := (52 +off, MOVE_R (52 + off))).
                  replace (52 + off) with (1 + (51 + off)) at 1 by lia. easy.
                  eapply (MOVE_R_spec (52 + off) (ls, Some b, rs)).
                  replace (23 + (52 + off)) with (24 + (51 + off)) by lia.
                  bsm sss POP empty with ZERO (j + c * !q') (j + c * ! q').
                  bsm sss stop.
               ++ bsm sss POP empty with ZERO (75 + off) (75 + off).
                  replace (75 + off) with (24 + (51 + off)) by lia.
                  bsm sss POP empty with ZERO (j + c * !q') (j + c * !q').
                  bsm sss stop.
            -- change (j + 76 * !i)  with off.
               bsm sss POP empty with ZERO (52 + off) (52 + off).
               destruct m eqn:Eq_mv.
               ++ eapply subcode_sss_compute_trans with (P := (52+off, MOVE_L (52 + off))). replace (52 + off) with (1 + (51 + off)) at 1 by lia. eauto.
                  eapply (MOVE_L_spec (52 + off) (ls, None, rs)).
                  replace (23 + (52 + off)) with (24 + (51 + off)
                                                 ) by lia.
                  bsm sss POP empty with ZERO (j + c * !q') (j + c * ! q').
                  bsm sss stop.
               ++ eapply subcode_sss_compute_trans with (P := (52 +off, MOVE_R (52 + off))).
                  replace (52 + off) with (1 + (51 + off)) at 1 by lia. easy.
                  eapply (MOVE_R_spec (52 + off) (ls, None, rs)).
                  replace (23 + (52 + off)) with (24 + (51 + off)) by lia.
                  bsm sss POP empty with ZERO (j + c * !q') (j + c * ! q').
                  bsm sss stop.
               ++ replace (52 + off) with (1 + (51 + off)) by lia.
                  bsm sss POP empty with ZERO (75 + off) (75 + off).
                  replace (75 + off) with (24 + (51 + off)) by lia.
                  bsm sss POP empty with ZERO (j + c * !q') (j  + c * !q').
                  bsm sss stop.
        + change (j + 76 * !i) with off.
          bsm sss POP empty with ZERO END END.
          bsm sss stop.
    Qed.

    Fixpoint sim (n : nat) (H : n <= S (num_states M)) : list (bsm_instr 4).
    Proof using j.
      destruct n.
      - exact [].
      - refine (sim n _ ++ _). abstract lia.
        assert (Hn : n < S (num_states M)) by abstract lia.
        refine (PROG (Fin.of_nat_lt Hn)).
    Defined.

    Definition SIM : list (bsm_instr 4). refine (@sim (S (num_states M)) _). Proof using M j. abstract lia. Defined.

    Lemma sim_length (n : nat) (H : n <= S (num_states M)) :
       @length (bsm_instr 4) (@sim n H) = c * n.
    Proof.
      induction n.
      - unfold sim. cbn. lia.
      - unfold sim. fold sim. rewrite app_length. rewrite PROG_length. rewrite IHn. lia.
    Qed.

    Lemma SIM_length : length SIM = c * (S (num_states M)).
    Proof.
      unfold SIM. rewrite sim_length. lia.
    Qed.
    Arguments sim _ _ : clear implicits.

    Lemma of_nat_lt_0 n (H : 0 < S n) : Fin.of_nat_lt H = @Fin.F1 n.
    Proof.
      unfold Fin.of_nat_lt. reflexivity.
    Qed.

    Arguments Fin.of_nat_lt _ {_} _.

    Lemma PROG_sim_sc q n (H : n <= S (num_states M)) : ! q < n -> (j + 76 * ! q, PROG q) <sc (j, sim n H).
    Proof.
      revert q.
      induction n as [n IH] using lt_wf_ind; intros q.
      destruct n.
      - intros. lia.
      - intros H0. eapply Nat.lt_eq_cases in H0 as [H0 | H0].
        + unfold sim. fold sim. eapply subcode_app_end. eapply IH. lia. lia.
        + inversion H0. subst. clear H0. unfold sim. fold sim. revert H IH.
          eapply (Fin.caseS' q).
          * intros H IH. cbn [Fin.to_nat proj1_sig sim]. rewrite of_nat_lt_0.
            cbn - [PROG]. eexists [], []. split. rewrite app_nil_r. reflexivity. reflexivity.
          * clear q. intros q H IH.
            erewrite Fin.of_nat_ext.
            rewrite Fin.of_nat_to_nat_inv.
            eapply subcode_right. rewrite sim_length. reflexivity.
    Qed.

    Lemma PROG_sc q : (j + 76 * ! q, PROG q) <sc (j, SIM).
    Proof.
      eapply PROG_sim_sc. destruct (Fin.to_nat q). cbn. lia.
    Qed.

    Theorem SIM_computes q t q' t' :
       KOSBTM.eval M q t q' t' -> (j,SIM) // (j + c * !q, enc_tape t) ->> (END, enc_tape t').
    Proof.
      induction 1.
      - eapply subcode_sss_compute_trans with (P := (j + 76 * !q, PROG q)). eapply PROG_sc.
        eapply sss_progress_compute. eapply PROG_spec.
        rewrite H.
        bsm sss stop.
      - eapply subcode_sss_compute_trans with (P := (j + 76 * !q, PROG q)). eapply PROG_sc.
        eapply sss_progress_compute. eapply PROG_spec.
        rewrite H. eapply IHeval.
    Qed.

    Theorem SIM_term q t i out :
       i < j \/ i >= j + length SIM ->
       (j,SIM) // (j + c * !q, enc_tape t) ->> (i, out) -> exists q' t', i = END /\ out = enc_tape t' /\ KOSBTM.eval M q t q' t'.
    Proof.
      intros Hout [k H]. revert q t H.
      induction k as [k IH] using lt_wf_ind; intros q t H.
      edestruct PROG_spec as [k' H'].
      eapply subcode_sss_subcode_inv in H. 4: eapply PROG_sc. 4: eapply H'. 2:{ apply bsm_sss_fun. }
      - destruct H as (k'' & -> & HH).
        destruct (δ (q, curr t)) as [ [[q' w] m] | ] eqn:Eq_nxt.
        + eapply IH in HH.
          * destruct HH as (q'' & t'' & -> & -> & HH). exists q'', t''; repeat split.
            econstructor. eassumption. eassumption.
          * destruct H'. lia.
        + eapply sss_steps_stop in HH as [= <- <-].
          exists q, t. repeat split. econstructor. easy.
          unfold out_code. right. unfold fst, code_end, snd, fst, plus. rewrite SIM_length. fold plus. lia.
      - unfold out_code.
        destruct Hout.
        + left. cbn. lia.
        + right. unfold fst, code_end, snd, fst. rewrite PROG_length.
          transitivity (j + length SIM). rewrite SIM_length. destruct (Fin.to_nat q). cbn - [plus mult]. lia. lia.
    Qed.

    Theorem SIM_correct t :
      HaltKOSBTM (M, t) <-> BSM_HALTING (existT _ 4 (existT _ j (existT _ SIM (enc_tape t)))).
    Proof.
      split.
      - intros (q' & t' & H). eapply SIM_computes in H.
        unfold BSM_HALTING. eexists. split. rewrite Nat.mul_comm in H.
        match type of H with _ // (?K, _) ->> _ => replace K with j in H end. 2: cbn; lia.
        eapply H.
        unfold out_code. right. unfold fst, code_end, snd, fst. rewrite SIM_length. lia.
      - intros ([i out] & H1 & H2). pose proof (HS := @SIM_term pos0).
        cbn [Fin.to_nat proj1_sig] in HS. rewrite NPeano.Nat.mul_0_r, NPeano.Nat.add_0_r in HS.
        eapply HS in H1 as (q' & t' & -> & -> & H).
        exists q', t'. eassumption.
        unfold out_code, code_start, code_end, fst, snd in H2. lia.
    Qed.

End fixM.

Require Import Undecidability.Synthetic.Definitions.

Theorem KOSBTM_to_BSM :
  HaltKOSBTM ⪯ Halt_BSM.
Proof.
  unshelve eexists.
  - intros [M t]. exists 4. exists 0. exists (SIM M 0). exact (enc_tape t).
  - intros [M t]. setoid_rewrite Halt_BSM_iff. eapply SIM_correct.
Qed.


Require Import FP.Core.
Require Import FP.Data.Product.
Require Import FP.Data.Option.
Require Import FP.Classes.Traversable.

Section Vanilla.
  Infix "v∷" := cons.
  Notation "v[ x , .. , y ]" := (cons x .. (cons y nil) ..).

  Definition vlmap {A B} (f:A -> B) : list A -> list B :=
    fix lmap xs :=
      match xs with
      | nil => nil
      | x v∷ xs => f x v∷ lmap xs
      end.

  Inductive vlist_eqv {A} `{! Eqv A } : relation (list A) :=
    | NullListEqv : vlist_eqv nil nil
    | ConsListEqv : forall x y xs ys, x ≃ y -> vlist_eqv xs ys -> vlist_eqv (x v∷ xs) (y v∷ ys).
  Inductive vlist_lte {A} `{! Eqv A ,! Lte A } : relation (list A) :=
    | NullListLte : forall xs, vlist_lte nil xs
    | ConsListLte : forall x y xs ys, x ⊑ y -> vlist_lte xs ys -> vlist_lte (x v∷ xs) (y v∷ ys).
  Global Instance : forall A `{! Eqv A }, Eqv (list A) := { eqv := vlist_eqv }.
  Admitted.
  Global Instance : forall A `{! Eqv A ,! Lte A }, Lte (list A) := { lte := vlist_lte }.
  Admitted.
End Vanilla.

Definition vlist := Coq.Init.Datatypes.list.
Definition vnil {A} : vlist A := Coq.Init.Datatypes.nil.
Definition vcons := Coq.Init.Datatypes.cons.

Definition list (A:qtype) : qtype := {| qdom := vlist (dom A) |}.
Definition nil {A} : dom (list A).
Admitted.
Definition cons {A} : dom (A ⇒ list A ⇒ list A).
Admitted.
Definition list_elim {A B} : dom (list A ⇒ B ⇒ (A ⇒ B ⇒ B) ⇒ B).
Admitted.
Definition linsert {A B} : dom (A ⇒ B ⇒ list (A × B) ⇒ list (A × B)).
Admitted.
Definition llookup {A B} `{! DecEqv (dom A) } : dom (A ⇒ list (A × B) ⇒ qoption B).
Admitted.
Definition zip {A B} : dom (list A ⇒ list B ⇒ list (A × B)).
Admitted.
Definition unzip {A B} : dom (list (A × B) ⇒ list A × list B).
Admitted.
Definition lmap {A B} : dom ((A ⇒ B) ⇒ list A ⇒ list B) :=
  λ (f:dom (A ⇒ B)) (x:dom (list A)) → vlmap (rfun f) x : dom (list B).

Notation "x ∷ xs" := (cons ∙ x ∙ xs).

Instance : Traversable list.
Admitted.