{-| Geometric 2D types, equipped with `SqlBind' instances.
-}
module DB.HSQL.Type.Geometric where

import DB.HSQL.Type
    (SqlType(SqlPoint,SqlLSeg,SqlPath,SqlBox,SqlPolygon,SqlCircle))
import Database.HSQL.Types(SqlBind(..))

-- | A 2D point.
data Point 
    = Point { pointX:: Double, pointY:: Double }
    deriving (Eq,Ord,Show,Read)

instance SqlBind Point where
    fromSqlValue SqlPoint s = case read s of
		                (x,y) -> Just (Point x y)
    fromSqlValue _ _ = Nothing

    toSqlValue (Point x y) = 
        '\'' : shows (x,y) "'"


-- | A 2D straight line.
data Line 
    = Line { lineBegin:: Point, lineEnd:: Point } 
    deriving (Eq, Show,Read)

instance SqlBind Line where
    fromSqlValue SqlLSeg s = 
        case read s of
	  [(x1,y1),(x2,y2)] -> Just (Line (Point x1 y1) (Point x2 y2))
    fromSqlValue _ _ = Nothing

    toSqlValue (Line (Point x1 y1) (Point x2 y2)) = 
        '\'' : shows [(x1,y1),(x2,y2)] "'"

-- | A 2D path, either open, or closed (looping). 
data Path 
    = OpenPath { pathPoints:: [Point] }
      -- ^ An open path
    | ClosedPath { pathPoints:: [Point] }
      -- ^ A looping path
    deriving (Eq, Show,Read)

instance SqlBind Path where
    fromSqlValue SqlPath ('(':s) = 
        case read ("["++init s++"]") of   -- closed path
	  ps -> Just (ClosedPath (map  (\(x,y) -> Point x y) ps))
    fromSqlValue SqlPath s = 
        case read s of   -- closed path        -- open path
	  ps -> Just (OpenPath (map  (\(x,y) -> Point x y) ps))
    fromSqlValue SqlLSeg s = 
        case read s of
	  [(x1,y1),(x2,y2)] -> Just (OpenPath [(Point x1 y1), (Point x2 y2)])
    fromSqlValue SqlPoint s = 
        case read s of
	  (x,y) -> Just (ClosedPath [Point x y])
    fromSqlValue _ _ = Nothing

    toSqlValue (OpenPath ps) = '\'' : shows ps "'"
    toSqlValue (ClosedPath ps) = "'(" ++ init (tail (show ps)) ++ "')"

-- | A 2D rectangle.
data Box 
    = Box { boxX1:: Double 
          , boxY1:: Double 
          , boxX2:: Double 
          , boxY2:: Double }
    deriving (Eq, Show,Read)

instance SqlBind Box where
    fromSqlValue SqlBox s = case read ("("++s++")") of
		              ((x1,y1),(x2,y2)) -> Just (Box x1 y1 x2 y2)
    fromSqlValue _ _ = Nothing

    toSqlValue (Box x1 y1 x2 y2) = 
        '\'' : shows ((x1,y1),(x2,y2)) "'"


-- | A 2D polygon (without holes).
data Polygon 
    = Polygon { polygonPoints:: [Point] } 
    deriving (Eq, Show,Read)

instance SqlBind Polygon where
    fromSqlValue SqlPolygon s = 
        case read ("["++init (tail s)++"]") of
	  ps -> Just (Polygon (map  (\(x,y) -> Point x y) ps))
    fromSqlValue _ _ = Nothing

    toSqlValue (Polygon ps) = 
        "'(" ++ init (tail (show ps)) ++ "')"


-- | A 2D circle
data Circle 
    = Circle { circleCenter:: Point 
             , circleRadius:: Double } 
    deriving (Eq, Show,Read)

instance SqlBind Circle where
    fromSqlValue SqlCircle s = case read ("("++init (tail s)++")") of
		                 ((x,y),r) -> Just (Circle (Point x y) r)
    fromSqlValue _ _ = Nothing

    toSqlValue (Circle (Point x y) r) = 
        "'<" ++ show (x,y) ++ "," ++ show r ++ "'>"