Publish early and publish often. That is the reason why you can read this. I started playing around with HOpenGL the Haskell port of OpenGL a common library for doing 3D graphics. I more or less took minutes of my efforts and make them public in this tutorial. I did not have any prior experience in graphics programming, when I started to work with HOpenGL.

Chapter 1
Introduction

1.1  A Little Bit of Practice

1.1.1  Opening Windows

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  createAWindow "Hello Window"
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= clear [ColorBuffer]

• initialize the OpenGL system
• define a window
• start the main procedure for dispaying everything and reacting on events

• create some window with the given name
• define, what is to be done, when the window contents is to be displayed. In the simple example above we simply clear the screen of any color by filling it with the default background color.

sep@swe10:~/hopengl/examples> ghc -package GLUT -o HelloWindow HelloWindow.hs
sep@swe10:~/hopengl/examples> ./HelloWindow

1.1.2  Drawing into Windows

Some Points

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
  (progName,_) <- getArgsAndInitialize
  createAWindow progName
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= displayPoints

myPoints :: [(GLfloat,GLfloat,GLfloat)]
myPoints =
  [(-0.25, 0.25, 0.0)
  ,(0.75, 0.35, 0.0)
  ,(0.75, -0.15, 0.0)
  ,((-0.75), -0.25, 0.0)]

displayPoints = do 
  clear [ColorBuffer]
  renderPrimitive Points 
    $mapM_ (\(x, y, z)->vertex$Vertex3 x y z) myPoints

A Polygon

Example:
So here the program from above with one word changed. Points becomes Polygon.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
   (progName,_) <-getArgsAndInitialize
   createAWindow progName
   mainLoop

createAWindow windowName = do
   createWindow windowName
   displayCallback $= displayPoints

displayPoints = do 
  clear [ColorBuffer]
  renderPrimitive Polygon 
    $mapM_ (\(x, y, z)->vertex$Vertex3 x y z) myPoints

myPoints :: [(GLfloat,GLfloat,GLfloat)]
myPoints =
  [(-0.25, 0.25, 0.0)
  ,(0.75, 0.35, 0.0)
  ,(0.75, -0.15, 0.0)
  ,((-0.75), -0.25, 0.0)]

Figure 1.1: A simple polygon.

1.2  A Little Bit of Theory

1.2.1  Haskell

1.2.2  OpenGL

1.2.3  Haskell and OpenGL

main = do
  let x = 5
  print x
  let x = 6
  print x
  xs  <- getLine
  print (length xs)

1.3  A Little Bit of Technics

1.4  A Little Bit of History

Chapter 2
Basics

2.1  Setting and Getting of Variables

2.1.1  Setting values

Example:
When we have created a window, we assign a size to it:

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  myWindow "Hello Window"
  mainLoop

myWindow name = do
  createWindow name 
  windowSize $= Size 800 500
  displayCallback $= clear [ColorBuffer]

Implementation of set

infixr 2 $=

class HasSetter s where
   ($=) :: s a -> a -> IO ()

2.1.2  Getting values

Example:
You can retrieve the size of the screen:

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  x<-get screenSize
  print x

sep@swe10:~/hopengl/examples> ghc -package GLUT -o Get Get.hs
sep@swe10:~/hopengl/examples> ./Get
Size 1024 768
sep@swe10:~/hopengl/examples>

Implementation of get

class HasGetter g where
   get :: g a -> IO a

2.1.3  Getting and Setting Values

Example:
The following program sets the size of a window. Afterwards the variable windowSize is retrieved:

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  myWindow "Hello Window"
  mainLoop

myWindow name = do
  createWindow name 
  windowSize $= Size 800 500
  x<-get windowSize
  print x
  displayCallback $= clear [ColorBuffer]

sep@swe10:~/hopengl/examples> ./SetGet
Size 300 300

2.1.4  What do the variables refer to

2.2  Basic Drawing

2.2.1  Display Functions

Clearing the Screen

Example:
The following simple program opens a window and clears its content pane whenever it is displayed:

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

main = do
  (progName,_) <- getArgsAndInitialize
  createAWindow progName
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= display

display = clear [ColorBuffer]

First Color Operations

data Color4 a = Color4 a a a a
   deriving ( Eq, Ord, Show )

Example:
This program opens a window with a red background.

import Graphics.UI.GLUT 
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  createAWindow "red"
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= display

display = do 
  clearColor $= Color4 1 0 0 1
  clear [ColorBuffer]

Committing Complete Drawing

2.2.2  Primitive Shapes

data PrimitiveMode =
     Points
   | Lines
   | LineLoop
   | LineStrip
   | Triangles
   | TriangleStrip
   | TriangleFan
   | Quads
   | QuadStrip
   | Polygon
   deriving ( Eq, Ord, Show )

vertex (Vertex3 x y z)

vertex$Vertex3 x y z

Points

Example:
This program draws one single yellow point on a black screen.

import Graphics.UI.GLUT 
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  createAWindow "points"
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= display

display = do 
  clear [ColorBuffer]
  currentColor $= Color4 1 1 0 1
  renderPrimitive Points
     (vertex (Vertex3 (0.1::GLfloat) 0.5 0))
  flush

Example:
In this program we use a nested do statement to define more points.

import Graphics.UI.GLUT 
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  createAWindow "more points"
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= display

display = do 
  clear [ColorBuffer]
  currentColor $= Color4 1 1 0 1
  renderPrimitive Points $
   do   

      vertex (Vertex3 (0.1::GLfloat) 0.6 0)    

      vertex (Vertex3 (0.1::GLfloat) 0.1 0)    
  flush

Example:
Thus we can rewrite a points example in the following way: points are defined as a list of triples. Furthermore we define some useful auxilliary functions:

import Graphics.UI.GLUT 
import Graphics.Rendering.OpenGL

main = do
  getArgsAndInitialize
  createAWindow "more points"
  mainLoop

createAWindow windowName = do
  createWindow windowName
  displayCallback $= display

display = do 
  clear [ColorBuffer]
  currentColor $= Color4 1 1 0 1
  let points = [(0.1,0.6,0::GLfloat)
               ,(0.2,0.8,0)
               ,(0.3,0.1,0)
               ,(0,0,0)
               ,(0.4,-0.8,0)
               ,(-0.2,-0.8,0)
               ]
  renderPoints points
  flush

makeVertexes = mapM_ (\(x,y,z)->vertex$Vertex3 x y z)

renderPoints = renderAs Points

renderAs figure ps = renderPrimitive figure$makeVertexes ps

Some useful functions

module PointsForRendering where
import Graphics.UI.GLUT 
import Graphics.Rendering.OpenGL

renderInWindow displayFunction = do 
  (progName,_) <-  getArgsAndInitialize
  createWindow progName
  displayCallback $= displayFunction
  mainLoop

displayPoints points primitiveShape = do 
  renderAs primitiveShape points
  flush

renderAs figure ps = renderPrimitive figure$makeVertexes ps

makeVertexes = mapM_ (\(x,y,z)->vertex$Vertex3 x y z)

mainFor primitiveShape 
 = renderInWindow (displayMyPoints primitiveShape) 

displayMyPoints primitiveShape = do
  clear [ColorBuffer]
  currentColor $= Color4 1 1 0 1
  displayPoints myPoints primitiveShape 

myPoints 
 = [(0.2,-0.4,0::GLfloat)
   ,(0.46,-0.26,0)
   ,(0.6,0,0)
   ,(0.6,0.2,0)
   ,(0.46,0.46,0)
   ,(0.2,0.6,0)
   ,(0.0,0.6,0)
   ,(-0.26,0.46,0)
   ,(-0.4,0.2,0)
   ,(-0.4,0,0)
   ,(-0.26,-0.26,0)
   ,(0,-0.4,0)
   ]

Example:
We can now render the example points in a oneliner:

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor Points

Lines

