distorted_hex.hs

gistfile1.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