Internal.hs

module Data.Hardware.Internal where



import Data.Function
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.String
import Test.QuickCheck



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



data TypeOf a = T
  -- Used to pass a type constraint to an overloaded function. This is safer
  -- than using undefined.

typeOf :: a -> TypeOf a
typeOf = const T



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



instance IsString ShowS
  where
    fromString = showString

(.+) :: ShowS -> ShowS -> ShowS
(.+) = (.)
  -- Works better than (.) with overloaded string literals.

infixr 9 .+

unwordS :: [ShowS] -> ShowS
unwordS []     = id
unwordS [s]    = s
unwordS (s:ss) = s .+ " " .+ unwordS ss

unlineS :: [ShowS] -> ShowS
unlineS []     = id
unlineS [s]    = s
unlineS (s:ss) = s . "\n" . unlineS ss



newtype Name = Name {unName :: String}
        deriving (Eq, Ord, IsString)

newtype Tag = Tag {unTag :: String}
        deriving (Eq, Ord, IsString)

instance Show Name
  where
    show = unName

instance Show Tag
  where
    show = unTag



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



class Num n => IntCast n
  where
    toInt   :: n -> Int
    fromInt :: Int -> n

instance IntCast Int
  where
    toInt   = id
    fromInt = id

instance IntCast Double
  where
    toInt   = round
    fromInt = fromIntegral



class Num n => DoubleCast n
  where
    toDouble   :: n -> Double
    fromDouble :: Double -> n

instance DoubleCast Double
  where
    toDouble   = id
    fromDouble = id

instance DoubleCast Int
  where
    toDouble   = fromIntegral
    fromDouble = round

instance DoubleCast Rational
  where
    toDouble   = fromRational
    fromDouble = toRational

icast :: (IntCast m, IntCast n) => m -> n
icast = fromInt . toInt
  -- Conversion between different integer types

dcast :: (DoubleCast m, DoubleCast n) => m -> n
dcast = fromDouble . toDouble
  -- Conversion between different floting point types



class Multiply n1 n2 n3 | n1 n2 -> n3, n1 n3 -> n2, n2 n3 -> n1
  where
    (><) :: n1 -> n2 -> n3

instance DoubleCast n => Multiply Double n n
  where
    d >< n = dcast d * n

instance DoubleCast n => Multiply n Double n
  where
    n >< d = n * dcast d



newtype Pin = Pin Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- Identifies a pin of a cell.

newtype ConstId = ConstId Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- Identifies a constant signal.

newtype PrimInpId = PrimInpId Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- Identifies a primary input signal.

newtype CellId = CellId Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- Identifies a cell.



newtype Length = Length Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- [nm]

newtype Width = Width Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- [nm]

newtype Height = Height Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
  -- [nm]



newtype Layer = Layer Int
        deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)



newtype Capacitance = Cap Double
        deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
  -- [F]

newtype Resistance = Res Double
        deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
  -- [Ω]

newtype Time = Time Double
        deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
  -- [s]

type Delay = Time

instance Multiply Resistance Capacitance Time
  where
    r >< c = dcast (r * dcast c)

instance Multiply Capacitance Resistance Time
  where
    c >< r = r >< c



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



type Position = (Width,Height)
type Size     = (Width,Height)



data Angle = Horizontal | Vertical
     deriving (Eq, Show)

data Direction = Rightwards | Leftwards | Upwards | Downwards
     deriving (Eq, Show)

type Orientation = (Bool, Direction)
  -- The bool tells whether or not the object is flipped around the y-axis.



directionAngle :: Direction -> Angle
directionAngle Rightwards = Horizontal
directionAngle Leftwards  = Horizontal
directionAngle _          = Vertical

north :: Orientation
north = (False,Upwards)
  -- This is taken as the standard orientation.



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



totalLookup :: Ord k => k -> Map k [a] -> [a]
totalLookup k = concat . maybeToList . Map.lookup k
  -- A lookup function that is defined for all keys.



--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------



spanning ::
    ((Position,Position) -> Double) -> [Position] -> [(Position,Position)]

spanning _    []     = []
spanning dist (p:ps) = span ps [p] []
  where
    span [] _  ls = ls
    span ps qs ls = span (delete p ps) (p:qs) ((p,q):ls)
      where
        (p,q) = minimumBy (compare `on` dist) [ (p,q) | p <- ps, q <- qs ]

  -- Computes the minimal spanning tree based on the given distance function.
  -- *** Comlexity: O(n²)



euclidDistance :: (Position,Position) -> Double
euclidDistance ((x1,y1),(x2,y2)) =
    sqrt $ fromIntegral $ (x1-x2)^2 + icast ((y1-y2)^2)

rectiDistance :: (Position,Position) -> Double
rectiDistance ((x1,y1),(x2,y2)) = icast (abs (x1-x2)) + icast (abs (y1-y2))

euclidSpanning :: [Position] -> [(Position,Position)]
euclidSpanning = spanning euclidDistance

rectiSpanning :: [Position] -> [(Position,Position)]
rectiSpanning = spanning rectiDistance



deriving instance Arbitrary Width
deriving instance Arbitrary Height



prop_span1 dist ps =
    length ps > 0 ==> length (spanning dist ps) == (length ps - 1)

prop_span2 dist ps = ps == nub ps ==> ls == nub ls
  where
    ls = spanning dist ps
  -- No duplicates in input means no dups. in output

prop_span3 dist ps = length ps > 1 ==> sort (nub ps) == sort (nub qs)
  where
    qs = concat [ [p,q] | (p,q) <- spanning dist ps ]
  -- The set of points is unchanged

prop_span4 dist ps = sum (map dist ls) <= sum (map dist ls')
  where
    ls  = spanning dist ps
    ls' = [ (p1,p2) | p1 <- ps, p2 <- ps ]  -- The complete graph

prop_span5 dist ps = sum (map dist ls) ~= sum (map dist ls')
  where
    a ~= b = abs (a-b) < 0.01

    ls  = spanning dist ps
    ls' = spanning dist (reverse ps)
  -- Sanity check



checkAll = do
    quickCheck $ prop_span1 euclidDistance
    quickCheck $ prop_span2 euclidDistance
    quickCheck $ prop_span3 euclidDistance
    quickCheck $ prop_span4 euclidDistance
    quickCheck $ prop_span5 euclidDistance

    quickCheck $ prop_span1 rectiDistance
    quickCheck $ prop_span2 rectiDistance
    quickCheck $ prop_span3 rectiDistance
    quickCheck $ prop_span4 rectiDistance
    quickCheck $ prop_span5 rectiDistance