Example:
Connecting our example points by lines. Pairs of points define singleton lines.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor Lines

Figure 2.1: Lines between points.

Example:
Now we make a loop of lines with our example points.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor LineLoop

Figure 2.2: A loop of lines.

Example:
Now we make a strip of lines with our example points.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor LineStrip

Figure 2.3: A strip in terms of lines.

Triangles

Example:
Our example vertexes define 12 points such that we get 4 triangles

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor Triangles

Figure 2.4: Triangles.

Example:
For our 12 points a triangle strip will create 10 triangles.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor TriangleStrip

Figure 2.5: A triangle strip.

Example:
Our example points as a fan. 10 triangles are rendered.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor TriangleFan

Figure 2.6: A triangle strip.

Quads

Example:
For our 12 example points OpenGL renders 3 quads

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor Quads

Figure 2.7: Quads.

Example:
Our examples vertexes now used for a strip of quads.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor QuadStrip

Figure 2.8: QuadStrips.

Polygons

• no convex corners are allowed.
• lines may not cross each other.
• polygons need to be planar.

Example:
Eventually our vertexes are used to define a polygon.

import PointsForRendering
import Graphics.Rendering.OpenGL

main = mainFor Polygon

2.2.3  Curves, Circles and so on

Circles

module Circle where 
import PointsForRendering
import Graphics.Rendering.OpenGL

circlePoints radius number 
 = [let alpha = twoPi * i /number 
    in  (radius*(sin (alpha)) ,radius * (cos (alpha)),0)  
   |i <- [1,2..number]]
  where
    twoPi = 2*pi

circle radius = circlePoints radius 100

renderCircleApprox r n
 = displayPoints (circlePoints r n) LineLoop

renderCircle r = displayPoints (circle r) LineLoop
fillCircle r = displayPoints (circle r) Polygon

Example:
First we test what kind of shape we get for small approximation numbers.

import PointsForRendering
import Circle

import Graphics.Rendering.OpenGL

main = renderInWindow $ do
        clear [ColorBuffer]
        renderCircleApprox 0.8 10

Figure 2.9: 10 points on a circle.

Example:
Now we can test, if the resulting circle is, what we expected.

import PointsForRendering
import Circle

import Graphics.Rendering.OpenGL

main = renderInWindow $ do
          clear [ColorBuffer]
          renderCircle 0.8

Figure 2.10: Rendering a full circle.

Example:
And eventually have a look at the filled circle.

import PointsForRendering
import Circle

import Graphics.Rendering.OpenGL

main 
 = renderInWindow $ do
     clear [ColorBuffer]
     fillCircle 0.8 

Figure 2.11: A filled circle.

Rings

module Ring where

import PointsForRendering
import Circle
import Graphics.Rendering.OpenGL

ringPoints innerRadius outerRadius 
 = concat$map (\(x,y)->[x,y]) (points++[p])
  where
    innerPoints = circle innerRadius
    outerPoints = circle outerRadius
    points@(p:_) = zip innerPoints outerPoints

ring innerRadius outerRadius 
 = displayPoints (ringPoints innerRadius outerRadius)  QuadStrip

Example:
We can test the ring functions:

import PointsForRendering
import Ring

import Graphics.Rendering.OpenGL

main = renderInWindow $  do
        clear [ColorBuffer]
        ring 0.7 0.9

Figure 2.12: A simple ring shape.

2.2.4  Attributes of primitives

Point Size

Example:
We set the point size to 10 pixels:

import Graphics.Rendering.OpenGL
import PointsForRendering

main = renderInWindow display

display = do
  pointSize $= 10
  displayMyPoints Points

Figure 2.13: Points of a large size.

Line Attributes

Example:
Setting the width of lines and a stipple:

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT
import PointsForRendering

main = renderInWindow display

display = do
  clearColor $= Color4 1 1 1 1
  clear [ColorBuffer]
  lineStipple $= Just (1,255) 
  currentColor $= Color4 0 0 0 1
  lineWidth $= 10 
  displayPoints squarePoints LineLoop
  flush

squarePoints
 = [(-0.7,-0.7,0),(0.7,-0.7,0),(0.7,0.7,0),(-0.7,0.7,0)]

Figure 2.14: Thick stippled lines.

Colors

Example:
We define a triangle. Before the three vertexes of the triangle are defined, the current color is set to a new value.

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT
import PointsForRendering

colorTriangle = do
  currentColor $= Color4 1 0 0 1
  vertex$Vertex3 (-0.5) (-0.5) (0::GLfloat)
  currentColor $= Color4 0 1 0 1
  vertex$Vertex3 (0.5) (-0.5) (0::GLfloat)
  currentColor $= Color4 0 0 1 1
  vertex$Vertex3 (-0.5) (0.5) (0::GLfloat)

main = renderInWindow display

display = do
  clearColor $= Color4 1 1 1 1
  clear [ColorBuffer]
  renderPrimitive Triangles colorTriangle
  flush

Figure 2.15: A triangle with different vertex colors

2.2.5  Tessellation

Example:
We want to render stars. These are shapes with convex corners.

module Star where
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT
import Data.Either
import Circle
import List

starPoints radius rays
 = map (\(_,(x,y,z))->Vertex3 x y z)(os++es)
  where
   (os,es) = partition (\(i,_)-> odd i)
               $zip [1,2..]
               $circlePoints radius rays

complexPolygon points
 = ComplexPolygon 
     [ComplexContour $map (\v->AnnotatedVertex v 0) points]

star radius rays= do
  startess 
    <- tessellate 
         TessWindingPositive 0 (Normal3 0 0 0) noOpCombiner 
            $complexPolygon (starPoints radius rays)
  drawSimplePolygon  startess

drawSimplePolygon  (SimplePolygon primitiveParts) =
  mapM_ renderPrimitiveParts primitiveParts
            
renderPrimitiveParts (Primitive primitiveMode vertices) =
  renderPrimitive primitiveMode
    $mapM_ (vertex . stripAnnotation) vertices 

stripAnnotation (AnnotatedVertex plainVertex _) = plainVertex

noOpCombiner _newVertex _weightedProperties = 0.0 ::GLfloat

import PointsForRendering
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT
import Star

main = renderInWindow$do
 clearColor $= Color4 1 1 1 1
 clear [ColorBuffer]

 currentColor $= Color4 1 0 0 1
 star 0.9 7

 currentColor $= Color4 1 1 0 1
 star 0.4 5

Figure 2.16: RenderStar

2.2.6  Cubes, Dodecahedrons and Teapots

Example:
You probably need very often the shape of a teapot. Since this is so elementary a library function is provided for this.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import PointsForRendering

main = renderInWindow display

display = do 
  clear [ColorBuffer]
  renderObject Solid$ Teapot 0.6
  flush

Figure 2.17: A tea pot.

Chapter 3
Modelling Transformations

3.1  Translate

Example:
The function ring we defined before only defined rings which have the center coordinates (0,0,0). If we want to place rings somewhere else then we need to apply a translate matrix.

import PointsForRendering
import Ring
import Graphics.Rendering.OpenGL

ringAt x y innerRadius outerRadius = do
  translate$Vector3 x y (0::GLfloat)
  ring innerRadius outerRadius

main = do 
  renderInWindow  someRings

someRings = do
  clearColor $= Color4 1 1 1 1
  clear [ColorBuffer]

  loadIdentity
  currentColor $= Color4 1 0 0 1
  ringAt 0.5 0.3 0.1 0.12

  loadIdentity
  currentColor $= Color4 0 1 0 1
  ringAt (-0.5) 0.3 0.3 0.5

  loadIdentity
  currentColor $= Color4 0 0 1 1
  ringAt (-1) (-1) 0.7 0.75

  loadIdentity
  currentColor $= Color4 0 1 1 1
  ringAt 0.7 0.7 0.2 0.3

Figure 3.1: Rings translated to different positions.

3.2  Rotate

Example:
In this example we apply the composition of two transformations. Squares are moved to some position and furthermore rotated around the z-axis.

module Squares where

import Graphics.Rendering.OpenGL
import PointsForRendering

myRect width height = 
  displayPoints [(w,h,0),(w,-h,0),(-w,-h,0),(-w,h,0)] Quads
   where
     w = width/2
     h = height/2

square width = myRect width width

import PointsForRendering
import Squares
import Graphics.Rendering.OpenGL

rotatedSquare alpha width  = do
  rotate alpha $Vector3 0 0 (1::GLfloat)
  square width

displayAt x y displayMe = do 
  translate$Vector3 x y (0::GLfloat)
  displayMe
  loadIdentity

main = do 
  renderInWindow  someSquares

someSquares = do
  clearColor $= Color4 1 1 1 1
  clear [ColorBuffer]

  currentColor $= Color4 1 0 0 1
  displayAt 0.5 0.3$rotatedSquare  15 0.12

  currentColor $= Color4 0 1 0 1
  displayAt (-0.5) 0.3$rotatedSquare 25 0.5

  currentColor $= Color4 0 0 1 1
  displayAt (-1) (-1)$rotatedSquare 4 0.75

  currentColor $= Color4 0 1 1 1
  displayAt 0.7 0.7$rotatedSquare 40 0.3

Figure 3.2: Squares translated and rotated.

3.3  Scaling

Example:
We apply three transformations on the tea pot example. We rotate and translate it and finally we stretch it a bit by a scale transformation.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import PointsForRendering
main = renderInWindow display

display = do 
  clear [ColorBuffer]
  scale 0.3 0.9 (0.3::GLfloat)
  translate$Vector3 (-0.3) 0.3 (0::GLfloat)
  rotate 30 $Vector3 0 1 (0::GLfloat)
  renderObject Solid$ Teapot 0.6
  loadIdentity
  flush

Figure 3.3: A coffee pot.

3.4  Composition of Transformations

rotatedSquareAt width alpha x y z = do
  translate$Vector3 x w y
  rotate alpha $Vector3 0 0 (1::GLfloat)
  square width

translate$Vector3 x w y
rotate alpha $Vector3 0 0 (1::GLfloat)

Example:
This example illustrates the different compositions of rotation and translation.

import PointsForRendering
import Squares
import Graphics.Rendering.OpenGL

displayAt x y displayMe = do 
  displayMe
  loadIdentity

main = do 
  renderInWindow  someSquares

someSquares = do
  clearColor $= Color4 1 1 1 1
  clear [ColorBuffer]

  currentColor $= Color4 0 0 0 1
  square 0.5
  loadIdentity

  currentColor $= Color4 0 0 1 1
  translate$Vector3 0.5 0.5 (0::GLfloat)
  square 0.5
  loadIdentity

  currentColor $= Color4 0 1 1 1
  rotate 35 $Vector3 0 0 (1::GLfloat)
  square 0.5
  loadIdentity

  currentColor $= Color4 1 0 0 1
  translate$Vector3 0.5 0.5 (0::GLfloat)
  rotate 35 $Vector3 0 0 (1::GLfloat)
  square 0.5
  loadIdentity

  currentColor $= Color4 1 1 0 1
  rotate 35 $Vector3 0 0 (1::GLfloat)
  translate$Vector3 0.5 0.5 (0::GLfloat)
  square 0.5
  loadIdentity

Figure 3.4: Different compositions of translation and rotation.

3.5  Defining your own transformation

3.5.1  Shear

module MyTransformations where
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

shear f = do
  m <-  (newMatrix RowMajor [1,f,0,0
                              ,0,1,0,0
                              ,0,0,1,0 
                              ,0,0,0,1])
  multMatrix (m:: GLmatrix GLfloat)

import PointsForRendering
import Circle
import Squares
import MyTransformations

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

main = renderInWindow$do
 loadIdentity
 clearColor $= Color4 1 1 1 1
 clear [ColorBuffer]
 translate$Vector3 0.5 0.5 (0::GLfloat)
 shear 0.5
 currentColor $= Color4 0 0 1 1
 fillCircle 0.5

 loadIdentity
 translate$Vector3 (-0.5) (-0.5) (0::GLfloat)
 shear 0.5
 currentColor $= Color4 1 0 0 1
 square 0.5

3.6  Some Word of Warning

Example:
In this example a ring is displayed. Each time the display function is called the contents of the ring moves a bit. Compile the program and hide the resulting window behind some other window. You will observe how the ring moves within the window, until it is no longer displayed.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import PointsForRendering
import Ring
import Squares

main = renderInWindow display

display = do 
  clear [ColorBuffer]
  translate$Vector3 (-0.1) 0.1 (0::GLfloat)
  ring 0.2 0.4
  flush

3.7  Local transformations

preservingMatrix :: IO a -> IO a

Example:
To demonstrate the use of preservingMatrix we provide a module, which is able to render a side of the famous Rubik's Cube. Such a side consists of 9 squares which are of some color and which have a black frame. We can render such a shape, by rendering the single framed squares at the origin and then move them to their position. This movement is done within a preservingMatrix application.

module RubikFace where
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import Squares
import PointsForRendering

frame width height border = do
  let bh = border/2
  let wh = width/2-bh
  let hh = height/2-bh

  preservingMatrix $ do
    translate $Vector3 0 hh (0::GLfloat)
    myRect width  border
  preservingMatrix $ do
    translate $Vector3 0 (-hh) (0::GLfloat)
    myRect width  border
  preservingMatrix $ do
    translate $Vector3 (-wh) 0 (0::GLfloat)
    myRect  border height 
  preservingMatrix $ do
    translate $Vector3 wh 0 (0::GLfloat)
    myRect  border height 

originField width color = do
  let frameWidth = width/10
  currentColor $= Color4 0 0 0 1
  frame width width frameWidth
  let sc = 18/20::GLfloat
  currentColor $= color
  square (width-frameWidth)

renderArea :: GLfloat -> [[Color4 GLfloat]] -> IO ()
renderArea width css
 = do
    let cs  = concat css
        cps = zip cs $ areaFields width
    mapM_  (\(c,f)-> f(originField width c)) cps

areaFields width = 
  [makeSquare x y |x<-[1,0,-1],y<-[1,0,-1]]
    where 
      makeSquare xn yn = \f -> preservingMatrix $ do
       let
         x = xn*width
         y = yn*width
       translate $Vector3 x y 0
       f

red     = Color4 1 0 0 (1::GLfloat)
green   = Color4 0 1 0 (1::GLfloat)
blue    = Color4 0 0 1 (1::GLfloat)
yellow  = Color4 1 1 0 (1::GLfloat)
white   = Color4 1 1 1 (1::GLfloat)
black   = Color4 0 0 0 (1::GLfloat)

import PointsForRendering
import Graphics.Rendering.OpenGL

import PointsForRendering
import RubikFace

_FIELD_WIDTH :: GLfloat
_FIELD_WIDTH = 1/5

main =  renderInWindow  faces

faces = do
  clearColor $= white
  clear [ColorBuffer]

  loadIdentity
  translate  $Vector3 (-0.6) 0.4 (0::GLfloat)
  renderArea _FIELD_WIDTH r1

  loadIdentity
  translate  $Vector3 (0.1) (-0.3) (0::GLfloat)
  rotate 290 $ Vector3 0 0 (1::GLfloat)
  scale 1.5 1.5 (1::GLfloat)
  renderArea _FIELD_WIDTH r1

r1=[[red,blue,yellow],[white,green,red],[green,yellow,blue]]

Chapter 4
Projection

4.1  The Function Reshape

Example:
We define the first reshape function for a window. It is the identity function, which does not specify anything, how to render the picture.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import PointsForRendering

main = do
  (progName,_) <- getArgsAndInitialize
  createWindow progName
  displayCallback $= display
  reshapeCallback $= Just reshape
  mainLoop

