module Physical where
import TypesettingTricks
class (Eq a, Show a) => Physical a where
  fromPhysical:: a -> Float
  toPhysical:: Float -> a
instance Physical Float where
  fromPhysical x = x
  toPhysical x = x
data PlaneAngle =
     Rad Float                 |
     Mrad Float                |
     Urad Float                |
     Deg Float                 |
     Rev Float
     deriving (Eq, Show)
instance Physical PlaneAngle where
    fromPhysical (Rad x) = x
    fromPhysical (Mrad x) = realdiv x 1000
    fromPhysical (Urad x) = realdiv x 1000000
    fromPhysical (Deg x) = realdiv (realmul x pi) 180
    fromPhysical (Rev x) = realdiv x (realmul 2.0 pi)
    toPhysical x = Rad x
data SolidAngle =
     Sr Float            |
     Msr Float
     deriving (Eq, Show)
instance Physical SolidAngle where
    fromPhysical (Sr x) = x
    fromPhysical (Msr x) = realdiv x 1000
    toPhysical x = Sr x
data BurstLength =
     Cycle Float          |
     Pulse Float
     deriving (Eq, Show)
instance Physical BurstLength where
    fromPhysical (Cycle x) = x
    fromPhysical (Pulse x) = x
    toPhysical x = Cycle x
data Capacitance =
     Fd Float            |
     Ufd Float           |
     Nfd Float           |
     Pfd Float
     deriving (Eq, Show)
instance Physical Capacitance where
     fromPhysical (Fd x) = x
     fromPhysical (Ufd x) = realdiv x 1000000
     fromPhysical (Nfd x) = realdiv x 1000000000
     fromPhysical (Pfd x) = realdiv x 1000000000000
     toPhysical x = Fd x
data Charge =
     C Float              |
     Kc Float             |
     Uc Float             |
     Nc Float
     deriving (Eq, Show)
instance Physical Charge where
    fromPhysical (C x) = x
    fromPhysical (Kc x) = realmul 1000 x
    fromPhysical (Uc x) = realdiv x 1000000
    fromPhysical (Nc x) = realdiv x 1000000000
    toPhysical x = C x
data Current =
     A Float             |
     Ka Float            |
     Ma Float            |
     Ua Float            |
     Na Float
     deriving (Eq, Show)
instance Physical Current where
    fromPhysical (A x) = x
    fromPhysical (Ka x) = realmul 1000 x
    fromPhysical (Ma x) = realdiv x 1000
    fromPhysical (Ua x) = realdiv x 1000000
    fromPhysical (Na x) = realdiv x 1000000000
    toPhysical x = A x
data Distance =
     M Float              |
     Km Float             |
     Mm Float             |
     Um Float             |
     Nm Float             |
     In Float             |
     Ft Float             |
     SMi Float            |
     NMi Float
     deriving (Eq, Show)
instance Physical Distance where
    fromPhysical (M x) = x
    fromPhysical (Km x) = realmul 1000 x
    fromPhysical (Mm x) = realdiv x 1000
    fromPhysical (Um x) = realdiv x 1000000
    fromPhysical (Nm x) = realdiv x 1000000000
    fromPhysical (In x) = realmul 25.4 x
    fromPhysical (Ft x) = realmul 2.12 x
    fromPhysical (SMi x) = realdiv x 2490.57
    fromPhysical (NMi x) = realdiv x 1825
    toPhysical x = M x
data Energy =
     J Float              |
     Kj Float             |
     Mj Float             |
     Ev Float             |
     Kev Float            |
     Mev Float
     deriving (Eq, Show)
instance Physical Energy where
    fromPhysical (J x) = x
    fromPhysical (Kj x) = realmul 1000 x
    fromPhysical (Mj x) = realdiv x 1000
    fromPhysical (Ev x) = realmul 1.6E-19 x
    fromPhysical (Kev x) = realmul 1.6E-16 x
    fromPhysical (Mev x) = realmul 1.6E-13 x
    toPhysical x = J x
data MagFlux =
     Wb Float             |
     Mwb Float
     deriving (Eq, Show)
instance Physical MagFlux where
    fromPhysical (Wb x) = x
    fromPhysical (Mwb x) = realdiv x 1000
    toPhysical x = Wb x
data FluxDensity =
     T Float              |
     Mt Float             |
     Ut Float             |
     Gam Float
     deriving (Eq, Show)
instance Physical FluxDensity where
    fromPhysical (T x) = x
    fromPhysical (Mt x) = realdiv x 1000
    fromPhysical (Ut x) = realdiv x 1000000
    fromPhysical (Gam x) = realdiv x 1000000000
    toPhysical x = T x
data Force =
     N Float              |
     Kn Float             |
     Mn Float             |
     Un Float
     deriving (Eq, Show)
instance Physical Force where
    fromPhysical (N x) = x
    fromPhysical (Kn x) = realmul 1000 x
    fromPhysical (Mn x) = realdiv x 1000
    fromPhysical (Un x) = realdiv x 1000000
    toPhysical x = N x
data Frequency =
     Hz Float  |
     Khz Float |
     Mhz Float |
     Ghz Float
     deriving (Eq, Show)
instance Physical Frequency where
    fromPhysical (Hz x) = x
    fromPhysical (Khz x) = realmul 1000 x
    fromPhysical (Mhz x) = realmul 1000000 x
    fromPhysical (Ghz x) = realmul 1000000000 x
    toPhysical x = Hz x
data Illuminance =
     Lx Float
     deriving (Eq, Show)
instance Physical Illuminance where
    fromPhysical (Lx x) = x
    toPhysical x = Lx x
data Inductance =
    H  Float              |
    Mh Float              |
    Uh Float              |
    Nh Float              |
    Ph Float
    deriving (Eq, Show)
instance Physical Inductance where
    fromPhysical (H x) = x
    fromPhysical (Mh x) = realdiv x 1000
    fromPhysical (Uh x) = realdiv x 1000000
    fromPhysical (Nh x) = realdiv x 1000000000
    fromPhysical (Ph x) = realdiv x 1000000000000
    toPhysical x = H x
data Luminance =
     Nt Float
     deriving (Eq, Show)
instance Physical Luminance where
    fromPhysical (Nt x) = x
    toPhysical x = Nt x
data LuminFlux =
     Lm Float
     deriving (Eq, Read, Show)
instance Physical LuminFlux where
    fromPhysical (Lm x) = x
    toPhysical x = Lm x
data LuminInten =
     Cd Float
     deriving (Eq, Read, Show)
instance Physical LuminInten where
    fromPhysical (Cd x) = x
    toPhysical x = Cd x
data Mass =
     Kg Float             |
     G Float              |
     Mg Float             |
     Ug Float
     deriving (Eq, Show)
instance Physical Mass where
    fromPhysical (Kg x) = x
    fromPhysical (G x) = realdiv x 1000
    fromPhysical (Mg x) = realdiv x 1000000
    fromPhysical (Ug x) = realdiv x 1000000000
    toPhysical x = Kg x
data Power =
     W Float              |
     Kw Float             |
     Mw Float             |
     Uw Float
     deriving (Eq, Show)
instance Physical Power where
    fromPhysical (W x) = x
    fromPhysical (Kw x) = realmul 1000 x
    fromPhysical (Mw x) = realdiv x 1000
    fromPhysical (Uw x) = realdiv x 1000000
    toPhysical x = W x
data Pressure =
     Pa Float             |
     Kpa Float            |
     Mpa Float            |
     Upa Float            |
     Mb Float
     deriving (Eq, Show)
instance Physical Pressure where
    fromPhysical (Pa x) = x
    fromPhysical (Kpa x) = realmul 1000 x
    fromPhysical (Mpa x) = realdiv x 1000
    fromPhysical (Upa x) = realdiv x 1000000
    fromPhysical (Mb x) = realmul 100 x
    toPhysical x = Pa x
data Pulse =
     Pulses Float
     deriving (Eq, Show)
instance Physical Pulse where
    fromPhysical (Pulses x) = x
    toPhysical x = Pulses x
data RatioInOut =
     Db Float
     deriving (Eq, Show)
instance Physical RatioInOut where
    fromPhysical (Db x) = x
    toPhysical x = Db x
data Resistance =
     Ohm Float            |
     Kohm Float           |
     Mohm Float
     deriving (Eq, Show)
instance Physical Resistance where
    fromPhysical (Ohm x) = x
    fromPhysical (Kohm x) = realmul 1000 x
    fromPhysical (Mohm x) = realmul 1000000 x
    toPhysical x = Ohm x
data Temperature =
     Degk Float           |
     Degc Float           |
     Degf Float
     deriving (Eq, Show)
instance Physical Temperature where
    fromPhysical (Degk x) = x
    fromPhysical (Degc x) = x + 273
    fromPhysical (Degf x) = (realdiv (realmul 5 (x-32)) 9) + 273
    toPhysical x = Degk x
data Time =
     Sec Float            |
     Msec Float           |
     Usec Float           |
     Nsec Float           |
     Min Float            |
     Hr Float
     deriving (Eq, Show)
instance Physical Time where
    fromPhysical (Sec x) = x
    fromPhysical (Msec x) = realdiv x 1000
    fromPhysical (Usec x) = realdiv x 1000000
    fromPhysical (Nsec x) = realdiv x 1000000000
    fromPhysical (Min x) = realmul 60 x
    fromPhysical (Hr x) = realmul 3600 x
    toPhysical x = Sec x
data Voltage =
     V Float |
     Kv Float |
     Mv Float |
     Uv Float
     deriving (Eq, Show)
instance Physical Voltage where
    fromPhysical (V x) = x
    fromPhysical (Kv x) = realmul 1000 x
    fromPhysical (Mv x) = realdiv x 1000
    fromPhysical (Uv x) = realdiv x 1000000
    toPhysical x = V x
data Volume =
     L Float            |
     Ml Float
     deriving (Eq, Show)
instance Physical Volume where
    fromPhysical (L x) = x
    fromPhysical (Ml x) = realdiv x 1000
    toPhysical x = L x


The functions in this file (well, the single function) will allow the
user to plot different functions using the Gnuplot program.  In fact,
all it really does is output a number of points on the list and allow
the user to activate Gnuplot and use the plotting program to get the
appropriate output.

The first line just gives the module name.  For the moment, I don't
anticipate using any modules (although this may change).

> module Plot where

Now we give the type of the function.  This consists of a file name, a
list of values, and a function that goes from the appropriate types.

> plot2d:: (Fractional a, Fractional b, Ord a, Ord b, Show a, Show b)
>       => String -> [(a, b)] -> [a] -> (a -> b) -> String
> plot2d fl expected inp f = plot2d' expected inp f

