module Graphics.Formats.Collada.GenerateObjects
where

import Data.Tree
import Data.Word
import qualified Data.Vector as V
import Data.Vector (Vector)
import Graphics.Formats.Collada.ColladaTypes
import Graphics.Formats.Collada.Vector2D3D

-- 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 (V3 1 0 0) x
                   (V3 0 1 0) y
                   (V3 0 0 1) z

tranrot = [ ("tran", Translate (V3 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 (V3 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 (V3 x y z)),
                          ("rot", rot 0 0 0)]
                         [] [] []
                         [(Point "point" (RGB 1 1 1) (Attenuation 1 0 0) )]

ambientLight = SceneNode "ambientLight" NOTYPE []
                         [("tran", Translate (V3 (-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] -> V3 -> 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")]

fl = V.fromList

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

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

diffuse c str (a, COMMON asset NoParam (PhongCol cs) s) = ("color_" ++ str, COMMON asset NoParam (PhongCol (map (replaceDiff c) cs)) s)

replaceDiff c (CDiffuse _) = CDiffuse (Color c)
replaceDiff _ c = c

ambient c str (a, COMMON asset NoParam (PhongCol cs) s) = ("color_" ++ str, COMMON asset NoParam (PhongCol (map (replaceAmb c) cs)) s)

replaceAmb c (CAmbient _) = CAmbient (Color c)
replaceAmb _ c = c


getDiffuseColor ( CDiffuse  (Color c) ) = Just c
getDiffuseColor _ = Nothing

getAmbientColor ( CAmbient  (Color c) ) = Just c
getAmbientColor _ = Nothing

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" Nothing

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


lines :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry]
lines p n pi ni = [Geometry "lines"
  [LS (LinePrimitive pi -- indices to vertices
                     ni -- indices to normals
                     V.empty -- no texure
                     [blue]
         )]
 (Vertices "lines_vertices" p n)]


trifans :: Vector V3 -> Vector V3 -> Vector (Vector Int)-> Vector (Vector Int) -> [Geometry]
trifans p n pi ni = [Geometry "trifans"
  [Trf (LinePrimitive pi -- indices to vertices
                      ni -- indices to normals
                      V.empty -- no texure
                      [blue]
         )]
 (Vertices "trifans_vertices" p n)]


tristrips :: Vector V3 -> Vector V3 -> Vector (Vector Int) -> Vector (Vector Int) -> [Geometry]
tristrips p n pi ni = [Geometry "tristrips"
  [Trs (LinePrimitive pi -- indices to vertices
                      ni -- indices to normals
                      V.empty -- no texure
                      [blue]
         )]
 (Vertices "trifans_vertices" p n)]


ge :: Geometry -> SceneNode
ge (Geometry name p v) = obj name [Geometry name p v] (V3 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 -> V3 -> String -> SceneNode
tran (SceneNode _   typ layer tr                     cam contr geo light) v3 str =
     (SceneNode str typ layer [("tr", Translate v3)] 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 (\(V3 a b c) -> (V3 (a+d) b c)))) $
                                        x_line y (map (\(V3 a b c) -> (V3 a (b+d) c))) $
                                        x_line z (\(V3 a b c) -> (V3 a b (c+d)))        (V3 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 (\(V 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)]
                                  )