display = do
 clear [ColorBuffer]
 displayPoints points Quads
   where 
    points 
     = [(0.5,0.5,0)
       ,(-0.5,0.5,0)
       ,(-0.5,-0.5,0)
       ,(0.5,-0.5,0)]

reshape s = return ()

Figure 4.1: Enlarging a window with the empty reshape function.

4.2  Viewport: The Visible Part of Screen

Example:
If you want the window to be used completely for rendering the image, then the position needs to be set to Position 0 0. i.e. no offset and as size the complete window size is to be used:

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import PointsForRendering

main = do
  (progName,_) <- getArgsAndInitialize
  createWindow progName
  displayCallback $= display
  reshapeCallback $= Just reshape
  mainLoop

display = do 
  clear [ColorBuffer]
  displayPoints points Quads
   where 
    points 
     = [(0.5,0.5,0)
       ,(-0.5,0.5,0)
       ,(-0.5,-0.5,0)
       ,(0.5,-0.5,0)]

reshape s@(Size w h) = do
  viewport $= (Position 0 0, s)

Example:
In this example only parts of the window are used for rendering the image. The image is smaller than the window.

import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL

import PointsForRendering

main = do
  (progName,_) <- getArgsAndInitialize
  createWindow progName
  clearColor $= Color4 0 0 0 0
  displayCallback $= display
  reshapeCallback $= Just reshape
  mainLoop

display = do
  clearColor $= Color4 1 1 1 1 
  clear [ColorBuffer]
  currentColor $= Color4 1 0 0 1
  displayPoints ps1 LineLoop
  displayPoints ps2 Lines
   where
    ps1=[(0.5,0.5,0),(-0.5,0.5,0),(-0.5,-0.5,0),(0.5,-0.5,0)]
    ps2=[(1,1,0),(-1,-1,0),(-1,1,0),(1,-1,0) ]

reshape s@(Size w h) = do
  viewport $= (Position 50 50, Size (w-80) (h-60))

Figure 4.2: A Viewport smaller than the window.

4.3  Orthographic Projection

Example:
We render the same image in two windows with different projection values:

import PointsForRendering
import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT
import Star

main = do
  (progName,_) <-  getArgsAndInitialize

  createWindow (progName++"1")
  displayCallback $= display 
  projection (-5) 5 (-5) 5 (-5) 5

  createWindow (progName++"2")
  displayCallback $= display 
  projection 0 0.8 (-0.8) 0.8 (-0.5) 0.5

  mainLoop

projection xl xu yl yu zl zu = do 
  matrixMode $= Projection
  loadIdentity
  ortho xl xu yl yu zl zu
  matrixMode $= Modelview 0

display = do
 clearColor $= Color4 1 1 1 1
 clear [ColorBuffer]
 currentColor $= Color4 1 0 0 1
 star 0.9 7
 currentColor $= Color4 1 1 0 1
 star 0.4 5

Figure 4.3: Two windows with different projection.

Chapter 5
Changing States

• it might react to some event, like some keyboard input or mouse event.
• it might change over time.

5.1  Modelling your own State

module StateUtil where

import Graphics.Rendering.OpenGL
import Data.IORef
import Graphics.UI.GLUT 

--instance HasSetter IORef  where
--  ($=) var val = writeIORef var val
 
--instance HasGetter IORef  where
--  get var = readIORef var

new = newIORef

5.2  Handling of Events

type KeyboardMouseCallback =
   Key -> KeyState -> Modifiers -> Position -> IO ()

data Key
   = Char Char
   | SpecialKey SpecialKey
   | MouseButton MouseButton
   deriving ( Eq, Ord, Show )

data KeyState
   = Down
   | Up
   deriving ( Eq, Ord, Show )

data Modifiers = Modifiers { shift, ctrl, alt :: KeyState }
   deriving ( Eq, Ord, Show )

5.2.1  Keyboard events

Example:
In this example we draw a circle. The radius of the circle can be changed by use of the + and - key.

import Circle
import PointsForRendering
import StateUtil

import Graphics.Rendering.OpenGL
import Data.IORef
import Graphics.UI.GLUT 

main = do
  (progName,_) <-  getArgsAndInitialize
  createWindow progName

  radius <- new 0.1

  displayCallback $= display radius

  keyboardMouseCallback $= Just (keyboard radius)
  mainLoop

display radius = do
  clear [ColorBuffer]
  r <- get radius
  fillCircle r

keyboard radius (Char '+') Down _ _ = do 
  r <- get radius
  radius $=  r+0.05
  postRedisplay Nothing
keyboard radius (Char '-') Down _ _ = do 
  r <- get radius
  radius $=  r-0.05
  postRedisplay Nothing
keyboard _ _ _ _ _ = return ()

5.3  Changing State over Time

Example:
We define our first animation. A ring is displayed with a changing radius.

import Ring 
import PointsForRendering
import StateUtil

import Graphics.Rendering.OpenGL
import Data.IORef
import Graphics.UI.GLUT  as GLUT

_STEP = 0.001

main = do
  (progName,_) <-  getArgsAndInitialize
  createWindow progName
  radius <- new 0.1
  step   <- new _STEP
  displayCallback $= display radius
  idleCallback $= Just (idle radius step)
  mainLoop

display radius = do
  clear [ColorBuffer]
  r <- get radius
  ring r (r+0.2)
  flush

idle radius step = do 
  r <- get radius
  s <- get step
  if r>=1 then step $= (-_STEP) 
          else if r<=0 then step $= _STEP
                       else return ()
  s <- get step
  radius $= r+s
  postRedisplay Nothing

5.3.1  Double buffering

Example:
The ring with changing radius over time now with double buffering.

import Ring 
import PointsForRendering
import StateUtil

import Graphics.Rendering.OpenGL
import Data.IORef
import Graphics.UI.GLUT  as GLUT

_STEP = 0.001

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [DoubleBuffered]
  createWindow progName
  radius <- new 0.1
  step   <- new _STEP
  displayCallback $= display radius
  idleCallback $= Just (idle radius step)
  mainLoop

display radius = do
  clear [ColorBuffer]
  r <- get radius
  ring r (r+0.2)
  swapBuffers

idle radius step = do 
  r <- get radius
  s <- get step
  if r>=1 then step $= (-_STEP) 
          else if r<=0 then step $= _STEP
                       else return ()
  s <- get step
  radius $= r+s
  postRedisplay Nothing

5.4  Pong: A first Game

import Circle 
import Squares 
import PointsForRendering
import StateUtil

import Graphics.Rendering.OpenGL
import Data.IORef
import Graphics.UI.GLUT  as GLUT

_LEFT  = -2
_RIGHT =  1
_TOP   =  1
_BOTTOM= -1

paddleWidth  = 0.07
paddleHeight = 0.2
ballRadius   = 0.035

_INITIAL_WIDTH :: GLsizei
_INITIAL_WIDTH=400

_INITIAL_HEIGHT::GLsizei
_INITIAL_HEIGHT=200

_INITIAL_BALL_DIR = 0.002
_INITIAL_PADDLE_DIR = 0.005

data Ball   = Ball (GLfloat,GLfloat) GLfloat GLfloat

type Paddle = (GLfloat,GLfloat,GLfloat)

data Game
 = Game { ball ::Ball
        , leftP,rightP :: Paddle
        , points ::(Int,Int)
        , moveFactor::GLfloat}

initGame
 = Game {ball=Ball (-0.8,0.3) _INITIAL_BALL_DIR _INITIAL_BALL_DIR
        ,leftP=(_LEFT+paddleWidth,_BOTTOM,0)
        ,rightP=(_RIGHT-2*paddleWidth,_BOTTOM,0)
        ,points=(0,0)
        ,moveFactor=1
        }

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [DoubleBuffered]
  createWindow progName
  game <- newIORef initGame
  --windowSize $= Size _INITIAL_WIDTH _INITIAL_HEIGHT
  fullScreen
  displayCallback $= display game
  idleCallback $= Just (idle game)
  keyboardMouseCallback $= Just (keyboard game)
  reshapeCallback $= Just (reshape game)
  mainLoop

