diff --git a/examples/tut_glue_blender.hs b/examples/tut_glue_blender.hs --- a/examples/tut_glue_blender.hs +++ b/examples/tut_glue_blender.hs @@ -6,13 +6,14 @@ module Main (main) where import Reanimate +import Reanimate.Builtin.Documentation import Codec.Picture.Types -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad import Data.Monoid -import qualified Data.Text as T -import Graphics.SvgTree hiding (text) +import qualified Data.Text as T +import Graphics.SvgTree hiding (text) import NeatInterpolation import System.Random import System.Random.Shuffle @@ -20,7 +21,7 @@ -- spritePercent = (/) <$> spriteT <*> spriteDur main :: IO () -main = seq texture $ reanimate $ pauseAtEnd 1 $ parA bg $ sceneAnimation $ do +main = seq texture $ reanimate $ pauseAtEnd 1 $ addStatic bg $ sceneAnimation $ do bend <- newVar 0 trans <- newVar 0 rotX <- newVar 0 @@ -50,7 +51,7 @@ wait 1 wait 2 where - bg = animate $ const $ mkBackgroundPixel (PixelRGBA8 252 252 252 0xFF) + bg = mkBackgroundPixel rtfdBackgroundColor texture :: Double -> FilePath texture t = svgAsPngFile $ mkGroup @@ -66,12 +67,20 @@ rotX_ = T.pack $ show rotX rotY_ = T.pack $ show rotY yScale_ = T.pack $ show (fromToS (9/2) 4 bend) + pWidthT = T.pack $ show (max 800 pWidth) + pHeightT = T.pack $ show (max 450 pHeight) in [text| import os import math import bpy +light = bpy.data.objects['Light'] +bpy.ops.object.select_all(action='DESELECT') +light.select_set(True) +bpy.ops.object.delete() + + cam = bpy.data.objects['Camera'] cam.location = (0,0,22.25 + ${transZ_}) cam.rotation_euler = (0, 0, 0) @@ -99,10 +108,13 @@ bpy.context.object.active_material = bpy.data.materials['Material'] mat = bpy.context.object.active_material image_node = mat.node_tree.nodes.new('ShaderNodeTexImage') -texture = mat.node_tree.nodes['Principled BSDF'] -texture.inputs['Roughness'].default_value = 1 -mat.node_tree.links.new(image_node.outputs['Color'], texture.inputs['Base Color']) +output = mat.node_tree.nodes['Material Output'] +#texture = mat.node_tree.nodes['Principled BSDF'] +#texture.inputs['Roughness'].default_value = 1 +#mat.node_tree.links.new(image_node.outputs['Color'], texture.inputs['Base Color']) +mat.node_tree.links.new(image_node.outputs['Color'], output.inputs['Surface']) + image_node.image = bpy.data.images.load('${img_}') @@ -141,9 +153,14 @@ scn = bpy.context.scene +scn.view_settings.view_transform = 'Standard' + #scn.render.engine = 'CYCLES' #scn.render.resolution_percentage = 10 +scn.render.resolution_x = ${pWidthT} #3200 +scn.render.resolution_y = ${pHeightT} #1800 + scn.render.film_transparent = True bpy.ops.render.render( write_still=True ) @@ -151,11 +168,11 @@ checker :: Int -> Int -> SVG checker w h = - withStrokeColor "lightblue" $ + withStrokeColor "lightgrey" $ withStrokeWidth (defaultStrokeWidth/2) $ mkGroup [ withStrokeWidth 0 $ - withFillOpacity 1 $ mkBackground "grey" + withFillOpacity 1 $ mkBackground "darkgrey" , mkGroup [ translate (stepX*x-offsetX + stepX/2) 0 $ mkLine (0, -screenHeight/2*0.9) (0, screenHeight/2*0.9) 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.4.0.0 +version: 0.4.1.0 -- synopsis: -- description: license: PublicDomain diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -65,6 +65,11 @@ formatHeight RenderGif = 180 formatHeight RenderWebm = 1440 +formatExtension :: Format -> String +formatExtension RenderMp4 = "mp4" +formatExtension RenderGif = "gif" +formatExtension RenderWebm = "webm" + {-| Main entry-point for accessing an animation. Creates a program that takes the following command-line arguments: @@ -126,11 +131,10 @@ target <- case renderTarget of Nothing -> do - self <- findOwnSource - pure $ case fmt of - RenderMp4 -> replaceExtension self "mp4" - RenderGif -> replaceExtension self "gif" - RenderWebm -> replaceExtension self "webm" + mbSelf <- findOwnSource + let ext = formatExtension fmt + self = fromMaybe "output" mbSelf + pure $ replaceExtension self ext Just target -> makeAbsolute target let diff --git a/src/Reanimate/Driver/Compile.hs b/src/Reanimate/Driver/Compile.hs --- a/src/Reanimate/Driver/Compile.hs +++ b/src/Reanimate/Driver/Compile.hs @@ -5,22 +5,30 @@ import System.Exit import System.FilePath import System.Process +import System.IO compile :: [String] -> IO () compile opts = do - self <- findOwnSource - let selfDir = takeDirectory self - selfName = takeBaseName self - outDir = selfDir ".reanimate" selfName - target = outDir selfName - ghcOptions = - ["-rtsopts", "--make", "-threaded", "-O2"] ++ - ["-odir", outDir, "-hidir", outDir] ++ - [self, "-o", target] - createDirectoryIfMissing True outDir - withCurrentDirectory selfDir $ do - checkExitCode =<< rawSystem "stack" (["ghc", "--"] ++ ghcOptions) - checkExitCode =<< rawSystem target opts + mbSelf <- findOwnSource + case mbSelf of + Nothing -> do + hPutStrLn stderr + "Failed to find source code. Did you already compile the animations?\n\ + \Try running again without the --compile flag." + exitFailure + Just self -> do + let selfDir = takeDirectory self + selfName = takeBaseName self + outDir = selfDir ".reanimate" selfName + target = outDir selfName + ghcOptions = + ["-rtsopts", "--make", "-threaded", "-O2"] ++ + ["-odir", outDir, "-hidir", outDir] ++ + [self, "-o", target] + createDirectoryIfMissing True outDir + withCurrentDirectory selfDir $ do + checkExitCode =<< rawSystem "stack" (["ghc", "--"] ++ ghcOptions) + checkExitCode =<< rawSystem target opts checkExitCode :: ExitCode -> IO () checkExitCode ExitSuccess = return () diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -37,7 +37,7 @@ serve :: Bool -> Maybe FilePath -> [String] -> Maybe FilePath -> IO () serve verbose mbGHCPath extraGHCOpts mbSelfPath = withManager $ \watch -> do hSetBuffering stdin NoBuffering - self <- maybe findOwnSource pure mbSelfPath + self <- maybe requireOwnSource pure mbSelfPath when verbose $ putStrLn $ "Found own source code at: " ++ self hasConnectionVar <- newMVar False @@ -176,20 +176,32 @@ ["-odir", tmpDir, "-hidir", tmpDir] -- FIXME: Move to a different module --- FIXME: Gracefully disable code reloading if source is missing. -findOwnSource :: IO FilePath +requireOwnSource :: IO FilePath +requireOwnSource = do + mbSelf <- findOwnSource + case mbSelf of + Nothing -> do + hPutStrLn stderr + "Rendering in browser window is only available when interpreting.\n\ + \To render a video file, use the 'render' command or run again with --help\n\ + \to see all available options." + exitFailure + Just self -> pure self + +findOwnSource :: IO (Maybe FilePath) findOwnSource = do fullArgs <- getFullArgs stackSource <- makeAbsolute (last fullArgs) exist <- doesFileExist stackSource - if exist - then return stackSource + if exist && isHaskellFile stackSource + then return (Just stackSource) else do prog <- getProgName + let hsProg + | isHaskellFile prog = prog + | otherwise = replaceExtension prog "hs" lst <- listDirectory "." - mbSelf <- findFile ("." : lst) prog - case mbSelf of - Nothing -> do - hPutStrLn stderr "Failed to find own source code." - exitFailure - Just self -> pure self + findFile ("." : lst) hsProg + +isHaskellFile :: FilePath -> Bool +isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"] diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -246,7 +246,7 @@ writeFile (frameName n) $ renderSvg width height $ nthFrame n modifyMVar_ done $ \nDone -> return (nDone + 1) - when (raster /= RasterNone) + when (isValidRaster raster) $ progressPrinter "rastered" frameCount $ \done -> handle h $ concurrentForM_ frames $ \n -> do applyRaster raster (frameName n) @@ -254,6 +254,9 @@ action (tmp rasterTemplate raster) where + isValidRaster RasterNone = False + isValidRaster RasterAuto = False + isValidRaster _ = True width = Just $ Px $ fromIntegral width_ height = Just $ Px $ fromIntegral height_ @@ -284,6 +287,7 @@ rasterTemplate :: Raster -> String rasterTemplate RasterNone = "render-%05d.svg" +rasterTemplate RasterAuto = "render-%05d.svg" rasterTemplate _ = "render-%05d.png" requireRaster :: Raster -> IO Raster diff --git a/src/Reanimate/Svg/LineCommand.hs b/src/Reanimate/Svg/LineCommand.hs --- a/src/Reanimate/Svg/LineCommand.hs +++ b/src/Reanimate/Svg/LineCommand.hs @@ -1,16 +1,15 @@ module Reanimate.Svg.LineCommand where -import Control.Lens ((%~), (&), (.~)) +import Control.Lens ((%~), (&), (.~)) import Control.Monad.Fix import Control.Monad.State -import Data.Functor -import Graphics.SvgTree hiding (height, line, path, use, - width) +import Data.Functor +import qualified Data.Vector.Unboxed as V +import qualified Geom2D.CubicBezier as Bezier +import Graphics.SvgTree hiding (height, line, path, use, width) import Linear.Metric -import Linear.V2 hiding (angle) +import Linear.V2 hiding (angle) import Linear.Vector -import qualified Data.Vector.Unboxed as V -import qualified Geom2D.CubicBezier as Bezier type CmdM a = State RPoint a @@ -67,9 +66,27 @@ lineLength cmd = case cmd of LineMove to -> 0 <$ put to - -- LineDraw to -> gets (distance to) <* put to - LineBezier points -> gets (distance (last points)) <* put (last points) + -- Straight line: + LineBezier [dst] -> gets (distance dst) <* put dst + -- Some kind of curve: + LineBezier lst -> do + from <- get + let bezier = rpointsToBezier (from:lst) + tol = 0.0001 + put (last lst) + pure $ Bezier.arcLength bezier 1 tol LineEnd to -> gets (distance to) <* put to + +rpointsToBezier :: [RPoint] -> Bezier.CubicBezier Double +rpointsToBezier lst = + case map toBezierPoint lst of + [a,b] -> Bezier.CubicBezier a a b b + [a,b,c] -> Bezier.quadToCubic (Bezier.QuadBezier a b c) + [a,b,c,d] -> Bezier.CubicBezier a b c d + _ -> error $ "rpointsToBezier: Invalid list of points: " ++ show lst + +toBezierPoint :: RPoint -> Bezier.Point Double +toBezierPoint (V2 a b) = Bezier.Point a b toLineCommands :: [PathCommand] -> [LineCommand] toLineCommands ps = evalState (worker zero Nothing ps) zero