module Shape where

import CommonIO
import Graphics.UI.WX as WX
import Graphics.UI.WXCore hiding (Colour)
import Graphics.UI.WXCore.Draw
import Math
import Text.Parse
--import Text.XML.HaXml.XmlContent
--import NetworkFile

import Colors
import Constants
import Common (removeQuotes) 

data Shape =
    Circle  { shapeStyle :: ShapeStyle, shapeRadius :: Double }
  | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }
						-- centred on (0,0)
  | Lines   { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] }
						-- no fill for open shape
  | Points  { shapeStyle :: ShapeStyle, shapePoints :: [DoublePoint] }
  | Rectangle { shapeStyle :: ShapeStyle
              , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }
  | Arc     { shapeStyle :: ShapeStyle, shapeRadius :: Double
            , shapeStart :: Double, shapeEnd :: Double
            , shapeCenter :: DoublePoint }
  | Ellipse { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint
            , shapeHRadius :: Double, shapeVRadius :: Double }
  | EllipticArc { shapeStyle :: ShapeStyle, shapeCenter :: DoublePoint
                , shapeHRadius :: Double, shapeVRadius :: Double 
                , shapeStart :: Double, shapeEnd :: Double }
  | RoundRec { shapeStyle :: ShapeStyle, shapeRadius :: Double
             , shapeUpperLeft :: DoublePoint, shapeLowerRight :: DoublePoint }
  | Text     { shapeStyle :: ShapeStyle, shapeText :: String }
  | Composite { shapeSegments :: [Shape] }	-- drawn in given order
  | TextInEllipse { shapeStyle :: ShapeStyle, shapeText :: String }
  deriving (Eq, Show, Read)

data ShapeStyle = ShapeStyle
    { styleStrokeWidth  :: Int
    , styleStrokeColour :: Colour
    , styleFill		:: Colour
    }
  deriving (Eq, Show, Read)

instance Parse Shape where
  parse = oneOf
      [ do{ isWord "Circle"
          ; return Circle
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeRadius"
              `discard` isWord "}"
          }
      , do{ isWord "Polygon"
          ; return Polygon
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapePerimeter"
              `discard` isWord "}"
          }
      , do{ isWord "Lines"
          ; return Lines
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapePerimeter"
              `discard` isWord "}"
          }
      , do{ isWord "Points"
          ; return Points
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapePoints"
              `discard` isWord "}"
          }
      , do{ isWord "Rectangle"
          ; return Rectangle
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeUpperLeft"
              `discard` isWord "," `apply` field "shapeLowerRight"
              `discard` isWord "}"
          }
      , do{ isWord "Arc"
          ; return Arc
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeRadius"
              `discard` isWord "," `apply` field "shapeStart"
              `discard` isWord "," `apply` field "shapeEnd"
              `discard` isWord "," `apply` field "shapeCenter"
              `discard` isWord "}"
          }
      , do{ isWord "Ellipse"
          ; return Ellipse
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeCenter"
              `discard` isWord "," `apply` field "shapeHRadius"
              `discard` isWord "," `apply` field "shapeVRadius"
              `discard` isWord "}"
          }
      , do{ isWord "EllipticArc"
          ; return EllipticArc
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeCenter"
              `discard` isWord "," `apply` field "shapeHRadius"
              `discard` isWord "," `apply` field "shapeVRadius"
              `discard` isWord "," `apply` field "shapeStart"
              `discard` isWord "," `apply` field "shapeEnd"
              `discard` isWord "}"
          }
      , do{ isWord "RoundRec"
          ; return RoundRec
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeRadius"
              `discard` isWord "," `apply` field "shapeUpperLeft"
              `discard` isWord "," `apply` field "shapeLowerRight"
              `discard` isWord "}"
          }
      , do{ isWord "Text"
          ; return Text
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeText"
              `discard` isWord "}"
          }
      , do{ isWord "Composite"
          ; return Composite
              `discard` isWord "{" `apply` field "shapeSegments"
              `discard` isWord "}"
          }
      , do{ isWord "TextInEllipse"
          ; return TextInEllipse
              `discard` isWord "{" `apply` field "shapeStyle"
              `discard` isWord "," `apply` field "shapeText"
              `discard` isWord "}"
          }
      ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Points,Rectangle,Arc,Ellipse,EllipticArc,RoundRec,Text,Composite,TextInEllipse)")

