(** * Skelet #1 *)
(** Following https://www.sligocki.com/2023/03/13/skelet-1-infinite.html *)
Set Warnings "-abstract-large-number".
Set Default Goal Selector "!".
Definition tm : TM := fun '(q, s) =>
match q, s with
| A, 0 => Some (1, R, B)  | A, 1 => Some (1, R, D)
| B, 0 => Some (1, L, C)  | B, 1 => Some (0, R, C)
| C, 0 => Some (1, R, A)  | C, 1 => Some (1, L, D)
| D, 0 => Some (0, R, E)  | D, 1 => Some (0, L, B)
| E, 0 => None            | E, 1 => Some (1, R, C)
end.
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).
Notation "l <| r" := (l <{{C}} 1 >> 0 >> r)  (at level 30).
Notation "l |> r" := (l {{A}}> r)  (at level 30).
Fixpoint run (n : nat) :=
match n with
| O => [0]
| S n => run n <: 1
end.
Definition x  := run 2 <+ run 2.
Definition Dl := run 2 <+ run 1.
Definition Dr := run 2 +> run 1.
Definition C0 := run 2 <+ run 3 <+ run 2.
Definition C1 := run 2 <+ run 0 <+ run 1.
Definition C2 := run 4 <+ run 2.
Definition C3 := run 1 <+ run 1.
Notation C := C3.
Definition R := const 0.
Definition L := const 0.
Definition P  := run 2.
Definition F0 := run 4 <+ run 3 <+ run 2.
Definition F1 := run 4 <+ run 0 <+ run 1.
Definition F2 := run 6 <+ run 2.
Definition F3 := run 3 <+ run 1.
Definition G0 := run 2 <+ run 3 <+ run 3 <+ run 2.
Definition G1 := run 2 <+ run 3 <+ run 0 <+ run 1.
Definition G2 := run 2 <+ run 5 <+ run 2.
Definition Fl := C2 <+ x^^7640 <+ Dl <+ x^^10344.
Definition Gl :=
x^^300 <+ Dl <+ x^^30826 <+ Dl <+ x^^72142 <+ Dl <+
x^^3076 <+ Dl <+ x^^1538 <+ Dl.
Definition Gr :=
x^^300 +> Dr +> x^^30826 +> Dr +> x^^72142 +> Dr +>
x^^3076 +> Dr +> x^^1538 +> Dr.
Definition Hl :=
C1 <+ Dl <+ x^^299 <+ C1 <+ Dl <+ x^^30825 <+
C1 <+ Dl <+ x^^72141 <+ C1 <+ Dl <+ x^^3075 <+
C1 <+ Dl <+ x^^1537.
Inductive lsym :=
| l_xs (n : positive)
| l_D
| l_P
| l_C0 | l_C1 | l_C2 | l_C3
| l_F0 | l_F1 | l_F2 | l_F3
| l_G0 | l_G1 | l_G2
| l_Fs (n : positive)
| l_Gs (n : positive)
| l_Hs (n : positive).
Inductive rsym :=
| r_xs (n : positive)
| r_D
| r_C
| r_P
| r_Gs (n : positive).
Notation ltape := (list lsym).
Notation rtape := (list rsym).
Definition F := [l_xs 10344; l_D; l_xs 7640; l_C2].
Definition G := [r_xs 300; r_D; r_xs 30826; r_D; r_xs 72142; r_D;
r_xs 3076; r_D; r_xs 1538; r_D].
Definition J := [l_D; l_C2; l_xs 95; l_C0;
l_xs 7713; l_D; l_D; l_xs 1866; l_C1;
l_xs 13231; l_D; l_xs 6197; l_C3;
l_xs 11066; l_D; l_xs 7279; l_C0;
l_xs 10524; l_D; l_xs 7550; l_C2;
l_xs 10389; l_D; l_xs 7618; l_C1;
l_xs 10355; l_D; l_xs 7635; l_C3;
l_xs 10347; l_D; l_xs 7639; l_C3;
l_xs 10345; l_D; l_xs 7640; l_C1].
Definition K : rtape :=
[r_xs 7639; r_D; r_xs 10347; r_C;
r_xs 7635; r_D; r_xs 10355; r_C;
r_xs 7619; r_D; r_xs 10387; r_C;
r_xs 7555; r_D; r_xs 10515; r_C;
r_xs 7299; r_D; r_xs 11027; r_C;
r_xs 6275; r_D; r_xs 13075; r_C;
r_xs 2179; r_D; r_D; r_xs 7088; r_C;
r_xs 1; r_C; r_xs 3849; r_P].
Definition uni_P : positive := 53946.
Definition uni_T : positive := 4 * uni_P - 5.
Definition eqb_l (a b : lsym) : bool :=
match a,b with
| l_xs n1,l_xs n2 => Pos.eqb n1 n2
| l_D,l_D
| l_P,l_P
| l_C0,l_C0 | l_C1,l_C1 | l_C2,l_C2 | l_C3,l_C3
| l_F0,l_F0 | l_F1,l_F1 | l_F2,l_F2 | l_F3,l_F3
| l_G0,l_G0 | l_G1,l_G1 | l_G2,l_G2 => true
| l_Fs n1,l_Fs n2 => Pos.eqb n1 n2
| l_Gs n1,l_Gs n2 => Pos.eqb n1 n2
| l_Hs n1,l_Hs n2 => Pos.eqb n1 n2
| _,_ => false
end.
Definition eqb_r (a b : rsym) : bool :=
match a,b with
| r_xs n1,r_xs n2 => Pos.eqb n1 n2
| r_D,r_D => true
| r_C,r_C => true
| r_P,r_P => true
| r_Gs n1,r_Gs n2 => Pos.eqb n1 n2
| _,_ => false
end.
Fixpoint eqb_rtape (xs ys : rtape): bool :=
match xs,ys with
| xh::xt,yh::yt => if eqb_r xh yh then eqb_rtape xt yt else false
| nil,nil => true
| _,_ => false
end.
Notation left := TM.L.
Notation right := TM.R.
Notation conf := (dir * ltape * rtape)%type.
Fixpoint lift_right (t : rtape) : side :=
match t with
| [] => R
| r_xs n :: t => x^^(Pos.to_nat n) *> lift_right t
| r_D :: t => Dr *> lift_right t
| r_C :: t => C *> lift_right t
| r_P :: t => P *> lift_right t
| r_Gs n :: t => Gr^^(Pos.to_nat n) *> lift_right t
end.
Fixpoint lift_left (t : ltape) : side :=
match t with
| [] => L
| l_xs n :: t => lift_left t <* x^^(Pos.to_nat n)
| l_D :: t => lift_left t <* Dl
| l_P :: t => lift_left t <* P
| l_C0 :: t => lift_left t <* C0
| l_C1 :: t => lift_left t <* C1
| l_C2 :: t => lift_left t <* C2
| l_C3 :: t => lift_left t <* C3
| l_F0 :: t => lift_left t <* F0
| l_F1 :: t => lift_left t <* F1
| l_F2 :: t => lift_left t <* F2
| l_F3 :: t => lift_left t <* F3
| l_G0 :: t => lift_left t <* G0
| l_G1 :: t => lift_left t <* G1
| l_G2 :: t => lift_left t <* G2
| l_Fs n :: t => lift_left t <* Fl^^(Pos.to_nat n)
| l_Gs n :: t => lift_left t <* Gl^^(Pos.to_nat n)
| l_Hs n :: t => lift_left t <* Hl^^(Pos.to_nat n)
end.
Definition lift (c : conf) : Q * tape :=
match c with
| (left,  l, r) => lift_left l <| lift_right r
| (right, l, r) => lift_left l |> lift_right r
end.
Definition decr (n : positive) : N :=
N.pred (N.pos n).
(** [max_stride] returns the maximum number of times the stride rule can be applied to a tape before it becomes no longer possible. If [None] is returned, that means the rule can be applied an arbitrarily high amount of times – that happens for the very tail of the tape, without any [r_C] symbols.  You'll note that [max_stride] is not critical for correctness in any way, since if it returns a value that's too large, the acceleration will simply not be applied. As such, we don't really prove anything about [max_stride]. *)
Fixpoint max_stride (xs : N) (t : rtape) : option N :=
match t with
| [r_P] => None
| r_P :: _ => Some 0%N
| [] => Some 0%N
| r_xs xs' :: t => max_stride (xs + N.pos xs') t
| r_D :: t => max_stride 0 t
| r_C :: t =>
match max_stride 0 t with
| Some n' => Some (N.min xs (N.shiftr n' 2))
| None => Some xs
end
| r_Gs _ :: t => max_stride 0 t
end.
Fixpoint stride (xs : N) (n : positive) (t : rtape) : option rtape :=
match t with
| [r_P] => Some (rxs xs [r_P])
| r_P :: _ => None
| [] => None
| r_xs xs' :: t => stride (xs + N.pos xs') n t
| r_D :: t =>
match stride 0 n t with
| Some t => Some (rxs xs (r_D :: t))
| None => None
end
| r_C :: t =>
if (N.pos n <=? xs)%N then
match stride 0 n~0~0 t with
| Some t => Some (rxs (xs - N.pos n) (r_C :: rxs (N.pos n~0) t))
| None => None
end
else
None
| r_Gs gs :: t =>
match stride 0 n t with
| Some t => Some (rxs xs (Grs (N.pos gs) t))
| None => None
end
end.
(** A "tail recursive" implementation of [stride] that hopefully, perhaps, possibly, might be better performance-wise when evaluating within Coq. Actual tail recursion would be a huge pain with smart constructors like [rxs], so let's try explicit continuations first. *)
Fixpoint stride' (xs : N) (n :positive) (t : rtape)
(k : rtape -> rtape) : option rtape :=
match t with
| [r_P] => Some (k (rxs xs [r_P]))
| r_P :: _ => None
| [] => None
| r_xs xs' :: t => stride' (xs + N.pos xs') n t k
| r_D :: t => stride' 0 n t (fun t => k (rxs xs (r_D :: t)))
| r_C :: t =>
if (N.pos n <=? xs)%N then
stride' 0 n~0~0 t (fun t => k (rxs (xs - N.pos n)
(r_C :: rxs (N.pos n~0) t)))
else
None
| r_Gs gs :: t =>
stride' 0 n t (fun t => k (rxs xs (Grs (N.pos gs) t)))
end.
Fixpoint stride_level (t : rtape) : nat :=
match t with
| [] => 0
| r_C :: t => S (stride_level t)
| _ :: t => stride_level t
end.
Definition try_stride (c : conf) : option conf :=
match c with
| (left, l, r) => None
| (right, l, r) =>
match stride 0 1 r with
| Some r => Some (left, l, r)
| None => None
end
end.
Definition step (c : conf) : option conf :=
match try_stride c with
| Some c' => Some c'
| None => simple_step c
end.
Arguments lxs _ _ /.
Arguments rxs _ _ /.
Opaque J.
Definition uni_cycle_count (xs : positive) (r : rtape) : N :=
let xs_limit := (N.pred (N.pos xs) / N.pos uni_P)%N in
match xs_limit with
| N0 => 0
| Npos _ =>
match max_stride 0 r with
| Some strides => N.min xs_limit (strides / N.pos uni_T)%N
| None => xs_limit
end
end.
Fixpoint strip_prefix'{A}(eqb:A->A->bool)(xs ys:list A):option (list A) :=
match xs with
| nil => Some ys
| xh::xt =>
match ys with
| nil => None
| yh::yt =>
if eqb xh yh then strip_prefix' eqb xt yt else None
end
end.
Definition try_uni_cycle (c : conf) : option conf :=
match c with
| (right, l_D :: l_C1 :: l_xs xs :: l, r) =>
match strip_prefix' eqb_l J l with
| Some l =>
match uni_cycle_count xs r with
| N0 => None
| Npos n =>
match stride 0 (n * uni_T) r with
| Some r' =>
Some (right, l_D :: l_C1 :: l_xs (xs - n * uni_P) ::
J ++ Fls (N.pos n) l, Grs (N.pos n) r')
| None => None
end
end
| None => None
end
| _ => None
end.
Definition fullstep (c : conf) : option conf :=
match try_uni_cycle c with
| Some c' => Some c'
| None => step c
end.
Transparent C1 P.
Local Hint Immediate cycle_nonhalt : core.
Local Obligation Tactic := intros; subst; auto; discriminate.
(* {~ halts tm (lift c)} + {True} *)
Definition is_cycling (c : conf) : bool :=
match c with
| (right, l_C0 :: l, r) =>
eqb_rtape K r
| _ => false
end.
Fixpoint doit n c :=
match n with
| O => false
| S n0 =>
if is_cycling c then
true
else
match fullstep c with
| Some c' => doit n0 c'
| None => false
end
end.

Lemma doit_spec n c:
doit n c = true ->
~halts tm (lift c).