module Graphics.Formats.Collada.GenerateObjects
where

import Data.Enumerable
import Data.Tree
import Data.Tuple.Gen
import Data.Word
import Graphics.Formats.Collada.ColladaTypes

-- type Scene = Tree SceneNode
n x = Node x []
makeScene sid sceneNodes = Node (SceneNode sid NOTYPE [] tranrot [] [] [] []) (map n sceneNodes)

-- | An animated cube
animatedCube :: (Scene, [Animation])
animatedCube = (aScene, animation)

-- | Example scene with a cube
aScene :: Scene
aScene = makeScene "aCube" (cameraAndLight ++ [aCube])

lightedGeometry :: [Geometry] -> Scene
lightedGeometry g = makeScene "g" (cameraAndLight ++ (map ge g))

lightedSceneNode :: SceneNode -> Scene
lightedSceneNode node = makeScene "node" (cameraAndLight ++ [node])

lightedScene :: Scene -> Scene
lightedScene node = Node EmptyRoot ((map n cameraAndLight) ++ [node])

-- | Every scene needs a camera and light
cameraAndLight = [ aCamera,
                   pointLight "pointLight" 3 4 10,
                   pointLight "pointL" (-500) 1000 400 ]

rot x y z = Rotate (1,0,0) x
                   (0,1,0) y
                   (0,0,1) z

tranrot = [ ("tran", Translate (0,0,0)), ("rot", rot 0 0 0) ] -- there have to be values for an animation channel to access

aCamera = SceneNode "camera0" NOTYPE []
                       [("tran", Translate (1000,2000,2500)),
                         ("rot", rot (-22) 13 0)]
                       -- [("lookat", LookAt (1000,1000,2500) (0,0,0) (0,1,0))]
                       [(Perspective "Persp" (ViewSizeXY (37,37)) (Z 10 1000) )]
                       [] [] []

pointLight str x y z = SceneNode str NOTYPE []
                         [("tran", Translate (x,y,z)),
                          ("rot", rot 0 0 0)]
                         [] [] []
                         [(Point "point" (RGB 1 1 1) (Attenuation 1 0 0) )]

ambientLight = SceneNode "ambientLight" NOTYPE []
                         [("tran", Translate ((-500),1000,400)),
                          ("rot", rot 0 0 0)]
                         [] [] []
                         [(Ambient "ambient" (RGB 1 1 1) )]

aCube :: SceneNode
aCube = SceneNode "cube_geometry" NOTYPE [] tranrot [] [] [cube] []

obj :: String -> [Geometry] -> (Float,Float,Float) -> SceneNode
obj name c tr = SceneNode name NOTYPE []
                         [("tran", Translate tr),
                          ("rot", rot 0 0 0)]
                         [] []
                         c -- geometries
                         []

-- | Example animation of the cube
animation :: [Animation]
animation = [Node ("cube_rotate", anim_channel) []]

anim_channel = AnimChannel ("input", [0, 1, 2, 3], [[("name","TIME"), ("type","Float")]] )
                           ("output",[0, 50, 100, 150], [[("name","ANGLE"), ("type","Float")]] )
                           [ Bezier [-0.333333, 0] [2.5, 0], -- intangent outtangent
                             Bezier [5,0] [7.916667, 0],
                             Bezier [8.333333, 56] [9.166667, 56],
                             Bezier [9.583333, 18.666666] [10.333333, -14.933331] ]
                           [("cube_geometry/rotateY","ANGLE")]

-- | A blue/textured cube
cube :: Geometry
cube = Geometry "cube"
       [PL (LinePrimitive
         [[0,2,3,1],[0,1,5,4],[6,7,3,2],[0,4,6,2],[3,7,5,1],[5,7,6,4]] -- indices to vertices
         [[0,0,0,0],[1,1,1,1],[2,2,2,2],[3,3,3,3],[4,4,4,4],[5,5,5,5]] -- indices to normals
         [] -- [[0,1,2,3],[0,1,2,3],[0,1,2,3],[0,1,2,3],[0,1,2,3],[0,1,2,3]] -- indices to texture coordinates, use an empty list when no texture
         -- [logo]
         [blue]
       )]
       (Vertices "cube_vertices"
         [(-10,10,10), (10,10,10), (-10,-10,10), (10,-10,10), -- vertices
          (-10,10,-10),(10,10,-10),(-10,-10,-10),(10,-10,-10)]
         [(0,0,1), (0,1,0), (0,-1,0), (-1,0,0), (1,0,0), (0,0,-1)] -- normals
       )

blue = ("blue", COMMON "" NoParam
               (PhongCol [(CEmission (Color (0,0,0,1))),
                          (CAmbient  (Color (0,0,0,1))),
                          (CDiffuse(Color (0.137255,0.403922,0.870588,1))),
                          (CSpecular(Color (0.5,0.5,0.5,1))),
                          (CShininess 16), 
                          (CReflective (Color (0,0,0,1))),
                          (CReflectivity 0.5),
                          (CTransparent (Color (0,0,0,1))),
                          (CTransparency 1),
                          (CIndex_of_refraction 0)]
               )
               ""
       )

logo = ("haskell-logo", COMMON "" NoParam
               (PhongTex [(TDiffuse tex)]
			             [[0,0,1,0,1,1,0,1]] -- [u0,v0,u1,v1,..] -coordinates (Floats between 0 and 1) that point into the texture
               )
               ""
       )

tex = Texture "logo" "Haskell-Logo-Variation.png"

polys :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
polys p n pi ni = [Geometry "polygons"
  [PL (LinePrimitive pi -- indices to vertices
                     ni -- indices to normals
                     [] -- no texure
              [blue]
         )]
 (Vertices "polygons_vertices" p n)]


