circle-packing-0.1.0.1: fay/fay-demo.hs

{-# LANGUAGE EmptyDataDecls    #-}

module FayDemo (main) where

import Language.Fay.FFI
import Language.Fay.Prelude
import Optimisation.CirclePacking

-- | Main entry point.
main :: Fay ()
main = do
    -- body <- getElementById "body"
    window <- getWindow
    addEventListener window "load" start False

colors = ["Black","Green","Silver", "Lime", "Gray", "Olive", "Yellow", "Maroon", "Navy", "Red", "Blue", "Purple", "Teal", "Fuchsia", "Aqua"]

parseInt :: String -> Int
parseInt = ffi "(function () { var n = window.parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"

start :: Fay ()
start = do
  input <- getElementById "input"
  addEventListener input "change" update False
  addEventListener input "input" update False
  addEventListener input "keyup" update False
  addEventListener input "paste" update False
  update

update :: Fay ()
update = do
  canvas <- getElementById "can"
  clearCanvas canvas

  context <- getContext canvas "2d"
  w <- getWidth canvas
  h <- getHeight canvas

  input <- getElementById "input"
  value <- getValue input
  let radii = map (fromIntegral . parseInt) (words value)

  let packed = packCircles id radii
  let colored = zip packed (cycle colors)
  forM_ colored $ \res -> do
    let circle = fst res
    let color = snd res
    beginPath context
    addCircle context (fst circle) (fst (snd circle) + w/2) (snd (snd circle) + h/2)
    setFillStyle context color
    fill context


class Eventable a

-- | A DOM element.
data Element
instance Foreign Element
instance Eventable Element

-- | Add an event listener to an element.
addEventListener :: (Foreign a,Eventable a) => a -> String -> Fay () -> Bool -> Fay ()
addEventListener = ffi "%1['addEventListener'](%2,%3,%4)"

-- | Get an element by its ID.
getElementById :: String -> Fay Element
getElementById = ffi "document['getElementById'](%1)"

getElementsByTagName :: String -> Fay Element
getElementsByTagName = ffi "document['getElementsByTagName'](%1)[0]"

--------------------------------------------------------------------------------
-- Images

data Image
instance Foreign Image
instance Eventable Image

-- | Make a new image.
newImage :: Fay Image
newImage = ffi "new Image()"

-- | Make a new image.
setSrc :: Image -> String -> Fay ()
setSrc = ffi "%1['src'] = %2"

--------------------------------------------------------------------------------
-- Canvas

-- | A canvas context.
data Context
instance Foreign Context

-- | Get an element by its ID.
getContext :: Element -> String -> Fay Context
getContext = ffi "%1['getContext'](%2)"

clearCanvas :: Element -> Fay ()
clearCanvas = ffi "%1['getContext']('2d')['clearRect']( 0 , 0 , %1['width'] , %1['height'])"

getValue :: Element -> Fay String
getValue = ffi "%1['value']"
getWidth :: Element -> Fay Double
getWidth = ffi "%1['width']"
getHeight :: Element -> Fay Double
getHeight = ffi "%1['height']"

beginPath :: Context ->  Fay ()
beginPath = ffi "%1['beginPath']()"

addCircle :: Context -> Double -> Double -> Double -> Fay ()
addCircle = ffi "%1['arc'](%3,%4,%2,0,2*Math.PI,false)"

-- | Set the fill style.
setFillStyle :: Context -> String -> Fay ()
setFillStyle = ffi "%1['fillStyle']=%2"

fill :: Context -> Fay ()
fill = ffi "%1['fill']()"

getWindow :: Fay Element
getWindow = ffi "window"

-- | Alert using window.alert.
alert :: Foreign a => a -> Fay ()
alert = ffi "window['alert'](%1)"

-- | Alert using window.alert.
print :: Double -> Fay ()
print = ffi "console['log'](%1)"

-- | Alert using window.alert.
printLog :: String -> Fay ()
printLog = ffi "console['log'](%1)"