diff --git a/semiring-num.cabal b/semiring-num.cabal --- a/semiring-num.cabal +++ b/semiring-num.cabal @@ -1,5 +1,5 @@ name: semiring-num -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Basic semiring class and instances description: Adds a basic semiring class homepage: https://github.com/oisdk/semiring-num @@ -18,8 +18,11 @@ , Data.Semiring.Numeric , Data.Semiring.Free , Test.Semiring + other-modules: Data.Semiring.Infinite + , Data.Semiring.TH build-depends: base >= 4.9 && < 5 , containers >= 0.5 + , template-haskell >= 2.11 default-language: Haskell2010 ghc-options: -Wall @@ -32,6 +35,8 @@ , smallcheck >= 1.1 , doctest >= 0.11 , containers >= 0.5 + , QuickCheck >= 2.8 + , nat-sized-numbers >= 0.1 ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Data/Semiring.hs b/src/Data/Semiring.hs --- a/src/Data/Semiring.hs +++ b/src/Data/Semiring.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} @@ -13,6 +17,12 @@ module Data.Semiring ( Semiring(..) + , StarSemiring(..) + , HasPositiveInfinity(..) + , HasNegativeInfinity(..) + , PositiveInfinite(..) + , NegativeInfinite(..) + , Infinite(..) , Add(..) , Mul(..) , add @@ -21,7 +31,6 @@ , Min(..) ) where - import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) @@ -30,9 +39,6 @@ import Data.Ratio (Ratio) import Numeric.Natural (Natural) -import Data.Set (Set) -import qualified Data.Set as Set - import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import Foreign.C.Types (CChar, CClock, CDouble, CFloat, CInt, @@ -54,9 +60,12 @@ import GHC.Generics (Generic, Generic1) import Data.Typeable (Typeable) - import Foreign.Storable (Storable) +import Data.Semiring.Infinite +import Data.Semiring.TH + + -- | A is like the -- the combination of two 'Data.Monoid.Monoid's. The first -- is called '<+>'; it has the identity element 'zero', and it is @@ -80,161 +89,209 @@ -- -- == Annihilation -- @'zero' '<.>' a = a '<.>' 'zero' = 'zero'@ -class Semiring a where - -- | The identity of '<+>'. - zero :: a - -- | The identity of '<.>'. - one :: a - -- | An associative binary operation, which distributes over '<+>'. - infixl 7 <.> - (<.>) :: a -> a -> a - -- | An associative, commutative binary operation. - infixl 6 <+> - (<+>) :: a -> a -> a - - default zero :: Num a => a - default one :: Num a => a - default (<+>) :: Num a => a -> a -> a - default (<.>) :: Num a => a -> a -> a +-- +-- An ordered semiring follows the laws: +-- @x '<=' y => x '<+>' z '<=' y '<+>' z@ +-- @x '<=' y => x '<+>' z '<=' y '<+>' z@ +-- @'zero' '<=' z '&&' x '<=' y => x '<.>' z '<=' y '<.>' z '&&' z '<.>' x '<=' z '<.>' y@ +class Semiring a where + -- | The identity of '<+>'. + zero + :: a + -- | The identity of '<.>'. + one + :: a + -- | An associative binary operation, which distributes over '<+>'. + infixl 7 <.> + (<.>) :: a -> a -> a + -- | An associative, commutative binary operation. + infixl 6 <+> + (<+>) :: a -> a -> a + default zero :: Num a => a + default one :: Num a => a + default (<+>) :: Num a => a -> a -> a + default (<.>) :: Num a => a -> a -> a + zero = 0 + {-# INLINE zero #-} + one = 1 + {-# INLINE one #-} + (<+>) = (+) + {-# INLINE (<+>) #-} + (<.>) = (*) + {-# INLINE (<.>) #-} - zero = 0 - one = 1 - (<+>) = (+) - (<.>) = (*) +-- | A +-- adds one operation, 'star' to a 'Semiring', such that it follows the +-- law: +-- +-- @'star' x = 'one' '<+>' x '<.>' 'star' x = 'one' '<+>' 'star' x '<.>' x@ +-- +-- For the semiring of types, this is equivalent to a list. When looking +-- at the 'Applicative' and 'Control.Applicative.Alternative' classes as +-- (near-) semirings, this is equivalent to the +-- 'Control.Applicative.many' operation. +-- +-- Another operation, 'plus', can be defined in relation to 'star': +-- +-- @'plus' x = x '<.>' 'star' x@ +-- +-- This should be recognizable as a non-empty list on types, or the +-- 'Control.Applicative.some' operation in +-- 'Control.Applicative.Alternative'. +class Semiring a => + StarSemiring a where + {-# MINIMAL star | plus #-} + star :: a -> a + plus :: a -> a + star x = one <+> plus x + plus x = x <.> star x ------------------------------------------------------------------------ -- Instances ------------------------------------------------------------------------ +type CoerceBinary a b = (a -> a -> a) -> b -> b -> b + instance Semiring Bool where - one = True - zero = False - (<+>) = (||) - (<.>) = (&&) + one = True + zero = False + (<+>) = (||) + (<.>) = (&&) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} -instance Semiring () where - one = () - zero = () - _ <+> _ = () - _ <.> _ = () +instance StarSemiring Bool where + star _ = True + plus = id + {-# INLINE star #-} + {-# INLINE plus #-} -cartProd :: (Ord a, Monoid a) => Set a -> Set a -> Set a -cartProd xs ys = - Set.foldl' (\a x -> - Set.foldl' (flip (Set.insert . mappend x)) a ys) - Set.empty xs +-- | Not lawful. Only for convenience. +instance Semiring a => + Semiring (NegativeInfinite a) where + one = pure one + zero = pure zero + (<+>) = + (coerce :: CoerceBinary (NegativeInfinite (Add a)) (NegativeInfinite a)) + mappend + (<.>) = liftA2 (<.>) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} --- | The 'Set' 'Semiring' is 'Data.Set.union' for '<+>', and a Cartesian --- product for '<.>'. -instance (Ord a, Monoid a) => Semiring (Set a) where - (<.>) = cartProd - (<+>) = Set.union - zero = Set.empty - one = Set.singleton mempty +-- | Not lawful. Only for convenience. +instance Semiring a => + Semiring (PositiveInfinite a) where + one = pure one + zero = pure zero + (<+>) = + (coerce :: CoerceBinary (PositiveInfinite (Add a)) (PositiveInfinite a)) + mappend + (<.>) = liftA2 (<.>) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} +-- | Not lawful. Only for convenience. +instance Semiring a => + Semiring (Infinite a) where + one = pure one + zero = pure zero + (<+>) = (coerce :: CoerceBinary (Infinite (Add a)) (Infinite a)) mappend + (<.>) = liftA2 (<.>) + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance (Eq a, Semiring a) => + StarSemiring (PositiveInfinite a) where + star (PosFinite x) + | x == zero = one + star _ = PositiveInfinity + +instance Semiring () where + one = () + zero = () + _ <+> _ = () + _ <.> _ = () + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + +instance StarSemiring () where + star _ = () + plus _ = () + {-# INLINE star #-} + {-# INLINE plus #-} + -- | A polynomial in /x/ can be defined as a list of its coefficients, -- where the /i/th element is the coefficient of /x^i/. This is the -- semiring for such a list. Adapted from . -instance Semiring a => Semiring [a] where - one = [one] - zero = [] - [] <+> ys = ys - xs <+> [] = xs - (x:xs) <+> (y:ys) = (x <+> y) : (xs <+> ys) - [] <.> _ = [] - _ <.> [] = [] - (x:xs) <.> (y:ys) = - (x <.> y) : (map (x <.>) ys <+> map (<.> y) xs <+> (xs <.> ys)) +instance Semiring a => + Semiring [a] where + one = [one] + zero = [] + [] <+> ys = ys + xs <+> [] = xs + (x:xs) <+> (y:ys) = (x <+> y) : (xs <+> ys) + [] <.> _ = [] + _ <.> [] = [] + (x:xs) <.> (y:ys) = + (x <.> y) : (map (x <.>) ys <+> map (<.> y) xs <+> (xs <.> ys)) ------------------------------------------------------------------------ -- Addition and multiplication newtypes ------------------------------------------------------------------------ - type WrapBinary f a = (a -> a -> a) -> f a -> f a -> f a -- | Monoid under '<+>'. Analogous to 'Data.Monoid.Sum', but uses the -- 'Semiring' constraint, rather than 'Num'. newtype Add a = Add - { getAdd :: a - } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac) + { getAdd :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,Semiring,StarSemiring) -- | Monoid under '<.>'. Analogous to 'Data.Monoid.Product', but uses the -- 'Semiring' constraint, rather than 'Num'. newtype Mul a = Mul - { getMul :: a - } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac) - -instance Functor Add where fmap = coerce - -instance Functor Mul where fmap = coerce - -instance Foldable Add where - foldr = - (coerce :: ((a -> b -> c) -> (b -> a -> c)) - -> (a -> b -> c) -> (b -> Add a -> c) - ) flip - foldl = coerce - foldMap = coerce - length = const 1 - -instance Foldable Mul where - foldr = - (coerce :: ((a -> b -> c) -> (b -> a -> c)) - -> (a -> b -> c) -> (b -> Mul a -> c) - ) flip - foldl = coerce - foldMap = coerce - length = const 1 - -instance Applicative Add where - pure = coerce - (<*>) = - (coerce :: ( (a -> b) -> a -> b) - -> (Add (a -> b) -> Add a -> Add b) - ) ($) - -instance Applicative Mul where - pure = coerce - (<*>) = - (coerce :: ( (a -> b) -> a -> b) - -> (Mul (a -> b) -> Mul a -> Mul b) - ) ($) - -instance Monad Add where (>>=) = flip coerce - -instance Monad Mul where (>>=) = flip coerce - -instance Semiring a => Semigroup (Add a) where - (<>) = (coerce :: WrapBinary Add a) (<+>) - -instance Semiring a => Semigroup (Mul a) where - (<>) = (coerce :: WrapBinary Mul a) (<.>) + { getMul :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable + ,Semiring,StarSemiring) -instance Semiring a => Monoid (Add a) where - mempty = Add zero - mappend = (<>) +instance Semiring a => + Semigroup (Add a) where + (<>) = (coerce :: WrapBinary Add a) (<+>) + {-# INLINE (<>) #-} -instance Semiring a => Monoid (Mul a) where - mempty = Mul one - mappend = (<>) +instance Semiring a => + Semigroup (Mul a) where + (<>) = (coerce :: WrapBinary Mul a) (<.>) + {-# INLINE (<>) #-} -instance Semiring a => Semiring (Add a) where - zero = Add zero - one = Add one - (<+>) = (coerce :: WrapBinary Add a) (<+>) - (<.>) = (coerce :: WrapBinary Add a) (<.>) +instance Semiring a => + Monoid (Add a) where + mempty = Add zero + mappend = (<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} -instance Semiring a => Semiring (Mul a) where - zero = Mul zero - one = Mul one - (<+>) = (coerce :: WrapBinary Mul a) (<+>) - (<.>) = (coerce :: WrapBinary Mul a) (<.>) +instance Semiring a => + Monoid (Mul a) where + mempty = Mul one + mappend = (<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} ------------------------------------------------------------------------ -- Addition and multiplication folds ------------------------------------------------------------------------ - -- | Takes the sum of the elements of a 'Foldable'. Analogous to 'sum' -- on numbers, or 'or' on 'Bool's. -- @@ -246,7 +303,9 @@ -- True -- >>> add [True, undefined] -- True -add :: (Foldable f, Semiring a) => f a -> a +add + :: (Foldable f, Semiring a) + => f a -> a add = getAdd . foldMap Add -- | Takes the product of the elements of a 'Foldable'. Analogous to @@ -260,13 +319,14 @@ -- False -- >>> mul [False, undefined] -- False -mul :: (Foldable f, Semiring a) => f a -> a +mul + :: (Foldable f, Semiring a) + => f a -> a mul = getMul . foldMap Mul ------------------------------------------------------------------------ -- Ord wrappers ------------------------------------------------------------------------ - -- | The "" or -- min-plus semiring. It is a semiring where: -- @@ -283,11 +343,9 @@ -- Taking ∞ to be 'maxBound' would break the above law. Using 'Nothing' -- to represent it follows the law. newtype Min a = Min - { getMin :: Maybe a - } deriving (Eq, Read, Show, Generic, Generic1, Functor, Foldable - ,Typeable) - -- } deriving (Eq, Ord, Read, Show, Generic, Generic1, Functor - -- ,Foldable) + { getMin :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) -- | The "" -- or max-plus semiring. It is a semiring where: @@ -305,103 +363,91 @@ -- Taking -∞ to be 'minBound' would break the above law. Using 'Nothing' -- to represent it follows the law. newtype Max a = Max - { getMax :: Maybe a - } deriving (Eq, Read, Show, Generic, Generic1, Functor, Foldable - ,Typeable) - -instance Ord a => Ord (Min a) where - compare (Min Nothing) (Min Nothing) = EQ - compare (Min Nothing) _ = LT - compare _ (Min Nothing) = GT - compare (Min (Just x)) (Min (Just y)) = compare x y - -instance Ord a => Ord (Max a) where - compare (Max Nothing) (Max Nothing) = EQ - compare (Max Nothing) _ = GT - compare _ (Max Nothing) = LT - compare (Max (Just x)) (Max (Just y)) = compare x y - - -instance Applicative Max where - pure = (coerce :: (a -> Maybe a) -> (a -> Max a)) Just - (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b) - -> Max (a -> b) -> Max a -> Max b - ) (<*>) - -instance Applicative Min where - pure = (coerce :: (a -> Maybe a) -> (a -> Min a)) Just - (<*>) = (coerce :: (Maybe (a -> b) -> Maybe a -> Maybe b) - -> Min (a -> b) -> Min a -> Min b - ) (<*>) - -instance Monad Max where - (>>=) = (coerce :: (Maybe a -> (a -> Maybe b) -> Maybe b) - -> Max a -> (a -> Max b) -> Max b - ) (>>=) - -instance Monad Min where - (>>=) = (coerce :: (Maybe a -> (a -> Maybe b) -> Maybe b) - -> Min a -> (a -> Min b) -> Min b - ) (>>=) + { getMax :: a + } deriving (Eq,Ord,Read,Show,Bounded,Generic,Generic1,Num,Enum,Typeable + ,Storable,Fractional,Real,RealFrac,Functor,Foldable,Traversable) -instance Ord a => Semigroup (Max a) where - Max Nothing <> x = x - x <> Max Nothing = x - Max (Just x) <> Max (Just y) = (Max . Just) (max x y) +instance Ord a => + Semigroup (Max a) where + (<>) = (coerce :: WrapBinary Max a) max + {-# INLINE (<>) #-} -instance Ord a => Semigroup (Min a) where - Min Nothing <> x = x - x <> Min Nothing = x - Min (Just x) <> Min (Just y) = (Min . Just) (min x y) +instance Ord a => + Semigroup (Min a) where + (<>) = (coerce :: WrapBinary Min a) min + {-# INLINE (<>) #-} --- | >>> (getMax . foldMap pure) [1..10] --- Just 10 -instance Ord a => Monoid (Max a) where - mempty = Max Nothing - mappend = (<>) +-- | >>> (getMax . foldMap Max) [1..10] +-- 10.0 +instance (Ord a, HasNegativeInfinity a) => + Monoid (Max a) where + mempty = Max negativeInfinity + mappend = (<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} --- | >>> (getMin . foldMap pure) [1..10] --- Just 1 -instance Ord a => Monoid (Min a) where - mempty = Min Nothing - mappend = (<>) +-- | >>> (getMin . foldMap Min) [1..10] +-- 1.0 +instance (Ord a, HasPositiveInfinity a) => + Monoid (Min a) where + mempty = Min positiveInfinity + mappend = (<>) + {-# INLINE mempty #-} + {-# INLINE mappend #-} -instance (Semiring a, Ord a) => Semiring (Max a) where - (<+>) = mappend - zero = mempty - (<.>) = liftA2 (<+>) - one = Max (Just zero) +instance (Semiring a, Ord a, HasNegativeInfinity a) => + Semiring (Max a) where + (<+>) = mappend + zero = mempty + (<.>) = (coerce :: WrapBinary Max a) (<+>) + one = Max zero + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} -instance (Semiring a, Ord a) => Semiring (Min a) where - (<+>) = mappend - zero = mempty - (<.>) = liftA2 (<+>) - one = Min (Just zero) +instance (Semiring a, Ord a, HasPositiveInfinity a) => + Semiring (Min a) where + (<+>) = mappend + zero = mempty + (<.>) = (coerce :: WrapBinary Min a) (<+>) + one = Min zero + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} -instance Bounded a => Bounded (Min a) where - maxBound = Min (Just maxBound) - minBound = Min Nothing +instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) => + StarSemiring (Max a) where + star (Max x) + | x > zero = Max positiveInfinity + | otherwise = Max zero -instance Bounded a => Bounded (Max a) where - minBound = Max (Just minBound) - maxBound = Max Nothing +instance (Semiring a, Ord a, HasPositiveInfinity a, HasNegativeInfinity a) => + StarSemiring (Min a) where + star (Min x) + | x < zero = Min negativeInfinity + | otherwise = Min zero ------------------------------------------------------------------------ -- (->) instance ------------------------------------------------------------------------ - -- | The @(->)@ instance is analogous to the one for 'Monoid'. -instance Semiring b => Semiring (a -> b) where - zero = const zero - one = const one - (f <+> g) x = f x <+> g x - (f <.> g) x = f x <.> g x +instance Semiring b => + Semiring (a -> b) where + zero = const zero + one = const one + (f <+> g) x = f x <+> g x + (f <.> g) x = f x <.> g x +instance StarSemiring b => + StarSemiring (a -> b) where + star f x = star (f x) + plus f x = plus (f x) ------------------------------------------------------------------------ -- Endo instance ------------------------------------------------------------------------ - -- | This is /not/ a true semiring. In particular, it requires the -- underlying monoid to be commutative, and even then, it is only a near -- semiring. It is, however, extremely useful. For instance, this type: @@ -410,28 +456,67 @@ -- -- Is a valid encoding of church numerals, with addition and -- multiplication being their semiring variants. -instance Monoid a => Semiring (Endo a) where - zero = Endo mempty - Endo f <+> Endo g = Endo (f `mappend` g) - one = mempty - (<.>) = mappend +instance Monoid a => + Semiring (Endo a) where + zero = Endo mempty + Endo f <+> Endo g = Endo (f `mappend` g) + one = mempty + (<.>) = mappend + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} +instance (Monoid a, Eq a) => + StarSemiring (Endo a) where + star (Endo f) = Endo converge + where + converge x = go x + where + go inp = + mappend + x + (if inp == next + then inp + else go next) + where + next = mappend x (f inp) + ------------------------------------------------------------------------ -- Instances for Bool wrappers ------------------------------------------------------------------------ - instance Semiring Any where - (<+>) = coerce (||) - zero = Any False - (<.>) = coerce (&&) - one = Any True + (<+>) = coerce (||) + zero = Any False + (<.>) = coerce (&&) + one = Any True + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} +instance StarSemiring Any where + star _ = Any True + plus = id + {-# INLINE star #-} + {-# INLINE plus #-} + instance Semiring All where - (<+>) = coerce (||) - zero = All False - (<.>) = coerce (&&) - one = All True + (<+>) = coerce (||) + zero = All False + (<.>) = coerce (&&) + one = All True + {-# INLINE zero #-} + {-# INLINE one #-} + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} +instance StarSemiring All where + star _ = All True + plus = id + {-# INLINE star #-} + {-# INLINE plus #-} + ------------------------------------------------------------------------ -- Boring instances ------------------------------------------------------------------------ @@ -502,38 +587,6 @@ ------------------------------------------------------------------------ -- Very boring instances ------------------------------------------------------------------------ -instance (Semiring a, Semiring b) => Semiring (a,b) where - zero = (zero, zero) - (a1,b1) <+> (a2,b2) = - (a1 <+> a2, b1 <+> b2) - one = (one, one) - (a1,b1) <.> (a2,b2) = - (a1 <.> a2, b1 <.> b2) -instance (Semiring a, Semiring b, Semiring c) => Semiring (a,b,c) where - zero = (zero, zero, zero) - (a1,b1,c1) <+> (a2,b2,c2) = - (a1 <+> a2, b1 <+> b2, c1 <+> c2) - one = (one, one, one) - (a1,b1,c1) <.> (a2,b2,c2) = - (a1 <.> a2, b1 <.> b2, c1 <.> c2) - -instance (Semiring a, Semiring b, Semiring c, Semiring d) => Semiring (a,b,c,d) where - zero = (zero, zero, zero, zero) - (a1,b1,c1,d1) <+> (a2,b2,c2,d2) = - (a1 <+> a2, b1 <+> b2, - c1 <+> c2, d1 <+> d2) - one = (one, one, one, one) - (a1,b1,c1,d1) <.> (a2,b2,c2,d2) = - (a1 <.> a2, b1 <.> b2, c1 <.> c2, d1 <.> d2) - -instance (Semiring a, Semiring b, Semiring c, Semiring d, Semiring e) => - Semiring (a,b,c,d,e) where - zero = (zero, zero, zero, zero, zero) - (a1,b1,c1,d1,e1) <+> (a2,b2,c2,d2,e2) = - (a1 <+> a2, b1 <+> b2, c1 <+> c2, - d1 <+> d2, e1 <+> e2) - one = (one, one, one, one, one) - (a1,b1,c1,d1,e1) <.> (a2,b2,c2,d2,e2) = - (a1 <.> a2, b1 <.> b2, c1 <.> c2, - d1 <.> d2, e1 <.> e2) +$(traverse semiringIns [2..9]) +$(traverse starIns [2..9]) diff --git a/src/Data/Semiring/Infinite.hs b/src/Data/Semiring/Infinite.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semiring/Infinite.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Semiring.Infinite + ( HasPositiveInfinity(..) + , HasNegativeInfinity(..) + , NegativeInfinite(..) + , PositiveInfinite(..) + , Infinite(..) + ) where + +import Foreign.C.Types (CDouble, CFloat) + +import Control.Applicative (liftA2) +import Data.Typeable (Typeable) +import GHC.Generics (Generic, Generic1) + +import Data.Word (Word8) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (Storable, alignment, peek, peekByteOff, + poke, pokeByteOff, sizeOf) + +import Data.Coerce +import Data.Monoid + +class HasPositiveInfinity a where + positiveInfinity :: a + default positiveInfinity :: RealFloat a => a + positiveInfinity = 1/0 + +class HasNegativeInfinity a where + negativeInfinity :: a + default negativeInfinity :: RealFloat a => a + negativeInfinity = negate (1/0) + +instance HasPositiveInfinity Double +instance HasNegativeInfinity Double +instance HasPositiveInfinity Float +instance HasNegativeInfinity Float +instance HasPositiveInfinity CDouble +instance HasNegativeInfinity CDouble +instance HasPositiveInfinity CFloat +instance HasNegativeInfinity CFloat + +data NegativeInfinite a + = NegativeInfinity + | NegFinite !a + deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor + ,Foldable, Traversable) + +data PositiveInfinite a + = PosFinite !a + | PositiveInfinity + deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor + ,Foldable, Traversable) + +instance Applicative NegativeInfinite where + pure = NegFinite + {-# INLINE pure #-} + NegFinite f <*> NegFinite x = NegFinite (f x) + _ <*> _ = NegativeInfinity + {-# INLINE (<*>) #-} + +instance Applicative PositiveInfinite where + pure = PosFinite + {-# INLINE pure #-} + PosFinite f <*> PosFinite x = PosFinite (f x) + _ <*> _ = PositiveInfinity + {-# INLINE (<*>) #-} + +data Infinite a + = Negative + | Finite !a + | Positive + deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor + ,Foldable, Traversable) + +instance Applicative Infinite where + pure = Finite + {-# INLINE pure #-} + Finite f <*> Finite x = Finite (f x) + Negative <*> Negative = Positive + Negative <*> _ = Negative + _ <*> Negative = Negative + _ <*> _ = Positive + {-# INLINE (<*>) #-} + +instance Bounded a => Bounded (NegativeInfinite a) where + {-# INLINE minBound #-} + {-# INLINE maxBound #-} + minBound = NegativeInfinity + maxBound = pure maxBound + +instance Bounded a => Bounded (PositiveInfinite a) where + {-# INLINE minBound #-} + {-# INLINE maxBound #-} + minBound = pure minBound + maxBound = PositiveInfinity + +instance Bounded (Infinite a) where + {-# INLINE minBound #-} + {-# INLINE maxBound #-} + minBound = Negative + maxBound = Positive + +instance HasNegativeInfinity (NegativeInfinite a) where + {-# INLINE negativeInfinity #-} + negativeInfinity = NegativeInfinity + +instance HasPositiveInfinity (PositiveInfinite a) where + {-# INLINE positiveInfinity #-} + positiveInfinity = PositiveInfinity + +instance HasNegativeInfinity (Infinite a) where + {-# INLINE negativeInfinity #-} + negativeInfinity = Negative + +instance HasPositiveInfinity (Infinite a) where + {-# INLINE positiveInfinity #-} + positiveInfinity = Positive + +instance (Enum a, Bounded a, Eq a) => Enum (NegativeInfinite a) where + succ = foldr (const . pure . succ) (pure minBound) + pred NegativeInfinity = error "Predecessor of negative infinity" + pred (NegFinite x) | x == minBound = NegativeInfinity + | otherwise = NegFinite (pred x) + toEnum 0 = NegativeInfinity + toEnum n = NegFinite (toEnum (n-1)) + fromEnum = foldr (const . succ . fromEnum) 0 + enumFrom NegativeInfinity = NegativeInfinity : map pure [minBound..] + enumFrom (NegFinite x) = map pure [x..] + +maxBoundOf :: Bounded a => f a -> a +maxBoundOf _ = maxBound + +instance (Enum a, Bounded a, Eq a) => Enum (PositiveInfinite a) where + pred = foldr (const . pure . pred) (pure maxBound) + succ PositiveInfinity = error "Successor of positive infinity" + succ (PosFinite x) | x == maxBound = PositiveInfinity + | otherwise = PosFinite (succ x) + toEnum n + | n == toEnum (maxBoundOf PositiveInfinity) + 1 = PositiveInfinity + | otherwise = PosFinite (toEnum n) + fromEnum p@PositiveInfinity = fromEnum (maxBoundOf p) + 1 + fromEnum (PosFinite x) = fromEnum x + enumFrom PositiveInfinity = [PositiveInfinity] + enumFrom (PosFinite x) = map pure [x..] ++ [PositiveInfinity] + +instance (Enum a, Bounded a, Eq a) => Enum (Infinite a) where + pred Negative = error "Predecessor of negative infinity" + pred Positive = Finite maxBound + pred (Finite x) | x == minBound = Negative + | otherwise = Finite (pred x) + succ Negative = Finite minBound + succ Positive = error "Successor of positive infinity" + succ (Finite x) | x == maxBound = Positive + | otherwise = Finite (succ x) + toEnum 0 = Negative + toEnum n | n == toEnum (maxBoundOf Positive) + 2 = Positive + | otherwise = Finite (toEnum (n-1)) + fromEnum Negative = 0 + fromEnum (Finite x) = fromEnum x + 1 + fromEnum p@Positive = fromEnum (maxBoundOf p) + 1 + enumFrom Positive = [Positive] + enumFrom Negative = Negative : map pure [minBound..] ++ [Positive] + enumFrom (Finite x) = map pure (enumFrom x) ++ [Positive] + +instance Monoid a => Monoid (NegativeInfinite a) where + {-# INLINE mempty #-} + {-# INLINE mappend #-} + mempty = pure mempty + mappend = liftA2 mappend + +instance Monoid a => Monoid (PositiveInfinite a) where + {-# INLINE mempty #-} + {-# INLINE mappend #-} + mempty = pure mempty + mappend = liftA2 mappend + +instance Monoid a => Monoid (Infinite a) where + {-# INLINE mempty #-} + {-# INLINE mappend #-} + mempty = pure mempty + Negative `mappend` Positive = Positive + Positive `mappend` Negative = Positive + Finite x `mappend` Finite y = pure (x `mappend` y) + Negative `mappend` _ = Negative + Positive `mappend` _ = Positive + _ `mappend` y = y + +instance Num a => Num (NegativeInfinite a) where + fromInteger = pure . fromInteger + (+) = liftA2 (+) + (*) = liftA2 (*) + abs = fmap abs + signum = foldr (const . pure . signum) (-1) + (-) = liftA2 (-) + +instance Num a => Num (PositiveInfinite a) where + fromInteger = pure . fromInteger + (+) = liftA2 (+) + (*) = liftA2 (*) + abs = fmap abs + signum = foldr (const . pure . signum) (-1) + (-) = liftA2 (-) + +type CoerceBinary a b = (a -> a -> a) -> (b -> b -> b) + +instance Num a => Num (Infinite a) where + fromInteger = Finite . fromInteger + (+) = (coerce :: CoerceBinary (Infinite (Sum a)) (Infinite a)) mappend + (*) = liftA2 (*) + signum Positive = 1 + signum Negative = -1 + signum (Finite x) = Finite (signum x) + negate Positive = Negative + negate Negative = Positive + negate (Finite x) = Finite (negate x) + abs Negative = Positive + abs x = fmap abs x + +-- Adapted from https://www.schoolofhaskell.com/user/snoyberg/random-code-snippets/storable-instance-of-maybe +instance Storable a => Storable (NegativeInfinite a) where + sizeOf x = sizeOf (strip x) + 1 + alignment x = alignment (strip x) + peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case + (1 :: Word8) -> NegFinite <$> peek (stripFPtr ptr) + _ -> pure NegativeInfinity + poke ptr NegativeInfinity + = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8) + poke ptr (NegFinite a) + = poke (stripFPtr ptr) a + *> pokeByteOff ptr (sizeOf a) (1 :: Word8) + +instance Storable a => Storable (PositiveInfinite a) where + sizeOf x = sizeOf (strip x) + 1 + alignment x = alignment (strip x) + peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case + (1 :: Word8) -> PosFinite <$> peek (stripFPtr ptr) + _ -> pure PositiveInfinity + poke ptr PositiveInfinity + = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (0 :: Word8) + poke ptr (PosFinite a) + = poke (stripFPtr ptr) a + *> pokeByteOff ptr (sizeOf a) (1 :: Word8) + +instance Storable a => Storable (Infinite a) where + sizeOf x = sizeOf (strip x) + 1 + alignment x = alignment (strip x) + peek ptr = (peekByteOff ptr . sizeOf . strip . stripPtr) ptr >>= \case + (0 :: Word8) -> Finite <$> peek (stripFPtr ptr) + 1 -> pure Negative + _ -> pure Positive + poke ptr Positive + = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (2 :: Word8) + poke ptr Negative + = pokeByteOff ptr ((sizeOf . strip . stripPtr) ptr) (1 :: Word8) + poke ptr (Finite a) + = poke (stripFPtr ptr) a + *> pokeByteOff ptr (sizeOf a) (1 :: Word8) + +strip :: f a -> a +strip _ = error "strip" + +stripFPtr :: Ptr (f a) -> Ptr a +stripFPtr = castPtr + +stripPtr :: Ptr a -> a +stripPtr _ = error "stripPtr" diff --git a/src/Data/Semiring/Numeric.hs b/src/Data/Semiring/Numeric.hs --- a/src/Data/Semiring/Numeric.hs +++ b/src/Data/Semiring/Numeric.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-| @@ -36,13 +37,18 @@ newtype Bottleneck a = Bottleneck { getBottleneck :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac) + ,Enum, Typeable, Storable, Fractional, Real, RealFrac + ,Functor, Foldable, Traversable) instance (Bounded a, Ord a) => Semiring (Bottleneck a) where (<+>) = (coerce :: WrapBinary Bottleneck a) max (<.>) = (coerce :: WrapBinary Bottleneck a) min zero = Bottleneck minBound one = Bottleneck maxBound + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE zero #-} + {-# INLINE one #-} -- | Positive numbers only. -- @@ -53,7 +59,8 @@ newtype Division a = Division { getDivision :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac) + ,Enum, Typeable, Storable, Fractional, Real, RealFrac + ,Functor, Foldable, Traversable) -- | Only expects positive numbers instance (Integral a, Semiring a) => Semiring (Division a) where @@ -61,6 +68,10 @@ (<.>) = (coerce :: WrapBinary Division a) lcm zero = Division zero one = Division one + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE zero #-} + {-# INLINE one #-} -- | -- has some information on this. Also @@ -74,13 +85,18 @@ newtype Łukasiewicz a = Łukasiewicz { getŁukasiewicz :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac) + ,Enum, Typeable, Storable, Fractional, Real, RealFrac + ,Functor, Foldable, Traversable) instance (Ord a, Num a) => Semiring (Łukasiewicz a) where (<+>) = (coerce :: WrapBinary Łukasiewicz a) max (<.>) = (coerce :: WrapBinary Łukasiewicz a) (\x y -> max 0 (x + y - 1)) zero = Łukasiewicz 0 one = Łukasiewicz 1 + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE zero #-} + {-# INLINE one #-} -- | -- has some information on this. Also @@ -94,115 +110,37 @@ newtype Viterbi a = Viterbi { getViterbi :: a } deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num - ,Enum, Typeable, Storable, Fractional, Real, RealFrac) + ,Enum, Typeable, Storable, Fractional, Real, RealFrac + ,Functor, Foldable, Traversable) instance (Ord a, Semiring a) => Semiring (Viterbi a) where (<+>) = (coerce :: WrapBinary Viterbi a) max (<.>) = (coerce :: WrapBinary Viterbi a) (<.>) zero = Viterbi zero one = Viterbi one + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE zero #-} + {-# INLINE one #-} -- | Useful for optimizing multiplication, or working with large numbers. -- -- @('<.>') = ('+') --x '<+>' y = -('log' ('exp' (-x) + 'exp' (-y))) ---'zero' = ∞ -- represented by 'Nothing' +--'zero' = ∞ --'one' = 0@ newtype Log a = Log - { getLog :: Maybe a - } deriving (Eq, Read, Show, Generic, Generic1, Typeable, Functor - ,Foldable, Applicative, Monad) - -instance (Semiring a, Floating a) => Semiring (Log a) where - zero = Log Nothing - one = Log (Just zero) - Log (Just x) <.> Log (Just y) = Log (Just (x + y)) - _ <.> _ = Log Nothing - Log Nothing <+> y = y - x <+> Log Nothing = x - Log (Just x) <+> Log (Just y) - = Log (Just (-(log (exp (-x) + exp (-y))))) - -instance Ord a => Ord (Log a) where - compare (Log Nothing) (Log Nothing) = EQ - compare (Log Nothing) _ = LT - compare _ (Log Nothing) = GT - compare (Log (Just x)) (Log (Just y)) = compare x y - ------------------------------------------------------------------------- --- Boring instances ------------------------------------------------------------------------- - -instance Functor Bottleneck where fmap = coerce -instance Functor Division where fmap = coerce -instance Functor Łukasiewicz where fmap = coerce -instance Functor Viterbi where fmap = coerce - -instance Foldable Bottleneck where - foldr = - (coerce :: ((a -> b -> c) -> (b -> a -> c)) - -> (a -> b -> c) - -> (b -> Bottleneck a -> c)) flip - foldl = coerce - foldMap = coerce - length = const 1 - null _ = False - -instance Foldable Division where - foldr = - (coerce :: ((a -> b -> c) -> (b -> a -> c)) - -> (a -> b -> c) - -> (b -> Division a -> c)) flip - foldl = coerce - foldMap = coerce - length = const 1 - null _ = False - -instance Foldable Łukasiewicz where - foldr = - (coerce :: ((a -> b -> c) -> (b -> a -> c)) - -> (a -> b -> c) - -> (b -> Łukasiewicz a -> c)) flip - foldl = coerce - foldMap = coerce - length = const 1 - null _ = False - -instance Foldable Viterbi where - foldr = - (coerce :: ((a -> b -> c) -> (b -> a -> c)) - -> (a -> b -> c) - -> (b -> Viterbi a -> c)) flip - foldl = coerce - foldMap = coerce - length = const 1 - null _ = False - -instance Applicative Bottleneck where - pure = coerce - (<*>) = - (coerce :: ((a -> b) -> a -> b) - -> (Bottleneck (a -> b) -> Bottleneck a -> Bottleneck b)) ($) - -instance Applicative Łukasiewicz where - pure = coerce - (<*>) = - (coerce :: ((a -> b) -> a -> b) - -> (Łukasiewicz (a -> b) -> Łukasiewicz a -> Łukasiewicz b)) ($) - -instance Applicative Division where - pure = coerce - (<*>) = - (coerce :: ((a -> b) -> a -> b) - -> (Division (a -> b) -> Division a -> Division b)) ($) - -instance Applicative Viterbi where - pure = coerce - (<*>) = - (coerce :: ((a -> b) -> a -> b) - -> (Viterbi (a -> b) -> Viterbi a -> Viterbi b)) ($) + { getLog :: a + } deriving (Eq, Ord, Read, Show, Generic, Generic1, Typeable, Functor + ,Foldable) -instance Monad Bottleneck where (>>=) = flip coerce -instance Monad Division where (>>=) = flip coerce -instance Monad Łukasiewicz where (>>=) = flip coerce -instance Monad Viterbi where (>>=) = flip coerce +instance (Floating a, HasPositiveInfinity a) => Semiring (Log a) where + zero = Log positiveInfinity + one = Log 0 + (<.>) = (coerce :: WrapBinary Log a) (+) + Log x <+> Log y + = Log (-(log (exp (-x) + exp (-y)))) + {-# INLINE (<+>) #-} + {-# INLINE (<.>) #-} + {-# INLINE zero #-} + {-# INLINE one #-} diff --git a/src/Data/Semiring/TH.hs b/src/Data/Semiring/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semiring/TH.hs @@ -0,0 +1,43 @@ +module Data.Semiring.TH where + +import Control.Monad +import Language.Haskell.TH + +repN :: Int -> String -> Q Dec +repN n nm = do + let v = VarP (mkName nm) + rhs <- TupE <$> replicateM n (pure (VarE (mkName nm))) + return $ ValD v (NormalB rhs) [] + +appN :: Int -> String -> Q Dec +appN n nm = do + let f = VarE (mkName nm) + xs <- replicateM n (newName "x") + let args = [TupP (map VarP xs)] + ntup = TupE (map (AppE f . VarE) xs) + return $ FunD (mkName nm) [Clause args (NormalB ntup) []] + +cmbN :: Int -> String -> Q Dec +cmbN n nm = do + let f = VarE (mkName nm) + xs <- replicateM n (newName "x") + ys <- replicateM n (newName "y") + let args = [TupP (map VarP xs), TupP (map VarP ys)] + ntup = TupE (zipWith (AppE . AppE f) (map VarE xs) (map VarE ys)) + return $ FunD (mkName nm) [Clause args (NormalB ntup) []] + +starIns :: Int -> Q Dec +starIns n = do + names <- replicateM n (newName "a") + let c = ConT (mkName "StarSemiring") + ct = map (AppT c . VarT) names + InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$> + sequence [appN n "star", appN n "plus"] + +semiringIns :: Int -> Q Dec +semiringIns n = do + names <- replicateM n (newName "a") + let c = ConT (mkName "Semiring") + ct = map (AppT c . VarT) names + InstanceD Nothing ct (AppT c $ foldl AppT (TupleT n) (map VarT names)) <$> + sequence [cmbN n "<+>", cmbN n "<.>", repN n "zero", repN n "one"] diff --git a/src/Test/Semiring.hs b/src/Test/Semiring.hs --- a/src/Test/Semiring.hs +++ b/src/Test/Semiring.hs @@ -20,9 +20,15 @@ , unaryLaws , binaryLaws , ternaryLaws + , starLaw + , plusLaw + , starLaws + , nearUnLaws + , nearTernaryLaws + , ordLaws ) where -import Data.Semiring (Semiring (..)) +import Data.Semiring (Semiring (..), StarSemiring (..)) -- | Plus is associative. plusAssoc :: (Eq a, Semiring a, Show a) => a -> a -> a -> Either String String @@ -102,7 +108,7 @@ l = (x <+> y) <.> z r = x <.> z <+> y <.> z s = unlines - [ "<.> does " ++ (if res then "" else "not ") ++ "distribute left over <+>." + [ "<.> does " ++ (if res then "" else "not ") ++ "distribute right over <+>." , " Law:" , " (x <+> y) <.> z = x <.> z <+> y <.> z" , " x = " ++ show x @@ -159,6 +165,16 @@ unaryLaws :: (Eq a, Semiring a, Show a) => a -> Either String String unaryLaws x = fmap unlines (sequence [plusId x, mulId x, annihilate x]) +nearUnLaws :: (Eq a, Semiring a, Show a) => a -> Either String String +nearUnLaws = plusId + +nearTernaryLaws :: (Eq a, Semiring a, Show a) + => a -> a -> a -> Either String String +nearTernaryLaws x y z = + fmap unlines (sequence [ plusAssoc x y z + , mulAssoc x y z + , mulDistribL x y z]) + binaryLaws :: (Eq a, Semiring a, Show a) => a -> a -> Either String String binaryLaws = plusComm @@ -170,3 +186,68 @@ , mulAssoc x y z , mulDistribL x y z , mulDistribR x y z]) + +starLaw :: (Eq a, StarSemiring a, Show a) => a -> Either String String +starLaw (x :: a) = if res then Right s else Left s where + res = l == st && r == st + l = one <+> x <.> star x + r = one <+> star x <.> x + st = star x + s = unlines + [ "star law" ++ (if res then "" else " not") ++ " followed." + , " Law:" + , " star x = one <+> x <.> star x = one <+> star x <.> x" + , " x = " ++ show x + , " one = " ++ show (one :: a) + , " star x = " ++ show st + , " one <+> x <.> star x = " ++ show l + , " one <+> star x <.> x = " ++ show r ] + +plusLaw :: (Eq a, StarSemiring a, Show a) => a -> Either String String +plusLaw (x :: a) = if res then Right s else Left s where + res = r == st + r = x <.> star x + st = plus x + s = unlines + [ "plus law" ++ (if res then "" else " not") ++ " followed." + , " Law:" + , " plus x = x <.> star x" + , " x = " ++ show x + , " star x = " ++ show st + , " x <.> star x = " ++ show r ] + +starLaws :: (Eq a, StarSemiring a, Show a) => a -> Either String String +starLaws x = fmap unlines (sequence [starLaw x, plusLaw x]) + + +ordAddLaw :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String +ordAddLaw (x :: a) (y :: a) (z :: a) = if res then Right s else Left s where + cnd = x <= y + lhs = x <+> z <= y <+> z + rhs = z <+> x <= z <+> y + res = not cnd || lhs && rhs + s = unlines + [ "ordering law" ++ (if res then "" else " not") ++ " followed." + , " Law:" + , " x <= y => x <+> z <= y <+> z && z <+> x <= z <+> y" + , " x = " ++ show x + , " y = " ++ show y + , " z = " ++ show z ] + +ordMulLaw :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String +ordMulLaw (x :: a) (y :: a) (z :: a) = if res then Right s else Left s where + cnd = x <= y && zero <= z + lhs = x <.> z <= y <.> z + rhs = z <.> x <= z <.> y + res = not cnd || lhs && rhs + s = unlines + [ "ordering law" ++ (if res then "" else " not") ++ " followed." + , " Law:" + , " x <= y => x <.> z <= y <.> z && z <.> x <= z <.> y" + , " x = " ++ show x + , " y = " ++ show y + , " z = " ++ show z ] + + +ordLaws :: (Ord a, Semiring a, Show a) => a -> a -> a -> Either String String +ordLaws x y z = fmap unlines (sequence [ordAddLaw x y z, ordMulLaw x y z]) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,31 +1,34 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Control.Applicative -import Control.Arrow (first) +import Control.Arrow (first) +import Data.Bool import Data.Foldable -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import qualified Data.Map.Strict as Map +import Data.Function +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map import Data.Monoid import Data.Semiring import Data.Semiring.Free import Data.Semiring.Numeric -import qualified Data.Set as Set +import GHC.TypeLits +import Numeric.Sized.WordOfSize import Test.DocTest +import Test.QuickCheck hiding (Positive (..), generate, + (.&.)) import Test.Semiring -import Test.SmallCheck -import Test.SmallCheck.Series -import GHC.TypeLits -import Data.Function -import Data.Bits +import Test.SmallCheck hiding (Testable, (==>)) +import Test.SmallCheck.Series hiding (Positive) +import qualified Test.SmallCheck.Series as SC ------------------------------------------------------------------------ @@ -35,41 +38,132 @@ smallCheck 1000 (unaryLaws :: UnaryLaws Integer) smallCheck 100 (binaryLaws :: BinaryLaws Integer) smallCheck 10 (ternaryLaws :: TernaryLaws Integer) + smallCheck 10 (ordLaws :: TernaryLaws Integer) - putStrLn "(WordN 2)" - smallCheck 16 (unaryLaws :: UnaryLaws (WordN 2)) - smallCheck 16 (binaryLaws :: BinaryLaws (WordN 2)) - smallCheck 16 (ternaryLaws :: TernaryLaws (WordN 2)) + putStrLn "(WordOfSize 2)" + smallCheck 16 (unaryLaws :: UnaryLaws (WordOfSize 2)) + smallCheck 16 (binaryLaws :: BinaryLaws (WordOfSize 2)) + smallCheck 16 (ternaryLaws :: TernaryLaws (WordOfSize 2)) + smallCheck 16 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2))) - putStrLn "(WordN 2,WordN 2)" - smallCheck 16 (unaryLaws :: UnaryLaws (WordN 2,WordN 2)) - smallCheck 14 (binaryLaws :: BinaryLaws (WordN 2,WordN 2)) - smallCheck 8 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2)) + putStrLn "(WordOfSize 2,WordOfSize 2)" + smallCheck 16 (unaryLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2)) + smallCheck 14 (binaryLaws :: BinaryLaws (WordOfSize 2,WordOfSize 2)) + smallCheck 8 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2)) + smallCheck 16 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2) + ,PositiveInfinite (WordOfSize 2))) - putStrLn "(WordN 2,WordN 2,WordN 2)" - smallCheck 10 (unaryLaws :: UnaryLaws (WordN 2,WordN 2,WordN 2)) - smallCheck 5 (binaryLaws :: BinaryLaws (WordN 2,WordN 2,WordN 2)) - smallCheck 2 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2,WordN 2)) + putStrLn "(WordOfSize 2,WordOfSize 2,WordOfSize 2)" + smallCheck 10 (unaryLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) + smallCheck 5 (binaryLaws :: BinaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) + smallCheck 2 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2)) + smallCheck 10 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2) + ,PositiveInfinite (WordOfSize 2) + ,PositiveInfinite (WordOfSize 2))) - putStrLn "(WordN 2,WordN 2,WordN 2,WordN 2)" - smallCheck 8 (unaryLaws :: UnaryLaws (WordN 2,WordN 2,WordN 2,WordN 2)) - smallCheck 4 (binaryLaws :: BinaryLaws (WordN 2,WordN 2,WordN 2,WordN 2)) - smallCheck 1 (ternaryLaws :: TernaryLaws (WordN 2,WordN 2,WordN 2,WordN 2)) + putStrLn "(WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)" + smallCheck 8 (unaryLaws :: UnaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) + smallCheck 4 (binaryLaws :: BinaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) + smallCheck 1 (ternaryLaws :: TernaryLaws (WordOfSize 2,WordOfSize 2,WordOfSize 2,WordOfSize 2)) + smallCheck 16 (starLaws :: UnaryLaws (PositiveInfinite (WordOfSize 2) + ,PositiveInfinite (WordOfSize 2) + ,PositiveInfinite (WordOfSize 2) + ,PositiveInfinite (WordOfSize 2))) + putStrLn "(Int,Int,Int,Int,Int)" + quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int)) + quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int)) + quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int)) + quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int)) + + putStrLn "(Int,Int,Int,Int,Int,Int)" + quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int)) + quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int)) + quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int)) + quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int)) + + putStrLn "(Int,Int,Int,Int,Int,Int,Int)" + quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int)) + quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int,Int)) + quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int)) + quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int)) + + putStrLn "(Int,Int,Int,Int,Int,Int,Int,Int)" + quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) + quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) + quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int,Int)) + quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int)) + + putStrLn "(Int,Int,Int,Int,Int,Int,Int,Int,Int)" + quickCheck (unaryLaws :: UnaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) + quickCheck (binaryLaws :: BinaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) + quickCheck (ternaryLaws :: TernaryLaws (Int,Int,Int,Int,Int,Int,Int,Int,Int)) + quickCheck (starLaws :: UnaryLaws (PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int + ,PositiveInfinite Int)) + putStrLn "Int" smallCheck 1000 (unaryLaws :: UnaryLaws Int) smallCheck 100 (binaryLaws :: BinaryLaws Int) smallCheck 10 (ternaryLaws :: TernaryLaws Int) + putStrLn "PosInf Integer" + smallCheck 1000 (nearUnLaws :: UnaryLaws (PositiveInfinite Integer)) + smallCheck 100 (binaryLaws :: BinaryLaws (PositiveInfinite Integer)) + smallCheck 10 (nearTernaryLaws :: TernaryLaws (PositiveInfinite Integer)) + smallCheck 10 (ordLaws :: TernaryLaws (PositiveInfinite Integer)) + + putStrLn "NegInf Integer" + smallCheck 1000 (nearUnLaws :: UnaryLaws (NegativeInfinite Integer)) + smallCheck 100 (binaryLaws :: BinaryLaws (NegativeInfinite Integer)) + smallCheck 10 (nearTernaryLaws :: TernaryLaws (NegativeInfinite Integer)) + smallCheck 10 (ordLaws :: TernaryLaws (NegativeInfinite Integer)) + + -- putStrLn "Inf Integer" + -- smallCheck 1000 (nearUnLaws :: UnaryLaws (Infinite Integer)) + -- smallCheck 100 (binaryLaws :: BinaryLaws (Infinite Integer)) + -- smallCheck 10 (nearTernaryLaws :: TernaryLaws (Infinite Integer)) + -- smallCheck 10 (ordLaws :: TernaryLaws (Infinite Integer)) + putStrLn "()" smallCheck 1 (unaryLaws :: UnaryLaws ()) smallCheck 1 (binaryLaws :: BinaryLaws ()) smallCheck 1 (ternaryLaws :: TernaryLaws ()) + smallCheck 1 (starLaws :: UnaryLaws ()) putStrLn "Bool" smallCheck 2 (unaryLaws :: UnaryLaws Bool) smallCheck 4 (binaryLaws :: BinaryLaws Bool) smallCheck 8 (ternaryLaws :: TernaryLaws Bool) + smallCheck 2 (starLaws :: UnaryLaws Bool) putStrLn "Any" smallCheck 2 (unLawsOn Any :: UnaryLaws Bool) @@ -81,40 +175,37 @@ smallCheck 4 (binLawsOn All :: BinaryLaws Bool) smallCheck 8 (ternLawsOn All :: TernaryLaws Bool) - putStrLn "[WordN 2]" - smallCheck 5 (unaryLaws :: UnaryLaws [WordN 2]) - smallCheck 4 (binaryLaws :: BinaryLaws [WordN 2]) - smallCheck 3 (ternaryLaws :: TernaryLaws [WordN 2]) - - putStrLn "Set [WordN 2]" - smallCheck 4 (unLawsOn Set.fromList :: UnaryLaws [[WordN 2]]) - smallCheck 3 (binLawsOn Set.fromList :: BinaryLaws [[WordN 2]]) - smallCheck 3 (ternLawsOn Set.fromList :: TernaryLaws [[WordN 2]]) + putStrLn "[WordOfSize 2]" + smallCheck 5 (unaryLaws :: UnaryLaws [WordOfSize 2]) + smallCheck 4 (binaryLaws :: BinaryLaws [WordOfSize 2]) + smallCheck 3 (ternaryLaws :: TernaryLaws [WordOfSize 2]) putStrLn "Min Integer" - smallCheck 1000 (unLawsOn Min :: UnaryLaws (Maybe Integer)) - smallCheck 100 (binLawsOn Min :: BinaryLaws (Maybe Integer)) - smallCheck 10 (ternLawsOn Min :: TernaryLaws (Maybe Integer)) + smallCheck 1000 (unLawsOn Min :: UnaryLaws (PositiveInfinite Integer)) + smallCheck 100 (binLawsOn Min :: BinaryLaws (PositiveInfinite Integer)) + smallCheck 10 (ternLawsOn Min :: TernaryLaws (PositiveInfinite Integer)) + smallCheck 1000 (starLaws . Min :: UnaryLaws (Infinite Integer)) putStrLn "Max Integer" - smallCheck 1000 (unLawsOn Max :: UnaryLaws (Maybe Integer)) - smallCheck 100 (binLawsOn Max :: BinaryLaws (Maybe Integer)) - smallCheck 10 (ternLawsOn Max :: TernaryLaws (Maybe Integer)) + smallCheck 1000 (unLawsOn Max :: UnaryLaws (NegativeInfinite Integer)) + smallCheck 100 (binLawsOn Max :: BinaryLaws (NegativeInfinite Integer)) + smallCheck 10 (ternLawsOn Max :: TernaryLaws (NegativeInfinite Integer)) + smallCheck 1000 (starLaws . Max :: UnaryLaws (Infinite Integer)) - putStrLn "Free (WordN 2)" - smallCheck 4 (unLawsOn Free :: UnaryLaws [[WordN 2]]) - smallCheck 3 (binLawsOn Free :: BinaryLaws [[WordN 2]]) - smallCheck 3 (ternLawsOn Free :: TernaryLaws [[WordN 2]]) + putStrLn "Free (WordOfSize 2)" + smallCheck 4 (unLawsOn Free :: UnaryLaws [[WordOfSize 2]]) + smallCheck 3 (binLawsOn Free :: BinaryLaws [[WordOfSize 2]]) + smallCheck 3 (ternLawsOn Free :: TernaryLaws [[WordOfSize 2]]) - putStrLn "Bottleneck (WordN 2)" - smallCheck 1000 (unLawsOn Bottleneck :: UnaryLaws (WordN 2)) - smallCheck 100 (binLawsOn Bottleneck :: BinaryLaws (WordN 2)) - smallCheck 10 (ternLawsOn Bottleneck :: TernaryLaws (WordN 2)) + putStrLn "Bottleneck (WordOfSize 2)" + smallCheck 1000 (unLawsOn Bottleneck :: UnaryLaws (WordOfSize 2)) + smallCheck 100 (binLawsOn Bottleneck :: BinaryLaws (WordOfSize 2)) + smallCheck 10 (ternLawsOn Bottleneck :: TernaryLaws (WordOfSize 2)) putStrLn "Division Integer" - smallCheck 1000 (unLawsOn (Division . getPositive) :: UnaryLaws (Positive Integer)) - smallCheck 100 (binLawsOn (Division . getPositive) :: BinaryLaws (Positive Integer)) - smallCheck 10 (ternLawsOn (Division . getPositive) :: TernaryLaws (Positive Integer)) + smallCheck 1000 (unLawsOn (Division . getPositive) :: UnaryLaws (SC.Positive Integer)) + smallCheck 100 (binLawsOn (Division . getPositive) :: BinaryLaws (SC.Positive Integer)) + smallCheck 10 (ternLawsOn (Division . getPositive) :: TernaryLaws (SC.Positive Integer)) putStrLn "Łukasiewicz Double" smallCheck 1000 (unLawsOn Łukasiewicz :: UnaryLaws Fraction) @@ -127,15 +218,19 @@ smallCheck 10 (ternLawsOn Viterbi :: TernaryLaws Fraction) putStrLn "Log Double" - smallCheck 1000 (unLawsOn Log :: UnaryLaws (Maybe Fraction)) - smallCheck 100 (binLawsOn Log :: BinaryLaws (Maybe Fraction)) - smallCheck 10 (ternLawsOn Log :: TernaryLaws (Maybe Fraction)) + quickCheck (unLawsOn Log :: UnaryLaws (Approx Double)) + quickCheck (binLawsOn Log :: BinaryLaws (Approx Double)) + quickCheck (ternLawsOn Log :: TernaryLaws (Approx Double)) putStrLn "Bool -> Bool" smallCheck 3 (unLawsOn fromFunc :: UnaryLaws (Bool -> Bool)) smallCheck 2 (binLawsOn fromFunc :: BinaryLaws (Bool -> Bool)) smallCheck 2 (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool)) + quickCheck (unLawsOn fromFunc :: UnaryLaws (Bool -> Bool)) + quickCheck (binLawsOn fromFunc :: BinaryLaws (Bool -> Bool)) + quickCheck (ternLawsOn fromFunc :: TernaryLaws (Bool -> Bool)) + putStrLn "Endo (Add Bool)" smallCheck 3 (unOn plusId eFromFunc :: UnaryLaws (Bool -> Bool)) smallCheck 3 (unOn mulId eFromFunc :: UnaryLaws (Bool -> Bool)) @@ -179,17 +274,38 @@ -- Serial wrappers -- | A type with a serial instance between zero and one -newtype Fraction - = Fraction Double - deriving (Show, Num, Fractional, Real, RealFrac, Floating, RealFloat, Semiring) +newtype Fraction = + Fraction Double + deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring) +newtype Approx a = + Approx a + deriving (Show,Num,Fractional,Real,RealFrac,Floating,RealFloat,Semiring + ,HasPositiveInfinity) + +instance (Arbitrary a, Num a, Ord a) => Arbitrary (Approx a) where + arbitrary = fmap Approx (suchThat arbitrary ((<100).abs)) + instance Eq Fraction where - Fraction x == Fraction y = abs (x-y) < 0.011 + Fraction x == Fraction y = abs (x - y) < 0.011 +instance (RealFloat a, Ord a) => + Eq (Approx a) where + Approx x == Approx y = + isInfinite x && isInfinite y || + x == y || + let n = abs (x - y) + in max (n / abs x) (n / abs y) < 0.011 + +instance (RealFloat a, Ord a) => Ord (Approx a) where + compare (Approx x) (Approx y) + | Approx x == Approx y = EQ + | otherwise = compare x y + instance Ord Fraction where - compare (Fraction x) (Fraction y) - | Fraction x == Fraction y = EQ - | otherwise = compare x y + compare (Fraction x) (Fraction y) + | Fraction x == Fraction y = EQ + | otherwise = compare x y instance Monad m => Serial m Fraction where series = fmap Fraction $ generate (\d -> if d >= 0 then pure 0 else empty) <|> rest where @@ -197,50 +313,24 @@ go lower upper = let mid = (lower + upper) / 2 in mid : interleave (go lower mid) (go mid upper) interleave (x:xs) (y:ys) = x : y : interleave xs ys - interleave _ _ = undefined - --- | A very small numeric type for exhaustiveness -newtype WordN (n :: Nat) = WordN { getWordN :: Word } deriving Show - -mask :: KnownNat n => WordN n -> Word -mask x = shift 1 (fromInteger (natVal x)) - 1 - -trunc :: KnownNat n => WordN n -> WordN n -trunc v@(WordN x) = WordN (x .&. mask v) - -instance KnownNat n => Bounded (WordN n) where - minBound = WordN 0 - maxBound = res where res = WordN (mask res) - -instance KnownNat n => Num (WordN n) where - WordN x + WordN y = trunc (WordN (x + y)) - WordN x * WordN y = trunc (WordN (x * y)) - WordN x - WordN y = trunc (WordN (x - y)) - fromInteger x = trunc (WordN (fromInteger x)) - abs = id - signum (WordN x) = WordN (signum x) - -instance KnownNat n => Eq (WordN n) where - (==) = (==) `on` getWordN . trunc + interleave _ _ = undefined -instance KnownNat n => Ord (WordN n) where - compare = compare `on` getWordN . trunc +instance (Monad m, KnownNat n) => Serial m (WordOfSize n) where + series = generate (`take` [minBound..maxBound]) -instance KnownNat n => Real (WordN n) where - toRational = toRational . getWordN +instance KnownNat n => Arbitrary (WordOfSize n) where + arbitrary = arbitraryBoundedEnum -instance KnownNat n => Enum (WordN n) where - fromEnum = fromEnum . getWordN - toEnum = trunc . WordN . toEnum +instance KnownNat n => Semiring (WordOfSize n) -instance KnownNat n => Integral (WordN n) where - toInteger = toInteger . getWordN - quotRem (WordN x) (WordN y) = (WordN (quot x y), WordN (rem x y)) +instance (Monad m, Serial m a) => Serial m (PositiveInfinite a) where + series = fmap (maybe PositiveInfinity PosFinite) series -instance (Monad m, KnownNat n) => Serial m (WordN n) where - series = generate (`take` [minBound..maxBound]) +instance (Monad m, Serial m a) => Serial m (NegativeInfinite a) where + series = fmap (maybe NegativeInfinity NegFinite) series -instance KnownNat n => Semiring (WordN n) +instance (Monad m, Serial m a) => Serial m (Infinite a) where + series = fmap (either (bool Positive Negative) Finite) series ------------------------------------------------------------------------ -- Function Equality @@ -283,7 +373,7 @@ c = maybe 1 succ (Map.lookup e m) nb = case b of Just (a,d) | d >= c -> (a,d) - _ -> (e,c) + _ -> (e,c) apply :: Enum a => Func a b -> a -> b apply (Func c cs) x = IntMap.findWithDefault c (fromEnum x) cs @@ -298,3 +388,64 @@ one = fromFunc one f <+> g = fromFunc (apply f <+> apply g) f <.> g = fromFunc (apply f <.> apply g) + +------------------------------------------------------------------------ +-- QuickCheck wrappers + +instance Arbitrary a => Arbitrary (PositiveInfinite a) where + arbitrary = fmap (maybe PositiveInfinity PosFinite) arbitrary + +instance Arbitrary a => Arbitrary (NegativeInfinite a) where + arbitrary = fmap (maybe NegativeInfinity NegFinite) arbitrary + +instance Arbitrary a => Arbitrary (Infinite a) where + arbitrary = fmap (either (bool Positive Negative) Finite) arbitrary + +instance Testable (Either String String) where + property = either (`counterexample` False) (const (property True)) + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + ,Arbitrary f) + => Arbitrary (a,b,c,d,e,f) where + arbitrary = (,,,,,) <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + ,Arbitrary f, Arbitrary g) + => Arbitrary (a,b,c,d,e,f,g) where + arbitrary = (,,,,,,) <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + ,Arbitrary f, Arbitrary g, Arbitrary h) + => Arbitrary (a,b,c,d,e,f,g,h) where + arbitrary = (,,,,,,,) <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e + ,Arbitrary f, Arbitrary g, Arbitrary h, Arbitrary i) + => Arbitrary (a,b,c,d,e,f,g,h,i) where + arbitrary = (,,,,,,,,) <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary