Section Reduction.
Variable P : CM.Cm1.
Variable capped_P : Forall (fun '(_, n) => n < 4) P.
Definition iP : list (CM.State * (CM.State * nat)) := combine (seq 0 (length P)) P.
Definition gotos : list (nat * BasicState * BasicState) :=
(* goto n #+i #-i *)
map (fun '(i, (j, n)) => (n, #+i, #-i)) iP ++
(* goto #?(i+1)*)
map (fun '(i, (j, n)) => (0, #?(1+(i:CM.State)), #?(1+(i:CM.State)))) iP ++
(* goto $?i*)
map (fun '(i, (j, n)) => (0, $?i, $?i)) iP ++
(* goto $+i*)
map (fun '(i, (j, n)) => (0, $+i, $+i)) iP ++
(* goto $-i*)
map (fun '(i, (j, n)) => (0, $-i, $-i)) iP ++
(* goto +| *)
[(0, +|, +|)].
Definition igotos : list (nat * (CM.State * BasicState * BasicState)) :=
combine (seq 0 (length gotos)) gotos.
(* space required to remember a goto operation *)
Definition G := length gotos + 4.
Local Definition SMX := SM.SMX (State := State) (Symbol := Symbol).
Local Definition Instruction := SM.Instruction (State := State) (Symbol := Symbol).
Local Definition Config := SM.Config (State := State) (Symbol := Symbol).
(* 1{?i}0 => 1{M n +i -i}0} : check divisibility by n+1*)
Definition index_try_spec : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([§1], [§0], '#?i), ([§1], [§0], goto n (#+i) (#-i)), false)).
(* {-i} -> {M 0 ?i+1 ?i+1} : next index on failure *)
Definition index_no_spec : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([], [§0], '#-i), ([], [§0], goto 0 (#? (1+i)) (#? (1+i))), false)).
(* r{+i}1l f-> l1{?j}r : next index on success *)
Definition index_yes_spec_1 : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([], [§1], '#+i), ([], [§1], ('#? j)), true)).
(* r{+i}0^(n+1)l f-> l1{M 0 ?Ii ?Ii}0^nr : step by n+1, increase by 1*)
Definition index_yes_spec_n1 : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([], repeat §0 (1+n), '#+i), (repeat §0 n, [§1], goto 0 ($?i) ($?i)), true)).
(* 01{?Ii} -> 1{M 0 +Ii +Ii}0 : increase success *)
Definition increase_try_spec_0 : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([§1] ++ [§0], [], '$?i), ([§1], [§0], goto 0 ($+i) ($+i)), false)).
(* 11{?Ii} -> 1{M 0 -Ii -Ii}0 : increase failure*)
Definition increase_try_spec_1 : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([§1] ++ [§1], [], '$?i), ([§1], [§0], goto 0 ($-i) ($-i)), false)).
(* l1{+Ii}r f-> r0{+i}l : report increase successful, continue *)
Definition increase_yes_spec : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([§1], [], '$+i), ([], [§0], '#+i), true)).
(* l1{-Ii}r f-> r0{M 0 +B +B}l : report increase failed, bound found *)
Definition increase_no_spec : nat * (CM.State * nat) -> Instruction :=
(fun '(i, (j, n)) => (([§1], [], '$-i), ([], [§0], goto 0 +| +|), true)).
(* l{M n X Y}0^Gr -> l0^(G-2-i)10^i1{?B}r *)
Definition goto_spec_G : _ -> Instruction :=
(fun '(i, (n, X, Y)) => (([], §0^G, goto n X Y), ([§1] ++ §0^i ++ [§1] ++ §0^(G-2-i), [], '?|), true)).
(* l{M n X Y}0^m 1r f-> r1{X/Y}0^ml *)
Definition goto_spec_1 : nat -> (nat * (nat * BasicState * BasicState)) -> Instruction :=
(fun m '(i, (n, X, Y)) =>
(([], §0^m ++ [§1], goto n X Y), (§0^m, [§1], basic_state (if m mod (n+1) is 0 then X else Y)), true)).
(* l0^(G-2-i)10^i1{+B}r -> 0^(n+1){M n X Y}0*)
Definition bound_yes_spec : _ -> Instruction :=
(fun '(i, (n, X, Y)) => (([§1] ++ §0^i ++ [§1] ++ §0^(G-2-i), [], '+|), (§0^(n+1), §0^(G-(n+1)), goto n X Y), false)).
(* 1{?B}1 -> 1{+B}1 *)
Definition bound_try_spec_1 : Instruction :=
(([§1], [§1], '?|), ([§1], [§1], '+|), true).
(* 1{?B}01 -> 1{+B}01 *)
Definition bound_try_spec_01 : Instruction :=
(([§0] ++ [§1], [§1], '?|), ([§0] ++ [§1], [§1], '+|), true).
(* 1{?B}00 -> 1{?0}01 *)
Definition bound_try_spec_00 : Instruction :=
(([§0] ++ [§0], [§1], '?|), ([§0] ++ [§1], [§1], '#?0), true).
Definition bound_try_spec : list Instruction :=
[bound_try_spec_1] ++ [bound_try_spec_01] ++ [bound_try_spec_00].
Definition index_ops : list Instruction :=
map index_try_spec iP ++ map index_no_spec iP ++ map index_yes_spec_1 iP ++ map index_yes_spec_n1 iP.
Definition increase_ops : list Instruction :=
map increase_try_spec_0 iP ++ map increase_try_spec_1 iP ++ map increase_yes_spec iP ++ map increase_no_spec iP.
Definition goto_ops : list Instruction :=
map goto_spec_G igotos ++ flat_map (fun m => map (goto_spec_1 m) igotos) (seq 0 G).
Definition bound_ops : list Instruction :=
map bound_yes_spec igotos ++ bound_try_spec.
(* stack machine instuctions *)
Definition M : SMX :=
locked index_ops ++ locked increase_ops ++ locked goto_ops ++ locked bound_ops.
Local Definition reachable_n := reachable_n M.
(* identifies matching iP instructions *)
Ltac unify_iP :=
match goal with H1 : In (?i, (?j1, ?n1)) iP, H2 : In (?i, (?j2, ?n2)) iP |- _ =>
have [? ?]:= in_iP_unique H1 H2; subst; clear H1 H2
end.
(* identifies matching igotos instructions *)
Ltac unify_igotos :=
match goal with
| H1 : In (?i, (?n1, ?X1, ?Y1)) igotos, H2 : In (?i, (?n2, ?X2, ?Y2)) igotos |- _ =>
have [? [? ?]] := in_igotos_unique H1 H2; subst; clear H1 H2
| H1 : In (?i1, (?n, ?X, ?Y)) igotos, H2 : In (?i2, (?n, ?X, ?Y)) igotos |- _ =>
have ? := in_igotos_unique_index H1 H2; subst; clear H1 H2
end.
(* simplifies app equalities *)
Ltac unify_app :=
match goal with
| H : ?l ++ ?l1 = ?l ++ ?l2 |- _ =>
move /app_inv_head in H; subst
| H : ?a :: ?l1 = ?a :: ?l2 |- _ =>
(have ? : l1 = l2 by congruence); subst; clear H
| H : §0^?n ++ (§1 :: ?v1) = §0^?m ++ (§1 :: ?v2) |- _ =>
have ? := zero_prefix_eq H; subst
| H1 : §0^G ++ ?v1 = §0^?n ++ (§1 :: ?v2), H2 : ?n < G |- _ =>
have ? := contradict_G_prefix H1 H2; clear H1 H2
| H1 : §0^?n ++ (§1 :: ?v2) = §0^G ++ ?v1, H2 : ?n < G |- _ =>
have ? := contradict_G_prefix (esym H1) H2; clear H1 H2
end.
(* starting CM1 configuration *)
Definition cm_start : CM.Config := {| CM.state := 0; CM.value := 1 |}.
(* successful bound search up to space C *)
Definition bound_reachable_n (C N: nat) : Prop :=
forall m l r, m <= C ->
reachable_n N (repeat §0 m ++ [§1] ++ r, [§1] ++ l, '?|) ([§1] ++ l, repeat §0 m ++ [§1] ++ r, '+|).
Definition goto_time (C N: nat) := (C+1)*(N+3).

(* goto 1 and switch to X/Y depending on c mod (n+1) *)
(* C is inductive argument for external bound lemma *)
Lemma first_goto_1 {C N: nat} : bound_reachable_n C N ->
forall (T: nat) (l r: list Symbol) T' n X Y c Z, In (n, X, Y) gotos -> (c - G) <= C -> T + goto_time C N <= T' ->
reachable_n T ([§1] ++ r, §0^c ++ l, basic_state (if c mod (n+1) is 0 then X else Y)) Z ->
reachable_n T' (l, §0^c ++ [§1] ++ r, goto n X Y) Z.