Здравствуйте, kurtx, Вы писали:

Делаю как на wiki:

Сначала пишу функцию деления списка на две части. Для начала опишу для удобства несколько типов.

data BinTree a = Leaf a | Branch (BinTree a) (BinTree a) deriving Show

type Freq = (Char, Integer)

Сама функция делит список на две части, суммы частот которых наиболее близки.

1. Для этого получаем сначала список всех возможных пар списков. Это можно сделать по разному (splitAt по всей длине или пройтись свёрткой, собирая списки). Мы сделаем просто — склеим головы и хвосты: zip (inits xs) (tails xs)

2. Отсортируем полученный список пар и выберем голову. sortBy в Haskell имеет тип (a -> a -> Ordering) -> [a] -> [a]. Т.к. у нас `a` — это ([(Char, Integer)], [(Char, Integer)]), то нам придётся сравнивать 4 списка (суммируем попарно, а потом берём разность), поэтому для упрощения напишем функцию сортировки, которая сравнивает значения получая их целые (Integer) представления:

sortAsInt :: (a -> Integer) -> [a] -> [a]
sortAsInt asInt xs = map fst $ sortBy (\(_, i) (_, j) -> i `compare` j) $ map (\xs -> (xs, asInt xs)) xs

Я предпочитаю лямбды не выписывать, поэтому в конечном коде их перенесу в where.

3. Собственно сама функция получения разницы сумм:

sumDiff xs ys = abs $ sndSum xs - sndSum ys
    where
            sndSum = sum . map snd

snd здесь нужно потому что у нас элемент xs (или ys) — это пара (Пара_списков, Разница_их_сумм)
Блин, быстрее пишется, чем объясняется.

Итого:

sortAsInt :: (a -> Integer) -> [a] -> [a]
sortAsInt asInt = map fst . sortBy sndCompare . map withInt
    where
        sndCompare (_, i) (_, j) = i `compare` j
        withInt xs = (xs, asInt xs)

divide :: [Freq] -> ([Freq], [Freq])
divide xs = head $ sortAsInt (uncurry sumDiff) $ zip (inits xs) (tails xs)
    where
        sndSum = sum . map snd
        sumDiff xs ys = abs $ sndSum xs - sndSum ys

Дальше генерация дерева. Это проще, т.к. генерация — это всего лишь рекурсивный обход — разделили на две части, для каждой части опять генерируем дерево и т.д. Если дошли до одиночного символа, генерируем из него листочек.

genTree :: [Freq] -> BinTree Freq
genTree [x] = Leaf x
genTree xs  = let (ls, rs) = divide xs in Branch (genTree ls) (genTree rs)

К>Тем самым мы абстрагировались от типа дерева. Можем вообще что угодно подсунуть, а ещё можем сделать монадную версию и, например, распечатать "ход мысли".

К>fanoM :: Monad m => ((pair -> m node), (node -> node -> m node)) -> [pair] -> m node

К>fanoM _ [] = error "сингулярность"
К>fanoM (mkLeaf,_) [x] = mkLeaf x
К>fanoM mk@(_,mkNode) xs = do
К>    let (ys,zs) = splitFano xs -- это не монадная операция
К>    ynode <- fanoM mk ys
К>    znode <- fanoM mk zs
К>    node <- mkNode ynode znode
К>    return node

Иллюстрации к этому делу

pairs = [('A',15), ('B',7), ('C',6), ('D',6), ('E',5)]

-- просто дерево
data BinTree x = Leaf x | Node (BinTree x) (BinTree x)

result1 = fano (Leaf,Node) pairs -- в качестве конструкторов - собственно конструкторы :)
{-
    Node
        Node
            Leaf ('A',15)
            Leaf ('B',7)
        Node
            Leaf ('C',6)
            Node
                Leaf ('D',6)
                Leaf ('E',5)
-}

-- дерево, каждый узел которого хранит суммарную вероятность
data BinTreeP x p = LeafP p x | NodeP p (BinTreeP x p) (BinTreeP x p)

result2 = fano (mkLeafP, mkNodeP) pairs -- а вот здесь придётся поработать!
    where
        mkLeafP (c,p) = LeafP p c
        mkNodeP n1 n2 = NodeP (getP n1 + getP n2) n1 n2
        getP (LeafP p _) = p
        getP (NodeP p _) = p
{-
    NodeP 39
        NodeP 22
            LeafP 15 'A'
            Leaf 7 'B'
        Node 17
            LeafP 6 'C'
            NodeP 11
                Leaf 6 'D'
                Leaf 5 'E'
-}

