import Graphics.UI.GLUT
import Data.IORef
type Vector = (Float, Float, Float)
type Tangent = (Float, Float, Float)
type Point = (Vector, Tangent)
type Pointlist = [Point]
type Spline = Float -> Vector
type SplineHomotopy = Float -> Spline
addVec :: Vector -> Vector -> Vector
addVec (x1,y1,z1) (x2,y2,z2) = (x1+x2, y1+y2, z1+z2)
minus :: Vector -> Vector
minus (x,y,z) = (-x,-y,-z)
mulVec :: Float -> Vector -> Vector
mulVec t (x,y,z) = (t * x, t * y, t* z)
len :: Vector -> Float
len (x,y,z) = sqrt (x^2 + y^2 + z^2)
buildSpline :: Pointlist -> Float -> Vector
buildSpline pl l =
let
x = (1 :: Float) / (fromIntegral ((length pl) - 1))
tt
| l==1 = (fromIntegral ((length pl) - 2))
| otherwise = l/x
t
| l==1 = 1
| otherwise = tt - (fromIntegral (floor tt))
(p0,m0) = pl !! ((floor tt) + 0)
(p1,m1) = pl !! ((floor tt) + 1)
in
(addVec (addVec (mulVec ( 2 * t^3 - 3 * t^2 + 1) p0)
(mulVec ( t^3 - 2 * t^2 + t) m0))
(addVec (mulVec ( t^3 - t^2 ) m1)
(mulVec (-2 * t^3 + 3 * t^2 ) p1)))
buildHomotopy :: Spline -> Spline -> Float -> Spline
buildHomotopy sp1 sp2 l sll =
let
sl
| sll==0 = 0.001
| sll==1 = 0.999
| otherwise = sll
{- p11 = sp1 (sl - 0.001)
p12 = sp1 (sl + 0.001)
p1 = sp1 sll
p21 = sp2 (sl - 0.001)
p22 = sp2 (sl + 0.001)
p2 = sp2 sll
t1 = addVec p11 (minus p12)
t2 = addVec p11 (minus p12)
t1n = mulVec ((1 :: Float) / (len t1)) t1
t2n = mulVec ((1 :: Float) / (len t2)) t2 -}
p1 = sp1 sll
p2 = sp2 sll
s = 1 - sin (pi*2/360 * 90 * l)
-- homsp = buildSpline [(p1, t1n), (p2, t2n)]
in
(addVec (mulVec s p1) (mulVec (1 - s) p2 ))
pm1 :: Point
pm1 = ((0.0,0.0,0),(0.0,1.0,0))
pm2 :: Point
pm2 = ((0.25,0.75,0),(0.0,0.0,0))
pm3 :: Point
pm3 = ((0.5,0.25,0),(-0.3,-0.5,0))
pm4 :: Point
pm4 = ((0.75,0.75,0),(0.3,0.3,0))
pm5 :: Point
pm5 = ((1.0,0.0,0),(0.0,0.0,0))
ps1 :: Point
ps1 = ((0.3,0.0,0),(0.0,0.0,0))
ps2 :: Point
ps2 = ((0.75,0.25,0),(-0.2,0.3,0))
ps3 :: Point
ps3 = ((0.3,0.75,0),(0.2,0.5,0))
ps4 :: Point
ps4 = ((0.75,1.0 ,0),(0.0,0.0,0))
ph1 :: Point
ph1 = ((0.25,1.0,0),(0.0,0.0,0))
ph2 :: Point
ph2 = ((0.25,0.0,0),(0.2,0.5,0))
ph3 :: Point
ph3 = ((0.5,0.5,0),(0.3,0.0,0))
ph4 :: Point
ph4 = ((0.75,0.0 ,0),(0.0,0.0,0))
pb1 :: Point
pb1 = ((0.25,1.0,0),(0.0,0.0,0))
pb2 :: Point
pb2 = ((0.25,0.0,0),(0.2,0.5,0))
pb3 :: Point
pb3 = ((0.5,0.5,0),(1.0,-1.0,0))
pb4 :: Point
pb4 = ((0.25,0.0 ,0),(0.0,0.0,0))
pa1 :: Point
pa1 = ((0.3,0.75,0),(0.0,0.0,0))
pa2 :: Point
pa2 = ((0.3,0.0,0),(0.5,0.5,0))
pa3 :: Point
pa3 = ((0.35,0.7,0),(0.2,-1.0,0))
pa4 :: Point
pa4 = ((0.75,0.0 ,0),(0.0,0.0,0))
pk1 :: Point
pk1 = ((0.3,1.0,0),(0.0,0.0,0))
pk2 :: Point
pk2 = ((0.3,0.0,0),(0.5,0.5,0))
pk3 :: Point
pk3 = ((0.6,0.6,0),(0.2,-1.0,0))
pk4 :: Point
pk4 = ((0.35,0.5 ,0),(0.0,0.0,0))
pk5 :: Point
pk5 = ((0.75,0.0 ,0),(0.0,0.0,0))
pe1 :: Point
pe1 = ((0.3,0.5,0),(0.0,0.0,0))
pe2 :: Point
pe2 = ((0.75,0.75,0),(-0.5,0.25,0))
pe3 :: Point
pe3 = ((0.3,0.5,0),(0.2,-0.3,0))
pe4 :: Point
pe4 = ((1.0,0.0 ,0),(0.0,0.0,0))
pl1 :: Point
pl1 = ((0.3,0.0,0),(0.0,0.0,0))
pl2 :: Point
pl2 = ((0.75,1.0,0),(-0.75,0.0,0))
pl3 :: Point
pl3 = ((0.75,0.0,0),(0.0,0.0,0))
h :: Pointlist
h = [ph1, ph2, ph3, ph4]
b :: Pointlist
b = [pb1, pb2, pb3, pb4]
k :: Pointlist
k = [pk1, pk2, pk3, pk4, pk5]
a :: Pointlist
a = [pa1, pa2, pa3, pa4]
m :: Pointlist
m = [pm1, pm2, pm3, pm4, pm5]
s :: Pointlist
s = [ps1, ps2, ps3, ps4]
e :: Pointlist
e = [pe1, pe2, pe3, pe4]
l :: Pointlist
l = [pl1, pl2, pl3]
o :: Pointlist
o = scalePointlist 0.25 (addOffsetToPointlist (1.0, 1.0, 0.0) (generateEquator 6 0))
letterToPointlist :: Char -> Pointlist
letterToPointlist c
| c == 'a' = a
| c == 'h' = h
| c == 'b' = b
| c == 'm' = m
| c == 'k' = k
| c == 'l' = l
| c == 's' = s
| c == 'e' = e
| c == 'o' = o
| otherwise = []
buildSplineWordi :: String -> Int -> Int -> Pointlist
buildSplineWordi st x max
| st == [] = []
| x < max = (addOffsetToPointlist ((fromIntegral x), 0.0, 0.0)
(letterToPointlist (head st))) ++
(buildSplineWordi (tail st) (x + 1) max)
| otherwise = []
buildSplineWord :: String -> Pointlist
buildSplineWord st = scalePointlist (1/(fromIntegral (length st))) (buildSplineWordi st 0 (length st))
generateEquator :: Int -> Rational -> Pointlist
generateEquator n beta
| (361 :: Rational) > beta = [((y,z,0),(0,0,0))] ++ generateEquator n (beta + nth)
| otherwise = []
where
nth = 360/(fromIntegral n)
alpha = (2 * pi * (fromRational beta) / 360)
(y,z) = rotate2d alpha
spline1 :: Spline
spline1 = buildSpline (scalePointlist (1/7)
(h ++ (addOffsetToPointlist (1.0, 0.0, 0.0) a)
++ (addOffsetToPointlist (2.0, 0.0, 0.0) m)
++ (addOffsetToPointlist (3.0, 0.0, 0.0) k)
++ (addOffsetToPointlist (4.0, 0.0, 0.0) e)
++ (addOffsetToPointlist (5.0, 0.0, 0.0) l)
++ (addOffsetToPointlist (6.0, 0.0, 0.0) l)))
spline2 :: Spline
spline2 = buildSpline (scalePointlist (1/6)
(h ++ (addOffsetToPointlist (1.0, 0.0, 0.0) a)
++ (addOffsetToPointlist (2.0, 0.0, 0.0) m)
++ (addOffsetToPointlist (3.0, 0.0, 0.0) m)
++ (addOffsetToPointlist (4.0, 0.0, 0.0) e)
++ (addOffsetToPointlist (5.0, 0.0, 0.0) l)))
rotate2d :: Float -> (Float,Float)
rotate2d alpha = ((cos alpha), (sin alpha))
spline4 :: Spline
spline4 = buildSpline (buildSplineWord "hamkell")
spline5 :: Spline
spline5 = buildSpline (buildSplineWord "llekmah")
spline3 :: Spline
spline3 = buildSpline (scalePointlist 0.25 (addOffsetToPointlist (2.0, 2.0, 0.0) (generateEquator 36 0)))
homotopy :: SplineHomotopy
homotopy = buildHomotopy spline4 spline3
buildHomPts :: Float -> Float -> (Float -> Float -> Vector) -> Rational -> [(Float, Float, Float)]
buildHomPts dist homdist hom l
| l > (0.99 :: Rational) = [(hom homdist (fromRational 1))] --shitty prelim solution
| otherwise = [(hom homdist (fromRational l))] ++ (buildHomPts dist homdist hom ( l + (toRational dist)))
buildVertexList :: [(Float,Float,Float)] -> [Vertex3 GLfloat]
buildVertexList pl = [Vertex3 x y z| (x,y,z) <- pl]
loop :: Float -> Float
loop t = t + 5.0
-- | t>0.98 = 0.0
-- | otherwise = (t + 0.01)
display :: IORef Float -> DisplayCallback
display x = do
-- clear all pixels
clear [ ColorBuffer ]
-- draw white polygon (rectangle) with corners at
-- (0.25, 0.25, 0.0) and (0.75, 0.75, 0.0)
color (Color3 1.0 1.0 (1.0 :: GLfloat))
-- resolve overloading, not needed in "real" programs
let vertex3f = vertex :: Vertex3 GLfloat -> IO ()
t <- readIORef x
renderPrimitive LineStrip $ mapM_ vertex3f (buildVertexList (buildHomPts 0.01 (0.5 * (1 + (sin (pi*t*2/360)))) homotopy 0))
-- flush
swapBuffers
myInit :: IO ()
myInit = do
-- select clearing color
clearColor $= Color4 0 0 0 0
-- initialize viewing values
matrixMode $= Projection
loadIdentity
ortho 0 1 0 1 (-1) 1
inc_anim :: IORef Float -> IO ()
inc_anim x = do t <- readIORef x
writeIORef x (loop t)
postRedisplay Nothing
addTimerCallback 100 (inc_anim x)
addOffsetToPointlist :: Vector -> Pointlist -> Pointlist
addOffsetToPointlist (x,y,z) pl = [ ((px + x, py + y, pz + z), t) | ((px, py, pz), t) <- pl ]
scalePointlist :: Float -> Pointlist -> Pointlist
scalePointlist s pl = [ ((s * x, s * y, s * z), (s * tx, s * ty, s * tz)) | ((x,y,z),(tx,ty,tz)) <- pl]
main :: IO ()
main = do
getArgsAndInitialize
initialDisplayMode $= [ DoubleBuffered, RGBMode ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
createWindow "hello"
myInit
ref <- newIORef 0.0
displayCallback $= (display ref)
addTimerCallback 100 (inc_anim ref)
mainLoop