click-clack-1.0.1: src/Graphics.hs

module Graphics where

import Prelude hiding (lines)

import qualified Graphics.Rendering.OpenGL as G
import qualified Graphics.UI.GLFW as G

import Types
import Utils
   
black = Color 0 0 0
red   = Color 1 0 0
green  = Color 0 1 0
blue  = Color 0 0 1
orange = Color 1 0.5 0
yellow = Color 1 1 0 
skyBlue = Color 0 1 1
violet = Color 1 0 1

raduga = [red, orange, yellow, green, skyBlue, blue, violet]

draw :: Picture -> IO ()
draw a = do
    G.clear [G.ColorBuffer]
    foldPicture (return ()) drawPrim (>>) a
    G.swapBuffers
    where drawPrim (Color r g b) prim = do
            G.color $ G.Color4 (d2gl r) (d2gl g) (d2gl b) 1
            drawPrimitive prim    


drawPrimitive :: Primitive -> IO ()
drawPrimitive a = case a of
    Line pa pb          -> lines [glPoint pa, glPoint pb]
    Circle pc rad       -> lineLoop $ circlePoints (glPoint pc) (d2gl rad)  
    Rect pa pb          -> lineLoop $ rectPoints (glPoint pa) (glPoint pb) 
    CircleSolid pc rad  -> polygon  $ circlePoints (glPoint pc) (d2gl rad)
    RectSolid pa pb     -> polygon  $ rectPoints (glPoint pa) (glPoint pb)
    Text pa msg         -> drawText (glPoint pa) msg
    where glPoint (Point x y) = (d2gl x, d2gl y)


type GLpoint = (G.GLfloat, G.GLfloat)

circlePoints (cx, cy) rad = zip xs ys
    where n = 50
          xs = fmap (\x -> cx + rad * sin (2*pi*x/n)) [0 .. n]
          ys = fmap (\x -> cy + rad * cos (2*pi*x/n)) [0 .. n]

rectPoints (ax, ay) (bx, by) = 
    [(ax, ay), (ax, by), (bx, by), (bx, ay), (ax, ay)]


lines       = primitive G.Lines
lineLoop    = primitive G.LineLoop
polygon     = primitive G.Polygon 

primitive primType = 
    G.renderPrimitive primType . mapM_ (uncurry vertex2f) 



drawText :: GLpoint -> String -> IO ()
drawText (a, b) msg = G.preservingMatrix $ 
    G.translate (G.Vector3 a b 0) >>
    G.scale (1.5::G.GLfloat) 1.5 1 >> G.renderString G.Fixed8x16 msg