display game = do
  clear [ColorBuffer]
  g <- get game
  let (Ball  pos xDir yDir) = ball g
  --a ball is a circle
  displayAt pos $ fillCircle ballRadius
  displayPaddle$leftP g
  displayPaddle$rightP g
  swapBuffers

displayPaddle (x,y,_) =  preservingMatrix$do 
  translate$Vector3 (paddleWidth/2) (paddleHeight/2) 0
  displayAt (x,y)$myRect paddleWidth paddleHeight

displayAt (x, y) displayMe = preservingMatrix$do 
  translate$Vector3 x y (0::GLfloat)
  displayMe

idle game = do 
  g <- get game
  let fac = moveFactor g
  game
    $= g{ball   = moveBall g
        ,leftP  = movePaddle (leftP g) fac
        ,rightP = movePaddle (rightP g) fac
        }
  postRedisplay Nothing

moveBall g 
 = Ball (x+factor*newXDir,y+factor*newYDir) newXDir newYDir
  where
   newXDir
    |      x-ballRadius <= xl+paddleWidth 
       &&  y+ballRadius >=yl 
       &&  y            <=yl+paddleHeight  
       = -xDir 
    |x <= _LEFT-ballRadius = 0
    |     x+ballRadius >= xr
       &&  y+ballRadius >=yr 
       &&  y            <=yr+paddleHeight       
       = -xDir 
    |x >= _RIGHT+ballRadius = 0
    |otherwise    = xDir
   newYDir
    |y > _TOP-ballRadius || y< _BOTTOM+ballRadius = -yDir 
    |newXDir == 0 = 0
    |otherwise = yDir  
   (Ball (x,y) xDir yDir) = ball g
   factor = moveFactor g
   (xl,yl,_) = leftP g
   (xr,yr,_) = rightP g

movePaddle (x,y,dir) factor =
  let y1 = y+ factor*dir
      newY = min  (_TOP-paddleHeight) $max _BOTTOM y1
  in (x,newY,dir)

keyboard game (Char 'a') upDown _ _ = do 
  g <- get game
  let (x,y,_) = leftP g
  game $= g{leftP=(x,y,paddleDir upDown)}
keyboard game (Char 'l') upDown _ _ = do 
  g <- get game
  let (x,y,_) = rightP g
  game $= g{rightP=(x,y,paddleDir upDown)}
keyboard game (Char '\32') Down _ _ = do 
  g <- get game
  let Ball (x,y) xD yD = ball g
  let xDir 
       |x<=_LEFT+3*paddleWidth = _INITIAL_BALL_DIR
       |x>=_RIGHT-3*paddleWidth = - _INITIAL_BALL_DIR
       |otherwise = xD
  if (xD==0)
    then game$=g{ball=Ball (x+4*xDir,y) xDir _INITIAL_BALL_DIR}
    else return ()
keyboard _ _ _ _ _ = return ()

paddleDir Down = _INITIAL_PADDLE_DIR
paddleDir Up   = -_INITIAL_PADDLE_DIR

reshape game s@(Size w h)  = do
  viewport $= (Position 0 0, s)
  matrixMode $= Projection
  loadIdentity
  ortho (-2.0) 1.0 (-1.0) 1.0 (-1.0) 1.0
  matrixMode $= Modelview 0
  g <- get game
  game$=g{moveFactor=fromIntegral w/fromIntegral _INITIAL_WIDTH}

Chapter 6
Third Dimension

6.1  Hidden Shapes

Example:
We render two shapes. A red square which is closer to the viewer and a blue circle which is farer away:

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT
import Squares
import Circle
import PointsForRendering

main = do
  (progName,_) <-  getArgsAndInitialize
  createWindow progName
  displayCallback $= display
  clearColor $= Color4 1 1 1 1
  mainLoop

display = do
  clear [ColorBuffer,DepthBuffer]
  loadIdentity
  translate (Vector3 0 0 (-0.5::GLfloat))
  currentColor $= Color4 1 0 0 1
  square 1

  loadIdentity
  translate (Vector3 0.2 0.2 (0.5::GLfloat))
  currentColor $= Color4 0 0 1 1
  fillCircle 0.5
  flush

Figure 6.1: Third dimension not correctly taken into account.

• as initial display mode WithDepthBuffer needs to be set.
• a depth function needs to be set. Usually the Less mode is used as function here. This ensures that closer objects hide objects farer away.
• the depth buffer needs to be cleared in the beginning of the display function.

Example:
Now we render the same to shapes as in the example before, but the depth machanism of OpenGL is activated.

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Squares
import Circle
import PointsForRendering

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer]

  createWindow progName

  depthFunc $= Just Less
  displayCallback $= display
  clearColor $= Color4 1 1 1 1
  mainLoop

display = do
  clear [ColorBuffer,DepthBuffer]
  loadIdentity
  translate (Vector3 0 0 (-0.5::GLfloat))
  currentColor $= Color4 1 0 0 1
  square 1

  loadIdentity
  translate (Vector3 0.2 0.2 (0.5::GLfloat))
  currentColor $= Color4 0 0 1 1
  fillCircle 0.5
  flush

Figure 6.2: Third dimension correctly taken into account by use of depth function.

6.2  Perspective Projection

Example:
We can test the orthographic projection. Two squares equally in size, but in different distances from the viewer are rendered:

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Squares
import Circle
import PointsForRendering

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer]
  createWindow progName
  depthFunc $= Just Less
  displayCallback $= display

  matrixMode $= Projection 
  loadIdentity
  ortho (-5) 5  (-5) 5 (1) 40
  matrixMode $= Modelview 0

  clearColor $= Color4 1 1 1 1
  mainLoop

display = do
  clear [ColorBuffer,DepthBuffer]
  loadIdentity
  translate (Vector3 0 0 (-2::GLfloat))
  currentColor $= Color4 1 0 0 1
  square 1

  loadIdentity
  translate (Vector3 4 4 (-5::GLfloat))
  currentColor $= Color4 0 0 1 1
  square 1
  flush

Figure 6.3: Two squares in orthographic projection.

• left: left bound for the closest orthogonal plane
• right: right bound for the closest orthogonal plane
• top: upper bound for the closest orthogonal plane
• bottom: lower bound for the closest orthogonal plane
• near: the closest things that can be seen
• far: the farest away things that can be seen

Example:
Now we render the two squares from the previous example again. This time we use a perspective projection:

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Squares
import Circle
import PointsForRendering

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer]
  createWindow progName
  depthFunc $= Just Less
  displayCallback $= display

  matrixMode $= Projection 
  loadIdentity
  let near   = 1
      far    = 40
      right  = 1
      top    = 1
  frustum (-right) right (-top) top near far
  matrixMode $= Modelview 0

  clearColor $= Color4 1 1 1 1
  mainLoop

display = do
  clear [ColorBuffer,DepthBuffer]
  loadIdentity
  translate (Vector3 0 0 (-2::GLfloat))
  currentColor $= Color4 1 0 0 1
  square 1

  loadIdentity
  translate (Vector3 4 4 (-5::GLfloat))
  currentColor $= Color4 0 0 1 1
  square 1
  flush

Figure 6.5: Two squares in perspective projection.

6.3  Setting up the Point of View

• the point, where the viewer is situated.
• the point at which the viewer is looking.
• and a vector, which specifies the direction which is to be up for the viewer.

6.3.1  Oribiting around the origin

module OrbitPointOfView where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import StateUtil
import Data.IORef

