1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE

/machines/1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB/1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB.v · raw
(* 1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB never halts.
   A binary counter fed at its left end.  The tape is read as a word of
   units D0 = 0000, D1 = 1000, P = 11000, S1 = 01000, SP = 011000 and
   W = 111000; one walk of B to the right and C back is one carry (Inc).
   Walls (SP, W) are rotors: a W fires on every second carry, sends three
   carries up and moves one unit right.  A periodic nursery at the left
   edge feeds walls into a conveyor; at the right end they are absorbed
   into a zone driven by a closed counter system.
   Template: none applies (the nearest, verify/CounterCmp_v1.v Module TM1,
   differs in 11 of 12 transitions); the shape follows Example.v's counter
   pattern (unit lemmas with the arrival on the rest as an argument).
   Structure:
   - unit lemmas by execution with the arrival on the rest as an argument
     (arr_Z, arr_D1, arr_P, arr_W), Theorem U (inc_arr: Inc w w' gives
     the arrival on the cells of w);
   - window runs of the nursery with the rest of the tape opaque and
     touched only by the W rule (wrun, wrun_spec, window), the initial
     segment of 203,465 steps (init), and the reduction nonhalt_of_abs;
   - carry library (IncN, digit counters, the wall rotor wall_feed,
     Lemma C1), the closed zone system (cs_step) with a verified
     executable step (csf_sound) and its run to the canonical state C(0);
   - upward flow for a prefix whose shifts stay inside it (IncX_flow);
   - the zone engine: carries through a cut (XN) with a verified bulk
     feed (xfeed), clean words as counters (XN_clean), one closed-system
     step through a cut (cutstep, the locality step of Lemma L), and
     affine families of states (fam, fz) with a verified runner
     (fstep_sound, frun_sound);
   - Theorem B pieces proved by family runs: the small classes
     nu2(b + 2) <= 40 (small_classes), the endgame with cut 12
     (endgame), the nested range 11 <= v <= 50 (nested), together
     E(K) for nu2(K + 9) <= 50 (E_low);
   - one closed-system step with a concrete low part and an arbitrary
     counter word above the cut (astep), and Lemma VF: one descent step
     of a value form, symbolic in Omega, off and the marker height
     (vs_gen, checked on 12 entry rows and 256 x 5 phase classes), and
     the descent at level 1 (VF1) and level 2 (VF2);
   - Lemma E (E1, E2, E3, LemmaE) and the plant, Lemma P (P12 .. P16,
     LemmaP, P_id), by hand on closed forms; the class recursion E(K)
     by well-founded induction (EK), Theorem B for every canonical state
     (thmB), and the closed system runs forever (zone_forever), with its
     orbit unique (cs_step_det, CSreach_det, CS_next);
   - the conveyor: walls with birth data and absolute positions, the
     bracket of Lemma T (bracket), the word above a position as a
     relation (WdR, with the zone of the current interval at the top),
     one carry through it (cascade: a wall in state SP turns to W, a W
     fires and moves up, or the top wall is absorbed exactly at the
     least fixed point of the closed system), the record invariant
     (RInv, RInv_step, RInv_U0), AbsDefined and nonhalt.
   Informal proof: the accompanying write-up (proof.md).
   Formalized with Claude Code (AI-assisted).
   Checked: compiles against unmodified busycoq BB6 (commit 0940bb9) with Coq 8.20.1;
   Print Assumptions nonhalt: Closed under the global context *)

From BusyCoq Require Import Individual62.
Require Import Lia String List Arith.
From Coq Require Import PArith NArith ZArith.
Import ListNotations.

Definition tm := Eval compute in (TM_from_str "1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB").

