4 people like it.

Turing machine interpreter

A Turing machine emulator. An infinite tape is simulated by a zipper, instructions are stored in the binary tree for faster lookup.

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
(* we store our instructions in the binary tree for faster search *)
type 'a Tree when 'a : comparison = 
     | Nil 
     | Node of 'a * ('a Tree) * ('a Tree)

let Leaf x = Node(x, Nil, Nil)

type State = int
type Base = char
(* tape is represented by a zipper *)
type Ribbon = (Base list)*(Base list) 
type OP = L | R | U | H
type Instr = State * Base * Base * State * OP
type Prog = Instr Tree
type TM = Prog * State * Ribbon


let insert x T =
    let rec insert' x T cont = 
        match T with
        | Nil           -> cont (Leaf x)
        | Node(a, l, r) ->
          if (x > a) then
              insert' x r (fun e -> cont <| Node(a, l, e))
          else
              insert' x l (fun e -> cont <| Node(a, e, r))
    insert' x T id


let flip f x y = f y x
let curry f x y = f (x, y)
let uncurry f (x, y) = f x y

(* creating a tape structure from a string *)
let mkrib (s : string) = ([' '], s.ToCharArray() |> List.ofArray)

(* equivalent to List.append << List.rev *)
let rec rev_append l1 l2  =
    match l1 with
    | []   -> l2
    | h::t -> rev_append t (h::l2)
    
(* move the head according to the operation *)
let proc rib op =
    match op,rib with
    | U,_         -> rib
    | L,([],r)    -> ([], ' '::r)
    | L,(h::t, r) -> (t, h::r)
    | R,(l,h::[]) -> (h::l, [' '])
    | R,(l, h::t) -> (h::l, t)
    | H,(l, r)    -> ([],rev_append l r)

(* Find an instruction in the instructions tree *)
let rec find fSt fSym = function
    | Nil -> failwith "Not found"
    | Node((st,sym,nsym,nst,op), l, r) ->
        if (fSt,fSym) = (st,sym) then (st,sym,nsym,nst,op)
        elif (fSt,fSym) <= (st,sym) then find fSt fSym l
        else find fSt fSym r

let findInstr st sym (P : Prog) = find st sym P

(* simulate a step of the machine *)
let step ((P, st, (ribL, sym::ribR)) : TM) =
  let (_,_,nsym,nst,op) = findInstr st sym P
  let newrib = proc (ribL, nsym::ribR) op
  (P, nst, newrib)


(* Print the tape *)
let print (P, st, (ribL,ribR)) =
    for c in (List.rev ribL) do printf "%c " c
    printf "[%c] " <| List.head ribR
    for c in (List.tail ribR) do printf "%c " c
    printf "\n"


let rec run ((P, st, rib) : TM) =
    match rib with
    (* if the left part of the ribbon is nil, then halt *)
    | ([],_) -> (P, st, rib)
    | (l, r) ->
        print (P, st, rib)
        let n = step (P,st,rib)
        run n

(* example machine: binary addition *)

let mtadd = 
    (
    [(0,'0','0',0,R);
    (0,'1','1',0,R);
    (0,' ',' ',1,R);
    (1,'0','0',1,R);
    (1,'1','1',1,R);
    (1,' ',' ',2,L);
    (2,'1','0',3,L);
    (2,'0','1',2,L);
    (2,' ',' ',5,R);
    (3,'1','1',3,L);
    (3,'0','0',3,L);
    (3,' ',' ',4,L);
    (4,'1','0',4,L);
    (4,'0','1',0,R);
    (4,' ',' ',0,R);
    (5,'1',' ',5,R);
    (5,' ',' ',5,H)] |> List.fold (flip insert) Nil,
    0, mkrib "001110 101")

run mtadd
union case Tree.Nil: 'a Tree
union case Tree.Node: 'a * 'a Tree * 'a Tree -> 'a Tree
type Tree<'a (requires comparison)> =
  | Nil
  | Node of 'a * 'a Tree * 'a Tree

Full name: Script.Tree<_>
val Leaf : x:'a -> 'a Tree (requires comparison)

Full name: Script.Leaf
val x : 'a (requires comparison)
type State = int

Full name: Script.State
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
type Base = char

Full name: Script.Base
Multiple items
val char : value:'T -> char (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.char

--------------------
type char = System.Char

Full name: Microsoft.FSharp.Core.char
type Ribbon = Base list * Base list

Full name: Script.Ribbon
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
type OP =
  | L
  | R
  | U
  | H

Full name: Script.OP
union case OP.L: OP
union case OP.R: OP
union case OP.U: OP
union case OP.H: OP
type Instr = State * Base * Base * State * OP

Full name: Script.Instr
type Prog = Instr Tree

Full name: Script.Prog
type TM = Prog * State * Ribbon

Full name: Script.TM
val insert : x:'a -> T:'a Tree -> 'a Tree (requires comparison)

Full name: Script.insert
val T : 'a Tree (requires comparison)
val insert' : ('b -> 'b Tree -> ('b Tree -> 'c) -> 'c) (requires comparison)
val x : 'b (requires comparison)
val T : 'b Tree (requires comparison)
val cont : ('b Tree -> 'c) (requires comparison)
val a : 'b (requires comparison)
val l : 'b Tree (requires comparison)
val r : 'b Tree (requires comparison)
val e : 'b Tree (requires comparison)
val id : x:'T -> 'T

