Ringing.hs

{-# LANGUAGE TupleSections #-}
module Ringing where

import Data.List (group, sort, find, intercalate)
import Data.Maybe (catMaybes, fromJust)

data Edge = (Int -> Maybe Int) :> Node
data Node = Node { nid :: Int, exit :: Bool, edges :: [Edge] }

instance Eq Node where
  Node n _ _ == Node n' _ _ = n == n'
instance Ord Node where
  Node n _ _ `compare` Node n' _ _ = n `compare` n'

t x y = Just $ x * y
p x y = Just $ x + y
o x y = if y `mod` x == 0 then Just $ y `div` x else Nothing
m x y = Just $ subtract x y

start, start2, start7, mid2, mid3, mid5, mid7, end3, end5 :: Node
start = Node 0 False [ (p 7) :> mid7
                   , (o 2) :> mid2
                   ]

mid7 = Node 1 False [ (o 2) :> start2
                  , (t 3) :> end3
                  , (m 5) :> end5
                  ]

mid2 = Node 2 False [ (p 7) :> start7
                  , (t 3) :> end3
                  , (m 5) :> end5
                  ]

start2 = Node 3 False [ (p 7) :> mid7 ]

start7 = Node 4 False [ (o 2) :> mid2 ]

end3 = Node 5 True [ (m 5) :> mid5 ]

end5 = Node 6 True [ (t 3) :> mid3 ]

mid5 = Node 7 False [ (p 7) :> start7
                  , (o 2) :> start2
                  , (t 3) :> end3
                  ]

mid3 = Node 8 False [ (p 7) :> start7
                  , (o 2) :> start2
                  , (m 5) :> end5
                  ]

step :: Int -> [Node] -> [(Int, [Node])]
step m ns@(Node _ _ es : _) = catMaybes $ map (\(f :> n) -> fmap (,n:ns) (f m)) es

uniq :: Ord a => [a] -> [a]
uniq = map head . group . sort

stage :: [(Int,[Node])] -> [(Int,[Node])]
stage = uniq . concatMap (uncurry step)

bfs :: String
bfs = (intercalate "." . map (name . nid) . snd $ result) ++ "$id"
  where result = fromJust $ find (\(m,ns) -> m == 2012 && exit (head ns)) search
        search :: [(Int,[Node])]
        search = concat $ iterate stage [(2011,[start])]
        name 0 = "($ 2011)"
        name 1 = "(+7)"
        name 2 = "(/2)"
        name 3 = "(/2)"
        name 4 = "(+7)"
        name 5 = "(*3)"
        name 6 = "(-5)"
        name 7 = "(-5)"
        name 8 = "(*3)"