setPointOfView pPos = do
  (alpha,beta,r) <- get pPos
  let
   (x,y,z)    = calculatePointOfView alpha beta r
   (x2,y2,z2) = calculatePointOfView ((alpha+90)`mod` 360) beta r  
  lookAt (Vertex3 x y z) (Vertex3 0 0 0) (Vector3 x2 y2 z2)

calculatePointOfView  alp bet r = 
  let alpha =  fromIntegral alp*2*pi/fromIntegral 360
      beta  =  fromIntegral bet*2*pi/fromIntegral 360
      y = r * cos alpha
      u = r * sin alpha
      x = u * cos beta
      z = u * sin beta
  in (x,y,z)

keyForPos pPos (Char '+')         = modPos pPos (id,id,\x->x-0.1)
keyForPos pPos (Char '-')         = modPos pPos (id,id,(+)0.1)
keyForPos pPos (SpecialKey KeyLeft) = modPos pPos (id,(+)359,id)
keyForPos pPos (SpecialKey KeyRight)= modPos pPos (id,(+)1,id)
keyForPos pPos (SpecialKey KeyUp)   = modPos pPos ((+)1,id,id)
keyForPos pPos (SpecialKey KeyDown) = modPos pPos ((+)359,id,id)
keyForPos  _  _                     = return ()

modPos pPos (ffst,fsnd,ftrd) = do
  (alpha,beta,r) <- get pPos
  pPos $= (ffst alpha `mod` 360,fsnd beta `mod` 360,ftrd r) 
  postRedisplay Nothing

reshape screenSize@(Size w h) = do
  viewport $= ((Position 0 0), screenSize)
  matrixMode $= Projection 
  loadIdentity
  let near   = 0.001
      far    = 40
      fov    = 90
      ang    = (fov*pi)/(360)
      top    = near / ( cos(ang) / sin(ang) )
      aspect = fromIntegral(w)/fromIntegral(h)
      right = top*aspect
  frustum (-right) right (-top) top near far
  matrixMode $= Modelview 0

Example:
Let us use the module above, to orbit around a cube. Therefore we a define simple module, which renders a cube with differently colored areas. The cube is situated at the origin. We render the six areas by rendering a square at the origin and translate and rotate it into its final position.

module ColorCube where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Squares
import StateUtil

locally = preservingMatrix

colorCube n = do
  locally $ do
    currentColor $= Color4 1 0 0 1
    translate$Vector3 0 0 (-n/2)
    square n
  locally $ do
    currentColor $= Color4 0 1 0 1
    translate$Vector3 0 0 (n/2)
    square n
  locally $ do
    currentColor $= Color4 0 0 1 1
    translate$Vector3 (n/2) 0 0
    rotate 90 $Vector3 0 (1::GLfloat) 0
    square n
  locally $ do
    currentColor $= Color4 1 1 0 1
    translate$Vector3 (-n/2) 0 0
    rotate 90 $Vector3 0 (1::GLfloat) 0
    square n
  locally $ do
    currentColor $= Color4 0 1 1 1
    translate$Vector3 0 (-n/2) 0
    rotate 90 $Vector3 (1::GLfloat) 0 0
    square n
  locally $ do
    currentColor $= Color4 1 1 1 1
    translate$Vector3 0 (n/2) 0
    rotate 90 $Vector3 (1::GLfloat) 0 0
    square n

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Squares
import OrbitPointOfView 
import StateUtil
import ColorCube

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer,DoubleBuffered]
  createWindow progName
  depthFunc $= Just Less

  pPos <- new (90::Int,270::Int,2.0)
  keyboardMouseCallback $= Just (keyboard pPos)

  displayCallback $= display pPos
  reshapeCallback $= Just reshape
  mainLoop

display pPos = do
  loadIdentity
  setPointOfView pPos
  clear [ColorBuffer,DepthBuffer]
  colorCube 1
  swapBuffers

keyboard pPos c _  _ _ = keyForPos pPos c

Figure 6.7: A view of the colored cube,

6.4  3D Game: Rubik's Cube

6.4.1  Cube Logics

module RubikLogic where 

data Rubik a
 = Rubik (Front a) (Top a) (Back a) (Bottom a) (Left a) (Right a)

type Front a  = Area a
type Top a    = Area a
type Back a   = Area a
type Bottom a = Area a
type Left a   = Area a
type Right a  = Area a

type Area a = [Row a]
type Row a  = [a]

data AreaPosition =  Front |Top| Back| Bottom| Left| Right

data RubikColor = Red|Blue|Yellow|Green|Orange|White|Black

instance Functor Rubik where
  fmap f (Rubik front top back bottom left right) 
    = Rubik (mf front) (mf top) (mf back) 
            (mf bottom) (mf left) (mf right)
   where
     mf = map (map f)

initCube  = Rubik (area Red)  (area Blue)  (area Yellow)
                  (area Green)(area Orange)(area White)

area c  = [[c,c,c],[c,c,c],[c,c,c]]

rotateArea RubikLogic.Front 
 (Rubik front top back bottom left right) =   
  Rubik front' top' back bottom' left' right'
   where 
     top'    = newRow 3 (reverse$column 3 left) top 
     bottom' = newRow 1 (reverse$column 1 right) bottom 
     left'   = newColumn 3 (row 1 bottom) left
     right'  = newColumn 1 (row 3 top) right
     front'  = rotateBy3 front

rotateArea RubikLogic.Back
 (Rubik front top back bottom left right) =   
   Rubik front' top' back' bottom' 
         (rotateBy2 left') (rotateBy2 right')
   where
    (Rubik back' bottom' front' top' left' right') =
      rotateArea RubikLogic.Front 
       (Rubik back bottom front top 
              (rotateBy2 left) (rotateBy2 right))

rotateArea RubikLogic.Bottom
 (Rubik front top back bottom left right) =   
  Rubik front' top back' bottom' left' right'
   where 
     back'   = newRow 1 (reverse$row 3 left) back 
     front'  = newRow 3 (row 3 right) front 
     left'   = newRow 3 (row 3 front) left
     right'  = newRow 3 (reverse$row 1 back) right
     bottom'  = rotateBy1 bottom


rotateArea RubikLogic.Top
 (Rubik front top back bottom left right) =   
  Rubik front' top' back' bottom left' right'
   where 
     back'   = newRow 3 (reverse$row 1 right) back 
     front'  = newRow 1 (row 1 left) front 
     left'   = newRow 1 (reverse$row 3 back) left
     right'  = newRow 1 (row 1 front) right
     top'  = rotateBy1 top

rotateArea RubikLogic.Left 
 (Rubik front top back bottom left right) =   
  Rubik front' top' back' bottom' left' right
   where 
     top'    = newColumn 1 (column 1 front) top 
     bottom' = newColumn 1 (column 1 back) bottom  
     left'   = rotateBy3 left
     back'   = newColumn 1 (column 1 top) back  
     front'  = newColumn 1 (column 1 bottom) front 

rotateArea RubikLogic.Right 
 (Rubik front top back bottom left right) =   
  Rubik front' top' back' bottom' left right'
   where 
     top'    = newColumn 3 (column 3 back) top 
     bottom' = newColumn 3 (column 3 front) bottom  
     right'  = rotateBy3 right
     back'   = newColumn 3 (column 3 bottom) back  
     front'  = newColumn 3 (column 3 top) front 

rotateBy1
  [[x1,x2,x3]
  ,[x8,x,x4]
  ,[x7,x6,x5]] =
  [[x3,x4,x5]
  ,[x2,x,x6]
  ,[x1,x8,x7]]

rotateBy2 =  rotateBy1 .rotateBy1
rotateBy3 =  rotateBy2 .rotateBy1

column n  = map (\row->row !! (n-1))

row n area = area !!(n-1)

newRow 1 row [a,r,ea] = [row,r,ea]
newRow 2 row [a,r,ea] = [a,row,ea]
newRow 3 row [a,r,ea] = [a,r,row]
 
