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