### 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
implemented earlier, `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 »