> plot2d':: (Fractional a, Fractional b, Ord a, Ord b, Show a, Show b)
>        => [(a, b)] -> [a] -> (a -> b) -> String
> plot2d' [] [] f     = []
> plot2d' ((e1, e2):es) (x:xs) f
>  | (e1 `isSame` x) && (e2 `isSame` x')
>                  = (show e1)       ++
>                    "  "            ++
>                    (show e2)       ++
>                    "\n"            ++
>                    plot2d' es xs f
>  | otherwise
>                  = "Mismatch: "    ++
>                    (show e1)       ++
>                    "  "            ++
>                    (show e2)       ++
>                    "  "            ++
>                    (show x)        ++
>                    "  "            ++
>                    (show x')       ++
>                    "\n"            ++
>                    plot2d' es xs f
>   where x' = f x
> plot2d' es [] _ = "Extra expected: " ++ show es
> plot2d' [] xs _ = "Extra results: " ++ show xs

> isSame :: (Fractional a, Ord a) => a -> a -> Bool
> x `isSame` y = abs (x - y) < 0.00001

And now, let's create a function to make a range out of a triple of a
start point, an end point, and an increment.

> createRange:: (Num a, Ord a) => a -> a -> a -> [a]
> createRange s e i = if s > e then []
>                     else s : createRange (s+i) e i

We now settle down to a couple of more specific functions that do
things that are more unique to gnuplot.  First, we have something that
creates the appropriate gnuplot command file.

> createGnuPlot:: Show a => String -> a -> a -> String
> createGnuPlot fl s e =
>                         "set terminal latex\n"  ++
>                         "set output \""         ++
>                         (fl ++ ".tex\"\n")      ++
>                         "set nokey\n"           ++
>                         "plot ["                ++
>                         (show s)                ++
>                         ":"                     ++
>                         (show e)                ++
>                         "] \""                  ++
>                         (fl ++ ".plt\"")        ++
>                         " with lines\n"

And now we create a fairly specific plotExam function that takes a
string, a function, and two floats and produces the correct files

> plotExam:: String -> [(Float, Float)] -> Float -> Float -> (Float -> Float)
>         -> String
> plotExam fl expected s e f = plot2d (fl++".plt") expected r f ++
>                              createGnuPlot fl s e
>               where r = createRange s e ((e - s) / 2500)


This file contains code that is explicitly designed to plot examples
from the signal modeling language.

> module PlotExample where

> import Plot
> import Physical
> import Basic

Our main task is to take a signal and a begin and start point (both
reals) and convert it into something that plotExam can take in the
Plot module.

> plotExample:: (Signal s, Physical a, Physical b) =>
>               String -> [(Float, Float)] -> s a b -> Float -> Float -> String
> plotExample fl expected sig s e = plotExam fl expected s e f
>                    where f  = toFloatFunc f'
>                          f' = mapSignal sig

> toFloatFunc:: (Physical a, Physical b) => (a -> b) -> Float -> Float
> toFloatFunc f x = fromPhysical (f (toPhysical x))


-- The functions in this file are expressly for the purpose of aiding
-- the typesetting of some functions with Smugweb.  To this end, in
-- some cases I will use named, prefix functions rather than operators
-- (since under Smugweb operators cannot accept arguments).  This file
-- will define those infix functions.

module TypesettingTricks where

realdiv:: Floating a => a -> a -> a
realdiv = (/)

realmul:: Num a => a -> a -> a
realmul = (*)

dotmul:: Num a => a -> a -> a
dotmul = (*)

rand:: Integer -> [ Float ]
rand i = r : rand i'
   where i' = ( (3146757 * i) + 1731) `mod` 4194304
         r = (fromInteger i') / 4194304.0


\begin{code}
module Arr (
  module Data.Array,

  safezipWith, safezip,
  row,
  sum1, map2, map3,
  mapat, mapat2, mapat3,
  mapindexed, mapindexed2, mapindexed3,
--  zipArr, sumArr, scaleArr,
  arraySize,

  matvec, inner,
  outerVector,

  Vector (Vector), toVector, fromVector, listVector, vectorList, vector,
  zipVector, scaleVector, sumVector, vectorNorm2, vectorSize,

  Matrix (Matrix), toMatrix, fromMatrix, listMatrix, matrixList, matrix,
  zipMatrix, scaleMatrix, sumMatrix,

  augment,
  trMatrix,

--   showsVector,
--   showsMatrix,
-- showsVecList, showsMatList
--  spy,
) where
import Data.Array
import Numeric
--import Trace
--import IOExtensions(unsafePerformIO)
\end{code}

@Vector@ and @Matrix@ are 1-based arrays with read/show in form of Lists.

\begin{code}
data Vector a = Vector (Array Int a) deriving (Eq) --, Show)

toVector :: Array Int a -> Vector a
toVector x = Vector x

fromVector :: Vector a -> Array Int a
fromVector (Vector x) = x

instance Functor (Vector) where
  fmap fn x = toVector (fmap fn (fromVector x))

{-instance Eq a => Eq (Vector a) where
--  (Vector x) == (Vector y) = x == y
-}

instance Show a => Show (Vector a) where
  showsPrec p x = showsPrec p (elems (fromVector x))

instance Read a => Read (Vector a) where
  readsPrec p = readParen False
                  (\r -> [(listVector s, t) | (s, t) <- reads r])

instance Num b => Num (Vector b) where
  (+) = zipVector "+" (+)
  (-) = zipVector "-" (-)
  negate = fmap negate
  abs = fmap abs
  signum = fmap signum
--   (*) = matMult -- works only for matrices!
--  fromInteger = fmap fromInteger
\end{code}

Convert a list to 1-based vector.

\begin{code}
listVector :: [a] -> Vector a
listVector x = toVector (listArray (1,length x) x)

vectorList :: Vector a -> [a]
vectorList = elems . fromVector

vector (l,u) x | l == 1 = toVector (array (l,u) x)
               | otherwise = error "vector: l != 1"

zipVector :: String -> (b -> c -> d) -> Vector b -> Vector c -> Vector d
zipVector s f (Vector a) (Vector b)
  | bounds a == bounds b = vector (bounds a) [(i, f (a!i) (b!i)) | i <- indices a]
  | otherwise            = error ("zipVector: " ++ s ++ ": unconformable arrays")

scaleVector :: Num a => a -> Vector a -> Vector a
scaleVector a = fmap (* a)

sumVector :: Num a => Vector a -> a
sumVector = sum . elems . fromVector

vectorNorm2 :: Num a => Vector a -> a
vectorNorm2 x = inner x x

vectorSize :: Vector a -> Int
vectorSize (Vector x) = rangeSize (bounds x)

\end{code}

==============

\begin{code}
data Matrix a = Matrix (Array (Int, Int) a) deriving Eq

toMatrix :: Array (Int, Int) a -> Matrix a
toMatrix x = Matrix x

fromMatrix :: Matrix a -> Array (Int, Int) a
fromMatrix (Matrix x) = x

instance Functor (Matrix) where
  fmap fn x = toMatrix (fmap fn (fromMatrix x))

--instance Eq a => Eq (Matrix a) where
--  (Matrix x) == (Matrix y) = x == y

instance Show a => Show (Matrix a) where
  showsPrec p x = vertl (matrixList x)

vertl [] = showString "[]"
vertl (x:xs) = showChar '[' . shows x . showl xs
    where showl [] = showChar ']'
          showl (x:xs) = showString ",\n" . shows x . showl xs

instance Read a => Read (Matrix a) where
    readsPrec p = readParen False
                  (\r -> [(listMatrix s, t) | (s, t) <- reads r])

instance Num b => Num (Matrix b) where
  (+) = zipMatrix "+" (+)
  (-) = zipMatrix "-" (-)
  negate = fmap negate
  abs = fmap abs
  signum = fmap signum
  x * y = toMatrix (matMult (fromMatrix x) (fromMatrix y)) -- works only for matrices!
--  fromInteger = fmap fromInteger
\end{code}

Convert a nested list to a matrix.

\begin{code}
listMatrix :: [[a]] -> Matrix a
listMatrix x = Matrix (listArray ((1, 1), (length x, length (x!!0))) (concat x))

matrixList :: Matrix a -> [[a]]
matrixList (Matrix x) = [ [x!(i,j) | j <- range (l',u')] | i <- range (l,u)]
         where ((l,l'),(u,u')) = bounds x

matrix ((l,l'),(u,u')) x | l == 1 && l' == 1 = toMatrix (array ((l,l'),(u,u')) x)
                         | otherwise = error "matrix: l != 1"

zipMatrix :: String -> (b -> c -> d) -> Matrix b -> Matrix c -> Matrix d
zipMatrix s f (Matrix a) (Matrix b)
  | bounds a == bounds b = matrix (bounds a) [(i, f (a!i) (b!i)) | i <- indices a]
  | otherwise            = error ("zipMatrix: " ++ s ++ ": unconformable arrays")

scaleMatrix :: Num a => a -> Matrix a -> Matrix a
scaleMatrix a = fmap (* a)

sumMatrix :: Num a => Matrix a -> a
sumMatrix = sum . elems . fromMatrix

\end{code}

============

\begin{code}
safezipWith :: String -> (a -> b -> c) -> [a] -> [b] -> [c]
safezipWith _ _ [] [] = []
safezipWith s f (x:xs) (y:ys) = f x y : safezipWith s f xs ys
safezipWith s _ _ _ = error ("safezipWith: " ++ s ++ ": unconformable vectors")

safezip :: [a] -> [b] -> [(a,b)]
safezip = safezipWith "(,)" (,)

trMatrix :: Matrix a -> Matrix a
trMatrix (Matrix x) = matrix ((l,l'),(u',u)) [((j,i), x!(i,j)) | j <- range (l',u'), i <- range (l,u)]
         where ((l,l'),(u,u')) = bounds x

row :: (Ix a, Ix b) => a -> Array (a,b) c -> Array b c
row i x = ixmap (l',u') (\j->(i,j)) x where ((l,l'),(u,u')) = bounds x

zipArr :: (Ix a) => String -> (b -> c -> d) -> Array a b -> Array a c -> Array a d
zipArr s f a b | bounds a == bounds b = array (bounds a) [(i, f (a!i) (b!i)) | i <- indices a]
               | otherwise            = error ("zipArr: " ++ s ++ ": unconformable arrays")
\end{code}

Valid only for b -> c -> b functions.

\begin{code}
zipArr' :: (Ix a) => String -> (b -> c -> b) -> Array a b -> Array a c -> Array a b
zipArr' s f a b | bounds a == bounds b = accum f a (assocs b)
                | otherwise            = error ("zipArr': " ++ s ++ ": unconformable arrays")
\end{code}

Overload arithmetical operators to work on lists.

\begin{code}
instance Num a => Num [a] where
  (+) = safezipWith "+" (+)
  (-) = safezipWith "-" (-)
  negate = fmap negate
  abs = fmap abs
  signum = fmap signum
--   (*) = undefined
--   fromInteger = undefined
\end{code}

\begin{code}
sum1 :: (Num a) => [a] -> a
sum1 = foldl1 (+)

--main = print (sum1 [[4,1,1], [5,1,2], [6,1,3,4]])
\end{code}

\begin{code}
map2 f = fmap (fmap f)
map3 f = fmap (map2 f)
\end{code}

Map function f at position n only.  Out of range indices are silently
ignored.

\begin{code}
mapat n f x = mapat1 0 f x where
    mapat1 _ _ [] = []
    mapat1 i f (x:xs) = (if i == n then f x else x) : mapat1 (i + 1) f xs

mapat2 (i,j) = mapat i . mapat j
mapat3 (i,j,k) = mapat i . mapat j . mapat k

-- main = print (mapat 2 (10+) [1,2,3,4])
-- main = print (mapat2 (1,0) (1000+) ginp)
-- main = print (mapat3 (1,0,1) (1000+) gw)
\end{code}

\begin{code}
mapindexed f x = mapindexed1 f 0 x where
    mapindexed1 _ _ [] = []
    mapindexed1 f n (x:xs) = f n x : mapindexed1 f (n + 1) xs

mapindexed2 f = mapindexed (\i -> mapindexed (\j -> f (i, j)))
mapindexed3 f = mapindexed (\i -> mapindexed (\j -> mapindexed (\k -> f (i, j, k))))

-- main = print (mapindexed (\x y -> mapat (10+) [1,2,3,4] y) [1,2,3,4])
-- main = print (mapindexed2 (\(i,j) x -> 100*i + 10*j + x) ginp)
-- main = print (mapindexed3 (\(i,j,k) x -> 1000*i + 100*j + 10*k + x) gw)
\end{code}

Overload arithmetical operators to work on arrays.

\begin{code}
instance (Ix a, Show a, Num b) => Num (Array a b) where
  (+) = zipArr "+" (+)
  (-) = zipArr "-" (-)
  negate = fmap negate
  abs = fmap abs
  signum = fmap signum
--   (*) = matMult -- works only for matrices!
--   fromInteger = map fromInteger
\end{code}

\begin{xcode}
scaleArr :: (Ix i, Num a) => a -> Array i a -> Array i a
scaleArr a = fmap (*a)

sumArr :: (Ix i, Num a) => Array i a -> a
sumArr = sum . elems
\end{xcode}

\begin{code}
arraySize :: (Ix i) => Array i a -> Int
arraySize = rangeSize . bounds
\end{code}

\begin{code}
matMult         :: (Ix a, Ix b, Ix c, Num d) =>
                   Array (a,b) d -> Array (b,c) d -> Array (a,c) d
matMult x y     =  array resultBounds
                         [((i,j), sum [x!(i,k) * y!(k,j) | k <- range (lj,uj)])
                                       | i <- range (li,ui),
                                         j <- range (lj',uj') ]
        where ((li,lj),(ui,uj))         =  bounds x
              ((li',lj'),(ui',uj'))     =  bounds y
              resultBounds
                | (lj,uj)==(li',ui')    =  ((li,lj'),(ui,uj'))
                | otherwise             = error "matMult: incompatible bounds"
\end{code}

Inner product of two vectors.

\begin{code}
inner :: Num a => Vector a -> Vector a -> a
inner (Vector v) (Vector w) = if b == bounds w
               then sum [v!i * w!i | i <- range b]
               else error "nn.inner: inconformable vectors"
            where b = bounds v
\end{code}

Outer product of two vectors $v \dot w^\mathrm{T}$.

\begin{code}
outerVector :: Num b => Vector b -> Vector b -> Matrix b
outerVector (Vector v) (Vector w) = if (l,u) == (l',u')
               then matrix ((l,l'),(u,u')) [((i,j), v!i * w!j) | i <- range (l,u), j <- range (l',u')]
               else error "nn.outer: inconformable vectors"
            where ((l,u),(l',u')) = (bounds v, bounds w)
\end{code}

\begin{code}
outerArr :: (Ix a, Num b) => Array a b -> Array a b -> Array (a,a) b
outerArr v w = if (l,u) == (l',u')
               then array ((l,l'),(u,u')) [((i,j), v!i * w!j) | i <- range (l,u), j <- range (l',u')]
               else error "nn.outer: inconformable vectors"
            where ((l,u),(l',u')) = (bounds v, bounds w)
\end{code}

Inner product of a matrix and a vector.

\begin{code}
matvec :: (Ix a, Num b) => Array (a,a) b -> Array a b -> Array a b
matvec w x | bounds x == (l',u') =
                array (l,u) [(i, sum [w!(i,j) * x!j | j <- range (l',u')])
                                | i <- range (l,u)]
           | otherwise           = error "nn.matvec: inconformable arrays"
         where ((l,l'),(u,u')) = bounds w
\end{code}

Append to a vector.

\begin{code}
augment :: (Num a) => Vector a -> a -> Vector a
augment (Vector x) y = Vector (array (a,b') ((b',y) : assocs x))
            where (a,b) = bounds x
                  b' = b + 1
\end{code}

Older approach (x!!i!!j fails in ghc-2.03).

\begin{code}
toMatrix' :: [[a]] -> Matrix a
toMatrix' x = Matrix (array ((1,1),(u,u')) [((i,j), (x!!(i-1))!!(j-1))
                             | i <- range (1,u), j <- range (1,u')])
          where (u,u') = (length x,length (x!!0))
\end{code}

Matrix 2D printout.

\begin{code}
padleft :: Int -> String -> String
padleft n x | n <= length x = x
            | otherwise = replicate (n - length x) ' ' ++ x
\end{code}

\begin{code}
padMatrix :: RealFloat a => Int -> Matrix a -> Matrix String
padMatrix n x = let ss = fmap (\a -> showFFloat (Just n) a "") x
                    maxw = maximum (fmap length (elems (fromMatrix ss)))
              in fmap (padleft maxw) ss
\end{code}

\begin{xcode}
showsVector :: (RealFloat a) => Int -> Vector a -> ShowS
showsVector n x z1 = let x' = padArr n x
                         (l,u) = bounds x' in
                  concat (fmap (\ (i, s) -> if i == u then s ++ "\n" else s ++ " ") (assocs x')) ++ z1
\end{xcode}

\begin{xcode}
showsMatrix :: RealFloat a => Int -> Matrix a -> ShowS
showsMatrix n x z1 = let x' = padMatrix n x
                         ((l,l'),(u,u')) = bounds x' in
                   concat (fmap (\ ((i,j), s) -> if j == u' then s ++ "\n" else s ++ " ") (assocs x')) ++ z1
\end{xcode}

{-
showsVecList n x s = foldr (showsVector n) s x
showsMatList n x s = foldr (showsMatrix n) s x
-}

\begin{code}
--spy :: Show a => String -> a -> a
--spy msg x = trace ('<' : msg ++ ": " ++ shows x ">\n") x
--spy x  = seq (unsafePerformIO (putStr ('<' : shows x ">\n"))) x
--spy x  = traceShow "z" x
\end{code}


\begin{code}
module Main(main) where
import Arr
\end{code}

\begin{code}
type F a = Vector a -> a
type DF a = Vector a -> Vector a
\end{code}

\begin{code}
data {-(Eval a) =>-} ScgData a = ScgData {k :: !Int, err :: !a,
                          w, p, r :: !(Vector a),
                          delta, pnorm2, lambda, lambdabar :: !a,
                          success :: !Bool}
\end{code}

\begin{code}
calculate2order :: Floating a => ScgData a -> a -> DF a -> ScgData a
calculate2order d sigma1 df =
  let pnorm2' = vectorNorm2 (p d)
      sigma = sigma1 / (sqrt pnorm2')
      s = scaleVector (1/sigma) (df ((w d) + (scaleVector sigma (p d))) - df (w d))
  in d {pnorm2 = pnorm2', delta = inner (p d) s}
\end{code}

\begin{code}
hessPosDef :: (Floating a, Ord a) => ScgData a -> ScgData a
hessPosDef d =
  let delta' = delta d + (lambda d - lambdabar d) * pnorm2 d {- step 3 -}
  in if delta' <= 0                             {- step 4 -}
     then let lambdabar' = 2.0 * (lambda d - delta' / pnorm2 d)
          in d {delta = -delta' + lambda d * pnorm2 d, lambda = lambdabar', lambdabar = lambdabar'}
     else d {delta = delta'}
\end{code}

\begin{code}
reduceError :: (Floating a, Ord a) => ScgData a -> DF a -> Bool -> a -> a -> ScgData a
reduceError d df restart bdelta mu =
  let r' = negate (df (w d))
      p' = if restart
           then r'
           else let beta = (vectorNorm2 r' - inner r' (r d)) / mu
                in r' + scaleVector beta (p d)
  in d {p = p', r = r', lambda = if bdelta >= 0.75 then lambda d / 4 else lambda d
    }
\end{code}

\begin{code}
data ScgInput a = ScgInput (F a) (DF a) (Vector a)
\end{code}

\begin{code}
scgIter :: (Floating a, Ord a) => ScgInput a -> [ScgData a]
scgIter (ScgInput f df w1) =
    let p1 = negate (df w1)                     {- step 1 -}
        r1 = p1
        pnorm21 = vectorNorm2 p1
        n = vectorSize w1
        sigma1 = 1.0e-4
        lambda1 = 1.0e-6
        err1 = f w1
    in iterate (\d ->
           let d1 = if success d                {- step 2 -}
                    then calculate2order d sigma1 df
                    else d
               d2 = hessPosDef d1
               mu = inner (p d2) (r d2)         {- step 5 -}
               alpha = mu / (delta d2)
               w' = (w d2) + scaleVector alpha (p d2)
               err' = f w'
               bdelta = 2 * (delta d2) * ((err d2) - err') / (mu^2) {- step 6 -}
               success' = (bdelta >= 0)         {- step 7 -}
               restart = ((k d) `mod` n == 0)
               d3 = if success'
                    then (reduceError (d2 {w = w'}) df restart bdelta mu)
                            {err = err', lambdabar = 0}
                    else d2 {lambdabar = lambda d2}
               d4 = if bdelta < 0.25          {- step 8 -}
                    then d3 {lambda = (lambda d3) + (delta d3) * (1 - bdelta) / (pnorm2 d3)}
                    else d3
           in d4 {k = k d4 + 1, success = success'}
       )
       (ScgData 1 err1 w1 p1 r1 0.0 pnorm21 lambda1 0.0 True)
\end{code}

\begin{code}
rosenbrock = ScgInput
  (\ (Vector x) -> 100 * (x!2 - x!1^2)^2 + (1 - x!1)^2)
  (\ (Vector x) -> listVector [-2 * (1 - x!1) - 400 * x!1 * (x!2 - x!1^2),
                              200 * (x!2 -x!1^2)])
  (listVector [-1,-1.0])
\end{code}

\begin{code}
main = case vectorList (w ((scgIter rosenbrock)!!1)) of
       [v1, v2] -> if (e1 `isSame` v1) && (e2 `isSame` v2)
                   then print (e1, e2)
                   else putStrLn ("Mismatch: " ++ show (e1, e2, v1, v2))
       vs -> putStrLn ("Wrong list length: " ++ show vs)

e1, e2 :: Floating a => a
e1 = -0.5105811455265337
e2 = -0.7565080326002654

isSame :: (Fractional a, Ord a) => a -> a -> Bool
x `isSame` y = abs (x - y) < 0.000000000000001
\end{code}


\section{Versions of {\tt append}}

\begin{code}
{-# LANGUAGE MagicHash #-}

module Append where

import GHC.Exts
import Types
\end{code}

\begin{code}
append_ :: [a] -> [a] -> [a]
append_ (x:xs) ys = x : (append_ xs ys)
append_ [] ys = ys

append_L_S_S :: String -> S Char -> S Char
append_L_S_S (a: b: c: d: e: a1: b1: c1: d1: e1: xs) ys
 = S5 a b c d e (S5 a1 b1 c1 d1 e1 (append_L_S_S xs ys))
append_L_S_S (a: b: c: d: e: xs) ys
 = S5 a b c d e (append_L_S_S xs ys)
append_L_S_S (a: b: c: d: _) ys
 = S4 a b c d ys
append_L_S_S (a: b: c: _) ys
 = S3 a b c ys
append_L_S_S (a: b: _) ys
 = S2 a b ys
append_L_S_S [a] ys
 = S1 a ys
append_L_S_S [] ys = ys

append_F_S_S :: F Char -> S Char -> S Char
append_F_S_S (F5 a b c d e (F5 a1 b1 c1 d1 e1 xs)) ys
 = S5 a b c d e (S5 a1 b1 c1 d1 e1 (append_F_S_S xs ys))
append_F_S_S (F5 a b c d e xs) ys
 = S5 a b c d e (append_F_S_S xs ys)
append_F_S_S (F4 a b c d) ys
 = S4 a b c d ys
append_F_S_S (F3 a b c) ys
 = S3 a b c ys
append_F_S_S (F2 a b) ys
 = S2 a b ys
append_F_S_S (F1 a) ys
 = S1 a ys
append_F_S_S FN ys = ys

append_L_SC_SC :: String -> SC -> SC
append_L_SC_SC (C# a: C# b: C# c: C# d:
                C# e: C# a1: C# b1: C# c1:
                C# d1: C# e1: xs) ys
 = SC5 a b c d e (SC5 a1 b1 c1 d1 e1 (append_L_SC_SC xs ys))
append_L_SC_SC (C# a: C# b: C# c: C# d:
                C# e: xs) ys
 = SC5 a b c d e (append_L_SC_SC xs ys)
append_L_SC_SC (C# a: C# b: C# c: C# d: _) ys
 = SC4 a b c d ys
append_L_SC_SC (C# a: C# b: C# c: _) ys
 = SC3 a b c ys
append_L_SC_SC (C# a: C# b: _) ys
 = SC2 a b ys
append_L_SC_SC [C# a] ys
 = SC1 a ys
append_L_SC_SC [] ys = ys

append_FC_SC_SC :: FC -> SC -> SC
append_FC_SC_SC (FC5 a b c d e (FC5 a1 b1 c1 d1 e1 xs)) ys
 = SC5 a b c d e (SC5 a1 b1 c1 d1 e1 (append_FC_SC_SC xs ys))
append_FC_SC_SC (FC5 a b c d e xs) ys
 = SC5 a b c d e (append_FC_SC_SC xs ys)
append_FC_SC_SC (FC4 a b c d) ys
 = SC4 a b c d ys
append_FC_SC_SC (FC3 a b c) ys
 = SC3 a b c ys
append_FC_SC_SC (FC2 a b) ys
 = SC2 a b ys
append_FC_SC_SC (FC1 a) ys
 = SC1 a ys
append_FC_SC_SC FCN ys = ys

append_F_L_L :: F a -> [a] -> [a]
append_F_L_L (F5 a b c d e (F5 a1 b1 c1 d1 e1 xs)) ys
 = a: b: c: d: e: a1: b1: c1: d1: e1: (append_F_L_L xs ys)
append_F_L_L (F5 a b c d e xs) ys
 = a: b: c: d: e: (append_F_L_L xs ys)
append_F_L_L (F4 a b c d) ys  = a: b: c: d: ys
append_F_L_L (F3 a b c) ys  = a: b: c: ys
append_F_L_L (F2 a b) ys  = a: b: ys
append_F_L_L (F1 a) ys  = a: ys
append_F_L_L FN ys = ys

append_S_L_L :: S Char -> String -> String
append_S_L_L (S5 a b c d e (S5 a1 b1 c1 d1 e1 xs)) ys
 =  a:  b:  c:  d:  e:  a1: b1:  c1:  d1:  e1: (append_S_L_L xs ys)
append_S_L_L (S5 a b c d e xs) ys
 =  a:  b:  c:  d: e: (append_S_L_L xs ys)
append_S_L_L (S4 a b c d xs) ys
 =  a:  b:  c:  d: (append_S_L_L xs ys)
append_S_L_L (S3 a b c xs) ys
 =  a:  b:  c: (append_S_L_L xs ys)
append_S_L_L (S2 a b xs) ys
 =  a:  b: (append_S_L_L xs ys)
append_S_L_L (S1 a xs) ys
 =  a: (append_S_L_L xs ys)
append_S_L_L SN ys = ys

append_FC_L_L :: FC -> String -> String
append_FC_L_L (FC5 a b c d e (FC5 a1 b1 c1 d1 e1 xs)) ys
 = C# a: C# b: C# c: C# d: C# e: C# a1:
      C# b1: C# c1: C# d1: C# e1:
         (append_FC_L_L xs ys)
append_FC_L_L (FC5 a b c d e xs) ys
 = C# a: C# b: C# c: C# d:
      C# e: (append_FC_L_L xs ys)
append_FC_L_L (FC4 a b c d) ys
 = C# a: C# b: C# c: C# d: ys
append_FC_L_L (FC3 a b c) ys
 = C# a: C# b: C# c: ys
append_FC_L_L (FC2 a b) ys  = C# a: C# b: ys
append_FC_L_L (FC1 a) ys  = C# a: ys
append_FC_L_L FCN ys = ys

append_SC_L_L :: SC -> String -> String
append_SC_L_L (SC5 a b c d e (SC5 a1 b1 c1 d1 e1 xs)) ys
 = C# a: C# b: C# c: C# d: C# e: C# a1:
      C# b1: C# c1: C# d1: C# e1:
          (append_SC_L_L xs ys)
append_SC_L_L (SC5 a b c d e xs) ys
 = C# a: C# b: C# c: C# d:
      C# e: (append_SC_L_L xs ys)
append_SC_L_L (SC4 a b c d xs) ys
 = C# a: C# b: C# c: C# d: (append_SC_L_L xs ys)
append_SC_L_L (SC3 a b c xs) ys
 = C# a: C# b: C# c: (append_SC_L_L xs ys)
append_SC_L_L (SC2 a b xs) ys
 = C# a: C# b: (append_SC_L_L xs ys)
append_SC_L_L (SC1 a xs) ys
 = C# a: (append_SC_L_L xs ys)
append_SC_L_L SCN ys = ys
\end{code}


\begin{code}
{-# LANGUAGE MagicHash #-}

import GHC.Exts
import Types
import Append

main = putStr (show (append_FC_L_L (FC2 a_ a_) []))
   where a_ = case 'a' of { C# x -> x }
\end{code}


\section{IDS types}

\begin{code}
{-# LANGUAGE MagicHash #-}

module Types where

import GHC.Exts

data F a = FN | F1 a | F2 a a | F3 a a a
         | F4 a a a a
         | F5 a a a a a (F a)

data FI = FIN | FI1 Int# | FI2 Int# Int# | FI3 Int# Int# Int#
        | FI4 Int# Int# Int# Int#
        | FI5 Int# Int# Int# Int# Int# FI

data FC = FCN | FC1 Char# | FC2 Char# Char#
        | FC3 Char# Char# Char#
        | FC4 Char# Char# Char# Char#
        | FC5 Char# Char# Char# Char# Char# FC
\end{code}

\begin{code}
data F2 a b = F2N | F21 a b | F22 a b a b | F23 a b a b a b
            | F24 a b a b a b a b
            | F25 a b a b a b a b a b (F2 a b)

data F3 a b c = F3N | F31 a b c | F32 a b c a b c
              | F33 a b c a b c a b c
              | F34 a b c a b c a b c a b c
              | F35 a b c a b c a b c a b c a b c (F3 a b c)

data F3I = F3IN
         | F3I1 Int# Int# Int#
         | F3I2 Int# Int# Int# Int# Int# Int#
         | F3I3 Int# Int# Int# Int# Int# Int# Int# Int# Int#
         | F3I4 Int# Int# Int# Int# Int# Int# Int# Int# Int#
                Int# Int# Int#
         | F3I5 Int# Int# Int# Int# Int# Int# Int# Int# Int#
                Int# Int# Int# Int# Int# Int# F3I
\end{code}

\begin{code}
data S a = SN | S1 a (S a) | S2 a a (S a) | S3 a a a (S a)
         | S4 a a a a (S a)
         | S5 a a a a a (S a)

data SI = SIN | SI1 Int# SI | SI2 Int# Int# SI
        | SI3 Int# Int# Int# SI
        | SI4 Int# Int# Int# Int# SI
        | SI5 Int# Int# Int# Int# Int# SI

data SC = SCN | SC1 Char# SC | SC2 Char# Char# SC
        | SC3 Char# Char# Char# SC
        | SC4 Char# Char# Char# Char# SC
        | SC5 Char# Char# Char# Char# Char# SC
\end{code}


       module Fast2haskell (
            Complex_type, Array_type, Assoc_type, Descr_type,
            abortstr, delay, fix, force, iff, iffrev, seQ,
            pair, strcmp,
            entier,
            land_i, lnot_i, lor_i, lshift_i, rshift_i,
            descr,
            destr_update, indassoc, lowbound, tabulate, upbound, update, valassoc) where {
            import Data.Bits;
--            import Word2;
            import Data.Word;
            import Data.Complex; -- 1.3
            import Data.Array; -- 1.3
--          import Data.Int ( Num(fromInt) );
            type Complex_type   = Complex Double;
            type Array_type b   = Array Int b;
            type Assoc_type a   = (Int, a);
            type Descr_type     = (Int,Int);
            abortstr      str                 = error ("abort:"++str); -- abort (OtherError str);
            delay         x                   = abortstr "delay not implemented";
            fix           f                   = fix_f where {fix_f = f fix_f};
            force         x                   = x; -- error  "force not implemented";
            iff           b     x  y          = if b then x else y;
            iffrev        y  x      b         = if b then x else y;
            seQ           x    y              = x `seq` y;
            pair          []                  = False;
            pair          x                   = True;
            strcmp        :: [Char] -> [Char] -> Bool;
            strcmp        x      y            = x == y;
            entier        x                   = fromIntegral (floor x);
            land_i        :: Int -> Int -> Int;
            land_i        x    y              = x .&. y;
            lnot_i        :: Int -> Int;
            lnot_i        x                   = complement x;
            lor_i         :: Int -> Int -> Int;
            lor_i         x    y              = x .|. y;
            lshift_i      :: Int -> Int -> Int;
            lshift_i      x    y              = x `shiftL` y;
            rshift_i      :: Int -> Int -> Int;
            rshift_i      x    y              = x `shiftR` y;
            write         x                   = abortstr "write not implemented";
            descr         l    u              = (l,u);
            destr_update  ar  i  x            = ar // [(i,x)];
            indassoc      (i,v)              = i;
            lowbound      (l,u)               = l;
            tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
            upbound       (l,u)               = u;
            update        ar i x              = ar // [(i,x)];
            valassoc      (i,v)               = v;
       }


module Main (main) -- TEST
where {
import Fast2haskell;
import Data.Complex;--1.3
import Data.Array;--1.3

    c_eps=(5.00000e-06 :: Double);
    c_t=True;
    c_f=False;
    c_input=(0 :: Int);
    f_main a_n=
        let {
            r_x=[(a_tf,(++) (show a_i) ((++) "\t" a_str))|(a_i,(a_tf,a_str))<-f_zip2 (enumFrom (1 :: Int)) c_testlist];
            r_noks=[(++) a_str "\n"|(a_tf,a_str)<-r_x,not a_tf];
            r_oks=[(++) a_str "\n"|(a_tf,a_str)<-r_x,a_tf]
         } in
            if (((>) :: (Int -> Int -> Bool)) a_n (0 :: Int))
            then (f_onetest ((!!) c_testlist (((-) :: (Int -> Int -> Int)) a_n (1 :: Int))))
            else
                ((++) (show (length r_oks)) ((++) " tests passed and " ((++) (show
                (length r_noks)) ((++) " failed\n" (c_concat r_noks)))));
    f_onetest (True,a_str)=(++) "true:  " ((++) a_str "\n");
    f_onetest (False,a_str)=(++) "false: " ((++) a_str "\n");
    f_booltest a_name True a_try=
        if a_try
        then (True,"")
        else
            (False,(++) a_name "\tok: true is: false");
    f_booltest a_name False a_try=
        if (not a_try)
        then (True,"")
        else
            (False,(++) a_name "\tok: false is: true");
    f_inttest a_name a_ok a_try=
        if (((==) :: (Int -> Int -> Bool)) a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (show a_ok) ((++) "\tis: "
            (show a_try)))));
    f_chartest a_name a_ok a_try=
        if (((==) :: (Int -> Int -> Bool)) (fromEnum a_ok) (fromEnum a_try))
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) ((:) a_ok []) ((++) "\tis: "
            ((:) a_try [])))));
    f_strtest a_name a_ok a_try=
        if (strcmp a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) a_ok ((++) "\tis: " a_try))));
    f_linttest a_name a_ok a_try=
        if (f_lintcmp a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (f_showlint a_ok) ((++) "\tis: "
            (f_showlint a_try)))));
    f_doubtest a_name a_ok a_try=
        if (((<=) :: (Double -> Double -> Bool)) (f_abs (((-) :: (Double -> Double -> Double)) a_ok a_try)) c_eps)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (show a_ok) ((++) "\tis: "
            ((++) (show a_try) ((++) "\tok-is: " (show (((-) :: (Double -> Double -> Double)) a_ok a_try))))))));
    f_alternating a_l=(:) (0 :: Int) ((:) (1 :: Int) a_l);
    f_showlint []=[];
    f_showlint a_xs=tail (c_concat [(++) "," (show a_x)|a_x<-a_xs]);
    f_lintcmp [] []=True;
    f_lintcmp [] a_ys=False;
    f_lintcmp a_xs []=False;
    f_lintcmp (a_x:a_xs) (a_y:a_ys)=
        if (((==) :: (Int -> Int -> Bool)) a_x a_y)
        then (f_lintcmp a_xs a_ys)
        else
            False;
    c_testlist=(:) (f_inttest "array" (10 :: Int) ((!) (array (descr (1 :: Int) (3 :: Int)) ((:)
        ((,) (3 :: Int) (30 :: Int)) ((:) ((,) (1 :: Int) (10 :: Int)) ((:) ((,) (2 :: Int) (20 :: Int)) [])))) (1 :: Int))) ((:) (f_inttest "array" (20 :: Int)
        ((!) (array (descr (1 :: Int) (3 :: Int)) ((:) ((,) (3 :: Int) (30 :: Int)) ((:) ((,) (1 :: Int) (10 :: Int))
        ((:) ((,) (2 :: Int) (20 :: Int)) [])))) (2 :: Int))) ((:) (f_inttest "array" (30 :: Int) ((!) (array (descr (1 :: Int) (3 :: Int))
        ((:) ((,) (3 :: Int) (30 :: Int)) [])) (3 :: Int))) ((:) (f_inttest "assoc" (0 :: Int) (indassoc ((,) (0 :: Int) (1 :: Int)))) ((:)
        (f_inttest "assoc" (1 :: Int) (valassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_inttest "bounds" (1 :: Int) (lowbound (bounds
        (listArray (descr (1 :: Int) (3 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))))))) ((:) (f_inttest "bounds" (3 :: Int)
        (upbound (bounds (listArray (descr (1 :: Int) (3 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))))
        ((:) (f_inttest "descr" (0 :: Int) (lowbound (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "descr" (1 :: Int) (upbound
        (descr (0 :: Int) (1 :: Int)))) ((:) (f_linttest "destr_update" ((:) (1 :: Int) ((:) (0 :: Int) ((:) (3 :: Int) []))) (elems
        (destr_update (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (1 :: Int) (0 :: Int)))) ((:)
        (f_linttest "destr_update" ((:) (0 :: Int) []) (elems (destr_update (listArray (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))) (0 :: Int) (0 :: Int)))) ((:) (f_linttest "elems" ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))
        (elems (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:)
        (f_linttest "elems" ((:) (1 :: Int) []) (elems (listArray (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int)
        ((:) (3 :: Int) [])))))) ((:) (f_inttest "indassoc" (0 :: Int) (indassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_linttest "listarray"
        ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))) (elems (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:) (f_linttest "listarray" ((:) (1 :: Int) []) (elems (listArray
        (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:) (f_inttest "lowbound" (0 :: Int) (lowbound
        (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "subscript" (1 :: Int) ((!) (tabulate ((!!) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (0 :: Int))) ((:) (f_inttest "subscript" (2 :: Int) ((!) (tabulate
        ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (1 :: Int))) ((:) (f_inttest "subscript" (3 :: Int)
        ((!) (tabulate ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (2 :: Int)))
        ((:) (f_linttest "tabulate" ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))) (elems (tabulate
        ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))))) ((:) (f_linttest "tabulate"
        ((:) (1 :: Int) []) (elems (tabulate ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))))
        (descr (0 :: Int) (0 :: Int))))) ((:) (f_inttest "upbound" (1 :: Int) (upbound (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "valassoc" (1 :: Int)
        (valassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_doubtest "add_x" (0.00000 :: Double) (realPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double))
        ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "add_x" (0.00000 :: Double) (imagPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double)))))
        ((:) (f_doubtest "add_x" (4.00000 :: Double) (realPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:)
        (f_doubtest "add_x" (6.00000 :: Double) (imagPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "complex" (1.00000 :: Double)
        (realPart ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "complex" (1.00000 :: Double) (imagPart ((:+) (0.00000 :: Double) (1.00000 :: Double)))) ((:)
        (f_doubtest "complex_im" (0.00000 :: Double) (imagPart ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "complex_im" (1.00000 :: Double) (imagPart ((:+) (0.00000 :: Double) (1.00000 :: Double))))
        ((:) (f_doubtest "complex_re" (0.00000 :: Double) (realPart ((:+) (0.00000 :: Double) (1.00000 :: Double)))) ((:) (f_doubtest "complex_re" (1.00000 :: Double) (realPart
        ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "mul_x" (0.00000 :: Double) (realPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double)))))
        ((:) (f_doubtest "mul_x" (0.00000 :: Double) (imagPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:)
        (f_doubtest "mul_x" (((negate) :: (Double -> Double)) (5.00000 :: Double)) (realPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:)
        (f_doubtest "mul_x" (10.0000 :: Double) (imagPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "sub_x" (0.00000 :: Double)
        (realPart (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "sub_x" (0.00000 :: Double) (imagPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "sub_x" (((negate) :: (Double -> Double)) (2.00000 :: Double)) (realPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "sub_x" (((negate) :: (Double -> Double)) (2.00000 :: Double)) (imagPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_inttest "seq" (2 :: Int) (seq (enumFrom (1 :: Int)) (2 :: Int)))
        ((:) (f_strtest "**" "this one" "should fail") [])))))))))))))))))))))))))))))))))))))))))));
    f_abs a_x=
        if (((<=) :: (Double -> Double -> Bool)) a_x (0.00000 :: Double))
        then (((negate) :: (Double -> Double)) a_x)
        else
            a_x;
    c_and=f_foldr (&&) True;
    f_cjustify a_n a_s=
        let {
            r_margin=((-) :: (Int -> Int -> Int)) a_n (length a_s);
            r_lmargin=((div) :: (Int -> Int -> Int)) r_margin (2 :: Int);
            r_rmargin=((-) :: (Int -> Int -> Int)) r_margin r_lmargin
         } in  (++) (f_spaces r_lmargin) ((++) a_s (f_spaces r_rmargin));
    c_concat=f_foldr (++) [];
    f_const a_x a_y=a_x;
    f_digit a_x=
        if (((<=) :: (Int -> Int -> Bool)) (fromEnum '0') (fromEnum a_x))
        then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_x) (fromEnum '9'))
        else
            False;
    f_drop 0 a_x=a_x;
    f_drop a_n (a_a:a_x)=f_drop (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x;
    f_drop a_n a_x=[];
    f_dropwhile a_f []=[];
    f_dropwhile a_f (a_a:a_x)=
        if (a_f a_a)
        then (f_dropwhile a_f a_x)
        else
            ((:) a_a a_x);
    c_e=((exp) :: (Double -> Double)) (1.00000 :: Double);
    f_filter a_f a_x=[a_a|a_a<-a_x,a_f a_a];
    f_foldl a_op a_r []=a_r;
    f_foldl a_op a_r (a_a:a_x)=
        let {
            f_strict a_f a_x=seq a_x (a_f a_x)
         } in  f_foldl a_op (f_strict a_op a_r a_a) a_x;
    f_foldl1 a_op (a_a:a_x)=f_foldl a_op a_a a_x;
    f_foldr a_op a_r []=a_r;
    f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x);
    f_foldr1 a_op (a_a:[])=a_a;
    f_foldr1 a_op (a_a:a_b:a_x)=a_op a_a (f_foldr1 a_op ((:) a_b a_x));
    f_fst (a_a,a_b)=a_a;
    f_id a_x=a_x;
    f_index a_x=
        let {
            f_f a_n []=[];
            f_f a_n (a_a:a_x)=(:) a_n (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x)
         } in  f_f (0 :: Int) a_x;
    f_init (a_a:a_x)=
        if (null a_x)
        then []
        else
            ((:) a_a (f_init a_x));
    f_iterate a_f a_x=(:) a_x (f_iterate a_f (a_f a_x));
    f_last a_x=(!!) a_x (((-) :: (Int -> Int -> Int)) (length a_x) (1 :: Int));
    f_lay []=[];
    f_lay (a_a:a_x)=(++) a_a ((++) "\n" (f_lay a_x));
    f_layn a_x=
        let {
            f_f a_n []=[];
            f_f a_n (a_a:a_x)=(++) (f_rjustify (4 :: Int) (show a_n)) ((++) ") " ((++) a_a ((++) "\n"
                (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x))))
         } in  f_f (1 :: Int) a_x;
    f_letter a_c=
        if (
            if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'a') (fromEnum a_c))
            then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'z'))
            else
                False)
        then True
        else
        if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'A') (fromEnum a_c))
        then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'Z'))
        else
            False;
    f_limit (a_a:a_b:a_x)=
        if (((==) :: (Double -> Double -> Bool)) a_a a_b)
        then a_a
        else
            (f_limit ((:) a_b a_x));
    f_lines []=[];
    f_lines (a_a:a_x)=
        let {
            r_xs=
                if (pair a_x)
                then (f_lines a_x)
                else
                    ((:) [] [])
         } in
            if (((==) :: (Int -> Int -> Bool)) (fromEnum a_a) (fromEnum '\o012'))
            then ((:) [] (f_lines a_x))
            else
                ((:) ((:) a_a (head r_xs)) (tail r_xs));
    f_ljustify a_n a_s=(++) a_s (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s)));
    f_map a_f a_x=[a_f a_a|a_a<-a_x];
    f_map2 a_f a_x a_y=[a_f a_a a_b|(a_a,a_b)<-f_zip2 a_x a_y];
    f_max a_xs=f_foldl1 f_max2 a_xs;
    f_max2 a_a a_b=
        if (((>=) :: (Int -> Int -> Bool)) a_a a_b)
        then a_a
        else
            a_b;
    f_member a_x a_a=c_or (f_map (flip ((==) :: (Int -> Int -> Bool)) a_a) a_x);
    f_merge [] a_y=a_y;
    f_merge (a_a:a_x) []=(:) a_a a_x;
    f_merge (a_a:a_x) (a_b:a_y)=
        if (((<=) :: (Int -> Int -> Bool)) a_a a_b)
        then ((:) a_a (f_merge a_x ((:) a_b a_y)))
        else
            ((:) a_b (f_merge ((:) a_a a_x) a_y));
    f_min a_xs=f_foldl1 f_min2 a_xs;
    f_min2 a_a a_b=
        if (((>) :: (Int -> Int -> Bool)) a_a a_b)
        then a_b
        else
            a_a;
    f_mkset []=[];
    f_mkset (a_a:a_x)=(:) a_a (f_filter (flip ((/=) :: (Int -> Int -> Bool)) a_a) (f_mkset a_x));
    c_or=f_foldr (||) False;
    c_pi=((*) :: (Double -> Double -> Double)) (4.00000 :: Double) (((atan) :: (Double -> Double)) (1.00000 :: Double));
    f_postfix a_a a_x=(++) a_x ((:) a_a []);
    c_product=f_foldl ((*) :: (Int -> Int -> Int)) (1 :: Int);
    f_rep a_n a_x=f_take a_n (f_repeat a_x);
    f_repeat a_x=(:) a_x (f_repeat a_x);
    c_reverse=f_foldl (flip (:)) [];
    f_rjustify a_n a_s=(++) (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))) a_s;
    f_scan a_op=
        let {
            f_g a_r []=(:) a_r [];
            f_g a_r (a_a:a_x)=(:) a_r (f_g (a_op a_r a_a) a_x)
         } in  f_g;
    f_snd (a_a,a_b)=a_b;
    f_sort a_x=
        let {
            r_n=length a_x;
            r_n2=((div) :: (Int -> Int -> Int)) r_n (2 :: Int)
         } in
            if (((<=) :: (Int -> Int -> Bool)) r_n (1 :: Int))
            then a_x
            else
                (f_merge (f_sort (f_take r_n2 a_x)) (f_sort (f_drop r_n2 a_x)));
    f_spaces a_n=f_rep a_n ' ';
    f_subtract a_x a_y=((-) :: (Int -> Int -> Int)) a_y a_x;
    c_sum=f_foldl ((+) :: (Int -> Int -> Int)) (0 :: Int);
