{-
   Smooth.hs (adapted from smooth.c which is (c) Silicon Graphics, Inc)
   This file is part of HOpenGL - a binding of OpenGL and GLUT for Haskell.
   Copyright (C) 2000  Sven Panne <Sven.Panne@informatik.uni-muenchen.de>

   This program demonstrates some characters of a 
   stroke (vector) font.  The characters are represented
   by display lists, which are given numbers which 
   correspond to the ASCII values of the characters.
   Use of callLists is demonstrated.
-}

import Data.Char   ( ord )
import Data.List   ( genericLength )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU
import Graphics.UI.GLUT

aData, eData, pData, rData, sData :: [[Vertex2 GLfloat]]
aData = [ [ Vertex2 0 0, Vertex2 0  9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9, Vertex2 5 0 ],
          [ Vertex2 0 5, Vertex2 5  5 ] ]
eData = [ [ Vertex2 5 0, Vertex2 0  0, Vertex2 0 10, Vertex2 5 10 ],
          [ Vertex2 0 5, Vertex2 4  5 ] ]
pData = [ [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5  9, Vertex2 5 6, Vertex2 4 5, Vertex2 0 5 ] ]
rData = [ [ Vertex2 0 0, Vertex2 0 10, Vertex2 4 10, Vertex2 5  9, Vertex2 5 6, Vertex2 4 5, Vertex2 0 5 ],
          [ Vertex2 3 5, Vertex2 5  0 ] ]
sData = [ [ Vertex2 0 1, Vertex2 1  0, Vertex2 4  0, Vertex2 5  1, Vertex2 5 4, Vertex2 4 5, Vertex2 1 5,
            Vertex2 0 6, Vertex2 0  9, Vertex2 1 10, Vertex2 4 10, Vertex2 5 9 ] ]

-- drawLetter interprets the instructions from the list
-- for that letter and renders the letter with line segments.
drawLetter :: [[Vertex2 GLfloat]] -> IO ()
drawLetter segments = do
   mapM_ (beginEnd LineStrip . (mapM_ vertex)) segments
   translate (Vector3 8 0 (0 :: GLfloat))

-- Create a display list for each of 6 characters
myInit :: IO ()
myInit = do
   shadeModel GL.Flat

   fontDisplayLists <- genLists 128
   case head fontDisplayLists of
      DisplayList fontOffset -> listBase fontOffset
   -- The repeated dropping is rather inefficient
   let nthDL c = head (drop (ord c) fontDisplayLists)
   mapM_ (\ (c, vss) -> newEndList (nthDL c) Compile (drawLetter vss))
         [ ('A', aData), ('E', eData), ('P', pData), ('R', rData), ('S', sData) ]
   newEndList (nthDL ' ') Compile (translate (Vector3 8 0 (0 :: GLfloat)))

test1, test2 :: String
test1 = "A SPARE SERAPE APPEARS AS"
test2 = "APES PREPARE RARE PEPPERS"

printStrokedString :: String -> IO ()
printStrokedString s =
   withArray (map ((fromIntegral :: Int -> GLubyte) . ord) s) $
      callLists (genericLength s) UnsignedByte

display :: DisplayCallback
display = do
   clear [ ColorBufferBit ]
   color (Color3 1.0 1.0 (1.0 :: GLfloat))
   pushMatrix
   scale 2.0 2.0 (2.0 :: GLfloat)
   translate (Vector3 10.0 30.0 (0.0 :: GLfloat))
   printStrokedString test1
   popMatrix
   pushMatrix
   scale 2.0 2.0 (2.0 :: GLfloat)
   translate (Vector3 10.0 13.0 (0.0 :: GLfloat))
   printStrokedString test2
   popMatrix
   flush

reshape :: ReshapeCallback
reshape (WindowSize w h) = do
   viewport (0, 0) (fromIntegral w, fromIntegral h)
   matrixMode Projection
   loadIdentity
   ortho2D 0.0 (fromIntegral w) 0.0 (fromIntegral h)

keyboard :: KeyboardMouseCallback
keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
keyboard _            _    _ _ = return ()

-- Main Loop
-- Open window with initial window size, title bar,
-- RGBA display mode, and handle input events.
main :: IO ()
main = do
   getArgsAndInitialize
   setInitialDisplayMode [ Single, RGB ]
   setInitialWindowSize (WindowSize 440 120)
   createWindow "stroke"
   myInit
   setReshapeCallback (Just reshape)
   setKeyboardMouseCallback (Just keyboard)
   setDisplayCallback display
   mainLoop
