diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,33 @@
# Revision history for reanimate
+## 0.3.0.0 -- 2020-05-11
+
+* Improve README.md with better examples at a higher framerate.
+* Improve canvas documentation, courtesy of William Yao.
+* Fix 'renameFile' bug when moving files between different file-systems.
+* Improve GeoJSON performance.
+* Improve SVG rendering performance.
+* CLI: Show time spent and time remaining when rendering.
+* Better support for external images.
+* Support external raster engines (inkscape, image magick, rsvg).
+* Fix framerate bug affecting GIFs.
+* Improve boundingbox performance.
+* Add generalized cubic bezier signal.
+
+## 0.2.0.2 -- 2020-02-25
+
+* Rewrite viewer from javascript to elm.
+* Improve API documentation.
+* Support for GeoJSON files (rendering borders, etc).
+* Fix bug affecting GIF frame rates.
+* Improve SVG serialization performance.
+* Add support for transitions (ie. functions that merge animations).
+* Properly handle ctrl-c when rendering.
+* Improve accuracy of bounding-box approximation.
+* Rewrite the API for building animations sequentially.
+* Expand 'pathify' to work on a larger subset of SVG.
+* Respect aspect ratio when 'height' or 'width' is specified but not both.
+
## 0.1.6.0 -- 2019-09-14
* Test suite.
diff --git a/docs/gifs/doc_cubicBezierS.gif b/docs/gifs/doc_cubicBezierS.gif
new file mode 100644
Binary files /dev/null and b/docs/gifs/doc_cubicBezierS.gif differ
diff --git a/examples/demo_tangent.hs b/examples/demo_tangent.hs
new file mode 100644
--- /dev/null
+++ b/examples/demo_tangent.hs
@@ -0,0 +1,110 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+{-# LANGUAGE OverloadedStrings #-}
+module Main(main) where
+
+import Control.Lens ((^.))
+import Control.Monad.State
+import qualified Data.Vector.Unboxed as V
+import Geom2D.CubicBezier (AnyBezier (..), Point (..),
+ evalBezierDeriv)
+import Graphics.SvgTree (Coord, Tree (..), mapTree,
+ pathDefinition)
+import Linear.Metric
+import Linear.V2 (V2 (..))
+import Linear.Vector
+import Reanimate
+import Reanimate.Builtin.Documentation
+
+main :: IO ()
+main = reanimate $ docEnv $ mkAnimation 30 $ \t ->
+ let piSvg = pathify $ lowerTransformations $ center $ scale 10 $ latex "s" in
+ mkGroup
+ [ mkBackgroundPixel rtfdBackgroundColor
+ , piSvg
+ , drawTangent t piSvg ]
+
+drawTangent :: Double -> SVG -> SVG
+drawTangent alpha | alpha >= 1 = id
+drawTangent alpha = mapTree worker
+ where
+ worker (PathTree path) =
+ let (V2 posX posY, tangent) =
+ atPartial alpha $ toLineCommands $ path^.pathDefinition
+ normed@(V2 tangentX tangentY) = normalize tangent ^* 4
+ V2 midX midY = lerp 0.5 0 normed
+ V2 normVectX normVectY = normalize tangent ^* (svgWidth normalTxt*1.1)
+ tangentSvg =
+ translate (posX) (posY) $
+ rotate (unangle normed/pi*180 + 180) $
+ translate 0 (svgHeight tangentTxt/2) $
+ tangentTxt
+ normalSvg =
+ translate (posX) (posY) $
+ rotate (unangle normed/pi*180 + 90) $
+ translate (svgWidth normalTxt/2*1.1) (svgHeight normalTxt/2*1.3) $
+ normalTxt
+ in mkGroup
+ [ withStrokeWidth (defaultStrokeWidth) $
+ withStrokeColor "black" $
+ translate (posX-midX) (posY-midY) $
+ mkLine (0, 0) (tangentX, tangentY)
+ , withStrokeWidth (defaultStrokeWidth) $
+ withStrokeColor "black" $
+ translate (posX) (posY) $
+ mkLine (0, 0) (-normVectY, normVectX)
+ , withStrokeWidth (defaultStrokeWidth*2) $
+ withStrokeColor "white" $
+ tangentSvg
+ , withFillOpacity 1 $ withFillColor "black" $ withStrokeWidth 0 $
+ tangentSvg
+ , withStrokeWidth (defaultStrokeWidth*2) $
+ withStrokeColor "white" $
+ normalSvg
+ , withFillOpacity 1 $ withFillColor "black" $ withStrokeWidth 0 $
+ normalSvg
+ ]
+ worker t = t
+ tangentTxt = scale 1.1 $ center $ latex "tangent"
+ normalTxt = scale 1.1 $ center $ latex "normal"
+
+atPartial :: Double -> [LineCommand] -> (V2 Double, V2 Double)
+atPartial alpha cmds = evalState (worker 0 cmds) zero
+ where
+ worker _d [] = pure (0, 0)
+ worker d (cmd:xs) = do
+ from <- get
+ len <- lineLength cmd
+ let frac = (targetLen-d) / len
+ if len == 0 || frac >= 1
+ then worker (d+len) xs
+ else do
+ let bezier = lineCommandToBezier from cmd
+ (pos, tangent) = evalBezierDeriv bezier frac
+ pure $ (fromPoint pos, fromPoint tangent)
+ totalLen = evalState (sum <$> mapM lineLength cmds) zero
+ targetLen = totalLen * alpha
+
+lineCommandToBezier :: V2 Coord -> LineCommand -> AnyBezier Coord
+lineCommandToBezier from line =
+ case line of
+ LineBezier [a] ->
+ AnyBezier $ V.fromList [toTuple from, toTuple a]
+ LineBezier [a,b] ->
+ AnyBezier $ V.fromList [toTuple from, toTuple a, toTuple b]
+ LineBezier [a,b,c] ->
+ AnyBezier $ V.fromList [toTuple from, toTuple a, toTuple b, toTuple c]
+ _ -> error (show line)
+
+fromPoint :: Point a -> V2 a
+fromPoint (Point x y) = V2 x y
+
+toTuple :: V2 a -> (a,a)
+toTuple (V2 x y) = (x, y)
+
+unangle :: (Floating a, Ord a) => V2 a -> a
+unangle a@(V2 ax ay) =
+ let alpha = asin $ ay / norm a
+ in if ax < 0
+ then pi - alpha
+ else alpha
diff --git a/examples/doc_cubicBezierS.golden b/examples/doc_cubicBezierS.golden
new file mode 100644
--- /dev/null
+++ b/examples/doc_cubicBezierS.golden
@@ -0,0 +1,50 @@
+0
+1
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+31
+32
+33
+34
+35
+36
+37
+38
+39
+40
+41
+42
+43
+44
+45
+46
+47
+48
+49
diff --git a/examples/doc_cubicBezierS.hs b/examples/doc_cubicBezierS.hs
new file mode 100644
--- /dev/null
+++ b/examples/doc_cubicBezierS.hs
@@ -0,0 +1,9 @@
+#!/usr/bin/env stack
+-- stack runghc --package reanimate
+module Main(main) where
+
+import Reanimate
+import Reanimate.Builtin.Documentation
+
+main :: IO ()
+main = reanimate $ docEnv $ signalA (cubicBezierS (0.0, 0.8, 0.9, 1.0)) drawProgress
diff --git a/examples/image.hs b/examples/image.hs
deleted file mode 100644
--- a/examples/image.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-#!/usr/bin/env stack
--- stack runghc --package reanimate
-module Main (main) where
-
-import Reanimate
-import qualified Graphics.SvgTree as Svg
-import Control.Lens ((&), (.~))
-import Graphics.SvgTree
-
-main :: IO ()
-main = reanimate $ animate $ const $
- ImageTree $ defaultSvg
- & Svg.imageCornerUpperLeft .~ (Svg.Num (-w/2), Svg.Num (-h/2))
- & Svg.imageWidth .~ Svg.Num w
- & Svg.imageHeight .~ Svg.Num h
- & Svg.imageHref .~ ("file://"++src)
-
-
- where
- w = screenWidth
- h = screenHeight
- src = "/home/lemmih/Coding/Haskell/reanimate/examples/haskell.svg"
diff --git a/examples/tut_glue_fourier.hs b/examples/tut_glue_fourier.hs
--- a/examples/tut_glue_fourier.hs
+++ b/examples/tut_glue_fourier.hs
@@ -12,8 +12,9 @@
-- layer 3
main :: IO ()
-main = reanimate $ parA bg $ sceneAnimation $ do
- play $ fourierA (fromToS 0 15) -- Rotate 15 times
+main = reanimate $ setDuration 30 $ sceneAnimation $ do
+ _ <- newSpriteSVG $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF)
+ play $ fourierA (fromToS 0 5) -- Rotate 15 times
# setDuration 50
# signalA (reverseS . powerS 2 . reverseS) -- Start fast, end slow
# pauseAtEnd 2
@@ -22,8 +23,6 @@
# reverseA
# signalA (powerS 2) -- Start slow, end fast
# pauseAtEnd 2
- where
- bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF)
-- layer 2
fourierA :: (Double -> Double) -> Animation
diff --git a/examples/tut_glue_latex.hs b/examples/tut_glue_latex.hs
--- a/examples/tut_glue_latex.hs
+++ b/examples/tut_glue_latex.hs
@@ -25,7 +25,7 @@
-- Draw equation
play $ drawAnimation strokedSvg
sprites <- forM glyphs $ \(fn, _, elt) ->
- newSpriteA $ animate $ const $ fn elt
+ newSpriteSVG $ fn elt
-- Yoink each glyph
forM_ (reverse sprites) $ \sprite -> do
spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE)
diff --git a/examples/tut_glue_potrace.hs b/examples/tut_glue_potrace.hs
--- a/examples/tut_glue_potrace.hs
+++ b/examples/tut_glue_potrace.hs
@@ -18,13 +18,10 @@
xRot <- newVar (-45)
yRot <- newVar 220
wf <- newSprite $ wireframe <$> unVar xRot <*> unVar yRot
- tweenVar yRot spinDur (\t v -> fromToS v (v+60*3) $ curveS 2 (t/spinDur))
+ fork $ tweenVar yRot spinDur $ \v -> fromToS v (v+60*3) . curveS 2
replicateM_ wobbles $ do
- tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v+90) $ curveS 2 (t/(wobbleDur/2)))
- fork $ do
- wait (wobbleDur/2)
- tweenVar xRot (wobbleDur/2) (\t v -> fromToS v (v-90) $ curveS 2 (t/(wobbleDur/2)))
- wait wobbleDur
+ tweenVar xRot (wobbleDur/2) $ \v -> fromToS v (v+90) . curveS 2
+ tweenVar xRot (wobbleDur/2) $ \v -> fromToS v (v-90) . curveS 2
destroySprite wf
play $ mkAnimation drawDuration (\t -> partialSvg t (wireframe (-45) 220))
# reverseA
diff --git a/examples/tut_glue_povray.hs b/examples/tut_glue_povray.hs
--- a/examples/tut_glue_povray.hs
+++ b/examples/tut_glue_povray.hs
@@ -6,7 +6,8 @@
module Main (main) where
import Reanimate
-import Reanimate.Povray (povraySlow)
+import Reanimate.Povray (povraySlow')
+import Reanimate.Raster
import Codec.Picture
import Codec.Picture.Types
@@ -21,7 +22,8 @@
main :: IO ()
-main = reanimate $ parA bg $ sceneAnimation $ do
+main = reanimate $ sceneAnimation $ do
+ newSpriteSVG $ mkBackgroundPixel $ PixelRGBA8 252 252 252 0xFF
zPos <- newVar 0
xRot <- newVar 0
zRot <- newVar 0
@@ -32,17 +34,14 @@
t <- spriteT
dur <- spriteDuration
pure $
- povraySlow [] $
+ mkImage screenWidth screenHeight $ povraySlow' [] $
script (svgAsPngFile (texture (t/dur))) transZ getX getZ
wait 2
- tweenVar zPos 9 (\t v -> fromToS v 8 (t/9))
- tweenVar xRot 9 (\t v -> fromToS v 360 $ curveS 2 (t/9))
- tweenVar zRot 9 (\t v -> fromToS v 360 $ curveS 2 (t/9))
+ fork $ tweenVar zPos 9 $ \v -> fromToS v 8
+ fork $ tweenVar xRot 9 $ \v -> fromToS v 360 . curveS 2
+ fork $ tweenVar zRot 9 $ \v -> fromToS v 360 . curveS 2
wait 10
- tweenVar zPos 2 (\t v -> fromToS v 0 $ curveS 3 (t/2))
- wait 2
- where
- bg = animate $ const $ mkBackgroundPixel $ PixelRGBA8 252 252 252 0xFF
+ tweenVar zPos 2 $ \v -> fromToS v 0 . curveS 3
texture :: Double -> SVG
texture t = frameAt (t*duration latexExample) latexExample
@@ -92,7 +91,7 @@
-- Draw equation
play $ drawAnimation strokedSvg
sprites <- forM glyphs $ \(fn, _, elt) ->
- newSpriteA $ animate $ const $ fn elt
+ newSpriteSVG $ fn elt
-- Yoink each glyph
forM_ (reverse sprites) $ \sprite -> do
spriteE sprite (overBeginning 1 $ aroundCenterE $ highlightE)
diff --git a/reanimate.cabal b/reanimate.cabal
--- a/reanimate.cabal
+++ b/reanimate.cabal
@@ -3,7 +3,7 @@
-- see http://haskell.org/cabal/users-guide/
name: reanimate
-version: 0.2.0.2
+version: 0.3.0.0
-- synopsis:
-- description:
license: PublicDomain
@@ -91,7 +91,7 @@
JuicyPixels, attoparsec, parallel,
cubicbezier, websockets,
hashable, fsnotify, open-browser, random-shuffle, base64-bytestring,
- vector, colour, cassava, ansi-wl-pprint, here, temporary,
+ vector >= 0.12.0.0, colour, cassava, ansi-wl-pprint, here, temporary,
optparse-applicative, chiphunk >= 0.1.2.1,
geojson, aeson >= 1.3.0.0
ghc-options: -Wall
diff --git a/src/Reanimate.hs b/src/Reanimate.hs
--- a/src/Reanimate.hs
+++ b/src/Reanimate.hs
@@ -11,20 +11,30 @@
between external components such as 'latex', 'ffmpeg', 'gnuplot', 'diagrams',
and 'povray'.
+= Canvas
+
+Reanimate uses its own internal, Cartesian coordinate system for animations,
+with a fixed canvas size of 16x9, where X and Y are real numbers. (0, 0) is
+located in the center of the canvas, with positive X going to the right, and
+positive Y going up. This means that e.g. (8, 4.5) is the top right corner
+and (-8, -4.5) is the bottom left corner. Note that this canvas size does not
+affect how large or small output resolution will be, although it /does/ affect
+aspect ratio.
+
+= Driver
+
+Reanimate features a web-based viewer which is opened by default if
+no other parameters are given. Key features:
+
+ * This viewer listens for changes to the source file and recompiles the
+ code automatically as needed.
+ * Animations are rendered with increasing fidelity until the frame
+ rate reaches 60 fps.
+ * Key commands for pausing, frame stepping, forward/rewind.
+ To pause press SPACE, to move -1\/+1\/-10\/+10 frames use LEFT\/RIGHT\/DOWN\/UP arrow keys.
-}
module Reanimate
- ( -- * Driver
- --
- -- | Reanimate features a web-based viewer which is opened by default if
- -- no other parameters are given. Key features:
- --
- -- * This viewer listens for changes to the source file and recompiles the
- -- code automatically as needed.
- -- * Animations are rendered with increasing fidelity until the frame
- -- rate reaches 60 fps.
- -- * Key commands for pausing, frame stepping, forward/rewind.
- -- To pause press SPACE, to move -1\/+1\/-10\/+10 frames use LEFT\/RIGHT\/DOWN\/UP arrow keys.
- reanimate,
+ ( reanimate,
-- * Animations
SVG,
Time,
@@ -62,6 +72,7 @@
bellS,
oscillateS,
fromListS,
+ cubicBezierS,
-- ** Scenes
(#),
Scene
diff --git a/src/Reanimate/Builtin/Documentation.hs b/src/Reanimate/Builtin/Documentation.hs
--- a/src/Reanimate/Builtin/Documentation.hs
+++ b/src/Reanimate/Builtin/Documentation.hs
@@ -48,3 +48,6 @@
height = 1
img = generateImage pixelRenderer width height
pixelRenderer x _y = f (fromIntegral x / fromIntegral (width-1))
+
+rtfdBackgroundColor :: PixelRGBA8
+rtfdBackgroundColor = PixelRGBA8 252 252 252 0xFF
diff --git a/src/Reanimate/Cache.hs b/src/Reanimate/Cache.hs
--- a/src/Reanimate/Cache.hs
+++ b/src/Reanimate/Cache.hs
@@ -7,6 +7,7 @@
, cacheDiskLines
) where
+import Control.Exception
import Control.Monad (unless)
import Data.Hashable
import Data.IORef
@@ -17,13 +18,13 @@
import qualified Data.Text.IO as T
import Graphics.SvgTree (Tree (..), unparse)
import Reanimate.Animation (renderTree)
+import Reanimate.Misc (renameOrCopyFile)
import System.Directory
import System.FilePath
import System.IO
-import Control.Exception
+import System.IO.Temp
import System.IO.Unsafe
import Text.XML.Light (Content (..), parseXML)
-import System.IO.Temp
-- Memory cache and disk cache
@@ -36,7 +37,7 @@
unless hit $ withSystemTempFile template $ \tmp h -> do
hClose h
gen tmp
- renameFile tmp path
+ renameOrCopyFile tmp path
evaluate path
cacheDisk :: (T.Text -> Maybe a) -> (a -> T.Text) -> (Text -> IO a) -> (Text -> IO a)
@@ -58,7 +59,7 @@
new <- gen key
T.hPutStr tmpHandle (render new)
hClose tmpHandle
- renameFile tmpPath path
+ renameOrCopyFile tmpPath path
return new
cacheDiskKey :: Text -> IO Tree -> IO Tree
diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs
--- a/src/Reanimate/Driver.hs
+++ b/src/Reanimate/Driver.hs
@@ -145,6 +145,8 @@
,"--target", target
,"+RTS", "-N", "-RTS"]
else do
+ raster <- selectRaster renderRaster
+ setRaster raster
setFPS fps
setWidth width
setHeight height
@@ -153,9 +155,10 @@
\ width: %d\n\
\ height: %d\n\
\ fmt: %s\n\
- \ target: %s\n"
- fps width height (showFormat fmt) target
- raster <- selectRaster renderRaster
+ \ target: %s\n\
+ \ raster: %s\n"
+ fps width height (showFormat fmt) target (show raster)
+
render animation target raster fmt width height fps
selectRaster :: Raster -> IO Raster
diff --git a/src/Reanimate/GeoProjection.hs b/src/Reanimate/GeoProjection.hs
--- a/src/Reanimate/GeoProjection.hs
+++ b/src/Reanimate/GeoProjection.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
module Reanimate.GeoProjection
( Projection(..)
@@ -6,6 +7,7 @@
, LonLat(..)
, project
, interpP
+ , interpBBP
, mergeP
, isValidP
, scaleP
@@ -17,6 +19,7 @@
, mercatorP
, mollweideP
, hammerP
+ , cylindricalEqualAreaP
, lambertP
, bottomleyP
, sinusoidalP
@@ -42,22 +45,33 @@
import Codec.Picture
import Codec.Picture.Types
-import Control.Lens ((^.))
+import Control.Lens ((^.))
import Control.Monad
import Control.Monad.ST
+import Control.Monad.ST.Unsafe
import Data.Aeson
import Data.Foldable
-import Data.Geospatial hiding (LonLat)
+import Data.Geospatial hiding (LonLat)
+import Data.Hashable
import Data.LinearRing
-import qualified Data.LineString as Line
+import qualified Data.LineString as Line
+import Data.Vector.Storable (unsafeWith)
+import qualified Data.Vector.Unboxed as V
import Debug.Trace
-import Graphics.SvgTree (Tree (None))
-import Linear (distance, lerp)
-import Linear.V2 hiding (angle)
+import Foreign
+import GHC.Exts (Double (..), cosDouble#, sinDouble#,
+ (*##), (+##), (-##), (/##))
+import Graphics.SvgTree (Tree (None))
+import Linear (distance, lerp)
+import Linear.V2 hiding (angle)
import Reanimate
import System.IO.Unsafe
-
+{-# INLINE halfPi #-}
+{-# INLINE sqrtPi #-}
+{-# INLINE sqrt2 #-}
+{-# INLINE epsilon #-}
+{-# INLINE tau #-}
-- Constants
halfPi, sqrtPi, sqrt2, epsilon, tau :: Double
halfPi = pi/2
@@ -70,136 +84,294 @@
toRads dec = dec/180 * pi
cot = recip . tan
+
srcPixel :: Pixel pixel => Image pixel -> LonLat -> pixel
srcPixel src (LonLat lam phi) =
- pixelAt src xPx yPx
+ -- pixelAt src xPx yPx
+ unsafePixelAt (imageData src) (pixelBaseIndex src xPx yPx)
where
!xPx = round $ ((lam+pi)/tau) * fromIntegral (imageWidth src-1)
!yPx = round $ (1-((phi+halfPi)/pi)) * fromIntegral (imageHeight src-1)
-{- HLINT ignore -}
-findValidCoord :: Image pixel -> Projection -> XYCoord -> XYCoord
-findValidCoord !src !p (XYCoord x y) = foldr const (XYCoord x y)
- [ XYCoord x' y'
- | let !xi = round $ x * wMax
- !yi = round $ y * hMax
- , !ax <- [xi, xi-1, xi+1]
- , ax >= 0
- , ax < w
- , let !x' = fromIntegral ax / wMax
- , !ay <- [yi, yi-1, yi+1]
- , ay >= 0
- , ay < h
- , let !y' = fromIntegral ay / hMax
- , validLonLat $! projectionInverse p $! XYCoord x' y'
- ]
+
+srcPixelFast :: Image PixelRGBA8 -> Double -> Double -> LonLat -> ST s PixelRGBA8
+srcPixelFast src wMax hMax (LonLat lam phi) = unsafeIOToST $
+ unsafeWith (imageData src) $ \ptr -> do
+ let ptr' = plusPtr ptr idx
+ r <- peek ptr'
+ g <- peek $ plusPtr ptr' 1
+ b <- peek $ plusPtr ptr' 2
+ a <- peek $ plusPtr ptr' 3
+ return $ PixelRGBA8 r g b a
where
- !w = imageWidth src
- !h = imageHeight src
- !wMax = fromIntegral (w-1)
- !hMax = fromIntegral (h-1)
+ !idx = pixelBaseIndex src xPx yPx
+ !xPx = round $ ((lam+pi)/tau) * wMax
+ !yPx = round $ (1-((phi+halfPi)/pi)) * hMax
-isInWorld :: Projection -> XYCoord -> Bool
-isInWorld p coord =
- odd $ length $ isInWorld' p coord
+{- HLINT ignore -}
+-- findValidCoord :: Int -> Int -> Double -> Double -> (XYCoord -> LonLat) -> XYCoord -> XYCoord
+-- findValidCoord !w !h !wMax !hMax !p_inv (XYCoord x y) = foldr const (XYCoord x y)
+-- [ XYCoord x' y'
+-- | let !xi = round $ x * wMax
+-- !yi = round $ y * hMax
+-- , !ax <- [xi, xi-1, xi+1]
+-- , ax >= 0
+-- , ax < w
+-- , let !x' = fromIntegral ax / wMax
+-- , !ay <- [yi, yi-1, yi+1]
+-- , ay >= 0
+-- , ay < h
+-- , let !y' = fromIntegral ay / hMax
+-- , validLonLat $! p_inv $! XYCoord x' y'
+-- ]
-isInWorld' :: Projection -> XYCoord -> [(Double, Double)]
-isInWorld' p (XYCoord x y) =
- [ (x1, y1)
- | (XYCoord x1 y1, XYCoord x2 y2) <- world
- , (y1 > y) /= (y2 > y) -- y is between y1 and y2
- , x < (x2 - x1) * (y - y1) / (y2 - y1) + x1 -- x is to the left of the line
- ]
- where
- world = worldPolygon p
+-- isInWorld :: Projection -> XYCoord -> Bool
+-- isInWorld p coord =
+-- odd $ length $ isInWorld' p coord
+--
+-- isInWorld' :: Projection -> XYCoord -> [(Double, Double)]
+-- isInWorld' p (XYCoord x y) =
+-- [ (x1, y1)
+-- | (XYCoord x1 y1, XYCoord x2 y2) <- world
+-- , (y1 > y) /= (y2 > y) -- y is between y1 and y2
+-- , x < (x2 - x1) * (y - y1) / (y2 - y1) + x1 -- x is to the left of the line
+-- ]
+-- where
+-- world = worldPolygon p
+--
+-- worldPolygon :: Projection -> [(XYCoord, XYCoord)]
+-- worldPolygon p =
+-- interp (-pi, -halfPi) (-pi, halfPi) ++
+-- interp (-pi, halfPi) (pi, halfPi) ++
+-- interp (pi, halfPi) (pi, -halfPi) ++
+-- interp (pi, -halfPi) (-pi, -halfPi)
+-- where
+-- apply (lam, phi) = projectionForward p $ LonLat lam phi
+-- steps = 100
+-- interp (x1, y1) (x2,y2) =
+-- [ ( apply (fromToS x1 x2 (n/steps), fromToS y1 y2 (n/steps))
+-- , apply (fromToS x1 x2 ((n+1)/steps), fromToS y1 y2 ((n+1)/steps)))
+-- | n <- [0..steps-1]]
-worldPolygon :: Projection -> [(XYCoord, XYCoord)]
-worldPolygon p =
- interp (-pi, -halfPi) (-pi, halfPi) ++
- interp (-pi, halfPi) (pi, halfPi) ++
- interp (pi, halfPi) (pi, -halfPi) ++
- interp (pi, -halfPi) (-pi, -halfPi)
- where
- apply (lam, phi) = projectionForward p $ LonLat lam phi
- steps = 100
- interp (x1, y1) (x2,y2) =
- [ ( apply (fromToS x1 x2 (n/steps), fromToS y1 y2 (n/steps))
- , apply (fromToS x1 x2 ((n+1)/steps), fromToS y1 y2 ((n+1)/steps)))
- | n <- [0..steps-1]]
+-- findNearestPixel :: MutableImage s PixelRGBA8 -> Int -> Int -> Int -> Int -> ST s PixelRGBA8
+-- findNearestPixel src w h srcX srcY = worker $ take 20
+-- [ (x, y)
+-- | n <- [1..]
+-- , x <- [srcX-n .. srcY+n]
+-- , y <- if x == srcX-n || x == srcX+n then [srcY-n,srcY+n] else [srcY-n .. srcY+n]
+-- , x >= 0
+-- , y >= 0
+-- , x < w
+-- , y < h
+-- ]
+-- where
+-- worker [] = pure $ PixelRGBA8 0xFF 0x00 0x00 0xFF
+-- worker ((x,y):rest) = do
+-- this <- readPixel src x y
+-- if this == blank
+-- then worker rest
+-- else return this
+-- blank = PixelRGBA8 0x00 0x00 0x00 0x00
-findNearestPixel :: MutableImage s PixelRGBA8 -> Int -> Int -> Int -> Int -> ST s PixelRGBA8
-findNearestPixel src w h srcX srcY = worker $ take 20
- [ (x, y)
- | n <- [1..]
- , x <- [srcX-n .. srcY+n]
- , y <- if x == srcX-n || x == srcX+n then [srcY-n,srcY+n] else [srcY-n .. srcY+n]
- , x >= 0
- , y >= 0
- , x < w
- , y < h
- ]
- where
- worker [] = pure $ PixelRGBA8 0xFF 0x00 0x00 0xFF
- worker ((x,y):rest) = do
- this <- readPixel src x y
- if this == blank
- then worker rest
- else return this
- blank = PixelRGBA8 0x00 0x00 0x00 0x00
+-- Original version: 134,925 pixels/second
+-- Inlined projections: 136,332 pixels/second
+-- TEST: no write pixels: 134,288 pixels/second !!!
+-- Fast theta: 1,489,719 pixels/second
+-- Cached theta: 3,622,254 pixels/second
+
+-- to equirectangularP: 9,015,326 pixels/second
+-- 9,680,217
+-- 9,466,744
+-- 14,830,330
+-- to lambertP: 6,735,973
+-- to mercatorP: 4,248,927
+-- to mollweideP: 3,593,545
+-- to hammerP: 3,237,699
+-- to bottomleyP: 3,864,848
+-- to sinusoidalP: 7,020,756
+-- to wernerP: 4,433,295
+-- to bonneP: 4,071,187
+-- to augustP: 2,553,177
+-- to collignonP: 5,486,849
+-- to eckert1P: 7,428,849
+-- to eckert3P: 6,666,936
+-- to eckert5P: 6,106,492
+-- to faheyP: 5,137,291
+-- to foucautP: 3,983,151
+-- to lagrangeP: 3,850,611
+-- interpFastP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8
+-- interpFastP !src (Projection _ p1 p1_inv) (Projection _ p2 p2_inv) !t = runST $ do
+-- unsafeIOToST $ putStrLn "Allocating new array"
+-- !img <- newMutableImage w h
+-- unsafeIOToST $ putStrLn "done"
+-- start <- unsafeIOToST $ getCurrentTime
+-- let factor = 2
+-- total = w*factor * h*factor
+-- let l1 =
+-- loopTo (w*factor) $ \x -> do
+-- loopTo (h*factor) $ \y -> do
+-- let thisIndex = (x*h*factor+y)
+-- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do
+-- now <- getCurrentTime
+-- let diff = realToFrac (diffUTCTime now start):: Double
+-- printf "%.2f pixels/second\n" (fromIntegral (total-thisIndex) / diff)
+-- let !x1' = fromIntegral x / (wMax*fromIntegral factor)
+-- !y1' = fromIntegral y / (hMax*fromIntegral factor)
+-- !lonlat = p1_inv $! XYCoord x1' y1'
+-- -- p = srcPixel src lonlat
+-- -- unsafeIOToST (evaluate lonlat)
+--
+-- when (validLonLat lonlat) $ do
+-- p <- srcPixelFast src wMax hMax lonlat
+-- when (pixelOpacity p /= 0) $ do
+-- let XYCoord !x1 !y1 = p1 lonlat
+-- -- !coord = p2 lonlat
+-- XYCoord !x2 !y2 = p2 lonlat -- findValidCoord w h wMax hMax p2_inv $ p2 lonlat
+-- !x3 = round $ fromToS x1 x2 t * wMax
+-- !y3 = round $ (1 - fromToS y1 y2 t) * hMax :: Int
+-- -- unsafeIOToST (evaluate coord)
+-- -- return ()
+-- when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $
+-- writePixel img x3 y3 p
+-- l1
+-- unsafeFreezeImage img
+-- where
+-- loopTo m fn = go m
+-- where go 0 = return ()
+-- go n = fn (n-1) >> go (n-1)
+-- !w = imageWidth src
+-- !h = imageHeight src
+-- !wMax = fromIntegral (w-1)
+-- !hMax = fromIntegral (h-1)
+
interpP :: Image PixelRGBA8 -> Projection -> Projection -> Double -> Image PixelRGBA8
-interpP !src !p1 !p2 !t = runST $ do
+interpP src p1 _ 0 = project src p1
+interpP src _ p2 1 = project src p2
+interpP !src (Projection _label1 p1 p1_inv) !(Projection _label2 p2 p2_inv) !t = runST $ do
!img <- newMutableImage w h
- let blank = PixelRGBA8 0x00 0x00 0x00 0x00
- let isBlank pixel = pixel == blank
- -- forM_ [0..w-1] $ \x ->
- -- forM_ [0..h-1] $ \y -> do
- -- let x1 = fromIntegral x / (wMax)
- -- y1 = 1 - fromIntegral y / (hMax)
- -- when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $
- -- writePixel img x y $ PixelRGBA8 0xFF 0x00 0x00 0xFF
+
let factor = 2
+ -- total = w*factor * h*factor
+ let l1 = do
+ -- start <- unsafeIOToST $ getCurrentTime
+ loopTo (w*factor) $ \x -> do
+ loopTo (h*factor) $ \y -> do
+ -- let thisIndex = (x*h*factor+y)
+ -- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do
+ -- now <- getCurrentTime
+ -- let diff = realToFrac (diffUTCTime now start):: Double
+ -- printf "%.2f pixels/second: %s\n" (fromIntegral (total-thisIndex) / diff) label1
+ let !x1' = fromIntegral x / (wMax*fromIntegral factor)
+ !y1' = fromIntegral y / (hMax*fromIntegral factor)
+ !lonlat = p1_inv $! XYCoord x1' y1'
+ -- p = srcPixel src lonlat
+
+ when (validLonLat lonlat) $ do
+ p <- srcPixelFast src wMax hMax lonlat
+ when (pixelOpacity p /= 0) $ do
+ let XYCoord x1 y1 = p1 lonlat
+ -- XYCoord x2 y2 = findValidCoord w h wMax hMax p2_inv $ p2 lonlat
+ XYCoord x2 y2 = p2 lonlat
+ !x3 = round $ fromToS x1 x2 t * wMax
+ !y3 = round $ (1 - fromToS y1 y2 t) * hMax
+ when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $
+ writePixel img x3 y3 p
+ l2 = do
+ -- start <- unsafeIOToST $ getCurrentTime
+ loopTo (w*factor) $ \x ->
+ loopTo (h*factor) $ \y -> do
+ -- let thisIndex = (x*h*factor+y)
+ -- when (thisIndex `mod` 1000000 == 0) $ unsafeIOToST $ do
+ -- now <- getCurrentTime
+ -- let diff = realToFrac (diffUTCTime now start):: Double
+ -- printf "%.2f pixels/second: %s\n" (fromIntegral (total-thisIndex) / diff) label2
+ let !x2' = fromIntegral x / (wMax*fromIntegral factor)
+ !y2' = fromIntegral y / (hMax*fromIntegral factor)
+ !lonlat = p2_inv (XYCoord x2' y2')
+ -- p = srcPixel src lonlat
+ when (validLonLat lonlat) $ do
+ p <- srcPixelFast src wMax hMax lonlat
+ when (pixelOpacity p /= 0) $ do
+ let XYCoord x2 y2 = p2 lonlat
+ -- XYCoord x1 y1 = findValidCoord w h wMax hMax p1_inv $ p1 lonlat
+ XYCoord x1 y1 = p1 lonlat
+ !x3 = round $ fromToS x1 x2 t * wMax
+ !y3 = round $ (1 - fromToS y1 y2 t) * hMax
+ when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do
+ writePixel img x3 y3 p
+ if t < 0.5
+ then l1 >> l2
+ else l2 >> l1
+ unsafeFreezeImage img
+ where
+ loopTo m fn = go m
+ where go 0 = return ()
+ go n = fn (n-1) >> go (n-1)
+ !w = imageWidth src
+ !h = imageHeight src
+ !wMax = fromIntegral (w-1)
+ !hMax = fromIntegral (h-1)
+
+interpBBP :: Image PixelRGBA8 -> Projection -> Projection ->
+ (Double,Double,Double,Double) -> (Double,Double,Double,Double) -> Double -> Image PixelRGBA8
+interpBBP !src (Projection _ p1 p1_inv) !(Projection _ p2 p2_inv) (fx,fy,fw,fh) (tx, ty, tw, th) !t = runST $ do
+ !img <- newMutableImage w h
+ let factor = 2
let l1 =
loopTo (w*factor) $ \x -> do
loopTo (h*factor) $ \y -> do
let !x1' = fromIntegral x / (wMax*fromIntegral factor)
!y1' = fromIntegral y / (hMax*fromIntegral factor)
- !lonlat = projectionInverse p1 $! XYCoord x1' y1'
- p = srcPixel src lonlat
- when (validLonLat lonlat && pixelOpacity p /= 0) $ do
- let XYCoord x1 y1 = projectionForward p1 lonlat
- XYCoord x2 y2 = findValidCoord src p2 $ projectionForward p2 lonlat
- !x3 = round $ fromToS x1 x2 t * wMax
- !y3 = round $ (1 - fromToS y1 y2 t) * hMax
- when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $
- writePixel img x3 y3 p
+ when (x1' >= fx && x1' <= fx+fw && y1' >= fy && y1' <= fy+fh) $ do
+ let !lonlat = p1_inv $! XYCoord x1' y1'
+ -- p = srcPixel src lonlat
+
+ when (validLonLat lonlat) $ do
+ -- let LonLat lam phi = lonlat
+ -- !xPx = ((lam+pi)/tau)
+ -- !yPx = (((phi+halfPi)/pi))
+ -- when (xPx >= fx && xPx <= fx+fw && yPx >= fy && yPx <= fy+fh) $ do
+ p <- srcPixelFast src wMax hMax lonlat
+ when (pixelOpacity p /= 0) $ do
+ let XYCoord x1 y1 = p1 lonlat
+ XYCoord x2 y2 = p2 lonlat
+ -- XYCoord x2 y2 = findValidCoord w h wMax hMax p2_inv $ p2 lonlat
+ !x3 = round $ fromToS x1 x2 t * wMax
+ !y3 = round $ (1 - fromToS y1 y2 t) * hMax
+ when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $
+ writePixel img x3 y3 p
l2 =
loopTo (w*factor) $ \x ->
loopTo (h*factor) $ \y -> do
let !x2' = fromIntegral x / (wMax*fromIntegral factor)
!y2' = fromIntegral y / (hMax*fromIntegral factor)
- !lonlat = projectionInverse p2 (XYCoord x2' y2')
- p = srcPixel src lonlat
- when (validLonLat lonlat && pixelOpacity p /= 0) $ do
- let XYCoord x2 y2 = projectionForward p2 lonlat
- XYCoord x1 y1 = findValidCoord src p1 $ projectionForward p1 lonlat
- !x3 = round $ fromToS x1 x2 t * wMax
- !y3 = round $ (1 - fromToS y1 y2 t) * hMax
- when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do
- writePixel img x3 y3 p
+ when (x2' >= tx && x2' <= tx+tw && y2' >= ty && y2' <= ty+th) $ do
+ let !lonlat = p2_inv (XYCoord x2' y2')
+ -- p = srcPixel src lonlat
+ when (validLonLat lonlat) $ do
+ p <- srcPixelFast src wMax hMax lonlat
+ when (pixelOpacity p /= 0) $ do
+ let XYCoord x2 y2 = p2 lonlat
+ -- XYCoord x1 y1 = findValidCoord w h wMax hMax p1_inv $ p1 lonlat
+ XYCoord x1 y1 = p1 lonlat
+ !x3 = round $ fromToS x1 x2 t * wMax
+ !y3 = round $ (1 - fromToS y1 y2 t) * hMax
+ when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do
+ writePixel img x3 y3 p
if t < 0.5
then l1 >> l2
else l2 >> l1
- when False $
- forM_ [0..w-1] $ \x ->
- forM_ [0..h-1] $ \y -> do
- let x1 = fromIntegral x / (wMax)
- y1 = 1 - fromIntegral y / (hMax)
- this <- readPixel img x y
- when (isBlank this) $
- when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $
- writePixel img x y =<< findNearestPixel img w h x y
+ -- when False $
+ -- forM_ [0..w-1] $ \x ->
+ -- forM_ [0..h-1] $ \y -> do
+ -- let x1 = fromIntegral x / (wMax)
+ -- y1 = 1 - fromIntegral y / (hMax)
+ -- this <- readPixel img x y
+ -- when (isBlank this) $
+ -- when (isInWorld (mergeP p1 p2 t) (XYCoord x1 y1)) $
+ -- writePixel img x y =<< findNearestPixel img w h x y
unsafeFreezeImage img
where
loopTo m fn = go m
@@ -210,6 +382,7 @@
!wMax = fromIntegral (w-1)
!hMax = fromIntegral (h-1)
+
eqLonLat :: LonLat -> LonLat -> Bool
eqLonLat (LonLat x1 y1) (LonLat x2 y2)
= eqDouble x1 x2 && eqDouble y1 y2
@@ -225,14 +398,19 @@
deriving (Read,Show,Eq,Ord)
data LonLat = LonLat !Double !Double -- -pi to +pi, -halfPi to +halfPi
deriving (Read,Show,Eq,Ord)
+instance Hashable LonLat where
+ hashWithSalt s (LonLat a b) = hashWithSalt s (a,b)
data Projection = Projection
- { projectionForward :: !(LonLat -> XYCoord)
+ { projectionLabel :: String
+ , projectionForward :: !(LonLat -> XYCoord)
+ --
+ -- (Double# -> Double# -> (# Double#, Double# #))
, projectionInverse :: !(XYCoord -> LonLat)
}
-- FIXME: Verify that 'src' has an aspect ratio of 2:1.
project :: Image PixelRGBA8 -> Projection -> Image PixelRGBA8
-project src (Projection _ pInv) = generateImage fn w h
+project src (Projection _label _ pInv) = generateImage fn w h
where
w = imageWidth src
h = imageHeight src
@@ -253,7 +431,7 @@
_validXYCoord (XYCoord x y) = x >= 0 && x <= 1 && y >= 0 && y <= 1
isValidP :: Projection -> Bool
-isValidP (Projection p pInv) = and
+isValidP (Projection _label p pInv) = and
[ check x y
| x <- [0..w-1::Int]
, y <- [0..h-1::Int] ]
@@ -269,7 +447,7 @@
|| trace (show (lonlat, lonlat2)) False
moveBottomP :: Double -> Projection -> Projection
-moveBottomP offset (Projection p pInv) = Projection p' pInv'
+moveBottomP offset (Projection label p pInv) = Projection label p' pInv'
where
p' (LonLat lon lat) =
case p (LonLat lon lat) of
@@ -280,7 +458,7 @@
moveTopP offset = flipYAxisP . moveBottomP offset . flipYAxisP
flipYAxisP :: Projection -> Projection
-flipYAxisP (Projection p pInv) = Projection p' pInv'
+flipYAxisP (Projection label p pInv) = Projection label p' pInv'
where
p' (LonLat lam phi) =
let XYCoord x y = p (LonLat lam (negate phi))
@@ -290,18 +468,17 @@
in LonLat lam (negate phi)
scaleP :: Double -> Double -> Projection -> Projection
-scaleP xScale yScale (Projection p pInv) = Projection forward inverse
+scaleP xScale yScale (Projection label p pInv) = Projection label forward inverse
where
forward lonlat =
case p lonlat of
XYCoord x y -> XYCoord ((x-0.5)*xScale+0.5) ((y-0.5)*yScale+0.5)
inverse (XYCoord x y) =
- let new = XYCoord ((x-0.5)/xScale+0.5) ((y-0.5)/yScale+0.5)
- in pInv new
+ pInv $ XYCoord ((x-0.5)/xScale+0.5) ((y-0.5)/yScale+0.5)
mergeP :: Projection -> Projection -> Double -> Projection
-mergeP p1 p2 t = Projection p pInv
+mergeP p1 p2 t = Projection (projectionLabel p1 ++ "/" ++ projectionLabel p2) p pInv
where
p lonlat =
let XYCoord x1 y1 = projectionForward p1 lonlat
@@ -317,7 +494,7 @@
-- | <>
equirectangularP :: Projection
-equirectangularP = Projection forward inverse
+equirectangularP = Projection "equirectangular" forward inverse
where
forward (LonLat lam phi) = XYCoord ((lam+pi)/tau) ((phi+pi/2)/pi)
inverse (XYCoord x y) = LonLat xPi yPi
@@ -327,7 +504,7 @@
-- | <>
mercatorP :: Projection
-mercatorP = Projection forward inverse
+mercatorP = Projection "mercator" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((lam+pi)/tau)
@@ -337,33 +514,65 @@
xPi = fromToS (-pi) pi x
yPi = fromToS (-pi) pi y
+thetas :: V.Vector Double
+thetas = V.fromList $
+ map (find_theta_fast . fromIndex) [0 .. granularity]
+
+granularity :: Int
+granularity = 50000
+
+toIndex :: Double -> Int
+toIndex phi = round ((phi+halfPi)/pi * fromIntegral granularity)
+fromIndex :: Int -> Double
+fromIndex x = fromToS (-halfPi) halfPi (fromIntegral x / fromIntegral granularity)
+granualize :: Double -> Double
+granualize = fromIndex . toIndex
+
+{-# INLINE mollweideP #-}
-- | <>
mollweideP :: Projection
-mollweideP = Projection forward inverse
+mollweideP = Projection "mollweide" forward inverse
where
- forward (LonLat lam phi) =
+ forward (LonLat !lam !phi) =
XYCoord ((x+sqrt2*2)/(4*sqrt2)) ((y+sqrt2)/(2*sqrt2))
where
x = (2*sqrt2)/pi * lam * cos theta
y = sqrt2*sin theta
- theta = find_theta 100
- find_theta :: Int -> Double
- find_theta 0 = phi
- find_theta _ | abs phi == pi/2 = signum phi * pi/2
- find_theta n =
- let sub = find_theta (n-1)
- in sub - (2*sub+sin (2*sub)-pi*sin phi)/(2+2*cos(2*sub))
+ theta = thetas V.! toIndex phi
+ -- find_theta :: Int -> Double
+ -- find_theta 0 = phi
+ -- find_theta _ | abs phi == pi/2 = signum phi * pi/2
+ -- find_theta n =
+ -- let !sub = find_theta (n-1)
+ -- in sub - (2*sub+sin (2*sub)-pi*sin phi)/(2+2*cos(2*sub))
inverse (XYCoord x' y') = LonLat lam phi
where
x = fromToS (-2*sqrt2) (2*sqrt2) x'
- y = fromToS (-sqrt2) sqrt2 y'
- theta = asin (y/sqrt2)
+ y = fromToS (-1) 1 y'
+ theta = granualize (asin y)
lam = pi*x/(2*sqrt2*cos theta)
phi = asin ((2*theta+sin(2*theta))/pi)
+find_theta_fast :: Double -> Double
+find_theta_fast !phi | abs phi == pi/2 = signum phi * halfPi
+find_theta_fast !(D# phi) = go phi
+ where
+ !(D# pi#) = pi
+ go acc =
+ let c = cosDouble# (acc +## acc)
+ s = sinDouble# (acc +## acc)
+ next =
+ acc -##
+ (acc +## acc +## s -## pi# *## (sinDouble# phi))
+ /## (2.0## +## c +## c) in
+ if abs (D# (next -## acc)) < epsilon
+ then D# next
+ else go next
+
+
-- | <>
hammerP :: Projection
-hammerP = Projection forward inverse
+hammerP = Projection "hammer" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((x+sqrt2*2)/(4*sqrt2)) ((y+sqrt2)/(2*sqrt2))
@@ -378,9 +587,20 @@
lam = 2 * atan2 (z*x) (2*(2*z**2-1))
phi = asin (z*y)
+cylindricalEqualAreaP :: Double -> Projection
+cylindricalEqualAreaP phi0 = Projection "lambert" forward inverse
+ where
+ cosPhi0 = cos phi0
+ forward (LonLat lam phi) =
+ XYCoord ((lam+pi)/tau) ((sin phi/cosPhi0+1/cosPhi0)/2/cosPhi0)
+ inverse (XYCoord x' y') = LonLat x (asin y / (asin cosPhi0 / halfPi))
+ where
+ x = fromToS (-pi) pi x'
+ y = fromToS (-1) 1 y' * cosPhi0
+
-- | <>
lambertP :: Projection
-lambertP = Projection forward inverse
+lambertP = Projection "lambert" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((lam+pi)/tau) ((sin phi+1)/2)
@@ -391,7 +611,7 @@
-- | <>
bottomleyP :: Double -> Projection
-bottomleyP !phi_1 = Projection forward inverse
+bottomleyP !phi_1 = Projection "bottomley" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((x+pi)/tau) ((y+pi/2)/pi)
@@ -413,7 +633,7 @@
-- | <>
sinusoidalP :: Projection
-sinusoidalP = Projection forward inverse
+sinusoidalP = Projection "sinusoidal" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((x+pi)/tau) ((y+pi/2)/pi)
@@ -427,7 +647,7 @@
-- | <>
wernerP :: Projection
-wernerP = moveTopP 0.23 $ Projection forward inverse
+wernerP = moveTopP 0.23 $ Projection "werner" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((x+pi)/tau) ((y+pi/2)/pi)
@@ -449,7 +669,8 @@
-- | <>
bonneP :: Double -> Projection
bonneP 0 = sinusoidalP
-bonneP phi_0 = moveTopP (-0.17*factor) $ scaleP 1 (fromToS 1 0.65 factor) $ Projection forward inverse
+bonneP phi_0 = moveTopP (-0.17*factor) $ scaleP 1 (fromToS 1 0.65 factor) $
+ Projection "bonne" forward inverse
where
factor = sin phi_0 / sin (pi/4)
forward (LonLat lam phi ) = XYCoord ((x+pi)/tau) ((y+halfPi)/pi)
@@ -471,7 +692,7 @@
-- | <>
orthoP :: LonLat -> Projection
-orthoP (LonLat lam_0 phi_0) = Projection forward inverse
+orthoP (LonLat lam_0 phi_0) = Projection "ortho" forward inverse
where
forward (LonLat lam phi)
| cosc < 0 =
@@ -503,7 +724,7 @@
| otherwise = v
cassiniP :: Projection
-cassiniP = Projection forward inverse
+cassiniP = Projection "cassini" forward inverse
where
forward (LonLat lam phi) =
XYCoord ((asin (cos phi * sin lam)+halfPi)/pi) ((atan2 (tan phi) (cos lam)+pi)/tau)
@@ -514,8 +735,9 @@
lam = atan2 (tan x) (cos y)
phi = asin (sin y * cos x)
+
augustP :: Projection
-augustP = scaleP 0.70 0.70 $ Projection forward inverse
+augustP = scaleP 0.70 0.70 $ Projection "august" forward inverse
where
xHi = 16/3
xLo = -xHi
@@ -550,7 +772,7 @@
-- | <>
collignonP :: Projection
-collignonP = Projection forward inverse
+collignonP = Projection "collignon" forward inverse
where
yHi = sqrtPi
yLo = sqrtPi * (1 - sqrt2)
@@ -571,7 +793,7 @@
-- | <>
eckert1P :: Projection
-eckert1P = Projection forward inverse
+eckert1P = Projection "eckert1" forward inverse
where
alpha = sqrt (8 / (3*pi))
yLo = -alpha * halfPi
@@ -591,7 +813,7 @@
-- | <>
eckert3P :: Projection
-eckert3P = Projection forward inverse
+eckert3P = Projection "eckert3" forward inverse
where
k = sqrt (pi * (4 + pi))
yLo = negate yHi
@@ -611,7 +833,7 @@
-- | <>
eckert5P :: Projection
-eckert5P = Projection forward inverse
+eckert5P = Projection "eckert5" forward inverse
where
k = sqrt (2 + pi)
yLo = negate yHi
@@ -629,9 +851,10 @@
lam = k * x / (1 + cos phi)
phi = y * k / 2
+{-# INLINE faheyP #-}
-- | <>
faheyP :: Projection
-faheyP = Projection forward inverse
+faheyP = Projection "fahey" forward inverse
where
faheyK = cos (toRads 35)
yLo = negate yHi
@@ -651,8 +874,9 @@
lam = x / (faheyK * sqrt (1 - t*t))
phi = 2 * atan2 y (1 + faheyK)
+{-# INLINE foucautP #-}
foucautP :: Projection
-foucautP = Projection forward inverse
+foucautP = Projection "foucaut" forward inverse
where
yLo = negate yHi
yHi = sqrtPi * tan (halfPi/2)
@@ -673,8 +897,9 @@
phi = 2 * k
lam = x * sqrtPi / 2 / (cos phi * cosk * cosk)
+{-# INLINE lagrangeP #-}
lagrangeP :: Projection
-lagrangeP = Projection forward inverse
+lagrangeP = Projection "lagrange" forward inverse
where
yLo = negate yHi
yHi = 2
@@ -691,7 +916,9 @@
x = 2 * sin (lam*n) / c
y = (v - 1/v) /c
inverse (XYCoord x' y')
- | abs (abs y'-1) < epsilon = LonLat 0 (signum y * halfPi)
+ | abs (y'-1) < epsilon
+ -- = LonLat 0 (signum y * halfPi)
+ = LonLat 100 100
| otherwise = LonLat lam phi
where
x = fromToS xLo xHi x' / 2
diff --git a/src/Reanimate/Memo.hs b/src/Reanimate/Memo.hs
--- a/src/Reanimate/Memo.hs
+++ b/src/Reanimate/Memo.hs
@@ -38,6 +38,10 @@
emptyCacheMap :: CacheMap
emptyCacheMap = CacheMap Map.empty Map.empty
+-- sizeCacheMap :: CacheMap -> Int
+-- sizeCacheMap (CacheMap sub vals) =
+-- sum (map sizeCacheMap (Map.elems sub)) + Map.size vals
+
cacheMapLookup :: [DynamicName] -> CacheMap -> Maybe Dynamic
cacheMapLookup [] _ = Nothing
cacheMapLookup [k] (CacheMap _ vals) = Map.lookup k vals
diff --git a/src/Reanimate/Misc.hs b/src/Reanimate/Misc.hs
--- a/src/Reanimate/Misc.hs
+++ b/src/Reanimate/Misc.hs
@@ -5,13 +5,17 @@
, runCmdLazy
, withTempDir
, withTempFile
+ , renameOrCopyFile
) where
-import Control.Exception (evaluate, finally)
+import Control.Exception (evaluate, finally, throw, catch)
import qualified Data.Text as T
import qualified Data.Text.IO as T
-import System.Directory (createDirectory, findExecutable,
- getTemporaryDirectory, removeFile)
+import Foreign.C.Error
+import GHC.IO.Exception
+import System.Directory (copyFile, createDirectory, findExecutable,
+ getTemporaryDirectory, removeFile,
+ renameFile)
import System.Exit (ExitCode (..))
import System.FilePath ((<.>), ())
import System.IO (hClose, hGetContents, hIsEOF, openTempFile)
@@ -19,6 +23,7 @@
runInteractiveProcess, showCommandForUser,
terminateProcess, waitForProcess)
+
requireExecutable :: String -> IO FilePath
requireExecutable exec = do
mbPath <- findExecutable exec
@@ -31,7 +36,7 @@
ret <- runCmd_ exec args
case ret of
Left err -> error $ showCommandForUser exec args ++ ":\n" ++ err
- Right{} -> return ()
+ Right{} -> return ()
runCmd_ :: FilePath -> [String] -> IO (Either String String)
runCmd_ exec args = do
@@ -61,7 +66,7 @@
_ <- evaluate (length stderr)
ret <- waitForProcess pid
case ret of
- ExitSuccess -> return (Left "")
+ ExitSuccess -> return (Left "")
ExitFailure{} -> return (Left stderr)
{-ExitFailure errMsg -> do
return $ Left $
@@ -75,6 +80,13 @@
terminateProcess pid
_ <- waitForProcess pid
return ()
+
+renameOrCopyFile :: FilePath -> FilePath -> IO ()
+renameOrCopyFile src dst = renameFile src dst `catch` exdev
+ where
+ exdev e = if fmap Errno (ioe_errno e) == Just eXDEV
+ then copyFile src dst >> removeFile src
+ else throw e
withTempDir :: (FilePath -> IO a) -> IO a
withTempDir action = do
diff --git a/src/Reanimate/Parameters.hs b/src/Reanimate/Parameters.hs
--- a/src/Reanimate/Parameters.hs
+++ b/src/Reanimate/Parameters.hs
@@ -1,18 +1,48 @@
module Reanimate.Parameters
- ( pFPS
+ ( Raster(..)
+ , Width
+ , Height
+ , FPS
+ , pRaster
+ , pFPS
, pWidth
, pHeight
, pNoExternals
+ , pRootDirectory
+ , setRaster
, setFPS
, setWidth
, setHeight
, setNoExternals
+ , setRootDirectory
) where
import System.IO.Unsafe
import Data.IORef
-import Reanimate.Render
+type Width = Int
+type Height = Int
+type FPS = Int
+
+data Raster
+ = RasterNone
+ | RasterAuto
+ | RasterInkscape
+ | RasterRSvg
+ | RasterConvert
+ deriving (Show)
+
+{-# NOINLINE pRasterRef #-}
+pRasterRef :: IORef Raster
+pRasterRef = unsafePerformIO (newIORef RasterNone)
+
+{-# NOINLINE pRaster #-}
+pRaster :: Raster
+pRaster = unsafePerformIO (readIORef pRasterRef)
+
+setRaster :: Raster -> IO ()
+setRaster = writeIORef pRasterRef
+
{-# NOINLINE pFPSRef #-}
pFPSRef :: IORef FPS
pFPSRef = unsafePerformIO (newIORef 0)
@@ -58,3 +88,13 @@
setNoExternals :: Bool -> IO ()
setNoExternals = writeIORef pNoExternalsRef
+{-# NOINLINE pRootDirectoryRef #-}
+pRootDirectoryRef :: IORef FilePath
+pRootDirectoryRef = unsafePerformIO (newIORef (error "root directory not set"))
+
+{-# NOINLINE pRootDirectory #-}
+pRootDirectory :: FilePath
+pRootDirectory = unsafePerformIO (readIORef pRootDirectoryRef)
+
+setRootDirectory :: FilePath -> IO ()
+setRootDirectory = writeIORef pRootDirectoryRef
diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs
--- a/src/Reanimate/Raster.hs
+++ b/src/Reanimate/Raster.hs
@@ -1,5 +1,7 @@
module Reanimate.Raster
- ( embedImage
+ ( mkImage
+ , cacheImage
+ , embedImage
, embedDynamicImage
, embedPng
, raster
@@ -35,7 +37,27 @@
import System.IO.Temp
import System.IO.Unsafe
+-- FIXME: Embed the image data as inline base64 iff no raster engine is specified.
+mkImage :: Double -> Double -> FilePath -> SVG
+mkImage width height path = unsafePerformIO $ do
+ exists <- doesFileExist target
+ unless exists $ copyFile path target
+ return $ flipYAxis $ ImageTree $ defaultSvg
+ & Svg.imageWidth .~ Svg.Num width
+ & Svg.imageHeight .~ Svg.Num height
+ & Svg.imageHref .~ ("file://"++target)
+ & Svg.imageCornerUpperLeft .~ (Svg.Num (-width/2), Svg.Num (-height/2))
+ & Svg.imageAspectRatio .~ Svg.PreserveAspectRatio False Svg.AlignNone Nothing
+ where
+ target = pRootDirectory show hashPath <.> takeExtension path
+ hashPath = hash path
+cacheImage :: (PngSavable pixel, Hashable a) => a -> Image pixel -> FilePath
+cacheImage key gen = unsafePerformIO $ cacheFile template $ \path ->
+ writePng path gen
+ where
+ template = show (hash key) <.> "png"
+
{-# INLINE embedImage #-}
embedImage :: PngSavable a => Image a -> Tree
embedImage img = embedPng width height (encodePng img)
@@ -119,7 +141,7 @@
convert <- requireExecutable "convert"
runCmd convert [ path, "-flatten", tmpBmpPath ]
runCmd potrace (args ++ ["--svg", "--output", tmpSvgPath, tmpBmpPath])
- renameFile tmpSvgPath svgPath
+ renameOrCopyFile tmpSvgPath svgPath
svg_data <- B.readFile svgPath
case parseSvgFile svgPath svg_data of
Nothing -> do
diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs
--- a/src/Reanimate/Render.hs
+++ b/src/Reanimate/Render.hs
@@ -10,16 +10,18 @@
import Control.Concurrent
import Control.Exception
-import Control.Monad (forM_, void)
+import Control.Monad (forM_, void, unless, forever)
import qualified Data.Text as T
import qualified Data.Text.IO as T
+import Data.Time
import Graphics.SvgTree (Number (..))
import Numeric
import Reanimate.Animation
import Reanimate.Misc
-import System.FilePath (())
-import System.FilePath (replaceExtension)
+import Reanimate.Parameters
import System.Exit
+import System.FilePath (())
+import System.FilePath (replaceExtension)
import System.IO
import Text.Printf (printf)
@@ -71,21 +73,9 @@
where
isSeen x = any (\y -> x `mod` y == 0) seen
-data Raster
- = RasterNone
- | RasterAuto
- | RasterInkscape
- | RasterRSvg
- | RasterConvert
- deriving (Show)
-
data Format = RenderMp4 | RenderGif | RenderWebm
deriving (Show)
-type Width = Int
-type Height = Int
-type FPS = Int
-
render :: Animation
-> FilePath
-> Raster
@@ -131,18 +121,35 @@
generateFrames :: Raster -> Animation -> Width -> Height -> FPS -> (FilePath -> IO a) -> IO a
generateFrames raster ani width_ height_ rate action = withTempDir $ \tmp -> do
+ setRootDirectory tmp
done <- newMVar (0::Int)
let frameName nth = tmp printf nameTemplate nth
- putStr $ "\r0/" ++ show frameCount
+ putStr $ "\rFrames rendered: 0/" ++ show frameCount ++ "\27[K\r"
hFlush stdout
- handle h $ concurrentForM_ frames $ \n -> do
- writeFile (frameName n) $ renderSvg width height $ nthFrame n
- applyRaster raster (frameName n)
- modifyMVar_ done $ \nDone -> do
- putStr $ "\r" ++ show (nDone+1) ++ "/" ++ show frameCount
- hFlush stdout
- return (nDone+1)
- putStrLn "\n"
+ start <- getCurrentTime
+ let statusPrinter = forever $ do
+ nDone <- readMVar done
+ now <- getCurrentTime
+ let spent = diffUTCTime now start
+ remaining = (spent / (fromIntegral nDone / fromIntegral frameCount)) - spent
+ putStr $ "\rFrames rendered: " ++ show nDone ++ "/" ++ show frameCount
+ putStr $ ", time spent: " ++ ppDiff spent
+ unless (nDone==0) $ do
+ putStr $ ", time remaining: " ++ ppDiff remaining
+ putStr $ ", total time: " ++ ppDiff (remaining+spent)
+ putStr $ "\27[K\r"
+ hFlush stdout
+ threadDelay 1000000
+ withBackgroundThread statusPrinter $ do
+ handle h $ concurrentForM_ frames $ \n -> do
+ writeFile (frameName n) $ renderSvg width height $ nthFrame n
+ applyRaster raster (frameName n)
+ modifyMVar_ done $ \nDone -> return (nDone+1)
+ now <- getCurrentTime
+ let spent = diffUTCTime now start
+ putStr $ "\rFrames rendered: " ++ show frameCount ++ "/" ++ show frameCount
+ putStr $ ", time spent: " ++ ppDiff spent
+ putStr $ "\27[K\n"
action (tmp rasterTemplate raster)
where
width = Just $ Px $ fromIntegral width_
@@ -152,11 +159,24 @@
\Hit ctrl-c again to abort."
return ()
h other = throwIO other
- frames = [0..frameCount-1]
+ -- frames = [0..frameCount-1]
+ frames = frameOrder rate frameCount
nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
frameCount = round (duration ani * fromIntegral rate) :: Int
nameTemplate :: String
nameTemplate = "render-%05d.svg"
+
+withBackgroundThread :: IO () -> IO a -> IO a
+withBackgroundThread t = bracket (forkIO t) killThread . const
+
+ppDiff :: NominalDiffTime -> String
+ppDiff diff
+ | hours == 0 && mins == 0 = show secs ++ "s"
+ | hours == 0 = printf "%.2d:%.2d" mins secs
+ | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs
+ where
+ (osecs, secs) = round diff `divMod` (60::Int)
+ (hours, mins) = osecs `divMod` 60
rasterTemplate :: Raster -> String
rasterTemplate RasterNone = "render-%05d.svg"
diff --git a/src/Reanimate/Signal.hs b/src/Reanimate/Signal.hs
--- a/src/Reanimate/Signal.hs
+++ b/src/Reanimate/Signal.hs
@@ -8,6 +8,7 @@
, bellS
, oscillateS
, fromListS
+ , cubicBezierS
) where
-- | Signals are time-varying variables. Signals can be composed using function
@@ -91,3 +92,16 @@
-- <>
bellS :: Double -> Signal
bellS steepness = curveS steepness . oscillateS
+
+-- | Cubic Bezier signal. Gives you a fair amount of control over how the
+-- signal will 'curve'.
+--
+-- Example:
+--
+-- > signalA (cubicBezierS (0.0, 0.8, 0.9, 1.0)) drawProgress
+--
+-- <>
+cubicBezierS :: (Double, Double, Double, Double) -> Signal
+cubicBezierS (x1, x2, x3, x4) s =
+ let ms = 1-s
+ in x1*ms^(3::Int) + 3*x2*ms^(2::Int)*s + 3*x3*ms*s^(2::Int) + x4*s^(3::Int)
diff --git a/src/Reanimate/Svg/BoundingBox.hs b/src/Reanimate/Svg/BoundingBox.hs
--- a/src/Reanimate/Svg/BoundingBox.hs
+++ b/src/Reanimate/Svg/BoundingBox.hs
@@ -44,7 +44,8 @@
case x of
LineMove to -> worker to xs
-- LineDraw to -> from:to:worker to xs
- -- FIXME: Use approximation from Geom2D.Bezier
+ LineBezier [p] ->
+ p : worker p xs
LineBezier ctrl -> -- approximation
[ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++
worker (last ctrl) xs