Shape[1][{1,1,1}]

Shape[2][

RotationTransform

Shape[j_,k_]:= Module[
{Width=0.1,Height=0.4,RotMat,v},
RotMat=Switch[k,
0, (({{1, 0, 0}, {0, 1, 0}, {0, 0, 1}})),
1,(({{0, 0, 1}, {0, 1, 0}, {1, 0, 0}})),
2,(({{1, 0, 0}, {0, 0, 1}, {0, 1, 0}}))
];
Switch[j,
0,v=RotMat.{Width/2,Width/2,Height/2};Cuboid[{#-v,#+v}]&,
1,v=RotMat.{0,0,Height/2};Cylinder[{#-v,#+v},Width]&,
2, v=RotMat.{0,0,Height/2};Cone[{#-v,#+v},Width]&    
]
]

Show[
Graphics3D[
{PointSize[0.02],
Table[Line[{{0,j,k},{2,j,k}}],{j,0,2},{k,0,2}],
Table[Line[{{i,0,k},{i,2,k}}],{i,0,2},{k,0,2}],
Table[Line[{{i,j,0},{i,j,2}}],{i,0,2},{j,0,2}],
Table[{Hue[i/3],Shape[j,k][{i,j,k}]},
{i,0,2},{j,0,2},{k,0,2}]}
],
SphericalRegion->True,
Boxed->False
]

Hmm=Shape[1][{1,1,1}]
Show[Graphics3D[Hmm]]
Show[Graphics3D[Rotate[Hmm,π/2,{1,0,0},{0,1,0}]]]

Text

?Cone

Show[
Graphics3D[
{PointSize[0.02],
Table[Point[{i,j,k}],
{i,0,2},{j,0,2},{k,0,2}]}
],
FaceGrids->All,
FaceGridsStyle->Blue
]

Reducing Precision

I want to be able to reducethe precision of a number

$MaxPrecision=$MachinePrecision

x=N[π,3];
FullForm[x]
y=SetPrecision[x+ 1/(2^8),3];
FullForm[y]
FullForm[x-y]

$MachinePrecision
$MachineEpsilon

DoubleToSingle[x_]:= Block[{$MaxPrecision=3,$MinPrecision=3},x]
x=N[π]
DoubleToSingle[x]-x

WriteString[3.141592653589793`]

3.141592653589793`

SlowConvert[x_]:=ImportString[ExportString[x,"Real32"],"Real32"][[1]]
FastConvert = Compile[
{{x, _Real}}, 
Z=ImportString[ExportString[{x},"Real32"],"Real32"];
Z[[1]],
{{Z,_Real,1}},
CompilationOptions->{"ExpressionOptimization"->True},
CompilationTarget->"C"]
x=N[π];
Timing[Do[SlowConvert[x],{100}];]
Timing[Do[FastConvert[x],{100}];]
FastConvert[x]-SlowConvert[x]

file = $TemporaryPrefix <>"test1";
FunnyFast[x_]:=Module[
{X},
BinaryWrite[file,x,"Real32"];
Close[file];
X=BinaryRead[file,"Real32"];
Close[file];
X
]

x=N[π];
Timing[Do[
y=FunnyFast[x];,
{(10^4)}]]

Compile

x=N[π]
Timing[
Do[
y=ImportString[ExportString[x,"Real32"],"Real32"][[1]],
{23}]
]
((Abs[x-y])/(Abs[x]))
{x,y}

{3.141592653589793`,3.1415927410125732`}

3.1415927410125732`

DoubleToSingle[x_]:=N[Sign[x]FromDigits[RealDigits[x,2,52],2]]

x=N[π];
BitSet[3.14159`,0]

SampleSize=(10^6);
Data=Table[
x=N[RandomReal[{-100,100}]];
y=DoubleToSingle[x];
(1/$MachineEpsilon)((x-y)/(Abs[x])),
{SampleSize}];
Histogram[Data,{-12.5,12.5,1}]

Double

$MaxPrecision=

Break

BadQuadratic[{a_,b_,c_}]:= Sort[ {((-b + (Sqrt[(b^2)- 4 a c]))/(2a)),((-b -(Sqrt[(b^2)- 4 a c]))/(2a))}];

As you can see below this does not always give as good an answer as you might hope.

ListLogPlot[
Sort[
Table[
{a,b,c}=RandomReal[{-1,1},{3}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
GridLines->Automatic,
Frame->True
]

A little though shows that the bad stuff probably happens when a×c is small.

a=(10.0^(-4));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

a=(10.0^(-8));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

a=(10.0^(-12));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

a=(10.0^(-16));
ListLogPlot[
Sort[
Table[
{b,c}=RandomReal[{-1,1},{2}];
{x1,x2}=BadQuadratic[{a,b,c}];
Norm[{a (x1^2)+ b x1 + c,a (x2^2)+ b x2 + c}],
{2300}]
],
PlotRange->All,
PlotLabel->StringForm["a=``",a],
GridLines->Automatic,
Frame->True
]

Big=(10^8);
aUp=0.0;
Do[
aUp = aUp + 1.0/i,
{i,1,Big,1}]

aDown=0.0;
Do[
aDown = aDown + 1.0/i,
{i,Big,1,-1}]
{aUup,aDown}
aDown-aUp

a