(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  If a relation R is L_computable then it is MMA_computable.

  Idea: simulate wCBV abstract machine by MMA, and inspect resulting closure.
*)

From Undecidability Require Import
  MinskyMachines.MM MinskyMachines.MMA L.L.
From Undecidability Require
  MinskyMachines.MMA.mma_defs L.Util.L_facts.
From Undecidability.Shared.Libs.DLW
  Require Import Vec.pos Vec.vec Code.sss Code.subcode.

From Undecidability Require Import
  MinskyMachines.Util.MMA_pairing L.AbstractMachines.wCBV.

Require Import PeanoNat List Lia Wf_nat.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

#[local] Unset Implicit Arguments.
#[local] Arguments ltof /.

(* local facts *)
Module Facts.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

Lemma firstn_repeat {X : Type} n {x : X} m : firstn n (repeat x m) = repeat x (Nat.min n m).
Proof.
  elim: n m => [|n IH]. { done. }
  move=> [|m]; [done|].
  by rewrite /= IH.
Qed.

Lemma Forall2_firstn {X Y : Type} {P : X -> Y -> Prop} {l1 l2 n} :
  Forall2 P l1 l2 -> Forall2 P (firstn n l1) (firstn n l2).
Proof.
  move=> H.  elim: H n. { by case=> [|?]; constructor. }
  move=> > ??? [|?]; by constructor.
Qed.

Lemma Forall2_repeat {X Y : Type} {P : X -> Y -> Prop} {l y n} :
  length l = n -> Forall (fun x => P x y) l -> Forall2 P l (repeat y n).
Proof.
  move=> + H. elim: H n.
  - by move=> [|n] ?; [constructor|].
  - move=> > ?? IH [|n]; [done|].
    move=> [/IH] ?. by constructor.
Qed.

Lemma list_sum_repeat n m : list_sum (repeat n m) = m * n.
Proof.
  elim: m. { done. }
  by move=> ? /= ->.
Qed.

Lemma R_inj n m (X Y : Fin.t m) : Fin.R n X = Fin.R n Y -> X = Y.
Proof.
  elim: n. { done. }
  by move=> n IH /= /pos_nxt_inj /IH.
Qed.

Lemma Fin_L_R_neq n m (p : Fin.t n) (q : Fin.t m) :
  Fin.L m p <> Fin.R n q.
Proof.
  elim: n p m q.
  - by apply: Fin.case0.
  - move=> n IH /= p. move: n p IH. apply: Fin.caseS; [done|].
    move=> > IH > /= /pos_nxt_inj. by apply: IH.
Qed.

Lemma vec_pos_append_R {T : Type} {n} {w : Vector.t T n} {m} {v : Vector.t T m} {X} :
  vec_pos (Vector.append w v) (Fin.R n X) = vec_pos v X.
Proof.
  by elim: w.
Qed.

Lemma vec_change_append_R {T : Type} {n} {w : Vector.t T n} {m} {v : Vector.t T m} {X} {x} :
  vec_change (Vector.append w v) (Fin.R n X) x = Vector.append w (vec_change v X x).
Proof.
  elim: w.
  - done.
  - by move=> > /= ->.
Qed.

Lemma vec_pos_append_L {T : Type} {n} {w : Vector.t T n} {m} {v : Vector.t T m} {X} :
  vec_pos (Vector.append w v) (Fin.L m X) = vec_pos w X.
Proof.
  elim: X w.
  - move=> ? w. by rewrite (Vector.eta w).
  - move=> > IH /= w. by rewrite (Vector.eta w) /=.
Qed.

Lemma vec_change_append_L {T : Type} {n} {w : Vector.t T n} {m} {v : Vector.t T m} {X} {x} :
  vec_change (Vector.append w v) (Fin.L m X) x = Vector.append (vec_change w X x) v.
Proof.
  elim: X w.
  - move=> ? w. by rewrite (Vector.eta w).
  - move=> > IH /= w. by rewrite (Vector.eta w) /= IH.
Qed.

