{-# LANGUAGE MultiWayIf #-}

-- Sorted as they are in 2htdp/image
-- | Image constructors
module Graphics.Htdp.Shape
  ( Mode
  , solid
  , outline
  , circle
  , ellipse
  , line
  , addLine
  , emptyImage
  , triangle
  , rightTriangle
  , isoscelesTriangle
  -- *** The following image from 2htdp/image documentation is useful for the following family of functions.
  -- |   <<diagrams/triangleDiagram.png>>
  , triangleSSS
  , triangleASS
  , triangleSAS
  , triangleSSA
  , triangleAAS
  , triangleASA
  , triangleSAA
  , square
  , rectangle
  , rhombus
  , star
  )
where

import           Data.Angle
import           Data.Fixed
import           Data.List
import           Graphics.Htdp.Combinator
import           Graphics.Htdp.Data.Image
import qualified Graphics.Gloss                as G
import           Graphics.Gloss.Data.Color
import           Graphics.Htdp.Util.Arithmetic

-- | Drawing mode.
data Mode = Solid | Outline deriving Eq

-- | Type of drawing mode.
solid, outline :: Mode
solid = Solid
outline = Outline

-- Initial point for all images
origin :: G.Point
origin = (0, 0)

-- | Adds a line to the given image @i@ of color @c@, starting from point @(x1, y1)@
--   and going to point @(x2, y2)@. If the line crosses the given image's binding box,
--   then new image dimesions are changed to accommodate the line.
addLine
  :: Image -- ^ @i@
  -> Float -- ^ @x1@
  -> Float -- ^ @y1@
  -> Float -- ^ @x2@
  -> Float -- ^ @y2@
  -> Color
  -> Image
addLine i x1 y1 x2 y2 c =
  placeImage (line (x1 - x2) (y1 - y2) c) ((x1 + x2) / 2) ((y1 + y2) / 2) i

-- | Constructs a circle of radius @r@, drawing mode @m@ and color @c@.
circle
  :: Float -- ^ @r@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
circle r mode c = Image { width  = r * 2
                        , height = r * 2
                        , shapes = [(G.color c $ circleKind r, origin)]
                        }
 where
  circleKind = case mode of
    Solid   -> G.circleSolid
    Outline -> G.circle

-- | Constructs an ellipse of width @w@, height @h@, mode @m@, and color @c@.
ellipse
  :: Float -- ^ @w@
  -> Float -- ^ @h@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
ellipse w h m c = Image { width  = w
                        , height = h
                        , shapes = [(circleToEllipse, origin)]
                        }
 where -- This took me longer than it should have
  circleToEllipse = G.scale (w / (2 * radius)) (h / (2 * radius)) circPic
  circPic         = fst . head . shapes $ circle radius m c
  radius          = (w + h) / 4

-- | Constructs an image of width and height @0@.
emptyImage :: Image
emptyImage = Image 0 0 []

-- | Constructs a triangle of two equal-length sides, of length @l@, where the
--   angle between those sides is @a@, mode is @m@ and color is @c@. If the angle
--   is less than @180@, then the triangle will point up, else it will point down.
isoscelesTriangle
  :: Float -- ^ @l@
  -> Float -- ^ @a@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
isoscelesTriangle sl deg m c = Image
  { width  = newW
  , height = newH
  , shapes = [(G.color c triangleShape, origin)]
  }
 where
  newW   = (2 * (sl ** 2) * (1 - (cosine . Degrees $ deg))) ** (1 / 2)
  newH   = computeRightSide sl (newW / 2)
  topDir = if mod' deg 360 < 180 then 1 else -1
  tShape =
    [ (negate newW / 2, negate topDir * (newH / 2))
    , (0              , topDir * newH / 2)
    , (newW / 2       , negate topDir * (newH / 2))
    ]
  triangleShape = case m of
    Solid   -> G.polygon tShape
    Outline -> G.line ((newW / 2, negate topDir * (newH / 2)) : tShape)

-- | Constructs an image of a line segment of color @c@ that connects the points
--   @(0,0)@ to @(x1, y1)@.
line
  :: Float -- ^ @x1@
  -> Float -- ^ @y1@
  -> Color -- ^ @c@
  -> Image
line x y c = Image { width  = abs x
                   , height = abs y
                   , shapes = [(G.color c $ G.Line lineShape, origin)]
                   }
  -- We want the line centered on the origin.
  -- For that, we will need to move the given points
  -- (I had to take a day off to get this)
  where lineShape = [(x / 2, negate y / 2), (negate x / 2, y / 2)]

-- | Constructs a rectangle of width @w@, height @h@, mode @m@, and color @c@.
rectangle
  :: Float -- ^ @w@
  -> Float -- ^ @h@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
rectangle w h mode c = Image { width  = w
                             , height = h
                             , shapes = [(G.color c $ rectShape w h, origin)]
                             }
 where
  rectShape = case mode of
    Solid   -> G.rectangleSolid
    Outline -> G.rectangleWire

-- | Constructs a four sided polygon with all equal sides of length @l@, where the
--   top and bottom pair of angles is @a@, and the left and right are @180 - a@.
--   As usual, mode is @m@ and color is @c@.
rhombus
  :: Float -- ^ @l@
  -> Float -- ^ @a@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
rhombus sideLength angle m c = Image { width  = base
                                     , height = opp
                                     , shapes = [(G.color c rShape, origin)]
                                     }
 where
  -- It's the law of Cosine bb
  base = (2 * (sideLength ** 2) * (1 - (cosine . Degrees $ angle))) ** (1 / 2)
  opp  = 2 * computeRightSide sideLength (base / 2)
  rhombusShape =
    [(negate base / 2, 0), (0, opp / 2), (base / 2, 0), (0, negate opp / 2)]
  rShape = case m of
    Solid   -> G.polygon rhombusShape
    Outline -> G.line ((0, negate opp / 2) : rhombusShape)

-- | Constructs a right triangle with base length @b@, perpendicular length
--   @p@, mode @m@, and color @c@.
rightTriangle
  :: Float -- ^ @b@
  -> Float -- ^ @p@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
rightTriangle b p m c = Image { width  = b
                              , height = p
                              , shapes = [(G.color c triangleShape, origin)]
                              }
 where
  tShape =
    [(b / 2, negate p / 2), (negate b / 2, p / 2), (negate b / 2, negate p / 2)]
  triangleShape = case m of
    Solid   -> G.polygon tShape
    Outline -> G.line ((negate b / 2, negate p / 2) : tShape)

-- | Constructs a square of side @s@, mode @m@, and color @c@.
square
  :: Float -- ^ @s@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
square w = rectangle w w

-- | Constructs a star with five points of mode @m@ and color @c@. The argument
--   @l@ determines the side length of the internal pentagon.
--   Currently, a solid star is glitchy since it is a non-convex polygon
--   and openGL (the underlying graphics library) doesn't draw them correctly.
--   This will be corrected in future versions.
star
  :: Float -- ^ @l@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
star side m c = Image { width  = w
                      , height = h
                      , shapes = [(G.color c sShape, origin)]
                      }
 where
    -- Pentagon is 108degs apart
  w          = (2 * triHyp) + side
  h          = (1.539 * side) + triPerp + bottomPerp
  triHyp     = (sine . Degrees $ 72) * (side / (sine . Degrees $ 36))
  triPerp    = computeRightSide triHyp (side / 2)
  bottomPerp = computeRightSide triHyp (bottom / 2)
  bottom     = (2 * (triHyp ** 2) * (1 - (cosine . Degrees $ 108))) ** (1 / 2)
  sShape     = case m of
    Solid ->
      G.polygon
        $ concat
        . transpose
        $ [[bLeftSt, bRightSt, rightSt, topSt, leftSt], pentPoints]
    Outline -> G.line (rightSt : starPoints) -- Some hack to fix solid
  starPoints = [bLeftSt, topSt, bRightSt, leftSt, rightSt]
  topSt      = (0, h / 2)
  leftSt     = (negate (w / 2), (h / 2) - triPerp)
  rightSt    = (negate . fst $ leftSt, snd leftSt)
  bLeftSt    = (negate (bottom / 2), negate (h / 2))
  bRightSt   = (negate . fst $ bLeftSt, snd bLeftSt)
  pentPoints = [bottomP, bRightP, rightP, leftP, bLeftP]
  bottomP    = (0, negate $ h / 2 - bottomPerp)
  leftP      = (negate $ side / 2, snd leftSt)
  rightP     = (negate . fst $ leftP, snd leftP)
  bLeftP     = (negate midPerp, negate $ h / 2 - (bottomPerp + midPerp))
  bRightP    = (negate . fst $ bLeftP, snd bLeftP)
  midPerp    = computeRightSide side $ (1.618 * side) / 2

-- | Constructs an upward-pointing equilateral triangle with length @l@,
--   mode @m@, and color @c@.
triangle
  :: Float -- ^ @l@
  -> Mode  -- ^ @m@
  -> Color -- ^ @c@
  -> Image
triangle sideLength = isoscelesTriangle sideLength 60

-- | Constructs a triangle of mode @m@, color @color@, angle @A@, angle @B@, and
--   length @c@. The variables refer to the diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleAAS
  :: Float -- ^ @A@
  -> Float -- ^ @B@
  -> Float -- ^ @c@
  -> Mode  -- ^ @m@
  -> Color -- ^ @color@
  -> Image
triangleAAS degr degl t = triangleSSS
  (t * (sine . Degrees $ degr) / (sine . Degrees $ 180 - (degl + degr)))
  (t * (sine . Degrees $ degl) / (sine . Degrees $ 180 - (degl + degr)))
  t

-- | Constructs a triangle of mode @m@, color @color@, angle @A@, angle @C@, and
--   length @b@. The variables refer to the diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleASA
  :: Float -- ^ @A@
  -> Float -- ^ @C@
  -> Float -- ^ @b@
  -> Mode  -- ^ @m@
  -> Color -- ^ @color@
  -> Image
triangleASA degl l degt = triangleSSS
  (l * (sine . Degrees $ degl) / (sine . Degrees $ 180 - (degt + degl)))
  l
  (l * (sine . Degrees $ degt) / (sine . Degrees $ 180 - (degt + degl)))

-- | Constructs a triangle of mode @m@, color @color@, angle @B@, angle @C@, and
--   length @a@. The variables refer to the diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleSAA
  :: Float -- ^ @B@
  -> Float -- ^ @C@
  -> Float -- ^ @a@
  -> Mode  -- ^ @m@
  -> Color -- ^ @color@
  -> Image
triangleSAA r degr degt = triangleSSS
  r
  (r * (sine . Degrees $ degr) / (sine . Degrees $ 180 - (degt + degr)))
  (r * (sine . Degrees $ degt) / (sine . Degrees $ 180 - (degt + degr)))

-- | Constructs a triangle of mode @m@, color @color@, angle @A@, and lengths
--   @b@ and @c@. The variables refer to the diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleASS
  :: Float -- ^ @A@
  -> Float -- ^ @b@
  -> Float -- ^ @c@
  -> Mode  -- ^ @mode@
  -> Color -- ^ @color@
  -> Image
triangleASS deg l t = triangleSSS
  (((l ** 2) + (t ** 2) - 2 * t * l * (cosine . Degrees $ deg)) ** (1 / 2))
  l
  t

-- | Constructs a triangle of mode @m@, color @color@, angle @B@, and lengths
--   @a@ and @c@. The variables refer to the diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleSAS
  :: Float -- ^ @B@
  -> Float -- ^ @a@
  -> Float -- ^ @c@
  -> Mode  -- ^ @mode@
  -> Color -- ^ @color@
  -> Image
triangleSAS r deg t = triangleSSS
  r
  (((r ** 2) + (t ** 2) - 2 * t * r * (cosine . Degrees $ deg)) ** (1 / 2))
  t

-- | Constructs a triangle of mode @m@, color @color@, angle @C@, and lengths
--   @a@ and @c@. The variables refer to the diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleSSA
  :: Float -- ^ @C@
  -> Float -- ^ @a@
  -> Float -- ^ @c@
  -> Mode  -- ^ @mode@
  -> Color -- ^ @color@
  -> Image
triangleSSA r l deg = triangleSSS
  r
  l
  (((r ** 2) + (l ** 2) - 2 * l * r * (cosine . Degrees $ deg)) ** (1 / 2))

-- | Constructs a triangle of side @a@, @b@, and @c@. The variables refer to the
--   diagram above.
--   If it's not possible to construct the triangle with the given arguments,
--   an empty image is returned.
triangleSSS
  :: Float -- ^ @a@
  -> Float -- ^ @b@
  -> Float -- ^ @c@
  -> Mode  -- ^ @m@
  -> Color -- ^ @color@
  -> Image
triangleSSS r l t m c =
  if (round . distance (bottX, negate newH / 2) $ (-t / 2, newH / 2) :: Integer)
     == (round l)
     && (round . distance (bottX, negate newH / 2) $ (t / 2, newH / 2) :: Integer
        )
     == round r
  then
    Image { width  = newW
          , height = newH
          , shapes = [(G.color c triangleShape, origin)]
          }
  else
    emptyImage

 where
  angleL =
    arccosine $ (l ** 2 - r ** 2 - t ** 2) / (-2 * r * t) :: Degrees Float
  angleR =
    arccosine $ (r ** 2 - l ** 2 - t ** 2) / (-2 * l * t) :: Degrees Float
  newH = (if angleR < angleL then l else r) * (sine $ min angleR angleL)
  newW = if
    | angleR < angleL && angleL > Degrees 90
    -> l * (sine $ Degrees 90 - min angleR angleL)
    | angleL < angleR && angleR > Degrees 90
    -> r * (sine $ Degrees 90 - min angleR angleL)
    | otherwise
    -> t
  bottW = computeRightSide (max l r) newH
  bottX = if l > r then bottW - (t / 2) else negate $ bottW - (t / 2)
  converter =
    convert (min bottX $ -t / 2) (-newW / 2) (max bottX $ t / 2) (newW / 2)
  tShape =
    [ (converter $ negate t / 2, newH / 2)
    , (converter bottX         , negate newH / 2)
    , (converter $ t / 2       , newH / 2)
    ]
  triangleShape = case m of
    Solid   -> G.polygon tShape
    Outline -> G.line ((converter $ t / 2, newH / 2) : tShape)