Full name: Microsoft.FSharp.Core.Operators.id
val flip : f:('a -> 'b -> 'c) -> x:'b -> y:'a -> 'c

Full name: Script.flip
val f : ('a -> 'b -> 'c)
val x : 'b
val y : 'a
val curry : f:('a * 'b -> 'c) -> x:'a -> y:'b -> 'c

Full name: Script.curry
val f : ('a * 'b -> 'c)
val x : 'a
val y : 'b
val uncurry : f:('a -> 'b -> 'c) -> x:'a * y:'b -> 'c

Full name: Script.uncurry
val mkrib : s:string -> char list * char list

Full name: Script.mkrib
val s : string
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
System.String.ToCharArray() : char []
System.String.ToCharArray(startIndex: int, length: int) : char []
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val ofArray : array:'T [] -> 'T list

Full name: Microsoft.FSharp.Collections.List.ofArray
val rev_append : l1:'a list -> l2:'a list -> 'a list

Full name: Script.rev_append
val l1 : 'a list
val l2 : 'a list
val h : 'a
val t : 'a list
val proc : char list * char list -> op:OP -> char list * char list

Full name: Script.proc
val rib : char list * char list
val op : OP
val r : char list
val h : char
val t : char list
val l : char list
val find : fSt:'a -> fSym:'b -> _arg1:('a * 'b * 'c * 'd * 'e) Tree -> 'a * 'b * 'c * 'd * 'e (requires comparison and comparison and comparison and comparison and comparison)

Full name: Script.find
val fSt : 'a (requires comparison)
val fSym : 'b (requires comparison)
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val st : 'a (requires comparison)
val sym : 'b (requires comparison)
val nsym : 'c (requires comparison)
val nst : 'd (requires comparison)
val op : 'e (requires comparison)
val l : ('a * 'b * 'c * 'd * 'e) Tree (requires comparison and comparison and comparison and comparison and comparison)
val r : ('a * 'b * 'c * 'd * 'e) Tree (requires comparison and comparison and comparison and comparison and comparison)
val findInstr : st:State -> sym:Base -> P:Prog -> State * Base * Base * State * OP

Full name: Script.findInstr
val st : State
val sym : Base
val P : Prog
val step : Prog * State * Ribbon -> Prog * State * (char list * char list)

Full name: Script.step
val ribL : Base list
val ribR : Base list
val nsym : Base
val nst : State
val newrib : char list * char list
val print : P:'a * st:'b * (char list * char list) -> unit

Full name: Script.print
val P : 'a
val st : 'b
val ribL : char list
val ribR : char list
val c : char
val rev : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.rev
val printf : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printf
val head : list:'T list -> 'T

Full name: Microsoft.FSharp.Collections.List.head
val tail : list:'T list -> 'T list

Full name: Microsoft.FSharp.Collections.List.tail
val run : Prog * State * Ribbon -> Prog * State * Ribbon

Full name: Script.run
val rib : Ribbon
val l : Base list
val r : Base list
val n : Prog * State * (char list * char list)
val mtadd : (int * char * char * int * OP) Tree * int * (char list * char list)

Full name: Script.mtadd
val fold : folder:('State -> 'T -> 'State) -> state:'State -> list:'T list -> 'State

Full name: Microsoft.FSharp.Collections.List.fold
Raw view New version

More information

Link:http://fssnip.net/aW
Posted:7 years ago
Author:Daniil
Tags: turing machine , algorithm