From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Export nondet_bool.
From iris_examples.proph Require Import eager_coin_spec.
From iris.prelude Require Import options.

(* Lazy implementation of the eager specification. The value of the coin is
unknown at the time of the creation of the coin. As a consequence, we rely on
a prophecy variable. *)

Definition new_lazy_coin : val :=
  λ: <>, (ref NONE, NewProph).

Definition read_lazy_coin : val :=
  λ: "cp",
  let: "c" := Fst "cp" in
  let: "p" := Snd "cp" in
  match: !"c" with
    NONE => let: "r" := nondet_bool #() in
           "c" <- SOME "r";; resolve_proph: "p" to: "r";; "r"
  | SOME "b" => "b"
  end.

Section proof.
  Context `{!heapGS Σ}.

  Definition val_to_bool (v : val) : bool := bool_decide (v = #true).

  Definition prophecy_to_bool (vs : list (val * val)) : bool :=
    default false (val_to_bool ∘ snd <$> head vs).

  Lemma prophecy_to_bool_of_bool (b : bool) v vs :
    prophecy_to_bool ((v, #b) :: vs) = b.
  Proof. by destruct b. Qed.

  Definition lazy_coin (cp : val) (b : bool) : iProp Σ :=
    (∃ (c : loc) (p : proph_id) (vs : list (val * val)),
        ⌜cp = (#c, #p)%V⌝ ∗ proph p vs ∗
        (c ↦ SOMEV #b ∨ (c ↦ NONEV ∗ ⌜b = prophecy_to_bool vs⌝)))%I.

  Lemma lazy_coin_exclusive (cp : val) (b1 b2 : bool) :
    lazy_coin cp b1 -∗ lazy_coin cp b2 -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct "H1" as (c1 p1 vs1) "(-> & Hp1 & _)".
    iDestruct "H2" as (c2 p2 vs2) "(% & Hp2 & _)".
    simplify_eq. iApply (proph_exclusive with "Hp1 Hp2").
  Qed.

  Lemma new_lazy_coin_spec :
    {{{ True }}}
      new_lazy_coin #()
    {{{ c b, RET c; lazy_coin c b }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam.
    wp_apply wp_new_proph; first done.
    iIntros (vs p) "Hp".
    wp_alloc c as "Hc".
    wp_pair.
    iApply ("HΦ" $! (#c, #p)%V ).
    rewrite /lazy_coin; eauto 10 with iFrame.
  Qed.

  Lemma read_lazy_coin_spec cp b :
    {{{ lazy_coin cp b }}}
      read_lazy_coin cp
    {{{ RET #b; lazy_coin cp b }}}.
  Proof.
    iIntros (Φ) "Hc HΦ".
    iDestruct "Hc" as (c p vs ->) "[Hp [Hc | [Hc ->]]]".
    - wp_lam. wp_load. wp_match.
      iApply "HΦ".
      rewrite /lazy_coin; eauto 10 with iFrame.
    - wp_lam. wp_load. wp_match.
      wp_apply nondet_bool_spec; first done.
      iIntros (r) "_".
      wp_let.
      wp_store.
      wp_apply (wp_resolve_proph with "[Hp]"); first done.
      iIntros (ws) "[-> Hws]".
      rewrite !prophecy_to_bool_of_bool.
      wp_seq.
      iApply "HΦ".
      rewrite /lazy_coin; eauto 10 with iFrame.
  Qed.

End proof.

Definition lazy_coin_spec_instance `{!heapGS Σ} :
  eager_coin_spec.eager_coin_spec Σ :=
  {| eager_coin_spec.new_coin_spec := new_lazy_coin_spec;
     eager_coin_spec.read_coin_spec := read_lazy_coin_spec;
     eager_coin_spec.coin_exclusive := lazy_coin_exclusive |}.

Typeclasses Opaque lazy_coin.


Require Import HoTT HoTT_axioms.
From Coq Require Import ssreflect.

Set Universe Polymorphism.

Class IsFun {A B} (R : A -> B -> Type) :=
  isFun : forall x, IsContr {y:B & R x y} .

Hint Mode IsFun - - ! : typeclass_instances.

Definition sym {A B} (R : A -> B -> Type) := fun b a => R a b.

Typeclasses Opaque sym.

Class IsWeakEquiv {A B} (R : A -> B -> Type) :=
  { isWFun :> IsFun R;
    isWFunSym :> IsFun (sym R) }.

Arguments isFun {_ _ _} _.
Arguments isWFun {_ _ _} _.
Arguments isWFunSym {_ _ _} _.

Definition funR {A B R} : IsFun R -> A -> B := fun H x => (isFun H x).1.1.

Definition center {A B} {R : A -> B -> Type} (F : IsFun R) :
  forall x, R x (funR F x) := fun x => (F x).1.2.

Definition IsFunIsHProp A B (R : A -> B -> Type) : IsHProp (IsFun R).
Proof.
by apply: IsTrunc_Forall => [|?]; [apply: funext|apply: IsHPropIsContr].
Defined.

Definition IsFunSymIsHProp A B (R : A -> B -> Type) : IsHProp (IsFun (sym R)) :=
  IsFunIsHProp B A (sym R).

Instance IsWeakEquiv_sym A B (R : A -> B -> Type) :
  forall (f : IsWeakEquiv R), IsWeakEquiv (sym R).
Proof. by move=> Rwe; split; [apply: isWFunSym|apply isWFun]. Defined.

Definition IsWeakEquiv_IsEquiv A B (R : A -> B -> Type) :
  forall (f : IsWeakEquiv R), IsEquiv (funR (isWFun f)).
Proof.
move=> [f g]; apply: (isequiv_adjointify _ (funR g)) => [x|y] /=.
  exact: (((g (funR f x)).2 (x;(center f) x))..1).
exact: (((f (funR g y)).2 (y;(center g) y))..1).
Defined.

