Video Creation

Shadi Ashnai, Wolfram Research, Inc.

(RowDefault[, (Spacer1), , (Spacer1), ])  #WolframTechConf

ABSTRACT

In this talk, I will show methods for producing insightful animations and videos. Techniques include capturing screens and webcams, touring around 2D/3D graphics, telling stories using user-controlled Manipulates, as well as using creative and unique ways in Wolfram Language to create videos from programs.

Outline

Tools

Capture from screens & connected webcams

Assemble images

Tour 2D or 3D images & graphics

From programs: fold, nest, ...

From Animations & Manipulates

Video editing & composition

Examples

Capture

Capture video from a connected webcam:

VideoCapture[]

Capture the screen:

VideoScreenCapture[]

Control capture programmatically:

stream=VideoRecord[{"Screen",2,{{0,0},{1000,1000}}}]

VideoStop[stream]

Video[stream,ImageSize->300]

Assemble images

Simple Examples

From a single image:

ConstantVideo[]

From a series of images:

SlideShowVideo[{,,}]

From a full list of frames:

i=;

NestList[ImageRestyle[#,#]&,i,2]

list=NestList[ImageRestyle[#,#]&,i,50];

Length[list]

FrameListVideo[list,FrameRate->15]

Map of the Roman Empire

ts=GeoVariant[(Entity[(EntityLabelSublabel["Roman Empire", "27 BC \[Hyphen] 395 AD"]), Entity["HistoricalCountry","RomanEmpire"], "Entity[\"HistoricalCountry\", \"RomanEmpire\"]", "historical country"]),"TimeSeries"]["Polygon"]

SlideShowVideo[TimeSeriesMapThread[GeoGraphics[{Purple,#2},GeoRange->(Entity[(EntityLabelSublabel["Roman Empire", "27 BC \[Hyphen] 395 AD"]), Entity["HistoricalCountry","RomanEmpire"], "Entity[\"HistoricalCountry\", \"RomanEmpire\"]", "historical country"]),GeoBackground->"Coastlines",PlotLabel->"Year: "<>DateString[#1,"Year"]]&,ts],DefaultDuration->20]

Other Examples

Tracking Hurricane Helene [link]

Example of solving the Cahn-Hilliard equation with NDSolve [link]

Tour 2D or 3D Images & Graphics

Tour around Images

Pan and zoom around a large image:

i=ExampleData[{"TestImage","Volubilis"}]

TourVideo[i,{\[LeftAssociation]"Position"->{5000,2000},"Width"->3000\[RightAssociation],\[LeftAssociation]"Position"->{2700,1800},"Width"->200\[RightAssociation]}]

Spiral around an image:

path=time|->With[{t=10-2time},<|"Position"->{400,210}+{18,10} t {Cos[t],Sin[t]},"Width"->60+25t|>];

ParametricPlot[path[t]["Position"],{t,0,5}]

i=;

HighlightImage[i,ParametricPlot[path[t]["Position"],{t,0,5},{PlotStyle->Directive[Thick,Yellow]}]]

TourVideo[i,path]

Tour of faces:

i=;

faces=FindFaces[i,PaddingSize->50];
HighlightImage[i,faces]

TourVideo[i,Append[Prepend[SortBy[faces,#[[1,1]]&],Full],Full],]

Tour on Maps

Tour around Germany:

TourVideo[GeoGraphics[],{(Entity["Munich", Entity["City",{"Munich","Bavaria","Germany"}], "Entity[\"City\", {\"Munich\", \"Bavaria\", \"Germany\"}]", "city"]),(Entity["Würzburg", Entity["City",{"Wurzburg","Bavaria","Germany"}], "Entity[\"City\", {\"Wurzburg\", \"Bavaria\", \"Germany\"}]", "city"])}]

TourVideo[GeoGraphics[],]

3D Tours

Simple rotation:

Tour3DVideo[]

Custom rotation:

position[t_]:={1200Cos[t],400Sin[t],100t}

Show[g=ExampleData[{"Geometry3D","CastleWall"}],ParametricPlot3D[position[t],{t,0,5}],PlotRange->All]

Tour3DVideo[g,position]

Other Examples

Simulating random hand-twirling for 3D digital objects with spherical splines [link]

Illuminating proteins: proteins, lighting, and videos [link]

Glam-ifying 3D graphics: simple video animations and techniques [link]

From programs: Fold, Nest, ...

Sow & Reap Video Frames

Sow and reap frames:

ReapVideo[NestWhileList[SowVideo@Pruning[#,{1}]&,Thinning[],Unequal,2]]

Sow on a condition:

video = ResourceData["Sample Video: Practicing Yoga"];

ReapVideo[VideoMapList[If[Length[FindFaces[#Image]]>0,SowVideo[#Image]]&,video];]

Fold Operations

Create a motion blur:

VideoFrameFold[Blend[{##},.1]&,]

Create a motion effect:

VideoFrameFold[ImageCompose[#1,RemoveBackground[#2,"Salient"]]&,]

VideoFrameFold[ImageCompose[#1,RemoveBackground[#2,"Salient"]]&,]

[Hidden] FoldPair Operation

video=;

f[{prevPts_,currFrames_}]:=Module[{pts=Quiet@DeleteMissing[
Last[ImageFeatureTrack[currFrames,prevPts,MaxFeatureDisplacement->15]]]},{HighlightImage[Last@currFrames,prevPts],pts}]

Video`VideoFrameFoldPair[f,,video,First,2,1]

From Animations

Simple Examples

f[s_]:=ImageTransformation[,FractionalPart[s#]&,]

Animate[f[s],{s,1,5}]

AnimationVideo[f[x],{s,1,5}]

Animate Evolution

n=128;
AnimationVideo[
ImageCrop[
Image[CellularAutomaton[30,{{1},0},Floor[i]]],
{2n-1,n},Top
],
{i,1,n,1}
]

Animation Over Time

AnimationVideo[AstroGraphics[AstroReferenceFrame->{"Horizon",(DateObject["Wed 27 Dec 2023 00:00:00""GMT"+2, DateObject[{2023,12,27,0,0,0},"Instant","Gregorian",2.`]])+(Quantity[i, "h", hours, "Hours"])},AstroBackground->"GalacticSky"],{i,0,24}]

Other Examples

WordCloudVideo: using replacements and interpolations for simple transitions [link]

Popping population bubbles: idle animations and GeoGraphics [link]

From Manipulates

Manipulate with one variable

Take this Manipulate expression:

Manipulate[Graphics[{Hue[h],Disk[]}],{h,0,1}]

By default, a variable is animated across its domain:

ManipulateVideo[Graphics[{Hue[h],Disk[]}],{h,0,1}]

This is also the same as AnimationVideo:

AnimationVideo[Graphics[{Hue[h],Disk[]}],{h,0,1}]

Specify how to animate the variable:

ManipulateVideo[Graphics[{Hue[h],Disk[]}],{h,<|0->0,1->.5,3->.5,4->1|>}]

Manipulate with multiple variables

Manipulate[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,0,1},{s,2,1}]

Multiple variables are animated synchronously across their domains:

ManipulateVideo[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,0,1},{s,2,1}]

Specify how to animate variables:

ManipulateVideo[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,<|0->0,1->.5,3->.5,4->1|>},
{s,<|0->1,2->4,4->2|>}]

KeyframeActions Option

Add keyframes to the Manipulate expression:

Manipulate[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,0,1},{s,2,1}]

Turn on keyframes and interactively add them to the list of actions:

Manipulate[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,0,1},{s,2,1},KeyframeActions->True]

Create a Manipulate with the KeyframeActions option:

m=Manipulate[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,0,1,Appearance->"Labeled"},{s,1,4,Appearance->"Labeled"},
KeyframeActions->{
0:>(h=0;s=1),
1:>(h=.5;s=4),
2:>(h=1;s=2)
}
]

Create a video from the Manipulate:

ManipulateVideo[Evaluate@m]

ManipulateVideo with KeyframeActions:

ManipulateVideo[Graphics[{Hue[h],Disk[{0,0},s]},PlotRange->4],{h,0,1},{s,1,4},KeyframeActions->{
0:>(h=0;s=1),
1:>(h=.5;s=4),
2:>(h=1;s=2)
}]

An example from Wolfram Demonstrations

Inspired by the Understanding 3D Rotation Demonstration:

ResourceData["Demonstrations Project: Understanding 3D Rotation"]

Here is a simpler Manipulate:

Manipulate[Pane[Column[{Style[RotationTransform["θ",{"wx","wy","wz"},{"px","py","pz"}],14,Bold],Style["⇓",25],},Center]],
{θ,-2Pi,2Pi},{px,0,1},{py,0,1}
]

And this is a video with specified control animation:

ManipulateVideo[,
{θ,-2π,2π,InterpolationOrder->1},{px,0,1,InterpolationOrder->1},{py,0,1,InterpolationOrder->1},
KeyframeActions->
{0:>{px=0,py=0,θ=-2π},
2:>{px=0,py=0,θ=0},
3:>{px=1,py=0,θ=0},
5:>{px=1,py=0,θ=2π},
6:>{px=.5,py=.5,θ=2π},
8:>{px=.5,py=.5,θ=0}}
]

Invitation: Create Experiments ...

Demonstrations Project [link]

Video Editing & Composition

Create a constant “title” video:

ConstantVideo[Graphics[Text[Style["Brush your teeth ...",32]]]]

Create a grid of multiple videos:

v1=GridVideo[ResourceData["Tooth Brushing Video Samples"],Spacings->5,Background->White]

v2=GridVideo[ResourceData["Cheerleading Video Samples"],Spacings->5,Background->White];

Join multiple videos over time:

VideoJoin[{ConstantVideo[Graphics[Text[Style["Brush your teeth ...",32]]],3],v1,ConstantVideo[Graphics[Text[Style["... before you dance!",32]]],3],v2},RasterSize->360]

Overlay your logo on a corner:

OverlayVideo[%,]

Add audio (this one is from Wolfram Tones):

final=VideoCombine[{%,}]

Before we wrap...

Generated Videos are in $WolframDocumentsDirectory:

$WolframDocumentsDirectory

FileNames["*.mp4",$WolframDocumentsDirectory<>"/Video"]//Length

v=AnimationVideo[Graphics[{Hue[h],Disk[]}],{h,0,1},]

Information[v,"ResourcePath"]

CopyFile[Information[v,"ResourcePath"],"~/Desktop/wtc/myfile.mp4"]

Export["~/Desktop/wtc/myfile.mp4",v]

Control the location of generated files:

AnimationVideo[Graphics[{Hue[h],Disk[]}],{h,0,1},GeneratedAssetLocation->NotebookDirectory[],]

Information[%,"ResourcePath"]

Thanks!

Video Computation Overview: https://wolfr.am/video

During WTC 2024

✓ Audio and Video Analysis, by Carlo Giacometti & Ali Hashmi

Thursday — 9:00 AM - 9:30 AM CT

✓ Video Creation

Thursday — 9:30 AM - 10:00 AM CT

Office Hour: Sound & Vision

Thursday — 1:00 PM - 2:00 PM CT

R&D Booth: Image, Audio & Video Computation [link]

Thursday — 12:00 PM - 12:30 PM CT

Friday — 12:30 PM - 1:00 PM CT

Init

Initialization

Null