Execute a Markov algorithm

You are encouraged to solve this task according to the task description, using any language you may know.


Task

Create an interpreter for a Markov Algorithm.

Rules have the syntax:

<ruleset> ::= ((<comment> | <rule>) <newline>+)*
<comment> ::= # {<any character>}
<rule> ::= <pattern> <whitespace> -> <whitespace> [.] <replacement>
<whitespace> ::= (<tab> | <space>) [<whitespace>]

There is one rule per line.

If there is a   .   (period)   present before the   <replacement>,   then this is a terminating rule in which case the interpreter must halt execution.

A ruleset consists of a sequence of rules, with optional comments.


 Rulesets 

Use the following tests on entries:



Ruleset 1

# This rules file is extracted from Wikipedia:
# http://en.wikipedia.org/wiki/Markov_Algorithm
A -> apple
B -> bag
S -> shop
T -> the
the shop -> my brother
a never used -> .terminating rule

Sample text of:

  I bought a B of As from T S. 
Should generate the output:

  I bought a bag of apples from my brother. 


Ruleset 2

A test of the terminating rule

# Slightly modified from the rules on Wikipedia
A -> apple
B -> bag
S -> .shop
T -> the
the shop -> my brother
a never used -> .terminating rule
Sample text of:

 I bought a B of As from T S.
Should generate:

 I bought a bag of apples from T shop.


Ruleset 3

This tests for correct substitution order and may trap simple regexp based replacement routines if special regexp characters are not escaped.

# BNF Syntax testing rules
A -> apple
WWWW -> with
Bgage -> ->.*
B -> bag
->.* -> money
W -> WW
S -> .shop
T -> the
the shop -> my brother
a never used -> .terminating rule

Sample text of:

 I bought a B of As W my Bgage from T S.
Should generate:

 I bought a bag of apples with my money from T shop.


Ruleset 4

This tests for correct order of scanning of rules, and may trap replacement routines that scan in the wrong order.   It implements a general unary multiplication engine.   (Note that the input expression must be placed within underscores in this implementation.)

### Unary Multiplication Engine, for testing Markov Algorithm implementations
### By Donal Fellows.
# Unary addition engine
_+1 -> _1+
1+1 -> 11+
# Pass for converting from the splitting of multiplication into ordinary
# addition
1! -> !1
,! -> !+
_! -> _
# Unary multiplication by duplicating left side, right side times
1*1 -> x,@y
1x -> xX
X, -> 1,1
X1 -> 1X
_x -> _X
,x -> ,X
y1 -> 1y
y_ -> _
# Next phase of applying
1@1 -> x,@y
1@_ -> @_
,@_ -> !_
++ -> +
# Termination cleanup for addition
_1 -> 1
1+_ -> 1
_+_ -> 

Sample text of:

  _1111*11111_ 
should generate the output:

  11111111111111111111 


Ruleset 5

A simple Turing machine,
implementing a three-state busy beaver.

The tape consists of 0s and 1s,   the states are A, B, C and H (for Halt), and the head position is indicated by writing the state letter before the character where the head is.
All parts of the initial tape the machine operates on have to be given in the input.

Besides demonstrating that the Markov algorithm is Turing-complete, it also made me catch a bug in the C++ implementation which wasn't caught by the first four rulesets.

# Turing machine: three-state busy beaver
#
# state A, symbol 0 => write 1, move right, new state B
A0 -> 1B
# state A, symbol 1 => write 1, move left, new state C
0A1 -> C01
1A1 -> C11
# state B, symbol 0 => write 1, move left, new state A
0B0 -> A01
1B0 -> A11
# state B, symbol 1 => write 1, move right, new state B
B1 -> 1B
# state C, symbol 0 => write 1, move left, new state B
0C0 -> B01
1C0 -> B11
# state C, symbol 1 => write 1, move left, halt
0C1 -> H01
1C1 -> H11

This ruleset should turn

  000000A000000 
into

  00011H1111000 


include "cowgol.coh";
include "strings.coh";
include "malloc.coh";
include "argv.coh";
include "file.coh";
 
record Rule is
    pattern: [uint8];
    replacement: [uint8];
    next: [Rule];
    terminates: uint8;
end record;
 
sub AllocRule(): (rule: [Rule]) is       
    rule := Alloc(@bytesof Rule) as [Rule];
    MemZero(rule as [uint8], @bytesof Rule);
end sub;
 
