htdp-image (empty) → 1.0.0.0
raw patch · 14 files changed
+1385/−0 lines, 14 filesdep +AC-Angledep +HUnitdep +basesetup-changedbinary-added
Dependencies added: AC-Angle, HUnit, base, gloss, htdp-image, test-framework, test-framework-hunit
Files
- CHANGELOG.md +83/−0
- LICENSE +30/−0
- README.md +58/−0
- Setup.hs +2/−0
- diagrams/triangleDiagram.png binary
- htdp-image.cabal +61/−0
- src/Graphics/Combinator.hs +315/−0
- src/Graphics/Data/Image.hs +46/−0
- src/Graphics/Htdp.hs +48/−0
- src/Graphics/Shape.hs +409/−0
- src/Graphics/Util/Arithmetic.hs +54/−0
- tests/CombinatorTest.hs +241/−0
- tests/Main.hs +13/−0
- tests/ShapeTest.hs +25/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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)+```+++++To draw five circles above each other:++```haskell+drawImage $ foldr1 above $ replicate 5 (circle 20 solid red)+```+ ++++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)+```+++++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+```++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diagrams/triangleDiagram.png view
binary file changed (absent → 11398 bytes)
+ htdp-image.cabal view
@@ -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+
+ src/Graphics/Combinator.hs view
@@ -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
+ src/Graphics/Data/Image.hs view
@@ -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)+ )+
+ src/Graphics/Htdp.hs view
@@ -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))
+ src/Graphics/Shape.hs view
@@ -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.+ -- | <<diagrams/triangleDiagram.png>>+ , 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)
+ src/Graphics/Util/Arithmetic.hs view
@@ -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
+ tests/CombinatorTest.hs view
@@ -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+ ]
+ tests/Main.hs view
@@ -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"
+ tests/ShapeTest.hs view
@@ -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]+