---------------------------------------------------
-- Tutorium 1 und 2 zu Informatik I WS 2003/2004 --
-- Alexander Butsch und Markus Westphal          --
--                                               --
-- BouncingBalls: Vollständig elastische Stöße   --
--                von 'Kugeln' gleicher Masse    --
---------------------------------------------------

import GraphicsUtils

------------------------------------ Vektor-Funktionen ------------------------------------------

type Vector = [Double]

-- S-Multiplikation
scale :: Double -> Vector -> Vector
scale s  xs = map ((*) s) xs

-- Vektor-Summe
vSum :: Vector -> Vector -> Vector
vSum  xs ys = zipWith (+) xs ys

-- Differenz
vDiff :: Vector -> Vector -> Vector
vDiff xs ys = zipWith (-) xs ys

-- Skalarprodukt
sProd :: Vector -> Vector -> Double
sProd xs ys = foldr (+) 0 (zipWith (*) xs ys)

-- Norm eines Vektors
norm :: Vector -> Double
norm  xs = sqrt (sProd xs xs)

-- Normieren eines Vektors
normalize :: Vector -> Vector
normalize xs | vnorm == 0 = xs
             | otherwise  = scale (1/vnorm) xs
             where vnorm = (norm xs)

-- Konvertieren: Vector -> Point
v2p :: Vector -> Point
v2p (x:y:xs) = (truncate x, truncate y)



------------------------------ Positions- und Richtungsberechnung für Bälle ---------------------

type Ball = (Vector, Double, Vector, Color)


updateBalls :: [Ball] -> [Ball]
updateBalls = moveBalls . bounceBalls . bounceBallsWalls

-- Neue Positionen für alle Bälle
moveBalls :: [Ball] -> [Ball]
moveBalls  = map (\(loc, r, dir, col) -> (vSum loc dir, r, scale reibung dir, col))

reibung :: Double
reibung = 1


-- Kollisionen mit Begrenzungen (Ball mit Wand)
bounceBallsWalls :: [Ball] -> [Ball]
bounceBallsWalls = map bounceBallWalls

bounceBallWalls  :: Ball -> Ball
bounceBallWalls ([x,y], r, [vx, vy], col) = ([x',y'], r, [vx', vy'], col)
    where (x', vx') | x <= leftX + r  = (leftX + r, -vx)
                    | x >= rightX - r = (rightX - r, -vx)
                    | otherwise       = (x, vx)
          (y', vy') | y <= topY + r   = (topY + r, -vy)
                    | y >= bottomY -r = (bottomY - r, -vy)
                    | otherwise       = (y, vy)

leftX, rightX, topY, bottomY :: Double
leftX   =    0
rightX  = 1000
topY    =    0
bottomY =  550


-- Kollisionen untereinader (Ball mit Ball)
bounceBalls :: [Ball] -> [Ball]
bounceBalls [] = []
bounceBalls (b:bs) = b':(bounceBalls bs')
                     where (b', bs') = bounceBall b bs []

bounceBall :: Ball -> [Ball] -> [Ball] -> (Ball, [Ball])
bounceBall b1 [] l = (b1, reverse l)
bounceBall b1 (b2:bs) l | collision b1 b2 = bounceBall b1' bs (b2':l)
                        | otherwise       = bounceBall b1  bs (b2:l)
                        where collision (loc1, rad1, _, _) (loc2, rad2, _, _) = norm (vDiff loc1 loc2) <= rad1 + rad2
                              (b1', b2')                                      = doBouncing b1 b2

doBouncing :: Ball -> Ball -> (Ball, Ball)
doBouncing (loc1, r1, dir1, col1) (loc2, r2, dir2, col2) = ((loc1, r1, dir1', col1), (loc2, r2, dir2', col2))
    where dir1' = vDiff dir1 sp
          dir2' = vSum  dir2 sp
          sp    = scale ((s1 - s2) / (sProd v v)) v
          s1    = sProd dir1 v
          s2    = sProd dir2 v
          v     = vDiff loc1 loc2

{-
-- Beseitgt Problem mit ballSet7
doBouncing :: Ball -> Ball -> (Ball, Ball)
doBouncing (loc1, r1, dir1, col1) (loc2, r2, dir2, col2) = ((loc1, r1, dir1', col1), (loc2, r2, dir2', col2))
    where dir1' = vDiff dir1 sp
          dir2' = vSum  dir2 sp
          sp    = scale ((s1 - s2) / (sProd v v)) v
          s1    = sProd dir1 v
          s2    = sProd dir2 v
          v     = vDiff loc1' loc2'
          (loc1', loc2') = prepareBouncing loc1 loc2 (scale 0.1 (normalize dir1)) (scale 0.1 (normalize dir2)) (r1+r2)

prepareBouncing :: Vector -> Vector -> Vector -> Vector -> Double -> (Vector, Vector)
prepareBouncing l1 l2 d1 d2 r | norm (vDiff l1 l2) < r = prepareBouncing l1' l2' d1 d2 r
                              | otherwise              = (l1, l2)
                              where l1' = vDiff l1 d1
                                    l2' = vDiff l2 d2
-}


--------------------------------- Funktionen zur grafischen Anzeige ----------------------------------

animate balls = do
  w <- openWindowEx "Bouncing Balls" (Just (0,0)) (1000,550) DoubleBuffered (Just 30)
  let
    loop balls = do
      setGraphic w (overGraphics (drawBalls (updateBalls balls)))
      getWindowTick w
      loop (updateBalls balls)
  loop balls


drawBalls :: [Ball] -> [Graphic]
drawBalls = map drawBall


drawBall :: Ball -> Graphic
drawBall (loc, r, _, col) = withColor col (ellipse (x-radius, y-radius) (x+radius, y+radius))
                           where (x, y) = v2p loc
                                 radius = truncate r



-------------------------------- Hauptprogramm mit Beispielen -----------------------------------

ballSet1, ballSet2, ballSet3, ballSet4, ballSet5, ballSet6, ballSet7 :: [Ball]
ballSet1 = [([185, 308], 16, [10, 0], White), ([429, 292], 16, [-1, 0],  Red)]
ballSet2 = [([185, 300], 16, [10, 0], White), ([429, 300], 16, [0, 0],   Red)] 
ballSet3 = [([385, 195], 16, [5, 0],  White), ([629, 179], 16, [-10, 0], Red), ([342, 360], 16, [0,0],  Green)]
ballSet4 = [([40, 300],  16, [15, 0], White), ([400, 307], 16, [0, 0],   Red), ([435, 287], 16, [0,0],  Red),  ([435, 327], 16, [0, 0], Red)]
ballSet5 = [([40, 300],  16, [7, 0],  White), ([400, 300], 16, [0, 0],   Red), ([500, 300], 16, [0,0],  Green)]
ballSet6 = [([25, 275],  16, [15, 0], White), ([195, 255], 16, [0,0],    Red), ([195, 295], 16, [0, 0], Red),  ([370, 115], 16, [0,0],  White), ([370, 435], 16, [0,0], White)]
ballSet7 = [([25, 275],  16, [20, 0], White), ([195, 255], 16, [0,0],    Red), ([195, 295], 16, [0, 0], Red),  ([370, 115], 16, [0,0],  White), ([370, 435], 16, [0,0], White)]


main ballSet = runGraphics (animate ballSet)

-- main ballSet1
-- main ballSet2
-- main ballSet3
-- main ballSet4
-- main ballSet5
-- main ballSet6
-- main ballSet7