Lemma vec_pos_cons {T : Type} {n} {w : Vector.t T n} x X :
  vec_pos (x ## w) (Fin.FS X) = vec_pos w X.
Proof. done. Qed.

Lemma vec_pos_hd {T : Type} {n} {w : Vector.t T n} x :
  vec_pos (x ## w) (Fin.F1) = x.
Proof. done. Qed.

Lemma vec_change_cons {T : Type} {n} {w : Vector.t T n} x X y :
  vec_change (x ## w) (Fin.FS X) y = x ## vec_change w X y.
Proof. done. Qed.

Lemma vec_change_hd {T : Type} {n} {w : Vector.t T n} x y :
  vec_change (x ## w) (Fin.F1) y = y ## w.
Proof. done. Qed.

Definition vec_simpl :=
  (@vec_pos_append_L, @vec_pos_append_R, @vec_change_append_L, @vec_change_append_R, @vec_pos_cons, @vec_pos_hd, @vec_change_cons, @vec_change_hd).

End Facts.

Import Facts.
Import L (term, var, app, lam).

Lemma closed_many_app_nat_enc {s} ns : L_facts.closed s ->
  L_facts.closed (fold_left (fun s n => app s (nat_enc n)) ns s).
Proof.
  elim: ns s. { done. }
  move=> n ns IH s ? /=. apply: IH.
  by apply: L_facts.app_closed; [|apply: L_facts.closed_nat_enc].
Qed.

Lemma sss_terminates_mma_f_ind {T : Type} {n : nat} (f : T -> (mm_state n)) (P : nat * list (mm_instr (pos n))) (R : T -> Prop) :
  (forall t, out_code (fst (f t)) P -> R t) ->
  (forall t1, (forall t2, sss_progress (mma_sss (n:=n)) P (f t1) (f t2) -> R t2) -> R t1) ->
  forall t, sss_terminates (mma_sss (n:=n)) P (f t) -> R t.
Proof.
  move=> H1 H2 t. move Et: (f t) => st Hst.
  pose R' := fun st' => forall t', f t' = st' -> R t'.
  suff: R' st by apply.
  move: Hst. apply: sss_terminates_ind.
  - by apply: mma_defs.mma_sss_fun.
  - move=> st' Hst' t' Ht'. apply: H1. by rewrite Ht'.
  - move=> st1' Hst1' t1' Ht1'. apply: H2.
    move=> t2'. rewrite Ht1' => /Hst1'.
    by apply; [apply: subcode_refl|].
Qed.

Module Argument.
Section Construction.
(* relation *)
Context {k0: nat} {R: Vector.t nat k0 -> nat -> Prop}.
(* term which computes the relation *)
Context {s0 : term} {Hs0 : L_facts.closed s0}.
(* s0 computes R *)
Context {Hs0R : forall (v : Vector.t nat k0) m, R v m <-> eval (Vector.fold_left (fun s n => app s (nat_enc n)) s0 v) (nat_enc m)}.
(* s0 computes numerals *)
Context {H's0R : forall (v : Vector.t nat k0) o, eval (Vector.fold_left (fun s n => app s (nat_enc n)) s0 v) o -> exists m, o = nat_enc m}.

#[local] Notation num_counters := ((1+k0)+6).
#[local] Notation counter := (pos num_counters).
#[local] Notation mm_instr := (mm_instr counter).

#[local] Notation "P // s ->> t" := (sss_compute (@mma_sss num_counters) P s t).
#[local] Notation "P // s -+> t" := (sss_progress (@mma_sss num_counters) P s t).
#[local] Notation "e #> x" := (vec_pos e x).
#[local] Notation "e [ v / x ]" := (vec_change e x v).

#[local] Arguments vec_change_neq {X n v p q x}.
#[local] Arguments vec_change_eq {X n v p q x}.
#[local] Arguments vec_change_comm {X n v p q x y}.
#[local] Arguments Nat.pow : simpl never.
#[local] Arguments flatten : simpl never.

(* auxiliary counters *)
#[local] Notation A := (Fin.R (1+k0) (Fin.F1) : counter).
#[local] Notation B := (Fin.R (1+k0) (Fin.FS (Fin.F1)) : counter).
#[local] Notation C := (Fin.R (1+k0) (Fin.FS (Fin.FS (Fin.F1))) : counter).
(* data counters *)
#[local] Notation TS := (Fin.R (1+k0) (Fin.FS (Fin.FS (Fin.FS (Fin.F1)))) : counter).
#[local] Notation CTX := (Fin.R (1+k0) (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.F1))))) : counter).
#[local] Notation U := (Fin.R (1+k0) (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.FS (Fin.F1)))))) : counter).

Lemma sss_terminates_sss_compute_inv P x y :
  P // x ->> y ->
  sss_terminates (mma_sss (n:=num_counters)) P x ->
  sss_terminates (mma_sss (n:=num_counters)) P y.
Proof.
  move=> ? [st] [Hx ?]. exists st. split; [|done].
  apply: sss_compute_inv; [|eassumption..].
  by apply: mma_defs.mma_sss_fun.
Qed.

#[local] Arguments plus : simpl never.

Definition enc_pair (m n: nat) := (n+n+1)*(2^m).

Fixpoint enc_term (s: term) : nat :=
  match s with
  | var n => enc_pair 0 n
  | lam s => enc_pair 1 (enc_term s)
  | app s t => enc_pair (2 + enc_term t) (enc_term s)
  end.

Definition enc_bool (b: bool) : nat :=
  if b then 1 else 0.

Fixpoint enc_list (ns : list nat) : nat :=
  match ns with
  | [] => 0
  | n::ns => enc_pair n (enc_list ns)
  end.

Fixpoint enc_closure (u: eterm) :=
  match u with
  | closure ctx s => enc_pair (enc_list (map enc_closure ctx)) (enc_term s)
  end.

Definition enc_cs ctx := enc_list (map enc_closure ctx).
Arguments enc_cs !ctx /.

Definition enc_future (u: bool * eterm) :=
  match u with
  | (b, x) => enc_pair (enc_bool b) (enc_closure x)
  end.

Definition enc_vs vs := enc_list (map enc_future vs).
Arguments enc_vs !vs /.

#[local] Opaque PACK PACK_len UNPACK UNPACK_len.

(*
machine_var_0 x xs vs y :
  machine x vs y ->
  machine (closure (x :: xs) (var 0)) vs y
*)
Definition CASE_VAR0_codes (p: nat) (offset : nat) : list (nat -> list mm_instr) :=
  UNPACK A CTX U ::
  ZERO CTX ::
  JMP A p :: [].

Definition CASE_VAR0 p offset := compose (CASE_VAR0_codes p offset) offset.

Definition CASE_VAR0_len := UNPACK_len+ZERO_len+JMP_len.

#[local] Hint Extern 0 (Fin.R _ _ <> Fin.R _ _) => by move=> /R_inj : core.
#[local] Hint Extern 0 (vec_pos (Vector.append _ _) (Fin.R _ _) = _) => by rewrite vec_pos_append_R : core.

Lemma CASE_VAR0_spec vs x ctx p w offset :
  (offset, CASE_VAR0 p offset) // (offset, Vector.append w (0##0##0##enc_vs vs##enc_cs (x :: ctx)##0##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs vs##0##(enc_closure x)##vec_nil)).
Proof.
  rewrite [enc_cs _]/=.
  apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
  apply: (compose_sss_compute_trans 1). { by apply: ZERO_spec. }
  apply: (compose_sss_compute_trans 2). { by apply: JMP_spec. }
  rewrite !vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_var_S x xs n vs y :
  machine (closure xs (var n)) vs y ->
  machine (closure (x :: xs) (var (S n))) vs y
*)
Definition CASE_VARS_codes (p: nat) (offset : nat) : list (nat -> list mm_instr) :=
  UNPACK A CTX B ::
  ZERO B ::
  PACK A U B ::
  PACK A U CTX ::
  JMP A p :: [].

Definition CASE_VARS p offset := compose (CASE_VARS_codes p offset) offset.

Definition CASE_VARS_len := UNPACK_len+ZERO_len+PACK_len+PACK_len+JMP_len.

Lemma CASE_VARS_spec vs u ctx n p w offset :
  (offset, CASE_VARS p offset) // (offset, Vector.append w (0##0##0##enc_vs vs##enc_cs (u :: ctx)##n##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs vs##0##(enc_closure (closure ctx (var n)))##vec_nil)).
Proof.
  rewrite [enc_cs _]/=.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: JMP_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_app xs s t vs y :
  machine (closure xs s) ((true, (closure xs t)) :: vs) y ->
  machine (closure xs (app s t)) vs y
*)
Definition CASE_APP_codes (p: nat) (offset : nat) : list (nat -> list mm_instr) :=
  ZERO A ::
  ZERO C ::
  MOVE CTX A ::
  MOVE2 A CTX C ::
  PACK A U CTX ::
  PACK A B C ::
  INC C ::
  PACK A B C ::
  PACK A TS B ::
  JMP A p :: [].

Definition CASE_APP p offset := compose (CASE_APP_codes p offset) offset.

Definition CASE_APP_len := ZERO_len+ZERO_len+MOVE_len+MOVE2_len+PACK_len+PACK_len+INC_len+PACK_len+PACK_len+JMP_len.

#[local] Arguments enc_future : simpl never.

Lemma CASE_APP_spec vs ctx s t p w offset :
  (offset, CASE_APP p offset) // (offset, Vector.append w (0##enc_term t##0##enc_vs vs##enc_cs ctx##enc_term s##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs ((true, closure ctx t) :: vs)##0##enc_closure (closure ctx s)##vec_nil)).
Proof.
  rewrite [enc_vs (_ :: _)]/=.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: MOVE_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: MOVE2_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 9). { by apply: JMP_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_lam_swap xs s z vs y :
  machine z ((false, (closure xs s)) :: vs) y ->
  machine (closure xs (lam s)) ((true, z) :: vs) y
*)
Definition CASE_LAM_SWAP_codes (p: nat) (offset : nat) : list (nat -> list mm_instr) :=
  PACK A U CTX ::
  PACK A U CTX ::
  PACK A TS U ::
  MOVE B U ::
  ZERO C ::
  JMP A p :: [].

Definition CASE_LAM_SWAP p offset := compose (CASE_LAM_SWAP_codes p offset) offset.

Definition CASE_LAM_SWAP_len := PACK_len+PACK_len+PACK_len+MOVE_len+ZERO_len+JMP_len.

Lemma CASE_LAM_SWAP_spec n s vs ctx p w offset :
  (offset, CASE_LAM_SWAP p offset) // (offset, Vector.append w (0##n##0##enc_vs vs##enc_cs ctx##enc_term s##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs ((false, closure ctx s) :: vs)##0##n##vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: MOVE_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: JMP_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_lam_subst xss xts s t vs y :
  machine (closure ((closure xts (lam t)) :: xss) s) vs y ->
  machine (closure xts (lam t)) ((false, (closure xss s)) :: vs) y
*)
Definition CASE_LAM_SUBST_codes (p: nat) (offset : nat) : list (nat -> list mm_instr) :=
  ZERO C ::
  INC C ::
  PACK A U C ::
  PACK A U CTX ::
  UNPACK A B CTX ::
  PACK A CTX U ::
  PACK A B CTX ::
  MOVE B U ::
  JMP A p :: [].

Definition CASE_LAM_SUBST p offset := compose (CASE_LAM_SUBST_codes p offset) offset.

Definition CASE_LAM_SUBST_len := ZERO_len+INC_len+PACK_len+PACK_len+UNPACK_len+PACK_len+PACK_len+MOVE_len+JMP_len.

Lemma CASE_LAM_SUBST_spec n vs s t xts xss p w offset :
  (offset, CASE_LAM_SUBST p offset) // (offset, Vector.append w (0##enc_closure (closure xss s)##n##enc_vs vs##enc_cs xts##enc_term t##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs vs##0##enc_closure (closure ((closure xts (lam t)) :: xss) s)##vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: MOVE_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: JMP_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

Definition CASE_LAM_codes (p q: nat) (offset : nat) : list (nat -> list mm_instr) :=
  JZ TS ((JZ_len+UNPACK_len+UNPACK_len+DEC_len+CASE_LAM_SUBST_len+CASE_LAM_SWAP_len)+offset) ::
  UNPACK A TS B ::
  UNPACK A B C ::
  DEC C ((JZ_len+UNPACK_len+UNPACK_len+DEC_len+CASE_LAM_SUBST_len) + offset) ::
  CASE_LAM_SUBST p ::
  CASE_LAM_SWAP p ::
  INC TS ::
  PACK A U TS ::
  JMP A q :: [].

Definition CASE_LAM p q offset := compose (CASE_LAM_codes p q offset) offset.

Definition CASE_LAM_len := JZ_len+UNPACK_len+UNPACK_len+DEC_len+CASE_LAM_SUBST_len+CASE_LAM_SWAP_len+INC_len+PACK_len+JMP_len.

Lemma CASE_LAM_nil_spec p q w offset n s :
  (offset, CASE_LAM p q offset) // (offset, Vector.append w (0##0##0##0##n##enc_term s##vec_nil)) ->>
    (q, Vector.append w (0##0##0##0##n##enc_term (lam s)##vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: JMP_spec. }
  by apply: sss_compute_refl.
Qed.

Lemma enc_pair_match {T : Type} {P Q : T} n m :
  match enc_pair n m with
  | 0 => P
  | S _ => Q
  end = Q.
Proof.
  have ? := Nat.pow_nonzero 2 n.
  suff: enc_pair n m = S (enc_pair n m - 1) by move=> ->.
  rewrite /enc_pair. nia.
Qed.

Lemma CASE_LAM_SUBST'_spec p q w s xss t xts vs offset :
  (offset, CASE_LAM p q offset) // (offset, Vector.append w (0##0##0##enc_vs ((false, (closure xss s)) :: vs)##enc_cs xts##enc_term t##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs vs##0##enc_closure (closure ((closure xts (lam t)) :: xss) s)##vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
  rewrite ?vec_simpl enc_pair_match. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: CASE_LAM_SUBST_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

Lemma CASE_LAM_SWAP'_spec p q w s xs z vs offset :
  (offset, CASE_LAM p q offset) // (offset, Vector.append w (0##0##0##enc_vs ((true, z) :: vs)##enc_cs xs##enc_term s##vec_nil)) ->>
    (p, Vector.append w (0##0##0##enc_vs ((false, closure xs s) :: vs)##0##enc_closure z##vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
  rewrite ?vec_simpl enc_pair_match. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { rewrite ?vec_simpl. by apply: CASE_LAM_SWAP_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(* compute natural number k for a (closure of a) Scott-encoded numeral k *)
Inductive decode_nat : list eterm -> term -> nat -> Prop :=
  | decode_nat_var n :
      decode_nat [] (var n) 0
  | decode_nat_var0 k xs' s' xs :
      decode_nat xs' s' k ->
      decode_nat ((closure xs' s') :: xs) (var 0) k
  | decode_nat_varS k n x xs :
      decode_nat xs (var n) k ->
      decode_nat (x :: xs) (var (S n)) k
  | decode_nat_lam k s xs :
      decode_nat ((closure [] (var 0)) :: xs) s k ->
      decode_nat xs (lam s) k
  | decode_nat_app xs s t k :
      decode_nat xs t k ->
      decode_nat xs (app s t) (S k).

Definition DECODE_NAT_codes (offset : nat) : list (nat -> list mm_instr) :=
  let delta_var := JZ_len+DEC_len+UNPACK_len+UNPACK_len+JMP_len+UNPACK_len+ZERO_len+PACK_len+JMP_len in
  let delta_lam := PACK_len+PACK_len+PACK_len+JMP_len in
  let delta_app := INC_len+ZERO_len+MOVE_len+JMP_len in
  UNPACK A U B ::
  DEC B ((UNPACK_len+DEC_len+delta_var) + offset) ::
  (* var _ CASE *) JZ CTX ((UNPACK_len+DEC_len+delta_var+DEC_len+delta_lam+delta_app)+offset) :: (* termination condition: (closure [] (var n)) *)
  DEC U ((UNPACK_len+DEC_len+JZ_len+DEC_len+UNPACK_len+UNPACK_len+JMP_len)+offset) ::
  (* var 0 CASE *) UNPACK A CTX U ::
  UNPACK A U CTX ::
  JMP A offset ::
  (* var (S n) CASE *) UNPACK A CTX B ::
  ZERO B ::
  PACK A U B ::
  JMP A offset ::
  DEC B ((UNPACK_len+DEC_len+delta_var+DEC_len+delta_lam)+offset) ::
  (* lam s CASE *) PACK A B C ::
  PACK A B C ::
  PACK A CTX B ::
  JMP A offset ::
  (* app s t CASE *) INC TS ::
  ZERO U ::
  MOVE B U ::
  JMP A offset ::
  ZERO CTX ::
  ZERO U :: [].

Definition DECODE_NAT offset := compose (DECODE_NAT_codes offset) offset.

Definition DECODE_NAT_len :=
  let delta_var := JZ_len+DEC_len+UNPACK_len+UNPACK_len+JMP_len+UNPACK_len+ZERO_len+PACK_len+JMP_len in
  let delta_lam := PACK_len+PACK_len+PACK_len+JMP_len in
  let delta_app := INC_len+ZERO_len+MOVE_len+JMP_len in
  UNPACK_len+DEC_len+delta_var+DEC_len+delta_lam+delta_app+ZERO_len+ZERO_len.

(* app depth to the right *)
Fixpoint app_depth_r (s : term) : nat :=
  match s with
  | var _ => 0
  | app _ t => S (app_depth_r t)
  | lam s => app_depth_r s
  end.

Lemma app_depth_r_subst_many_repeat n s ts :
  app_depth_r (subst_many s n ts) = app_depth_r (subst_many s 0 ((repeat (var 0) n) ++ ts)).
Proof.
  elim: s n ts.
  - move=> x n ts /=.
    have [?|?] : x < n \/ n <= x by lia.
    + rewrite app_nth1. { by rewrite map_length seq_length. }
      rewrite app_nth1. { by rewrite repeat_length. }
      rewrite map_nth (@nth_indep _ _ x (var x) (var 0)). { by rewrite repeat_length. }
      by rewrite nth_repeat seq_nth.
    + rewrite app_nth2 map_length seq_length. { done. }
      by rewrite app_nth2 repeat_length.
  - by move=> ? _ ? + ?? /= => ->.
  - move=> s IH n ts /=.
    by rewrite [LHS]IH [RHS]IH app_assoc -repeat_app.
Qed.

Lemma app_depth_r_var_S x xs n :
  app_depth_r (flatten (closure (x :: xs) (var (S n)))) = app_depth_r (flatten (closure xs (var n))).
Proof.
  rewrite !flatten_var /=.
  have [Hn|Hn] : n < length (map flatten xs) \/ length (map flatten xs) <= n by lia.
  - by rewrite (nth_indep _ (var (S n)) (var n) Hn).
  - by rewrite !(nth_overflow _ _ Hn).
Qed.

Lemma app_depth_r_lam xs s :
  app_depth_r (flatten (closure xs (lam s))) = app_depth_r (flatten (closure (closure [] (var 0) :: xs) s)).
Proof.
  by rewrite /= app_depth_r_subst_many_repeat.
Qed.

Lemma decode_nat_app_depth_r xs s : decode_nat xs s (app_depth_r (flatten (closure xs s))).
Proof.
  move E: (closure xs s) => y.
  elim /(induction_ltof1 _ eterm_size) : y xs s E.
  rewrite /ltof. move=> [xs [n|s t|s]] IH ?? [-> ->].
  - move: xs IH => [|x xs].
    + move=> ?. rewrite flatten_term. by apply: decode_nat_var.
    + move: n => [|n].
      * move: x => [xs' x'] IH. apply: decode_nat_var0.
        rewrite flatten_var. apply: IH; [|done].
        rewrite /=. lia.
      * move=> IH. apply: decode_nat_varS.
        rewrite app_depth_r_var_S.
        apply: IH; [|done]. rewrite /=. lia.
  - rewrite flatten_app /=. apply: decode_nat_app. apply: IH; [|done].
    rewrite /=. lia.
  - apply: decode_nat_lam. rewrite app_depth_r_lam.
    apply: IH; [|done]. rewrite /=. lia.
Qed.

Lemma decode_nat_nat_enc xs s n : flatten (closure xs s) = L.nat_enc n -> decode_nat xs s n.
Proof.
  intros Hn. have := decode_nat_app_depth_r xs s.
  congr decode_nat. rewrite Hn.
  clear Hn. by elim: n => *; [|congr S].
Qed.

Lemma DECODE_NAT_spec offset n xs s k w :
  flatten (closure xs s) = L.nat_enc n ->
  (offset, DECODE_NAT offset) // (offset, Vector.append w (0 ## 0 ## 0 ## k ## enc_cs xs ## enc_term s ## vec_nil)) ->>
    (DECODE_NAT_len+offset, Vector.append w (0 ## 0 ## 0 ## k+n ## 0 ## 0 ## vec_nil)).
Proof.
  rewrite /DECODE_NAT. move=> /decode_nat_nat_enc H. elim: H k.
  - move=> >.
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: JZ_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 20). { by apply: ZERO_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 21). { by apply: ZERO_spec. }
    rewrite ?vec_simpl Nat.add_0_r. by apply: sss_compute_refl.
  - move=> > _ IH ?.
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: JZ_spec. }
    rewrite ?vec_simpl enc_pair_match. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: JMP_spec. }
    by apply: IH.
  - move=> > _ IH ?.
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: JZ_spec. }
    rewrite ?vec_simpl enc_pair_match. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: ZERO_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 9). { by apply: PACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 10). { by apply: JMP_spec. }
    by apply: IH.
  - move=> > _ IH ?.
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 11). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 12). { by apply: PACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 13). { by apply: PACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 14). { by apply: PACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 15). { by apply: JMP_spec. }
    by apply: IH.
  - move=> > _ IH k.
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: UNPACK_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 11). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 16). { by apply: INC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 17). { by apply: ZERO_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 18). { by apply: MOVE_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 19). { by apply: JMP_spec. }
    rewrite -/enc_term -(Nat.add_succ_comm k). by apply: IH.