-- распечатка
printFano = fanoM (printLeaf,printNode) -- монада IO
    where
        printLeaf (c,p) = do -- (Char,Int) -> IO (String,Int)
                putStrLn (show c ++ ": " ++ show p)
                return ([c],p)
        printNode (s1,p1) (s2,p2) = do
                let p = p1+p2
                putStrLn (show s1 ++ ", " ++ show s2 ++ ": " ++ show p)
                return (s1++s2, p)
{-
'A': 15
'B': 7
"AB": 22
'C': 6
'D': 6
'E': 5
"DE": 11
"CDE": 17
"ABCDE": 39
-}

Здравствуйте, kurtx, Вы писали:

K>В качестве упражнений пишу расчеты лабораторных работ по Теории Информации на Haskell. И вот загвоздка, не могу сгенерировать бинарное дерево:
K>Визуально дерево должно выглядеть вот так:
K>http://en.wikipedia.org/wiki/Shannon-Fano_coding

K>Группы символов делятся по алгоритму:
K> 1. сумма первой группы (p1) и второй (p2) равна нулю;
K> 2. p1 <= p2 ?
K> * да: добавить в первую группу символ с начала таблицы;
K> * нет: добавить во вторую группу символ с конца таблицы;
K> 3. если все символы разделены на группы, то завершить алгоритм, иначе перейти к шагу 2.

K>Т.е. надо как-то рекурсивно поделить список [('A',15), ('B',7), ('C',6), ('D',6), ('E',5)] на группы и натянуть результат на дерево. Уже 3-ий день не могу это сделать
K>Помогите кодом или советом. Спасибо.

Давай начнём с того, что будем разбивать список. А уже с результатами разбиения делать что угодно — например, строить дерево.
Т.е. примерно так

fano ::
    ((pair -> node) {-конструктор листа-}, (node -> node -> node) {-конструктор узла-}) ->
    [pair] {-список пар элемент-вероятность-} ->
    node {-на выходе получаем дерево-}

fano _ [] = error "сингулярность!"
fano (mkLeaf,_) [x] = mkLeaf x -- терминальный случай
fano (mkLeaf,mkNode) [x,y] = mkNode (mkLeaf x) (mkLeaf y) -- тривиальный случай общего выражения (см.ниже)
fano mk@(_,mkNode) xs =
    let (ys,zs) = splitFano xs -- расщепили
    in mkNode (fano mk ys) (fano mk zs)

splitFano :: [pair] -> ([pair],[pair])

Тем самым мы абстрагировались от типа дерева. Можем вообще что угодно подсунуть, а ещё можем сделать монадную версию и, например, распечатать "ход мысли".

fanoM :: Monad m => ((pair -> m node), (node -> node -> m node)) -> [pair] -> m node

fanoM _ [] = error "сингулярность"
fanoM (mkLeaf,_) [x] = mkLeaf x
fanoM mk@(_,mkNode) xs = do
    let (ys,zs) = splitFano xs -- это не монадная операция
    ynode <- fanoM mk ys
    znode <- fanoM mk zs
    node <- mkNode ynode znode
    return node

Доброго времени суток.
Почитав статьи на RSDN решил изучить декларативную парадигму, в частности функциональный подход.
В качестве упражнений пишу расчеты лабораторных работ по Теории Информации на Haskell. И вот загвоздка, не могу сгенерировать бинарное дерево:

module Main where

-- бинарное дерево
data BinTree a = Leaf a | Branch (BinTree a) (BinTree a)

