Problem 92: Von Koch’s conjecture
A brute-force solution checks all node numberings (i.e. permutations of [1, n]) and keeps those that satisfy the conjectured property. The conjecture is that for every tree, there is at least one such numbering.
import Data.List (nub, permutations, sort) import Data.Array vonkoch edges = filter conjecture nodes where -- The conjecture involves trees, so the number of edges is the number of vertices -- minus one: n = length edges + 1 nodes = permutations [1..n] conjecture numbering = dists == nub dists where node_array = listArray (1, n) numbering dists = sort $ map (\(x, y) -> abs (node_array ! x - node_array ! y)) edges
The last line is the meat of it, really: it computes the differences for all edges, under a numbering / permutation. There must be 0 duplicates in that list of differences, which is equivalent to requiring that all pairs of differences are not equal (as it appears on other solutions).
Problem 93: An arithmetic puzzle
This reminded me a lot of similar undergrad assignments. Let’s get the boilerplate out of the way:
import Data.Maybe import Data.List import Data.Hashable import Data.HashMap.Lazy type Equation = (Expression, Expression) data Expression = Const Integer | Binary Expression Operator Expression deriving (Eq, Show) data Operator = Plus | Minus | Multiply | Divide deriving (Bounded, Eq, Enum, Show) -- I just wanted to use the hash map from unordered-containers, really. -- To use with HashMap we can just convert to an Int and use the existing Hashable -- instance: instance Hashable Operator where hashWithSalt = hashUsing fromEnum type Value = Rational
Now that’s out of the way, let’s focus on the solution:
-- The `puzzle` function will be given the list of integers, and produce all the -- equations: puzzle :: [Integer] -> [Equation] puzzle ns | length ns > 1 = equations ns | otherwise = error "can't form an equation with less than 2 numbers!" -- Helper to give us all the non-empty partitions of a list: splits :: (Eq a) => [a] -> [([a], [a])] splits xs = Data.List.filter (\(x, y) -> x /=  && y /= ) (zip (inits xs) (tails xs)) -- We form equations by partitioning the numbers in all possible ways, and then producing -- all possible expressions from each partition: equations :: [Integer] -> [Equation] equations ns = [(l, r) | (ns1, ns2) <- splits ns, (l, v1) <- expressions ns1, (r, v2) <- expressions ns2, v1 == v2] -- How do we form an expression? By inserting operators between all possible partitions of -- our list of numbers, recursively, of course! expressions :: [Integer] -> [(Expression, Value)] expressions [n] = [(Const n, fromInteger n)] expressions ns = [ (Binary e1 op e2, v) | (ns1, ns2) <- splits ns, (e1, v1) <- expressions ns1, (e2, v2) <- expressions ns2, op <- [minBound..maxBound], not (right_associative op e2), v <- maybeToList (apply op v1 v2)] -- Applying an operator to obtain a value might fail (e.g. division by zero), so we will -- use Maybe to handle it. Thus, the guard above will only produce values `v` which do not -- contain a division by zero! Neat! apply :: Operator -> Value -> Value -> Maybe Value apply Plus x y = Just (x + y) apply Minus x y = Just (x - y) apply Multiply x y = Just (x * y) apply Divide x 0 = Nothing apply Divide x y = Just (x / y) -- expr OP (expr OP expr) == (expr OP expr) OP expr -- Only applies on a few cases, phew: right_associative :: Operator -> Expression -> Bool right_associative Plus (Binary _ Plus _) = True right_associative Plus (Binary _ Minus _) = True right_associative Multiply (Binary _ Multiply _) = True right_associative Multiply (Binary _ Divide _) = True right_associative _ _ = False
With that part done, now we need to produce a legible representation of an equation. We’ll start by defining operator precedence and “names”:
opname = fromList [(Plus, " + "), (Minus, " - "), (Multiply, " * "), (Divide, " / ")] opprec = fromList [(Plus, 2), (Minus, 2), (Multiply, 1), (Divide, 1)]
It seems reasonable to produce a
showS function for this purpose..
show_equation :: Equation -> ShowS show_equation (l, r) = show_expression 0 l . showString " = " . show_expression 0 r show_expression :: Int -> Expression -> ShowS show_expression _ (Const n) = shows n show_expression prec (Binary e1 op e2) = showParen (prec > oper_prec) $ show_expression oper_prec e1 . showString (opname ! op) . show_expression (oper_prec + 1) e2 where oper_prec = opprec ! op
..which we will use by concatenating everything to the empty string:
main = mapM_ print $ Data.List.map (flip show_equation "") $ puzzle [2, 3, 5, 7, 11]
Problem 94: K-regular simple graphs with N nodes
In this solution, we’ll use the graph representations (and conversion functions) we
combinations from problem 26, and
canon from problem 85. Then we
can begin searching for k-regular graphs of order n:
regular :: Int -> Int -> [Graph Int] -- A k-regular graph of order n can only exist iff n > k and n*k is even: regular n k | odd (n * k) =  | otherwise = nub_canonical . (filter (test_degrees k)) $ candidates where candidates = [Graph [1..n] edges | edges <- combinations (n*k `div` 2) possible_edges] possible_edges = [(x, y) | x <- [1..n], y <- [(x+1)..n]] -- Test if all nodes of a graph have degree equal to k: test_degrees k (Graph vs es) = all (== k) (map degree vs) where degree v = length $ filter (\(x, y) -> x == v || y == v) es -- Filter out the isomorphic graphs. Remember that isomorphic graphs have the same -- canonical representation: nub_canonical :: (Enum a, Eq a, Ord a) => [Graph a] -> [Graph a] nub_canonical = nubBy ((==) `on` (canon . graph_to_adj))
Fairly straightforward based on the mathematical definitions, really. Not a lot to explain here (I think?).
Problem 95: English number words
This seemed almost too easy:
full_words :: Integer -> String full_words n = concat $ intersperse "-" [ digits !! digitToInt d | d <- show n] where digits = ["zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine"]
Problem 96: Syntax checker
Let’s follow the state machine with some inline comments:
identifier :: String -> Bool -- The empty string is not a valid identifier: identifier  = False -- Valid identifiers begin with a letter, and are followed by either.. identifier (c : cs) = isLetter c && identifier_part cs where -- the empty string, or identifier_part  = True -- a hyphen which is followed by an alphanumeric string, or identifier_part ('-' : cs) = alphanumeric cs -- an alphanumeric string. identifier_part cs = alphanumeric cs -- An alphanumeric string is not empty, alphanumeric  = False -- and begins with a letter or a digit, followed by an `identifier_part` alphanumeric (c : cs) = isAlphaNum c && identifier_part cs
Up next, sudoku puzzles!« Past Future »