Re: An entropy measure of rational number fractal dimension: d=0.3732201657487591656832916543359
- To: mathgroup at smc.vnet.net
- Subject: [mg50324] Re: An entropy measure of rational number fractal dimension: d=0.3732201657487591656832916543359
- From: "Roger L. Bagula" <rlbtftn at netscape.net>
- Date: Fri, 27 Aug 2004 02:57:45 -0400 (EDT)
- References: <cgkgcm$gac$1@smc.vnet.net>
- Reply-to: tftn at earthlink.net
- Sender: owner-wri-mathgroup at wolfram.com
Shannon entropy link: http://www.astro.phys.ethz.ch/papers/benz/schwarz/schwarz/subsection3_3_4.html Roger Bagula wrote: > I've done some other work using the Farey tree functions on the interval > > [0,1]. > In this case because of the singularity at Log[0], I limit > myself to single repetitions of fractions in the interval (0,1], zero > excluded. > As the number on points gets larger this average gets smaller but very > slowly > so this is an upper bound for the dimension by an entropy measure of > this type > ( Ulam base two information entropy). > It is in the right range for the 3 set, 1/3 sets model: > 1/3 rational numbers > 1/3 irrational algebraic numbers > 1/3 transcendental numbers > where rational numbers never touch transcendental numbers. > This program is a start of 49000 where duplicates are deleted and zero > is deleted > to deplete that number in the end average. > It is an honest effort to make an estimate of the true fractal dimension > of the rational numbers. > > > Mathematica notebook: > > (*********************************************************************** > > Mathematica-Compatible Notebook > > This notebook can be used on any computer system with Mathematica 3.0, > MathReader 3.0, or any compatible application. The data for the notebook > starts with the line of stars above. > > To get the notebook into a Mathematica-compatible application, do one of > the following: > > * Save the data starting with the line of stars above into a file > with a name ending in .nb, then open the file inside the application; > > * Copy the data starting with the line of stars above to the > clipboard, then use the Paste menu command inside the application. > > Data for notebooks contains only printable 7-bit ASCII and can be > sent directly in email or through ftp in text mode. Newlines can be > CR, LF or CRLF (Unix, Macintosh or MS-DOS style). > > NOTE: If you modify the data for this notebook not in a Mathematica- > compatible application, you must delete the line below containing the > word CacheID, otherwise Mathematica-compatible applications may try to > use invalid cache data. > > For more information on notebooks and Mathematica-compatible > applications, contact Wolfram Research: > web: http://www.wolfram.com > email: info at wolfram.com > phone: +1-217-398-0700 (U.S.) > > Notebook reader applications are available free of charge from > Wolfram Research. > ***********************************************************************) > > (*CacheID: 232*) > > > (*NotebookFileLineBreakTest > NotebookFileLineBreakTest*) > (*NotebookOptionsPosition[ 2931, 92]*) > (*NotebookOutlinePosition[ 3774, 119]*) > (* CellTagsIndexPosition[ 3730, 115]*) > (*WindowFrame->Normal*) > > > > Notebook[{ > Cell[BoxData[ > \(Clear\ [f, a, b]\)], "Input"], > > Cell[BoxData[{ > \(f[a_, b_] := \((\((a/b)\)/\((1 - a/b)\))\) /; 0 <= a/b <= 1/2\), > \(f[a_, b_] := \((\((1 - a/b)\)/\((a/b)\))\) /; 1/2 < a/b <= 1\)}], > "Input"], > > Cell[BoxData[ > \( (*\ symmetrical\ table\ of\ Farey\ rational\ numbers*) \)], "Input"], > > Cell[BoxData[ > \(\(a = Table[If[n < m, f[n, m], f[m, n]], {n, 1, 700}, {m, 1, \ 700}]; > \)\)], "Input"], > > Cell[BoxData[ > \( (*\ members\ only\ once\ with\ zero\ excluded\ interval\ \((0, 1\)] > \ *) \)], "Input"], > > Cell[BoxData[ > \(\(a2 = Delete[Union[Flatten[a]], 1]; \)\)], "Input"], > > Cell[BoxData[ > \( (*\ > average\ binary\ entropy\ taken\ as\ H0 = > \(-Log\) \((base2)\)[1/2]\ to\ give\ a\ Shannon\ information/\ Ulam\ > entropy\ based\ dimension*) \)], "Input"], > > Cell[BoxData[ > \( (*\ H = \(H0 + Sum[\(-p\)*Log[p]/Log[2], n]/\(n\ : \ d\) = H/H0\)*) > \)], "Input"], > > Cell[CellGroupData[{ > > Cell[BoxData[ > \(Dim_entropy = > N[\((Apply[Plus, \(-Log[a2]\)*a2/Log[2]]/\(Dimensions[a2]\)[\([1]\)])\)/ > \((\(-Log[1/2]\)/Log[2])\), 20]\)], "Input"], > > Cell[BoxData[ > \(0.3732201657487591656832916543359`20\)], "Output"] > }, Open ]] > }, > FrontEndVersion->"Macintosh 3.0", > ScreenRectangle->{{0, 1920}, {0, 1060}}, > WindowSize->{1730, 963}, > WindowMargins->{{Automatic, 76}, {17, Automatic}}, > MacintoshSystemPageSetup->"\<\ > 00/0001804P000000_@2@?olonh35@9B7`<5:@?l0040004/0B`000003509H04/ > 02d5X5k/02H20@4101P00BL?00400@0000000000000000010000000000000000 > 0000000000000002000000@210D00000\>" > ] > > > (*********************************************************************** > Cached data follows. If you edit this Notebook file directly, not using > Mathematica, you must remove the line containing CacheID at the top of > the file. The cache data will then be recreated when you save this file > from within Mathematica. > ***********************************************************************) > > (*CellTagsOutline > CellTagsIndex->{} > *) > > (*CellTagsIndex > CellTagsIndex->{} > *) > > (*NotebookFileOutline > Notebook[{ > Cell[1709, 49, 49, 1, 27, "Input"], > Cell[1761, 52, 170, 3, 43, "Input"], > Cell[1934, 57, 89, 1, 27, "Input"], > Cell[2026, 60, 110, 2, 27, "Input"], > Cell[2139, 64, 115, 2, 27, "Input"], > Cell[2257, 68, 72, 1, 27, "Input"], > Cell[2332, 71, 204, 4, 27, "Input"], > Cell[2539, 77, 110, 2, 27, "Input"], > > Cell[CellGroupData[{ > Cell[2674, 83, 168, 3, 27, "Input"], > Cell[2845, 88, 70, 1, 26, "Output"] > }, Open ]] > } > ] > *) > > > > > (*********************************************************************** > End of Mathematica Notebook file. > ***********************************************************************) > > > > Respectfully, Roger L. Bagula > > tftn at earthlink.net, 11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 : > URL : http://home.earthlink.net/~tftn > URL : http://victorian.fortunecity.com/carmelita/435/ > > > > -- Respectfully, Roger L. Bagula tftn at earthlink.net, 11759Waterhill Road, Lakeside,Ca 92040-2905,tel: 619-5610814 : URL : http://home.earthlink.net/~tftn URL : http://victorian.fortunecity.com/carmelita/435/