[Haskell-cafe] Strange subtract operator behavior - and lazy naturals

[John Meacham]

On Wed, Oct 17, 2007 at 03:13:23AM +0100, Lennart Augustsson wrote:
> If naturals have a perfectly reasonable subtraction then they also have a
> perfectly reasonable negate; the default is 0-x.
> 
> (Oh, subtraction wasn't THAT reasonable, you say. :) )


I suppose I was overextending the use of 'perfectly reasonable' here. :)

tangent:

if anyone is interested, Although I bet this has been implemented a
hundred times over, I have attached my lazy naturals module below just
for larks. It is quite efficient as such things go and very lazy. for
instance (genericLength xs > 5) will only evaluate up to the 5th element
of the list before returning a result. and ((1 `div` 0) > 17) is true,
not bottom.

Anyone have any comments on my lazy multiplication algorithm? since each
number is of the form (x + rx) (an integer, plus the lazy remainder) I
just did the multiplicitive expansion 

(x + rx) * (y + ry) -> x*y + x*ry + y*rx + rx*ry
then I simplify to 
(x + rx) * (y + ry) -> x*y + x*ry + rx*(y + ry)
which saves a nice recursive call to * speeding thinsg up signifigantly.
but is there a better way?

since (+) is lazy, we can still get a good lazy result without
evaluating the tails when multiplying... that is nice.

also, what do you think 
n `mod` 0 should be? I can see arguments for it being 'n', 0, or
Infinity depending on how you look at it.. hmm..


If anyone wants me to clean this up and package it as a real module, I
would be happy to do so.

sorry for the tangent. just one of those days.

        John


-- 
John Meacham - ⑆repetae.net⑆john⑈
-------------- next part --------------

-- Copyright (c) 2007 John Meacham (john at repetae dot net)
-- 
-- Permission is hereby granted, free of charge, to any person obtaining a
-- copy of this software and associated documentation files (the
-- "Software"), to deal in the Software without restriction, including
-- without limitation the rights to use, copy, modify, merge, publish,
-- distribute, sublicense, and/or sell copies of the Software, and to
-- permit persons to whom the Software is furnished to do so, subject to
-- the following conditions:
-- 
-- The above copyright notice and this permission notice shall be included
-- in all copies or substantial portions of the Software.
-- 
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
-- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

-- efficient lazy naturals

module Util.LazyNum where

-- Nat data type is eqivalant to a type restricted lazy list that is strict in
-- its elements.
--
-- Invarients: (Sum x _) => x > 0
-- in particular (Sum 0 _) is _not_ valid and must not occur.

data Nat = Sum !Integer Nat | Zero
    deriving(Show)

instance Eq Nat where
    Zero == Zero = True
    Zero == _ = False
    _ == Zero = False
    Sum x nx == Sum y ny = case compare x y of
        EQ -> nx == ny
        LT -> nx == Sum (y - x) ny
        GT -> Sum (x - y) nx == ny


instance Ord Nat where
    Zero <= _ = True
    _ <= Zero = False
    Sum x nx <= Sum y ny = case compare x y of
        EQ -> nx <= ny
        LT -> nx <= Sum (y - x) ny
        GT -> Sum (x - y) nx <= ny

    Zero `compare` Zero = EQ
    Zero `compare` _ = LT
    _    `compare` Zero = GT
    Sum x nx `compare` Sum y ny = case compare x y of
        EQ -> nx `compare` ny
        LT -> nx `compare` Sum (y - x) ny
        GT -> Sum (x - y) nx `compare` ny

    x < y = not (x >= y)
    x >= y = y <= x
    x > y = y < x


instance Num Nat where
    Zero + y = y
    x + Zero = x
    Sum x n1 + Sum y n2 = Sum (x + y) (n1 + n2)

    Zero - _ = zero
    x - Zero = x
    Sum x n1 - Sum y n2 = case compare x y of
        GT -> Sum (x - y) n1 - n2
        EQ -> n1 - n2
        LT -> n1 - Sum (y - x) n2
    negate _ = zero
    abs x = x
    signum Zero = zero
    signum _ = one
    fromInteger x = if x <= 0 then zero else Sum x Zero

    Zero * _ = Zero
    _ * Zero = Zero
    (Sum x nx) * (Sum y ny) = Sum (x*y) ((f x ny) + (nx * (fint y + ny))) where
        f y Zero = Zero
        f y (Sum x n) = Sum (x*y) (f y n)



instance Real Nat where
    toRational n = toRational (toInteger n)

instance Enum Nat where
    succ x = Sum 1 x
    pred Zero = Zero
    pred (Sum n x) = if n == 1 then x else Sum (n - 1) x
    enumFrom x = x:[ Sum n x | n <- [1 ..]]
    enumFromThen x y = x:y:f (y + z) where
        z = y - x
        f x = x:f (x + z)
    toEnum = fromIntegral
    fromEnum = fromIntegral

-- d > 0
doDiv :: Nat -> Integer -> Nat
doDiv n d = f 0 n where
    f _ Zero = 0
    f cm (Sum x nx) = sum d (f m nx) where
        (d,m) = (x + cm) `quotRem` d
        sum 0 x = x
        sum n x = Sum n x

doMod :: Nat -> Integer -> Nat
doMod n d = f 0 n where
    f 0 Zero = Zero
    f r Zero = fint r
    f r (Sum x nx) = f ((r + x) `rem` d) nx

instance Integral Nat where
    _ `div` Zero = infinity
    n1 `div` n2 | n1 < n2 = 0
                 | otherwise = doDiv n1 (toInteger n2)
    n1 `mod` Zero = n1 -- XXX
    n1 `mod` n2 | n1 < n2 = n1
                | otherwise = doMod n1 (toInteger n2)
    n `divMod` Zero = (infinity,n)
    n `divMod` d | n < d = (0,n)
                 | otherwise = let d' = toInteger d in (doDiv n d',doMod n d')
    quotRem = divMod
    quot = div
    rem = mod
    toInteger n = f 0 n where
        f n _ | n `seq` False = undefined
        f n Zero = n
        f n (Sum x n1) = let nx = n + x in nx `seq` f nx n1

-- convert to integer unless it is too big, in which case Nothing is returned

natToInteger :: Integer -> Nat -> Maybe Integer
natToInteger limit n = f 0 n where
    f n _ | n > limit = Nothing
    f n Zero = Just n
    f n (Sum x n1) = let nx = n + x in nx `seq` f nx n1

natShow :: Nat -> String
natShow n = case natToInteger bigNum n of
    Nothing -> "(too big)"
    Just v -> show v

natFoldr :: (Integer -> b -> b) -> b -> Nat -> b
natFoldr cons nil n = f n where
    f Zero = nil
    f (Sum x r) = cons x (f r)

-- some utility routines

natEven :: Nat -> Bool
natEven n = f True n where
    f r Zero = r
    f r (Sum x n) = if even x then f r n else f (not r) n

zero = Zero
one = Sum 1 Zero
infinity = Sum bigNum infinity
bigNum = 100000000000
fint x = Sum x Zero

-- random testing stuff for ghci

ti op x y = (toInteger $ x `op` y, toInteger x `op` toInteger y)

depth n | n <= 0 = error "depth exceeded"
        | otherwise = Sum n (depth $ n - 1)

depth' n | n <= 0 = Zero
         | otherwise = Sum n (depth' $ n - 1)