Napier's Bones

Author

Eric W. Weisstein
January 25, 2011

This notebook downloaded from http://mathworld.wolfram.com/notebooks/RecreationalMath/NapiersBones.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/NapiersBones.html.

©2010 Wolfram Research, Inc. except for portions noted otherwise

Code

Bone[-1,x_]:={
{Red,Rectangle[{x,-9},{x+1,0}]},
Table[Line[{{i,0},{i,-9}}],{i,x,x+1}],
Table[Line[{{x,i},{x+1,i}}],{i,-9,0}],
Table[
Text[n,{x+.5,-n+.5},BaseStyle->14],
{n,9}]
}
Bone[n_,x_]:=Module[{i},
{
Table[Line[{{i,0},{i,-9}}],{i,x,x+1}],
Table[Line[{{x,i},{x+1,i}}],{i,-9,0}],
Table[Line[{{x,i},{x+1,i+1}}],{i,-9,-2}],
Text[n,{x+.5,-.5},BaseStyle->14],
Table[Text[If[#==0,"",#]&[(n i-Mod[n i,10])/10],{x+.25,-i+.7}],{i,2,9}],
Table[Text[Mod[n i,10],{x+.75,-i+.3}],{i,2,9}]
}
]
Bones[l_List?VectorQ]:={Bone[-1,0],MapIndexed[Bone[#1,Sequence@@#2]&,l]}
Bones[n_,l_List?VectorQ]:={
{Yellow,Rectangle[{1,-n},{1+Length[l],-n+1}]},
Bones[l]
}

Options[Text]

Bones

V5

<<Graphics`Colors`

Show[Graphics[
Bones[Range[0,9]],
AspectRatio->Automatic]
]

V6

Graphics[Bones[Range[0,9]]]

Example

Show[Graphics[
Bones[7,{4,8,9,6}],
AspectRatio->Automatic]
]