A simple tool developed in Haskell to reduce a sequence of elements, represented by strings,

to a simple expression by finding repeating patterns.

Using ghci, to reduce the sequence ["a","a","b","c","a","b","c"]:

*Reducer> let (expr,patterns) = reduce ["a","a","b","c","a","b","c"]

The final reduced expression is:

*Reducer> expr

["a","P0","P0"]

And the patterns found are:

*Reducer> patterns

[("P0",["a","b","c"])]

You can use the main.hs program to build a GraphViz representation of the reduced

expression. The input expression shoud be stored in a JSON file:

$ cat ex/input.json

["a","a","b","c","a","b","c"]

run the program using for example runhaskell, giving as argument the input file,

and saving the output to a new file:

$ runhaskell main.hs ex/input.json > ex/expr.dot

Now use the dot tool from GrpahViz to create a png file for example:

$ dot -Tpng ex/expr.dot > ex/expr.png

You should see something similar to the image below:


module Reducer (reduce,toDot) where

import Data.List

ngramsSet 0 _ = []

ngramsSet _ [] = []

ngramsSet n xs

| length ngram == n = ngram : ngramsSet n (tail xs)

| otherwise = []

where

ngram = take n xs

ngramsCount l = [ (x,length(filter (==x) l)) | x <- nub l ]

ngrams n l = ngramsCount $ ngramsSet n l

allGrams l = [ (n, ngrams n l) | n <- reverse [2 .. div (length l) 2] ]

filtGrams l = filter ( (>1).snd ) l -- remove n-grams with occurences == 1

replace _ _ [] = []

replace pat sub l = if (pat == take (length pat) l) then

sub : replace pat sub (drop (length pat) l)

else

(head l) : replace pat sub (tail l)

replaceCount _ [] = 0

replaceCount pat l

| pat == take (length pat) l = 1 + replaceCount pat (drop (length pat) l)

| otherwise = 0 + replaceCount pat (tail l)

reduce l = reduceAux l []

reduceAux l ps = let a = allGrams l

f = [ (fst i, filtGrams (snd i)) | i <- a ]

f2 = filter ( (/=[]).snd ) f

flat = map fst (concat (map snd f2))

(x, y) = replaceAll l flat 0 []

in

if y == [] then (x, ps)

else reduceAux x (ps++y)

replaceAll l [] _ ps = (l, ps)

replaceAll l (x:xs) c ps =

let cnt = replaceCount x l

pid = nextId c

in

if cnt>1 then replaceAll (replace x pid l) xs (c+1) (ps++[(pid, x)])

else replaceAll l xs c ps

nextId c = "P" ++ show c -- create next pattern id

getP p [] = []

getP p (x:xs)

| p == (fst x) = snd x

| otherwise = getP p xs

toDot (expr,_) =

let header = ["digraph auto {","rankdir=LR;", "size=\"7,5\";", "node [shape = circle];"]

edges = [ toEdge e | e <- zip [1..] (ngramsSet 2 expr) ]

in unlines $ concat [header,edges,["}"]]

toEdge (n,[f,t]) = concat ["\"",f,"\" -> \"",t,"\" [ label =\"",show n,"\" ];"]

digraph auto {

rankdir=LR;

size="7,5";

node [shape = circle];

"a" -> "P0" [ label ="1" ];

"P0" -> "P0" [ label ="2" ];

}

["a","a","b","c","a","b","c"]

import Reducer

import System.Environment

import qualified Data.ByteString.Lazy as BS

import qualified Data.Aeson as A

main = do

[file] <- getArgs

content <- BS.readFile file

let Just input = A.decode content :: Maybe [String]

putStr $ toDot $ reduce input