\begin{code}
{-# OPTIONS -fno-implicit-prelude -fglasgow-exts #-}
module NumExtras (
    Module((*>)),
    Lattice(up, dn),
    max, min, abs
) where
import NumPrelude hiding (abs)
import PreludeBase hiding (max, min)
import qualified Prelude as StdPrelude
\end{code}

\begin{code}
infixl 7 *>
infixl 5 `up`, `dn`
\end{code}

\begin{code}
class (Additive b, Num a) => Module a b where
    (*>) :: a -> b -> b
\end{code}

To define any Additive as a module over Integer, you can use integerMultiply:

\begin{code}
integerMultiply :: (ToInteger a, Additive b) => a -> b -> b
integerMultiply a b = reduceRepeated (+) zero b (toInteger a)
\end{code}

\begin{code}
prop_ModuleAction a b c            = (a * b) *> c == a *> (b *> c)
prop_ModuleRightDistributive a b c =   a *> (b+c) == a*>b + a*>c
prop_ModuleLeftDistributive a b c  =   (a+b) *> c == a*>c + b*>c
\end{code}

\begin{code}
instance Module Integer Integer where
    (*>) = (*)

instance Module Rational Rational where
    (*>) = (*)

instance Module Integer Rational where
    x *> y = (fromInteger x) * y

instance (Additive a, Additive b) => Additive (a,b) where
    (x1,y1) + (x2,y2) = (x1+x2,y1+y2)
    zero = (zero, zero)
    (x1,y1) - (x2,y2) = (x1-x2,y1-y2)
instance (Module a b, Module a c) => Module a (b,c) where
    x *> (y, z) = (x*>y, x*>z)
\end{code}

\begin{code}
class Lattice a where
    up, dn :: a -> a -> a
\end{code}

\begin{code}
prop_UpCommutative a b      =          a `up` b == b `up` a
prop_DnCommutative a b      =          a `dn` b == b `dn` a
prop_UpAssociative a b c    = a `up` (b `up` c) == (a `up` b) `up` c
prop_DnAssociative a b c    = a `dn` (b `dn` c) == (a `dn` b) `dn` c
prop_UpDnDistributive a b c = a `up` (b `dn` c) == (a `up` b) `dn` (a `up` c)
prop_DnUpDistributive a b c = a `dn` (b `up` c) == (a `dn` b) `up` (a `dn` c)
\end{code}

\begin{code}
instance Lattice Integer where
    up = StdPrelude.max
    dn = StdPrelude.min

instance Lattice Rational where
    up = StdPrelude.max
    dn = StdPrelude.min

instance (Lattice a, Lattice b) => Lattice (a,b) where
    (x1,y1)`up`(x2,y2) = (x1`up`x2, y1`up`y2)
    (x1,y1)`dn`(x2,y2) = (x1`dn`x2, y1`dn`y2)
\end{code}

\begin{code}
max, min :: (Lattice a) => a -> a -> a
max = up
min = dn

abs x = x `up` (-x)
\end{code}