quiz : 解答編 : Concurrent Clean : ソースコード

プログラミング

出力は、最終結果だけでなく、計算過程も出力するようにしています。

module Main

import StdEnv, OptEnv

// utility
(-->|) infixl 0
(-->|) a (p,f) :== if p (f a) a

interleave as bs :== il1 as bs
  where
    il1 []     _  = []
    il1 [a:ar] bs = [a:il2 ar bs]

    il2 _  []     = []
    il2 as [b:br] = [b:il1 as br]

// main routine
Start :: *World -> *World
Start w
    # (f,w) = stdio w
    # f = f
        --> (align ns as --> map (fwritess o draw)
                         --> reverse
                         --> flip interleave $ repeat $ fwrites "---------\n"
                         --> reelU)
        //--> fwritess $ draw $ hd $ align ns as
    # (ok, w) = fclose f w
    = w
  where
    //ns = [1,2,3,4]
    //as = [(1,2),(1,3),(1,4),(2,4),(3,4)]
    ns = [1,2,3,4,5,6,7,8]
    as = [(1,6),(6,8),(1,2),(2,3),(2,4),(3,5),(4,7),(5,8),(7,8)]
    //ns = [1,2,3,4,5,6,7]
    //as = [(1,2),(1,4),(1,7),(2,3),(3,5),(4,5),(5,6),(5,7),(6,7)]
    //ns = [1,2,3,4]
    //as = [(1,2),(2,4),(1,3),(3,4)]


charset :: {Char}
charset =: {a \\ a <- ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']}

::Node :== Int
::Arc :== (!Node,!Node)
::Point :== (!Int,!Int)
::Cell :== (!Node,!Point)

showNode :: Node -> Char
showNode n = charset.[n]

draw :: [Cell] -> [String]
draw g = drawCanvas g canvas
  where
    (mX, mY) = foldl (\(x0,y0) (_,(x1,y1)) = (max x0 x1, max y0 y1)) (0,0) g

    canvas :: [String]
    canvas = let line = {' ' \\ j <- [0..mX]} in [line \\ i <- [0..mY]]

    drawCanvas :: [Cell] [String] -> [String]
    drawCanvas [] cv = cv
    drawCanvas [(n,(x,y)):gr] cv = drawCanvas gr $ updateAt y (cv!!y := (x, showNode n)) cv

fwritess :: [String] *File -> *File
fwritess ss f = f --> reelU $ map (\s f = f <<< s <<< "\n") ss


align :: [Node] [Arc] -> [[Cell]]
align nodes arcs = initCell --> alignY --> alignX
  where
    preNodes :: Node -> [Node]
    preNodes n = map fst $ filter (\a = n == snd a) arcs

    postNodes :: Node -> [Node]
    postNodes n = map snd $ filter (\a = n == fst a) arcs

    toCell :: [Cell] Node -> Cell
    toCell cs n = case filter (\(m,_) = m == n) cs of
                    []    = abort $ "error at toCell of " +++ toString n
                    [a:_] = a

    toPoint :: [Cell] Node -> Point
    toPoint cs n = snd $ toCell cs n

    initCell :: [Cell]
    initCell = [(n,(i,0)) \\ n <- nodes & i <|- [!0..]]

    alignY :: [Cell] -> [[Cell]]
    alignY cs = (\(_,r,_) = r) $ alignY (last cs) (0, [cs], [])
      where
        updateCell (n,p) [] = []
        updateCell (n,p) [(m,q):cr] | n == m = [(n,p):cr]
                                             = [(m,q):updateCell (n,p) cr]

        alignY :: Cell (Int, [[Cell]], [Node]) -> (Int, [[Cell]], [Node])
        alignY c=:(n,(x,y)) (lbl, css=:[cs:_], ns) = (lbl, css2, [n:ns])
                                                             --> (pns --> map alignY
                                                                      --> flip interleave (repeat inclbl)
                                                                      --> init
                                                                      --> reelU)
          where
            pns = map (toCell cs2) $ filter (not o (flip isMember ns)) $ preNodes n
            cs2 = updateCell (n,(x,lbl)) cs
            css2 = [cs2:css]
            inclbl (l,c,n) = (inc l,c,n)

    alignX :: [[Cell]] -> [[Cell]]
    alignX css=:[cs:csr] = alignX 0 [cs:css]
      where
        len = length cs

        alignX :: Int [[Cell]] -> [[Cell]]
        alignX i css=:[cs:csr] | i < len = alignX (inc i) [(updateAt i (n,(x2,y)) cs):csr]
                                         = css
          where
            (n,(x,y)) = cs!!i
            x2 = case preNodes n of
                   [] = x
                   ps = inc $ maxList $ map (fst o (toPoint cs)) ps