{-
   Haskell Dynamics Engine, Copyright (C) 2007 Ruben Henner Zilibowitz
   All rights reserved. Email: rubenz@cse.unsw.edu.au Web: www.cse.unsw.edu.au/~rubenz
   
   This is free software; you can redistribute it and/or modify it
   under the terms of the GNU General Public License that is include with this
   package in the file LICENSE-GPL.TXT.
-}

module World(demoScenes,tenpins,bowlingBall) where

import Objects
import Matrix3x3
import Quaternions

type DemoScene = (String,[Body],[Joint],Vector RealNum,RealNum,[RGBColour])

demoScenes :: [DemoScene]
demoScenes = [rings,danglingCapsules,wall,bowling,hugeBowling,rollerCoaster,coaster2,coaster3,coaster4,rollerCoaster']

-- ground and two walls
groundPlane = makeBody plane2 1e9 (Vec 0 0 0) 1 (Vec 0 0 0) 0 True
xzPlane = makeBody (Plane (Vec (-2) 0 0) (Vec (-2) 0 1) (Vec (-2) 1 0)) 1e9 0 1 0 0 True
yzPlane = makeBody (Plane (Vec 0 (-2) 0) (Vec 1 (-2) 0) (Vec 0 (-2) 1)) 1e9 0 1 0 0 True

-- some simple geometries

sphere1 = Sphere 1
sphere2 = Sphere 0.35
plane1 = Plane (Vec 0 0 0.8) (Vec 1 0 1.2) (Vec 0 1 1)
plane2 = Plane (Vec 0 0 0) (Vec 0 1 0) (Vec 1 0 0)
sphereCappedCylinder1 = SphereCappedCylinder 0.36 2.5
sphereCappedCylinder2 = SphereCappedCylinder 0.2 1.6
thing1 = CompoundGeometry [(sphereCappedCylinder1,Quaternions.normalise (Q 1 1 0 0),0),
                           (sphereCappedCylinder1,Quaternions.normalise (Q 1 0 1 0),0),
                           (sphereCappedCylinder1,Quaternions.normalise (Q 1 0 0.2 1),Vec 0 0 1)]

-- sample world with two chained together rings
rings = ("rings",
         [makeBody sphereCappedCylinder2 1 (Vec 2 2 (y+5)) (Q 1 y 1 0) 0 0 False | y<-[0..6]] ++
         [makeBody sphereCappedCylinder2 1 (Vec 4 4 (y+5)) (Q 1 y 1 0) 0 0 False | y<-[0..7]] ++
         [groundPlane,xzPlane,yzPlane],
         [Joint_ 1 2 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 2 3 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8))),
           Joint_ 3 4 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 4 5 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8))),
           Joint_ 5 6 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 6 7 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8))),
           Joint_ 7 1 (BallSocket (Vec 0 0 0.8) (Vec 0 0 (-0.8)))] ++
          [Joint_ 8 9 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 9 10 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8))),
           Joint_ 10 11 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 11 12 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8))),
           Joint_ 12 13 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 13 14 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8))),
           Joint_ 14 15 (BallSocket (Vec 0 0 0.8) (Vec 0 0 0.8)),
           Joint_ 15 8 (BallSocket (Vec 0 0 (-0.8)) (Vec 0 0 (-0.8)))],
          let x = 9.8 / (sqrt 3) in Vec (-x) (-x) (-x),
          0.8,
          gradient)

-- sample world with capsules cahined together hanging from a point
danglingCapsules = ("dangling chain",
                    [makeBody (Sphere 0.5) 1e9 (Vec 0 0 0) 1 (Vec 0 0 0) 0 True] ++
                    [makeBody sphereCappedCylinder1 10 (Vec 2 2 (1.5*y)) (Q 1 0 0 0) 0 0 False | y <- [1..5]],
                    [Joint_ 1 2 (BallSocket (Vec 0 0 (-0.5)) (Vec 0 0 1.61))] ++ [Joint_ y (y+1) (BallSocket (Vec 0 0 (-1.61)) (Vec 0 0 1.61)) | y <- [2..5]],Vec 0 0 (-9.8),
                    0.8,
                    gradient)

-- sample world with sphere stacked up to make a wall resting on the ground
wall = ("wall",
        groundPlane :
        [makeBody (Sphere 0.5) 1 (Vec x 1 z) 1 0 0 False | x <- [(-3)..3], z <- [1..7]]
        ,[],Vec 0 0 (-9.8),0.8,gradient)

