-- This is written in Haskell.
{--
HBase -- general-purpose libraries for Haskell
Copyright (C) 2003 Ashley Yakeley <ashley@semantic.org>

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--}

module Main where
	{
	import Numeric;
	import Prelude;

	for :: (Monad m) => [a] -> (a -> m ()) -> m ();
	for [] _ = return ();
	for (a:as) f = do
		{
		f a;
		for as f;
		};

	dodouble :: (Monad m) => ((Double,String) -> m ()) -> ((Double,String) -> m ());
	dodouble f (d,s) = do
		{
		f (d,s);
		f (-d,"-"++s);
		};

	reals :: [(Double,String)];
	reals =
		[
		(0.0,"0"),
		(encodeFloat 1 (-1075),"(encodeFloat 1 -1075)"),
		(encodeFloat 1 (-1074),"(encodeFloat 1 -1074)"),
		(5E-324,"5E-324"),
		(1E-323,"1E-323"),
		(1E-310,"1E-310"),
		(1E-308,"1E-308"),
		(encodeFloat 1 (-1023),"(encodeFloat 1 -1023)"),
		(encodeFloat 0x10000000000000 (-1075),"(encodeFloat 0x10000000000000 -1075)"),
		(encodeFloat 0x10000000000001 (-1075),"(encodeFloat 0x10000000000001 -1075)"),
		(encodeFloat 0x1FFFFFFFFFFFF8 (-1075),"(encodeFloat 0x1FFFFFFFFFFFF8 -1075)"),
		(encodeFloat 0x1FFFFFFFFFFFFC (-1075),"(encodeFloat 0x1FFFFFFFFFFFFC -1075)"),
		(encodeFloat 0x0FFFFFFFFFFFFD (-1074),"(encodeFloat 0x0FFFFFFFFFFFFD -1074)"),
		(encodeFloat 0x1FFFFFFFFFFFFD (-1075),"(encodeFloat 0x1FFFFFFFFFFFFD -1075)"),
		(encodeFloat 0x0FFFFFFFFFFFFE (-1074),"(encodeFloat 0x0FFFFFFFFFFFFE -1074)"),
		(encodeFloat 0x1FFFFFFFFFFFFE (-1075),"(encodeFloat 0x1FFFFFFFFFFFFE -1075)"),
		(encodeFloat 0x0FFFFFFFFFFFFF (-1074),"(encodeFloat 0x0FFFFFFFFFFFFF -1074)"),
		(encodeFloat 0x1FFFFFFFFFFFFF (-1075),"(encodeFloat 0x1FFFFFFFFFFFFF -1075)"),
		(encodeFloat 0x20000000000000 (-1075),"(encodeFloat 0x20000000000000 -1075)"),
		(encodeFloat 0x10000000000000 (-1074),"(encodeFloat 0x10000000000000 -1074)"),
		(encodeFloat 0x10000000000001 (-1074),"(encodeFloat 0x10000000000001 -1074)"),
		(1E-307,"1E-307"),
		(1E-200,"1E-200"),
		(1E-16,"1E-16"),
		(1E-6,"1E-6"),
		(0.2,"1/5"),
		(0.5,"1/2"),
		(0.8,"4/5"),
		(1.0,"1"),
		(27.0,"27"),
		(34.2,"34.2"),
		(1E10,"1E10"),
		(1E100,"1E100"),
		(1E300,"1E300"),
		(1.0/0.0,"infinity"),
		(0.0/0.0,"NaN")
		];

	tests :: [(Double -> Bool,String)];
	tests =
		[
		(\r -> r == r,"r==r"),
		(isNaN,"isNaN"),
		(isInfinite,"isInfinite"),
		(isDenormalized,"isDenormalized"),
		(isNegativeZero,"isNegativeZero"),
		(isIEEE,"isIEEE")
		];

	showI :: Integer -> String;
	showI = show;

	showSignedHex :: Integer -> String;
	showSignedHex i | i < 0 = "-"++(showSignedHex (-i));
	showSignedHex i = "0x" ++ (showHex i "");

	showDecodeFloat :: Double -> String;
	showDecodeFloat d = (showSignedHex m)++"*2^"++(show e) where
		{
		(m,e) = decodeFloat d;
		};

	rshows :: [(Double -> String,String)];
	rshows =
		[
		(showDecodeFloat,"decodeFloat"),
		(show . toRational,"rational"),
		(\r -> show (properFraction r :: (Integer,Double)) ,"properFraction"),
		(showI . truncate,"truncate"),
		(showI . round,"round"),
		(showI . ceiling,"ceiling"),
		(showI . floor,"floor")
		];

	main :: IO ();
	main = do
		{
		for reals (dodouble (\(r,name) -> do
			{
			putStrLn ("--- "++name);
			putStrLn ("Show: " ++(show r));
			putStr "Properties:";
			for tests (\(test,tname) -> if test r then putStr (" " ++tname) else return ());
			putStrLn "";
			putStr "Equivalence:";
			for reals (dodouble (\(r',name') -> if (r == r') then putStr (" " ++name') else return ()));
			putStrLn "";
			if isNaN r
			 then putStrLn "*** NaN"
			 else for rshows (\(f,fname) -> putStrLn (fname ++ ": " ++ (f r)));
			}));
		};
	}