Wired-0.2: Data/Hardware/Internal.hs
-- | This module defines types of a general nature that are used by the "Lava",
-- "Layout" and "Wired" libraries. It also defines operations on those types.
module Data.Hardware.Internal where
import Control.Arrow ((***))
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 (Arbitrary, (==>), quickCheck)
--------------------------------------------------------------------------------
-- * Type-parameterized results
--------------------------------------------------------------------------------
-- | The phantom parameter @t@ can be used to pass a type constraint to an
-- overloaded function.
data Res t a = R {result :: !a}
deriving (Eq, Show)
-- Res could be instantiated for Applicative, but that's not always very
-- useful, since it only allows computations where all expressions have the
-- same type of t.
instance Functor (Res t)
where
fmap f (R t) = R (f t)
--------------------------------------------------------------------------------
-- * Difference strings
--------------------------------------------------------------------------------
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 . "\n"
unlineS (s:ss) = s . "\n" . unlineS ss
--------------------------------------------------------------------------------
-- * Identifiers
--------------------------------------------------------------------------------
type Name = String
type Tag = String
--------------------------------------------------------------------------------
-- * Numerical types
--------------------------------------------------------------------------------
class Num n => IntCast n
where
toInt :: n -> Int
fromInt :: Int -> n
instance IntCast Int
where
toInt = id
fromInt = id
instance IntCast Integer
where
toInt = fromInteger
fromInt = toInteger
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 Integer
where
toDouble = fromIntegral
fromDouble = round
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 InPin = InPin Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
-- Identifies a input pin of a cell.
newtype OutPin = OutPin Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
-- Identifies a output pin of a cell.
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 {unLength :: Integer}
deriving
( Eq
, Show
, Ord
, Arbitrary
)
-- The interpretation of a length unit depends on the application. We're
-- using Integer because otherwise we can easily get overflows when two
-- lengths are multiplied. The limit for 32-bit Int is below 50000², which is
-- easily reached, e.g. for a circuit layout with a unit of 0.1nm.
type XPos = Length
type YPos = Length
type Width = Length
type Height = Length
-- Note that distinguishing between different distance types would be quite
-- inconvenient, since they are often used in the same numeric expressions.
class Value v
where
value :: v -> Rational
-- Gives the actual value of the argument.
-- This allows the Num and Fractional instances for Length to abstract away
-- from the length unit used in an application. For example, by defining
--
-- value (Length l) = fromIntegral l * 1e-9
--
-- we get
--
-- fromInteger 1 :: Length ---> Length 1000000000
--
-- The alternative would be to let application libraries export abstract
-- constructor functions for Length, but then we'd still want fromInteger to
-- behave correctly since it gets inserted implicitly if one happens to forget
-- using a constructor function.
instance Value Length => Num Length
where
Length l1 + Length l2 = Length (l1+l2)
Length l1 - Length l2 = Length (l1-l2)
Length l1 * Length l2 = Length (l1*l2)
abs (Length l) = Length (abs l)
signum (Length l) = Length (signum l)
fromInteger i = Length $ round (fromIntegral i / value (Length 1))
instance Value Length => Fractional Length
where
fromRational r = Length $ round (r / value (Length 1))
addLen :: Length -> Length -> Length
addLen (Length l1) (Length l2) = Length (l1+l2)
subLen :: Length -> Length -> Length
subLen (Length l1) (Length l2) = Length (l1-l2)
mulLen :: Integral n => Length -> n -> Length
mulLen (Length l) n = Length (l * toInteger n)
mulLen2 :: Length -> Length -> Integer
mulLen2 (Length l1) (Length l2) = l1*l2
divLen :: Integral n => Length -> n -> Length
divLen (Length l) n = Length (l `div` toInteger n)
-- These operations can be used when there's no Value Length instance in
-- scope.
newtype Layer_ = Layer Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
-- Safe layer type (for internal use).
type Layer = Int
-- Unsafe layer type (for user convenience).
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
newtype TransitionTime = TransitionTime Double
deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
-- [s]
instance Multiply Resistance Capacitance Time
where
r >< c = dcast (r * dcast c)
instance Multiply Capacitance Resistance Time
where
c >< r = r >< c
class DoubleCast t => IsTime t
instance IsTime Time
instance IsTime TransitionTime
timeCast :: (IsTime t1, IsTime t2) => t1 -> t2
timeCast = dcast
--------------------------------------------------------------------------------
-- * Misc. types
--------------------------------------------------------------------------------
type Position = (XPos, YPos)
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. The
-- standard direction is north (see below). This representation is inspired by
-- the DEF file format.
directionAngle :: Direction -> Angle
directionAngle Rightwards = Horizontal
directionAngle Leftwards = Horizontal
directionAngle _ = Vertical
north :: Orientation
north = (False,Upwards)
-- This is taken as the standard orientation.
--------------------------------------------------------------------------------
-- * Total lookup in partial maps
--------------------------------------------------------------------------------
-- | A lookup function that is defined for all keys.
totalLookup :: Ord k => k -> Map k [a] -> [a]
totalLookup k = concat . maybeToList . Map.lookup k
--------------------------------------------------------------------------------
-- * Spanning trees
--------------------------------------------------------------------------------
-- | Computes the minimal spanning tree based on the given distance function.
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 ]
-- XXX Comlexity: O(n²)
euclidDistance :: (Position,Position) -> Double
euclidDistance ((Length x1, Length y1),(Length x2, Length y2)) =
sqrt $ toDouble $ (x1-x2)^2 + (y1-y2)^2
rectiDistance :: (Position,Position) -> Double
rectiDistance ((Length x1, Length y1),(Length x2, Length y2)) =
toDouble $ abs (x1-x2) + abs (y1-y2)
euclidSpanning :: [Position] -> [(Position,Position)]
euclidSpanning = spanning euclidDistance
rectiSpanning :: [Position] -> [(Position,Position)]
rectiSpanning = spanning rectiDistance
-- ** Properties
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 n = spanning dist ps == ls
where
n' = abs n + 1 :: Int -- Positive
scaleUp (x,y) = (x `mulLen` n', y `mulLen` n')
scaleDown (x,y) = (x `divLen` n', y `divLen` n')
ls = map (scaleDown *** scaleDown) $ spanning dist $ map scaleUp ps
-- Only relative distances matter.
prop_span6 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_span6 euclidDistance
quickCheck $ prop_span1 rectiDistance
quickCheck $ prop_span2 rectiDistance
quickCheck $ prop_span3 rectiDistance
quickCheck $ prop_span4 rectiDistance
quickCheck $ prop_span5 rectiDistance
quickCheck $ prop_span6 rectiDistance
--------------------------------------------------------------------------------
-- * Bilinear interpolation
--------------------------------------------------------------------------------
data Table2D i x y q = Table2D
{ tableLengthX :: i
, tableLengthY :: i
, tableAxisX :: i -> x
, tableAxisY :: i -> y
, tableValues :: i -> i -> q
}
-- It is assumed that
-- * tableAxisX is defined for all [0 .. tableLengthX-1]
-- * tableAxisY is defined for all [0 .. tableLengthY-1]
-- * tableValues is defined for all [0 .. tableLengthX-1] and
-- [0 .. tableLengthY-1]
-- * tableAxisX and tableAxisY are both >= 2.
nearestPoints :: (Num i, Ord a) => i -> (i -> a) -> a -> ((i,a),(i,a))
nearestPoints n axis a
| a >= a2 = ((i2,a2), (i1,a1))
| otherwise = nearest i2 a2
where
i1 = n-1
i2 = n-2
a1 = axis i1
a2 = axis i2
nearest 1 ah = ((0, axis 0), (1,ah))
nearest ih ah
| a >= al = ((il,al), (ih,ah))
| otherwise = nearest il al
where
il = ih-1
al = axis il
-- axis is assumed to be monotonous, that is, map axis [0 .. n-1] should
-- return a sorted list.
-- If (ip1,ip2) = nearestPoints n axis a then ip1 and ip2 are the two
-- closest surrounding points (and their indices) of a in the axis. If a is
-- outside the range of the axis, the two closest points are returned.
bilinInterpolate1
:: ( Fractional x
, Fractional y
, Fractional q
, DoubleCast x
, DoubleCast y
, DoubleCast q
)
=> (x,y) -> (x,y) -> (q,q,q,q) -> x -> y -> q
bilinInterpolate1 (x1,y1) (x2,y2) (f_Q11,f_Q21,f_Q12,f_Q22) x y = dcast $
( (toDouble f_Q11 * (x2'-x') * (y2'-y'))
+ (toDouble f_Q21 * (x'-x1') * (y2'-y'))
+ (toDouble f_Q12 * (x2'-x') * (y'-y1'))
+ (toDouble f_Q22 * (x'-x1') * (y'-y1'))
)
/
((x2'-x1') * (y2'-y1'))
where
x' = toDouble x
y' = toDouble y
x1' = toDouble x1
y1' = toDouble y1
x2' = toDouble x2
y2' = toDouble y2
-- Taken from Wikipedia.
findPoints
:: (Num i, Ord x, Ord y)
=> Table2D i x y q -> x -> y -> ((x,y), (x,y), (q,q,q,q))
findPoints (Table2D xLen yLen xAxis yAxis vals) x y =
((x1,y1), (x2,y2), (f_Q11,f_Q21,f_Q12,f_Q22))
where
((ix1,x1),(ix2,x2)) = nearestPoints xLen xAxis x
((iy1,y1),(iy2,y2)) = nearestPoints yLen yAxis y
f_Q11 = vals ix1 iy1
f_Q21 = vals ix2 iy1
f_Q12 = vals ix1 iy2
f_Q22 = vals ix2 iy2
-- Finds the four nearest sorrounding (if possible) points in the table.
-- Returns the coordinates and the values of the points.
bilinInterpolate
:: ( Num i
, Ord x
, Ord y
, Fractional x
, Fractional y
, Fractional q
, DoubleCast x
, DoubleCast y
, DoubleCast q
)
=> Table2D i x y q -> x -> y -> q
bilinInterpolate table x y = bilinInterpolate1 xy1 xy2 fQs x y
where
(xy1,xy2,fQs) = findPoints table x y
-- Works even when coordinates are outside the table.