Turing machine (basic model) & PDA simulation in F#, with some examples

PDA.fsx

open System

type State = int
type StackSymbol = char
type Symbol = char

let toString = List.toArray >> String
let second f (a, b) = (a, f b)
let safeTail = function | [] -> [] | _ :: rest -> rest
let toChars (s : string) = s.ToCharArray() |> Array.toList

[<Literal>]
let StackGuard = '?'
[<Literal>]
let InputGuard = '#'

type TransitionFunc = (State * StackSymbol * Symbol) -> (State * string)

let runPDA (input : string) (f : TransitionFunc) debug =
    let rec run state (stack : StackSymbol list) (input : Symbol list) =
        let inputSymbol = defaultArg (List.tryHead input) InputGuard
        let stackSymbol = defaultArg (List.tryHead stack) StackGuard
        
        if debug then printf "%c%s%d%s%c; " StackGuard (toString stack) state (toString input) InputGuard
        
        let stack' = safeTail stack
        let input' = safeTail input
        let state', stackAdd = f (state, stackSymbol, inputSymbol)
        let stackNew = (toChars stackAdd |> List.rev) @ stack'
        
        if debug then printfn "%A -> %A" (state, stackSymbol, inputSymbol) (state', stackAdd)
        
        if state' < 0 then
            (state', stackNew)
        else
            run state' stackNew input'
    run 0 [] (toChars input)
    
let REJ = -1, ""
let ACC = -2, ""
    
let equalZeroOneCount = function
    | 0, 'a', 'a' -> 0, "aa"
    | 0, 'b', 'a' -> 0, ""
    | 0, '?', 'a' -> 0, "a"
    | 0, 'a', 'b' -> 0, ""
    | 0, 'b', 'b' -> 0, "bb"
    | 0, '?', 'b' -> 0, "b"
    | 0, 'a', '#' -> REJ
    | 0, 'b', '#' -> REJ
    | 0, '?', '#' -> ACC
    | s -> failwith ("Invalid state: " + string s)

let checkLang input =
    runPDA input equalZeroOneCount false |> fst = -2

checkLang "aabbaabba"

TuringMachine.fsx

open System

type State = int
type Symbol = char
type Move = L | R

[<Literal>]
let EmptySymbol = '.'

[<Literal>]
let GuardSymbol = '#'

type TransitionFunc = State * Symbol -> State * Symbol * Move

let toString = List.toArray >> String
let second f (a, b) = (a, f b)
let safeTail = function | [] -> [] | _ :: rest -> rest
let toChars (s : string) = s.ToCharArray() |> Array.toList
let skipWhileRight f = List.rev >> List.skipWhile f >> List.rev

let turingMachineInternal (left' : char list) (right' : char list) (f : TransitionFunc) debug =
    let rec run state left right : (int * char list * char list) =
        let symbol = defaultArg (List.tryHead right) EmptySymbol
        if debug then printf "%s%d%s; %A " (List.rev left |> toString) state (skipWhileRight ((=) EmptySymbol) right |> toString) (state, symbol)
        let state', symbol', move = f (state, symbol)
        if debug then printfn "-> %A" (state', symbol', move)
        if state' < 0 then
            (state', left, symbol' :: safeTail right)
        else
            let left', right' =
                match move with
                | L -> (List.tail left, List.head left :: symbol' :: safeTail right)
                | R -> (symbol' :: left, safeTail right)
            run state' left' right'
    let stateResult, left, right = run 0 left' right'
    let rightResult = right |> List.takeWhile ((<>) EmptySymbol)
    let leftResult = left |> (if List.isEmpty rightResult then List.skipWhile ((=) EmptySymbol) else id) |> List.rev
    (stateResult, leftResult @ rightResult)

let turingMachine (input : string) (f : TransitionFunc) debug =
    turingMachineInternal [] (toChars input) f debug |> second toString
    
let turingMachineWithGuard (input : string) (f : TransitionFunc) debug =
    turingMachineInternal ['#'] (toChars input) f debug |> second toString

let REJ = -1, '.', R
let ACC = -2, '.', R

// f(n, m) = max 0 (n - m), for every natural (>= 0) n and m
let subTransFunc = function
    |  0, 'n' ->  2, '#', R
    |  0, 'm' ->  1, '.', R
    |  0, '.' -> -1, '.', R
    |  1, 'm' ->  1, '.', R
    |  1, '.' -> -1, '.', R
    |  2, 'n' ->  2, 'n', R
    |  2, 'm' ->  3, 'n', R
    |  2, '.' -> 10, '.', L
    |  3, 'm' ->  3, 'm', R
    |  3, '.' ->  4, '.', L
    |  4, 'n' ->  5, 'n', L
    |  4, 'm' ->  4, 'm', L
    |  4, '.' -> 12, '.', R
    |  5, 'n' ->  5, 'n', L
    |  5, '.' ->  6, '.', R
    |  5, '#' ->  6, '#', R
    |  6, 'n' ->  7, '.', R
    |  7, 'n' ->  7, 'n', R
    |  7, 'm' ->  8, 'm', R
    |  7, '.' -> 14, '?', L
    |  8, 'm' ->  8, 'm', R
    |  8, '.' ->  9, '.', L
    |  9, 'm' ->  4, '.', L
    | 10, 'n' -> 10, 'n', L
    | 10, '#' -> -1, 'n', R
    | 12, 'm' -> 12, '.', R
    | 12, '.' -> 13, '.', L
    | 13, '.' -> 13, '.', L
    | 13, '#' -> -1, '.', R
    | 14, 'n' -> 14, 'n', L
    | 14, '.' -> 15, '.', R
    | 15, 'n' -> 16, '.', L
    | 15, '?' -> 19, '.', L
    | 16, 'n' -> 17, 'n', R
    | 16, '.' -> 16, '.', L
    | 16, '#' -> 18, 'n', R
    | 17, '.' -> 18, 'n', R
    | 18, 'n' -> 16, '.', L
    | 18, '.' -> 18, '.', R
    | 18, '?' -> -1, '.', R
    | 19, '.' -> 19, '.', L
    | 19, '#' -> -1, '.', R
    | s -> failwith ("Invalid state: " + string s)

let sub a b =
    let _, result = turingMachine (String('n', a) + String('m', b)) subTransFunc false
    result.Length

// Language of the form a^i b^j c^k, k = max i j (w/o spaces)
let langAcc = function
    | 0, 'a' -> 0, 'a', R
    | 0, 'b' -> 1, 'b', R
    | 0, 'c' -> 2, 'c', R
    | 0, '.' -> ACC
    | 1, 'a' -> REJ
    | 1, 'b' -> 1, 'b', R
    | 1, 'c' -> 2, 'c', R
    | 1, '.' -> REJ
    | 2, 'a' -> REJ
    | 2, 'b' -> REJ
    | 2, 'c' -> 2, 'c', R
    | 2, '.' -> 3, '?', L
    | 3, 'a' -> 5, '.', R
    | 3, 'b' -> 3, 'b', L
    | 3, 'c' -> 3, 'c', L
    | 3, '#' -> 4, '#', R
    | 4, 'b' -> 6, '.', R
    | 4, 'c' -> REJ
    | 4, '?' -> REJ
    | 5, 'a' -> 5, 'a', R
    | 5, 'b' -> 6, '.', R
    | 5, 'c' -> 7, '.', L
    | 5, '.' -> 5, '.', R
    | 5, '?' -> REJ
    | 6, 'b' -> 6, 'b', R
    | 6, 'c' -> 7, '.', L
    | 6, '.' -> 6, '.', R
    | 6, '?' -> REJ
    | 7, 'a' -> 5, '.', R
    | 7, 'b' -> 7, 'b', L
    | 7, '.' -> 7, '.', L
    | 7, '#' -> 8, '#', R
    | 8, 'b' -> 9, '.', R
    | 8, 'c' -> REJ
    | 8, '.' -> 8, '.', R
    | 8, '?' -> ACC
    | 9, 'b' -> 9, 'b', R
    | 9, 'c' -> 10, '.', L
    | 9, '.' -> 9, '.', R
    | 9, '?' -> REJ
    | 10, 'b' -> 9, '.', R
    | 10, '.' -> 10, '.', L
    | 10, '#' -> 8, '#', R
    | s -> failwith ("Invalid state: " + string s)

let checkLang input =
    turingMachineWithGuard input langAcc false |> fst = -2

sub 999 10
checkLang "aaacccc"