module SubHask.Algebra.Container
where
import Control.Monad
import GHC.Prim
import Control.Monad
import GHC.TypeLits
import qualified Prelude as P
import Prelude (tail,head,last)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import SubHask.Algebra
import SubHask.Algebra.Ord
import SubHask.Category
import SubHask.Compatibility.Base
import SubHask.SubType
import SubHask.Internal.Prelude
import SubHask.TemplateHaskell.Deriving
data Box v = Box
{ smallest :: !v
, largest :: !v
}
deriving (Read,Show)
mkMutable [t| forall v. Box v |]
invar_Box_ordered :: (Lattice v, HasScalar v) => Box v -> Logic v
invar_Box_ordered b = largest b >= smallest b
type instance Scalar (Box v) = Scalar v
type instance Logic (Box v) = Logic v
type instance Elem (Box v) = v
type instance SetElem (Box v) v' = Box v'
instance (Lattice v, Arbitrary v) => Arbitrary (Box v) where
arbitrary = do
v1 <- arbitrary
v2 <- arbitrary
return $ Box (inf v1 v2) (sup v1 v2)
instance (Eq v, HasScalar v) => Eq_ (Box v) where
b1==b2 = smallest b1 == smallest b2
&& largest b1 == largest b2
instance (Lattice v, HasScalar v) => Semigroup (Box v) where
b1+b2 = Box
{ smallest = inf (smallest b1) (smallest b2)
, largest = sup (largest b1) (largest b2)
}
instance (Lattice v, HasScalar v) => Constructible (Box v) where
singleton v = Box v v
instance (Lattice v, HasScalar v) => Container (Box v) where
elem a (Box lo hi) = a >= lo && a <= hi
newtype Jaccard a = Jaccard a
deriveHierarchy ''Jaccard
[ ''Ord
, ''Boolean
, ''Ring
, ''Foldable
]
instance
( Lattice_ a
, Field (Scalar a)
, Normed a
, Logic (Scalar a) ~ Logic a
, Boolean (Logic a)
, HasScalar a
) => Metric (Jaccard a)
where
distance (Jaccard xs) (Jaccard ys) = 1 size (xs && ys) / size (xs || ys)
newtype Hamming a = Hamming a
deriveHierarchy ''Hamming
[ ''Ord
, ''Boolean
, ''Ring
, ''Foldable
]
instance
( Foldable a
, Eq (Elem a)
, Eq a
, ClassicalLogic (Scalar a)
, HasScalar a
) => Metric (Hamming a)
where
distance (Hamming xs) (Hamming ys) =
go (toList xs) (toList ys) 0
where
go [] [] i = i
go xs [] i = i + fromIntegral (size xs)
go [] ys i = i + fromIntegral (size ys)
go (x:xs) (y:ys) i = go xs ys $ i + if x==y
then 0
else 1
distanceUB (Hamming xs) (Hamming ys) dist =
go (toList xs) (toList ys) 0
where
go xs ys tot = if tot > dist
then tot
else go_ xs ys tot
where
go_ (x:xs) (y:ys) i = go xs ys $ i + if x==y
then 0
else 1
go_ [] [] i = i
go_ xs [] i = i + fromIntegral (size xs)
go_ [] ys i = i + fromIntegral (size ys)
newtype Levenshtein a = Levenshtein a
deriveHierarchy ''Levenshtein
[ ''Ord
, ''Boolean
, ''Ring
, ''Foldable
]
instance
( Foldable a
, Eq (Elem a)
, Eq a
, Show a
, HasScalar a
, ClassicalLogic (Scalar a)
, Bounded (Scalar a)
) => Metric (Levenshtein a)
where
distance (Levenshtein xs) (Levenshtein ys) =
fromIntegral $ dist (toList xs) (toList ys)
dist :: Eq a => [a] -> [a] -> Int
dist a b
= last (if lab == 0
then mainDiag
else if lab > 0
then lowers P.!! (lab 1)
else uppers P.!! (1 lab))
where
mainDiag = oneDiag a b (head uppers) (1 : head lowers)
uppers = eachDiag a b (mainDiag : uppers)
lowers = eachDiag b a (mainDiag : lowers)
eachDiag a [] diags = []
eachDiag a (bch:bs) (lastDiag:diags) = oneDiag a bs nextDiag lastDiag : eachDiag a bs diags
where
nextDiag = head (tail diags)
oneDiag a b diagAbove diagBelow = thisdiag
where
doDiag [] b nw n w = []
doDiag a [] nw n w = []
doDiag (ach:as) (bch:bs) nw n w = me : (doDiag as bs me (tail n) (tail w))
where
me = if ach == bch then nw else 1 + min3 (head w) nw (head n)
firstelt = 1 + head diagBelow
thisdiag = firstelt : doDiag a b firstelt diagAbove (tail diagBelow)
lab = size a size b
min3 x y z = if x < y then x else min y z
newtype Uncompensated s = Uncompensated s
deriveHierarchy ''Uncompensated
[ ''Ord
, ''Boolean
, ''Normed
, ''Monoid
, ''Constructible
]
instance Foldable s => Foldable (Uncompensated s) where
uncons (Uncompensated s) = case uncons s of
Nothing -> Nothing
Just (x,xs) -> Just (x, Uncompensated xs)
unsnoc (Uncompensated s) = case unsnoc s of
Nothing -> Nothing
Just (xs,x) -> Just (Uncompensated xs,x)
foldMap f (Uncompensated s) = foldMap f s
foldr f a (Uncompensated s) = foldr f a s
foldr' f a (Uncompensated s) = foldr' f a s
foldr1 f (Uncompensated s) = foldr1 f s
foldr1' f (Uncompensated s) = foldr1' f s
foldl f a (Uncompensated s) = foldl f a s
foldl' f a (Uncompensated s) = foldl' f a s
foldl1 f (Uncompensated s) = foldl1 f s
foldl1' f (Uncompensated s) = foldl1' f s
sum = foldl' (+) zero
newtype Lexical a = Lexical { unLexical :: a }
deriveHierarchy ''Lexical [ ''Eq_, ''Foldable, ''Constructible, ''Monoid ]
instance
(Logic a~Bool
, Ord (Elem a)
, Foldable a
, Eq_ a
) => POrd_ (Lexical a)
where
inf a1 a2 = if a1<a2 then a1 else a2
(Lexical a1)<(Lexical a2) = go (toList a1) (toList a2)
where
go (x:xs) (y:ys) = if x<y
then True
else if x>y
then False
else go xs ys
go [] [] = False
go [] _ = True
go _ [] = False
instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => MinBound_ (Lexical a) where
minBound = Lexical zero
instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Lattice_ (Lexical a) where
sup a1 a2 = if a1>a2 then a1 else a2
(Lexical a1)>(Lexical a2) = go (toList a1) (toList a2)
where
go (x:xs) (y:ys) = if x>y
then True
else if x<y
then False
else go xs ys
go [] [] = False
go [] _ = False
go _ [] = True
instance (Logic a~Bool, Ord (Elem a), Foldable a, Eq_ a) => Ord_ (Lexical a) where
newtype ComponentWise a = ComponentWise { unComponentWise :: a }
deriveHierarchy ''ComponentWise [ ''Eq_, ''Foldable, ''Monoid ]
class (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a
instance (Boolean (Logic a), Logic (Elem a) ~ Logic a) => SimpleContainerLogic a
instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => POrd_ (ComponentWise a) where
inf (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2)
where
go (x:xs) (y:ys) = inf x y:go xs ys
go _ _ = []
instance (SimpleContainerLogic a, Eq_ a, POrd_ (Elem a), Foldable a) => MinBound_ (ComponentWise a) where
minBound = ComponentWise zero
instance (SimpleContainerLogic a, Eq_ a, Lattice_ (Elem a), Foldable a) => Lattice_ (ComponentWise a) where
sup (ComponentWise a1) (ComponentWise a2) = fromList $ go (toList a1) (toList a2)
where
go (x:xs) (y:ys) = sup x y:go xs ys
go xs [] = xs
go [] ys = ys