diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,83 @@ +# Revision history for htdp-image + +## 1.0.0.0 -- 2019-07-21 + +* Remove emptyScene. +* Added abovesAlign, besidesAlign. +* Added documentation. +* Ready for hackage! (I think...) + + +## 0.4.2.0 -- 2019-07-21 + +* Added triangle function family. + + +## 0.4.1.0 -- 2019-07-20 + +* Added {overlay, underlay}AlignOffset/Align/XY + + +## 0.4.0.0 -- 2019-07-20 + +* placeImage now increases the binding box to fit both images + (as compared to just assuming that the second image is the base) +* Redefined {above, beside}, {above, beside}Align using placeImageAlign +* Added {overlay, underlay}Align. +* Added a simple implementation of rotate. + + +## 0.3.1.0 -- 2019-07-17 + +* Add aboveAlign, besideAlign, placeImageAlign, besides, aboves, and placeImages +* Fix overlay/underlay (assumed that (0, 0) was always the center of an image) + +## 0.3.0.0 -- 2019-07-16 + +* Change coordinate system to screen coordinate system! + + +## 0.2.6.0 -- 2019-07-16 + +* Added star +* Provide alias for Solid and Outline + + +## 0.2.5.0 -- 2019-07-14 + +* Added overlay and underlay + + +## 0.2.4.0 -- 2019-07-14 + +* Added empty-image and rhombus + +## 0.2.3.0 -- 2019-07-14 + +* Added line +* Fixed drawImage (crashed if width or height was zero) + + +## 0.2.2.0 -- 2019-07-13 + +* Added rectangle, square, and ellipse +* Access to Image data type + + +## 0.2.1.0 -- 2019-07-11 + +* Added triangle + + +## 0.2.0.0 -- 2019-07-11 + +* Htdp is now the entry point, giving access to only the functions + required for creating images. + + +## 0.1.0.0 -- 2019-07-10 + +* Basic idea behind the implementation +* Provides utility to draw circles by placing them on top, + beside, or above each other. +* White empty scene for background diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Turab Jafri + +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 Turab Jafri 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +# htdp-image + +htdp-image is a simple graphics library inspired by [Racket](https://racket-lang.org/)'s [2htdp/image](https://docs.racket-lang.org/teachpack/2htdpimage.html) library. Check the [feature list](https://github.com/trajafri/htdp-image/blob/master/FEATURELIST.md) to see what has been ported from 2htdp/image so far. + +Under the hood, it is currently a wrapper on top of [Gloss](http://gloss.ouroborus.net/), another easy to use graphics library, but htdp-image +makes drawing objects even easier for beginners. + +In the future, if it seems like Gloss is limiting the features this library wishes +to implement, then the newer versions might start using graphics libraries that +work on a lower level than Gloss. + +This library uses the [combinator pattern](https://wiki.haskell.org/Combinator_pattern) to draw images. + + +For an example program, check [tromino-tile](https://github.com/trajafri/tromino-tile). + + +## Examples: + +To draw five circles beside each other: + +```haskell +drawImage $ foldr1 beside $ replicate 5 (circle 20 solid red) +``` + +![alt text](https://raw.githubusercontent.com/trajafri/htdp-image/master/example-images/beside.png "Four circles beside each other") + + +To draw five circles above each other: + +```haskell +drawImage $ foldr1 above $ replicate 5 (circle 20 solid red) +``` + +![alt text](https://raw.githubusercontent.com/trajafri/htdp-image/master/example-images/above.png "Four circles above each other") + + +To draw four circles stacked on top of each other (2 on 2): + +```haskell +drawImage $ above (beside redCirc blueCirc) (beside blueCirc redCirc) + where + redCirc = (circle 20 solid red) + blueCirc = (circle 20 solid blue) +``` + +![alt text](https://raw.githubusercontent.com/trajafri/htdp-image/master/example-images/above-beside.png "Two circles stacked on each other") + + +To draw four iterations of the sierpinski triangle (don't try super big iterations!): + +```haskell +drawImage $ sier . sier . sier . sier $ (triangle 20 solid red) + where + sier t = above t $ beside t t +``` + +![alt text](https://raw.githubusercontent.com/trajafri/htdp-image/master/example-images/sierpinski.png "Sierpinski 4") 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/diagrams/triangleDiagram.png b/diagrams/triangleDiagram.png new file mode 100644 Binary files /dev/null and b/diagrams/triangleDiagram.png differ diff --git a/htdp-image.cabal b/htdp-image.cabal new file mode 100644 --- /dev/null +++ b/htdp-image.cabal @@ -0,0 +1,61 @@ +name: htdp-image +version: 1.0.0.0 +license: BSD3 +license-file: LICENSE +author: Turab Jafri +maintainer: trajafri@gmail.com +category: Graphics +build-type: Simple +extra-source-files: CHANGELOG.md README.md +extra-doc-files: diagrams/triangleDiagram.png +cabal-version: 2.0 + +synopsis: + Beginner friendly graphics library. + +description: + htdp-image is a simple graphics library inspired by Racket's htdp/image. + Under the hood, it is a wrapper on top of Gloss, another easy + to use graphics library but htdp-image makes drawing objects even easier for beginners. + As long as Gloss works on a machine, this library should also work. + +source-repository head + type: git + location: https://github.com/trajafri/htdp-image + +library + exposed-modules: Graphics.Htdp, + Graphics.Data.Image, + Graphics.Shape, + Graphics.Combinator + other-modules: Graphics.Util.Arithmetic + build-depends: AC-Angle ^>=1.0, + base ^>=4.12, + gloss ^>=1.13.0 + hs-source-dirs: src + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + default-language: Haskell2010 + +test-suite htdp-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: ShapeTest, + CombinatorTest + build-depends: base ^>=4.12, + gloss ^>=1.13.0, + htdp-image, + HUnit ^>=1.6.0, + test-framework ^>=0.8.2, + test-framework-hunit ^>=0.3.0 + hs-source-dirs: tests + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + default-language: Haskell2010 + diff --git a/src/Graphics/Combinator.hs b/src/Graphics/Combinator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Combinator.hs @@ -0,0 +1,315 @@ +{-# LANGUAGE MultiWayIf, RecordWildCards #-} + +-- | Utility to combine images. + +module Graphics.Combinator + ( Alignment + , high + , low + , mid + , overlay + , overlayAlign + , overlayOffset + , overlayAlignOffset + , overlayXY + , underlay + , underlayAlign + , underlayOffset + , underlayXY + , underlayAlignOffset + , beside + , besides + , besideAlign + , besidesAlign + , above + , aboves + , aboveAlign + , abovesAlign + , placeImage + , placeImages + , placeImageAlign + , placeImagesAlign + ) +where + +import Graphics.Data.Image +import Graphics.Util.Arithmetic +import Prelude hiding ( Left + , Right + ) + +-- | Alignment position +data Alignment = Low | Mid | High + +-- | Position to align at. +-- On x-axis, low means left, high means right. +-- On y-axis, low means bottom, high means top. +low, mid, high :: Alignment +low = Low +mid = Mid +high = High + +-- Function to determine the alignment shift in above/beside +imageOffset :: (Image -> Float) -> Alignment -> Image -> Image -> Float +imageOffset dim al i1 i2 = case al of + Low -> lowAlign + Mid -> 0 + High -> negate lowAlign + where lowAlign = (dim i2 - dim i1) / 2 + +-- | Constructs an image by placing @i1@ on top of @i2@, aligned along +-- the center. +above + :: Image -- ^ @i1@ + -> Image -- ^ @i2@ + -> Image +above = aboveAlign mid + +-- | Constructs an image by placing all images in a vertical row, aligned +-- along the center such that the first image in @is@ is at the top. +aboves + :: [Image] -- ^ @is@ + -> Image +aboves = foldr1 above + +-- | Constructs an image by placing @i1@ on top of @i2@, aligned as +-- specified by @al@. +aboveAlign + :: Alignment -- ^ @al@ + -> Image -- ^ @i1@ + -> Image -- ^ @i2@ + -> Image +aboveAlign a i1 i2 = placeImage i2 + (offset + width i1 / 2) + (height i1 + height i2 / 2) + i1 + where offset = imageOffset width a i1 i2 + +-- | Constructs an image by placing all images in a veritcal row, aligned +-- as specified by @al@ such that the first image in @is@ is at the top. +abovesAlign + :: Alignment -- ^ @al@ + -> [Image] -- ^ @is@ + -> Image +abovesAlign a = foldr1 $ aboveAlign a + +-- | Constructs an image by placing @i1@ on the left of @i2@, aligned along +-- the center. +beside + :: Image -- ^ @i1@ + -> Image -- ^ @i2@ + -> Image +beside = besideAlign mid + +-- | Constructs an image by placing all images in a horizontal row, aligned +-- along the center such that the first image in @is@ is on the left. +besides + :: [Image] -- ^ @is@ + -> Image +besides = foldr1 beside + +-- | Constructs an image by placing @i1@ on the left of @i2@, aligned as +-- specified by @al@. +besideAlign + :: Alignment -- ^ @al@ + -> Image -- ^ @i1@ + -> Image -- ^ @i2@ + -> Image +besideAlign a i1 i2 = placeImage i2 + (width i1 + width i2 / 2) + (negate offset + height i1 / 2) + i1 + where offset = imageOffset height a i1 i2 + +-- | Constructs an image by placing all images in a horizontal row, aligned +-- as specified by @al@ such that the first image in @is@ is on the left. +besidesAlign + :: Alignment -- ^ @al@ + -> [Image] -- ^ @is@ + -> Image +besidesAlign a = foldr1 $ besideAlign a + +-- | Places @i1@ on top of @i2@ with @i1@'s center at position @(x, y)@. +-- Unlike 2htdp/image's place-image, placeImage increases the binding box +-- so that both images fit in it, instead of cropping parts of @i1@ that +-- lay outside of @i2@'s bounds. +placeImage + :: Image -- ^ @i1@ + -> Float -- ^ @x@ + -> Float -- ^ @y@ + -> Image -- ^ @i2@ + -> Image +placeImage i1 x y = placeImageAlign i1 x y mid mid + +-- | Places each @i@ in @is@ onto @i2@ using `placeImage`, using the coordinates +-- @(x, y)@ in @ps@. +placeImages + :: [Image] -- ^ @is@ + -> [(Float, Float)] -- ^ @ps@ + -> Image -- ^ @i2@ + -> Image +placeImages is ps base = + foldr (\(i1, (x, y)) i2 -> placeImage i1 x y i2) base $ zip is ps + +-- | Like `placeImage`, but anchors @i1@ on @i2@ by the alignment specified +-- by @xAl@ and @yAl@. +placeImageAlign + :: Image -- ^ @i1@ + -> Float -- ^ @x@ + -> Float -- ^ @y@ + -> Alignment -- ^ @xAl@ + -> Alignment -- ^ @yAL@ + -> Image -- ^ @i2@ + -> Image +placeImageAlign i1 x y xAl yAl i2 = Image { width = newW + , height = newH + , shapes = newShapes + } + where + -- width and height of new image + newW = max (width i2) $ max (width i1) $ if incWCase + then (width i1 / 2) + (abs newX) + (width i2 / 2) + else 0 + newH = max (height i2) $ max (height i1) $ if incHCase + then (height i1 / 2) + (abs newY) + (height i2 / 2) + else 0 + -- whether i1's width/height lay outside of i2's width/height + incWCase = (abs newX) + (width i1 / 2) > (width i2 / 2) + incHCase = (abs newY) + (height i1 / 2) > (height i2 / 2) + -- x/y position converted from screen coord to cartesian coord + newX = + convert 0 (negate $ width i2 / 2) (width i2) (width i2 / 2) x + xOffset + newY = + convert 0 (height i2 / 2) (height i2) (negate $ height i2 / 2) y + yOffset + --x/y offset based on the given alignment + xOffset = shiftImage width xAl + yOffset = shiftImage height yAl + shiftImage dim a = case a of + Low -> dim i1 / 2 + Mid -> 0 + High -> negate $ dim i1 / 2 + -- if i1 covers i2, don't move i1 at all, but shift i2 + -- if i1 is within i2, don't move i2 at all, but shift i1 + -- else, move both + newShapes + | newW == width i1 && newH == height i1 + = [ (p, (ox - newX, oy - newY)) | (p, (ox, oy)) <- shapes i2 ] ++ shapes i1 + | newW == width i2 && newH == height i2 + = shapes i2 ++ [ (p, (ox + newX, oy + newY)) | (p, (ox, oy)) <- shapes i1 ] + | otherwise + = [ (p, (x2 + x2Shift, y2 + y2Shift)) | (p, (x2, y2)) <- shapes i2 ] + ++ [ (p, (x1 + x1Shift, y1 + y1Shift)) | (p, (x1, y1)) <- shapes i1 ] + -- shift magnitudes + x2Shift = xDir * ((newW - width i2) / 2) + y2Shift = yDir * ((newH - height i2) / 2) + x1Shift = (negate xDir) * ((newW - width i1) / 2) + y1Shift = (negate yDir) * ((newH - height i1) / 2) + -- direction based on i1's location relative to i2 + xDir = if + | newX > 0 -> -1 + | newX < 0 -> 1 + | otherwise -> 0 + yDir = if + | newY > 0 -> -1 + | newY < 0 -> 1 + | otherwise -> 0 + + +-- | Like `placeImages`, but anchors @is@ on @i2@ by the alignment specified +-- by @xAl@ and @yAl@. +placeImagesAlign + :: [Image] -- ^ @is@ + -> [(Float, Float)] -- ^ @ps@ + -> Alignment -- ^ @xAl@ + -> Alignment -- ^ @yAl@ + -> Image -- ^ @i2@ + -> Image +placeImagesAlign is ps xAl yAl b = + foldr (\(i1, (x, y)) i2 -> placeImageAlign i1 x y xAl yAl i2) b $ zip is ps + +-- | Places @i1@ on the center of @i2@. +overlay + :: Image -- ^ @i1@ + -> Image -- ^ @i2@ + -> Image +overlay i1 i2 = placeImage i1 (width i2 / 2) (height i2 / 2) i2 + +-- | Places @i1@ on top of @i2@ and uses @xAl@ and @yAl@ for alignment. +overlayAlign + :: Alignment -- ^ @xAl@ + -> Alignment -- ^ @yal@ + -> Image -- ^ @i1@ + -> Image -- ^ @i2@ + -> Image +overlayAlign xAl yAl i1 = overlayAlignOffset xAl yAl i1 0 0 + +-- | Places @i1@ on top of @i2@ and moves @i2@ by @x@ pixels to the right, +-- and @y@ pixels down. +overlayOffset + :: Image -- ^ @i1@ + -> Float -- ^ @x@ + -> Float -- ^ @y@ + -> Image -- ^ @i2@ + -> Image +overlayOffset = overlayAlignOffset mid mid + +-- | Places @i1@ on top of @i2@ by lining them on their top left corners, +-- then @i2@ is shifted to the right by @x@ pixels and down by @y@ pixels. +overlayXY + :: Image -- ^ @i1@ + -> Float -- ^ @x@ + -> Float -- ^ @y@ + -> Image -- ^ @i2@ + -> Image +overlayXY i1 x y i2 = placeImage i1 (width i1 / 2 - x) (height i1 / 2 - y) i2 + +-- | Combination of `overlayAlign` and `overlayOffset`. +overlayAlignOffset + :: Alignment -> Alignment -> Image -> Float -> Float -> Image -> Image +overlayAlignOffset xAl yAl i1 x y i2 = placeImageAlign i1 + shiftedX + shiftedY + mid + mid + i2 + where + newX = (width i2 / 2 - x) + newY = (height i2 / 2 - y) + wDiff = (width i2 - width i1) / 2 + hDiff = (height i2 - height i1) / 2 + shiftedX = + newX + + (case xAl of + Low -> (-wDiff) + Mid -> 0 + High -> wDiff + ) + shiftedY = + newY + + (case yAl of + Low -> hDiff + Mid -> 0 + High -> (-hDiff) + ) + +-- | Same of `overlay`, but with image arguments flipped. +underlay :: Image -> Image -> Image +underlay = flip overlay + +-- | Same of `overlayAlign`, but with image arguments flipped. +underlayAlign :: Alignment -> Alignment -> Image -> Image -> Image +underlayAlign xAl yAl i1 i2 = overlayAlign xAl yAl i2 i1 + +-- | Same of `overlayOffset`, but with image arguments flipped. +underlayOffset :: Image -> Float -> Float -> Image -> Image +underlayOffset i1 x y i2 = overlayOffset i2 (negate x) (negate y) i1 + +-- | Same of `overlayAlignOffset`, but with image arguments flipped. +underlayAlignOffset + :: Alignment -> Alignment -> Image -> Float -> Float -> Image -> Image +underlayAlignOffset xAl yAl i1 x y i2 = + overlayAlignOffset xAl yAl i2 (negate x) (negate y) i1 + +-- | Same of `overlayXY`, but with image arguments flipped. +underlayXY :: Image -> Float -> Float -> Image -> Image +underlayXY i1 x y i2 = overlayXY i2 (negate x) (negate y) i1 diff --git a/src/Graphics/Data/Image.hs b/src/Graphics/Data/Image.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Data/Image.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Image related utilities. +module Graphics.Data.Image + ( Image(..) + , rotate + ) +where + +import Data.Angle +import qualified Graphics.Gloss as G + +-- | A 2D Image. +data Image = Image {width :: Float , -- ^ Width of image + height :: Float , -- ^ Height of image + shapes :: [(G.Picture, G.Point)] -- ^ Collection of all Gloss Pictures that create the Image. + } deriving Eq + +-- | Rotates @i@ by @deg@ degrees in a counter-clockwise direction. +-- Unlike 2htdp/image's rotate function, this function is not smart enough +-- to reduce the rotated image's binding box to fit the actual image. +-- Instead, it just creates a new binding box so that @i@'s binding box +-- fits in it. +rotate + :: Float -- ^ @deg@ + -> Image -- ^ @i@ + -> Image +rotate deg Image {..} = Image newW newH + $ map (\(p, c) -> (G.rotate (negate deg) p, rotateC c)) shapes + where + newW = + width + * (abs . sine . Degrees $ 90 - deg) + + height + * (abs . sine . Degrees $ deg) + newH = + width + * (abs . sine . Degrees $ deg) + + height + * (abs . sine . Degrees $ 90 - deg) + rotateC :: (Float, Float) -> (Float, Float) + rotateC (x, y) = + ( x * (cosine . Degrees $ deg) + y * (negate . sine . Degrees $ deg) + , x * (sine . Degrees $ deg) + y * (cosine . Degrees $ deg) + ) + diff --git a/src/Graphics/Htdp.hs b/src/Graphics/Htdp.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Htdp.hs @@ -0,0 +1,48 @@ +{-| htdp-image is a simple graphics library written on top of [Gloss](https://hackage.haskell.org/package/gloss-1.13.0.1/docs/Graphics-Gloss.html) + that allows users to create complex images by combining smaller images. + + For example, four iterations of the sierpinski triangle can be drawn as: + + @ + import Graphics.Htdp + main = drawImage $ sier . sier . sier . sier $ triangle 20 solid red + where + sier :: Image -> Image + sier t = above t (beside t t) + @ + + Once the image is drawn, you can use Gloss key bindings to navigate around. +-} + +module Graphics.Htdp + ( module Graphics.Gloss.Data.Color + -- * Image constructors + , module Graphics.Shape + -- * Image combinators + , module Graphics.Combinator + -- * Image + , Image + , width + , height + , rotate + -- * Output + , drawImage + ) +where + +import qualified Graphics.Gloss as G +import Graphics.Gloss.Data.Color +import Graphics.Combinator +import Graphics.Data.Image +import Graphics.Shape + +-- | Function to draw an image in a new window with same dimensions as the given image. +drawImage :: Image -> IO () +drawImage i = + G.display + (G.InWindow "htdp-image" + (succ . round . width $ i, succ . round . height $ i) + (0 , 0) + ) + G.white + $ G.Pictures (map (\(p, (x, y)) -> G.translate x y p) (shapes i)) diff --git a/src/Graphics/Shape.hs b/src/Graphics/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Shape.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE MultiWayIf #-} + +-- Sorted as they are in 2htdp/image +-- | Image constructors +module Graphics.Shape + ( Mode + , solid + , outline + , circle + , ellipse + , line + , addLine + , emptyImage + , triangle + , rightTriangle + , isoscelesTriangle + -- *** The following image from 2htdp/image documentation is useful for the following family of functions. + -- | <> + , triangleSSS + , triangleASS + , triangleSAS + , triangleSSA + , triangleAAS + , triangleASA + , triangleSAA + , square + , rectangle + , rhombus + , star + ) +where + +import Data.Angle +import Data.Fixed +import Data.List +import Graphics.Combinator +import Graphics.Data.Image +import qualified Graphics.Gloss as G +import Graphics.Gloss.Data.Color +import Graphics.Util.Arithmetic + +-- | Drawing mode. +data Mode = Solid | Outline deriving Eq + +-- | Type of drawing mode. +solid, outline :: Mode +solid = Solid +outline = Outline + +-- Initial point for all images +origin :: G.Point +origin = (0, 0) + +-- | Adds a line to the given image @i@ of color @c@, starting from point @(x1, y1)@ +-- and going to point @(x2, y2)@. If the line crosses the given image's binding box, +-- then new image dimesions are changed to accommodate the line. +addLine + :: Image -- ^ @i@ + -> Float -- ^ @x1@ + -> Float -- ^ @y1@ + -> Float -- ^ @x2@ + -> Float -- ^ @y2@ + -> Color + -> Image +addLine i x1 y1 x2 y2 c = + placeImage (line (x1 - x2) (y1 - y2) c) ((x1 + x2) / 2) ((y1 + y2) / 2) i + +-- | Constructs a circle of radius @r@, drawing mode @m@ and color @c@. +circle + :: Float -- ^ @r@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +circle r mode c = Image { width = r * 2 + , height = r * 2 + , shapes = [(G.color c $ circleKind r, origin)] + } + where + circleKind = case mode of + Solid -> G.circleSolid + Outline -> G.circle + +-- | Constructs an ellipse of width @w@, height @h@, mode @m@, and color @c@. +ellipse + :: Float -- ^ @w@ + -> Float -- ^ @h@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +ellipse w h m c = Image { width = w + , height = h + , shapes = [(circleToEllipse, origin)] + } + where -- This took me longer than it should have + circleToEllipse = G.scale (w / (2 * radius)) (h / (2 * radius)) circPic + circPic = fst . head . shapes $ circle radius m c + radius = (w + h) / 4 + +-- | Constructs an image of width and height @0@. +emptyImage :: Image +emptyImage = Image 0 0 [] + +-- | Constructs a triangle of two equal-length sides, of length @l@, where the +-- angle between those sides is @a@, mode is @m@ and color is @c@. If the angle +-- is less than @180@, then the triangle will point up, else it will point down. +isoscelesTriangle + :: Float -- ^ @l@ + -> Float -- ^ @a@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +isoscelesTriangle sl deg m c = Image + { width = newW + , height = newH + , shapes = [(G.color c triangleShape, origin)] + } + where + newW = (2 * (sl ** 2) * (1 - (cosine . Degrees $ deg))) ** (1 / 2) + newH = computeRightSide sl (newW / 2) + topDir = if mod' deg 360 < 180 then 1 else -1 + tShape = + [ (negate newW / 2, negate topDir * (newH / 2)) + , (0 , topDir * newH / 2) + , (newW / 2 , negate topDir * (newH / 2)) + ] + triangleShape = case m of + Solid -> G.polygon tShape + Outline -> G.line ((newW / 2, negate topDir * (newH / 2)) : tShape) + +-- | Constructs an image of a line segment of color @c@ that connects the points +-- @(0,0)@ to @(x1, y1)@. +line + :: Float -- ^ @x1@ + -> Float -- ^ @y1@ + -> Color -- ^ @c@ + -> Image +line x y c = Image { width = abs x + , height = abs y + , shapes = [(G.color c $ G.Line lineShape, origin)] + } + -- We want the line centered on the origin. + -- For that, we will need to move the given points + -- (I had to take a day off to get this) + where lineShape = [(x / 2, negate y / 2), (negate x / 2, y / 2)] + +-- | Constructs a rectangle of width @w@, height @h@, mode @m@, and color @c@. +rectangle + :: Float -- ^ @w@ + -> Float -- ^ @h@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +rectangle w h mode c = Image { width = w + , height = h + , shapes = [(G.color c $ rectShape w h, origin)] + } + where + rectShape = case mode of + Solid -> G.rectangleSolid + Outline -> G.rectangleWire + +-- | Constructs a four sided polygon with all equal sides of length @l@, where the +-- top and bottom pair of angles is @a@, and the left and right are @180 - a@. +-- As usual, mode is @m@ and color is @c@. +rhombus + :: Float -- ^ @l@ + -> Float -- ^ @a@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +rhombus sideLength angle m c = Image { width = base + , height = opp + , shapes = [(G.color c rShape, origin)] + } + where + -- It's the law of Cosine bb + base = (2 * (sideLength ** 2) * (1 - (cosine . Degrees $ angle))) ** (1 / 2) + opp = 2 * computeRightSide sideLength (base / 2) + rhombusShape = + [(negate base / 2, 0), (0, opp / 2), (base / 2, 0), (0, negate opp / 2)] + rShape = case m of + Solid -> G.polygon rhombusShape + Outline -> G.line ((0, negate opp / 2) : rhombusShape) + +-- | Constructs a right triangle with base length @b@, perpendicular length +-- @p@, mode @m@, and color @c@. +rightTriangle + :: Float -- ^ @b@ + -> Float -- ^ @p@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +rightTriangle b p m c = Image { width = b + , height = p + , shapes = [(G.color c triangleShape, origin)] + } + where + tShape = + [(b / 2, negate p / 2), (negate b / 2, p / 2), (negate b / 2, negate p / 2)] + triangleShape = case m of + Solid -> G.polygon tShape + Outline -> G.line ((negate b / 2, negate p / 2) : tShape) + +-- | Constructs a square of side @s@, mode @m@, and color @c@. +square + :: Float -- ^ @s@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +square w = rectangle w w + +-- | Constructs a star with five points of mode @m@ and color @c@. The argument +-- @l@ determines the side length of the internal pentagon. +-- Currently, a solid star is glitchy since it is a non-convex polygon +-- and openGL (the underlying graphics library) doesn't draw them correctly. +-- This will be corrected in future versions. +star + :: Float -- ^ @l@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +star side m c = Image { width = w + , height = h + , shapes = [(G.color c sShape, origin)] + } + where + -- Pentagon is 108degs apart + w = (2 * triHyp) + side + h = (1.539 * side) + triPerp + bottomPerp + triHyp = (sine . Degrees $ 72) * (side / (sine . Degrees $ 36)) + triPerp = computeRightSide triHyp (side / 2) + bottomPerp = computeRightSide triHyp (bottom / 2) + bottom = (2 * (triHyp ** 2) * (1 - (cosine . Degrees $ 108))) ** (1 / 2) + sShape = case m of + Solid -> + G.polygon + $ concat + . transpose + $ [[bLeftSt, bRightSt, rightSt, topSt, leftSt], pentPoints] + Outline -> G.line (rightSt : starPoints) -- Some hack to fix solid + starPoints = [bLeftSt, topSt, bRightSt, leftSt, rightSt] + topSt = (0, h / 2) + leftSt = (negate (w / 2), (h / 2) - triPerp) + rightSt = (negate . fst $ leftSt, snd leftSt) + bLeftSt = (negate (bottom / 2), negate (h / 2)) + bRightSt = (negate . fst $ bLeftSt, snd bLeftSt) + pentPoints = [bottomP, bRightP, rightP, leftP, bLeftP] + bottomP = (0, negate $ h / 2 - bottomPerp) + leftP = (negate $ side / 2, snd leftSt) + rightP = (negate . fst $ leftP, snd leftP) + bLeftP = (negate midPerp, negate $ h / 2 - (bottomPerp + midPerp)) + bRightP = (negate . fst $ bLeftP, snd bLeftP) + midPerp = computeRightSide side $ (1.618 * side) / 2 + +-- | Constructs an upward-pointing equilateral triangle with length @l@, +-- mode @m@, and color @c@. +triangle + :: Float -- ^ @l@ + -> Mode -- ^ @m@ + -> Color -- ^ @c@ + -> Image +triangle sideLength = isoscelesTriangle sideLength 60 + +-- | Constructs a triangle of mode @m@, color @color@, angle @A@, angle @B@, and +-- length @c@. The variables refer to the diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleAAS + :: Float -- ^ @A@ + -> Float -- ^ @B@ + -> Float -- ^ @c@ + -> Mode -- ^ @m@ + -> Color -- ^ @color@ + -> Image +triangleAAS degr degl t = triangleSSS + (t * (sine . Degrees $ degr) / (sine . Degrees $ 180 - (degl + degr))) + (t * (sine . Degrees $ degl) / (sine . Degrees $ 180 - (degl + degr))) + t + +-- | Constructs a triangle of mode @m@, color @color@, angle @A@, angle @C@, and +-- length @b@. The variables refer to the diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleASA + :: Float -- ^ @A@ + -> Float -- ^ @C@ + -> Float -- ^ @b@ + -> Mode -- ^ @m@ + -> Color -- ^ @color@ + -> Image +triangleASA degl l degt = triangleSSS + (l * (sine . Degrees $ degl) / (sine . Degrees $ 180 - (degt + degl))) + l + (l * (sine . Degrees $ degt) / (sine . Degrees $ 180 - (degt + degl))) + +-- | Constructs a triangle of mode @m@, color @color@, angle @B@, angle @C@, and +-- length @a@. The variables refer to the diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleSAA + :: Float -- ^ @B@ + -> Float -- ^ @C@ + -> Float -- ^ @a@ + -> Mode -- ^ @m@ + -> Color -- ^ @color@ + -> Image +triangleSAA r degr degt = triangleSSS + r + (r * (sine . Degrees $ degr) / (sine . Degrees $ 180 - (degt + degr))) + (r * (sine . Degrees $ degt) / (sine . Degrees $ 180 - (degt + degr))) + +-- | Constructs a triangle of mode @m@, color @color@, angle @A@, and lengths +-- @b@ and @c@. The variables refer to the diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleASS + :: Float -- ^ @A@ + -> Float -- ^ @b@ + -> Float -- ^ @c@ + -> Mode -- ^ @mode@ + -> Color -- ^ @color@ + -> Image +triangleASS deg l t = triangleSSS + (((l ** 2) + (t ** 2) - 2 * t * l * (cosine . Degrees $ deg)) ** (1 / 2)) + l + t + +-- | Constructs a triangle of mode @m@, color @color@, angle @B@, and lengths +-- @a@ and @c@. The variables refer to the diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleSAS + :: Float -- ^ @B@ + -> Float -- ^ @a@ + -> Float -- ^ @c@ + -> Mode -- ^ @mode@ + -> Color -- ^ @color@ + -> Image +triangleSAS r deg t = triangleSSS + r + (((r ** 2) + (t ** 2) - 2 * t * r * (cosine . Degrees $ deg)) ** (1 / 2)) + t + +-- | Constructs a triangle of mode @m@, color @color@, angle @C@, and lengths +-- @a@ and @c@. The variables refer to the diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleSSA + :: Float -- ^ @C@ + -> Float -- ^ @a@ + -> Float -- ^ @c@ + -> Mode -- ^ @mode@ + -> Color -- ^ @color@ + -> Image +triangleSSA r l deg = triangleSSS + r + l + (((r ** 2) + (l ** 2) - 2 * l * r * (cosine . Degrees $ deg)) ** (1 / 2)) + +-- | Constructs a triangle of side @a@, @b@, and @c@. The variables refer to the +-- diagram above. +-- If it's not possible to construct the triangle with the given arguments, +-- an empty image is returned. +triangleSSS + :: Float -- ^ @a@ + -> Float -- ^ @b@ + -> Float -- ^ @c@ + -> Mode -- ^ @m@ + -> Color -- ^ @color@ + -> Image +triangleSSS r l t m c = + if (round . distance (bottX, negate newH / 2) $ (-t / 2, newH / 2) :: Integer) + == (round l) + && (round . distance (bottX, negate newH / 2) $ (t / 2, newH / 2) :: Integer + ) + == round r + then + Image { width = newW + , height = newH + , shapes = [(G.color c triangleShape, origin)] + } + else + emptyImage + + where + angleL = + arccosine $ (l ** 2 - r ** 2 - t ** 2) / (-2 * r * t) :: Degrees Float + angleR = + arccosine $ (r ** 2 - l ** 2 - t ** 2) / (-2 * l * t) :: Degrees Float + newH = (if angleR < angleL then l else r) * (sine $ min angleR angleL) + newW = if + | angleR < angleL && angleL > Degrees 90 + -> l * (sine $ Degrees 90 - min angleR angleL) + | angleL < angleR && angleR > Degrees 90 + -> r * (sine $ Degrees 90 - min angleR angleL) + | otherwise + -> t + bottW = computeRightSide (max l r) newH + bottX = if l > r then bottW - (t / 2) else negate $ bottW - (t / 2) + converter = + convert (min bottX $ -t / 2) (-newW / 2) (max bottX $ t / 2) (newW / 2) + tShape = + [ (converter $ negate t / 2, newH / 2) + , (converter bottX , negate newH / 2) + , (converter $ t / 2 , newH / 2) + ] + triangleShape = case m of + Solid -> G.polygon tShape + Outline -> G.line ((converter $ t / 2, newH / 2) : tShape) diff --git a/src/Graphics/Util/Arithmetic.hs b/src/Graphics/Util/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Util/Arithmetic.hs @@ -0,0 +1,54 @@ +module Graphics.Util.Arithmetic + ( computeHypotenuse + , computeRightSide + , convert + , distance + , heron + ) +where + +computeHypotenuse :: Float -> Float -> Float +computeHypotenuse a b = (a ** 2 + b ** 2) ** (1 / 2) + +computeRightSide :: Float -> Float -> Float +computeRightSide h a = (h ** 2 - a ** 2) ** (1 / 2) + +convert :: Float -> Float -> Float -> Float -> Float -> Float +convert a1 a2 b1 b2 c1 = (((c1 - a1) * (b2 - a2)) / (b1 - a1)) + a2 + +{- y_a1 = 0x + ba y_a2 = 0x + bb + a1 = ba a2 = bb +------------------------------------------------------ + y_b1 = m + ba y_b2 = M + bb + b1 - ba = m b2 - bb = M + b1 - a1 = m b2 - a2 = M +------------------------------------------------------ + y_c1 = mx + ba y_c2 = Mx + bb + y_c1 - ba = mx y_c2 - bb = Mx + c1 - a1 = (b1 - a1)x c2 - a2 = (b2 - a2)x + c2 - a2 + ------- = x + b2 - a2 + + c1 - a1 = (b1 - a1)(c2 - a2) + ----------------- + (b2 - a2) + + (c1 - a1)(b2 - a2) + ------------------ = c2 - a2 + (b1 - a1) + + + c2 = (c1 - a1)(b2 - a2) + a2 + ------------------ + (b1 - a1) + +Thanks RRose +-} + +distance :: (Float, Float) -> (Float, Float) -> Float +distance (x1, y1) (x2, y2) = ((y2 - y1) ** 2 + (x2 - x1) ** 2) ** (1 / 2) + +heron :: Float -> Float -> Float -> Float +heron a b c = (p * (p - a) * (p - b) * (p - c)) ** (1 / 2) + where p = (a + b + c) / 2 diff --git a/tests/CombinatorTest.hs b/tests/CombinatorTest.hs new file mode 100644 --- /dev/null +++ b/tests/CombinatorTest.hs @@ -0,0 +1,241 @@ +module CombinatorTest + ( combinatorTests + ) +where + +import Graphics.Data.Image +import Graphics.Htdp +import Graphics.Gloss ( Picture ) +import Graphics.Gloss.Data.Picture ( blank ) +import Test.HUnit + +bp :: Picture +bp = blank -- blank picture + +image1 :: Image +image1 = Image { width = 50 + , height = 50 + , shapes = [(bp, (0, 0)), (bp, (10, 10)), (bp, (30, 20))] + } + +image2 :: Image +image2 = Image { width = 10 + , height = 50 + , shapes = [(bp, (30, 20)), (bp, (10, 40)), (bp, (70, 90))] + } + +image3 :: Image +image3 = Image { width = 50 + , height = 10 + , shapes = [(bp, (0, 20)), (bp, (10, 0)), (bp, (7, 9))] + } + +widthError :: String +widthError = "creates incorrect width for images " + +heightError :: String +heightError = "creates incorrect height for images " + +posError :: String +posError = "shifts images incorrectly " + + -- Check if size increases properly +aboveWidthTest :: Test +aboveWidthTest = TestList + [ TestCase + $ assertBool (widthError ++ "1") (50 == (width $ above image1 image2)) + , TestCase + $ assertBool (widthError ++ "2") (50 == (width $ above image1 image3)) + , TestCase + $ assertBool (widthError ++ "3") (50 == (width $ above image2 image3)) + , TestCase + $ assertBool (widthError ++ "4") (10 == (width $ above image2 image2)) + ] + +-- Check if height is the max of two +aboveHeightTest :: Test +aboveHeightTest = TestList + [ TestCase + $ assertBool (heightError ++ "1") (100 == (height $ above image1 image2)) + , TestCase + $ assertBool (heightError ++ "2") (60 == (height $ above image1 image3)) + , TestCase + $ assertBool (heightError ++ "3") (60 == (height $ above image2 image3)) + ] + +-- Check if positions are shifted correctly +abovePosTest :: Test +abovePosTest = TestList + [ TestCase $ assertBool + (posError ++ "1") + ( [(0, 25), (10, 35), (30, 45), (30, -5), (10, 15), (70, 65)] + == (map snd . shapes $ above image1 image2) + ) + , TestCase $ assertBool + (posError ++ "2") + ( [(0, 5), (10, 15), (30, 25), (0, -5), (10, -25), (7, -16)] + == (map snd . shapes $ above image1 image3) + ) + , TestCase $ assertBool + (posError ++ "3") + ( [(30, 25), (10, 45), (70, 95), (0, -5), (10, -25), (7, -16)] + == (map snd . shapes $ above image2 image3) + ) + ] + +-- Check if size increases properly +besideWidthTest :: Test +besideWidthTest = TestList + [ TestCase + $ assertBool (widthError ++ "1") (60 == (width $ beside image1 image2)) + , TestCase + $ assertBool (widthError ++ "2") (100 == (width $ beside image1 image3)) + , TestCase + $ assertBool (widthError ++ "3") (60 == (width $ beside image2 image3)) + ] + +-- Check if height is the max of two +besideHeightTest :: Test +besideHeightTest = TestCase $ do + assertBool (heightError ++ "1") (50 == (height $ beside image1 image2)) + assertBool (heightError ++ "2") (50 == (height $ beside image1 image3)) + assertBool (heightError ++ "3") (50 == (height $ beside image2 image3)) + assertBool (heightError ++ "4") (10 == (height $ beside image3 image3)) + +-- Check if positions are shifted correctly +besidePosTest :: Test +besidePosTest = TestList + [ TestCase $ assertBool + (posError ++ "1") + ( [(-5, 0), (5, 10), (25, 20), (55, 20), (35, 40), (95, 90)] + == (map snd . shapes $ beside image1 image2) + ) + , TestCase $ assertBool + (posError ++ "2") + ( [(-25, 0), (-15, 10), (5, 20), (25, 20), (35, 0), (32, 9)] + == (map snd . shapes $ beside image1 image3) + ) + , TestCase $ assertBool + (posError ++ "3") + ( [(5, 20), (-15, 40), (45, 90), (5, 20), (15, 0), (12, 9)] + == (map snd . shapes $ beside image2 image3) + ) + ] + +placeImageXError :: String +placeImageXError = "X dimension computed incorrectly for test " + +placeImageYError :: String +placeImageYError = "X dimension computed incorrectly for test " + +placeImageSizeTest :: Test +placeImageSizeTest = TestList + [ TestCase + $ assertEqual (placeImageXError ++ i) expW (width pic) + >> assertEqual (placeImageYError ++ i) expH (height pic) + | (i, expW, expH, pic) <- +-- image on center + [ ("0", 50, 50, placeImage image1 25 25 image1) + , ("1", 50, 50, placeImage image1 5 25 image2) + , ("2", 50, 50, placeImage image1 25 5 image3) + , ("3", 50, 50, placeImage image2 25 25 image1) + , ("4", 10, 50, placeImage image2 5 25 image2) + , ("5", 50, 50, placeImage image2 25 5 image3) + , ("6", 50, 50, placeImage image3 25 25 image1) + , ("7", 50, 50, placeImage image3 5 25 image2) + , ( "8" + , 50 + , 10 + , placeImage image3 25 5 image3 + ) +-- image on the left mid + , ("9" , 75, 50, placeImage image1 0 25 image1) + , ("10", 50, 50, placeImage image1 0 25 image2) + , ("11", 75, 50, placeImage image1 0 5 image3) + , ("12", 55, 50, placeImage image2 0 25 image1) + , ("13", 15, 50, placeImage image2 0 25 image2) + , ("14", 55, 50, placeImage image2 0 5 image3) + , ("15", 75, 50, placeImage image3 0 25 image1) + , ("16", 50, 50, placeImage image3 0 25 image2) + , ("17", 75, 10, placeImage image3 0 5 image3) + ] + ] + +placeImagePosTest :: Test +placeImagePosTest = TestList + [ TestCase $ assertEqual (posError ++ i) (l1 ++ l2) (shapes pic) + | (i, l1, l2, pic) <- +-- image on center + [ ("0", shapes image1, shapes image1, placeImage image1 25 25 image1) + , ("1", shapes image2, shapes image1, placeImage image1 5 25 image2) + , ("2", shapes image3, shapes image1, placeImage image1 25 5 image3) + , ("3", shapes image1, shapes image2, placeImage image2 25 25 image1) + , ("4", shapes image2, shapes image2, placeImage image2 5 25 image2) + , ("5", shapes image3, shapes image2, placeImage image2 25 5 image3) + , ("6", shapes image1, shapes image3, placeImage image3 25 25 image1) + , ("7", shapes image2, shapes image3, placeImage image3 5 25 image2) + , ( "8" + , shapes image3 + , shapes image3 + , placeImage image3 25 5 image3 + ) +-- image on left mid + , ( "9" + , [ (p, (x + 12.5, y)) | (p, (x, y)) <- shapes image1 ] + , [ (p, (x - 12.5, y)) | (p, (x, y)) <- shapes image1 ] + , placeImage image1 0 25 image1 + ) + , ( "10" + , [ (p, (x + 5, y)) | (p, (x, y)) <- shapes image2 ] + , shapes image1 + , placeImage image1 0 25 image2 + ) + , ( "11" + , [ (p, (x + 12.5, y)) | (p, (x, y)) <- shapes image3 ] + , [ (p, (x - 12.5, y)) | (p, (x, y)) <- shapes image1 ] + , placeImage image1 0 5 image3 + ) + , ( "12" + , [ (p, (x + 2.5, y)) | (p, (x, y)) <- shapes image1 ] + , [ (p, (x - 22.5, y)) | (p, (x, y)) <- shapes image2 ] + , placeImage image2 0 25 image1 + ) + , ( "13" + , [ (p, (x + 2.5, y)) | (p, (x, y)) <- shapes image2 ] + , [ (p, (x - 2.5, y)) | (p, (x, y)) <- shapes image2 ] + , placeImage image2 0 25 image2 + ) + , ( "14" + , [ (p, (x + 2.5, y)) | (p, (x, y)) <- shapes image3 ] + , [ (p, (x - 22.5, y)) | (p, (x, y)) <- shapes image2 ] + , placeImage image2 0 5 image3 + ) + , ( "15" + , [ (p, (x + 12.5, y)) | (p, (x, y)) <- shapes image1 ] + , [ (p, (x - 12.5, y)) | (p, (x, y)) <- shapes image3 ] + , placeImage image3 0 25 image1 + ) + , ( "16" + , [ (p, (x + 20, y)) | (p, (x, y)) <- shapes image2 ] + , shapes image3 + , placeImage image3 0 25 image2 + ) + , ( "17" + , [ (p, (x + 12.5, y)) | (p, (x, y)) <- shapes image3 ] + , [ (p, (x - 12.5, y)) | (p, (x, y)) <- shapes image3 ] + , placeImage image3 0 5 image3 + ) + ] + ] + +combinatorTests :: Test +combinatorTests = TestList + [ TestLabel "aboveWidthTest" aboveWidthTest + , TestLabel "aboveHeightTest" aboveHeightTest + , TestLabel "abovePosTest" abovePosTest + , TestLabel "besideWidthTest" besideWidthTest + , TestLabel "besideHeightTest" besideHeightTest + , TestLabel "besidePosTest" besidePosTest + , TestLabel "placeImageSizeTest" placeImageSizeTest + , TestLabel "placeImagePosTest" placeImagePosTest + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import CombinatorTest +import ShapeTest +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + +main :: IO () +main = do + print "Testing..." + defaultMain . hUnitTestToTests $ TestList [combinatorTests, shapeTests] + print "...Complete" diff --git a/tests/ShapeTest.hs b/tests/ShapeTest.hs new file mode 100644 --- /dev/null +++ b/tests/ShapeTest.hs @@ -0,0 +1,25 @@ +module ShapeTest + ( shapeTests + ) +where + +import Graphics.Data.Image +import Graphics.Htdp +import qualified Graphics.Gloss as G +import Test.HUnit + +errorMsg :: String +errorMsg = "drawn incorrectly" + +circleTests :: Test +circleTests = TestCase $ do + assertEqual errorMsg + (G.Color green $ G.circleSolid 10) + (fst . head . shapes $ circle 10 solid green) + assertEqual errorMsg + (G.Color green $ G.circle 10) + (fst . head . shapes $ circle 10 outline green) + +shapeTests :: Test +shapeTests = TestList [TestLabel "circleTests" circleTests] +