update

Task/Execute-a-Markov-algorithm/Bracmat/execute-a-markov-algorithm.bracmat

@@ -0,0 +1,214 @@
+markov=
+{
+First the patterns that describe the rules syntax.
+This is a naive and not very efficient way to parse the rules, but it closely
+matches the problem description, which is nice.
+}
+    ( ruleset
+    =     >%@" " ?   { Added: assume that a rule cannot start with whitespace.
+                       The %@ say that the thing to match must be exactly one
+                       byte. % means 'one or more'. @ means 'zero or one'.
+                     }
+        : ((!comment|!rule) !newlines) !ruleset
+      |         { Recursion terminates here: match empty string. }
+    )
+  & (comment="#" ?com)
+  & ( rule
+    =   %?pattern
+        !whitespace
+        "->"
+        !whitespace
+        ( "." %?replacement&stop:?stop
+        | %?replacement
+        )
+    )
+  & ( whitespace
+    = (\t|" ") (!whitespace|)
+    )
+  & ( newlines
+    =   ( (\n|\r)
+        & ( :!pattern:!replacement {Do nothing. We matched an empty line.}
+          |   (!pattern.!replacement.!stop) !rules:?rules
+                {
+                Add pattern, replacement and the stop (empty string or "stop")
+                to a list of triplets. This list will contain the rules in
+                reverse order.
+                Then, reset these variables, so they are not added once more
+                if an empty line follows.
+                }
+            & :?stop:?pattern:?replacement
+          )
+        )
+        (!newlines|)
+    )
+{
+Compile the textual rules to a single Bracmat pattern.
+}
+  & ( compileRules
+    =   stop pattern replacement rules,pat rep stp
+      .   :?stop:?pattern:?replacement:?rules
+                {
+                Important! Initialise these variables.
+                }
+        & @(!arg:!ruleset)
+                {
+                That's all. The textual rules are parsed and converted to a
+                list of triplets. The rules in the list are in reversed order.
+                }
+        & !rules:(?pat.?rep.?stp) ?rules
+                {
+                The head of the list is the last rule. Use it to initialise
+                the pattern "ruleSetAsPattern".
+                The single quote introduces a macro substition. All symbols
+                preceded with a $ are substituted.
+                }
+        &
+            ' ( ?A ()$pat ?Z
+              & $stp:?stop
+              & $rep:?replacement
+              )
+          : (=?ruleSetAsPattern)
+                {
+                Add all remaining rules as new subpatterns to
+                "ruleSetAsPattern". Separate with the OR symbol.
+                }
+        &   whl
+          ' ( !rules:(?pat.?rep.?stp) ?rules
+            &
+                ' (   ?A ()$pat ?Z
+                    & $stp:?stop
+                    & $rep:?replacement
+                  | $ruleSetAsPattern
+                  )
+              : (=?ruleSetAsPattern)
+            )
+        & '$ruleSetAsPattern
+    )
+        {
+        Function that takes two arguments: a rule set (as text)
+        and a subject string.
+        The function returns the transformed string.
+        }
+  & ( applyRules
+    =     rulesSetAsText subject ruleSetAsPattern
+        , A Z replacement stop
+      .   !arg:(?rulesSetAsText.?subject)
+        & compileRules$!rulesSetAsText:(=?ruleSetAsPattern)
+                {
+                Apply rule until no match
+                or until variable "stop" has been set to the value "stop".
+                }
+        &   whl
+          ' ( @(!subject:!ruleSetAsPattern)
+            & str$(!A !replacement !Z):?subject
+            & !stop:~stop
+            )
+        & !subject
+    )
+{
+Tests:
+}
+  &   out
+    $ ( applyRules
+      $ ( "# 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
+"
+        . "I bought a B of As from T S."
+        )
+      )
+  &   out
+    $ ( applyRules
+      $ ( "# Slightly modified from the rules on Wikipedia
+A -> apple
+B -> bag
+S -> .shop
+T -> the
+the shop -> my brother
+a never used -> .terminating rule
+"
+        . "I bought a B of As from T S."
+        )
+      )
+  &   out
+    $ ( applyRules
+      $ ( "# 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
+"
+        . "I bought a B of As W my Bgage from T S."
+        )
+      )
+  &   out
+    $ ( applyRules
+      $ ( "### 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
+_+_ ->
+"
+        . "_1111*11111_"
+        )
+      )
+  &   out
+    $ ( applyRules
+      $ ( "# 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
+"
+        . 000000A000000
+        )
+      )
+  & ok
+| failure;

