Skip to content

Instantly share code, notes, and snippets.

@Lysxia Lysxia/Knots.hs
Created Jun 7, 2017

Embed
What would you like to do?
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)
@Lysxia

This comment has been minimized.

Copy link
Owner Author

commented Jun 7, 2017

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.