-- -----------------------------------------------------------------------
--
-- $Source: /repository/uni/htk/resources/Geometry.hs,v $
--
-- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen
--
-- $Revision: 1.6 $ from $Date: 2002/03/05 19:09:08 $  
-- Last modification by $Author: ger $
--
-- -----------------------------------------------------------------------

---
-- The <code>module Geometry</code> exports basic geometric types and
-- functionality.
module Geometry (

  Distance(..),

  Size, 
  Coord, 
  Position,
  Geometry, 

  cm, pp, mm, ic, tocm, toinch    

) where

import GUIValue
import Char
import Debug(debug)


-- -----------------------------------------------------------------------
-- Position/Size
-- -----------------------------------------------------------------------

---
-- The <code>Position</code> - a pair of two <code>Distance</code> values.
type Position = (Distance, Distance) 

---
-- The <code>Size</code> datatype - a pair of two <code>Distance</code>
-- values.
type Size = (Distance, Distance) 

---
-- The <code>Point</code> 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
---
-- Internal.
   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
---
-- Internal.
  cdefault = (cdefault, cdefault, cdefault, cdefault)
---
-- Internal.
  toGUIValue v = GUIVALUE HaskellTk (show (Geometry' v))
---
-- Internal.
  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 <code>Coord</code> datatype - e.g. representing the coords of
-- a canvas item.
type Coord = [Position]

---
-- Internal.
data Coord' = Coord' Coord

---
-- Internal.
instance GUIValue [(Distance,Distance)] where
---
-- Internal.
  cdefault = []
---
-- Internal.
  toGUIValue v = GUIVALUE HaskellTk (show (Coord' v))
---
-- Internal.
  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
---
-- Internal.
  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 <code>Distance</code> 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
---
-- Internal.
  cdefault = Distance (-100)

---
-- Internal.
instance Enum Distance where 
---
-- Internal.
  fromEnum (Distance d)= d
---
-- Internal.
  toEnum d = Distance d

---
-- Internal.
instance Num Distance where
---
-- Internal.
  (Distance p1) + (Distance p2) = Distance (p1 + p2)
---
-- Internal.
  (Distance p1) * (Distance p2) = Distance (p1 * p2)
---
-- Internal.
  negate (Distance p) = Distance (negate p)
---
-- Internal.
  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 <code>Distance</code>.
cm :: Double -> Distance
cm c = (Distance . round) (c * 35.4)

---
-- Conversion from points to <code>Distance</code>.
pp :: Double -> Distance
pp i = ic (i / 72)

---
-- Conversion from mm to <code>Distance</code>.
mm :: Double -> Distance
mm i = cm (i / 10)

---
-- Conversion from inch to <code>Distance</code>.
ic :: Double -> Distance
ic i = (Distance . round) (i * 90.0)

---
-- Conversion from <code>Distance</code> to cm.
tocm :: Distance -> Double
tocm (Distance p) = (fromIntegral p) / 35.4  

---
-- Conversion from <code>Distance</code> to inch.
toinch :: Distance -> Double
toinch (Distance p) = (fromIntegral p) / 90.0