import System.IO
import Data.Char
-- ppm image file
-- P3 width height maxcolorval r g b r g b r g b ...
-- max line length: 70


type Angle = Double
type ScreenCoord = (Angle, Angle)
type Color = (Int, Int, Int)
type Coord = (Double, Double, Double)
data Sphere = Sphere Coord Double Color deriving (Show, Eq)

degrees = pi / 180

eye = (0, 0, 8)

x_of (x, _, _) = x
y_of (_, y, _) = y
z_of (_, _, z) = z

sphere1 = Sphere (80, 43, 5) 10 (55,255,0)
sphere2 = Sphere (30, 65, -5) 20 (255,60,0)

spheres = [sphere1, sphere2]


alpha1 = 120 * degrees
alpha2 = 0 * degrees

beta1 = 20 * degrees
beta2 = -20 * degrees

floorscale = 4

w = 800
h = 300

oversampling = 1 -- each pixel is 2x2 rays

black :: Color
black = (0,0,0)

ov_alphaoffset = ((alpha2 - alpha1) / (w-1)) / oversampling
ov_betaoffset  = ((beta2 - beta1) / (h-1)) / oversampling

ov_alphaoffsets = take (round oversampling) [0,ov_alphaoffset..]
ov_betaoffsets  = take (round oversampling) [0,ov_betaoffset..]

imgheader = "P3 " ++ (show w) ++ " " ++ (show h) ++ " 255\n"

alphas = take (round w) [alpha1,(alpha1 + ((alpha2 - alpha1) / (w-1)))..]
betas  = take (round h) [beta1,(beta1 + ((beta2 - beta1) / (h-1)))..]


-- spherical projection,
-- return coordinates from a given coordinate, extended by given
-- angles to some distance
spherical_proj :: Coord -> Angle -> Angle -> Double -> Coord
spherical_proj (x,y,z) alpha beta dist = (x + dist*cos alpha + dist*cos beta,
                                          y + dist*sin alpha,
                                          z + dist*sin beta)


-- intersect sphere

-- discr = 4(( A u + B v + C w )^2 - (A^2 + B^2 + C^2)(u^2 + v^2 + w^2))
-- where u = source_x - sphere_x (v and w analogous)
-- where A = cos alpha + cos beta
--       B = sin alpha
--       C = sin beta

discr :: Coord -> ScreenCoord -> Sphere -> Double
discr source (alpha, beta) (Sphere centre radius _) = 4*(( aa * u + bb * v + cc * w )^2 -
                                        (aa*aa + bb*bb + cc*cc)*(u*u + v*v + w*w - radius^2))
      where u = (x_of source) - (x_of centre)
            v = (y_of source) - (y_of centre)
            w = (z_of source) - (z_of centre)
            aa = cos alpha + cos beta
            bb = sin alpha
            cc = sin beta

-- the intersect functions return (Coord, Distance, Color)
-- distance = 0 means no intersection
intersect_sphere :: Coord -> ScreenCoord -> Sphere -> (Coord, Double, Color)
intersect_sphere source (alpha, beta) (Sphere centre radius color)
        | delta > 0 = (spherical_proj source alpha beta t, t, color)
        | otherwise = ((0,0,0), 0, black)
            where t = min ((-b - sqrt(delta)) / (2*a)) ((-b + sqrt(delta)) / (2*a))
                  delta = discr source (alpha, beta) (Sphere centre radius color)
                  a = aa^2 + bb^2 + cc^2
                  b = 2 * (aa*u + bb*v + cc*w)
                  u = (x_of source) - (x_of centre)
                  v = (y_of source) - (y_of centre)
                  w = (z_of source) - (z_of centre)
                  aa = cos alpha + cos beta
                  bb = sin alpha
                  cc = sin beta


intersect_point_floor :: Coord -> ScreenCoord -> (Coord, Double)
intersect_point_floor (_, _, z) (alpha, beta)
        | beta < 0 = (  (-z * (cos alpha) / (sin beta) - 2 * (cos beta) / (sin beta),
                         -z * (sin alpha) / (sin beta),
                         0),
                      -z / (sin beta) )
        | otherwise = ((0, 0, 0), 0)