Notation "c --> c'" := (c -[ tm ]-> c')   (at level 40).
Notation "c -->* c'" := (c -[ tm ]->* c') (at level 40).
Notation "c -->+ c'" := (c -[ tm ]->+ c') (at level 40).

(* ===================================================================== *)
(* 1. Arrivals on sides: one carry entering a side in state B and        *)
(*    coming back in state C.                                            *)
(* ===================================================================== *)

Definition ArrS (r r' : side) : Prop := forall l, l {{B}}> r -->* l <{{C}} r'.

(* first cell 0: B0 -> 1LC *)
Lemma arr_Z r : ArrS (0 >> r) (1 >> r).
Proof. intros l. execute. Qed.

(* D1: B> 1000 r --> 1111 B> r ~> 1111 <C r' --> <C 0000 r' *)
Lemma arr_D1 r r' : ArrS r r' -> ArrS ([1;0;0;0] *> r) ([0;0;0;0] *> r').
Proof.
  intros H l. cbn [Str_app].
  do 4 step. follow H. execute.
Qed.

(* P: B> 11000 r --> 10111 B> r ~> 10111 <C r' --> <C 11000 r' *)
Lemma arr_P r r' : ArrS r r' -> ArrS ([1;1;0;0;0] *> r) ([1;1;0;0;0] *> r').
Proof.
  intros H l. cbn [Str_app].
  do 5 step. follow H. execute.
Qed.

(* W: B> 111000 r --> 100111 B> r ~> 100111 <C r1 --> 000111 B> r1 ~> ...
      --> 101111 B> r2 ~> 101111 <C r3 --> <C 110000 r3 *)
Lemma arr_W r r1 r2 r3 : ArrS r r1 -> ArrS r1 r2 -> ArrS r2 r3 ->
  ArrS ([1;1;1;0;0;0] *> r) ([1;1;0;0;0;0] *> r3).
Proof.
  intros H1 H2 H3 l. cbn [Str_app].
  do 6 step. follow H1.
  do 11 step. follow H2.
  do 11 step. follow H3.
  execute.
Qed.

(* ===================================================================== *)
(* 2. Units and unit words; one carry (Inc); Theorem U (arrival = Inc).  *)
(* ===================================================================== *)

Inductive unt := uD0 | uD1 | uP | uS1 | uSP | uW.

Definition ucells (u : unt) : list Sym :=
  match u with
  | uD0 => [0;0;0;0]
  | uD1 => [1;0;0;0]
  | uP  => [1;1;0;0;0]
  | uS1 => [0;1;0;0;0]
  | uSP => [0;1;1;0;0;0]
  | uW  => [1;1;1;0;0;0]
  end.

Fixpoint enc (w : list unt) : list Sym :=
  match w with
  | [] => []
  | u :: w' => ucells u ++ enc w'
  end.

Definition Rs (w : list unt) : side := enc w *> const 0.

Lemma Rs_cons u w : Rs (u :: w) = ucells u *> Rs w.
Proof. unfold Rs. cbn [enc]. apply Str_app_assoc. Qed.

Lemma enc_app a b : enc (a ++ b) = enc a ++ enc b.
Proof. induction a as [|u a IH]; cbn; [reflexivity|]. rewrite IH, app_assoc. reflexivity. Qed.

Lemma Rs_app a b : Rs (a ++ b) = enc a *> Rs b.
Proof. unfold Rs. rewrite enc_app. apply Str_app_assoc. Qed.

(* The shift: one extra 0 cell, re-read as units.  It passes D0 units and
   prepends 0 to the head of the first other unit; on S1, SP or W it is a
   hit, which is not a unit word. *)
Fixpoint shift (w : list unt) : option (list unt) :=
  match w with
  | [] => Some []
  | uD0 :: w' =>
      match shift w' with
      | Some w'' => Some (uD0 :: w'')
      | None => None
      end
  | uD1 :: w' => Some (uS1 :: w')
  | uP :: w' => Some (uSP :: w')
  | _ => None
  end.

Lemma shift_spec w w' : shift w = Some w' -> 0 >> Rs w = Rs w'.
Proof.
  revert w'; induction w as [|u w IH]; intros w' H; cbn in H.
  - inversion H; subst. unfold Rs. cbn. symmetry. apply const_unfold.
  - destruct u; try discriminate.
    + destruct (shift w) as [w''|] eqn:E; [|discriminate].
      inversion H; subst. rewrite !Rs_cons. rewrite <- (IH w'' eq_refl). reflexivity.
    + inversion H; subst. rewrite !Rs_cons. reflexivity.
    + inversion H; subst. rewrite !Rs_cons. reflexivity.
Qed.

(* One carry entering a unit word at its left end. *)
Inductive Inc : list unt -> list unt -> Prop :=
| Inc_nil : Inc [] [uD1]
| Inc_D0 w : Inc (uD0 :: w) (uD1 :: w)
| Inc_S1 w : Inc (uS1 :: w) (uP :: w)
| Inc_SP w : Inc (uSP :: w) (uW :: w)
| Inc_D1 w w' : Inc w w' -> Inc (uD1 :: w) (uD0 :: w')
| Inc_P w w' : Inc w w' -> Inc (uP :: w) (uP :: w')
| Inc_W w w1 w2 w3 w4 : Inc w w1 -> Inc w1 w2 -> Inc w2 w3 -> shift w3 = Some w4 ->
    Inc (uW :: w) (uP :: w4).

(* Theorem U *)
Theorem inc_arr w w' : Inc w w' -> ArrS (Rs w) (Rs w').
Proof.
  induction 1.
  - assert (E1 : Rs [] = 0 >> const 0) by (unfold Rs; cbn; apply const_unfold).
    assert (E2 : Rs [uD1] = 1 >> const 0).
    { unfold Rs. cbn. f_equal. rewrite <- !const_unfold. reflexivity. }
    rewrite E1, E2. apply arr_Z.
  - rewrite !Rs_cons. apply arr_Z.
  - rewrite !Rs_cons. apply arr_Z.
  - rewrite !Rs_cons. apply arr_Z.
  - rewrite !Rs_cons. apply arr_D1; auto.
  - rewrite !Rs_cons. apply arr_P; auto.
  - rewrite !Rs_cons. rewrite <- (shift_spec _ _ H2).
    change ([1;1;0;0;0] *> 0 >> Rs w3) with ([1;1;0;0;0;0] *> Rs w3).
    eapply arr_W; eauto.
Qed.

Lemma Inc_det w a b : Inc w a -> Inc w b -> a = b.
Proof.
  intros H; revert b; induction H; intros b Hb; inversion Hb; subst; auto.
  - f_equal; auto.
  - f_equal; auto.
  - assert (w1 = w5) by auto; subst.
    assert (w2 = w6) by auto; subst.
    assert (w3 = w7) by auto; subst.
    congruence.
Qed.

(* three carries, then the first unit is P and is removed (a pop) *)
Definition Inc3Pop (U U' : list unt) : Prop :=
  exists a b, Inc U a /\ Inc a b /\ Inc b (uP :: U').

Fixpoint Pops (k : nat) (U U' : list unt) : Prop :=
  match k with
  | O => U = U'
  | S k' => exists U1, Inc3Pop U U1 /\ Pops k' U1 U'
  end.

(* ===================================================================== *)
(* 3. Window runs: the machine on a finite window, with the rest of the  *)
(*    tape an opaque unit word touched only by the W rule (Inc3Pop).     *)
(* ===================================================================== *)

(* (left cells nearest first, head symbol, right cells, state); the left
   cells are followed by 0^inf, the right cells by the opaque side X. *)
Definition lcfg : Type := (list Sym * Sym * list Sym * Q)%type.

Definition lc (X : side) (c : lcfg) : Q * tape :=
  match c with (l, m, r, q) => (q, (l *> const 0, m, r *> X)) end.

(* one step; the flag is true when the head leaves the window to the left *)
Definition lstep (c : lcfg) : option (lcfg * bool) :=
  match c with
  | (l, m, r, q) =>
      match tm (q, m) with
      | None => None
      | Some (s, L, q') =>
          match l with
          | [] => Some (([], 0, s :: r, q'), true)
          | x :: l' => Some ((l', x, s :: r, q'), false)
          end
      | Some (s, R, q') =>
          match r with
          | [] => None
          | x :: r' => Some ((s :: l, x, r', q'), false)
          end
      end
  end.

Lemma lstep_spec X c c' b : lstep c = Some (c', b) -> lc X c --> lc X c'.
Proof.
  destruct c as [[[l m] r] q]. unfold lstep.
  destruct (tm (q, m)) as [[[s d] q']|] eqn:E; [|discriminate].
  destruct d.
  - destruct l as [|x l']; intros H; inversion H; subst.
    + apply (step_left (l := const 0) (r := r *> X) E).
    + apply (step_left (l := x >> l' *> const 0) (r := r *> X) E).
  - destruct r as [|x r']; intros H; inversion H; subst.
    apply (step_right (l := l *> const 0) (r := x >> r' *> X) E).
Qed.

(* the W rule applies: state B on 1, the window ends with 1 1 0 0 0 *)
Definition wready (c : lcfg) : bool :=
  match c with
  | (_, S1, S1 :: S1 :: S0 :: S0 :: S0 :: [], B) => true
  | _ => false
  end.

Definition wpop (c : lcfg) : lcfg :=
  match c with
  | (l, _, _, _) =>
      match l with
      | [] => ([], 0, [1;1;0;0;0;0;1;1;0;0;0], C)
      | x :: l' => (l', x, [1;1;0;0;0;0;1;1;0;0;0], C)
      end
  end.

Lemma wpop_spec c U U' : wready c = true -> Inc3Pop U U' ->
  lc (Rs U) c -->* lc (Rs U') (wpop c).
Proof.
  intros Hw [a [b [H1 [H2 H3]]]].
  destruct c as [[[l m] r] q].
  assert (HW := arr_W _ _ _ _ (inc_arr _ _ H1) (inc_arr _ _ H2) (inc_arr _ _ H3) (l *> const 0)).
  unfold wready in Hw.
  destruct m; [discriminate|].
  destruct r as [|[|] [|[|] [|[|] [|[|] [|[|] [|]]]]]]; try discriminate.
  destruct q; try discriminate.
  rewrite Rs_cons in HW.
  destruct l as [|x l']; exact HW.
Qed.

Fixpoint wrun (fuel : nat) (c : lcfg) : option (lcfg * nat) :=
  match fuel with
  | O => None
  | S f =>
      if wready c then
        match wrun f (wpop c) with
        | Some (c', k) => Some (c', S k)
        | None => None
        end
      else
        match lstep c with
        | None => None
        | Some (c', true) => Some (c', O)
        | Some (c', false) => wrun f c'
        end
  end.

Lemma wrun_spec f c c' k : wrun f c = Some (c', k) ->
  forall U U', Pops k U U' -> lc (Rs U) c -->+ lc (Rs U') c'.
Proof.
  revert c c' k; induction f as [|f IH]; intros c c' k H U U' HP; [discriminate|].
  cbn in H.
  destruct (wready c) eqn:Ew.
  - destruct (wrun f (wpop c)) as [[c1 k1]|] eqn:E1; [|discriminate].
    inversion H; subst. destruct HP as [U1 [HU1 HP1]].
    eapply evstep_progress_trans.
    + apply (wpop_spec c U U1 Ew HU1).
    + eapply IH; eauto.
  - destruct (lstep c) as [[c1 [|]]|] eqn:E1; [| |discriminate].
    + inversion H; subst. cbn in HP; subst.
      apply progress_base. eapply lstep_spec; eauto.
    + eapply progress_step.
      * eapply lstep_spec; eauto.
      * eapply IH; eauto.
Qed.

(* ===================================================================== *)
(* 4. The nursery: 8 record types and their window runs (Lemma N).       *)
(* ===================================================================== *)

Inductive rt := XC | XD | XE | YC | YD | YE | ZD | ZE.

Definition rq (t : rt) : Q :=
  match t with
  | XC | YC => C
  | XD | YD | ZD => D
  | XE | YE | ZE => E
  end.

(* the gadget: the first three 1-runs after the head cell and 3 cells *)
Definition rg (t : rt) : list Sym :=
  match t with
  | XC => [1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0]
  | XD => [1;1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0]
  | XE => [1;1;1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0;0; 1;1; 0;0;0]
  | YC => [1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0]
  | YD => [1;1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0]
  | YE => [1;1;1;1;0;1;1;1;1; 0;0;0;0; 1;1; 0;0;0]
  | ZD => [1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0; 1;1;1; 0;0;0]
  | ZE => [1;1;1;1;1;1; 0;0;0;0; 1;1; 0;0;0; 1;1;1; 0;0;0]
  end.

Definition rnext (t : rt) : rt :=
  match t with
  | XC => XD | XD => XE | XE => YC | YC => YD
  | YD => YE | YE => ZD | ZD => ZE | ZE => XC
  end.

(* W-rule uses (pops) of each window run *)
Definition rk (t : rt) : nat :=
  match t with XE => 3 | YE => 12 | ZE => 2 | _ => 0 end.

(* the new walls put in front of the unit word *)
Definition rF (t : rt) : list unt :=
  match t with
  | XE => [uW; uW; uP; uSP]
  | YE => [uW; uP; uW; uP; uP; uSP; uP; uP; uP; uP; uSP]
  | ZE => [uP; uSP]
  | _ => []
  end.

(* the configuration at a left record: 0^inf <q G U 0^inf *)
Definition rcfg (t : rt) (U : list unt) : Q * tape :=
  const 0 <{{rq t}} rg t *> Rs U.

Lemma window_gen t U U' :
  wrun 4000 ([], 0, rg t, rq t) = Some (([], 0, rg (rnext t) ++ enc (rF t), rq (rnext t)), rk t) ->
  Pops (rk t) U U' -> rcfg t U -->+ rcfg (rnext t) (rF t ++ U').
Proof.
  intros H HP.
  pose proof (wrun_spec _ _ _ _ H U U' HP) as G.
  unfold rcfg. rewrite Rs_app, <- Str_app_assoc.
  exact G.
Qed.

Lemma window t U U' : Pops (rk t) U U' -> rcfg t U -->+ rcfg (rnext t) (rF t ++ U').
Proof.
  apply window_gen. destruct t; vm_compute; reflexivity.
Qed.

(* ===================================================================== *)
(* 5. The initial segment: 203,465 steps to the first X record.          *)
(* ===================================================================== *)

Definition U0 : list unt :=
  [uP; uSP; uP; uW; uP; uP; uP; uSP; uP; uP; uP; uP; uW;
   uP; uP; uP; uP; uP; uP; uP; uW;
   uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uP; uW;
   uP; uP; uP; uP; uP; uP; uP; uP; uP; uP;
   uD0; uD0; uD1; uD1; uD1; uD1].

Lemma init : c0 -->* rcfg XC U0.
Proof.
  change (rcfg XC U0) with (cconfig_to_config ([], rg XC ++ enc U0, 0, C)).
  rewrite c0_to_cconfig.
  apply cconfig_evstep_dec_spec with (n := 1000000).
  vm_compute. reflexivity.
Qed.

(* ===================================================================== *)
(* 6. Reduction to the unit-word dynamics.                               *)
(* ===================================================================== *)

Inductive Reach : rt -> list unt -> Prop :=
| Reach0 : Reach XC U0
| ReachS t U U' : Reach t U -> Pops (rk t) U U' -> Reach (rnext t) (rF t ++ U').

Definition AbsDefined : Prop := forall t U, Reach t U -> exists U', Pops (rk t) U U'.

Lemma nonhalt_of_abs : AbsDefined -> ~ halts tm c0.
Proof.
  intros H.
  eapply multistep_nonhalt; [apply init|].
  apply (progress_nonhalt_cond tm (rt * list unt) (XC, U0)
           (fun p => rcfg (fst p) (snd p)) (fun p => Reach (fst p) (snd p))).
  - intros [t U] HR. cbn in HR. destruct (H t U HR) as [U' HP].
    exists (rnext t, rF t ++ U'). split.
    + apply window; auto.
    + econstructor; eauto.
  - constructor.
Qed.

(* ===================================================================== *)
(* 7. Carry library: n carries (IncN), P transparency, digit counters,   *)
(*    Lemma C1.                                                          *)
(* ===================================================================== *)

Inductive IncN : nat -> list unt -> list unt -> Prop :=
| IncN_0 w : IncN 0 w w
| IncN_S n w w1 w2 : Inc w w1 -> IncN n w1 w2 -> IncN (S n) w w2.

Lemma IncN_1 w w' : Inc w w' -> IncN 1 w w'.
Proof. intros H. econstructor; eauto. constructor. Qed.

Lemma IncN_1_inv w w' : IncN 1 w w' -> Inc w w'.
Proof. intros H. inversion H as [|n w0 w1 w2 Hi Hn]; subst. inversion Hn; subst. auto. Qed.

Lemma IncN_add a b w w1 w2 : IncN a w w1 -> IncN b w1 w2 -> IncN (a + b) w w2.
Proof. induction 1; intros; cbn; auto. econstructor; eauto. Qed.

Lemma IncN_split a b w w2 : IncN (a + b) w w2 -> exists w1, IncN a w w1 /\ IncN b w1 w2.
Proof.
  revert w; induction a as [|a IH]; intros w H; cbn in H.
  - exists w. split; [constructor|auto].
  - inversion H as [|n' w' wa wb Hi Hn]; subst. destruct (IH _ Hn) as [w3 [H5 H6]].
    exists w3. split; auto. econstructor; eauto.
Qed.

Lemma IncN_det n w a b : IncN n w a -> IncN n w b -> a = b.
Proof.
  intros H; revert b; induction H as [|n w w1 w2 Hi Hn IH]; intros b Hb;
    inversion Hb as [|n' w' wa wb Hi' Hn']; subst; auto.
  assert (w1 = wa) by (eapply Inc_det; eauto). subst. auto.
Qed.

Lemma IncN_snoc n w w1 w2 : IncN n w w1 -> Inc w1 w2 -> IncN (S n) w w2.
Proof.
  intros H1 H2. replace (S n) with (n + 1) by lia.
  eapply IncN_add; eauto. apply IncN_1; auto.
Qed.

(* P is transparent *)
Lemma IncN_P n w w' : IncN n w w' -> IncN n (uP :: w) (uP :: w').
Proof. induction 1; econstructor; eauto. constructor; auto. Qed.

Lemma IncN_P_inv n w x : IncN n (uP :: w) x -> exists w', x = uP :: w' /\ IncN n w w'.
Proof.
  revert w; induction n as [|n IH]; intros w H; inversion H; subst.
  - exists w; split; [auto|constructor].
  - match goal with Hi : Inc (uP :: w) ?y, Hn : IncN n ?y x |- _ =>
      inversion Hi; subst; destruct (IH _ Hn) as [w'' [E H']]; subst end.
    eexists. split; [reflexivity|]. econstructor; eauto.
Qed.

Fixpoint Ps (a : nat) : list unt := match a with O => [] | S a' => uP :: Ps a' end.

Lemma IncN_Ps a n w w' : IncN n w w' -> IncN n (Ps a ++ w) (Ps a ++ w').
Proof. induction a; cbn; auto. intros H. apply IncN_P; auto. Qed.

(* one digit: t carries on a digit b pass (b + t) / 2 carries up *)
Definition dig (b : nat) : unt := if Nat.eqb (Nat.modulo b 2) O then uD0 else uD1.
Definition dval (u : unt) : nat := match u with uD1 => 1 | _ => 0 end.
Definition isdig (u : unt) : bool := match u with uD0 | uD1 => true | _ => false end.

Lemma IncN_digit t u w w' : isdig u = true -> IncN ((dval u + t) / 2) w w' ->
  IncN t (u :: w) (dig (dval u + t) :: w').
Proof.
  revert u w w'. induction t as [t IH] using lt_wf_ind. intros u w w' Hu H.
  destruct t as [|[|t]].
  - destruct u; try discriminate; cbn in *; inversion H; subst; constructor.
  - destruct u; try discriminate; cbn in *.
    + inversion H; subst. apply IncN_1. constructor.
    + apply IncN_1. apply IncN_1_inv in H. constructor; auto.
  - (* two carries first *)
    destruct u; try discriminate.
    + (* D0: D0 -> D1 -> D0 + one carry *)
      replace ((dval uD0 + S (S t)) / 2) with (1 + (dval uD0 + t) / 2) in H.
      2:{ cbn [dval]. rewrite !Nat.add_0_l. replace (S (S t)) with (t + 1 * 2)%nat by lia.
          rewrite Nat.div_add by lia. lia. }
      destruct (IncN_split _ _ _ _ H) as [w1 [H1 H2]].
      apply IncN_1_inv in H1.
      replace (S (S t)) with (2 + t) by lia.
      eapply IncN_add.
      * econstructor; [constructor|]. econstructor; [constructor; eauto|]. constructor.
      * replace (dig (dval uD0 + (2 + t))) with (dig (dval uD0 + t)).
        { apply IH; try lia; auto. }
        unfold dig. cbn [dval]. f_equal.
        replace (O + (2 + t))%nat with (t + 1 * 2)%nat by lia. rewrite Nat.Div0.mod_add. reflexivity.
    + (* D1: D1 -> D0 + carry -> D1 *)
      replace ((dval uD1 + S (S t)) / 2) with (1 + (dval uD1 + t) / 2) in H.
      2:{ cbn [dval]. replace (1 + S (S t))%nat with ((1 + t) + 1 * 2)%nat by lia.
          rewrite Nat.div_add by lia. lia. }
      destruct (IncN_split _ _ _ _ H) as [w1 [H1 H2]].
      apply IncN_1_inv in H1.
      replace (S (S t)) with (2 + t) by lia.
      eapply IncN_add.
      * econstructor; [constructor; eauto|]. econstructor; [constructor|]. constructor.
      * replace (dig (dval uD1 + (2 + t))) with (dig (dval uD1 + t)).
        { apply IH; try lia; auto. }
        unfold dig. cbn [dval]. f_equal.
        replace (1 + (2 + t))%nat with ((1 + t) + 1 * 2)%nat by lia. rewrite Nat.Div0.mod_add. reflexivity.
Qed.

(* walls: SP (state 0, absorbs the next carry) and W (state 1, fires) *)
Definition wallu (b : bool) : unt := if b then uW else uSP.

Lemma Inc_SP_W r : Inc (uSP :: r) (uW :: r).
Proof. constructor. Qed.

(* a firing: three carries on the rest, then the shift lands on its first unit, a P *)
Lemma Inc_W_fire r r' : Inc3Pop r r' -> Inc (uW :: r) (uP :: uSP :: r').
Proof.
  intros [a [b [H1 [H2 H3]]]]. eapply Inc_W; eauto.
Qed.

Lemma Pops_add a b U U1 U2 : Pops a U U1 -> Pops b U1 U2 -> Pops (a + b) U U2.
Proof.
  revert U; induction a as [|a IH]; intros U H1 H2; cbn in *.
  - subst; auto.
  - destruct H1 as [V [HV H1]]. exists V. split; [auto|eapply IH; eauto].
Qed.

Lemma Pops_split a b U U2 : Pops (a + b) U U2 -> exists U1, Pops a U U1 /\ Pops b U1 U2.
Proof.
  revert U; induction a as [|a IH]; intros U H; cbn in *.
  - exists U. split; auto.
  - destruct H as [V [HV H]]. destruct (IH _ H) as [U1 [H1 H2]].
    exists U1. split; auto. exists V. auto.
Qed.

(* the rotor: t carries on a wall in state b fire it (t + b) / 2 times *)
Lemma wall_feed t (b : bool) r r' :
  Pops ((t + Nat.b2n b) / 2) r r' ->
  IncN t (wallu b :: r) (Ps ((t + Nat.b2n b) / 2) ++ wallu (Nat.odd (t + Nat.b2n b)) :: r').
Proof.
  revert b r r'. induction t as [t IH] using lt_wf_ind. intros b r r' H.
  destruct b.
  - (* W *)
    destruct t as [|t].
    + cbn in *. subst. constructor.
    + replace ((S t + Nat.b2n true) / 2) with (1 + (t + Nat.b2n false) / 2) in *.
      2:{ cbn [Nat.b2n]. replace (S t + 1) with (t + 0 + 1 * 2) by lia.
          rewrite Nat.div_add by lia. lia. }
      destruct (Pops_split _ _ _ _ H) as [r1 [H1 H2]].
      cbn in H1. destruct H1 as [V [HV E]]. subst V.
      econstructor.
      * apply Inc_W_fire. eauto.
      * assert (E : forall x y, Ps (1 + x) ++ y = uP :: (Ps x ++ y)) by reflexivity.
        rewrite E. apply IncN_P.
        replace (Nat.odd (S t + Nat.b2n true)) with (Nat.odd (t + Nat.b2n false)).
        { exact (IH t ltac:(lia) false r1 r' H2). }
        cbn [Nat.b2n]. replace (S t + 1) with (S (S (t + 0))) by lia.
        rewrite Nat.odd_succ_succ. reflexivity.
  - (* SP *)
    destruct t as [|t].
    + cbn in *. subst. constructor.
    + replace ((S t + Nat.b2n false) / 2) with ((t + Nat.b2n true) / 2) in *.
      2:{ cbn [Nat.b2n]. f_equal. lia. }
      econstructor.
      * apply Inc_SP_W.
      * replace (Nat.odd (S t + Nat.b2n false)) with (Nat.odd (t + Nat.b2n true)).
        { apply (IH t ltac:(lia) true). auto. }
        cbn [Nat.b2n]. f_equal. lia.
Qed.

(* Lemma C1: three carries turn a first unit P, S1, SP or W into P *)
Lemma C1 u r x : In u [uP; uS1; uSP; uW] -> IncN 3 (u :: r) x -> exists x', x = uP :: x'.
Proof.
  intros Hu H.
  destruct Hu as [<-|[<-|[<-|[<-|[]]]]].
  - apply IncN_P_inv in H. destruct H as [w' [E _]]. eauto.
  - inversion H as [|n w w1 w2 Hi Hn]; subst. inversion Hi; subst.
    apply IncN_P_inv in Hn. destruct Hn as [w' [E _]]. eauto.
  - inversion H as [|n w w1 w2 Hi Hn]; subst. inversion Hi; subst.
    inversion Hn as [|n' w' wa wb Hi' Hn']; subst. inversion Hi'; subst.
    apply IncN_P_inv in Hn'. destruct Hn' as [w'' [E _]]. eauto.
  - inversion H as [|n w w1 w2 Hi Hn]; subst. inversion Hi; subst.
    apply IncN_P_inv in Hn. destruct Hn as [w' [E _]]. eauto.
Qed.

(* r binary digits of v, least significant first *)
Fixpoint digits (r v : nat) : list unt :=
  match r with
  | O => []
  | S r' => dig v :: digits r' (v / 2)
  end.

Lemma dval_dig v : dval (dig v) = v mod 2.
Proof.
  unfold dig. destruct (Nat.eqb_spec (v mod 2) 0) as [E|E]; cbn [dval]; [lia|].
  pose proof (Nat.mod_upper_bound v 2). lia.
Qed.

Lemma isdig_dig v : isdig (dig v) = true.
Proof. unfold dig. destruct (Nat.eqb (v mod 2) 0); reflexivity. Qed.

Lemma dig_mod v : dig (v mod 2) = dig v.
Proof. unfold dig. rewrite Nat.Div0.mod_mod. reflexivity. Qed.

(* t carries on an r-digit counter pass ((v mod 2^r) + t) / 2^r carries up *)
Lemma IncN_digits r v t rest rest' :
  IncN ((v mod 2 ^ r + t) / 2 ^ r) rest rest' ->
  IncN t (digits r v ++ rest) (digits r (v + t) ++ rest').
Proof.
  revert v t. induction r as [|r IH]; intros v t H.
  - cbn [digits app]. replace ((v mod 2 ^ 0 + t) / 2 ^ 0) with t in H; [auto|].
    rewrite Nat.pow_0_r, Nat.mod_1_r, Nat.div_1_r. lia.
  - cbn [digits app].
    assert (Ev : v = 2 * (v / 2) + v mod 2) by (apply Nat.div_mod; lia).
    assert (E1 : (v + t) / 2 = v / 2 + (v mod 2 + t) / 2).
    { rewrite Ev at 1. replace (2 * (v / 2) + v mod 2 + t) with ((v mod 2 + t) + (v / 2) * 2) by lia.
      rewrite Nat.div_add by lia. lia. }
    replace (dig (v + t)) with (dig (dval (dig v) + t)).
    2:{ rewrite dval_dig. rewrite <- dig_mod, <- (dig_mod (v + t)). f_equal.
        rewrite Nat.Div0.add_mod_idemp_l. reflexivity. }
    apply IncN_digit; [apply isdig_dig|].
    rewrite E1, dval_dig. apply IH.
    replace ((v / 2) mod 2 ^ r + (v mod 2 + t) / 2) with ((v mod 2 ^ S r + t) / 2).
    + rewrite Nat.Div0.div_div. rewrite Nat.pow_succ_r'. exact H.
    + rewrite Nat.pow_succ_r'. rewrite Nat.Div0.mod_mul_r.
      replace (v mod 2 + 2 * ((v / 2) mod 2 ^ r) + t) with ((v mod 2 + t) + ((v / 2) mod 2 ^ r) * 2) by lia.
      rewrite Nat.div_add by lia. lia.
Qed.

(* ===================================================================== *)
(* 8. The closed zone system (proof.md section 5).                       *)
(* ===================================================================== *)

Definition notP (w : list unt) : Prop := match w with uP :: _ => False | _ => True end.

Definition pj (j : nat) : nat := nth (j mod 8) [47; 48; 48; 47; 48; 47; 48; 47] 47.

(* one step: feed c = D + p(j) carries, every leading P is dropped and adds
   3 carries, stop at the least fixed point m = c + 3 A(m), then the
   absorption shift *)
Definition cs_step (Z : list unt) (D j : nat) (Z' : list unt) (D' j' : nat) : Prop :=
  exists m A Y,
    IncN m Z (Ps A ++ Y) /\ notP Y /\ m = D + pj j + 3 * A /\
    (forall m' A' Y', m' < m -> IncN m' Z (Ps A' ++ Y') -> notP Y' -> m' <> D + pj j + 3 * A') /\
    shift Y = Some Z' /\ D' = D + A /\ j' = S j.

Inductive CSreach : list unt -> nat -> nat -> Prop :=
| CS1 : CSreach [uS1; uD0; uD1; uD1; uD1; uD0; uD1] 0 1
| CSS Z D j Z' D' j' : CSreach Z D j -> cs_step Z D j Z' D' j' -> CSreach Z' D' j'.

(* executable carries *)
Fixpoint incf (n : nat) (w : list unt) : option (list unt) :=
  match n with
  | O => None
  | S n' =>
      match w with
      | [] => Some [uD1]
      | uD0 :: w' => Some (uD1 :: w')
      | uS1 :: w' => Some (uP :: w')
      | uSP :: w' => Some (uW :: w')
      | uD1 :: w' => match incf n' w' with Some x => Some (uD0 :: x) | None => None end
      | uP :: w' => match incf n' w' with Some x => Some (uP :: x) | None => None end
      | uW :: w' =>
          match incf n' w' with
          | None => None
          | Some x1 =>
              match incf n' x1 with
              | None => None
              | Some x2 =>
                  match incf n' x2 with
                  | None => None
                  | Some x3 => match shift x3 with Some x4 => Some (uP :: x4) | None => None end
                  end
              end
          end
      end
  end.

Lemma incf_sound n w w' : incf n w = Some w' -> Inc w w'.
Proof.
  revert w w'; induction n as [|n IH]; intros w w' H; [discriminate|].
  destruct w as [|u w]; cbn in H.
  - inversion H; constructor.
  - destruct u.
    + inversion H; constructor.
    + destruct (incf n w) eqn:E; inversion H; subst. constructor; auto.
    + destruct (incf n w) eqn:E; inversion H; subst. constructor; auto.
    + inversion H; constructor.
    + inversion H; constructor.
    + destruct (incf n w) as [x1|] eqn:E1; [|discriminate].
      destruct (incf n x1) as [x2|] eqn:E2; [|discriminate].
      destruct (incf n x2) as [x3|] eqn:E3; [|discriminate].
      destruct (shift x3) as [x4|] eqn:E4; inversion H; subst.
      eapply Inc_W; eauto.
Qed.

Fixpoint incNf (fuel k : nat) (w : list unt) : option (list unt) :=
  match k with
  | O => Some w
  | S k' => match incf fuel w with Some x => incNf fuel k' x | None => None end
  end.

Lemma incNf_sound fuel k w w' : incNf fuel k w = Some w' -> IncN k w w'.
Proof.
  revert w; induction k as [|k IH]; intros w H; cbn in H.
  - inversion H; constructor.
  - destruct (incf fuel w) eqn:E; [|discriminate].
    econstructor; [eapply incf_sound; eauto|]. auto.
Qed.

Fixpoint splitP (w : list unt) : nat * list unt :=
  match w with
  | uP :: w' => let (a, y) := splitP w' in (S a, y)
  | _ => (O, w)
  end.

Lemma splitP_spec w : let (a, y) := splitP w in w = Ps a ++ y /\ notP y.
Proof.
  induction w as [|u w IH]; cbn; [split; [reflexivity|exact I]|].
  destruct u; try (split; [reflexivity|exact I]).
  destruct (splitP w) as [a y]. destruct IH as [E N]. subst. split; auto.
Qed.

Lemma Ps_notP_inj a b x y : Ps a ++ x = Ps b ++ y -> notP x -> notP y -> a = b /\ x = y.
Proof.
  revert b; induction a as [|a IH]; intros [|b] E Nx Ny; cbn in *.
  - auto.
  - subst. contradiction.
  - subst. contradiction.
  - inversion E. destruct (IH b H0 Nx Ny). auto.
Qed.

(* leading P units are never lost *)
Lemma IncN_Ps_inv k a y x : IncN k (Ps a ++ y) x -> exists y', x = Ps a ++ y' /\ IncN k y y'.
Proof.
  revert x; induction a as [|a IH]; intros x H; cbn in *.
  - eauto.
  - apply IncN_P_inv in H. destruct H as [w' [E H]]. subst.
    destruct (IH _ H) as [y' [E2 H2]]. subst. eauto.
Qed.

Lemma Ps_prefix_le a b y Y : Ps a ++ y = Ps b ++ Y -> notP Y -> a <= b.
Proof.
  revert b; induction a as [|a IH]; intros [|b] E N; cbn in *; try lia.
  - subst. contradiction.
  - inversion E. specialize (IH b H0 N). lia.
Qed.

(* no fixed point at m' *)
Definition NF (Z : list unt) (c m' : nat) : Prop :=
  forall A' Y', IncN m' Z (Ps A' ++ Y') -> notP Y' -> m' <> c + 3 * A'.

Fixpoint cs_loop (fuel cf c m : nat) (Zm : list unt) : option (nat * nat * list unt) :=
  match fuel with
  | O => None
  | S f =>
      let (a, y) := splitP Zm in
      if Nat.eqb m (c + 3 * a) then Some (m, a, y)
      else
        match incNf cf (c + 3 * a - m) Zm with
        | Some Zm' => cs_loop f cf c (c + 3 * a) Zm'
        | None => None
        end
  end.

Lemma cs_loop_sound fuel cf c Z m Zm m2 A2 Y2 :
  cs_loop fuel cf c m Zm = Some (m2, A2, Y2) ->
  IncN m Z Zm -> (forall m', m' < m -> NF Z c m') ->
  (forall A Y, Zm = Ps A ++ Y -> notP Y -> m <= c + 3 * A) ->
  IncN m2 Z (Ps A2 ++ Y2) /\ notP Y2 /\ m2 = c + 3 * A2 /\ (forall m', m' < m2 -> NF Z c m').
Proof.
  revert m Zm; induction fuel as [|f IH]; intros m Zm H HZ HNF Hle; [discriminate|].
  cbn [cs_loop] in H. pose proof (splitP_spec Zm) as HS.
  destruct (splitP Zm) as [A Y]. destruct HS as [EZ NY].
  specialize (Hle A Y EZ NY).
  destruct (Nat.eqb m (c + 3 * A)) eqn:Em; [apply Nat.eqb_eq in Em | apply Nat.eqb_neq in Em].
  - inversion H; subst. repeat split; auto.
  - destruct (incNf cf (c + 3 * A - m) Zm) as [Zm'|] eqn:E; [|discriminate].
    apply incNf_sound in E.
    assert (HZ' : IncN (c + 3 * A) Z Zm').
    { replace (c + 3 * A) with (m + (c + 3 * A - m)) by lia. eapply IncN_add; eauto. }
    eapply IH; eauto.
    + intros m' Hm' A' Y' H' NY'.
      destruct (Nat.lt_ge_cases m' m) as [Hlt|Hge].
      * apply (HNF m' Hlt A' Y' H' NY').
      * (* between m and c + 3A: at least A leading P *)
        replace m' with (m + (m' - m)) in H' by lia.
        destruct (IncN_split _ _ _ _ H') as [w1 [Hw1 Hw2]].
        assert (w1 = Zm) by (eapply IncN_det; eauto). subst w1.
        rewrite EZ in Hw2. destruct (IncN_Ps_inv _ _ _ _ Hw2) as [y' [Ey' _]].
        pose proof (Ps_prefix_le _ _ _ _ (eq_sym Ey') NY'). lia.
    + intros A' Y' EZ' NY'. subst Zm'.
      replace (c + 3 * A) with (m + (c + 3 * A - m)) in HZ' by lia.
      destruct (IncN_split _ _ _ _ HZ') as [w1 [Hw1 Hw2]].
      assert (w1 = Zm) by (eapply IncN_det; eauto). subst w1.
      rewrite EZ in Hw2. destruct (IncN_Ps_inv _ _ _ _ Hw2) as [y' [Ey' _]].
      pose proof (Ps_prefix_le _ _ _ _ (eq_sym Ey') NY'). lia.
Qed.

Definition csf (fuel cf : nat) (s : list unt * nat * nat) : option (list unt * nat * nat) :=
  let '(z, d, j) := s in
  match incNf cf (d + pj j) z with
  | None => None
  | Some zc =>
      match cs_loop fuel cf (d + pj j) (d + pj j) zc with
      | None => None
      | Some (m, a, y) =>
          match shift y with
          | Some z' => Some (z', d + a, S j)
          | None => None
          end
      end
  end.

Lemma csf_sound fuel cf Z D j Z' D' j' :
  csf fuel cf (Z, D, j) = Some (Z', D', j') -> cs_step Z D j Z' D' j'.
Proof.
  unfold csf. intros H.
  destruct (incNf cf (D + pj j) Z) as [Zc|] eqn:E1; [|discriminate].
  destruct (cs_loop fuel cf (D + pj j) (D + pj j) Zc) as [[[m A] Y]|] eqn:E2; [|discriminate].
  destruct (shift Y) as [Z''|] eqn:E3; inversion H; subst.
  apply incNf_sound in E1.
  destruct (cs_loop_sound _ _ _ Z _ _ _ _ _ E2 E1) as [H1 [H2 [H3 H4]]].
  - intros m' Hm' A' Y' _ _. lia.
  - intros. lia.
  - exists m, A, Y. repeat split; auto.
    intros m' A' Y' Hm' HI HN. apply (H4 m' Hm' A' Y' HI HN).
Qed.

Fixpoint csiter (n : nat) (s : list unt * nat * nat) : option (list unt * nat * nat) :=
  match n with
  | O => Some s
  | S n' => match csf 200 200 s with Some s' => csiter n' s' | None => None end
  end.

Lemma csiter_reach n Z D j Z' D' j' :
  CSreach Z D j -> csiter n (Z, D, j) = Some (Z', D', j') -> CSreach Z' D' j'.
Proof.
  revert Z D j; induction n as [|n IH]; intros Z D j HR H; cbn [csiter] in H.
  - inversion H; subst; auto.
  - destruct (csf 200 200 (Z, D, j)) as [[[Z1 D1] j1]|] eqn:E; [|discriminate].
    eapply IH; [|exact H]. econstructor; [exact HR|]. eapply csf_sound; eauto.
Qed.

(* the closed system reaches the canonical state C(0) at j = 17 *)
Lemma C0_reach : CSreach [uS1; uD0; uD1; uD1; uD1; uD1; uD1] 16 17.
Proof.
  eapply (csiter_reach 16); [constructor|].
  vm_compute. reflexivity.
Qed.

(* ===================================================================== *)
(* 9. Pops on conveyor words (used by the record invariant).             *)
(* ===================================================================== *)

Lemma IncN_3_inv w x : IncN 3 w x -> exists a b, Inc w a /\ Inc a b /\ Inc b x.
Proof.
  intros H.
  inversion H as [|n1 w1 a1 x1 H1 Hn1]; subst.
  inversion Hn1 as [|n2 w2 a2 x2 H2 Hn2]; subst.
  inversion Hn2 as [|n3 w3 a3 x3 H3 Hn3]; subst.
  inversion Hn3; subst. eauto.
Qed.

Lemma Inc3Pop_of w x : IncN 3 w (uP :: x) -> Inc3Pop w x.
Proof. intros H. destruct (IncN_3_inv _ _ H) as [a [b [H1 [H2 H3]]]]. exists a, b. auto. Qed.

Lemma IncN_of_Inc3Pop w x : Inc3Pop w x -> IncN 3 w (uP :: x).
Proof.
  intros [a [b [H1 [H2 H3]]]].
  econstructor; [eauto|]. econstructor; [eauto|]. econstructor; [eauto|]. constructor.
Qed.

(* a firing over a wire: three carries pass the first P, which is popped *)
Lemma Inc3Pop_P y y3 : IncN 3 y y3 -> Inc3Pop (uP :: y) y3.
Proof. intros H. apply Inc3Pop_of. apply IncN_P. auto. Qed.

Lemma Pops_Ps k a y y' : IncN (3 * k) y y' -> Pops k (Ps (k + a) ++ y) (Ps a ++ y').
Proof.
  revert y; induction k as [|k IH]; intros y H; cbn [Pops].
  - cbn in *. inversion H; subst. reflexivity.
  - replace (3 * S k) with (3 + 3 * k) in H by lia.
    destruct (IncN_split _ _ _ _ H) as [y3 [H3 Hk]].
    exists (Ps (k + a) ++ y3). split.
    + cbn [Ps app]. apply Inc3Pop_P. apply IncN_Ps. auto.
    + apply IH. auto.
Qed.

(* a firing directly below a wall: the wall above has moved (Lemma C1) *)
Lemma Inc3Pop_wall (b : bool) r r' :
  Pops ((3 + Nat.b2n b) / 2) r r' ->
  Inc3Pop (wallu b :: r) (Ps ((3 + Nat.b2n b) / 2 - 1) ++ wallu (Nat.odd (3 + Nat.b2n b)) :: r').
Proof.
  intros H. apply Inc3Pop_of.
  pose proof (wall_feed 3 b r r' H) as G.
  destruct b; cbn in *; exact G.
Qed.


(* ===================================================================== *)
(* 10. Upward flow (Lemma L, item 1): a prefix X that passes e carries   *)
(*     up, with every shift landing inside X, acts on X ++ Y as          *)
(*     X' ++ inc^e(Y).                                                   *)
(* ===================================================================== *)

(* a shift that must land inside X *)
Fixpoint shiftX (X : list unt) : option (list unt) :=
  match X with
  | [] => None
  | uD0 :: X' =>
      match shiftX X' with
      | Some X'' => Some (uD0 :: X'')
      | None => None
      end
  | uD1 :: X' => Some (uS1 :: X')
  | uP :: X' => Some (uSP :: X')
  | _ => None
  end.

Lemma shiftX_app X X' Y : shiftX X = Some X' -> shift (X ++ Y) = Some (X' ++ Y).
Proof.
  revert X'; induction X as [|u X IH]; intros X' H; cbn in H; [discriminate|].
  destruct u; try discriminate.
  - destruct (shiftX X) as [X''|] eqn:E; [|discriminate]. inversion H; subst.
    cbn [app shift]. rewrite (IH X'' eq_refl). reflexivity.
  - inversion H; subst. reflexivity.
  - inversion H; subst. reflexivity.
Qed.

Inductive IncX : list unt -> nat -> list unt -> Prop :=
| IncX_nil : IncX [] 1 []
| IncX_D0 X : IncX (uD0 :: X) 0 (uD1 :: X)
| IncX_S1 X : IncX (uS1 :: X) 0 (uP :: X)
| IncX_SP X : IncX (uSP :: X) 0 (uW :: X)
| IncX_D1 X e X' : IncX X e X' -> IncX (uD1 :: X) e (uD0 :: X')
| IncX_P X e X' : IncX X e X' -> IncX (uP :: X) e (uP :: X')
| IncX_W X e1 e2 e3 X1 X2 X3 X4 :
    IncX X e1 X1 -> IncX X1 e2 X2 -> IncX X2 e3 X3 -> shiftX X3 = Some X4 ->
    IncX (uW :: X) (e1 + e2 + e3) (uP :: X4).

Lemma IncX_flow X e X' : IncX X e X' ->
  forall Y Y', IncN e Y Y' -> Inc (X ++ Y) (X' ++ Y').
Proof.
  induction 1; intros Y Y' HY; cbn [app].
  - apply IncN_1_inv. exact HY.
  - inversion HY; subst. constructor.
  - inversion HY; subst. constructor.
  - inversion HY; subst. constructor.
  - constructor. auto.
  - constructor. auto.
  - rewrite <- Nat.add_assoc in HY.
    destruct (IncN_split _ _ _ _ HY) as [Y1 [Ha Hbc]].
    destruct (IncN_split _ _ _ _ Hbc) as [Y2 [Hb Hc]].
    eapply Inc_W.
    + apply IHIncX1. exact Ha.
    + apply IHIncX2. exact Hb.
    + apply IHIncX3. exact Hc.
    + apply shiftX_app. assumption.
Qed.

(* n carries on X *)
Inductive IncXN : nat -> list unt -> nat -> list unt -> Prop :=
| IncXN_0 X : IncXN 0 X 0 X
| IncXN_S n X e X1 e' X2 : IncX X e X1 -> IncXN n X1 e' X2 -> IncXN (S n) X (e + e') X2.

Lemma IncXN_flow n X e X' : IncXN n X e X' ->
  forall Y Y', IncN e Y Y' -> IncN n (X ++ Y) (X' ++ Y').
Proof.
  induction 1; intros Y Y' HY.
  - inversion HY; subst. constructor.
  - destruct (IncN_split _ _ _ _ HY) as [Y1 [H1 H2]].
    econstructor.
    + eapply IncX_flow; eauto.
    + apply IHIncXN. exact H2.
Qed.

(* executable version *)
Fixpoint incXf (n : nat) (X : list unt) : option (nat * list unt) :=
  match n with
  | O => None
  | S n' =>
      match X with
      | [] => Some (1%nat, [])
      | uD0 :: X' => Some (O, uD1 :: X')
      | uS1 :: X' => Some (O, uP :: X')
      | uSP :: X' => Some (O, uW :: X')
      | uD1 :: X' => match incXf n' X' with Some (e, x) => Some (e, uD0 :: x) | None => None end
      | uP :: X' => match incXf n' X' with Some (e, x) => Some (e, uP :: x) | None => None end
      | uW :: X' =>
          match incXf n' X' with
          | None => None
          | Some (e1, x1) =>
              match incXf n' x1 with
              | None => None
              | Some (e2, x2) =>
                  match incXf n' x2 with
                  | None => None
                  | Some (e3, x3) =>
                      match shiftX x3 with
                      | Some x4 => Some (e1 + e2 + e3, uP :: x4)
                      | None => None
                      end
                  end
              end
          end
      end
  end.

Lemma incXf_sound n X e X' : incXf n X = Some (e, X') -> IncX X e X'.
Proof.
  revert X e X'; induction n as [|n IH]; intros X e X' H; [discriminate|].
  destruct X as [|u X]; cbn [incXf] in H.
  - inversion H; constructor.
  - destruct u.
    + inversion H; constructor.
    + destruct (incXf n X) as [[e0 x]|] eqn:E; inversion H; subst. constructor; auto.
    + destruct (incXf n X) as [[e0 x]|] eqn:E; inversion H; subst. constructor; auto.
    + inversion H; constructor.
    + inversion H; constructor.
    + destruct (incXf n X) as [[e1 x1]|] eqn:E1; [|discriminate].
      destruct (incXf n x1) as [[e2 x2]|] eqn:E2; [|discriminate].
      destruct (incXf n x2) as [[e3 x3]|] eqn:E3; [|discriminate].
      destruct (shiftX x3) as [x4|] eqn:E4; inversion H; subst.
      eapply IncX_W; eauto.
Qed.

Local Open Scope bool_scope.

(* ===================================================================== *)
(* 11. Binary words: bin v (least significant first, no trailing D0).    *)
(* ===================================================================== *)

Fixpoint binp (p : positive) : list unt :=
  match p with
  | xH => [uD1]
  | xO p' => uD0 :: binp p'
  | xI p' => uD1 :: binp p'
  end.

Definition binN (n : N) : list unt := match n with N0 => [] | Npos p => binp p end.

Definition bin (v : nat) : list unt := binN (N.of_nat v).

Definition digN (n : N) : unt :=
  match n with
  | N0 => uD0
  | Npos xH => uD1
  | Npos (xO _) => uD0
  | Npos (xI _) => uD1
  end.

Lemma dig_even x : dig (2 * x) = uD0.
Proof. unfold dig. replace (2 * x) with (0 + x * 2) by lia. rewrite Nat.Div0.mod_add. reflexivity. Qed.

Lemma dig_odd x : dig (2 * x + 1) = uD1.
Proof. unfold dig. replace (2 * x + 1) with (1 + x * 2) by lia. rewrite Nat.Div0.mod_add. reflexivity. Qed.

Lemma digN_dig n : digN n = dig (N.to_nat n).
Proof.
  destruct n as [|[p|p|]]; cbn [digN].
  - reflexivity.
  - change (N.to_nat (Npos (xI p))) with (Pos.to_nat (xI p)). rewrite Pos2Nat.inj_xI. symmetry. replace (S (2 * Pos.to_nat p)) with (2 * Pos.to_nat p + 1) by lia.
    apply dig_odd.
  - change (N.to_nat (Npos (xO p))) with (Pos.to_nat (xO p)). rewrite Pos2Nat.inj_xO. symmetry. apply dig_even.
  - reflexivity.
Qed.

Lemma Inc_binp p : Inc (binp p) (binp (Pos.succ p)).
Proof.
  induction p as [p IH|p IH|]; cbn [binp Pos.succ].
  - constructor. exact IH.
  - constructor.
  - constructor. constructor.
Qed.

Lemma Inc_binN n : Inc (binN n) (binN (N.succ n)).
Proof. destruct n as [|p]; cbn. - constructor. - apply Inc_binp. Qed.

Lemma IncN_binN t n : IncN t (binN n) (binN (n + N.of_nat t)).
Proof.
  revert n; induction t as [|t IH]; intros n.
  - rewrite N.add_0_r. constructor.
  - econstructor; [apply Inc_binN|].
    replace (n + N.of_nat (S t))%N with (N.succ n + N.of_nat t)%N by lia. apply IH.
Qed.

Lemma IncN_bin t v : IncN t (bin v) (bin (v + t)).
Proof. unfold bin. rewrite Nat2N.inj_add. apply IncN_binN. Qed.

Lemma binN_eq n : binN n = if N.eqb n 0 then [] else digN n :: binN (N.div2 n).
Proof. destruct n as [|[p|p|]]; reflexivity. Qed.

Lemma bin_eq v : bin v = if Nat.eqb v 0 then [] else dig v :: bin (v / 2).
Proof.
  unfold bin. rewrite binN_eq. destruct v as [|v]; [reflexivity|].
  replace (N.eqb (N.of_nat (S v)) 0) with false by (symmetry; apply N.eqb_neq; lia). cbn [Nat.eqb].
  rewrite digN_dig, Nat2N.id. f_equal. f_equal.
  apply N2Nat.inj. rewrite N2Nat.inj_div2, !Nat2N.id, Nat.div2_div. reflexivity.
Qed.

Lemma bin_pos v : 0 < v -> bin v = dig v :: bin (v / 2).
Proof. intros H. rewrite bin_eq. destruct v; [lia|reflexivity]. Qed.

Lemma bin_0 : bin 0 = [].
Proof. reflexivity. Qed.

Lemma IncN_nil_bin t : IncN t [] (bin t).
Proof. pose proof (IncN_bin t 0) as H. exact H. Qed.

(* dig and division facts *)
Lemma dig_add_even v s : dig (v + 2 * s) = dig v.
Proof. unfold dig. replace (v + 2 * s) with (v + s * 2) by lia. rewrite Nat.Div0.mod_add. reflexivity. Qed.

Lemma div2_add_even v s : (v + 2 * s) / 2 = v / 2 + s.
Proof. replace (v + 2 * s) with (v + s * 2) by lia. apply Nat.div_add. lia. Qed.

Lemma digits_app_bin n x y : x < 2 ^ n -> 0 < y -> digits n x ++ bin y = bin (x + 2 ^ n * y).
Proof.
  revert x y; induction n as [|n IH]; intros x y Hx Hy.
  - cbn in *. replace x with 0%nat by lia. f_equal. lia.
  - cbn [digits app]. rewrite (bin_pos (x + 2 ^ S n * y)).
    2:{ pose proof (Nat.pow_nonzero 2 (S n)). nia. }
    rewrite Nat.pow_succ_r'.
    replace (x + 2 * 2 ^ n * y) with (x + 2 * (2 ^ n * y)) by lia.
    rewrite dig_add_even, div2_add_even. f_equal.
    apply IH; auto. rewrite Nat.pow_succ_r' in Hx.
    apply Nat.Div0.div_lt_upper_bound. lia.
Qed.

Lemma bin_ones k q : bin (2 ^ k - 1 + 2 ^ (k + 1) * q) = repeat uD1 k ++ bin (2 * q).
Proof.
  induction k as [|k IH].
  - cbn [repeat app]. replace (2 ^ 0 - 1 + 2 ^ (0 + 1) * q) with (2 * q) by (cbn; lia). reflexivity.
  - pose proof (Nat.pow_nonzero 2 k).
    rewrite bin_pos.
    2:{ rewrite Nat.pow_succ_r'. lia. }
    replace (2 ^ S k - 1 + 2 ^ (S k + 1) * q) with (2 * (2 ^ k - 1 + 2 ^ (k + 1) * q) + 1).
    2:{ rewrite !Nat.pow_succ_r', !Nat.pow_add_r. cbn. lia. }
    rewrite dig_odd. cbn [repeat app]. f_equal.
    rewrite <- IH. f_equal.
    replace (2 * (2 ^ k - 1 + 2 ^ (k + 1) * q) + 1) with (1 + (2 ^ k - 1 + 2 ^ (k + 1) * q) * 2) by lia.
    rewrite Nat.div_add by lia. reflexivity.
Qed.

(* digit-only words *)
Fixpoint allb (f : unt -> bool) (w : list unt) : bool :=
  match w with [] => true | u :: w' => f u && allb f w' end.

Fixpoint ndig (X : list unt) : nat :=
  match X with [] => O | u :: X' => (if isdig u then 1 else 0) + ndig X' end.

Fixpoint val (X : list unt) : nat :=
  match X with [] => O | u :: X' => if isdig u then dval u + 2 * val X' else val X' end.

Lemma digits_val Xd : allb isdig Xd = true -> Xd = digits (length Xd) (val Xd).
Proof.
  induction Xd as [|u Xd IH]; intros H; [reflexivity|].
  cbn [allb] in H. apply andb_prop in H. destruct H as [Hu H].
  cbn [length digits val]. rewrite Hu.
  f_equal.
  - destruct u; try discriminate; cbn [dval].
    + rewrite Nat.add_0_l. symmetry. apply dig_even.
    + rewrite Nat.add_comm. symmetry. apply dig_odd.
  - rewrite div2_add_even. replace (dval u / 2) with 0%nat.
    + apply IH; auto.
    + destruct u; reflexivity.
Qed.

Lemma val_lt Xd : allb isdig Xd = true -> val Xd < 2 ^ length Xd.
Proof.
  induction Xd as [|u Xd IH]; intros H; cbn; [lia|].
  apply andb_prop in H. destruct H as [Hu H]. rewrite Hu.
  specialize (IH H). assert (dval u <= 1) by (destruct u; cbn; lia). lia.
Qed.

(* ===================================================================== *)
(* 12. Carries through a cut: XN t X e X' says that t carries on X ++ Y  *)
(*     give X' ++ Y' whenever e carries on Y give Y' (every shift lands  *)
(*     inside X).                                                        *)
(* ===================================================================== *)

Definition XN (t : nat) (X : list unt) (e : nat) (X' : list unt) : Prop :=
  forall Y Y', IncN e Y Y' -> IncN t (X ++ Y) (X' ++ Y').

Lemma XN_0 X : XN 0 X 0 X.
Proof. intros Y Y' H. inversion H; subst. constructor. Qed.

Lemma XN_nil t : XN t [] t [].
Proof. intros Y Y' H. exact H. Qed.

Lemma XN_add a b X e1 X1 e2 X2 : XN a X e1 X1 -> XN b X1 e2 X2 -> XN (a + b) X (e1 + e2) X2.
Proof.
  intros H1 H2 Y Y' H. destruct (IncN_split _ _ _ _ H) as [Y1 [Ha Hb]].
  eapply IncN_add; [apply H1; exact Ha | apply H2; exact Hb].
Qed.

Lemma XN_P t X e X' : XN t X e X' -> XN t (uP :: X) e (uP :: X').
Proof. intros H Y Y' HY. cbn [app]. apply IncN_P. apply H. exact HY. Qed.

Lemma XN_digit t u X e X' : isdig u = true -> XN ((dval u + t) / 2) X e X' ->
  XN t (u :: X) e (dig (dval u + t) :: X').
Proof. intros Hu H Y Y' HY. cbn [app]. apply IncN_digit; auto. Qed.

Lemma XN_S1 t X e X' : XN t X e X' -> XN (S t) (uS1 :: X) e (uP :: X').
Proof. intros H Y Y' HY. cbn [app]. econstructor; [constructor|]. apply IncN_P. apply H. exact HY. Qed.

Lemma XN_SP t X e X' : XN t (uW :: X) e X' -> XN (S t) (uSP :: X) e X'.
Proof. intros H Y Y' HY. cbn [app]. econstructor; [constructor|]. apply (H Y Y' HY). Qed.

Lemma XN_W t X e1 X1 X2 e2 X3 : XN 3 X e1 X1 -> shiftX X1 = Some X2 -> XN t X2 e2 X3 ->
  XN (S t) (uW :: X) (e1 + e2) (uP :: X3).
Proof.
  intros H1 Hs H2 Y Y' HY. destruct (IncN_split _ _ _ _ HY) as [Y1 [Ha Hb]].
  specialize (H1 _ _ Ha). destruct (IncN_3_inv _ _ H1) as [a [b [Ha1 [Ha2 Ha3]]]].
  cbn [app]. econstructor.
  - eapply Inc_W; [exact Ha1|exact Ha2|exact Ha3|]. apply shiftX_app. exact Hs.
  - apply IncN_P. apply H2. exact Hb.
Qed.

(* the executable bulk feed, with N counts *)
Fixpoint xfeed (f : nat) (t : N) (X : list unt) : option (list unt * N) :=
  match f with
  | O => None
  | S f' =>
    if N.eqb t 0 then Some (X, 0%N) else
    match X with
    | [] => Some ([], t)
    | uD0 :: X' =>
        match xfeed f' (N.div2 t) X' with Some (X'', e) => Some (digN t :: X'', e) | None => None end
    | uD1 :: X' =>
        match xfeed f' (N.div2 (N.succ t)) X' with
        | Some (X'', e) => Some (digN (N.succ t) :: X'', e) | None => None end
    | uP :: X' => match xfeed f' t X' with Some (X'', e) => Some (uP :: X'', e) | None => None end
    | uS1 :: X' => match xfeed f' (N.pred t) X' with Some (X'', e) => Some (uP :: X'', e) | None => None end
    | uSP :: X' => xfeed f' (N.pred t) (uW :: X')
    | uW :: X' =>
        match xfeed f' 3 X' with
        | Some (X1, e1) =>
            match shiftX X1 with
            | Some X2 =>
                match xfeed f' (N.pred t) X2 with
                | Some (X3, e2) => Some (uP :: X3, (e1 + e2)%N)
                | None => None
                end
            | None => None
            end
        | None => None
        end
    end
  end.

Lemma xfeed_sound f t X X' e : xfeed f t X = Some (X', e) -> XN (N.to_nat t) X (N.to_nat e) X'.
Proof.
  revert t X X' e; induction f as [|f IH]; intros t X X' e H; [discriminate|].
  cbn [xfeed] in H.
  destruct (N.eqb t 0) eqn:Et.
  { apply N.eqb_eq in Et. subst. inversion H; subst. apply XN_0. }
  apply N.eqb_neq in Et.
  assert (Ht : N.to_nat t = S (N.to_nat (N.pred t))) by lia.
  destruct X as [|u X0].
  { inversion H; subst. apply XN_nil. }
  destruct u.
  - destruct (xfeed f (N.div2 t) X0) as [[X'' e']|] eqn:E; inversion H; subst.
    rewrite digN_dig.
    replace (N.to_nat t) with (dval uD0 + N.to_nat t) at 2 by reflexivity.
    apply XN_digit; [reflexivity|].
    cbn [dval]. rewrite Nat.add_0_l, <- Nat.div2_div, <- N2Nat.inj_div2. apply IH. exact E.
  - destruct (xfeed f (N.div2 (N.succ t)) X0) as [[X'' e']|] eqn:E; inversion H; subst.
    rewrite digN_dig, N2Nat.inj_succ.
    apply XN_digit; [reflexivity|].
    cbn [dval]. replace (1 + N.to_nat t) with (N.to_nat (N.succ t)) by lia.
    rewrite <- Nat.div2_div, <- N2Nat.inj_div2. apply IH. exact E.
  - destruct (xfeed f t X0) as [[X'' e']|] eqn:E; inversion H; subst.
    apply XN_P. apply IH. exact E.
  - destruct (xfeed f (N.pred t) X0) as [[X'' e']|] eqn:E; inversion H; subst.
    rewrite Ht. apply XN_S1. apply IH. exact E.
  - rewrite Ht. apply XN_SP. apply IH. exact H.
  - destruct (xfeed f 3 X0) as [[X1 e1]|] eqn:E1; [|discriminate].
    destruct (shiftX X1) as [X2|] eqn:E2; [|discriminate].
    destruct (xfeed f (N.pred t) X2) as [[X3 e2]|] eqn:E3; inversion H; subst.
    rewrite Ht, N2Nat.inj_add. eapply XN_W.
    + apply IH in E1. exact E1.
    + exact E2.
    + apply IH. exact E3.
Qed.

(* ===================================================================== *)
(* 13. Clean words (D0, D1, P only) are counters: the P units pass.      *)
(* ===================================================================== *)

Fixpoint fill (X : list unt) (v : nat) : list unt :=
  match X with
  | [] => []
  | u :: X' => if isdig u then dig v :: fill X' (v / 2) else u :: fill X' v
  end.

Definition cleanu (u : unt) : bool := match u with uD0 | uD1 | uP => true | _ => false end.

Lemma XN_clean X t : allb cleanu X = true ->
  XN t X ((val X + t) / 2 ^ ndig X) (fill X (val X + t)).
Proof.
  revert t; induction X as [|u X IH]; intros t H.
  - cbn [val ndig fill]. rewrite Nat.pow_0_r, Nat.add_0_l, Nat.div_1_r. apply XN_nil.
  - cbn [allb] in H. apply andb_prop in H. destruct H as [Hu H].
    destruct u; try discriminate; cbn [ndig val fill isdig].
    + (* D0 *)
      replace (dig (dval uD0 + 2 * val X + t)) with (dig (dval uD0 + t)).
      2:{ replace (dval uD0 + 2 * val X + t) with ((dval uD0 + t) + 2 * val X) by lia.
          symmetry. apply dig_add_even. }
      replace ((dval uD0 + 2 * val X + t) / 2) with (val X + (dval uD0 + t) / 2).
      2:{ replace (dval uD0 + 2 * val X + t) with ((dval uD0 + t) + 2 * val X) by lia.
          rewrite div2_add_even. lia. }
      replace ((dval uD0 + 2 * val X + t) / 2 ^ (1 + ndig X)) with ((val X + (dval uD0 + t) / 2) / 2 ^ ndig X).
      2:{ rewrite Nat.pow_add_r, Nat.pow_1_r, <- Nat.Div0.div_div.
          replace (dval uD0 + 2 * val X + t) with ((dval uD0 + t) + 2 * val X) by lia.
          rewrite div2_add_even. f_equal. lia. }
      apply XN_digit; [reflexivity|]. apply IH. exact H.
    + (* D1 *)
      replace (dig (dval uD1 + 2 * val X + t)) with (dig (dval uD1 + t)).
      2:{ replace (dval uD1 + 2 * val X + t) with ((dval uD1 + t) + 2 * val X) by lia.
          symmetry. apply dig_add_even. }
      replace ((dval uD1 + 2 * val X + t) / 2) with (val X + (dval uD1 + t) / 2).
      2:{ replace (dval uD1 + 2 * val X + t) with ((dval uD1 + t) + 2 * val X) by lia.
          rewrite div2_add_even. lia. }
      replace ((dval uD1 + 2 * val X + t) / 2 ^ (1 + ndig X)) with ((val X + (dval uD1 + t) / 2) / 2 ^ ndig X).
      2:{ rewrite Nat.pow_add_r, Nat.pow_1_r, <- Nat.Div0.div_div.
          replace (dval uD1 + 2 * val X + t) with ((dval uD1 + t) + 2 * val X) by lia.
          rewrite div2_add_even. f_equal. lia. }
      apply XN_digit; [reflexivity|]. apply IH. exact H.
    + (* P *)
      rewrite Nat.add_0_l. apply XN_P. apply IH. exact H.
Qed.

Lemma fill_mod X v s : fill X (v + 2 ^ ndig X * s) = fill X v.
Proof.
  revert v; induction X as [|u X IH]; intros v; cbn [fill ndig]; [reflexivity|].
  destruct (isdig u) eqn:Hu.
  - rewrite Nat.pow_add_r, Nat.pow_1_r.
    replace (v + 2 * 2 ^ ndig X * s) with (v + 2 * (2 ^ ndig X * s)) by lia.
    rewrite dig_add_even, div2_add_even, IH. reflexivity.
  - rewrite Nat.add_0_l, IH. reflexivity.
Qed.

Lemma div_mod_shift v n s : (v + 2 ^ n * s) / 2 ^ n = v / 2 ^ n + s.
Proof.
  pose proof (Nat.pow_nonzero 2 n).
  replace (v + 2 ^ n * s) with (v + s * 2 ^ n) by lia. apply Nat.div_add. lia.
Qed.

(* digit heads stay digit heads *)
Definition dhead (w : list unt) : bool := match w with uD0 :: _ | uD1 :: _ => true | _ => false end.

Lemma Inc_dhead w w' : dhead w = true -> Inc w w' -> dhead w' = true.
Proof. intros H Hi. destruct Hi; cbn in *; try discriminate; reflexivity. Qed.

Lemma IncN_dhead n w w' : dhead w = true -> IncN n w w' -> dhead w' = true.
Proof. intros H Hi. induction Hi; auto. apply IHHi. eapply Inc_dhead; eauto. Qed.

Lemma dhead_app X Y : dhead X = true -> dhead (X ++ Y) = true.
Proof. intros H. destruct X as [|[] X]; cbn in *; auto; discriminate. Qed.

Lemma dhead_notP w : dhead w = true -> notP w.
Proof. destruct w as [|[] w]; cbn; auto; discriminate. Qed.

(* ===================================================================== *)
(* 14. One closed-system step through a cut (the locality step).         *)
(*     Phase 1: the first T0 carries act on X alone (all drops happen    *)
(*     there); phase 2: the rest; the absorption shift.                  *)
(* ===================================================================== *)

Lemma cutstep X Y T0 e1 A X1 c e2 X2 D j Z' Y' :
  XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true ->
  XN (c + 3 * A - T0) X1 e2 X2 -> T0 <= c -> c = D + pj j ->
  IncN (e1 + e2) Y Y' -> shift (X2 ++ Y') = Some Z' ->
  cs_step (X ++ Y) D j Z' (D + A) (S j).
Proof.
  intros H1 Hd H2 HT Hc HY Hs.
  destruct (IncN_split _ _ _ _ HY) as [Y1 [HY1 HY2]].
  specialize (H1 _ _ HY1). specialize (H2 _ _ HY2).
  assert (Hd2 : dhead (X2 ++ Y') = true).
  { eapply IncN_dhead; [|exact H2]. apply dhead_app. exact Hd. }
  exists (c + 3 * A), A, (X2 ++ Y').
  split; [|split; [|split; [|split; [|split]]]].
  - replace (c + 3 * A) with (T0 + (c + 3 * A - T0)) by lia.
    eapply IncN_add; [exact H1|]. rewrite <- app_assoc. apply IncN_Ps. exact H2.
  - apply dhead_notP. exact Hd2.
  - lia.
  - intros m' A' Y'' Hm Hi HN.
    destruct (Nat.lt_ge_cases m' T0) as [Hlt|Hge]; [lia|].
    replace m' with (T0 + (m' - T0)) in Hi by lia.
    destruct (IncN_split _ _ _ _ Hi) as [w1 [Hw1 Hw2]].
    assert (w1 = (Ps A ++ X1) ++ Y1) by (eapply IncN_det; eauto). subst w1.
    rewrite <- app_assoc in Hw2.
    destruct (IncN_Ps_inv _ _ _ _ Hw2) as [y' [Ey' Hy']].
    assert (Hdy : dhead y' = true) by (eapply IncN_dhead; [apply dhead_app; exact Hd|exact Hy']).
    destruct (Ps_notP_inj _ _ _ _ Ey' HN (dhead_notP _ Hdy)) as [EA _]. lia.
  - exact Hs.
  - split; reflexivity.
Qed.

(* ===================================================================== *)
(* 15. Affine families of closed-system states and their runner.         *)
(*     A family stands for the states, for every u,                      *)
(*       zone X ++ bin (y + ay u),  D = D0 + aD u,  j = j0 + aD u.       *)
(* ===================================================================== *)

Record fam := mkF { fX : list unt; fy : N; fay : N; fD : N; fj : N; faD : N }.

Definition st : Type := (list unt * nat * nat)%type.

Definition fz (F : fam) (u : nat) : st :=
  (fX F ++ bin (N.to_nat (fy F) + N.to_nat (fay F) * u),
   N.to_nat (fD F) + N.to_nat (faD F) * u,
   N.to_nat (fj F) + N.to_nat (faD F) * u).

Definition CS (s s' : st) : Prop :=
  cs_step (fst (fst s)) (snd (fst s)) (snd s) (fst (fst s')) (snd (fst s')) (snd s').

Inductive CSplus : st -> st -> Prop :=
| CSp1 s s' : CS s s' -> CSplus s s'
| CSpS s s1 s' : CS s s1 -> CSplus s1 s' -> CSplus s s'.

Lemma CSplus_trans a b c : CSplus a b -> CSplus b c -> CSplus a c.
Proof. induction 1 as [x y Hs|x y z Hs H1 IH]; intros Hn; [eapply CSpS; eauto|]. eapply CSpS; eauto. Qed.

Lemma CS_j s s' : CS s s' -> snd s' = S (snd s).
Proof.
  destruct s as [[z d] j], s' as [[z' d'] j']. unfold CS. cbn.
  intros [m [a [y [_ [_ [_ [_ [_ [_ E]]]]]]]]]. exact E.
Qed.

Lemma CSplus_j a b : CSplus a b -> snd a < snd b.
Proof. induction 1 as [x y Hs|x y z Hs H1 IH]; apply CS_j in Hs; lia. Qed.

Definition pjN (j : N) : N := N.of_nat (pj (N.to_nat (j mod 8))).

Lemma pj_mod j : pj j = pj (j mod 8).
Proof. unfold pj. rewrite Nat.Div0.mod_mod. reflexivity. Qed.

Lemma pjN_spec j : N.to_nat (pjN j) = pj (N.to_nat j).
Proof. unfold pjN. rewrite Nat2N.id, N2Nat.inj_mod. rewrite (pj_mod (N.to_nat j)). reflexivity. Qed.

Lemma pj_add8 j a : a mod 8 = O -> forall u, pj (j + a * u) = pj j.
Proof.
  intros Ha u. rewrite (pj_mod (j + a * u)), (pj_mod j). f_equal.
  apply Nat.Div0.mod_divides in Ha. destruct Ha as [g Hg]. subst a.
  replace (j + 8 * g * u) with (j + (g * u) * 8) by lia. apply Nat.Div0.mod_add.
Qed.

Fixpoint valN (X : list unt) : N :=
  match X with
  | [] => 0%N
  | u :: X' => if isdig u then (N.of_nat (dval u) + 2 * valN X')%N else valN X'
  end.

Lemma valN_spec X : N.to_nat (valN X) = val X.
Proof.
  induction X as [|u X IH]; cbn [valN val]; [reflexivity|].
  destruct (isdig u); [|exact IH].
  rewrite N2Nat.inj_add, N2Nat.inj_mul, Nat2N.id, IH. reflexivity.
Qed.

Fixpoint fillN (X : list unt) (v : N) : list unt :=
  match X with
  | [] => []
  | u :: X' => if isdig u then digN v :: fillN X' (N.div2 v) else u :: fillN X' v
  end.

Lemma fillN_spec X v : fillN X v = fill X (N.to_nat v).
Proof.
  revert v; induction X as [|u X IH]; intros v; cbn; [reflexivity|].
  destruct (isdig u); rewrite IH; [|reflexivity].
  rewrite digN_dig, N2Nat.inj_div2, Nat.div2_div. reflexivity.
Qed.

Fixpoint fnorm (n : nat) (F : fam) : fam :=
  match n with
  | O => F
  | S n' =>
      if N.even (fay F) && N.ltb 0 (fy F) then
        fnorm n' (mkF (fX F ++ [digN (fy F)]) (N.div2 (fy F)) (N.div2 (fay F)) (fD F) (fj F) (faD F))
      else F
  end.

Lemma fnorm_spec n F u : fz (fnorm n F) u = fz F u.
Proof.
  revert F; induction n as [|n IH]; intros F; cbn [fnorm]; [reflexivity|].
  destruct (N.even (fay F) && N.ltb 0 (fy F)) eqn:E; [|reflexivity].
  apply andb_prop in E. destruct E as [Ee Ey]. apply N.ltb_lt in Ey.
  rewrite IH. unfold fz. cbn [fX fy fay fD fj faD].
  f_equal. f_equal.
  apply N.even_spec in Ee. destruct Ee as [g Hg].
  rewrite <- app_assoc. f_equal.
  rewrite (bin_pos (N.to_nat (fy F) + N.to_nat (fay F) * u)) by lia.
  rewrite Hg. rewrite !N2Nat.inj_div2, !Nat.div2_div, N2Nat.inj_mul.
  replace (N.to_nat (fy F) + N.to_nat 2 * N.to_nat g * u) with (N.to_nat (fy F) + 2 * (N.to_nat g * u)) by (cbn; lia).
  rewrite dig_add_even, div2_add_even, digN_dig.
  replace (N.to_nat 2 * N.to_nat g / 2) with (N.to_nat g).
  - reflexivity.
  - replace (N.to_nat 2 * N.to_nat g) with (0 + N.to_nat g * 2) by (cbn; lia).
    rewrite Nat.div_add by lia. reflexivity.
Qed.

Definition n3 (a : nat) : N := N.of_nat (3 * a).

Lemma n3_spec a : N.to_nat (n3 a) = 3 * a.
Proof. unfold n3. apply Nat2N.id. Qed.

Definition phase2 (F : fam) (X1 : list unt) (a : nat) : option (list unt * N * N) :=
  let nd := N.of_nat (ndig X1) in
  if allb cleanu X1 then
    let v := (valN X1 + n3 a)%N in
    Some (fillN X1 v, (v / 2 ^ nd)%N, (fay F + faD F / 2 ^ nd)%N)
  else if N.eqb (faD F) 0 then
    match xfeed 4000 (n3 a) X1 with
    | Some (X2, e2) => Some (X2, e2, fay F)
    | None => None
    end
  else None.

Definition fstep (R : nat) (F : fam) : option fam :=
  if negb (N.eqb (faD F mod 8) 0) then None else
  match xfeed 4000 (fD F + pjN (fj F)) (fX F) with
  | None => None
  | Some (Xt, e1) =>
    let (a, X1) := splitP Xt in
    if negb (dhead X1) then None else
    if negb (N.eqb (faD F mod 2 ^ N.of_nat (ndig X1)) 0) then None else
    match phase2 F X1 a with
    | None => None
    | Some (X2, e2, ay2) =>
      let y2 := (fy F + e1 + e2)%N in
      match shiftX X2 with
      | Some X3 => Some (fnorm (R - ndig X3) (mkF X3 y2 ay2 (fD F + N.of_nat a) (N.succ (fj F)) (faD F)))
      | None =>
        if N.eqb ay2 0 && N.eqb (faD F) 0 then
          match shift (X2 ++ binN y2) with
          | Some Z3 => Some (mkF Z3 0 0 (fD F + N.of_nat a) (N.succ (fj F)) (faD F))
          | None => None
          end
        else None
      end
    end
  end.

Lemma phase2_sound F X1 a X2 e2 ay2 u :
  phase2 F X1 a = Some (X2, e2, ay2) ->
  N.to_nat (faD F) mod 2 ^ ndig X1 = O ->
  XN (3 * a + N.to_nat (faD F) * u) X1 (N.to_nat e2 + (N.to_nat ay2 - N.to_nat (fay F)) * u) X2 /\
  N.to_nat (fay F) <= N.to_nat ay2.
Proof.
  unfold phase2. intros H Hdiv.
  destruct (allb cleanu X1) eqn:Ec.
  - injection H as <- <- <-.
    apply Nat.Div0.mod_divides in Hdiv. destruct Hdiv as [g Hg].
    assert (Hp : N.to_nat (2 ^ N.of_nat (ndig X1)) = 2 ^ ndig X1).
    { rewrite N2Nat.inj_pow, Nat2N.id. reflexivity. }
    assert (Hg' : N.to_nat (faD F / 2 ^ N.of_nat (ndig X1)) = g).
    { rewrite N2Nat.inj_div, Hp, Hg. rewrite Nat.mul_comm, Nat.div_mul; [reflexivity|].
      apply Nat.pow_nonzero. lia. }
    split; [|rewrite N2Nat.inj_add; lia].
    rewrite N2Nat.inj_add, Hg'.
    replace (N.to_nat (fay F) + g - N.to_nat (fay F)) with g by lia.
    rewrite fillN_spec, !N2Nat.inj_div, !Hp, !N2Nat.inj_add, !n3_spec, !valN_spec.
    pose proof (XN_clean X1 (3 * a + N.to_nat (faD F) * u) Ec) as G.
    rewrite Hg in G.
    replace (val X1 + (3 * a + 2 ^ ndig X1 * g * u)) with ((val X1 + 3 * a) + 2 ^ ndig X1 * (g * u)) in G by lia.
    rewrite fill_mod, div_mod_shift in G.
    rewrite Hg. exact G.
  - destruct (N.eqb (faD F) 0) eqn:E0; [|discriminate].
    apply N.eqb_eq in E0. rewrite E0. cbn [N.to_nat].
    destruct (xfeed 4000 (n3 a) X1) as [[X2' e2']|] eqn:Ex; [|discriminate].
    injection H as <- <- <-.
    split; [|lia].
    apply xfeed_sound in Ex. rewrite n3_spec in Ex.
    replace (3 * a + 0 * u) with (3 * a) by lia.
    replace (N.to_nat e2' + (N.to_nat (fay F) - N.to_nat (fay F)) * u) with (N.to_nat e2') by lia.
    exact Ex.
Qed.

Lemma if_negb_true A (x y : A) : (if negb true then x else y) = y.
Proof. reflexivity. Qed.

(* PITFALL: [cbn in H] on the unfolded fstep makes Qed hang (kernel conversion);
   rewriting with [if_negb_true] is instant. *)
Lemma fstep_sound R F F' : fstep R F = Some F' -> forall u, CS (fz F u) (fz F' u).
Proof.
  unfold fstep. intros H u.
  destruct (N.eqb (faD F mod 8) 0) eqn:E8; [|discriminate]. rewrite if_negb_true in H.
  apply N.eqb_eq in E8.
  destruct (xfeed 4000 (fD F + pjN (fj F)) (fX F)) as [[Xt e1]|] eqn:Ex; [|discriminate].
  pose proof (splitP_spec Xt) as HS. destruct (splitP Xt) as [a X1].
  destruct HS as [EXt _].
  destruct (dhead X1) eqn:Ed; [|discriminate]. rewrite if_negb_true in H.
  destruct (N.eqb (faD F mod 2 ^ N.of_nat (ndig X1)) 0) eqn:Em; [|discriminate]. rewrite if_negb_true in H.
  apply N.eqb_eq in Em.
  assert (Hdiv : N.to_nat (faD F) mod 2 ^ ndig X1 = O).
  { replace (2 ^ ndig X1) with (N.to_nat (2 ^ N.of_nat (ndig X1))) by (rewrite N2Nat.inj_pow, Nat2N.id; reflexivity).
    rewrite <- N2Nat.inj_mod, Em. reflexivity. }
  destruct (phase2 F X1 a) as [[[X2 e2] ay2]|] eqn:Ep; [|discriminate].
  destruct (phase2_sound F X1 a X2 e2 ay2 u Ep Hdiv) as [HX2 Hay].
  apply xfeed_sound in Ex. rewrite EXt in Ex.
  assert (H8 : N.to_nat (faD F) mod 8 = O).
  { replace 8 with (N.to_nat 8) by reflexivity. rewrite <- N2Nat.inj_mod, E8. reflexivity. }
  set (aD := N.to_nat (faD F)) in *.
  set (D0 := N.to_nat (fD F)). set (j0 := N.to_nat (fj F)).
  assert (Hc : N.to_nat (fD F + pjN (fj F)) + aD * u = (D0 + aD * u) + pj (j0 + aD * u)).
  { rewrite N2Nat.inj_add, pjN_spec. fold D0 j0. rewrite pj_add8 by exact H8. lia. }
  set (y0 := N.to_nat (fy F)) in *. set (ay := N.to_nat (fay F)) in *.
  assert (HY : IncN (N.to_nat e1 + (N.to_nat e2 + (N.to_nat ay2 - ay) * u))
                 (bin (y0 + ay * u)) (bin (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u))).
  { replace (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u)
      with ((y0 + ay * u) + (N.to_nat e1 + (N.to_nat e2 + (N.to_nat ay2 - ay) * u))).
    - apply IncN_bin.
    - rewrite !N2Nat.inj_add. fold y0. rewrite Nat.mul_sub_distr_r.
      assert (ay * u <= N.to_nat ay2 * u) by (apply Nat.mul_le_mono_r; exact Hay). lia. }
  assert (Hstep : forall Z', shift (X2 ++ bin (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u)) = Some Z' ->
            cs_step (fX F ++ bin (y0 + ay * u)) (D0 + aD * u) (j0 + aD * u) Z'
                    (D0 + aD * u + a) (S (j0 + aD * u))).
  { intros Z' Hs.
    apply (cutstep (fX F) (bin (y0 + ay * u)) (N.to_nat (fD F + pjN (fj F))) (N.to_nat e1) a X1
             (D0 + aD * u + pj (j0 + aD * u)) (N.to_nat e2 + (N.to_nat ay2 - ay) * u) X2
             (D0 + aD * u) (j0 + aD * u) Z' (bin (N.to_nat (fy F + e1 + e2) + N.to_nat ay2 * u))).
    - exact Ex.
    - exact Ed.
    - replace ((D0 + aD * u + pj (j0 + aD * u)) + 3 * a - N.to_nat (fD F + pjN (fj F)))
        with (3 * a + aD * u) by (clear -Hc; lia).
      exact HX2.
    - clear -Hc. lia.
    - reflexivity.
    - exact HY.
    - exact Hs. }
  clear Hdiv H8 Em E8 HY Hc HX2 Hay Ex.
  destruct (shiftX X2) as [X3|] eqn:Es.
  - inversion H; subst. clear H. unfold CS. rewrite fnorm_spec. unfold fz. cbn [fst snd fX fy fay fD fj faD].
    fold aD D0 j0 y0 ay.
    replace (N.to_nat (fD F + N.of_nat a) + aD * u) with (D0 + aD * u + a) by (rewrite N2Nat.inj_add, Nat2N.id; lia).
    replace (N.to_nat (N.succ (fj F)) + aD * u) with (S (j0 + aD * u)) by (rewrite N2Nat.inj_succ; lia).
    apply Hstep. apply shiftX_app. exact Es.
  - destruct (N.eqb ay2 0 && N.eqb (faD F) 0) eqn:Ec; [|discriminate].
    apply andb_prop in Ec. destruct Ec as [Ea Eb]. apply N.eqb_eq in Ea, Eb.
    destruct (shift (X2 ++ binN (fy F + e1 + e2))) as [Z3|] eqn:Ez; inversion H; subst. clear H.
    unfold CS, fz. cbn [fst snd fX fy fay fD fj faD].
    fold aD D0 j0 y0 ay.
    assert (HaD : aD = O) by (unfold aD; rewrite Eb; reflexivity).
    replace (N.to_nat (fD F + N.of_nat a) + aD * u) with (D0 + aD * u + a) by (rewrite N2Nat.inj_add, Nat2N.id; lia).
    replace (N.to_nat (N.succ (fj F)) + aD * u) with (S (j0 + aD * u)) by (rewrite N2Nat.inj_succ; lia).
    cbn [N.to_nat] in *. rewrite Nat.mul_0_l, Nat.add_0_l, bin_0, app_nil_r.
    apply Hstep. rewrite Nat.mul_0_l, Nat.add_0_r.
    unfold bin. rewrite N2Nat.id. exact Ez.
Qed.

(* canonical states C(b) = S1 D0 D1^4 bin(b + 1), D = 32b + 16, j = 32b + 17 *)
Definition Cst (b : nat) : st := ([uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b), 32 * b + 16, 32 * b + 17).

Definition unt_eq_dec (a b : unt) : {a = b} + {a <> b}.
Proof. decide equality. Defined.

Definition lsteqb (l1 l2 : list unt) : bool := if list_eq_dec unt_eq_dec l1 l2 then true else false.

Definition canonb (F : fam) : bool :=
  match fX F with
  | uS1 :: uD0 :: uD1 :: uD1 :: uD1 :: uD1 :: Xd =>
    allb isdig Xd && N.leb 17 (fj F) && N.eqb ((fj F - 17) mod 32) 0 && N.eqb (fD F + 1) (fj F) &&
    N.eqb (faD F mod 32) 0 &&
    (if N.eqb (fay F) 0 && N.eqb (faD F) 0 then lsteqb (Xd ++ binN (fy F)) (binN ((fj F - 17) / 32 + 1))
     else N.ltb 0 (fy F) &&
          N.eqb (valN Xd + 2 ^ N.of_nat (length Xd) * fy F) ((fj F - 17) / 32 + 1) &&
          N.eqb (2 ^ N.of_nat (length Xd) * fay F) (faD F / 32))
  | _ => false
  end.

Lemma canonb_sound F : canonb F = true -> exists b0 g, forall u, fz F u = Cst (b0 + g * u).
Proof.
  unfold canonb. destruct (fX F) as [|[] [|[] [|[] [|[] [|[] [|[] Xd]]]]]] eqn:EX; try discriminate.
  intros H.
  apply andb_prop in H. destruct H as [H Hf].
  apply andb_prop in H. destruct H as [H He].
  apply andb_prop in H. destruct H as [H Hd].
  apply andb_prop in H. destruct H as [H Hc].
  apply andb_prop in H. destruct H as [Ha Hb].
  apply N.leb_le in Hb. apply N.eqb_eq in Hc, Hd, He.
  exists (N.to_nat ((fj F - 17) / 32)), (N.to_nat (faD F / 32)). intros u.
  assert (E1 : N.to_nat (fj F - 17) mod 32 = O).
  { replace 32 with (N.to_nat 32) by reflexivity. rewrite <- N2Nat.inj_mod, Hc. reflexivity. }
  assert (E2 : N.to_nat (faD F) mod 32 = O).
  { replace 32 with (N.to_nat 32) by reflexivity. rewrite <- N2Nat.inj_mod, He. reflexivity. }
  assert (Hb' : 17 <= N.to_nat (fj F)) by lia.
  assert (Hd' : N.to_nat (fD F) + 1 = N.to_nat (fj F)) by (rewrite <- Hd; rewrite N2Nat.inj_add; reflexivity).
  rewrite N2Nat.inj_sub in E1.
  apply Nat.Div0.mod_divides in E1, E2. destruct E1 as [p Hp], E2 as [q Hq].
  replace (N.to_nat 17) with 17 in Hp by reflexivity.
  assert (Ebj : N.to_nat ((fj F - 17) / 32) = p).
  { rewrite N2Nat.inj_div, N2Nat.inj_sub. replace (N.to_nat 17) with 17 by reflexivity.
    replace (N.to_nat 32) with 32 by reflexivity. rewrite Hp. rewrite Nat.mul_comm, Nat.div_mul; lia. }
  assert (Eg : N.to_nat (faD F / 32) = q).
  { rewrite N2Nat.inj_div. replace (N.to_nat 32) with 32 by reflexivity. rewrite Hq.
    rewrite Nat.mul_comm, Nat.div_mul; lia. }
  rewrite Ebj, Eg.
  unfold fz, Cst. rewrite EX. cbn [app].
  f_equal; [f_equal|].
  - do 6 f_equal.
    destruct (N.eqb (fay F) 0 && N.eqb (faD F) 0) eqn:Ec.
    + apply andb_prop in Ec. destruct Ec as [Ea Eb]. apply N.eqb_eq in Ea, Eb.
      unfold lsteqb in Hf.
      destruct (list_eq_dec unt_eq_dec (Xd ++ binN (fy F)) (binN ((fj F - 17) / 32 + 1))) as [Eq|]; [|discriminate].
      rewrite Ea, Eb in *. cbn [N.to_nat] in *. rewrite !Nat.mul_0_l, !Nat.add_0_r.
      unfold bin. rewrite N2Nat.id, Eq. f_equal.
      apply N2Nat.inj. rewrite Nat2N.id, N2Nat.inj_add, Ebj. cbn. lia.
    + apply andb_prop in Hf. destruct Hf as [Hf H6].
      apply andb_prop in Hf. destruct Hf as [H4 H5].
      apply N.ltb_lt in H4. apply N.eqb_eq in H5, H6.
      rewrite (digits_val Xd Ha) at 1.
      rewrite digits_app_bin; [| apply val_lt; exact Ha | lia].
      f_equal.
      apply (f_equal N.to_nat) in H5, H6.
      rewrite N2Nat.inj_add, N2Nat.inj_mul, N2Nat.inj_pow, valN_spec, Nat2N.id in H5.
      rewrite N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id in H6.
      rewrite N2Nat.inj_add, Ebj in H5. rewrite Eg in H6.
      change (N.to_nat 2) with 2%nat in H5, H6.
      change (N.to_nat 1) with 1%nat in H5.
      rewrite Nat.mul_add_distr_l, Nat.mul_assoc, H6. lia.
  - rewrite Hq. clear -Hd' Hp Hb'. nia.
  - rewrite Hq. clear -Hp Hb'. nia.
Qed.

Fixpoint frun (n R : nat) (F : fam) : bool :=
  match n with
  | O => false
  | S n' =>
      match fstep R F with
      | None => false
      | Some F' => canonb F' || frun n' R F'
      end
  end.

Lemma frun_sound n R F : frun n R F = true -> forall u, exists b', CSplus (fz F u) (Cst b').
Proof.
  revert F; induction n as [|n IH]; intros F H u; [discriminate|].
  cbn [frun] in H. destruct (fstep R F) as [F'|] eqn:E; [|discriminate].
  pose proof (fstep_sound R F F' E u) as H1.
  destruct (canonb F') eqn:Ec.
  - destruct (canonb_sound F' Ec) as [b0 [g Hg]]. exists (b0 + g * u). rewrite <- Hg. constructor. exact H1.
  - cbn in H. destruct (IH F' H u) as [b' Hb']. exists b'. eapply CSpS; eauto.
Qed.

(* ===================================================================== *)
(* 16. Small classes: C(b) with nu2(b + 2) <= 40 (proof.md 6.6).         *)
(* ===================================================================== *)

Definition Zcl (b : N) : list unt := [uS1; uD0; uD1; uD1; uD1; uD1] ++ binN (b + 1).

Definition sc_direct (k o0 : nat) : fam :=
  let b := (N.of_nat o0 * 2 ^ N.of_nat k - 2)%N in
  mkF (Zcl b) 0 0 (32 * b + 16) (32 * b + 17) 0.

Definition sc_fam (k o0 : nat) : fam :=
  let j0 := (32 * ((N.of_nat o0 + 16) * 2 ^ N.of_nat k - 2) + 17)%N in
  mkF ([uS1; uD0] ++ repeat uD1 (k + 4) ++ uD0 :: digits 3 ((o0 - 1) / 2)) 1 1 (j0 - 1) j0
      (2 ^ N.of_nat (k + 9)).

Definition sc_ok (k o0 : nat) : bool :=
  (if Nat.eqb k O && Nat.eqb o0 1%nat then true else frun 100 10000 (sc_direct k o0)) &&
  frun 100 (k + 9) (sc_fam k o0).

Fixpoint upto (n : nat) : list nat := match n with O => [] | S n' => upto n' ++ [n'] end.

Lemma upto_In k n : k < n -> In k (upto n).
Proof.
  induction n as [|n IH]; intros H; [lia|]. cbn [upto]. apply in_or_app.
  destruct (Nat.eq_dec k n) as [->|Hne]; [right; left; reflexivity|left; apply IH; lia].
Qed.

Definition odds16 : list nat := [1%nat; 3; 5; 7; 9; 11; 13; 15].

Lemma sc_all : forallb (fun k => forallb (fun o0 => sc_ok k o0) odds16) (upto 41) = true.
Proof. vm_compute. reflexivity. Qed.

Lemma sc_ok_of k o0 : k <= 40 -> In o0 odds16 -> sc_ok k o0 = true.
Proof.
  intros Hk Ho. pose proof sc_all as H.
  rewrite forallb_forall in H. specialize (H k (upto_In k 41 ltac:(lia))).
  rewrite forallb_forall in H. apply H. exact Ho.
Qed.

Lemma odd_decomp n : 0 < n -> exists k o, n = o * 2 ^ k /\ Nat.odd o = true.
Proof.
  induction n as [n IH] using lt_wf_ind. intros Hn.
  destruct (Nat.odd n) eqn:Eo.
  - exists O, n. split; [cbn; lia|exact Eo].
  - assert (Ee : Nat.even n = true) by (rewrite <- Nat.negb_odd, Eo; reflexivity).
    apply Nat.even_spec in Ee. destruct Ee as [m Hm].
    destruct (IH m ltac:(lia) ltac:(lia)) as [k [o [E1 E2]]].
    exists (S k), o. split; [rewrite Nat.pow_succ_r'; lia|exact E2].
Qed.

Lemma Cst_zone k q b : b + 2 = (2 * q + 1) * 2 ^ k ->
  fst (fst (Cst b)) = [uS1; uD0; uD1; uD1; uD1; uD1] ++ repeat uD1 k ++ bin (2 * q).
Proof.
  intros H. cbn [Cst fst]. f_equal. rewrite <- bin_ones. f_equal.
  rewrite Nat.pow_add_r, Nat.pow_1_r. pose proof (Nat.pow_nonzero 2 k). nia.
Qed.

Lemma odd_mod16 o : Nat.odd o = true -> In (o mod 16) odds16.
Proof.
  intros H. assert (Ho : o mod 2 = 1%nat).
  { rewrite Nat.odd_spec in H. destruct H as [m Hm]. subst. rewrite Nat.add_comm, Nat.mul_comm, Nat.Div0.mod_add. reflexivity. }
  assert (E : o mod 16 mod 2 = 1%nat).
  { transitivity (o mod 2); [|exact Ho]. rewrite (Nat.div_mod_eq o 16) at 2.
    replace (16 * (o / 16) + o mod 16) with (o mod 16 + (8 * (o / 16)) * 2) by lia.
    rewrite Nat.Div0.mod_add. reflexivity. }
  assert (o mod 16 < 16) by (apply Nat.mod_upper_bound; lia).
  remember (o mod 16) as r. clear -E H0.
  do 16 (destruct r as [|r]; [cbn in E; try discriminate; cbn; tauto|]). lia.
Qed.

Lemma odds16_half r : In r odds16 -> r = 2 * ((r - 1) / 2) + 1.
Proof. cbn. intros H. repeat (destruct H as [<-|H]; [reflexivity|]). destruct H. Qed.

Theorem small_classes b k o : b + 2 = o * 2 ^ k -> Nat.odd o = true -> k <= 40 ->
  exists b', CSplus (Cst b) (Cst b').
Proof.
  intros Hb Ho Hk.
  set (o0 := o mod 16).
  assert (Hin : In o0 odds16) by (apply odd_mod16; exact Ho).
  pose proof (sc_ok_of k o0 Hk Hin) as Hok. unfold sc_ok in Hok.
  apply andb_prop in Hok. destruct Hok as [Hd Hf].
  assert (Hpk := Nat.pow_nonzero 2 k ltac:(lia)).
  assert (Ho16 : o = o0 + 16 * (o / 16)) by (unfold o0; pose proof (Nat.div_mod o 16); lia).
  assert (Hq0 : o0 = 2 * ((o0 - 1) / 2) + 1) by (apply odds16_half; exact Hin).
  destruct (o / 16) as [|t] eqn:Et.
  - (* o = o0: direct run *)
    rewrite Nat.mul_0_r, Nat.add_0_r in Ho16.
    destruct (Nat.eqb k O && Nat.eqb o0 1%nat) eqn:E0.
    { apply andb_prop in E0. destruct E0 as [E1 E2]. apply Nat.eqb_eq in E1, E2. subst k.
      rewrite E2 in Ho16. subst o. cbn in Hb. lia. }
    destruct (frun_sound _ _ _ Hd 0) as [b' Hb'].
    exists b'. replace (Cst b) with (fz (sc_direct k o0) 0); [exact Hb'|].
    unfold fz, sc_direct, Cst, Zcl. cbn [fX fy fay fD fj faD].
    assert (Eb : (N.of_nat o0 * 2 ^ N.of_nat k - 2 = N.of_nat b)%N).
    { apply N2Nat.inj. rewrite Nat2N.id, N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, !Nat2N.id.
      change (N.to_nat 2) with 2%nat. rewrite <- Ho16. lia. }
    rewrite Eb. cbn [N.to_nat]. rewrite !Nat.mul_0_r, !Nat.add_0_r, bin_0, app_nil_r.
    f_equal; [f_equal|].
    + f_equal. unfold bin. f_equal. lia.
    + rewrite N2Nat.inj_add, N2Nat.inj_mul, Nat2N.id. reflexivity.
    + rewrite N2Nat.inj_add, N2Nat.inj_mul, Nat2N.id. reflexivity.
  - (* o = o0 + 16 (1 + t): the family at u = t *)
    destruct (frun_sound _ _ _ Hf t) as [b' Hb'].
    exists b'. replace (Cst b) with (fz (sc_fam k o0) t); [exact Hb'|].
    set (q0 := (o0 - 1) / 2) in *.
    set (q := q0 + 8 * (1 + t)).
    assert (Hoq : o = 2 * q + 1) by (unfold q; lia).
    assert (Hz := Cst_zone k q b ltac:(rewrite <- Hoq; exact Hb)).
    destruct (Cst b) as [[zc dc] jc] eqn:EC. cbn [fst] in Hz. subst zc.
    unfold Cst in EC. inversion EC; subst dc jc. clear EC.
    unfold fz, sc_fam. cbn [fX fy fay fD fj faD].
    f_equal; [f_equal|].
    + rewrite Nat.add_comm, repeat_app. cbn [repeat app]. rewrite <- !app_assoc. cbn [app].
      do 6 f_equal. f_equal.
      rewrite (bin_pos (2 * q)) by (unfold q; lia).
      rewrite dig_even. f_equal.
      replace (2 * q / 2) with q by (rewrite Nat.mul_comm, Nat.div_mul; lia).
      change (N.to_nat 1) with 1%nat.
      rewrite digits_app_bin.
      * f_equal. unfold q, q0. cbn. lia.
      * assert (o0 < 16) by (unfold o0; apply Nat.mod_upper_bound; lia).
        change (2 ^ 3) with 8%nat. apply Nat.Div0.div_lt_upper_bound. lia.
      * lia.
    + rewrite N2Nat.inj_sub, N2Nat.inj_add, N2Nat.inj_mul, N2Nat.inj_sub, N2Nat.inj_mul,
        !N2Nat.inj_pow, N2Nat.inj_add, !Nat2N.id.
      change (N.to_nat 2) with 2%nat. change (N.to_nat 32) with 32%nat.
      change (N.to_nat 16) with 16%nat. change (N.to_nat 17) with 17%nat. change (N.to_nat 1) with 1%nat.
      rewrite Nat.pow_add_r. change (2 ^ 9) with 512%nat.
      assert (2 <= (o0 + 16) * 2 ^ k) by nia.
      rewrite Ho16 in Hb. nia.
    + rewrite N2Nat.inj_add, N2Nat.inj_mul, N2Nat.inj_sub, N2Nat.inj_mul,
        !N2Nat.inj_pow, N2Nat.inj_add, !Nat2N.id.
      change (N.to_nat 2) with 2%nat. change (N.to_nat 32) with 32%nat.
      change (N.to_nat 16) with 16%nat. change (N.to_nat 17) with 17%nat.
      rewrite Nat.pow_add_r. change (2 ^ 9) with 512%nat.
      assert (2 <= (o0 + 16) * 2 ^ k) by nia.
      rewrite Ho16 in Hb. nia.
Qed.

(* ===================================================================== *)
(* 17. Value forms (proof.md 6.2): digits of V with heads at positions   *)
(*     0..3 and the marker P at position L.                              *)
(* ===================================================================== *)

Fixpoint vfl (hs : list (list unt)) (L V : nat) : list unt :=
  match L with
  | O => uP :: bin V
  | S L' => hd [] hs ++ dig V :: vfl (tl hs) L' (V / 2)
  end.

Fixpoint vlow (hs : list (list unt)) (L R V : nat) : list unt :=
  match L with
  | O => uP :: digits R V
  | S L' =>
      match R with
      | O => []
      | S R' => hd [] hs ++ dig V :: vlow (tl hs) L' R' (V / 2)
      end
  end.

Lemma digits_mod R V s : digits R (V + 2 ^ R * s) = digits R V.
Proof.
  revert V; induction R as [|R IH]; intros V; [reflexivity|].
  cbn [digits]. rewrite Nat.pow_succ_r'.
  replace (V + 2 * 2 ^ R * s) with (V + 2 * (2 ^ R * s)) by lia.
  rewrite dig_add_even, div2_add_even, IH. reflexivity.
Qed.

Lemma digits_bin_split R V : 2 ^ R <= V -> bin V = digits R V ++ bin (V / 2 ^ R).
Proof.
  intros H. pose proof (Nat.pow_nonzero 2 R ltac:(lia)) as Hp.
  pose proof (Nat.div_mod_eq V (2 ^ R)) as Ed.
  assert (E : digits R V = digits R (V mod 2 ^ R)).
  { rewrite <- (digits_mod R (V mod 2 ^ R) (V / 2 ^ R)). f_equal. lia. }
  rewrite E, digits_app_bin.
  - f_equal. lia.
  - apply Nat.mod_upper_bound. lia.
  - apply Nat.div_str_pos. lia.
Qed.

Lemma vfl_split hs L R V : L < R -> 2 ^ R <= V -> vfl hs L V = vlow hs L R V ++ bin (V / 2 ^ R).
Proof.
  revert hs R V; induction L as [|L IH]; intros hs R V HL HV.
  - cbn [vfl vlow app]. f_equal. apply digits_bin_split. exact HV.
  - destruct R as [|R]; [lia|]. cbn [vfl vlow]. rewrite <- app_assoc. cbn [app]. f_equal. f_equal.
    rewrite (IH (tl hs) R (V / 2)) by (try lia; rewrite Nat.pow_succ_r' in HV; apply Nat.div_le_lower_bound; lia).
    f_equal. f_equal. rewrite Nat.Div0.div_div. rewrite Nat.pow_succ_r'. reflexivity.
Qed.

Lemma vlow_mod hs L R V s : vlow hs L R (V + 2 ^ R * s) = vlow hs L R V.
Proof.
  revert hs R V; induction L as [|L IH]; intros hs R V.
  - cbn [vlow]. rewrite digits_mod. reflexivity.
  - destruct R as [|R]; [reflexivity|]. cbn [vlow]. rewrite Nat.pow_succ_r'.
    replace (V + 2 * 2 ^ R * s) with (V + 2 * (2 ^ R * s)) by lia.
    rewrite dig_add_even, div2_add_even, IH. reflexivity.
Qed.

(* rows: heads at positions 0..3, lambda, mu, the w slope alpha, w = alpha off + wp - wn, D = j - d *)
Record vrow := mkV { vh : list (list unt); vlam : nat; vmu : nat; val_ : nat; vwp : nat; vwn : nat; vd : nat }.

Definition phrows : list vrow :=
  [ mkV [[uS1]] 24 1 1 0 20 2;
    mkV [[uS1]] 24 1 1 0 20 2;
    mkV [[]; [uS1]] 24 1 1 0 20 2;
    mkV [[]; [uSP]] 25 2 2 0 42 3;
    mkV [[uS1; uP; uP]] 24 1 1 0 24 4;
    mkV [[]; []; [uS1]] 24 1 1 0 21 2;
    mkV [[]; [uS1; uP]] 24 1 1 0 24 3;
    mkV [[uS1; uP; uP]] 24 1 1 0 24 4 ].

Definition phrow (phi : nat) : vrow := nth phi phrows (mkV [] 24 1 1 0 24 4).

Definition vfz (r : vrow) (k Om off : nat) : st :=
  let L := k + vlam r - off in
  let V := vmu r * Om + val_ r * off + vwp r - (vwn r + 3 * 2 ^ (L - 1)) in
  let j := Om + off - 64 in
  (vfl (vh r) L V, j - vd r, j).

Definition off_end (k : nat) : nat := if Nat.eqb ((k + 20) mod 8) 3 then k + 21 else k + 20.

Definition VFe (k Om : nat) : st := vfz (phrow (off_end k mod 8)) k Om (off_end k).

(* the same in N, for the family bases *)
Fixpoint digitsN (r : nat) (v : N) : list unt :=
  match r with O => [] | S r' => digN v :: digitsN r' (N.div2 v) end.

Lemma digitsN_spec r v : digitsN r v = digits r (N.to_nat v).
Proof.
  revert v; induction r as [|r IH]; intros v; [reflexivity|]. cbn [digitsN digits].
  rewrite IH, digN_dig, N2Nat.inj_div2, Nat.div2_div. reflexivity.
Qed.

Fixpoint vlowN (hs : list (list unt)) (L R : nat) (V : N) : list unt :=
  match L with
  | O => uP :: digitsN R V
  | S L' =>
      match R with
      | O => []
      | S R' => hd [] hs ++ digN V :: vlowN (tl hs) L' R' (N.div2 V)
      end
  end.

Lemma vlowN_spec hs L R V : vlowN hs L R V = vlow hs L R (N.to_nat V).
Proof.
  revert hs R V; induction L as [|L IH]; intros hs R V; cbn [vlowN vlow].
  - rewrite digitsN_spec. reflexivity.
  - destruct R; [reflexivity|]. rewrite IH, digN_dig, N2Nat.inj_div2, Nat.div2_div. reflexivity.
Qed.

(* the family of VF states at the end offset: base (k0, Om0), cut R; all in N *)
Definition off_endN (k : N) : N := if N.eqb ((k + 20) mod 8) 3 then (k + 21)%N else (k + 20)%N.

Definition egr (k0 : N) : vrow := phrow (N.to_nat (off_endN k0 mod 8)).

Definition egL (k0 : N) : nat := N.to_nat (k0 + N.of_nat (vlam (egr k0)) - off_endN k0).

Definition egV (k0 : N) (Om0 : N) : N :=
  (N.of_nat (vmu (egr k0)) * Om0 + N.of_nat (val_ (egr k0)) * off_endN k0 + N.of_nat (vwp (egr k0)) -
   N.of_nat (vwn (egr k0) + 3 * 2 ^ (egL k0 - 1)))%N.

Definition egF (k0 : N) (Om0 : N) (R : nat) : fam :=
  let j0 := (Om0 + off_endN k0 - 64)%N in
  mkF (vlowN (vh (egr k0)) (egL k0) R (egV k0 Om0)) (egV k0 Om0 / 2 ^ N.of_nat R) 1
      (j0 - N.of_nat (vd (egr k0))) j0 (2 ^ N.of_nat R).

Definition egok (k0 : N) (Om0 : N) (R : nat) : bool :=
  Nat.ltb (egL k0) R && N.leb (2 ^ N.of_nat R) (egV k0 Om0) && N.leb 64 Om0 &&
  Nat.eqb (vmu (egr k0)) 1 && Nat.eqb (val_ (egr k0)) 1 && Nat.leb (vd (egr k0)) 20 &&
  frun 120 R (egF k0 Om0 R).

Definition egbase (kap : nat) : N := N.of_nat (if Nat.ltb kap 41 then kap + 4096 else kap).

Definition eg_ok (kap : nat) : bool :=
  Nat.eqb ((kap + 9) mod 2048) O || egok (egbase kap) (2 ^ 46) 12.

Lemma eg_all : forallb eg_ok (upto 4096) = true.
Proof. vm_compute. reflexivity. Qed.

Definition ns_ok (v : nat) (s0 : N) : bool :=
  egok (s0 * 2 ^ N.of_nat v - 9) (2 ^ N.of_nat (v + 10)) (v + 2).

Lemma ns_all : forallb (fun v => ns_ok (v + 11) 1 && ns_ok (v + 11) 3) (upto 40) = true.
Proof. vm_compute. reflexivity. Qed.

Lemma off_endN_spec k : N.to_nat (off_endN k) = off_end (N.to_nat k).
Proof.
  unfold off_endN, off_end.
  replace (N.eqb ((k + 20) mod 8) 3) with (Nat.eqb ((N.to_nat k + 20) mod 8) 3).
  - destruct (Nat.eqb _ _); lia.
  - rewrite <- (N2Nat.id ((k + 20) mod 8)). rewrite N2Nat.inj_mod, N2Nat.inj_add.
    change (N.to_nat 20) with 20%nat. change (N.to_nat 8) with 8%nat.
    destruct (Nat.eqb_spec ((N.to_nat k + 20) mod 8) 3) as [E|E]; symmetry.
    + apply N.eqb_eq. rewrite E. reflexivity.
    + apply N.eqb_neq. intros C. apply E. apply (f_equal N.to_nat) in C. rewrite Nat2N.id in C. exact C.
Qed.

Lemma mod8_of k k0 R : 3 <= R -> k0 <= k -> (k - k0) mod 2 ^ R = O -> k mod 8 = k0 mod 8.
Proof.
  intros HR Hk H. apply Nat.Div0.mod_divides in H. destruct H as [c Hc].
  replace k with (k0 + (2 ^ (R - 3) * c) * 8).
  - apply Nat.Div0.mod_add.
  - replace R with (3 + (R - 3)) in Hc by lia. rewrite Nat.pow_add_r in Hc. cbn in Hc. lia.
Qed.

Lemma off_end_shift k k0 : k mod 8 = k0 mod 8 -> off_end k = k + (off_end k0 - k0) /\ k0 + 20 <= off_end k0 /\
  off_end k mod 8 = off_end k0 mod 8.
Proof.
  intros H. unfold off_end.
  assert (E : (k + 20) mod 8 = (k0 + 20) mod 8).
  { rewrite (Nat.Div0.add_mod k), (Nat.Div0.add_mod k0), H. reflexivity. }
  rewrite E. destruct (Nat.eqb ((k0 + 20) mod 8) 3); (split; [lia|split; [lia|]]).
  - replace (k + 21) with (k + 21) by reflexivity. rewrite (Nat.Div0.add_mod k), (Nat.Div0.add_mod k0), H. reflexivity.
  - rewrite (Nat.Div0.add_mod k), (Nat.Div0.add_mod k0), H. reflexivity.
Qed.

Lemma eg_family k0 Om0 R k Om : egok k0 Om0 R = true -> 3 <= R -> N.to_nat k0 <= k ->
  (k - N.to_nat k0) mod 2 ^ R = O -> N.to_nat Om0 <= Om -> (Om - N.to_nat Om0) mod 2 ^ R = O ->
  exists b', CSplus (VFe k Om) (Cst b').
Proof.
  intros Hok HR Hk HkR HO HOR.
  unfold egok in Hok.
  apply andb_prop in Hok. destruct Hok as [Hok Hrun].
  apply andb_prop in Hok. destruct Hok as [Hok Hd].
  apply andb_prop in Hok. destruct Hok as [Hok Hal].
  apply andb_prop in Hok. destruct Hok as [Hok Hmu].
  apply andb_prop in Hok. destruct Hok as [Hok H64].
  apply andb_prop in Hok. destruct Hok as [HL HV].
  apply Nat.ltb_lt in HL. apply N.leb_le in HV, H64. apply Nat.eqb_eq in Hmu, Hal. apply Nat.leb_le in Hd.
  assert (Hpr := Nat.pow_nonzero 2 R ltac:(lia)).
  apply Nat.Div0.mod_divides in HkR, HOR. destruct HkR as [ck Hck], HOR as [cO HcO].
  set (u := cO + ck).
  destruct (frun_sound _ _ _ Hrun u) as [b' Hb']. exists b'.
  replace (VFe k Om) with (fz (egF k0 Om0 R) u); [exact Hb'|].
  set (n0 := N.to_nat k0) in *.
  assert (H8 : k mod 8 = n0 mod 8).
  { apply (mod8_of k n0 R); auto. rewrite Hck, Nat.mul_comm, Nat.Div0.mod_mul. reflexivity. }
  destruct (off_end_shift k n0 H8) as [Eoff [Hoff Eom]].
  set (off0 := off_end n0) in *.
  assert (Eo0 : N.to_nat (off_endN k0) = off0) by (unfold off0, n0; apply off_endN_spec).
  assert (Er : egr k0 = phrow (off_end k mod 8)).
  { unfold egr. rewrite Eom. f_equal. rewrite N2Nat.inj_mod, Eo0. reflexivity. }
  set (r := egr k0) in *.
  assert (EL : egL k0 = k + vlam r - off_end k).
  { unfold egL. fold r. rewrite N2Nat.inj_sub, N2Nat.inj_add, Nat2N.id, Eo0. fold n0. lia. }
  set (L := egL k0) in *.
  set (Om0' := N.to_nat Om0) in *.
  assert (EV0 : N.to_nat (egV k0 Om0) = Om0' + off0 + vwp r - (vwn r + 3 * 2 ^ (L - 1))).
  { unfold egV. fold r L. rewrite N2Nat.inj_sub, !N2Nat.inj_add, !N2Nat.inj_mul, !Nat2N.id, Eo0, Hmu, Hal.
    fold Om0'. lia. }
  set (V0 := N.to_nat (egV k0 Om0)) in *.
  assert (HV' : 2 ^ R <= V0).
  { unfold V0. replace (2 ^ R) with (N.to_nat (2 ^ N.of_nat R)) by (rewrite N2Nat.inj_pow, Nat2N.id; reflexivity). lia. }
  assert (EV : vmu r * Om + val_ r * off_end k + vwp r - (vwn r + 3 * 2 ^ (k + vlam r - off_end k - 1))
               = V0 + 2 ^ R * u).
  { rewrite <- EL. fold L. rewrite Hmu, Hal. unfold u. rewrite Eoff. lia. }
  unfold VFe, vfz. rewrite <- Er. fold r. rewrite EV, <- EL. fold L.
  unfold fz, egF. cbn [fX fy fay fD fj faD]. fold r L. rewrite vlowN_spec. fold V0.
  assert (Ep : N.to_nat (2 ^ N.of_nat R) = 2 ^ R) by (rewrite N2Nat.inj_pow, Nat2N.id; reflexivity).
  f_equal; [f_equal|].
  - rewrite (vfl_split (vh r) L R (V0 + 2 ^ R * u)) by lia.
    rewrite vlow_mod, div_mod_shift. f_equal. f_equal.
    rewrite N2Nat.inj_div, Ep. change (N.to_nat 1) with 1%nat. fold V0. lia.
  - rewrite Ep, N2Nat.inj_sub, N2Nat.inj_sub, N2Nat.inj_add, Eo0, Nat2N.id.
    change (N.to_nat 64) with 64%nat. fold Om0'. unfold u. rewrite Eoff.
    assert (64 <= Om0') by (unfold Om0'; lia). lia.
  - rewrite Ep, N2Nat.inj_sub, N2Nat.inj_add, Eo0.
    change (N.to_nat 64) with 64%nat. fold Om0'. unfold u. rewrite Eoff.
    assert (64 <= Om0') by (unfold Om0'; lia). lia.
Qed.

Lemma pow_le_mono2 a b : a <= b -> 2 ^ a <= 2 ^ b.
Proof. intros H. apply Nat.pow_le_mono_r; lia. Qed.

Lemma pow_mod_sub a b c U : c <= a -> c <= b -> 2 ^ b <= U * 2 ^ a -> (U * 2 ^ a - 2 ^ b) mod 2 ^ c = O.
Proof.
  intros Ha Hb H.
  replace a with (c + (a - c)) by lia. replace b with (c + (b - c)) by lia.
  rewrite !Nat.pow_add_r.
  replace (U * (2 ^ c * 2 ^ (a - c)) - 2 ^ c * 2 ^ (b - c)) with ((U * 2 ^ (a - c) - 2 ^ (b - c)) * 2 ^ c).
  - apply Nat.Div0.mod_mul.
  - rewrite Nat.mul_sub_distr_r. f_equal; lia.
Qed.

(* the endgame of proof.md 6.4 with the cut R = 12 (proof.md 10): nu2(k + 9) <= 10 *)
Theorem endgame k U : 41 <= k -> (k + 9) mod 2048 <> O -> 1 <= U ->
  exists b', CSplus (VFe k (U * 2 ^ (k + 5))) (Cst b').
Proof.
  intros Hk Hv HU.
  set (kap := k mod 4096).
  assert (Hkap : kap < 4096) by (apply Nat.mod_upper_bound; lia).
  pose proof eg_all as H. rewrite forallb_forall in H. specialize (H kap (upto_In _ _ Hkap)).
  unfold eg_ok in H.
  assert (Ev : (kap + 9) mod 2048 = (k + 9) mod 2048).
  { unfold kap. rewrite (Nat.div_mod_eq k 4096) at 2.
    replace (4096 * (k / 4096) + k mod 4096 + 9) with ((k mod 4096 + 9) + (2 * (k / 4096)) * 2048) by lia.
    rewrite Nat.Div0.mod_add. reflexivity. }
  rewrite Ev in H. destruct (Nat.eqb_spec ((k + 9) mod 2048) O) as [E|_]; [contradiction|]. cbn [orb] in H.
  assert (Ek : k = 4096 * (k / 4096) + kap) by (apply Nat.div_mod_eq).
  assert (E0 : N.to_nat (egbase kap) = if Nat.ltb kap 41 then kap + 4096 else kap).
  { unfold egbase. apply Nat2N.id. }
  assert (Hpk : 2 ^ 46 <= 2 ^ (k + 5)) by (apply pow_le_mono2; lia).
  eapply (eg_family (egbase kap) (2 ^ 46) 12); [exact H|lia| | | |].
  - rewrite E0. destruct (Nat.ltb_spec kap 41); [|lia].
    assert (1 <= k / 4096) by (destruct (k / 4096); lia). lia.
  - rewrite E0. replace (2 ^ 12) with 4096 by reflexivity.
    destruct (Nat.ltb_spec kap 41).
    + assert (1 <= k / 4096) by (destruct (k / 4096); lia).
      replace (k - (kap + 4096)) with ((k / 4096 - 1) * 4096) by lia. apply Nat.Div0.mod_mul.
    + replace (k - kap) with ((k / 4096) * 4096) by lia. apply Nat.Div0.mod_mul.
  - rewrite N2Nat.inj_pow. change (N.to_nat 2) with 2%nat. change (N.to_nat 46) with 46%nat. nia.
  - rewrite N2Nat.inj_pow. change (N.to_nat 2) with 2%nat. change (N.to_nat 46) with 46%nat.
    apply pow_mod_sub; [lia|lia|nia].
Qed.

(* the nested range of proof.md 6.5 for 11 <= v <= 50 (proof.md 10) *)
Theorem nested k U s v : k + 9 = s * 2 ^ v -> Nat.odd s = true -> 11 <= v <= 50 -> 1 <= U ->
  exists b', CSplus (VFe k (U * 2 ^ (k + 5))) (Cst b').
Proof.
  intros Hks Hs Hv HU.
  pose proof ns_all as H. rewrite forallb_forall in H.
  specialize (H (v - 11) (upto_In (v - 11) 40 ltac:(lia))). replace (v - 11 + 11) with v in H by lia.
  apply andb_prop in H. destruct H as [H1 H3].
  assert (Hpv := Nat.pow_nonzero 2 v ltac:(lia)).
  assert (Hv2 : 2 ^ 11 <= 2 ^ v) by (apply pow_le_mono2; lia).
  change (2 ^ 11) with 2048%nat in Hv2.
  assert (Hsm : s mod 4 = 1%nat \/ s mod 4 = 3).
  { rewrite Nat.odd_spec in Hs. destruct Hs as [m Hm]. subst s.
    pose proof (Nat.mod_upper_bound (2 * m + 1) 4 ltac:(lia)).
    assert (E : (2 * m + 1) mod 4 = (2 * (m mod 2) + 1) mod 4).
    { rewrite (Nat.div_mod_eq m 2) at 1.
      replace (2 * (2 * (m / 2) + m mod 2) + 1) with ((2 * (m mod 2) + 1) + (m / 2) * 4) by lia.
      apply Nat.Div0.mod_add. }
    pose proof (Nat.mod_upper_bound m 2 ltac:(lia)).
    destruct (m mod 2) as [|[|]] eqn:Em; [left|right|lia]; rewrite E; reflexivity. }
  assert (Hdec : s = 4 * (s / 4) + s mod 4) by apply Nat.div_mod_eq.
  assert (Hk5 : v + 10 <= k + 5).
  { assert (v + 6 <= 2 ^ v).
    { clear -Hv. assert (forall n, 4 <= n -> n + 6 <= 2 ^ n).
      { induction n; intros Hn; [lia|]. destruct (Nat.eq_dec n 3) as [->|]; [cbn; lia|].
        rewrite Nat.pow_succ_r'. specialize (IHn ltac:(lia)). lia. }
      apply H; lia. }
    assert (1 <= s) by (destruct s; [discriminate|lia]). nia. }
  assert (Hpk : 2 ^ (v + 10) <= 2 ^ (k + 5)) by (apply pow_le_mono2; lia).
  destruct Hsm as [Hsm|Hsm]; rewrite Hsm in Hdec.
  - eapply (eg_family _ _ (v + 2) k _ H1); [lia| | | |].
    + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id. change (N.to_nat 1) with 1%nat.
      change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat. nia.
    + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id. change (N.to_nat 1) with 1%nat.
      change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat.
      replace (k - (1 * 2 ^ v - 9)) with ((s / 4) * 2 ^ (v + 2)).
      * apply Nat.Div0.mod_mul.
      * rewrite Nat.pow_add_r. change (2 ^ 2) with 4%nat. nia.
    + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. nia.
    + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. apply pow_mod_sub; [lia|lia|nia].
  - eapply (eg_family _ _ (v + 2) k _ H3); [lia| | | |].
    + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id.
      change (N.to_nat 3) with 3%nat. change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat. nia.
    + rewrite N2Nat.inj_sub, N2Nat.inj_mul, N2Nat.inj_pow, Nat2N.id.
      change (N.to_nat 3) with 3%nat. change (N.to_nat 2) with 2%nat. change (N.to_nat 9) with 9%nat.
      replace (k - (3 * 2 ^ v - 9)) with ((s / 4) * 2 ^ (v + 2)).
      * apply Nat.Div0.mod_mul.
      * rewrite Nat.pow_add_r. change (2 ^ 2) with 4%nat. nia.
    + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. nia.
    + rewrite N2Nat.inj_pow, Nat2N.id. change (N.to_nat 2) with 2%nat. apply pow_mod_sub; [lia|lia|nia].
Qed.

Lemma odd_not_mod2048 s v : Nat.odd s = true -> v <= 10 -> (s * 2 ^ v) mod 2048 <> O.
Proof.
  intros Hs Hv E. apply Nat.Div0.mod_divides in E. destruct E as [t Ht].
  assert (E2 : 2048 = 2 ^ v * 2 ^ (11 - v)).
  { rewrite <- Nat.pow_add_r. replace (v + (11 - v)) with 11 by lia. reflexivity. }
  rewrite E2 in Ht.
  assert (Hp := Nat.pow_nonzero 2 v ltac:(lia)).
  assert (Es : s = 2 ^ (11 - v) * t).
  { apply (Nat.mul_cancel_r _ _ (2 ^ v)); [lia|]. rewrite Ht. lia. }
  replace (11 - v) with (S (10 - v)) in Es by lia. rewrite Nat.pow_succ_r' in Es.
  rewrite Es in Hs. rewrite <- Nat.mul_assoc in Hs. rewrite Nat.odd_mul in Hs. discriminate.
Qed.

(* E(K) of proof.md 6.5 for every K with nu2(K + 9) <= 50, without induction hypothesis *)
Theorem E_low K U s v : 41 <= K -> K + 9 = s * 2 ^ v -> Nat.odd s = true -> v <= 50 -> 1 <= U ->
  exists b', CSplus (VFe K (U * 2 ^ (K + 5))) (Cst b').
Proof.
  intros HK Hks Hs Hv HU.
  destruct (Nat.le_gt_cases v 10) as [Hle|Hgt].
  - apply endgame; [exact HK| |exact HU]. rewrite Hks. apply odd_not_mod2048; auto.
  - eapply nested; [exact Hks|exact Hs|lia|exact HU].
Qed.


(* ===================================================================== *)
(* 18. Counter words above a cut, and one closed-system step with a      *)
(*     concrete low part and an arbitrary counter word above it.         *)
(* ===================================================================== *)

Definition ctr (Yc : nat -> list unt) : Prop := forall n e, IncN e (Yc n) (Yc (n + e)).

Lemma ctr_bin : ctr bin.
Proof. intros n e. apply IncN_bin. Qed.

Lemma vfl_nil m V : vfl [] m V = digits m V ++ uP :: bin (V / 2 ^ m).
Proof.
  revert V; induction m as [|m IH]; intros V.
  - cbn [vfl digits app]. rewrite Nat.pow_0_r, Nat.div_1_r. reflexivity.
  - cbn [vfl digits app hd tl]. rewrite IH. rewrite Nat.Div0.div_div, <- Nat.pow_succ_r'. reflexivity.
Qed.

Lemma ctr_vfl m : ctr (vfl [] m).
Proof.
  intros n e. rewrite !vfl_nil. apply IncN_digits. apply IncN_P.
  replace ((n + e) / 2 ^ m) with (n / 2 ^ m + (n mod 2 ^ m + e) / 2 ^ m).
  - apply IncN_bin.
  - pose proof (Nat.pow_nonzero 2 m ltac:(lia)).
    assert (E : n + e = (n mod 2 ^ m + e) + (n / 2 ^ m) * 2 ^ m) by (pose proof (Nat.div_mod_eq n (2 ^ m)); lia).
    rewrite E, Nat.div_add by lia. lia.
Qed.

Lemma astep X Yc n D j T0 e1 A X1 X3 :
  ctr Yc ->
  XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true ->
  T0 <= D + pj j ->
  shiftX (fill X1 (val X1 + (D + pj j + 3 * A - T0))) = Some X3 ->
  cs_step (X ++ Yc n) D j
    (X3 ++ Yc (n + (e1 + (val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1))) (D + A) (S j).
Proof.
  intros HY H1 Hd Hc HT Hs.
  apply (cutstep X (Yc n) T0 e1 A X1 (D + pj j) ((val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1)
           (fill X1 (val X1 + (D + pj j + 3 * A - T0))) D j
           (X3 ++ Yc (n + (e1 + (val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1)))
           (Yc (n + (e1 + (val X1 + (D + pj j + 3 * A - T0)) / 2 ^ ndig X1))) H1 Hd).
  - apply (XN_clean X1 (D + pj j + 3 * A - T0) Hc).
  - exact HT.
  - reflexivity.
  - apply HY.
  - apply shiftX_app. exact Hs.
Qed.

(* ===================================================================== *)
(* 19. Splitting value forms at a cut.                                   *)
(* ===================================================================== *)

Lemma vlow_L hs L L' R V : R < L -> R < L' -> vlow hs L R V = vlow hs L' R V.
Proof.
  revert hs L L' V; induction R as [|R IH]; intros hs L L' V H1 H2.
  - destruct L, L'; try lia. reflexivity.
  - destruct L as [|L], L' as [|L']; try lia. cbn [vlow]. rewrite (IH (tl hs) L L' (V / 2)) by lia. reflexivity.
Qed.

Lemma vfl_split_hi hs L R V : R < L -> length hs <= R ->
  vfl hs L V = vlow hs L R V ++ vfl [] (L - R) (V / 2 ^ R).
Proof.
  revert hs L V; induction R as [|R IH]; intros hs L V HL Hh.
  - destruct hs; [|cbn in Hh; lia]. destruct L as [|L]; [lia|].
    cbn [vlow app]. rewrite Nat.sub_0_r, Nat.pow_0_r, Nat.div_1_r. reflexivity.
  - destruct L as [|L]; [lia|]. cbn [vfl vlow]. rewrite <- app_assoc. cbn [app].
    rewrite (IH (tl hs) L (V / 2)) by (try lia; destruct hs; cbn in *; lia).
    replace (S L - S R) with (L - R) by lia.
    rewrite Nat.Div0.div_div, <- Nat.pow_succ_r'. reflexivity.
Qed.

Lemma vfl_split_le hs L R V : L <= R -> 2 ^ R <= V -> vfl hs L V = vlow hs L R V ++ bin (V / 2 ^ R).
Proof.
  revert hs R V; induction L as [|L IH]; intros hs R V HL HV.
  - cbn [vfl vlow app]. f_equal. apply digits_bin_split. exact HV.
  - destruct R as [|R]; [lia|]. cbn [vfl vlow]. rewrite <- app_assoc. cbn [app]. f_equal. f_equal.
    rewrite (IH (tl hs) R (V / 2)) by (try lia; rewrite Nat.pow_succ_r' in HV; apply Nat.div_le_lower_bound; lia).
    f_equal. f_equal. rewrite Nat.Div0.div_div. rewrite Nat.pow_succ_r'. reflexivity.
Qed.

Lemma lsteqb_eq a b : lsteqb a b = true -> a = b.
Proof. unfold lsteqb. destruct (list_eq_dec unt_eq_dec a b); [auto|discriminate]. Qed.

(* ===================================================================== *)
(* 20. One descent step of a value form (Lemma VS of proof.md 6.3),      *)
(*     symbolic in Omega, off and the marker height: the check runs the  *)
(*     first T0 = 4096 carries on the low 8 digits (with the heads, and  *)
(*     the marker when L <= 8), the rest of the carry phase by counter   *)
(*     arithmetic on residues, and the absorption shift; the identities *)
(*     on the coefficients of Omega, off and 2^(L-1) make the next state *)
(*     the next value form for every member.                             *)
(* ===================================================================== *)

Definition vzf (r : vrow) (o L : nat) (low : bool) : Z :=
  (Z.of_nat (val_ r * o + vwp r) - Z.of_nat (vwn r) - (if low then Z.of_nat (3 * 2 ^ (L - 1)) else 0))%Z.

Definition vt0 (r : vrow) (off0 a : nat) (X1 : list unt) : Z :=
  (Z.of_nat (val X1 + off0 + pj off0 + 3 * a) - Z.of_nat (64 + vd r + 4096))%Z.

Definition vsrun (r : vrow) (off0 Lc : nat) : option (list unt * N * nat * list unt * list unt) :=
  match xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256))) with
  | None => None
  | Some (Xt, e1) =>
    match splitP Xt with
    | (a, X1) =>
      match shiftX (fillN X1 (Z.to_N (vt0 r off0 a X1 mod 2 ^ Z.of_nat (ndig X1)))) with
      | None => None
      | Some X3 => Some (Xt, e1, a, X1, X3)
      end
    end
  end.

Definition vscond (fx : bool) (r r' : vrow) (off0 Lc : nat) (e1 : N) (a : nat) (X1 X3 : list unt) : bool :=
  let low := Nat.leb Lc 8 in
  let L2 := if low then Lc + ndig X3 - 8 else S (ndig X3) in
  dhead X1 && allb cleanu X1 && Nat.leb 5 Lc && Nat.leb Lc 9 &&
  Nat.eqb (vlam r' + 8) (vlam r + 1 + ndig X3) && Nat.eqb (vd r' + a) (vd r + 1) &&
  Nat.leb (length (vh r')) (ndig X3) && Nat.leb (length (vh r)) 8 && Nat.leb 9 (Lc + ndig X3) &&
  Nat.leb (ndig X1) 8 && Nat.leb (ndig X3) 8 && Nat.leb 1 L2 && Nat.leb L2 (if low then ndig X3 else S (ndig X3)) &&
  lsteqb X3 (vlowN (vh r') L2 (ndig X3) (Z.to_N (vzf r' (S off0) L2 low mod 2 ^ Z.of_nat (ndig X3)))) &&
  Z.eqb (vzf r off0 Lc low / 256 + Z.of_N e1 + vt0 r off0 a X1 / 2 ^ Z.of_nat (ndig X1))
        (vzf r' (S off0) L2 low / 2 ^ Z.of_nat (ndig X3)) &&
  Nat.eqb (vmu r + 2 ^ (8 - ndig X1)) (vmu r' * 2 ^ (8 - ndig X3)) &&
  (fx || Nat.eqb (val_ r + 2 ^ (8 - ndig X1)) (val_ r' * 2 ^ (8 - ndig X3))).

Definition vsok (fx : bool) (r r' : vrow) (off0 Lc : nat) : bool :=
  match vsrun r off0 Lc with
  | Some (Xt, e1, a, X1, X3) => vscond fx r r' off0 Lc e1 a X1 X3
  | None => false
  end.

Lemma vsrun_spec r off0 Lc Xt e1 a X1 X3 : vsrun r off0 Lc = Some (Xt, e1, a, X1, X3) ->
  xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256))) = Some (Xt, e1) /\
  splitP Xt = (a, X1) /\
  shiftX (fillN X1 (Z.to_N (vt0 r off0 a X1 mod 2 ^ Z.of_nat (ndig X1)))) = Some X3.
Proof.
  unfold vsrun.
  destruct (xfeed 4000 4096 (vlowN (vh r) Lc 8 (Z.to_N (vzf r off0 Lc (Nat.leb Lc 8) mod 256)))) as [[Xt' e1']|];
    [|discriminate].
  destruct (splitP Xt') as [a' X1'] eqn:ES.
  destruct (shiftX (fillN X1' (Z.to_N (vt0 r off0 a' X1' mod 2 ^ Z.of_nat (ndig X1'))))) as [X3'|] eqn:Es;
    [|discriminate].
  intros H. injection H as <- <- <- <- <-. auto.
Qed.

Lemma Zdm (z : Z) (m : nat) : 0 < m -> z = (Z.of_nat m * (z / Z.of_nat m) + z mod Z.of_nat m)%Z /\
  (0 <= z mod Z.of_nat m < Z.of_nat m)%Z.
Proof. intros H. split; [apply Z.div_mod; lia | apply Z.mod_pos_bound; lia]. Qed.

Lemma pj_shift8 off0 a : a mod 8 = O -> pj (off0 + a) = pj off0.
Proof.
  intros Ha. rewrite (pj_mod (off0 + a)), (pj_mod off0). f_equal.
  rewrite Nat.Div0.add_mod, Ha, Nat.add_0_r, Nat.Div0.mod_mod. reflexivity.
Qed.

Lemma vs_core r r' L V L' V' X0 Yc n n' D j e1 A X1 r2 M2 X3 :
  ctr Yc ->
  vfl (vh r) L V = X0 ++ Yc n -> vfl (vh r') L' V' = X3 ++ Yc n' ->
  XN 4096 X0 e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true ->
  4096 <= D + pj j -> val X1 + (D + pj j + 3 * A - 4096) = r2 + 2 ^ ndig X1 * M2 -> r2 < 2 ^ ndig X1 ->
  shiftX (fill X1 r2) = Some X3 -> n' = n + (e1 + M2) ->
  cs_step (vfl (vh r) L V) D j (vfl (vh r') L' V') (D + A) (S j).
Proof.
  intros HY Hz Hz' HX Hd Hc HT Hm Hr Hs Hn.
  rewrite Hz, Hz'.
  assert (E2 : (val X1 + (D + pj j + 3 * A - 4096)) / 2 ^ ndig X1 = M2).
  { rewrite Hm, div_mod_shift, Nat.div_small by exact Hr. lia. }
  assert (Hs' : shiftX (fill X1 (val X1 + (D + pj j + 3 * A - 4096))) = Some X3).
  { rewrite Hm, fill_mod. exact Hs. }
  pose proof (astep X0 Yc n D j 4096 e1 A X1 X3 HY HX Hd Hc HT Hs') as H.
  rewrite E2, <- Hn in H. exact H.
Qed.

Lemma Zpow_nat n : (2 ^ Z.of_nat n)%Z = Z.of_nat (2 ^ n).
Proof. rewrite Nat2Z.inj_pow. reflexivity. Qed.

Lemma pow_split n : n <= 8 -> 2 ^ n * 2 ^ (8 - n) = 256.
Proof. intros H. rewrite <- Nat.pow_add_r. replace (n + (8 - n)) with 8 by lia. reflexivity. Qed.

(* the arithmetic of one descent step, on plain numbers *)
Lemma ar_main (mu al wp wn mu' al' wp' wn' w g off0 lc lc2 hc P1 P3 Pn Pn3 PL PL' vX p a vdr : nat)
  (e1 : N) (vz vz2 t0 : Z) :
  vz = (Z.of_nat (al * off0 + wp) - Z.of_nat wn - Z.of_nat lc)%Z ->
  vz2 = (Z.of_nat (al' * S off0 + wp') - Z.of_nat wn' - Z.of_nat lc2)%Z ->
  3 * PL = lc + 768 * hc -> 3 * PL' = lc2 + 3 * Pn3 * hc ->
  Pn * P1 = 256 -> Pn3 * P3 = 256 -> 0 < Pn -> 0 < Pn3 ->
  t0 = (Z.of_nat (vX + off0 + p + 3 * a) - Z.of_nat (64 + vdr + 4096))%Z ->
  (vz / 256 + Z.of_N e1 + t0 / Z.of_nat Pn = vz2 / Z.of_nat Pn3)%Z ->
  mu + P1 = mu' * P3 -> (al + P1 = al' * P3 \/ g = O) ->
  wn + 3 * PL + 256 <= mu * (256 * w) + al * (off0 + 256 * g) + wp ->
  4096 + 64 + vdr <= 256 * w + (off0 + 256 * g) ->
  4096 <= 256 * w + (off0 + 256 * g) - 64 - vdr + p ->
  exists Qn M2 Q'n,
    mu * (256 * w) + al * (off0 + 256 * g) + wp - (wn + 3 * PL) = Z.to_nat (vz mod 256) + 256 * Qn /\
    Z.to_nat (vz mod 256) < 256 /\ 1 <= Qn /\
    vX + (256 * w + (off0 + 256 * g) - 64 - vdr + p + 3 * a - 4096) = Z.to_nat (t0 mod Z.of_nat Pn) + Pn * M2 /\
    Z.to_nat (t0 mod Z.of_nat Pn) < Pn /\
    mu' * (256 * w) + al' * S (off0 + 256 * g) + wp' - (wn' + 3 * PL') =
      Z.to_nat (vz2 mod Z.of_nat Pn3) + Pn3 * Q'n /\
    Z.to_nat (vz2 mod Z.of_nat Pn3) < Pn3 /\
    Q'n = Qn + (N.to_nat e1 + M2).
Proof.
  intros Hvz Hvz2 HPL HPL' HPn HPn3 Hp Hp3 Ht0 Hq Hmu Hal HV Hc HT.
  destruct (Zdm vz 256 ltac:(lia)) as [Ev Bv]. change (Z.of_nat 256) with 256%Z in Ev, Bv.
  destruct (Zdm t0 Pn Hp) as [Et Bt]. destruct (Zdm vz2 Pn3 Hp3) as [Ev2 Bv2].
  set (Qz := (vz / 256 + Z.of_nat (mu * w + al * g) - 3 * Z.of_nat hc)%Z).
  set (M2z := (t0 / Z.of_nat Pn + Z.of_nat P1 * Z.of_nat (w + g))%Z).
  set (Q'z := (vz2 / Z.of_nat Pn3 + Z.of_nat P3 * Z.of_nat (mu' * w + al' * g) - 3 * Z.of_nat hc)%Z).
  assert (EV : Z.of_nat (mu * (256 * w) + al * (off0 + 256 * g) + wp - (wn + 3 * PL)) = (vz mod 256 + 256 * Qz)%Z).
  { unfold Qz. clear -Hvz HPL HV Ev. lia. }
  assert (HQ : (1 <= Qz)%Z) by (clear -EV HV Bv; lia).
  assert (E256 : (Z.of_nat Pn * (Z.of_nat P1 * Z.of_nat (w + g)) = 256 * Z.of_nat (w + g))%Z).
  { rewrite Z.mul_assoc, <- Nat2Z.inj_mul, HPn. reflexivity. }
  assert (ET : Z.of_nat (vX + (256 * w + (off0 + 256 * g) - 64 - vdr + p + 3 * a - 4096)) =
               (t0 mod Z.of_nat Pn + Z.of_nat Pn * M2z)%Z).
  { unfold M2z. rewrite Z.mul_add_distr_l, E256. clear -Ht0 Hc HT Et. lia. }
  assert (HM : (0 <= M2z)%Z).
  { assert ((0 <= Z.of_nat (vX + (256 * w + (off0 + 256 * g) - 64 - vdr + p + 3 * a - 4096)))%Z) by lia.
    clear -ET Bt H Hp. nia. }
  assert (E256' : (Z.of_nat Pn3 * (Z.of_nat P3 * Z.of_nat (mu' * w + al' * g)) = 256 * Z.of_nat (mu' * w + al' * g))%Z).
  { rewrite Z.mul_assoc, <- Nat2Z.inj_mul, HPn3. reflexivity. }
  assert (EV' : (Z.of_nat (mu' * (256 * w) + al' * S (off0 + 256 * g) + wp') - Z.of_nat (wn' + 3 * PL') =
                 vz2 mod Z.of_nat Pn3 + Z.of_nat Pn3 * Q'z)%Z).
  { unfold Q'z. rewrite Z.mul_sub_distr_l, Z.mul_add_distr_l, E256'.
    assert ((Z.of_nat (3 * PL') = Z.of_nat lc2 + 3 * (Z.of_nat Pn3 * Z.of_nat hc))%Z) by (rewrite HPL'; lia).
    clear -Hvz2 H Ev2. lia. }
  assert (HQQ : Q'z = (Qz + Z.of_N e1 + M2z)%Z).
  { unfold Q'z, Qz, M2z.
    assert (Hm1 : (Z.of_nat P3 * Z.of_nat (mu' * w) = Z.of_nat (mu * w + P1 * w))%Z).
    { rewrite <- Nat2Z.inj_mul. f_equal. replace (mu * w + P1 * w) with ((mu + P1) * w) by ring.
      rewrite Hmu. ring. }
    assert (Hm2 : (Z.of_nat P3 * Z.of_nat (al' * g) = Z.of_nat (al * g + P1 * g))%Z).
    { rewrite <- Nat2Z.inj_mul. f_equal. destruct Hal as [Hal|Hal].
      - replace (al * g + P1 * g) with ((al + P1) * g) by ring. rewrite Hal. ring.
      - subst g. ring. }
    rewrite Nat2Z.inj_add, Z.mul_add_distr_l, Hm1, Hm2.
    clear -Hq. rewrite <- Hq. lia. }
  exists (Z.to_nat Qz), (Z.to_nat M2z), (Z.to_nat Q'z).
  assert (HQ' : (1 <= Q'z)%Z) by (rewrite HQQ; clear -HQ HM; lia).
  split; [|split; [|split; [|split; [|split; [|split; [|split]]]]]].
  - apply Nat2Z.inj. rewrite EV, Nat2Z.inj_add, Nat2Z.inj_mul, !Z2Nat.id by lia. reflexivity.
  - lia.
  - lia.
  - apply Nat2Z.inj. rewrite ET, Nat2Z.inj_add, Nat2Z.inj_mul, !Z2Nat.id by lia. reflexivity.
  - lia.
  - apply Nat2Z.inj. rewrite Nat2Z.inj_sub.
    + rewrite EV', Nat2Z.inj_add, Nat2Z.inj_mul, !Z2Nat.id by lia. reflexivity.
    + apply Nat2Z.inj_le. clear -EV' Bv2 HQ' Hp3. nia.
  - lia.
  - rewrite HQQ. apply Nat2Z.inj. rewrite !Nat2Z.inj_add, N_nat_Z, !Z2Nat.id by lia. lia.
Qed.

Lemma ar_pj w g off0 : off0 < 256 -> 4160 <= 256 * w + (off0 + 256 * g) ->
  pj (256 * w + (off0 + 256 * g) - 64) = pj off0.
Proof.
  intros H1 H2. replace (256 * w + (off0 + 256 * g) - 64) with (off0 + (32 * w + 32 * g - 8) * 8) by lia.
  apply pj_shift8. apply Nat.Div0.mod_mul.
Qed.

Lemma if_true A (x y : A) : (if true then x else y) = x.
Proof. reflexivity. Qed.

Lemma if_false A (x y : A) : (if false then x else y) = y.
Proof. reflexivity. Qed.

Lemma vs_gen fx r r' off0 Lc g w k off :
  vsok fx r r' off0 Lc = true -> off0 < 256 ->
  off = off0 + 256 * g -> (fx = true -> g = O) ->
  (Lc <= 8 /\ k + vlam r - off = Lc \/ Lc = 9 /\ 9 <= k + vlam r - off) ->
  vwn r + 3 * 2 ^ (k + vlam r - off - 1) + 256 <= vmu r * (256 * w) + val_ r * off + vwp r ->
  4096 + 64 + vd r <= 256 * w + off ->
  CS (vfz r k (256 * w) off) (vfz r' k (256 * w) (S off)).
Proof.
  intros Hok Ho0 Hoff Hfx HLc HV Hc. subst off.
  (* PITFALL: destructing [vsrun ..] inside the hypothesis makes Qed hang; destruct in the goal *)
  revert Hok. unfold vsok.
  destruct (vsrun r off0 Lc) as [[[[[Xt e1] a] X1] X3]|] eqn:Er; [|intros Hok; discriminate Hok].
  intros Hok.
  destruct (vsrun_spec _ _ _ _ _ _ _ _ Er) as [Ex [ES Es]]. clear Er.
  unfold vscond in Hok.
  repeat rewrite Bool.andb_true_iff in Hok.
  destruct Hok as [[[[[[[[[[[[[[[[Hd Hcl] H5] H9] Hlam] Hvd] Hlh'] Hlh] H9n] Hnd] Hnd3] HL21] HL22] HX3] Hq] Hmu] Hal].
  apply Nat.leb_le in H5, H9, Hlh', Hlh, H9n, Hnd, Hnd3, HL21, HL22.
  apply Nat.eqb_eq in Hlam, Hvd, Hmu.
  apply lsteqb_eq in HX3. apply Z.eqb_eq in Hq.
  assert (Hal' : val_ r + 2 ^ (8 - ndig X1) = val_ r' * 2 ^ (8 - ndig X3) \/ g = O).
  { destruct fx; [right; apply Hfx; reflexivity | left; apply Nat.eqb_eq; exact Hal]. }
  clear Hal.
  apply xfeed_sound in Ex. change (N.to_nat 4096) with 4096%nat in Ex.
  pose proof (splitP_spec Xt) as HS. rewrite ES in HS. destruct HS as [EXt _]. rewrite EXt in Ex.
  rewrite fillN_spec, Z_N_nat in Es. rewrite vlowN_spec, Z_N_nat in Ex, HX3.
  rewrite (Zpow_nat (ndig X1)) in Es, Hq. rewrite (Zpow_nat (ndig X3)) in Hq, HX3.
  set (t0 := vt0 r off0 a X1) in *.
  set (vz := vzf r off0 Lc (Nat.leb Lc 8)) in *.
  set (L2 := if Nat.leb Lc 8 then Lc + ndig X3 - 8 else S (ndig X3)) in *.
  set (vz2 := vzf r' (S off0) L2 (Nat.leb Lc 8)) in *.
  assert (HPn : 2 ^ ndig X1 * 2 ^ (8 - ndig X1) = 256) by (apply pow_split; exact Hnd).
  assert (HPn3 : 2 ^ ndig X3 * 2 ^ (8 - ndig X3) = 256) by (apply pow_split; exact Hnd3).
  assert (Pn_pos : 0 < 2 ^ ndig X1) by (apply Nat.neq_0_lt_0, Nat.pow_nonzero; lia).
  assert (Pn3_pos : 0 < 2 ^ ndig X3) by (apply Nat.neq_0_lt_0, Nat.pow_nonzero; lia).
  set (j := 256 * w + (off0 + 256 * g) - 64).
  assert (Hpj : pj j = pj off0) by (apply ar_pj; [exact Ho0|clear -Hc; lia]).
  assert (HT : 4096 <= 256 * w + (off0 + 256 * g) - 64 - vd r + pj off0) by (clear -Hc; lia).
  assert (HT' : 4096 <= j - vd r + pj j) by (rewrite Hpj; exact HT).
  unfold CS, vfz. cbn [fst snd]. fold j.
  replace (256 * w + S (off0 + 256 * g) - 64 - vd r') with (j - vd r + a) by (clear -Hvd Hc; unfold j; lia).
  replace (256 * w + S (off0 + 256 * g) - 64) with (S j) by (clear -Hc; unfold j; lia).
  set (L := k + vlam r - (off0 + 256 * g)) in *.
  set (L' := k + vlam r' - S (off0 + 256 * g)).
  assert (EL' : L' = L + ndig X3 - 8) by (clear -Hlam HLc H5 H9n; unfold L', L; lia).
  set (V := vmu r * (256 * w) + val_ r * (off0 + 256 * g) + vwp r - (vwn r + 3 * 2 ^ (L - 1))).
  set (V' := vmu r' * (256 * w) + val_ r' * S (off0 + 256 * g) + vwp r' - (vwn r' + 3 * 2 ^ (L' - 1))).
  destruct HLc as [[HLc HL]|[HLc HL]].
  - (* marker below the cut: the upper part is bin *)
    assert (Elow : Nat.leb Lc 8 = true) by (apply Nat.leb_le; exact HLc).
    assert (EL2 : L2 = Lc + ndig X3 - 8) by (unfold L2; rewrite Elow; reflexivity).
    destruct (ar_main (vmu r) (val_ r) (vwp r) (vwn r) (vmu r') (val_ r') (vwp r') (vwn r') w g off0
                (3 * 2 ^ (Lc - 1)) (3 * 2 ^ (L2 - 1)) 0 (2 ^ (8 - ndig X1)) (2 ^ (8 - ndig X3))
                (2 ^ ndig X1) (2 ^ ndig X3) (2 ^ (L - 1)) (2 ^ (L' - 1)) (val X1) (pj off0) a (vd r) e1 vz vz2 t0)
      as [Qn [M2 [Q'n [EV [Bv [HQ [ET [Bt [EV' [Bv' EQ]]]]]]]]]].
    + unfold vz, vzf. rewrite Elow. reflexivity.
    + unfold vz2, vzf. rewrite Elow. reflexivity.
    + rewrite HL. lia.
    + replace L' with L2 by (rewrite EL', EL2, HL; reflexivity). lia.
    + exact HPn.
    + exact HPn3.
    + exact Pn_pos.
    + exact Pn3_pos.
    + unfold t0, vt0. reflexivity.
    + exact Hq.
    + exact Hmu.
    + exact Hal'.
    + exact HV.
    + exact Hc.
    + exact HT.
    + fold V in EV. fold V' in EV'.
      set (v0n := Z.to_nat (vz mod 256)) in *. set (r2n := Z.to_nat (t0 mod Z.of_nat (2 ^ ndig X1))) in *.
      set (v02n := Z.to_nat (vz2 mod Z.of_nat (2 ^ ndig X3))) in *.
      clearbody v0n r2n v02n. clear Hq Hmu Hal'.
      assert (Hz : vfl (vh r) L V = vlow (vh r) Lc 8 v0n ++ bin Qn).
      { rewrite (vfl_split_le (vh r) L 8 V) by (change (2 ^ 8) with 256; lia).
        rewrite EV. change 256 with (2 ^ 8). rewrite vlow_mod, div_mod_shift, Nat.div_small by exact Bv.
        rewrite HL. reflexivity. }
      assert (Hz' : vfl (vh r') L' V' = X3 ++ bin Q'n).
      { rewrite (vfl_split_le (vh r') L' (ndig X3) V').
        - rewrite EV', vlow_mod, div_mod_shift, Nat.div_small, Nat.add_0_l by exact Bv'.
          replace L' with L2 by (rewrite EL', EL2, HL; reflexivity). rewrite <- HX3. reflexivity.
        - rewrite EL', HL. rewrite EL2 in HL22. rewrite Elow in HL22. lia.
        - rewrite EV'. nia. }
      eapply (vs_core r r' L V L' V' _ bin Qn Q'n (j - vd r) j (N.to_nat e1) a X1 _ M2 X3 ctr_bin Hz Hz' Ex Hd Hcl HT').
      * rewrite Hpj. unfold j. exact ET.
      * exact Bt.
      * exact Es.
      * exact EQ.
  - (* marker above the cut: the upper part is a digit word with the marker *)
    assert (Ehi : Nat.leb Lc 8 = false) by (apply Nat.leb_gt; lia).
    assert (EL2 : L2 = S (ndig X3)) by (unfold L2; rewrite Ehi; reflexivity).
    subst Lc.
    destruct (ar_main (vmu r) (val_ r) (vwp r) (vwn r) (vmu r') (val_ r') (vwp r') (vwn r') w g off0
                0 0 (2 ^ (L - 9)) (2 ^ (8 - ndig X1)) (2 ^ (8 - ndig X3))
                (2 ^ ndig X1) (2 ^ ndig X3) (2 ^ (L - 1)) (2 ^ (L' - 1)) (val X1) (pj off0) a (vd r) e1 vz vz2 t0)
      as [Qn [M2 [Q'n [EV [Bv [HQ [ET [Bt [EV' [Bv' EQ]]]]]]]]]].
    + unfold vz, vzf. rewrite Ehi. reflexivity.
    + unfold vz2, vzf. rewrite Ehi. reflexivity.
    + replace (L - 1) with (8 + (L - 9)) by lia. rewrite Nat.pow_add_r. change (2 ^ 8) with 256. lia.
    + replace (L' - 1) with (ndig X3 + (L - 9)) by lia. rewrite Nat.pow_add_r. lia.
    + exact HPn.
    + exact HPn3.
    + exact Pn_pos.
    + exact Pn3_pos.
    + unfold t0, vt0. reflexivity.
    + exact Hq.
    + exact Hmu.
    + exact Hal'.
    + exact HV.
    + exact Hc.
    + exact HT.
    + fold V in EV. fold V' in EV'.
      set (v0n := Z.to_nat (vz mod 256)) in *. set (r2n := Z.to_nat (t0 mod Z.of_nat (2 ^ ndig X1))) in *.
      set (v02n := Z.to_nat (vz2 mod Z.of_nat (2 ^ ndig X3))) in *.
      clearbody v0n r2n v02n. clear Hq Hmu Hal'.
      assert (Hz : vfl (vh r) L V = vlow (vh r) 9 8 v0n ++ vfl [] (L - 8) Qn).
      { rewrite (vfl_split_hi (vh r) L 8 V) by lia.
        rewrite (vlow_L (vh r) L 9 8 V) by lia.
        rewrite EV. change 256 with (2 ^ 8). rewrite vlow_mod, div_mod_shift, Nat.div_small by exact Bv.
        reflexivity. }
      assert (Hz' : vfl (vh r') L' V' = X3 ++ vfl [] (L - 8) Q'n).
      { rewrite (vfl_split_hi (vh r') L' (ndig X3) V') by lia.
        replace (L' - ndig X3) with (L - 8) by lia.
        rewrite (vlow_L (vh r') L' (S (ndig X3)) (ndig X3) V') by lia.
        rewrite EV', vlow_mod, div_mod_shift, Nat.div_small, Nat.add_0_l by exact Bv'.
        rewrite <- EL2, <- HX3. reflexivity. }
      eapply (vs_core r r' L V L' V' _ (vfl [] (L - 8)) Qn Q'n (j - vd r) j (N.to_nat e1) a X1 _ M2 X3
                (ctr_vfl (L - 8)) Hz Hz' Ex Hd Hcl HT').
      * rewrite Hpj. unfold j. exact ET.
      * exact Bt.
      * exact Es.
      * exact EQ.
Qed.

(* ===================================================================== *)
(* 21. The value-form tables (proof.md 6.2): the entry table for level 1 *)
(*     at off 20..31 and the phase table elsewhere; the finite checks.   *)
(* ===================================================================== *)

Definition enrows : list vrow :=
  [ mkV [[]; [uS1]] 24 1 0 0 0 2;
    mkV [[]; [uSP]] 25 2 0 0 0 3;
    mkV [[uS1; uP; uP]] 24 1 0 0 2 4;
    mkV [[]; []; []; [uS1]] 24 1 0 0 0 2;
    mkV [[]; []; [uS1; uP]] 24 1 0 0 4 3;
    mkV [[]; []; [uSP; uP]] 25 2 0 0 4 4;
    mkV [[uS1]; [uP; uP; uP]] 24 1 0 0 4 5;
    mkV [[uS1; uP; uP; uP]] 24 1 0 1 0 5;
    mkV [[uS1]] 24 1 0 8 0 2;
    mkV [[]; []; [uS1]] 24 1 0 8 0 2;
    mkV [[]; [uS1; uP]] 24 1 0 6 0 3;
    mkV [[uS1; uP; uP]] 24 1 0 7 0 4 ].

Definition row1 (off : nat) : vrow :=
  if Nat.leb off 31 then nth (off - 20) enrows (phrow 0) else phrow (off mod 8).

Definition en_ok (i : nat) : bool := vsok true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9.

Definition lcs : list nat := [5%nat; 6; 7; 8; 9].

Definition ph_ok (o : nat) : bool :=
  forallb (fun Lc => vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc) lcs.

(* PITFALL: state the vm_compute facts over named predicates; a named
   [Definition x := forallb (fun ..) ..] makes the kernel evaluate the
   checks lazily when it is unfolded in a conversion *)
(* the kernel must unfold these before vsok, or it evaluates vsok lazily *)
Strategy expand [en_ok ph_ok].

Lemma en_all : forallb en_ok (upto 12) = true.
Proof. vm_compute. reflexivity. Qed.

Lemma ph_all : forallb ph_ok (upto 256) = true.
Proof. vm_compute. reflexivity. Qed.

(* bounds on the rows *)
Definition rowok (r : vrow) : bool :=
  Nat.leb 1 (vmu r) && Nat.leb (vwn r) 42 && Nat.leb (vd r) 5 && Nat.leb 24 (vlam r) && Nat.leb (vlam r) 25.

Lemma nth_rowok l d n : forallb rowok l = true -> rowok d = true -> rowok (nth n l d) = true.
Proof.
  revert n; induction l as [|x l IH]; intros n H Hd; destruct n; cbn in *; auto;
    apply andb_prop in H; destruct H; auto.
Qed.

Lemma phrow_ok phi : rowok (phrow phi) = true.
Proof. unfold phrow. apply nth_rowok; reflexivity. Qed.

Lemma row1_ok off : rowok (row1 off) = true.
Proof. unfold row1. destruct (Nat.leb off 31); [apply nth_rowok; [reflexivity|apply phrow_ok]|apply phrow_ok]. Qed.

Lemma rowok_spec r : rowok r = true -> 1 <= vmu r /\ vwn r <= 42 /\ vd r <= 5 /\ 24 <= vlam r <= 25.
Proof.
  unfold rowok. intros H. repeat rewrite Bool.andb_true_iff in H.
  destruct H as [[[[H1 H2] H3] H4] H5]. apply Nat.leb_le in H1, H2, H3, H4, H5. lia.
Qed.

Lemma row1_lam off : 20 <= off -> vlam (row1 off) <= off + 4.
Proof.
  intros H. destruct (Nat.le_gt_cases off 31) as [Hle|Hgt].
  - assert (E : off = 20 + (off - 20)) by lia. rewrite E.
    assert (Hi : off - 20 < 12) by lia.
    generalize (off - 20) Hi. clear. intros i Hi.
    assert (Hc : forallb (fun i => Nat.leb (vlam (row1 (20 + i))) (20 + i + 4)) (upto 12) = true) by reflexivity.
    rewrite forallb_forall in Hc. apply Nat.leb_le. apply Hc. apply upto_In. exact Hi.
  - destruct (rowok_spec _ (row1_ok off)). lia.
Qed.

Lemma mod8_256 off : (off mod 256) mod 8 = off mod 8.
Proof.
  rewrite (Nat.div_mod_eq off 256) at 2.
  replace (256 * (off / 256) + off mod 256) with (off mod 256 + (32 * (off / 256)) * 8) by lia.
  rewrite Nat.Div0.mod_add. reflexivity.
Qed.

Lemma Smod8_256 off : S (off mod 256) mod 8 = S off mod 8.
Proof.
  rewrite (Nat.div_mod_eq off 256) at 2.
  replace (S (256 * (off / 256) + off mod 256)) with (S (off mod 256) + (32 * (off / 256)) * 8) by lia.
  rewrite Nat.Div0.mod_add. reflexivity.
Qed.

(* PITFALL: rewriting inside a hypothesis that mentions vsok makes Qed hang;
   take the boolean facts as plain terms and rewrite only goals *)
Lemma en_at i : i < 12 -> vsok true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9 = true.
Proof. intros Hi. exact (proj1 (forallb_forall en_ok (upto 12)) en_all i (upto_In _ _ Hi)). Qed.

Lemma ph_at o Lc : o < 256 -> In Lc lcs -> vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc = true.
Proof.
  intros Ho HL.
  exact (proj1 (forallb_forall (fun Lc => vsok false (phrow (o mod 8)) (phrow (S o mod 8)) o Lc) lcs)
           (proj1 (forallb_forall ph_ok (upto 256)) ph_all o (upto_In _ _ Ho)) Lc HL).
Qed.

(* one descent step with a phase row *)
Lemma vs_ph k w off :
  5 <= k + vlam (phrow (off mod 8)) - off ->
  vwn (phrow (off mod 8)) + 3 * 2 ^ (k + vlam (phrow (off mod 8)) - off - 1) + 256 <=
    vmu (phrow (off mod 8)) * (256 * w) + val_ (phrow (off mod 8)) * off + vwp (phrow (off mod 8)) ->
  4096 + 64 + vd (phrow (off mod 8)) <= 256 * w + off ->
  CS (vfz (phrow (off mod 8)) k (256 * w) off) (vfz (phrow (S off mod 8)) k (256 * w) (S off)).
Proof.
  intros HL HV Hc.
  set (L := k + vlam (phrow (off mod 8)) - off) in *.
  set (Lc := if Nat.leb L 8 then L else 9).
  assert (HLc : In Lc lcs) by (unfold Lc, lcs; destruct (Nat.leb_spec L 8); cbn; lia).
  assert (Ho : off mod 256 < 256) by (apply Nat.mod_upper_bound; lia).
  rewrite <- (mod8_256 off), <- (Smod8_256 off).
  apply (vs_gen false _ _ (off mod 256) Lc (off / 256) w k off (ph_at _ _ Ho HLc) Ho).
  - pose proof (Nat.div_mod_eq off 256). lia.
  - discriminate.
  - rewrite mod8_256. unfold Lc. fold L. destruct (Nat.leb_spec L 8); [left|right]; lia.
  - rewrite mod8_256. exact HV.
  - rewrite mod8_256. exact Hc.
Qed.

(* one descent step with an entry row (level 1, off 20..31) *)
Lemma vs_en k w off :
  20 <= off <= 31 -> 9 <= k + vlam (row1 off) - off ->
  vwn (row1 off) + 3 * 2 ^ (k + vlam (row1 off) - off - 1) + 256 <=
    vmu (row1 off) * (256 * w) + val_ (row1 off) * off + vwp (row1 off) ->
  4096 + 64 + vd (row1 off) <= 256 * w + off ->
  CS (vfz (row1 off) k (256 * w) off) (vfz (row1 (S off)) k (256 * w) (S off)).
Proof.
  intros Ho HL HV Hc.
  assert (Hi : off - 20 < 12) by lia.
  assert (E : off = 20 + (off - 20)) by lia.
  remember (off - 20) as i eqn:Ei. clear Ei. subst off.
  apply (vs_gen true (row1 (20 + i)) (row1 (21 + i)) (20 + i) 9 0 w k (20 + i) (en_at i Hi)); lia.
Qed.

Inductive CSstar : st -> st -> Prop :=
| CSs0 s : CSstar s s
| CSsS s s1 s' : CS s s1 -> CSstar s1 s' -> CSstar s s'.

Lemma CSstar_snoc a b c : CSstar a b -> CS b c -> CSstar a c.
Proof.
  intros H1. induction H1 as [s|s s1 s' Hs H1 IH]; intros H2.
  - econstructor; [exact H2|constructor].
  - econstructor; [exact Hs|]. apply IH. exact H2.
Qed.

Lemma CSstar_plus a b c : CSstar a b -> CSplus b c -> CSplus a c.
Proof.
  intros H1. induction H1 as [s|s s1 s' Hs H1 IH]; intros H2.
  - exact H2.
  - eapply CSpS; [exact Hs|]. apply IH. exact H2.
Qed.

Lemma descent (rowf : nat -> vrow) k Om a b :
  (forall x, a <= x < b -> CS (vfz (rowf x) k Om x) (vfz (rowf (S x)) k Om (S x))) -> a <= b ->
  CSstar (vfz (rowf a) k Om a) (vfz (rowf b) k Om b).
Proof.
  intros H Hab. replace b with (a + (b - a)) by lia.
  assert (Hn : forall n, a + n <= b -> CSstar (vfz (rowf a) k Om a) (vfz (rowf (a + n)) k Om (a + n))).
  { induction n as [|n IH]; intros Hn.
    - rewrite Nat.add_0_r. constructor.
    - eapply CSstar_snoc; [apply IH; lia|]. replace (a + S n) with (S (a + n)) by lia. apply H. lia. }
  apply Hn. lia.
Qed.

(* ===================================================================== *)
(* 22. Lemma VF (proof.md 6.3): the value form is carried from off 20    *)
(*     (level 1) or off' 17 (level 2) down to off_end.                   *)
(* ===================================================================== *)

Lemma off_end_L5 k x l : x < off_end k -> 24 <= l -> (x = k + 20 -> l = 25) -> 5 <= k + l - x.
Proof.
  unfold off_end. intros Hx Hl H25.
  destruct (Nat.eqb ((k + 20) mod 8) 3); [|lia].
  destruct (Nat.eq_dec x (k + 20)) as [E|E]; [specialize (H25 E); lia|lia].
Qed.

Lemma off_end_phase3 k x : x < off_end k -> x = k + 20 -> x mod 8 = 3.
Proof.
  unfold off_end. intros Hx E. subst x.
  destruct (Nat.eqb_spec ((k + 20) mod 8) 3); [assumption|lia].
Qed.

Lemma pow_ge k a : a <= k -> 2 ^ a <= 2 ^ k.
Proof. intros H. apply Nat.pow_le_mono_r; lia. Qed.

Theorem VF1 k o : 41 <= k -> 1 <= o ->
  CSstar (vfz (row1 20) k (o * 2 ^ (k + 5)) 20) (VFe k (o * 2 ^ (k + 5))).
Proof.
  intros Hk Ho.
  set (T := 2 ^ (k + 3)).
  assert (HT : 4096 <= T) by (unfold T; change 4096 with (2 ^ 12); apply pow_ge; lia).
  set (w := o * 2 ^ (k - 3)).
  assert (Ew : o * 2 ^ (k + 5) = 256 * w).
  { unfold w. replace (k + 5) with (8 + (k - 3)) by lia. rewrite Nat.pow_add_r. change (2 ^ 8) with 256. lia. }
  assert (Ew' : 256 * w = o * (4 * T)).
  { rewrite <- Ew. unfold T. replace (k + 5) with (2 + (k + 3)) by lia. rewrite Nat.pow_add_r. reflexivity. }
  rewrite Ew. unfold VFe.
  assert (Hend : 61 <= off_end k) by (unfold off_end; destruct (Nat.eqb _ _); lia).
  assert (Er : phrow (off_end k mod 8) = row1 (off_end k)).
  { unfold row1. replace (Nat.leb (off_end k) 31) with false; [reflexivity|symmetry; apply Nat.leb_gt; lia]. }
  rewrite Er.
  apply descent; [|lia].
  intros x Hx.
  destruct (rowok_spec _ (row1_ok x)) as [Hmu [Hwn [Hvd [Hl1 Hl2]]]].
  assert (HLx : vlam (row1 x) <= x + 4) by (apply row1_lam; lia).
  assert (HL5 : 5 <= k + vlam (row1 x) - x).
  { apply off_end_L5; [lia|lia|]. intros E.
    assert (E3 := off_end_phase3 k x ltac:(lia) E).
    unfold row1. replace (Nat.leb x 31) with false by (symmetry; apply Nat.leb_gt; lia).
    rewrite E3. reflexivity. }
  assert (HP : 2 ^ (k + vlam (row1 x) - x - 1) <= T) by (unfold T; apply pow_ge; lia).
  assert (Hm : 256 * w <= vmu (row1 x) * (256 * w)) by nia.
  assert (HV : vwn (row1 x) + 3 * 2 ^ (k + vlam (row1 x) - x - 1) + 256 <=
               vmu (row1 x) * (256 * w) + val_ (row1 x) * x + vwp (row1 x)) by nia.
  assert (Hc : 4096 + 64 + vd (row1 x) <= 256 * w + x) by nia.
  destruct (Nat.le_gt_cases x 31) as [Hle|Hgt].
  - apply vs_en; [lia|lia|exact HV|exact Hc].
  - assert (E1 : row1 x = phrow (x mod 8)).
    { unfold row1. replace (Nat.leb x 31) with false by (symmetry; apply Nat.leb_gt; lia). reflexivity. }
    assert (E2 : row1 (S x) = phrow (S x mod 8)).
    { unfold row1. replace (Nat.leb (S x) 31) with false by (symmetry; apply Nat.leb_gt; lia). reflexivity. }
    rewrite E1, E2. rewrite E1 in HL5, HV, Hc. apply vs_ph; assumption.
Qed.

Theorem VF2 v S : 12 <= v -> 2 <= S ->
  CSstar (vfz (phrow 1) (v - 10) (S * 2 ^ v) 17) (VFe (v - 10) (S * 2 ^ v)).
Proof.
  intros Hv HS.
  set (k := v - 10).
  set (T := 2 ^ (v - 3)).
  assert (HT : 512 <= T) by (unfold T; change 512 with (2 ^ 9); apply pow_ge; lia).
  set (w := S * 2 ^ (v - 8)).
  assert (Ew : S * 2 ^ v = 256 * w).
  { unfold w. replace v with (8 + (v - 8)) at 1 by lia. rewrite Nat.pow_add_r. change (2 ^ 8) with 256. lia. }
  assert (Ew' : 256 * w = S * (8 * T)).
  { rewrite <- Ew. unfold T. replace v with (3 + (v - 3)) at 1 by lia. rewrite Nat.pow_add_r. reflexivity. }
  rewrite Ew. unfold VFe.
  change (phrow 1) with (phrow (17 mod 8)).
  apply (descent (fun x => phrow (x mod 8))); [|unfold off_end; destruct (Nat.eqb _ _); lia].
  intros x Hx. cbv beta.
  destruct (rowok_spec _ (phrow_ok (x mod 8))) as [Hmu [Hwn [Hvd [Hl1 Hl2]]]].
  assert (HL5 : 5 <= k + vlam (phrow (x mod 8)) - x).
  { apply off_end_L5; [lia|lia|]. intros E. rewrite (off_end_phase3 k x ltac:(lia) E). reflexivity. }
  assert (HP : 2 ^ (k + vlam (phrow (x mod 8)) - x - 1) <= T) by (unfold T; apply pow_ge; unfold k; lia).
  assert (Hm : 256 * w <= vmu (phrow (x mod 8)) * (256 * w)) by nia.
  assert (HV : vwn (phrow (x mod 8)) + 3 * 2 ^ (k + vlam (phrow (x mod 8)) - x - 1) + 256 <=
               vmu (phrow (x mod 8)) * (256 * w) + val_ (phrow (x mod 8)) * x + vwp (phrow (x mod 8))) by nia.
  assert (Hc : 4096 + 64 + vd (phrow (x mod 8)) <= 256 * w + x) by nia.
  apply vs_ph; assumption.
Qed.



(* ===================================================================== *)
(* 23. Lemma E (proof.md 6.1): C(b) at off 17 to the value form at 20.   *)
(* ===================================================================== *)

Lemma bin_pow_odd i q : bin (2 ^ i * (2 * q + 1)) = repeat uD0 i ++ uD1 :: bin q.
Proof.
  induction i as [|i IH].
  - cbn [repeat app]. rewrite Nat.pow_0_r, Nat.mul_1_l. rewrite bin_pos by lia.
    rewrite dig_odd. f_equal. f_equal.
    replace (2 * q + 1) with (1 + q * 2) by lia. rewrite Nat.div_add by lia. reflexivity.
  - rewrite Nat.pow_succ_r'. rewrite bin_pos by (pose proof (Nat.pow_nonzero 2 i); nia).
    rewrite <- Nat.mul_assoc, dig_even.
    replace (2 * (2 ^ i * (2 * q + 1)) / 2) with (2 ^ i * (2 * q + 1)).
    + rewrite IH. reflexivity.
    + rewrite (Nat.mul_comm 2 (2 ^ i * (2 * q + 1))), Nat.div_mul by lia. reflexivity.
Qed.

Lemma shift_D0s m w : shift (repeat uD0 m ++ w) =
  match shift w with Some w' => Some (repeat uD0 m ++ w') | None => None end.
Proof.
  induction m as [|m IH]; cbn [repeat app shift]; [destruct (shift w); reflexivity|].
  rewrite IH. destruct (shift w); reflexivity.
Qed.

Lemma pj17 b : pj (32 * b + 17) = 48.
Proof.
  rewrite pj_mod. replace (32 * b + 17) with (1 + (4 * b + 2) * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity.
Qed.

Lemma cs_step_conv Z D j Z' D1 j1 D2 j2 : cs_step Z D j Z' D1 j1 -> D1 = D2 -> j1 = j2 -> cs_step Z D j Z' D2 j2.
Proof. intros H -> ->. exact H. Qed.

Lemma E1 k q : 41 <= k ->
  let b := (2 * q + 1) * 2 ^ k - 2 in
  CS (Cst b) (repeat uD0 (k + 6) ++ uS1 :: bin q, 32 * b + 17, 32 * b + 18).
Proof.
  intros Hk b.
  set (o := 2 * q + 1) in *.
  set (P := 2 ^ (k - 3)).
  assert (HP : 2 ^ k = 8 * P) by (unfold P; replace k with (3 + (k - 3)) at 1 by lia; rewrite Nat.pow_add_r; reflexivity).
  assert (HP1 : 4096 <= P) by (unfold P; change 4096 with (2 ^ 12); apply pow_ge; lia).
  assert (Hb : b = 8 * o * P - 2) by (unfold b; rewrite HP; lia).
  unfold CS, Cst. cbn [fst snd].
  (* the zone is S1 :: bin V17 with V17 = 256 oP - 2 *)
  assert (Ez : [uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b) =
               [uS1; uD0; uD1; uD1; uD1; uD1; uD1; uD1; uD1] ++ bin (o * P - 1)).
  { change ([uS1; uD0; uD1; uD1; uD1; uD1] ++ bin (S b)) with (uS1 :: (digits 5 30 ++ bin (S b))).
    rewrite digits_app_bin by (cbn [Nat.pow Nat.mul Nat.add]; lia).
    rewrite (digits_bin_split 8) by (change (2 ^ 8) with 256; change (2 ^ 5) with 32; rewrite Hb; clear -HP1; nia).
    replace (30 + 2 ^ 5 * S b) with (254 + 2 ^ 8 * (o * P - 1)) by (rewrite Hb; change (2 ^ 5) with 32; change (2 ^ 8) with 256; clear -HP1; nia).
    rewrite digits_mod, div_mod_shift, Nat.div_small by (change (2 ^ 8) with 256; lia).
    reflexivity. }
  rewrite Ez.
  assert (Hx : xfeed 4000 4096 [uS1; uD0; uD1; uD1; uD1; uD1; uD1; uD1; uD1] =
               Some (uP :: [uD1; uD0; uD1; uD1; uD1; uD1; uD1; uD1], 16%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 4096) with 4096%nat in Hx. change (N.to_nat 16) with 16%nat in Hx.
  set (X1 := [uD1; uD0; uD1; uD1; uD1; uD1; uD1; uD1]).
  assert (Hc : 32 * b + 16 + pj (32 * b + 17) = 256 * (o * P)) by (rewrite pj17, Hb; nia).
  pose proof (XN_clean X1 (32 * b + 16 + pj (32 * b + 17) + 3 * 1 - 4096) eq_refl) as H2.
  replace (val X1 + (32 * b + 16 + pj (32 * b + 17) + 3 * 1 - 4096)) with (0 + 2 ^ ndig X1 * (o * P - 15)) in H2
    by (rewrite Hc; change (val X1) with 253; change (ndig X1) with 8; change (2 ^ 8) with 256; nia).
  rewrite fill_mod, div_mod_shift, Nat.Div0.div_0_l, Nat.add_0_l in H2.
  change (fill X1 0) with (repeat uD0 8) in H2.
  eapply cs_step_conv.
  { apply (cutstep [uS1; uD0; uD1; uD1; uD1; uD1; uD1; uD1; uD1] (bin (o * P - 1)) 4096 16 1 X1
             (32 * b + 16 + pj (32 * b + 17)) (o * P - 15) (repeat uD0 8) (32 * b + 16) (32 * b + 17) _
             (bin (2 ^ (k - 2) * (2 * q + 1))) Hx eq_refl H2).
    - rewrite Hc. nia.
    - reflexivity.
    - replace (2 ^ (k - 2) * (2 * q + 1)) with (o * P - 1 + (16 + (o * P - 15))).
      + apply IncN_bin.
      + unfold o, P. replace (k - 2) with (S (k - 3)) by lia. rewrite Nat.pow_succ_r'. fold P. nia.
    - rewrite shift_D0s, bin_pow_odd, shift_D0s. cbn [shift].
      rewrite app_assoc, <- repeat_app. replace (8 + (k - 2)) with (k + 6) by lia. reflexivity. }
  - lia.
  - lia.
Qed.

Definition s1w (q : nat) : list unt := if Nat.eqb q 0 then [uS1] else uP :: bin (2 * q - 1).

Lemma IncN_s1w q : IncN q (uS1 :: bin q) (s1w q).
Proof.
  unfold s1w. destruct q as [|q]; [constructor|]. cbn [Nat.eqb].
  econstructor; [constructor|]. apply IncN_P.
  replace (2 * S q - 1) with (S q + q) by lia. apply IncN_bin.
Qed.

Lemma digits_pow2 i : digits (S i) (2 ^ i) = repeat uD0 i ++ [uD1].
Proof.
  induction i as [|i IH]; [reflexivity|].
  change (digits (S (S i)) (2 ^ S i)) with (dig (2 ^ S i) :: digits (S i) (2 ^ S i / 2)).
  rewrite Nat.pow_succ_r', dig_even. rewrite Nat.mul_comm, Nat.div_mul by lia. rewrite IH. reflexivity.
Qed.

Lemma pj18 b : pj (32 * b + 18) = 48.
Proof.
  rewrite pj_mod. replace (32 * b + 18) with (2 + (4 * b + 2) * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity.
Qed.

Lemma odd_half q P : 0 < P -> (2 * q + 1) * P / (2 * P) = q.
Proof.
  intros HP. symmetry. apply Nat.div_unique with P; lia.
Qed.

Lemma E2 k q : 41 <= k ->
  let b := (2 * q + 1) * 2 ^ k - 2 in
  CS (repeat uD0 (k + 6) ++ uS1 :: bin q, 32 * b + 17, 32 * b + 18)
     (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q, 32 * b + 17, 32 * b + 19).
Proof.
  intros Hk b.
  set (o := 2 * q + 1) in *.
  set (P := 2 ^ (k - 3)).
  assert (HP : 2 ^ k = 8 * P) by (unfold P; replace k with (3 + (k - 3)) at 1 by lia; rewrite Nat.pow_add_r; reflexivity).
  assert (HP1 : 4096 <= P) by (unfold P; change 4096 with (2 ^ 12); apply pow_ge; lia).
  assert (HP2 : 2 ^ (k - 2) = 2 * P) by (unfold P; replace (k - 2) with (S (k - 3)) by lia; apply Nat.pow_succ_r').
  assert (Hb : b = 8 * o * P - 2) by (unfold b; rewrite HP; lia).
  unfold CS. cbn [fst snd].
  replace (repeat uD0 (k + 6)) with (repeat uD0 8 ++ digits (k - 2) 0).
  2:{ replace (digits (k - 2) 0) with (repeat uD0 (k - 2)).
      - rewrite <- repeat_app. f_equal. lia.
      - generalize (k - 2). intros n. induction n as [|n IH]; [reflexivity|]. cbn [repeat digits]. rewrite IH. reflexivity. }
  rewrite <- app_assoc.
  assert (Hx : xfeed 4000 4096 (repeat uD0 8) = Some (repeat uD0 8, 16%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 4096) with 4096%nat in Hx. change (N.to_nat 16) with 16%nat in Hx.
  assert (Hc : 32 * b + 17 + pj (32 * b + 18) = 256 * (o * P) + 1) by (rewrite pj18, Hb; nia).
  pose proof (XN_clean (repeat uD0 8) (32 * b + 17 + pj (32 * b + 18) + 3 * 0 - 4096) eq_refl) as H2.
  replace (val (repeat uD0 8) + (32 * b + 17 + pj (32 * b + 18) + 3 * 0 - 4096))
    with (1 + 2 ^ ndig (repeat uD0 8) * (o * P - 16)) in H2
    by (rewrite Hc; change (val (repeat uD0 8)) with O; change (ndig (repeat uD0 8)) with 8; change (2 ^ 8) with 256; nia).
  rewrite fill_mod, div_mod_shift, Nat.div_small in H2 by (change (ndig (repeat uD0 8)) with 8; cbn; lia).
  change (fill (repeat uD0 8) 1) with [uD1; uD0; uD0; uD0; uD0; uD0; uD0; uD0] in H2.
  eapply cs_step_conv.
  { apply (cutstep (repeat uD0 8) (digits (k - 2) 0 ++ uS1 :: bin q) 4096 16 0 (repeat uD0 8)
             (32 * b + 17 + pj (32 * b + 18)) (0 + (o * P - 16)) [uD1; uD0; uD0; uD0; uD0; uD0; uD0; uD0]
             (32 * b + 17) (32 * b + 18) _ (digits (k - 2) (0 + o * P) ++ s1w q) Hx eq_refl H2).
    - rewrite Hc. nia.
    - reflexivity.
    - replace (16 + (0 + (o * P - 16))) with (o * P) by nia.
      apply IncN_digits. rewrite Nat.Div0.mod_0_l, Nat.add_0_l, HP2. unfold o. rewrite odd_half by lia.
      apply IncN_s1w.
    - rewrite (shiftX_app [uD1; uD0; uD0; uD0; uD0; uD0; uD0; uD0] [uS1; uD0; uD0; uD0; uD0; uD0; uD0; uD0]) by reflexivity.
      f_equal.
      replace (0 + o * P) with (P + 2 ^ (k - 2) * q) by (rewrite HP2; unfold o; lia).
      rewrite digits_mod. replace (k - 2) with (S (k - 3)) by lia. unfold P. rewrite digits_pow2.
      cbn [app]. f_equal.
      replace (k + 4) with (7 + (k - 3)) by lia. rewrite repeat_app. cbn [repeat app].
      rewrite <- app_assoc. cbn [app]. reflexivity. }
  - lia.
  - lia.
Qed.

Lemma pj19 b : pj (32 * b + 19) = 47.
Proof.
  rewrite pj_mod. replace (32 * b + 19) with (3 + (4 * b + 2) * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity.
Qed.

Lemma IncN_s1w_up q : IncN (2 * q + 1) (s1w q) (uP :: bin (4 * q)).
Proof.
  unfold s1w. destruct q as [|q]; cbn [Nat.eqb].
  - change (IncN 1 [uS1] [uP]). econstructor; [constructor|]. constructor.
  - apply IncN_P. replace (4 * S q) with (2 * S q - 1 + (2 * S q + 1)) by lia. apply IncN_bin.
Qed.

Lemma E3 k q : 41 <= k ->
  let b := (2 * q + 1) * 2 ^ k - 2 in
  CS (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q, 32 * b + 17, 32 * b + 19)
     ([uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0] ++ digits (k - 3) (2 ^ (k - 4)) ++ uP :: bin (4 * q),
      32 * b + 18, 32 * b + 20).
Proof.
  intros Hk b.
  set (o := 2 * q + 1) in *.
  set (P := 2 ^ (k - 3)).
  assert (HP : 2 ^ k = 8 * P) by (unfold P; replace k with (3 + (k - 3)) at 1 by lia; rewrite Nat.pow_add_r; reflexivity).
  assert (HP1 : 4096 <= P) by (unfold P; change 4096 with (2 ^ 12); apply pow_ge; lia).
  assert (HP4 : P = 2 * 2 ^ (k - 4)) by (unfold P; replace (k - 3) with (S (k - 4)) by lia; apply Nat.pow_succ_r').
  assert (Hb : b = 8 * o * P - 2) by (unfold b; rewrite HP; lia).
  unfold CS. cbn [fst snd].
  replace (uS1 :: repeat uD0 (k + 4) ++ uD1 :: s1w q)
    with ((uS1 :: repeat uD0 8) ++ digits (k - 3) (2 ^ (k - 4)) ++ s1w q).
  2:{ replace (k - 3) with (S (k - 4)) by lia. rewrite digits_pow2.
      replace (k + 4) with (8 + (k - 4)) by lia. rewrite repeat_app.
      cbn [app]. rewrite <- !app_assoc. reflexivity. }
  assert (Hx : xfeed 4000 4096 (uS1 :: repeat uD0 8) =
               Some (uP :: [uD1; uD1; uD1; uD1; uD1; uD1; uD1; uD1], 15%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 4096) with 4096%nat in Hx. change (N.to_nat 15) with 15%nat in Hx.
  set (X1 := [uD1; uD1; uD1; uD1; uD1; uD1; uD1; uD1]) in Hx.
  assert (Hc : 32 * b + 17 + pj (32 * b + 19) = 256 * (o * P)) by (rewrite pj19, Hb; nia).
  pose proof (XN_clean X1 (32 * b + 17 + pj (32 * b + 19) + 3 * 1 - 4096) eq_refl) as H2.
  replace (val X1 + (32 * b + 17 + pj (32 * b + 19) + 3 * 1 - 4096))
    with (2 + 2 ^ ndig X1 * (o * P - 15)) in H2
    by (rewrite Hc; change (val X1) with 255; change (ndig X1) with 8; change (2 ^ 8) with 256; nia).
  rewrite fill_mod, div_mod_shift, Nat.div_small in H2 by (change (ndig X1) with 8; cbn; lia).
  change (fill X1 2) with [uD0; uD1; uD0; uD0; uD0; uD0; uD0; uD0] in H2.
  eapply cs_step_conv.
  { apply (cutstep (uS1 :: repeat uD0 8) (digits (k - 3) (2 ^ (k - 4)) ++ s1w q) 4096 15 1 X1
             (32 * b + 17 + pj (32 * b + 19)) (0 + (o * P - 15)) [uD0; uD1; uD0; uD0; uD0; uD0; uD0; uD0]
             (32 * b + 17) (32 * b + 19) _ (digits (k - 3) (2 ^ (k - 4) + o * P) ++ uP :: bin (4 * q)) Hx eq_refl H2).
    - rewrite Hc. nia.
    - reflexivity.
    - replace (15 + (0 + (o * P - 15))) with (o * P) by nia.
      apply IncN_digits. fold P.
      replace ((2 ^ (k - 4) mod P + o * P) / P) with (2 * q + 1).
      + apply IncN_s1w_up.
      + rewrite Nat.mod_small by lia. apply Nat.div_unique with (2 ^ (k - 4)); unfold o; lia.
    - rewrite (shiftX_app [uD0; uD1; uD0; uD0; uD0; uD0; uD0; uD0] [uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0]) by reflexivity.
      f_equal. f_equal.
      replace (2 ^ (k - 4) + o * P) with (2 ^ (k - 4) + 2 ^ (k - 3) * o) by (unfold P; lia).
      rewrite digits_mod. reflexivity. }
  - lia.
  - lia.
Qed.

(* the off 20 form of Lemma E is the level-1 value form at off 20 *)
Lemma vfl_row20 m W : vfl [[]; [uS1]] (S (S m)) (4 * W) = uD0 :: uS1 :: uD0 :: vfl [] m W.
Proof.
  cbn [vfl hd tl app].
  replace (4 * W) with (2 * (2 * W)) by lia. rewrite dig_even.
  rewrite (Nat.mul_comm 2 (2 * W)), Nat.div_mul by lia. rewrite dig_even.
  rewrite (Nat.mul_comm 2 W), Nat.div_mul by lia. reflexivity.
Qed.

Lemma E_id k q : 41 <= k ->
  let b := (2 * q + 1) * 2 ^ k - 2 in
  ([uD0; uS1; uD0; uD0; uD0; uD0; uD0; uD0] ++ digits (k - 3) (2 ^ (k - 4)) ++ uP :: bin (4 * q),
   32 * b + 18, 32 * b + 20) = vfz (row1 20) k ((2 * q + 1) * 2 ^ (k + 5)) 20.
Proof.
  intros Hk b. unfold b.
  assert (E5 : 2 ^ (k + 5) = 32 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 5) with 32; lia).
  assert (E3' : 2 ^ (k + 3) = 8 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 3) with 8; lia).
  assert (E2' : 2 ^ (k + 2) = 4 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 2) with 4; lia).
  assert (E1' : 2 ^ (k + 1) = 2 * 2 ^ k) by (rewrite Nat.pow_add_r; change (2 ^ 1) with 2; lia).
  assert (HK : 1 <= 2 ^ k) by (pose proof (Nat.pow_nonzero 2 k); lia).
  unfold vfz. change (row1 20) with (mkV [[]; [uS1]] 24 1 0 0 0 2). cbn [vlam vmu val_ vwp vwn vd vh].
  replace (k + 24 - 20) with (S (S (k + 2))) by lia.
  replace (S (S (k + 2)) - 1) with (k + 3) by lia.
  match goal with |- context [vfl _ _ ?V] =>
    replace V with (4 * (2 ^ (k + 1) + 2 ^ (k + 2) * (4 * q))) by (rewrite E5, E3', E2', E1'; nia) end.
  rewrite vfl_row20, vfl_nil, digits_mod.
  replace ((2 ^ (k + 1) + 2 ^ (k + 2) * (4 * q)) / 2 ^ (k + 2)) with (4 * q)
    by (apply Nat.div_unique with (2 ^ (k + 1)); rewrite ?E2', ?E1'; lia).
  replace (k + 2) with (S (k + 1)) by lia. rewrite digits_pow2.
  replace (k - 3) with (S (k - 4)) by lia. rewrite digits_pow2.
  replace (k + 1) with (5 + (k - 4)) by lia. rewrite repeat_app.
  assert (HK6 : 64 <= 2 ^ k) by (change 64 with (2 ^ 6); apply pow_ge; lia).
  f_equal; [f_equal|]; try (cbn [app repeat]; rewrite <- ?app_assoc; reflexivity);
    rewrite E5; clear -HK6; nia.
Qed.

(* Lemma E: C(b) reaches the level-1 value form at off 20 *)
Theorem LemmaE k q : 41 <= k ->
  CSplus (Cst ((2 * q + 1) * 2 ^ k - 2)) (vfz (row1 20) k ((2 * q + 1) * 2 ^ (k + 5)) 20).
Proof.
  intros Hk.
  eapply CSpS; [apply (E1 k q Hk)|].
  eapply CSpS; [apply (E2 k q Hk)|].
  apply CSp1. rewrite <- (E_id k q Hk). apply (E3 k q Hk).
Qed.


(* ===================================================================== *)
(* 24. Lemma P (proof.md 6.5): the plant, off' 12 to off' 17.            *)
(* ===================================================================== *)

Lemma pjg g i : pj (8 * g + i) = pj i.
Proof.
  rewrite pj_mod, (pj_mod i). f_equal. replace (8 * g + i) with (i + g * 8) by lia. apply Nat.Div0.mod_add.
Qed.

Lemma digits_0 n : digits n 0 = repeat uD0 n.
Proof.
  induction n as [|n IH]; [reflexivity|].
  change (digits (S n) 0) with (dig 0 :: digits n (0 / 2)). change (0 / 2) with O. rewrite IH. reflexivity.
Qed.

Lemma digits_snoc m x : x < 2 ^ m -> digits (S m) x = digits m x ++ [uD0].
Proof.
  revert x; induction m as [|m IH]; intros x Hx.
  - cbn in Hx. assert (x = O) by lia. subst. reflexivity.
  - change (digits (S (S m)) x) with (dig x :: digits (S m) (x / 2)).
    rewrite IH.
    + reflexivity.
    + rewrite Nat.pow_succ_r' in Hx. apply Nat.Div0.div_lt_upper_bound. lia.
Qed.

(* t carries on an r-digit block holding v leave v' and pass p *)
Lemma IncN_dig_q r v t p v' rest rest' : v' < 2 ^ r -> v + t = v' + 2 ^ r * p ->
  v < 2 ^ r -> IncN p rest rest' -> IncN t (digits r v ++ rest) (digits r v' ++ rest').
Proof.
  intros Hv' E Hv H.
  replace (digits r v') with (digits r (v + t)) by (rewrite E, digits_mod; reflexivity).
  apply IncN_digits. replace ((v mod 2 ^ r + t) / 2 ^ r) with p; [exact H|].
  rewrite Nat.mod_small by exact Hv. rewrite E. rewrite div_mod_shift, Nat.div_small by exact Hv'. reflexivity.
Qed.

Lemma XN_clean_q X t vx nd x p : allb cleanu X = true -> val X = vx -> ndig X = nd ->
  x < 2 ^ nd -> vx + t = x + 2 ^ nd * p -> XN t X p (fill X x).
Proof.
  intros Hc <- <- Hx E. pose proof (XN_clean X t Hc) as H.
  rewrite E, fill_mod, div_mod_shift, Nat.div_small in H by exact Hx. exact H.
Qed.

(* one closed-system step: a concrete low part X takes the first T0 carries
   (all drops), its clean rest X1 the remaining ones, Y the passed ones *)
Lemma pstep X Y T0 e1 A X1 vx nd x p X3 Y' D j D' j' :
  XN T0 X e1 (Ps A ++ X1) -> dhead X1 = true -> allb cleanu X1 = true -> val X1 = vx -> ndig X1 = nd ->
  x < 2 ^ nd -> vx + (D + pj j + 3 * A - T0) = x + 2 ^ nd * p -> T0 <= D + pj j ->
  IncN (e1 + p) Y Y' -> shiftX (fill X1 x) = Some X3 -> D' = D + A -> j' = S j ->
  CS (X ++ Y, D, j) (X3 ++ Y', D', j').
Proof.
  intros H1 Hd Hc Ev En Hx E HT HY Hs -> ->. unfold CS; cbn [fst snd].
  eapply (cutstep X Y T0 e1 A X1 (D + pj j) p (fill X1 x) D j (X3 ++ Y') Y' H1 Hd).
  - eapply XN_clean_q; eauto.
  - exact HT.
  - reflexivity.
  - exact HY.
  - apply shiftX_app. exact Hs.
Qed.

(* a step without drops on a zone with a digit at the bottom *)
Lemma cs_nodrop Z D j Y Z' : dhead Z = true -> IncN (D + pj j) Z Y -> shift Y = Some Z' ->
  CS (Z, D, j) (Z', D, S j).
Proof.
  intros Hd HI Hs. unfold CS; cbn [fst snd].
  exists (D + pj j), O, Y.
  split; [exact HI|]. split; [apply dhead_notP; eapply IncN_dhead; eauto|]. split; [lia|]. split.
  - intros m' A' Y' Hm Hi HN. destruct A' as [|A'].
    + lia.
    + exfalso. pose proof (IncN_dhead _ _ _ Hd Hi) as H. cbn in H. discriminate.
  - split; [exact Hs|split; lia].
Qed.

Lemma Inc_W3 w w3 w4 : IncN 3 w w3 -> shift w3 = Some w4 -> Inc (uW :: w) (uP :: w4).
Proof.
  intros H Hs. destruct (IncN_3_inv _ _ H) as [a [b [H1 [H2 H3]]]].
  eapply Inc_W; eauto.
Qed.

Lemma s1w_pos Q : 1 <= Q -> s1w Q = uP :: bin (2 * Q - 1).
Proof. intros HQ. unfold s1w. destruct Q; [lia|reflexivity]. Qed.

Definition gP (n Q : nat) : nat := (2 * Q + 1) * 2 ^ n - 8.

Lemma HW n : 7 <= n -> 128 <= 2 ^ n.
Proof. intros Hn. change 128 with (2 ^ 7). apply pow_ge. lia. Qed.

Lemma Hg n Q : 7 <= n -> 8 * gP n Q + 64 = 8 * ((2 * Q + 1) * 2 ^ n).
Proof. intros Hn. pose proof (HW n Hn). unfold gP. nia. Qed.

Lemma vfl_S1 m V : 1 <= m -> vfl [[uS1]] m V = uS1 :: digits m V ++ uP :: bin (V / 2 ^ m).
Proof.
  intros Hm. destruct m as [|m]; [lia|].
  change (vfl [[uS1]] (S m) V) with (uS1 :: vfl [] (S m) V). f_equal. apply vfl_nil.
Qed.

Lemma digits_snoc' m x : 1 <= m -> x < 2 ^ (m - 1) -> digits m x = digits (m - 1) x ++ [uD0].
Proof. intros Hm Hx. destruct m as [|m]; [lia|]. replace (S m - 1) with m in * by lia. apply digits_snoc. exact Hx. Qed.

Lemma P12 n Q : 7 <= n -> 1 <= Q ->
  CS ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), 8 * gP n Q + 8, 8 * gP n Q + 12)
     ([uD0; uD0; uD0; uSP] ++ digits n (2 ^ n - 3) ++ bin (4 * Q + 1), 8 * gP n Q + 11, 8 * gP n Q + 13).
Proof.
  intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *.
  assert (Hx : xfeed 4000 8 [uS1; uP; uP; uD0; uD0; uD0; uP] =
               Some (Ps 3 ++ [uD1; uD1; uD1; uP], 0%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 8) with 8%nat in Hx. change (N.to_nat 0) with O in Hx.
  eapply (pstep _ _ 8 0 3 [uD1; uD1; uD1; uP] 7 3 0 ((2 * Q + 1) * W)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia].
  - cbn. lia.
  - rewrite pjg. change (pj 12) with 48. change (2 ^ 3) with 8. lia.
  - rewrite pjg. change (pj 12) with 48. lia.
  - rewrite Nat.add_0_l. apply (IncN_dig_q n (W - 3) _ (2 * Q + 1) (W - 3)); [fold W; lia|fold W; nia|fold W; lia|].
    replace (4 * Q + 1) with (2 * Q + (2 * Q + 1)) by lia. apply IncN_bin.
  - reflexivity.
Qed.

Lemma P13 n Q : 7 <= n -> 1 <= Q ->
  CS ([uD0; uD0; uD0; uSP] ++ digits n (2 ^ n - 3) ++ bin (4 * Q + 1), 8 * gP n Q + 11, 8 * gP n Q + 13)
     ([uD0; uS1; uD0; uP] ++ digits n (2 ^ n - 3) ++ uD0 :: s1w Q, 8 * gP n Q + 11, 8 * gP n Q + 14).
Proof.
  intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *.
  set (R := digits n (W - 3) ++ bin (4 * Q + 1)).
  set (R4 := digits n 0 ++ digits 1 0 ++ uS1 :: bin Q).
  assert (HR : Inc (uW :: R) (uP :: R4)).
  { apply (Inc_W3 R (digits n 0 ++ bin (4 * Q + 2))).
    - unfold R. apply (IncN_dig_q n (W - 3) 3 1 0); [fold W; lia|fold W; lia|fold W; lia|].
      replace (4 * Q + 2) with (4 * Q + 1 + 1) by lia. apply IncN_bin.
    - replace (4 * Q + 2) with (2 ^ 1 * (2 * Q + 1)) by (cbn; lia). rewrite bin_pow_odd, digits_0.
      rewrite shift_D0s. cbn [repeat app shift]. unfold R4. rewrite digits_0. reflexivity. }
  replace (8 * gP n Q + 14) with (S (8 * gP n Q + 13)) by lia.
  apply (cs_nodrop _ _ _ ([uD0; uD1; uD0; uP] ++ digits n (W - 3) ++ digits 1 0 ++ s1w Q)).
  - reflexivity.
  - rewrite pjg. change (pj 13) with 47.
    replace (8 * gP n Q + 11 + 47) with (8 + (8 + ((8 * ((2 * Q + 1) * W) - 22)))) by lia.
    eapply IncN_add.
    { change ([uD0; uD0; uD0; uSP] ++ R) with (digits 3 0 ++ uSP :: R).
      apply (IncN_dig_q 3 0 8 1 0 _ (uW :: R)); [cbn; lia|cbn; lia|cbn; lia|]. apply IncN_1. constructor. }
    eapply IncN_add.
    { apply (IncN_dig_q 3 0 8 1 0 _ (uP :: R4)); [cbn; lia|cbn; lia|cbn; lia|]. apply IncN_1. exact HR. }
    change ([uD0; uD1; uD0; uP] ++ digits n (W - 3) ++ digits 1 0 ++ s1w Q)
      with (digits 3 2 ++ uP :: digits n (W - 3) ++ digits 1 0 ++ s1w Q).
    apply (IncN_dig_q 3 0 _ ((2 * Q + 1) * W - 3) 2); [cbn; lia|change (2 ^ 3) with 8; nia|cbn; lia|].
    apply IncN_P. unfold R4.
    apply (IncN_dig_q n 0 _ (2 * Q) (W - 3)); [fold W; lia|fold W; nia|fold W; lia|].
    apply (IncN_dig_q 1 0 _ Q 0); [cbn; lia|cbn; lia|cbn; lia|]. apply IncN_s1w.
  - apply shiftX_app. reflexivity.
Qed.

Lemma P14 n Q : 7 <= n -> 1 <= Q ->
  CS ([uD0; uS1; uD0; uP] ++ digits n (2 ^ n - 3) ++ uD0 :: s1w Q, 8 * gP n Q + 11, 8 * gP n Q + 14)
     ([uS1; uP; uD0; uP] ++ digits n (2 ^ n - 5) ++ uD0 :: uP :: bin (4 * Q), 8 * gP n Q + 11, 8 * gP n Q + 15).
Proof.
  intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *.
  assert (Hx : xfeed 4000 2 [uD0; uS1; uD0] = Some (Ps 0 ++ [uD0; uP; uD0], 0%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 2) with 2%nat in Hx. change (N.to_nat 0) with O in Hx.
  change ([uD0; uS1; uD0; uP] ++ digits n (W - 3) ++ uD0 :: s1w Q)
    with ([uD0; uS1; uD0] ++ uP :: digits n (W - 3) ++ uD0 :: s1w Q).
  change ([uS1; uP; uD0; uP] ++ digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q))
    with ([uS1; uP; uD0] ++ uP :: digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q)).
  eapply (pstep _ _ 2 0 0 [uD0; uP; uD0] 0 2 1 (2 * (2 * Q + 1) * W - 2)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia].
  - cbn. lia.
  - rewrite pjg. change (pj 14) with 48. change (2 ^ 2) with 4. lia.
  - rewrite pjg. change (pj 14) with 48. lia.
  - rewrite Nat.add_0_l. apply IncN_P. rewrite s1w_pos by exact HQ.
    apply (IncN_dig_q n (W - 3) _ (2 * (2 * Q + 1)) (W - 5)); [fold W; lia|fold W; nia|fold W; lia|].
    change (uD0 :: uP :: bin (2 * Q - 1)) with (digits 1 0 ++ uP :: bin (2 * Q - 1)).
    change (uD0 :: uP :: bin (4 * Q)) with (digits 1 0 ++ uP :: bin (4 * Q)).
    apply (IncN_dig_q 1 0 _ (2 * Q + 1) 0); [cbn; lia|cbn; lia|cbn; lia|].
    apply IncN_P. replace (4 * Q) with (2 * Q - 1 + (2 * Q + 1)) by lia. apply IncN_bin.
  - reflexivity.
Qed.

Lemma P15 n Q : 7 <= n -> 1 <= Q ->
  CS ([uS1; uP; uD0; uP] ++ digits n (2 ^ n - 5) ++ uD0 :: uP :: bin (4 * Q), 8 * gP n Q + 11, 8 * gP n Q + 15)
     ([uS1; uP] ++ digits n (2 ^ n - 6) ++ uD0 :: uP :: bin (8 * Q + 2), 8 * gP n Q + 13, 8 * gP n Q + 16).
Proof.
  intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *.
  assert (Hx : xfeed 4000 1 [uS1; uP; uD0] = Some (Ps 2 ++ [uD0], 0%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 1) with 1%nat in Hx. change (N.to_nat 0) with O in Hx.
  change ([uS1; uP; uD0; uP] ++ digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q))
    with ([uS1; uP; uD0] ++ uP :: digits n (W - 5) ++ uD0 :: uP :: bin (4 * Q)).
  change ([uS1; uP] ++ digits n (W - 6) ++ uD0 :: uP :: bin (8 * Q + 2))
    with ([uS1] ++ uP :: digits n (W - 6) ++ uD0 :: uP :: bin (8 * Q + 2)).
  eapply (pstep _ _ 1 0 2 [uD0] 0 1 1 (4 * (2 * Q + 1) * W - 1)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia].
  - cbn. lia.
  - rewrite pjg. change (pj 15) with 47. change (2 ^ 1) with 2. lia.
  - rewrite pjg. change (pj 15) with 47. lia.
  - rewrite Nat.add_0_l. apply IncN_P.
    apply (IncN_dig_q n (W - 5) _ (4 * (2 * Q + 1)) (W - 6)); [fold W; lia|fold W; nia|fold W; lia|].
    change (uD0 :: uP :: bin (4 * Q)) with (digits 1 0 ++ uP :: bin (4 * Q)).
    change (uD0 :: uP :: bin (8 * Q + 2)) with (digits 1 0 ++ uP :: bin (8 * Q + 2)).
    apply (IncN_dig_q 1 0 _ (2 * (2 * Q + 1)) 0); [cbn; lia|cbn; lia|cbn; lia|].
    apply IncN_P. replace (8 * Q + 2) with (4 * Q + 2 * (2 * Q + 1)) by lia. apply IncN_bin.
  - reflexivity.
Qed.

Lemma P16 n Q : 7 <= n -> 1 <= Q ->
  CS ([uS1; uP] ++ digits n (2 ^ n - 6) ++ uD0 :: uP :: bin (8 * Q + 2), 8 * gP n Q + 13, 8 * gP n Q + 16)
     ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17).
Proof.
  intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'. set (W := 2 ^ n) in *.
  set (H := 2 ^ (n - 1)).
  assert (EH : W = 2 * H) by (unfold W, H; replace n with (S (n - 1)) at 1 by lia; apply Nat.pow_succ_r').
  assert (Ed : digits n (W - 6) = uD0 :: digits (n - 1) (H - 3)).
  { replace n with (S (n - 1)) at 1 by lia. change (digits (S (n - 1)) (W - 6)) with (dig (W - 6) :: digits (n - 1) ((W - 6) / 2)).
    replace (W - 6) with (2 * (H - 3)) by lia. rewrite dig_even.
    rewrite (Nat.mul_comm 2 (H - 3)), Nat.div_mul by lia. reflexivity. }
  rewrite Ed.
  assert (Hx : xfeed 4000 1 [uS1; uP; uD0] = Some (Ps 2 ++ [uD0], 0%N)) by reflexivity.
  apply xfeed_sound in Hx. change (N.to_nat 1) with 1%nat in Hx. change (N.to_nat 0) with O in Hx.
  change ([uS1; uP] ++ (uD0 :: digits (n - 1) (H - 3)) ++ uD0 :: uP :: bin (8 * Q + 2))
    with ([uS1; uP; uD0] ++ digits (n - 1) (H - 3) ++ uD0 :: uP :: bin (8 * Q + 2)).
  eapply (pstep _ _ 1 0 2 [uD0] 0 1 1 (4 * (2 * Q + 1) * W)); [exact Hx|reflexivity|reflexivity|reflexivity|reflexivity| | | | | |lia|lia].
  - cbn. lia.
  - rewrite pjg. change (pj 16) with 47. change (2 ^ 1) with 2. lia.
  - rewrite pjg. change (pj 16) with 47. lia.
  - rewrite Nat.add_0_l.
    assert (HH : 64 <= H) by lia.
    apply (IncN_dig_q (n - 1) (H - 3) _ (8 * (2 * Q + 1)) (H - 3)); [fold H; lia|fold H; nia|fold H; lia|].
    change (uD0 :: uP :: bin (8 * Q + 2)) with (digits 1 0 ++ uP :: bin (8 * Q + 2)).
    change (uD0 :: uP :: bin (16 * Q + 6)) with (digits 1 0 ++ uP :: bin (16 * Q + 6)).
    apply (IncN_dig_q 1 0 _ (4 * (2 * Q + 1)) 0); [cbn; lia|cbn; lia|cbn; lia|].
    apply IncN_P. replace (16 * Q + 6) with (8 * Q + 2 + 4 * (2 * Q + 1)) by lia. apply IncN_bin.
  - reflexivity.
Qed.

Theorem LemmaP n Q : 7 <= n -> 1 <= Q ->
  CSplus ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q), 8 * gP n Q + 8, 8 * gP n Q + 12)
         ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17).
Proof.
  intros Hn HQ.
  eapply CSpS; [apply P12; auto|]. eapply CSpS; [apply P13; auto|]. eapply CSpS; [apply P14; auto|].
  eapply CSpS; [apply P15; auto|]. apply CSp1. apply P16; auto.
Qed.

(* the plant end is the level-2 value form at off' 17 *)
Lemma P_id n Q : 7 <= n -> 1 <= Q ->
  ([uS1] ++ digits (n - 1) (2 ^ (n - 1) - 3) ++ uD0 :: uP :: bin (16 * Q + 6), 8 * gP n Q + 15, 8 * gP n Q + 17)
  = vfz (phrow 1) (n - 7) ((2 * Q + 1) * 2 ^ (n + 3)) 17.
Proof.
  intros Hn HQ. pose proof (HW n Hn) as HW'. pose proof (Hg n Q Hn) as Hg'.
  assert (EH : 2 ^ n = 2 * 2 ^ (n - 1)) by (replace n with (S (n - 1)) at 1 by lia; apply Nat.pow_succ_r').
  assert (E3 : 2 ^ (n + 3) = 8 * 2 ^ n) by (rewrite Nat.pow_add_r; change (2 ^ 3) with 8; lia).
  assert (HH : 64 <= 2 ^ (n - 1)) by lia.
  unfold vfz. change (phrow 1) with (mkV [[uS1]] 24 1 1 0 20 2). cbn [vlam vmu val_ vwp vwn vd vh].
  replace (n - 7 + 24 - 17) with n by lia.
  match goal with |- context [vfl _ _ ?V] =>
    replace V with ((2 ^ (n - 1) - 3) + 2 ^ n * (16 * Q + 6)) by (rewrite E3, EH; rewrite EH in Hg'; nia) end.
  rewrite vfl_S1 by lia. rewrite digits_mod. rewrite (digits_snoc' n) by lia.
  replace ((2 ^ (n - 1) - 3 + 2 ^ n * (16 * Q + 6)) / 2 ^ n) with (16 * Q + 6)
    by (apply Nat.div_unique with (2 ^ (n - 1) - 3); lia).
  f_equal; [f_equal|]; try (cbn [app]; rewrite <- ?app_assoc; reflexivity); rewrite E3; lia.
Qed.

(* the start of the plant is the value form at off_end(K) when 8 | K + 9 *)
Lemma vfl_plant y : vfl [[uS1; uP; uP]] 3 (8 * y) = [uS1; uP; uP; uD0; uD0; uD0; uP] ++ bin y.
Proof.
  cbn [vfl hd tl app].
  replace (8 * y) with (2 * (4 * y)) by lia. rewrite dig_even.
  rewrite (Nat.mul_comm 2 (4 * y)), Nat.div_mul by lia.
  replace (4 * y) with (2 * (2 * y)) by lia. rewrite dig_even.
  rewrite (Nat.mul_comm 2 (2 * y)), Nat.div_mul by lia. rewrite dig_even.
  rewrite (Nat.mul_comm 2 y), Nat.div_mul by lia. reflexivity.
Qed.



Lemma VFe_plant K Om n Q : 7 <= n -> 1 <= Q -> (K + 9) mod 8 = O -> 41 <= K ->
  Om + K + 9 = (2 * Q + 1) * 2 ^ (n + 3) ->
  VFe K Om = ([uS1; uP; uP; uD0; uD0; uD0; uP] ++ digits n (2 ^ n - 3) ++ bin (2 * Q),
              8 * gP n Q + 8, 8 * gP n Q + 12).
Proof.
  intros Hn HQ H8 HK HM.
  assert (HW : 128 <= 2 ^ n) by (change 128 with (2 ^ 7); apply pow_ge; lia).
  assert (E3 : 2 ^ (n + 3) = 8 * 2 ^ n) by (rewrite Nat.pow_add_r; change (2 ^ 3) with 8; lia).
  assert (Eo : off_end K = K + 21).
  { unfold off_end. replace ((K + 20) mod 8) with 3; [reflexivity|].
    replace (K + 20) with (3 + ((K + 9) / 8 + 1) * 8) by (pose proof (Nat.div_mod_eq (K + 9) 8); lia).
    rewrite Nat.Div0.mod_add. reflexivity. }
  assert (E4 : (K + 21) mod 8 = 4).
  { replace (K + 21) with (4 + ((K + 9) / 8 + 1) * 8) by (pose proof (Nat.div_mod_eq (K + 9) 8); lia).
    rewrite Nat.Div0.mod_add. reflexivity. }
  unfold VFe. rewrite Eo, E4. unfold vfz. change (phrow 4) with (mkV [[uS1; uP; uP]] 24 1 1 0 24 4).
  cbn [vlam vmu val_ vwp vwn vd vh].
  replace (K + 24 - (K + 21)) with 3 by lia.
  change (2 ^ (3 - 1)) with 4.
  match goal with |- context [vfl _ _ ?V] =>
    replace V with (8 * ((2 ^ n - 3) + 2 ^ n * (2 * Q))) by (rewrite E3 in HM; clear -HM HW; nia) end.
  rewrite vfl_plant. rewrite <- digits_app_bin by lia.
  unfold gP. f_equal; [f_equal|]; nia.
Qed.

(* ===================================================================== *)
(* 25. The class recursion E(K) and Theorem B (proof.md 6.5, 6.7).       *)
(* ===================================================================== *)

Theorem EK K : 41 <= K -> forall U, 1 <= U -> exists b', CSplus (VFe K (U * 2 ^ (K + 5))) (Cst b').
Proof.
  induction K as [K IH] using lt_wf_ind. intros HK U HU.
  destruct (odd_decomp (K + 9) ltac:(lia)) as [v [s [Hks Hs]]].
  destruct (Nat.le_gt_cases v 50) as [Hv|Hv].
  - eapply E_low; eauto.
  - (* the plant, Lemma VF at level 2, then the induction hypothesis at v - 10 *)
    assert (Hs1 : 1 <= s) by (destruct s; [discriminate|lia]).
    assert (Hlin : v + 5 <= 2 ^ v).
    { assert (v - 1 < 2 ^ (v - 1)) by (apply Nat.pow_gt_lin_r; lia).
      replace v with (S (v - 1)) at 2 by lia. rewrite Nat.pow_succ_r'. lia. }
    assert (Hpk : 2 ^ v <= K + 9) by (rewrite Hks; clear -Hs1; nia).
    assert (Hvk : v + 1 <= K + 5) by lia.
    set (S0 := s + U * 2 ^ (K + 5 - v)).
    assert (ES : U * 2 ^ (K + 5) + K + 9 = S0 * 2 ^ v).
    { unfold S0. replace (U * 2 ^ (K + 5) + K + 9) with (U * 2 ^ (K + 5) + (K + 9)) by lia.
      rewrite Hks. replace (K + 5) with ((K + 5 - v) + v) at 1 by lia.
      rewrite Nat.pow_add_r. nia. }
    assert (Hodd : Nat.odd S0 = true).
    { unfold S0. replace (K + 5 - v) with (S (K + 4 - v)) by lia. rewrite Nat.pow_succ_r'.
      rewrite Nat.odd_add, Hs.
      replace (U * (2 * 2 ^ (K + 4 - v))) with (2 * (U * 2 ^ (K + 4 - v))) by lia.
      rewrite Nat.odd_mul. reflexivity. }
    destruct (proj1 (Nat.odd_spec S0) Hodd) as [Q EQ].
    assert (HQ : 1 <= Q).
    { assert (2 <= U * 2 ^ (K + 5 - v)).
      { replace (K + 5 - v) with (S (K + 4 - v)) by lia. rewrite Nat.pow_succ_r'.
        pose proof (Nat.pow_nonzero 2 (K + 4 - v)). nia. }
      unfold S0 in EQ. lia. }
    set (n := v - 3).
    assert (Hn : 7 <= n) by (unfold n; lia).
    assert (Ev : n + 3 = v) by (unfold n; lia).
    assert (H8 : (K + 9) mod 8 = O).
    { rewrite Hks. replace v with (3 + (v - 3)) by lia. rewrite Nat.pow_add_r.
      replace (s * (2 ^ 3 * 2 ^ (v - 3))) with ((s * 2 ^ (v - 3)) * 8) by (change (2 ^ 3) with 8; lia).
      apply Nat.Div0.mod_mul. }
    destruct (IH (v - 10) ltac:(lia) ltac:(lia) (32 * S0) ltac:(lia)) as [b' Hb']. exists b'.
    rewrite (VFe_plant K (U * 2 ^ (K + 5)) n Q Hn HQ H8 HK) by (rewrite Ev, ES, EQ; lia).
    eapply CSplus_trans; [apply (LemmaP n Q Hn HQ)|].
    rewrite (P_id n Q Hn HQ).
    replace (n - 7) with (v - 10) by lia. rewrite Ev.
    replace (2 * Q + 1) with S0 by lia.
    eapply CSstar_plus; [apply VF2; lia|].
    replace (S0 * 2 ^ v) with ((32 * S0) * 2 ^ (v - 10 + 5)).
    + exact Hb'.
    + assert (E5 : 2 ^ v = 32 * 2 ^ (v - 10 + 5)).
      { replace v with (5 + (v - 10 + 5)) at 1 by lia. rewrite Nat.pow_add_r. change (2 ^ 5) with 32. lia. }
      rewrite E5. ring.
Qed.

Theorem thmB b : exists b', CSplus (Cst b) (Cst b').
Proof.
  destruct (odd_decomp (b + 2) ltac:(lia)) as [k [o [Hb Ho]]].
  destruct (Nat.le_gt_cases k 40) as [Hk|Hk].
  - eapply small_classes; eauto.
  - destruct (proj1 (Nat.odd_spec o) Ho) as [q Eq].
    replace b with ((2 * q + 1) * 2 ^ k - 2) by lia.
    destruct (EK k ltac:(lia) (2 * q + 1) ltac:(lia)) as [b' Hb']. exists b'.
    eapply CSplus_trans; [apply LemmaE; lia|].
    eapply CSstar_plus; [apply VF1; lia|].
    exact Hb'.
Qed.

(* ===================================================================== *)
(* 26. The closed system runs forever: every step j >= 1 is reached.     *)
(* ===================================================================== *)

Definition CSr (s : st) : Prop := CSreach (fst (fst s)) (snd (fst s)) (snd s).

Lemma CSplus_reach s s' : CSr s -> CSplus s s' -> CSr s'.
Proof.
  intros H1 H2. induction H2 as [x y Hs|x y z Hs H IH].
  - destruct x as [[zx dx] jx], y as [[zy dy] jy]. unfold CSr in *. cbn in *. econstructor; eauto.
  - apply IH. destruct x as [[zx dx] jx], y as [[zy dy] jy]. unfold CSr in *. cbn in *. econstructor; eauto.
Qed.

Lemma all_Cst N0 : exists b, N0 <= b /\ CSr (Cst b).
Proof.
  induction N0 as [|N0 [b [Hb HR]]].
  - exists O. split; [lia|]. exact C0_reach.
  - destruct (thmB b) as [b' Hp]. exists b'. split.
    + pose proof (CSplus_j _ _ Hp) as Hj. cbn in Hj. lia.
    + eapply CSplus_reach; eauto.
Qed.

Lemma CSreach_down Z D j : CSreach Z D j -> forall j', 1 <= j' <= j -> exists Z' D', CSreach Z' D' j'.
Proof.
  induction 1 as [|Z D j Z' D' j' H IH Hs]; intros j0 Hj0.
  - assert (j0 = 1%nat) by lia. subst. eexists _, _. constructor.
  - assert (Ej : j' = S j) by (destruct Hs as [m [A [Y [_ [_ [_ [_ [_ [_ Ej]]]]]]]]]; exact Ej).
    destruct (Nat.eq_dec j0 j') as [->|Hne].
    + exists Z', D'. econstructor; eauto.
    + apply IH. lia.
Qed.

Theorem zone_forever J : 1 <= J -> exists Z D, CSreach Z D J.
Proof.
  intros HJ. destruct (all_Cst J) as [b [Hb HR]].
  unfold CSr, Cst in HR. cbn in HR.
  eapply CSreach_down; [exact HR|lia].
Qed.


(* ===================================================================== *)
(* 27. The closed-system orbit is a function: determinism, and every     *)
(*     reached state has a next step.                                    *)
(* ===================================================================== *)

Lemma cs_step_j Z D j Z' D' j' : cs_step Z D j Z' D' j' -> j' = S j.
Proof. intros [m [a [y [_ [_ [_ [_ [_ [_ E]]]]]]]]]. exact E. Qed.

Lemma cs_step_det Z D j Z1 D1 j1 Z2 D2 j2 :
  cs_step Z D j Z1 D1 j1 -> cs_step Z D j Z2 D2 j2 -> Z1 = Z2 /\ D1 = D2.
Proof.
  intros Hc1 Hc2.
  destruct Hc1 as [m1 [a1 [y1 [H1 [N1 [E1 [M1 [Hs1 [Ed1 _]]]]]]]]].
  destruct Hc2 as [m2 [a2 [y2 [H2 [N2 [E2 [M2 [Hs2 [Ed2 _]]]]]]]]].
  assert (Em : m1 = m2).
  { destruct (Nat.lt_trichotomy m1 m2) as [Hl|[Hl|Hl]]; auto.
    - exfalso. exact (M2 m1 a1 y1 Hl H1 N1 E1).
    - exfalso. exact (M1 m2 a2 y2 Hl H2 N2 E2). }
  rewrite <- Em in H2. pose proof (IncN_det _ _ _ _ H1 H2) as E.
  destruct (Ps_notP_inj _ _ _ _ E N1 N2) as [Ea Ey]. subst a2 y2.
  rewrite Hs1 in Hs2. injection Hs2 as Hz. split; [exact Hz|lia].
Qed.

Lemma CSreach_pos Z D j : CSreach Z D j -> 1 <= j.
Proof. induction 1 as [|Z D j Z' D' j' H IH Hs]; [lia|]. apply cs_step_j in Hs. lia. Qed.

Lemma CSreach_det Z1 D1 j : CSreach Z1 D1 j -> forall Z2 D2, CSreach Z2 D2 j -> Z1 = Z2 /\ D1 = D2.
Proof.
  induction 1 as [|Z D j Z' D' j' H IH Hs]; intros Z2 D2 H2.
  - inversion H2 as [|z0 d0 k0 z1 d1 k1 H0 Hs0]; subst; [auto|].
    apply cs_step_j in Hs0. apply CSreach_pos in H0. lia.
  - pose proof (cs_step_j _ _ _ _ _ _ Hs) as Ej. subst j'.
    inversion H2 as [|z0 d0 k0 z1 d1 k1 H0 Hs0]; subst.
    + apply CSreach_pos in H. lia.
    + pose proof (cs_step_j _ _ _ _ _ _ Hs0) as Ej0. assert (k0 = j) by lia. subst k0.
      destruct (IH _ _ H0) as [Ez Ed]. subst z0 d0.
      exact (cs_step_det _ _ _ _ _ _ _ _ _ Hs Hs0).
Qed.

(* every reached state of the closed system has its next step *)
Theorem CS_next Z D j : CSreach Z D j -> exists Z' D', cs_step Z D j Z' D' (S j).
Proof.
  intros H. destruct (zone_forever (S j) ltac:(lia)) as [Z2 [D2 H2]].
  inversion H2 as [|z0 d0 k0 z1 d1 k1 H0 Hs0]; subst.
  - apply CSreach_pos in H. lia.
  - pose proof (cs_step_j _ _ _ _ _ _ Hs0) as E. assert (k0 = j) by lia. subst k0.
    destruct (CSreach_det _ _ _ H0 _ _ H) as [Ez Ed]. subst z0 d0. eauto.
Qed.

(* below the least fixed point the zone count stays under c + 3 A(m) *)
Lemma leading_P w : exists a y, w = Ps a ++ y /\ notP y.
Proof.
  induction w as [|u w [a [y [E N]]]].
  - exists O, (@nil unt). split; [reflexivity|exact I].
  - destruct u; [exists O, (uD0 :: w) | exists O, (uD1 :: w) | exists (S a), y
                 | exists O, (uS1 :: w) | exists O, (uSP :: w) | exists O, (uW :: w)];
      (split; [cbn; try (subst w); reflexivity | cbn; try exact I; exact N]).
Qed.

Lemma IncN_le m m' Z Y : m' <= m -> IncN m Z Y -> exists Y', IncN m' Z Y'.
Proof.
  intros Hle H. replace m with (m' + (m - m')) in H by lia.
  destruct (IncN_split _ _ _ _ H) as [Y1 [H1 _]]. eauto.
Qed.

(* ===================================================================== *)
(* 28. Pops through a conveyor wall that is not the top wall: a wall      *)
(*     fed by f pops fires (3 f + b) / 2 times, each a pop of the rest.   *)
(* ===================================================================== *)

Lemma odd_plus2 n : Nat.odd (n + 2) = Nat.odd n.
Proof. replace (n + 2) with (S (S n)) by lia. apply Nat.odd_succ_succ. Qed.

Lemma Ps_add a b x : Ps a ++ Ps b ++ x = Ps (a + b) ++ x.
Proof. induction a as [|a IH]; [reflexivity|]. cbn [Ps app]. rewrite IH. reflexivity. Qed.

Lemma Pops_wall f a (b : bool) r r' :
  Pops ((3 * f + Nat.b2n b) / 2) r r' ->
  Pops f (Ps a ++ wallu b :: r)
         (Ps (a + (3 * f + Nat.b2n b) / 2 - f) ++ wallu (Nat.odd (3 * f + Nat.b2n b)) :: r').
Proof.
  revert a b r. induction f as [|f IH]; intros a b r H.
  - destruct b; simpl in H |- *; subst r'; rewrite ?Nat.add_0_r, ?Nat.sub_0_r; reflexivity.
  - set (g := (3 + Nat.b2n b) / 2).
    set (b1 := Nat.odd (3 + Nat.b2n b)).
    assert (Eg : (3 * S f + Nat.b2n b) / 2 = g + (3 * f + Nat.b2n b1) / 2).
    { unfold g, b1. destruct b.
      - change (Nat.b2n true) with 1%nat. change (Nat.odd (3 + 1)) with false. change (Nat.b2n false) with O.
        replace (3 * S f + 1) with ((3 * f + 0) + 2 * 2) by lia.
        rewrite Nat.div_add by lia. change ((3 + 1) / 2) with 2%nat. lia.
      - change (Nat.b2n false) with O. change (Nat.odd (3 + 0)) with true. change (Nat.b2n true) with 1%nat.
        replace (3 * S f + 0) with ((3 * f + 1) + 1 * 2) by lia.
        rewrite Nat.div_add by lia. change ((3 + 0) / 2) with 1%nat. lia. }
    assert (Eo : Nat.odd (3 * S f + Nat.b2n b) = Nat.odd (3 * f + Nat.b2n b1)).
    { unfold b1. destruct b.
      - change (Nat.b2n true) with 1%nat. change (Nat.odd (3 + 1)) with false. change (Nat.b2n false) with O.
        replace (3 * S f + 1) with ((3 * f + 0) + 2 + 2) by lia. rewrite !odd_plus2. reflexivity.
      - change (Nat.b2n false) with O. change (Nat.odd (3 + 0)) with true. change (Nat.b2n true) with 1%nat.
        replace (3 * S f + 0) with ((3 * f + 1) + 2) by lia. rewrite odd_plus2. reflexivity. }
    rewrite Eg in H. destruct (Pops_split _ _ _ _ H) as [r1 [H1 H2]].
    assert (Hg : 1 <= g) by (unfold g; destruct b; cbn; lia).
    exists (Ps (a + g - 1) ++ wallu b1 :: r1). split.
    + apply Inc3Pop_of.
      replace (uP :: Ps (a + g - 1) ++ wallu b1 :: r1) with (Ps a ++ Ps g ++ wallu b1 :: r1).
      * apply IncN_Ps. apply (wall_feed 3 b r r1 H1).
      * rewrite Ps_add. assert (Ea : a + g = S (a + g - 1)) by lia. rewrite Ea at 1. reflexivity.
    + rewrite Eo, Eg. replace (a + (g + (3 * f + Nat.b2n b1) / 2) - S f)
        with (a + g - 1 + (3 * f + Nat.b2n b1) / 2 - f) by lia.
      apply IH. exact H2.
Qed.

(* ===================================================================== *)
(* 29. Birth data of the walls (proof.md 4, 5) and the bracket of Lemma T. *)
(*     Wall w < 6 is a wall of U0 (absorption order); wall w >= 6 has     *)
(*     birth phase (w - 6) mod 8.  b is the birth index in the U0 frame,  *)
(*     s = 1 for W, H the carries received before the next wall's birth.  *)
(* ===================================================================== *)

Definition u0b : list Z := [32; 20; 12; 7; 3; 1]%Z.
Definition u0s : list nat := [1; 1; 1; 0; 1; 0]%nat.
Definition u0H : list nat := [0; 0; 0; 0; 0; 9]%nat.
Definition phb : list Z := [2; 0; -1; 10; 5; 2; 0; 1]%Z.
Definition phs : list nat := [0; 1; 1; 0; 0; 1; 1; 0]%nat.
Definition phH : list nat := [0; 0; 36; 0; 0; 0; 6; 9]%nat.

Definition wb (w : nat) : Z := if Nat.ltb w 6 then nth w u0b 0%Z else nth ((w - 6) mod 8) phb 0%Z.
Definition wsb (w : nat) : nat := if Nat.ltb w 6 then nth w u0s O else nth ((w - 6) mod 8) phs O.
Definition wH (w : nat) : nat := if Nat.ltb w 6 then nth w u0H O else nth ((w - 6) mod 8) phH O.

(* Lemma T: p(J mod 8) = 43 - 3 b_J + 2 b_(J-1) + s_(J-1) + H_(J-1) *)
Definition bracket_ok (J : nat) : bool :=
  Z.eqb (Z.of_nat (pj J))
        (43 - 3 * wb J + 2 * wb (J - 1) + Z.of_nat (wsb (J - 1)) + Z.of_nat (wH (J - 1)))%Z.

Lemma bracket_small : forallb bracket_ok [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14]%nat = true.
Proof. vm_compute. reflexivity. Qed.

Lemma wdata_period w : 6 <= w -> wb (w + 8) = wb w /\ wsb (w + 8) = wsb w /\ wH (w + 8) = wH w.
Proof.
  intros Hw. unfold wb, wsb, wH.
  destruct (Nat.ltb_spec (w + 8) 6) as [|_]; [lia|]. destruct (Nat.ltb_spec w 6) as [|_]; [lia|].
  replace (w + 8 - 6) with ((w - 6) + 1 * 8) by lia. rewrite Nat.Div0.mod_add. auto.
Qed.

Theorem bracket J : 1 <= J -> bracket_ok J = true.
Proof.
  induction J as [J IH] using lt_wf_ind. intros HJ.
  destruct (Nat.le_gt_cases J 14) as [Hle|Hgt].
  - pose proof bracket_small as H. rewrite forallb_forall in H. apply H.
    cbn [In]. lia.
  - specialize (IH (J - 8) ltac:(lia) ltac:(lia)).
    unfold bracket_ok in *.
    destruct (wdata_period (J - 8) ltac:(lia)) as [E1 [_ _]].
    destruct (wdata_period (J - 1 - 8) ltac:(lia)) as [F1 [F2 F3]].
    replace (J - 8 + 8) with J in E1 by lia. replace (J - 1 - 8 + 8) with (J - 1) in F1, F2, F3 by lia.
    replace (J - 8 - 1) with (J - 1 - 8) in IH by lia.
    rewrite E1, F1, F2, F3.
    replace (pj J) with (pj (J - 8)); [exact IH|].
    assert (EJ : J mod 8 = (J - 8) mod 8).
    { rewrite <- (Nat.Div0.mod_add (J - 8) 1 8). f_equal. lia. }
    rewrite (pj_mod J), (pj_mod (J - 8)), EJ. reflexivity.
Qed.


(* ===================================================================== *)
(* 30. The conveyor seen from a position: walls with absolute positions  *)
(*     and carry counts, and above the youngest absorbed wall the zone   *)
(*     of the next interval.  Positions are in the U0 frame shifted by   *)
(*     one, so the zone bottom is 44 + D + A.                            *)
(* ===================================================================== *)

Lemma wb_ge w : (-1 <= wb w)%Z.
Proof.
  unfold wb. destruct (Nat.ltb w 6).
  - assert (H : forall i, (-1 <= nth i u0b 0)%Z).
    { intros i. do 6 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. }
    apply H.
  - assert (H : forall i, (-1 <= nth i phb 0)%Z).
    { intros i. do 8 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. }
    apply H.
Qed.

Lemma wb_le w : (wb w <= 32)%Z.
Proof.
  unfold wb. destruct (Nat.ltb w 6).
  - assert (H : forall i, (nth i u0b 0 <= 32)%Z).
    { intros i. do 6 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. }
    apply H.
  - assert (H : forall i, (nth i phb 0 <= 32)%Z).
    { intros i. do 8 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. }
    apply H.
Qed.

Lemma wsb_le w : wsb w <= 1.
Proof.
  unfold wsb. destruct (Nat.ltb w 6).
  - assert (H : forall i, nth i u0s O <= 1).
    { intros i. do 6 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. }
    apply H.
  - assert (H : forall i, nth i phs O <= 1).
    { intros i. do 8 (destruct i as [|i]; [cbn; lia|]). destruct i; cbn; lia. }
    apply H.
Qed.

Definition bq (w : nat) : nat := Z.to_nat (wb w + 1).
Definition fw (w R : nat) : nat := (R + wsb w) / 2.
Definition posw (w R : nat) : nat := bq w + fw w R.
Definition Rab (w D : nat) : nat := 2 * (44 + D - bq w) - wsb w.

Lemma bq_spec w : Z.of_nat (bq w) = (wb w + 1)%Z.
Proof. unfold bq. pose proof (wb_ge w). rewrite Z2Nat.id; lia. Qed.

Lemma bq_le w : bq w <= 33.
Proof. pose proof (bq_spec w). pose proof (wb_le w). lia. Qed.

(* Lemma T in the shifted frame *)
Lemma bracket_nat w : pj (S w) + 3 * bq (S w) = 44 + 2 * bq w + wsb w + wH w.
Proof.
  pose proof (bracket (S w) ltac:(lia)) as H. unfold bracket_ok in H. apply Z.eqb_eq in H.
  replace (S w - 1) with w in H by lia.
  pose proof (bq_spec w). pose proof (bq_spec (S w)). lia.
Qed.

Definition nofix (Z : list unt) (D J m : nat) : Prop :=
  forall A Y, IncN m Z (Ps A ++ Y) -> notP Y -> m <> D + pj J + 3 * A.

(* the zone of interval J after m carries, seen from position p *)
Definition ZoneR (J m p : nat) (u : list unt) : Prop :=
  exists Z D A Y, CSreach Z D J /\ IncN m Z (Ps A ++ Y) /\ notP Y /\
    (forall m', m' < m -> nofix Z D J m') /\ p <= 44 + D + A /\ u = Ps (44 + D + A - p) ++ Y.

(* the zone of interval 0 (the partial interval before the first
   absorption): the counter D0 D0 D1^4 = bin 60 after m carries *)
Definition Zone0 (m p : nat) (u : list unt) : Prop := m <= 33 /\ p <= 44 /\ u = Ps (44 - p) ++ bin (60 + m).

(* the word from position p upward, where w is the youngest wall in it and
   has received R carries since its birth *)
Fixpoint WdR (w p R : nat) (u : list unt) : Prop :=
  (exists Z D, CSreach Z D (S w) /\ Rab w D <= R /\ ZoneR (S w) (R - Rab w D) p u) \/
  ((forall Z D, CSreach Z D (S w) -> R < Rab w D) /\ p <= posw w R /\
   exists u', u = Ps (posw w R - p) ++ wallu (Nat.odd (R + wsb w)) :: u' /\
   match w with
   | O => Zone0 (3 * fw 0 R) (S (posw 0 R)) u'
   | S w' => WdR w' (S (posw w R)) (wH w' + 3 * fw w R) u'
   end).

Lemma WdR_eq w p R u : WdR w p R u <->
  (exists Z D, CSreach Z D (S w) /\ Rab w D <= R /\ ZoneR (S w) (R - Rab w D) p u) \/
  ((forall Z D, CSreach Z D (S w) -> R < Rab w D) /\ p <= posw w R /\
   exists u', u = Ps (posw w R - p) ++ wallu (Nat.odd (R + wsb w)) :: u' /\
   match w with
   | O => Zone0 (3 * fw 0 R) (S (posw 0 R)) u'
   | S w' => WdR w' (S (posw w R)) (wH w' + 3 * fw w R) u'
   end).
Proof. destruct w; reflexivity. Qed.

(* the precondition of a carry: a zone above may take one more carry *)
Definition Can (w R : nat) : Prop :=
  forall Z D, CSreach Z D (S w) -> Rab w D <= R ->
    (exists Y', IncN (S (R - Rab w D)) Z Y') /\ nofix Z D (S w) (R - Rab w D).

(* ---- small word lemmas ---- *)

Lemma Inc_Ps a y y' : Inc y y' -> Inc (Ps a ++ y) (Ps a ++ y').
Proof. intros H. apply IncN_1_inv. apply IncN_Ps. apply IncN_1. exact H. Qed.

Lemma Ps_snoc a x : Ps a ++ uP :: x = Ps (S a) ++ x.
Proof. induction a as [|a IH]; [reflexivity|]. cbn [Ps app]. rewrite IH. reflexivity. Qed.

Lemma Ps_P_cons n y t : Ps n ++ y = uP :: t -> notP y -> 1 <= n /\ t = Ps (n - 1) ++ y.
Proof.
  intros E N. destruct n as [|n].
  - cbn in E. subst y. contradiction.
  - cbn in E. injection E as E. split; [lia|]. replace (S n - 1) with n by lia. auto.
Qed.

Lemma notP_wall b x : notP (wallu b :: x).
Proof. destruct b; exact I. Qed.

Lemma shift_notP Y Z' : notP Y -> shift Y = Some Z' -> notP Z'.
Proof.
  intros N H. destruct Y as [|u Y]; cbn in H.
  - injection H as <-. exact I.
  - destruct u; try discriminate; cbn in N; try contradiction.
    + destruct (shift Y); [|discriminate]. injection H as <-. exact I.
    + injection H as <-. exact I.
Qed.

Lemma Ps_le a b y y' : Ps a ++ y = Ps b ++ y' -> notP y' -> a <= b.
Proof.
  revert b; induction a as [|a IH]; intros b E N; [lia|].
  destruct b as [|b]; cbn in E.
  - subst y'. contradiction.
  - injection E as E. apply IH in E; [lia|exact N].
Qed.

Lemma fw_even w R : Nat.odd (R + wsb w) = false -> fw w (S R) = fw w R.
Proof.
  intros H. unfold fw. assert (He : Nat.even (R + wsb w) = true) by (rewrite <- Nat.negb_odd, H; reflexivity).
  apply Nat.even_spec in He. destruct He as [k Hk].
  replace (S R + wsb w) with (1 + k * 2) by lia. rewrite Hk.
  rewrite Nat.div_add by lia. rewrite (Nat.mul_comm 2 k), Nat.div_mul by lia. reflexivity.
Qed.

Lemma fw_odd w R : Nat.odd (R + wsb w) = true -> fw w (S R) = S (fw w R).
Proof.
  intros H. unfold fw. apply Nat.odd_spec in H. destruct H as [k Hk].
  replace (S R + wsb w) with (0 + (k + 1) * 2) by lia. rewrite Hk.
  rewrite Nat.div_add by lia. replace (2 * k + 1) with (1 + k * 2) by lia.
  rewrite Nat.div_add by lia. change (0 / 2) with O. change (1 / 2) with O. lia.
Qed.

Lemma odd_S_false w R : Nat.odd (R + wsb w) = true -> Nat.odd (S R + wsb w) = false.
Proof. intros H. replace (S R + wsb w) with (S (R + wsb w)) by lia. rewrite Nat.odd_succ, <- Nat.negb_odd, H. reflexivity. Qed.

Lemma odd_S_true w R : Nat.odd (R + wsb w) = false -> Nat.odd (S R + wsb w) = true.
Proof. intros H. replace (S R + wsb w) with (S (R + wsb w)) by lia. rewrite Nat.odd_succ, <- Nat.negb_odd, H. reflexivity. Qed.

Lemma fw_mono w R R' : R <= R' -> fw w R <= fw w R'.
Proof. intros H. unfold fw. apply Nat.Div0.div_le_mono. lia. Qed.

Lemma fw_add3 w R : S (fw w R) <= fw w (R + 3).
Proof.
  unfold fw. replace (R + 3 + wsb w) with ((R + wsb w + 1) + 1 * 2) by lia.
  rewrite Nat.div_add by lia. pose proof (Nat.Div0.div_le_mono (R + wsb w) (R + wsb w + 1) 2 ltac:(lia)). lia.
Qed.

Lemma Rab_parity w D R : Nat.odd (R + wsb w) = false -> R < Rab w D -> S R < Rab w D.
Proof.
  intros Ho HR. pose proof (wsb_le w). pose proof (bq_le w). unfold Rab in *.
  assert (He : Nat.even (R + wsb w) = true) by (rewrite <- Nat.negb_odd, Ho; reflexivity).
  apply Nat.even_spec in He. destruct He as [k Hk].
  destruct (Nat.eq_dec (S R) (2 * (44 + D - bq w) - wsb w)) as [E|E]; [|lia].
  exfalso. assert (2 * k + 1 = 2 * (44 + D - bq w)) by lia. lia.
Qed.

(* below the least fixed point: m <= c + 3 A(m) *)
Lemma below Z D J ms As Ys : IncN ms Z (Ps As ++ Ys) -> notP Ys ->
  (forall m', m' < ms -> nofix Z D J m') ->
  forall m A Y, m <= ms -> IncN m Z (Ps A ++ Y) -> notP Y -> m <= D + pj J + 3 * A.
Proof.
  intros Hs Ns Hmin m. induction m as [|m IH]; intros A Y Hm H N; [lia|].
  replace (S m) with (m + 1) in H by lia. destruct (IncN_split _ _ _ _ H) as [W [H1 H2]].
  destruct (leading_P W) as [A0 [Y0 [EW N0]]]. subst W.
  specialize (IH A0 Y0 ltac:(lia) H1 N0).
  assert (Hne : m <> D + pj J + 3 * A0) by (apply (Hmin m ltac:(lia) A0 Y0 H1 N0)).
  destruct (IncN_Ps_inv _ _ _ _ H2) as [y' [Ey _]].
  pose proof (Ps_le _ _ _ _ (eq_sym Ey) N) as Hle. lia.
Qed.

(* the zone state at an interval and its step *)
Lemma zone_at J : 1 <= J -> exists Z D Z' D', CSreach Z D J /\ cs_step Z D J Z' D' (S J) /\ CSreach Z' D' (S J).
Proof.
  intros HJ. destruct (zone_forever J HJ) as [Z [D H]]. destruct (CS_next _ _ _ H) as [Z' [D' Hs]].
  exists Z, D, Z', D'. split; [exact H|split; [exact Hs|econstructor; eauto]].
Qed.

(* ===================================================================== *)
(* 31. The cascade: one carry at the bottom of the word above a position. *)
(* ===================================================================== *)

Lemma WdR_pop w p R t : WdR w p R (uP :: t) -> WdR w (S p) R t.
Proof.
  rewrite !WdR_eq. intros [[Z [D [H1 [H2 [Z0 [D0 [A [Y [G1 [G2 [G3 [G4 [G5 E]]]]]]]]]]]]]|[H1 [H2 [u' [E H3]]]]].
  - left. exists Z, D. split; [exact H1|split; [exact H2|]].
    destruct (Ps_P_cons _ _ _ (eq_sym E) G3) as [Hn Et].
    exists Z0, D0, A, Y. split; [exact G1|]. split; [exact G2|]. split; [exact G3|]. split; [exact G4|].
    split; [lia|]. replace (44 + D0 + A - S p) with (44 + D0 + A - p - 1) by lia. exact Et.
  - right. destruct (Ps_P_cons _ _ _ (eq_sym E) (notP_wall _ _)) as [Hn Et].
    split; [exact H1|split; [lia|]]. exists u'. split; [|exact H3].
    replace (posw w R - S p) with (posw w R - p - 1) by lia. exact Et.
Qed.

Lemma bin_notP v : notP (bin v).
Proof.
  destruct v as [|v]; [exact I|]. rewrite bin_pos by lia. unfold dig. destruct (Nat.eqb _ _); exact I.
Qed.

Lemma Ps_P_cons' n y : 1 <= n -> exists t, Ps n ++ y = uP :: t.
Proof. intros H. destruct n as [|n]; [lia|]. exists (Ps n ++ y). reflexivity. Qed.

(* one carry into the zone part *)
Lemma zone_carry J m p u : ZoneR J m p u ->
  (forall Z D, CSreach Z D J -> (exists Y', IncN (S m) Z Y') /\ nofix Z D J m) ->
  exists u', Inc u u' /\ ZoneR J (S m) p u'.
Proof.
  intros [Z [D [A [Y [HR [HI [HN [Hmin [Hp Eu]]]]]]]]] HC. subst u.
  destruct (HC Z D HR) as [[Y' HY'] Hnf].
  replace (S m) with (m + 1) in HY' by lia.
  destruct (IncN_split _ _ _ _ HY') as [W [H1 H2]].
  pose proof (IncN_det _ _ _ _ H1 HI) as EW. subst W.
  destruct (IncN_Ps_inv _ _ _ _ H2) as [y1 [Ey1 Hy1]]. subst Y'.
  apply IncN_1_inv in Hy1.
  destruct (leading_P y1) as [dA [Y2 [Ey2 N2]]]. subst y1.
  exists (Ps (44 + D + (A + dA) - p) ++ Y2). split.
  - replace (Ps (44 + D + (A + dA) - p) ++ Y2) with (Ps (44 + D + A - p) ++ (Ps dA ++ Y2)).
    + apply Inc_Ps. exact Hy1.
    + rewrite Ps_add. replace (44 + D + A - p + dA) with (44 + D + (A + dA) - p) by lia. reflexivity.
  - exists Z, D, (A + dA), Y2. split; [exact HR|]. split.
    + replace (S m) with (m + 1) by lia. eapply IncN_add; [exact HI|].
      rewrite <- Ps_add. apply IncN_Ps. apply IncN_1. exact Hy1.
    + split; [exact N2|]. split.
      * intros m' Hm'. destruct (Nat.eq_dec m' m) as [->|Hne]; [exact Hnf|]. apply Hmin. lia.
      * split; [lia|reflexivity].
Qed.

Lemma Can_lt w' R0 Z D ms As Ys :
  CSreach Z D (S w') -> IncN ms Z (Ps As ++ Ys) ->
  (forall m', m' < ms -> nofix Z D (S w') m') ->
  R0 < Rab w' D + ms -> Can w' R0.
Proof.
  intros HR HI Hmin Hlt Z0 D0 H0 Hab.
  destruct (CSreach_det _ _ _ H0 _ _ HR) as [-> ->]. split.
  - apply (IncN_le ms _ _ (Ps As ++ Ys)); [lia|exact HI].
  - apply Hmin. lia.
Qed.

Lemma cs_step_min Z D j Z' D' j' : cs_step Z D j Z' D' j' ->
  exists ms As Ys, IncN ms Z (Ps As ++ Ys) /\ notP Ys /\ ms = D + pj j + 3 * As /\
    (forall m', m' < ms -> nofix Z D j m') /\ shift Ys = Some Z' /\ D' = D + As.
Proof.
  intros [ms [As [Ys [H1 [H2 [H3 [H4 [H5 [H6 _]]]]]]]]].
  exists ms, As, Ys. split; [exact H1|]. split; [exact H2|]. split; [exact H3|].
  split; [|split; [exact H5|exact H6]].
  intros m' Hm' A' Y' HI HN. exact (H4 m' A' Y' Hm' HI HN).
Qed.

Lemma fw_val w R k : R + wsb w = 2 * k + 1 -> fw w R = k.
Proof. intros H. unfold fw. rewrite H. symmetry. apply Nat.div_unique with 1%nat; lia. Qed.

Lemma cascade w : forall p R u, WdR w p R u -> Can w R -> exists u', Inc u u' /\ WdR w p (S R) u'.
Proof.
  induction w as [|w' IH]; intros p R u HW HC; apply WdR_eq in HW;
    destruct HW as [[Z [D [HR [Hab HZ]]]]|[Hlive [Hp [u' [Eu Hrest]]]]].
  - destruct (zone_carry _ _ _ _ HZ) as [u'' [Hi HZ']].
    + intros Z0 D0 HR0. destruct (CSreach_det _ _ _ HR _ _ HR0) as [<- <-]. exact (HC Z D HR Hab).
    + exists u''. split; [exact Hi|]. apply WdR_eq. left. exists Z, D. split; [exact HR|]. split; [lia|].
      replace (S R - Rab 0 D) with (S (R - Rab 0 D)) by lia. exact HZ'.
  - (* wall 0, live: its rest is the counter of interval 0 *)
    assert (Eb0 : bq 0 = 33) by reflexivity. assert (Es0 : wsb 0 = 1%nat) by reflexivity.
    pose proof (Hlive _ _ CS1) as Hl0. unfold Rab in Hl0. rewrite Eb0, Es0 in Hl0.
    destruct Hrest as [Hm0 [Hp0 Eu']]. subst u'.
    set (f := fw 0 R) in *. set (pW := posw 0 R) in *.
    assert (Hpw : pW = 33 + f) by (unfold pW, posw; rewrite Eb0; reflexivity).
    destruct (Nat.odd (R + wsb 0)) eqn:Ho.
    + destruct (proj1 (Nat.odd_spec _) Ho) as [k Hk].
      assert (Ef : f = k) by (apply fw_val; exact Hk).
      rewrite Es0 in Hk.
      assert (H3 : IncN 3 (Ps (44 - S pW) ++ bin (60 + 3 * f)) (Ps (44 - S pW) ++ bin (60 + 3 * f + 3))).
      { apply IncN_Ps. apply IncN_bin. }
      try rewrite Ho in Eu. cbn [wallu] in Eu. subst u.
      destruct (Nat.eq_dec (S R) 21) as [Eabs|Hmv].
      * assert (Ef10 : f = 10) by lia.
        assert (Ez : 44 - S pW = O) by lia. rewrite Ez in H3 |- *. cbn [Ps app] in H3 |- *.
        assert (Eb : bin (60 + 3 * f + 3) = [uD1; uD0; uD1; uD1; uD1; uD0; uD1]) by (rewrite Ef10; reflexivity).
        rewrite Eb in H3.
        exists (Ps (S pW - p) ++ [uS1; uD0; uD1; uD1; uD1; uD0; uD1]). split.
        -- replace (Ps (S pW - p) ++ [uS1; uD0; uD1; uD1; uD1; uD0; uD1])
             with (Ps (pW - p) ++ uP :: [uS1; uD0; uD1; uD1; uD1; uD0; uD1])
             by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity).
           apply Inc_Ps. eapply Inc_W3; [exact H3|reflexivity].
        -- apply WdR_eq. left. exists [uS1; uD0; uD1; uD1; uD1; uD0; uD1], O. split; [constructor|].
           split; [unfold Rab; rewrite Eb0, Es0; lia|].
           replace (S R - Rab 0 0) with O by (unfold Rab; rewrite Eb0, Es0; lia).
           exists [uS1; uD0; uD1; uD1; uD1; uD0; uD1], O, O, [uS1; uD0; uD1; uD1; uD1; uD0; uD1].
           split; [constructor|]. split; [constructor|]. split; [exact I|]. split; [intros; lia|].
           split; [lia|]. replace (44 + 0 + 0 - p) with (S pW - p) by lia. reflexivity.
      * assert (Hx : 1 <= 44 - S pW) by lia.
        destruct (Ps_P_cons' _ (bin (60 + 3 * f + 3)) Hx) as [t Et]. rewrite Et in H3.
        exists (Ps (S pW - p) ++ uSP :: t). split.
        -- replace (Ps (S pW - p) ++ uSP :: t) with (Ps (pW - p) ++ uP :: uSP :: t)
             by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity).
           apply Inc_Ps. eapply Inc_W3; [exact H3|reflexivity].
        -- apply WdR_eq. right.
           assert (Ep : posw 0 (S R) = S pW) by (unfold pW, posw; rewrite fw_odd by exact Ho; lia).
           split; [intros Z0 D0 Hc0; unfold Rab; rewrite Eb0, Es0; lia|].
           split; [rewrite Ep; lia|].
           exists t. split.
           ++ rewrite Ep, (odd_S_false _ _ Ho). reflexivity.
           ++ rewrite Ep. rewrite (fw_odd _ _ Ho). fold f.
              assert (Ht : t = Ps (44 - S pW - 1) ++ bin (60 + 3 * f + 3)).
              { destruct (Ps_P_cons _ _ _ Et (bin_notP _)) as [_ E2]. exact E2. }
              split; [lia|]. split; [lia|]. rewrite Ht.
              replace (44 - S pW - 1) with (44 - S (S pW)) by lia.
              replace (60 + 3 * S f) with (60 + 3 * f + 3) by lia. reflexivity.
    + try rewrite Ho in Eu. cbn [wallu] in Eu. subst u.
      exists (Ps (pW - p) ++ uW :: Ps (44 - S pW) ++ bin (60 + 3 * f)). split.
      * apply Inc_Ps. constructor.
      * apply WdR_eq. right.
        assert (Ep : posw 0 (S R) = pW) by (unfold pW, posw; rewrite fw_even by exact Ho; reflexivity).
        split; [intros Z0 D0 H0; apply Rab_parity; [exact Ho|exact (Hlive Z0 D0 H0)]|].
        split; [rewrite Ep; exact Hp|].
        eexists. split.
        -- rewrite Ep, (odd_S_true _ _ Ho). reflexivity.
        -- rewrite Ep, (fw_even _ _ Ho). fold f. split; [exact Hm0|]. split; [exact Hp0|]. reflexivity.
  - destruct (zone_carry _ _ _ _ HZ) as [u'' [Hi HZ']].
    + intros Z0 D0 HR0. destruct (CSreach_det _ _ _ HR _ _ HR0) as [<- <-]. exact (HC Z D HR Hab).
    + exists u''. split; [exact Hi|]. apply WdR_eq. left. exists Z, D. split; [exact HR|]. split; [lia|].
      replace (S R - Rab (S w') D) with (S (R - Rab (S w') D)) by lia. exact HZ'.
  - (* a live wall W = S w' *)
    set (W := S w') in *.
    set (pW := posw W R) in *. set (f := fw W R) in *.
    change (WdR w' (S pW) (wH w' + 3 * f) u') in Hrest.
    set (R' := wH w' + 3 * f) in *.
    destruct (Nat.odd (R + wsb W)) eqn:Ho.
    + (* W: it fires *)
      destruct (proj1 (Nat.odd_spec _) Ho) as [k Hk].
      assert (Ef : f = k) by (apply fw_val; exact Hk).
      destruct (zone_at W ltac:(unfold W; lia)) as [Z [D [Z1 [D1 [HR [Hst HR1]]]]]].
      destruct (cs_step_min _ _ _ _ _ _ Hst) as [ms [As [Ys [HIs [HNs [Ems [Hmins [Hshs ED]]]]]]]].
      pose proof (Hlive Z1 D1 HR1) as HlR.
      pose proof (bracket_nat w') as Hbr. fold W in Hbr.
      pose proof (bq_le W). pose proof (bq_le w'). pose proof (wsb_le W). pose proof (wsb_le w').
      assert (Hpw : pW = bq W + f) by reflexivity.
      unfold Rab in HlR.
      assert (Hkey : ms + Rab w' D = R' + 3 * (44 + D1 - bq W - f)) by (unfold Rab, R'; lia).
      assert (Hf1 : f + 1 <= 44 + D1 - bq W) by lia.
      destruct (IH _ _ _ Hrest (Can_lt w' R' Z D ms As Ys HR HIs Hmins ltac:(lia))) as [u1 [Hi1 HW1]].
      destruct (IH _ _ _ HW1 (Can_lt w' (S R') Z D ms As Ys HR HIs Hmins ltac:(lia))) as [u2 [Hi2 HW2]].
      destruct (IH _ _ _ HW2 (Can_lt w' (S (S R')) Z D ms As Ys HR HIs Hmins ltac:(lia))) as [u3 [Hi3 HW3]].
      assert (HW3' := HW3). apply WdR_eq in HW3'.
      try rewrite Ho in Eu. cbn [wallu] in Eu. subst u.
      destruct (Nat.eq_dec (S R) (2 * (44 + D1 - bq W) - wsb W)) as [Eabs|Hmv].
      * (* the absorbing firing *)
        assert (Hm3 : S (S (S R')) - Rab w' D = ms) by (unfold Rab in *; lia).
        destruct HW3' as [[Z3 [D3 [HR3 [Hab3 [Z4 [D4 [A4 [Y4 [G1 [G2 [G3 [G4 [G5 E4]]]]]]]]]]]]]|[Hl3 _]].
        2:{ exfalso. specialize (Hl3 Z D HR). unfold Rab in *. lia. }
        destruct (CSreach_det _ _ _ HR3 _ _ HR) as [-> ->].
        destruct (CSreach_det _ _ _ G1 _ _ HR) as [-> ->].
        rewrite Hm3 in G2. pose proof (IncN_det _ _ _ _ G2 HIs) as EI.
        destruct (Ps_notP_inj _ _ _ _ EI G3 HNs) as [-> ->].
        assert (Ez : 44 + D + As - S pW = O) by lia. rewrite Ez in E4. cbn [Ps app] in E4. subst u3.
        exists (Ps (S pW - p) ++ Z1). split.
        -- replace (Ps (S pW - p) ++ Z1) with (Ps (pW - p) ++ uP :: Z1)
             by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity).
           apply Inc_Ps. eapply Inc_W; [exact Hi1|exact Hi2|exact Hi3|exact Hshs].
        -- apply WdR_eq. left. exists Z1, D1. split; [exact HR1|]. split; [unfold Rab; lia|].
           replace (S R - Rab W D1) with O by (unfold Rab; lia).
           exists Z1, D1, O, Z1. split; [exact HR1|]. split; [constructor|].
           split; [exact (shift_notP _ _ HNs Hshs)|]. split; [intros; lia|].
           split; [lia|]. replace (44 + D1 + 0 - p) with (S pW - p) by lia. reflexivity.
      * (* the wall moves up *)
        assert (Hmv' : S R < 2 * (44 + D1 - bq W) - wsb W) by lia.
        assert (Hf2 : f + 2 <= 44 + D1 - bq W) by lia.
        assert (Ht : exists t, u3 = uP :: t).
        { destruct HW3' as [[Z3 [D3 [HR3 [Hab3 [Z4 [D4 [A4 [Y4 [G1 [G2 [G3 [G4 [G5 E4]]]]]]]]]]]]]|[Hl3 [Hp3 [u4 [E4 _]]]]].
          - destruct (CSreach_det _ _ _ HR3 _ _ HR) as [-> ->].
            destruct (CSreach_det _ _ _ G1 _ _ HR) as [-> ->].
            set (m3 := S (S (S R')) - Rab w' D) in *.
            assert (Hm3 : m3 < ms) by (unfold m3, Rab in *; lia).
            pose proof (below Z D W ms As Ys HIs HNs Hmins m3 A4 Y4 ltac:(lia) G2 G3) as Hb.
            pose proof (Hmins m3 Hm3 A4 Y4 G2 G3) as Hn.
            assert (Hx : 1 <= 44 + D + A4 - S pW) by (unfold m3, Rab in *; lia).
            destruct (Ps_P_cons' (44 + D + A4 - S pW) Y4 Hx) as [t Et]. exists t. rewrite E4. exact Et.
          - assert (Hlv : forall Z0 D0, CSreach Z0 D0 (S w') -> R' < Rab w' D0).
            { intros Z0 D0 Hc0. specialize (Hl3 Z0 D0 Hc0). lia. }
            apply WdR_eq in Hrest.
            destruct Hrest as [[Z5 [D5 [HR5 [Hab5 _]]]]|[_ [Hp5 _]]].
            + exfalso. specialize (Hlv Z5 D5 HR5). lia.
            + pose proof (fw_add3 w' R'). unfold posw in Hp5, E4.
              assert (Hx : 1 <= bq w' + fw w' (S (S (S R'))) - S pW).
              { replace (S (S (S R'))) with (R' + 3) by lia. lia. }
              destruct (Ps_P_cons' _ (wallu (Nat.odd (S (S (S R')) + wsb w')) :: u4) Hx) as [t Et]. exists t. rewrite E4. exact Et. }
        destruct Ht as [t Et]. subst u3.
        exists (Ps (S pW - p) ++ uSP :: t). split.
        -- replace (Ps (S pW - p) ++ uSP :: t) with (Ps (pW - p) ++ uP :: uSP :: t)
             by (rewrite Ps_snoc; replace (S (pW - p)) with (S pW - p) by lia; reflexivity).
           apply Inc_Ps. eapply Inc_W; [exact Hi1|exact Hi2|exact Hi3|reflexivity].
        -- apply WdR_eq. right.
           assert (Ep : posw W (S R) = S pW) by (unfold pW, posw; rewrite fw_odd by exact Ho; lia).
           split; [intros Z0 D0 Hc0; destruct (CSreach_det _ _ _ Hc0 _ _ HR1) as [-> ->]; unfold Rab; lia|].
           split; [rewrite Ep; lia|].
           exists t. split.
           ++ rewrite Ep, (odd_S_false _ _ Ho). reflexivity.
           ++ change (WdR w' (S (posw W (S R))) (wH w' + 3 * fw W (S R)) t).
              rewrite Ep. rewrite (fw_odd _ _ Ho). fold f.
              replace (wH w' + 3 * S f) with (S (S (S R'))) by (unfold R'; lia).
              apply WdR_pop. exact HW3.
    + (* SP: it becomes W *)
      try rewrite Ho in Eu. cbn [wallu] in Eu. subst u.
      exists (Ps (pW - p) ++ uW :: u'). split.
      * apply Inc_Ps. constructor.
      * apply WdR_eq. right.
        assert (Ep : posw W (S R) = pW) by (unfold pW, posw; rewrite fw_even by exact Ho; reflexivity).
        split; [intros Z0 D0 H0; apply Rab_parity; [exact Ho|exact (Hlive Z0 D0 H0)]|].
        split; [rewrite Ep; exact Hp|].
        exists u'. split.
        -- rewrite Ep, (odd_S_true _ _ Ho). reflexivity.
        -- change (WdR w' (S (posw W (S R))) (wH w' + 3 * fw W (S R)) u').
           rewrite Ep, (fw_even _ _ Ho). exact Hrest.
Qed.

(* ===================================================================== *)
(* 32. The record invariant (proof.md 7) and AbsDefined.                 *)
(* ===================================================================== *)

Lemma cascadeN w p R u t : WdR w p R u -> (forall i, i < t -> Can w (R + i)) ->
  exists u', IncN t u u' /\ WdR w p (R + t) u'.
Proof.
  revert R u. induction t as [|t IH]; intros R u H HC.
  - exists u. split; [constructor|]. rewrite Nat.add_0_r. exact H.
  - destruct (cascade w p R u H) as [u1 [Hi H1]]; [rewrite <- (Nat.add_0_r R); apply HC; lia|].
    destruct (IH (S R) u1 H1) as [u2 [Hn H2]].
    { intros i Hi'. replace (S R + i) with (R + S i) by lia. apply HC. lia. }
    exists u2. split; [econstructor; eauto|]. replace (R + S t) with (S R + t) by lia. exact H2.
Qed.

Lemma live_small w R : R < 2 * (44 - bq w) - wsb w -> forall Z D, CSreach Z D (S w) -> R < Rab w D.
Proof. intros H Z D _. unfold Rab. pose proof (bq_le w). lia. Qed.

Lemma Can_live w R : R < 2 * (44 - bq w) - wsb w -> Can w R.
Proof. intros H Z D HR Hab. pose proof (live_small w R H Z D HR). lia. Qed.

Lemma Pops_bottom Y k b R u : WdR Y b R u -> R + 3 * k < 2 * (44 - bq Y) - wsb Y ->
  exists u', Pops k u u' /\ WdR Y (b + k) (R + 3 * k) u'.
Proof.
  revert b R u. induction k as [|k IH]; intros b R u H Hl.
  - exists u. split; [reflexivity|]. rewrite !Nat.add_0_r. exact H.
  - destruct (cascadeN Y b R u 3 H) as [u3 [H3 HW3]].
    { intros i Hi. apply Can_live. lia. }
    assert (Ht : exists t, u3 = uP :: t).
    { assert (HW3' := HW3). apply WdR_eq in HW3'.
      destruct HW3' as [[Z [D [HR [Hab _]]]]|[_ [Hp [u4 [E4 _]]]]].
      - exfalso. unfold Rab in Hab. pose proof (bq_le Y). lia.
      - assert (H' := H). apply WdR_eq in H'. destruct H' as [[Z [D [HR [Hab _]]]]|[_ [Hp0 _]]].
        + exfalso. unfold Rab in Hab. pose proof (bq_le Y). lia.
        + pose proof (fw_add3 Y R). unfold posw in Hp0, E4.
          destruct (Ps_P_cons' (bq Y + fw Y (R + 3) - b) (wallu (Nat.odd (R + 3 + wsb Y)) :: u4)) as [t Et]; [lia|].
          exists t. rewrite E4. exact Et. }
    destruct Ht as [t Et]. subst u3.
    destruct (IH (S b) (R + 3) t (WdR_pop _ _ _ _ HW3)) as [u' [Hp Hw]]; [lia|].
    exists u'. split.
    + exists t. split; [apply Inc3Pop_of; exact H3|exact Hp].
    + replace (b + S k) with (S b + k) by lia. replace (R + 3 * S k) with (R + 3 + 3 * k) by lia. exact Hw.
Qed.

Lemma WdR_push w p q R0 u bqv sv : WdR w q R0 u -> R0 = wH w -> bq (S w) = bqv -> wsb (S w) = sv ->
  sv <= 1 -> p <= bqv -> S bqv = q -> 0 < 2 * (44 - bqv) - sv ->
  WdR (S w) p 0 (Ps (bqv - p) ++ wallu (Nat.odd sv) :: u).
Proof.
  intros H HR0 Hb Hs Hsv Hp Hq Hl.
  assert (E0 : fw (S w) 0 = O) by (unfold fw; rewrite Hs; apply Nat.div_small; lia).
  assert (Ep : posw (S w) 0 = bqv) by (unfold posw; rewrite E0, Hb; lia).
  apply WdR_eq. right. split; [apply live_small; rewrite Hb, Hs; exact Hl|]. split; [rewrite Ep; exact Hp|].
  exists u. split; [rewrite Ep, Hs; reflexivity|].
  change (WdR w (S (posw (S w) 0)) (wH w + 3 * fw (S w) 0) u).
  rewrite E0, Ep, Nat.mul_0_r, Nat.add_0_r, Hq, <- HR0. exact H.
Qed.

Lemma wdata5 w : 5 <= w ->
  wb w = nth ((w + 2) mod 8) phb 0%Z /\ wsb w = nth ((w + 2) mod 8) phs O /\ wH w = nth ((w + 2) mod 8) phH O.
Proof.
  intros Hw. destruct (Nat.eq_dec w 5) as [->|Hne]; [split; [reflexivity|split; reflexivity]|].
  unfold wb, wsb, wH. destruct (Nat.ltb_spec w 6) as [|_]; [lia|].
  replace ((w + 2) mod 8) with ((w - 6) mod 8); [auto|].
  replace (w + 2) with ((w - 6) + 1 * 8) by lia. rewrite Nat.Div0.mod_add. reflexivity.
Qed.

Lemma wd w r : 5 <= w -> (w + 2) mod 8 = r ->
  bq w = Z.to_nat (nth r phb 0%Z + 1) /\ wsb w = nth r phs O /\ wH w = nth r phH O.
Proof.
  intros Hw Hr. destruct (wdata5 w Hw) as [E1 [E2 E3]]. rewrite Hr in E1, E2, E3.
  split; [unfold bq; rewrite E1; reflexivity|split; assumption].
Qed.

Lemma mod8_S w r : (w + 2) mod 8 = r -> (S w + 2) mod 8 = (S r) mod 8.
Proof.
  intros H. subst r. replace (S w + 2) with ((w + 2) + 1) by lia.
  replace (S ((w + 2) mod 8)) with ((w + 2) mod 8 + 1) by lia.
  rewrite Nat.Div0.add_mod_idemp_l. reflexivity.
Qed.

Lemma mod8_S' w r r' : (w + 2) mod 8 = r -> S r mod 8 = r' -> (S w + 2) mod 8 = r'.
Proof. intros H1 H2. rewrite (mod8_S _ _ H1). exact H2. Qed.

Definition rbase (t : rt) : nat := match t with YC | YD | YE => O | _ => 1%nat end.
Definition rph (t : rt) : nat := match t with XC | XD | XE => 7%nat | YC | YD | YE => 2%nat | _ => 6%nat end.

Definition RInv (t : rt) (U : list unt) : Prop :=
  exists Y, 5 <= Y /\ (Y + 2) mod 8 = rph t /\ WdR Y (rbase t) 0 U.

Lemma bq_small w : 5 <= w -> bq w <= 12.
Proof.
  intros Hw. destruct (wdata5 w Hw) as [E _]. pose proof (bq_spec w) as H. rewrite E in H.
  assert (Hb : forall i, (nth i phb 0%Z <= 10)%Z) by (intros i; do 8 (destruct i as [|i]; [cbn; lia|]); destruct i; cbn; lia).
  specialize (Hb ((w + 2) mod 8)). lia.
Qed.

Lemma RInv_step t U : RInv t U -> exists U', Pops (rk t) U U' /\ RInv (rnext t) (rF t ++ U').
Proof.
  intros [Y [HY [Hph HW]]].
  pose proof (bq_small Y HY) as Hbq. pose proof (wsb_le Y) as Hsy.
  destruct t; cbn [rk rF rnext rbase rph app] in *;
    try (exists U; split; [reflexivity|exists Y; split; [exact HY|split; [exact Hph|exact HW]]]).
  - (* XE: 3 pops, then W W P SP *)
    destruct (Pops_bottom Y 3 1 0 U HW) as [U' [HP HW']]; [lia|]. change (WdR Y 4 9 U') in HW'.
    exists U'. split; [exact HP|].
    destruct (wd Y 7 HY Hph) as [_ [_ HH0]]. cbn in HH0.
    pose proof (mod8_S' _ _ 0 Hph eq_refl) as P1.
    destruct (wd (S Y) 0 ltac:(lia) P1) as [B1 [S1' H1']]. cbn in B1, S1', H1'.
    pose proof (mod8_S' _ _ 1 P1 eq_refl) as P2.
    destruct (wd (S (S Y)) 1 ltac:(lia) P2) as [B2 [S2' H2']]. cbn in B2, S2', H2'.
    pose proof (mod8_S' _ _ 2 P2 eq_refl) as P3.
    destruct (wd (S (S (S Y))) 2 ltac:(lia) P3) as [B3 [S3' _]]. cbn in B3, S3'.
    pose proof (WdR_push Y 2 4 9 U' 3 0 HW' (eq_sym HH0) B1 S1' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1.
    pose proof (WdR_push (S Y) 1 2 0 _ 1 1 W1 (eq_sym H1') B2 S2' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W2.
    pose proof (WdR_push (S (S Y)) 0 1 0 _ 0 1 W2 (eq_sym H2') B3 S3' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W3.
    exists (S (S (S Y))). split; [lia|]. split; [exact P3|]. exact W3.
  - (* YE: 12 pops, then W P W P P SP P P P P SP *)
    destruct (Pops_bottom Y 12 0 0 U HW) as [U' [HP HW']]; [lia|]. change (WdR Y 12 36 U') in HW'.
    exists U'. split; [exact HP|].
    destruct (wd Y 2 HY Hph) as [_ [_ HH0]]. cbn in HH0.
    pose proof (mod8_S' _ _ 3 Hph eq_refl) as P1.
    destruct (wd (S Y) 3 ltac:(lia) P1) as [B1 [S1' H1']]. cbn in B1, S1', H1'.
    pose proof (mod8_S' _ _ 4 P1 eq_refl) as P2.
    destruct (wd (S (S Y)) 4 ltac:(lia) P2) as [B2 [S2' H2']]. cbn in B2, S2', H2'.
    pose proof (mod8_S' _ _ 5 P2 eq_refl) as P3.
    destruct (wd (S (S (S Y))) 5 ltac:(lia) P3) as [B3 [S3' H3']]. cbn in B3, S3', H3'.
    pose proof (mod8_S' _ _ 6 P3 eq_refl) as P4.
    destruct (wd (S (S (S (S Y)))) 6 ltac:(lia) P4) as [B4 [S4' _]]. cbn in B4, S4'.
    pose proof (WdR_push Y 7 12 36 U' 11 0 HW' (eq_sym HH0) B1 S1' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1.
    pose proof (WdR_push (S Y) 4 7 0 _ 6 0 W1 (eq_sym H1') B2 S2' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W2.
    pose proof (WdR_push (S (S Y)) 2 4 0 _ 3 1 W2 (eq_sym H2') B3 S3' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W3.
    pose proof (WdR_push (S (S (S Y))) 1 2 0 _ 1 1 W3 (eq_sym H3') B4 S4' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W4.
    exists (S (S (S (S Y)))). split; [lia|]. split; [exact P4|]. exact W4.
  - (* ZE: 2 pops, then P SP *)
    destruct (Pops_bottom Y 2 1 0 U HW) as [U' [HP HW']]; [lia|]. change (WdR Y 3 6 U') in HW'.
    exists U'. split; [exact HP|].
    destruct (wd Y 6 HY Hph) as [_ [_ HH0]]. cbn in HH0.
    pose proof (mod8_S' _ _ 7 Hph eq_refl) as P1.
    destruct (wd (S Y) 7 ltac:(lia) P1) as [B1 [S1' _]]. cbn in B1, S1'.
    pose proof (WdR_push Y 1 3 6 U' 2 0 HW' (eq_sym HH0) B1 S1' ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1.
    exists (S Y). split; [lia|]. split; [exact P1|]. exact W1.
Qed.

Lemma RInv_U0 : RInv XC U0.
Proof.
  exists 5. split; [lia|]. split; [reflexivity|].
  assert (W0 : WdR 0 22 0 (Ps 11 ++ uW :: Ps 10 ++ bin 60)).
  { apply WdR_eq. right. split; [apply live_small; vm_compute; lia|].
    split; [vm_compute; lia|]. exists (Ps 10 ++ bin 60). split; [reflexivity|].
    split; [vm_compute; lia|]. split; [vm_compute; lia|]. reflexivity. }
  pose proof (WdR_push 0 14 22 0 _ 21 1 W0 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W1.
  pose proof (WdR_push 1 9 14 0 _ 13 1 W1 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W2.
  pose proof (WdR_push 2 5 9 0 _ 8 0 W2 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W3.
  pose proof (WdR_push 3 3 5 0 _ 4 1 W3 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W4.
  pose proof (WdR_push 4 1 3 0 _ 2 0 W4 eq_refl eq_refl eq_refl ltac:(lia) ltac:(lia) eq_refl ltac:(lia)) as W5.
  exact W5.
Qed.

Lemma Pops_det k U U1 U2 : Pops k U U1 -> Pops k U U2 -> U1 = U2.
Proof.
  revert U; induction k as [|k IH]; intros U H1 H2; cbn in H1, H2.
  - congruence.
  - destruct H1 as [V1 [[a1 [b1 [Ha1 [Hb1 Hc1]]]] H1]]. destruct H2 as [V2 [[a2 [b2 [Ha2 [Hb2 Hc2]]]] H2]].
    assert (a1 = a2) by (eapply Inc_det; eauto). subst a2.
    assert (b1 = b2) by (eapply Inc_det; eauto). subst b2.
    assert (E : uP :: V1 = uP :: V2) by (eapply Inc_det; eauto). injection E as ->.
    eapply IH; eauto.
Qed.

Lemma Reach_RInv t U : Reach t U -> RInv t U.
Proof.
  induction 1 as [|t U U' HR IH HP].
  - exact RInv_U0.
  - destruct (RInv_step t U IH) as [U'' [HP' HI]].
    rewrite (Pops_det _ _ _ _ HP HP'). exact HI.
Qed.

Theorem AbsDefined_proof : AbsDefined.
Proof.
  intros t U HR. destruct (RInv_step t U (Reach_RInv t U HR)) as [U' [HP _]]. eauto.
Qed.

Lemma nonhalt: ~halts tm c0.
Proof. apply nonhalt_of_abs, AbsDefined_proof. Qed.

(*
```
1RB---_1LC1RE_1LD0LC_1LE1LC_1RF0RE_1RA0RB

     0    1
A   1RB  ---
B   1LC  1RE
C   1LD  0LC
D   1LE  1LC
E   1RF  0RE
F   1RA  0RB

units: D0 = 0000, D1 = 1000, P = 11000, S1 = 01000, SP = 011000, W = 111000

arrival (one carry), for every left context l:
  l B> w 0^inf  -->*  l <C w' 0^inf          when Inc w w'
  Z    B> 0 x        --> <C 1 x                     (D0 -> D1, S1 -> P, SP -> W, blank -> D1)
  D1   B> 1000 r     --> 1111 B> r ~> 1111 <C r' --> <C 0000 r'
  P    B> 11000 r    --> 10111 B> r ~> 10111 <C r' --> <C 11000 r'
  W    B> 111000 r   --> 100111 B> r ~> --> 000111 B> r1 ~> --> 101111 B> r2 ~>
                     --> <C 110000 r3              (W r --> P shift(inc^3 r))

left records 0^inf <q G U 0^inf, q G (8 types, cycle XC XD XE YC YD YE ZD ZE):
  XC C 111111 0000 11 0000 11 000    XD D 1111111 0000 11 0000 11 000
  XE E 11111111 0000 11 0000 11 000  (3 W uses, F = W W P SP)
  YC C 1101111 0000 11 000           YD D 11101111 0000 11 000
  YE E 111101111 0000 11 000         (12 W uses, F = W P W P P SP P P P P SP)
  ZD D 11111 0000 11 000 111 000     ZE E 111111 0000 11 000 111 000  (2 W uses, F = P SP)
  window: q G U  -->+  q' G' F Phi_k(U),   Phi = pop o inc^3

c0 -->* XC record with U0 = P SP P W P^3 SP P^4 W P^7 W P^11 W P^10 D0 D0 D1^4   (203,465 steps)

closed zone system (Z, D, j): feed D + p(j mod 8) carries, p = 47 48 48 47 48 47 48 47,
  drop leading P (+3 carries each), stop at the least fixed point, absorption shift;
  from Z1 = S1 D0 D1 D1 D1 D0 D1, D = 0, j = 1 it reaches C(0) = S1 D0 D1^5, D = 16, j = 17.
  canonical states C(b) = S1 D0 D1^4 bin(b+1), D = 32b + 16, j = 32b + 17.

zone engine (cut: X below, Y above; every shift lands in X):
  XN t X e X'    t carries on X ++ Y give X' ++ Y' whenever e carries on Y give Y'
  cutstep        the first T0 carries act on X alone (all drops happen there),
                 the rest is counter arithmetic on X, the absorption shift lands in X
  family         (X, y, ay, D, j, aD) stands for zone X ++ bin(y + ay u),
                 D + aD u, j + aD u, for every u >= 0; one run covers every u

proved by family runs (vm_compute):
  small classes  nu2(b+2) = k <= 40: 327 direct runs + 328 families (o mod 16)
  endgame        value form at off_end(k), nu2(k+9) <= 10, every U >= 1:
                 4,094 families (k mod 2^12), cut 12
  nested range   value form at off_end(k), k + 9 = s 2^v, 11 <= v <= 50:
                 80 families (s mod 4), cut v + 2

value forms VF(k, Om, off): digits of mu Om + w(off) - 3 2^(L-1), heads below digit 3,
  marker P at digit L = k + lam - off; j = Om - 64 + off, D = j - d
  descent step   VF(off) --> VF(off + 1) for every Om = 0 mod 256, c >= 4096, L >= 5:
                 the first 4096 carries on the low 8 digits, then counter arithmetic on
                 residues; classes: 12 entry offsets (level 1, off 20..31) and
                 off mod 256 x (L = 5, 6, 7, 8 or L >= 9) on the phase table
  VF1            level 1, k >= 41: VF(k, o 2^(k+5), 20) -->* VF at off_end(k)
  VF2            level 2, v >= 12, S >= 2: VF(v - 10, S 2^v, 17) -->* VF at off_end(v - 10)

entry (b + 2 = (2q+1) 2^k, k >= 41) and plant (n = v - 3, S = 2Q + 1), by hand:
  off 17  S1 D0 D1^(k+4) D0 bin(q)          off' 12  S1 P P D0 D0 D0 P [2^n-3]_n bin(2Q)
  off 18  D0^(k+6) S1 bin(q)                off' 13  D0 D0 D0 SP [2^n-3]_n bin(4Q+1)
  off 19  S1 D0^(k+4) D1 s1w(q)             off' 14  D0 S1 D0 P [2^n-3]_n D0 P bin(2Q-1)
  off 20  D0 S1 D0^(k+2) D1 P bin(4q)       off' 15  S1 P D0 P [2^n-5]_n D0 P bin(4Q)
                                            off' 16  S1 P [2^n-6]_n D0 P bin(8Q+2)
                                            off' 17  S1 [2^(n-1)-3]_(n-1) D0 P bin(16Q+6)
  E(K): nu2(K+9) <= 50 by family runs; otherwise plant, VF2 and E(nu2(K+9) - 10)

conveyor (positions in the U0 frame + 1, wall w: birth index b_w, state s_w, H_w):
  wall w after R carries: position b_w + (R + s_w)/2, W iff R + s_w odd,
  the wall above it has received H_w' + 3 (R + s_w)/2 carries
  Lemma T  p(J mod 8) = 43 - 3 b_J + 2 b_(J-1) + s_(J-1) + H_(J-1)
  top wall absorbed  <=>  zone count reaches the least fixed point of the closed system
  record   pops through the youngest wall, then the new walls F with R = 0
```
*)