module Wired.Model where



import Control.Monad.Reader
import Control.Monad.Writer
import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.String

import Data.Hardware.Internal
import Lava.Internal
import Layout.Internal



class CellLibrary lib => WiredLibrary lib
  where
    featureSize :: Res lib Length
      -- Half feature size

    guideLength :: Layer -> Res lib Length
      -- Minimal guide length

    rowHeight :: Res lib Height

    -- XXX Put more design rule information here (e.g. which rows are flipped)?



type Guide = (Signal, Layer_, Direction, Length)
  -- A roting guide associated with a signal.

type Wired lib = LayoutT Guide CellId (Lava lib)
  -- Each box is associated with a cell. Space may be associated with a guide.

class ( MonadLava lib m
      , WiredLibrary lib
      , MonadLayout Guide CellId m
      )
   => MonadWired lib m

instance ( MonadLava lib m
         , WiredLibrary lib
         , MonadLayout Guide CellId m
         )
      => MonadWired lib m



runWired
    :: CellLibrary lib
    => Wired lib a -> (a, (DesignDB lib, Floorplan Guide CellId))

runWired w = (a,(db,fp))
  where
    ((a,fp),db) = runLava $ runLayoutT w



instance MonadLava lib m => MonadLava lib (LayoutT s b m)
  where
    newPrimInpId = lift newPrimInpId
    newCellId    = lift newCellId
    declare      = lift . declare

    listenDecls (LayoutT ma) = LayoutT $ do
        pl <- ask
        ((a,fps),decls) <- lift $ lift $
            listenDecls $ runWriterT $ runReaderT ma pl
        tell fps
        return (a,decls)

    toLava = toLava . liftM fst . runLayoutT



instance Value Length
  where
    value (Length l) = fromIntegral l * 1e-10
  -- Distance is currently represented in units of 0.1nm.



convertGuide
    :: (Position, AbsBlock Guide CellId)
    -> (Signal, (Layer_,Position,Position))

convertGuide bl = (sig,(lay,pos1,pos2))
  where
    (_, Space _ (Just (sig,lay,dir,len))) = bl

    pos1@(x,y) = blockCenter bl

    pos2 = case dir of
      Rightwards -> (x+len, y)
      Leftwards  -> (x+len, y)
      Upwards    -> (x, y-len)
      Downwards  -> (x, y-len)



mkGuideDB
    :: Floorplan Guide CellId -> Map Signal [(Layer_,Position,Position)]

mkGuideDB fp = Map.fromListWith (++)
    [ (sig,[g])
      | bl@(_, Space _ (Just _)) <- fst $ absolutize fp
      , let (sig,g) = convertGuide bl
    ]
  -- Can be conveniently used with totalLookup.



renderWired :: forall lib a . WiredLibrary lib => Name -> Wired lib a -> IO ()
renderWired title w = renderFloorplan_ (feat`divLen`2) title fp []
  where
    feat = result (featureSize :: Res lib Length)
    fp   = snd $ snd $ runWired w
  -- feat/2 is a reasonable scale for lines and names.



fpToLines
    :: (Signal -> Maybe Color)
    -> Floorplan Guide CellId
    -> [([(Position,Position)], Color)]
fpToLines sigCol fp =
    [ (rectiSpanning [pos | (_,pos,_) <- guides], col)
      | (sig,guides) <- Map.toList $ mkGuideDB fp
      , Just col     <- [sigCol sig]
      , length guides >= 2
    ]

  -- Returns the lines between the guides in the floorplan. Guides associated
  -- with the same signal end up in the same cluster. This sort of assumes that
  -- the cells have guides marking the position of each of their pins, otherwise
  -- the lines will only include the guides between the cells (if any), and the
  -- cells will look disconnected when drawn.
  --
  -- The guides are treated as single points regardless of their length.



renderWiredWithNetsCol :: forall lib a . WiredLibrary lib =>
    Maybe Color -> (Tag -> Maybe Color) -> Name -> Wired lib a -> IO ()

renderWiredWithNetsCol defaultCol tagCol title w =
    renderFloorplan_ (feat`divLen`2) title fp (fpToLines sigCol fp)
  where
    feat    = result (featureSize :: Res lib Length)
    (db,fp) = snd $ runWired w

    sigCol sig = case totalLookup sig (sigTagDB db) of
      t:_ -> tagCol t
      _   -> defaultCol


renderWiredWithNets :: forall lib a .
    WiredLibrary lib => Name -> Wired lib a -> IO ()
renderWiredWithNets = renderWiredWithNetsCol (Just black) (const Nothing)



wire__
    :: (MonadWired lib m, PortStruct p Signal t)
    => Direction -> Length -> Layer_ -> Width -> (p -> m p)

wire__ dir len lay pitch = mapPortM $ \sig -> do
    space_ pitch (Just (sig,lay,dir,len))
    return sig



wire_
    :: (MonadWired lib m, PortStruct p Signal t)
    => Direction -> Length -> Layer -> Width -> (p -> m p)

wire_ dir len lay wit = wire__ dir len (icast lay) wit



wireN, wireS, wireW, wireE
    :: (MonadWired lib m, PortStruct p Signal t)
    => Length -> Layer -> Width -> (p -> m p)

wireN = wire_ Upwards
wireS = wire_ Downwards
wireW = wire_ Leftwards
wireE = wire_ Rightwards



guide__ :: forall lib m p t
     . (MonadWired lib m, PortStruct p Signal t)
    => Direction -> Layer_ -> Width -> (p -> m p)

guide__ dir lay pitch = mapPortM $ \sig -> do
    space_
      pitch
      (Just (sig,lay,dir, result (guideLength (icast lay) :: Res lib Length)))
    return sig



guide_
    :: (MonadWired lib m, PortStruct p Signal t)
    => Direction -> Layer -> Width -> (p -> m p)

guide_ dir lay pitch = guide__ dir (icast lay) pitch



guide, guideN, guideS, guideW, guideE
    :: (MonadWired lib m, PortStruct p Signal t)
    => Layer -> Width -> (p -> m p)

-- | To be used when direction doesn't matter (e.g. when @guideLength = 0@).
guide = guide_ Downwards

guideN = guide_ Upwards
guideS = guide_ Downwards
guideW = guide_ Leftwards
guideE = guide_ Rightwards



mkCell
    :: MonadWired lib m
    => Name
    -> Width
    -> Height
    -> m a
    -> m a

mkCell nm x y ma = do
    (a, [Cell cid _ _]) <- listenDecls ma
    block x y nm cid a