sub ParseRule(text: [uint8]): (rule: [Rule]) is
    sub ParseError() is
        print("Failed to parse rule: ");
        print(text);
        print_nl();
        ExitWithError();
    end sub;
 
    var cur := text; 
    sub SkipWs() is 
        while [cur] != 0 and [cur] <= ' ' loop cur := @next cur; end loop; 
    end sub;
 
    sub AllocAndCopy(src: [uint8], length: intptr): (copy: [uint8]) is
        copy := Alloc(length + 1);
        MemCopy(src, length, copy);
        [copy + length] := 0;
    end sub;
 
    SkipWs();
    if [cur] == '#' or [cur] == 0 then # comment or empty line
        rule := 0 as [Rule];
        return;
    end if;
    var patternStart := cur;
 
    # find the " ->"
    while [cur] != 0 
    and ([cur] > ' ' or [cur+1] != '-' or [cur+2] != '>') loop
        cur := @next cur;
    end loop;
    if [cur] == 0 then ParseError(); end if;
 
    # find last char of pattern
    var patternEnd := cur;
    while patternStart < patternEnd and [patternEnd] <= ' ' loop
        patternEnd := @prev patternEnd;
    end loop;
 
    cur := cur + 3; # whitespace + '->'
    SkipWs();
    var replacementStart := cur;
 
    # find last char of replacement
    while [cur] != 0 loop cur := @next cur; end loop;
    while replacementStart < cur and [cur] <= ' ' loop
        cur := @prev cur;
    end loop;
 
    # make rule object
    rule := AllocRule();
    rule.pattern := AllocAndCopy(patternStart, patternEnd-patternStart+1);
    if [replacementStart] == '.' then
        rule.terminates := 1;
        replacementStart := @next replacementStart;
    end if;
    rule.replacement := AllocAndCopy(replacementStart, cur-replacementStart+1);
end sub;
 
sub FindMatch(needle: [uint8], haystack: [uint8]): (match: [uint8]) is
    match := 0 as [uint8];
    while [haystack] != 0 loop
        var n := needle;
        var h := haystack; 
        while [n] != 0 and [h] != 0 and [n] == [h] loop
            n := @next n;
            h := @next h;
        end loop;
        if [n] == 0 then
            match := haystack;
            return;
        end if;
        haystack := @next haystack;
    end loop;
end sub;
 
const NO_MATCH := 0;
const HALT := 1;
const CONTINUE := 2;
sub ApplyRule(rule: [Rule], in: [uint8], out: [uint8]): (result: uint8) is
    var match := FindMatch(rule.pattern, in);
    if match == 0 as [uint8] then
        result := NO_MATCH;
    else
        var len := StrLen(rule.replacement);
        var patlen := StrLen(rule.pattern);
        var rest := match + patlen;
        MemCopy(in, match-in, out);
        MemCopy(rule.replacement, len, out+(match-in));
        CopyString(rest, out+(match-in)+len);
        if rule.terminates != 0 then
            result := HALT;
        else
            result := CONTINUE;
        end if;
    end if;
end sub;
 
sub ApplyRules(rules: [Rule], buffer: [uint8]): (r: [uint8]) is
    var outbuf: uint8[256];
    var rule := rules;
    r := buffer;
 
    while rule != 0 as [Rule] loop
        case ApplyRule(rule, buffer, &outbuf[0]) is
            when NO_MATCH: 
                rule := rule.next;
            when HALT:
                CopyString(&outbuf[0], buffer);
                return;
            when CONTINUE:
                CopyString(&outbuf[0], buffer);
                rule := rules;
        end case;
    end loop;
end sub; 
 
sub ReadFile(filename: [uint8]): (rules: [Rule]) is
    var linebuf: uint8[256];
    var fcb: FCB;
    var bufptr := &linebuf[0];
 
    rules := 0 as [Rule];
    var prevRule := 0 as [Rule];
 
    if FCBOpenIn(&fcb, filename) != 0 then
        print("Cannot open file: ");
        print(filename);
        print_nl();
        ExitWithError();
    end if;
 
    var length := FCBExt(&fcb);
    var ch: uint8 := 1;
    while length != 0 and ch != 0 loop
        ch := FCBGetChar(&fcb);
        length := length - 1;
        [bufptr] := ch;
        bufptr := @next bufptr;
 
        if ch == '\n' then
            [bufptr] := 0;
            bufptr := &linebuf[0];
            var rule := ParseRule(&linebuf[0]);
            if rule != 0 as [Rule] then
                if rules == 0 as [Rule] then rules := rule; end if;
                if prevRule != 0 as [Rule] then prevRule.next := rule; end if;
                prevRule := rule;
            end if;
        end if;
    end loop;
 
    var dummy := FCBClose(&fcb);
end sub;
 
ArgvInit();
var fname := ArgvNext();
if fname == 0 as [uint8] then
    print("usage: markov [pattern file] [pattern]\n");
    ExitWithError();
end if;
 
var patbuf: uint8[256];
var patptr := &patbuf[0];
loop
    var patpart := ArgvNext();
    if patpart == 0 as [uint8] then
        if patptr != &patbuf[0] then patptr := @prev patptr; end if;
        [patptr] := 0;
        break;
    end if;
    var partlen := StrLen(patpart);
    MemCopy(patpart, partlen, patptr);
    patptr := patptr + partlen + 1;
    [@prev patptr] := ' ';
end loop;
 
print(ApplyRules(ReadFile(fname), &patbuf[0]));
print_nl();