data
    T_sys_message=F_Stdout [Char] | F_Stderr [Char] | F_Tofile [Char] [Char] | F_Closefile [Char] | F_Appendfile [Char] | F_System [Char] | F_Exit Int;
    f_take 0 a_x=[];
    f_take a_n (a_a:a_x)=(:) a_a (f_take (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x);
    f_take a_n a_x=[];
    f_takewhile a_f []=[];
    f_takewhile a_f (a_a:a_x)=
        if (a_f a_a)
        then ((:) a_a (f_takewhile a_f a_x))
        else
            [];
    f_transpose a_x=
        let {
            r_x'=f_takewhile pair a_x
         } in
            if (null r_x')
            then []
            else
                ((:) (f_map head r_x') (f_transpose (f_map tail r_x')));
    f_until a_f a_g a_x=
        if (a_f a_x)
        then a_x
        else
            (f_until a_f a_g (a_g a_x));
    f_zip2 (a_a:a_x) (a_b:a_y)=(:) (a_a,a_b) (f_zip2 a_x a_y);
    f_zip2 a_x a_y=[];
    f_zip3 (a_a:a_x) (a_b:a_y) (a_c:a_z)=(:) (a_a,a_b,a_c) (f_zip3 a_x a_y a_z);
    f_zip3 a_x a_y a_z=[];
    f_zip4 (a_a:a_w) (a_b:a_x) (a_c:a_y) (a_d:a_z)=(:) (a_a,a_b,a_c,a_d) (f_zip4 a_w a_x a_y a_z);
    f_zip4 a_w a_x a_y a_z=[];
    f_zip5 (a_a:a_v) (a_b:a_w) (a_c:a_x) (a_d:a_y) (a_e:a_z)=(:) (a_a,a_b,a_c,a_d,a_e) (f_zip5 a_v a_w a_x a_y a_z);
    f_zip5 a_v a_w a_x a_y a_z=[];
    f_zip6 (a_a:a_u) (a_b:a_v) (a_c:a_w) (a_d:a_x) (a_e:a_y) (a_f:a_z)=(:) (a_a,a_b,a_c,a_d,a_e,a_f) (f_zip6 a_u a_v a_w a_x a_y a_z);
    f_zip6 a_u a_v a_w a_x a_y a_z=[];
    f_zip (a_x,a_y)=f_zip2 a_x a_y;
    main = putStr (f_main c_input)
}