lines :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
lines p n pi ni = [Geometry "lines"
  [LS (LinePrimitive pi -- indices to vertices
                     ni -- indices to normals
                     [] -- no texure
              [blue]
         )]
 (Vertices "lines_vertices" p n)]


trifans :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
trifans p n pi ni = [Geometry "trifans"
  [Trf (LinePrimitive pi -- indices to vertices
                      ni -- indices to normals
                      [] -- no texure
              [blue]
         )]
 (Vertices "trifans_vertices" p n)]


tristrips :: [(Float,Float,Float)] -> [(Float,Float,Float)] -> [[Int]] -> [[Int]] -> [Geometry]
tristrips p n pi ni = [Geometry "tristrips"
  [Trs (LinePrimitive pi -- indices to vertices
                      ni -- indices to normals
                      [] -- no texure
              [blue]
         )]
 (Vertices "trifans_vertices" p n)]


ge :: Geometry -> SceneNode
ge (Geometry name p v) = obj name [Geometry name p v] (0,0,0)
-- ------------------
-- a bigger example
-- ------------------
animatedCubes = (scene2, animation2)
animatedCubes2 = [(scene2, animation2)]

scene2 :: Scene
scene2 = Node EmptyRoot $ [ n aCamera, n (pointLight "pl" (-500) 1000 400) ] ++ (map n test_objs)

-- | Animation of several cubes
animation2 :: [Animation]
animation2 = [Node ("cube_rotate", new_channels anim_channel test_objs) []]

emptyAnimation :: [[Animation]]
emptyAnimation = []

emptyAnim :: [Animation]
emptyAnim = []

-- | generate an animation that points to the cubes
new_channels :: AnimChannel -> [SceneNode] -> AnimChannel
new_channels (AnimChannel i o interp _) nodes =
              AnimChannel i o interp $ map (\obj -> ((obj_name obj) ++ "/rotateY","ANGLE")) nodes

obj_name (SceneNode n _ _ _ _ _ _ _) = n

-- | a helper function for xyz_grid
tran :: SceneNode -> (Float,Float,Float) -> String -> SceneNode
tran (SceneNode _   typ layer tr                             cam contr geo light) (tx, ty, tz) str =
     (SceneNode str typ	layer [("tr", Translate (tx,ty,tz))] cam contr geo light)

test_objs :: [SceneNode]
test_objs = xyz_grid 10 10 10 150 aCube

-- | Generate a 3 dimensional grid where an object (stored in a SceneNode) is repeated in along the grid
xyz_grid :: Int -> Int -> Int -> Float -> SceneNode -> [SceneNode]
xyz_grid x y z d obj = zipWith (tran obj)
                       (concat (concat (x_line x (map (map (\(a,b,c) -> (a+d,b,c)))) $
                                        x_line y (map (\(a,b,c) -> (a,b+d,c))) $
                                        x_line z (\(a,b,c) -> (a,b,c+d))        (0,0,0)) ))
                       (enum_obj obj [1..(x*y*z)])

enum_obj obj (i:is) = ((obj_name obj) ++ (show i)) : (enum_obj obj is)

x_line 0 change value = []
x_line n change value = value : ( x_line (n-1) change (change value) )

-------------------------------------------------------------------
-- visualizing a stream of positions with copies of a base object
-------------------------------------------------------------------

positions = map (\(x, y, z) -> (x*100, y*100, z*100) ) $
 -- map (\(x,y,z) -> (fromIntegral x, fromIntegral y, fromIntegral z))
 en

en :: [(Float,Float,Float)] 
-- en :: [(Word8,Word8,Word8)]
-- en = take 100 enumerate
-- en = take 100 all3s

en = map (\(x,y)->(x*20,y*20,0)) []

base_objects = map (rename aCube) (map show [1..(length positions)])

rename :: SceneNode -> String -> SceneNode
rename (SceneNode str        typ layer tr cam contr geo light) s =
       (SceneNode (str ++ s) typ layer tr cam contr geo light)

getName (SceneNode str _ _ _ _ _ _ _) = str
get_name (Geometry str _ _) = str

animatedStream = (streamScene base_objects, streamAnimation positions base_objects)

streamScene :: [SceneNode] -> Scene
streamScene objects = Node EmptyRoot $ [ n aCamera,
                                         n (pointLight "pl" (-500) 1000 400) ] ++
                                         (map n $ objects)

streamAnimation :: [(Float,Float,Float)] -> [SceneNode] -> [Animation]
streamAnimation ps base_objects =
       [Node ("cube_stream", EmptyAnim) (map n $ concat $
             zipWith (\ind bo -> [tr_channel ind ((show ind) ++ "1") bo (length ps) s1 "X"] ++
                                 [tr_channel ind ((show ind) ++ "2") bo (length ps) s2 "Y"] ++
                                 [tr_channel ind ((show ind) ++ "3") bo (length ps) s3 "Z"])
            [1..(length ps)] (map getName base_objects) )
       ]
  where
    s1 = map (\(a,b,c) -> a) ps
    s2 = map (\(a,b,c) -> b) ps
    s3 = map (\(a,b,c) -> c) ps

tr_channel ind name bname lps s c = ( "anim" ++ name,
                           AnimChannel ("input", map (*0.3) (map fromIntegral [0..(lps-1)]), [[("name","TIME"), ("type","Float")]] )
                                       ("output", (take ind s) ++ (take (lps-ind) (repeat (head (drop ind s)))),
                                         [[("name",c), ("type","Float")]] )
                                       (take lps (repeat Linear))
                                       [(bname ++ "/tran",c)]
                                  )