patternMinor

"Ringing in the New Year (2011→ 2012)" puzzle

Submitted by: @import:stackexchange-codereview·Mar 10, 2026·

Viewed 0 times

the2011yearnewringing2012puzzle

Problem

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 -> Rational)
, accept :: Bool
, f2 :: (Rational -> 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 -> [Label]
travel t = map rootLabel $
concat $ takeWhile (not . null) $
iterate (\ts -> concat $ map step ts) [t]

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

Solution

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 -> Rational -> Rational
op UL = (+7)
op UR = (*3)
op DL = (/2)
op DR = (subtract 5)

-- Gives the possible candidates for a position
candidates :: Pos -> [(Pos,Lbl)]
candidates = \p -> case p of M -> map (L,) left ++ map (R,) right
                             L -> map (M,) left
                             R -> 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 -> 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 -> Memo -> [St]
solve (viewl -> top@(v,p,l) : St -> [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

Code Snippets

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 -> Rational -> Rational
op UL = (+7)
op UR = (*3)
op DL = (/2)
op DR = (subtract 5)

-- Gives the possible candidates for a position
candidates :: Pos -> [(Pos,Lbl)]
candidates = \p -> case p of M -> map (L,) left ++ map (R,) right
                             L -> map (M,) left
                             R -> 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 -> 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 -> Memo -> [St]
solve (viewl -> top@(v,p,l) :< rest) memo
  | solved top = reverse (retrievePath memo top)
  | otherwise  =
     let new = [ (st,top)
               | (p',l') <- 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 && denominator v' /= 1)
               -- ^ 1) don't divide by two unless the denominator is 1
               , v' < 10000
               -- ^ 2) don't go above 10000
               , st `M.notMember` memo
               -- ^ Don't revisit a state
               ]
     in  solve (rest >< 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 -> St -> [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

Context

StackExchange Code Review Q#9344, answer score: 4

Revisions (0)

No revisions yet.