INblobs-0.1.1: src/Ports.hs

module Ports 
    ( Port
    , Ports
    , PortName
    , PortZone(..)

    , isTheSameAs
    , isInterfacePort
    , drawPorts
    , drawPort 
    , drawFig 
    , drawPrincipalPort 
    , portZone 
    , isUp
    ) where

import Math
import Constants
import Shape
import CommonIO
import Colors
import Graphics.UI.WX as WX
import Graphics.UI.WXCore

{- | 'Ports' represents the extra information for a generalization of nodes in which a node have special points where it can conect with other nodes (more conrrectly the ports of other nodes). 

Each port is represented by its name and a point relative to the center of node shape.
-}

type PortName = String
type Port = (PortName, DoublePoint)

type Ports = [Port]

-- | Equality on ports. Right now it is exactly the same as @(==)@.
isTheSameAs :: Port -> Port -> Bool
isTheSameAs = (==)

isInterfacePort :: PortName -> Bool
isInterfacePort = (== "interface")

drawPorts :: Size -> DC () -> DoublePoint -> Ports -> [Prop (DC ())] -> IO ()
drawPorts ppi dc centre ports options =  
  case ports of 
    [("interface",position)] -> drawPrincipalPort ppi dc centre optionsIP position
    p  -> when (not $ null p)
                    (if hasPrincipalPorts
                     then do drawPrincipalPort ppi dc centre optionsPP (snd $ head p)
                             mapM_ ( drawPort ppi dc centre optionsP . snd ) (tail p)
                     else mapM_ ( drawPort ppi dc centre optionsP . snd ) p
                    )

  where options' = [ brushKind  := BrushSolid ] ++ options
        optionsP  = [ brushColor := kPortBrushColor
                    , penColor   := kPortPenColor 
                    ] ++ options'
        optionsPP = [ brushColor := kPrincipalPortBrushColor 
                    , penColor   := kPrincipalPortPenColor 
                    ] ++ options'
        optionsIP = [ brushColor := kInterfacePortBrushColor 
                    , penColor   := kInterfacePortPenColor 
                    ] ++ options'

drawPort :: Size -> DC () -> DoublePoint -> [Prop (DC ())] -> DoublePoint -> IO ()
drawPort ppi dc centre options point =
    WX.circle dc 
              (logicalToScreenPoint ppi $ translate centre point)
              (logicalToScreenX ppi kPortRadius)
              options

drawPrincipalPort :: Size -> DC () -> DoublePoint -> [Prop (DC ())] -> DoublePoint -> IO ()
drawPrincipalPort ppi dc centre options point = 
   WX.polygon dc points options
   where centro = logicalToScreenPoint ppi $ translate centre point
         param  = kPrincipalPortSize
         points = 
            [ pointMove (vector param     param)     centro
            , pointMove (vector param     (- param)) centro
            , pointMove (vector (- param) (- param)) centro
            , pointMove (vector (- param) param)     centro
            ]

drawFig :: DC () -> Rect -> Shape -> Ports -> [Prop (DC ())] -> IO ()
drawFig dc r shape ports options = 
  do{
    -- Scale if the DC we are drawing to has a different PPI from the screen
    ; dcPPI <- dcGetPPI dc
    ; screenPPI <- getScreenPPI
    ; when (dcPPI /= screenPPI) $
        dcSetUserScale dc
            (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI ))
            (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI ))

    -- Set font
    ; set dc [ fontFamily := FontDefault, fontSize := 10 ]

    ; let ppi = screenPPI
          -- center of drawing area
          center = screenToLogicalPoint ppi $ rectCentralPoint r 

    ; logicalDraw ppi dc center shape options
    ; drawPorts ppi dc center ports options
    }


data PortZone = Ztop | Zbottom | Zleft | Zright deriving (Show)

-- | Divides the 2D space with y=x and y=-x rects 
portZone :: Port -> PortZone
portZone (_, DoublePoint x y) | y >  x && y <= -x = Zleft
                              | y >= x && y >  -x = Zbottom
                              | y <  x && y >= -x = Zright
                              | y <= x && y <  -x = Ztop

-- | A different division in 2D space; the port is in the upper part of the node?
isUp :: Port -> Bool
isUp (_, DoublePoint _ y) = y <= 0