module Knots.PD where
import Knots.Prelude
import qualified Data.Set as Set
data Node a = N a a a a
deriving (Eq,Show,Read,Foldable,Functor)
type PD a = [ Node a ]
indices :: Ord a => PD a -> Set a
indices = foldl (foldl (flip Set.insert)) Set.empty
trefoil :: PD Int
trefoil = [ N 1 2 3 4
, N 4 5 6 1
, N 5 3 2 6
]
data ElMo
= Mult Int Int Int
| Comult Int Int Int
| Neg (ElMo)
deriving (Eq,Show)
resolve_set :: (Ord a) => PD a -> Set (Set a)
resolve_set pd = foldr resolve_one_set (Set.map Set.singleton $ indices pd) pd
resolve_one_set :: Ord a => Node a -> Set (Set a) -> Set (Set a)
resolve_one_set (N i j k l) = mergeParts i j . mergeParts k l
mergeParts :: Ord a => a -> a -> Set (Set a) -> Set (Set a)
mergeParts x y = uncurry Set.insert .
foldl (\(s,p) t ->
if not (Set.null $ Set.intersection s t)
then (s `Set.union` t, p)
else (s, Set.insert t p)) (Set.fromList [x,y], Set.empty)
mirror :: PD a -> PD a
mirror = map (\(N i j k l) -> N l i j k)
switch :: Node a -> Node a
switch (N i j k l) = N i l j k
switch' :: Set Int -> PD a -> PD a
switch' _ [] = []
switch' s (x:xs) | 0 `Set.member` s = switch x : rest
| otherwise = x : rest
where rest = switch' (Set.map (subtract 1) s) xs
replaceBySeveral :: Eq a => a -> [a] -> PD a -> PD a
replaceBySeveral x zs = fst . foldl f ([],zs) where
f (pd,[]) node = (node:pd, zs)
f (pd,(y:ys)) node =
case replace_x_by y node of
Just node' -> ((node' : pd), ys)
Nothing -> ((node : pd), (y:ys))
replace_x_by y (N a b c d)
| x == a = Just (N y b c d)
| x == b = Just (N a y c d)
| x == c = Just (N a b y d)
| x == d = Just (N a b c y)
| otherwise = Nothing
replaceFirst :: Eq a => a -> a -> PD a -> PD a
replaceFirst _ _ [] = []
replaceFirst x y (N a b c d : pd)
| x == a = N y b c d : pd
| x == b = N a y c d : pd
| x == c = N a b y d : pd
| x == d = N a b c y : pd
| otherwise = N a b c d : replaceFirst x y pd
addHopfy :: Ord a => a
-> a
-> a
-> a
-> a
-> PD a
-> PD a
addHopfy x y1 y2 y3 y4 pd = [ N y2 y3 y4 y1, N y3 y2 x y4 ] ++ replaceFirst x y1 pd