A graphical interface for showing the Diagram.

A Diagram consists of Atoms, which are connected to each other via ports. Each
port has an orientation (N.E.W.S. directions), which decides the direction
of the line that connects it.

Everything is aligned on a grid with a unit scale.

> {-# LANGUAGE NoMonomorphismRestriction #-}
> module Diagram 
>   ( Atom(..)
>   , Port(..)
>   , Diagram(..)
>   , Direction(..) 
>   , Dirty(..)
>   , HLSet
>   , Frame
>   , M
>   , unit, unit'
>   , margin
>   , initWindow
>   , setupEvents
>   , setDiagram
>   , modifyDiagram
>   , getDiagram
>   , getFont
>   , getFactor
>   , getDirty
>   , whenDirty
>   , setDirty
>   , renderString
>   , renderText
>   , renderFrame
>   , renderDiagram
>   , emptyFrame
>   , betweenFrame 
>   , vector3
>   , color3
>   , drawApplicator
>   , drawAbstractor
>   , drawDelimiter
>   , drawDuplicator
>   , drawCycle
>   , drawEraser
>   , drawTwoPin
>   , drawSingle
>   , autoAdjust
>   ) where

> import qualified Graphics.UI.GLFW as GLFW
> import qualified Graphics.Rendering.OpenGL as GL
> import qualified Graphics.Rendering.OpenGL.GL.Texturing.Objects as TO
> import Graphics.Rendering.OpenGL (($=), GLclampf, GLfloat)

> import qualified Data.Vector.Unboxed as UV 
> import qualified Data.Set as Set
> import qualified Data.Map as Map 
> import qualified Data.IntMap as IntMap 
> import Data.List (sortBy, elemIndex)
> import Data.Complex
> import Data.IORef
> import Data.Maybe (fromMaybe, fromJust)
> import Control.Arrow (first, second)
> import Control.Monad
> import Control.Monad.Trans
> import Control.Monad.Trans.State
> import Control.Monad.IO.Class
> import Control.Monad.Task
> import Graphics.UI.GLFW.Task
> import Debug.Trace
> import Grid

> import Data.Bits ( (.&.) )
> import Foreign ( withArray )
> import Paths_LambdaINet (getDataFileName)

> type Font = TO.TextureObject

> type Color = (GLfloat -> GL.Color4 GLfloat) -> IO ()

> data Atom = Atom { 
>   atomID     :: Int,
>   atomLabel  :: String,
>   atomPorts  :: [Port],
>   atomSize   :: Size,
>   atomDraw   :: Color -> Font -> IO ()                 -- drawing procedure
>   }

> instance Eq Atom where
>    a == b = atomID a == atomID b

> instance Ord Atom where
>    compare a b = atomID a `compare` atomID b

> instance Show Atom where
>    show a = "(id=" ++ show (atomID a) ++ ", label=" ++ atomLabel a ++
>             ", ports=" ++ show (atomPorts a) ++ ", size=" ++ 
>             show (atomSize a) ++ ")"

> data Port = Port {
>   owner   :: Atom,
>   portEnd :: Port,
>   portDir :: Direction,
>   portPos :: Position                 -- relative to the atom's center
>   }

> instance Eq Port where
>   p == q = (owner p == owner q) && (portPos p == portPos q)

> instance Ord Port where
>   compare p q = case owner p `compare ` owner q of
>                   EQ -> portPos p `compare` portPos q
>                   r  -> r

> instance Show Port where
>   show p = "(" ++ show (atomID (owner p)) ++ "-" ++ 
>            show (atomID (owner (portEnd p))) ++
>            ", dir=" ++ show (portDir p) ++ ")"

> data Direction = N | W | S | E deriving (Show, Eq, Enum, Ord)
> type Position = (Float, Float)
> type Size = (Float, Float)                -- radius in X and Y direction

> portdir' :: Direction -> Port -> Direction
> portdir' d p = 
>   let a = owner p
>   in toEnum ((fromEnum (portDir p) + fromEnum d) `mod` 4)
>
> portdir :: Monad m => Port -> GridT Direction m Direction
> portdir p = do
>   let a = owner p
>   d <- lookupNode (atomID a) >>= return . maybe N snd 
>   return $ portdir' d p
>
> portpos' :: Direction -> Position -> Position
> portpos' dir (x, y) = 
>   let r = sqrt (x * x + y * y)
>       t = asin (y / r)
>       t1 = if x < 0 then pi - t else t
>   in case dir of
>     N -> (x, y)
>     W -> vec r (t1 + pi / 2)
>     S -> vec r (t1 + pi)
>     E -> vec r (t1 - pi / 2)
>   where 
>     vec r t = (r * cos t, r * sin t)

> portpos :: Monad m => Port -> GridT Direction m Position
> portpos p = do
>   let a = owner p
>   d <- lookupNode (atomID a) >>= return . maybe N snd 
>   return $ portpos' d (portPos p)

A graph consists of isolated components, which has a starting Atom.

> data Diagram = Diagram { 
>   startAtoms :: [Atom],
>   allAtoms :: IntMap.IntMap Atom
>   } deriving (Eq, Show)

> emptyDiagram = Diagram [] IntMap.empty

The layout process maintains a list of ports to be checked, and
for each port:

  1. check its direction;

  2. if its connecting Atom is not layed out, put it along the port direction.

  3. put those unchecked ports of the connected Atom in the list;

  4 repeat until nothing's left.

> -- layoutByPort :: Monad m => [Port] -> GridT Direction m ()
> layoutByPort visited [] = return ()
> layoutByPort visited (p:ps) = do
>   let a = owner p
>       i = atomID a
>       q = portEnd p
>       b = owner q
>       j = atomID b
>   case IntMap.lookup j visited of
>     Just _  -> layoutByPort visited ps
>     Nothing -> do
>       node <- lookupNode j 
>       case node of
>         Just _ -> return ()
>         Nothing -> do 
>           (((x, y), r), _) <- lookupNode i >>= return . fromMaybe (notFound "layoutByPort:" i)
>           pd <- portdir p
>           pp <- portpos p
>           let qd = autorotate pd (portdir' N q)
>               (xd, yd, dx, dy) = placement pd (portdir' qd q) pp (portpos' qd (portPos q))
>               (bw, bh) = atomSize b
>               rb = sqrt (bw * bw + bh * bh) / 2
>           -- traceShow ("newNode", j) $
>           newNode j (x + xd * (r + rb + realToFrac margin) + dx, y + yd * (r + rb + realToFrac margin) + dy) rb qd
>       let ht = filter (/= q) (atomPorts b)  
>       layoutByPort (IntMap.insert i () visited) $ ht ++ ps 

> interleave (x:xs) (y:ys) = x : y : interleave xs ys
> interleave [] ys = ys
> interleave xs [] = xs

> notFound msg i = error (msg ++ " atom " ++ show i ++ " not found")

The placement returns the relative position and adjustment according to the
line directions.

> placement N N (x1, y1) (x2, y2) = (signum x1, 0, x1 - x2, y1 - y2)
> placement N S (x1, y1) (x2, y2) = (0,  1, x1 - x2, 0)
> placement S S (x1, y1) (x2, y2) = (signum x1, 0, x1 - x2, y1 - y2)
> placement S N (x1, y1) (x2, y2) = (0, -1, x1 - x2, 0)
> placement E E (x1, y1) (x2, y2) = (0,  signum y1, x1 - x2, y1 - y2)
> placement E W (x1, y1) (x2, y2) = (1,  0, 0, y1 - y2)
> placement W W (x1, y1) (x2, y2) = (0,  signum y1, x1 - x2, y1 - y2)
> placement W E (x1, y1) (x2, y2) = (-1, 0, 0, y1 - y2)
> placement _ _ _ _ = error "impossible placement: direction not match!"

The autorotate function returns a rotation (with respect to N) such that the
second direction would meet the first one head to head.

> autorotate N N = S
> autorotate N E = E
> autorotate N W = W
> autorotate N S = N
> autorotate E N = W
> autorotate E E = S
> autorotate E W = N
> autorotate E S = E
> autorotate W N = E
> autorotate W E = N
> autorotate W W = S
> autorotate W S = W
> autorotate S N = N
> autorotate S E = W
> autorotate S W = E
> autorotate S S = S

> margin = 3 
> unit = 12 :: Float         -- grid unit in pixels
> unit' = realToFrac unit
> speed = 0.95               -- how fast it zooms

> showDiagram = undefined

> initWindow w h = do
>   let row = realToFrac h / unit / 2
>       col = realToFrac w / unit / 2
>   GLFW.openWindow (GL.Size w h) [GLFW.DisplayAlphaBits 8] GLFW.Window
>   GLFW.windowTitle $= "Diagram"
>   GL.clearColor $= clearcolor
>   GL.shadeModel $= GL.Smooth
>   -- enable antialiasing
>   GL.lineSmooth $= GL.Enabled
>   GL.blend $= GL.Enabled
>   GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
>   GL.lineWidth $= 1.5
>   -- load font
>   font <- loadFont
>   return (S0 font (row, col) (0,0,1) emptyDiagram Lightly)

> setupEvents reduce = do
>   fork $ forever $ watch onRefresh >> setDirty Lightly
>   fork $ forever $ watch onSize >>= reshape
>   fork $ forever $ handleLeftButton reduce
>   fork $ forever $ handleZoom
>   fork $ forever $ handleKeys
>   fork $ watch (onKey >=> isPress >=> isKey GLFW.ESC) >> exit
>   fork $ watch onClose >> exit

> reshape (GL.Size w h) = do
>   liftIO $ do
>     GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
>     GL.matrixMode $= GL.Projection
>     GL.loadIdentity
>   let row = realToFrac h / unit / 2
>       col = realToFrac w / unit / 2
>       (r, c) = (realToFrac row, realToFrac col)
>   liftIO $ GL.ortho2D (-c) c (-r) r
>   modifyRowCol $ const (row, col)

> data Dirty = None | Lightly | Dirty deriving (Eq, Show, Enum, Ord)

> data S = S0 { font    :: Font
>             , rowcol  :: (Float, Float)
>             , factor  :: (Float, Float, Float)
>             , diagram :: Diagram
>             , dirty   :: Dirty
>             }
>    
> type M m a = TaskT Event (GridT Direction (StateT S m)) a

> modifyRowCol f  = lift $ lift $ modify $ \s -> s { rowcol = f (rowcol s), dirty = Lightly } 
> modifyFactor f  = lift $ lift $ modify $ \s -> s { factor = f (factor s), dirty = Lightly } 
> modifyDiagram f = lift $ lift $ modify $ \s -> s { diagram = f (diagram s), dirty = Dirty } 
> setDiagram = modifyDiagram . const
> getFont    = lift $ lift $ fmap font get 
> getRowCol  = lift $ lift $ fmap rowcol get 
> getFactor  = lift $ lift $ fmap factor get 
> getDiagram = lift $ lift $ fmap diagram get 
> getDirty   = lift $ lift $ fmap dirty get 
> setDirty d = lift $ lift $ modify $ \s -> s { dirty = d }
> whenDirty f = do
>   d <- lift $ lift $ fmap dirty get
>   when (d /= None) f

To support animating the "morphism" between two diagrams, we render each diagram
into a Frame.

> data Frame = Frame 
>   { objs  :: IntMap.IntMap (Atom, GLfloat, GLfloat, GLfloat, GLfloat)  -- (atom, x, y, rotation, alpha)
>   , wires :: Map.Map (Port, Port) (Wire, GLfloat)                      -- wire between ports
>   } deriving (Eq, Show)

> emptyFrame = Frame IntMap.empty Map.empty

> type Wire = UV.Vector (Float, Float)

> wirePoints = 15 -- number of line connecting points in every wire

We can morph a frame into another by compute a frame in between based on
a ratio between 0 (same as f0) and 1 (same as f1).

> betweenFrame (Frame objs wires) (Frame objs' wires') t = Frame obs wis
>   where
>     obs = IntMap.mergeWithKey bothO leftO rightO objs objs'
>     wis = Map.mergeWithKey bothW leftW rightW wires wires'
>     bothO _ (i, x, y, r, a) (j, x', y', r', a') | atomPorts i == atomPorts j = Just (j, x %% x', y %% y', r %%% r', a %% a')
>                                                 | otherwise = Just (j { atomDraw = drawBoth }, x %% x', y %% y', r', t)
>       where drawBoth _ f = do
>               GL.preservingMatrix (GL.rotate (r - r') (vector3 0 0 1) >> 
>                                    atomDraw i (GL.color . ($ (1 - t))) f)
>               GL.preservingMatrix (atomDraw j (GL.color . ($ t)) f) 
>     leftO  = IntMap.map (\(i, x, y, r, _) -> (i, x, y, r, 1 - t)) 
>     rightO = IntMap.map (\(i, x, y, r, _) -> (i, x, y, r, t)) 
>     bothW _ (us, _) (vs, _) = Just (UV.zipWith (\(x, y) (x', y') -> (x %% x', y %% y')) us vs, 1)
>     leftW = Map.map (\(w, _) -> (w, 1 - t))
>     rightW =Map.map (\(w, _) -> (w, t))
>     x %% y = x * (1 - t') + y * t'
>     r %%% r' = if r' > r then if r' - r > 180 then r %% (r' - 360) else r %% r'
>                          else if r - r' > 180 then r %% (r' + 360) else r %% r'
>     t' = realToFrac t

Sometimes it is useful to highlight a set of wires when we render the frame.

> type HLSet = Set.Set ((Int, Int), (Int, Int)) -- A pair of (atomID, portIndex) 
> elemHLSet (p, q) s = Set.member (getIdx p, getIdx q) s
>   where getIdx p = (atomID a, u)
>           where a = owner p
>                 u = maybe (-1) id $ elemIndex p (atomPorts a)

> renderFrame font hlset (Frame objs wires) = do
>   IntMap.fold ((>>) . drawObj) (return ()) objs
>   Map.foldWithKey ((.) (>>) . drawWire) (return ()) wires
>   where
>     drawObj (a, x, y, d, c) = GL.preservingMatrix $ do
>       GL.translate (vector3 x y 0) 
>       GL.rotate d (vector3 0 0 1)
>       atomDraw a (GL.color . ($ c)) font 
>     drawWire pq@(p, q) (lines, c) = do
>       let i = atomID $ owner p
>           j = atomID $ owner q
>           (_, _, _, _, a) = objs IntMap.! i
>           (_, _, _, _, b) = objs IntMap.! j
>       GL.preservingMatrix $ GL.color (linecolor c) >> polyline lines 
>       when (elemHLSet pq hlset) $ GL.preservingMatrix $
>         GL.translate (vector3 1 1 0) >> GL.color (linecolor c) >> polyline lines 

> renderDiagram :: MonadIO m => Diagram -> M m Frame 
> renderDiagram d = lift $ do
>   let atoms = allAtoms d
>   existing <- getGrid
>   let removed = foldr IntMap.delete existing $ IntMap.keys (allAtoms d)
>   mapM_ removeNode $ IntMap.keys removed
>   mapM_ layoutAtoms (startAtoms d)
>   nodes <- getGrid
>   let newNodes = foldr IntMap.delete nodes $ IntMap.keys existing
>   adjustNodes atoms nodes
>   nodes <- getNodes
>   let nodes' = map (fst . snd) nodes
>   foldl ((. drawAtom nodes' atoms) . (>>=)) (return emptyFrame) nodes 
>   where
>     layoutAtoms a = do
>        let i = atomID a
>            (wa, ha) = atomSize a
>            r = sqrt (wa * wa + ha * ha) / 2
>        mx <- getNodes >>= return . maximum . (0:) . map (fst . fst . fst . snd) 
>        lookupNode i >>= maybe (newNode i (mx, 0) r N) (\_ -> return ())
>        layoutByPort IntMap.empty $ atomPorts a
>     drawAtom nodes atoms (i, (((x, y), _), o)) (Frame objs wires) = do
>       let a = fromMaybe (notFound "drawAtom:" i) $ IntMap.lookup i atoms
>       let objs' = IntMap.insert i (a, realToFrac x, realToFrac y, realToFrac (90 * fromEnum o), 1) objs
>       let cond i j p q = i < j || (i == j && portPos p <= portPos q)
>       lines <- linesFromAtom cond lineSeg (i, a, o, x, y)
>       let wires' = foldr (\(k, w) ws -> Map.insert k (polyBezier w, 1) ws) wires lines
>       return $ Frame objs' wires'
>       where
>         lineSeg id x y x' y' pd qd = (id, 
>           (x, y) : navigate nodes (x + px', y + py') (x' + qx', y' + qy') ++ [(x', y')])
>           where (px', py') = extend pd
>                 (qx', qy') = extend qd

> linesFromAtom cond f (i, a, o, x, y) = sequence 
>   [ do let pd = portdir' o p
>            (px, py) = portpos' o (portPos p)
>        qd <- portdir q
>        (qx, qy) <- portpos q
>        (x', y') <- lookupNode j >>= return . maybe (notFound "sequence line:" j) (fst . fst)
>        return $ f (p, q) (x + px) (y + py) (x' + qx) (y' + qy) pd qd
>   | p <- atomPorts a,
>     let q = portEnd p,
>     let j = atomID (owner q),
>     cond i j p q ]

Adjust the rotation of each node to make lines "more straight".

> adjustNodes atoms = sequence_ . map adjustAtom . IntMap.keys
>   where
>     adjustAtom i = do
>       let a = fromMaybe (notFound "adjustNodes:" i) $ IntMap.lookup i atoms
>           ds = [ N, W, S, E ]
>           cond _ _ _ _ = True
>       (x, y) <- lookupNode i >>= return . fst . fst . fromMaybe (notFound "impossible1" i)
>       weighted <- sequence [ linesFromAtom cond (const lineDis) (i, a, o, x, y) >>= return . sum | o <- ds ]
>       let sorted = sortBy (\u v -> compare (snd u) (snd v)) $ zip ds weighted 
>           w = head $ sorted
>       modifyNodeVal i $ \d -> if fromMaybe (notFound "impossible2" d) (lookup d sorted) - snd w > 0.1 then fst w else d
>     lineDis x0 y0 x1 y1 pd qd = dis (x0, y0) (x1, y1)
>       -- dis (x0, y0) (x0', y0') + dis (x0', y0') (x1', y1') + dis (x1', y1') (x1, y1)
>       where (px', py') = extend pd
>             (qx', qy') = extend qd
>             x0' = x0 + px'
>             y0' = y0 + py'
>             x1' = x1 + qx'
>             y1' = y1 + qy'
>     dis (x0, y0) (x1, y1) = sqrt (dx * dx + dy * dy)
>       where dx = x0 - x1
>             dy = y0 - y1

> extend N = ( 0,  1)
> extend S = ( 0, -1)
> extend W = (-1,  0)
> extend E = ( 1,  0)

> navigate nodes (x0,y0) (x1, y1) = 
>   case (backTo . sorted . collided . relative) nodes of
>     [] -> [(x0,y0),(x1,y1)]
>     node@((x2,y2),r):_ -> 
>       if abs (x0 - x1) < 1e-4 && abs (y0 - y1) < 1e-4 
>         then [(x0, y0)]
>         else 
>           case midPoint node (x0,y0) (x1,y1) of
>             Just (x3, y3) -> navigate nodes (x0,y0) (x3,y3) ++ navigate nodes (x3,y3) (x1,y1)
>             Nothing -> [(x0,y0), (x1,y1)]
>   where 
>     (p, a) = polar $ toC (x1, y1)
>     fromC (x :+ y) = (x + x0, y + y0)
>     toC (x, y) = (x - x0) :+ (y - y0)
>     backTo   = map (\((p, t), d) -> (fromC $ mkPolar p (t + a), d))
>     sorted   = sortBy (\u v -> compare (snd $ fst u) (snd $ fst v)) . 
>                map (\(c, d) -> (polar c, d))
>     collided = filter (\(x :+ y, d) -> x >= 0 && x <= p && y >= -(d+tolerance) && y <= (d+tolerance))
>     relative = map ((\((r, b), d) -> (mkPolar r (b - a), d)) . first (polar . toC))

> tolerance = margin / 5

> midPoint ((x0,y0),d) (x1,y1) (x2,y2) = 
>   let (p, a) = polar $ toC (x1, y1)
>       (q, b) = polar $ toC (x2, y2)
>       d' = d + tolerance + tolerance
>       a' = acos (d'/p) `or` acos (d/p)
>       b' = acos (d'/q) `or` acos (d/q)
>       t  = ((a + b) - a' + b') / 2
>       t' = ((a + b) - b' + a') / 2
>       r  = d' / cos (t - b' - b)
>       r' = d' / cos (t' - a' - a)
>   in if isNaN a' || isNaN b' then Nothing
>      else case (isNaN r, isNaN r') of
>             (True, True)  -> Nothing
>             (False, True) -> Just $ fromC $ mkPolar r t
>             (True, False) -> Just $ fromC $ mkPolar r' t'
>             _             -> Just $ fromC $ if abs r + 0.01 < abs r' then mkPolar r t else mkPolar r' t'
>   where
>     fromC (x :+ y) = (x + x0, y + y0)
>     toC (x, y) = (x - x0) :+ (y - y0)
>     or x y = if isNaN x then y else x

> onLocated f g = do
>   (GL.Position mx my) <- liftIO $ GL.get GLFW.mousePos
>   (cx, cy, scale) <- getFactor
>   (row, col) <- getRowCol 
>   let (w, h) = (col * unit, row * unit) 
>       x = (fromIntegral mx - w - cx) / scale / unit 
>       y = (h - fromIntegral my - cy) / scale / unit
>   lift (locateNode (x, y)) >>= \i -> case i of 
>     [] -> g 
>     uid:_ -> f uid

> handleLeftButton reduce = do
>   watch (onButton >=> isPress >=> isButton GLFW.ButtonLeft)
>   GL.Position mx my <- liftIO $ GL.get GLFW.mousePos
>   onLocated (moveOrReduce (mx, my)) (shift (mx, my))
>   where
>     shift (mx, my) = do
>       watch (onPos `orElse` (onButton >=> isRelease)) >>=
>         either track (\_ -> return ())
>       where
>         track (GL.Position x y) = do
>           let dx = 10 * fromIntegral (x - mx) / unit
>               dy = 10 * fromIntegral (my - y) / unit
>           modifyFactor $ \(cx, cy, scale) -> (cx - dx / scale, cy - dy / scale, scale)
>           shift (x, y)
>     moveOrReduce (mx, my) uid = do
>       src <- lift getGrid
>       (ax, ay) <- lift $ lookupNode uid >>= return . maybe (notFound "moveOrReduce:" uid) (fst . fst)
>       watch (onPos `orElse` (onButton >=> isRelease)) >>=
>         either (move src ax ay) (\_ -> reduce uid >> setDirty Dirty)
>       where
>         move src ax ay (GL.Position x y) = do
>           (_, _, scale) <- getFactor
>           let ax' = ax + (realToFrac (x - mx) / scale / unit)
>               ay' = ay + (realToFrac (my - y) / scale / unit)
>           lift $ setGrid src
>           lift $ modifyNodePos uid (\(_, r) -> ((ax', ay'), r))
>           setDirty Lightly
>           watch (onPos `orElse` (onButton >=> isRelease)) >>=
>             either (move src ax ay) (\_ -> return ())
>       
> handleKeys = do
>   watch (onKey >=> isRelease >=> isKey ' ')
>   autoAdjust 
> 
> handleZoom = do
>   oz <- liftIO $ GL.get GLFW.mouseWheel
>   z  <- watch onWheel
>   modifyFactor $ \(x, y, scale) -> (x, y, scale * (speed ** fromIntegral (oz - z)))

> gridBounds :: Monad m => GridT Direction m (Float, Float, Float, Float)
> gridBounds = do
>   pos <- getNodes >>= return . map (fst . snd)
>   return $ foldr updateBounds (0,0,0,0) pos
>   where
>     updateBounds ((x, y), r) (x0, y0, x1, y1) = 
>       (min x0 (x - r), min y0 (y - r), max x1 (x + r), max y1 (y + r))

> autoAdjust = do
>   GL.Size w h <- liftIO $ GL.get GLFW.windowSize 
>   (x0, y0, x1, y1) <- lift $ gridBounds 
>   let cx = unit * (x0 + x1) / 2
>       cy = unit * (y0 + y1) / 2    
>       sx = (x1 - x0 + margin) * unit / realToFrac w
>       sy = (y1 - y0 + margin) * unit / realToFrac h
>       ms = max sx sy  
>       s  = if ms < 1 then 1 else ms
>   modifyFactor $ const (-cx / s, -cy / s, 1/s)

> {-
> renderGrid grid = do 
>   (c0, r0, c1, r1) <- gridBounds 
>       l1 = [(x, r0, x, r1) | x <- [c0 .. c1]] 
>       l2 = [(c0, y, c1, y) | y <- [r0 .. r1]]
>   GL.color gridcolor 
>   GL.renderPrimitive GL.Lines (mapM_ line (l1 ++ l2))
>   mapM_ (\ (x, y) -> GL.preservingMatrix (do
>     GL.translate (vector3 (fromIntegral x) (fromIntegral y) 0)
>     GL.renderPrimitive GL.LineStrip (circle 0.1 0.1 4))) (Set.elems grid)
>   where
>     line (x1, y1, x2, y2) = do
>       GL.vertex (vertex3 (fromIntegral x1) (fromIntegral y1) 0)
>       GL.vertex (vertex3 (fromIntegral x2) (fromIntegral y2) 0)
> -}

> circle :: GLfloat -> GLfloat -> GLfloat -> IO ()
> circle r1 r2 step =
>   let is = take (truncate step + 1) [0, i' .. ]
>       i' = 2 * pi / step
>       vs = [ (r1 * cos i, r2 * sin i) | i <- is ]
>   in mapM_ (\(x, y) -> GL.vertex (GL.Vertex3 x y 0)) vs

> locateAtom atoms mx my = do
>   uids <- locateNode (mx, my) 
>   case uids of
>     [] -> return Nothing
>     i:_ -> return $ atoms IntMap.! i 

Some primilinary font support

> loadFont = do
>   fontpath <- getDataFileName "font.tga"
>   [font] <- GL.genObjectNames 1
>   GL.textureBinding GL.Texture2D $= Just font
>   -- this next line is important, otherwise it won't render the texture!
>   GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
>   GLFW.loadTexture2D fontpath [GLFW.OriginUL, GLFW.NoRescale]
>   return font

> renderChar font c = do
>   let y = fromIntegral (fromEnum c `rem` 16 * 16) / 256
>       x = fromIntegral (fromEnum c `quot` 16 * 8) / 128
>       dx = 8 / 128
>       dy = 16 / 256
>       h = 16 / unit' 
>       w = 8 / unit'
>   GL.preservingMatrix $ GL.renderPrimitive GL.Quads (do
>     GL.texCoord (texCoord2 x y)
>     GL.vertex (vertex3 0 h 0)
>     GL.texCoord (texCoord2 x (y + dy))
>     GL.vertex (vertex3 0 0 0)
>     GL.texCoord (texCoord2 (x + dx) (y + dy))
>     GL.vertex (vertex3 w 0 0)
>     GL.texCoord (texCoord2 (x + dx) y)
>     GL.vertex (vertex3 w h 0))
>   GL.translate (vector3 w 0 0)

> renderString font s = do
>   GL.texture GL.Texture2D $= GL.Enabled
>   GL.textureBinding GL.Texture2D $= Just font
>   GL.preservingMatrix $ mapM_ (renderChar font) s
>   GL.texture GL.Texture2D $= GL.Disabled

> renderText font = mapM_ out . lines
>   where out s = renderString font s >> GL.translate (vector3 0 (-1.25) 0)

> color4 = GL.Color4 :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> GL.Color4 GLfloat
> color3 = GL.Color3 :: GLfloat -> GLfloat -> GLfloat -> GL.Color3 GLfloat
> vector3 = GL.Vector3 :: GLfloat -> GLfloat -> GLfloat -> GL.Vector3 GLfloat
> vertex3 = GL.Vertex3 :: GLfloat -> GLfloat -> GLfloat -> GL.Vertex3 GLfloat
> texCoord2 = GL.TexCoord2 :: GLfloat -> GLfloat -> GL.TexCoord2 GLfloat

> clearcolor = GL.Color4 1 1 1 1
> linecolor = color4 0 0 0 
> gridcolor = color4 0.9 0.9 0.9
> unitcolor = color4 0 0 0
> textcolor = color4 0 0 1
> portcolor = color4 1 0 0

The drawing routings for Nodes

> drawApplicator label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.LineStrip (circle 1.5 1.5 20)
>   GL.translate (vector3 0 1.5 0)
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 0.5 0))
>   GL.translate (vector3 0 (-3) 0)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 (-0.5) 0))
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color unitcolor
>   GL.translate (vector3 1.5 1.5 0)
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0.5 0 0))
>   GL.translate (vector3 (-1.5 - 4 / unit') (-8 / unit') 0)
>   renderString font label

