A Simple Model of Magnetization

elem[x_,y_,z_,φ_]:=Rotate[{{If[φ>0,Red,Green],Polygon[{{{x-.4,y+.1,z-.1},{x,y+.1,z-.1},{x,y-.1,z-.1},{x-.4,y-.1,z-.1}},{{x-.4,y+.1,z+.1},{x,y+.1,z+.1},{x,y-.1,z+.1},{x-.4,y-.1,z+.1}},
{{x-.4,y+.1,z-.1},{x,y+.1,z-.1},{x,y+.1,z+.1},{x-.4,y+.1,z+.1}},
{{x-.4,y-.1,z-.1},{x,y-.1,z-.1},{x,y-.1,z+.1},{x-.4,y-.1,z+.1}},
{{x,y-.1,z-.1},{x,y+.1,z-.1},{x,y+.1,z+.1},{x,y-.1,z+.1}},
{{x-.4,y-.1,z-.1},{x-.4,y+.1,z-.1},{x-.4,y+.1,z+.1},{x-.4,y-.1,z+.1}}}]},{If[φ>0,Green,Red],Polygon[{{{x,y+.1,z-.1},{x+.4,y+.1,z-.1},{x+.4,y-.1,z-.1},{x,y-.1,z-.1}},{{x,y+.1,z+.1},{x+.4,y+.1,z+.1},{x+.4,y-.1,z+.1},{x,y-.1,z+.1}},
{{x,y+.1,z-.1},{x+.4,y+.1,z-.1},{x+.4,y+.1,z+.1},{x,y+.1,z+.1}},
{{x,y-.1,z-.1},{x+.4,y-.1,z-.1},{x+.4,y-.1,z+.1},{x,y-.1,z+.1}},
{{x+.4,y-.1,z-.1},{x+.4,y+.1,z-.1},{x+.4,y+.1,z+.1},{x+.4,y-.1,z+.1}},
{{x,y-.1,z-.1},{x,y+.1,z-.1},{x,y+.1,z+.1},{x,y-.1,z+.1}}}]}},RandomReal[{-π+Abs[φ]-.3,π-Abs[φ]+.3}],{RandomReal[],RandomReal[],RandomReal[]},{x,y,z}];

box={Polygon[{{-5,1.6,-1.6},{5,1.6,-1.6},{5,1.6,1.6},{-5,1.6,1.6}}],
Polygon[{{-5,-1.6,-1.6},{5,-1.6,-1.6},{5,1.6,-1.6},{-5,1.6,-1.6}}],
Polygon[{{-5,-1.6,-1.6},{-5,1.6,-1.6},{-5,1.6,1.6},{-5,-1.6,1.6}}],
Polygon[{{-5,-1.6,-1.6},{5,-1.6,-1.6},{5,-1.6,1.6},{-5,-1.6,1.6}}],
Polygon[{{-5,-1.6,1.6},{5,-1.6,1.6},{5,1.6,1.6},{-5,1.6,1.6}}],
Polygon[{{5,-1.6,-1.6},{5,1.6,-1.6},{5,1.6,1.6},{5,-1.6,1.6}}]
};

Manipulate[
Graphics3D[{
{Opacity[.3],EdgeForm[{}],LightGray,box},
Table[elem[i,j,k,α],{i,-4,4},{j,-1,1},{k,-1,1}],Polygon[{{-α,0,3-.1α},{.6α,0,3-.1α},{.6α,0,3-.2α},{α,0,3},{.6α,0,3+.2α},{.6α,0,3+.1α},{-α,0,3+.1α}}]},PlotRange->{{-6,6},{-2,2},{-2,4}},ImageSize->500,Boxed->False],
{{α,0,"magnetizing field"},-π,π,(π/24.),Appearance->"Labeled"},SaveDefinitions->True]

THIS NOTEBOOK IS THE SOURCE CODE FROM

"A Simple Model of Magnetization" from The Wolfram Demonstrations Project
 http://demonstrations.wolfram.com/ASimpleModelOfMagnetization/

Contributed by: Hans-Joachim Domke

A full-function Wolfram Mathematica 6 system is required to edit this notebook.
GET WOLFRAM MATHEMATICA 6 »

© The Wolfram Demonstrations Project & Contributors   |   Terms of Use   |   Make a new version of this Demonstration »