-- ten pin bowling
bowling = ("tenpin bowling",
           groundPlane : bowlingBall : (tenpins 4) ++
           [makeBody (SphereCappedCylinder pinRadius 100) 1e9 (Vec 3.5 0 pinRadius) (Q 1 1 0 0) 0 0 True,
            makeBody (SphereCappedCylinder pinRadius 100) 1e9 (Vec (-3.5) 0 pinRadius) (Q 1 1 0 0) 0 0 True],
           [],Vec 0 0 (-9.8),0.8,gradient)

--fifty five pin bowling
hugeBowling = ("fifty-five pin bowling",groundPlane : bowlingBall : (tenpins 10),[],Vec 0 0 (-9.8),0.8,gradient)

-- some constants
pinRadius = 0.36
bowlingBallRadius = 0.6
tenpins n = [makeBody (SphereCappedCylinder pinRadius 1.25) 4 (Vec (x+0.5*y-(n*0.5)) (-y*sqrt3on2) 1.2) 1 0 0 False | x <- [0..n], y <- [0..n], x+y<=n]
bowlingBall = makeBody (Objects.Sphere bowlingBallRadius) 8 (Vec (0) (-20) 0.7) 1 (Vec 0 30 0) 0 False
sqrt3on2 = 0.5 * (sqrt 3)

-- a roller coaster
rollerCoaster = ("marble track",
   [marble (Vec (-4.9) 0 2.75),marble (Vec (-1.9) 0 1.95)] ++
    (makeTrackFromFunctionInXZ (\x -> x*x*0.1) (-5) 3 0.66 0.1 0.29) ++
    (makeTrackFromFunctionInXZ (\x -> x*x*0.1 - 1) (-3) 5 0.66 0.1 0.29) ++
    (makeTrackFromFunctionInXZ (\x -> x*x*0.1 - 2) (-5) 5 0.66 0.1 0.29),
    [],Vec 0 0 (-9.8),0.2,gradient)

-- a roller coaster
rollerCoaster' = ("roller coaster damped sine wave",
   [marble (Vec 0.2 0 ((f 0.2)+0.4))] ++ (makeTrackFromFunctionInXZ f 0.1 (8*pi) 0.5 0.1 0.29),
    [],
    Vec 0 0 (-9.8),
    0.2,
    gradient)
   where f t = 2 * (sin t) / t

marble start = makeBody (Sphere 0.3) 1 start 1 0 0 False

makePiece :: Vector RealNum -> Vector RealNum -> RealNum -> Body
makePiece p1 p2 r = makeBody (SphereCappedCylinder r len) 1e9 pos (rotationFromTo (Vec 0 0 1) (p2-p1)) 0 0 True
   where
      pos = (p1 + p2) .*. 0.5
      len = Matrix3x3.magnitude (p2 - p1)

rotationFromTo :: Vector RealNum -> Vector RealNum -> Quaternion RealNum
rotationFromTo from to
   | norm (fromN-toN) < 1e-9 = 1
   | norm (fromN+toN) < 1e-9 = -1
   | otherwise = Quaternions.normalise (Q cosaon2 rx ry rz)
   where
      fromN = Matrix3x3.normalise from
      toN = Matrix3x3.normalise to
      (Vec rx ry rz) = (Matrix3x3.normalise (cross fromN toN)) .*. sinaon2
      cosa = dot toN fromN
      cosaon2 = sqrt ((1+cosa)*0.5)
      sinaon2 = sqrt ((1-cosa)*0.5)

fitPiecesToFunctionInXZ :: (RealNum -> RealNum) -> RealNum -> RealNum -> RealNum -> RealNum -> [Body]
fitPiecesToFunctionInXZ f x1 x2 dx r = [makePiece v1 v2 r | (v1,v2) <- zip vs (tail vs)]
   where vs = [Vec x 0 (f x) | x <- [x1,x1+dx..x2]]

makeTrackFromFunctionInXZ :: (RealNum -> RealNum) -> RealNum -> RealNum -> RealNum -> RealNum -> RealNum -> [Body]
makeTrackFromFunctionInXZ f x1 x2 dx r s = (map (shiftBody (Vec 0 (-s) 0)) rail) ++ (map (shiftBody (Vec 0 s 0)) rail)
   where rail = fitPiecesToFunctionInXZ f x1 x2 dx r

shiftBody :: Vector RealNum -> Body -> Body
shiftBody s body = body {position = ((position body) + s)}

