Knots.hs

module Knots where

import Data.Char (chr, ord)
import Data.Foldable (for_)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set

-- See https://en.wikipedia.org/wiki/Combinatorial_map

-- Two special darts at the ends of the curve,
-- and those in the middle are distinctly numbered.
data Dart = Start | Middle Int | End
  deriving (Eq, Ord, Show)

-- A combinatorial map representing a planar graph
-- corresponding to a self-intersecting curve with two ends.
data Graph = Graph
  { vertices :: Map Dart Dart  -- Permutation cycling around vertices.
  , edges :: Map Dart Dart     -- Involution matching darts on the same edge.
  , darts :: Int               -- Number of Middle darts (used to generate IDs for new darts)
  } deriving (Eq, Ord, Show)

-- Trivial graph with no crossings.
singleEdge :: Graph
singleEdge = Graph
  { vertices = Map.fromList [(Start, Start), (End, End)]
  , edges = Map.fromList [(Start, End), (End, Start)]
  , darts = 0
  }

-- Graph with one crossing.
singleLoop :: Graph
singleLoop = crossEnd singleEdge End

-- Find the opposite dart associated to the same edge.
edgeNext :: Graph -> Dart -> Dart
edgeNext Graph{edges=es} d = es Map.! d

-- Find the next dart around the same vertex.
vertexNext :: Graph -> Dart -> Dart
vertexNext Graph{vertices=vs} d = vs Map.! d

-- Find the next dart around the same face.
faceNext :: Graph -> Dart -> Dart
faceNext g = edgeNext g . vertexNext g

-- Find all darts around a face.
face :: Graph -> Dart -> [Dart]
face g d = d : (takeWhile (/= d) . tail . iterate (faceNext g)) d

{- Cross dart 'd'
 -
 - Before
 -
 - >         |
 - >         |
 - >      End|
 - >         .
 - >  d
 - > -----------------
 - >                y
 -
 - After:
 -
 - >         |
 - >         |x
 - >         |
 - >        t|
 - >  d      | u
 - > --------+--------
 - >       w |      y
 - >         |v
 - >         |
 - >      End|
 - >         .
 -
 -}
crossEnd :: Graph -> Dart -> Graph
crossEnd g d = Graph
  { vertices = Map.union newVertex (vertices g)
  , edges = Map.union newEdges (edges g)
  , darts = darts g + 4
  } where
    newVertex = Map.fromList [(t, w), (w, v), (v, u), (u, t)]
    newEdges = Map.fromList [e | (x, y) <- newEdges', e <- [(x, y), (y, x)]]
    newEdges'
      | d == End = [(End, v), (w, t), (u, y)]
      | y == End = [(End, v), (u, t), (w, d)]
      | otherwise = [(d, w), (t, x), (u, y), (v, End)]
    t : u : v : w : _ = fmap Middle [darts g ..]
    x = edgeNext g End
    y = edgeNext g d

-- Try all ways of extending a curve with one crossing.
step :: Graph -> [Graph]
step g = fmap (\d -> crossEnd g d) (face g End)

-- Try all ways of extending a curve with 'c' crossings.
enumerate :: Int -> Graph -> [Graph]
enumerate 0 g = [g]
enumerate c g = step g >>= enumerate (c - 1)

-- Map a curve to an oriented pattern.
classify :: Graph -> [Int]
classify g = go 1 Start Map.empty
  where
    go n d visited =
      let w : x : y : z : _ = iterate (vertexNext g) (edgeNext g d)
      in case () of
        _ | End <- w -> []
          | Just i <- Map.lookup x visited -> i : go n y visited
          | Just i <- Map.lookup z visited -> (- i) : go n y visited
        _ -> n : go (n+1) y (Map.insert y n visited)

-- Map a curve to an unoriented pattern.
classify' :: Graph -> [Int]
classify' = fmap abs . classify

-- Map a curve to an unoriented canonical pattern.
classify'' :: Graph -> [Int]
classify'' = (\x -> min x ((relabel . reverse) x)) . classify'

relabel :: [Int] -> [Int]
relabel xs = go Map.empty 1 xs
  where
    go _ _ [] = []
    go r n (i : is) = case Map.lookup i r of
      Just j -> j : go r n is
      Nothing -> n : go (Map.insert i n r) (n+1) is

-- Show a pattern
showPattern :: [Int] -> String
showPattern = (>>= f)
  where
    f c = [chr (abs (c - 1) + ord 'A')] ++ ['\'' | c < 0]

main :: IO ()
main = do
  for_
    [ length
    , Set.size . Set.fromList . fmap classify
    , Set.size . Set.fromList . fmap classify'
    , Set.size . Set.fromList . fmap classify''
    ] $ \count -> do
    for_ [0 .. 6] $ \i ->
      putStrLn $ show (i + 1) ++ ": " ++ show (count (enumerate i singleLoop))
    putStrLn ""

  for_ (Set.toList . Set.fromList . fmap classify $ enumerate 2 singleLoop) $ \p ->
    putStrLn (showPattern p)

  putStrLn ""

  for_ (Set.toList . Set.fromList . fmap classify' $ enumerate 2 singleLoop) $ \p ->
    putStrLn (showPattern p)

Drawing of these graphs with 2 and 3 crossings. http://imgur.com/a/9bXwV