Fractal Shoulder Angels and Devils

Adam Rumpf, 3/15/2016

Introduction

This program is mostly meant as a joke. It displays a man with a tiny angel and devil on each shoulder, each of which has a tinier angel and devil on each shoulder, and so on. The main function combine[] accepts (in order): a graphics object for the base, a graphics object for each left shoulder, a graphics object for each right shoulder, relative coordinates for the left child, relative coordinates for the right child, a scaling factor for the left child, a scaling factor for the right child, and a number of generations of children to include. There is also a Manipulate environment defined below which allows these elements to be adjusted with sliders and by clicking and dragging to position.

Code

Initialization

(* Graphics objects for a man, angel, and devil. *)
man=Graphics[{Opacity[0],Rectangle[{-0.7,0},{0.7,1.5}],Opacity[1],LightGray,Disk[{0,0.9},0.25],Disk[{0,0.5},0.25],Rectangle[{-0.25,0},{0.25,0.5}]}];
angel=Graphics[{Opacity[0],Rectangle[{-0.7,0},{0.7,1.5}],Opacity[1],LightBlue,Disk[{0,0.9},0.25],Disk[{0,0.5},0.25],Rectangle[{-0.25,0},{0.25,0.5}],Polygon[{{0.15,0.6},{0.55,1},{0.5,0.1},{0.15,0.4}}],Polygon[{{-0.15,0.6},{-0.55,1},{-0.5,0.1},{-0.15,0.4}}],Disk[{0,1.25},{0.3,0.075}],White,Disk[{0,1.25},{0.2,0.0375}]}];
devil=Graphics[{Opacity[0],Rectangle[{-0.7,0},{0.7,1.5}],Opacity[1],LightRed,Disk[{0,0.9},0.25],Disk[{0,0.5},0.25],Rectangle[{-0.25,0},{0.25,0.5}],Polygon[{{0,1},{0.3,1.2},{0.1,0.8}}],Polygon[{{0,1},{-0.3,1.2},{-0.1,0.8}}],Annulus[{-0.1,0.55},{0.45,0.5},{Pi,3Pi/2}],Polygon[{{-0.65,0.5},{-0.5,0.5},{-0.575,0.65}}]}];

(* Given three graphics objects b, l, and r (for base, left, and right), and given relative coordinates cl and cr (for left and right), and given scaling factors sl and sr, generates a graphics object containing all 3.  The optional argument n allows for recursively applying combine n times. *)
combine[b_,l_,r_,cl_,cr_,sl_,sr_,1]:=Graphics[{b/.Graphics->Identity,Translate[Scale[l,sl],cl]/.Graphics->Identity,Translate[Scale[r,sr],cr]/.Graphics->Identity}];combine[b_,l_,r_,cl_,cr_,sl_,sr_,n_]:=combine[b,combine[l,l,r,cl,cr,sl,sr,n-1],combine[r,l,r,cl,cr,sl,sr,n-1],cl,cr,sl,sr,1]

Demonstration

(* Single angel/devil *)
combine[man,devil,angel,{-0.6,0.5},{0.6,0.5},0.4,0.4,1]

(* 7 layers of angels/devils *)
combine[man,devil,angel,{-0.75,0.5},{0.75,0.5},0.4,0.4,7]

(* Unbalanced angels/devils *)
combine[man,devil,angel,{-0.75,0.4},{0.75,0.7},0.4,0.5,5]

(* Adjustable angels/devils *)
Manipulate[combine[man,devil,angel,left,right,sl,sr,n],{{sl,0.4,"devil scaling"},0.1,1.5},{{sr,0.4,"angel scaling"},0.1,1.5},{{left,{-0.6,0.5}},Locator},{{right,{0.6,0.5}},Locator},{{n,2,"rows"},1,6,1}]