module Algebra.Core(
BS.ByteString,BS.readFile,BS.writeFile,BS.hGetContents,
Void,(:*:),(:+:),
Semigroup(..),Monoid(..),Ring(..),
SubSemi(..),
Unit(..),
Endo(..),StrictEndo(..),
Dual(..),Product(..),
OrdList(..),Interleave(..),Accum(..),Max(..),Id(..),
Category(..),(<<<),(>>>),(+++),
Choice(..),Split(..),
const,(&),is,fix,
first,second,
ifThenElse,bool,guard,fail,unit,when,unless,
tailSafe,headDef,
rmod,inside,swap,
Orderable(..),
comparing,insertOrd,invertOrd,
module Prelude
) where
import Prelude hiding (
readFile,writeFile,
Functor(..),Monad(..),
sequence,mapM,mapM_,sequence_,(=<<),
map,(++),foldl,foldr,foldr1,concat,filter,length,sum,lookup,
(+),(*),(.),id,const,
or,any,and,all,elem,
until)
import qualified Prelude as P
import Data.Tree
import qualified Data.ByteString as BS
import Data.Ord (comparing)
data Void
type a:*:b = (a,b)
type a:+:b = Either a b
class Semigroup m where
(+) :: m -> m -> m
default (+) :: Num m => m -> m -> m
(+) = (P.+)
infixl 6 +
instance Semigroup Void where _+_ = undefined
instance Semigroup () where _+_ = ()
instance Semigroup Bool where (+) = (||)
instance Semigroup Int
instance Semigroup Float
instance Semigroup Double
instance Semigroup Integer
instance Semigroup [a] where []+l = l ; (x:t)+l = x:(t+l)
instance (Semigroup a,Semigroup b) => Semigroup (a:*:b) where ~(a,b) + ~(c,d) = (a+c,b+d)
instance (Semigroup a,Semigroup b,Semigroup c) => Semigroup (a,b,c) where
~(a,b,c) + ~(a',b',c') = (a+a',b+b',c+c')
instance SubSemi b a => Semigroup (a:+:b) where
Left a+Left b = Left (a+b)
a+b = Right (from a+from b)
where from = cast <|> id
instance Semigroup (Maybe a) where
Nothing + b = b ; a + _ = a
class Semigroup m => Monoid m where
zero :: m
default zero :: Num m => m
zero = 0
instance Monoid Void where zero = undefined
instance Monoid () where zero = ()
instance Monoid Int ; instance Monoid Integer
instance Monoid Float ; instance Monoid Double
instance Monoid [a] where zero = []
instance (Monoid a,Monoid b) => Monoid (a:*:b) where zero = (zero,zero)
instance (Monoid a,Monoid b,Monoid c) => Monoid (a,b,c) where
zero = (zero,zero,zero)
instance (SubSemi b a,Monoid a) => Monoid (a:+:b) where zero = Left zero
instance Monoid Bool where zero = False
instance Monoid (Maybe a) where zero = Nothing
class (Semigroup a,Semigroup b) => SubSemi a b where
cast :: b -> a
instance Monoid a => SubSemi a () where cast _ = zero
instance Monoid a => SubSemi a Void where cast _ = zero
class Monoid m => Ring m where
one :: m
default one :: Num m => m
one = 1
(*) :: m -> m -> m
default (*) :: Num m => m -> m -> m
(*) = (P.*)
infixl 7 *
instance Ring Bool where one = True ; (*) = (&&)
instance Ring Int
instance Ring Integer
instance Ring Float
instance Ring Double
instance Monoid a => Ring [a] where
one = zero:one
(a:as) * (b:bs) = a+b:as*bs
_ * _ = zero
instance (Ring a,Ring b) => Ring (a:*:b) where
one = (one,one) ; ~(a,b) * ~(c,d) = (a*c,b*d)
class Unit f where
pure :: a -> f a
instance Unit (Either a) where pure = Right
instance Unit Maybe where pure = Just
instance Monoid w => Unit ((,) w) where pure a = (zero,a)
instance Unit ((->) b) where pure = P.const
instance Unit [] where pure a = [a]
instance Unit Tree where pure a = Node a []
instance Unit IO where pure = P.return
class Category k where
id :: k a a
(.) :: k b c -> k a b -> k a c
instance Category (->) where
id = P.id
(.) = (P..)
(<<<) :: Category k => k b c -> k a b -> k a c
(<<<) = (.)
(>>>) :: Category k => k a b -> k b c -> k a c
(>>>) = flip (<<<)
infixr 1 >>>,<<<
infixr 9 .
class Category k => Choice k where
(<|>) :: k a c -> k b c -> k (a:+:b) c
infixr 1 <|>
instance Choice (->) where
(f <|> _) (Left a) = f a
(_ <|> g) (Right b) = g b
class Category k => Split k where
(<#>) :: k a c -> k b d -> k (a,b) (c,d)
infixr 2 <#>
instance Split (->) where f <#> g = \ ~(a,b) -> (f a,g b)
newtype Product a = Product { getProduct :: a }
instance Ring a => Semigroup (Product a) where
Product a+Product b = Product (a*b)
instance Ring a => Monoid (Product a) where
zero = Product one
newtype Endo k a = Endo { runEndo :: k a a }
instance Category k => Semigroup (Endo k a) where Endo f+Endo g = Endo (g . f)
instance Category k => Monoid (Endo k a) where zero = Endo id
newtype StrictEndo a = StrictEndo { runStrictEndo :: a -> a }
instance Semigroup (StrictEndo a) where
StrictEndo f + StrictEndo g = StrictEndo h
where h a = let fa = f a in fa `seq` g fa
newtype Accum a = Accum { getAccum :: Maybe a }
instance Monoid a => Semigroup (Accum a) where
Accum Nothing + Accum Nothing = Accum Nothing
Accum a + Accum b = Accum (Just (from a+from b))
where from = maybe zero id
instance Monoid a => Monoid (Accum a) where zero = Accum Nothing
instance Unit Accum where pure = Accum . pure
newtype Id a = Id { getId :: a }
deriving Show
instance Unit Id where pure = Id
newtype Max a = Max { getMax :: a }
deriving (Eq,Ord,Bounded,Show)
instance Ord a => Semigroup (Max a) where Max a+Max b = Max (max a b)
instance (Ord a,Bounded a) => Monoid (Max a) where zero = Max minBound
instance (Ord a,Bounded a) => Ring (Max a) where
one = Max maxBound
Max a * Max b = Max (min a b)
newtype Dual m = Dual { getDual :: m }
instance Semigroup m => Semigroup (Dual m) where Dual a+Dual b = Dual (b+a)
deriving instance Monoid m => Monoid (Dual m)
instance Ring m => Ring (Dual m) where
one = Dual one
Dual a * Dual b = Dual (b*a)
newtype OrdList a = OrdList { getOrdList :: [a] }
deriving (Eq,Ord,Show)
instance Orderable a => Semigroup (OrdList a) where
OrdList oa + OrdList ob = OrdList (oa ++ ob)
where (x:xt) ++ (y:yt) = a : c : cs
where (a,_,z) = inOrder x y
~(c:cs) = if z then xt ++ (y:yt) else (x:xt) ++ yt
a ++ b = a + b
deriving instance Orderable a => Monoid (OrdList a)
deriving instance Unit OrdList
class Ord t => Orderable t where
inOrder :: t -> t -> (t,t,Bool)
instance Ord t => Orderable (Max t) where
inOrder (Max a) (Max b) = (Max x,Max y,z)
where ~(x,y) | z = (a,b)
| otherwise = (b,a)
z = a<=b
insertOrd :: Orderable t => t -> [t] -> [t]
insertOrd e [] = [e]
insertOrd e (x:xs) = a:y:ys
where (a,_,z) = inOrder e x
~(y:ys) = if z then x:xs else insertOrd e xs
newtype Interleave a = Interleave { interleave :: [a] }
instance Semigroup (Interleave a) where
Interleave ia + Interleave ib = Interleave (inter ia ib)
where inter (a:as) bs = a:inter bs as
inter [] bs = bs
deriving instance Monoid (Interleave a)
(&) :: a -> (a -> b) -> b
(&) = flip ($)
infixl 0 &
is :: a -> (a -> Bool) -> Bool
is = (&)
infixr 1 +++
(+++) :: Split k => (a -> k c c) -> (b -> k d d) -> (a:+:b) -> k (c,d) (c,d)
f +++ g = first.f <|> second.g
second :: Split k => k a b -> k (c,a) (c,b)
second a = id <#> a
first :: Split k => k a b -> k (a,c) (b,c)
first a = a <#> id
guard :: (Unit m,Monoid (m ())) => Bool -> m ()
guard p = if p then unit else zero
ifThenElse :: Bool -> a -> a -> a
ifThenElse b th el = if b then th else el
bool :: a -> a -> Bool -> a
bool th el b = ifThenElse b th el
tailSafe :: [a] -> [a]
tailSafe [] = [] ; tailSafe (_:t) = t
headDef :: a -> [a] -> a
headDef d [] = d ; headDef _ (x:_) = x
fail :: String -> a
fail = error
const :: Unit m => a -> m a
const = pure
fix :: (a -> a) -> a
fix f = y where y = f y
unit :: Unit m => m ()
unit = pure ()
when :: Unit m => Bool -> m () -> m ()
when p m = if p then m else unit
unless :: Unit m => Bool -> m () -> m ()
unless p m = if p then unit else m
invertOrd :: Ordering -> Ordering
invertOrd GT = LT ; invertOrd LT = GT ; invertOrd EQ = EQ
inside :: Ord t => t -> t -> (t -> Bool)
inside x y = \z -> x<z && z<y
rmod :: (RealFrac m,Ring m) => m -> m -> m
a`rmod`b = b * r
where _n :: Int
(_n,r) = properFraction (a/b)
infixl 7 `rmod`
swap :: (a,b) -> (b,a)
swap (a,b) = (b,a)