{-# LANGUAGE
      ConstraintKinds,
      DeriveFunctor,
      DeriveFoldable,
      NoImplicitPrelude,
      NoMonomorphismRestriction,
      RebindableSyntax,
      ScopedTypeVariables #-}
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
          ]

-- | ElMo is short for Elementary Morphism, for the building blocks of our
-- matrices.
data ElMo
    = Mult Int Int Int
    | Comult Int Int Int
    | Neg (ElMo)
    deriving (Eq,Show)

--instance Default ElMo where
--    def = Zero 0 0

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 -- ^ Position where to add hopfy
                  -> a -- ^ Fresh name (1)
                  -> a -- ^ Fresh name (2)
                  -> a -- ^ Fresh name (3)
                  -> a -- ^ Fresh name (4)
                  -> 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