htdp-image 1.0.0.0 → 1.1.0.0

raw patch · 13 files changed

+841/−836 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• htdp-image.cabal +5/−5
• src/Graphics/Combinator.hs +0/−315
• src/Graphics/Data/Image.hs +0/−46
• src/Graphics/Htdp.hs +5/−5
• src/Graphics/Htdp/Combinator.hs +315/−0
• src/Graphics/Htdp/Data/Image.hs +46/−0
• src/Graphics/Htdp/Shape.hs +409/−0
• src/Graphics/Htdp/Util/Arithmetic.hs +54/−0
• src/Graphics/Shape.hs +0/−409
• src/Graphics/Util/Arithmetic.hs +0/−54
• tests/CombinatorTest.hs +1/−1
• tests/ShapeTest.hs +1/−1

@@ -1,5 +1,10 @@ # Revision history for htdp-image +## 1.1.0.0 -- 2019-07-25++* Add "Htdp" to submodules++ ## 1.0.0.0 -- 2019-07-21  * Remove emptyScene.

@@ -1,5 +1,5 @@ name:                  htdp-image-version:               1.0.0.0+version:               1.1.0.0 license:               BSD3 license-file:          LICENSE author:                Turab Jafri@@ -25,10 +25,10 @@  library   exposed-modules:     Graphics.Htdp,-                       Graphics.Data.Image,-                       Graphics.Shape,-                       Graphics.Combinator-  other-modules:       Graphics.Util.Arithmetic+                       Graphics.Htdp.Combinator,+                       Graphics.Htdp.Data.Image,+                       Graphics.Htdp.Shape+  other-modules:       Graphics.Htdp.Util.Arithmetic   build-depends:       AC-Angle ^>=1.0,                        base ^>=4.12,                        gloss ^>=1.13.0

@@ -1,315 +0,0 @@-{-# 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

@@ -1,46 +0,0 @@-{-# 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)-    )-

@@ -17,9 +17,9 @@ module Graphics.Htdp   ( module Graphics.Gloss.Data.Color     -- * Image constructors-  , module Graphics.Shape+  , module Graphics.Htdp.Shape     -- * Image combinators-  , module Graphics.Combinator+  , module Graphics.Htdp.Combinator     -- * Image   , Image   , width@@ -32,9 +32,9 @@  import qualified Graphics.Gloss                as G import           Graphics.Gloss.Data.Color-import           Graphics.Combinator-import           Graphics.Data.Image-import           Graphics.Shape+import           Graphics.Htdp.Combinator+import           Graphics.Htdp.Data.Image+import           Graphics.Htdp.Shape  -- | Function to draw an image in a new window with same dimensions as the given image. drawImage :: Image -> IO ()

@@ -0,0 +1,315 @@+{-# LANGUAGE MultiWayIf, RecordWildCards #-}++-- | Utility to combine images.++module Graphics.Htdp.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.Htdp.Data.Image+import           Graphics.Htdp.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

@@ -0,0 +1,46 @@+{-# LANGUAGE RecordWildCards #-}++-- | Image related utilities.+module Graphics.Htdp.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)+    )+

@@ -0,0 +1,409 @@+{-# LANGUAGE MultiWayIf #-}++-- Sorted as they are in 2htdp/image+-- | Image constructors+module Graphics.Htdp.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.Htdp.Combinator+import           Graphics.Htdp.Data.Image+import qualified Graphics.Gloss                as G+import           Graphics.Gloss.Data.Color+import           Graphics.Htdp.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)

@@ -0,0 +1,54 @@+module Graphics.Htdp.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

@@ -1,409 +0,0 @@-{-# 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)

@@ -1,54 +0,0 @@-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

@@ -3,7 +3,7 @@   ) where -import           Graphics.Data.Image+import           Graphics.Htdp.Data.Image import           Graphics.Htdp import           Graphics.Gloss                 ( Picture ) import           Graphics.Gloss.Data.Picture    ( blank )

@@ -3,7 +3,7 @@   ) where -import           Graphics.Data.Image+import           Graphics.Htdp.Data.Image import           Graphics.Htdp import qualified Graphics.Gloss                as G import           Test.HUnit