99 problems in Haskell, 92-96

2015 Nov 16

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 »

Comments:

comments powered by Disqus