Qed.

(* main simulation routine; by case analysis on current term *)
(* U stores the current closure, TS stores the futures *)
(* on success decode resulting Scott numeral into pos0 *)
Definition PROG_codes (offset : nat) : list (nat -> list mm_instr) :=
  ZERO A ::
  UNPACK A U CTX ::
  UNPACK A U B ::
  DEC B ((ZERO_len+UNPACK_len+UNPACK_len+DEC_len+DEC_len+CASE_VAR0_len+CASE_VARS_len)+offset) ::
  (* var _ CASE *) DEC U ((ZERO_len+UNPACK_len+UNPACK_len+DEC_len+DEC_len+CASE_VAR0_len)+offset) ::
  (* var 0 CASE *) CASE_VAR0 offset ::
  (* var (S n) CASE *) CASE_VARS offset ::
  DEC B ((ZERO_len+UNPACK_len+UNPACK_len+DEC_len+DEC_len+CASE_VAR0_len+CASE_VARS_len+DEC_len+CASE_LAM_len)+offset) ::
  (* lam s CASE *) CASE_LAM offset ((ZERO_len+UNPACK_len+UNPACK_len+DEC_len+DEC_len+CASE_VAR0_len+CASE_VARS_len+DEC_len+CASE_LAM_len+CASE_APP_len)+offset) ::
  (* app s t CASE *) CASE_APP offset ::
  DECODE_NAT ::
  ZERO Fin.F1 ::
  MOVE TS Fin.F1 :: [].

Definition PROG offset := compose (PROG_codes offset) offset.

Definition PROG_len := ZERO_len+UNPACK_len+UNPACK_len+DEC_len+DEC_len+CASE_VAR0_len+CASE_VARS_len+DEC_len+CASE_LAM_len+CASE_APP_len+DECODE_NAT_len+ZERO_len+MOVE_len.

Lemma PROG_len_spec offset : length (PROG offset) = PROG_len.
Proof. done. Qed.

#[local] Opaque PROG.

Lemma ZERO_spec' X v offset : (offset, ZERO X offset) // (offset, v) -+> (ZERO_len + offset, vec_change v X 0).
Proof.
  have [[|k]] := ZERO_spec X v offset.
  - move=> /sss_steps_0_inv /(f_equal fst) /=. rewrite /ZERO_len /DEC_len. lia.
  - move=> Hk. exists (S k). by split; [lia|].
Qed.

(*
machine_var_0 x xs vs y :
  machine x vs y ->
  machine (closure (x :: xs) (var 0)) vs y
*)
Lemma PROG_VAR0_spec offset vs x xs w :
  (offset, PROG offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure (closure (x :: xs) (var 0)) ## vec_nil)) -+>
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure x ## vec_nil)).
Proof.
  rewrite [enc_closure _]/=.
  rewrite ?vec_simpl. apply: (compose_sss_progress_trans 0). { by apply: ZERO_spec'. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: CASE_VAR0_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_var_S x xs n vs y :
  machine (closure xs (var n)) vs y ->
  machine (closure (x :: xs) (var (S n))) vs y
*)
Lemma PROG_VARS_spec offset vs x xs n w :
  (offset, PROG offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure (closure (x :: xs) (var (S n))) ## vec_nil)) -+>
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure (closure xs (var n)) ## vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_progress_trans 0). { by apply: ZERO_spec'. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: CASE_VARS_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_app xs s t vs y :
  machine (closure xs s) ((true, (closure xs t)) :: vs) y ->
  machine (closure xs (app s t)) vs y
*)
Lemma PROG_APP_spec offset vs xs s t w :
  (offset, PROG offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure (closure xs (app s t)) ## vec_nil)) -+>
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs ((true, (closure xs t)) :: vs) ## 0 ## enc_closure (closure xs s) ## vec_nil)).
Proof.
  rewrite [enc_vs (_ :: _)]/=.
  rewrite ?vec_simpl. apply: (compose_sss_progress_trans 0). { by apply: ZERO_spec'. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 9). { by apply: CASE_APP_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_lam_swap xs s z vs y :
  machine z ((false, (closure xs s)) :: vs) y ->
  machine (closure xs (lam s)) ((true, z) :: vs) y
*)
Lemma PROG_LAM_SWAP_spec offset vs xs s z w :
  (offset, PROG offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs ((true, z) :: vs) ## 0 ## enc_closure (closure xs (lam s)) ## vec_nil)) -+>
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs ((false, (closure xs s)) :: vs) ## 0 ## enc_closure z ## vec_nil)).
Proof.
  rewrite ![enc_vs (_ :: _)]/=.
  rewrite ?vec_simpl. apply: (compose_sss_progress_trans 0). { by apply: ZERO_spec'. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: CASE_LAM_SWAP'_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_lam_subst xss xts s t vs y :
  machine (closure ((closure xts (lam t)) :: xss) s) vs y ->
  machine (closure xts (lam t)) ((false, (closure xss s)) :: vs) y
*)
Lemma PROG_LAM_SUBST_spec offset vs xss xts s t w :
  (offset, PROG offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs ((false, (closure xss s)) :: vs) ## 0 ## enc_closure (closure xts (lam t)) ## vec_nil)) -+>
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure (closure ((closure xts (lam t)) :: xss) s) ## vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_progress_trans 0). { by apply: ZERO_spec'. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: CASE_LAM_SUBST'_spec. }
  rewrite ?vec_simpl. by apply: sss_compute_refl.
Qed.

(*
machine_lam xs s :
  machine (closure xs (lam s)) nil (closure xs (lam s)).
*)
Lemma PROG_LAM_spec offset xs s n w :
  flatten (closure xs (lam s)) = L.nat_enc n ->
  (offset, PROG offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs [] ## 0 ## enc_closure (closure xs (lam s)) ## vec_nil)) ->>
  (PROG_len+offset, vec_change (Vector.append w vec_zero) Fin.F1 n).
Proof.
  move=> Hn.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: CASE_LAM_nil_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 10). { apply: DECODE_NAT_spec. exact: Hn. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 11). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 12). { by apply: MOVE_spec. }
  apply: sss_compute_refl'. congr pair. by rewrite (Vector.eta w) /= ?vec_simpl.
Qed.

Lemma PROG_simulation offset x vs y n w : machine x vs y -> flatten y = L.nat_enc n ->
  (offset, PROG offset) //
    (offset, Vector.append w (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure x ## vec_nil)) ->>
    (PROG_len+offset, vec_change (Vector.append w vec_zero) Fin.F1 n).
Proof.
  elim=> > ?; [..|by apply: PROG_LAM_spec] => IH ?.
  all: apply: sss_compute_trans; [|by apply: IH].
  all: apply: sss_progress_compute.
  - by apply: PROG_VAR0_spec.
  - by apply: PROG_VARS_spec.
  - by apply: PROG_APP_spec.
  - by apply: PROG_LAM_SWAP_spec.
  - by apply: PROG_LAM_SUBST_spec.
Qed.

(*
  Scott-encoding of a given numeral n
  TS := n
  ~> U := encode_term (nat_enc n)
*)
Definition NAT_ENC_codes (p offset : nat) : list (nat -> list mm_instr) :=
  let loop := ZERO_len+ZERO_len+ZERO_len+INC_len+PACK_len+INC_len+PACK_len+INC_len+PACK_len in
  ZERO U ::
  ZERO B ::
  ZERO C ::
  INC U ::
  PACK A U B :: (* var 1 *)
  INC B ::
  PACK A U B :: (* lam (var 1) *)
  INC B ::
  PACK A U B :: (* lam (lam (var 1)) *)
  DEC TS ((loop+DEC_len+JMP_len)+offset) ::
  JMP A p ::
  ZERO B ::
  PACK A B C :: (* var 0 *)
  INC U ::
  INC U ::
  PACK A B U :: (* app (var 0) s *)
  MOVE B U ::
  INC B ::
  PACK A U B :: (* lam (app (var 0) s) *)
  INC B ::
  PACK A U B :: (* lam (lam (app (var 0) s)) *)
  JMP A (loop+offset) :: [].

Definition NAT_ENC_len :=
  let loop := ZERO_len+ZERO_len+ZERO_len+INC_len+PACK_len+INC_len+PACK_len+INC_len+PACK_len in
  loop+DEC_len+JMP_len+ZERO_len+PACK_len+INC_len+INC_len+PACK_len+MOVE_len+INC_len+PACK_len+INC_len+PACK_len+JMP_len.

Definition NAT_ENC p offset := compose (NAT_ENC_codes p offset) offset.

Lemma NAT_ENC_spec offset p n c w :
  (offset, NAT_ENC p offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## n ## c ## 0 ## vec_nil)) ->>
  (p, Vector.append w (0 ## 0 ## 0 ## 0 ## c ## enc_term (L.nat_enc n) ## vec_nil)).
Proof.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 1). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: PACK_spec. }
  rewrite ?vec_simpl.
  suff : forall m, (offset, compose (NAT_ENC_codes p offset) offset) //
    ((ZERO_len+ZERO_len+ZERO_len+INC_len+PACK_len+INC_len+PACK_len+INC_len+PACK_len) + offset,
        Vector.append w (0 ## 0 ## 0 ## n ## c ## enc_term (L.nat_enc m) ## vec_nil)) ->>
    (p, Vector.append w (0 ## 0 ## 0 ## 0 ## c ## enc_term (L.nat_enc (m+n)) ## vec_nil)).
  { move=> /(_ 0). by apply. }
  elim: n.
  { move=> m.
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 9). { by apply: DEC_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 10). { by apply: JMP_spec. }
    rewrite Nat.add_0_r. by apply: sss_compute_refl. }
  move=> n IH m.
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 9). { by apply: DEC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 11). { by apply: ZERO_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 12). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 13). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 14). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 15). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 16). { by apply: MOVE_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 17). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 18). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 19). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 20). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 21). { by apply: JMP_spec. }
  rewrite -(Nat.add_succ_comm m n). by apply: (IH (S m)).
Qed.

(*
  Initialization routine:
  U := s, CTX := [n1; ..; nm]
  ~> U = closure ([], s (nat_enc n1) .. (nat_enc nm))
*)
Definition INIT_codes offset : list (nat -> list mm_instr) :=
  JZ CTX ((JZ_len+UNPACK_len+PACK_len+NAT_ENC_len+INC_len+INC_len+UNPACK_len+PACK_len+MOVE_len+JMP_len)+offset) ::
  UNPACK A CTX TS ::
  PACK A CTX U ::
  NAT_ENC ((JZ_len+UNPACK_len+PACK_len+NAT_ENC_len)+offset) ::
  INC U ::
  INC U ::
  UNPACK A CTX B ::
  PACK A B U :: (* app s [n] *)
  MOVE B U ::
  JMP A offset ::
  PACK A U B :: [].

Definition INIT_len := JZ_len+UNPACK_len+PACK_len+NAT_ENC_len+INC_len+INC_len+UNPACK_len+PACK_len+MOVE_len+JMP_len+PACK_len.

Definition INIT offset := compose (INIT_codes offset) offset.

