(* 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