intersect_floor :: Coord -> ScreenCoord -> (Coord, Double, Color)
intersect_floor source (alpha, beta)
        | x > (-0.5) && x < 0.5 = ((x, y, z), t, (0, attn, attn))
        | y > (-0.5) && y < 0.5 = ((x, y, z), t, (attn, attn, 0))
        | (round (x/floorscale) `mod` 2) == (round (y/floorscale) `mod` 2) = ((x, y, z), t, (attn, 0, 0))
        | otherwise              = ((x, y, z), t, (attn, attn, attn))
        where attn = max 0 (round (255 - 8*(sqrt t)))
              ((x, y, z), t) = intersect_point_floor source (alpha, beta)

-- blue is beautiful, but a green tint is nice too
skycolor :: Coord -> ScreenCoord -> Color
skycolor source (alpha, beta) = (60,
            round ((sqrt (alpha/6)) / (sqrt (90 * degrees)) * 128),
            round ((sqrt beta) / (sqrt (90 * degrees)) * 255) )

data SphereIntersect = SphereIntersect Double Color deriving (Eq, Show) -- distance color
instance Ord SphereIntersect where
  (SphereIntersect d1 _) `compare` (SphereIntersect d2 _) = d1 `compare` d2

nearest_sphere :: Coord -> ScreenCoord -> [Sphere] -> SphereIntersect
nearest_sphere source scoord spheres =
                        minimum [(SphereIntersect distance color) | (_, distance, color) <- intersections]
                        where intersections = map (intersect_sphere source scoord) spheres

-- also include floor in objects
nearest_obj :: Coord -> ScreenCoord -> [Sphere] -> (Double, Color)
nearest_obj source scoord spheres
            | spheredist > 0 = (spheredist, spherecolor)
--            | floordist > spheredist && spheredist > 0   = (spheredist, spherecolor)
            | otherwise                                  = (floordist, floorcolor)
            where   (SphereIntersect spheredist spherecolor)  = nearest_sphere source scoord spheres
                    (_, floordist, floorcolor) = intersect_floor source scoord

-- First iteration
pixel_color :: Coord -> ScreenCoord -> Color
pixel_color source scoord
            | nearest_object_dist > 0 = objcolor
            | beta > 0  = skycolor source scoord
            | beta == 0 = (0, 255, 0)
            | otherwise = (255, 0, 255)
            where   (_, beta) = scoord
                    (nearest_object_dist, objcolor) = nearest_obj source scoord spheres


--pixel_color :: Coord -> ScreenCoord -> Color
--pixel_color source (alpha, beta)
--        | intersect_sphere source (alpha, beta) sphere1 > 0 = (200, 0, 0)
--        | intersect_sphere source (alpha, beta) sphere2 > 0 = (0, 200, 0)
--        | beta > 0  = skycolor source (alpha, beta)
--        | beta == 0 = (0, 255, 0)
--        | otherwise = floorcolor source (alpha, beta)

cartProdTranspose xs ys = [(y,x) | x <- xs, y <- ys]
cartProd xs ys = [(x,y) | x <- xs, y <- ys]

pixel_to_ppm (r,g,b) = show r ++ " " ++ show g ++ " " ++ show b ++ "\n"

tuple2sum x y = (a1 + b1, a2 + b2)
               where (a1, a2) = x
                     (b1, b2) = y

-- from one pixel (alpha, beta), get a list of oversampled pixels
oversample :: ScreenCoord -> [ScreenCoord]
oversample (a,b) = map (tuple2sum (a,b)) (cartProd ov_alphaoffsets ov_betaoffsets)

tuple3sum x y = (a1 + b1, a2 + b2, a3 + b3)
               where (a1, a2, a3) = x
                     (b1, b2, b3) = y

coloraverage :: [Color] -> Color
coloraverage xs = ( round (fromIntegral s1/l),
                    round (fromIntegral s2/l),
                    round (fromIntegral s3/l) )
                    where (s1, s2, s3) = foldr tuple3sum (0,0,0) xs
                          l = fromIntegral (length xs)

-- calculate color of oversampled pixels
ov_color :: [ScreenCoord] -> Color
ov_color xs = coloraverage (map (pixel_color eye) xs)

-- list of list of (alpha, beta)-tuples
ov_pixels = map oversample (cartProdTranspose betas alphas)

allpixels = map ov_color ov_pixels

image = imgheader ++ (foldr (++) "" (map pixel_to_ppm allpixels))

main = writeFile "foo.ppm" image