99 questions/Solutions/92

(***) Von Koch's conjecture

Several years ago I met a mathematician who was intrigued by a problem for which he didn't know a solution. His name was Von Koch, and I don't know whether the problem has been solved since.

https://prof.ti.bfh.ch/hew1/informatik3/prolog/p-99/p92a.gif

Anyway the puzzle goes like this: Given a tree with N nodes (and hence N-1 edges). Find a way to enumerate the nodes from 1 to N and, accordingly, the edges from 1 to N-1 in such a way, that for each edge K the difference of its node numbers equals to K. The conjecture is that this is always possible.

For small trees the problem is easy to solve by hand. However, for larger trees, and 14 is already very large, it is extremely difficult to find a solution. And remember, we don't know for sure whether there is always a solution!

Write a predicate that calculates a numbering scheme for a given tree. What is the solution for the larger tree pictured below?

https://prof.ti.bfh.ch/hew1/informatik3/prolog/p-99/p92b.gif

Solution:

vonKoch edges = do
    let n = length edges + 1
    nodes <- permutations [1..n]
    let nodeArray = listArray (1,n) nodes
    let dists = sort $ map (\(x,y) -> abs (nodeArray ! x - nodeArray ! y)) edges
    guard $ and $ zipWith (/=) dists (tail dists)
    return nodes

This is a simple brute-force solver. This function will permute all assignments of the different node numbers and will then verify that all of the edge differences are different. This code uses the List Monad.

A solution which sorts nodes by their degree and tries to assign values to the nodes in descending order of degree:

import Data.List (sortBy)                                                                                                                                                                                                                   
import Data.Ord (comparing)

vonKoch :: [(Int, Int)] -> [[(Int, Int)]]

vonKoch edges = koch (reverse adj) [] [] []
    where koch [] _ _ vplan = return vplan
          koch ((v, us):vs) eused vused vplan =
            do (vn, eused') <-  [(x, eused')
                                | x <- [1..maxvn],
                                  x `notElem` vused,
                                  let en = map (abs . (x-)) (map (findn vplan) us),
                                  let (eused', f) = foldl (\(l, f) d ->
                                        (d:l, f && d `notElem` l
                                                && 1 <= d && d <= maxen))
                                        (eused, True) en, f]
               koch vs eused' (vn:vused) ((v, vn):vplan)
          maxen = length edges
          maxvn = maxen + 1
          deg x = length $ filter (\(a, b) -> a == x || b == x) edges
          genAdj [] = []
          genAdj (v:vs) = (v, [u | u <- vs, (v, u) `elem` edges || (u, v) `elem` edges]):genAdj vs
          findn vplan u = snd $ head $ filter ((== u) . fst) vplan
          adj = genAdj $ sortBy (comparing deg) [1..maxvn]