newColumn n column area = map (doIt n) areaC
  where
    areaC =  zip area column
    doIt 1 ((r:ow),c) = c:ow 
    doIt 2 ((r:o:w),c) = r:c:w 
    doIt 3 ((r:o:w:xs),c) = r:o:c:xs 

6.4.2  Rendering the Cube

module RenderRubik where 

import Graphics.Rendering.OpenGL as OpenGL hiding (Red,Green,Blue)
import Graphics.UI.GLUT  as GLUT hiding (Red,Green,Blue)

import PointsForRendering
import RubikLogic
import RubikFace
import Squares

_FIELD_WIDTH :: GLfloat
_FIELD_WIDTH = 1/3

renderCube (Rubik front top back bottom left right) = do
 render RubikLogic.Top     top
 render RubikLogic.Back    back
 render RubikLogic.Front   front
 render RubikLogic.Bottom  bottom
 render RubikLogic.Left    left
 render RubikLogic.Right   right

render Top    cs = preservingMatrix$do
  translate $Vector3 (1.5*_FIELD_WIDTH) 0 0
  rotate (90)$Vector3  0 1 (0::GLfloat)
  renderCubeSide cs

render RubikLogic.Back   cs = preservingMatrix$ do
  translate $Vector3 0 0 (-1.5*_FIELD_WIDTH)
  rotate (180)$Vector3 0 0 (1::GLfloat)
  rotate (180)$Vector3 1 0 (0::GLfloat)
  renderCubeSide cs

render Bottom cs = preservingMatrix$ do
  translate $Vector3  (-1.5*_FIELD_WIDTH) 0 0
  rotate (270)$Vector3  0 1 (0::GLfloat)
  renderCubeSide cs

render RubikLogic.Front  cs = preservingMatrix$ do
  translate $Vector3 0 0 (1.5*_FIELD_WIDTH)
  renderCubeSide cs

render RubikLogic.Left   cs = preservingMatrix$ do
  translate $Vector3 0 (1.5*_FIELD_WIDTH)  0
  rotate (270) $Vector3 1 0 (0::GLfloat)
  renderCubeSide cs

render RubikLogic.Right  cs = preservingMatrix$ do
  translate $Vector3 0 (-1.5*_FIELD_WIDTH)  0
  rotate (270) $Vector3 1 0 (0::GLfloat)
  rotate (180)$Vector3 1 0 (0::GLfloat)
  renderCubeSide cs

renderCubeSide css = renderArea _FIELD_WIDTH  css

field = square _FIELD_WIDTH

doColor Red    = Color4 1 0 0 1.0
doColor Green  = Color4 0 1 0 1.0
doColor Blue   = Color4 0 0 1 1.0
doColor Yellow = Color4 1 1 0 1.0
doColor Orange = Color4 1 0.5 0.5 1
doColor White  = Color4 1 1 1 1.0
doColor Black  = Color4 0 0 0 1.0

6.4.3  Rubik's Cube

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Data.IORef

import OrbitPointOfView
import StateUtil
import RubikLogic
import RenderRubik

main = do 
  initialDisplayMode $= [DoubleBuffered,RGBMode,WithDepthBuffer]
  (progName,_) <-  getArgsAndInitialize

  createWindow progName

  depthFunc $= Just Less

  pPos  <- new (90::Int,270::Int,2.0)
  pCube <- new initCube

  displayCallback $= display pPos pCube
  keyboardMouseCallback $= Just (keyboard pPos pCube)

  reshapeCallback $= Just reshape
  mainLoop

display pPos pCube = do
  clearColor $= Color4 1 1 1 1
  clear [ColorBuffer,DepthBuffer]
  loadIdentity
  setPointOfView pPos
  cube <- get pCube 
  renderCube$fmap doColor  cube
  swapBuffers

keyboard _ pCube (Char '1') Down _ _
  = rot pCube RubikLogic.Top 
keyboard _ pCube (Char '2') Down _ _ 
 = rot pCube RubikLogic.Bottom 
keyboard _ pCube (Char '3') Down _ _ 
 = rot pCube RubikLogic.Front
keyboard _ pCube (Char '4') Down _ _
  = rot pCube RubikLogic.Back
keyboard _ pCube (Char '5') Down _ _
  = rot pCube RubikLogic.Left
keyboard _ pCube (Char '6') Down _ _ 
 = rot pCube RubikLogic.Right
keyboard pPos _   c         _    _ _
  = keyForPos pPos c 

rot pCube p = do
  cube <- get pCube
  pCube $= rotateArea p cube
  postRedisplay Nothing

6.5  Light

module Cube where 

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import PointsForRendering

cube l = renderAs Quads corners
  where 
   corners =
    [(l,0,l),(0,0,l),(0,l,l),(l,l,l)
    ,(l,l,l),(l,l,0),(l,0,0),(l,0,l)
    ,(0,0,0),(l,0,0),(l,0,l),(0,0,l)
    ,(l,l,0),(0,l,0),(0,0,0),(l,0,0)
    ,(0,l,l),(l,l,l),(l,l,0),(0,l,0)
    ,(0,l,l),(0,l,0),(0,0,0),(0,0,l)
    ]

Example:
We make a first try at rendering a cube:

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Cube

main = do 
  (progName,_) <-  getArgsAndInitialize
  createWindow progName
  displayCallback $= display
  mainLoop

display = do
  clear [ColorBuffer]
  rotate 40 (Vector3 1 1 (1::GLfloat)) 
  cube 0.5
  loadIdentity
  flush

Figure 6.9: An unlit cube.

6.5.1  Defining a light source

Example:
Now we can render a cube with a defined light source:

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT  as GLUT

import Cube

main = do 
  (progName,_) <-  getArgsAndInitialize

  depthFunc $= Just Less

  createWindow progName

  lighting $= Enabled
  position (Light 0) $= Vertex4 1 0.4 0.8  1
  light (Light 0) $= Enabled

  displayCallback $= display
  mainLoop

display = do
  clear [ColorBuffer]
  rotate 40 (Vector3 1 1 (1::GLfloat)) 
  cube 0.5
  loadIdentity
  flush

Figure 6.10: A lit cube.

6.5.2  Tux the Penguin

Overall Setup

import Graphics.Rendering.OpenGL as OpenGL
import Graphics.UI.GLUT  as GLUT

import OrbitPointOfView 
import StateUtil

main = do
  (progName,_) <-  getArgsAndInitialize
  initialDisplayMode $= [WithDepthBuffer,DoubleBuffered]
  pPos <- new (90::Int,270::Int,1.0)	
  depthFunc $= Just Less
  createWindow progName

  lighting  $= Enabled
  normalize $= Enabled
  depthFunc $= Just Less

  position (Light 0) $= Vertex4 0 0 (10) 0
  ambient (Light 0) $= Color4 1 1 1 1
  diffuse (Light 0) $= Color4 1 1 1 1
  specular (Light 0) $= Color4 1 1 1 1
  light (Light 0) $= Enabled

  displayCallback $= display pPos
  keyboardMouseCallback $= Just (keyboard pPos)
  reshapeCallback $= Just reshape 
  mainLoop

keyboard pPos c _  _ _ = keyForPos pPos c

display pPos = do
  loadIdentity
  clearColor $= Color4 1 0 0 1
  setPointOfView pPos
  clear [ColorBuffer,DepthBuffer]
  tux
  swapBuffers

Auxilliary Functions

sphere r xs ys zs = do
  scal xs ys zs
  createSphere r

createSphere r = renderObject Solid $Sphere' r 50 50

scal:: GLfloat -> GLfloat -> GLfloat -> IO ()
scal x y z = scale x y z

transl:: GLfloat -> GLfloat -> GLfloat -> IO ()
transl x y z= translate$Vector3 x y z

rota:: GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
rota a x y z  = rotate a $ Vector3 x y z 