-- !!! Defines functions as an instance of Num

module Main where

instance (Eq a, Eq b) => Eq (a->b)

instance Show (a->b) where
  show f = "<<function>>"

instance (Num a, Num b) => Num (a->b) where
    f + g    = \x -> f x + g x
    negate f = \x -> - (f x)
    f * g    = \x -> f x * g x
    fromInteger n = \x -> fromInteger n

ss :: Float -> Float
cc :: Float -> Float
tt :: Float -> Float

ss = sin * sin
cc = cos * cos
tt = ss + cc
-- sin**2 + cos**2 = 1

main = putStrLn ((show (tt 0.4))++ "  "++(show (tt 1.652)))


-- Copyright (c) 2000 Galois Connections, Inc.
-- All rights reserved.  This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.

module Construct
    ( Surface (..)
    , Face (..)
    , CSG (..)
    , Texture
    , Transform
    , union, intersect, difference
    , plane, sphere, cube, cylinder, cone
    , transform
    , translate, translateX, translateY, translateZ
    , scale, scaleX, scaleY, scaleZ, uscale
    , rotateX, rotateY, rotateZ
    , eye, translateEye
    , rotateEyeX, rotateEyeY, rotateEyeZ
    ) where

import Geometry

-- In each case, we model the surface by a point and a pair of tangent vectors.
-- This gives us enough information to determine the surface
-- normal at that point, which is all that is required by the current
-- illumination model.  We can't just save the surface normal because
-- that isn't preserved by transformations.

