Here's a quick, dirty and probably buggy implementation of COMIT in Haskell.
The COMIT programmers' reference manual seems to be paywalled (I'm looking at you, ACM!), so I used the description in An introduction to COMIT programming. Numeral subscripts, shelves etc. are not implemented, and I don't know how to behave in corner cases (like * A + $ + $ + B = 2 *).
There's no parser (yet), so instead of LABEL A + $1 + $ = 2 + B NEXT, you need to write ("LABEL", [LLit "A", Repeat 1, Any], [Match 2, RLit "B"], "NEXT") etc.
The output is just a list of the workspace states. The workspace itself is a list of strings. Here are two examples from the manual:
ws1 = [" BILL", ",", " THEY", " SAY", ",", " IS", " RETIRED"]
ex1 = [("*", [LLit ",", Any, LLit ","], [], "*")]
*Main> run ex1 ws1
[[" BILL"," IS"," RETIRED"]]
and a 3-line program using the marker technique:
ws2 = ["A", "B", "C", "A", "B"]
ex2 = [("*", [Any], [RLit "*Q", Match 1], "*"),
("FIND", [LLit "*Q", Any, LLit "A"], [Match 2, Match 3, Match 1], "FIND"),
("*", [LLit "A", LLit "*Q"], [], "*")]
*Main> run ex2 ws2
[["*Q","A","B","C","A","B"],
["A","*Q","B","C","A","B"],
["A","B","C","A","*Q","B"],
["A","B","C","A","*Q","B"],
["A","B","C","B"]]
Code:
data LElem a = LLit a | Repeat Int | Any deriving (Show)
data RElem a = RLit a | Match Int deriving (Show)
type Label = String
type Workspace a = [a]
type Matching a = [[a]]
type Rule a = (Label, [LElem a], [RElem a], Label)
splits (x:xs) = ([], (x:xs)) : [(x:ys,zs) | (ys,zs) <- splits xs]
splits [] = [([],[])]
-- if the lhs deosn't start with Any, the zeroeth match takes the part of the
-- workspace before the actual match. Otherwise, it's empty.
match :: (Show a, Eq a) => [LElem a] -> Workspace a -> [Matching a]
match rs@(Any:_) ws = do { m <- match' rs ws; return ([]:m) }
match rs ws = matchShortest rs ws
match' :: (Show a, Eq a) => [LElem a] -> Workspace a -> [Matching a]
match' [] ws = [[ws]] -- keep end of workspace after match
match' (LLit l:rs) (w:ws)
| l == w = do { m <- match' rs ws; return ([w]:m) }
| otherwise = []
match' (Repeat n:rs) ws
| length ws >= n = do { m <- match' rs (drop n ws); return ((take n ws):m) }
| otherwise = []
match' [Any] ws = [[ws,[]]] -- $ at end matches everything
match' (Any:rs) ws = matchShortest rs ws
match' rs ws = [] -- fail
matchShortest rs ws = take 1 [xs:m | (xs, ys) <- splits ws, m <- match' rs ys]
-- keep first and last part of match, apply rhs to everything else
replace :: [RElem a] -> Matching a -> Workspace a
replace rs m = (head m) ++ concatMap f rs ++ (last m) where
f (RLit w) = [w]
f (Match k) = m !! k
next :: Label -> [Rule a] -> [Rule a]
next _ [] = []
next n rss@((n',_,_,_):rss')
| n == n' = rss
| otherwise = next n rss'
exec :: (Show a, Eq a) => [Rule a] -> [Rule a] -> Workspace a -> [Workspace a]
exec _ [] ws = []
exec rss css ws = ws' : exec rss css' ws' where
(_, lhs, rhs, n):_ = css
m = match lhs ws
(ws', css') = case (m, n) of
([], _) -> (ws, tail css) -- match failed
(_, "*") -> (ws'', tail css) -- next line
(_, _) -> (ws'', next n rss) -- goto label
ws'' = replace rhs (head m)
run rss ws = exec rss rss ws
COMIT feels very similar to sed or awk, except that it works on list of words ("constituents") instead of just a list of characters, and so is obviously geared to represent grammars and term rewriting systems.