rotateZ a = rota a 0 0 1
rotateY a = rota a 0 1 0
rotateX a = rota a 1 0 0

crMat (rd,gd,bd) (rs,gs,bs) exp = do
  materialDiffuse   Front $= Color4 rd gd bd  1.0
  materialAmbient   Front $= Color4 rd gd bd  1.0
  materialSpecular  Front $= Color4 rs gs bs  1.0
  materialShininess Front $= exp

  materialDiffuse   Back $= Color4 rd gd bd  1.0
  materialSpecular  Back $= Color4 rs gs bs  1.0
  materialShininess Back $= exp

whitePenguin = crMat (0.58, 0.58, 0.58)(0.2, 0.2, 0.2) 50.0
blackPenguin = crMat (0.1, 0.1, 0.1)   (0.5, 0.5, 0.5) 20.0
beakColour   = crMat (0.64, 0.54, 0.06)(0.4, 0.4, 0.4) 5
nostrilColour= crMat (0.48039, 0.318627, 0.033725)(0.0,0.0,0.0) 1
irisColour   = crMat (0.01, 0.01, 0.01)(0.4, 0.4, 0.4) 90.0

Torso and Head

makeBody = do
  preservingMatrix$do
    blackPenguin
    sphere 1 0.95 1.0 0.8
  preservingMatrix$do
    whitePenguin
    transl 0 0 0.17
    sphere 1 0.8 0.9 0.7

createTorso = preservingMatrix$do
  scal 0.9 0.9 0.9
  makeBody

createShoulders = preservingMatrix$do
  transl 0 0.4 0.05
  leftArm
  rightArm
  scal 0.72 0.72 0.72
  makeBody

createNeck = preservingMatrix$do
 transl 0 0.9 0.07
 createHead
 rotateY 90
 blackPenguin
 sphere 0.8 0.45 0.5 0.45
 transl 0 (-0.08) 0.35
 whitePenguin
 sphere 0.66 0.8 0.9 0.7

createHead = preservingMatrix$do
 transl 0 0.3 0.07
 createBeak
 createEyes
 rotateY 90
 blackPenguin
 sphere 1 0.42 0.5 0.42

createBeak = do
  preservingMatrix$do
    transl 0 (-0.205) 0.3
    rotateX 10
    beakColour
    sphere 0.8 0.23 0.12 0.4
  preservingMatrix$do
    beakColour
    transl 0 (-0.23) 0.3
    rotateX 10
    sphere 0.66 0.21 0.17 0.38

Eyes

createEyes = preservingMatrix$do
  leftEye
  leftIris
  rightEye
  rightIris

leftEye = preservingMatrix$do
  transl 0.13 (-0.03) 0.38
  rotateY 18
  rotateZ 5
  rotateX 5
  whitePenguin
  sphere 0.66 0.1 0.13 0.03

rightEye = preservingMatrix$do
  transl (-0.13) (-0.03) 0.38
  rotateY (-18)
  rotateZ (-5)
  rotateX 5
  whitePenguin
  sphere 0.66 0.1 0.13 0.03

leftIris = preservingMatrix$do
  transl 0.12 (-0.045) 0.4
  rotateY 18
  rotateZ 5
  rotateX 5
  irisColour
  sphere 0.66 0.055 0.07 0.03

rightIris = preservingMatrix$do
  transl (-0.12) (-0.045) 0.4
  rotateY (-18)
  rotateZ (-5)
  rotateX 5
  irisColour
  sphere 0.66 0.055 0.07 0.03

Legs

leftArm = preservingMatrix$do
  rotateY 180
  transl (-0.56) 0.3 0
  rotateZ 45
  rotateX 90
  leftForeArm
  blackPenguin
  sphere 0.66 0.34 0.1 0.2

rightArm = preservingMatrix$do
  transl (-0.56) 0.3 0
  rotateZ 45
  rotateX(-90)
  rightForeArm
  blackPenguin
  sphere 0.66 0.34 0.1 0.2

leftForeArm = preservingMatrix$do
  transl (-0.23) 0 0
  rotateZ 20
  rotateX 90
  leftHand
  blackPenguin
  sphere 0.66 0.3 0.07 0.15

rightForeArm = leftForeArm

leftHand = preservingMatrix$do
  transl (-0.24) 0 0
  rotateZ 20
  rotateX 90
  blackPenguin
  sphere 0.5 0.12 0.05 0.12

leftTigh = preservingMatrix$do
  rotateY 180
  transl (-0.28) (-0.8) 0
  rotateY 110
  leftHipBall
  leftCalf

  rotateY (-110)
  transl 0 (-0.1) 0
  beakColour
  sphere 0.5 0.07 0.3 0.07

leftHipBall = preservingMatrix$do 
  blackPenguin
  sphere 0.5 0.09 0.18 0.09

rightTigh = preservingMatrix$do
  transl (-0.28) (-0.8) 0
  rotateY (-110)
  rightHipBall
  rightCalf

  transl 0 (-0.1) 0
  beakColour
  sphere 0.5 0.07 0.3 0.07

rightHipBall = preservingMatrix$do 
  blackPenguin
  sphere 0.5 0.09 0.18 0.09

leftCalf = preservingMatrix$do
 transl 0 (-0.21) 0
 rotateY 90
 leftFoot
 beakColour
 sphere 0.5 0.06 0.18 0.06

rightCalf = preservingMatrix$do
 transl 0 (-0.21) 0
 rightFoot
 beakColour
 sphere 0.5 0.06 0.18 0.06

Feet

foot = preservingMatrix$do
  scal  1.1 1.0 1.3 
  beakColour
  footBase
  toe1
  toe2
  toe3

footBase = preservingMatrix$do
  sphere 0.66 0.25 0.08 0.18

toe1 = preservingMatrix$do
  transl (-0.07) 0 0.1
  rotateY 30
  scal 0.27 0.07 0.11
  createSphere 0.66

toe2 = preservingMatrix$do
 transl (-0.07) 0 (-0.1)
 rotateY (-30)
 sphere 0.66  0.27 0.07 0.11

toe3 = preservingMatrix$do
  transl (-0.08) 0 0
  sphere 0.66  0.27 0.07 0.10

leftFoot = preservingMatrix$do
  transl 0 (-0.09) 0
  rotateY (100) 
  foot

rightFoot = preservingMatrix$do
  transl 0 (-0.09) 0
  rotateY 180
  foot

Tail

createTail = preservingMatrix$ do
  transl 0 (-0.4) (-0.5)
  rotateX (-60)
  transl 0 0.15 0
  blackPenguin
  sphere 0.5 0.2 0.3 0.1

The complete penguin

tux = preservingMatrix$do
  scale 0.35 0.35 (0.35::GLfloat)
  rotateY (-180)
  rotateZ (-180)
  createTorso
  createShoulders
  createNeck
  leftTigh
  rightTigh
  createTail

Index

List of Figures

Bibliography

[]

Norman Chin, Chris Frazier, Paul Ho, Zicheng Lui, and Kevin P. Smith. The OpenGL Graphics System Utility Library, 1998. ftp://ftp.sgi.com/opengl/doc/opengl1.2/glu1.3.ps.

[]

Mark J. Kilgard. The OpenGL Utility Toolkit (GLUT), 1996. www.opengl.org/developers/documentation/glut/glut-3.spec.ps.

[]

Simon L. Peyton Jones and Philip Wadler. Imperative functional programming. In Proceedings 20th Symposium on Principles of Programming Languages, pages 71-84, Charleston, South Carolina, 1993. ACM.

[]

P. Wadler. Comprehending monads. In Proceedings of Symposium on Lisp and Functional Programming, pages 61-78, Nice, France, June 1990. ACM.

[]

Mason Woo, OpenGL Architecture Review Board, Jackie Neider, Tom Davis, and Dave Shreiner. OpenGL Programming Guide 3rd Edition. Addison-Wesley, Reading, MA, 1997.