Picture.hs

module Graphics.Gloss.Relative.Internal.Picture where

import Graphics.Gloss
import Graphics.Gloss.Relative.Internal.Dimension

import Data.Semigroup
import Data.Monoid

-- * Pictures

translateX :: Float -> Picture -> Picture
translateX x p = Translate x 0 p

translateY :: Float -> Picture -> Picture
translateY y p = Translate 0 y p

-- The default Monoid instance for 'Picture' is buggy, since Blank is not in fact a neutral element.
emptyPicture :: Picture
emptyPicture = Pictures []

joinPicture :: Picture -> Picture -> Picture
joinPicture (Pictures xs) (Pictures ys) = catPictures $ xs ++ ys
joinPicture x (Pictures ys) = catPictures (x : ys)
joinPicture (Pictures xs) y = catPictures (xs ++ [y])
joinPicture x y = catPictures [x,y]

catPictures :: [Picture] -> Picture
catPictures [x] = x
catPictures xs = Pictures xs

-- | Flattens a picture, by eliminating some nested transforms.
-- NOTE: OpenGL backends have a nested transforms stack of only 32, so we need to make sure to flatten Pictures before rendering to avoid stack overflows.
flattenPicture :: Picture -> Picture
flattenPicture p = Pictures $ flatten identityMatrix p

-- Representing Affine Transformation Matrices.
-- | a c e |
-- | b d f |
-- | 0 0 1 |
data Matrix = Matrix Float Float Float Float Float Float

identityMatrix :: Matrix
identityMatrix = Matrix 1 0 0 1 0 0

isShearedMatrix :: Matrix -> Bool
isShearedMatrix (Matrix a b c d _ _) = 
    let dotProduct = a * c + b * d
        epsilon = 0.0001
    in abs dotProduct > epsilon

multiplyMatrix :: Matrix -> Matrix -> Matrix
multiplyMatrix (Matrix a1 b1 c1 d1 e1 f1) (Matrix a2 b2 c2 d2 e2 f2) =
    Matrix (a1*a2 + c1*b2) (b1*a2 + d1*b2)
           (a1*c2 + c1*d2) (b1*c2 + d1*d2)
           (a1*e2 + c1*f2 + e1) (b1*e2 + d1*f2 + f1)

flatten :: Matrix -> Picture -> [Picture]
flatten m pic | isShearedMatrix m = [transformLeaf m pic]
flatten m Blank = []
flatten m (Pictures ps) = concatMap (flatten m) ps
flatten m (Translate x y p) = flatten (m `multiplyMatrix` Matrix 1 0 0 1 x y) p
flatten m (Scale sx sy p) = flatten (m `multiplyMatrix` Matrix sx 0 0 sy 0 0) p
flatten m (Rotate deg p) =
        let rad = -deg * pi / 180 -- Gloss is clockwise
            s = sin rad
            c = cos rad
        in flatten (m `multiplyMatrix` Matrix c (-s) s c 0 0) p
flatten m (Polygon points) = [Polygon (map (transformPoint m) points)]
flatten m (Line points) = [Line (map (transformPoint m) points)]
flatten m pic = [transformLeaf m pic]

transformPoint :: Matrix -> Point -> Point
transformPoint (Matrix a b c d e f) (x, y) = 
    (a*x + c*y + e, b*x + d*y + f)

transformLeaf :: Matrix -> Picture -> Picture
transformLeaf (Matrix a b c d e f) leaf =
    let
        tx = e
        ty = f
        sx = sqrt (a*a + b*b)
        -- Use the determinant to handle negative scaling/flipping
        det = a*d - b*c
        sy = (signum det) * sqrt (c*c + d*d)
        angle = atan2 b a * 180 / pi
    in
        Translate tx ty $ Rotate (-angle) $ Scale sx sy leaf

-- * Regions

-- | A rectangular region within the screen.
data Region = Region
    { regionLeftTop :: Point
    , regionDimension :: Dimension
    } deriving (Eq,Ord,Show)

instance Semigroup Region where
    (Region (x1,y1) (w1,h1)) <> (Region (x2,y2) (w2,h2)) = Region (xmin,ymin) (abs (xmax-xmin),abs (ymax-ymin))
         where xmin = min x1 x2
               ymin = min y1 y2
               xmax = max (x1+w1) (x2+w2)
               ymax = max (y1+h1) (y2+h2)

instance Monoid Region where
    mempty = Region (0,0) (0,0)

