{-# LANGUAGE CPP #-} {- Copyright 2018 The CodeWorld Authors. All rights reserved. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} module CodeWorld.Picture where import CodeWorld.Color import Data.List import Data.Monoid ((<>)) import Data.Text (Text, pack) import GHC.Stack type Point = (Double, Double) translatedPoint :: Double -> Double -> Point -> Point translatedPoint tx ty (x, y) = (x + tx, y + ty) rotatedPoint :: Double -> Point -> Point rotatedPoint = rotatedVector scaledPoint :: Double -> Double -> Point -> Point scaledPoint kx ky (x, y) = (kx * x, ky * y) dilatedPoint :: Double -> Point -> Point dilatedPoint k (x, y) = (k * x, k * y) type Vector = (Double, Double) vectorLength :: Vector -> Double vectorLength (x, y) = sqrt (x ^ 2 + y ^ 2) vectorDirection :: Vector -> Double vectorDirection (x, y) = atan2 y x vectorSum :: Vector -> Vector -> Vector vectorSum (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) vectorDifference :: Vector -> Vector -> Vector vectorDifference (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) scaledVector :: Double -> Vector -> Vector scaledVector k (x, y) = (k * x, k * y) {-| Angle is in radians -} rotatedVector :: Double -> Vector -> Vector rotatedVector angle (x, y) = (x * cos angle - y * sin angle, x * sin angle + y * cos angle) dotProduct :: Vector -> Vector -> Double dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 getDebugSrcLoc :: CallStack -> SrcLoc getDebugSrcLoc cs = case Data.List.find ((== "main") . srcLocPackage) locs of Just loc -> loc Nothing -> error "Cannot find debug source location." where locs = map snd (getCallStack cs) data Picture = SolidPolygon SrcLoc [Point] | SolidClosedCurve SrcLoc [Point] | Polygon SrcLoc [Point] | ThickPolygon SrcLoc [Point] !Double | Rectangle SrcLoc !Double !Double | SolidRectangle SrcLoc !Double !Double | ThickRectangle SrcLoc !Double !Double !Double | ClosedCurve SrcLoc [Point] | ThickClosedCurve SrcLoc [Point] !Double | Polyline SrcLoc [Point] | ThickPolyline SrcLoc [Point] !Double | Curve SrcLoc [Point] | ThickCurve SrcLoc [Point] !Double | Circle SrcLoc !Double | SolidCircle SrcLoc !Double | ThickCircle SrcLoc !Double !Double | Sector SrcLoc !Double !Double !Double | Arc SrcLoc !Double !Double !Double | ThickArc SrcLoc !Double !Double !Double !Double | StyledLettering SrcLoc !TextStyle !Font !Text | Lettering SrcLoc !Text | Color SrcLoc !Color !Picture | Translate SrcLoc !Double !Double !Picture | Scale SrcLoc !Double !Double !Picture | Dilate SrcLoc !Double !Picture | Rotate SrcLoc !Double !Picture | CoordinatePlane SrcLoc | Logo SrcLoc | Pictures [Picture] | Blank SrcLoc data TextStyle = Plain | Bold | Italic deriving (Show) data Font = SansSerif | Serif | Monospace | Handwriting | Fancy | NamedFont !Text deriving (Show) -- | A blank picture blank :: HasCallStack => Picture blank = Blank (getDebugSrcLoc callStack) -- | A thin sequence of line segments, with these points as endpoints polyline :: HasCallStack => [Point] -> Picture polyline ps = Polyline (getDebugSrcLoc callStack) ps -- | A thin sequence of line segments, with these points as endpoints path :: HasCallStack => [Point] -> Picture path ps = Polyline (getDebugSrcLoc callStack) ps {-# WARNING path ["Please use polyline instead of path.", "path may be removed July 2019."] #-} -- | A thick sequence of line segments, with given line width and endpoints thickPolyline :: HasCallStack => Double -> [Point] -> Picture thickPolyline n ps = ThickPolyline (getDebugSrcLoc callStack) ps n -- | A thick sequence of line segments, with given line width and endpoints thickPath :: HasCallStack => Double -> [Point] -> Picture thickPath n ps = ThickPolyline (getDebugSrcLoc callStack) ps n {-# WARNING thickPath ["Please used thickPolyline instead of thickPath.", "thickPath may be removed July 2019."] #-} -- | A thin polygon with these points as vertices polygon :: HasCallStack => [Point] -> Picture polygon ps = Polygon (getDebugSrcLoc callStack) ps -- | A thick polygon with this line width and these points as -- vertices thickPolygon :: HasCallStack => Double -> [Point] -> Picture thickPolygon n ps = ThickPolygon (getDebugSrcLoc callStack) ps n -- | A solid polygon with these points as vertices solidPolygon :: HasCallStack => [Point] -> Picture solidPolygon ps = SolidPolygon (getDebugSrcLoc callStack) ps -- | A smooth curve passing through these points. curve :: HasCallStack => [Point] -> Picture curve ps = Curve (getDebugSrcLoc callStack) ps -- | A thick smooth curve with this line width, passing through these points. thickCurve :: HasCallStack => Double -> [Point] -> Picture thickCurve n ps = ThickCurve (getDebugSrcLoc callStack) ps n -- | A smooth closed curve passing through these points. closedCurve :: HasCallStack => [Point] -> Picture closedCurve ps = ClosedCurve (getDebugSrcLoc callStack) ps -- | A thick smooth closed curve with this line width, passing through these points. thickClosedCurve :: HasCallStack => Double -> [Point] -> Picture thickClosedCurve n ps = ThickClosedCurve (getDebugSrcLoc callStack) ps n -- | A solid smooth closed curve passing through these points. solidClosedCurve :: HasCallStack => [Point] -> Picture solidClosedCurve ps = SolidClosedCurve (getDebugSrcLoc callStack) ps rectangleVertices :: Double -> Double -> [Point] rectangleVertices w h = [ (w / 2, h / 2), (w / 2, -h / 2), (-w / 2, -h / 2), (-w / 2, h / 2) ] -- | A thin rectangle, with this width and height rectangle :: HasCallStack => Double -> Double -> Picture rectangle w h = Rectangle (getDebugSrcLoc callStack) w h -- | A solid rectangle, with this width and height solidRectangle :: HasCallStack => Double -> Double -> Picture solidRectangle w h = SolidRectangle (getDebugSrcLoc callStack) w h -- | A thick rectangle, with this line width, and width and height thickRectangle :: HasCallStack => Double -> Double -> Double -> Picture thickRectangle lw w h = ThickRectangle (getDebugSrcLoc callStack) lw w h -- | A thin circle, with this radius circle :: HasCallStack => Double -> Picture circle = Circle (getDebugSrcLoc callStack) -- | A thick circle, with this line width and radius thickCircle :: HasCallStack => Double -> Double -> Picture thickCircle = ThickCircle (getDebugSrcLoc callStack) -- | A thin arc, starting and ending at these angles, with this radius -- -- Angles are in radians. arc :: HasCallStack => Double -> Double -> Double -> Picture arc b e r = Arc (getDebugSrcLoc callStack) b e r -- | A thick arc with this line width, starting and ending at these angles, -- with this radius. -- -- Angles are in radians. thickArc :: HasCallStack => Double -> Double -> Double -> Double -> Picture thickArc w b e r = ThickArc (getDebugSrcLoc callStack) b e r w -- | A solid circle, with this radius solidCircle :: HasCallStack => Double -> Picture solidCircle = SolidCircle (getDebugSrcLoc callStack) -- | A solid sector of a circle (i.e., a pie slice) starting and ending at these -- angles, with this radius -- -- Angles are in radians. sector :: HasCallStack => Double -> Double -> Double -> Picture sector = Sector (getDebugSrcLoc callStack) -- | A rendering of text characters. text :: HasCallStack => Text -> Picture text = Lettering (getDebugSrcLoc callStack) -- | A rendering of text characters. lettering :: HasCallStack => Text -> Picture lettering = Lettering (getDebugSrcLoc callStack) -- | A rendering of text characters, with a specific choice of font and style. styledText :: HasCallStack => TextStyle -> Font -> Text -> Picture styledText = StyledLettering (getDebugSrcLoc callStack) -- | A rendering of text characters onto a Picture, with a specific -- choice of font and style. styledLettering :: HasCallStack => TextStyle -> Font -> Text -> Picture styledLettering = StyledLettering (getDebugSrcLoc callStack) -- | A picture drawn entirely in this color. colored :: HasCallStack => Color -> Picture -> Picture colored = Color (getDebugSrcLoc callStack) -- | A picture drawn entirely in this colour. coloured :: HasCallStack => Color -> Picture -> Picture coloured = colored -- | A picture drawn translated in these directions. translated :: HasCallStack => Double -> Double -> Picture -> Picture translated = Translate (getDebugSrcLoc callStack) -- | A picture scaled by these factors. scaled :: HasCallStack => Double -> Double -> Picture -> Picture scaled = Scale (getDebugSrcLoc callStack) -- | A picture scaled by these factors. dilated :: HasCallStack => Double -> Picture -> Picture dilated = Dilate (getDebugSrcLoc callStack) -- | A picture rotated by this angle. -- -- Angles are in radians. rotated :: HasCallStack => Double -> Picture -> Picture rotated = Rotate (getDebugSrcLoc callStack) -- A picture made by drawing these pictures, ordered from top to bottom. pictures :: [Picture] -> Picture pictures = Pictures #if MIN_VERSION_base(4,11,0) instance Semigroup Picture where a <> (Pictures bs) = Pictures (a : bs) a <> b = Pictures [a, b] #endif instance Monoid Picture where mempty = blank mappend a (Pictures bs) = Pictures (a : bs) mappend a b = Pictures [a, b] mconcat = pictures -- | Binary composition of pictures. (&) :: Picture -> Picture -> Picture infixr 0 & (&) = mappend -- | A coordinate plane. Adding this to your pictures can help you measure distances -- more accurately. -- -- Example: -- -- main = drawingOf (myPicture <> coordinatePlane) -- myPicture = ... coordinatePlane :: HasCallStack => Picture coordinatePlane = CoordinatePlane (getDebugSrcLoc callStack) -- | The CodeWorld logo. codeWorldLogo :: HasCallStack => Picture codeWorldLogo = Logo (getDebugSrcLoc callStack)