data Surface
  = Planar Point Vector Vector
  | Spherical Point Vector Vector
  | Cylindrical Point Vector Vector
  | Conic Point Vector Vector
  deriving Show

data Face
  = PlaneFace
  | SphereFace
  | CubeFront
  | CubeBack
  | CubeLeft
  | CubeRight
  | CubeTop
  | CubeBottom
  | CylinderSide
  | CylinderTop
  | CylinderBottom
  | ConeSide
  | ConeBase
  deriving Show

data CSG a
  = Plane a
  | Sphere a
  | Cylinder a
  | Cube a
  | Cone a
  | Transform Matrix Matrix (CSG a)
  | Union (CSG a) (CSG a)
  | Intersect (CSG a) (CSG a)
  | Difference (CSG a) (CSG a)
  | Box Box (CSG a)
  deriving (Show)

-- the data returned for determining surface texture
-- the Face tells which face of a primitive this is
-- the Point is the point of intersection in object coordinates
-- the a is application-specific texture information
type Texture a = (Face, Point, a)

union, intersect, difference            :: CSG a -> CSG a -> CSG a

union p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Union p q)
union p q = Union p q

-- rather pessimistic
intersect p@(Box b1 _) q@(Box b2 _) = Box (mergeBox b1 b2) (Intersect p q)
intersect p q = Intersect p q

difference (Box b1 p) q = Box b1 (Difference p q)
-- no need to box again inside
-- difference p@(Box b1 _) q = Box b1 (Difference p q)
difference p q = Difference p q

mkBox b p = Box b p

plane, sphere, cube, cylinder, cone     :: a -> CSG a

plane = Plane
sphere s =
    mkBox (B (-1 - epsilon) (1 + epsilon)
             (-1 - epsilon) (1 + epsilon)
             (-1 - epsilon) (1 + epsilon)) (Sphere s)
cone s =
    mkBox (B (-1 - epsilon) (1 + epsilon)
             (   - epsilon) (1 + epsilon)
             (-1 - epsilon) (1 + epsilon)) (Cone s)
cube s =
    mkBox (B (- epsilon) (1 + epsilon)
             (- epsilon) (1 + epsilon)
             (- epsilon) (1 + epsilon)) (Cube s)
cylinder s =
    mkBox (B (-1 - epsilon) (1 + epsilon)
             (   - epsilon) (1 + epsilon)
             (-1 - epsilon) (1 + epsilon)) (Cylinder s)

----------------------------
-- Object transformations
----------------------------

type Transform = (Matrix, Matrix)

transform :: Transform -> CSG a -> CSG a

