Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- import Graphics.UI.Gtk hiding (fill)
- import Graphics.Rendering.Cairo
- import Data.Time.Clock.POSIX
- import Time
- frac = snd . properFraction
- modf a b = frac (a / b) * b
- normalizeAngle a | a < 0 = 2*pi + (a `modf` (2*pi))
- normalizeAngle a = a `modf` (2*pi)
- floorf = fromInteger . fst . properFraction
- angularDistance a b =
- f (na - nb)
- where na = normalizeAngle a
- nb = normalizeAngle b
- f a | a > pi = a - 2*pi
- f a | a < -pi = a + 2*pi
- f a = a
- cylinderProjection r (x, y) =
- (mx * 200/z, my * 200/z)
- where mx = r * sin (x/r)
- my = y
- z = 400 + r + r * cos (x/r)
- scaleP f (x,y) = (x*f, y*f)
- translateP u v (x,y) = (x+u, y+v)
- rotateP a (x,y) = (cos a * x - sin a * y, sin a * x + cos a * y)
- gon n =
- map nrot [0..n-1]
- where nrot i = let a = 2*pi*i/n in
- (cos a, sin a)
- hexagon = gon 6
- drawHexagon col rot r rows i = do
- let y = if (floor i) `mod` 2 == 0
- then 0
- else 1.732
- let transform = cylinderProjection r . scaleP (2*pi*r/rows) . translateP (rows*rot/(2*pi) + i) (y+col*1.732*2) . rotateP (pi/2)
- let hex = map transform hexagon
- save
- newPath
- uncurry moveTo $ head hex
- mapM_ (uncurry lineTo) $ tail hex
- closePath
- stroke
- setSourceRGBA 0.8 0 1 1
- let nex = map (transform . translateP (-0.4) 0.333 . scaleP 0.2) hexagon
- newPath
- uncurry moveTo $ head nex
- mapM_ (uncurry lineTo) $ tail nex
- closePath
- fill
- restore
- drawHexagons col rot r rows i = do
- drawHexagon col rot r rows (i*2)
- drawHexagon col rot r rows (i*2+1)
- exposeHandler widget e = do
- drawWin <- widgetGetDrawWindow widget
- (wi,hi) <- widgetGetSize widget
- let (w,h) = (realToFrac wi, realToFrac hi)
- t <- getPOSIXTime
- let rot = normalizeAngle ((realToFrac t) / 5)
- let rows = 50
- let columns = 25
- let radius = 150
- let hexagonRadius = 2*pi*radius / rows
- renderWithDrawable drawWin $ do
- save
- setSourceRGBA 1 1 1 1
- paint
- setSourceRGBA 0 0 0 1
- translate (w/2) (h/2) -- (-3*hexagonRadius)
- setLineWidth 0.5
- mapM_ (\i -> do
- mapM_ (drawHexagons (i-columns/2) (rot) radius rows) [i*2..i*2+rows/6-4])
- [0..columns-1]
- scale 0.5 0.5
- setLineWidth 0.5
- mapM_ (\i -> do
- mapM_ (drawHexagons (i-columns) (-rot*4) radius rows) [i*2..i*2+rows/6-4])
- [0..columns*2-1]
- restore
- widgetQueueDraw widget
- return True
- main = do
- initGUI
- window <- windowNew
- da <- drawingAreaNew
- set window [ containerChild := da ]
- windowSetDefaultSize window 410 450
- onExpose da (exposeHandler da)
- onDestroy window mainQuit
- widgetShowAll window
- mainGUI
Add Comment
Please, Sign In to add comment