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.

> module Diagram where

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

> import Data.IntMap as IntMap hiding (filter, map)
> import qualified Data.Set as Set 
> import Data.IORef
> import Data.Maybe (fromMaybe, fromJust)

> import System.IO.Unsafe

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

debugger 

> debug = seq . unsafePerformIO . (putStrLn $!!)
> debug1 s v = seq (unsafePerformIO $ putStrLn $!! (s ++ show v)) v
> ($!!) f s = seq (length s) (f s)

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

> instance Eq Atom where
>    a == b = atomID a == 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 Show Port where
>   show p = "(" ++ show (atomID (owner p)) ++ "-" ++ 
>            show (atomID (owner (portEnd p))) ++
>            ", dir=" ++ show (portDir p) ++ ")"

> portdir' d p = 
>   let a = owner p
>   in toEnum ((fromEnum (portDir p) + fromEnum d) `mod` 4)
>
> portdir posMap p = 
>   let a = owner p
>       d = maybe N snd (IntMap.lookup (atomID a) posMap)
>   in portdir' d p
>
> portpos' dir (x, y) = 
>   let r = sqrt $ fromIntegral (x * x + y * y)
>       t = asin (fromIntegral 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 = (round (r * cos t), round (r * sin t))

> portpos posMap p = 
>   let a = owner p
>       d = maybe N snd (IntMap.lookup (atomID a) posMap)
>    in portpos' d (portPos p)

> type Position = (Int, Int)
> type Positions = IntMap (Position, Direction)
> type Size = (Int, Int)                -- radius in X and Y direction

> data Direction = N | W | S | E deriving (Show, Eq, Enum, Ord)

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

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

A grid is a set containing all occupied positions.

> type Grid = Set.Set Position

> occupied :: Grid -> Position -> Size -> Bool
> occupied grid (x, y) (w, h) = 
>   any (flip Set.member grid) [(x + i, y + j) | i <- [-(w + margin) .. (w + margin)], j <- [-(h + margin) .. (h + margin)]]

> occupy :: Grid -> Position -> Size ->  Grid
> occupy grid (x, y) (w, h) = 
>   foldr Set.insert grid 
>     [(x + i, y + j) | i <- [-w .. w], j <- [-h .. h]]

> position :: Grid -> Position -> Position -> Size -> Position
> position grid (x, y) (dx, dy) (w, h) = 
>   if occupied grid (x, y) (w, h) 
>     then position grid (x + dx * margin, y + dy * margin) (dx, dy) (w, h)
>     else (x, y)

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 such that it doesn't overlap with anything.

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

  4 repeat until nothing's left.

> layout :: [Int] -> (Positions, Grid) -> [Port] -> 
>           (Positions, Grid)
> layout visited sol [] = sol
> layout visited (posMap, grid) (p:ps) = 
>   let a = owner p
>       i = atomID a
>       ((x, y), _) = posMap ! i
>       q = portEnd p
>       b = owner q
>       j = atomID b
>       d = maybe (autorotate (portdir posMap p) (portdir' N q)) snd 
>             (IntMap.lookup j posMap)
>       (xd, yd, dx, dy) = placement (portdir posMap p) (portdir' d q)
>                                    (portpos posMap p) (portpos' d (portPos q))
>       (aw, ah) = atomSize a
>       (bw, bh) = atomSize b
>       pos = position grid (x + xd * (aw + bw + margin) + dx, 
>               y + yd * (ah + bh + margin) + dy) (xd, yd) (bw, bh)
>       rs = filter (/= q) (atomPorts b)
>       posMap' = insert j (pos, d) posMap 
>   in if elem j visited
>     then layout visited (posMap, grid) ps
>     else case IntMap.lookup j posMap of
>       Just (pos, _) -> layout (atomID a : visited) (posMap, occupy grid pos (bw, bh)) (rs ++ ps)
>       Nothing  -> layout (atomID a : visited) (posMap', occupy grid pos (bw, bh)) (rs ++ ps)

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

> placement N N (x1, y1) (x2, y2) = (signum x1, -1, x1 - x2, y1 - y2)
> placement N S (x1, y1) (x2, y2) = (signum x1,  1, x1 - x2, 0)
> placement S S (x1, y1) (x2, y2) = (signum x1,  1, x1 - x2, y1 - y2)
> placement S N (x1, y1) (x2, y2) = (signum x1, -1, x1 - x2, 0)
> placement E E (x1, y1) (x2, y2) = (-1, signum y1, x1 - x2, y1 - y2)
> placement E W (x1, y1) (x2, y2) = ( 1, signum y1, 0, y1 - y2)
> placement W W (x1, y1) (x2, y2) = ( 1, signum y1, x1 - x2, y1 - y2)
> placement W E (x1, y1) (x2, y2) = (-1, signum y1, 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 = 2
> unit = 12 :: GLfloat         -- grid unit is 10 pixel

> showDiagram = undefined

> initWindow w h = do
>   let row = realToFrac h / unit / 2
>       col = realToFrac w / unit / 2
>   writeIORef rowcolRef (row, col)
>   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
>   writeIORef fontRef (Just font) 
>   GLFW.windowSizeCallback $= reshape

too troublesome to carry this around, so make it IORef!

> fontRef = unsafePerformIO (newIORef Nothing)
> rowcolRef = unsafePerformIO (newIORef (0, 0))

> reshape (GL.Size w h) = 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)
>   GL.ortho2D (-c) c (-r) r
>   writeIORef rowcolRef (row, col)

> renderDiagram posMap d = 
>   let starts = startAtoms d
>       pos = map (\a -> (maybe Nothing (Just . fst) (IntMap.lookup (atomID a) posMap), a)) starts
>       pg@(posMap', grid) = foldr (\ (p, a) (pm, gr) -> 
>           let i = atomID a
>               (wa, ha) = atomSize a
>               mx = maximum (0 : map fst (Set.elems gr))
>               p' = fromMaybe (mx + 4, 0) p
>               dir = maybe N snd (IntMap.lookup i pm)
>           in layout [] (insert i (p', dir) pm, occupy gr p' (wa, ha)) (atomPorts a)) (posMap, Set.empty) pos
>       (io, grid') = render pg
>   in ((posMap', grid'), io)
>   where 
>     render (posMap, grid) = foldWithKey (\i a (io, grid) -> 
>       let ((x, y), d) = posMap ! i
>           (lines, grid') = foldr (\ (p, q) (ls, grid) -> 
>               let (l, grid') = runLine grid p q
>               in (l:ls, grid')) ([], grid)
>             [ ((x + px, y + py, portdir posMap p),
>               (x' + qx, y' + qy, portdir posMap q))
>             | p <- atomPorts a,
>               let q = portEnd p, 
>               let j = atomID (owner q),
>               i < j || (i == j && portPos p <= portPos q),
>               let ((x', y'), _) = posMap ! j,
>               let (px, py) = portpos posMap p,
>               let (qx, qy) = portpos posMap q ]
>           action = do 
>             GL.preservingMatrix (do
>               GL.translate (vector3 (fromIntegral x) (fromIntegral y) 0) 
>               let o = maybe N snd (IntMap.lookup i posMap)
>               GL.rotate (realToFrac (90 * fromEnum o)) (vector3 0 0 1)
>               atomDraw a) 
>             GL.preservingMatrix $ mapM_ (\l -> do
>               GL.color linecolor
>               GL.renderPrimitive GL.LineStrip $ mapM_ (\ (x0, y0) ->
>                 GL.vertex (vertex3 (fromIntegral x0) (fromIntegral y0) 0)) l) lines
>             io
>       in (action, grid')) (return (), grid) (allAtoms d)

The following is a very naive but fast line layout algorithm.

> runLine grid (x0, y0, d0) (x1, y1, d1) = 
>   let (var, f) = flexLine (x0, y0, d0) (x1, y1, d1)
>       lines = map f (iterateList var)
>       g l = let l' = mark l --(take (length l - 2) (tail l))
>              in Set.fromList l' --Set.\\ Set.fromList (take 3 l' ++ drop (length l' - 3) l')
>       LineSeg (l, s) _ = minimum $ take 10 $
>                map (\x -> let s = g x in LineSeg (x, s) (Set.size (Set.intersection grid s))) lines
>   in (l, Set.union grid s)
>   where
>     mark [] = []
>     mark [(x0,y0)] = []
>     mark l@((x0,y0):(x1,y1):rs) = Set.toList $ Set.fromList $
>       [(x, y) | x <- segment x0 x1, y <- segment y0 y1] ++ mark (tail l)
>     segment x0 x1 | x0 == x1 = [x0]
>     segment x0 x1 = x0 : segment (x0 + signum (x1 - x0)) x1

> data LineSeg a b = LineSeg a b deriving (Eq, Show)
> instance (Eq a, Eq b, Ord b) => Ord (LineSeg a b) where
>   compare (LineSeg _ x) (LineSeg _ y) = compare x y

> running grid l = running' l
>   where
>     running' l@(p@(x0, y0):q@(x1, y1):r@(x2, y2):xs) = 
>       (Set.member p grid && Set.member q grid && Set.member r grid && 
>        (((x0 == x1) && (x1 == x2) && (y1 + y1 == y0 + y2)) || 
>         ((y0 == y1) && (y1 == y2) && (x1 + x1 == x0 + x2)))) || running' (tail l)
>     running' _ = False

> iterateList :: [[a]] -> [[a]]
> iterateList l = [ zipWith (!!) l idx | idx <- dia (length l) 0 ]

> dia d n = dia' d n ++ dia d (n + 1)
>   where
>     dia' 1 n = [[n]]
>     dia' d n = [ u : v | u <- [0 .. n], v <- dia' (d - 1) (n - u)]

> flexLine :: (Int, Int, Direction) -> (Int, Int, Direction) -> 
>             ([[Int]], [Int] -> [(Int, Int)])
> flexLine (x0, y0, N) (x1, y1, N) = 
>   ([inc (max y0 y1)], \[y] -> [(x0, y0), (x0, y), (x1, y), (x1, y1)])
> flexLine (x0, y0, S) (x1, y1, S) = 
>   ([dec (min y0 y1)], \[y] -> [(x0, y0), (x0, y), (x1, y), (x1, y1)])
> flexLine (x0, y0, E) (x1, y1, E) = 
>   ([inc (max x0 x1)], \[x] -> [(x0, y0), (x, y0), (x, y1), (x1, y1)])
> flexLine (x0, y0, W) (x1, y1, W) = 
>   ([dec (min x0 x1)], \[x] -> [(x0, y0), (x, y0), (x, y1), (x1, y1)])
> flexLine (x0, y0, N) (x1, y1, E) = 
>   ([inc y0, inc x1], \[y, x] -> [(x0, y0), (x0, y), (x, y), (x, y1), (x1, y1)])
> flexLine (x0, y0, N) (x1, y1, W) = 
>   ([inc y0, dec x1], \[y, x] -> [(x0, y0), (x0, y), (x, y), (x, y1), (x1, y1)])
> flexLine (x0, y0, S) (x1, y1, E) = 
>   ([dec y0, inc x1], \[y, x] -> [(x0, y0), (x0, y), (x, y), (x, y1), (x1, y1)])
> flexLine (x0, y0, S) (x1, y1, W) = 
>   ([dec y0, dec x1], \[y, x] -> [(x0, y0), (x0, y), (x, y), (x, y1), (x1, y1)])
> flexLine (x0, y0, N) (x1, y1, S) | y0 > y1 = 
>   ([inc y0, alt ((x0 + x1) `div` 2), dec y1], 
>   \[y, x, y'] -> [(x0, y0), (x0, y), (x, y), (x, y'), (x1, y'), (x1, y1)])
> flexLine (x0, y0, N) (x1, y1, S) = 
>   ([alt ((y0 + y1) `div` 2)], 
>   \[y] -> [(x0, y0), (x0, y), (x1, y), (x1, y1)])
> flexLine (x0, y0, E) (x1, y1, W) | x0 > x1 = 
>   ([inc x0, alt ((y0 + y1) `div` 2), dec x1], 
>   \[x, y, x'] -> [(x0, y0), (x, y0), (x, y), (x', y), (x', y1), (x1, y1)])
> flexLine (x0, y0, E) (x1, y1, W) = 
>   ([alt ((x0 + x1) `div` 2)], 
>   \[x] -> [(x0, y0), (x, y0), (x, y1), (x1, y1)])
> flexLine p q = flexLine q p

> inc x = [x..]
> dec x = [x, x-1 ..]
> alt x = alt' (x : inc x) (tail (dec x))
>   where alt' (i:is) (j:js) = i : j : alt' is js


> data UserAction = UserAction (IO (UserAction, IO ()))

> lastKeyTime = unsafePerformIO (newIORef 0)
> readKeyPress l = do
>   t <- GL.get GLFW.time
>   t0 <- readIORef lastKeyTime
>   k <- readKeyPress' l
>   case k of
>     Nothing -> return Nothing
>     _ -> if t - t0 < 0.4
>       then return Nothing
>       else do
>         writeIORef lastKeyTime t
>         return k
>   where 
>     readKeyPress' :: Enum a => [a] -> IO (Maybe a)
>     readKeyPress' [] = return Nothing
>     readKeyPress' (k:ks) = do
>       p <- GLFW.getKey k
>       if p == GLFW.Press then return (Just k) else readKeyPress' ks

> handleUserAction factor (keySet, keyHandle) reduce d = do
>   let r@((_, grid), _) = renderDiagram empty d
>   autoAdjust grid factor
>   buttonReleased d r
>   where
>     buttonReleased d r@((posMap, grid), render) = do
>       left <- GLFW.getMouseButton GLFW.ButtonLeft
>       right <- GLFW.getMouseButton GLFW.ButtonRight
>       zoom <- GLFW.getKey GLFW.LALT
>       shift <- GLFW.getKey GLFW.LCTRL
>       case (left == GLFW.Press, right == GLFW.Press, 
>             zoom == GLFW.Press, shift == GLFW.Press) of
>         (True, _, False, False) -> processButton GLFW.ButtonLeft
>         (_, _, True, False) -> processZoom GLFW.LALT
>         (_, _, False, True) -> processShift GLFW.LCTRL
>         (_, True, _, _) -> processButton GLFW.ButtonRight
>         _ -> do
>             k <- readKeyPress (' ' : keySet)
>             case k of 
>               Just k' ->
>                 if k' == ' '
>                   then do
>                     --writeIORef factor (0,0,1)
>                     autoAdjust grid factor
>                     return (UserAction $ buttonReleased d r, render)
>                   else do
>                     (d', r'@(_, render')) <- keyHandle k' d r
>                     return (UserAction $ buttonReleased d' r', render')
>               Nothing -> return (UserAction $ buttonReleased d r, render)
>       where
>         processButton but = do
>           GL.Position mx my <- GL.get GLFW.mousePos
>           (cx, cy, scale) <- readIORef factor
>           (row, col) <- readIORef rowcolRef
>           let (w, h) = (col * unit, row * unit) 
>               atom = locateAtom (allAtoms d) posMap 
>                     ((fromIntegral mx - w - cx) / scale / unit) 
>                     ((h - fromIntegral my - cy) / scale / unit)
>           t0 <- GL.get GLFW.time
>           return (UserAction $ buttonPressed but
>                   d r atom (mx, my) t0, render)
>
>         processZoom key = do
>           GL.Position mx my <- GL.get GLFW.mousePos
>           t0 <- GL.get GLFW.time
>           return (UserAction $ mouseZoom key (mx, my, mx, my, t0) d r, render)

>         processShift key = do
>           GL.Position mx my <- GL.get GLFW.mousePos
>           t0 <- GL.get GLFW.time
>           return (UserAction $ mouseShift key (mx, my, mx, my, t0) d r, render)

>     buttonPressed but d r@((posMap, _), render) atom mp t0 = do
>       status <- GLFW.getMouseButton but
>       if status == GLFW.Release
>         then case atom of
>           Just a -> 
>             if but == GLFW.ButtonRight
>               then do
>                 (ids, d') <- reduce (atomID a)
>                 let posMap' = filterWithKey (\i _ -> elem i ids) posMap
>                     r'@(_, render') = renderDiagram posMap' d'
>                 return (UserAction $ buttonReleased d' r', render')
>               else do
>                 let (pos, o) = posMap ! atomID a
>                     o' = toEnum ((fromEnum o + 1) `mod` 4)
>                     posMap' = adjust (const (pos, o')) (atomID a) posMap
>                     r'@(_, render') = renderDiagram posMap' d
>                 return (UserAction $ buttonReleased d r', render')
>           _ -> return (UserAction $ buttonReleased d r, render)
>         else do
>           t1 <- GL.get GLFW.time
>           case (t1 - t0 > 0.4, atom) of
>             (True, Just a) -> do
>               let ((x, y), _) = posMap ! atomID a
>               return (UserAction $ buttonHolding but d r a ((x, y), mp), render)
>             _ -> return (UserAction $ buttonPressed but d r atom mp t0, render)
>     buttonHolding but d r@((posMap, _), _) atom s@((ax, ay), (mx, my)) = do
>       status <- GLFW.getMouseButton but
>       GL.Position mx' my' <- GL.get GLFW.mousePos
>       (_, _, scale) <- readIORef factor
>       let ax' = ax + truncate (realToFrac (mx' - mx) / scale / unit)
>           ay' = ay + truncate (realToFrac (my - my') / scale / unit)
>           i = atomID atom
>           posMap' = adjust (\ ((x, y), d) -> ((ax', ay'), d)) i posMap 
>           r'@(_, render) = renderDiagram posMap' d
>       if status == GLFW.Release
>         then return (UserAction $ buttonReleased d r', render)
>         else return (UserAction $ buttonHolding but d r' atom s, render)
>
>     mouseZoom key state d r = do
>       status <- GLFW.getKey key
>       if status == GLFW.Release 
>         then return (UserAction $ buttonReleased d r, snd r)
>         else do
>           (dx, dy, state') <- relativeSpeed state
>           (cx, cy, scale) <- readIORef factor
>           let scale' = scale * (dx - dy) / 100
>           writeIORef factor (cx, cy, scale + scale')
>           return (UserAction $ mouseZoom key state' d r, snd r)

>     mouseShift key state d r = do
>       status <- GLFW.getKey key
>       if status == GLFW.Release
>         then return (UserAction $ buttonReleased d r, snd r)
>         else do
>           (dx, dy, state') <- relativeSpeed state
>           (cx, cy, scale) <- readIORef factor
>           writeIORef factor (cx - dx, cy - dy, scale)
>           return (UserAction $ mouseShift key state' d r, snd r)

>     relativeSpeed (mx, my, x0, y0, t0) = do
>       GL.Position x y <- GL.get GLFW.mousePos
>       t1 <- GL.get GLFW.time
>       let (mx', my') = if signum (x0 - mx) * signum (x - x0) < 0 ||
>                           signum (y0 - my) * signum (y - y0) < 0
>                          then (x0, y0) else (mx, my)
>           dx = fromIntegral (x - mx') / realToFrac (t1 - t0) / 1000
>           dy = fromIntegral (my' - y) / realToFrac (t1 - t0) / 1000
>       return (dx, dy, (mx', my', x, y, t1))

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

> gridBounds grid = 
>   let (xs, ys) = unzip (Set.elems grid)
>   in (minimum xs, minimum ys, maximum xs, maximum ys)
>   
> renderGrid grid = do 
>   let (c0, r0, c1, r1) = gridBounds grid       
>       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 posMap mx my = locate (toList posMap)
>   where
>     locate [] = Nothing
>     locate ((i, ((x, y), _)):rs) =  
>       let a = atoms ! i
>       in if inside (x, y) (atomSize a) then Just a else locate rs
>     inside (x, y) (w, h) =
>       (realToFrac (x - w) <= mx) &&
>       (realToFrac (x + w) > mx) &&
>       (realToFrac (y - w) <= my) &&
>       (realToFrac (y + w) > my)

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 s = do
>   Just font <- readIORef fontRef
>   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 = mapM_ out . lines
>   where out s = renderString s >> GL.translate (vector3 0 (-1.25) 0)

> 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 = color3 0 0 0
> gridcolor = color3 0.9 0.9 0.9
> unitcolor = color3 0 0 0
> textcolor = color3 0 0 1
> portcolor = color3 1 0 0

The drawing routings for Nodes

> drawApplicator label = do
>   GL.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))
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.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 label

> drawAbstractor label = do
>   GL.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))
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.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 label

> drawDelimiter label = do
>   GL.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)
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.color unitcolor
>   GL.translate (vector3 1.2 (1 - 8 / unit) 0)
>   renderString label

> drawDuplicator label = do
>   GL.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))
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.color unitcolor
>   GL.translate (vector3 (-4 / unit) (1 - 8 / unit) 0)
>   renderString label

> drawEraser label = do
>   GL.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)
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.color unitcolor
>   GL.translate (vector3 (- fromIntegral (length label * 4) / unit) (1.2 - 8 / unit) 0)
>   renderString label

> drawTwoPin label = do
>   GL.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))
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.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))
>   GL.color textcolor
>   GL.translate (vector3 (- fromIntegral (length label * 4) / unit) (1.5 - 8 / unit) 0)
>   renderString label

> drawSingle label = do
>   GL.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))
>   GL.color portcolor
>   GL.renderPrimitive GL.Polygon (circle 0.2 0.2 10)
>   GL.color textcolor
>   GL.translate (vector3 (- fromIntegral (length label * 4) / unit) (- 1.5 - 8 / unit) 0)
>   renderString label