The Kauffman Bracket using Haskell

Here's a program to compute the Kauffman Bracket of a knot using Haskell, written by Dylan Thurston. The required imports are at Media:PreludeBase.lhs (File:PreludeBase.lhs), Media:NumPrelude.lhs (File:NumPrelude.lhs), Media:VectorSpace.lhs (File:VectorSpace.lhs), Media:Polynomial.lhs (File:Polynomial.lhs)).

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)