import Graphics.UI.GLFW
import Graphics.Rendering.OpenGL
import Control.Monad

import Data.IORef
import System.Exit
import Data.Function
import Control.Concurrent

title = "Sierpinsky triangle"

width, height :: GLsizei

width = 700
height = 600

w2, h2 :: GLfloat

w2 = (fromIntegral  width) / 2
h2 = (fromIntegral  height)  / 2

dw2, dh2 :: GLdouble

dw2 = fromRational $ toRational w2
dh2 = fromRational $ toRational h2

white = Color4 (1::GLfloat) 1 1 0
black = Color4 (0::GLfloat) 0 0 1
red = Color4 (1::GLfloat) 0 0 1

triangle ax ay bx by cx cy = renderPrimitive Triangles $ do
  vertex2f ax ay
  vertex2f bx by
  vertex2f cx cy

clearCenters [] = return []
clearCenters (x@(ax, ay, bx, by, cx, cy):xs) = do
  let a1x = ax
      a1y = ay
      b1x = (ax + bx) / 2
      b1y = (ay + by) / 2
      c1x = (cx + ax) / 2
      c1y = (cy + ay) / 2
      a2x = b1x
      a2y = b1y
      b2x = bx
      b2y = by
      c2x = (cx + bx) / 2
      c2y = (cy + by) / 2
      a3x = c1x
      a3y = c1y
      b3x = c2x
      b3y = c2y
      c3x = cx
      c3y = cy
  triangle b1x b1y c1x c1y c2x c2y
  cleared <- clearCenters xs
  return $ if length xs > 5000 then (x:xs) else
           (x : (a1x, a1y, b1x, b1y, c1x, c1y):(a2x, a2y, b2x, b2y, c2x, c2y):
        (a3x, a3y, b3x, b3y, c3x, c3y):cleared)

vertex2f a b = vertex (Vertex3 a b 0)

main = do
  initialize
  openWindow (Size width height) [] Window
  windowTitle $= title
  clearColor $= Color4 1 1 1 1
  windowCloseCallback $= exitWith ExitSuccess
  windowSizeCallback  $= (\size -> viewport $= (Position 0 0, size))
  ortho (-dw2-50) (dw2+50) (-dh2-50) (dh2+50) (-1) 1
  let       ax = -w2
            ay = -h2
            bx = w2
            by = -h2
            cx = 0
            cy = h2 * tan (pi / 3) - h2
  triangles <- newIORef [(ax, ay, bx, by, cx, cy)]
  let loop = do
        clear [ColorBuffer]
        color black
        triangle ax ay bx by cx cy
        color white
        xs <- readIORef triangles
        clearCenters xs >>= writeIORef triangles
        swapBuffers
        threadDelay 50000
        loop

  loop