https://www.cl.cam.ac.uk/teaching/1920/CompTheory/

register_machine.sml

datatype instr = halt | plus of int * int | minus of int * int * int;

exception invalid;
(* Decode list/program from int *)
local
  fun decode_pair x = let
      fun h pos 0 = raise invalid
        | h pos n = if n mod 2 = 0 then h (pos + 1) (n div 2) else (pos, n div 2)
    in h (Int.toLarge 0) x end

  fun decode_instr 0 = halt
    | decode_instr x = let val (f, s) = decode_pair x in
       if f mod 2 = 0
       then plus (Int.fromLarge (f div 2), Int.fromLarge s)
       else let val (j, k) = decode_pair (s + 1)
            in minus (Int.fromLarge (f div 2), Int.fromLarge j, Int.fromLarge k) end end
in
  fun decode_list 0 = []
    | decode_list x = let
      val (a, b) = decode_pair x
    in a :: (decode_list b) end

  fun decode_program x = map decode_instr (decode_list x);
end

(* Encode list/program to int *)
local
  fun sqr (x:IntInf.int) = x * x

  fun pow(x, 0) = 1
   |  pow(x, 1) = x
   |  pow(x, n) = if n mod 2 = 0
                  then sqr(pow(x, n div 2))
                  else x * sqr(pow(x, (n - 1) div 2))

  fun encode_pair(x, y) = pow(2, x) * (2 * y + 1)

  fun encode_instr halt = 0
    | encode_instr (plus(r, l)) = encode_pair(2 * (Int.toLarge r), (Int.toLarge l))
    | encode_instr (minus(r, l, l')) = encode_pair(2 * (Int.toLarge r) + 1, encode_pair(Int.toLarge l, Int.toLarge l') - 1)
in
  fun encode_list nil = 0
    | encode_list (x::lst) = encode_pair(x, encode_list lst)

  fun encode_program p = encode_list(map encode_instr p)
end

(* Run programs *)
local
  fun max (x, y) = if x > y then x else y

  fun max_register prog = let
      fun reg halt = 0
        | reg (plus(r, _)) = r
        | reg (minus(r, _, _)) = r
    in foldl max 0 (map reg prog) end;

  fun empty_list n = List.tabulate(max(0, n), fn x => Int.toLarge 0)
in
  fun run p reg = let
      exception stop;
      val prog = Array.fromList p
      val registers = Array.fromList((0 :: reg) @ empty_list ((max_register p) - (length reg)))
      val pc = ref 0;

      fun run halt = raise stop
        | run (plus(r, l)) = (Array.update(registers, r, (Array.sub(registers, r)) + 1); l)
        | run (minus(r, l, l')) = let val v = Array.sub(registers, r)
                                  in if v = 0 then l' else (Array.update(registers, r, v - 1); l) end
      fun step () = let
          val i = Array.sub(prog, !pc) handle Subscript => raise stop
        in ((pc := run i); step()) end
    in step() handle stop => (Int.toLarge (!pc)) :: (Array.foldr op:: [] registers) end
end

(* Examples *)
val add = [minus(1,1,2), plus(0,0), minus(2,3,4), plus(0,2), halt];
val multiply = [minus(1,1,6), minus(2,2,4), plus(0,3), plus(3,1), minus(3,5,0), plus(2,4), halt];

u.sml

use "register_machine.sml";

(*
Compiles the universal turing machine from the provided blocks

Seems to work on small examples only using one or two R+ instructions

Programs longer than a few instructions or that
use R- (which maps to much larger numbers) seems to be infesible
*)

local
  local val x = ref ~1
  in fun alloc_link () = let val r = !x in (x := r - 1; r) end end

  val code = ref [] : instr list ref;

  fun edit_program adjust = let
    fun h (halt) = halt
      | h (plus(r, l)) = plus(r, adjust l)
      | h (minus(r, l, l')) = minus(r, adjust l, adjust l')
  in map h end;

  fun base_label b = edit_program (fn x => if x < 0 then x else x + b)

  fun link_label from to = code := (edit_program (fn x => if x = from then to else x) (!code))

  fun add_code prog = let
      val index = length (!code)
    in (code := !code @ (base_label index prog); index) end;

  val p = 1
  val a = 2
  val pc = 3
  val n = 4
  val c = 5
  val r = 6
  val s = 7
  val t = 8
  val z = 9

  fun assignment_block(s, r) = let
      val link1 = alloc_link()
    in (add_code [
      minus(s, 0, 1),
      minus(r, 2, 4),
      plus(z, 3),
      plus(s, 1),
      minus(z, 5, link1),
      plus(r, 4)
    ], link1) end;

  fun push_block(x, l) = let
      val link1 = alloc_link()
    in (add_code [
      plus(z, 1),
      minus(l, 2, 3),
      plus(z, 0),
      minus(z, 4, 5),
      plus(l, 3),
      minus(x, 1, link1)
    ], link1) end;

  fun pop_block(l, x) = let
      val link1 = alloc_link()
      val link2 = alloc_link()
    in (add_code [
      minus(x, 0, 1),
      minus(l, 2, link2),
      plus(l, 3),
      minus(l, 4, 5),
      plus(z, 3),
      minus(z, 7, 6),
      plus(x, 3),
      minus(z, 8, link1),
      plus(l, 5)
    ], link1, link2) end;

  fun plus_block(r) = let
      val link1 = alloc_link()
    in (add_code [plus(r, link1)], link1) end;

  fun minus_block(r) = let
      val link1 = alloc_link()
      val link2 = alloc_link()
    in (add_code [minus(r, link1, link2)], link1, link2) end;

  val (_, l1) = push_block(0, a)
  val (in2, l2) = assignment_block(t, p)
  val (in3, l3, l'3) = pop_block(t, n)
  val (in4, l4, l'4) = minus_block(pc)
  val (in5, l5, l'5) = pop_block(n, c)
  val (in6, l6, l'6) = pop_block(a, 0)
  val (in7, l7, l'7) = pop_block(a, r)
  val (in8, l8, l'8) = minus_block(c)
  val (in9, l9) = plus_block(r)
  val (in10, l10) = assignment_block(pc, n)
  val (in11, l11) = push_block(r, a)
  val (in12, l12, l'12) = pop_block(s, r)
  val (in13, l13, l'13) = minus_block(c)
  val (in14, l14) = push_block(r, s)
  val (in15, l15) = plus_block(n)
  val (in16, l16, l'16) = pop_block(n, pc)
  val (in17, l17, l'17) = minus_block(r)
  val halt' = add_code [halt]

  val _ = link_label l1 in2
  val _ = link_label l2 in3
  val _ = link_label l3 in4
  val _ = link_label l'3 in6
  val _ = link_label l4 in3
  val _ = link_label l'4 in5
  val _ = link_label l5 in7
  val _ = link_label l'5 in6
  val _ = link_label l6 halt'
  val _ = link_label l'6 halt'
  val _ = link_label l7 in8
  val _ = link_label l'7 in8
  val _ = link_label l8 in13
  val _ = link_label l'8 in9
  val _ = link_label l9 in10
  val _ = link_label l10 in11
  val _ = link_label l11 in12
  val _ = link_label l12 in11
  val _ = link_label l'12 in2
  val _ = link_label l13 in14
  val _ = link_label l'13 in15
  val _ = link_label l14 in7
  val _ = link_label l15 in16
  val _ = link_label l16 in17
  val _ = link_label l'16 in17
  val _ = link_label l17 in11
  val _ = link_label l'17 in10
in
  val U = !code

  (* never going to work... it's way too big *)
  (* val encoded = encode_program(U) *)
end