{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {- Copyright 2019 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 Control.DeepSeq import Data.List import Data.Monoid ((<>)) import Data.Text (Text) import GHC.Generics (Generic) import GHC.Stack import Util.EmbedAsUrl -- | A point in two dimensions. A point is written with the x coordinate -- first, and the y coordinate second. For example, (3, -2) is the point -- with x coordinate 3 a y coordinate -2. type Point = (Double, Double) -- | Moves a given point by given x and y offsets -- -- >>> translatedPoint 1 2 (10, 10) -- (11.0, 12.0) -- >>> translatedPoint (-1) (-2) (0, 0) -- (-1.0, -2.0) translatedPoint :: Double -> Double -> Point -> Point translatedPoint tx ty (x, y) = (x + tx, y + ty) -- | Rotates a given point by given angle, in radians -- -- >>> rotatedPoint 45 (10, 0) -- (7.071, 7.071) rotatedPoint :: Double -> Point -> Point rotatedPoint = rotatedVector -- | Reflects a given point across a line through the origin at this -- angle, in radians. For example, an angle of 0 reflects the point -- vertically across the x axis, while an angle of @pi / 2@ reflects the -- point horizontally across the y axis. reflectedPoint :: Double -> Point -> Point reflectedPoint th (x, y) = (x * cos a + y * sin a, x * sin a - y * cos a) where a = 2 * th -- | Scales a given point by given x and y scaling factor. Scaling by a -- negative factor also reflects across that axis. -- -- >>> scaledPoint 2 3 (10, 10) -- (20, 30) scaledPoint :: Double -> Double -> Point -> Point scaledPoint kx ky (x, y) = (kx * x, ky * y) -- | Dilates a given point by given uniform scaling factor. Dilating by a -- negative factor also reflects across the origin. -- -- >>> dilatedPoint 2 (10, 10) -- (20, 20) dilatedPoint :: Double -> Point -> Point dilatedPoint k (x, y) = (k * x, k * y) -- | A two-dimensional vector type Vector = (Double, Double) -- | The length of the given vector. -- -- >>> vectorLength (10, 10) -- 14.14 vectorLength :: Vector -> Double vectorLength (x, y) = sqrt (x*x + y*y) -- | The counter-clockwise angle, in radians, that a given vector make with the X-axis -- -- >>> vectorDirection (1,0) -- 0.0 -- >>> vectorDirection (1,1) -- 0.7853981633974483 -- >>> vectorDirection (0,1) -- 1.5707963267948966 vectorDirection :: Vector -> Double vectorDirection (x, y) = atan2 y x -- | The sum of two vectors vectorSum :: Vector -> Vector -> Vector vectorSum (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) -- | The difference of two vectors vectorDifference :: Vector -> Vector -> Vector vectorDifference (x1, y1) (x2, y2) = (x1 - x2, y1 - y2) -- | Scales a given vector by a given scalar multiplier. -- -- >>> scaledPoint 2 (10, 10) -- (20, 20) scaledVector :: Double -> Vector -> Vector scaledVector k (x, y) = (k * x, k * y) -- | Rotates a given vector by a given angle in radians -- -- >>> rotatedVector pi (1.0, 0.0) -- (-1.0, 1.2246467991473532e-16) -- >>> rotatedVector (pi / 2) (1.0, 0.0) -- (6.123233995736766e-17, 1.0) rotatedVector :: Double -> Vector -> Vector rotatedVector angle (x, y) = (x * cos angle - y * sin angle, x * sin angle + y * cos angle) -- | The dot product of two vectors dotProduct :: Vector -> Vector -> Double dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 -- | A design, diagram, or drawing that can be displayed and seen. -- In technical terms, a picture is an assignment of a color to -- every point of the coordinate plane. CodeWorld contains functions -- to create pictures from simple geometry primitives, to transform -- existing pictures, and to combine simpler pictures into more -- complex compositions. -- -- Ultimately, a picture can be drawn on the screen using one of the -- CodeWorld entry points such as 'drawingOf'. data Picture = SolidPolygon (Maybe SrcLoc) [Point] | SolidClosedCurve (Maybe SrcLoc) [Point] | Polygon (Maybe SrcLoc) [Point] | ThickPolygon (Maybe SrcLoc) [Point] !Double | Rectangle (Maybe SrcLoc) !Double !Double | SolidRectangle (Maybe SrcLoc) !Double !Double | ThickRectangle (Maybe SrcLoc) !Double !Double !Double | ClosedCurve (Maybe SrcLoc) [Point] | ThickClosedCurve (Maybe SrcLoc) [Point] !Double | Polyline (Maybe SrcLoc) [Point] | ThickPolyline (Maybe SrcLoc) [Point] !Double | Curve (Maybe SrcLoc) [Point] | ThickCurve (Maybe SrcLoc) [Point] !Double | Circle (Maybe SrcLoc) !Double | SolidCircle (Maybe SrcLoc) !Double | ThickCircle (Maybe SrcLoc) !Double !Double | Sector (Maybe SrcLoc) !Double !Double !Double | Arc (Maybe SrcLoc) !Double !Double !Double | ThickArc (Maybe SrcLoc) !Double !Double !Double !Double | StyledLettering (Maybe SrcLoc) !TextStyle !Font !Text | Lettering (Maybe SrcLoc) !Text | Color (Maybe SrcLoc) !Color !Picture | Translate (Maybe SrcLoc) !Double !Double !Picture | Scale (Maybe SrcLoc) !Double !Double !Picture | Dilate (Maybe SrcLoc) !Double !Picture | Rotate (Maybe SrcLoc) !Double !Picture | Reflect (Maybe SrcLoc) !Double !Picture | Clip (Maybe SrcLoc) !Double !Double !Picture | CoordinatePlane (Maybe SrcLoc) | Sketch (Maybe SrcLoc) !Text !Text !Double !Double | Pictures (Maybe SrcLoc) [Picture] | PictureAnd (Maybe SrcLoc) [Picture] | Blank (Maybe SrcLoc) deriving (Generic) instance NFData Picture -- A style in which to draw lettering. Either 'Plain', 'Bold', or -- 'Italic' data TextStyle = Plain -- ^ Plain letters with no style | Bold -- ^ Heavy, thick lettering used for emphasis | Italic -- ^ Slanted script-like lettering used for emphasis deriving (Generic, Show) instance NFData TextStyle -- A font in which to draw lettering. There are several built-in -- font families ('SansSerif', 'Serif', 'Monospace', 'Handwriting', -- and 'Fancy') that can look different on each screen. 'NamedFont' -- can be used for a specific font. However, if the font is not -- installed on the computer running your program, a different font -- may be used instead. data Font = SansSerif | Serif | Monospace | Handwriting | Fancy | NamedFont !Text deriving (Generic, Show) instance NFData Font -- | 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 2020."] #-} -- | 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 2020."] #-} -- | 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) {-# WARNING text ["Please used lettering instead of text.", "text may be removed July 2020."] #-} -- | 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) {-# WARNING styledText ["Please used styledLettering instead of styledText.", "styledText may be removed July 2020."] #-} -- | 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 in the x and y directions. Scaling -- by a negative factoralso reflects across that axis. scaled :: HasCallStack => Double -> Double -> Picture -> Picture scaled = Scale (getDebugSrcLoc callStack) -- | A picture scaled uniformly in all directions by this scale factor. -- Dilating by a negative factor also reflects across the origin. dilated :: HasCallStack => Double -> Picture -> Picture dilated = Dilate (getDebugSrcLoc callStack) -- | A picture rotated by this angle about the origin. -- -- Angles are in radians. rotated :: HasCallStack => Double -> Picture -> Picture rotated = Rotate (getDebugSrcLoc callStack) -- | A picture reflected across a line through the origin at this angle, in -- radians. For example, an angle of 0 reflects the picture vertically -- across the x axis, while an angle of @pi / 2@ reflects the picture -- horizontally across the y axis. reflected :: HasCallStack => Double -> Picture -> Picture reflected = Reflect (getDebugSrcLoc callStack) -- | A picture clipped to a rectangle around the origin with this width and height. clipped :: HasCallStack => Double -> Double -> Picture -> Picture clipped = Clip (getDebugSrcLoc callStack) -- A picture made by drawing these pictures, ordered from top to bottom. pictures :: HasCallStack => [Picture] -> Picture pictures = Pictures (getDebugSrcLoc callStack) -- | Binary composition of pictures. (&) :: HasCallStack => Picture -> Picture -> Picture infixr 0 & a & PictureAnd loc2 bs | srcContains loc1 loc2 = PictureAnd loc1 (a:bs) where loc1 = getDebugSrcLoc callStack a & b = PictureAnd (getDebugSrcLoc callStack) [a, b] instance Monoid Picture where mempty = blank mappend = (&) mconcat = pictures #if MIN_VERSION_base(4,11,0) instance Semigroup Picture where (<>) = (&) #endif -- | 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 = Sketch (getDebugSrcLoc callStack) "codeWorldLogo" $(embedAsUrl "image/svg+xml" "data/codeworld.svg") 17.68 7.28 -- | An image from a standard image format. The image can be any universally -- supported format, including SVG, PNG, JPG, etc. SVG should be preferred, as -- it behaves better with transformations. image :: HasCallStack => Text -- ^ Name for the picture, used for debugging -> Text -- ^ Data-scheme URI for the image data -> Double -- ^ Width, in CodeWorld screen units -> Double -- ^ Height, in CodeWorld screen units -> Picture image = Sketch (getDebugSrcLoc callStack) getDebugSrcLoc :: CallStack -> Maybe SrcLoc getDebugSrcLoc cs = Data.List.find ((== "main") . srcLocPackage) locs where locs = map snd (getCallStack cs) srcContains :: Maybe SrcLoc -> Maybe SrcLoc -> Bool srcContains Nothing _ = False srcContains _ Nothing = True srcContains (Just a) (Just b) = srcLocFile a == srcLocFile b && srcLocStartLine a < srcLocStartLine b || (srcLocStartLine a == srcLocStartLine b && srcLocStartCol a <= srcLocStartCol b) && srcLocEndLine a > srcLocEndLine b || (srcLocEndLine a == srcLocEndLine b && srcLocEndCol a >= srcLocEndCol b)