{-# Language OverloadedStrings #-}
{-# Language ViewPatterns #-}

module CodeWorld.Test.Rewrite (
  normalize,
  normalizeNoOrder,
  normalizeAndAbstract,
  ) where


import Data.Fixed                       (mod')
import Data.Generics.Uniplate.Data      (rewrite)
import Data.List.Extra                  (sort, takeEnd)

import CodeWorld.Tasks.Color            (black)
import CodeWorld.Tasks.VectorSpace (
  Point,
  atOriginWithOffset,
  crossProduct,
  dotProduct,
  isRectangle,
  reflectedPoint,
  rotatedVector,
  rotationAngle,
  scaledVector,
  sideLengths,
  vectorDifference,
  vectorSum,
  )
import CodeWorld.Tasks.Picture          (Picture(..), toInterface)
import CodeWorld.Tasks.Types            (Shape(..), Style(..))
import CodeWorld.Test.Abstract          (AbstractPicture)



{- |
Apply a set of rewriting rules to the Picture's syntax tree,
then abstract concrete parameters of the nodes,
resulting in an t`CodeWorld.Test.AbstractPicture`.

The new tree is normalized, simplified
and allows for more /fuzzy/ comparisons and queries.
-}
normalizeAndAbstract :: Picture -> AbstractPicture
normalizeAndAbstract :: Picture -> AbstractPicture
normalizeAndAbstract = Picture -> AbstractPicture
forall a. Drawable a => Picture -> a
toInterface (Picture -> AbstractPicture)
-> (Picture -> Picture) -> Picture -> AbstractPicture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> Picture
normalize

{- |
Apply a set of rewriting rules to the Picture's syntax tree.
The result is a normalized and simplified tree in /canonical/ form,
which draws the same image.
-}
normalize :: Picture -> Picture
normalize :: Picture -> Picture
normalize = (Picture -> Maybe Picture) -> Picture -> Picture
forall on. Uniplate on => (on -> Maybe on) -> on -> on
rewrite Picture -> Maybe Picture
applyRewritingRules

{- |
Same as `normalize`,
but also erases information on which subpictures are drawn in front or behind others.
-}
normalizeNoOrder :: Picture -> Picture
normalizeNoOrder :: Picture -> Picture
normalizeNoOrder Picture
p = case Picture -> Picture
normalize Picture
p of
  Pictures [Picture]
ps -> [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ [Picture] -> [Picture]
forall a. Ord a => [a] -> [a]
sort [Picture]
ps
  Picture
rp          -> Picture
rp


applyRewritingRules :: Picture -> Maybe Picture
applyRewritingRules :: Picture -> Maybe Picture
applyRewritingRules Picture
p
  | Picture
p Picture -> Picture -> Bool
forall a. Eq a => a -> a -> Bool
== Picture
rewritten = Maybe Picture
forall a. Maybe a
Nothing
  | Bool
otherwise = Picture -> Maybe Picture
forall a. a -> Maybe a
Just Picture
rewritten
  where
    rewritten :: Picture
rewritten = Picture -> Picture
rewriting Picture
p

rewriting :: Picture -> Picture
rewriting :: Picture -> Picture
rewriting (AnyCircle Style
_ Double
0) = Picture
Blank
rewriting (ThickCircle Double
t (Double -> Double
forall a. Num a => a -> a
abs -> Double
r))
  | Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
r = Double -> Picture
SolidCircle (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
rewriting (AnyCircle Style
s (Double -> Double
forall a. Num a => a -> a
abs -> Double
r)) = Style -> Double -> Picture
AnyCircle Style
s Double
r

rewriting (AnyRectangle Style
_ Double
0 Double
_) = Picture
Blank
rewriting (AnyRectangle Style
_ Double
_ Double
0) = Picture
Blank
rewriting (ThickRectangle Double
t (Double -> Double
forall a. Num a => a -> a
abs -> Double
l) (Double -> Double
forall a. Num a => a -> a
abs -> Double
w))
  | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
l Bool -> Bool -> Bool
|| Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
w = Double -> Double -> Picture
SolidRectangle (Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
rewriting (AnyRectangle Style
s (Double -> Double
forall a. Num a => a -> a
abs -> Double
l) (Double -> Double
forall a. Num a => a -> a
abs -> Double
w)) = Style -> Double -> Double -> Picture
toWideRectangle Style
s Double
l Double
w

rewriting (AnyArc Style
s Double
a1 Double
a2 Double
r) = Style -> Double -> Double -> Double -> Picture
checkArc Style
s Double
a1 Double
a2 Double
r

rewriting (AnyPolyline (Closed (Outline Maybe Double
mOutline)) [Point]
ps) = Shape -> [Point] -> Picture
AnyPolyline (Maybe Double -> Shape
Open Maybe Double
mOutline) ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ [Point] -> [Point]
toOpenShape [Point]
ps
rewriting (AnyPolyline Shape
s ([Point] -> [Point]
removeSurplus -> [Point]
ps)) = Shape -> [Point] -> Picture
checkForRectangle Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ [Point] -> [Point]
toOpenShape [Point]
ps

rewriting (AnyCurve (Closed (Outline Maybe Double
mOutline)) [Point]
ps) = Shape -> [Point] -> Picture
AnyCurve (Maybe Double -> Shape
Open Maybe Double
mOutline) ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ [Point] -> [Point]
toOpenShape [Point]
ps
rewriting (AnyCurve Shape
s [Point]
ps) = ([Point] -> Picture) -> [Point] -> Picture
handlePointList (Shape -> [Point] -> Picture
AnyCurve Shape
s) ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ [Point] -> [Point]
toOpenShape [Point]
ps

rewriting (Lettering Text
"") = Picture
Blank
rewriting (StyledLettering TextStyle
_ Font
_ Text
"") = Picture
Blank
rewriting (StyledLettering TextStyle
_ Font
_ Text
t) = Text -> Picture
Lettering Text
t

rewriting (Translate Double
0 Double
0 Picture
p) = Picture
p
rewriting (Translate Double
x Double
y Picture
p) = case Picture
p of
  Translate Double
a Double
b Picture
q  -> Double -> Double -> Picture -> Picture
Translate (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b) Picture
q
  Pictures [Picture]
ps      -> [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ (Picture -> Picture) -> [Picture] -> [Picture]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Picture -> Picture
Translate Double
x Double
y) [Picture]
ps
  Picture
Blank            -> Picture
Blank
  Color Color
c Picture
q        -> Color -> Picture -> Picture
Color Color
c (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Picture -> Picture
Translate Double
x Double
y Picture
q
  AnyPolyline Shape
s [Point]
ps -> Shape -> [Point] -> Picture
AnyPolyline Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point -> Point -> Point
vectorSum (Double
x,Double
y)) [Point]
ps
  AnyCurve Shape
s [Point]
ps    -> Shape -> [Point] -> Picture
AnyCurve Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Point -> Point -> Point
vectorSum (Double
x,Double
y)) [Point]
ps
  Picture
_                -> Double -> Double -> Picture -> Picture
Translate Double
x Double
y Picture
p

rewriting (Color Color
c Picture
p) = case Picture
p of
  Color Color
_ Picture
q      -> Color -> Picture -> Picture
Color Color
c Picture
q
  Pictures [Picture]
ps    -> [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ (Picture -> Picture) -> [Picture] -> [Picture]
forall a b. (a -> b) -> [a] -> [b]
map (Color -> Picture -> Picture
Color Color
c) [Picture]
ps
  Picture
Blank          -> Picture
Blank
  Picture
_              -> if Color
c Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
black then Picture
p else Color -> Picture -> Picture
Color Color
c Picture
p

rewriting (Dilate Double
d Picture
p) = Double -> Double -> Picture -> Picture
Scale Double
d Double
d Picture
p

rewriting (Scale Double
0 Double
_ Picture
_) = Picture
Blank
rewriting (Scale Double
_ Double
0 Picture
_) = Picture
Blank
rewriting (Scale Double
1 Double
1 Picture
p) = Picture
p
rewriting (Scale Double
fac1 Double
fac2 (AnyCircle Style
s Double
r))
  | Double
fac1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
fac2 = Style -> Double -> Picture
AnyCircle Style
s (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac1)
rewriting (Scale Double
fac1 Double
fac2 (AnyRectangle Style
s Double
l Double
w)) =
  Style -> Double -> Double -> Picture
AnyRectangle Style
s (Double
l Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac1) (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac2)
rewriting (Scale Double
fac1 Double
fac2 Picture
p) = case Picture
p of
  Scale Double
f1 Double
f2 Picture
q    -> Double -> Double -> Picture -> Picture
Scale (Double
f1 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac1) (Double
f2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac2) Picture
q
  Translate Double
x Double
y Picture
q  -> Double -> Double -> Picture -> Picture
Translate
    (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac1)
    (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fac2)
    (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Picture -> Picture
Scale Double
fac1 Double
fac2 Picture
q
  Picture
Blank            -> Picture
Blank
  Color Color
c Picture
q        -> Color -> Picture -> Picture
Color Color
c (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Picture -> Picture
Scale Double
fac1 Double
fac2 Picture
q
  Pictures [Picture]
ps      -> [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ (Picture -> Picture) -> [Picture] -> [Picture]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Picture -> Picture
Scale Double
fac1 Double
fac2) [Picture]
ps
  AnyPolyline Shape
s [Point]
ps -> Shape -> [Point] -> Picture
AnyPolyline Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Point -> Point
scaledVector Double
fac1 Double
fac2) [Point]
ps
  AnyCurve Shape
s [Point]
ps    -> Shape -> [Point] -> Picture
AnyCurve Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Point -> Point
scaledVector Double
fac1 Double
fac2) [Point]
ps
  Picture
_                -> Double -> Double -> Picture -> Picture
Scale Double
fac1 Double
fac2 Picture
p

rewriting (Rotate (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a) Picture
p)
    | Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 = Picture
p
    | Bool
otherwise = case Picture
p of
      Scale Double
fac1 Double
fac2 c :: Picture
c@(AnyCircle {})
        | Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2 Bool -> Bool -> Bool
|| Double
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
3Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
                      -> Double -> Double -> Picture -> Picture
Scale Double
fac2 Double
fac1 Picture
c
      Rotate Double
a2 Picture
q     -> Double -> Picture -> Picture
Rotate (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
a2) Picture
q
      Reflect Double
a2 Picture
q    -> Double -> Picture -> Picture
Reflect (Double
a2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
aDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) Picture
q
      Translate Double
x Double
y Picture
q -> Double -> Double -> Picture -> Picture
Translate
                          (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double -> Double
forall a. Floating a => a -> a
cos Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double -> Double
forall a. Floating a => a -> a
sin Double
a)
                          (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double -> Double
forall a. Floating a => a -> a
sin Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double -> Double
forall a. Floating a => a -> a
cos Double
a)
                          (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Picture -> Picture
Rotate Double
a Picture
q
      Color Color
c Picture
q       -> Color -> Picture -> Picture
Color Color
c (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Picture -> Picture
Rotate Double
a Picture
q
      Pictures [Picture]
ps     -> [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ (Picture -> Picture) -> [Picture] -> [Picture]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Picture -> Picture
Rotate Double
a) [Picture]
ps
      r :: Picture
r@AnyRectangle {}
        | Double
a Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
forall a. Floating a => a
pi -> Double -> Picture -> Picture
Rotate (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
forall a. Floating a => a
pi) Picture
r
      c :: Picture
c@AnyCircle {}      -> Picture
c
      AnyPolyline Shape
s [Point]
ps -> Shape -> [Point] -> Picture
AnyPolyline Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Point -> Point
rotatedVector Double
a) [Point]
ps
      AnyCurve Shape
s [Point]
ps    -> Shape -> [Point] -> Picture
AnyCurve Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Point -> Point
rotatedVector Double
a) [Point]
ps
      Picture
_                -> Double -> Picture -> Picture
Rotate Double
a Picture
p

rewriting (Reflect (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a1) (Reflect (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a2) Picture
p))
  | Double
a1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
a2 = Picture
p
  | Bool
otherwise = Double -> Picture -> Picture
Rotate (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
a1Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2) Picture
p
rewriting (Reflect Double
a r :: Picture
r@(AnyRectangle {})) = Double -> Picture -> Picture
Rotate (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
aDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2) Picture
r
rewriting (Reflect Double
_ c :: Picture
c@(AnyCircle {})) = Picture
c
rewriting (Reflect Double
a (Pictures [Picture]
ps)) = [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$ (Picture -> Picture) -> [Picture] -> [Picture]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Picture -> Picture
Reflect Double
a) [Picture]
ps
rewriting (Reflect (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a) (Translate Double
x Double
y Picture
p)) =
  let
    twoTimesSquaredSubOne :: (Double -> a) -> a
twoTimesSquaredSubOne Double -> a
f = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* Double -> a
f Double
aa -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
2 :: Int) a -> a -> a
forall a. Num a => a -> a -> a
-a
1
    twoTimesCosSin :: Double
twoTimesCosSin = Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
cos Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
sin Double
a
  in Double -> Double -> Picture -> Picture
Translate
    ((Double -> Double) -> Double
forall {a}. Num a => (Double -> a) -> a
twoTimesSquaredSubOne Double -> Double
forall a. Floating a => a -> a
cos Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
twoTimesCosSin Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
    (Double
twoTimesCosSin Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double -> Double) -> Double
forall {a}. Num a => (Double -> a) -> a
twoTimesSquaredSubOne Double -> Double
forall a. Floating a => a -> a
sin Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
    (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Picture -> Picture
Reflect Double
a Picture
p
rewriting (Reflect Double
a (Rotate Double
a2 Picture
p)) = Double -> Picture -> Picture
Reflect (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- (Double
a2Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)) Picture
p
rewriting (Reflect Double
a (Color Color
c Picture
q))   = Color -> Picture -> Picture
Color Color
c (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Picture -> Picture
Reflect Double
a Picture
q
rewriting (Reflect (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a) Picture
p) = case Picture
p of
  AnyPolyline Shape
s [Point]
ps -> Shape -> [Point] -> Picture
AnyPolyline Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Point -> Point
reflectedPoint Double
a) [Point]
ps
  AnyCurve Shape
s [Point]
ps    -> Shape -> [Point] -> Picture
AnyCurve Shape
s ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> [Point] -> [Point]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Point -> Point
reflectedPoint Double
a) [Point]
ps
  Picture
_                -> Double -> Picture -> Picture
Reflect Double
a Picture
p

rewriting (Pictures [Picture]
ps) = (Picture -> Picture -> Picture) -> Picture -> [Picture] -> Picture
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Picture
a -> Picture -> Picture
rewriting (Picture -> Picture) -> (Picture -> Picture) -> Picture -> Picture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> Picture -> Picture
And Picture
a) Picture
Blank [Picture]
ps
rewriting (And Picture
Blank Picture
p) = Picture
p
rewriting (And Picture
p Picture
Blank) = Picture
p
rewriting (And (AnyPolyline Shape
s1 [Point]
ps1) (AnyPolyline Shape
s2 [Point]
ps2))
  | Shape
s1 Shape -> Shape -> Bool
forall a. Eq a => a -> a -> Bool
== Shape
s2 = ([Point] -> Picture) -> [Point] -> [Point] -> Picture
handleLikeFreeShapes (Shape -> [Point] -> Picture
AnyPolyline Shape
s1) [Point]
ps1 [Point]
ps2
rewriting (And (AnyCurve Shape
s1 [Point]
ps1) (AnyCurve Shape
s2 [Point]
ps2))
  | Shape
s1 Shape -> Shape -> Bool
forall a. Eq a => a -> a -> Bool
== Shape
s2 = ([Point] -> Picture) -> [Point] -> [Point] -> Picture
handleLikeFreeShapes (Shape -> [Point] -> Picture
AnyCurve Shape
s1) [Point]
ps1 [Point]
ps2
rewriting (And Picture
p Picture
q) = if Picture -> Picture -> Bool
lowerPrecedence Picture
p Picture
q
    then Picture -> Picture -> Picture
And Picture
q Picture
p
    else [Picture] -> Picture
Pictures ([Picture] -> Picture) -> [Picture] -> Picture
forall a b. (a -> b) -> a -> b
$  [Picture]
ps1 [Picture] -> [Picture] -> [Picture]
forall a. [a] -> [a] -> [a]
++ [Picture]
ps2
  where
    ps1 :: [Picture]
ps1 = case Picture
p of
      Pictures [Picture]
ps -> [Picture]
ps
      Picture
_           -> [Picture
p]
    ps2 :: [Picture]
ps2 = case Picture
q of
      Pictures [Picture]
ps -> [Picture]
ps
      Picture
_           -> [Picture
q]
rewriting Picture
p = Picture
p


-- This only considers the "open shape" variant if both kinds exist.
-- The closed variant is rewritten to an open one in a rule above.
lowerPrecedence :: Picture -> Picture -> Bool
lowerPrecedence :: Picture -> Picture -> Bool
lowerPrecedence (AnyPolyline {}) (AnyCurve {}) = Bool
True
lowerPrecedence (AnyPolyline (Open Maybe Double
_) [Point]
_) (SolidPolygon {}) = Bool
True
lowerPrecedence (Polyline {}) (ThickPolyline {}) = Bool
True
lowerPrecedence (AnyCurve (Open Maybe Double
_) [Point]
_) (SolidClosedCurve {}) = Bool
True
lowerPrecedence (Curve {}) (ThickCurve {}) = Bool
True
lowerPrecedence Picture
_ Picture
_ = Bool
False

toOpenShape :: [Point] -> [Point]
toOpenShape :: [Point] -> [Point]
toOpenShape [Point]
ps
  | [Point]
start <- Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
take Int
1 [Point]
ps, [Point]
start [Point] -> [Point] -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
takeEnd Int
1 [Point]
ps = [Point]
ps [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
start
  | Bool
otherwise = [Point]
ps

toWideRectangle :: Style -> Double -> Double -> Picture
toWideRectangle :: Style -> Double -> Double -> Picture
toWideRectangle Style
style Double
l Double
w
    | Double
l Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
w = Style -> Double -> Double -> Picture
AnyRectangle Style
style Double
l Double
w
    | Bool
otherwise = Double -> Picture -> Picture
Rotate (Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Style -> Double -> Double -> Picture
AnyRectangle Style
style Double
w Double
l


checkArc :: Style -> Double -> Double -> Double -> Picture
checkArc :: Style -> Double -> Double -> Double -> Picture
checkArc Style
_ Double
_ Double
_ Double
0 = Picture
Blank
checkArc Style
style (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a1) (Double -> Double
forall a. (Floating a, Real a) => a -> a
capAngle -> Double
a2) Double
r
  | Double
a1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
a2              = Picture
Blank
  | Double
a1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
a2               = Style -> Double -> Double -> Double -> Picture
AnyArc Style
style Double
a2 Double
a1 Double
r
  | Double -> Double
forall a. Num a => a -> a
abs (Double
a1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a2) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi = Style -> Double -> Picture
AnyCircle Style
style Double
r
  | Bool
otherwise             = Style -> Double -> Double -> Double -> Picture
AnyArc Style
style Double
a1 Double
a2 Double
r

handlePointList :: ([Point] -> Picture) -> [Point] -> Picture
handlePointList :: ([Point] -> Picture) -> [Point] -> Picture
handlePointList [Point] -> Picture
shape [Point]
ps
    | [Point] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Point]
noRepeats Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Picture
Blank
    | Bool
otherwise = [Point] -> Picture
shape [Point]
noRepeats
  where
    noRepeats :: [Point]
noRepeats = [Point] -> [Point]
forall a. Eq a => [a] -> [a]
removeDupes [Point]
ps

removeDupes :: Eq a => [a] -> [a]
removeDupes :: forall a. Eq a => [a] -> [a]
removeDupes []       = []
removeDupes xs :: [a]
xs@(a
x:[a]
_) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [ a
a | (a
a,a
b) <- [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
xs) [a]
xs, a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
b]

-- remove all points that lie on line segments between neighbours
removeSurplus :: [Point] -> [Point]
removeSurplus :: [Point] -> [Point]
removeSurplus (Point
a:Point
p:Point
b:[Point]
xs)
  | Point
pSubA <- Point -> Point -> Point
vectorDifference Point
p Point
a,
    Double -> Double
forall a. Num a => a -> a
abs (Point -> Point -> Double
crossProduct (Point -> Point -> Point
vectorDifference Point
b Point
a) Point
pSubA) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0.01 Bool -> Bool -> Bool
&&
    Point -> Point -> Double
dotProduct Point
pSubA (Point -> Point -> Point
vectorDifference Point
p Point
b) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0
    = [Point] -> [Point]
removeSurplus ([Point] -> [Point]) -> [Point] -> [Point]
forall a b. (a -> b) -> a -> b
$ Point
aPoint -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:Point
bPoint -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:[Point]
xs
  | Bool
otherwise = Point
a Point -> [Point] -> [Point]
forall a. a -> [a] -> [a]
: [Point] -> [Point]
removeSurplus (Point
pPoint -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:Point
bPoint -> [Point] -> [Point]
forall a. a -> [a] -> [a]
:[Point]
xs)
removeSurplus [Point]
xs = [Point]
xs

handleLikeFreeShapes
  :: ([Point] -> Picture)
  -> [Point]
  -> [Point]
  -> Picture
handleLikeFreeShapes :: ([Point] -> Picture) -> [Point] -> [Point] -> Picture
handleLikeFreeShapes [Point] -> Picture
s1 [Point]
ps1 [Point]
ps2
  | [Point]
endPs1 [Point] -> [Point] -> Bool
forall a. Eq a => a -> a -> Bool
== [Point]
startPs2
  = [Point] -> Picture
s1 ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ [Point]
ps1 [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
restPs2
  | [Point]
endPs1 [Point] -> [Point] -> Bool
forall a. Eq a => a -> a -> Bool
== [Point]
startRevPs2
  = [Point] -> Picture
s1 ([Point] -> Picture) -> [Point] -> Picture
forall a b. (a -> b) -> a -> b
$ [Point]
ps1 [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point]
endRevPs2
  | Bool
otherwise = [Picture] -> Picture
Pictures [[Point] -> Picture
s1 [Point]
ps1, [Point] -> Picture
s1 [Point]
ps2]
    where
      ([Point]
startPs2,[Point]
restPs2) = Int -> [Point] -> ([Point], [Point])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 [Point]
ps2
      ([Point]
startRevPs2, [Point]
endRevPs2) = Int -> [Point] -> ([Point], [Point])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 ([Point] -> ([Point], [Point])) -> [Point] -> ([Point], [Point])
forall a b. (a -> b) -> a -> b
$ [Point] -> [Point]
forall a. [a] -> [a]
reverse [Point]
ps2
      endPs1 :: [Point]
endPs1 = Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
takeEnd Int
1 [Point]
ps1

checkForRectangle :: Shape -> [Point] -> Picture
checkForRectangle :: Shape -> [Point] -> Picture
checkForRectangle Shape
shape [Point]
ps = case Shape -> [Point] -> Maybe Picture
pointsToRectangle Shape
shape [Point]
ps of
  Maybe Picture
Nothing -> ([Point] -> Picture) -> [Point] -> Picture
handlePointList (Shape -> [Point] -> Picture
AnyPolyline Shape
shape) [Point]
ps
  Just Picture
r  -> Picture
r

pointsToRectangle :: Shape -> [Point] -> Maybe Picture
pointsToRectangle :: Shape -> [Point] -> Maybe Picture
pointsToRectangle Shape
shapeKind [Point]
ps
  | [Point] -> Bool
isRectangle [Point]
ps = Picture -> Maybe Picture
forall a. a -> Maybe a
Just (Picture -> Maybe Picture) -> Picture -> Maybe Picture
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Picture -> Picture
Translate Double
x Double
y (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Picture -> Picture
Rotate Double
angle (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Picture
shapeToUse Double
xLen Double
yLen
  | Bool
otherwise = Maybe Picture
forall a. Maybe a
Nothing
  where
    (Double
xLen,Double
yLen) = [Point] -> Point
sideLengths [Point]
ps
    angle :: Double
angle = [Point] -> Double
rotationAngle [Point]
originPs
    ([Point]
originPs,(Double
x,Double
y)) = [Point] -> ([Point], Point)
atOriginWithOffset (Int -> [Point] -> [Point]
forall a. Int -> [a] -> [a]
drop Int
1 [Point]
ps)
    shapeToUse :: Double -> Double -> Picture
shapeToUse = case Shape
shapeKind of
      Closed (Outline (Just Double
t)) -> Double -> Double -> Double -> Picture
ThickRectangle Double
t
      Open (Just Double
t)             -> Double -> Double -> Double -> Picture
ThickRectangle Double
t
      Closed Style
Solid              -> Double -> Double -> Picture
SolidRectangle
      Shape
_                         -> Double -> Double -> Picture
Rectangle

capAngle :: (Floating a, Real a) => a -> a
capAngle :: forall a. (Floating a, Real a) => a -> a
capAngle a
a = a
a a -> a -> a
forall a. Real a => a -> a -> a
`mod'` (a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Floating a => a
pi)