Lemma INIT_spec offset ns s w :
  (offset, INIT offset) //
  (offset, Vector.append w (0 ## 0 ## 0 ## 0 ## enc_list ns ## enc_term s ## vec_nil)) ->>
  (INIT_len+offset, Vector.append w (0 ## 0 ## 0 ## 0 ## 0 ## enc_closure (closure [] (fold_left (fun s n => app s (L.nat_enc n)) ns s)) ## vec_nil)).
Proof.
  elim: ns s => [s|n ns IH s].
  { rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
    rewrite ?vec_simpl. apply: (compose_sss_compute_trans 10). { by apply: PACK_spec. }
    rewrite ?vec_simpl. by apply: sss_compute_refl. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 0). { by apply: JZ_spec. }
  rewrite ?vec_simpl enc_pair_match. apply: (compose_sss_compute_trans 1). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 2). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 3). { by apply: NAT_ENC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 4). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 5). { by apply: INC_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 6). { by apply: UNPACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 7). { by apply: PACK_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 8). { by apply: MOVE_spec. }
  rewrite ?vec_simpl. apply: (compose_sss_compute_trans 9). { by apply: JMP_spec. }
  rewrite ?vec_simpl. by apply: (IH (app s (L.nat_enc n))).
Qed.

(*
  Initialization routine:
  ~> TS := [n1 .. nm]
*)
Definition INIT_INPUT_codes (offset : nat) : list (nat -> list mm_instr) :=
  map (PACK Fin.F1 CTX) (map (Fin.L 6) (map Fin.FS (rev (pos_list k0)))).

Definition INIT_INPUT_len := k0*PACK_len.

Definition INIT_INPUT offset := compose (INIT_INPUT_codes offset) offset.

Lemma INIT_INPUT_len_spec {offset} : length (INIT_INPUT offset) = INIT_INPUT_len.
Proof.
  rewrite /INIT_INPUT /INIT_INPUT_codes (length_compose (lengths := repeat PACK_len k0)).
  - apply: Forall2_repeat.
    + by rewrite !map_length rev_length pos_list_length.
    + apply /Forall_map /Forall_map /Forall_map /Forall_forall => *.
      by apply: PACK_len_spec.
  - by rewrite list_sum_repeat.
Qed.

Lemma fold_left_vec_zero_eq {n : nat} {w : Vector.t nat n} ps :
  (forall i, not (In i ps) -> vec_pos w i = 0) ->
  fold_left (fun v i => vec_change v i 0) ps w = vec_zero.
Proof.
  elim: ps w.
  - move=> w Hw /=. apply: vec_pos_ext => ?.
    by rewrite vec_zero_spec Hw.
  - move=> i ps IH w Hips /=. apply: IH => j Hjps.
    have [->|?] := pos_eq_dec i j.
    + by rewrite vec_change_eq.
    + rewrite vec_change_neq //. apply: Hips. by case.
Qed.

Lemma INIT_INPUT_spec offset w v :
  vec_pos (Vector.append (0 ## w) v) CTX = 0 ->
  (offset, INIT_INPUT offset) //
  (offset, Vector.append (0 ## w) v) ->>
  (INIT_INPUT_len+offset, vec_change (Vector.append vec_zero v) CTX (enc_list (Vector.to_list w))).
Proof.
  suff: forall (ps : list (Fin.t k0)) offset ns (w : vec nat k0) v,
    vec_pos v pos4 = enc_list ns ->
    NoDup ps ->
    (offset, compose (map (PACK Fin.F1 CTX) (map (Fin.L 6) (map Fin.FS ps))) offset) //
    (offset, Vector.append (0 ## w) v) ->>
    ((PACK_len * (length ps)) + offset,
      Vector.append (0 ## fold_left (fun w i => vec_change w i 0) ps w) (vec_change v pos4 (enc_list ((map (vec_pos w) (rev ps)) ++ ns)))).
  { move=> + /[dup] Hv. rewrite ?vec_simpl.
    move=> /(_ _ offset nil w v) /[apply]. move=> /(_ (rev (pos_list k0))).
    apply: unnest. { apply: NoDup_rev. by apply: pos_list_NoDup. }
    congr sss_compute. congr pair.
    - rewrite /INIT_INPUT_len rev_length pos_list_length. lia.
    - rewrite ?vec_simpl in Hv.
      congr Vector.append.
      + rewrite fold_left_vec_zero_eq //.
        move=> i H. exfalso. apply: H.
        by have /In_rev := pos_list_prop i.
      + rewrite rev_involutive app_nil_r. congr vec_change. congr enc_list.
        rewrite map_pos_list_vec. by elim: w; [|move=> > /= ->]. }
  elim.
  { move=> *. cbn. apply: sss_compute_refl'. by rewrite vec_change_same'. }
  move=> i ps IH {}offset ns {}w {}v Hv /NoDup_cons_iff [Hi /IH {}IH].
  apply: (compose_sss_compute_trans 0). { apply: PACK_spec; [done..|]. apply: nesym. by apply: Fin_L_R_neq. }
  rewrite /=. apply: subcode_sss_compute. { by apply: subcode_right. }
  have := (IH (PACK_len+offset) (vec_pos w i :: ns) (vec_change w i 0) (vec_change v pos4 (enc_list (vec_pos w i :: ns)))).
  apply: unnest. { by rewrite vec_change_eq. }
  rewrite PACK_len_spec /= ?vec_simpl Hv. congr sss_compute.
  - congr pair. lia.
  - congr pair; [lia|].
    congr Vector.cons. congr Vector.append.
    rewrite vec_change_idem /= map_app /= -app_assoc /=.
    congr vec_change. congr enc_list. congr List.app.
    apply /map_ext_in_iff => j Hj. apply: vec_change_neq => ?.
    apply: Hi. apply /In_rev. by subst j.
Qed.

Definition INIT_s0_codes (offset : nat) : list (nat -> list mm_instr) :=
  repeat (INC U) (enc_term s0).

Definition INIT_s0_len := enc_term s0.

Definition INIT_s0 offset := compose (INIT_s0_codes offset) offset.

Lemma INIT_s0_len_spec {offset} : length (INIT_s0 offset) = INIT_s0_len.
Proof.
  rewrite /INIT_s0 /INIT_s0_codes /INIT_s0_len.
  elim: (enc_term s0) offset. { done. }
  move=> n IH offset /=. by rewrite IH.
Qed.

#[local] Arguments repeat_spec {A n x y}.

Lemma INIT_s0_spec offset v :
  vec_pos v U = 0 ->
  (offset, INIT_s0 offset) //
  (offset, v) ->>
  (INIT_s0_len+offset, vec_change v U (enc_term s0)).
Proof.
  suff : forall j m offset v, j <= m ->
    v#>Fin.R (1 + k0) pos5 = m-j ->
    (offset, compose (repeat (INC U) m) offset) //
    ((m-j)+offset, v) ->>
    (m + offset, vec_change v U m).
  { move=> /(_ (enc_term s0) (enc_term s0)). rewrite Nat.sub_diag. by apply. }
  elim. { move=> m {}offset {}v _. rewrite !Nat.sub_0_r => ?. apply: sss_compute_refl'. by rewrite vec_change_same'. }
  move=> j IH m {}offset {}v ? Hv.
  have EmSj : m - S j = length (compose (firstn (m - S j) (repeat (INC U) m)) offset).
  { rewrite (length_compose (lengths := repeat INC_len (m - S j))).
  - apply: Forall2_repeat. { rewrite firstn_length repeat_length. lia. }
    rewrite firstn_repeat. by apply /Forall_forall => ? /repeat_spec ->.
  - by rewrite list_sum_repeat /INC_len Nat.mul_1_r. }
  rewrite EmSj. apply: (compose_sss_compute_trans).
  { rewrite (nth_indep _ _ (INC U)). { rewrite repeat_length. lia. }
    rewrite nth_repeat. apply: INC_spec. }
  rewrite -EmSj.
  have -> : 1 + (m - S j + offset) = (m - j) + offset by lia.
  rewrite Hv. apply: sss_compute_trans.
  { apply: IH; [lia|]. by rewrite vec_change_eq; [|lia]. }
  rewrite vec_change_idem. by apply: sss_compute_refl.
Qed.

(*
  Overall computation:
  1) TS := [n1; ..; nk0]
  2) U := s0
  3) U := s0 n1 .. nk0
  4) U := closure [] (s0 n1 .. nk0)
  5) compute
*)
Definition COMPUTE_codes (offset : nat) : list (nat -> list mm_instr) :=
  INIT_INPUT ::
  INIT_s0 ::
  INIT ::
  PROG :: [].

Definition COMPUTE offset := compose (COMPUTE_codes offset) offset.

Definition COMPUTE_lengths :=
  [INIT_INPUT_len; INIT_s0_len; INIT_len; PROG_len].

Definition COMPUTE_len := list_sum COMPUTE_lengths.

Lemma COMPUTE_lengths_spec offset :
  Forall2 (fun c l => forall j, length (c j) = l) (COMPUTE_codes offset) COMPUTE_lengths.
Proof.
  by do 4 (constructor; [auto using INIT_INPUT_len_spec, INIT_s0_len_spec|]).
Qed.

Lemma COMPUTE_len_spec offset : length (COMPUTE offset) = COMPUTE_len.
Proof.
  apply: length_compose. by apply: COMPUTE_lengths_spec.
Qed.

Lemma list_sum_append l ls offset :
  l + (list_sum ls + offset) = list_sum (ls ++ [l]) + offset.
Proof.
  rewrite list_sum_app /=. lia.
Qed.

Lemma simulation_init offset w :
  (offset, COMPUTE offset) //
    (offset, Vector.append (0 ## w) vec_zero) ->>
    ((list_sum (firstn 3 COMPUTE_lengths))+offset, Vector.append vec_zero
      (0 ## 0 ## 0 ## 0 ## 0 ## enc_closure (closure [] (fold_left (fun s n => app s (L.nat_enc n)) (Vector.to_list w) s0)) ## vec_nil)).
Proof.
  have compose_trans := (compose_sss_compute_length_trans _ (COMPUTE_lengths_spec offset)).
  rewrite ?vec_simpl. apply: (compose_trans 0). { by apply: INIT_INPUT_spec. }
  rewrite ?vec_simpl list_sum_append. apply: (compose_trans 1). { by apply: INIT_s0_spec. }
  rewrite ?vec_simpl list_sum_append. apply: (compose_trans 2). { by apply: INIT_spec. }
  rewrite ?vec_simpl list_sum_append. by apply: sss_compute_refl.
Qed.

(*
   s n1 .. nk0 evaluates to n
=> COMPUTE [n1 .. nm] [s] ~> n
*)
Lemma simulation offset y n w :
  machine (closure [] (fold_left (fun s n => app s (L.nat_enc n)) (Vector.to_list w) s0)) [] y ->
  flatten y = L.nat_enc n ->
  (offset, COMPUTE offset) // (offset, Vector.append (0 ## w) vec_zero) ->> (COMPUTE_len+offset, n ## vec_zero).
Proof.
  move=> /PROG_simulation /[apply] HPROG.
  have compose_trans := (compose_sss_compute_length_trans _ (COMPUTE_lengths_spec offset)).
  apply: sss_compute_trans. { by apply: simulation_init. }
  rewrite ?vec_simpl. apply: (compose_trans 3). { by apply: HPROG. }
  rewrite list_sum_append. apply: sss_compute_refl'. congr pair.
  rewrite (vec_zero_S k0) /=. congr Vector.cons.
  clear. by elim: (k0) => [|k IH]; [|rewrite /= IH].
Qed.

Lemma sss_terminates_PROG_machine offset vs x :
  sss_terminates (mma_sss (n:=num_counters)) (offset, PROG offset)
    (offset, Vector.append vec_zero
      (0 ## 0 ## 0 ## enc_vs vs ## 0 ## enc_closure x ## vec_nil)) ->
  eclosed x ->
  Forall eclosed_future vs ->
  exists y, machine x vs y.
Proof.
  have H' : forall (P Q : eterm -> Prop), (forall y, P y -> Q y) -> (exists y, P y) -> exists y, Q y.
  { firstorder done. }
  pose f := fun t => (offset, Vector.append vec_zero (0 ## 0 ## 0 ## enc_vs (fst t) ## 0 ## enc_closure (snd t) ## vec_nil)).
  pose P := fun t => eclosed (snd t) -> Forall eclosed_future (fst t) -> exists y, machine (snd t) (fst t) y.
  suff : forall vs_x,
    sss_terminates (mma_sss (n:=num_counters)) (offset, PROG offset) (f _ vs_x) ->
    P vs_x by move=> /(_ (vs, x)).
  apply: sss_terminates_mma_f_ind.
  { move=> [{}vs {}x]. have := PROG_len_spec offset. move: (PROG offset) => ? /= ->.
    rewrite /PROG_len /DEC_len. by lia. }
  subst P. move=> [{}vs [xs [{}x|s t|s]]] /= IH.
  - move: x xs IH => [|x] [|z xs] /= IH.
    + move=> [/boundE] /=. lia.
    + have := PROG_VAR0_spec offset vs z xs vec_zero.
      move=> /(IH (vs, z)) /= {}IH [_] [/IH] {}IH _ /IH.
      apply: H' => ?. by apply: machine_var_0.
    + move=> [/boundE]. lia.
    + have := PROG_VARS_spec offset vs z xs x vec_zero.
      move=> /(IH (vs, (closure xs (var x)))) /= {}IH.
      move=> [/bound_var_S_iff] ? [??] /IH.
      apply: unnest. { done. }
      apply: H' => ?. by apply: machine_var_S.
  - have := PROG_APP_spec offset vs xs s t vec_zero.
    move=> /(IH (((true, closure xs t) :: vs), (closure xs s))) /= {}IH.
    move=> [/boundE [??]] ??. move: IH.
    apply: unnest. { done. }
    apply: unnest. { by constructor. }
    apply: H' => ?. by apply: machine_app.
  - move: vs IH => [|[[] z] vs] /= IH.
    + move=> *. eexists. by apply: machine_lam.
    + have := PROG_LAM_SWAP_spec offset vs xs s z vec_zero.
      move=> /(IH (((false, closure xs s) :: vs), z)) /= {}IH.
      move=> [??] /Forall_cons_iff [??].
      move: IH.
      apply: unnest. { done. }
      apply: unnest. { by constructor. }
      apply: H' => ?. by apply: machine_lam_swap.
    + move: z IH => [xs's s'] /= IH.
      have := PROG_LAM_SUBST_spec offset vs xs's xs s' s vec_zero.
      move=> /(IH (vs, closure (closure xs (lam s) :: xs's) s')) /= {}IH.
      move=> [??] /Forall_cons_iff [/= [/boundE ??] ?].
      move: IH.
      apply: unnest. { done. }
      apply: unnest. { done. }
      apply: H' => ?. by apply: machine_lam_subst.
Qed.

(* MMA termination implies L-evaluation *)
Lemma sss_terminates_COMPUTE_eval offset v :
  sss_terminates (mma_sss (n:=num_counters)) (offset, COMPUTE offset) (offset, Vector.append (0 ## v) vec_zero) ->
  exists t, eval (Vector.fold_left (fun (s : term) (n0 : nat) => app s (nat_enc n0)) s0 v) t.
Proof using Hs0.
  have := simulation_init offset v.
  move=> /sss_terminates_sss_compute_inv /[apply].
  move=> /subcode_sss_terminates.
  set i := list_sum (firstn 3 COMPUTE_lengths) + offset.
  move=> /(_ (i, PROG i)).
  apply: unnest.
  { apply: (subcode_nth_compose 3).
    rewrite (length_compose (lengths := firstn 3 COMPUTE_lengths)) //.
    apply: Forall2_firstn. by apply: COMPUTE_lengths_spec. }
  rewrite Vector.to_list_fold_left.
  move=> /(sss_terminates_PROG_machine _ nil _).
  apply: unnest. { split; [|done]. apply /L_facts.closed_dcl. by apply: closed_many_app_nat_enc. }
  apply: unnest. { done. }
  move=> [?] /wCBV.machine_inverse_simulation.
  apply: unnest. { split; [|done]. apply /L_facts.closed_dcl. by apply: closed_many_app_nat_enc.  }
  apply: unnest. { done. }
  rewrite flatten_term => ?. eexists. eassumption.
Qed.

Lemma MMA_computable_R : MMA_computable R.
Proof using Hs0 Hs0R H's0R.
  eexists _, (COMPUTE 1). move=> v m.
  have /wCBV.machine_correctness H := closed_many_app_nat_enc (Vector.to_list v) Hs0.
  split.
  - move=> /Hs0R. rewrite Vector.to_list_fold_left.
    move=> /H [y] [/simulation] /[apply] {}H.
    do 2 eexists. split. { by apply: H. }
    right. rewrite /= COMPUTE_len_spec. lia.
  - move=> [n] [v'] Hmv'. apply /Hs0R.
    rewrite Vector.to_list_fold_left. apply /H.
    apply /wCBV.machine_correctness. { by apply: closed_many_app_nat_enc. }
    have [t] : exists t, eval (Vector.fold_left (fun (s : term) (n : nat) => app s (nat_enc n)) s0 v) t.
    { apply: sss_terminates_COMPUTE_eval. eexists. by eassumption. }
    move=> /[dup] /H's0R [m' ->].
    rewrite Vector.to_list_fold_left.
    move=> Hm'. suff: m = m' by move ->.
    move: Hm' => /H [y] [/simulation] /[apply] /(_ 1) {}H.
    have : sss_output (mma_sss (n:=num_counters)) (1, COMPUTE 1)
      (1, Vector.append (0 ## v) vec_zero) (COMPUTE_len + 1, m' ## vec_zero).
    { split; [done|]. right. rewrite /= COMPUTE_len_spec. lia. }
    move: Hmv' (@mma_defs.mma_sss_fun num_counters) => /sss_output_fun /[apply] /[apply].
    by case.
Qed.

End Construction.
End Argument.

(* use L_computable_closed *)
From Undecidability Require
  L.Util.ClosedLAdmissible.

Theorem L_computable_to_MMA_computable {k} (R : Vector.t nat k -> nat -> Prop) :
  L_computable R -> MMA_computable R.
Proof.
  move=> /ClosedLAdmissible.L_computable_can_closed [s] [Hs] s_spec.
  apply: Argument.MMA_computable_R.
  - eassumption.
  - move=> v. by case: (s_spec v).
  - move=> v. by case: (s_spec v).
Qed.


Add Rec LoadPath "../src/" as PolyOp.
Add ML Path "../src/".

From Coq Require Import ZArith.
From PolyOp Require Import Modp.

Open Scope Z_scope.

Goal forall x x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 : Z,
    exists k : Z,
    ((x + (x0 * 2 ^ 51 + (x1 * 2 ^ 102 + (x2 * 2 ^ 153 + x3 * 2 ^ 204)))) *
     (x4 + (x5 * 2 ^ 51 + (x6 * 2 ^ 102 + (x7 * 2 ^ 153 + x8 * 2 ^ 204)))) -
     (x2 * 19 * x6 - x9 * 2 ^ 64 + (x3 * 19 * x5 - x10 * 2 ^ 64) -
      x11 * 2 ^ 64 + (x * x4 - x12 * 2 ^ 64) - x13 * 2 ^ 64 +
      (x0 * 19 * x8 - x14 * 2 ^ 64) - x15 * 2 ^ 64 +
      (x1 * 19 * x7 - x16 * 2 ^ 64) - x17 * 2 ^ 64 -
      x18 * 2 ^ 51 +
      ((x19 + (x20 + x21) + (x22 + x23) + (x24 + x25) + (x26 + x27)) * 2 ^ 13 +
       x28) * 19 - x29 * 2 ^ 51 + x30 * 19 +
      ((x29 +
        (x * x5 - x31 * 2 ^ 64 + (x0 * x4 - x32 * 2 ^ 64) - x33 * 2 ^ 64 +
         (x1 * 19 * x8 - x34 * 2 ^ 64) - x35 * 2 ^ 64 +
         (x2 * 19 * x7 - x36 * 2 ^ 64) - x37 * 2 ^ 64 +
         (x3 * 19 * x6 - x38 * 2 ^ 64) - x39 * 2 ^ 64 -
         x40 * 2 ^ 51 +
         ((x9 + (x10 + x11) + (x12 + x13) + (x14 + x15) + (x16 + x17)) *
          2 ^ 13 + x18)) - x41 * 2 ^ 51) * 2 ^ 51 +
       ((x41 +
         (x * x6 - x42 * 2 ^ 64 + (x0 * x5 - x43 * 2 ^ 64) - x44 * 2 ^ 64 +
          (x1 * x4 - x45 * 2 ^ 64) - x46 * 2 ^ 64 +
          (x2 * 19 * x8 - x47 * 2 ^ 64) - x48 * 2 ^ 64 +
          (x3 * 19 * x7 - x49 * 2 ^ 64) - x50 * 2 ^ 64 -
          x51 * 2 ^ 51 +
          ((x31 + (x32 + x33) + (x34 + x35) + (x36 + x37) + (x38 + x39)) *
           2 ^ 13 + x40)) - x52 * 2 ^ 51) * 2 ^ 102 +
        ((x52 +
          (x * x7 - x53 * 2 ^ 64 + (x0 * x6 - x54 * 2 ^ 64) - x55 * 2 ^ 64 +
           (x1 * x5 - x56 * 2 ^ 64) - x57 * 2 ^ 64 +
           (x2 * x4 - x58 * 2 ^ 64) - x59 * 2 ^ 64 +
           (x3 * 19 * x8 - x60 * 2 ^ 64) - x61 * 2 ^ 64 -
           x62 * 2 ^ 51 +
           ((x42 + (x43 + x44) + (x45 + x46) + (x47 + x48) + (x49 + x50)) *
            2 ^ 13 + x51)) - x63 * 2 ^ 51) * 2 ^ 153 +
         (x63 +
          (x * x8 - x19 * 2 ^ 64 + (x0 * x7 - x20 * 2 ^ 64) - x21 * 2 ^ 64 +
           (x1 * x6 - x22 * 2 ^ 64) - x23 * 2 ^ 64 +
           (x2 * x5 - x24 * 2 ^ 64) - x25 * 2 ^ 64 +
           (x3 * x4 - x26 * 2 ^ 64) - x27 * 2 ^ 64 -
           x28 * 2 ^ 51 +
           ((x53 + (x54 + x55) + (x56 + x57) + (x58 + x59) + (x60 + x61)) *
            2 ^ 13 + x62)) - x30 * 2 ^ 51) * 2 ^ 204)))))%Z =
    (k *
     57896044618658097711785492504343953926634992332820282019728792003956564819949)%Z.
Proof.
  intros.
  modp_find_witness.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive bool : Set :=
| True : bool
| False : bool.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Fixpoint eqb (n : natural) (m : natural) {struct n} : bool :=
  match n with
  | Succ n' =>
    match m with
    | Succ m' => eqb n' m'
    | Zero => False
    end
  | Zero =>
    match m with
    | Succ _ => False
    | Zero => True
    end
  end.

Definition synth (lf1 : natural) : natural := Zero.


Require Import LogicMain.
Import ListNotations.

Obligation Tactic := congruence.

Inductive byzantineConsensus :=
	R' | B' | A | X | CR' | VR' | B | VB' | A' | P | R | Y | Z | VA' |  CA'.

Program Instance modelPortsEqDec : EqDec byzantineConsensus eq :=
	{equiv_dec x y :=
		 match x, y with
		| R' , R' => in_left
		| R' , B' => in_right
		| R' , A => in_right
		| R' , X => in_right
		| R' , CR' => in_right
		| R' , VR' => in_right
		| R' , B => in_right
		| R' , VB' => in_right
		| R' , A' => in_right
		| R' , P => in_right
		| R' , R => in_right
		| R' , Y => in_right
		| R' , Z => in_right
		| R' , VA' => in_right
		| R' , CA' => in_right
		| B' , R' => in_right
		| B' , B' => in_left
		| B' , A => in_right
		| B' , X => in_right
		| B' , CR' => in_right
		| B' , VR' => in_right
		| B' , B => in_right
		| B' , VB' => in_right
		| B' , A' => in_right
		| B' , P => in_right
		| B' , R => in_right
		| B' , Y => in_right
		| B' , Z => in_right
		| B' , VA' => in_right
		| B' , CA' => in_right
		| A , R' => in_right
		| A , B' => in_right
		| A , A => in_left
		| A , X => in_right
		| A , CR' => in_right
		| A , VR' => in_right
		| A , B => in_right
		| A , VB' => in_right
		| A , A' => in_right
		| A , P => in_right
		| A , R => in_right
		| A , Y => in_right
		| A , Z => in_right
		| A , VA' => in_right
		| A , CA' => in_right
		| X , R' => in_right
		| X , B' => in_right
		| X , A => in_right
		| X , X => in_left
		| X , CR' => in_right
		| X , VR' => in_right
		| X , B => in_right
		| X , VB' => in_right
		| X , A' => in_right
		| X , P => in_right
		| X , R => in_right
		| X , Y => in_right
		| X , Z => in_right
		| X , VA' => in_right
		| X , CA' => in_right
		| CR' , R' => in_right
		| CR' , B' => in_right
		| CR' , A => in_right
		| CR' , X => in_right
		| CR' , CR' => in_left
		| CR' , VR' => in_right
		| CR' , B => in_right
		| CR' , VB' => in_right
		| CR' , A' => in_right
		| CR' , P => in_right
		| CR' , R => in_right
		| CR' , Y => in_right
		| CR' , Z => in_right
		| CR' , VA' => in_right
		| CR' , CA' => in_right
		| VR' , R' => in_right
		| VR' , B' => in_right
		| VR' , A => in_right
		| VR' , X => in_right
		| VR' , CR' => in_right
		| VR' , VR' => in_left
		| VR' , B => in_right
		| VR' , VB' => in_right
		| VR' , A' => in_right
		| VR' , P => in_right
		| VR' , R => in_right
		| VR' , Y => in_right
		| VR' , Z => in_right
		| VR' , VA' => in_right
		| VR' , CA' => in_right
		| B , R' => in_right
		| B , B' => in_right
		| B , A => in_right
		| B , X => in_right
		| B , CR' => in_right
		| B , VR' => in_right
		| B , B => in_left
		| B , VB' => in_right
		| B , A' => in_right
		| B , P => in_right
		| B , R => in_right
		| B , Y => in_right
		| B , Z => in_right
		| B , VA' => in_right
		| B , CA' => in_right
		| VB' , R' => in_right
		| VB' , B' => in_right
		| VB' , A => in_right
		| VB' , X => in_right
		| VB' , CR' => in_right
		| VB' , VR' => in_right
		| VB' , B => in_right
		| VB' , VB' => in_left
		| VB' , A' => in_right
		| VB' , P => in_right
		| VB' , R => in_right
		| VB' , Y => in_right
		| VB' , Z => in_right
		| VB' , VA' => in_right
		| VB' , CA' => in_right
		| A' , R' => in_right
		| A' , B' => in_right
		| A' , A => in_right
		| A' , X => in_right
		| A' , CR' => in_right
		| A' , VR' => in_right
		| A' , B => in_right
		| A' , VB' => in_right
		| A' , A' => in_left
		| A' , P => in_right
		| A' , R => in_right
		| A' , Y => in_right
		| A' , Z => in_right
		| A' , VA' => in_right
		| A' , CA' => in_right
		| P , R' => in_right
		| P , B' => in_right
		| P , A => in_right
		| P , X => in_right
		| P , CR' => in_right
		| P , VR' => in_right
		| P , B => in_right
		| P , VB' => in_right
		| P , A' => in_right
		| P , P => in_left
		| P , R => in_right
		| P , Y => in_right
		| P , Z => in_right
		| P , VA' => in_right
		| P , CA' => in_right
		| R , R' => in_right
		| R , B' => in_right
		| R , A => in_right
		| R , X => in_right
		| R , CR' => in_right
		| R , VR' => in_right
		| R , B => in_right
		| R , VB' => in_right
		| R , A' => in_right
		| R , P => in_right
		| R , R => in_left
		| R , Y => in_right
		| R , Z => in_right
		| R , VA' => in_right
		| R , CA' => in_right
		| Y , R' => in_right
		| Y , B' => in_right
		| Y , A => in_right
		| Y , X => in_right
		| Y , CR' => in_right
		| Y , VR' => in_right
		| Y , B => in_right
		| Y , VB' => in_right
		| Y , A' => in_right
		| Y , P => in_right
		| Y , R => in_right
		| Y , Y => in_left
		| Y , Z => in_right
		| Y , VA' => in_right
		| Y , CA' => in_right
		| Z , R' => in_right
		| Z , B' => in_right
		| Z , A => in_right
		| Z , X => in_right
		| Z , CR' => in_right
		| Z , VR' => in_right
		| Z , B => in_right
		| Z , VB' => in_right
		| Z , A' => in_right
		| Z , P => in_right
		| Z , R => in_right
		| Z , Y => in_right
		| Z , Z => in_left
		| Z , VA' => in_right
		| Z , CA' => in_right
		| VA' , R' => in_right
		| VA' , B' => in_right
		| VA' , A => in_right
		| VA' , X => in_right
		| VA' , CR' => in_right
		| VA' , VR' => in_right
		| VA' , B => in_right
		| VA' , VB' => in_right
		| VA' , A' => in_right
		| VA' , P => in_right
		| VA' , R => in_right
		| VA' , Y => in_right
		| VA' , Z => in_right
		| VA' , VA' => in_left
		| VA' , CA' => in_right
		| CA' , R' => in_right
		| CA' , B' => in_right
		| CA' , A => in_right
		| CA' , X => in_right
		| CA' , CR' => in_right
		| CA' , VR' => in_right
		| CA' , B => in_right
		| CA' , VB' => in_right
		| CA' , A' => in_right
		| CA' , P => in_right
		| CA' , R => in_right
		| CA' , Y => in_right
		| CA' , Z => in_right
		| CA' , VA' => in_right
		| CA' , CA' => in_left
	end
	}.

Close Scope Q_scope.

Program Instance dataProp_eqdec2 {name data : Type} `{EqDec name eq} `{EqDec data eq} : EqDec (dataProp name data) eq :=
    {
      equiv_dec x y :=
        match x, y with
          | dataInPorts a x, dataInPorts b y => if a == b then if x == y then in_left else in_right else in_right
          | dataInFifo a x b, dataInFifo c y d => if a == c then if b == d then if x == y then in_left else in_right else in_right else in_right
          | dataBothPorts _ a b, dataBothPorts _ c d => if a == c then if b == d then in_left else in_right else in_right
          | dataInPorts a x , dataInFifo b y c => in_right
          | dataInPorts a x , dataBothPorts _ b y => in_right
          | dataInFifo a x b , dataInPorts c y => in_right
          | dataInFifo a x b , dataBothPorts _ c y => in_right
          | dataBothPorts _ a b , dataInPorts c y => in_right
          | dataBothPorts _ a b , dataInFifo c y d  => in_right
        end
     }.

Definition timerProp (n : nat) := true.

Definition presetTimerProp (n: nat) :=
  match n with
  | 0 => true
  | Datatypes.S m => false
  end.

Definition timerAPProp (n : nat) :=
  match n with
  | 1 => true
  | 0 => false
  | Datatypes.S m => false
  end.

Definition timerBPProp (n:nat) :=
  match n with
  | 0 => true
  | Datatypes.S m => false
  end.

Definition timerVAProp (n:nat) :=
  match n with
  | 0 => true
  | Datatypes.S m => false
  end.

Definition BizantineConsensusFlowProgram := [flowFilter timerProp R' B'; flowSync nat B' A; flowSync nat B' X;
flowFilter timerProp X CR'; flowFilter timerProp A VR'; flowFilter timerProp B VB'; flowFilter timerBPProp A' B;
flowFilter timerAPProp A' P; flowFilter timerProp  P R; flowSync nat R Y; flowSync nat R Z; flowFilter timerVAProp Y VA';
flowFilter timerProp Z CA'].

Definition BizantineConsensusBlockProgram := [flowSyncdrain A X; flowaSyncdrain VR' CR'; flowaSyncdrain VB' A;
flowaSyncdrain VA' CA'; flowSyncdrain Y Z].

Definition pi := sProgram (reoProg BizantineConsensusFlowProgram BizantineConsensusBlockProgram).

Definition piStar := star (reoProg BizantineConsensusFlowProgram BizantineConsensusBlockProgram).

Definition t := [dataPorts A' 1].

(*Property 1 - For the data to be in CA, it requires no data in any of the V's*)

 Definition property1 := Eval compute in constructModel
  [R'; B' ; A ; X ; CR' ; VR' ; B ; VB' ; A' ; P ; R ; Y ; Z ; VA'; CA'] [t]
  (((imp (box t piStar(proposition (dataInPorts CA' 1)))
         (box t piStar(and (and (neg(proposition (dataInPorts VA' 1)))
                           (neg(proposition (dataInPorts VB' 1))))
                      (neg(proposition (dataInPorts VR' 1))))))))
  (length(BizantineConsensusFlowProgram) + length(BizantineConsensusBlockProgram)).

Eval compute in property1.

Eval compute in singleFormulaVerify property1 (((imp
                  (box t piStar(proposition (dataInPorts CA' 1)))
                  (box t piStar(and (and (neg(proposition (dataInPorts VA' 1))) (neg(proposition (dataInPorts VB' 1))))
                        (neg(proposition (dataInPorts VR' 1)))))))) t.

(*Property 2 - For the data to be in CA, it requires no data in any of the V's*)

Definition t' := [dataPorts A' 0].

(*  Definition property2 := Eval compute in constructModel
  [R'; B' ; A ; X ; CR' ; VR' ; B ; VB' ; A' ; P ; R ; Y ; Z ; VA'; CA'] [t']
  (((imp (and(box t' piStar(proposition (dataInPorts VA' 0)))
              (box t' piStar (proposition (dataInPorts VR' 0))))
         (box t' piStar((and (neg(proposition (dataInPorts CA' 0)))
                            (neg(proposition (dataInPorts CR' 0)))))))))
  (length(BizantineConsensusFlowProgram) + length(BizantineConsensusBlockProgram)).  *)

Definition property2 := Eval compute in constructModel
  [R'; B' ; A ; X ; CR' ; VR' ; B ; VB' ; A' ; P ; R ; Y ; Z ; VA'; CA'] [t']
  (((imp ((box t' piStar(proposition (dataInPorts VA' 0))))
         (box t' piStar((and (neg(proposition (dataInPorts CA' 0)))
                            (neg(proposition (dataInPorts CR' 0)))))))))
  (length(BizantineConsensusFlowProgram) + length(BizantineConsensusBlockProgram)).

Eval compute in property2.

Eval compute in singleFormulaVerify property2 (((imp ((box t' piStar(proposition (dataInPorts VA' 0))))
         (box t' piStar((and (neg(proposition (dataInPorts CA' 0)))
                            (neg(proposition (dataInPorts CR' 0))))))))) t.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.Extensions.Syntax_CoreTransit.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.ModalLogic.
Require Import Logic.ModalLogic.ProofTheory.RewriteClass.
Require Import Logic.ModalLogic.ProofTheory.IntuitionisticDerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.Extensions.ProofTheory.Stable.
Require Import Logic.Extensions.ProofTheory.ModalSeparation.
Require Import Logic.Extensions.ProofTheory.Corable.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import CoreTransitNotation.

Class CoreTransitSeparationLogic (L: Language) {minL: MinimunLanguage L} {pL: PropositionalLanguage L} {sL: SeparationLanguage L} {CtsL: CoreTransitSeparationLanguage L} (Gamma: ProofTheory L) {minAX: MinimunAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {sGamma: SeparationLogic L Gamma} {CosGamma: Corable L Gamma}:= {
  core_tr_SystemK: @SystemK L minL pL (ct_mL L) Gamma minAX ipGamma;
  core_tr_PTransparent: @PropositionalTransparentModality L minL pL (ct_mL L) Gamma minAX ipGamma core_tr_SystemK;
  core_tr_STransparent1: @SeparationTransparentModality1 L minL pL (ct_mL L) sL Gamma minAX ipGamma core_tr_SystemK sGamma;
  core_tr_STransparent2: @SeparationTransparentModality2 L minL pL (ct_mL L) sL Gamma minAX ipGamma core_tr_SystemK sGamma;
  core_tr_andp_sepcon: forall x y, |-- core_tr (x && y) --> core_tr (x * y);
  coreAbsorb: @ModalAbsorbStable L minL (ct_mL L) Gamma corable
}.

Section CoreTransit.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {CtsL: CoreTransitSeparationLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}
        {CosGamma: Corable L Gamma}
        {CtsGamma: CoreTransitSeparationLogic L Gamma}.

Lemma core_tr_andp: forall x y, |-- core_tr (x && y) <--> core_tr x && core_tr y.
Proof. intros. apply (@boxp_andp L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK). Qed.

Lemma core_tr_orp: forall x y, |-- core_tr (x || y) <--> core_tr x || core_tr y.
Proof. intros. apply (@boxp_orp L _ _ (ct_mL L) Gamma _ _ _ core_tr_PTransparent). Qed.

Lemma core_tr_sepcon: forall x y, |-- core_tr x * core_tr y <--> core_tr (x * y).
Proof.
  intros.
  apply solve_andp_intros.
  + apply (@sepcon_boxp L _ _ (ct_mL L) sL Gamma _ _ _ _ core_tr_STransparent1).
  + apply (@boxp_sepcon L _ _ (ct_mL L) sL Gamma _ _ _ _ core_tr_STransparent2).
Qed.

Instance core_tr_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) core_tr.
Proof. apply (@boxp_proper_impp L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK). Qed.

Instance core_tr_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) core_tr.
Proof. apply (@boxp_proper_iffp L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK). Qed.

Lemma core_tr_andp_sepcon_iffp {GC: GarbageCollectSeparationLogic L Gamma}: forall x y, |-- core_tr (x && y) <--> core_tr (x * y).
Proof.
  intros.
  apply solve_andp_intros.
  + apply core_tr_andp_sepcon.
  + (* TODO: modularize this proof. *)
    pose proof (@axiom_K L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK).
    simpl in H; rewrite <- H; clear H.
    apply (@rule_N L _ _ (ct_mL L) Gamma _ _ core_tr_SystemK).
    apply solve_impp_andp.
    - rewrite <- (sepcon_elim1 x y) at 2.
      apply provable_impp_refl.
    - rewrite <- (sepcon_elim2 x y) at 2.
      apply provable_impp_refl.
Qed.

Lemma core_tr_dup {GC: GarbageCollectSeparationLogic L Gamma}: forall x, |-- core_tr x <--> core_tr x * core_tr x.
Proof.
  intros.
  rewrite <- (andp_dup x) at 1.
  rewrite core_tr_andp_sepcon_iffp.
  rewrite core_tr_sepcon.
  apply provable_iffp_refl.
Qed.

Lemma core_tr_absorb_corable: forall x, corable x -> |-- x --> core_tr x.
Proof. intros. apply (@boxp_absorb_stable _ _ (ct_mL L) Gamma corable coreAbsorb); auto. Qed.

End CoreTransit.

Existing Instances core_tr_proper_impp core_tr_proper_iffp.


Require Import Core.Core Core.StructNormalizer VstLib.
Require Import VST.floyd.proofauto.
(* Require Import BFL.Exec. *)
Require Import Clight.ber_tlv_length.
Require Import Core.Notations Core.SepLemmas Core.Tactics Core.VstTactics.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. Proof. mk_varspecs prog. Defined.

Section Ber_fetch_len.

Open Scope  bool.
Open Scope int.
Fixpoint aux_loop ptr len skip oct size sizeofval :
   (int * int * int * int) :=
  match ptr with
  | x :: xs => if (negb (oct == 0)) && ((skip + 1) <=u size)
              then if (len >> ((Int.repr 8 * sizeofval) - (Int.repr 8 + 1))) == 0
                   then let len' := Int.or (len << Int.repr 8) x in
                        aux_loop xs len' (skip + 1) (oct - 1) size sizeofval
                   else (Int.neg 1, oct, len, skip)
              else (0, oct, len, skip)
  | nil => (0, 0, 0, 0)
  end.

Definition bfl_loop ptr len  skip oct size sizeofval
  := aux_loop ptr len skip oct size sizeofval.

Definition ber_fetch_len ptr isc len_r size sizeofval rssizem :
   (int * int) :=
  if eq_dec size 0
  then (0, len_r)
  else let oct := Znth 0 ptr in
       if eq_dec (oct & Int.repr 128) 0
       then (1, oct)
       else if (negb (isc =? 0)) && (oct == Int.repr 128)
            then (1, Int.neg 1)
            else if eq_dec oct (Int.repr 255)
                 then (Int.neg 1, len_r)
                 else let oct := oct & (Int.repr 127) in
                      match bfl_loop (skipn 1%nat ptr) 0 1 oct size sizeofval with
                      | (z, oct, len, skip) => if eq_dec z (Int.neg 1)
                                       then (z, len_r)
                                       else
                                         if eq_dec oct 0
                                              then if (len < 0) || (rssizem < len)
                                                   then (Int.neg 1, len_r)
                                                   else (skip, len)
                                              else (0, len_r)
                      end.
Open Scope Z.

Definition ber_fetch_len_spec : ident * funspec :=
  DECLARE _ber_fetch_length
    WITH c : Z,  b : block, i : ptrofs,
         size : int, data : list int,
         len_r : val
    PRE [tint, tptr tvoid, tuint, tptr tint]
      PROP ((* definite length *)
           (Znth 0 data & Int.repr 128)%int = 0%int;
             (* primitive tag *)
            c = 0;
            Ptrofs.unsigned i + len data < Ptrofs.modulus;
            Forall (fun x => 0 <= Int.unsigned x <= Byte.max_unsigned) data;
            0 < len data)
      PARAMS (Vint (Int.repr 0); (Vptr b i); Vint size; len_r)
      GLOBALS ()
      SEP (data_at Tsh (tarray tuchar (Zlength data))
                   (map Vint data) (Vptr b i);
           data_at_ Tsh tint len_r)
    POST [tint]
      let r := ber_fetch_len data c 0%int size (Int.repr (sizeof tuint))
       (Int.repr (Int.max_unsigned)) in
      PROP ()
      LOCAL (temp ret_temp (Vint ((fst r))))
      SEP (data_at Tsh (tarray tuchar (Zlength data))
                   (map Vint (data)) (Vptr b i);
           if eq_dec (fst r) 0%int
           then  data_at_ Tsh tint len_r
           else if eq_dec (fst r) (Int.neg 1%int)
                then  data_at_ Tsh tint len_r
                else
                  data_at Tsh tint (Vint (snd r)) len_r).

Definition Gprog := ltac:(with_library prog [ber_fetch_len_spec]).

Lemma Znth_0_cons_sublist :  forall (ls : list int),
             0 < len ls ->
             Znth 0 ls :: sublist 1 (len ls) ls = ls.
  { intros.
    erewrite Znth_cons_sublist.
    autorewrite with sublist.
    auto. lia. }
Qed.

Theorem ber_fetch_len_correctness : semax_body Vprog Gprog
                                          (normalize_function f_ber_fetch_length
                                                              composites)
                                          ber_fetch_len_spec.
Proof.
  start_function.
  forward.
  forward_if.
  forward.
  assert (data_at Tsh (tarray tuchar (len data)) (map Vint data) (Vptr b i) =
          (data_at Tsh tuchar (Vint (Znth 0 data)) (Vptr b i) *
          data_at Tsh (tarray tuchar (len data - 1))
                  (sublist 1 (len data) (map Vint data))
                  (Vptr b (i + 1)%ptrofs))%logic) as D.
  { erewrite split_non_empty_list
      with (i := Vint (Znth 0 data))
           (j2 := len data - 1)
           (ls' := sublist 1 (len data) (map Vint data)).
    auto. erewrite <- map_sublist;
            erewrite <- map_cons;
            f_equal; erewrite Znth_0_cons_sublist; try lia; auto.
    all: autorewrite with sublist; strip_repr. }
  erewrite D.
  Intros.
  forward.
  entailer!.
  eapply Forall_Znth with (i0 := 0) in H2; try lia.
  forward_if; try contradiction.
  forward.
  forward.
  unfold ber_fetch_len.
  repeat rewrite_if_b.
  simpl.
  erewrite <- D.
  entailer!.
Qed.

(* Indefinite length branch:
- forward_if (temp _t'1 Vzero); try contradiction.
  + admit.
    (* forward.
       entailer!. *)
  + forward_if; try contradiction.
    forward_if.
    * admit. (* forward.
      { unfold ber_fetch_len.
        repeat rewrite_if_b.
        simpl.
        entailer!.
        admit. (* split as before *) } *)
    * repeat forward.
      (* Loop *)
       match goal with
       | [ _ : _ |-  semax _ ?P ?C ?Post ] =>
         forward_loop (PROP ( )
                       LOCAL (temp _skipped (Vint (Int.repr 1));
                              temp _buf (Vptr b (i + 1)%ptrofs);
                              temp _len (Vint (Int.repr 0));
                              temp _oct (Vint (Znth 0 data & Int.repr 127)%int);
                              temp _t'1 Vzero;
                              temp __is_constructed (Vint (Int.repr 0));
                              temp _bufptr (Vptr b i);
                              temp _size (Vint size);
                              temp _len_r len_r)
                       SEP (data_at Tsh tuchar (Vint (Znth 0 data)) (Vptr b i);
                            data_at Tsh (tarray tuchar (len data - 1))
                                    (sublist 1 (len data) (map Vint data))
                                    (Vptr b (i + 1)%ptrofs); data_at_ Tsh tint len_r))
         break: P
        end.
       -- (* PRE to LI *)
         entailer!.
       -- (* LI C LI *)
         forward_if [temp _skipped (if eq_dec (Znth 0 data & Int.repr 127)%int 0%int
                                   then Vone
                                   else (Vint (1 + 1)%int)) ;
                     temp _t'2 (if eq_dec (Znth 0 data & Int.repr 127)%int 0%int
                                then Vzero
                                else Val.of_bool ((1 + 1)%int <=u size))].
         ++ repeat forward.
            repeat rewrite_if_b.
            entailer!.
         ++ forward.
            repeat rewrite_if_b.
            entailer!.
         Arguments eq_dec : simpl never.
         ++ forward_if.
            ** forward_if; try discriminate.
               normalize.
               erewrite split_non_empty_list
                 with (i := Vint (Znth 1 data))
                      (j2 := len data - 2)
                      (ls' := sublist 2 (len data) (map Vint data)).
               Intros.
               forward.
               entailer!.
               eapply Forall_Znth with (i0 := 1) in H1; try lia.
               admit. (* 0 <= 1 < len data *)
               repeat forward.
               entailer!.
               1-5: admit.
            ** forward.
               entailer!.
               admit.
       -- (* BREAK rest POST *)
         forward_if.
         forward_if (temp _t'4 (if (0 <? 0)
                                then Vone
                                else (Val.of_bool ((-1) >> 1 >> 1 <? 0)))).
         ** forward.
            entailer!.
         ** forward.
            entailer!.
            admit.
         ** forward_if.
            --- forward.
                entailer!.
                admit.
                admit.
            --- forward.
                forward.
                entailer!.
                admit.
                admit.
         ** forward.
            entailer!.
            admit.
            admit.
Admitted.
*)

End Ber_fetch_len.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6b.
Require Export lemma__betweennotequal.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__differenceofparts.
Require Export lemma__equalitysymmetric.
Require Export lemma__extensionunique.
Require Export lemma__interior5.
Require Export lemma__partnotequalwhole.
Require Export lemma__ray1.
Require Export logic.
Definition lemma__layoffunique : forall A B C D, (euclidean__defs.Out A B C) -> ((euclidean__defs.Out A B D) -> ((euclidean__axioms.Cong A C A D) -> (C = D))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
intro H1.
assert (* Cut *) (euclidean__axioms.Cong A D A C) as H2.
- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A C D H1).
- assert (* Cut *) ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as H3.
-- apply (@lemma__ray1.lemma__ray1 A B C H).
-- assert (* Cut *) ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H4.
--- apply (@lemma__ray1.lemma__ray1 A B D H0).
--- assert (* Cut *) (euclidean__axioms.Cong A B A B) as H5.
---- apply (@euclidean__axioms.cn__congruencereflexive A B).
---- assert (* Cut *) (euclidean__axioms.Cong B C B C) as H6.
----- apply (@euclidean__axioms.cn__congruencereflexive B C).
----- assert (* Cut *) (euclidean__axioms.Cong C B C B) as H7.
------ apply (@euclidean__axioms.cn__congruencereflexive C B).
------ assert (* Cut *) (euclidean__axioms.Cong A C A C) as H8.
------- apply (@euclidean__axioms.cn__congruencereflexive A C).
------- assert (* Cut *) (C = D) as H9.
-------- assert ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as H9 by exact H3.
assert ((euclidean__axioms.BetS A C B) \/ ((B = C) \/ (euclidean__axioms.BetS A B C))) as __TmpHyp by exact H9.
destruct __TmpHyp as [H10|H10].
--------- assert (* Cut *) (C = D) as H11.
---------- assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H11 by exact H4.
assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as __TmpHyp0 by exact H11.
destruct __TmpHyp0 as [H12|H12].
----------- assert (* Cut *) (euclidean__axioms.Cong C B D B) as H13.
------------ apply (@lemma__differenceofparts.lemma__differenceofparts A C B A D B H1 H5 H10 H12).
------------ assert (* Cut *) (euclidean__axioms.Cong B C B D) as H14.
------------- assert (* Cut *) ((euclidean__axioms.Cong B C B D) /\ ((euclidean__axioms.Cong B C D B) /\ (euclidean__axioms.Cong C B B D))) as H14.
-------------- apply (@lemma__congruenceflip.lemma__congruenceflip C B D B H13).
-------------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H15.
------------- assert (* Cut *) (euclidean__axioms.Cong C C C D) as H15.
-------------- apply (@lemma__interior5.lemma__interior5 A C B C A C B D H10 H10 H8 H7 H1 H14).
-------------- assert (* Cut *) (euclidean__axioms.Cong C D C C) as H16.
--------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric C C C D H15).
--------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H17.
---------------- intro H17.
assert (* Cut *) (euclidean__axioms.neq C C) as H18.
----------------- apply (@euclidean__axioms.axiom__nocollapse C D C C H17 H16).
----------------- assert (* Cut *) (C = C) as H19.
------------------ assert (* Cut *) (False) as H19.
------------------- assert (* Cut *) (C = C) as H19.
-------------------- apply (@logic.eq__refl Point C).
-------------------- apply (@H18 H19).
------------------- assert (False) as H20 by exact H19.
apply (@logic.eq__refl Point C).
------------------ apply (@H18 H19).
---------------- apply (@euclidean__tactics.NNPP (C = D)).
-----------------intro H18.
assert (* Cut *) (False) as H19.
------------------ apply (@H17 H18).
------------------ contradiction H19.

----------- destruct H12 as [H13|H13].
------------ assert (* Cut *) (euclidean__axioms.BetS A C D) as H14.
------------- apply (@eq__ind__r euclidean__axioms.Point D (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.BetS A C B0) -> (euclidean__axioms.BetS A C D)))))))) with (x := B).
--------------intro H14.
intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
exact H19.

-------------- exact H13.
-------------- exact H.
-------------- exact H0.
-------------- exact H5.
-------------- exact H6.
-------------- exact H7.
-------------- exact H10.
------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H15.
-------------- intro H15.
assert (* Cut *) (~(euclidean__axioms.Cong A C A D)) as H16.
--------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C D H14).
--------------- apply (@H16 H1).
-------------- apply (@euclidean__tactics.NNPP (C = D)).
---------------intro H16.
assert (* Cut *) (False) as H17.
---------------- apply (@H15 H16).
---------------- contradiction H17.

------------ assert (* Cut *) (euclidean__axioms.BetS A C D) as H14.
------------- apply (@lemma__3__6b.lemma__3__6b A C B D H10 H13).
------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H15.
-------------- intro H15.
assert (* Cut *) (~(euclidean__axioms.Cong A C A D)) as H16.
--------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C D H14).
--------------- apply (@H16 H1).
-------------- apply (@euclidean__tactics.NNPP (C = D)).
---------------intro H16.
assert (* Cut *) (False) as H17.
---------------- apply (@H15 H16).
---------------- contradiction H17.

---------- exact H11.
--------- destruct H10 as [H11|H11].
---------- assert (* Cut *) (euclidean__axioms.Cong A B A D) as H12.
----------- apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> (((euclidean__axioms.BetS A D B0) \/ ((B0 = D) \/ (euclidean__axioms.BetS A B0 D))) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> (euclidean__axioms.Cong A B0 A D)))))))) with (x := B).
------------intro H12.
intro H13.
intro H14.
intro H15.
intro H16.
intro H17.
exact H1.

------------ exact H11.
------------ exact H.
------------ exact H0.
------------ exact H4.
------------ exact H5.
------------ exact H6.
------------ exact H7.
----------- assert (* Cut *) (euclidean__axioms.Cong A D A B) as H13.
------------ apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> (((euclidean__axioms.BetS A D B0) \/ ((B0 = D) \/ (euclidean__axioms.BetS A B0 D))) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.Cong A B0 A D) -> (euclidean__axioms.Cong A D A B0))))))))) with (x := B).
-------------intro H13.
intro H14.
intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
exact H2.

------------- exact H11.
------------- exact H.
------------- exact H0.
------------- exact H4.
------------- exact H5.
------------- exact H6.
------------- exact H7.
------------- exact H12.
------------ assert (* Cut *) (C = D) as H14.
------------- assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H14 by exact H4.
assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as __TmpHyp0 by exact H14.
destruct __TmpHyp0 as [H15|H15].
-------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H16.
--------------- intro H16.
assert (* Cut *) (~(euclidean__axioms.Cong A D A B)) as H17.
---------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A D B H15).
---------------- apply (@H17 H13).
--------------- apply (@euclidean__tactics.NNPP (C = D)).
----------------intro H17.
assert (* Cut *) (False) as H18.
----------------- apply (@H16 H17).
----------------- contradiction H18.

-------------- destruct H15 as [H16|H16].
--------------- assert (* Cut *) (C = B) as H17.
---------------- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric C B H11).
---------------- assert (* Cut *) (D = B) as H18.
----------------- apply (@eq__ind euclidean__axioms.Point B (fun C0 => (euclidean__defs.Out A B C0) -> ((euclidean__axioms.Cong A C0 A D) -> ((euclidean__axioms.Cong A D A C0) -> ((euclidean__axioms.Cong B C0 B C0) -> ((euclidean__axioms.Cong C0 B C0 B) -> ((euclidean__axioms.Cong A C0 A C0) -> ((C0 = B) -> (D = B))))))))) with (y := C).
------------------intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
apply (@eq__ind__r euclidean__axioms.Point D (fun B0 => (euclidean__defs.Out A B0 B0) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A D A B0) -> ((euclidean__axioms.Cong A B0 A D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 B0 B0 B0) -> ((euclidean__axioms.Cong B0 B0 B0 B0) -> ((euclidean__axioms.Cong A B0 A D) -> ((euclidean__axioms.Cong A D A B0) -> ((B0 = B0) -> (D = B0))))))))))))) with (x := B).
-------------------intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
exact H35.

------------------- exact H16.
------------------- exact H18.
------------------- exact H0.
------------------- exact H20.
------------------- exact H19.
------------------- exact H5.
------------------- exact H23.
------------------- exact H22.
------------------- exact H21.
------------------- exact H12.
------------------- exact H13.
------------------- exact H24.

------------------ exact H11.
------------------ exact H.
------------------ exact H1.
------------------ exact H2.
------------------ exact H6.
------------------ exact H7.
------------------ exact H8.
------------------ exact H17.
----------------- assert (* Cut *) (C = D) as H19.
------------------ apply (@eq__ind euclidean__axioms.Point B (fun D0 => (euclidean__defs.Out A B D0) -> ((euclidean__axioms.Cong A C A D0) -> ((euclidean__axioms.Cong A D0 A C) -> ((euclidean__axioms.Cong A B A D0) -> ((euclidean__axioms.Cong A D0 A B) -> ((D0 = B) -> (C = D0)))))))) with (y := D).
-------------------intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
apply (@eq__ind euclidean__axioms.Point B (fun C0 => (euclidean__defs.Out A B C0) -> ((euclidean__axioms.Cong A B A C0) -> ((euclidean__axioms.Cong A C0 A B) -> ((euclidean__axioms.Cong B C0 B C0) -> ((euclidean__axioms.Cong C0 B C0 B) -> ((euclidean__axioms.Cong A C0 A C0) -> ((C0 = B) -> ((B = B) -> (C0 = B)))))))))) with (y := C).
--------------------intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
assert (B = B) as H32 by exact H31.
intro H33.
exact H33.

-------------------- exact H11.
-------------------- exact H.
-------------------- exact H21.
-------------------- exact H20.
-------------------- exact H6.
-------------------- exact H7.
-------------------- exact H8.
-------------------- exact H17.
-------------------- exact H24.

------------------- exact H16.
------------------- exact H0.
------------------- exact H1.
------------------- exact H2.
------------------- exact H12.
------------------- exact H13.
------------------- exact H18.
------------------ exact H19.
--------------- assert (* Cut *) (euclidean__axioms.BetS A C D) as H17.
---------------- apply (@eq__ind__r euclidean__axioms.Point C (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.Cong A B0 A D) -> ((euclidean__axioms.Cong A D A B0) -> ((euclidean__axioms.BetS A B0 D) -> (euclidean__axioms.BetS A C D)))))))))) with (x := B).
-----------------intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
intro H22.
intro H23.
intro H24.
exact H24.

----------------- exact H11.
----------------- exact H.
----------------- exact H0.
----------------- exact H5.
----------------- exact H6.
----------------- exact H7.
----------------- exact H12.
----------------- exact H13.
----------------- exact H16.
---------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H18.
----------------- intro H18.
assert (* Cut *) (~(euclidean__axioms.Cong A C A D)) as H19.
------------------ apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A C D H17).
------------------ apply (@H19 H1).
----------------- apply (@euclidean__tactics.NNPP (C = D)).
------------------intro H19.
assert (* Cut *) (False) as H20.
------------------- apply (@H18 H19).
------------------- contradiction H20.

------------- exact H14.
---------- assert (* Cut *) (C = D) as H12.
----------- assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as H12 by exact H4.
assert ((euclidean__axioms.BetS A D B) \/ ((B = D) \/ (euclidean__axioms.BetS A B D))) as __TmpHyp0 by exact H12.
destruct __TmpHyp0 as [H13|H13].
------------ assert (* Cut *) (euclidean__axioms.BetS A D C) as H14.
------------- apply (@lemma__3__6b.lemma__3__6b A D B C H13 H11).
------------- assert (euclidean__axioms.Cong A D A C) as H15 by exact H2.
assert (* Cut *) (~(euclidean__axioms.neq C D)) as H16.
-------------- intro H16.
assert (* Cut *) (~(euclidean__axioms.Cong A D A C)) as H17.
--------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A D C H14).
--------------- apply (@H17 H15).
-------------- apply (@euclidean__tactics.NNPP (C = D)).
---------------intro H17.
assert (* Cut *) (False) as H18.
---------------- apply (@H16 H17).
---------------- contradiction H18.

------------ destruct H13 as [H14|H14].
------------- assert (* Cut *) (euclidean__axioms.BetS A D C) as H15.
-------------- apply (@eq__ind__r euclidean__axioms.Point D (fun B0 => (euclidean__defs.Out A B0 C) -> ((euclidean__defs.Out A B0 D) -> ((euclidean__axioms.Cong A B0 A B0) -> ((euclidean__axioms.Cong B0 C B0 C) -> ((euclidean__axioms.Cong C B0 C B0) -> ((euclidean__axioms.BetS A B0 C) -> (euclidean__axioms.BetS A D C)))))))) with (x := B).
---------------intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
exact H20.

--------------- exact H14.
--------------- exact H.
--------------- exact H0.
--------------- exact H5.
--------------- exact H6.
--------------- exact H7.
--------------- exact H11.
-------------- assert (* Cut *) (~(euclidean__axioms.neq C D)) as H16.
--------------- intro H16.
assert (* Cut *) (~(euclidean__axioms.Cong A D A C)) as H17.
---------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A D C H15).
---------------- apply (@H17 H2).
--------------- apply (@euclidean__tactics.NNPP (C = D)).
----------------intro H17.
assert (* Cut *) (False) as H18.
----------------- apply (@H16 H17).
----------------- contradiction H18.

------------- assert (* Cut *) (euclidean__axioms.neq A B) as H15.
-------------- assert (* Cut *) ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq A D))) as H15.
--------------- apply (@lemma__betweennotequal.lemma__betweennotequal A B D H14).
--------------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H18.
-------------- assert (* Cut *) (euclidean__axioms.Cong B C B D) as H16.
--------------- apply (@lemma__differenceofparts.lemma__differenceofparts A B C A B D H5 H1 H11 H14).
--------------- assert (* Cut *) (C = D) as H17.
---------------- apply (@lemma__extensionunique.lemma__extensionunique A B C D H11 H14 H16).
---------------- exact H17.
----------- exact H12.
-------- exact H9.
Qed.


(** * Well-founded relation on [parse_of] *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Relations.Relation_Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {G : grammar Char}.

  Section size.
    Definition size_of_parse_item'
               (size_of_parse : forall {str pats} (p : parse_of G str pats), nat)
               {str it} (p : parse_of_item G str it) : nat
      := match p with
           | ParseTerminal _ _ _ _ => 0
           | ParseNonTerminal _ _ p' => S (size_of_parse p')
         end.

    Section bodies.
      Context (size_of_parse : forall {str pats} (p : parse_of G str pats), nat)
              (size_of_parse_production : forall {str pat} (p : parse_of_production G str pat), nat).

      Definition size_of_parse_step {str pats} (p : parse_of G str pats) : nat
        := match p with
             | ParseHead _ _ p' => S (@size_of_parse_production _ _ p')
             | ParseTail _ _ p' => S (@size_of_parse _ _ p')
           end.

      Definition size_of_parse_production_step {str pat} (p : parse_of_production G str pat) : nat
        := match p with
             | ParseProductionNil _ => 0
             | ParseProductionCons _ _ _ p' p''
               => S (size_of_parse_item' (@size_of_parse) p' + @size_of_parse_production _ _ p'')
           end.

      Global Arguments size_of_parse_step _ _ !_ / .
      Global Arguments size_of_parse_production_step _ _ !_ / .
    End bodies.

    Fixpoint size_of_parse {str pats} (p : parse_of G str pats) : nat
      := @size_of_parse_step (@size_of_parse) (@size_of_parse_production) str pats p
    with size_of_parse_production {str pat} (p : parse_of_production G str pat) : nat
         := @size_of_parse_production_step (@size_of_parse) (@size_of_parse_production) str pat p.

    Definition size_of_parse_item
               {str it} (p : parse_of_item G str it) : nat
      := @size_of_parse_item' (@size_of_parse) str it p.
  End size.

  Definition parse_of_lt {str pats} : relation (parse_of G str pats)
    := ltof _ size_of_parse.
  Definition parse_of_production_lt {str pat} : relation (parse_of_production G str pat)
    := ltof _ size_of_parse_production.
  Definition parse_of_item_lt {str it} : relation (parse_of_item G str it)
    := ltof _ size_of_parse_item.

  Definition parse_of_wf {str pats} : well_founded (@parse_of_lt str pats)
    := well_founded_ltof _ _.
  Definition parse_of_production_wf {str pat} : well_founded (@parse_of_production_lt str pat)
    := well_founded_ltof _ _.
  Definition parse_of_item_wf {str it} : well_founded (@parse_of_item_lt str it)
    := well_founded_ltof _ _.
End rel.

Ltac simpl_size_of_parse :=
  repeat match goal with
           | [ |- appcontext[@size_of_parse ?Char ?HSLM ?HSL ?G ?str ?pat ?p] ]
             => change (@size_of_parse Char HSLM HSL G str pat p)
                with (@size_of_parse_step Char HSLM HSL G (@size_of_parse Char HSLM HSL G) (@size_of_parse_production Char HSLM HSL G) str pat p);
               simpl @size_of_parse_step
           | [ |- appcontext[@size_of_parse_production ?Char ?HSLM ?HSL ?G ?str ?pat ?p] ]
             => change (@size_of_parse_production Char HSLM HSL G str pat p)
                with (@size_of_parse_production_step Char HSLM HSL G (@size_of_parse Char HSLM HSL G) (@size_of_parse_production Char HSLM HSL G) str pat p);
               simpl @size_of_parse_production_step
         end.