"Ringing in the New Year (2011→ 2012)" puzzle
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