-- обходим дерево, генерируем для каждого символа его код
calcRule :: BinTree (Char,Integer) -> [(Char,String)]
calcRule (Branch lhs rhs) =
  let
    calc' :: String -> BinTree (Char,Integer) -> [(Char,String)]
    calc' code (Leaf x) = [(fst x, code)]
    calc' code (Branch lhs rhs) = (calc' (code ++ "0") lhs) ++ (calc' (code ++ "1") rhs)
  in
    (calc' "0" lhs) ++ (calc' "1" rhs)

-- генерируем дерево
genTree :: [(Char,Integer)] -> BinTree (Char,Integer)
{-
-- вот такое дерево должно получиться
genTree _ = Branch (Branch (Leaf ('A',15))
                           (Leaf ('B',7)))
                   (Branch (Leaf ('C',6))
                           (Branch (Leaf ('D',6))
                                   (Leaf ('E',5))))
-}
genTree sepp = undefined

-- получаем список пар (символ, код) из списка (символ, кол-во)
getRule :: [(Char,Integer)] -> [(Char,String)]
getRule sorted_ch_count_pairs =
  let
    tree = genTree sorted_ch_count_pairs
  in
    calcRule tree

--------
main =
  let
    -- список (символ, кол-во)
    char_count_pairs = [('A',15), ('B',7), ('C',6), ('D',6), ('E',5)]
  in
    print $ getRule char_count_pairs

Визуально дерево должно выглядеть вот так:
http://en.wikipedia.org/wiki/Shannon-Fano_coding

Группы символов делятся по алгоритму:
1. сумма первой группы (p1) и второй (p2) равна нулю;
2. p1 <= p2 ?
* да: добавить в первую группу символ с начала таблицы;
* нет: добавить во вторую группу символ с конца таблицы;
3. если все символы разделены на группы, то завершить алгоритм, иначе перейти к шагу 2.

Т.е. надо как-то рекурсивно поделить список [('A',15), ('B',7), ('C',6), ('D',6), ('E',5)] на группы и натянуть результат на дерево. Уже 3-ий день не могу это сделать
Помогите кодом или советом. Спасибо.

К>Давай начнём с того, что будем разбивать список. А уже с результатами разбиения делать что угодно — например, строить дерево.

Ну а теперь, когда мы умеем конструировать и проч. — займёмся собственно алгоритмом splitFano
Для начала попробуем без пар, а просто с вероятностями.

Тупой подход:

splitFano xs =
    let
        xys = [ splitAt k xs | k <- [1..(length xs)-1] ] -- все возможные разбиения
        delta (ys,zs) = abs(sum ys - sum zs)
        ds = map delta xys -- дельты сумм для каждого разбиения
        d = minimum ds -- находим наилучший результат
        k = findIndex (==d) ds -- находим его позицию
    in xys !! k -- возвращаем k-е разбиение

Здесь мы многократно считаем суммы, проделывая уйму лишней работы.

Во-первых, вспомним, что (sum ys) + (sum zs) == (sum xs). Поэтому (sum ys) — (sum zs) = (sum xs) — 2*(sum zs)

Во-вторых, можем посчитать частичные суммы — вместо того, чтобы делать это каждый раз

sums xs = ..... -- придумай алгоритм сам
-- на входе     [15,  7,  6,  6,  5]
-- на выходе [0, 15, 22, 28, 34, 39]

(Получить список сумм можно самыми разными способами — это тоже своего рода разминка для мозгов)

Получается

splitFano xs =
    let
        ss = sums xs
        total = last ss
        ds = map (\s -> abs(total-s*2)) ss
        d = minimum ds
        k = findIndex (==d) ds
    in splitAt k xs

Думаете, это всё, что можно выжать? Отнюдь!
Если мы возьмём график дельты (не абсолютной), то видно, что он
— убывает
— кандидаты на минимум абсолютной дельты — это 0 и два ближайших к нему значения (положительное и отрицательное)
Поэтому можно попробовать сэкономить...
Экономия будет выражаться в том, что мы не станем считать хвост списка sums xs, при условии, что total = sum xs был переплавлен компилятором и идёт по другому пути, нежели конструирование списка частичных сумм. (А использует foldl' (+) 0)

И это ещё не всё.
А зачем нам в каждом рекурсивном вызове fano вычислять суммы? Давайте один раз посчитаем.

fano (mkLeaf,mkNode) pairs =
    let
        -- предварительная работа
        n = length pairs
        ps = listArray (0,n-1) pairs -- чтобы обеспечить быстрый произвольный доступ к элементам
        ss = listArray (0,n) (sums $ snd $ unzip pairs) -- массив частичных сумм
        sumij i j = (ss!j) - (ss!i) -- функция суммы поддиапазона [i..j)
        elem i = ps!i -- i'й элемент
        -- функция разбиения
        splitf i j = -- полуинтервал [i..j) разбиваем по k на полуинтервалы [i..k),[k..j)
            let
                total = sumij i j
                ds = map (\k -> abs(sumij i k - sumij k j)) [i+1..j]
                d = minimum ds
                k = i + (findIndex (==d) ds)
            in k
        -- ну а теперь собственно обход
        fano' i j
            | j<=i = error "!!!"
            | j==i+1 = mkLeaf $ elem i
            | otherwise = mkNode (fano' i k) (fano' k j) where k = splitf i j

Ух, нагородил!

Не поручусь, что не накосячил где-то, поэтому проверяйте, отлаживайте...