regionScreenSize :: Region -> ScreenSize
regionScreenSize (Region (x,y) (xdim,ydim)) = (ceiling $ maxX * 2,ceiling $ maxY * 2)
    where
    maxX = max (abs x) (abs $ x + xdim)
    maxY = max (abs y) (abs $ y + ydim)

dimensionToRegion :: Dimension -> Region
dimensionToRegion (w,h) = Region { regionLeftTop = (-w/2,h/2), regionDimension = (w,h) }

pointInsideRegion :: Point -> Region -> Bool
pointInsideRegion (mouseX,mouseY) r =
    let (regionLeft,regionTop) = regionLeftTop r
        (w,h) = regionDimension r 
        regionRight = regionLeft + w 
        regionBottom = regionTop - h 
    in (regionLeft <= mouseX && mouseX <= regionRight) && (regionBottom <= mouseY && mouseY <= regionTop)

-- converts a point inside a region to a relative point within the region
pointWithinRegion :: Point -> Region -> Maybe Point
pointWithinRegion p@(x,y) r = if pointInsideRegion p r
    then
        let (regionLeft,regionTop) = regionLeftTop r 
            (w,h) = regionDimension r
            regionCenterX = regionLeft + w / 2
            regionCenterY = regionTop - h / 2
        in Just (x - regionCenterX,y - regionCenterY)
    else Nothing

translateRegionX :: Float -> Region -> Region
translateRegionX f r = r { regionLeftTop = translatePointX f (regionLeftTop r) }

translateRegionY :: Float -> Region -> Region
translateRegionY f r = r { regionLeftTop = translatePointY f (regionLeftTop r) }

-- * Picture bounding box

-- | Estimates the 'Region' of a 'Picture'.
pictureRegion :: Picture -> Region
pictureRegion = bbToRegion . bbox

pictureScreenSize :: Picture -> ScreenSize
pictureScreenSize = regionScreenSize . pictureRegion 

pictureDimension :: Picture -> Dimension
pictureDimension = screenSizeToDimension . pictureScreenSize

type Elipsis = (Float,Float,Float,Float,Float,Float)
data BB = BB { bbElipsis :: [Elipsis], bbPoints :: [Point] } deriving Show

instance Semigroup BB where
    (BB es1 ps1) <> (BB es2 ps2) = BB (es1++es2) (ps1++ps2)
instance Monoid BB where
    mempty = BB [] []

bbox :: Picture -> BB
bbox Blank = mempty
bbox (Polygon l) = BB [] l
bbox (Line l) = BB [] l
bbox (Circle r) = case (circElipsis r) of
    Nothing -> mempty
    Just e -> BB [e] []
bbox (ThickCircle r thick) = case (circElipsis $ r + thick / 2) of
    Nothing -> mempty
    Just e -> BB [e] []
bbox (Arc _ _ r) = bbox (Circle r) -- big overapproximation
bbox (ThickArc _ _ r thick) = bbox (ThickCircle r thick) -- big overapproximation
bbox (Text str) = bbox $ Translate (textWidth/2) (fromIntegral charHeight/2) rect
    where
    rect = rectangleWire textWidth (realToFrac charHeight)
    textWidth = realToFrac (length str) * (realToFrac charWidth)
bbox (Bitmap bmp) = bbox $ rectangleWire (fromIntegral w) (fromIntegral h)
    where (w,h) = bitmapSize bmp
bbox (BitmapSection rect bmp) = bbox $ rectangleWire (fromIntegral w) (fromIntegral h)
    where (w,h) = rectSize rect
bbox (Color c p) = bbox p
bbox (Scale x y p) = scaleBB x y (bbox p)
bbox (Translate x y p) = translateBB x y (bbox p)
bbox (Rotate alpha p) = rotateBB alpha (bbox p)
bbox (Pictures xs) = mconcat $ map bbox xs

charHeight :: Int
charHeight =  104
charWidth :: Int
charWidth = 70

scaleBB :: Float -> Float -> BB -> BB
scaleBB x y (BB es ps) = BB (map (scaleElipsis x y) es) (scalePath x y ps)

translateBB :: Float -> Float -> BB -> BB
translateBB x y (BB es ps) = BB (map (translateElipsis x y) es) (translatePath x y ps)

rotateBB :: Float -> BB -> BB
rotateBB alpha (BB es ps) = BB (map (rotateElipsis alpha) es) (rotatePath alpha ps)

