jort-1.0.0: Scenes.hs

module Scenes where

import Basics
import Objects
import Vectors
import Camera 
import World 
import Anims
import Bitmaps
import Env
import System.IO.Unsafe
import Textures
import Colors
import Control.Applicative

-------------------
-- Colors

white = grayTint 1.0
blue = hue (-2*pi/3)
violet = hue (-pi/2)
magenta = hue (-pi/3)
red = hue 0
orange = hue (pi/6)
yellow = hue (pi/3)
green = hue (2*pi/3)
cyan = hue pi
black = rgb 0 0 0

----------------------
-- Textures
	  
mirror = const Material 
	 {diffuse = blackColor,
	  materialReflection = whiteColor,
	  materialRefraction = blackColor,
	  materialRefrCoef = 0
	 }
	     
glass = const Material 
	{diffuse = blackColor,  -- FIXME
	 materialReflection = grayTint 0.0,
	 materialRefraction = grayTint 1,
	 materialRefrCoef = 1.33
	}


ivoryChess = project stdVertical $
	     checkboard (vec 15 15 15) (matte white) (matte black)

joelChess = project stdVertical $
	    checkboard (vec 15 15 15) (matte blue) (matte yellow)


---------------------
-- Vectors

stdVertical = vec 0 1 0

origin = constVec 0

camloc = (vec 0 10 (-40))
camLook = origin 

lightloc = negate (vec 12 12 12)

cam1 = cameraLooks stdVertical camloc camLook




ellipsoid = Quadric origin (vec 0.5 0.5 0.5) (sq 7)
-- hyperboloid = Quadric origin (vec 0 1.2 0) (sq 7) 
-- hyperboloid' = Quadric origin (vec 0 1.2 0) (negate $ sq 7) 
-- cylinder = Quadric origin (vec 0 1 0) (sq 7) 


aQuad :: Anim Shape
aQuad = pure $ Quadric (vec 0 0 0) (vec 1.2 0 0) (sq 7)


aPoint1 = MetaPoint <$> (liss (pure (vec 10 10 10)) (pure (vec 1 2 3)) (pure (vec 0 0 0))) <*> pure 2
aPoint2 = MetaPoint <$> (liss (pure (vec 10 10 10)) (pure (vec 1 2 3)) (pure (vec 1 1 1))) <*> pure 2
aPoint3 = MetaPoint <$> (liss (pure (vec 10 10 10)) (pure (vec 1 2 3)) (pure (vec 2 2 2))) <*> pure 2


aM = aMeta [aPoint1, aPoint2, aPoint3] (pure 0.1)

animScene :: Anim World
animScene = world <$>
            sequ [
	     -- object <$> (Sphere <$> (orbit (const stdVertical) (pure vec 5 10 0) ) <*> pure 7) <*> pure mirror,
             -- object <$> aM <*> pure (matte blue),
             object <$> (Quadric origin <$> (orbit (pure $ vec 0 1 0) (pure $ vec 0.5 0.5 0.5)) <*> pure (sq 7)) <*> pure glass,
             -- object <$> (Quadric origin <$> (vec <$> pure 0 <*> (subtract 2 <$> ask) <*> pure 0) <*> pure (sq 7)) <*> pure (matte green),
             object <$> (Plane <$> pure (vec 0 1 0) <*> pure (-15)) <*> pure ivoryChess
            ] 
            <*> pure [DirLight (normalized (vec 0 (-3) 0)) (grayTint 0.8),
                      AmbientLight (grayTint 0.15)
                     ] 
            <*> pure env
    where orb = orbit (const stdVertical) (pure vec 15 10 0)

env = rainbowEnv 
--env = skyBitmapEnv skyBitmap



skyBitmap = unsafePerformIO $ loadBitmap "ciel.tif"