diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Francesco Ariis + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Francesco Ariis nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changes.txt b/changes.txt new file mode 100644 --- /dev/null +++ b/changes.txt @@ -0,0 +1,5 @@ +0.1.0.0 +------- + +- Released Tue 11 Jun 2019 20:35:43 CEST. +- Added Bresenham's algorithm. diff --git a/line-drawing.cabal b/line-drawing.cabal new file mode 100644 --- /dev/null +++ b/line-drawing.cabal @@ -0,0 +1,39 @@ +cabal-version: >=1.10 +name: line-drawing +version: 0.1.0.0 +synopsis: raster line drawing +description: Line drawing algorithms to approximate a + line segment on discrete graphical media (raster). + + Currently just Bresenham algorithm. +bug-reports: fa-ml@ariis.it +license: BSD3 +license-file: LICENSE +author: Francesco Ariis +maintainer: fa-ml@ariis.it +copyright: © 2019 Francesco Ariis +category: Graphics +build-type: Simple +extra-source-files: changes.txt + +library + exposed-modules: Line.Draw + build-depends: base == 4.* + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite test + default-language: Haskell2010 + HS-Source-Dirs: test, src + main-is: Test.hs + build-depends: base == 4.* + , hspec == 2.7.* + other-modules: Line.Draw + Line.DrawSpec + type: exitcode-stdio-1.0 + ghc-options: -Wall + +source-repository head + type: darcs + location: http://ariis.it/link/repos/line-drawing/ diff --git a/src/Line/Draw.hs b/src/Line/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Line/Draw.hs @@ -0,0 +1,86 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Line.Draw +-- Copyright : (C) 2019 Francesco Ariis +-- License : BSD3 (see LICENSE file) +-- +-- Maintainer : Francesco Ariis +-- Stability : provisional +-- Portability : portable +-- +-- Rasterisation of line segments on discrete graphical media +-- (). +-- +-- Example: +-- +-- @ +-- λ> bresenham (0, 0) (4, 2) +-- [(0,0), (1,0), (2,1), (3,1), (4,2)] +-- @ +-- +-------------------------------------------------------------------------------- + +module Line.Draw ( + Coords, + bresenham + ) + where + +import qualified Data.List as L +import qualified Data.Tuple as T + +type Coords = (Int, Int) +type State = (Int, Int, Int) + -- curr x, curr y, treshold + +-- | Rasterising a line using +-- . +bresenham :: Coords -> Coords -> [Coords] +bresenham x@(x1, y1) y@(x2, y2) + | m1Check = bresenhamBase x y + | otherwise = let x' = T.swap x + y' = T.swap y + in map (T.swap) (bresenhamBase x' y') + where + m1Check :: Bool + m1Check = abs (x2 - x1) >= abs (y2 - y1) + + +----------------- +-- ANCILLARIES -- +----------------- + +bresenhamBase :: Coords -> Coords -> [Coords] +bresenhamBase (x1, y1) (x2, y2) = + let -- first treshold + ti = 2 * ady - adx + in L.unfoldr f (x1, y1, ti) + where + -- slope + dx, dy, adx, ady :: Int + dx = x2 - x1 + dy = y2 - y1 + adx = abs dx + ady = abs dy + + -- sign of increment + ix, iy :: Int -> Int + ix | dx > 0 = (+1) + | otherwise = (subtract 1) + iy | dy > 0 = (+1) + | otherwise = (subtract 1) + + -- step function, takes (x, y, treshold) + f :: State -> Maybe (Coords, State) + f (cx, cy, t) + | abs cx > abs x2 = Nothing + | otherwise = + let cx' = ix cx + + cy' | t > 0 = iy cy + | otherwise = cy + + t' | t > 0 = t - 2 * adx + 2 * ady + | otherwise = t + 2 * ady + in Just ((cx, cy), (cx', cy', t')) + diff --git a/test/Line/DrawSpec.hs b/test/Line/DrawSpec.hs new file mode 100644 --- /dev/null +++ b/test/Line/DrawSpec.hs @@ -0,0 +1,33 @@ +module Line.DrawSpec where + +import Line.Draw + +import Test.Hspec + + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + + describe "bresenham" $ do + it "rasterises a simple line" $ + bresenham (0, 0) (4, 4) `shouldBe` + [(0,0), (1,1), (2,2), (3,3), (4,4)] + it "rasterises a line" $ + bresenham (0, 0) (4, 2) `shouldBe` + [(0,0), (1,0), (2,1), (3,1), (4,2)] + it "rasterises a line, quadrant 2, m<1" $ + bresenham (0, 0) (-4, 2) `shouldBe` + [(0,0), (-1,0), (-2,1), (-3,1), (-4,2)] + it "rasterises a line, quadrant 3, m<1" $ + bresenham (0, 0) (-4, -2) `shouldBe` + [(0,0), (-1,0), (-2,-1), (-3,-1), (-4,-2)] + it "rasterises a line, quadrant 1, m>1" $ + bresenham (0, 0) (2, 4) `shouldBe` + [(0,0), (0,1), (1,2), (1,3), (2,4)] + it "rasterises a line, quadrant 4, m>1" $ + bresenham (0, 0) (2, -4) `shouldBe` + [(0,0), (0,-1), (1,-2), (1,-3), (2,-4)] + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}