Загрузить файлы в «/»

Main.hs

@@ -0,0 +1,88 @@
+import Control.Concurrent (threadDelay)
+
+data Tree = T Tree Tree | U Tree Tree | F Tree Tree | None deriving (Read, Eq)
+
+showv :: Tree -> String
+showv (T _ _) = "T"
+showv (F _ _) = "F"
+showv (U _ _) = "U"
+showv None = ""
+
+isNone None = True
+isNone _ = False
+
+showRel b (a, c)
+    | isNone a = ""
+    | otherwise = b ++ " -> " ++ b ++ c
+
+surround l r m = l <> m <> r
+
+commas joiner [] = mempty
+commas joiner [a] = a
+commas joiner (a:b) = a <> joiner <> commas joiner b
+
+showGV _ (None, _) = ""
+showGV b (a, c) =
+    let
+        ind = b ++ c
+        val = showv a
+        prefix = ((ind ++ " -> ") ++)
+        children = case a of
+            (T l r) -> [l, r]
+            (U l r) -> [l, r]
+            (F l r) -> [l, r]
+    in
+        commas "; " $ (ind ++ surround "[label=\"" "\"]" val):
+         [f ind subs
+         | f <- [showRel, showGV]
+         , subs <- (zip children ["L", "R"])
+         , f ind subs /= ""]
+ 
+instance Show Tree where
+    show :: Tree -> String
+    show x = surround "digraph{" "}" $ showGV "Z" (x, "")
+
+
+update :: Tree -> Tree
+-- нисходящие нули
+update (F (U a b) (U c d)) = F (update $ F a b) (update $ F c d)
+update (F (F a b) (U c d)) = F (update $ F a b) (update $ F c d)
+update (F (U a b) (F c d)) = F (update $ F a b) (update $ F c d)
+
+-- восходящие единицы
+update (U (T a b) (U c d)) = T (update $ T a b) (update $ U c d)
+update (U (U a b) (T c d)) = T (update $ U a b) (update $ T c d)
+update (U (T a b) (F c d)) = T (update $ T a b) (update $ F c d)
+update (U (F a b) (T c d)) = T (update $ F a b) (update $ T c d)
+
+-- обобщение нуля
+update (U (F a b) (F c d)) = F (update $ F a b) (update $ F c d)
+
+-- частная единица
+update (T (F a b) (U c d)) = T (update $ F a b) (update $ T c d)
+update (T (U a b) (F c d)) = T (update $ T a b) (update $ F c d)
+
+-- контрадикторные правила
+--update (U (T a b) c) = T (update $ U a b) (update c)
+--update (F (T a b) c) = U (update $ U a b) (update c)
+--update (U (T a b) (U c d)) = T (update $ T a b) (update $ U c d)
+--update (U (U a b) (T c d)) = T (update $ U a b) (update $ T c d)
+
+-- универсальная рекурсия
+update (T l r) = T (update l) (update r) 
+update (U l r) = U (update l) (update r) 
+update (F l r) = F (update l) (update r) 
+-- база рекурсии
+update None = None
+
+iterateN :: Int -> Tree -> [Tree]
+iterateN 0 t = [t]
+iterateN i t =
+    let t' = update t
+    in if t' == t then [t] else t:(iterateN (i-1) t')
+
+main :: IO ()
+main = do
+    ln <- getLine
+    let tr = (read ln :: Tree)
+    mapM_ print $ iterateN 100 tr