module DB.HSQL.Type.Geometric where

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

-- |
data Point 
    = Point Double Double 
    deriving (Eq, Show)

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) "'"


-- |
data Line 
    = Line Point Point 
    deriving (Eq, Show)

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)] "'"


-- |
data Path 
    = OpenPath [Point] 
    | ClosedPath [Point] 
    deriving (Eq, Show)

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)) ++ "')"


-- |
data Box 
    = Box Double Double Double Double 
    deriving (Eq, Show)

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)) "'"


-- |
data Polygon 
    = Polygon [Point] 
    deriving (Eq, Show)

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)) ++ "')"


-- | 
data Circle 
    = Circle Point Double 
    deriving (Eq, Show)

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 ++ "'>"