diff --git a/Data/WrapAround.hs b/Data/WrapAround.hs --- a/Data/WrapAround.hs +++ b/Data/WrapAround.hs @@ -29,15 +29,27 @@ -} module Data.WrapAround ( WrapMap() + , WM , wrapmap + , wm , WrapPoint() + , WP , wrappoint + , wp , addPoints + , add , addPoints' + , add' , distance , subtractPoints + , diff + , subtractPoints' + , diff' , toCoords + , coords + , vec , vectorRelation + , relation -- , windowView -- , WrapWindow(..) ) where @@ -49,14 +61,22 @@ } deriving (Show) +type WM = WrapMap + +circleRadians = 2 * pi + +radius = (/ circleRadians) + -- |Generates a 'WrapMap'. -wrapmap :: Double -- ^ Width +wm, wrapmap :: Double -- ^ Width -> Double -- ^ Height -> WrapMap -wrapmap width height = WrapMap { radiusR = height / (2 * pi) - , radiusr = width / (2 * pi) - } +wrapmap w h = WrapMap { radiusR = radius h + , radiusr = radius w + } +wm = wrapmap + -- |A representation of a point location that allows for wrapping in the -- vertical or horizontal direction. data WrapPoint = WrapPoint { angler :: Double -- radians around tube center @@ -64,104 +84,152 @@ } deriving (Show) +type WP = WrapPoint + -- |Generates a 'WrapPoint'. -wrappoint :: WrapMap -- ^ Corresponding WrapMap structure +wp, wrappoint :: WrapMap -- ^ Corresponding WrapMap structure -> (Double, Double) -- ^ x, y coordinates -> WrapPoint -wrappoint wmap (x, y) - = let angleR' = fixAngle (y / radiusR wmap) in - let angler' = fixAngle (x / radiusr wmap) in - WrapPoint { angleR = angleR', angler = angler' } +wrappoint wmap (x, y) = + WrapPoint { angleR = fixAngle (y / radiusR wmap) + , angler = fixAngle (x / radiusr wmap) + } --- |Converts a WrapPoint to x, y coordinates. Generally you will only will only --- want to use this function for informational purposes, for example, to print --- out the x, y coordinates or to feed the coordinates to a graphics display --- function. If you convert a WrapPoint to x, y coordinates so that you can --- perform calculations with the coordinates, you must handle the wrapping math --- yourself and you are doing the work the module is supposed to do for you. -toCoords :: WrapMap -- ^ Corresponding WrapMap structure +wp = wrappoint + +-- |Converts a 'WrapPoint' to coordinates. +coords,toCoords,vec :: WrapMap -- ^ Corresponding WrapMap structure -> WrapPoint -- ^ WrapPoint to be converted -> (Double, Double) -toCoords WrapMap { radiusR = mRadiusR, radiusr = mRadiusr } - WrapPoint { angleR = pAngleR, angler = pAngler } - = (pAngler * mRadiusr, pAngleR * mRadiusR) +toCoords WrapMap { radiusR = rR, radiusr = rr } + WrapPoint { angleR = aR, angler = ar } + = (ar * rr, aR * rR) +coords = toCoords + +vec = toCoords + -- |Adds two WrapPoints together (vector style). -addPoints :: WrapPoint -- ^ The first WrapPoint in the operation - -> WrapPoint -- ^ The WrapPoint to be added to the first WrapPoint - -> WrapPoint -addPoints wp1 wp2 - = let angleR' = fixAngle (angleR wp1 + angleR wp2) in - let angler' = fixAngle (angler wp1 + angler wp2) in - WrapPoint { angleR = angleR', angler = angler' } +add,addPoints + :: WrapPoint -- ^ The first WrapPoint in the operation + -> WrapPoint -- ^ The WrapPoint to be added to the first WrapPoint + -> WrapPoint +addPoints a b = + WrapPoint { angleR = fixAngle (angleRSum a b) + , angler = fixAngle (anglerSum a b) + } +add = addPoints + +angleRSum a b = angleR a + angleR b +anglerSum a b = angler a + angler b + -- |Adds a WrapPoint and a pair of x, y coordinates (vector style). -addPoints' :: WrapMap -- ^ The corresponding WrapMap structure - -> WrapPoint -- ^ The WrapPoint in the operation - -> (Double, Double) -- ^ The x, y coordinates to be added to the WrapPoint - -> WrapPoint -addPoints' wmap wp1 (x, y) - = let wp2 = wrappoint wmap (x, y) in - let angleR' = fixAngle (angleR wp1 + angleR wp2) in - let angler' = fixAngle (angler wp1 + angler wp2) in - WrapPoint { angleR = angleR', angler = angler' } +add', addPoints' + :: WrapMap -- ^ The corresponding WrapMap structure + -> WrapPoint -- ^ The WrapPoint in the operation + -> (Double, Double) -- ^ The x, y coordinates to be added to the WrapPoint + -> WrapPoint +addPoints' w a v + = let b = wp w v in + WrapPoint { angleR = fixAngle (angleRSum a b) + , angler = fixAngle (anglerSum a b) + } +add' = addPoints' + +angleRDiff a b = angleR a - angleR b +anglerDiff a b = angleR a - angler b + -- |Subtracts a WrapPoint from a WrapPoint (vector style). -subtractPoints :: WrapPoint -- ^ The first WrapPoint in the operation - -> WrapPoint -- ^ The WrapPoint to be subtracted from the first WrapPoint - -> WrapPoint -subtractPoints wp1 wp2 - = let angleR' = fixAngle (angleR wp1 - angleR wp2) in - let angler' = fixAngle (angler wp1 - angler wp2) in - WrapPoint { angleR = angleR', angler = angler' } +diff, subtractPoints + :: WrapPoint -- ^ The first WrapPoint in the operation + -> WrapPoint -- ^ The WrapPoint to be subtracted from the first WrapPoint + -> WrapPoint +subtractPoints a b = + WrapPoint { angleR = fixAngle (angleRDiff a b) + , angler = fixAngle (anglerDiff a b) + } +diff = subtractPoints + +negV (x,y) = (-x,-y) + +-- |Subtracts coordinates from a WrapPoint (vector style). +diff', subtractPoints' + :: WrapMap -- ^ The corresponding WrapMap structure + -> WrapPoint -- ^ The WrapPoint in the operation + -> (Double, Double) -- ^ The x, y coordinates to be added to the WrapPoint + -> WrapPoint +subtractPoints' a b c = addPoints' a b (negV c) + +diff' = subtractPoints' + +join f a = f a a + +sqr = join (*) + +distrib f g a b = g (f a) (f b) + +sumSquares = distrib sqr (+) + +hypotenuse a b = sqrt (sumSquares a b) + -- |Finds the distance between two WrapPoints. distance :: WrapMap -- ^ The corresponding WrapMap structure -> WrapPoint -- ^ The first WrapPoint -> WrapPoint -- ^ The second WrapPoint -> Double -distance wmap wp1 wp2 - = let (dX, dY) = vectorRelation wmap wp1 wp2 in - sqrt (dX**2 + dY**2) +distance w a b + = let (x, y) = vectorRelation w a b in + hypotenuse x y -fixAngle :: Double -> Double -fixAngle radians - = let q = radians / (2 * pi) in - let angle = radians - fromIntegral (truncate q) * (2 * pi) in - if angle < 0 then 2 * pi + angle - else angle +isPos = (>= 0) +isNeg = not . isPos +fixAngle r + = let q = r / circleRadians in + let a = r - fromIntegral (truncate q) * circleRadians in + if isNeg a then circleRadians + a + else a + +absDiff a b = abs (a - b) + +spinCCW = (+ circleRadians) +spinCW = flip (-) circleRadians + -- |Returns the relationship between two WrapPoints as a pair of x, y -- coordinates (a vector). -vectorRelation :: WrapMap -- ^ The corresponding WrapMap structure - -> WrapPoint -- ^ The first WrapPoint - -> WrapPoint -- ^ The second WrapPoint - -> (Double, Double) -vectorRelation WrapMap { radiusR = mRadiusR, radiusr = mRadiusr } - WrapPoint { angleR = p1angleR, angler = p1angler } - WrapPoint { angleR = p2angleR, angler = p2angler } - = let dXa = abs (p2angler - p1angler) in - let dYa = abs (p2angleR - p1angleR) in - let dXb = if p1angler < p2angler - then abs ((p1angler + 2 * pi) - p2angler) - else abs ((p1angler - 2 * pi) - p2angler) in - let dYb = if p1angleR < p2angleR - then abs ((p1angleR + 2 * pi) - p2angleR) - else abs ((p1angleR - 2 * pi) - p2angleR) in +relation, vectorRelation + :: WrapMap -- ^ The corresponding WrapMap structure + -> WrapPoint -- ^ The first WrapPoint + -> WrapPoint -- ^ The second WrapPoint + -> (Double, Double) +vectorRelation WrapMap { radiusR = rR, radiusr = rr } + WrapPoint { angleR = aR1, angler = ar1 } + WrapPoint { angleR = aR2, angler = ar2 } + = let dXa = absDiff ar2 ar1 in + let dYa = absDiff aR2 aR1 in + let dXb = if ar1 < ar2 + then abs (spinCCW ar1 - ar2) + else abs (spinCW ar1 - ar2) in + let dYb = if aR1 < aR2 + then abs (spinCCW aR1 - aR2) + else abs (spinCW aR1 - aR2) in let dX = if dXa <= dXb - then p2angler - p1angler - else if p1angler <= p2angler - then (p2angler - 2 * pi) - p1angler - else (p2angler + 2 * pi) - p1angler in + then ar2 - ar1 + else if ar1 <= ar2 + then spinCW ar2 - ar1 + else spinCCW ar2 - ar1 in let dY = if dYa <= dYb - then p2angleR - p1angleR - else if p1angleR <= p2angleR - then (p2angleR - 2 * pi) - p1angleR - else (p2angleR + 2 * pi) - p1angleR in - let dX' = dX * mRadiusr in - let dY' = dY * mRadiusR in - (dX', dY') + then aR2 - aR1 + else if aR1 <= aR2 + then spinCW aR2 - aR1 + else spinCCW aR2 - aR1 in + (dX * rr, dY * rR) +relation = vectorRelation + -- Maybe add these someday after I find them useful -- data WrapWindow = WrapWindow { tlCorner :: (Double, Double) @@ -180,4 +248,3 @@ -- let vx' = vx in -- let vy' = (-vy) in -- (vx' + fst (tlCorner window), vy' + snd (tlCorner window)) - diff --git a/wrap-around-example.hs b/wrap-around-example.hs --- a/wrap-around-example.hs +++ b/wrap-around-example.hs @@ -2,34 +2,50 @@ import GHC.Float import Data.WrapAround -dispmode = InWindow "WrapAround module test" (1024, 768) (0, 0) +dispmode = InWindow "WrapAround module test" (800, 600) (0, 0) main = simulate dispmode (dim green) 10 model dispmodel stepfunc -data Model = Model { particles :: [(WrapPoint, (Double, Double))] - , wrapMap :: WrapMap } +data Model = Model { particles :: [(WP, (Double, Double))] + , wmap :: WM } deriving (Show) -wmap = wrapmap 200 300 - -model = Model { particles = [ (wrappoint wmap (10, 10), (10, 0)) - , (wrappoint wmap (30, 30), ((-5), (-5))) - ] - , Main.wrapMap = wmap +model = let wmap' = wm 800 600 in + let wrap (a, b) = (wp wmap' a, b) in + Model { particles = map wrap [ ((60, 30), (10, 0)) + , ((110, 140), (0, 18)) + , ((90, 50), (-8, 14)) + ] + , wmap = wmap' } -dispmodel m = let ps = do (wp, _) <- particles m - let (px, py) = toCoords (Main.wrapMap m) wp in - [ Polygon [ (double2Float px, double2Float py) - , (double2Float px + 10, double2Float py) - , (double2Float px + 10, double2Float py + 10) - , (double2Float px, double2Float py + 10) - ] ] in - Translate (-100.0) (-150.0) (Color green (Pictures ps)) +appPair f (x, y) = (f x, f y) -stepfunc _ _ m = let map = Main.wrapMap m in - let nparticles = do (wp, (x, y)) <- particles m - [ (addPoints' map wp (x, y), (x, y)) ] in - m { particles = nparticles } +downgrade a = appPair double2Float a + +dispmodel m = let s = [ let (x, y) = downgrade (coords (wmap m) p) in + Polygon [ (x, y) + , (x + 10, y) + , (x + 10, y + 10) + , (x, y + 10) + ] + | (p, _) <- particles m + ] in + Translate + (-400) (-300) + (Pictures [ (Color black + (Polygon [ (800, 600) + , (0, 600) + , (0, 0) + , (800, 0) + ])) + , (Color green + (Pictures s)) + ]) + +stepfunc _ _ m = m { particles = [ (add' (wmap m) p v, v) + | (p, v) <- particles m + ] + } diff --git a/wraparound.cabal b/wraparound.cabal --- a/wraparound.cabal +++ b/wraparound.cabal @@ -3,7 +3,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.0.1.1 +Version: 0.0.2 -- A short (one-line) description of the package. Synopsis: Convenient handling of points on a seamless 2-dimensional plane