> drawAbstractor label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.LineStrip (circle 1.5 1.5 20)
>   GL.translate (vector3 0 1.5 0)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 0.5 0))
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color unitcolor
>   GL.translate (vector3 0 (-3) 0)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 (-0.5) 0))
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.translate (vector3 1.5 1.5 0)
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0.5 0 0))
>   GL.translate (vector3 (-1.5 - 4 / unit') (- 8 / unit') 0)
>   renderString font label

> drawDelimiter label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.LineStrip (do
>     GL.vertex (vertex3 (-1) 0.2 0)
>     GL.vertex (vertex3 (-1) (-0.2) 0)
>     GL.vertex (vertex3 1 (-0.2) 0)
>     GL.vertex (vertex3 1 0.2 0))
>   GL.renderPrimitive GL.Lines (do
>     GL.vertex (vertex3 0 2 0)
>     GL.vertex (vertex3 0 1 0)
>     GL.vertex (vertex3 0 (-1) 0)
>     GL.vertex (vertex3 0 (-2) 0))
>   GL.translate (vector3 0 1 0)
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.translate (vector3 0 (-2) 0)
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color unitcolor
>   GL.translate (vector3 1.2 (1 - 8 / unit') 0)
>   renderString font label

> drawDuplicator = drawDuplicator' unitcolor
> drawCycle True  = drawDuplicator' (color4 0 1 0)
> drawCycle False = drawDuplicator' (color4 0.5 1 0.5)

> drawDuplicator' labelColor label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.LineStrip (do
>     GL.vertex (vertex3 (-1.5) 1 0)
>     GL.vertex (vertex3 0 (-1) 0)
>     GL.vertex (vertex3 1.5 1 0)
>     GL.vertex (vertex3 (-1.5) 1 0))
>   GL.translate (vector3 (-1) 1 0)
>   GL.renderPrimitive GL.Lines (do
>     GL.vertex (vertex3 0 0 0)
>     GL.vertex (vertex3 0 1 0))
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.translate (vector3 2 0 0)
>   GL.renderPrimitive GL.Lines (do
>     GL.vertex (vertex3 0 0 0)
>     GL.vertex (vertex3 0 1 0))
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.translate (vector3 (-1) (-2) 0)
>   GL.renderPrimitive GL.Lines (do
>     GL.vertex (vertex3 0 0 0)
>     GL.vertex (vertex3 0 (-1) 0))
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color unitcolor
>   GL.translate (vector3 (-4 / unit') (1 - 8 / unit') 0)
>   color labelColor
>   renderString font label

> drawEraser label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.Lines (do
>     GL.vertex (vertex3 0 (-1.2) 0)
>     GL.vertex (vertex3 0 (-2) 0))
>   GL.renderPrimitive GL.LineStrip (circle 1.2 1.2 20)
>   GL.renderPrimitive GL.LineStrip (circle 0.8 0.8 20)
>   GL.translate (vector3 0 (-1.2) 0)
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color unitcolor
>   GL.translate (vector3 (- fromIntegral (length label * 4) / unit') (1.2 - 8 / unit') 0)
>   renderString font label

> drawTwoPin label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.LineStrip (circle 1.5 1.5 20)
>   GL.translate (vector3 0 1.5 0)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 0.5 0))
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color unitcolor
>   GL.translate (vector3 0 (-3) 0)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 (-0.5) 0))
>   GL.renderPrimitive GL.LineStrip (circle 0.2 0.2 10)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0.5 0 0))
>   color textcolor
>   GL.translate (vector3 (- fromIntegral (length label * 4) / unit') (1.5 - 8 / unit') 0)
>   renderString font label

