Perfect matchings and continued fractions

graph.hs

import Data.Ratio
import Data.List
import Control.Monad

-- I'm using two Haskell types for the two vertex types in
-- a bipartite graph.
-- Edges only go from type a to type b.
data BipartiteGraph a b = G [a] [b] [(a, b)]

instance (Show a, Show b) => Show (BipartiteGraph a b) where
    show (G as bs ab) = "G " ++ show as ++ " " ++ show bs
                             ++ " " ++ show ab

-- Find perfect matchings
-- Naive algorithm.
-- It picks a vertex and an edge attached to it
-- and then counts the matchings in the rest of the graph.
-- (I could just pick edges instead of picking a vertex first
-- but this code mutated from something slightly different.)
perfect :: (Eq a, Eq b, Show a, Show b) =>
           BipartiteGraph a b -> [[(a, b)]]
perfect g@(G (a:as) bs ab) =
    do
        b <- map snd $ filter ((a ==) . fst) ab
        guard $ b `elem` bs
        let bs' = delete b bs
        r <- perfect (G as bs' ab)
        return $ (a,b) : r
perfect (G [] _ _) = [[]]

-- Add tile to snake graph.
-- The key to these functions is that at any moment there
-- is a "front" of three vertices that new tiles can attach
-- to. These three vertices have types a, b, a or types
-- b, a, b. So there are two zig functions and two zag
-- functions.
zig_aba :: (BipartiteGraph a b, (a, b, a)) -> b -> a ->
           (BipartiteGraph a b, (b, a, b))
zig_aba (G va vb e, (a0, b1, _)) u v =
    (G (v : va) (u : vb) ((a0, u) : (v, b1) : (v, u) : e), (u, v, b1))

zig_bab :: (BipartiteGraph a b, (b, a, b)) -> a -> b ->
           (BipartiteGraph a b, (a, b, a))
zig_bab (G va vb e, (b0, a1, _)) u v =
    (G (u : va) (v : vb) ((u, b0) : (u, v) : (a1, v) : e), (u, v, a1))

zag_aba :: (BipartiteGraph a b, (a, b, a)) -> a -> b ->
           (BipartiteGraph a b, (b, a, b))
zag_aba (G va vb e, (_, b1, a2)) u v =
    (G (u : va) (v : vb) ((a2, v) : (u, b1) : (u, v) : e), (b1, u, v))

zag_bab :: (BipartiteGraph a b, (b, a, b)) -> b -> a ->
           (BipartiteGraph a b, (a, b, a))
zag_bab (G va vb e, (_, a1, b2)) u v =
    (G (v : va) (u : vb) ((a1, u) : (v, b2) : (v, u) : e), (a1, u, v))

-- Build entire snake graph.
zigzag_aba [] (g, _) _ = g
zigzag_aba [1] (g, _) _ = g
zigzag_aba (0 : ns) gaba i = zagzig_aba ns gaba i
zigzag_aba (n : ns) gaba i =
    zagzig_bab (n-1 : ns) (zig_aba gaba i (i+1)) (i+2)

zigzag_bab [] (g, _) _ = g
zigzag_bab [1] (g, _) _ = g
zigzag_bab (0 : ns) gbab i = zagzig_bab ns gbab i
zigzag_bab (n : ns) gbab i =
    zagzig_aba (n-1 : ns) (zig_bab gbab i (i+1)) (i+2)

zagzig_aba [] (g, _) _ = g
zagzig_aba [1] (g, _) _ = g
zagzig_aba (0 : ns) gaba i = zigzag_aba ns gaba i
zagzig_aba (n : ns) gaba i =
    zigzag_bab (n-1 : ns) (zag_aba gaba i (i+1)) (i+2)

zagzig_bab [] (g, _) _ = g
zagzig_bab [1] (g, _) _ = g
zagzig_bab (0 : ns) gbab i = zigzag_bab ns gbab i
zagzig_bab (n : ns) gbab i =
    zigzag_aba (n-1 : ns) (zag_bab gbab i (i+1)) (i+2)

-- Build entire snake graph from continued fraction using
-- graph 0---1 as "seed".
seed = G [0] [1] [(0, 1)]
g frac = zigzag_aba frac (seed, (0, 1, undefined)) 2

continued :: [Integer] -> Ratio Integer
continued [a] = fromInteger a
continued (a : as) = fromInteger a+1/continued as

main = do
    let frac = [3]
    print $ g frac
    let n = length $ perfect $ g frac
    let d = length $ perfect $ g (tail frac)
    print $ continued frac
    print (n, d)