{-# LANGUAGE MagicHash #-}

-- !!! simple tests of primitive arrays
--
module Main ( main ) where

import GHC.Exts
import Data.Char 	( chr )

import Control.Monad.ST
import Data.Array.ST
import Data.Array.Unboxed

import Data.Ratio

main = putStr
	 (test_chars	++ "\n"  ++
	  test_ints	++ "\n"  ++
	  test_addrs	++ "\n"  ++
	  test_floats	++ "\n"  ++
	  test_doubles	++ "\n"  ++
	  test_ptrs	++ "\n")


-- Arr# Char# -------------------------------------------
-- (main effort is in packString#)

test_chars :: String
test_chars
  = let arr# = f 1000
    in
	shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Char

    f size@(I# size#)
      = runST (
	    -- allocate an array of the specified size
	  newArray_ (0, (size-1))	>>= \ arr# ->

	    -- fill in all elements; elem i has "i" put in it
	  fill_in arr# 0# (size# -# 1#) >>

	    -- freeze the puppy:
	  freeze arr#
	)

    fill_in :: STUArray s Int Char -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
	then return ()
	else writeArray arr_in# (I# first#) ((chr (I# first#))) >>
	     fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Char -> Int# -> Int# -> [Char]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
	then []
	else (arr ! (I# from#))
	     : (lookup_range arr (from# +# 1#) to#)

-- Arr# Int# -------------------------------------------

test_ints :: String
test_ints
  = let arr# = f 1000
    in
	shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Int

    f size@(I# size#)
      = runST (
	    -- allocate an array of the specified size
	  newArray_ (0, (size-1))	>>= \ arr# ->

	    -- fill in all elements; elem i has i^2 put in it
	  fill_in arr# 0# (size# -# 1#) >>

	    -- freeze the puppy:
	  freeze arr#
	)

    fill_in :: STUArray s Int Int -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
	then return ()
	else writeArray arr_in# (I# first#) (I# (first# *# first#)) >>
	     fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Int -> Int# -> Int# -> [Int]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
	then []
	else (arr ! (I# from#))
	     : (lookup_range arr (from# +# 1#) to#)

-- Arr# Addr# -------------------------------------------

test_addrs :: String
test_addrs
  = let arr# = f 1000
    in
	shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int (Ptr ())

    f size@(I# size#)
      = runST (
	    -- allocate an array of the specified size
	  newArray_ (0, (size-1))	>>= \ arr# ->

	    -- fill in all elements; elem i has i^2 put in it
	  fill_in arr# 0# (size# -# 1#) >>

	    -- freeze the puppy:
	  freeze arr#
	)

    fill_in :: STUArray s Int (Ptr ()) -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
	then return ()
	else writeArray arr_in# (I# first#)
			    (Ptr (int2Addr# (first# *# first#))) >>
	     fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int (Ptr ()) -> Int# -> Int# -> [ Int ]
    lookup_range arr from# to#
      = let
	    a2i (Ptr a#) = I# (addr2Int# a#)
	in
	if isTrue# (from# ># to#)
	then []
	else (a2i (arr ! (I# from#)))
	     : (lookup_range arr (from# +# 1#) to#)

-- Arr# Float# -------------------------------------------

test_floats :: String
test_floats
  = let arr# = f 1000
    in
	shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Float

    f size@(I# size#)
      = runST (
	    -- allocate an array of the specified size
	  newArray_ (0, (size-1))	>>= \ arr# ->

	    -- fill in all elements; elem i has "i * pi" put in it
	  fill_in arr# 0# (size# -# 1#) >>

	    -- freeze the puppy:
	  freeze arr#
	)

    fill_in :: STUArray s Int Float -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
	then return ()
{-	else let e = ((fromIntegral (I# first#)) * pi)
	     in trace (show e) $ writeFloatArray arr_in# (I# first#) e >>
	     fill_in arr_in# (first# +# 1#) last#
-}
	else writeArray arr_in# (I# first#) ((fromIntegral (I# first#)) * pi) >>
	     fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Float -> Int# -> Int# -> [Float]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
	then []
	else (arr ! (I# from#))
	     : (lookup_range arr (from# +# 1#) to#)

-- Arr# Double# -------------------------------------------

test_doubles :: String
test_doubles
  = let arr# = f 1000
    in
	shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Double

    f size@(I# size#)
      = runST (
	    -- allocate an array of the specified size
	  newArray_ (0, (size-1))	>>= \ arr# ->

	    -- fill in all elements; elem i has "i * pi" put in it
	  fill_in arr# 0# (size# -# 1#) >>

	    -- freeze the puppy:
	  freeze arr#
	)

    fill_in :: STUArray s Int Double -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
	then return ()
	else writeArray arr_in# (I# first#) ((fromIntegral (I# first#)) * pi) >>
	     fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Double -> Int# -> Int# -> [Double]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
	then []
	else (arr ! (I# from#))
	     : (lookup_range arr (from# +# 1#) to#)

-- Arr# (Ratio Int) (ptrs) ---------------------------------
-- just like Int# test

test_ptrs :: String
test_ptrs
  = let arr# = f 1000
    in
	shows (lookup_range arr# 42 416) "\n"
  where
    f :: Int -> Array Int (Ratio Int)

    f size
      = runST (
	  newArray (1, size) (3 % 5)	>>= \ arr# ->
	  -- don't fill in the whole thing
	  fill_in arr# 1 400		>>
	  freeze arr#
	)

    fill_in :: STArray s Int (Ratio Int) -> Int -> Int -> ST s ()

    fill_in arr_in# first last
      = if (first > last)
	then return ()
	else writeArray arr_in# first (fromIntegral (first * first)) >>
	     fill_in  arr_in# (first + 1) last

    lookup_range :: Array Int (Ratio Int) -> Int -> Int -> [Ratio Int]
    lookup_range array from too
      = if (from > too)
	then []
	else (array ! from) : (lookup_range array (from + 1) too)