bbToRegion :: BB -> Region
bbToRegion (BB es ps) = mconcat $ pathRegion ps : map elipsisRegion es

pathRegion :: Path -> Region
pathRegion [] = mempty
pathRegion l = Region (xmin,ymin) (abs (xmax-xmin),abs (ymax-ymin))
 where (xs,ys) = unzip l
       xmin = minimum xs
       ymin = minimum ys
       xmax = maximum xs
       ymax = maximum ys

elipsisRegion :: Elipsis -> Region
elipsisRegion (a,b,c,d,e,f) | dlt==0 = mempty
                        | otherwise = Region (xl,yb) (abs (xr-xl),abs (yt-yb))
 where dlt = 4*a*c - b^2
       xc = (b*e - 2*c*d) / dlt
       yc = (b*d - 2*a*e) / dlt
       xr = xc + sqrt ((2*b*e-4*c*d)^2+4*dlt*(e^2-4*c*f)) / (2*dlt)
       yt = yc + sqrt ((2*b*d-4*a*e)^2+4*dlt*(d^2-4*a*f)) / (2*dlt)
       xl = xc - sqrt ((2*b*e-4*c*d)^2+4*dlt*(e^2-4*c*f)) / (2*dlt)
       yb = yc - sqrt ((2*b*d-4*a*e)^2+4*dlt*(d^2-4*a*f)) / (2*dlt)

-- converts point from cartesian to polar coordinates
toPolar :: Point -> (Float,Float)
toPolar (x,y) = (sqrt (x^2+y^2), atan2 y x)

-- converts point from polar to cartesian
toCartesian :: (Float,Float) -> Point
toCartesian (r,gama) = (r*cos gama,r*sin gama)

-- a circle as an elipsis
circElipsis :: Float -> Maybe Elipsis
circElipsis 0 = Nothing
circElipsis r = Just (1/r^2,0,1/r^2,0,0,-1)

rotatePoint :: Float -> Point -> Point
rotatePoint alpha (x,y) = toCartesian (r,gama + (rad (-alpha)))
 where (r,gama) = toPolar (x,y)
 
rotatePath :: Float -> Path -> Path
rotatePath alpha = map (rotatePoint alpha)

rotateElipsis :: Float -> Elipsis -> Elipsis
rotateElipsis alpha (a,b,c,d,e,f) = (a',b',c',d',e',f')
 where theta = rad (alpha)
       a' = a*(cos theta)^2 + b*sin theta*cos theta + c*(sin theta)^2
       b' = 2*(c-a)*sin theta*cos theta + b*((cos theta)^2-(sin theta)^2)
       c' = a*(sin theta)^2 - b*sin theta*cos theta + c*(cos theta)^2
       d' = d*cos theta + e*sin theta
       e' = -d*sin theta + e*cos theta
       f' = f

translatePoint :: Float -> Float -> Point -> Point
translatePoint x y (a,b) = (a+x,b+y)

translatePointX :: Float -> Point -> Point
translatePointX f (x,y) = (x+f,y)

translatePointY :: Float -> Point -> Point
translatePointY f (x,y) = (x,y+f)

translatePath :: Float -> Float -> Path -> Path
translatePath x y = map (translatePoint x y)

translateElipsis :: Float -> Float -> Elipsis -> Elipsis
translateElipsis x y (a,b,c,d,e,f) = (a',b',c',d',e',f')
 where a' = a
       b' = b
       c' = c
       d' = d - 2*a*x - b*y
       e' = e - b*x - 2*c*y
       f' = f + a*x^2 + b*x*y + c*y^2 - d*x -e*y

scalePoint :: Float -> Float -> Point -> Point
scalePoint xs ys (x,y) = (x*xs,y*ys)

scalePath :: Float -> Float -> Path -> Path
scalePath xs ys = map (scalePoint xs ys)

scaleElipsis :: Float -> Float -> Elipsis -> Elipsis
scaleElipsis xs ys (a,b,c,d,e,f) = (a',b',c',d',e',f')
 where a' = a / (xs^2)
       b' = b / (xs * ys)
       c' = c / (ys^2)
       d' = d / xs
       e' = e / ys
       f' = f

mulPointwise :: Point -> Point -> Point
mulPointwise (a,b) (c,d) = (a*c,b*d)

-- * Auxiliary functions

-- | Converts degrees to radians
rad :: Float -> Float
rad alpha = alpha * pi / 180

-- | Converts radians to degrees
deg :: Float -> Float
deg alpha = alpha * 180 / pi