Instantly share code, notes, and snippets.

# kig/gist:33599 Created Dec 8, 2008

What would you like to do?
distorted_hex.hs
 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