"Ringing in the New Year (2011→ 2012)" puzzle I am  trying to solve the puzzle RINGING IN THE NEW YEAR.


  Start at 2011. By moving through the maze and doing any arithmetic operations you encounter, exit the maze with a result of 2012. You may pass through an operation several times, but not twice in a row.
  
  2011  2012


My solution is to construct an breadth first search tree of the graph, and go through it, do the arithmetic operations.

In my windows 7 machine, it takes 29s to get the result.

How to make it better? (Improvement of algorithm or better way of compiling)

module Main where

import Data.Ratio
import Data.Tree

data Label = Label
  { f1     :: (Rational -&gt; Rational)
  , accept :: Bool
  , f2     :: (Rational -&gt; Rational)
  , value  :: Rational
  , disp   :: [String]
  }

initial = Node (Label (const 2011) False (const 2011) 2011 [""])
               [ Node (Label (const 2011) False (+7) 0 ["+7"]) center1
               ]

label1, label2, label3, label4 :: Label
label1 = Label (+7)         False (/2)          0 ["+7", "/2"]
label2 = Label (/2)         False (+7)          0 ["/2", "+7"]
label3 = Label (subtract 5) True  (*3)          0 ["-5", "*3"]
label4 = Label (*3)         True  (subtract 5) 0 ["*3", "-5"]

tree1, tree2, tree3, tree4 :: Tree Label
tree1 = Node label1 center2
tree2 = Node label2 center1
tree3 = Node label3 center4
tree4 = Node label4 center3

center1, center2, center3, center4 :: Forest Label
center1 = [ tree3, tree4, tree2 ]
center2 = [ tree3, tree4, tree1 ]
center3 = [ tree4, tree1, tree2 ]
center4 = [ tree3, tree1, tree2 ]

travel :: Tree Label -&gt; [Label]
travel t = map rootLabel $
                      concat $ takeWhile (not . null) $
                      iterate (\ts -&gt; concat $ map step ts) [t]

step :: Tree Label -&gt; Forest Label
step (Node l sub) = map update sub
  where
    update (Node l' sub') = Node l'{ accept = (accept l') &amp;&amp; ((f1 l') v == 2012)
                                   , value = ((f2 l').(f1 l')) v, disp = disp l ++ disp l'} sub'
    v = value l

main = (print . (\l -&gt; concat (disp l) ++ " = " ++ show (value l))) $ head $ filter accept $ travel initial
I wrote this solution that runs in 0.2 seconds on my computer when compiled. It also does a BFS with memoisation. However, it uses two heuristics: Don't divide by two unless the denominator is 1 and don't go above 10000. A more elegant way would be to use a priority queue that prioritises "states" like these. However, using these heuristics does not guarantee an optimal solution.

As a side note, this question might be better for code review than Stack Overflow.

import Data.Ratio
import Data.Map (Map)
import qualified Data.Map as M
import Data.Sequence hiding (reverse)

-- Left, Middle, or Right
data Pos = L | M | R
 deriving (Eq,Ord,Show)

-- Up/Down Left/Right
data Lbl = UL | UR | DL | DR
 deriving (Eq,Ord,Show)

-- The operators in the labels
op :: Lbl -&gt; Rational -&gt; Rational
op UL = (+7)
op UR = (*3)
op DL = (/2)
op DR = (subtract 5)

-- Gives the possible candidates for a position
candidates :: Pos -&gt; [(Pos,Lbl)]
candidates = \p -&gt; case p of M -&gt; map (L,) left ++ map (R,) right
                             L -&gt; map (M,) left
                             R -&gt; map (M,) right
  where right = [UR,DR]
        left  = [UL,DL]

-- The state is the value, position and the last label (cannot revisit it)
type St = (Rational,Pos,Lbl)

-- The memo map, remembers if a state has been visited before and
-- which was the previos state
type Memo = Map St St

-- Is this a solved state?
solved :: St -&gt; Bool
solved (2012,R,_) = True
solved _          = False

-- The initial state
initSt :: St
initSt = (2011,L,DR)  -- ugly hack, say the last label was DR ;)

-- Solve, with a queue of states to visit and a memo map
solve :: Seq St -&gt; Memo -&gt; [St]
solve (viewl -&gt; top@(v,p,l) :&lt; rest) memo
  | solved top = reverse (retrievePath memo top)
  | otherwise  =
     let new = [ (st,top)
               | (p',l') &lt;- candidates p
               -- ^ Get the candidate locations from here
               , l /= l'
               -- ^ Don't go through the same label twice
               , let st@(v',_,_) = (op l' v,p',l')
               -- ^ Calculate the new state
               -- Two heuristics:
               , not (l == DL &amp;&amp; denominator v' /= 1)
               -- ^ 1) don't divide by two unless the denominator is 1
               , v' &lt; 10000
               -- ^ 2) don't go above 10000
               , st `M.notMember` memo
               -- ^ Don't revisit a state
               ]
     in  solve (rest &gt;&lt; fromList (map fst new))
               -- ^ Enqueue the new states
               (memo `M.union` M.fromList new)
               -- ^ Add these to the memoization

-- Retrieve the path from the memo map
retrievePath :: Memo -&gt; St -&gt; [St]
retrievePath memo st@(v,p,l)
  | st == initSt = [initSt]
  | otherwise    = st : retrievePath memo (memo M.! st)

-- This is the problem with 2011 and 2012
problem = solve (singleton initSt) (M.singleton initSt initSt)

main = print problem