From b466bcc6bef53be85f033d05fd820e5ae1dbf6dd Mon Sep 17 00:00:00 2001 From: David Himmelstrup Date: Thu, 20 Feb 2020 16:34:52 +0800 Subject: [PATCH] Misc cleanup. (#55) Former-commit-id: 8490a1405235c3902e8bca9d7fc2f6845b287d19 --- examples/tut_glue_blender.hs | 18 +- src/Reanimate/Blender.hs | 4 +- src/Reanimate/Builtin/Flip.hs | 1 + src/Reanimate/Builtin/Images.hs | 3 + src/Reanimate/Chiphunk.hs | 6 +- src/Reanimate/ColorMap.hs | 8 +- src/Reanimate/ColorSpace.hs | 8 +- src/Reanimate/Driver.hs | 13 +- src/Reanimate/Driver/CLI.hs | 5 +- src/Reanimate/Driver/Server.hs | 1 - src/Reanimate/Effect.hs | 8 +- src/Reanimate/Examples.hs | 563 ------------------------------ src/Reanimate/GeoProjection.hs | 69 ++-- src/Reanimate/Morph.hs | 13 +- src/Reanimate/PolyShape.hs | 24 +- src/Reanimate/Povray.hs | 5 +- src/Reanimate/Raster.hs | 1 - src/Reanimate/Render.hs | 8 +- src/Reanimate/Scene.hs | 6 +- src/Reanimate/Signal.hs | 2 +- src/Reanimate/Svg.hs | 16 +- src/Reanimate/Svg/BoundingBox.hs | 2 +- src/Reanimate/Svg/Constructors.hs | 58 +-- src/Reanimate/Svg/LineCommand.hs | 59 ++-- test/UnitTests.hs | 6 +- 25 files changed, 175 insertions(+), 732 deletions(-) delete mode 100644 src/Reanimate/Examples.hs diff --git a/examples/tut_glue_blender.hs b/examples/tut_glue_blender.hs index 3dee7fa..aaf09c8 100755 --- a/examples/tut_glue_blender.hs +++ b/examples/tut_glue_blender.hs @@ -17,6 +17,8 @@ import Graphics.SvgTree import System.Random import System.Random.Shuffle +-- spritePercent = (/) <$> spriteT <*> spriteDur + main :: IO () main = seq texture $ reanimate $ pauseAtEnd 1 $ parA bg $ sceneAnimation $ do bend <- newVar 0 @@ -33,17 +35,17 @@ main = seq texture $ reanimate $ pauseAtEnd 1 $ parA bg $ sceneAnimation $ do return $ seq (texture (t/dur)) $ blender (script (texture (t/dur)) getBend getTrans getRotX getRotY) wait 2 - tweenVar trans 5 (\t v -> fromToS v (-2) $ curveS 2 (t/5)) - tweenVar bend 5 (\t v -> fromToS v 1 $ curveS 2 (t/5)) - tweenVar rotY 15 (\t v -> fromToS v (pi*2*2) $ curveS 2 (t/15)) + tweenVar trans 5 (\t v -> fromToS v (-2) $ curveS 2 t) + tweenVar bend 5 (\t v -> fromToS v 1 $ curveS 2 t) + tweenVar rotY 15 (\t v -> fromToS v (pi*2*2) $ curveS 2 t) fork $ do - tweenVar rotX 5 (\t v -> fromToS v (-pi/5) $ curveS 2 (t/5)) + tweenVar rotX 5 (\t v -> fromToS v (-pi/5) $ curveS 2 t) wait 5 - tweenVar rotX 5 (\t v -> fromToS v (pi/5) $ curveS 2 (t/5)) + tweenVar rotX 5 (\t v -> fromToS v (pi/5) $ curveS 2 t) wait (15-5) - tweenVar bend 5 (\t v -> fromToS v 0 $ curveS 2 (t/5)) - tweenVar rotX 5 (\t v -> fromToS v 0 $ curveS 2 (t/5)) - tweenVar trans 5 (\t v -> fromToS v 0 $ curveS 2 (t/5)) + tweenVar bend 5 (\t v -> fromToS v 0 $ curveS 2 t) + tweenVar rotX 5 (\t v -> fromToS v 0 $ curveS 2 t) + tweenVar trans 5 (\t v -> fromToS v 0 $ curveS 2 t) wait 4 -- tweenVar trans 1 (\t v -> fromToS v 0 $ curveS 2 t) wait 1 diff --git a/src/Reanimate/Blender.hs b/src/Reanimate/Blender.hs index de6bc02..26f4d1f 100644 --- a/src/Reanimate/Blender.hs +++ b/src/Reanimate/Blender.hs @@ -22,11 +22,11 @@ import Data.Hashable blender :: Text -> SVG blender script = - (unsafePerformIO $ mkBlenderImage script) + unsafePerformIO $ mkBlenderImage script blender' :: Text -> FilePath blender' script = - (unsafePerformIO $ mkBlenderImage' script) + unsafePerformIO $ mkBlenderImage' script mkBlenderImage :: Text -> IO Tree mkBlenderImage script | pNoExternals = pure $ mkText script diff --git a/src/Reanimate/Builtin/Flip.hs b/src/Reanimate/Builtin/Flip.hs index 0ab025c..6224e42 100755 --- a/src/Reanimate/Builtin/Flip.hs +++ b/src/Reanimate/Builtin/Flip.hs @@ -2,6 +2,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ApplicativeDo #-} +{- HLINT ignore -} module Reanimate.Builtin.Flip ( FlipSprite(..) , flipSprite diff --git a/src/Reanimate/Builtin/Images.hs b/src/Reanimate/Builtin/Images.hs index 09ca55a..8825a5f 100644 --- a/src/Reanimate/Builtin/Images.hs +++ b/src/Reanimate/Builtin/Images.hs @@ -29,14 +29,17 @@ loadJPG key = unsafePerformIO $ do Left err -> error err Right img -> return $ convertRGB8 img +{- HLINT ignore svgLogo -} -- | <> svgLogo :: SVG svgLogo = unsafePerformIO $ embedImage "data/svg-logo.svg" +{- HLINT ignore haskellLogo -} -- | <> haskellLogo :: SVG haskellLogo = unsafePerformIO $ embedImage "data/haskell.svg" +{- HLINT ignore githubIcon -} -- | <> githubIcon :: SVG githubIcon = unsafePerformIO $ embedImage "data/github-icon.svg" diff --git a/src/Reanimate/Chiphunk.hs b/src/Reanimate/Chiphunk.hs index b9fb3d2..bccec97 100644 --- a/src/Reanimate/Chiphunk.hs +++ b/src/Reanimate/Chiphunk.hs @@ -49,9 +49,9 @@ renderBodyStore space store = do angle <- get $ bodyAngle body let bodySvg = translate posX posY $ - rotate (angle/pi*180) $ + rotate (angle/pi*180) svg - modifyIORef lst $ (bodySvg:) + modifyIORef lst (bodySvg:) ) nullPtr result <- readIORef lst return $ mkGroup result @@ -72,7 +72,7 @@ simulate space store fps stepsPerFrame dur = do in frozen V.! key polyShapesToBody :: Space -> [PolyShape] -> IO Body -polyShapesToBody space poly = do +polyShapesToBody space poly = polygonsToBody space (map (map toVect) $ plDecompose poly) where toVect (V2 x y) = Vect x y diff --git a/src/Reanimate/ColorMap.hs b/src/Reanimate/ColorMap.hs index 073c2bf..d3c2a67 100644 --- a/src/Reanimate/ColorMap.hs +++ b/src/Reanimate/ColorMap.hs @@ -163,9 +163,9 @@ sinebow t = PixelRGB8 r g b pi_1_3 = pi / 3 pi_2_3 = pi * 2 / 3 x = (0.5 - t) * pi - r = round $ 255 * sin(x)**2 - g = round $ 255 * sin(x+pi_1_3)**2 - b = round $ 255 * sin(x+pi_2_3)**2 + r = round $ 255 * sin x**2 + g = round $ 255 * sin (x+pi_1_3)**2 + b = round $ 255 * sin (x+pi_2_3)**2 -- | Given a number t in the range [0,1], returns the corresponding color from -- the “cividis” color vision deficiency-optimized color scheme designed by @@ -499,7 +499,7 @@ colors = V.fromList . map (toColor . map (fromIntegral . digitToInt) . T.unpack) toColor _ = error "Reanimate.ColorMap.colors: Broken data" ramp :: Vector PixelRGB8 -> Double -> PixelRGB8 -ramp v = \t -> v V.! (max 0 $ min (len-1) $ round $ t * (len'-1)) +ramp v = \t -> v V.! max 0 (min (len-1) $ round $ t * (len'-1)) where len = V.length v len' = fromIntegral len diff --git a/src/Reanimate/ColorSpace.hs b/src/Reanimate/ColorSpace.hs index a7747c2..fd12ba9 100644 --- a/src/Reanimate/ColorSpace.hs +++ b/src/Reanimate/ColorSpace.hs @@ -16,7 +16,7 @@ import Reanimate.Svg.Constructors type Nanometer = Integer - +{-# NOINLINE lightXYZCoordinates #-} lightXYZCoordinates :: Map Nanometer (Double, Double, Double) lightXYZCoordinates = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/CIExyz.csv" @@ -25,6 +25,7 @@ lightXYZCoordinates = unsafePerformIO $ do Right vec -> return $ Map.fromList [ (nm, (x,y,z)) | (nm,x,y,z) <- V.toList vec, nm <= 700 ] +{-# NOINLINE bigXYZCoordinates #-} bigXYZCoordinates :: Map Nanometer (Double, Double, Double) bigXYZCoordinates = unsafePerformIO $ do dat <- BS.readFile =<< getDataFileName "data/CIE_XYZ.csv" @@ -41,7 +42,7 @@ nmToColor nm = do renderXYZCoordinates :: Tree renderXYZCoordinates = withFillOpacity 0 $ - mkLinePath $ + mkLinePath [ (x, 1-y) | (_nm, (x,y,_z)) <- Map.toList lightXYZCoordinates ] @@ -54,11 +55,12 @@ lightLABCoordinates = Map.map fn lightXYZCoordinates renderLABCoordinates :: Tree renderLABCoordinates = withFillOpacity 0 $ - mkLinePath $ + mkLinePath [ (a/350, (1-b)/150) | (_nm, (_l,a,b)) <- Map.toList lightLABCoordinates ] +{-# NOINLINE coneSensitivity #-} -- (Long, Medium, Short) coneSensitivity :: Map Nanometer (Double, Double, Double) coneSensitivity = unsafePerformIO $ do diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs index 13e9a9b..7e3fa94 100644 --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -126,15 +126,12 @@ reanimate animation = do RenderWebm -> replaceExtension self "webm" Just target -> makeAbsolute target - let fps = guessParameter renderFPS (fmap presetFPS renderPreset) $ - (formatFPS fmt) + let fps = guessParameter renderFPS (fmap presetFPS renderPreset) $ formatFPS fmt (width, height) = - case userPreferredDimensions renderWidth renderHeight of - Just userPref -> userPref - Nothing -> - ( maybe (formatWidth fmt) presetWidth renderPreset - , maybe (formatHeight fmt) presetHeight renderPreset - ) + fromMaybe + ( maybe (formatWidth fmt) presetWidth renderPreset + , maybe (formatHeight fmt) presetHeight renderPreset ) + (userPreferredDimensions renderWidth renderHeight) if renderCompile then diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs index db9149b..389caab 100644 --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} module Reanimate.Driver.CLI ( getDriverOptions , Options(..) @@ -17,7 +16,7 @@ import Prelude import Reanimate.Render (FPS, Format (..), Height, Raster (..), Width) -data Options = Options +newtype Options = Options { optsCommand :: Command } deriving (Show) @@ -106,7 +105,7 @@ commandP = subparser(command "raw" rawCommand <|> infoParser viewCommand rawCommand :: ParserInfo Command -rawCommand = info (parse) +rawCommand = info parse (progDesc "Output raw SVGs for animation at 60 fps. Used internally by viewer.") where parse = pure Raw diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs index 6452610..6035f2e 100644 --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -5,7 +5,6 @@ module Reanimate.Driver.Server ) where import Control.Concurrent -import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (SomeException, catch, finally) import Control.Monad import Control.Monad.Fix (fix) diff --git a/src/Reanimate/Effect.hs b/src/Reanimate/Effect.hs index d12cb28..75c8bf5 100644 --- a/src/Reanimate/Effect.hs +++ b/src/Reanimate/Effect.hs @@ -62,7 +62,7 @@ overInterval :: Time -- ^ time after start of animation when the effect should s -> Time -- ^ time after start of the animation when the effect should finish -> Effect -- ^ The Effect to modify -> Effect -- ^ Effect which will only affect the specified interval within the animation -overInterval start end effect _d t = +overInterval start end effect _d t = if start <= t && t <= end then effect dur ((t - start) / dur) else id @@ -71,11 +71,11 @@ overInterval start end effect _d t = -- | @reverseE effect@ starts where the @effect@ ends and vice versa. reverseE :: Effect -> Effect -reverseE fn = \d t -> fn d (d-t) +reverseE fn d t = fn d (d-t) -- | Delay the effect so that it only starts after specified duration and then runs till the end of animation. delayE :: Duration -> Effect -> Effect -delayE delayT fn = \d t -> overEnding (d-delayT) fn d t +delayE delayT fn d = overEnding (d-delayT) fn d -- | Modify the animation by applying the effect. If desired, you can apply multiple effects to single animation by calling this function multiple times. applyE :: Effect -> Animation -> Animation @@ -123,7 +123,7 @@ scaleE target d t = scale (1 + (target-1) * t/d) translateE :: Double -> Double -> Effect translateE x y d t = translate (x * t/d) (y * t/d) --- | Transform the effect so that the image passed to the effect's image-modifying +-- | Transform the effect so that the image passed to the effect's image-modifying -- function has coordinates (0, 0) shifted to the center of its bounding box. -- Also see 'aroundCenter'. aroundCenterE :: Effect -> Effect diff --git a/src/Reanimate/Examples.hs b/src/Reanimate/Examples.hs deleted file mode 100644 index 01dc77d..0000000 --- a/src/Reanimate/Examples.hs +++ /dev/null @@ -1,563 +0,0 @@ -{-# LANGUAGE Arrows #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeFamilies #-} -module Reanimate.Examples where - -{- -import Control.Lens () -import qualified Data.Map as M -import Graphics.SvgTree as S hiding (circle, width) -import Linear.V2 - -import Reanimate.Combinators -import Reanimate.Diagrams -import Reanimate.LaTeX -import Reanimate.Monad -import Reanimate.Signal -import Reanimate.Svg - -import Diagrams.Prelude (deg, turn, withEnvelope, (@@)) -import qualified Diagrams.Prelude as D -import qualified Diagrams.TwoD.Path.LSystem as D --} - -{- -sinewave :: Ani () -sinewave = proc () -> do - duration 10 -< () - emit -< toHtml $ mkBackground "black" - idx <- signalOscillate 0 1 -< () - emit -< do - defs_ $ clipPath_ [id_ "clip"] $ toHtml $ - mkRect (Num 0, Num (-height)) (Num $ idx*width) (Num 320) - toHtml $ translate margin height $ withStrokeColor "white" $ - withClipPathRef (Ref "clip") $ mkPathText $ renderPathText $ approxFnData 1000 wave - toHtml $ withStrokeColor "white" $ - mkLine (Num margin, Num 10) (Num margin, Num 170) - toHtml $ withStrokeColor "white" $ - mkLine (Num margin, Num height) (Num (margin+width), Num height) - let (circX, circY) = wave idx - emit -< g_ [transform_ $ Lucid.translate margin height] $ - circle_ [num_ cx_ circX, num_ cy_ circY, r_ "3", fill_ "red"] - where - freq = 3; margin = 30; width = 260; height = 90 - wave idx = (idx*width, sin (idx*pi*2*freq) * 50) - -morph_wave :: Ani () -morph_wave = proc () -> do - duration 5 -< () - morph <- signalOscillate 0 1 -< () - emit -< toHtml $ mkBackground "black" - emit -< toHtml $ withStrokeColor "white" $ mkGroup - [ translate 30 50 $ mkPathText $ renderPathText wave1 - , translate 30 130 $ mkPathText $ renderPathText wave2 - , translate 30 90 $ mkPathText $ renderPathText $ morphPath wave1 wave2 morph - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 3; width = 260 - wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - wave2 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20) - -morph_wave_circle :: Ani () -morph_wave_circle = proc t -> do - duration 5 -< () - idx <- signalOscillate 0 1 -< () - emit -< toHtml $ withStrokeColor "white" $ mkGroup - [ mkBackground "black" - , translate 30 90 $ mkPathText $ renderPathText $ morphPath circle wave1 idx - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 5; width = 260; radius = 50 - wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - circle = approxFnData 1000 $ \idx -> - (cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius) - -progressMeters :: Ani () -progressMeters = proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - annotate' (adjustSpeed 1.0 progressMeter) -< g_ [transform_ $ Lucid.translate 40 20] - annotate' (adjustSpeed 2.0 progressMeter) -< g_ [transform_ $ Lucid.translate 140 20] - annotate' (adjustSpeed 0.5 progressMeter) -< g_ [transform_ $ Lucid.translate 240 20] - - emit -< do - text_ [x_ "55", y_ "150", font_size_ "20" - , text_anchor_ "middle" - , fill_ "white"] "1x" - text_ [x_ "155", y_ "150", font_size_ "20" - , text_anchor_ "middle" - , fill_ "white"] "2x" - text_ [x_ "255", y_ "150", font_size_ "20" - , text_anchor_ "middle" - , fill_ "white"] "0.5x" - -progressMeter :: Ani () -progressMeter = loop $ proc () -> do - duration 5 -< () - h <- signal 0 100 -< () - emit -< rect_ [ width_ "30", height_ "100", stroke_ "white", stroke_width_ "2", fill_opacity_ "0" ] - emit -< rect_ [ width_ "30", num_ height_ h, stroke_ "white", fill_ "white" ] - returnA -< () - -highlight :: Ani () -highlight = proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - emit -< do - path_ (commonAttrs "white" ++ [d_ $ renderPathText rect1]) - path_ (commonAttrs "white" ++ [d_ $ renderPathText rect2]) - - path_ (commonAttrs "white" ++ [d_ $ renderPathText rect3]) - path_ (commonAttrs "lightblue" ++ [d_ $ renderPathText rect4]) - path_ (commonAttrs "yellow" ++ [d_ $ renderPathText rect5]) - path_ (commonAttrs "red" ++ [d_ $ renderPathText rect6]) - - follow - [ mkTransition highlight1 highlight2 - , mkTransition highlight2 highlight3 - , mkTransition highlight3 highlight4 - , mkTransition highlight4 highlight5 - , mkTransition highlight5 highlight6 - , mkTransition highlight6 highlight1 - ] -< () - - where - mkTransition from to = pauseAtEnd 1 $ proc () -> do - duration 1 -< () - s <- signalSCurve 2 0 1 -< () - let trans = morphPath from to s - emit -< - path_ (highlightAttrs "green" ++ [d_ $ renderPathText trans <> "Z"]) - mkRect x y width height = - [ (x,y), (x+width, y), (x+width, y+height), (x,y+height) ] - rect1 = mkRect margin margin w h - rect2 = mkRect (320-margin-w*2) margin (w*2) h - rect3 = mkRect margin (180-margin-h) w h - rect4 = mkRect (320/3) (180-margin-h) w h - rect5 = mkRect (320/3*2-w) (180-margin-h) w h - rect6 = mkRect (320-margin-w) (180-margin-h) w h - highlight1 = mkRect (margin-b) (margin-b) (w+2*b) (h+2*b) - highlight2 = mkRect (320-margin-w*2-b) (margin-b) (w*2+2*b) (h+2*b) - highlight3 = mkRect (320-margin-w-b) (180-margin-h-b) (w+2*b) (h+2*b) - highlight4 = mkRect (320/3*2-w-b) (180-margin-h-b) (320/3+2*b) (h+2*b) - highlight5 = mkRect (320/3-b) (180-margin-h-b) (320/3+2*b) (h+2*b) - highlight6 = mkRect (margin-b) (180-margin-h-b) (320/3+2*b) (h+2*b) - b = 7 - margin = 30 - w = 30 - h = 30 - commonAttrs c = [stroke_width_ "2", stroke_ c, fill_ c] - highlightAttrs c = [stroke_width_ "2", stroke_ c, fill_opacity_ "0"] - -clip_rect :: Ani () -clip_rect = proc () -> do - emit -< toHtml $ mkBackground "black" - annotate' $ follow - [ sim - [ sim [ paintStatic prev | prev <- [max 0 (n-4) .. n-1] ] - , sim [ runAni "black" i | i <- [n-4], i>=0 ] - , runAni "white" n ] - | n <- [0..15] - ] -< g_ [transform_ $ Lucid.translate (320/2) (180/2)] - where - paintStatic nth = proc () -> - emit -< toHtml $ withStrokeColor "white" $ - square (20+nth*10) - runAni color nth = circle_clip $ proc () -> do - duration 1 -< () - emit -< toHtml $ withStrokeColor color $ - square (20+nth*10) - square side = center $ withFillOpacity 0 $ withStrokeWidth (Num 2) $ - mkRect (Num 0, Num 0) (Num side) (Num side) - -circle_clip :: Ani () -> Ani () -circle_clip sub = proc () -> do - arc <- signal (pi*2) 0 -< () - let startX = pack$show$sin 0 * 1000 - startY = pack$show$cos 0 * 1000 - xPos = pack$show$sin arc * 1000 - yPos = pack$show$cos arc * 1000 - long = if arc < pi then "1" else "0" - emit -< clipPath_ [id_ $ uniqName] $ - path_ [ d_ $ "M "<>startX<>" "<>startY<>" A 1000 1000 0 "<>long<>" 1 " - <>xPos<> " "<>yPos<>" L 0 0 Z"] - annotate' sub -< - g_ [clip_path_ $ "url(#"<>uniqName<>")"] - where - uniqName = "clip" -- XXX: Not very unique? - - -scaling :: Ani () -scaling = adjustSpeed 2 $ syncAll - [ proc () -> - annotate' animation -< g_ [transform_ $ Lucid.translate x y <> " " <> Lucid.scale 0.5 0.5] - | x <- [0,160] - , y <- [0,90] - | animation <- [sinewave, morph_wave, highlight, progressMeters]] - - -label :: String -> Ani () -label str = proc () -> do - emit -< text_ [x_ "0", y_ "16", font_size_ "16" - , fill_ "white"] (toHtml str) - -valentine :: Ani () -valentine = proc () -> do - follow - [ all_red - , sim [ background - , follow [backgroundDelay, sim [delay 6.4 (fallingLove 0.09) - ,delay 4.9 (fallingLove 0.12) - ,delay 4.5 (fallingLove 0.88) - ,delay 0.3 (fallingLove 0.43) - ,delay 5.3 (fallingLove 0.93) - ,delay 0.1 (fallingLove 0.80) - ,delay 1.1 (fallingLove 0.39) - ,delay 2.3 (fallingLove 0.21) - ,delay 2.9 (fallingLove 0.77) - ,delay 3.4 (fallingLove 0.46) - ,delay 6.2 (fallingLove 0.19) - ,delay 5.9 (fallingLove 0.53) - ,delay 3.2 (fallingLove 0.14) - ,delay 7.7 (fallingLove 0.99) ]] - , follow [heart_ani, heart_disappear] - , follow [backgroundDelay, message "", message "" - , message "", message "爱", message "" - , message "", message ""]] - ] -<() - where - all_red = proc () -> do - duration 1 -< () - emit -< rect_ [width_ "100%", height_ "100%", fill_ "red"] - background = freezeAtEnd $ proc () -> do - duration 2 -< () - n <- signal 0 0xFF -< () - let color = "#FF" ++ hex n ++ hex n - emit -< rect_ [width_ "100%", height_ "100%", fill_ $ pack color] - backgroundDelay = freezeAtEnd $ proc () -> do - duration (animationDuration background-1) -< () - returnA -< () - heart_ani = repeatAni 10 $ proc () -> do - duration 1 -< () - n <- signalOscillateSCurve 2 0.9 1.1 -< () - annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "] - heart_disappear = proc () -> do - duration 3 -< () - n <- signal 0.9 10 -< () - annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "] - white = loop $ proc () -> do - duration 1 -< () - emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"] - fallingLove xPos = proc () -> do - duration 2 -< () - n <- signal 0 1 -< () - o <- signalOscillate (-1) 1 -< () - emit -< - g_ [transform_ $ Lucid.translate (xPos*360) (210*n)] $ - g_ [transform_ $ Lucid.rotate (45*o)] $ - text_ [font_size_ "18" - ,text_anchor_ "middle" - ,fill_ "red"] "爱" - message txt = proc () -> do - duration 1 -< () - o <- signalOscillate 0 1 -< () - n <- signalOscillateSCurve 2 0.9 1.1 -< () - emit -< - g_ [transform_ $ Lucid.translate 160 110, num_ opacity_ o] $ - g_ [transform_ $ Lucid.scale n n ] $ - text_ [x_ "0", y_ "-12", font_size_ "24" - , text_anchor_ "middle" - , fill_ "white"] txt - - drawHeart = proc () -> do - emit -< - g_ [transform_ $ Lucid.translate (-170) (-260)] $ - g_ [transform_ $ Lucid.rotateAround 225 150 121 <> " " <> Lucid.scale 0.4 0.4] $ - path_ ([stroke_ "red", fill_"red", d_ dat]) - dat = "M0 200 v-200 h200 a100,100 90 0,1 0,200 a100,100 90 0,1 -200,0 z" - hex n = if n < 0x10 then "0" ++ showHex (round n) "" - else showHex (round n) "" - -frequencies :: Ani () -frequencies = proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - n <- signal 0 2 -< () - follow -- [drawUpWave - [ drawLine - , drawFirstWave - , drawSecondWave - , drawUpWave - ] -< n - where - freqs = [11, 5, 17]; margin = 30; width = 260; height = 90 - drawLine = freezeAtEnd $ proc _ -> do - label "drawLine" -< () - duration 1 -< () - n <- signal margin (width+margin) -< () - emit -< do - line_ [ num_ x1_ margin, num_ y1_ height - , num_ x2_ n, num_ y2_ height - , stroke_ "white"] - circle_ [num_ cx_ n, num_ cy_ height, r_ "3", fill_ "red"] - drawFirstWave = freezeAtEnd $ proc move -> do - label "drawFirstWave" -< () - duration 3 -< () - n <- signal 0 1 -< () - emit -< do - g_ [transform_ $ Lucid.translate margin height] $ renderPath $ morphPath line1 (wave1 move) n - let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] - circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY*n), num_ r_ 3, fill_ "red"] - drawSecondWave = freezeAtEnd $ proc move -> do - label "drawSecondWave" -< () - duration 3 -< () - emit -< do - g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move - let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] - circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"] - drawUpWave = freezeAtEnd $ proc move -> do - label "drawUpWave" -< () - duration 2 -< () - n <- signal 0 1 -< () - emit -< do - g_ [transform_ $ Lucid.scale 1 (1-0.5*n)] $ do - g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move - let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ] - circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"] - line1 = approxFnData 1000 $ \idx -> - (idx*width, 0) - wave1 n = approxFnData 1000 $ \idx -> - (idx*width, sum [ sin ((idx+n)*pi*2*freq) * 20 | freq <- freqs ]) - - -latex_basic :: Ani () -latex_basic = proc () -> do - duration 2 -< () - s <- signalOscillate 0 1 -< () - emit -< toHtml $ mkGroup - [ mkBackground "black" - , translate (320/2) (180/2) $ mkGroup - [ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) text - , withFillColor "white" $ withFillOpacity s text] ] - where - text = scale 4 $ center $ latexAlign - "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" - -bezier :: Ani () -bezier = adjustSpeed 0.4 $ proc () -> do - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - follow - [ orderN [pointA, pointB] - , morph [pointA, pointA, pointB] [pointA, pointC, pointB] - , orderN [pointA, pointC, pointB] - , morph [pointA, pointC, pointB, pointB] [pointA, pointC, pointD, pointB] - , orderN [pointA, pointC, pointD, pointB] - , morph [pointA, pointC, pointD, pointB] [pointA, pointA, pointB, pointB]] -< () - where - pointA = (70,130); pointB = (270,120); pointC = (30,30); pointD = (250,50) - - morph old new = proc () -> do - duration 0.5 -< () - s <- signal 0 1 -< () - let new' = map (\(a,b) -> between a b s) (zip old new) - emit -< forM_ (zip new' (tail new')) $ \(a,b) -> do - renderPath $ - approxFnData 100 $ \idx -> - between a b idx - emit -< mapM_ secondaryCircleAt new' - emit -< primaryCircleAt (head new') - orderN lst = proc () -> do - duration 2 -< () - s <- signalOscillate 0 1 -< () - emit -< primaryCircleAt =<< orderN' (map const lst) s <* mapM_ secondaryCircleAt lst - orderN' [a] s = do - renderPath $ take (round $ 100*s) $ approxFnData 100 $ \idx -> a idx - return (a s) - orderN' lst s = do - forM_ (zip lst (tail lst)) $ \(a,b) -> renderPath $ - approxFnData 100 $ \idx -> - between (a s) (b s) idx - let middlePoints = map (\(a,b) -> \idx -> between (a idx) (b idx) idx) (zip lst (tail lst)) - orderN' middlePoints s <* mapM_ secondaryCircleAt (map ($s) middlePoints) - - secondaryCircleAt (x,y) = circle_ [num_ cx_ x, num_ cy_ y, num_ r_ 3, fill_ "green"] - primaryCircleAt (x,y) = circle_ [num_ cx_ x, num_ cy_ y, num_ r_ 3, fill_ "red"] - between a b _ | a==b = a - between (x1, y1) (x2, y2) idx = - ( x1 + idx * (x2 - x1) - , y1 + idx * (x2-x1) * (y2 - y1) / (x2 - x1)) - -pathSquare :: Ani () -pathSquare = proc () -> do - duration 2 -< () - s <- signalOscillate 0 1 -< () - emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"] - emit -< g_ [stroke_ "white"] $ toHtml (square s) - where - square s = S.PathTree (myPath s) - myPath s = S.defaultSvg - & S.pathDefinition .~ interpolatePathCommands s myPathCmds - myPathCmds = - [ S.MoveTo S.OriginAbsolute [V2 100 100] - , S.LineTo S.OriginAbsolute [V2 200 150] - , S.LineTo S.OriginRelative [V2 (-10) (-100)] - , S.EndPath - ] - -latex_draw :: Ani () -latex_draw = pauseAtEnd 1 $ proc () -> do - emit -< toHtml $ mkBackground "black" - drawText `andThen` fillText -< () - where - msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}" - glyphs = center $ latexAlign msg - placement = translate (320/2) (180/2) . scale 5 - fillText = proc () -> do - duration 1 -< () - s <- signal 0 1 -< () - emit -< toHtml $ placement $ - withFillColor "white" $ withFillOpacity s $ - glyphs - drawText = proc () -> do - duration 2 -< () - s <- signal 0 1 -< () - emit -< toHtml $ placement $ - withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) $ - partialSvg s glyphs - - -bbox :: Ani () -bbox = proc () -> do - emit -< toHtml $ mkBackground "black" - duration 5 -< () - annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)] - annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)] - -bbox1 :: Ani () -bbox1 = proc () -> do - s <- signal 0 1 -< () - emit -< do - toHtml $ mkBoundingBox $ rotate (360*s) svg - toHtml $ withFillColor "white" $ rotate (360*s) svg - where - svg = scale 3 $ center $ latexAlign "\\sum_{k=1}^\\infty" - -bbox2 :: Ani () -bbox2 = proc () -> do - s <- signalOscillate 0 1 -< () - emit -< do - toHtml $ mkBoundingBox $ partialSvg s heartShape - toHtml $ withStrokeColor "white" $ withFillOpacity 0 $ partialSvg s heartShape - -mkBoundingBox :: Tree -> Tree -mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $ - mkRect (S.Num x, S.Num y) (S.Num w) (S.Num h) - where - (x, y, w, h) = boundingBox svg - -heartShape = - center $ rotateAroundCenter 225 $ mkPathString - "M0.0,40.0 v-40.0 h40.0\ - \a20.0 20.0 90.0 0 1 0.0,40.0\ - \a20.0 20.0 90.0 0 1 -40.0,0.0 Z" - -latex_color :: Ani () -latex_color = proc () -> do - duration 0.1 -< () - emit -< toHtml $ mkBackground "black" - emit -< toHtml $ translate (320/2) (180/2) $ withStrokeWidth (Num 0.2) $ - withStrokeColor "white" $ - withSubglyphs [0] (withFillColor "blue") $ - withSubglyphs [1] (withFillColor "yellow") $ - withSubglyphs [2] (withFillColor "green") $ - withSubglyphs [3] (withFillColor "red") $ - withSubglyphs [4] (withFillColor "darkslategrey") $ - svg - where - svg = scale 10 $ center $ latex "\\LaTeX" --} - -{- -morph_wave :: Animation -morph_wave = autoReverse $ mkAnimation 2.5 $ do - morph <- getSignal signalLinear - emit $ mkBackground "black" - emit $ withStrokeColor "white" $ translate (-320/2) (-180/2) $ mkGroup - [ translate 30 50 $ mkLinePath wave1 - , translate 30 130 $ mkLinePath wave2 - , translate 30 90 $ mkLinePath $ morphPath wave1 wave2 morph - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 3; width = 260 - wave1 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - wave2 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20) - -morph_wave_circle :: Animation -morph_wave_circle = autoReverse $ mkAnimation 2.5 $ do - idx <- getSignal signalLinear - emit $ mkBackground "black" - emit $ withStrokeColor "white" $ translate (-320/2) (-180/2) $ mkGroup - [ translate 30 90 $ mkLinePath $ morphPath circle wave1 idx - , mkLine (Num 30, Num 10) (Num 30, Num 170) - , mkLine (Num 30, Num 90) (Num 290, Num 90) ] - where - freq = 5; width = 260; radius = 50 - wave1 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20) - circle = approxFnData 100 $ \idx -> - (cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius) - -progressMeters :: Animation -progressMeters = - bg `sim` labels `sim` - mapA (translate (-100) 0) (adjustSpeed 1.0 progressMeter) `simLoop` - mapA (translate 0 0) (adjustSpeed 2.0 progressMeter) `simLoop` - mapA (translate 100 0) (adjustSpeed 0.5 progressMeter) - where - bg = mkAnimation 0 $ emit $ mkBackground "black" - labels = mkAnimation 0 $ emit $ translate 0 70 $ withFillColor "white" $ mkGroup - [ translate (-100) 0 $ scale 2 $ center $ latex "1x" - , translate 0 0 $ scale 2 $ center $ latex "2x" - , translate 100 0 $ scale 2 $ center $ latex "0.5x" - ] - -progressMeter :: Animation -progressMeter = mkAnimation 3 $ do - h <- getSignal $ signalFromTo 0 100 signalLinear - emit $ center $ mkGroup - [ withStrokeColor "white" $ withStrokeWidth (Num 2) $ withFillOpacity 0 $ - mkRect (Num 30) (Num 100) - , withFillColor "white" $ - mkRect (Num 30) (Num h) ] - - -diaSize :: Animation -diaSize = mkAnimation 0.1 $ do - emit $ mkBackground "white" - emit $ translate (-320/2) (-180/2) dSvg - where - dSvg = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ - D.scale 3 $ - D.translate (V2 0 (-30)) $ - D.rotate (90 @@ deg) $ - D.lwO 0.1 $ D.strokePath (D.getTurtlePath (D.tree3 4)) - -wavyTree :: Animation -wavyTree = mkAnimation 1 $ do - s <- oscillate $ getSignal $ signalFromTo 1 2 signalLinear - emit $ mkBackground "white" - emit $ translate (-320/2) (-180/2) (dSvg s) - where - dSvg s = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $ - D.scale 3 $ - D.translate (V2 0 (-30)) $ - D.rotate (90 @@ deg) $ - D.lwO 0.1 $ D.strokePath (D.getTurtlePath (tree s)) - gens = 4 - tree s = - D.lSystem gens (s/16 @@ turn) (D.symbols "F") rules - rules = M.fromList [D.rule 'F' "FF-[->F+F+>F]+[+>F->F->F]"] --} diff --git a/src/Reanimate/GeoProjection.hs b/src/Reanimate/GeoProjection.hs index dec2d25..592f838 100644 --- a/src/Reanimate/GeoProjection.hs +++ b/src/Reanimate/GeoProjection.hs @@ -43,9 +43,10 @@ import Debug.Trace import Reanimate -- Constants -halfPi, sqrtPi, epsilon, tau :: Double +halfPi, sqrtPi, sqrt2, epsilon, tau :: Double halfPi = pi/2 sqrtPi = sqrt pi +sqrt2 = sqrt2 epsilon = 1.0e-12 tau = pi*2 @@ -60,6 +61,7 @@ srcPixel src (LonLat lam phi) = xPx = round $ ((lam+pi)/tau) * fromIntegral (imageWidth src-1) yPx = round $ (1-((phi+halfPi)/pi)) * fromIntegral (imageHeight src-1) +{- HLINT ignore -} findValidCoord :: Image PixelRGB8 -> Projection -> XYCoord -> XYCoord findValidCoord src p (XYCoord x y) = fromMaybe (XYCoord x y) $ listToMaybe [ XYCoord x' y' @@ -67,7 +69,7 @@ findValidCoord src p (XYCoord x y) = fromMaybe (XYCoord x y) $ listToMaybe yi = round $ y * hMax , ax <- [xi, xi-1, xi+1] , ay <- [yi, yi-1, yi+1] - , (ax >= 0 && ax < w && ay >= 0 && ay < h) + , ax >= 0 && ax < w && ay >= 0 && ay < h , let x' = fromIntegral ax / wMax y' = fromIntegral ay / hMax , validLonLat $ projectionInverse p (XYCoord x' y') @@ -147,8 +149,8 @@ interpP src p1 p2 t = runST $ do 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 (validLonLat lonlat && validXYCoord (XYCoord x2 y2)) $ do - when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ do + when (validLonLat lonlat && validXYCoord (XYCoord x2 y2)) $ + when (x3 >= 0 && x3 < w && y3 >= 0 && y3 < h) $ writePixel img x3 y3 (promotePixel $ srcPixel src lonlat) forM_ [0..(w*factor)-1] $ \x -> forM_ [0..(h*factor)-1] $ \y -> do @@ -166,8 +168,8 @@ interpP src p1 p2 t = runST $ do writePixel img x3 y3 (promotePixel $ srcPixel src lonlat) forM_ [1..w-1] $ \x -> forM_ [0..h-1] $ \y -> do - let x1 = fromIntegral x / (wMax) - y1 = 1 - fromIntegral y / (hMax) + 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)) $ @@ -234,9 +236,8 @@ isValidP (Projection p pInv) = and y = (fromIntegral yPx / fromIntegral (h-1)) lonlat = pInv (XYCoord x y) lonlat2 = pInv $ p lonlat - in if not (validLonLat lonlat) || eqLonLat lonlat lonlat2 - then True - else trace (show (lonlat, lonlat2)) $ False + in not (validLonLat lonlat) || eqLonLat lonlat lonlat2 + || trace (show (lonlat, lonlat2)) False moveBottomP :: Double -> Projection -> Projection moveBottomP offset (Projection p pInv) = Projection p' pInv' @@ -301,7 +302,7 @@ mercatorP = Projection forward inverse where forward (LonLat lam phi) = XYCoord ((lam+pi)/tau) - (((log(tan(pi/4+phi/2))) + pi)/tau) + ((log(tan(pi/4+phi/2)) + pi)/tau) inverse (XYCoord x y) = LonLat xPi (atan (sinh yPi)) where xPi = fromToS (-pi) pi x @@ -314,7 +315,6 @@ mollweideP = Projection forward inverse forward (LonLat lam phi) = XYCoord ((x+sqrt2*2)/(4*sqrt2)) ((y+sqrt2)/(2*sqrt2)) where - sqrt2 = sqrt 2 x = (2*sqrt2)/pi * lam * cos theta y = sqrt2*sin theta theta = find_theta 100 @@ -326,10 +326,10 @@ mollweideP = Projection forward inverse 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*sqrt(2)) (2*sqrt(2)) x' - y = fromToS (-sqrt 2) (sqrt 2) y' - theta = asin (y/sqrt(2)) - lam = pi*x/(2*sqrt(2)*cos theta) + x = fromToS (-2*sqrt2) (2*sqrt2) x' + y = fromToS (-sqrt2) sqrt2 y' + theta = asin (y/sqrt2) + lam = pi*x/(2*sqrt2*cos theta) phi = asin ((2*theta+sin(2*theta))/pi) -- | <> @@ -339,13 +339,12 @@ hammerP = Projection forward inverse forward (LonLat lam phi) = XYCoord ((x+sqrt2*2)/(4*sqrt2)) ((y+sqrt2)/(2*sqrt2)) where - sqrt2 = sqrt 2 - x = (2*sqrt2*cos phi*sin (lam/2))/(sqrt (1+cos phi*cos (lam/2))) - y = (sqrt2*sin phi)/(sqrt (1+cos phi*cos (lam/2))) + x = (2*sqrt2*cos phi*sin (lam/2))/sqrt (1+cos phi*cos (lam/2)) + y = (sqrt2*sin phi)/ sqrt (1+cos phi*cos (lam/2)) inverse (XYCoord x' y') = LonLat lam phi where - x = fromToS (-2*sqrt(2)) (2*sqrt(2)) x' - y = fromToS (-sqrt 2) (sqrt 2) y' + x = fromToS (-2*sqrt2) (2*sqrt2) x' + y = fromToS (-sqrt2) sqrt2 y' z = sqrt (1 - (x/4)**2 - (y/2)**2) lam = 2 * atan2 (z*x) (2*(2*z**2-1)) phi = asin (z*y) @@ -358,7 +357,7 @@ lambertP = Projection forward inverse XYCoord ((lam+pi)/tau) ((sin phi+1)/2) inverse (XYCoord x' y') = LonLat x (asin y) where - x = fromToS (-pi) (pi) x' + x = fromToS (-pi) pi x' y = fromToS (-1) 1 y' -- | <> @@ -374,7 +373,7 @@ bottomleyP phi_1 = Projection forward inverse e = lam * sin phi_1 * sin rho / rho inverse (XYCoord x' y') = LonLat lam phi where - x = fromToS (-pi) (pi) x' + x = fromToS (-pi) pi x' y = fromToS (-pi/2) (pi/2) y' x1 = x * sin phi_1 y1 = pi/2 - y @@ -394,7 +393,7 @@ sinusoidalP = Projection forward inverse y = phi inverse (XYCoord x' y') = LonLat (x/cos y) y where - x = fromToS (-pi) (pi) x' + x = fromToS (-pi) pi x' y = fromToS (-pi/2) (pi/2) y' -- | <> @@ -410,7 +409,7 @@ wernerP = moveTopP 0.23 $ Projection forward inverse y = pi/2 - rho * cos e inverse (XYCoord x' y') = LonLat lam phi where - x = fromToS (-pi) (pi) x' + x = fromToS (-pi) pi x' y = fromToS (-pi/2) (pi/2) y' rho = sqrt (x**2 + (pi/2 - y)**2) e = atan2 x (pi/2 -y) @@ -433,7 +432,7 @@ bonneP phi_0 = moveTopP (-0.17*factor) $ scaleP 1 (fromToS 1 0.65 factor) $ Proj y = cotPhi0 - rho * cos e inverse (XYCoord x' y') = LonLat lam phi where - x = fromToS (-pi) (pi) x' + x = fromToS (-pi) pi x' y = fromToS (-pi/2) (pi/2) y' cotPhi0 = cot phi_0 rho = sqrt (x*x + (cot phi_0 - y)**2) @@ -457,8 +456,8 @@ orthoP lam_0 phi_0 = Projection forward inverse inverse (XYCoord x' y') = LonLat lam phi where x = fromToS (-16/9) (16/9) x' - y = fromToS (-1) (1) y' - lam = wrap (-pi) (pi) $ + y = fromToS (-1) 1 y' + lam = wrap (-pi) pi $ lam_0 + atan2 (x * sin c) (rho * cos c * cos phi_0 - y * sin c * sin phi_0) phi = wrap (-pi/2) (pi/2) $ asin ((cos c * sin phi_0 + y * sin c * cos phi_0)/rho) @@ -477,7 +476,7 @@ cassiniP = Projection forward inverse inverse (XYCoord x' y') = LonLat lam phi where x = fromToS (-halfPi) halfPi x' - y = fromToS (-pi) (pi) y' + y = fromToS (-pi) pi y' lam = atan2 (tan x) (cos y) phi = asin (sin y * cos x) @@ -497,8 +496,8 @@ augustP = scaleP 0.70 0.70 $ Projection forward inverse y = tanPhi / c x2 = x*x y2 = y*y - xPos = (4 / 3 * x * (3+x2 - 3*y2)) - yPos = (4 / 3 * y * (3 + 3*x2 - y2)) + xPos = 4 / 3 * x * (3+x2 - 3*y2) + yPos = 4 / 3 * y * (3 + 3*x2 - y2) inverse (XYCoord x' y') = LonLat lam phi where x = fromToS xLo xHi x' * 3 / 8 @@ -507,7 +506,7 @@ augustP = scaleP 0.70 0.70 $ Projection forward inverse y2 = y*y s = 1 + x2 + y2 sin3Eta = sqrt ((s - sqrt (s*s - 4 * y * y)) / 2) - eta = asin (sin3Eta) / 3 + eta = asin sin3Eta / 3 xi = if sin3Eta /= 0 then acosh (abs (y / sin3Eta)) / 3 else asinh (abs x) / 3 cosEta = cos eta coshXi = cosh xi @@ -520,9 +519,9 @@ collignonP :: Projection collignonP = Projection forward inverse where yHi = sqrtPi - yLo = sqrtPi * (1 - sqrt 2) - xLo = -pi*(2/sqrtPi)*(sqrt 2) - xHi = pi*(2/sqrtPi)*(sqrt 2) + yLo = sqrtPi * (1 - sqrt2) + xLo = -pi*(2/sqrtPi)*sqrt2 + xHi = pi*(2/sqrtPi)*sqrt2 forward (LonLat lam phi) = XYCoord ((x-xLo)/(xHi-xLo)) ((y-yLo)/(yHi-yLo)) where alpha = sqrt (1 - sin phi) @@ -658,7 +657,7 @@ lagrangeP = Projection forward inverse 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 (abs y'-1) < epsilon = LonLat 0 (signum y * halfPi) | otherwise = LonLat lam phi where x = fromToS xLo xHi x' / 2 diff --git a/src/Reanimate/Morph.hs b/src/Reanimate/Morph.hs index 7065d3a..9fabcf6 100644 --- a/src/Reanimate/Morph.hs +++ b/src/Reanimate/Morph.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ParallelListComp #-} module Reanimate.Morph where import Control.Lens @@ -65,13 +64,13 @@ splitLineLength alpha from cmd = LineEnd -> (LineEnd, LineEnd) -} interpolateLineCommands :: Double -> [LineCommand] -> [LineCommand] -> [LineCommand] -interpolateLineCommands alpha x y = map worker (zip x y) +interpolateLineCommands alpha = zipWith worker where - worker (LineMove p1, LineMove p2) = LineMove (lerp alpha p1 p2) - worker (LineBezier ps1, LineBezier ps2) = + worker (LineMove p1) (LineMove p2) = LineMove (lerp alpha p1 p2) + worker (LineBezier ps1) (LineBezier ps2) = LineBezier [lerp alpha x y | (x,y) <- merge ps1 ps2] - worker (LineEnd, LineEnd) = LineEnd - worker (x,y) = error (show (x,y)) + worker LineEnd LineEnd = LineEnd + worker x y = error (show (x,y)) merge [] [] = [] merge [x] [y] = [(x,y)] merge (x:xs) [y] = (x,y) : merge xs [y] @@ -264,7 +263,7 @@ loopIntersections (Loop start cs) point = worker start cs V2 pointX pointY = point mkPoint (V2 a1 a2) = Bezier.Point a1 a2 fromPoint (Bezier.Point x y) = V2 x y - farPoint = (Bezier.Point 1000 pointY) -- FIXME + farPoint = Bezier.Point 1000 pointY -- FIXME -- line = Bezier.Line (mkPoint point) farPoint lineBezier = Bezier.CubicBezier (mkPoint point) farPoint farPoint farPoint worker from [] = [] diff --git a/src/Reanimate/PolyShape.hs b/src/Reanimate/PolyShape.hs index 6937409..a718636 100644 --- a/src/Reanimate/PolyShape.hs +++ b/src/Reanimate/PolyShape.hs @@ -31,7 +31,7 @@ module Reanimate.PolyShape import Chiphunk.Low import Control.Lens ((&), (.~)) -import Data.List (nub, partition, sortBy, minimumBy) +import Data.List (minimumBy, nub, partition, sortOn) import Data.Ord import Debug.Trace import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint, @@ -39,9 +39,9 @@ import Geom2D.CubicBezier (ClosedPath (..), CubicBezier (..), DPoint, arcLength, arcLengthParam, bezierIntersection, bezierSubsegment, closedPathCurves, closest, colinear, - curvesToClosed, curvesToClosed, - evalBezier, interpolateVector, reorient, - splitBezier, union, vectorDistance) + curvesToClosed, evalBezier, + interpolateVector, reorient, splitBezier, + union, vectorDistance) import Graphics.SvgTree (PathCommand (..), RPoint, Tree (..), defaultSvg, pathDefinition) import Linear.V2 @@ -144,7 +144,7 @@ plGroupTouching pls = worker [polyShapeOrigin (head pls)] pls let (touching, notTouching) = partition (isTouching seen) shapes in if null touching then plGroupTouching notTouching - else map ((,)seen) (map (changeOrigin seen) touching) : + else map ((,) seen . changeOrigin seen) touching : worker (seen ++ concatMap plPoints touching) notTouching isTouching pts = any (`elem` pts) . plPoints changeOrigin seen (PolyShape (ClosedPath segments)) = PolyShape $ ClosedPath $ helper [] segments @@ -164,9 +164,7 @@ plDecompose = plDecompose' 0.001 -- | Deconstruct a polyshape into non-intersecting, convex polygons. plDecompose' :: Double -> [PolyShape] -> [[RPoint]] plDecompose' tol = - concatMap decomposePolygon . - map (plPolygonify tol) . - map mergePolyShapeHoles . + concatMap (decomposePolygon . plPolygonify tol . mergePolyShapeHoles) . plGroupShapes . unionPolyShapes @@ -240,12 +238,12 @@ cmdsToPolyShapes cmds = finalize ((toGPoint from, JoinLine):acc) $ worker dst [] xs worker _from acc (LineEnd{}:LineMove dst:xs) = - finalize (acc) $ + finalize acc $ worker dst [] xs worker from acc [LineEnd orig] | from /= orig = finalize ((toGPoint from, JoinLine):acc) [] worker _from acc [LineEnd{}] = - finalize (acc) [] + finalize acc [] worker from acc (LineBezier [x]:xs) = worker x ((toGPoint from, JoinLine) : acc) xs worker from acc (LineBezier [a,b,c]:xs) = @@ -306,7 +304,7 @@ plGroupShapes = worker { polyShapeParent = s , polyShapeHoles = holes } in prime : worker nonHoles - | otherwise = trace ("Found hole, putting back") $ worker (rest ++ [s]) + | otherwise = trace "Found hole, putting back" $ worker (rest ++ [s]) worker [] = [] parents :: PolyShape -> [PolyShape] -> [PolyShape] @@ -325,7 +323,7 @@ mergePolyShapeHoles (PolyShapeWithHoles parent (child:children)) = mergePolyShapeHole :: PolyShape -> PolyShape -> PolyShape mergePolyShapeHole parent child = snd $ head $ - sortBy (comparing fst) + sortOn fst [ cutSingleHole newParent child | newParent <- polyShapePermutations parent ] @@ -379,7 +377,7 @@ cutSingleHole parent child = -- straight line from child origin x2p = lineBetween childOrigin p - lineBetween a b = CubicBezier a a a b + lineBetween a = CubicBezier a a a plCurves :: PolyShape -> [CubicBezier Double] plCurves = closedPathCurves . unPolyShape diff --git a/src/Reanimate/Povray.hs b/src/Reanimate/Povray.hs index d3c1a82..59c9138 100644 --- a/src/Reanimate/Povray.hs +++ b/src/Reanimate/Povray.hs @@ -27,11 +27,11 @@ import Data.Hashable povrayRaw :: [String] -> Text -> Tree povrayRaw args script = - (unsafePerformIO $ mkPovrayImage args script) + unsafePerformIO $ mkPovrayImage args script povrayRaw' :: [String] -> Text -> FilePath povrayRaw' args script = - (unsafePerformIO $ mkPovrayImage' args script) + unsafePerformIO $ mkPovrayImage' args script povray :: [String] -> Text -> Tree povray args = povrayRaw (["+H180","+W320", "+A"] ++ args) @@ -77,4 +77,3 @@ mkPovrayImage' args script = cacheFile template $ \target -> do where template = show (hash key) <.> "png" key = T.concat (script:map T.pack args) - diff --git a/src/Reanimate/Raster.hs b/src/Reanimate/Raster.hs index bb7bc2d..39a4dfd 100644 --- a/src/Reanimate/Raster.hs +++ b/src/Reanimate/Raster.hs @@ -9,7 +9,6 @@ module Reanimate.Raster , svgAsPngFile' ) where -import Codec.Picture.Types import Codec.Picture import Codec.Picture.Types (dynamicMap) import Control.Lens ((&), (.~)) diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs index bc2f74c..4023fa9 100644 --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -10,7 +10,7 @@ module Reanimate.Render import Control.Concurrent import Control.Exception -import Control.Monad (forM_) +import Control.Monad (forM_, void) import qualified Data.Text as T import qualified Data.Text.IO as T import Graphics.SvgTree (Number (..)) @@ -47,7 +47,7 @@ renderSvgs ani = do -- XXX: Merge with 'renderSvgs' renderSnippets :: Animation -> IO () -renderSnippets ani = do +renderSnippets ani = forM_ [0..frameCount-1] $ \nth -> do let now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth frame = frameAt now ani @@ -67,7 +67,7 @@ frameOrder fps nFrames = worker [] fps filterFrameList :: [Int] -> Int -> Int -> [Int] filterFrameList seen nthFrame nFrames = - filter (not.isSeen) $ [0, nthFrame .. nFrames-1] + filter (not.isSeen) [0, nthFrame .. nFrames-1] where isSeen x = any (\y -> x `mod` y == 0) seen @@ -196,5 +196,3 @@ concurrentForM_ lst action = do case mbE of Nothing -> return () Just e -> throwIO (e :: SomeException) - where - void x = x >> return () diff --git a/src/Reanimate/Scene.hs b/src/Reanimate/Scene.hs index 84ae1ae..8ae445c 100644 --- a/src/Reanimate/Scene.hs +++ b/src/Reanimate/Scene.hs @@ -137,7 +137,7 @@ tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s () tweenVar (Var ref) dur fn = do now <- queryNow liftST $ modifySTRef ref $ \prev t -> - fn (prev t) ((max 0 $ min dur $ t-now)/dur) + fn (prev t) (max 0 (min dur $ t-now)/dur) wait dur unVar :: Var s a -> Frame s a @@ -152,7 +152,7 @@ findVar cond (v:vs) = do if cond val then return v else findVar cond vs applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s () -applyVar var sprite fn = do +applyVar var sprite fn = spriteModify sprite $ do varFn <- unVar var return $ \(svg, zindex) -> @@ -193,7 +193,7 @@ newSprite render = do return $ \d absT -> let relD = (if spriteDur < 0 then d else spriteDur)-now relT = absT-now in - if relT < 0 || (if relD+now==d then False else relD <= relT) + if relT < 0 || (relD+now/=d && relD <= relT) then (None, 0) else spriteEffect relD relT (fn absT relD relT) return $ Sprite now ref diff --git a/src/Reanimate/Signal.hs b/src/Reanimate/Signal.hs index e0d0ed5..9afb83a 100644 --- a/src/Reanimate/Signal.hs +++ b/src/Reanimate/Signal.hs @@ -31,7 +31,7 @@ fromListS fns t = worker 0 fns -- -- <> constantS :: Double -> Signal -constantS x = const x +constantS = const -- | Signal with new starting and end values. -- diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs index 0d63b71..873ac09 100644 --- a/src/Reanimate/Svg.hs +++ b/src/Reanimate/Svg.hs @@ -7,7 +7,7 @@ module Reanimate.Svg , module Reanimate.Svg.Unuse ) where -import Control.Lens ((%~), (&), (.~), (^.)) +import Control.Lens ((%~), (&), (.~), (^.), (?~)) import Control.Monad.State import Graphics.SvgTree hiding (height, line, path, use, width) @@ -38,7 +38,7 @@ lowerTransformations = worker Transform.identity GroupTree g -> GroupTree $ g & groupChildren %~ map (worker m') & transform .~ Nothing - _ -> mkGroup [t] & transform .~ Just [ Transform.toTransformation m ] + _ -> mkGroup [t] & transform ?~ [ Transform.toTransformation m ] lowerIds :: Tree -> Tree lowerIds = mapTree worker @@ -56,7 +56,7 @@ simplify root = where worker None = [] worker (DefinitionTree d) = - concatMap dropNulls $ + concatMap dropNulls [DefinitionTree $ d & groupChildren %~ concatMap worker] worker (GroupTree g) | g ^. drawAttributes == defaultSvg = @@ -199,8 +199,8 @@ pathify = mapTree worker & drawAttributes .~ circ ^. drawAttributes & pathDefinition .~ [MoveTo OriginAbsolute [V2 (x-r) y] - ,EllipticalArc OriginRelative [(r, r, 0,True,False,(V2 (r*2) 0)) - ,(r, r, 0,True,False,(V2 (-r*2) 0))]] + ,EllipticalArc OriginRelative [(r, r, 0,True,False,V2 (r*2) 0) + ,(r, r, 0,True,False,V2 (-r*2) 0)]] PolyLineTree pl -> let points = pl ^. polyLinePoints in PathTree $ defaultSvg @@ -217,8 +217,8 @@ pathify = mapTree worker & drawAttributes .~ elip ^. drawAttributes & pathDefinition .~ [ MoveTo OriginAbsolute [V2 (cx-rx) cy] - , EllipticalArc OriginRelative [(rx, ry, 0,True,False,(V2 (rx*2) 0)) - ,(rx, ry, 0,True,False,(V2 (-rx*2) 0))]] + , EllipticalArc OriginRelative [(rx, ry, 0,True,False,V2 (rx*2) 0) + ,(rx, ry, 0,True,False,V2 (-rx*2) 0)]] t -> t unpackCircle circ = do let (x,y) = circ ^. circleCenter @@ -239,7 +239,7 @@ pathify = mapTree worker return (x,y,w,h) pointsToPathCommands points = case points of [] -> [] - (p:ps) -> [ MoveTo OriginAbsolute [p] + (p:ps) -> [ MoveTo OriginAbsolute [p] , LineTo OriginAbsolute ps ] unpackNumber n = case toUserUnit defaultDPI n of diff --git a/src/Reanimate/Svg/BoundingBox.hs b/src/Reanimate/Svg/BoundingBox.hs index 528a0ee..ab8ed76 100644 --- a/src/Reanimate/Svg/BoundingBox.hs +++ b/src/Reanimate/Svg/BoundingBox.hs @@ -46,7 +46,7 @@ linePoints = worker zero -- LineDraw to -> from:to:worker to xs -- FIXME: Use approximation from Geom2D.Bezier LineBezier ctrl -> -- approximation - [ last (partial_bezier_points (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++ + [ last (partialBezierPoints (from:ctrl) 0 (recip chunks*i)) | i <- [0..chunks]] ++ worker (last ctrl) xs LineEnd p -> p : worker p xs chunks = 10 diff --git a/src/Reanimate/Svg/Constructors.hs b/src/Reanimate/Svg/Constructors.hs index 0e23397..56e2305 100644 --- a/src/Reanimate/Svg/Constructors.hs +++ b/src/Reanimate/Svg/Constructors.hs @@ -75,23 +75,27 @@ withTransformations transformations t = translate :: Double -> Double -> Tree -> Tree translate x y = withTransformations [Translate x y] --- | @rotate angle image@ rotates the @image@ around origin @(0,0)@ counterclockwise by @angle@ given in degrees. +-- | @rotate angle image@ rotates the @image@ around origin @(0,0)@ counterclockwise by @angle@ +-- given in degrees. rotate :: Double -> Tree -> Tree rotate a = withTransformations [Rotate a Nothing] --- | @rotate angle point image@ rotates the @image@ around given @point@ counterclockwise by @angle@ given in degrees. +-- | @rotate angle point image@ rotates the @image@ around given @point@ counterclockwise by +-- @angle@ given in degrees. rotateAround :: Double -> RPoint -> Tree -> Tree rotateAround a (V2 x y) = withTransformations [Rotate a (Just (x,y))] --- | @rotate angle image@ rotates the @image@ around the center of its bounding box counterclockwise by @angle@ given in degrees. +-- | @rotate angle image@ rotates the @image@ around the center of its bounding box counterclockwise +-- by @angle@ given in degrees. rotateAroundCenter :: Double -> Tree -> Tree rotateAroundCenter a t = rotateAround a (V2 (x+w/2) (y+h/2)) t where (x,y,w,h) = boundingBox t --- | @arounCenter f image@ first moves the image so the center of its bounding box is at the origin @(0, 0)@, --- applies transformation @f@ to it and then moves the transformed image back to its original position. +-- | @aroundCenter f image@ first moves the image so the center of its bounding box is at the origin +-- @(0, 0)@, applies transformation @f@ to it and then moves the transformed image back to its +-- original position. aroundCenter :: (Tree -> Tree) -> Tree -> Tree aroundCenter fn t = translate (-offsetX) (-offsetY) $ fn $ translate offsetX offsetY t @@ -115,26 +119,30 @@ aroundCenterX fn t = (x,_y,w,_h) = boundingBox t -- | Scale the image uniformly by given factor along both X and Y axes. --- For example @scale 2 image@ makes the image twice as large, while @scale 0.5 image@ makes it half the original size. --- Negative values are also allowed, and lead to flipping the image along both X and Y axes. +-- For example @scale 2 image@ makes the image twice as large, while @scale 0.5 image@ makes it +-- half the original size. Negative values are also allowed, and lead to flipping the image along +-- both X and Y axes. scale :: Double -> Tree -> Tree scale a = withTransformations [Scale a Nothing] --- | @scaleToSize width height@ resizes the image so that its bounding box has corresponding @width@ and @height@. +-- | @scaleToSize width height@ resizes the image so that its bounding box has corresponding @width@ +-- and @height@. scaleToSize :: Double -> Double -> Tree -> Tree scaleToSize w h t = scaleXY (w/w') (h/h') t where (_x, _y, w', h') = boundingBox t --- | @scaleToWidth width@ scales the image so that the width of its bounding box ends up having given @width@. +-- | @scaleToWidth width@ scales the image so that the width of its bounding box ends up having +-- given @width@. scaleToWidth :: Double -> Tree -> Tree scaleToWidth w t = scale (w/w') t where (_x, _y, w', _h') = boundingBox t --- | @scaleToHeight height@ scales the image so that the height of its bounding box ends up having given @height@. +-- | @scaleToHeight height@ scales the image so that the height of its bounding box ends up having +-- given @height@. scaleToHeight :: Double -> Tree -> Tree scaleToHeight h t = scale (h/h') t @@ -146,15 +154,18 @@ scaleXY :: Double -> Double -> Tree -> Tree scaleXY x y = withTransformations [Scale x (Just y)] --- | Flip the image along vertical axis so that what was on the right will end up on left and vice versa. +-- | Flip the image along vertical axis so that what was on the right will end up on left and vice +-- versa. flipXAxis :: Tree -> Tree flipXAxis = scaleXY (-1) 1 --- | Flip the image along horizontal so that what was on the top will end up in the bottom and vice versa. +-- | Flip the image along horizontal so that what was on the top will end up in the bottom and vice +-- versa. flipYAxis :: Tree -> Tree flipYAxis = scaleXY 1 (-1) --- | Translate given image so that the center of its bouding box coincides with coordinates @(0, 0)@. +-- | Translate given image so that the center of its bouding box coincides with coordinates +-- @(0, 0)@. center :: Tree -> Tree center t = translate (-x-w/2) (-y-h/2) t where @@ -263,14 +274,16 @@ mkDefinitions forest = DefinitionTree $ defaultSvg & groupChildren .~ forest -- | Create an element by referring to existing element defined previously. --- For example you can create a graphical element, assign ID to it using 'withId', wrap it in 'mkDefinitions' and then use it via @use "myId"@. +-- For example you can create a graphical element, assign ID to it using 'withId', wrap it in +-- 'mkDefinitions' and then use it via @use "myId"@. -- See mkUse :: String -> Tree mkUse name = UseTree (defaultSvg & useName .~ name) Nothing -- | A clip path restricts the region to which paint can be applied. -- See -mkClipPath :: String -- ^ ID of the clip path, which can then be referred to by other elements using 'withClipPathRef'. +mkClipPath :: String -- ^ ID of the clip path, which can then be referred to by other elements + -- using 'withClipPathRef'. -> [Tree] -- ^ List of shapes that will determine the final shape of the clipping region -> Tree mkClipPath idTag forest = withId idTag $ ClipPathTree $ defaultSvg @@ -317,10 +330,11 @@ mkBackgroundPixel :: PixelRGBA8 -> Tree mkBackgroundPixel pixel = withFillColorPixel pixel $ mkRect screenWidth screenHeight --- | Take list of rows, where each row consists of number of images and display them in regular grid structure. +-- | Take list of rows, where each row consists of number of images and display them in regular +-- grid structure. -- All rows will get equal amount of vertical space. --- The images within each row will get equal amount of horizontal space, independent of the other rows. --- Each row can contain different number of cells. +-- The images within each row will get equal amount of horizontal space, independent of the other +-- rows. Each row can contain different number of cells. gridLayout :: [[Tree]] -> Tree gridLayout rows = mkGroup [ translate (-screenWidth/2+colSep*nCol) @@ -343,10 +357,12 @@ gridLayout rows = mkGroup -- <> mkText :: T.Text -> Tree mkText str = - (flipYAxis $ - TextTree Nothing $ defaultSvg + flipYAxis + (TextTree Nothing $ defaultSvg & textRoot .~ span_ & fontSize .~ pure (Num 2)) - & textAnchor .~ pure (TextAnchorMiddle) + & textAnchor .~ pure TextAnchorMiddle + -- Note: TextAnchorMiddle is placed on the 'flipYAxis' group such that it can easily + -- be overwritten by the user. where span_ = defaultSvg & spanContent .~ [SpanText str] diff --git a/src/Reanimate/Svg/LineCommand.hs b/src/Reanimate/Svg/LineCommand.hs index 497fc55..afa8d78 100644 --- a/src/Reanimate/Svg/LineCommand.hs +++ b/src/Reanimate/Svg/LineCommand.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE LambdaCase #-} module Reanimate.Svg.LineCommand where import Control.Lens ((%~), (&), (.~)) import Control.Monad.Fix import Control.Monad.State +import Data.Functor import Graphics.SvgTree hiding (height, line, path, use, width) import Linear.Metric import Linear.V2 hiding (angle) import Linear.Vector --- import qualified Geom2D.CubicBezier as Bezier +import qualified Data.Vector.Unboxed as V +import qualified Geom2D.CubicBezier as Bezier type CmdM a = State RPoint a @@ -57,7 +58,7 @@ partialLine alpha cmds = evalState (worker 0 cmds) zero adjustLineLength :: Double -> RPoint -> LineCommand -> LineCommand adjustLineLength alpha from cmd = case cmd of - LineBezier points -> LineBezier $ drop 1 $ partial_bezier_points (from:points) 0 alpha + LineBezier points -> LineBezier $ drop 1 $ partialBezierPoints (from:points) 0 alpha LineMove p -> LineMove p -- LineDraw t -> LineDraw (lerp alpha t from) LineEnd p -> LineBezier [lerp alpha p from] @@ -65,7 +66,7 @@ adjustLineLength alpha from cmd = lineLength :: LineCommand -> CmdM Double lineLength cmd = case cmd of - LineMove to -> pure 0 <* put to + LineMove to -> 0 <$ put to -- LineDraw to -> gets (distance to) <* put to LineBezier points -> gets (distance (last points)) <* put (last points) LineEnd to -> gets (distance to) <* put to @@ -90,12 +91,12 @@ mkStraightLine :: RPoint -> LineCommand mkStraightLine p = LineBezier [p] toLineCommand :: RPoint -> Maybe RPoint -> PathCommand -> CmdM [LineCommand] -toLineCommand startPos mbPrevControlPt cmd = do +toLineCommand startPos mbPrevControlPt cmd = case cmd of MoveTo OriginAbsolute [] -> pure [] MoveTo OriginAbsolute lst -> put (last lst) *> gets (pure.LineMove) MoveTo OriginRelative lst -> modify (+ sum lst) *> gets (pure.LineMove) - LineTo OriginAbsolute lst -> forM lst (\to -> put to *> pure (mkStraightLine to)) + LineTo OriginAbsolute lst -> forM lst (\to -> put to $> mkStraightLine to) LineTo OriginRelative lst -> forM lst (\to -> modify (+to) *> gets mkStraightLine) HorizontalTo OriginAbsolute lst -> forM lst $ \x -> modify (_x .~ x) *> gets mkStraightLine @@ -105,9 +106,9 @@ toLineCommand startPos mbPrevControlPt cmd = do forM lst $ \y -> modify (_y .~ y) *> gets mkStraightLine VerticalTo OriginRelative lst -> forM lst $ \y -> modify (_y %~ (+y)) *> gets mkStraightLine - CurveTo OriginAbsolute quads -> do - forM quads $ \(a,b,c) -> put c *> pure (LineBezier [a,b,c]) - CurveTo OriginRelative quads -> do + CurveTo OriginAbsolute quads -> + forM quads $ \(a,b,c) -> put c $> LineBezier [a,b,c] + CurveTo OriginRelative quads -> forM quads $ \(a,b,c) -> do from <- get <* modify (+c) pure $ LineBezier $ map (+from) [a,b,c] @@ -117,9 +118,9 @@ toLineCommand startPos mbPrevControlPt cmd = do from <- get <* adjustPosition o to let c1 = maybe (makeAbsolute o from c2) (mirrorPoint from) mbControl pure $ LineBezier [c1,makeAbsolute o from c2,makeAbsolute o from to] - QuadraticBezier OriginAbsolute pairs -> do - forM pairs $ \(a,b) -> put b *> pure (LineBezier [a,b]) - QuadraticBezier OriginRelative pairs -> do + QuadraticBezier OriginAbsolute pairs -> + forM pairs $ \(a,b) -> put b $> LineBezier [a,b] + QuadraticBezier OriginRelative pairs -> forM pairs $ \(a,b) -> do from <- get <* modify (+b) pure $ LineBezier $ map (+from) [a,b] @@ -130,10 +131,10 @@ toLineCommand startPos mbPrevControlPt cmd = do let c1 = maybe from (mirrorPoint from) mbControl pure $ LineBezier [c1,makeAbsolute o from to] EllipticalArc o points -> concat <$> - (forM points $ \(rotX, rotY, angle, largeArc, sweepFlag, to) -> do + forM points (\(rotX, rotY, angle, largeArc, sweepFlag, to) -> do from <- get <* adjustPosition o to return $ convertSvgArc from rotX rotY angle largeArc sweepFlag (makeAbsolute o from to)) - EndPath -> put startPos *> pure [LineEnd startPos] + EndPath -> put startPos $> [LineEnd startPos] where mirrorPoint c p = c*2-p adjustPosition OriginRelative p = modify (+p) @@ -153,6 +154,7 @@ calculateVectorAngle ux uy vx vy tb = atan2 vy vx -- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs +{- HLINT ignore convertSvgArc -} convertSvgArc :: RPoint -> Coord -> Coord -> Coord -> Bool -> Bool -> RPoint -> [LineCommand] convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) | x0 == x && y0 == y @@ -188,7 +190,7 @@ convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry) dtheta = if (not sweepFlag && dtheta' > 0) then (dtheta' - 2 * pi) - else (if (sweepFlag && dtheta' < 0) then (dtheta' + 2 * pi) else dtheta') + else (if (sweepFlag && dtheta' < 0) then dtheta' + 2 * pi else dtheta') segments' = ceiling (abs (dtheta / (pi / 2.0))) delta = dtheta / fromInteger segments' @@ -217,25 +219,14 @@ convertSvgArc (V2 x0 y0) radiusX radiusY angle largeArcFlag sweepFlag (V2 x y) dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2) dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2) - --- Algorithm taken from manim. It's magic. -bezier :: [RPoint] -> Double -> RPoint -bezier points t = sum - [ point ^* (((1-t)**(fromIntegral $ n-k)) * (t**fromIntegral k) * fromIntegral (choose n k)) - | (k, point) <- zip [0..] points - , let n = length points-1 ] - where - choose n k = product [n,n-1 .. n-k+1] `div` product [1..k] - -partial_bezier_points :: [RPoint] -> Double -> Double -> [RPoint] -partial_bezier_points points a b - | isNaN end_prop || isInfinite end_prop = replicate (length points) (last points) - | otherwise = [ bezier (take (i+1) a_to_1) end_prop | i <- [0..length points-1] ] - where - a_to_1 = [ bezier (drop i points) a | i <- [0..length points-1] ] - end_prop = (b-a) / (1-a) - - +partialBezierPoints :: [RPoint] -> Double -> Double -> [RPoint] +partialBezierPoints ps a b = + let fromP (V2 i j) = (i, j) + toP (i, j) = V2 i j + c1 :: Bezier.AnyBezier Double + c1 = Bezier.unsafeFromVector (V.fromList $ map fromP ps) + os = V.toList $ Bezier.toVector $ Bezier.bezierSubsegment c1 a b + in map toP os interpolatePathCommands :: Double -> [PathCommand] -> [PathCommand] interpolatePathCommands alpha = lineToPath . partialLine alpha . toLineCommands diff --git a/test/UnitTests.hs b/test/UnitTests.hs index 838442f..3abbcf8 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -20,8 +20,12 @@ import Test.Tasty.HUnit unitTestFolder :: FilePath -> IO TestTree unitTestFolder path = do files <- sort <$> getDirectoryContents path + mbWDiff <- findExecutable "wdiff" + let diff = case mbWDiff of + Nothing -> ["diff", "--strip-trailing-cr"] + Just wdiff -> [wdiff, "--no-common"] return $ testGroup "animate" - [ goldenVsStringDiff file (\ref new -> ["diff", "--strip-trailing-cr", ref, new]) fullPath (genGolden hsPath) + [ goldenVsStringDiff file (\ref new -> diff ++ [ref, new]) fullPath (genGolden hsPath) | file <- files , let fullPath = path file hsPath = replaceExtension fullPath "hs"