How to parametrize a constant (in this particular recursive function)? - haskell

Question

test1 correctly produces the following structure from the string "abcdef":
(a,(1,[0])) -- type 'a' occur 1 time in position 0
(b,(1,[1])) -- type 'b' occur 1 time in position 1
(c,(1,[2]))
(d,(1,[3]))
(e,(1,[4]))
(f*,(1,[5])) -- type 'f' is the last of the list
But this result depends on the number 6, that is the length of a very particular class of string, invalid for general case.
So if the string in test1 is instead "abc" the result is wrong:
(a,(1,[0]))
(b,(1,[7]))
(c*,(1,[8]))
If the string in test1 is instead "abcdefgh" the result is also wrong:
(a,(1,[0]))
(b,(1,[2])) -- Should be [1]
(c,(1,[3])) -- Should be [2]
(d,(1,[4])) -- ...
(e,(1,[5]))
(f,(1,[6]))
(g,(1,[7]))
(h*,(1,[8]))
In addTrieWithCounter I'm not able to substitue this constant (6) with a parameterized function on the length of the word.
The CONTEXT of this function. The addTrieWithCounter will be placed in a special "loop" such "al alts" becames: addTrieWithCounter ... "al" 0 -> "drop the space" -> addTrieWithCounter ... "alts" 3. So the occurrences will be aligned with the initial string.
-- analyzing "all alts" should be obtained this result.
(a,(2,[4,0])) -- type 'a' occur 2 times in positions 3 and 0 (reversed order)
(l,(2,[5,1])) -- type 'l' (of seq "al") occur 2 times in positions 4 and 1 (reversed order)
(l*,(1,[2])) -- type 'l' (of seq "all") occur 1 time in positions 2
(t,(1,[6])) -- type 't' (of seq "alt") occur 1 time in positions 6
(s*,(1,[7])) -- type 's' (of seq "alts") occur 1 time in positions 7
It will be a trivial thing, but I have no idea.
Thanks in advance for your suggestions.
import qualified Data.Map as M
import Text.PrettyPrint as TP
import Data.Either (either)
data Trie a b = Nil | Trie (M.Map (Either a a) (b, Trie a b)) deriving Show
-- (Just a note: Trie will be a Monoid's instance. So with "Either" it is possible to distinguish the following cases: "all" and "alliance")
-- add an element to a Trie
addTrieWithCounter
:: Ord a =>
(Trie a (Int, [t1]), Int)
-> ((Int, [t1]) -> Int -> (Int, [t1]))
-> [a]
-> (Trie a (Int, [t1]), Int)
addTrieWithCounter (t,st) f [] = (t,st)
addTrieWithCounter (Nil,st) f xs = addTrieWithCounter (Trie M.empty, st) f xs
addTrieWithCounter (Trie m,st) f [x] =
(Trie $ M.insertWith (\(c,_) _ -> (f c st,Nil)) (Left x) (f (0,[]) st,Nil) m,st + 1)
addTrieWithCounter (Trie m, st) f (x:xs) =
case M.lookup (Right x) m of -- !!!!! PROBLEM IN THE FOLLOWING LINE !!!!!
Nothing -> let (t',st') = addTrieWithCounter (Nil, 6 - length xs ) f xs
in (Trie $ M.insert (Right x) (f (0,[]) st,t') m,st + 1)
Just (c,t) -> let (t',st') = addTrieWithCounter (t,st) f xs -- TO CHANGE
in (Trie $ M.insert (Right x) (f c st',t') m,st')
showTrieS f (t,_) = showTrie f t
showTrie :: Show a => (Either t t -> String) -> Trie t a -> Doc
showTrie _ Nil = empty
showTrie f (Trie m)
| M.null m = empty
| otherwise =
vcat $
do (k,(count,t)) <- M.assocs m
return $
vcat [ lparen TP.<> text (f k) TP.<> comma TP.<> (text . show $ count) TP.<> rparen
, nest 4 (showTrie f t)
]
test1 = showTrieS f1 t
where
f1 = (either (:"*") (:""))
t = addTrieWithCounter (Trie M.empty,0) f2 "abcdef"
f2 (cr,poss) st = ((cr + 1),(st : poss))

Answer 1

This will get you most of the way there. It doesn't solve your
exact problem, but shows how to remove the hard-coded length value.
import qualified Data.Map.Strict as M
import qualified Data.IntSet as S
import Data.Monoid
import Text.PrettyPrint hiding ((<>))
data GenTrie a b = Trie (M.Map a (b, GenTrie a b))
deriving (Show)
emptyTrie = Trie M.empty
data Info = Info { _count :: Int, _positions :: S.IntSet }
deriving (Show)
type Trie = GenTrie Char Info
addString :: Int -> String -> Trie -> Trie
addString i cs t = go t i cs
where
go :: Trie -> Int -> String -> Trie
go t i [] = t
go t i (c:cs) =
let Trie m = t
pair =
case M.lookup c m of
Nothing ->
let t2 = go emptyTrie (i+1) cs
val = Info 1 (S.singleton i)
in (val, t2)
Just (info,t1) ->
let t2 = go t1 (i+1) cs
val = info { _count = _count info+1
, _positions = S.insert i (_positions info)
}
in (val, t2)
in Trie (M.insert c pair m)
printTrie = putStrLn . showTrie
showTrie = render . trieToDoc
trieToDoc :: Trie -> Doc
trieToDoc (Trie m)
| M.null m = empty
| otherwise =
vcat $
do (ch, (info,t)) <- M.assocs m
let count = show (_count info)
pos = show (S.toList (_positions info))
return $
vcat [ text [ch] <> space <> text count <> space <> text pos
, nest 4 (trieToDoc t)
]
test1 = printTrie $ addString 0 "abc" emptyTrie
test2 = printTrie $ addString 4 "alts" $ addString 0 "all" emptyTrie

Answer 2

addTrieWithCounter (Trie m,st) f (x:xs) =
case M.lookup (Right x) m of
Nothing -> let (t',st') = addTrieWithCounter (Nil, st + 1 ) f xs
in (Trie $ M.insert (Right x) (f (0,[]) st,t') m, st')
Just (c,t) -> let (t',st') = addTrieWithCounter (t,st + 1) f xs
in (Trie $ M.insert (Right x) (f c st,t') m,st')