クイズ: Graphical Partition

http://mput.dip.jp/mput/?date=20051007#p01
Concurrent Cleanで解いてみた。
Haskellの回答をいろいろ見てたら、choiceとかcombとかお決まりのパターンがあるんだね。
http://www.sampou.org/cgi-bin/haskell.cgi?Programming%3a%b6%cc%bc%ea%c8%a2%3a%c1%c8%b9%e7%a4%bb
あと、「or []」は False になるので、case は不要でした。
なので、それを使ってみたら、かなり短くなった。

module graph3

import StdEnv

/** イディオム **/
choice  :: Int [a] -> [([a], [a])]
choice 0 xs = [([], xs)]
choice n [] = []
choice n [x:xs] = [([x:ys], zs) \\ (ys, zs) <- (choice (n-1) xs)] ++
                  [(ys, [x:zs]) \\ (ys, zs) <- (choice n xs)]


problem =
    //[1, 2, 2, 3, 4]       // True
    [5, 2, 3, 2, 3, 2, 5] // True
    //[4, 4, 4, 2, 2]       // False
    //[1, 1, 4]             // False

Start
    = isGraphical problem


isGraphical :: [Int] -> Bool
isGraphical []
    = True
isGraphical graph
    = or (map isGraphical next)
where
    next = map (\ (g1, g2) = g2 ++ (map (\x = x - 1) g1)) (choice (hd graph) (tl graph))

• • • -

(最初の回答)
Concurrent Cleanで解いてみた。なんか、無駄に長いなぁ・・・。なんでこんなに長いんだろ。
最初、単純無向グラフの意味を取り違えて、多重辺の存在チェックを忘れていて、はまってしまいました。

module graph

import StdEnv

::Graph :== [Int]
::Edge :== (Int, Int)
::Problem :== (Graph, [Edge])

problem =
    //[1, 2, 2, 3, 4]       // True
    [5, 2, 3, 2, 3, 2, 5] // True
    //[4, 4, 4, 2, 2]       // False
    //[1, 1, 4]             // False

Start
    = isGraphical (problem, [])


instance == Edge
where
    (==) (a, b) (c, d)
        | a == c && b == d
            = True
        | a == d && b == c
            = True
        = False

isGraphical :: Problem -> Bool
isGraphical ([], _)
    = False
isGraphical (graph, edges)
    | top >= length graph
        = True
    = case next of
        [] = False
        _  = or (map isGraphical next)
where
    next = nextProblems [] (decrementGraph graph top, edges) top 1
    top  = firstNonZeroNode graph

nextProblems :: [Problem] Problem Int Int -> [Problem]
nextProblems res problem top pos
    | pos >= length graph
        = res
    | top == pos || isMember (top, pos) edges || graph!!pos == 0
        = nextProblems res problem top (pos+1)
        = nextProblems [(nextGraph, [(top, pos):edges]):res] problem top (pos+1)
where
    (graph, edges) = problem
    nextGraph = decrementGraph graph pos

decrementGraph :: Graph Int -> Graph
decrementGraph graph pos
    = (take pos graph) ++ [graph!!pos - 1] ++ (drop (pos+1) graph)

firstNonZeroNode :: Graph -> Int
firstNonZeroNode graph
    = fst (foldl f (0,True) graph)
where
    f (x,False) _ = (x, False)
    f (x,True ) 0 = (x + 1, True)
    f (x,True ) y = (x, False)

• • • -

(２つめの回答)
よく考えたら、これでいいことが分かった。最初のアイデアをちょっと修正するだけでよかったらしい。

module graph2

import StdEnv

problem =
    //[1, 2, 2, 3, 4]       // True
    [5, 2, 3, 2, 3, 2, 5] // True
    //[4, 4, 4, 2, 2]       // False
    //[1, 1, 4]             // False

Start
    = isGraphical problem


isGraphical :: [Int] -> Bool
isGraphical []
    = True
isGraphical graph
    = case next of
        [] = False
        _  = or (map isGraphical next)
where
    next = nextGraphs (hd graph) (tl graph)

nextGraphs :: Int [Int] -> [[Int]]
nextGraphs n1 ns
    | n1 >  length ns
        = []
    = map (\edges = map (\(x,y) = x - y) (zip (ns,edges))) (makeEdge [] n1 (length ns))
where
    makeEdge :: [Int] Int Int -> [[Int]]
    makeEdge res 0 0
        = [res]
    makeEdge res cnt len
        | cnt > len
            = []
        = edge1 ++ edge2
    where
        edge1
            | cnt > 0
                = makeEdge [1:res] (cnt-1) (len-1)
                = []
        edge2 = makeEdge [0:res] cnt (len-1)