instance Parse ShapeStyle where
  parse = do{ isWord "ShapeStyle"
            ; return ShapeStyle
                `discard` isWord "{" `apply` field "styleStrokeWidth"
                `discard` isWord "," `apply` field "styleStrokeColour"
                `discard` isWord "," `apply` field "styleFill"
                `discard` isWord "}"
            }

{-
instance HTypeable Shape where
  toHType s = Defined "Shape" [] [ Constr "Circle" [] []
                                 , Constr "Polygon" [] []
                                 , Constr "Lines" [] []
                                 , Constr "Composite" [] []
                                 ]
instance XmlContent Shape where
  toContents s@(Circle{}) =
      [ mkElemC "Circle" (toContents (shapeStyle s)
                      ++ [mkElemC "radius" (toContents (shapeRadius s))]) ]
  toContents s@(Polygon{}) =
      [ mkElemC "Polygon" (toContents (shapeStyle s)
                      ++ [mkElemC "perimeter" (concatMap toContents
                                                         (shapePerimeter s))]) ]
  toContents s@(Lines{}) =
      [ mkElemC "Lines" (toContents (shapeStyle s)
                      ++ [mkElemC "perimeter" (concatMap toContents
                                                         (shapePerimeter s))]) ]
  toContents s@(Composite{}) =
      [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ]
  parseContents = do
      { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"]
      ; case t of
          "Circle" -> interior e $
                       do{ style <- parseContents
                         ;  r <- inElement "radius" parseContents
                         ; return (Circle {shapeStyle=style, shapeRadius=r})
                         }
          "Polygon" -> interior e $
                       do{ style <- parseContents
                         ; p <- inElement "perimeter" $ many1 parseContents
                         ; return (Polygon {shapeStyle=style, shapePerimeter=p})
                         }
          "Lines" -> interior e $
                       do{ style <- parseContents
                         ; p <- inElement "perimeter" $ many1 parseContents
                         ; return (Lines {shapeStyle=style, shapePerimeter=p})
                         }
          "Composite" -> interior e $ do{ ss <- many1 parseContents
                                        ; return (Composite {shapeSegments=ss})
                                        }
      }

instance HTypeable ShapeStyle where
  toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []]
instance XmlContent ShapeStyle where
  toContents s =
      [ mkElemC "ShapeStyle"
          [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s))
          , mkElemC "StrokeColour" (toContents (styleStrokeColour s))
          , mkElemC "Fill" (toContents (styleFill s))
          ]
      ]
  parseContents = inElement "ShapeStyle" $ do
      { w <- inElement "StrokeWidth" parseContents
      ; c <- inElement "StrokeColour" parseContents
      ; f <- inElement "Fill" parseContents
      ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c
                           , styleFill=f })
      }
-}

logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [Prop (DC ())] -> IO ()
logicalDraw ppi dc centre shape options =
    case shape of
      Circle {}   -> WX.circle dc (logicalToScreenPoint ppi centre)
                                  (logicalToScreenX ppi (shapeRadius shape))
                                  (style2options (shapeStyle shape)++options)

      Polygon {}  -> WX.polygon dc (map (logicalToScreenPoint ppi
                                             . translate centre)
                                          (shapePerimeter shape))
                                   (style2options (shapeStyle shape)++options)

      Lines {}    -> logicalLineSegments ppi dc (map (translate centre)
                                                     (shapePerimeter shape))
                                   (style2options (shapeStyle shape)++options)

      Points {}   -> mapM_ (\p -> WX.drawPoint dc 
                                            (logicalToScreenPoint ppi                                                                    $ translate centre p)
                                            (style2options (shapeStyle shape)++options)
                           ) 
                           $ shapePoints shape

      Rectangle {} -> WX.drawRect dc 
                                  (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )
                                  (style2options (shapeStyle shape)++options)

      Arc {} -> WX.arc dc (logicalToScreenPoint ppi . translate centre $ shapeCenter shape)
                          (logicalToScreenX ppi (shapeRadius shape))
                          (shapeStart shape)
                          (shapeEnd shape)
                          (style2options (shapeStyle shape)++options)

      Ellipse {} -> WX.ellipse dc
                               (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))
                               (style2options (shapeStyle shape)++options)

      EllipticArc {} -> WX.ellipticArc 
                               dc
                               (doRect (shapeCenter shape) (shapeHRadius shape) (shapeVRadius shape))
                               (shapeStart shape)
                               (shapeEnd shape)
                               (style2options (shapeStyle shape)++options)

      RoundRec {} -> WX.roundedRect dc 
                                    (rectFrom (shapeUpperLeft shape) (shapeLowerRight shape) )
                                    (shapeRadius shape)
                                    (style2options (shapeStyle shape)++options)

      Text {} -> do textSize <- getTextExtent dc (shapeText shape)
                    let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre
                                            . scale 0.5 
                                            . screenToLogicalPoint ppi $ pointFromSize textSize
                    WX.drawText dc (removeQuotes $ shapeText shape) 
                                upperCorner
                                (style2options (shapeStyle shape)++options)

      Composite {} -> mapM_ (\s-> logicalDraw ppi dc centre s options)
                           (shapeSegments shape)

      TextInEllipse {} -> 
                 do let txt = removeQuotes (shapeText shape)  
                    textSize <- getTextExtent dc (shapeText shape)
                    let upperCorner = logicalToScreenPoint ppi . subtractDoublePoint centre
                                            . scale 0.5 
                                            . screenToLogicalPoint ppi $ pointFromSize textSize
                    WX.ellipse dc
                               (rect (pointSub upperCorner $ Point 5 5) 
                                     $ Size (sizeW textSize + 10) (sizeH textSize + 10) )
                               (style2options (shapeStyle shape)++options)
                    WX.drawText dc txt upperCorner 
                                (style2options (shapeStyle shape)++options)

    where rectFrom :: DoublePoint -> DoublePoint -> Rect
          rectFrom upperLeftCorner lowerRightCorner =  
             rectBetween (logicalToScreenPoint ppi $ translate centre upperLeftCorner)
                         (logicalToScreenPoint ppi $ translate centre lowerRightCorner)
          doRect :: DoublePoint -> Double -> Double -> Rect
          doRect ellipseCenter hRadius vRadius = 
             rectBetween (logicalToScreenPoint ppi . translate centre 
                           $ subtractDoublePoint ellipseCenter $ DoublePoint hRadius vRadius)
                         (logicalToScreenPoint ppi . translate centre 
                           $ translate ellipseCenter $ DoublePoint hRadius vRadius)

logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()
logicalLineSegments _   _  [_p]                  _options = return ()
logicalLineSegments ppi dc (fromPoint:toPoint:ps) options =
  do{ line dc (logicalToScreenPoint ppi fromPoint)
              (logicalToScreenPoint ppi toPoint) options
    ; logicalLineSegments ppi dc (toPoint:ps) options
    }

circle :: Shape
circle = Circle  { shapeStyle = defaultShapeStyle
                 , shapeRadius = kNODE_RADIUS }

style2options :: ShapeStyle -> [Prop (DC ())]
style2options sty =
    [ penWidth := styleStrokeWidth sty
    , penColor := wxcolor (styleStrokeColour sty)
    , brushKind := BrushSolid
    , brushColor := wxcolor (styleFill sty)
    ]

defaultShapeStyle :: ShapeStyle
defaultShapeStyle =
    ShapeStyle	{ styleStrokeWidth = 1
		, styleStrokeColour = licorice
		, styleFill = nodeColor }