diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Hiromi ISHII (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Hiromi ISHII nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/algebraic-prelude.cabal b/algebraic-prelude.cabal new file mode 100644 --- /dev/null +++ b/algebraic-prelude.cabal @@ -0,0 +1,42 @@ +name: algebraic-prelude +version: 0.1.0.0 +synopsis: Algebraically structured Prelude +description: This package provides a drop-in replacement for Prelude module, + based on algebraic hierarchy provided by package. +homepage: https://github.com/konn/algebraic-prelude#readme +license: BSD3 +license-file: LICENSE +author: Hiromi ISHII +maintainer: konn.jinro _at_ gmail.com +copyright: 2015 (c) Hiromi ISHII +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: AlgebraicPrelude + build-depends: base >= 4.7 && < 5 + , algebra >= 4.3 + , basic-prelude + , lens == 4.* + , semigroups + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: -Wall + + +executable sandpit + hs-source-dirs: examples + Main-is: sandpit.hs + build-depends: base + , algebraic-prelude + default-language: Haskell2010 + ghc-options: -Wall + default-extensions: NoImplicitPrelude + buildable: False + +source-repository head + type: git + location: https://github.com/konn/computational-algebra diff --git a/examples/sandpit.hs b/examples/sandpit.hs new file mode 100644 --- /dev/null +++ b/examples/sandpit.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where +import AlgebraicPrelude + +default (Fraction Integer) + +arg, main :: IO () +arg = do + putStrLn "Good morning everybody!" + if True + then print (5.2 :: Rational) + else print $ take 5 [1 :: Double,2,345] +main = arg diff --git a/src/AlgebraicPrelude.hs b/src/AlgebraicPrelude.hs new file mode 100644 --- /dev/null +++ b/src/AlgebraicPrelude.hs @@ -0,0 +1,588 @@ +{-# LANGUAGE ConstraintKinds, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This module provides drop-in replacement for @'Prelude'@ module in base package, +-- based on algebraic hierarchy provided by +-- package. +-- You can use this module with @NoImplicitPrelude@ language option. +-- +-- This module implicitly exports following modules: +-- +-- * "Numeric.Algebra" module, except +-- +-- * @'NA.fromInteger'@: +-- this module exports Prelude's @'fromInteger'@ to make number literals +-- work properly. +-- For @'NA.fromInteger'@ from @algebra@ package, use @'fromInteger''@. +-- +-- * @('NA.^')@ is renamed to @('^^')@, and @('^')@ is redefined as @'NA.pow'@. +-- +-- * The module "Numeric.Algebra.Unital.UnitNormalForm", except for @'NA.normalize'@; +-- hence its name is too general, we export it as @'normaliseUnit'@. +-- +-- * Following modules are exported as-is: +-- +-- * "Numeric.Decidable.Associates" +-- * "Numeric.Decidable.Units" +-- * "Numeric.Decidable.Zero" +-- * "Numeric.Domain.Class" +-- * "Numeric.Domain.Euclidean" +-- * "Numeric.Domain.GCD" +-- * "Numeric.Domain.Integral" +-- * "Numeric.Domain.PID" +-- * "Numeric.Domain.UFD" +-- * "Numeric.Field.Fraction" +-- * "Numeric.Semiring.ZeroProduct" +-- +-- * Non-numeric part of this module is almost same as "BasicPrelude". +-- But the following combinators are not generalized from "Prelude": +-- +-- * @'String'@-specific functions: @'getArgs'@, @'getContents'@, +-- @'getLine'@, @'interact'@, @'putStr'@, @'putStrLn'@, +-- @'read'@, @'readFile'@, @'writeFile'@, @'lines'@, @'unlines'@, +-- @'words'@ and @'unwords'@. +-- +-- * @('.')@ is just a function composition; not a Categorical composition. + +module AlgebraicPrelude + (module AlgebraicPrelude, + -- * Old Prelude's Numeric type classes and functions, without confliction + P.Num(abs,signum),P.Integral(),P.toInteger, P.Real(..), P.Fractional (), + P.Floating(..), P.RealFrac(..), P.RealFloat(..), + ) where +import BasicPrelude as AlgebraicPrelude hiding + (Floating (..), + Fractional (..), + Integral (..), + Num (..), + Rational, + Real (..), + RealFloat (..), + RealFrac (..), + fromShow, + gcd, + getArgs, + getContents, + getLine, + id, + interact, + lcm, + lines, + product, + putStr, + putStrLn, + read, + readFile, + show, + subtract, + sum, + unlines, + unwords, + words, + writeFile, + (.), + (\\), + (^), + (^^)) +import qualified Control.Lens.TH as L +import qualified Data.Ratio as P +import qualified Data.Semigroup as Semi +import Numeric.Algebra as AlgebraicPrelude hiding + (Order (..), + fromInteger, + (^)) +import qualified Numeric.Algebra as NA +import Numeric.Algebra.Unital.UnitNormalForm as AlgebraicPrelude hiding + (normalize) +import qualified Numeric.Algebra.Unital.UnitNormalForm as NA +import Numeric.Decidable.Associates as AlgebraicPrelude +import Numeric.Decidable.Units as AlgebraicPrelude +import Numeric.Decidable.Zero as AlgebraicPrelude +import Numeric.Domain.Class as AlgebraicPrelude +import Numeric.Domain.Euclidean as AlgebraicPrelude +import Numeric.Domain.GCD as AlgebraicPrelude +import Numeric.Domain.Integral as AlgebraicPrelude +import Numeric.Domain.PID as AlgebraicPrelude +import Numeric.Domain.UFD as AlgebraicPrelude +import Numeric.Field.Fraction as AlgebraicPrelude +import Numeric.Semiring.ZeroProduct as AlgebraicPrelude +import Prelude as AlgebraicPrelude (Show (..), + ceiling, + div, + floor, + getContents, + getLine, + id, + interact, + lines, + mod, + putStr, + putStrLn, + readFile, + show, + unlines, + unwords, + words, + writeFile, + (.)) +import qualified Prelude as P + +-- * Basic types and renamed operations +-- | We use @'Fraction'@ instead of @'Ratio'@ for consistency. +type Rational = Fraction Integer + +infixr 8 ^, ^^ + +-- | To work with Num literals. +fromInteger :: P.Num r => Integer -> r +fromInteger = P.fromInteger +{-# INLINE [1] fromInteger #-} +{-# RULES +"fromInteger/Integer" + fromInteger = id + #-} + +-- | @algebra@ package's original @'NA.fromInteger'@. +fromInteger' :: Ring r => Integer -> r +fromInteger' = NA.fromInteger + +fromRational :: DivisionRing r => P.Rational -> r +fromRational r = NA.fromInteger (P.numerator r) / NA.fromInteger (P.denominator r) +{-# INLINE [1] fromRational #-} +{-# RULES +"fromRational/Rational" [~1] + fromRational = id + #-} + +normaliseUnit :: UnitNormalForm r => r -> r +normaliseUnit = NA.normalize + +-- | Specialised version of @'pow'@ which takes @'Natural'@s as a power. +(^) :: Unital r => r -> Natural -> r +(^) = pow + +-- | The original power function @('NA.^')@ of @algebra@ +(^^) :: Division r => r -> Integer -> r +(^^) = (NA.^) + +{-# RULES +"negate/Ring" forall (x :: Ring a => a). + P.negate x = NA.negate x + +"minus/Ring" forall (x :: Ring a => a) y. + x P.- y = x NA.- y + + #-} + +-- * Combinator to use with @RebindableSyntax@ extensions. +ifThenElse :: Bool -> a -> a -> a +ifThenElse p t f = if p then t else f + +-- * Wrapper types for conversion between @'Num'@ family +-- and algebraic hierarchy provided by @algebra@. + +-- | Wrapping Prelude's numerical types to treat with +-- @'Numeric.Algebra'@ hierachy. +-- +-- For @'Field'@ or @'Euclidean'@ instances, see @'WrapIntegral'@ and @'WrapField'@. +-- +-- __N.B.__ This type provides a mean to convert from @'Num'@s +-- to @'Ring'@s, but there is no guarantee that +-- @'WrapNum' a@ is actually ring. +-- For example, due to precision limitation, +-- @'WrapPreldue' 'Double'@ even fails to be semigroup! +-- For another simpler example, even though @'Natural'@ comes +-- with @'Num'@ instance, but it doesn't support @'negate'@, +-- so it cannot be @'Group'@. +newtype WrapNum a = WrapNum { unwrapNum :: a } + deriving (Read, Show, Eq, Ord) + +instance (P.Num a) => Additive (WrapNum a) where + WrapNum a + WrapNum b = WrapNum (a P.+ b) + {-# INLINE (+) #-} + sinnum1p n (WrapNum a) = WrapNum ((1 P.+ fromIntegral n) P.* a) + {-# INLINE sinnum1p #-} + +instance (P.Num a) => LeftModule Natural (WrapNum a) where + n .* WrapNum r = WrapNum (P.fromIntegral n P.* r) + {-# INLINE (.*) #-} + +instance (P.Num a) => RightModule Natural (WrapNum a) where + WrapNum r *. n = WrapNum (r P.* P.fromIntegral n) + {-# INLINE (*.) #-} + +instance (P.Num a) => Monoidal (WrapNum a) where + zero = WrapNum (P.fromInteger 0) + {-# INLINE zero #-} + sinnum n (WrapNum a) = WrapNum ((fromIntegral n) P.* a) + {-# INLINE sinnum #-} + +instance (P.Num a) => LeftModule Integer (WrapNum a) where + n .* WrapNum r = WrapNum (P.fromIntegral n P.* r) + {-# INLINE (.*) #-} + +instance (P.Num a) => RightModule Integer (WrapNum a) where + WrapNum r *. n = WrapNum (r P.* P.fromIntegral n) + {-# INLINE (*.) #-} + +instance (P.Num a) => Group (WrapNum a) where + negate (WrapNum a) = WrapNum $ P.negate a + {-# INLINE negate #-} + WrapNum a - WrapNum b = WrapNum (a P.- b) + {-# INLINE (-) #-} + subtract (WrapNum a) (WrapNum b) = WrapNum (P.subtract a b) + {-# INLINE subtract #-} + times n (WrapNum a) = WrapNum $ fromIntegral n P.* a + {-# INLINE times #-} + +instance (P.Num a) => Multiplicative (WrapNum a) where + WrapNum p * WrapNum q = WrapNum (p P.* q) + {-# INLINE (*) #-} + pow1p (WrapNum p) n = WrapNum (p P.^ (n + 1)) + {-# INLINE pow1p #-} + +instance (P.Num a) => Unital (WrapNum a) where + one = WrapNum $ P.fromInteger 1 + {-# INLINE one #-} + pow (WrapNum a) n = WrapNum $ a P.^ n + {-# INLINE pow #-} + +instance P.Num a => Abelian (WrapNum a) +instance P.Num a => Semiring (WrapNum a) +instance P.Num a => Rig (WrapNum a) where + fromNatural = WrapNum . P.fromIntegral + {-# INLINE fromNatural #-} +instance P.Num a => Ring (WrapNum a) where + fromInteger = WrapNum . P.fromInteger + {-# INLINE fromInteger #-} + +instance P.Num a => Commutative (WrapNum a) + +instance (P.Num a, Eq a) => DecidableZero (WrapNum a) where + isZero (WrapNum a) = a == 0 + {-# INLINE isZero #-} + +-- | Similar to @'WrapNum'@, but produces @'Field'@ instances from +-- @'Fractional'@s. +-- +-- See also: @'WrapIntegral'@ and @'WrapNum'@. +newtype WrapFractional a = WrapFractional { unwrapFractional :: a } + +instance (P.Num a) => Additive (WrapFractional a) where + WrapFractional a + WrapFractional b = WrapFractional (a P.+ b) + {-# INLINE (+) #-} + sinnum1p n (WrapFractional a) = WrapFractional ((1 P.+ fromIntegral n) P.* a) + {-# INLINE sinnum1p #-} + +instance (P.Num a) => LeftModule Natural (WrapFractional a) where + n .* WrapFractional r = WrapFractional (P.fromIntegral n P.* r) + {-# INLINE (.*) #-} + +instance (P.Num a) => RightModule Natural (WrapFractional a) where + WrapFractional r *. n = WrapFractional (r P.* P.fromIntegral n) + {-# INLINE (*.) #-} + +instance (P.Num a) => Monoidal (WrapFractional a) where + zero = WrapFractional (P.fromInteger 0) + {-# INLINE zero #-} + sinnum n (WrapFractional a) = WrapFractional ((fromIntegral n) P.* a) + {-# INLINE sinnum #-} + +instance (P.Num a) => LeftModule Integer (WrapFractional a) where + n .* WrapFractional r = WrapFractional (P.fromIntegral n P.* r) + {-# INLINE (.*) #-} + +instance (P.Num a) => RightModule Integer (WrapFractional a) where + WrapFractional r *. n = WrapFractional (r P.* P.fromIntegral n) + {-# INLINE (*.) #-} + +instance (P.Num a) => Group (WrapFractional a) where + negate (WrapFractional a) = WrapFractional $ P.negate a + {-# INLINE negate #-} + WrapFractional a - WrapFractional b = WrapFractional (a P.- b) + {-# INLINE (-) #-} + subtract (WrapFractional a) (WrapFractional b) = WrapFractional (P.subtract a b) + {-# INLINE subtract #-} + times n (WrapFractional a) = WrapFractional $ fromIntegral n P.* a + {-# INLINE times #-} + +instance (P.Num a) => Multiplicative (WrapFractional a) where + WrapFractional p * WrapFractional q = WrapFractional (p P.* q) + {-# INLINE (*) #-} + pow1p (WrapFractional p) n = WrapFractional (p P.^ (n + 1)) + {-# INLINE pow1p #-} + +instance (P.Num a) => Unital (WrapFractional a) where + one = WrapFractional $ P.fromInteger 1 + {-# INLINE one #-} + pow (WrapFractional a) n = WrapFractional $ a P.^ n + {-# INLINE pow #-} + +instance P.Num a => Abelian (WrapFractional a) +instance P.Num a => Semiring (WrapFractional a) +instance P.Num a => Rig (WrapFractional a) where + fromNatural = WrapFractional . P.fromIntegral + {-# INLINE fromNatural #-} +instance P.Num a => Ring (WrapFractional a) where + fromInteger = WrapFractional . P.fromInteger + {-# INLINE fromInteger #-} + +instance P.Num a => Commutative (WrapFractional a) + +instance (P.Num a, Eq a) => DecidableZero (WrapFractional a) where + isZero (WrapFractional a) = a == 0 + {-# INLINE isZero #-} + +instance P.Fractional a => Division (WrapFractional a) where + recip = WrapFractional . P.recip . unwrapFractional + {-# INLINE recip #-} + WrapFractional a / WrapFractional b = WrapFractional $ a P./ b + {-# INLINE (/) #-} + WrapFractional a \\ WrapFractional b = WrapFractional $ P.recip a P.* b + {-# INLINE (\\) #-} + WrapFractional a ^ n = WrapFractional (a P.^^ n) + {-# INLINE (^) #-} + +instance (Eq a, P.Fractional a) => ZeroProductSemiring (WrapFractional a) +instance (Eq a, P.Fractional a) => DecidableUnits (WrapFractional a) where + isUnit (WrapFractional r) = r /= 0 + {-# INLINE isUnit #-} + + recipUnit (WrapFractional r) = + if r == 0 + then Nothing + else Just (WrapFractional $ P.recip r) + {-# INLINE recipUnit #-} + +instance (Eq a, P.Fractional a) => DecidableAssociates (WrapFractional a) where + isAssociate (WrapFractional a) (WrapFractional b) = + (a == 0 && b == 0) || (a /= 0 && b /= 0) + {-# INLINE isAssociate #-} + +instance (Eq a, P.Fractional a) => UnitNormalForm (WrapFractional a) +instance (Eq a, P.Fractional a) => IntegralDomain (WrapFractional a) +instance (Eq a, P.Fractional a) => GCDDomain (WrapFractional a) +instance (Eq a, P.Fractional a) => Euclidean (WrapFractional a) +instance (Eq a, P.Fractional a) => PID (WrapFractional a) +instance (Eq a, P.Fractional a) => UFD (WrapFractional a) + +-- | Similar to @'WrapNum'@, but produces @'Euclidean'@ instances from +-- @'Integral'@s. +-- +-- See also: @'WrapFractional'@ and @'WrapNum'@. +newtype WrapIntegral a = WrapIntegral { unwrapIntegral :: a } + +instance (P.Num a) => Additive (WrapIntegral a) where + WrapIntegral a + WrapIntegral b = WrapIntegral (a P.+ b) + {-# INLINE (+) #-} + sinnum1p n (WrapIntegral a) = WrapIntegral ((1 P.+ fromIntegral n) P.* a) + {-# INLINE sinnum1p #-} + +instance (P.Num a) => LeftModule Natural (WrapIntegral a) where + n .* WrapIntegral r = WrapIntegral (P.fromIntegral n P.* r) + {-# INLINE (.*) #-} + +instance (P.Num a) => RightModule Natural (WrapIntegral a) where + WrapIntegral r *. n = WrapIntegral (r P.* P.fromIntegral n) + {-# INLINE (*.) #-} + +instance (P.Num a) => Monoidal (WrapIntegral a) where + zero = WrapIntegral (P.fromInteger 0) + {-# INLINE zero #-} + sinnum n (WrapIntegral a) = WrapIntegral ((fromIntegral n) P.* a) + {-# INLINE sinnum #-} + +instance (P.Num a) => LeftModule Integer (WrapIntegral a) where + n .* WrapIntegral r = WrapIntegral (P.fromIntegral n P.* r) + {-# INLINE (.*) #-} + +instance (P.Num a) => RightModule Integer (WrapIntegral a) where + WrapIntegral r *. n = WrapIntegral (r P.* P.fromIntegral n) + {-# INLINE (*.) #-} + +instance (P.Num a) => Group (WrapIntegral a) where + negate (WrapIntegral a) = WrapIntegral $ P.negate a + {-# INLINE negate #-} + WrapIntegral a - WrapIntegral b = WrapIntegral (a P.- b) + {-# INLINE (-) #-} + subtract (WrapIntegral a) (WrapIntegral b) = WrapIntegral (P.subtract a b) + {-# INLINE subtract #-} + times n (WrapIntegral a) = WrapIntegral $ fromIntegral n P.* a + {-# INLINE times #-} + +instance (P.Num a) => Multiplicative (WrapIntegral a) where + WrapIntegral p * WrapIntegral q = WrapIntegral (p P.* q) + {-# INLINE (*) #-} + pow1p (WrapIntegral p) n = WrapIntegral (p P.^ (n + 1)) + {-# INLINE pow1p #-} + +instance (P.Num a) => Unital (WrapIntegral a) where + one = WrapIntegral $ P.fromInteger 1 + {-# INLINE one #-} + pow (WrapIntegral a) n = WrapIntegral $ a P.^ n + {-# INLINE pow #-} + +instance P.Num a => Abelian (WrapIntegral a) +instance P.Num a => Semiring (WrapIntegral a) +instance P.Num a => Rig (WrapIntegral a) where + fromNatural = WrapIntegral . P.fromIntegral + {-# INLINE fromNatural #-} +instance P.Num a => Ring (WrapIntegral a) where + fromInteger = WrapIntegral . P.fromInteger + {-# INLINE fromInteger #-} + +instance P.Num a => Commutative (WrapIntegral a) + +instance (P.Num a, Eq a) => DecidableZero (WrapIntegral a) where + isZero (WrapIntegral a) = a == 0 + {-# INLINE isZero #-} + +instance (Eq a, P.Integral a) => ZeroProductSemiring (WrapIntegral a) +instance (Eq a, P.Integral a) => DecidableUnits (WrapIntegral a) where + isUnit (WrapIntegral r) = r == 1 || r == P.negate 1 + {-# INLINE isUnit #-} + + recipUnit (WrapIntegral r) = + if isUnit (WrapIntegral r) + then Nothing + else Just (WrapIntegral r) + {-# INLINE recipUnit #-} + +instance (Eq a, P.Integral a) => DecidableAssociates (WrapIntegral a) where + isAssociate (WrapIntegral a) (WrapIntegral b) = P.abs a == P.abs b + {-# INLINE isAssociate #-} + +instance (Eq a, P.Integral a) => UnitNormalForm (WrapIntegral a) where + splitUnit (WrapIntegral 0) = (WrapIntegral 1, WrapIntegral 0) + splitUnit (WrapIntegral a) = (WrapIntegral $ P.signum a, WrapIntegral $ P.abs a) + {-# INLINE splitUnit #-} + +instance (Eq a, P.Integral a) => IntegralDomain (WrapIntegral a) +instance (Eq a, P.Integral a) => GCDDomain (WrapIntegral a) where + gcd (WrapIntegral a) (WrapIntegral b) = WrapIntegral (P.gcd a b) + {-# INLINE gcd #-} + + lcm (WrapIntegral a) (WrapIntegral b) = WrapIntegral (P.lcm a b) + {-# INLINE lcm #-} + +instance (Eq a, P.Integral a) => Euclidean (WrapIntegral a) where + divide (WrapIntegral f) (WrapIntegral g) = + let (q, r) = P.divMod f g + in (WrapIntegral q, WrapIntegral r) + {-# INLINE divide #-} + degree (WrapIntegral 0) = Nothing + degree (WrapIntegral a) = Just $ P.fromIntegral (P.abs a) + {-# INLINE degree #-} + + quot (WrapIntegral a) (WrapIntegral b) = WrapIntegral $ P.div a b + {-# INLINE quot #-} + rem (WrapIntegral a) (WrapIntegral b) = WrapIntegral $ P.mod a b + {-# INLINE rem #-} + +instance (Eq a, P.Integral a) => PID (WrapIntegral a) +instance (Eq a, P.Integral a) => UFD (WrapIntegral a) + +-- | Turning types from @'Numeric.Algebra'@ into Prelude's Num instances. +-- +-- N.B. Since @'Real'@'s @'toRational'@ constraint is too tight, +-- we won't provide the inverse of @'WrapIntegral'@ and +-- provide @'Fractional'@ instance only. +newtype WrapAlgebra a = WrapAlgebra { unwrapAlgebra :: a } + deriving (Read, Show, Eq, Ord) + +instance (Ring a, UnitNormalForm a) => P.Num (WrapAlgebra a) where + WrapAlgebra a + WrapAlgebra b = WrapAlgebra $ a NA.+ b + {-# INLINE (+) #-} + WrapAlgebra a - WrapAlgebra b = WrapAlgebra $ a NA.- b + {-# INLINE (-) #-} + WrapAlgebra a * WrapAlgebra b = WrapAlgebra $ a NA.* b + {-# INLINE (*) #-} + fromInteger = WrapAlgebra . NA.fromInteger + {-# INLINE fromInteger #-} + signum = WrapAlgebra . leadingUnit . unwrapAlgebra + {-# INLINE signum #-} + abs = WrapAlgebra . normaliseUnit . unwrapAlgebra + {-# INLINE abs #-} + negate = WrapAlgebra . negate . unwrapAlgebra + {-# INLINE negate #-} + +instance (DivisionRing a, UnitNormalForm a) => P.Fractional (WrapAlgebra a) where + WrapAlgebra a / WrapAlgebra b = WrapAlgebra (a / b) + {-# INLINE (/) #-} + recip (WrapAlgebra a) = WrapAlgebra (recip a) + {-# INLINE recip #-} + fromRational = WrapAlgebra . fromRational + {-# INLINE fromRational #-} + +instance Euclidean a => P.Num (Fraction a) where + {-# SPECIALISE instance P.Num (Fraction Integer) #-} + (+) = (NA.+) + (-) = (NA.-) + negate = NA.negate + (*) = (NA.*) + fromInteger = NA.fromInteger + abs = normaliseUnit + signum = leadingUnit + +instance Euclidean d => P.Fractional (Fraction d) where + {-# SPECIALISE instance P.Fractional (Fraction Integer) #-} + fromRational r = fromInteger' (P.numerator r) % fromInteger' (P.denominator r) + recip = NA.recip + (/) = (NA./) + +-- | @'Monoid'@ instances for @'Additive'@s. +-- N.B. Unlike @'WrapNum'@, @'P.Num'@ instance is +-- just inhereted from the unwrapped data. +newtype Add a = Add { runAdd :: a } + deriving (Read, Show, Eq, Ord, P.Num) + +instance Additive a => Semi.Semigroup (Add a) where + Add a <> Add b = Add (a NA.+ b) + {-# INLINE (<>) #-} + + sconcat = Add . sum1 . map runAdd + {-# INLINE sconcat #-} + + stimes n = Add . sinnum1p (P.fromIntegral n P.- 1) . runAdd + {-# INLINE stimes #-} + +instance Monoidal a => Monoid (Add a) where + mappend = (Semi.<>) + {-# INLINE mappend #-} + mempty = Add zero + {-# INLINE mempty #-} + mconcat = Add . sum . map runAdd + {-# INLINE mconcat #-} + +-- | @'Monoid'@ instances for @'Additive'@s. +-- N.B. Unlike @'WrapNum'@, @'P.Num'@ instance is +-- just inhereted from the unwrapped data. +newtype Mult a = Mult { runMult :: a } + deriving (Read, Show, Eq, Ord, P.Num) + +instance Multiplicative a => Semi.Semigroup (Mult a) where + Mult a <> Mult b = Mult (a NA.* b) + {-# INLINE (<>) #-} + + sconcat = Mult . product1 . map runMult + {-# INLINE sconcat #-} + + stimes n = Mult . flip pow1p (P.fromIntegral n P.- 1) . runMult + {-# INLINE stimes #-} + +instance Unital a => Monoid (Mult a) where + mappend = (Semi.<>) + {-# INLINE mappend #-} + mempty = Mult one + {-# INLINE mempty #-} + mconcat = Mult . product . map runMult + {-# INLINE mconcat #-} + +L.makeWrapped ''WrapNum +L.makeWrapped ''WrapIntegral +L.makeWrapped ''WrapFractional +L.makeWrapped ''WrapAlgebra +L.makeWrapped ''Add +L.makeWrapped ''Mult