Create a gist now

Instantly share code, notes, and snippets.

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment