-- | 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.