gistfile1.txt

У меня возникла следующая задача, не по работе,
а обучения ради, в результате которой возник 
вопрос, а как правильно писать tying the knot
алгоритмы. (Сама задача решена, теперь остаётся вопрос как это сделать красиво)

Задача:
Полная задача это подсчёт очков в го, но она
разбита на подзадачи.
Текущая задача: Дана сетка в R^n, в узлах сетки или
стенка или пустое место, нужно на каждом пустом
месте поставить множество (Set) значений, куда
можно добраться из этой точки.
След задача, в дополнение к множеству записывать значение вычисленное на значений на границах.

Решить задачу хочется функционально, т.к. понятно,
что существует куча всем известных императивных
алгоритмов.

При решении этой задачи я столкнулся со следующей
проблемой (для простоты рассмотрим 1D), хочется
научить хацкель решать системы следующего вида:

a = 1 U b
b = 2 U a U c
c = 3 U b

Решение тут очевидное a = b = c = {1,2,3},
но для хацкеля это цикл т.к. a = 1U2Ua...

Сразу же возникает идея разбить цикл, это
возможно если каждому множеству сопоставить
индекс, т.е.:
(a' = [1,b'], a = fromList $ concatMap (f [1]) a')
(b' = [2,a',c'], b = fromList $ concatMap (f [2] b')

Где f рекурсивно проходит выражения отфильтровывая
лишние элементы (переданные в параметре)
Но у этого решения достаточно высокая цена, для каждой
точки мы проводим вычисления заново т.е. заодно и тратится лишняя память, этого можно избежать двумя способами
1). Руками заменять b = concatMap.. на b=a, но это работает только для одномерных структур а так же для более сложных выражений
2). Делать таблицу кешей, но это тоже не идеальный вариант.

Другой вариант это использовать комбинатом неподвижной точки:

fa = fix (\f s -> 
  let s' = 1 U fb s
  in if s == s' then s' else f s')
a = fa S.empty

Тут (если это сработает) мы вычисляем сразу все выражения, что является большим плюсом.

А как вообще обычно решают такие задачи?

Попробовал тупой вариант с мемоизацией, зафейлился :)

import Data.Array
import Data.Maybe (fromJust)

type Element = Int
type Set = Char
type Table = Array TableIndex Bool
type TableIndex = (Set, Element)
type Equations = [(Set, [Either Set Element])]

generateArray :: Ix i => (i, i) -> (i -> e) -> Array i e
generateArray is g = array is [(i, g i) | i <- range is]

makeTable :: (TableIndex, TableIndex) -> Equations -> Table
makeTable is equations = table
  where
    table = generateArray is generator
    generator (s, e) = let eq = fromJust $ lookup s equations
                       in not $ all (either (\p -> not (table ! (p, e))) (e /=)) eq

main :: IO ()
main = do
  let eq = [ ('a', [Right 1, Left 'b'])
           , ('b', [Right 2, Left 'a', Left 'c'])
           , ('c', [Right 3, Left 'b'])
           ]
      t = makeTable (('a', 1), ('c', 3)) eq
  print (t ! ('a', 1))
  print (t ! ('a', 2))
  print (t ! ('a', 3))
  return ()

Зависает на 3ей:

*Main> main
True
True
  C-c C-cInterrupted.

Попробую с фиксированной точкой сообразить.

Вот что-то более рабочее, хоть и не через фиксированную точку. Выворачивает уравнения наизнанку, отделяя константы от переменных; замыкает уравнения с переменными; а потом подставляет константы.

Для операций над множествами использовал списковые union и (\), потому что и так в тексте есть "множества", поэтому боялся запутаться. Теперь списки можно в принципе и заменить на Data.Set.

import Data.List (union, (\\))
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import qualified Data.Map as Map (empty, map, mapWithKey, alter, (!), lookup)

type Element = Int
type Set = Char

type ConstInclusion = Map Element [Set]
type VariableInclusion = Map Set [Set]
type Inclusion = Map Element [Set]

type Equations = [(Set, [Element], [Set])]

(!&) :: Ord a => Map a [b] -> a -> [b]
m !& k = fromMaybe [] (Map.lookup k m)

reverseEquations :: Equations -> (ConstInclusion, VariableInclusion)
reverseEquations eqs = (foldr insertConstSet Map.empty eqs
                       , foldr insertVariableSet Map.empty eqs)
  where
    insertConstSet (s, es, _) = foldr ((.) . Map.alter (addSet s)) id es
    insertVariableSet (sl, _, ss) = foldr ((.) . Map.alter (addSet sl)) id (sl : ss)
    addSet s Nothing = Just [s]
    addSet s (Just ss) = Just (s : ss)

closure :: VariableInclusion -> VariableInclusion
closure incl = Map.mapWithKey (\s _ -> go s [s]) incl
  where
    go s acc = let delta = foldr (union . (incl !&)) [] acc \\ acc
               in if null delta then acc else go s (delta ++ acc)

applyConsts :: ConstInclusion -> VariableInclusion -> ConstInclusion
applyConsts consts closed = Map.map (foldr (union . (closed !&)) []) consts

main :: IO ()
main = do
  let eq = [ ('a', [1], "b")
           , ('b', [2], "a")
           , ('c', [3], "bd")
           , ('d', [4], "")
           ]
      (simple, recursive) = reverseEquations eq
      closed = closure recursive
      solved = applyConsts simple closed
  print solved

Ах, да, возвращает вывернутые множества. То есть Map от элемента к множествам, которым этот элемент принадлежит:

*Main> main
fromList [(1,"cba"),(2,"acb"),(3,"c"),(4,"cd")]

я хотел примерно такое:

import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set

loeb :: Functor a => a (a x -> x) -> a x
loeb x = fmap (\a -> a (loeb x)) x

data Nested c a 
      = Leaf [a]
      | Inner c [Nested c a]
      deriving (Show)

-- | removes only 1 cycle
flatten1 :: Eq c  => c -> [Nested c a] -> [a]
flatten1 i xs = concatMap f xs
  where
    f (Leaf ys) = ys
    f (Inner c ys) 
      | c == i = []
      | otherwise = flatten1 i ys

-- | removes arbitrary number of cycles
flatten :: (Ord c)  => Set c -> [Nested c a] -> [a]
flatten i xs = concatMap f xs
  where
    f (Leaf ys) = ys
    f (Inner c ys) 
      | c `Set.member` i = []
      | otherwise = flatten (c `Set.insert` i) ys
-- Одномерный пример
test = Map.fromList 
  [ (1, \m -> ([Leaf [1], g 2 m]))
  , (2, \m -> ([Leaf [2], g 1 m, g 3 m]))
  , (3, \m -> ([Leaf [3], g 2 m]))
  ]
  where 
    g i m = Inner i (m Map.! i)

-- Многомерный пример
testE = Map.mapWithKey (\k v -> Set.fromList $ flatten (Set.singleton k) v)
      $ loeb test

test2 = Map.fromList 
  [ ((1,1), \m -> ([Leaf [1], g (1,2) m, g (2,1) m]))
  , ((1,2), \m -> ([Leaf [2], g (1,1) m, g (2,2) m]))
  , ((2,1), \m -> ([Leaf [3], g (1,1) m, g (2,2) m]))
  , ((2,2), \m -> ([Leaf [4], g (2,1) m, g (1,2) m]))
  ]
  where 
    g i m = Inner i (m Map.! i)
testE2 = Map.mapWithKey (\k v -> Set.fromList $ flatten (Set.singleton k) v)
       $ loeb test2