Task/Execute-a-Markov-algorithm/Racket/execute-a-markov-algorithm-1.rkt

@@ -0,0 +1,28 @@
+#lang racket
+
+(struct ->  (A B))
+(struct ->. (A B))
+
+(define ((Markov-algorithm . rules) initial-string)
+  (let/cc stop
+    ; rewriting rules
+    (define (rewrite rule str)
+      (match rule
+        [(->  a b) (cond [(replace a str b) => apply-rules]
+                         [else str])]
+        [(->. a b) (cond [(replace a str b) => stop]
+                         [else str])]))
+    ; the cycle through rewriting rules
+    (define (apply-rules s) (foldl rewrite s rules))
+    ; the result is a fixed point of rewriting procedure
+    (fixed-point apply-rules initial-string)))
+
+;; replaces the first substring A to B in a string s
+(define (replace A s B)
+  (and (regexp-match? (regexp-quote A) s)
+       (regexp-replace (regexp-quote A) s B)))
+
+;; Finds the least fixed-point of a function
+(define (fixed-point f x0)
+  (let loop ([x x0] [fx (f x0)])
+    (if (equal? x fx) fx (loop fx (f fx)))))

Task/Execute-a-Markov-algorithm/Racket/execute-a-markov-algorithm-2.rkt

@@ -0,0 +1,11 @@
+> (define MA
+    (Markov-algorithm
+     (->  "A" "apple")
+     (->  "B" "bag")
+     (->. "S" "shop")
+     (->  "T" "the")
+     (->  "the shop" "my brother")
+     (->. "a never used" "terminating rule")))
+
+> (MA "I bought a B of As from T S.")
+"I bought a bag of apples from T shop."

Task/Execute-a-Markov-algorithm/Racket/execute-a-markov-algorithm-3.rkt

@@ -0,0 +1,22 @@
+;; the reader
+(define (read-rules source)
+  (with-input-from-string source
+    (λ () (for*/list ([line (in-lines)]
+                      #:unless (should-be-skipped? line))
+            (match line
+              [(rx-split A "[[:blank:]]->[[:blank:]][.]" B) (->. A B)]
+              [(rx-split A "[[:blank:]]->[[:blank:]]" B)    (->  A B)])))))
+
+;; the new pattern for the match form
+(define-match-expander rx-split
+  (syntax-rules ()
+    [(rx-split A rx B)
+     (app (λ (s) (regexp-split (pregexp rx) s)) (list A B))]))
+
+;; skip empty lines and comments
+(define (should-be-skipped? line)
+  (or (regexp-match? #rx"^#.*" line)
+      (regexp-match? #px"^[[:blank:]]*$" line)))
+
+(define (read-Markov-algorithm source)
+  (apply Markov-algorithm (read-rules source)))

Task/Execute-a-Markov-algorithm/Racket/execute-a-markov-algorithm-4.rkt

@@ -0,0 +1,64 @@
+(define R3 (read-Markov-algorithm "
+# 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"))
+
+(define R4
+  (read-Markov-algorithm "
+### 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
+_+_ -> "))
+
+(define R5
+  (read-Markov-algorithm "
+# 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"))

Task/Execute-a-Markov-algorithm/Racket/execute-a-markov-algorithm-5.rkt

@@ -0,0 +1,8 @@
+> (R3 "I bought a B of As W my Bgage from T S.")
+"I bought a bag of apples with my money from T shop."
+
+> (R4 "_1111*11111_")
+"11111111111111111111"
+
+> (R5 "000000A000000")
+"00011H1111000"