-- another roller coaster
coaster2 = ("spiral marble track",
   (marble (((f1 0.1) + (f2 0.1)).*.0.5 + (Vec 0 0 0.4))) : (makeRailFromFunction f1 (0,3*pi) 0.33 0.1) ++ (makeRailFromFunction f2 (0,3*pi) 0.33 0.1),
   [],
   Vec 0 0 (-9.8),0.2,gradient)
   where f1 t = Vec (2.2*(sin t)) (2.2*(cos t)) (-0.2*t + 2)
         f2 t = Vec (1.7*(sin t)) (1.7*(cos t)) (-0.25*t + 2)

-- yet another roller coaster
coaster3 = ("crazy marble track",
   [marble (f t) | t <- [4.9,4.3..3]] ++ (makeTrackFromFunction f f' (-5,5) 0.5 0.41 0.1),
    [],
    Vec 0 0 (-9.8),
    0.4,
    gradient)
   where f t = Vec t (0.5*(sin (1.0*t))) (0.2*t^2)
         f' t = Vec 1 (0.5*(cos (1.0*t))) (0.4*t)

-- yet another roller coaster!
coaster4 = ("torus knot roller coaster",
   [marble (f 0.1),marble (f 0.35),marble (f 0.6),marble (f 0.95)] ++ (makeTrackFromFunction f f' (0,1) 0.01 0.36 0.05),
    [],
    Vec 0 0 (-9.8),
    0.4,
    gradient)
   where f = torusKnot outerRadius innerRadius m n
         f' = torusKnot' outerRadius innerRadius m n
         outerRadius = 3
         innerRadius = 2
         m = 3
         n = 2

makeTrackFromFunction ::
   (RealNum -> Vector RealNum) ->
   (RealNum -> Vector RealNum) ->
   (RealNum,RealNum) ->
   RealNum ->
   RealNum ->
   RealNum ->
   [Body]
makeTrackFromFunction f f' bounds dt s r = (makeRailFromFunction r1 bounds dt r) ++ (makeRailFromFunction r2 bounds dt r) ++ (makeRailFromFunction r3 bounds dt r)
   where
      p1 = Vec 1 0 0
      p2 = Vec (-0.5) ((sqrt 3)*0.5) 0
      p3 = Vec (-0.5) (-(sqrt 3)*0.5) 0
      rot t = rotationFromTo (Vec 0 0 1) (f' t)
      r1 t = (f t) + ((rot t) .* p1).*.s
      r2 t = (f t) + ((rot t) .* p2).*.s
      r3 t = (f t) + ((rot t) .* p3).*.s

makeRailFromFunction ::
   (RealNum -> Vector RealNum) ->
   (RealNum,RealNum) ->
   RealNum ->
   RealNum ->
   [Body]
makeRailFromFunction f (t0,t1) dt r = [makePiece v1 v2 r | (v1,v2) <- zip vs (tail vs)]
   where vs = [f t | t <- [t0,t0+dt..t1]]

-- these function give parametric equations in cartesian form for the torus family of knots as well as the first derivative.
-- One could try making a marble on track simulation with a torus knot shaped track.

torusKnot r1 r2 m n t = Vec ((r1 + r2*(cos (2*pi*n*t)))*(cos (2*pi*m*t))) ((r1 + r2*(cos (2*pi*n*t)))*(sin (2*pi*m*t))) (r2*(sin (2*pi*n*t)))

torusKnot' r1 r2 m n t = Vec ((-n-m)*pi*r2*sin((2*n+2*m)*pi*t)+(m-n)*pi*r2*sin((2*n-2*m)*pi*t)-2*m*pi*r1*sin(2*m*pi*t))
                             ((n+m)*pi*r2*cos((2*n+2*m)*pi*t)+(m-n)*pi*r2*cos((2*n-2*m)*pi*t)+2*m*pi*r1*cos(2*m*pi*t))
                             (2*n*pi*r2*cos(2*n*pi*t))

-- colours

gradient = [hsv2rgb i 1 1 | i <- [0.0,0.6789..]]

-- converts from an HSV color to an RGB color
hsv2rgb :: Float -> Float -> Float -> RGBColour
hsv2rgb h s v
   | hi == 0 = (v,t,p)
   | hi == 1 = (q,v,p)
   | hi == 2 = (p,v,t)
   | hi == 3 = (p,q,v)
   | hi == 4 = (t,p,v)
   | hi == 5 = (v,p,q)
   where
      i = floor (h / 60)
      hi = i `mod` 6
      f = h/60 - (fromIntegral i)
      p = v*(1-s)
      q = v*(1-f*s)
      t = v*(1 - (1 - f)*s)