juicy-draw (empty) → 0.1.0.0
raw patch · 6 files changed
+346/−0 lines, 6 filesdep +JuicyPixelsdep +basedep +juicy-drawsetup-changed
Dependencies added: JuicyPixels, base, juicy-draw, primitive
Files
- LICENSE +20/−0
- README.md +79/−0
- Setup.hs +16/−0
- app/Main.hs +38/−0
- juicy-draw.cabal +37/−0
- src/Codec/Picture/Drawing.hs +156/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2018 Richard Cook++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,79 @@+# `juicy-draw`++[](https://travis-ci.org/rcook/juicy-draw)+[](http://hackage.haskell.org/package/juicy-draw)+[](https://raw.githubusercontent.com/rcook/juicy-draw/master/LICENSE)++Functions for drawing and filling lines, rectangles and polygons directly onto a [JuicyPixels][juicypixels] mutable image; inspired by [JuicyPixels-canvas][juicypixels-canvas] but without the `Canvas` part++## Example++++See [code][example-code].++## Set up dev tools++This project can be built using the [Stack][stack] build tool.++```bash+stack build intero+stack build --copy-compiler-tool ghcid+```++## ghcid++```bash+stack exec ghcid -- -T':main'+```++## Build++```bash+stack build+```++## Test++```bash+stack test+```++## Run demo++```bash+stack exec juicy-draw-demo+```++## Upload package++```+stack upload .+```++## Upload documentation++I use my [`upload-haddocks`][upload-haddocks] tool which requires a functioning installation of Python and pip:++```+pip install --user upload-haddocks+upload-haddocks+```++## Releases++[View change log for more information][change-log]++## Licence++[MIT License][licence]++Copyright © 2017, Richard Cook.++[change-log]: CHANGELOG.md+[example-code]: app/Main.hs+[juicypixels]: https://hackage.haskell.org/package/JuicyPixels+[juicypixels-canvas]: https://hackage.haskell.org/package/JuicyPixels-canvas+[licence]: LICENSE+[stack]: http://haskellstack.org/+[upload-haddocks]: https://github.com/rcook/upload-haddocks
+ Setup.hs view
@@ -0,0 +1,16 @@+{-|+Module : Main+Description : Setup entrypoint for @juicy-draw@+Copyright : (C) Richard Cook, 2018+Licence : MIT+Maintainer : rcook@rcook.org+Stability : stable+Portability : portable+-}++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,38 @@+module Main (main) where++import Codec.Picture+import Codec.Picture.Drawing++main :: IO ()+main = do+ let w = 480+ h = 360++ img <- withMutableImage w h (PixelRGB8 150 0 0) $ \m -> do+ -- A green diagonal line+ drawLine m 0 0 (w - 1) (h - 1) (PixelRGB8 0 255 0)++ -- A blue square at a 45-degree angle+ drawPolygon m [(50, 50), (75, 75), (100, 50), (75, 25), (50, 50)] (PixelRGB8 0 0 255)++ -- An orange bounding rectangle+ drawRectangle m 0 0 (w - 1) (h - 1) (PixelRGB8 255 150 0)++ -- A mangenta filled rectangle+ fillRectangle m 200 30 250 130 (PixelRGB8 255 0 255)++ -- A dark green filled triangle+ fillTriangle m 50 200 250 300 70 350 (PixelRGB8 0 150 50)++ -- A blue pentagon+ drawPolygon m+ [ (340, 80)+ , (245, 149)+ , (281, 261)+ , (399, 261)+ , (435, 149)+ , (340, 80)+ ]+ (PixelRGB8 0 0 255)++ writePng "example.png" img
+ juicy-draw.cabal view
@@ -0,0 +1,37 @@+name: juicy-draw+version: 0.1.0.0+synopsis: Functions for drawing and filling lines, rectangles and polygons directly onto a mutable image+description: This package provides 2D primitives for drawing/fill simple 2D shapes+homepage: https://github.com/rcook/juicy-draw#readme+license: MIT+license-file: LICENSE+author: Richard Cook+maintainer: rcook@rcook.org+copyright: 2018 Richard Cook+category: Graphics+build-type: Simple+cabal-version: >= 1.10+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/rcook/juicy-draw++library+ default-language: Haskell2010+ ghc-options: -O2 -Wall -fno-warn-missing-signatures+ hs-source-dirs: src+ build-depends:+ JuicyPixels+ , base >= 4.7 && < 5+ , primitive+ exposed-modules: Codec.Picture.Drawing++executable juicy-draw-demo+ default-language: Haskell2010+ hs-source-dirs: app+ main-is: Main.hs+ build-depends:+ JuicyPixels+ , base >= 4.7 && < 5+ , juicy-draw
+ src/Codec/Picture/Drawing.hs view
@@ -0,0 +1,156 @@+{-|+Module : Codec.Picture.Draw+Description : Functions for drawing and filling lines, rectangles and polygons directly onto a mutable image+Copyright : (C) Richard Cook, 2018+Licence : MIT+Maintainer : rcook@rcook.org+Stability : stable+Portability : portable++Functions for drawing and filling lines, rectangles and polygons directly onto a JuicyPixels mutable image+-}++module Codec.Picture.Drawing+ ( drawLine+ , drawPolygon+ , drawRectangle+ , fillRectangle+ , fillTriangle+ , withDefaultMutableImage+ , withMutableImage+ ) where++import Codec.Picture.Types+ ( Image+ , MutableImage(..)+ , Pixel+ , createMutableImage+ , newMutableImage+ , unsafeFreezeImage+ , writePixel+ )+import Control.Monad (when)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Foldable (for_)++-- | Create an image given a function to apply to a default empty mutable image+withDefaultMutableImage :: (Pixel px, PrimMonad m) =>+ Int -- ^ image width+ -> Int -- ^ image height+ -> (MutableImage (PrimState m) px -> m ()) -- ^ function to apply to mutable image+ -> m (Image px) -- ^ immutable image result+withDefaultMutableImage w h f = do+ m <- newMutableImage w h+ f m+ unsafeFreezeImage m++-- | Create an image given a function to apply to an empty mutable image+withMutableImage :: (Pixel px, PrimMonad m) =>+ Int -- ^ image width+ -> Int -- ^ image height+ -> px -- ^ background colour+ -> (MutableImage (PrimState m) px -> m ()) -- ^ function to apply to mutable image+ -> m (Image px) -- ^ action+withMutableImage w h px f = do+ m <- createMutableImage w h px+ f m+ unsafeFreezeImage m++-- | Draw a line in the specified colour+drawLine :: (Pixel px, PrimMonad m) =>+ MutableImage (PrimState m) px -- ^ mutable image+ -> Int -- ^ x-coordinate of starting point+ -> Int -- ^ y-coordinate of starting point+ -> Int -- ^ x-coordinate of end point+ -> Int -- ^ y-coordinate of end point+ -> px -- ^ colour+ -> m () -- ^ action+drawLine m x1 y1 x2 y2 colour =+ let dx = fromIntegral (x2 - x1) :: Double+ dy = fromIntegral (y2 - y1) :: Double+ in+ if abs dx > abs dy+ then+ for_ [min x1 x2..max x1 x2] $ \x ->+ let y = y1 + truncate (dy * fromIntegral (x - x1) / dx)+ in writePixel m x y colour+ else+ for_ [min y1 y2..max y1 y2] $ \y ->+ let x = x1 + truncate (dx * fromIntegral (y - y1) / dy)+ in writePixel m x y colour++-- | Draw a polygon in the specified colour+drawPolygon :: (Pixel px, PrimMonad m) =>+ MutableImage (PrimState m) px -- ^ mutable image+ -> [(Int, Int)] -- ^ sequence of vertices+ -> px -- ^ colour+ -> m () -- ^ action+drawPolygon _ [] _ = pure ()+drawPolygon _ [_] _ = pure ()+drawPolygon m ((x1, y1) : xs@((x2, y2) : _)) colour = do+ drawLine m x1 y1 x2 y2 colour+ drawPolygon m xs colour++-- | Draw a rectangle in the specified colour+drawRectangle :: (Pixel px, PrimMonad m) =>+ MutableImage (PrimState m) px -- ^ mutable image+ -> Int -- ^ x-coordinate of top-left corner+ -> Int -- ^ y-coordinate of top-left corner+ -> Int -- ^ x-coordinate of bottom-right corner+ -> Int -- ^ y-coordinate of bottom-right corner+ -> px -- ^ colour+ -> m () -- ^ action+drawRectangle m x1 y1 x2 y2 = drawPolygon m [(x1, y1), (x2, y1), (x2, y2), (x1, y2), (x1, y1)]++-- | Fill a rectangle with the specified colour+fillRectangle :: (Pixel px, PrimMonad m) =>+ MutableImage (PrimState m) px -- ^ mutable image+ -> Int -- ^ x-coordinate of top-left corner+ -> Int -- ^ y-coordinate of top-left corner+ -> Int -- ^ x-coordinate of bottom-right corner+ -> Int -- ^ y-coordinate of bottom-right corner+ -> px -- ^ colour+ -> m () -- ^ action+fillRectangle m x0 y0 x1 y1 px =+ for_ [(x, y) | x <- [x0..x1], y <- [y0..y1]] $ \(x, y) -> writePixel m x y px++-- | Fill a triangle with the specified colour+fillTriangle :: (Pixel px, PrimMonad m) =>+ MutableImage (PrimState m) px -- ^ mutable image+ -> Int -- ^ x-coordinate of first vertex+ -> Int -- ^ y-coordinate of first vertex+ -> Int -- ^ x-coordinate of second vertex+ -> Int -- ^ y-coordinate of second vertex+ -> Int -- ^ x-coordinate of third vertex+ -> Int -- ^ y-coordinate of third vertex+ -> px -- ^ colour+ -> m () -- ^ action+fillTriangle m@(MutableImage w h _) v1x v1y v2x v2y v3x v3y px =+ let (minX, maxX) = minMax3 v1x v2x v3x+ (minY, maxY) = minMax3 v1y v2y v3y+ minX' = max minX 0+ minY' = max minY 0+ maxX' = min maxX (w - 1)+ maxY' = min maxY (h - 1)+ in+ for_ [(x, y) | x <- [minX'..maxX'], y <- [minY'..maxY']] $ \(x, y) -> do+ let w0 = orient2D v2x v2y v3x v3y x y+ w1 = orient2D v3x v3y v1x v1y x y+ w2 = orient2D v1x v1y v2x v2y x y+ when (w0 >= 0 && w1 >= 0 && w2 >= 0) $ writePixel m x y px++orient2D :: Int -> Int -> Int -> Int -> Int -> Int -> Int+orient2D ax ay bx by cx cy = (bx - ax) * (cy - ay) - (by - ay) * (cx - ax)++min3 :: Int -> Int -> Int -> Int+min3 a b c+ | a < b = min a c+ | otherwise = min b c++max3 :: Int -> Int -> Int -> Int+max3 a b c+ | a > b = max a c+ | otherwise = max b c++minMax3 :: Int -> Int -> Int -> (Int, Int)+minMax3 a b c = (min3 a b c, max3 a b c)