transform (m, m')   (Transform mp mp' p) = Transform  (multMM m mp)       (multMM mp' m') p
transform mm'       (Union p q)          = Union      (transform mm' p)   (transform mm' q)
transform mm'       (Intersect p q)      = Intersect  (transform mm' p)   (transform mm' q)
transform mm'       (Difference p q)     = Difference (transform mm' p)   (transform mm' q)
transform mm'@(m,_) (Box box p)          = Box        (transformBox m box) (transform mm' p)
transform (m, m')   prim                 = Transform  m m' prim

translate                               :: Coords -> CSG a -> CSG a
translateX, translateY, translateZ      :: Double -> CSG a -> CSG a

translate xyz = transform $ transM xyz
translateX x = translate (x, 0, 0)
translateY y = translate (0, y, 0)
translateZ z = translate (0, 0, z)

scale                                   :: Coords -> CSG a -> CSG a
scaleX, scaleY, scaleZ, uscale          :: Double -> CSG a -> CSG a

scale xyz = transform $ scaleM xyz
scaleX x = scale (x, 1, 1)
scaleY y = scale (1, y, 1)
scaleZ z = scale (1, 1, z)
uscale u = scale (u,u,u)

rotateX, rotateY, rotateZ               :: Radian -> CSG a -> CSG a

rotateX a = transform $ rotxM a
rotateY a = transform $ rotyM a
rotateZ a = transform $ rotzM a

unit = matrix
      ( ( 1.0, 0.0, 0.0, 0.0 ),
        ( 0.0, 1.0, 0.0, 0.0 ),
        ( 0.0, 0.0, 1.0, 0.0 ),
        ( 0.0, 0.0, 0.0, 1.0 ) )

transM (x, y, z)
  = ( matrix
      ( ( 1, 0, 0, x ),
        ( 0, 1, 0, y ),
        ( 0, 0, 1, z ),
        ( 0, 0, 0, 1 ) ),
      matrix
      ( ( 1, 0, 0, -x ),
        ( 0, 1, 0, -y ),
        ( 0, 0, 1, -z ),
        ( 0, 0, 0,  1 ) ) )

scaleM (x, y, z)
  = ( matrix
      ( (   x',    0,    0, 0 ),
        (    0,   y',    0, 0 ),
        (    0,    0,   z', 0 ),
        (    0,    0,    0, 1 ) ),
      matrix
      ( ( 1/x',    0,    0, 0 ),
        (    0, 1/y',    0, 0 ),
        (    0,    0, 1/z', 0 ),
        (    0,    0,    0, 1 ) ) )
  where x' = nonZero x
        y' = nonZero y
        z' = nonZero z

rotxM t
  = ( matrix
      ( (      1,      0,      0, 0 ),
        (      0,  cos t, -sin t, 0 ),
        (      0,  sin t,  cos t, 0 ),
        (      0,      0,      0, 1 ) ),
      matrix
      ( (      1,      0,      0, 0 ),
        (      0,  cos t,  sin t, 0 ),
        (      0, -sin t,  cos t, 0 ),
        (      0,      0,      0, 1 ) ) )

rotyM t
  = ( matrix
      ( (  cos t,      0,  sin t, 0 ),
        (      0,      1,      0, 0 ),
        ( -sin t,      0,  cos t, 0 ),
        (      0,      0,      0, 1 ) ),
      matrix
      ( (  cos t,      0, -sin t, 0 ),
        (      0,      1,      0, 0 ),
        (  sin t,      0,  cos t, 0 ),
        (      0,      0,      0, 1 ) ) )

rotzM t
  = ( matrix
      ( (  cos t, -sin t,      0, 0 ),
        (  sin t,  cos t,      0, 0 ),
        (      0,      0,      1, 0 ),
        (      0,      0,      0, 1 ) ),
      matrix
      ( (  cos t,  sin t,      0, 0 ),
        ( -sin t,  cos t,      0, 0 ),
        (      0,      0,      1, 0 ),
        (      0,      0,      0, 1 ) ) )

-------------------
-- Eye transformations

-- These are used to specify placement of the eye.
-- `eye' starts out at (0, 0, -1).
-- These are implemented as inverse transforms of the model.
-------------------

eye                                     :: Transform
translateEye                            :: Coords -> Transform -> Transform
rotateEyeX, rotateEyeY, rotateEyeZ      :: Radian -> Transform -> Transform

eye = (unit, unit)
translateEye xyz (eye1, eye2)
  = (multMM m1 eye1, multMM eye2 m2)
  where (m1, m2) = transM xyz
rotateEyeX t (eye1, eye2)
  = (multMM m1 eye1, multMM eye2 m2)
  where (m1, m2) = rotxM t
rotateEyeY t (eye1, eye2)
  = (multMM m1 eye1, multMM eye2 m2)
  where (m1, m2) = rotyM t
rotateEyeZ t (eye1, eye2)
  = (multMM m1 eye1, multMM eye2 m2)
  where (m1, m2) = rotzM t

-------------------
-- Bounding boxes
-------------------

mergeBox (B x11  x12  y11  y12  z11  z12) (B x21  x22  y21  y22  z21  z22) =
    B (x11 `min` x21) (x12 `max` x22)
      (y11 `min` y21) (y12 `max` y22)
      (z11 `min` z21) (z12 `max` z22)

transformBox t (B x1  x2  y1  y2  z1  z2)
  = (B (foldr1 min (map xCoord pts'))
       (foldr1 max (map xCoord pts'))
       (foldr1 min (map yCoord pts'))
       (foldr1 max (map yCoord pts'))
       (foldr1 min (map zCoord pts'))
       (foldr1 max (map zCoord pts')))
  where pts' = map (multMP t) pts
        pts =  [point x1 y1 z1,
                point x1 y1 z2,
                point x1 y2 z1,
                point x1 y2 z2,
                point x2 y1 z1,
                point x2 y1 z2,
                point x2 y2 z1,
                point x2 y2 z2]


-- Copyright (c) 2000 Galois Connections, Inc.
-- All rights reserved.  This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.

module CSG(module Construct,
           module Geometry,
           module Intersections,
           module Interval,
           module Misc) where

import Construct
import Geometry
import Intersections
import Interval
import Misc


-- Copyright (c) 2000 Galois Connections, Inc.
-- All rights reserved.  This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.

module Data where

import Data.Array

import CSG
import Geometry
import Illumination
import Primitives
import Surface

import Debug.Trace

-- Now the parsed (expression) language

type Name = String

type Code = [GMLToken]

data GMLToken
    -- All these can occur in parsed code
        = TOp     GMLOp
        | TId     Name
        | TBind   Name
        | TBool   Bool
        | TInt    Int
        | TReal   Double
        | TString String
        | TBody   Code
        | TArray  Code
        | TApply
        | TIf
         -- These can occur in optimized/transformed code
         -- NONE (yet!)

instance Show GMLToken where
   showsPrec p (TOp op)     = shows op
   showsPrec p (TId id)     = showString id
   showsPrec p (TBind id)   = showString ('/' : id)
   showsPrec p (TBool bool) = shows bool
   showsPrec p (TInt i)     = shows i
   showsPrec p (TReal d)    = shows d
   showsPrec p (TString s)  = shows s
   showsPrec p (TBody code) = shows code
   showsPrec p (TArray code) = showString "[ "
                            . foldr (\ a b -> a . showChar ' ' . b) id (map shows code)
                            . showString "]"
   showsPrec p (TApply)     = showString "apply"
   showsPrec p (TIf)        = showString "if"

   showList  code = showString "{ "
                  . foldr (\ a b -> a . showChar ' ' . b) id (map shows code)
                  . showString "}"

-- Now the value language, used inside the interpreter

type Stack = [GMLValue]

data GMLValue
        = VBool    !Bool
        | VInt     !Int
        | VReal    !Double
        | VString  String
        | VClosure Env Code
        | VArray   (Array Int GMLValue)         -- FIXME: Haskell array
        -- uses the interpreter version of point
        | VPoint   { xPoint :: !Double
                   , yPoint :: !Double
                   , zPoint :: !Double
                   }
        -- these are abstract to the interpreter
        | VObject  Object
        | VLight   Light
        -- This is an abstract object, used by the abstract interpreter
        | VAbsObj  AbsObj

-- There are only *3* basic abstract values,
-- and the combinators also.

data AbsObj
    = AbsFACE
    | AbsU
    | AbsV
      deriving (Show)

instance Show GMLValue where
   showsPrec p value = showString (showStkEle value)

showStkEle :: GMLValue -> String
showStkEle (VBool b)      = show b ++ " :: Bool"
showStkEle (VInt i)       = show i ++ " :: Int"
showStkEle (VReal r)      = show r ++ " :: Real"
showStkEle (VString s)    = show s ++ " :: String"
showStkEle (VClosure {})  = "<closure> :: Closure"
showStkEle (VArray arr)
     = "<array (" ++  show (succ (snd (bounds arr))) ++ " elements)> :: Array"
showStkEle (VPoint x y z) = "(" ++ show x
                         ++ "," ++ show y
                         ++ "," ++ show z
                         ++ ") :: Point"
showStkEle (VObject {})   = "<Object> :: Object"
showStkEle (VLight {})    = "<Light> :: Object"
showStkEle (VAbsObj vobs) = "{{ " ++ show vobs ++ "}} :: AbsObj"

-- An abstract environment

newtype Env = Env [(Name, GMLValue)] deriving Show

emptyEnv :: Env
emptyEnv = Env []

extendEnv :: Env -> Name -> GMLValue -> Env
extendEnv (Env e) n v = Env ((n, v):e)

lookupEnv :: Env -> Name -> Maybe GMLValue
lookupEnv (Env e) n = lookup n e

-- All primitive operators
--
-- There is no Op_apply, Op_false, Op_true and Op_if
-- (because they appear explicitly in the rules).

data GMLOp
   = Op_acos
   | Op_addi
   | Op_addf
   | Op_asin
   | Op_clampf
   | Op_cone
   | Op_cos
   | Op_cube
   | Op_cylinder
   | Op_difference
   | Op_divi
   | Op_divf
   | Op_eqi
   | Op_eqf
   | Op_floor
   | Op_frac
   | Op_get
   | Op_getx
   | Op_gety
   | Op_getz
   | Op_intersect
   | Op_length
   | Op_lessi
   | Op_lessf
   | Op_light
   | Op_modi
   | Op_muli
   | Op_mulf
   | Op_negi
   | Op_negf
   | Op_plane
   | Op_point
   | Op_pointlight
   | Op_real
   | Op_render
   | Op_rotatex
   | Op_rotatey
   | Op_rotatez
   | Op_scale
   | Op_sin
   | Op_sphere
   | Op_spotlight
   | Op_sqrt
   | Op_subi
   | Op_subf
   | Op_trace       -- non standard, for debugging GML programs
   | Op_translate
   | Op_union
   | Op_uscale
    deriving (Eq,Ord,Ix,Bounded)

instance Show GMLOp where
   showsPrec _ op = showString (opNameTable ! op)

------------------------------------------------------------------------------

-- And how we use the op codes (there names, there interface)

-- These keywords include, "apply", "if", "true" and "false",
-- they are not parsed as operators, but are
-- captured by the parser as a special case.

keyWords :: [String]
keyWords = [ kwd | (kwd,_,_) <- opcodes ]

-- Lookup has to look from the start (or else...)
opTable :: [(Name,GMLToken)]
opTable = [ (kwd,op) | (kwd,op,_) <- opcodes ]

opNameTable :: Array GMLOp Name
opNameTable = array (minBound,maxBound)
                  [ (op,name) | (name,TOp op,_) <- opcodes ]

undef = error "undefined function"
image = error "undefined function: talk to image group"

-- typically, its best to have *one* opcode table,
-- so that mis-alignments do not happen.

opcodes :: [(String,GMLToken,PrimOp)]
opcodes =
 [ ("apply",      TApply,               error "incorrect use of apply")
 , ("if",         TIf,                  error "incorrect use of if")
 , ("false",      TBool False,          error "incorrect use of false")
 , ("true",       TBool True,           error "incorrect use of true")
 ] ++ map (\ (a,b,c) -> (a,TOp b,c))
   -- These are just invocation, any coercions need to occur between here
   -- and before arriving at the application code (like deg -> rad).
 [ ("acos",       Op_acos,       Real_Real (rad2deg . acos))
 , ("addi",       Op_addi,       Int_Int_Int (+))
 , ("addf",       Op_addf,       Real_Real_Real (+))
 , ("asin",       Op_asin,       Real_Real (rad2deg . asin))
 , ("clampf",     Op_clampf,     Real_Real clampf)
 , ("cone",       Op_cone,       Surface_Obj cone)
 , ("cos",        Op_cos,        Real_Real (cos . deg2rad))
 , ("cube",       Op_cube,       Surface_Obj cube)
 , ("cylinder",   Op_cylinder,   Surface_Obj cylinder)
 , ("difference", Op_difference, Obj_Obj_Obj difference)
 , ("divi",       Op_divi,       Int_Int_Int (ourQuot))
 , ("divf",       Op_divf,       Real_Real_Real (/))
 , ("eqi",        Op_eqi,        Int_Int_Bool (==))
 , ("eqf",        Op_eqf,        Real_Real_Bool (==))
 , ("floor",      Op_floor,      Real_Int floor)
 , ("frac",       Op_frac,       Real_Real (snd . properFraction))
 , ("get",        Op_get,        Arr_Int_Value ixGet)
 , ("getx",       Op_getx,       Point_Real (\ x y z -> x))
 , ("gety",       Op_gety,       Point_Real (\ x y z -> y))
 , ("getz",       Op_getz,       Point_Real (\ x y z -> z))
 , ("intersect",  Op_intersect,  Obj_Obj_Obj intersect)
 , ("length",     Op_length,     Arr_Int (succ . snd . bounds))
 , ("lessi",      Op_lessi,      Int_Int_Bool (<))
 , ("lessf",      Op_lessf,      Real_Real_Bool (<))
 , ("light",      Op_light,      Point_Color_Light light)
 , ("modi",       Op_modi,       Int_Int_Int (ourRem))
 , ("muli",       Op_muli,       Int_Int_Int (*))
 , ("mulf",       Op_mulf,       Real_Real_Real (*))
 , ("negi",       Op_negi,       Int_Int negate)
 , ("negf",       Op_negf,       Real_Real negate)
 , ("plane",      Op_plane,      Surface_Obj plane)
 , ("point",      Op_point,      Real_Real_Real_Point VPoint)
 , ("pointlight", Op_pointlight, Point_Color_Light pointlight)
 , ("real",       Op_real,       Int_Real fromIntegral)
 , ("render",     Op_render,     Render $ render eye)
 , ("rotatex",    Op_rotatex,    Obj_Real_Obj (\ o d -> rotateX (deg2rad d) o))
 , ("rotatey",    Op_rotatey,    Obj_Real_Obj (\ o d -> rotateY (deg2rad d) o))
 , ("rotatez",    Op_rotatez,    Obj_Real_Obj (\ o d -> rotateZ (deg2rad d) o))
 , ("scale",      Op_scale,      Obj_Real_Real_Real_Obj (\ o x y z -> scale (x,y,z) o))
 , ("sin",        Op_sin,        Real_Real (sin . deg2rad))
 , ("sphere",     Op_sphere,     Surface_Obj sphere') -- see comment at end of file
 , ("spotlight",  Op_spotlight,  Point_Point_Color_Real_Real_Light mySpotlight)
 , ("sqrt",       Op_sqrt,       Real_Real ourSqrt)
 , ("subi",       Op_subi,       Int_Int_Int (-))
 , ("subf",       Op_subf,       Real_Real_Real (-))
 , ("trace",      Op_trace,      Value_String_Value mytrace)
 , ("translate",  Op_translate,  Obj_Real_Real_Real_Obj (\ o x y z -> translate (x,y,z) o))
 , ("union",      Op_union,      Obj_Obj_Obj union)
 , ("uscale",     Op_uscale,     Obj_Real_Obj (\ o r -> uscale r o))
 ]

-- This enumerate all possible ways of calling the fixed primitives

-- The datatype captures the type at the *interp* level,
-- the type of the functional is mirrored on this (using Haskell types).

data PrimOp

    -- 1 argument
    = Int_Int         (Int -> Int)
    | Real_Real       (Double -> Double)
    | Point_Real      (Double -> Double -> Double -> Double)
    | Surface_Obj     (SurfaceFn Color Double -> Object)
    | Real_Int        (Double -> Int)
    | Int_Real        (Int -> Double)
    | Arr_Int         (Array Int GMLValue -> Int)

    -- 2 arguments
    | Int_Int_Int     (Int -> Int -> Int)
    | Int_Int_Bool    (Int -> Int -> Bool)
    | Real_Real_Real  (Double -> Double -> Double)
    | Real_Real_Bool  (Double -> Double -> Bool)
    | Arr_Int_Value   (Array Int GMLValue -> Int -> GMLValue)

    -- Many arguments, typically image mangling

    | Obj_Obj_Obj            (Object -> Object -> Object)
    | Point_Color_Light      (Coords -> Color -> Light)
    | Real_Real_Real_Point   (Double -> Double -> Double -> GMLValue)
    | Obj_Real_Obj           (Object -> Double -> Object)
    | Obj_Real_Real_Real_Obj (Object -> Double -> Double -> Double -> Object)
    | Value_String_Value     (GMLValue -> String -> GMLValue)

    | Point_Point_Color_Real_Real_Light
                             (Coords -> Coords -> Color -> Radian -> Radian -> Light)
    -- And finally render
    | Render                 (Color -> [Light] -> Object -> Int -> Double -> Int -> Int -> String -> IO ())

data Type
    = TyBool
    | TyInt
    | TyReal
    | TyString
    | TyCode
    | TyArray
    | TyPoint
    | TyObject
    | TyLight
    | TyAlpha
    | TyAbsObj
      deriving (Eq,Ord,Ix,Bounded)

typeTable =
  [ ( TyBool,   "Bool")
  , ( TyInt,    "Int")
  , ( TyReal,   "Real")
  , ( TyString, "String")
  , ( TyCode,   "Code")
  , ( TyArray,  "Array")
  , ( TyPoint,  "Point")
  , ( TyObject, "Object")
  , ( TyLight,  "Light")
  , ( TyAlpha,  "<anything>")
  , ( TyAbsObj, "<abs>")
  ]

typeNames = array (minBound,maxBound) typeTable

instance Show Type where
   showsPrec _ op = showString (typeNames ! op)

getPrimOpType :: PrimOp -> [Type]
getPrimOpType (Int_Int         _) = [TyInt]
getPrimOpType (Real_Real       _) = [TyReal]
getPrimOpType (Point_Real      _) = [TyPoint]
getPrimOpType (Surface_Obj     _) = [TyCode]
getPrimOpType (Real_Int        _) = [TyReal]
getPrimOpType (Int_Real        _) = [TyInt]
getPrimOpType (Arr_Int         _) = [TyArray]
getPrimOpType (Int_Int_Int     _) = [TyInt,TyInt]
getPrimOpType (Int_Int_Bool    _) = [TyInt,TyInt]
getPrimOpType (Real_Real_Real  _) = [TyReal,TyReal]
getPrimOpType (Real_Real_Bool  _) = [TyReal,TyReal]
getPrimOpType (Arr_Int_Value   _) = [TyArray,TyInt]
getPrimOpType (Obj_Obj_Obj            _) = [TyObject,TyObject]
getPrimOpType (Point_Color_Light      _) = [TyPoint,TyPoint]
getPrimOpType (Real_Real_Real_Point   _) = [TyReal,TyReal,TyReal]
getPrimOpType (Obj_Real_Obj           _) = [TyObject,TyReal]
getPrimOpType (Obj_Real_Real_Real_Obj _) = [TyObject,TyReal,TyReal,TyReal]
getPrimOpType (Value_String_Value     _) = [TyAlpha,TyString]
getPrimOpType (Point_Point_Color_Real_Real_Light _)
                                         = [TyPoint,TyPoint,TyPoint,TyReal,TyReal]
getPrimOpType (Render                 _) = [TyPoint,
                                            TyLight,
                                            TyObject,
                                            TyInt,
                                            TyReal,
                                            TyReal,
                                            TyReal,
                                            TyString]

-- Some primitives with better error message

mytrace v s = trace (s ++" : "++ show v ++ "\n") v

ixGet :: Array Int GMLValue -> Int -> GMLValue
ixGet arr i
   | inRange (bounds arr) i = arr ! i
   | otherwise = error ("failed access with index value "
                     ++ show i
                     ++ " (should be between 0 and "
                     ++ show (snd (bounds arr)) ++ ")")

ourQuot :: Int -> Int -> Int
ourQuot _ 0 = error "attempt to use divi to divide by 0"
ourQuot a b = a `quot` b

ourRem :: Int -> Int -> Int
ourRem _ 0 = error "attempt to use remi to divide by 0"
ourRem a b = a `rem` b

ourSqrt :: Double -> Double
ourSqrt n | n < 0     = error "attempt to use sqrt on a negative number"
          | otherwise = sqrt n

mySpotlight p1 p2 col cutoff exp = spotlight p1 p2 col (deg2rad cutoff) exp

-- The problem specification gets the mapping for spheres backwards
-- (it maps the image from right to left).
-- We've fixed that in the raytracing library so that it goes from left
-- to right, but to keep the GML front compatible with the problem
-- statement, we reverse it here.

sphere' :: SurfaceFn Color Double -> CSG (SurfaceFn Color Double)
sphere' (SFun f) = sphere (SFun (\i u v -> f i (1 - u) v))
sphere' s = sphere s


-- Copyright (c) 2000 Galois Connections, Inc.
-- All rights reserved.  This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.

module Eval where

import Control.Monad
import Data.Array

import Geometry
import CSG
import Surface
import Data
import Parse (rayParse, rayParseF)

class Monad m => MonadEval m where
  doOp :: PrimOp -> GMLOp -> Stack -> m Stack
  tick :: m ()
  err  :: String -> m a

  tick = return ()

newtype Pure a = Pure a deriving Show

instance Functor Pure where
    fmap = liftM

instance Applicative Pure where
    pure = Pure
    (<*>) = ap

instance Monad Pure where
    Pure x >>= k = k x
    return       = pure
    fail s       = error s

instance MonadEval Pure where
  doOp   = doPureOp
  err  s = error s

instance MonadEval IO where
  doOp prim op stk = do { -- putStrLn ("Calling " ++ show op
                          --           ++ " << " ++ show stk ++ " >>")
                          doAllOp  prim op stk
                        }
  err  s = error s

data State
        = State { env   :: Env
                , stack :: Stack
                , code  :: Code
                } deriving Show

callback :: Env -> Code -> Stack -> Stack
callback env code stk
      = case eval (State { env = env, stack = stk, code = code}) of
             Pure stk -> stk

{-# SPECIALIZE eval ::  State -> Pure Stack #-}
{-# SPECIALIZE eval ::  State -> IO Stack #-}

eval :: MonadEval m => State -> m Stack
eval st =
  do { () <- return () -- $ unsafePerformIO (print st)   -- Functional debugger
     ; if moreCode st then
       do { tick             -- tick first, so as to catch loops on new eval.
            ; st' <- step st
            ; eval st'
            }
        else return (stack st)
     }

moreCode :: State -> Bool
moreCode (State {code = []}) = False
moreCode _                   = True

-- Step has a precondition that there *is* code to run
{-# SPECIALIZE step ::  State -> Pure State #-}
{-# SPECIALIZE step ::  State -> IO State #-}
step :: MonadEval m => State -> m State

-- Rule 1: Pushing BaseValues
step st@(State{ stack = stack, code = (TBool b):cs })
    = return (st { stack = (VBool b):stack,    code = cs })
step st@(State{ stack = stack, code = (TInt i):cs })
    = return (st { stack = (VInt i):stack,     code = cs })
step st@(State{ stack = stack, code = (TReal r):cs })
    = return (st { stack = (VReal r):stack,    code = cs })
step st@(State{ stack = stack, code = (TString s):cs })
    = return (st { stack = (VString s):stack,  code = cs })

-- Rule 2: Name binding
step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) =
  return (State { env = extendEnv env id v, stack = stack,  code = cs })
step st@(State{ env = env, stack = [], code = (TBind id):cs }) =
  err "Attempt to bind the top of an empty stack"

-- Rule 3: Name lookup
step st@(State{ env = env, stack = stack, code = (TId id):cs }) =
  case (lookupEnv env id) of
  Just v -> return (st { stack = v:stack,  code = cs })
  Nothing -> err ("Cannot find value for identifier: " ++ id)

-- Rule 4: Closure creation
step st@(State{ env = env, stack = stack, code = (TBody body):cs }) =
  return (st { stack = (VClosure env body):stack, code = cs })

-- Rule 5: Application
step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) =
  do { stk <- eval (State {env = env', stack = stack, code = code'})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = [], code = TApply:cs }) =
  err "Application with an empty stack"
step st@(State{ env = env, stack = _:_, code = TApply:cs }) =
  err "Application of a non-closure"

-- Rule 6: Arrays
step st@(State{ env = env, stack = stack, code = TArray code':cs }) =
  do { stk <- eval (State {env = env, stack = [], code = code'})
     ; let last = length stk-1
     ; let arr = array (0,last) (zip [last,last-1..] stk)
     ; return (st { stack = (VArray arr):stack, code = cs })
     }

-- Rule 7 & 8: If statement
step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) =
  do { stk <- eval (State {env = e1, stack = stack, code = c1})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) =
  do { stk <- eval (State {env = e2, stack = stack, code = c2})
     ; return (st { stack = stk, code = cs })
     }
step st@(State{ env = env, stack = _, code = TIf:cs }) =
  err "Incorrect use of if (bad and/or inappropriate values on the stack)"

-- Rule 9: Operators
step st@(State{ env = env, stack = stack, code = (TOp op):cs }) =
  do { stk <- doOp (opFnTable ! op) op stack
     ; return (st { stack = stk, code = cs })
     }

-- Rule Opps
step _ = err "Tripped on sidewalk while stepping."

--------------------------------------------------------------------------
-- Operator code

opFnTable :: Array GMLOp PrimOp
opFnTable = array (minBound,maxBound)
                  [ (op,prim) | (_,TOp op,prim) <- opcodes ]

doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack
doPureOp _ Op_render _ =
    err ("\nAttempting to call render from inside a purely functional callback.")
doPureOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators

{-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Pure Stack #-}
{-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> IO Stack #-}
{-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Abs Stack #-}

doPrimOp ::  (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack

-- 1 argument.

doPrimOp (Int_Int fn) _ (VInt i1:stk)
  = return ((VInt (fn i1)) : stk)
doPrimOp (Real_Real fn) _ (VReal r1:stk)
  = return ((VReal (fn r1)) : stk)
doPrimOp (Point_Real fn) _ (VPoint x y z:stk)
  = return ((VReal (fn x y z)) : stk)

-- This is where the callbacks happen from...
doPrimOp (Surface_Obj fn) _ (VClosure env code:stk)
  = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of
      Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] ->
           let
               res = prop (color c1 c2 c3) r1 r2 r3
           in
               return ((VObject (fn (SConst res))) : stk)
      _ -> return ((VObject (fn (SFun call))) : stk)
  where
        -- The most general case
        call i r1 r2 =
          case callback env code [VReal r2,VReal r1,VInt i] of
             [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3]
                 -> prop (color c1 c2 c3) r1 r2 r3
             stk -> error ("callback failed: incorrectly typed return arguments"
                         ++ show stk)

doPrimOp (Real_Int fn) _ (VReal r1:stk)
  = return ((VInt (fn r1)) : stk)
doPrimOp (Int_Real fn) _ (VInt r1:stk)
  = return ((VReal (fn r1)) : stk)
doPrimOp (Arr_Int fn) _ (VArray arr:stk)
  = return ((VInt (fn arr)) : stk)

-- 2 arguments.

doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk)
  = return ((VInt (fn i1 i2)) : stk)
doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk)
  = return ((VBool (fn i1 i2)) : stk)
doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk)
  = return ((VReal (fn r1 r2)) : stk)
doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk)
  = return ((VBool (fn r1 r2)) : stk)
doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk)
  = return ((fn arr i) : stk)

    -- Many arguments, typically image mangling

doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk)
  = return ((VObject (fn o1 o2)) : stk)
doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk)
  = return (VLight (fn (x,y,z) (color r g b)) : stk)
doPrimOp (Point_Point_Color_Real_Real_Light fn) _
         (VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk)
  = return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk)
doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk)
  = return ((fn r1 r2 r3) : stk)
doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk)
  = return (VObject (fn o r) : stk)
doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk)
  = return (VObject (fn o r1 r2 r3) : stk)

-- This one is our testing harness
doPrimOp (Value_String_Value fn) _ (VString s:o:stk)
  = res `seq` return (res : stk)
  where
     res = fn o s

doPrimOp primOp op args
  = err ("\n\ntype error when attempting to execute builtin primitive \"" ++
          show op ++ "\"\n\n| " ++
          show op ++ " takes " ++ show (length types) ++ " argument" ++ s
                   ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++
          "      " ++ unwords [ show ty | ty <- types ]  ++ "\n|\n|" ++
          " currently, the relevant argument" ++ s ++ " on the stack " ++
                  are ++ "\n|\n| " ++
          unwords [ "(" ++ show arg ++ ")"
                  | arg <-  reverse (take (length types) args) ]  ++ "\n|\n| "
          ++ "    (top of stack is on the right hand side)\n\n")
  where
      len   = length types
      s =  (if len /= 1 then "s" else "")
      are =  (if len /= 1 then "are" else "is")
      the =  (if len /= 1 then "" else " the")
      types = getPrimOpType primOp

-- Render is somewhat funny, because it can only get called at top level.
-- All other operations are purely functional.

doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack
doAllOp (Render render) Op_render
                           (VString str:VInt ht:VInt wid:VReal fov
                           :VInt dep:VObject obj:VArray arr
                           :VPoint r g b : stk)
  = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str
       ; return stk
       }
  where
      lights = [ light | (VLight light) <- elems arr ]

doAllOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators

------------------------------------------------------------------------------
{-
 - Abstract evaluation.
 -
 - The idea is you check for constant code that
 - (1) does not look at its arguments
 - (2) gives a fixed result
 -
 - We run for 100 steps.
 -
 -}

absapply :: Env -> Code -> Stack -> Maybe Stack
absapply env code stk =
     case runAbs (eval (State env stk code)) 100 of
       AbsState stk _ -> Just stk
       AbsFail m      -> Nothing

newtype Abs a   = Abs { runAbs :: Int -> AbsState a }
data AbsState a = AbsState a !Int
                | AbsFail String

instance Functor Abs where
    fmap = liftM

instance Applicative Abs where
    pure x = Abs (\ n -> AbsState x n)
    (<*>) = ap

instance Monad Abs where
    (Abs fn) >>= k = Abs (\ s -> case fn s of
                                   AbsState r s' -> runAbs (k r) s'
                                   AbsFail m     -> AbsFail m)
    return       = pure
    fail s       = Abs (\ n -> AbsFail s)

instance MonadEval Abs where
  doOp = doAbsOp
  err  = fail
  tick = Abs (\ n -> if n <= 0
                     then AbsFail "run out of time"
                     else AbsState () (n-1))

doAbsOp :: PrimOp -> GMLOp -> Stack -> Abs Stack
doAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk)
               = return ((VPoint r1 r2 r3) : stk)
 -- here, you could have an (AbsPoint :: AbsObj) which you put on the
 -- stack, with any object in the three fields.
doAbsOp _ op _ = err ("operator not understood (" ++ show op ++ ")")

------------------------------------------------------------------------------
-- Driver

mainEval :: Code -> IO ()
mainEval prog = do { stk <- eval (State emptyEnv [] prog)
                   ; return ()
                   }
{-
  * Oops, one of the example actually has something
  * on the stack at the end.
  * Oh well...
                   ; if null stk
                     then return ()
                     else do { putStrLn done
                             ; print stk
                             }
-}

done = "Items still on stack at (successful) termination of program"

------------------------------------------------------------------------------
-- testing

test :: String -> Pure Stack
test is = eval (State emptyEnv [] (rayParse is))

testF :: String -> IO Stack
testF is = do prog <- rayParseF is
              eval (State emptyEnv [] prog)

testA :: String -> Either String (Stack,Int)
testA is = case runAbs (eval (State emptyEnv
                                    [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV]
                                    (rayParse is))) 100 of
             AbsState a n -> Right (a,n)
             AbsFail m -> Left m

abstest1 = "1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply"

-- should be [3:: Int]
et1 = test "1 /x { x } /f 2 /x f apply x addi"


-- Copyright (c) 2000 Galois Connections, Inc.
-- All rights reserved.  This software is distributed as
-- free software under the license in the file "LICENSE",
-- which is included in the distribution.

module Geometry
    ( Coords
    , Ray
    , Point  -- abstract
    , Vector -- abstract
    , Matrix -- abstract
    , Color  -- abstract
    , Box(..)
    , Radian
    , matrix
    , coord
    , color
    , uncolor
    , xCoord , yCoord , zCoord
    , xComponent , yComponent , zComponent
    , point
    , vector
    , nearV
    , point_to_vector
    , vector_to_point
    , dot
    , cross
    , tangents
    , addVV
    , addPV
    , subVV
    , negV
    , subPP
    , norm
    , normalize
    , dist2
    , sq
    , distFrom0Sq
    , distFrom0
    , multSV
    , multMM
    , transposeM
    , multMV
    , multMP
    , multMQ
    , multMR
    , white
    , black
    , addCC
    , subCC
    , sumCC
    , multCC
    , multSC
    , nearC
    , offsetToPoint
    , epsilon
    , inf
    , nonZero
    , eqEps
    , near
    , clampf
    ) where

type Coords = (Double,Double,Double)

type Ray = (Point,Vector)    -- origin of ray, and unit vector giving direction

data Point  = P !Double !Double !Double -- implicit extra arg of 1
    deriving (Show)
data Vector = V !Double !Double !Double -- implicit extra arg of 0
    deriving (Show, Eq)
data Matrix = M !Quad   !Quad   !Quad   !Quad
    deriving (Show)

data Color  = C !Double !Double !Double
    deriving (Show, Eq)

data Box = B !Double !Double !Double !Double !Double !Double
    deriving (Show)

data Quad   = Q !Double !Double !Double !Double
    deriving (Show)

type Radian = Double

type Tup4 a = (a,a,a,a)

--{-# INLINE matrix #-}
matrix :: Tup4 (Tup4 Double) -> Matrix
matrix ((m11, m12, m13, m14),
          (m21, m22, m23, m24),
          (m31, m32, m33, m34),
          (m41, m42, m43, m44))
  = M (Q m11 m12 m13 m14)
      (Q m21 m22 m23 m24)
      (Q m31 m32 m33 m34)
      (Q m41 m42 m43 m44)

coord x y z = (x, y, z)

color r g b = C r g b

uncolor (C r g b) = (r,g,b)

{-# INLINE xCoord #-}
xCoord (P x y z) = x
{-# INLINE yCoord #-}
yCoord (P x y z) = y
{-# INLINE zCoord #-}
zCoord (P x y z) = z

{-# INLINE xComponent #-}
xComponent (V x y z) = x
{-# INLINE yComponent #-}
yComponent (V x y z) = y
{-# INLINE zComponent #-}
zComponent (V x y z) = z

point :: Double -> Double -> Double -> Point
point x y z = P x y z

vector :: Double -> Double -> Double -> Vector
vector x y z = V x y z

nearV :: Vector -> Vector -> Bool
nearV (V a b c) (V d e f) = a `near` d && b `near` e && c `near` f

point_to_vector :: Point -> Vector
point_to_vector (P x y z) = V x y z

vector_to_point :: Vector -> Point
vector_to_point (V x y z)  = P x y z

{-# INLINE vector_to_quad #-}
vector_to_quad :: Vector -> Quad
vector_to_quad (V x y z) = Q x y z 0

{-# INLINE point_to_quad #-}
point_to_quad :: Point -> Quad
point_to_quad (P x y z) = Q x y z 1

{-# INLINE quad_to_point #-}
quad_to_point :: Quad -> Point
quad_to_point (Q x y z _) = P x y z

{-# INLINE quad_to_vector #-}
quad_to_vector :: Quad -> Vector
quad_to_vector (Q x y z _) = V x y z

--{-# INLINE dot #-}
dot :: Vector -> Vector -> Double
dot (V x1 y1 z1) (V x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2

cross :: Vector -> Vector -> Vector
cross (V x1 y1 z1) (V x2 y2 z2)
  = V (y1 * z2 - z1 * y2) (z1 * x2 - x1 * z2) (x1 * y2 - y1 * x2)

-- assumption: the input vector is a normal
tangents :: Vector -> (Vector, Vector)
tangents v@(V x y z)
  = (v1, v `cross` v1)
  where v1 | x == 0    = normalize (vector 0 z (-y))
           | otherwise = normalize (vector (-y) x 0)

{-# INLINE dot4 #-}
dot4 :: Quad -> Quad -> Double
dot4 (Q x1 y1 z1 w1) (Q x2 y2 z2 w2) = x1 * x2 + y1 * y2 + z1 * z2 + w1 * w2

addVV :: Vector -> Vector -> Vector
addVV (V x1 y1 z1) (V x2 y2 z2)
    = V (x1 + x2) (y1 + y2) (z1 + z2)

addPV :: Point -> Vector -> Point
addPV (P x1 y1 z1) (V x2 y2 z2)
    = P (x1 + x2) (y1 + y2) (z1 + z2)

subVV :: Vector -> Vector -> Vector
subVV (V x1 y1 z1) (V x2 y2 z2)
    = V (x1 - x2) (y1 - y2) (z1 - z2)

negV :: Vector -> Vector
negV (V x1 y1 z1)
    = V (-x1) (-y1) (-z1)

subPP :: Point -> Point -> Vector
subPP (P x1 y1 z1) (P x2 y2 z2)
    = V (x1 - x2) (y1 - y2) (z1 - z2)

--{-# INLINE norm #-}
norm :: Vector -> Double
norm (V x y z) = sqrt (sq x + sq y + sq z)

--{-# INLINE normalize #-}
-- normalize a vector to a unit vector
normalize :: Vector -> Vector
normalize v@(V x y z)
             | norm /= 0 = multSV (1/norm) v
             | otherwise = error "normalize empty!"
    where norm = sqrt (sq x + sq y + sq z)

-- This does computes the distance *squared*
dist2 :: Point -> Point -> Double
dist2 us vs = sq x + sq y + sq z
    where
       (V x y z) = subPP us vs

{-# INLINE sq #-}
sq :: Double -> Double
sq d = d * d

{-# INLINE distFrom0Sq #-}
distFrom0Sq :: Point -> Double  -- Distance of point from origin.
distFrom0Sq (P x y z) = sq x + sq y + sq z

{-# INLINE distFrom0 #-}
distFrom0 :: Point -> Double  -- Distance of point from origin.
distFrom0 p = sqrt (distFrom0Sq p)

--{-# INLINE multSV #-}
multSV :: Double -> Vector -> Vector
multSV k (V x y z) = V (k*x) (k*y) (k*z)

--{-# INLINE multMM #-}
multMM :: Matrix -> Matrix -> Matrix
multMM m1@(M q1 q2 q3 q4) m2
     = M (multMQ m2' q1)
         (multMQ m2' q2)
         (multMQ m2' q3)
         (multMQ m2' q4)
  where
     m2' = transposeM m2

{-# INLINE transposeM #-}
transposeM :: Matrix -> Matrix
transposeM (M (Q e11  e12  e13  e14)
              (Q e21  e22  e23  e24)
              (Q e31  e32  e33  e34)
              (Q e41  e42  e43  e44)) = (M (Q e11  e21  e31  e41)
                                           (Q e12  e22  e32  e42)
                                           (Q e13  e23  e33  e43)
                                           (Q e14  e24  e34  e44))

--multMM m1 m2 = [map (dot4 row) (transpose m2) | row <- m1]

--{-# INLINE multMV #-}
multMV :: Matrix -> Vector -> Vector
multMV m v = quad_to_vector (multMQ m (vector_to_quad v))

--{-# INLINE multMP #-}
multMP :: Matrix -> Point -> Point
multMP m p = quad_to_point (multMQ m (point_to_quad p))

-- mat vec = map (dot4 vec) mat

{-# INLINE multMQ #-}
multMQ :: Matrix -> Quad -> Quad
multMQ (M q1 q2 q3 q4) q
       = Q (dot4 q q1)
           (dot4 q q2)
           (dot4 q q3)
           (dot4 q q4)

{-# INLINE multMR #-}
multMR :: Matrix -> Ray -> Ray
multMR m (r, v) = (multMP m r, multMV m v)

white :: Color
white = C 1 1 1
black :: Color
black = C 0 0 0

addCC :: Color -> Color -> Color
addCC (C a b c) (C d e f) = C (a+d) (b+e) (c+f)

subCC :: Color -> Color -> Color
subCC (C a b c) (C d e f) = C (a-d) (b-e) (c-f)

sumCC :: [Color] -> Color
sumCC = foldr addCC black

multCC :: Color -> Color -> Color
multCC (C a b c) (C d e f) = C (a*d) (b*e) (c*f)

multSC :: Double -> Color -> Color
multSC k       (C a b c) = C (a*k) (b*k) (c*k)

nearC :: Color -> Color -> Bool
nearC (C a b c) (C d e f) = a `near` d && b `near` e && c `near` f

offsetToPoint :: Ray -> Double -> Point
offsetToPoint (r,v) i = r `addPV` (i `multSV` v)

--

epsilon, inf :: Double      -- approximate zero and infinity
epsilon = 1.0e-10
inf = 1.0e20

nonZero :: Double -> Double         -- Use before a division. It makes definitions
nonZero x | x > epsilon  = x        -- more complete and I bet the errors that get
          | x < -epsilon = x        -- introduced will be undetectable if epsilon
          | otherwise    = epsilon  -- is small enough

eqEps x y = abs (x-y) < epsilon
near = eqEps

clampf :: Double -> Double
clampf p | p < 0 = 0
         | p > 1 = 1
         | True  = p