uni-htk-2.2.0.0: HTk/Kernel/Geometry.hs
{-# LANGUAGE FlexibleInstances #-}
-- | The @module Geometry@ exports basic geometric types and
-- functionality.
module HTk.Kernel.Geometry (
Distance(..),
Size,
Coord,
Position,
Geometry,
cm, pp, mm, ic, tocm, toinch
) where
import HTk.Kernel.GUIValue
import Data.Char
-- -----------------------------------------------------------------------
-- Position/Size
-- -----------------------------------------------------------------------
-- | The @Position@ - a pair of two @Distance@ values.
type Position = (Distance, Distance)
-- | The @Size@ datatype - a pair of two @Distance@
-- values.
type Size = (Distance, Distance)
-- | The @Point@ datatype.
data Point = Point (Distance, Distance)
-- | Internal.
instance GUIValue (Distance,Distance) where
-- Internal.
cdefault = (cdefault,cdefault)
-- Internal.
toGUIValue v = GUIVALUE HaskellTk (show (Point v))
-- Internal.
maybeGUIValue (GUIVALUE _ s) =
case [x | (Point x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
-- | Internal.
instance Read Point where
-- Internal.
readsPrec p b =
case (readsPrec p b) of
[(x,xs)] -> (case (readsPrec p xs) of
[(y,ys)] -> [(Point (x,y),ys)]
_ -> []
)
_ -> []
-- | Internal.
instance Show Point where
showsPrec d (Point (x,y)) r = show x ++ " " ++ show y ++ r
-- -----------------------------------------------------------------------
-- Geometry
-- -----------------------------------------------------------------------
-- | The Geometry datatype - normally representing position, width and
-- height.
type Geometry = (Distance, Distance, Distance, Distance)
data Geometry' = Geometry' Geometry
-- | Internal.
instance GUIValue (Distance, Distance, Distance, Distance) where
cdefault = (cdefault, cdefault, cdefault, cdefault)
toGUIValue v = GUIVALUE HaskellTk (show (Geometry' v))
maybeGUIValue (GUIVALUE _ s) =
case [x | (Geometry' x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
-- | Internal.
instance Show Geometry' where
-- Internal.
showsPrec d (Geometry' (w, h, x, y)) r =
show w ++ "x" ++ show h ++ "+" ++ show x ++ "+" ++ show y ++ r
-- | Internal.
instance Read Geometry' where
-- Internal.
readsPrec p str =
case readsPrec p str of
[(w,s')] -> readsPrecX1 p s' w
_ -> []
where
readsPrecX1 p s w =
case (dropWhile isSpace s) of
('x':s') -> readsPrecH p s' w
s' -> readsPrecH p s' w
readsPrecH p s w =
case readsPrec p s of
[(h,s')] -> readsPrecP1 p s' w h
_ -> []
readsPrecP1 p s w h =
case (dropWhile isSpace s) of
('+':s') -> readsPrecX p s' w h
s' -> readsPrecX p s' w h
readsPrecX p s w h =
case readsPrec p s of
[(x,s')] -> readsPrecP2 p s' w h x
_ -> []
readsPrecP2 p s w h x =
case (dropWhile isSpace s) of
('+':s') -> readsPrecY p s' w h x
s' -> readsPrecY p s' w h x
readsPrecY p s w h x =
case readsPrec p s of
[(y,s')] -> [(Geometry' (w,h,x,y),s')]
_ -> []
-- -----------------------------------------------------------------------
-- Coordinates
-- -----------------------------------------------------------------------
-- | The @Coord@ datatype - e.g. representing the coords of
-- a canvas item.
type Coord = [Position]
-- | Internal.
data Coord' = Coord' Coord
-- | Internal.
instance GUIValue [(Distance,Distance)] where
cdefault = []
toGUIValue v = GUIVALUE HaskellTk (show (Coord' v))
maybeGUIValue (GUIVALUE _ s) =
case [x | (Coord' x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
-- | Internal.
instance Show Coord' where
-- Internal.
showsPrec d (Coord' []) r =
r
showsPrec d (Coord' (x:l)) r =
show (toGUIValue x) ++ " " ++ showsPrec d (Coord' l) r
-- | Internal.
instance Read Coord' where
readsPrec p s =
case (dropWhile isSpace s) of
[] -> [(Coord' [],[])]
s' -> readsPrecElem p s'
where
readsPrecElem p s =
case (readsPrec p s) of
[(Point pos,s')] -> readsPrecTail p s' pos
_ -> []
readsPrecTail p s pos =
case (readsPrec p s) of
[(Coord' l,s')] -> [(Coord' (pos:l),s')]
_ -> []
-- -----------------------------------------------------------------------
-- Distance
-- -----------------------------------------------------------------------
-- | The @Distance@ datatype - general representation of
-- distances in HTk.
newtype Distance = Distance Int deriving (Eq, Ord)
-- | Internal.
instance Show Distance where
-- Internal.
showsPrec d (Distance i) r = showsPrec d i r
-- | Internal.
instance Read Distance where
-- Internal.
readsPrec p b =
case (readsPrec p b) of
[(i,xs)] -> [(Distance (round (i::Double)),xs)]
_ -> []
-- | Internal.
instance GUIValue Distance where
cdefault = Distance (-100)
-- | Internal.
instance Enum Distance where
fromEnum (Distance d)= d
toEnum d = Distance d
-- | Internal.
instance Num Distance where
(Distance p1) + (Distance p2) = Distance (p1 + p2)
(Distance p1) * (Distance p2) = Distance (p1 * p2)
negate (Distance p) = Distance (negate p)
abs (Distance p) = Distance (abs p)
-- Internal.
signum (Distance p) = Distance (signum p)
-- Internal.
fromInteger i = Distance (fromInteger i)
-- | Internal.
instance Real Distance where
-- Internal.
toRational (Distance i) = toRational i
-- | Internal.
instance Integral Distance where
-- Internal.
toInteger (Distance i) = toInteger i
-- Internal.
(Distance d1) `quotRem` (Distance d2) = (Distance q, Distance d)
where (q, d)= d1 `quotRem` d2
-- -----------------------------------------------------------------------
-- Distance List
-- -----------------------------------------------------------------------
data Distances = Distances [Distance]
-- | Internal.
instance GUIValue [Distance] where
-- Internal.
cdefault = []
-- Internal.
toGUIValue v = GUIVALUE HaskellTk (show (Distances v))
-- Internal.
maybeGUIValue (GUIVALUE _ s) =
case [x | (Distances x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
instance Show Distances where
showsPrec d (Distances []) r =
r
showsPrec d (Distances (x:l)) r =
show x ++ " " ++ showsPrec d (Distances l) r
instance Read Distances where
readsPrec p s =
case (dropWhile isSpace s) of
[] -> [(Distances [],[])]
s' -> readsPrecElem p s'
where
readsPrecElem p s =
case (readsPrec p s) of
[(d,s')] -> readsPrecTail p s' d
_ -> []
readsPrecTail p s d =
case (readsPrec p s) of
[(Distances l,s')] -> [(Distances (d:l),s')]
_ -> []
-- -----------------------------------------------------------------------
-- Conversion
-- -----------------------------------------------------------------------
-- | Conversion from cm to @Distance@.
cm :: Double -> Distance
cm c = (Distance . round) (c * 35.4)
-- | Conversion from points to @Distance@.
pp :: Double -> Distance
pp i = ic (i / 72)
-- | Conversion from mm to @Distance@.
mm :: Double -> Distance
mm i = cm (i / 10)
-- | Conversion from inch to @Distance@.
ic :: Double -> Distance
ic i = (Distance . round) (i * 90.0)
-- | Conversion from @Distance@ to cm.
tocm :: Distance -> Double
tocm (Distance p) = (fromIntegral p) / 35.4
-- | Conversion from @Distance@ to inch.
toinch :: Distance -> Double
toinch (Distance p) = (fromIntegral p) / 90.0