[ add a lot of new regression tests, many bugs that the lhc developers found, make regress.prl check the 'mustfail' status of tests
John Meacham <john@repetae.net>**20090902002017
 Ignore-this: 455861464ee8627b72f3dc343d7447e9
] move ./regress/tests/3_shootout ./regress/tests/8_shootout
adddir ./regress/tests/7_large
move ./regress/tests/1_io/basic/fastest_fib.expected.stdout ./regress/tests/7_large/fastest_fib.expected.stdout
move ./regress/tests/1_io/basic/fastest_fib.hs ./regress/tests/7_large/fastest_fib.hs
addfile ./regress/tests/0_prim/Recursive2.hs
addfile ./regress/tests/4_bugs/Defaulting.expected.stdout
addfile ./regress/tests/4_bugs/Defaulting.hs
addfile ./regress/tests/4_bugs/ImportZeal.expected.stdout
addfile ./regress/tests/4_bugs/ImportZeal.hs
addfile ./regress/tests/4_bugs/NoMonomorphism.expected.stdout
addfile ./regress/tests/4_bugs/NoMonomorphism.hs
addfile ./regress/tests/4_bugs/Parsing1.hs
addfile ./regress/tests/4_bugs/Qualify1.hs
addfile ./regress/tests/4_bugs/Segfault1.expected.stdout
addfile ./regress/tests/4_bugs/Segfault1.hs
addfile ./regress/tests/4_bugs/Shadowing.hs
addfile ./regress/tests/4_bugs/Shadowing.mustfail
addfile ./regress/tests/4_bugs/UnpackedPoly.expected.stdout
addfile ./regress/tests/4_bugs/UnpackedPoly.hs
addfile ./regress/tests/7_large/RayT.args
addfile ./regress/tests/7_large/RayT.expected.stdout
addfile ./regress/tests/7_large/RayT.hs
hunk ./regress/regress.prl 144
-my @libs = $opt_l ? ("-pjhc") : ("--noauto", "-i$jhc_dir/lib/jhc", "-i$jhc_dir/lib/base","-i$jhc_dir/lib/haskell98");
+my @libs = $opt_l ? ("-L-", "-L$jhc_dir", "-pjhc") : ("--noauto", "-i$jhc_dir/lib/jhc", "-i$jhc_dir/lib/base","-i$jhc_dir/lib/haskell98");
hunk ./regress/regress.prl 162
+            my $must_fail = -f "$cwd/$ln.mustfail" ? 1 : 0;
hunk ./regress/regress.prl 189
+            if($must_fail) {
+                if($r == 0) {
+                    rlog "Compilation Succeeded When It shouldn't!";
+                    $error++;
+                    $result->{compile_status} = 'FAIL';
+                    next;
+                } else {
+                    $result->{compile_status} = 'PASS';
+                    next;
+                }
+            }
hunk ./regress/regress.prl 240
+    return $_[0] if defined $_[0] && $_[0] =~ /[A-Z]+/;
hunk ./regress/tests/0_prim/Recursive2.hs 1
+
+a = b
+b = a
+
+main :: IO ()
+main = return ()
hunk ./regress/tests/4_bugs/Defaulting.expected.stdout 1
+4611686018427387904
+3.141592653589793
hunk ./regress/tests/4_bugs/Defaulting.hs 1
+x = 2^62
+y = pi
+
+main :: IO ()
+main = do print x
+          print y
hunk ./regress/tests/4_bugs/ImportZeal.expected.stdout 1
+{True->False;False->True}
hunk ./regress/tests/4_bugs/ImportZeal.hs 1
+
+---------------------------------------------------------------------
+-- SmallCheck: another lightweight testing library.
+-- Colin Runciman, August 2006
+-- Version 0.4, 23 May 2008
+--
+-- After QuickCheck, by Koen Claessen and John Hughes (2000-2004).
+---------------------------------------------------------------------
+
+{-
+module Test.SmallCheck (
+  smallCheck, smallCheckI, depthCheck, test,
+  Property, Testable,
+  forAll, forAllElem,
+  exists, existsDeeperBy, thereExists, thereExistsElem,
+  exists1, exists1DeeperBy, thereExists1, thereExists1Elem,
+  (==>),
+  Series, Serial(..),
+  (\/), (><), two, three, four,
+  cons0, cons1, cons2, cons3, cons4,
+  alts0, alts1, alts2, alts3, alts4,
+  N(..), Nat, Natural,
+  depth, inc, dec
+  ) where
+-}
+
+import Data.List (intersperse)
+import Control.Monad (when)
+import System.IO (stdout, hFlush)
+import Foreign (unsafePerformIO)  -- used only for Testable (IO a)
+
+------------------ <Series of depth-bounded values> -----------------
+
+-- Series arguments should be interpreted as a depth bound (>=0)
+-- Series results should have finite length
+
+type Series a = Int -> [a]
+
+-- sum
+infixr 7 \/
+(\/) :: Series a -> Series a -> Series a
+s1 \/ s2 = \d -> s1 d ++ s2 d
+
+-- product
+infixr 8 ><
+(><) :: Series a -> Series b -> Series (a,b)
+s1 >< s2 = \d -> [(x,y) | x <- s1 d, y <- s2 d]
+
+------------------- <methods for type enumeration> ------------------
+
+-- enumerated data values should be finite and fully defined
+-- enumerated functional values should be total and strict
+
+-- bounds:
+-- for data values, the depth of nested constructor applications
+-- for functional values, both the depth of nested case analysis
+-- and the depth of results
+ 
+class Serial a where
+  series   :: Series a
+  coseries :: Series b -> Series (a->b)
+
+instance Serial () where
+  series      _ = [()]
+  coseries rs d = [ \() -> b
+                  | b <- rs d ]
+
+instance Serial Int where
+  series      d = [(-d)..d]
+  coseries rs d = [ \i -> if i > 0 then f (N (i - 1))
+                          else if i < 0 then g (N (abs i - 1))
+                          else z
+                  | z <- alts0 rs d, f <- alts1 rs d, g <- alts1 rs d ]
+
+instance Serial Integer where
+  series      d = [ toInteger (i :: Int)
+                  | i <- series d ]
+  coseries rs d = [ f . (fromInteger :: Integer->Int)
+                  | f <- coseries rs d ]
+
+newtype N a = N a
+              deriving (Eq, Ord)
+
+instance Show a => Show (N a) where
+  show (N i) = show i
+
+instance (Integral a, Serial a) => Serial (N a) where
+  series      d = map N [0..d']
+                  where
+                  d' = fromInteger (toInteger d)
+  coseries rs d = [ \(N i) -> if i > 0 then f (N (i - 1))
+                              else z
+                  | z <- alts0 rs d, f <- alts1 rs d ]
+
+type Nat = N Int
+type Natural = N Integer
+
+instance Serial Float where
+  series     d = [ encodeFloat sig exp
+                 | (sig,exp) <- series d,
+                   odd sig || sig==0 && exp==0 ]
+  coseries rs d = [ f . decodeFloat
+                  | f <- coseries rs d ]
+             
+instance Serial Double where
+  series      d = [ frac (x :: Float)
+                  | x <- series d ]
+  coseries rs d = [ f . (frac :: Double->Float)
+                  | f <- coseries rs d ]
+
+frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b
+frac = fromRational . toRational
+
+instance Serial Char where
+  series      d = take (d+1) ['a'..'z']
+  coseries rs d = [ \c -> f (N (fromEnum c - fromEnum 'a'))
+                  | f <- coseries rs d ]
+
+instance (Serial a, Serial b) =>
+         Serial (a,b) where
+  series      = series >< series
+  coseries rs = map uncurry . (coseries $ coseries rs)
+
+instance (Serial a, Serial b, Serial c) =>
+         Serial (a,b,c) where
+  series      = \d -> [(a,b,c) | (a,(b,c)) <- series d]
+  coseries rs = map uncurry3 . (coseries $ coseries $ coseries rs)
+
+instance (Serial a, Serial b, Serial c, Serial d) =>
+         Serial (a,b,c,d) where
+  series      = \d -> [(a,b,c,d) | (a,(b,(c,d))) <- series d]
+  coseries rs = map uncurry4 . (coseries $ coseries $ coseries $ coseries rs)
+
+uncurry3 :: (a->b->c->d) -> ((a,b,c)->d)
+uncurry3 f (x,y,z) = f x y z
+
+uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e)
+uncurry4 f (w,x,y,z) = f w x y z
+
+two   :: Series a -> Series (a,a)
+two   s = s >< s
+
+three :: Series a -> Series (a,a,a)
+three s = \d -> [(x,y,z) | (x,(y,z)) <- (s >< s >< s) d]
+
+four  :: Series a -> Series (a,a,a,a)
+four  s = \d -> [(w,x,y,z) | (w,(x,(y,z))) <- (s >< s >< s >< s) d]
+
+cons0 :: 
+         a -> Series a
+cons0 c _ = [c]
+
+cons1 :: Serial a =>
+         (a->b) -> Series b
+cons1 c d = [c z | d > 0, z <- series (d-1)]
+
+cons2 :: (Serial a, Serial b) =>
+         (a->b->c) -> Series c
+cons2 c d = [c y z | d > 0, (y,z) <- series (d-1)]
+
+cons3 :: (Serial a, Serial b, Serial c) =>
+         (a->b->c->d) -> Series d
+cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)]
+
+cons4 :: (Serial a, Serial b, Serial c, Serial d) =>
+         (a->b->c->d->e) -> Series e
+cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)]
+
+alts0 ::  Series a ->
+            Series a
+alts0 as d = as d
+
+alts1 ::  Serial a =>
+            Series b -> Series (a->b)
+alts1 bs d = if d > 0 then coseries bs (dec d)
+             else [\_ -> x | x <- bs d]
+
+alts2 ::  (Serial a, Serial b) =>
+            Series c -> Series (a->b->c)
+alts2 cs d = if d > 0 then coseries (coseries cs) (dec d)
+             else [\_ _ -> x | x <- cs d]
+
+alts3 ::  (Serial a, Serial b, Serial c) =>
+            Series d -> Series (a->b->c->d)
+alts3 ds d = if d > 0 then coseries (coseries (coseries ds)) (dec d)
+             else [\_ _ _ -> x | x <- ds d]
+
+alts4 ::  (Serial a, Serial b, Serial c, Serial d) =>
+            Series e -> Series (a->b->c->d->e)
+alts4 es d = if d > 0 then coseries (coseries (coseries (coseries es))) (dec d)
+             else [\_ _ _ _ -> x | x <- es d]
+
+instance Serial Bool where
+  series        = cons0 True \/ cons0 False
+  coseries rs d = [ \x -> if x then r1 else r2
+                  | r1 <- rs d, r2 <- rs d ]
+
+instance Serial a => Serial (Maybe a) where
+  series        = cons0 Nothing \/ cons1 Just
+  coseries rs d = [ \m -> case m of
+                       Nothing -> z
+                       Just x  -> f x
+                  |  z <- alts0 rs d ,
+                     f <- alts1 rs d ]
+
+instance (Serial a, Serial b) => Serial (Either a b) where
+  series        = cons1 Left \/ cons1 Right
+  coseries rs d = [ \e -> case e of
+                          Left x  -> f x
+                          Right y -> g y
+                  |  f <- alts1 rs d ,
+                     g <- alts1 rs d ]
+
+instance Serial a => Serial [a] where
+  series        = cons0 [] \/ cons2 (:)
+  coseries rs d = [ \xs -> case xs of
+                           []      -> y
+                           (x:xs') -> f x xs'
+                  |   y <- alts0 rs d ,
+                      f <- alts2 rs d ]
+
+-- Thanks to Ralf Hinze for the definition of coseries
+-- using the nest auxiliary.
+
+instance (Serial a, Serial b) => Serial (a->b) where
+  series = coseries series
+  coseries rs d = 
+    [ \ f -> g [ f a | a <- args ] 
+    | g <- nest args d ]
+    where
+    args = series d
+    nest []     _ = [ \[] -> c
+                    | c <- rs d ]
+    nest (a:as) _ = [ \(b:bs) -> f b bs
+                    | f <- coseries (nest as) d ]
+
+-- For customising the depth measure.  Use with care!
+
+depth :: Int -> Int -> Int
+depth d d' | d >= 0    = d'+1-d
+           | otherwise = error "SmallCheck.depth: argument < 0"
+
+dec :: Int -> Int
+dec d | d > 0     = d-1
+      | otherwise = error "SmallCheck.dec: argument <= 0"
+
+inc :: Int -> Int
+inc d = d+1
+
+-- show the extension of a function (in part, bounded both by
+-- the number and depth of arguments)
+instance (Serial a, Show a, Show b) => Show (a->b) where
+  show f = 
+    if maxarheight == 1
+    && sumarwidth + length ars * length "->;" < widthLimit then
+      "{"++(
+      concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars]
+      )++"}"
+    else
+      concat $ [a++"->\n"++indent r | (a,r) <- ars]
+    where
+    ars = take lengthLimit [ (show x, show (f x))
+                           | x <- series depthLimit ]
+    maxarheight = maximum  [ max (height a) (height r)
+                           | (a,r) <- ars ]
+    sumarwidth = sum       [ length a + length r 
+                           | (a,r) <- ars]
+    indent = unlines . map ("  "++) . lines
+    height = length . lines
+    (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Int)
+
+---------------- <properties and their evaluation> ------------------
+
+-- adapted from QuickCheck originals: here results come in lists,
+-- properties have depth arguments, stamps (for classifying random
+-- tests) are omitted, existentials are introduced
+
+newtype PR = Prop [Result]
+
+data Result = Result {ok :: Maybe Bool, arguments :: [String]}
+
+nothing :: Result
+nothing = Result {ok = Nothing, arguments = []}
+
+result :: Result -> PR
+result res = Prop [res]
+
+newtype Property = Property (Int -> PR)
+
+class Testable a where
+  property :: a -> Int -> PR
+
+instance Testable Bool where
+  property b _ = Prop [Result (Just b) []]
+
+instance Testable PR where
+  property prop _ = prop
+
+instance (Serial a, Show a, Testable b) => Testable (a->b) where
+  property f = f' where Property f' = forAll series f
+
+instance Testable Property where
+  property (Property f) d = f d
+
+-- For testing properties involving IO.  Unsafe, so use with care!
+instance Testable a => Testable (IO a) where
+  property = property . unsafePerformIO
+
+evaluate :: Testable a => a -> Series Result
+evaluate x d = rs where Prop rs = property x d
+
+forAll :: (Show a, Testable b) => Series a -> (a->b) -> Property
+forAll xs f = Property $ \d -> Prop $
+  [ r{arguments = show x : arguments r}
+  | x <- xs d, r <- evaluate (f x) d ]
+
+forAllElem :: (Show a, Testable b) => [a] -> (a->b) -> Property
+forAllElem xs = forAll (const xs)
+
+existence :: (Show a, Testable b) => Bool -> Series a -> (a->b) -> Property
+existence u xs f = Property existenceDepth
+  where
+  existenceDepth d = Prop [ Result (Just valid) arguments ]
+    where
+    witnesses = [ show x | x <- xs d, all pass (evaluate (f x) d) ]
+    valid     = enough witnesses
+    enough    = if u then unique else (not . null)
+    arguments = if valid then []
+                else if null witnesses then ["non-existence"]
+                else "non-uniqueness" : take 2 witnesses
+
+unique :: [a] -> Bool
+unique [_] = True
+unique  _  = False
+
+pass :: Result -> Bool
+pass (Result Nothing _)  = True
+pass (Result (Just b) _) = b
+
+thereExists :: (Show a, Testable b) => Series a -> (a->b) -> Property
+thereExists = existence False
+
+thereExists1 :: (Show a, Testable b) => Series a -> (a->b) -> Property
+thereExists1 = existence True
+
+thereExistsElem :: (Show a, Testable b) => [a] -> (a->b) -> Property
+thereExistsElem xs = thereExists (const xs)
+
+thereExists1Elem :: (Show a, Testable b) => [a] -> (a->b) -> Property
+thereExists1Elem xs = thereExists1 (const xs)
+
+exists :: (Show a, Serial a, Testable b) => (a->b) -> Property
+exists = thereExists series
+
+exists1 :: (Show a, Serial a, Testable b) => (a->b) -> Property
+exists1 = thereExists1 series
+
+existsDeeperBy :: (Show a, Serial a, Testable b) => (Int->Int) -> (a->b) -> Property
+existsDeeperBy f = thereExists (series . f)
+
+exists1DeeperBy :: (Show a, Serial a, Testable b) => (Int->Int) -> (a->b) -> Property
+exists1DeeperBy f = thereExists1 (series . f)
+ 
+infixr 0 ==>
+
+(==>) :: Testable a => Bool -> a -> Property
+True ==>  x = Property (property x)
+False ==> x = Property (const (result nothing))
+
+--------------------- <top-level test drivers> ----------------------
+
+-- similar in spirit to QuickCheck but with iterative deepening
+
+test :: Testable a => a -> IO ()
+test = smallCheckI
+
+-- test for values of depths 0..d stopping when a property
+-- fails or when it has been checked for all these values
+smallCheck :: Testable a => Int -> a -> IO ()
+smallCheck d = iterCheck 0 (Just d)
+
+-- interactive variant, asking the user whether testing should
+-- continue/go deeper after a failure/completed iteration
+smallCheckI :: Testable a => a -> IO ()
+smallCheckI = iterCheck 0 Nothing
+
+depthCheck :: Testable a => Int -> a -> IO ()
+depthCheck d = iterCheck d (Just d)
+
+iterCheck :: Testable a => Int -> Maybe Int -> a -> IO ()
+iterCheck dFrom mdTo t = iter dFrom
+  where
+  iter d = do
+    putStrLn ("Depth "++show d++":")
+    let Prop results = property t d
+    ok <- check (mdTo==Nothing) 0 0 True results
+    maybe (whenUserWishes "  Deeper" () $ iter (d+1))
+          (\dTo -> when (ok && d < dTo) $ iter (d+1))
+          mdTo
+
+check :: Bool -> Integer -> Integer -> Bool -> [Result] -> IO Bool
+check i n x ok rs | null rs = do
+  putStr ("  Completed "++show n++" test(s)")
+  putStrLn (if ok then " without failure." else ".")
+  when (x > 0) $
+    putStrLn ("  But "++show x++" did not meet ==> condition.")
+  return ok
+check i n x ok (Result Nothing _ : rs) = do
+  progressReport i n x
+  check i (n+1) (x+1) ok rs
+check i n x f (Result (Just True) _ : rs) = do
+  progressReport i n x
+  check i (n+1) x f rs
+check i n x f (Result (Just False) args : rs) = do
+  putStrLn ("  Failed test no. "++show (n+1)++". Test values follow.")
+  mapM_ (putStrLn . ("  "++)) args
+  ( if i then
+      whenUserWishes "  Continue" False $ check i (n+1) x False rs
+    else
+      return False )
+
+whenUserWishes :: String -> a -> IO a -> IO a
+whenUserWishes wish x action = do
+  putStr (wish++"? ")
+  hFlush stdout
+  reply <- getLine
+  ( if (null reply || reply=="y") then action
+    else return x )
+
+progressReport :: Bool -> Integer -> Integer -> IO ()
+progressReport i n x | n >= x = do
+  when i $ ( putStr (n' ++ replicate (length n') '\b') >>
+             hFlush stdout )
+   where
+   n' = show n
+
+main = print not
hunk ./regress/tests/4_bugs/NoMonomorphism.expected.stdout 1
+9
+15.6
+2.8957571600107794e-36
hunk ./regress/tests/4_bugs/NoMonomorphism.hs 1
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# JHC_OPTIONS -fno-monomorphism-restriction #-}
+
+x = 234
+y = 15
+
+main = do print (x `mod` y)
+          print (x / y)
+          print (x ** (-y))
+
hunk ./regress/tests/4_bugs/Parsing1.hs 1
+
+x :: Int
+x = 0;
+
+main :: IO ()
+main = return ()
hunk ./regress/tests/4_bugs/Qualify1.hs 1
+module Main where
+
+import qualified Prelude as P
+
+data T = T
+
+-- GHC doesn't allow: T.show T = "T". What does the haskell98 doc say?
+{-
+  idecls  ->  { idecl_1 ; ... ; idecl_n }             (n>=0)
+  idecl   ->  (funlhs | var) rhs
+          |                                           (empty) 
+-}
+-- var, of course, does not permit qnames.
+
+instance P.Show T where
+  show T = "T"
+
+main :: P.IO ()
+main = P.return ()
+
hunk ./regress/tests/4_bugs/Segfault1.expected.stdout 1
+5888896
hunk ./regress/tests/4_bugs/Segfault1.hs 1
+module Main where
+
+
+main :: IO ()
+main = print $ sum [ length $ show n | n <- [1..1000000::Int] ]
hunk ./regress/tests/4_bugs/Shadowing.hs 1
+
+
+
+main :: IO ()
+main = putStrLn "Hello"
+
+putStrLn :: String -> IO ()
+putStrLn _str = return ()
+
hunk ./regress/tests/4_bugs/UnpackedPoly.expected.stdout 1
+Bar (Foo ["Hi!"])
hunk ./regress/tests/4_bugs/UnpackedPoly.hs 1
+-- This triggers the same issue that prevents HashTable from building
+
+data Foo a = Foo [a] deriving Show
+
+data Bar a = Bar !(Foo a) deriving Show
+
+main = print (Bar (Foo ["Hi!"]))
hunk ./regress/tests/7_large/RayT.args 1
+2 100
binary ./regress/tests/7_large/RayT.expected.stdout
oldhex
*
newhex
*50350a313030203130300a3235350a000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000000d447faec0edefc5b578490e000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000306693a7e2e9d0b6995c1f00
*00000000000000000000000000000000000000000000000000000000003184dbe6edf2f6f9fbfc
*fcfbf8e3931d000000000000000000000000000000000000000000000000000000000000000000
*000000000000000a58a5c8d2dbe2e8edf2f6f9fcfcbc5d00000000000000000000000000000000
*000000000000000000001792d1dce5ebf1f5f8fbfdfefffefdfaf6ed8e0e000000000000000000
*000000000000000000000000000000000000000000000000000000004c9db5c0cad2d9e0e6ebf0
*f4f8fbfdfffedb3e000000000000000000000000000000000000000000000042b2ccd7dfe6ebf0
*f4f7fafcfdfefefdfbf8f4edd34200000000000000000000000000000000000000000000000000
*00000000000000000017719caab5bfc7cfd6dce2e7ecf0f4f8fafcfefdfb8a0000000000000000
*0000000000000000000000000066b5c4cfd7dee4e9edf1f4f7f8fafbfbfaf9f7f4efe8dc7b681d
*000000000000000000000000000000000000000000000000000000000c4c57758f9ca8b2bbc3ca
*d1d7dce2e6ebeff2f5f8fafbfaf8c50f0000000000000000000000000000000000005eaab9c4cd
*d5dbe1e5e9edf0f2f4f5f6f7f6f5f4f1ede8e0d3e7f7b339000000000000000000000000000000
*000000000000000000136dc2bb727f8d99a3adb5bdc4cad0d6dbe0e5e9eceff2f4f6f6f6f3c00e
*00000000000000000000000000000000439cadb9c2cad1d7dce0e4e8eaedeff0f1f1f1f0efede9
*e5dfd6c7ebf8ee7e000000000000000000000000000000000000000000003395b4bc5e6d7c8994
*9ea7afb6bdc4cacfd4d9dee2e5e9eceef0f1f1f0edab0000000000000000000000000000001d8a
*9eabb5bec5ccd1d6dbdee2e4e7e8eaebebebeae9e7e4e1dbd4cabbf1f1e6850000000000000000
*0000000000000000000000002a889fb15f586977838e97a0a8afb6bcc2c8cdd2d6dadee1e4e7e9
*eaebebe9e46d0000000000000000000000000000668c9ca7b1b9c0c6cbd0d4d8dbdee0e2e3e4e4
*e4e4e3e1dedbd6d0c7bac6ece5d86e000000000000000000000000000000000000196c86998040
*5564717d879098a0a7aeb4bac0c5caced2d6dadddfe1e3e4e4e3e0d91a00000000000000000000
*000024778a98a2abb3b9bfc4c9cdd1d4d6d8dadcdddddddcdbdad7d4d0cac2b8a4d9ded4c22b00
*0000000000000000000000000000000345687e90323d4f5e6a757f8890989fa6acb2b8bdc1c6ca
*ced1d5d7dadbdddddddbd680000000000000000000000000517686929ca5acb2b8bdc1c5c9ccce
*d1d2d4d5d5d5d5d4d2d0cdc9c3bcb3a4b3d3cbbe7c000000000000000000000000000000001245
*5f736421384956626d7780888f979da4a9afb4b9bdc2c5c9cccfd1d3d4d5d5d4d0c81700000000
*0000000000000d5c71808c959da4abb0b5b9bdc1c4c6c8cacbcccdcdcccbcac8c5c1bcb5ac9f91
*c7c0b49f10000000000000000d00000000000000163b53662e1d31414e5a646e777f878e949ba0
*a6abb0b4b9bcc0c3c6c8cacccdcdccc9c3510000000000000000000020586b79848d959ca2a8ad
*b1b5b8bbbec0c1c3c3c4c4c3c3c1bfbcb8b3ada49885afb2a8953530648fbadadfe2e5e7e7d8ae
*74470e0f2e45580e16293845515b656d767d848b91979da2a7abafb3b7babdbfc1c3c4c4c3c1bc
*85000000000000000000002a5264717c858d939a9fa4a8acafb2b4b6b8b9babbbbbab9b8b6b3af
*aaa49c907f94a39fabc0cfd6dce2e6eaedeff1f3f4f4f3f1eda45f3643000d202f3c47515b646c
*747b81888e93989da2a6aaadb1b3b6b8b9babbbab8b4a9000000000000000000002a4a5b68737c
*838a90969a9fa2a6a8abadafb0b1b1b1b0afaeaca9a5a09a9287767fadbfcad2d8dee3e7ebeef1
*f4f6f7f9f9faf9f8f6f2d46100051625313d47515a626a71777e84898e93989ca0a4a7aaacaeb0
*b1b1b0aeaaa1120000000000000000002641525f69727a80868c9095989c9fa1a3a5a6a7a7a7a6
*a5a4a19e9b968f877c6c87c0c9d1d7dde2e6eaedf1f3f6f8fafbfcfdfdfdfcfaf7b600000b1a27
*323d464f575f666d73797f84898e9296999da0a2a4a6a7a7a6a4a098230000000000000000001c
*3747545f686f767c81868a8e919497999a9b9c9c9c9c9a9996938f8a847c716085c7ced4dadfe3
*e7ebeef1f4f7f9fafcfdfefefefefdfbbb0000020e1c27323b444d545c62696f747a7f83878b8f
*9295989a9b9c9c9c9a968d20000000000000000000102b3c49545d646b71777b808387898c8e8f
*90919191908f8d8b88847f786f64527fcad0d6dbe0e4e8ebeef1f4f6f8fafcfdfefffffffe8e1f
*00000004101c263039414951575e646a6f74787d8184878a8d8f909191918e8a811d0000000000
*00000000061e303d48515960666b7074787b7e808284858686868584827f7c77726b6256438bcb
*d1d6dbdfe3e7ebeef1f3f5f8f9fbfcfdfeffff8f000000000000040f1a242d363e454c53595e64
*696d7175797c7f818385868685827e740d000000000000000000000f22303b444d545a5f64686c
*7072757778797a7a79797775726f6a655d544731a5cbd1d6dadfe3e6e9eceff2f4f6f8fafbfcfd
*feee1000000000000000030e18212a323940474d53585d62666a6d71737678797a7a7876716400
*000000000000000000000313222e3740474d53585c606366686a6c6d6d6d6d6c6a6865615d564f
*443626c5cbd0d5d9dde1e5e8ebeef0f2f4f6f8f9fafbfcad000000000000000000020b141d252d
*343b41474c51565a5e6265676a6c6d6d6d6b68623c00000000000000000000000004131f293239
*40464b4f5356595b5d5f606060605e5d5a57534e473f33224fc4cacfd3d8dcdfe3e6e9ebeef0f2
*f4f6f7f8f9fa7d000000000000000000000107101820272e343a4045494e5255585b5d5f606060
*5e5a521e00000000000000000000000000040f1a232b32383d4145494c4e505152525252504e4c
*48443e372d200ca6c3c8cdd2d6dadde0e4e6e9ebeef0f2f3f5f6f7f87c00000000000000000000
*0000030b131a21272d33383c4145484b4e50515252514f4a3b0300000000000000000000000000
*00020a131c23292e33373b3d40424344444443413f3c39342d251a0a00bcc1c6cbcfd3d7dbdee1
*e4e6e9ebedeff1f2f3f4f57b0000000000000000000000000001050c13191f252a2f33373b3e40
*42434444423e371a0000000000000000000000000000000000040b13191f24282b2e3133343535
*3433322f2c27221b11050022babfc4c9cdd1d4d8dbdee1e4e6e8eaeceeeff0f1f2790000000000
*0000000000000000000001050b11171c2125292c2f3233353534312c1f02000000000000000000
*0000000000000000000003080e13181b1e21232424252423211e1a150e070100004eb7bdc1c6ca
*ced2d5d8dbdee0e3e5e7e9eaecedeeef9600000000000000000000000000000000000103080d12
*161a1d2022242524221e1605000000000000000000000000000000000000000000000103060a0d
*101113131312110e0b0703000000000079b5babfc3c7cbced2d5d8dbdde0e2e4e6e7e9eaebecc0
*00000000000000000000000000000000000000000103070a0d10121313120f0902000000000000
*0000000000000000000000000000000000000000000001020203030201010000000000000015ad
*b2b7bbc0c4c8cbced2d4d7dadcdee0e2e4e5e6e7e8e90000000000000000000000000000000000
*000000000000000102020302010000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000052a9afb4b8bcc0c4c8cbced1d4d6d8dbdddee0
*e1e3e4e5e548000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000a97a6abb0b5b9bdc1c4c7cacdd0d2d5d7d9dbdcdedfe0e1e27f0000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000000000000000000000000000000000004c9da3a8adb1b5b9bdc0c3c6c9ccce
*d1d3d5d7d8dadbdcdddec200000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000098a999fa4a9adb1b5b9bcbfc2c5c8cacdcfd1d3d4d6d7d8d9dada290000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000004590969ba0a5a9adb1b5b8
*bbbec1c4c6c8cbcdced0d1d3d4d5d5d68600000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000087d8c91979ca0a5a9adb0b4b7babdbfc2c4c6c8cacccdcecfd0d1d2c5
*0d0000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000000000000000000000000000000004d81878d93979c
*a0a5a8acafb3b6b8bbbdc0c2c4c5c7c8cacbcccdcdcd5a00000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000e767d83898e93989ca0a4a7abaeb1b4b6b9bbbdbfc1c2c4c5
*c6c7c8c8c9b0000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000497278
*7e84898e93979b9fa3a6a9acafb2b4b6b8babcbebfc0c1c2c3c4c4c44900000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000018656d73797f84898e92969a9ea1a4a7aaadafb1b4
*b5b7b9babbbcbdbebfbfbfa7000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*004360686e747a7f84898d9195999c9fa2a5a8aaacaeb0b2b4b5b6b7b8b9babababa4500000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000000000000000000000000000000013535b62696f757a7f84888c9094979a9d
*a0a3a5a7a9abadafb0b1b2b3b4b4b5b5b49d000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000334d555d636a6f757a7e83878b8e9295989b9da0a2a4a6a8a9abacadaeaeafafafaf
*af4c00000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000000000000000000000a3e474f575e646a6f74797d81
*85898c8f9295989a9d9fa1a2a4a5a6a7a8a9a9aaaaa9a99d0a0000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000001d37414951585e64696e73787c8083878a8d90929597999b9d9ea0a1a2a3
*a3a4a4a4a4a3a25a00000000000000000000000000000000000000000000000000000000000000
*0000000000000000000000000000000000000000000000000000000000000226313a434a51585e
*63686d72767a7d8184878a8d8f91939597989a9b9c9d9d9e9e9e9d9d9c9b1c0000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000081e29333c444b51575d62676c7074777b7e818487898b8d8f91
*929495969797989898979796946e00000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000000000000000000000000000000000000000616222c
*353d444b51565c6165696d7175787b7e80838587898b8c8e8f90919191919191908f8e8c340000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000010d19242d353d444a50555a5f63676b6e7275787a
*7d7f818385868788898a8b8b8b8b8a898887857a08000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000004111c252e353c43494e53585c6064686b6e717476787a7c7e808182838384848484838281
*807e7b430000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000000000000000000000000000000000000007131d262d353b41474c5155595d
*6164676a6d6f72747677797a7b7c7d7d7d7d7d7c7b7a7876736f0d000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000109141d252d333a3f45494e52565a5d606366686b6d6f7072737475767676
*7675757472706e6b673d0000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000000000000000000000000000000010a141c242b3137
*3d42464b4f5256595c5f61646668696b6c6d6e6e6f6f6e6e6d6c6a6865625e580a000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000020a131b22292f353a3e43474b4e5255575a5c5e60626364
*656667676766666563625f5c58544d240000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000001
*09111920262c31363b3f43464a4d4f525456585a5b5d5d5e5f5f5f5e5d5c5b5956534e49422b00
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000000000000000000000000000000001070f161d23282d32363a3e4144474a4c
*4e505253545556565656565553514f4c48433d341d000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000050c13191f24292d3235393c3f41444648494b4c4d4d4d4d4d4c4b4a4845413d
*372f240a0000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000000000000000000000000000002080f151a1f24282c
*303336383b3d3f404243444444444443413f3d3a3630291f0e0000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000040a10151a1e2226292c2f3134353738393a3a3a3a393837
*34312e2922190a0000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000001
*050a0f14181c1f2225272a2b2d2e2f3030302f2e2d2b2825201a11050000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*00000000000000000000000000000000000000000000000104080d1114171a1d1f212223242525
*252422211e1b161008010000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*0000000000000000000205080c0f1113151718181919181715130f0b0501000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000103050709
*0a0b0c0c0b0a090604020000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000000000000000000
*000000000000000000000000000000000000000000000001010101000000000000000000000000
*000000000000000000000000000000000000000000000000000000000000000a
hunk ./regress/tests/7_large/RayT.hs 1
+import System
+infinity = 1/0
+delta = sqrt e where e = encodeFloat (floatRadix e) (-floatDigits e)
+infixl 7 .*, *|
+data Vector = V !Double !Double !Double deriving (Show, Eq)
+s *| V x y z = V (s * x) (s * y) (s * z)
+instance Num Vector where
+    V x y z + V x' y' z' = V (x + x') (y + y') (z + z')
+    V x y z - V x' y' z' = V (x - x') (y - y') (z - z')
+    fromInteger i = V x x x where x = fromInteger i
+V x y z .* V x' y' z' = x * x' + y * y' + z * z'
+vlength r = sqrt (r .* r)
+unitise r = 1 / vlength r *| r
+
+data Scene
+    = Sphere !Vector !Double
+    | Group !Vector !Double Scene Scene Scene Scene Scene
+    deriving (Show)
+
+ray_sphere (V dx dy dz) (V vx vy vz) r =
+  let disc = vx * vx + vy * vy + vz * vz - r * r
+  in  if disc < 0 then infinity else
+      let b = vx * dx + vy * dy + vz * dz
+          b2 = b * b
+      in  if b2 < disc then infinity else
+          let disk = sqrt(b2 - disc)
+              t1 = b - disk
+          in  if t1 > 0 then t1 else b + disk
+
+ray_sphere' (V ox oy oz) (V dx dy dz) (V cx cy cz) r =
+  let vx = cx - ox; vy = cy - oy; vz = cz - oz
+      vv = vx * vx + vy * vy + vz * vz
+      b = vx * dx + vy * dy + vz * dz
+      disc = b * b - vv + r * r
+  in  disc >= 0 && b + sqrt disc >= 0
+
+data Hit = H {l :: !Double, nv :: Vector }
+
+intersect dir@(V dx dy dz) hit s = case s of
+    Sphere center@(V cx cy cz) radius ->
+      let l' = ray_sphere dir center radius in
+      if l' >= l hit then hit else
+	let x = l' * dx - cx
+	    y = l' * dy - cy
+	    z = l' * dz - cz
+	    il = 1 / sqrt(x * x + y * y + z * z)
+	in  H {l = l', nv = V (il * x) (il * y) (il * z) }
+    Group center radius a b c d e ->
+      let l' = ray_sphere dir center radius in
+      if l' >= l hit then hit else
+	let f h s = intersect dir h s in
+	f (f (f (f (f hit a) b) c) d) e
+
+intersect' orig dir s = case s of
+    Sphere center radius -> ray_sphere' orig dir center radius
+    Group center radius a b c d e ->
+      let f s = intersect' orig dir s in
+      ray_sphere' orig dir center radius && (f a || f b || f c || f d || f e)
+
+neg_light = unitise (V 1 3 (-2))
+
+ray_trace dir scene =
+  let hit = intersect dir (H infinity 0) scene in
+  if l hit == infinity then 0 else
+    let n = nv hit in
+    let g = n .* neg_light in
+    if g < 0 then 0 else
+      if intersect' (l hit *| dir + delta *| n) neg_light scene then 0 else g
+
+fold5 f x a b c d e = f (f (f (f (f x a) b) c) d) e
+
+create level c r =
+  let obj = Sphere c r in
+  if level == 1 then obj else
+    let a = 3 * r / sqrt 12 in
+    let bound (c, r) s = case s of
+	 Sphere c' r' -> (c, max r (vlength (c - c') + r'))
+         Group _ _ v w x y z -> fold5 bound (c, r) v w x y z in
+    let aux x' z' = create (level - 1 :: Int) (c + V x' a z') (0.5 * r) in
+    let w = aux (-a) (-a); x = aux a (-a) in
+    let y = aux (-a) a; z = aux a a in
+    let (c1, r1) = fold5 bound (c + V 0 r 0, 0) obj w x y z in
+    Group c1 r1 obj w x y z
+
+ss = 4
+pixel_vals n scene y x = sum
+  [ let f a da = a - n / 2 + da / ss; d = unitise (V (f x dx) (f y dy) n)
+    in  ray_trace d scene | dx <- [0..ss-1], dy <- [0..ss-1] ]
+main = do 
+    [level,ni] <- fmap (map read) getArgs
+    let n = fromIntegral ni
+	scene = create level (V 0 (-1) 4) 1  
+	scale x = 0.5 + 255 * x / (ss*ss)
+	picture = [ toEnum $ truncate $ scale $ pixel_vals n scene y x | y <- [n-1,n-2..0], x <- [0..n-1]]
+    putStrLn $ "P5\n" ++ show ni ++ " " ++ show ni ++ "\n255\n" ++ picture