module Math.Spline.Knots
( Knots
, knot, multipleKnot
, mkKnots, fromList
, knots, numKnots
, toList, distinctKnots, numDistinctKnots
, knotMultiplicity, setKnotMultiplicity
, knotDomain
) where
import Prelude hiding (sum)
import Data.Foldable (Foldable(foldMap), sum)
import qualified Data.Map as M
import Data.Monoid (Monoid(..))
import Data.Maybe (fromMaybe)
data Knots a = Knots !Int (M.Map a Int) deriving (Eq, Ord)
instance Show a => Show (Knots a) where
showsPrec p ks@(Knots 1 _) = showParen (p > 10)
( showString "knot "
. showsPrec 11 (head $ knots ks)
)
showsPrec p ks = showParen (p > 10)
( showString "mkKnots "
. showsPrec 11 (knots ks)
)
instance (Ord a) => Monoid (Knots a) where
mempty = Knots 0 M.empty
mappend (Knots n1 v1) (Knots n2 v2) =
Knots (n1 + n2) (M.filter (/=0) (M.unionWith (+) v1 v2))
instance Foldable Knots where
foldMap f = foldMap f . knots
knot :: Ord a => a -> Knots a
knot x = multipleKnot x 1
multipleKnot :: Ord a => a -> Int -> Knots a
multipleKnot k n
| n <= 0 = Knots 0 (M.empty)
| otherwise = Knots n (M.singleton k n)
mkKnots :: (Ord a) => [a] -> Knots a
mkKnots ks = fromList (map (\k -> (k,1)) ks)
fromList :: (Ord k) => [(k, Int)] -> Knots k
fromList ks = Knots (sum kMap) kMap
where kMap = M.fromListWith (+) (filter ((>0).snd) ks)
toList :: Knots k -> [(k, Int)]
toList (Knots _ ks) = M.toList ks
numKnots :: Knots t -> Int
numKnots (Knots n _) = n
numDistinctKnots :: Knots t -> Int
numDistinctKnots (Knots _ ks) = M.size ks
knots :: Knots t -> [t]
knots (Knots _ ks) = concat [replicate n k | (k,n) <- M.toAscList ks]
distinctKnots :: Knots t -> [t]
distinctKnots (Knots _ ks) = M.keys ks
knotMultiplicity :: (Ord k) => k -> Knots k -> Int
knotMultiplicity k (Knots _ ks) = fromMaybe 0 (M.lookup k ks)
setKnotMultiplicity :: Ord k => k -> Int -> Knots k -> Knots k
setKnotMultiplicity k n (Knots m ks)
| n <= 0 = Knots (m n') (M.delete k ks)
| otherwise = Knots (m + n n') (M.insert k n ks)
where
n' = knotMultiplicity k (Knots m ks)
knotDomain :: Knots a -> Int -> Maybe (a,a)
knotDomain ks@(Knots n _) p
| n > 2*p = Just (head (drop p kts), head (drop p (reverse kts)))
| otherwise = Nothing
where
kts = knots ks