> drawSingle label color font = do
>   color unitcolor
>   GL.renderPrimitive GL.LineStrip (circle 1.5 1.5 20)
>   GL.translate (vector3 0 1.5 0)
>   GL.renderPrimitive GL.Lines (do
>      GL.vertex (vertex3 0 0 0)
>      GL.vertex (vertex3 0 0.5 0))
>   color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   color textcolor
>   GL.translate (vector3 (- fromIntegral (length label * 4) / unit') (- 1.5 - 8 / unit') 0)
>   renderString font label

> polyline = GL.renderPrimitive GL.LineStrip . UV.mapM_ draw
>   where
>     draw (x, y) = GL.vertex (vertex3 (realToFrac x) (realToFrac y) 0)
> 
> polyBezier [] = UV.empty
> polyBezier ps = UV.map (bezier ps) segs
>   where
>     size = wirePoints - 1 -- floor (lineLength ps / margin * 10)
>     segs = UV.generate (size + 1) $ \i -> if i < size then fromIntegral i / fromIntegral size else 1
>     lineLength ((x1,y1):(x2,y2):ps) = 
>       let dx = x2 - x1
>           dy = y2 - y1
>       in sqrt (dx * dx + dy * dy) + lineLength ((x2,y2):ps)
>     lineLength _ = 0
>
> bezier [(x1,y1)] t = (x1, y1)
> bezier [(x1,y1),(x2,y2)] t = (x1 + ((x2 - x1) * t), 
>                               y1 + ((y2 - y1) * t))
> bezier ps t = bezier (map (\ (p, q) -> bezier [p,q] t) (zip ps (tail ps))) t