The Kauffman Bracket using Haskell
From Knot Atlas
Jump to navigationJump to search
Here's a program to compute the Kauffman Bracket of a knot using Haskell, written by Dylan Thurston:
Compute the Jones polynomial, in stupid and more clever ways.
> {-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}
> module Jones
> where
> import Prelude()
> import PreludeBase
> import NumPrelude
> import VectorSpace
> import Polynomial
> data Node a = Cross a a a a | Join a a
> deriving (Eq, Show, Read, Ord)
> instance Functor Node where
> fmap f (Cross a b c d) = Cross (f a) (f b) (f c) (f d)
> fmap f (Join a b) = Join (f a) (f b)
> type PD = [Node Int]
Some simple knots for testing.
> k31 :: PD
> k31 = [Cross 1 4 2 5, Cross 3 6 4 1, Cross 5 2 6 3]
The ring we work over. (Really we should work in Laurent polynomials,
but this is the code I had on hand.)
> type R = Ratio (Poly Rational)
> av, ai :: R
> av = (shiftPoly 1) % 1
> ai = recip av
> kauffman :: PD -> R
> kauffman [] = one
> kauffman (Join a b:pd) | a == b = (-av*av-ai*ai) * kauffman pd
> kauffman (Join a b:pd) | otherwise =
> kauffman (map (fmap (\c -> if (c == a) then b else c)) pd)
> kauffman (Cross a b c d:pd) =
> ai * kauffman (Join a b:Join c d:pd)
> + av * kauffman (Join a d:Join b c:pd)
The required imports are at PreludeBase.lhs (File:PreludeBase.lhs), NumPrelude.lhs (File:NumPrelude.lhs), VectorSpace.lhs (File:VectorSpace.lhs) and at Polynomial.lhs (File:Polynomial.lhs).
