Message Boards Message Boards

GROUPS:

[GIF] Creating an animated Dragon curve fractal

Posted 6 years ago
16898 Views
|
10 Replies
|
28 Total Likes
|

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!

10 Replies
Posted 6 years ago

Thank you, your dragon is great :)

Posted 6 years ago

Brilliant Vitaliy, I could watch this all day.

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!

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

Exceptionally compact and elegant!

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

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

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.

I see video. Very cool.

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

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract