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)
data Res t a = R {result :: !a}
deriving (Eq, Show)
instance Functor (Res t)
where
fmap f (R t) = R (f t)
instance IsString ShowS
where
fromString = showString
(.+) :: ShowS -> ShowS -> ShowS
(.+) = (.)
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
type Name = String
type Tag = String
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
dcast :: (DoubleCast m, DoubleCast n) => m -> n
dcast = fromDouble . toDouble
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)
newtype OutPin = OutPin Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
newtype PrimInpId = PrimInpId Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
newtype CellId = CellId Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
newtype Length = Length {unLength :: Integer}
deriving
( Eq
, Show
, Ord
, Arbitrary
)
type XPos = Length
type YPos = Length
type Width = Length
type Height = Length
class Value v
where
value :: v -> Rational
instance Value Length => Num Length
where
Length l1 + Length l2 = Length (l1+l2)
Length l1 Length l2 = Length (l1l2)
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))
(/) = error "(/) not defined for Length"
addLen :: Length -> Length -> Length
addLen (Length l1) (Length l2) = Length (l1+l2)
subLen :: Length -> Length -> Length
subLen (Length l1) (Length l2) = Length (l1l2)
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)
newtype Layer_ = Layer Int
deriving (Eq, Show, Ord, Num, Real, Integral, Enum, IntCast)
type Layer = Int
newtype Capacitance = Cap Double
deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
newtype Resistance = Res Double
deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
newtype Time = Time Double
deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
type Delay = Time
newtype TransitionTime = TransitionTime Double
deriving (Eq, Show, Num, Ord, Fractional, IntCast, DoubleCast)
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
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)
directionAngle :: Direction -> Angle
directionAngle Rightwards = Horizontal
directionAngle Leftwards = Horizontal
directionAngle _ = Vertical
north :: Orientation
north = (False,Upwards)
totalLookup :: Ord k => k -> Map k [a] -> [a]
totalLookup k = concat . maybeToList . Map.lookup k
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 ]
euclidDistance :: (Position,Position) -> Double
euclidDistance ((Length x1, Length y1),(Length x2, Length y2)) =
sqrt $ toDouble $ (x1x2)^2 + (y1y2)^2
rectiDistance :: (Position,Position) -> Double
rectiDistance ((Length x1, Length y1),(Length x2, Length y2)) =
toDouble $ abs (x1x2) + abs (y1y2)
euclidSpanning :: [Position] -> [(Position,Position)]
euclidSpanning = spanning euclidDistance
rectiSpanning :: [Position] -> [(Position,Position)]
rectiSpanning = spanning rectiDistance
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
prop_span3 dist ps = length ps > 1 ==> sort (nub ps) == sort (nub qs)
where
qs = concat [ [p,q] | (p,q) <- spanning dist ps ]
prop_span4 dist ps = sum (map dist ls) <= sum (map dist ls')
where
ls = spanning dist ps
ls' = [ (p1,p2) | p1 <- ps, p2 <- ps ]
prop_span5 dist ps n = spanning dist ps == ls
where
n' = abs n + 1 :: Int
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
prop_span6 dist ps = sum (map dist ls) ~= sum (map dist ls')
where
a ~= b = abs (ab) < 0.01
ls = spanning dist ps
ls' = spanning dist (reverse ps)
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
data Table2D i x y q = Table2D
{ tableLengthX :: i
, tableLengthY :: i
, tableAxisX :: i -> x
, tableAxisY :: i -> y
, tableValues :: i -> i -> q
}
nearestPoints :: (Num i, Eq 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 = n1
i2 = n2
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 = ih1
al = axis il
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
findPoints
:: (Num i, Eq 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
bilinInterpolate
:: ( Num i
, Eq 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