Definition IsFunRf A B (f : A -> B) : IsFun (fun a b => f a = b).
Proof.
move=> a; exists (f a;eq_refl) => - [b b_fa].
by apply: path_sigma_uncurried; exists b_fa; apply: transport_paths_r.
Defined.

Definition IsFunRfsymIsWeakEquiv A B (f : A -> B) :
  IsFun (sym (fun a b => f a = b)) -> IsWeakEquiv (fun a b => f a = b).
Proof. by move=> ?; split=> //; apply: IsFunRf. Defined.

Definition IsFun_sym A A' (R R': A -> A' -> Type) :
  (forall a a', R a a' ≃ R' a a') -> IsFun R -> IsFun R'.
Proof.
move=> ReR' FR x; set R'xFx := ReR' _ _ (center FR x).
exists (funR FR x;R'xFx) => - [y R'xy].
apply: path_sigma_uncurried; have Fxy := ((FR x).2 (y; e_inv' (ReR' _ _) R'xy)).
exists (Fxy..1); have /= := (Fxy..2); move: (Fxy..1) => /= {Fxy} Fxy.
by case: _ / Fxy R'xy => /= ??; apply: Move_equiv_equiv.
Defined.

Class Rel A B := rel : A -> B -> Type.

Hint Mode Rel ! ! : typeclass_instances.
Typeclasses Transparent Rel.

Arguments rel {_ _ _} _ _.

Notation "x ≈ y" := (rel x y) (at level 20).

Class FR_Type A B :=
  { _Rel :> Rel A B;
    _REquiv:> IsWeakEquiv (@rel _ _ _Rel);
  }.

Infix "⋈" := FR_Type (at level 25).

Arguments _Rel {_ _} _.
Arguments _REquiv {_ _} _.
Typeclasses Transparent _Rel.

(*! Universe !*)

Instance FR_Type_def@{i j} : Rel@{j j j} Type@{i} Type@{i} :=
 FR_Type@{i i i i i}.

Hint Extern 0 (?x ≈ ?y) => eassumption : typeclass_instances.

Hint Extern 0 (_Rel _ _ _) => eassumption : typeclass_instances.

Definition FRForall {A A'} {B : A -> Type} {B' : A' -> Type} (RA : Rel A A')
          (RB: forall x y (H: x ≈ y), Rel (B x) (B' y)) :
  Rel (forall x, B x) (forall y, B' y)
  :=
  fun f g => forall x y (H:x ≈ y), f x ≈ g y.

Definition IsFun_id A : IsFun (fun a a' : A => a = a').
Proof. exact: IsFun_sym (fun _ _ => Equiv_id _) (IsFunRf _ _ id). Defined.

Definition FR_Type_id A: FR_Type_def A A.
Proof.
suff : IsWeakEquiv (fun a b : A => a = b) by apply: Build_FR_Type.
split; first exact: IsFun_id.
move=> a; exists (a;eq_refl : sym _ a a) => - [b b_a].
by apply: path_sigma_uncurried; exists b_a^; case: b_a.
Defined.

Instance FP_Type : Type ⋈ Type.
Proof.
  econstructor. unfold rel. unshelve econstructor.
  intro A. unshelve econstructor.
  exists A. apply FR_Type_id.
  intros [B e]. apply path_sigma_uncurried. unshelve eexists.
  cbn. apply univalence.
  unshelve econstructor.
  exact (funR (e.(_REquiv).(isWFun))). apply IsWeakEquiv_IsEquiv.
  cbn. cheat.
  intro A. unshelve econstructor.
  exists A. apply FR_Type_id.
  intros [B e]. apply path_sigma_uncurried. unshelve eexists.
  cbn. apply univalence.
  unshelve econstructor.
  exact (funR (e.(_REquiv).(isWFunSym))).
  unfold sym in e.
  apply (IsWeakEquiv_IsEquiv _ _ _ (IsWeakEquiv_sym _ _ _ (_REquiv e))).
  cbn.
  cheat.
Defined.

Definition IsFun_forall (A A' : Type)
           (B : A -> Type) (B' : A' -> Type)
           (RA : Rel A A')
           (RB: forall x y (H: x ≈ y), Rel (B x) (B' y))
           (eAsym : IsFun (sym RA))
           (eB : forall a a' e, IsFun (RB a a' e)):
  IsFun (FRForall RA RB).
Proof.
  intro f.
  unshelve econstructor.
  - unshelve eexists.
    + intros x. apply ((funR (eB ((funR eAsym) x) x (center eAsym x))) (f (funR eAsym x))).
    + intros a a' ea. cbn.
      pose (e := (eAsym a').2 (a ; ea)).
      apply (transport_eq (fun X => (RB a a' ea) (f a)
                                                  (((eB X .1 a' X .2) (f X .1)).1) .1) e^).
        exact (center (eB a a' ea) (f a)).
  - intros [g efg]. cbn in *. eapply path_sigma_uncurried.
    unshelve eexists. cbn. apply funext.
    + intros a'.
        exact ((((eB (funR eAsym a') a' (center eAsym a')) (f (funR eAsym a'))).2 (g a'; efg _ a' _))..1).
    + cbn. unfold FRForall.
      rewrite transport_forall_cst.
      apply funext; intro a; apply funext; intro a'; apply funext ; intro e. unfold rel in eB.
      rewrite (transport_funext_aux (fun y0 y  =>
                                       forall (e0 : RA a y0), (RB a y0 e0) (f a) y)).
        rewrite transport_forall_cst.
        set (T := (RB a a' e) (f a)).
        rewrite <- (transport_ap T ((fun X : {y : A & sym RA a' y} =>
                                       (((eB X .1 a' X .2)(f X .1)) .1) .1))).
        rewrite <- transport_pp.
        unfold center, funR, isFun.
        set (isContrT := (eB a a' e) (f a)).
        destruct ((eAsym a') .2 (a; e))^. cbn.
        change (transport_eq T (isContrT .2 (g a'; efg a a' e) ..1)
                             (isContrT .1) .2 = efg a a' e).
        apply transport_pr1_path.
Defined.

Hint Extern 1 (Rel (forall x:?A, _) (forall x:?A', _)) =>
  refine (@FRForall A A' _ _ _ _); cbn in *; intros : typeclass_instances.

Definition Forall_sym_sym
           {A A'} {B : A -> Type} {B' : A' -> Type} (RA : Rel A A')
           (RB: forall x y (H: x ≈ y), Rel (B x) (B' y)) :
  forall f g, FRForall RA RB f g ≃ sym (FRForall (sym RA) (fun x y e => sym (RB y x e))) f g.
Proof.
  intros. unshelve econstructor; cbn.
  compute; intros; auto.
  unshelve econstructor.
  - compute; intros; auto.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Defined.

Definition FP_forall (A A' : Type) (eA : A ⋈ A')
           (B : A -> Type) (B' : A' -> Type) (eB : B ≈ B') :
  (forall x : A, B x) ⋈ (forall x : A', B' x).
Proof.
  unshelve econstructor.
  unshelve eapply FRForall.
  intros. eapply eB. typeclasses eauto.
  split.
  apply IsFun_forall; typeclasses eauto.
  eapply IsFun_sym. eapply Forall_sym_sym.
  apply IsFun_forall. destruct eA. destruct _REquiv0. assumption.
  intros. destruct (eB a' a e). destruct _REquiv0. assumption.
Defined.

Inductive list (A : Type) : Type :=
    nil : list A | cons : A -> list A -> list A.

Arguments nil {_}.
Arguments cons {_} _ _.

Notation "[ ]" := nil (format "[ ]").
Notation "[ x ]" := (cons x nil).
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)).

Infix "::" := cons (at level 60, right associativity).

Inductive listR {A B} (R : A -> B -> Type) : list A -> list B -> Type :=
  listR_nil : listR R nil nil
| listR_cons : forall {a b l l'},
    (R a b) -> (listR R l l') -> listR R (a::l) (b::l').

Definition transport_listR_cons A B (RA : A -> B -> Type)
           (a :A) b b' (l: list A ) (lb lb':list B) (h:b=b') (e:lb=lb')
  (E: RA a b) (E': listR RA l lb):
   transport_eq
    (fun Y => listR RA (a::l) Y)
    (ap2 cons h e) (listR_cons _ E E')  =
  listR_cons RA (transport_eq (fun X => RA _ X) h E)
                (transport_eq (fun X : list B => listR RA l X) e E').
  destruct h, e. reflexivity.
Defined.

Definition IsFun_list (A A' : Type) (RA : A -> A' -> Type)
           (FA : IsFun RA) : IsFun (listR RA).
Proof.
  intro l. unshelve econstructor.
  - unshelve eexists.
    + exact (list_rec A (fun _ => list A') []
                      (fun a _ l' => cons (funR FA a) l') l).
    + induction l.
      * exact (listR_nil _).
      * eapply listR_cons; try assumption. apply center.
  - intros [l' ell'].
    induction ell'; cbn.
    + reflexivity.
    + apply path_sigma_uncurried. unshelve eexists; cbn in *.
      * apply ap2. exact (((FA a).2 (b ;r))..1). exact (IHell'..1).
      * rewrite transport_listR_cons. apply ap2.
        exact (((FA a).2 (b ;r))..2).
        exact (IHell'..2).
Defined.

Definition listR_sym_sym A A' (R : A -> A' -> Type) :
  forall l l', listR R l l' ≃ sym (listR (sym R)) l l'.
Proof.
  intros l l'. unshelve econstructor.
  induction 1; constructor; assumption.
  unshelve eapply isequiv_adjointify.
  - induction 1; constructor; assumption.
  - intro e; induction e; cbn. reflexivity.
    apply ap2; try reflexivity; assumption.
  - intro e; induction e; cbn. reflexivity.
    apply ap2; try reflexivity; assumption.
Defined.

Definition FP_list (A A' : Type) (eA : A ⋈ A'):
  list A ⋈ list A'.
Proof.
  unshelve econstructor.
  exact (listR (_Rel eA)).
  split.
  apply IsFun_list; typeclasses eauto.
  eapply IsFun_sym. eapply listR_sym_sym.
  apply IsFun_list. destruct eA. destruct _REquiv0.
  exact isWFunSym0.
Defined.


Require Import SquiggleEq.varInterface.
Require Import SquiggleEq.UsefulTypes.

Section VarPair.

Context {Var T2 vc} {deqnvar : Deq Var} {varcl freshv}
{varclass: @VarType Var vc deqnvar varcl freshv} {deqt2 : Deq T2} (def: T2).

Notation NVar := (Var * T2)%type.

Instance varClassNVar : VarClass NVar vc :=
fun p => varClass (fst p).

Require  Import SquiggleEq.list.
Require  Import Coq.Lists.List.

Instance freshVarsNVar : FreshVars NVar vc:=
fun (n:nat)
  (c : option vc) (avoid suggested : list NVar)
=>
  let vars := freshVars n c (map fst avoid) (map fst suggested) in
  let names := listPad def (map snd suggested) n in
  combine vars names.

Require Import SquiggleEq.tactics.

Lemma freshVarsPosCorrect:
forall (n : nat) (oc : option vc) (avoid original : list NVar),
let lf := freshVarsNVar n oc avoid original in
(NoDup lf /\ list.disjoint lf avoid /\ Datatypes.length lf = n) /\
(forall c : vc, oc = Some c -> forall v : NVar, In v lf -> varClassNVar v = c).
Proof.
  simpl. intros ? ? ? ?. unfold freshVarsNVar.
  addFreshVarsSpec. repnd.
  dands.
- apply (nodup_map fst).
  rewrite <- combine_map_fst2; auto.
  rewrite HfreshVars0. apply listPad_length.
- intros Hl. apply (disjoint_map fst).
  rewrite <- combine_map_fst2; auto.
  rewrite HfreshVars0. apply listPad_length.
- unfold  freshVarsNVar. setoid_rewrite combine_length.
  rewrite HfreshVars0.
  apply Min.min_l. apply listPad_length.
- intros ? ? ? Hin. destruct v.
  apply in_combine in Hin. apply proj1 in Hin.
  eapply HfreshVars in Hin; eauto.
Qed.

Instance vartypePos : VarType NVar vc.
  apply Build_VarType.
  exact freshVarsPosCorrect.
Defined.

End VarPair.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2005-12-05

substitutions
*)

Set Implicit Arguments.

From Coq Require Import Relations.
From CoLoR Require Import LogicUtil VTerm.

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig). Notation terms := (list term).

  Definition substitution := variable -> term.

  Fixpoint sub (s : substitution) (t : term) : term :=
    match t with
    | Var x => s x
    | Fun f ts => Fun f (map (sub s) ts)
    end.

  Lemma sub_fun : forall s f ts, sub s (Fun f ts) = Fun f (map (sub s) ts).

  Proof. refl. Qed.

  Section properties.

    Variable succ : relation term.

    Definition substitution_closed :=
      forall t1 t2 s, succ t1 t2 -> succ (sub s t1) (sub s t2).

  End properties.

End S.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Coq.Unicode.Utf8.

Local Open Scope program_scope.

Require Import FinProof.Common.
Require Import FinProof.ProgrammingWith.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.

Local Open Scope record.

Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolSpec.

(* Module SML (xt: XTypesSig) (sm: StateMonadSig). *)

Module DePoolSpec := DePoolSpec XTypesSig StateMonadSig.
Import DePoolSpec.
Import LedgerClass.
Import SolidityNotations.

Require Import ZArith.
Local Open Scope Z_scope.

Compute (xIntPlus 0%Z 1%Z).

(* Import xt. Import sm. *)

Local Open Scope solidity_scope.
Local Open Scope string_scope.

Inductive LedgerFunction : Type -> Type :=
 | LedgerFunction0: forall X, LedgerFunction (LedgerT X)
 | LedgerFunction_Next: forall X Y, LedgerFunction Y -> LedgerFunction (X -> Y).

(*  Notation "◯" := (LedgerFunction0) (at level 100).
 Notation " a ⇉ b " := (LedgerFunction1 a b) (at level 100, right associativity).

Check ◯ nat.
Check  nat ⇉ ◯ nat.
Check  nat ⇉ nat ⇉ ◯ nat. *)

Inductive SolidityExpression : Type -> Type :=
| SolidityScalar : forall {X}, LedgerT X -> SolidityExpression X
| SolidityState : forall {X U} {m: Ledger -> U}`{Accessor Ledger U m}`{EmbeddedType Ledger U} (f: U -> X)`{Accessor U X f} ,  SolidityExpression X
| SolidityField : forall {S U}`{Struct S} (f:S->U)`{Accessor _ _ f}, SolidityExpression S -> SolidityExpression U
| SolidityIndex : forall {K V}`{XBoolEquable XBool K}`{XDefault V}, SolidityExpression K -> SolidityExpression (XHMap K V) -> SolidityExpression V
| SolidityPlus : SolidityExpression XInteger -> SolidityExpression XInteger -> SolidityExpression XInteger
| SolidityIfElse : forall {X},  SolidityExpression XBool -> SolidityExpression X -> SolidityExpression X -> SolidityExpression X
| SolidityIf : forall {X},  SolidityExpression XBool -> SolidityExpression X -> SolidityExpression True
(* | SolidityFunction: forall {X B}`{Ledgerable X B}, X -> SolidityExpression B *)
(* | SolidityFunctionCall: forall {X A B}`{Ledgerable X (A -> B)}, X -> SolidityExpression A -> SolidityExpression B
 *).

Notation " # e " := (SolidityScalar e) (at level 100).
Notation " 'μ' e " := (SolidityState e) (at level 100).
Notation " r ^^ f " := (SolidityField f r) (at level 100).
Notation " m [[ i ]] " := (SolidityIndex i m) (at level 100).

Definition sReader {X} (e : SolidityExpression X): LedgerT X.
Proof.
    induction e.
    - refine l.
    - refine (↑ (ε f)).
    - refine (do r' ← IHe;
             $ (f r')).
    - refine (
        do k' ← IHe1;
        do m' ← IHe2;
        $ ( m' [ k' ] )
    ) .
    - refine (
        do x' ← IHe1;
        do y' ← IHe2;
        $ ( xIntPlus x' y' )
    ) .
    - refine (
        do b' ← IHe1;
        do x' ← IHe2;
        do y' ← IHe3;
        $ ( xBoolIfElse b' x' y' )
    ) .
    - refine (
        do b' ← IHe1;
        xBoolIf b' ( IHe2 >> $I )
    ) .
Defined.

 Class Ledgerable (X: Type) :=
 {
     ledgerable : LedgerFunction X ;
     ledgerFirstType : Type ;
     ledgerTailType : Type ;
     ledgerJoin : LedgerT X -> X ;
     sApply : X -> SolidityExpression ledgerFirstType -> ledgerTailType
 }.

 Notation " 'α' " := (sApply ) (at level 100).

 Instance LedgerT_Ledgerable {X} : Ledgerable (LedgerT X) := {
    ledgerable := LedgerFunction0 X ;
    ledgerFirstType := True ;
    ledgerTailType :=  SolidityExpression X ;
    ledgerJoin := fun mx => mx >>= Datatypes.id ;
    (*sApply : X -> ledgerFirstType -> ledgerTailType*)
    sApply := fun f _ => SolidityScalar f
 }.

 Instance LedgerTNext_Ledgerable {X Y}`{Ledgerable Y} :
                      Ledgerable (X -> Y) := {
    ledgerable := LedgerFunction_Next X Y ledgerable ;
    (* toLedgerBaseType := fun (f: X -> Y) => inject (fun (x: X) => toLedgerBaseType (f x))  *)
    ledgerFirstType := X ;
    ledgerTailType := Y ;
    (* LedgerT (X -> Y) -> X -> Y *)
    ledgerJoin := fun (mf: LedgerT (X -> Y)) => fun x => ledgerJoin (mf >>= fun f => return! (f x)) ;
    (*sApply : X -> ledgerFirstType -> ledgerTailType*)
    sApply := fun (f : X -> Y) (sx: SolidityExpression X) => ledgerJoin (sReader sx >>= fun x => return! (f x))
 }.

(* Check ledgerable (X:=nat -> nat -> LedgerT nat).
Compute ledgerFirstType (X:=nat -> nat -> LedgerT nat).
Compute ledgerTailType (X:=nat -> nat -> LedgerT nat).
Compute ledgerFirstType (X:= LedgerT nat).
Compute ledgerTailType (X:= LedgerT nat). *)

Fixpoint ledgerableDegree {X} (a: LedgerFunction X) : nat :=
    match a with
    | LedgerFunction0 _ => 0
    | LedgerFunction_Next _ _ f => S (ledgerableDegree f)
    end.

(* Check SolidityScalar ($ xInt0).
Check SolidityState DePoolContract_ι_m_association.
Check SolidityField contractAddress (SolidityScalar ($ default)).
Check SolidityIndex (SolidityScalar ($xInt0)) (SolidityScalar ($xHMapEmpty)). *)
(* Check SolidityFunction (fun x: nat => return! x : LedgerT nat).
Check SolidityFunction (fun (x: Z) (y: Z) => return! (x + y) : LedgerT Z).
Check SolidityFunction (fun (x: Z) (y: Z) => (x + y) : Z).
Check SolidityFunction (return! 0 : LedgerT Z). *)

(* Notation " 'ϕ' f " := (SolidityFunction f) (at level 100).*)

Check #$xInt0.
Check μ DePoolContract_ι_m_association.
Check (#$default) ^^ contractAddress.
Check (#$xHMapEmpty) [[ #$xInt0 ]].
Check (#$xHMapEmpty) [[ #$xInt0 ]] ^^ contractAddress.
Check (#$xHMapEmpty) [[ μ DePoolContract_ι_m_association ]] ^^ contractAddress.
Check @SolidityState.
Check α.

Existing Instance monadStateT.
Existing Instance monadStateStateT.

Check (α (fun (x y: XInteger) => $ (xIntPlus x y ) : LedgerT XInteger) (#$xInt2)) (* : XInteger -> LedgerT XInteger *).
Let a := (α (fun (x y: XInteger) => $ (xIntPlus x y ) : LedgerT XInteger) (#$xInt2)) : XInteger -> LedgerT XInteger.
Let b := α a (#$xInt100).
Check b :LedgerT XInteger.

Lemma foo1:  eval_state b default  = 102 .
Proof.
    compute.
    auto.
Qed.

(* Check (ϕ (fun (x y: XInteger) => $ (xIntPlus x y ) : LedgerT XInteger)).
Check  (ϕ (fun (x: XInteger) => (↑2 U1! ValidatorBase_ι_m_validatorWallet := $ x) : LedgerT True)).
 *)
Let g := sReader (α (α (fun (x: XInteger) => (↑2 U1! ValidatorBase_ι_m_validatorWallet := $ x): LedgerT True) (#$xInt2)) (#$I)).

Lemma foo2: eval_state (↑2 D2! ValidatorBase_ι_m_validatorWallet) (exec_state g default) = 2.
Proof.
    compute.
    auto.
Qed.

Definition sWriter {X} (e : SolidityExpression X) (v : LedgerT X): LedgerT True.
Proof.
    intros.
    induction e. exact ($I).

    refine (do v' ← v;
    modify (fun r => {$ r with m := {$ (r ->> m) with f := v' $} $} ) >> $ I).

    refine (do v' ← v;
    do o ← sReader e;
    IHe ($ {$ o with f := v' $} )
    ).

    refine (do v' ← v;
    do k' ← sReader e1;
    do m' ← sReader e2;
    IHe2 ($  (m' [k'] ← v') )
    ).

    exact ($I).
    exact ($I).
    exact ($I).
Defined.

Definition sAssign {X} (el er : SolidityExpression X) :=
    sWriter el (sReader er).

Check sAssign (μ DePoolContract_ι_m_association) (#$xInt0).
Check sAssign ((μ RoundsBase_ι_m_rounds) [[ μ DePoolContract_ι_m_association  ]] ^^ RoundsBase_ι_Round_ι_id )
              ((#$xHMapEmpty) [[ μ DePoolContract_ι_m_association ]] ^^ contractAddress).

Notation " a ':=' b " :=  ( sAssign a b ) (at level 100).

Check ((μ RoundsBase_ι_m_rounds) [[ μ DePoolContract_ι_m_association  ]] ^^ RoundsBase_ι_Round_ι_id ) :=
              ((#$xHMapEmpty) [[ μ DePoolContract_ι_m_association ]] ^^ contractAddress).

Notation " a ':=' b ; t" :=  ( let a :=  sReader b in t) (at level 100).

Check a :=  ((#$xHMapEmpty) [[ μ DePoolContract_ι_m_association ]] ^^ contractAddress) ; a.

Check b.
Check a := #b; a.

End SML.


Require Import ssreflect ssrbool ssrnat eqtype seq fintype.
Require Import procstate procstatemonad tuple bitsops bitsprops bitsopsprops.
Require Import SPred septac spec safe basic basicprog program macros.
Require Import instr instrsyntax instrcodec instrrules reader pointsto cursor.
Require Import Setoid RelationClasses Morphisms CSetoid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope instr_scope.

Section LanguageDefinitions.
  Inductive var := xa | xb | xc.

  Inductive expr :=
    evar (x: var)
  | eliteral (value: DWORD)
  | esubtract (x y: var)
  | elessthan (x y: var).

  Inductive cmd :=
    Cassign (x: var) (e: expr)
  | Cseq (C1 C2: cmd)
  | Cwhile (e: expr) (C: cmd)
  | Cif (e: expr) (C1 C2: cmd).

  Definition varEq x y :=
    match x, y with
    | xa, xa => true
    | xb, xb => true
    | xc, xc => true
    | _ , _ => false
    end.

  Lemma var_eqP: Equality.axiom varEq.
  Proof.
    move=> x y. case: x; case: y; by constructor.
  Qed.

  Canonical var_eqMixin := EqMixin var_eqP.
  Canonical var_eqType := Eval hnf in EqType _ var_eqMixin.

End LanguageDefinitions.

Section Compiler.
  Definition var_reg v : Reg :=
    match v with xa => EAX | xb => EBX | xc => ECX end.

  (* Puts the result in EDX *)
  Definition compile_expr e : program :=
    match e with
    | evar x => MOV EDX, (var_reg x)
    | eliteral v => MOV EDX, v
    | esubtract x1 x2 =>
        let r1 := var_reg x1 in
        let r2 := var_reg x2 in
        MOV EDX, r1;;
        SUB EDX, r2
    | elessthan x1 x2 =>
        if x1 == x2 then
          (* this special case is my coward's way out of proving a general rule
             for CMP. *)
          (MOV EDX, 0): program
        else
          let r1 := var_reg x1 in
          let r2 := var_reg x2 in
          (* The tricky bit is to move the carry flag into a register *)
          CMP r1, r2;;
          MOV EDX, 0;;
          ADC EDX, 0
    end.

  Definition compile_condition (e: expr) : program :=
    compile_expr e;; TEST EDX, EDX.

  Fixpoint compile_cmd (C: cmd) : program :=
    match C with
    | Cassign dst e => compile_expr e;; MOV (var_reg dst), EDX
    | Cseq C1 C2 => prog_seq (compile_cmd C1) (compile_cmd C2)
    | Cwhile e C =>
        while (compile_condition e) CC_Z false (
          compile_cmd C
        )
    | Cif e C1 C2 =>
        compile_condition e;;
        ifthenelse CC_Z false (
          compile_cmd C1
        ) (
          compile_cmd C2
        )
    end.
End Compiler.

Section LogicDefinitions.
  Definition stack := var -> DWORD.

  Instance stackEquiv : Equiv stack := {
     equiv s1 s2 := forall n, s1 n = s2 n
  }.

  Instance stackType : type stack.
  Proof.
    split.
    move => s n; reflexivity.
    move => s1 s2 Hs n; specialize (Hs n); symmetry; assumption.
    move => s1 s2 s3 H12 H23 n; specialize (H12 n); specialize (H23 n).
    transitivity (s2 n); assumption.
  Qed.

  Definition asn := ILFunFrm stack Prop.

  Local Existing Instance ILFun_Ops.
  Local Existing Instance ILFun_ILogic.

  Global Instance asn_ops : ILogicOps asn := _.
  Global Instance asn_logic : ILogic asn := _.

  Definition mkAsn (P : stack -> Prop) := mkILFunFrm stack Prop P.
  Global Implicit Arguments mkAsn [].

  Definition stack_denot (s: stack) :=
    EAX ~= s xa ** EBX ~= s xb ** ECX ~= s xc.

  Definition asn_denot (P: asn) : SPred :=
    Exists s, P s /\\ stack_denot s.

  (* The high-level triple for the imp language. It lives in the low-level spec
     logic, which is maybe not really appropriate, but it works. *)
  Definition triple (P: asn) (C: cmd) (Q: asn) : spec :=
    basic (asn_denot P) (compile_cmd C) (asn_denot Q) @ (EDX? ** OSZCP?).

  (* Expression evaluation *)
  Definition eeval (e: expr) (s: stack) : DWORD :=
    match e with
    | evar x => s x
    | eliteral v => v
    | esubtract x1 x2 => subB (s x1) (s x2)
    | elessthan x1 x2 => if ltB (s x1) (s x2) then #1 else #0
    end.

  (* A substitution in its most general form maps variable names to
     expressions. *)
  Definition substitution := var -> expr.

  (* This is the substitution that replaces x with e and leaves all other
     variables unchanged. *)
  Definition subst1 e x : substitution :=
    fun y => if y == x then e else evar y.

  (* Apply a substitution to a stack *)
  Definition stack_subst (f: substitution) (s: stack) : stack :=
    fun x => eeval (f x) s.

  (* Apply a substitution to an assertion or an evaluated expression *)

   Definition subst {A} (f: substitution) (E: stack -> A) : stack -> A :=
    fun s => E (stack_subst f s).

   Require Import FunctionalExtensionality.

   Program Definition asn_subst (f : substitution) (E : stack -> Prop) : asn:=
     mkAsn (subst f E) _.
   Next Obligation.
     assert (subst f E t = subst f E t').
     apply f_equal; apply functional_extensionality; apply H.
     rewrite <- H1; assumption.
   Qed.

End LogicDefinitions.

Notation "E [ e // x ]" := (subst (subst1 e x) E)
  (at level 7, left associativity, format "E [ e  //  x ]").

Section LogicLemmas.
  (* It's possible to pull out one stack variable, change it, and then get back
     a state corresponding to a substitution on the original stack. *)
  Lemma var_assign_subst x e s:
    stack_denot s |-- var_reg x ~= s x **
      (var_reg x ~= eeval e s -* stack_denot (stack_subst (subst1 e x) s)).
  Proof.
    rewrite /stack_denot. rewrite /stack_subst /subst1.
    case: x => /=; ssimpl; apply wandSPAdj; by ssimpl.
  Qed.

  (* Read-only version of the above *)
  Lemma regs_read_var x s:
    stack_denot s |-- var_reg x ~= s x **
      (var_reg x ~= s x -* stack_denot s).
  Proof.
    rewrite /stack_denot.
    case: x => /=; ssimpl; apply: wandSPAdj; by ssimpl.
  Qed.

  (* Terrible hack *)
  Lemma regs_read_vars x y s:
    y <> x ->
    stack_denot s |-- var_reg x ~= s x ** var_reg y ~= s y **
                     (var_reg x ~= s x ** var_reg y ~= s y -* stack_denot s).
  Proof.
    rewrite /stack_denot.
    case: x; case: y => //= _; ssimpl; apply wandSPAdj; by ssimpl.
  Qed.

  Lemma sepSPwand P Q:
    P ** (P -* Q) |-- Q.
  Proof. rewrite sepSPC. exact: sepSPAdj. Qed.

  Lemma lt_irreflexive x: (x < x) = false.
  Proof. by elim: x. Qed.

  Lemma leBltB_neg {n} (x y: BITS n): ltB x y = ~~leB y x.
  Proof. by rewrite ltB_nat leB_nat ltnNge. Qed.

  Lemma compile_expr_correct s e:
    |-- basic EDX? (compile_expr e) (EDX ~= eeval e s)
        @ (stack_denot s ** OSZCP?).
  Proof.
    autorewrite with push_at. case: e.
    - move=> x.
      eapply basic_basic; first apply MOV_RanyR_rule.
      - rewrite ->regs_read_var. by ssimpl.
      rewrite /eeval. ssimpl. exact: sepSPwand.
    - move=> value.
      eapply basic_basic; first apply MOV_RanyI_rule; reflexivity.
    - move=> x y.
      eapply basic_seq.
      - eapply basic_basic; first apply MOV_RanyR_rule.
        + rewrite ->regs_read_var. by ssimpl.
        done.
      eapply basic_basic; first apply SUB_RR_rule.
      - ssimpl. rewrite ->sepSPwand. rewrite ->regs_read_var. by ssimpl.
      elim E: (sbbB false (s x) (s y)) => [carry res].
      rewrite /OSZCP /stateIsAny. sbazooka.
      rewrite sepSPA. rewrite ->sepSPwand. cancel2. rewrite /eeval.
      by rewrite E/snd.
    - move=> x y. rewrite /compile_expr.
      case Hxy: (x == y).
      - move/eqP: Hxy => <-.
        eapply basic_basic; first apply MOV_RanyI_rule.
        - reflexivity.
        rewrite /eeval. rewrite ltB_nat.
        rewrite lt_irreflexive. reflexivity.
      elim E: (sbbB false (s x) (s y)) => [carry res].
      eapply basic_seq.
      - eapply basic_basic; first apply CMP_RR_rule.
        + rewrite ->regs_read_vars. by ssimpl.
        + by move/eqP: Hxy.
        reflexivity.
      eapply basic_seq.
      - eapply basic_basic; first apply MOV_RanyI_rule.
        + ssimpl. reflexivity.
        reflexivity.
      elim E': (adcB carry (#0: DWORD) #0) => [carry' res'].
      eapply basic_basic; first apply ADC_RI_rule.
      - eassumption.
      - rewrite E /natAsDWORD/fst/snd. by ssimpl.
      rewrite [X in X ** (_ -* _)]sepSPC. rewrite ->sepSPwand.
      rewrite /OSZCP /stateIsAny. sbazooka.
      rewrite /eeval.
      have Hless := sbbB_ltB_leB (s x) (s y).
      rewrite E /fst in Hless.
      destruct carry.
      - rewrite Hless.
        rewrite /adcB in E'.
        rewrite adcBmain_nat in E'.
        rewrite splitmsb_fromNat in E'.
        rewrite toNat_fromNat0 in E'.
        rewrite [X in #(X)]/= in E'. rewrite !addn0 in E'.
        rewrite /nat_of_bool in E'. by injection E' => -> _.
      - rewrite leBltB_neg Hless.
        rewrite /adcB adcBmain_nat in E'.
        rewrite splitmsb_fromNat in E'.
        rewrite toNat_fromNat0 in E'.
        rewrite [X in #(X)]/= in E'. rewrite !addn0 in E'.
        rewrite /nat_of_bool in E'. rewrite [~~true]/=. cbv iota. by injection E' => -> _.
  Qed.

  Lemma compile_condition_correct s e:
    |-- basic (EDX? ** OSZCP?) (compile_condition e)
              (EDX? ** ZF ~= (eeval e s == zero _) **
               OF? ** SF? ** CF? ** PF?)
          @ (stack_denot s).
  Proof.
    rewrite /compile_condition. autorewrite with push_at.
    apply: basic_seq. have He := (@compile_expr_correct s e).
    autorewrite with push_at in He.
    eapply (basic_basic_context (T:=program)); first apply He.
    - done.
    - by ssimpl.
    - reflexivity.
    eapply basic_basic; first apply TEST_self_rule.
    - by ssimpl.
    rewrite /stateIsAny /OSZCP. sbazooka; reflexivity.
  Qed.
End LogicLemmas.

Section LogicRules.
  Theorem triple_assign (Q : asn) e x S:
    S |-- triple (asn_subst (subst1 e x) Q) (Cassign x e) Q.
  Proof.
    rewrite /triple /=. autorewrite with push_at. rewrite {1}/asn_denot.
    specintros => s Hsubst.
    eapply basic_seq.
    - have He := (@compile_expr_correct s e).
      autorewrite with push_at in He. eapply (basic_basic_context (T:=program)).
      - apply He.
      - done.
      - by ssimpl.
      reflexivity.
    - eapply basic_basic; first apply MOV_RanyR_rule.
      - rewrite ->var_assign_subst with (e:=e) (x:=x).
        rewrite /stack_denot. ssimpl. rewrite {6}/stateIsAny. sbazooka.
      rewrite /stateIsAny. sbazooka. rewrite /asn_denot /stack_denot.
      rewrite ->sepSPwand. ssplits; first apply Hsubst. by sbazooka.
  Qed.

  Local Instance asn_denot_entails:
    Proper (lentails ++> lentails) asn_denot.
  Proof.
    move=> P P' HPP'. rewrite /asn_denot.
    sdestructs => s HP. ssplits; last reflexivity.
    specialize (HPP' s HP). assumption.
  Qed.

  Theorem triple_roc P' Q' S P C Q:
    P |-- P' ->
    Q' |-- Q ->
    S |-- triple P' C Q' ->
    S |-- triple P C Q.
  Proof. rewrite /triple. move=> HP HQ HS. by rewrite ->HP, <-HQ. Qed.

  Theorem triple_exists A S f C Q:
    (forall a:A, S |-- triple (f a) C Q) ->
    S |-- triple (lexists f) C Q.
  Proof.
    rewrite /triple. move=> H. rewrite /asn_denot. autorewrite with push_at.
    specintros => s [a Ha]. specialize (H a). autorewrite with push_at in H.
    eapply basic_roc_pre; last apply H.
    rewrite /asn_denot. by sbazooka.
  Qed.

  Theorem triple_seq Q S P R C1 C2:
    S |-- triple P C1 Q ->
    S |-- triple Q C2 R ->
    S |-- triple P (Cseq C1 C2) R.
  Proof.
    rewrite /triple. autorewrite with push_at.
    move=> H1 H2. simpl compile_cmd.
    eapply basic_seq; rewrite -/compile_cmd -/interpProgram.
    - apply H1.
    - apply H2.
  Qed.

  Program Definition blurb e b := mkAsn (fun s => (eeval e s == zero _) = b) _.
  Next Obligation.
    assert (eeval e t = eeval e t').
    apply f_equal; apply functional_extensionality; apply H.
    rewrite H0. reflexivity.
  Qed.

  Theorem triple_while S (P : asn) e C:
    S |-- triple (blurb e false //\\ P) C P ->
    S |-- triple P (Cwhile e C) ((blurb e true) //\\ P).
  Proof.
    rewrite /triple. autorewrite with push_at. move=> HC. simpl compile_cmd.
    set (I := fun b:bool =>
      asn_denot ((blurb e b) //\\ P) **
      EDX? ** OF? ** SF? ** CF? ** PF?).
    eapply basic_roc_post; first last; first apply (while_rule (I:=I)).
    - rewrite /asn_denot. specintros => s HP.
      have He := (@compile_condition_correct s e).
      autorewrite with push_at in He.
      eapply (basic_basic_context (T:=program)); first apply He.
      + done.
      + by ssimpl.
      rewrite /I /asn_denot /ConditionIs. by sbazooka.
    - eapply basic_roc_pre; last apply HC.
      rewrite /I /ConditionIs /stateIsAny. by sbazooka.
    - rewrite /I /ConditionIs /stateIsAny /negb. by sbazooka.
  Qed.

  Theorem triple_if S P e C1 C2 Q:
    S |-- triple ((blurb e false) //\\ P) C1 Q ->
    S |-- triple ((blurb e true) //\\ P) C2 Q ->
    S |-- triple P (Cif e C1 C2) Q.
  Proof.
    rewrite /triple. autorewrite with push_at. move=> HC1 HC2 /=.
    rewrite [_ P]/asn_denot. specintros => s HP.
    apply: basic_seq.
    - have He := (@compile_condition_correct s e).
      autorewrite with push_at in He.
      eapply (basic_basic_context (T:=program)); first apply He.
      + done.
      + by ssimpl.
      reflexivity.
    set (I := fun b:bool =>
      asn_denot ((blurb e b) //\\ P) **
      EDX? ** OF? ** SF? ** CF? ** PF?).
    apply: basic_roc_pre; last apply (if_rule (P:=I)).
    - rewrite /I /asn_denot /ConditionIs. by sbazooka.
    - eapply basic_roc_pre; last apply HC1.
      rewrite /I /ConditionIs /stateIsAny. by sbazooka.
    - eapply basic_roc_pre; last apply HC2.
      rewrite /I /ConditionIs /stateIsAny /negb. by sbazooka.
  Qed.

  Local Transparent ILFun_Ops.
  Lemma subst_true_special_case (e : expr) (x: var): |-- (asn_subst (subst1 e x) (ltrue:asn)).
  Proof. move=> s _. apply I. Qed.

End LogicRules.


Add LoadPath "/home/mads/Downloads/sf/".
Require Export Basics.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
      | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert(x=v) as H by reflexivity;
    clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
      set (x := name); move_to_top x
    | assert_eq x name; move_to_top x
    | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

Theorem andb_true_elim1: forall b c : bool, andb b c = true -> b = true.
Proof.
  intros b c.
  intros H.
  destruct b.
  Case "b = true".
  reflexivity.
  Case "b = false".
  rewrite <- H.
  reflexivity.
 Qed.

Theorem andb_true_elim2 : forall b c : bool, andb b c = true -> c = true.
Proof.
intros b c.
intros H.
destruct c.
Case "c = true".
reflexivity.
Case "c = false".
rewrite <- H.
destruct b.
reflexivity.
reflexivity.
Qed.


(*
  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.