[Date Index] [Thread Index] [Author Index]

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/