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.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