Message Boards Message Boards

[GIF] Creating an animated Dragon curve fractal

GROUPS:

I created a nice Dragon 'curve' fractal animation, hope you enjoy! It is based on the repeated 'shearing' of an image:

enter image description here

And if you do that many times you get:

enter image description here

SetDirectory[NotebookDirectory[]];
$HistoryLength=10;
ClearAll[ImageFromDataRules,ImageFromDataRulesBlend]
ImageFromDataRules[data_,rules_]:=ImagePad[Image[data/.rules],{{(1280-imgsize)/2,(1280-imgsize)/2},{(720-imgsize)/2,(720-imgsize)/2}},Cback]
ImageFromDataRules[data_,numbers_,colors_]:=ImageFromDataRules[data,Rule@@@({numbers,(List@@ColorConvert[#,"RGB"])&/@colors}\[Transpose])]
ImageFromDataRulesBlend[data_,numbers_,{cbe_,cba_,c1_,c2_},blend_]:=ImageFromDataRules[data,numbers,{cbe,cba,Blend[{c1,cbe},blend],Blend[{c2,cbe},blend]}]

ClearAll[HorizontalStep,VerticalStep]
HorizontalStep[img_?MatrixQ,size_,f_,dir_Integer:1]:=Module[{i=img,mov,col},
    i=i/.{col1->begin,col2->begin};
    If[Not[IntegerQ[Length[i]size]],Print["O no!"];Abort[];];
    i=Partition[i,Length[i]size];
    mov=dir (-1)^Range[Length[i]]Length[img]size f/2;
    i=MapThread[RotateLeft[#1,{0,Round[#2]}]&,{i,mov}];
    col=Table[If[EvenQ[j],col1,col2],{j,Length[i]}];
    i=MapThread[#1/.begin->#2&,{i,col}];
    Join@@i
]
VerticalStep[img_?MatrixQ,size_,f_]:=Transpose[HorizontalStep[Transpose[img],size,f,-1]]

imgsize=512; (*we have to start with some 2^n*)
startsize=1/2;
nums={begin,back,col1,col2}={0,1,2,3};
cols={Cbegin,Cback,Ccol1,Ccol2}=ColorData["Rainbow"]/@Range[1/4,1,1/4];
cols[[1]]=Blend[{Ccol1,Ccol2}];
img=ConstantArray[begin,imgsize startsize{1,1}];
img=ArrayPad[img,imgsize startsize/2,back];

fn=0;
Dynamic[fn]
tmp=ImageFromDataRules[img,nums,cols];
Export[ToString[++fn]<>".png",tmp];

cycles=4;

Do[
    startsize/=2;
    tmp2=HorizontalStep[img,startsize,0];
    Do[(*intro*)
        tmp=ImageFromDataRulesBlend[tmp2,nums,cols,b];
        Export[ToString[++fn]<>".png",tmp];
    ,
        {b,Range[1,0,-1/16]}
    ];
    Do[(*move*)
        tmp=HorizontalStep[img,startsize,j];
        tmp=ImageFromDataRules[tmp,nums,cols];
        Export[ToString[++fn]<>".png",tmp]
    ,
        {j,Range[0,1,1/12]}
    ];

    tmp2=HorizontalStep[img,startsize,1];
    Do[(*outro*)
        tmp=ImageFromDataRulesBlend[tmp2,nums,cols,b];
        Export[ToString[++fn]<>".png",tmp];
    ,
        {b,Range[0,1,1/16]}
    ];
    img=HorizontalStep[img,startsize,1];
    tmp=ImageFromDataRulesBlend[img,nums,cols,1];
    Do[Export[ToString[++fn]<>".png",tmp],{20}];


    startsize/=2;
    tmp2=VerticalStep[img,startsize,0];
    Do[(*intro*)
        tmp=ImageFromDataRulesBlend[tmp2,nums,cols,b];
        Export[ToString[++fn]<>".png",tmp];
    ,
        {b,Range[1,0,-1/16]}
    ];
    Do[(*move*)
        tmp=VerticalStep[img,startsize,j];
        tmp=ImageFromDataRules[tmp,nums,cols];
        Export[ToString[++fn]<>".png",tmp]
    ,
        {j,Range[0,1,1/12]}
    ];
    tmp2=VerticalStep[img,startsize,1];
    Do[(*outro*)
        tmp=ImageFromDataRulesBlend[tmp2,nums,cols,b];
        Export[ToString[++fn]<>".png",tmp];
    ,
        {b,Range[0,1,1/16]}
    ];
    img=VerticalStep[img,startsize,1];
    tmp=ImageFromDataRulesBlend[img,nums,cols,1];
    Do[Export[ToString[++fn]<>".png",tmp],{20}];
,
    {cycles}
]
Do[Export[ToString[++fn]<>".png",tmp],{60}]

This will output a bunch of images that can then be assembled into an animation.

See also here on YouTube: https://www.youtube.com/watch?v=ug9fhgy9N60

Hope you like it!

POSTED BY: Sander Huisman
Answer
2 years ago

@Vitaliy Kaurov I can't seem to embed videos, is it possible?

POSTED BY: Sander Huisman
Answer
2 years ago

No, no embedding yet, but we are working on that. Nice post, @Sander Huisman, beautiful animations !

POSTED BY: Vitaliy Kaurov
Answer
2 years ago

I see video. Very cool.

POSTED BY: Kathryn Cramer
Answer
2 years ago

Thanks! I was planning to embed this YouTube video: https://www.youtube.com/watch?v=ug9fhgy9N60

But I couldn't (or don't know how to). So I added some GIF animations to give you the idea.

POSTED BY: Sander Huisman
Answer
2 years ago

I am posting this for our China friends - exceptionally graceful code:

i = 0; Dynamic@Graphics@Line@AnglePath[KroneckerSymbol[-1, Range[++i]] Pi/2]

enter image description here

POSTED BY: Vitaliy Kaurov
Answer
2 years ago

Exceptionally compact and elegant!

POSTED BY: Sander Huisman
Answer
2 years ago

A variant that eventually fills all of 2D space:

i=0; Dynamic@Graphics@
Table[Rotate[Line@AnglePath[KroneckerSymbol[-1,Range[i++]] Pi/2],j Pi/2,{-1,0}],{j,0,3}]

enter image description here

Chris

POSTED BY: Christopher Carlson
Answer
2 years ago

Brilliant Vitaliy, I could watch this all day.

POSTED BY: Adam Black
Answer
1 year ago

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the tops of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!

POSTED BY: Moderation Team
Answer
1 year ago

Thank you, your dragon is great :)

POSTED BY: Thomas Eli
Answer
1 year ago

Group Abstract Group Abstract