Oneliner's Pie in the Sky

Oneliner's Pie in the Sky

This page is under development. Comments are welcome, but please load any comments in the comments section at the bottom of the page. Please include your wiki MONIKER and date in your comment with the same courtesy that I will give you. Aside from your courtesy, your wiki MONIKER and date as a signature and minimal good faith of any internet post are the rules of this TCL-WIKI. Its very hard to reply reasonably without some background of the correspondent on his WIKI bio page. Thanks, gold 12Dec2018


Introduction


gold Here are some one line procedures using pi (3.14...) and associated series or functions. I have modified a slot calculator in eTCL to handle these oneline procedures in the script at bottom of page. The user can add new algorithms by adding a new procedure in the code and adding a number line to the if statement that controls the algorithm selection The oneline procedures for generating PI can also be pasted into the eTCL console easily. There are some series for 1/N*N and 1/N*N*N*N which gives fractions of pi. Other functions for testing include eulers double prime probability ,the Monte Carlo random algorithm, and the strip integral of a quadrant. The accuracy of these individual solutions varies with the number of trials and the algorithms used are fairly slow, even glacial closers.


Because the calculator is checking the accuracy of the answers in the reporting bins, most of the oneliner procedures call for the number of terms or iterations along with the initial values. Now, lets define and pseudocode an error formula either by

       [ expr { 1 -(estimated)/( ideal & exact ) } ] or 
       if negative and not greater than one,    
       set error as [ expr   ( ideal & exact ) /   (estimated) -1. ] 

In the script, the exact answer is considered to be the pi constant stored in the TCL interpreter. If an algorithm reported pi to be 3.35 and greater than the exact answer as 3.141592 , the error formula would be (3.35/3.141592-1.)*100 or 6.6 per cent. If an algorithm reported pi to be 3.03 and less than the exact answer as 3.141592 , the error formula would be (1-3.03/3.141592)*100 or 3.3 per cent. Two comparison if statements in the TCL code select the proper error formula.


Experience in running the PI series calculator allows several observations. For example in selecting trials, the algorithm using ratio of gcd pairs to N trials needs about a million random pairs for 3 significant figures of pi. The Monte Carlo (random process) algorithm, as derived from the TCL random function, the x and y pairs that are digital fractions bounding a quadrant from 0 to 1 units height.


As might be expected, the algorithm based on random numbers do not return the same value of pi each time.


The successive prime in pairs algorithm is based on a variant to Euler's rule, testing if the ratio of one prime number found in successive N:N+1 pairs to N trials is about pi squared over 6. The user picks N as the number of trials on the list on positive integers. In the successive N:N+1 pairs, selecting N>70 might take considerable time checking for prime numbers.


The successive prime in pairs algorithm was easier to code, but is a little suspect because the integer numbers were not randomly chosen (as specified by the Euler rule for paired primes).

The strip integral area integrates the area of a quarter unit circle or quadrant from zero to X (1.0) to find pi. Since the area of a circle is pi*r*r, the quadrant for the unit circle would be pi*1*1/4 or pi/4. Given N as the number of strips, the width of each strip $ww would be 1 unit /N. The height of each strip would be sqrt(1-$ww*$ww), which in the unit circle procedes from one to near zero on the y axis. The area of each individual strip would be the product of the width ww and the height. The TCL script sums the individual strips to estimate the area of the quadrant. The strip integral algorithm is limited by the number of strips and it takes about 10,000 strips to find a reasonable pi. The user can select the N as the number of strips over the interval of zero to one units. However, selecting over 1000 strip intervals will take some processing time. The arctangent formula as atan(1/57)... seemed to give the best results and was selected as the default solution for pi.


A tally of microseconds has been added to the calculator under test.


The isprime procedure was posted DKF script by SKB and the gcdE procedure was posted by RS. See Buffon's Needle. DKF script on Sample Math Programs The genesis of the DKF Monte Carlo algorithm is found in Sample Math Programs.


     proc pietry {aa bb} {for {set i 1} {$i<=$bb} {incr i} { set aa [expr $aa +6./($i*$i) ]  } ;return [expr sqrt($aa)] }
    #usage  [ pietry 0 1000] answer is 3.14063

     proc piefourth {aa bb} {for {set i 1} {$i<=$bb} {incr i 2} { set aa [expr $aa +8./($i*$i) ]  } ;return [expr sqrt($aa)] }
     
      #usage; $t insert 1.0 " piefourth  [ piefourth  0 5000 ]     "  answer is 3.14146
 proc pitofourover90 {aa bb} {for {set i 1} {$i<=$bb} {incr i} { set aa [expr $aa +1./($i*$i*$i*$i) ]  } ;return $aa }
    # set answer [ pitofourover90 0 10 ];answer is pi**4/90. or 1.08013

     proc pietry4 {aa bb} {for {set i 1} {$i<=$bb} {incr i 1} { set aa [expr $aa +90./($i*$i*$i*$i) ]  } ;set aa [expr sqrt($aa)];return [expr sqrt($aa)] }

 #usage:pietry4 0 100,  answer is 3.141592

 proc atan5 {aa }  { return [expr {(1.*$aa)-(pow($aa,3)/3.)+(pow($aa,5)/5.)-(pow($aa,7)/7.)+(pow($aa,9)/9.)-(pow($aa,11)/11.) } ]  } 

 proc pietanic { } { return [expr 4.*44.*[atan5 [expr 1./57]]+4.*7.*[atan5 [expr 1./239]] -4.*12*[atan5 [expr 1./682]]+4.*24*[atan5 [expr 1./12943]] ]}

  #usage [pietanic ], returns 3.1415926535897922; appears to be accurate to 14 decimal places.

     proc isprime x {expr {$x>1 && ![regexp {^(oo+?)\1+$} [string repeat o $x]]}}
    #[SMH] returns 1 if prime and zero if not.,usage [isprime 23] has answer of 1 (one) [isprime 20] has answer of 0 (zero)
   
 proc primepi {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} { if { [isprime $i] || [isprime [expr $i+1] ]} {incr cc;}}; expr {sqrt(6./((1.*$cc)/($n*1)))}}
     #Usage:$t.text insert 1.0 " primepi   [primepi 50]   "  3.2163, not bad for a prime number algorithm
     # Here n is the nth positive integer from zero.
     # This algorithm was easier to code, but is a little suspect 
     #because the integer numbers were not randomly chosen
     # (as specified by the Euler rule for paired primes).

       proc ran {} {return [expr rand()]};

   proc montepi {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} {set x [ran ]; set y [ran]; if {($x*$x + $y*$y) < 1} {incr cc;}}; expr {4e0*$cc/$n}}#
   #usage: montepi 90, answer is 3.1555,
   # not bad for a Monte Carlo (random process) algorithm.
   # derived from the TCL random function, the x and y pairs that are digital fractions from 0 to 1.

     proc gcdE {a b} {expr {$b==0? $a: [gcdE $b [expr {$a%$b}]]}} #RS

   proc montepithon {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} {set x [expr {int(10000*[ran ])}];set y [expr {int(10000*[ran ])}] ;if {[gcdE $x $y]<2} {incr cc}; }; return  [expr {sqrt(6.*$n/$cc)}]  }
   #usage:[ montepithon  50 ], n is the number of trials or number of interger pairs tested.
   #answer varies from 2.97 to 3.27 on small trial of 50 integer pairs.
   # This ratio of gcd pairs to N trials needs
   # about a million pairs for 3 significant figures of pi.
   # This algorithm is based on Euler's rule
   # that ratio of trials to found gcd pairs is about pi squared over 6.

     proc listnumbers { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend booboo [ expr 1.* $i] };return $booboo}
      #returns list of integer numbers from aa to bb as reals with decimals,usage [listnumbers 1 5] , answwer is 1.0 2.0 3.0 4.0 5.0  
       proc listnumbersodd { aa bb} { for {set i 1} {$i<=$bb} {incr i 2} {lappend booboo [expr 1.*$i] };return $booboo}
       #returns list of odd numbers from aa to bb as reals with decimals, usage [ listnumbersodd 0 10],answer is 1.0 3.0 5.0 7.0 9.0
       proc listprimes { aa bb} { for {set i 1} {$i<=$bb} {incr i 2} { if {[isprime $i] } {lappend booboo [expr 1.*$i]   } };return $booboo}
    #returns list of prime numbers  from aa to bb, usage [listprimes 0 25],answer is 3.0 5.0 7.0 11.0 13.0 17.0 19.0 23.0
      proc euler4 {aa bb} {for {set i 1} {$i<=$bb} {incr i 1} { set aa [expr $aa+1./([fac $i]) ]  } ;return [expr (1.*$aa)] ; }
      #usage: $t insert 1.0 "euler number [ euler4 1 100 ]"; answer is 2.71828, procedure fac above should be loaded too.
     #The Gregory-Leibnez series for the arctan  has alternating powers of negative one.
     # arctan series = x - x^3/3 + x^5/5 - x^7/7 + ...
   # arctan(1)=pi/4 = x - x^3/3 + x^5/5 - x^7/7 + ...
  # substituting 1 for x
  # pi = 4.-4./3+4/5+4./7
 proc liebniz {aa bb} {console show;set i 1;while {$i <= $bb} {set dd [expr {2.*$i+1}];set ee [expr { (1.*pow(-1,$i)*1.)/ $dd }] ; puts $ee;set aa    [expr $aa + $ee];incr i;};return [expr 4.*$aa];}
 puts " [ liebniz 1 500 ]"

GWM time your results:

time {puts "[liebniz 1 50000]"}
3.141612653189785
16297000 microseconds per iteration

remove the puts $ee - 8 times faster:

proc liebniz {aa bb} {console show;set i 1;while {$i <= $bb} {set dd [expr {2.*$i+1}];set ee [expr { (1.*pow(-1,$i)*1.)/ $dd }] ; set aa    [expr $aa + $ee];incr i;};return [expr 4.*$aa];}
time {puts "[liebniz 1 50000]"}
3.141612653189785
2359000 microseconds per iteration

Brace your expr for 40 times faster still:

proc liebniz {aa bb} {console show;set i 1;while {$i <= $bb} {set dd [expr {2.*$i+1}];set ee [expr { (1.*pow(-1,$i)*1.)/ $dd }] ; set aa    [expr { $aa + $ee } ];incr i;};return [expr 4.*$aa];}
(Michel.GANDC9200) 7 % time {puts "[liebniz 1 50000]"}
3.141612653189785
63000 microseconds per iteration

Note that this timing is limited by my cpu clock to 16 ms accuracy (all my timings were multiples of 16 ms), so use ten times as many iterations:

time {puts "[liebniz 1 500000]"}
3.1415946535856922
531000 microseconds per iteration

OR use this version after removal of redundant operations (pow(-1,N) is bound to be slower than a simple choice:

  proc liebniz2 {aa bb} {console show;set i 1; set dd 1;while {$i <= $bb} {incr dd 2 ; set aa    [expr {$aa + ($i%2?-1.:1.)/ $dd}];incr i;};return [expr 4.*$aa];}

Again ten times the number of iterations:

time {puts "[liebniz2 1 500000]"}
3.1415946535856922
203000 microseconds per iteration

at least 2.5 times faster than the braced version of code.

Note that the first pass through the code requires the byte code compiler to compile (takes some time) so use the 2nd or subsequent run of the proc for accurate time dependence measurement.

   # arctan5 passes value in radians, aa is initial value, bb is number of terms or iterations.
   # needs at least 1000 iteratios to return a recognizable value of pi.
   proc arctan5 {aa bb} {console show;set i 1;set tt $aa;while {$i <= $bb} {set dd [expr {2.*$i+1}];set ee [expr { (1.*pow (-1,$i)*1.)*(pow($tt,$dd))/   $dd }] ; puts $ee;set aa [expr $aa + $ee];incr i;};return [expr 1.*$aa];}
    puts " [ arctan5 .5 10000 

 proc pi {args} [subst -novariable {expr [expr {atan2(0,-1)}] $args}]

 #finds equivalent diameter of circle that has same area of box or rectangle:aa and bb are sides of rectangle.
 #usage: set hexxx [box1 5 5];answer=5.6418
 proc box1 {aa bb } { set pie [pi]  ;return [ expr sqrt(($aa *  $bb*4 )/ ($pie))]}

AMG: What's the subst for? I would have done it this way:

proc pi {} {expr acos(-1)}

Also, there's no need for a temporary variable in [box1]. If you insist, be aware that it's perfectly legal for a proc and a variable to have the same name; you could have said "set pi [pi]". For safety and efficiency, always be sure to brace your expr-essions! Heh, I neglected to brace my expression in [pi], but that's one of the extremely rare cases where it won't matter: no spaces, no substitutions. Bracing does two things: One, when the entire expression is a single word (single argument), it can be bytecode-compiled. Two, if substitutions are performed by [expr] only and not Tcl itself, injection attacks are prevented.

proc box1 {aa bb} {expr {sqrt(($aa * $bb * 4) / [pi])}}

gold Your solution is more concise.


AMG: The return value of a Tcl procedure is inherited from the return value of the last command to execute within that procedure. Therefore, many uses of the [return] command are redundant. For example, this procedure:

proc anglecosa {a b c} {return [expr {($b*$b+$c*$c-$a*$a)/(2.*$b*$c)}]}

can be written more simply:

proc anglecosa {a b c} {expr {($b*$b+$c*$c-$a*$a)/(2.*$b*$c)}}

Also, the conditional arguments to [if], [while], [for] are already expr-essions, so there's no need to nest a call to [expr]. For example,

proc emmy2 {} {if {[expr {rand()}] <= 0.9} {return 1}}

can be simplified quite a lot:

proc emmy2 {} {if {rand() <= 0.9} {return 1}}

Screenshots Section

http://farm2.static.flickr.com/1351/4724107651_bf40e633dc.jpg

Comments Section

Please place any comments here, Thanks.

gold 30Jun2010,Changes. Added microssecond tally to calculator under test. Also added brackets to some of the expr statements.

References:


Appendix Code

appendix TCL programs and scripts

gold Here are one line procedures for fortran like "call" in eTCL, mostly altered proc from LV in Salt and Sugar page.

  console show
  proc pie {} {expr acos(-1)}
  proc writer {args } { puts $args }
  proc call {args} {uplevel catch [list $args]}
  call writer "jack" "&" "jill"
  call writer jack & jill went up the hill with [pie]

gold Here are some one line procedures for circle area and law of cosines.

   proc pi {} {expr {acos(-1)}}  #from AMG see below
   proc degtoradiansconst {} {return [ expr {180./[pi]}  ]}
   proc degz {} {return [ expr {180./[pi]}  ]}
   proc degx {aa} {return [ expr { [degz]*acos($aa) }  ]}
   proc inrad {a b c} {return  [expr {(sqrt(($a+$b+$c)*($a+$b-$c)*($a-$b+$c)*($b+$c-$a)))/(2.*($a+$b+$c)) } ] }
   proc circlediameter {radius} { return [ expr { 2.* $radius } ] }
   proc circlearea {radius} { return  [  expr { [pi]*($radius**2) }]}
   proc circlecircumference   {radius} {return [ expr {2.*[pi]*$radius }]}
   proc spherediameter  {radius}  {return  [ expr { 2.* $radius }]}
   proc spherevolume   {radius}  { return [ expr { (4./3.)*[pi]*($radius**3) }]}
   proc spheresurface    {radius} { return [ expr { 4.*[pi]*($radius**3) }]}
   proc cubevolume {aa}  { return [ expr { 1.*$aa*$aa*$aa } ] }
   proc squarearea  {aa}  { return [ expr { 1.*$aa*$aa } ] }
   proc ellipsoidvolume {aa bb cc} { return [ expr { 1.*(4./3.)*[pi]*$aa*$bb*$cc } ] }
   proc ellipsearea1 { aa bb } {return [ expr { 1.*[pi]*$aa*$bb  } ]}
   proc ellipseperimeterx {aa bb} { set tt [ expr { ($aa*$aa+$bb*$bb)/2.}];return [ expr { 2.*[pi]*sqrt($tt)} ] }
   proc spherevolumex {aa  } { return [ expr { 1.*(4./3.)*[pi]*$aa*$aa*$aa } ] }
   proc spheroidvolumex {aa cc } { return [ expr { 1.*(4./3.)*[pi]*$aa*$aa*$cc } ] }
   proc torusvolumex {aa bb }  { return [ expr {(1./4.)  *[pi]*[pi] * ($aa + $bb) * ($aa - $bb)*2.}] }
   proc torussurfacex {aa bb }  { return [ expr { [pi]*[pi] *  ($aa*$aa - $bb*$bb) }] } 
   proc conesurfacex {aa rr }  { return [ expr { [pi]*$rr*$aa}] }
   proc cylindersurfacesidex {aa rr }  { return [ expr {2.* [pi]*$rr*$aa}] }   
   proc cylinderwholesurfacesidex {aa rr }  { return [ expr {2.* [pi]*$rr*$aa +2.*[pi]*$rr*$rr}] }   
   proc cylindervolumesidex {aa rr }  { return [ expr { [pi]*$rr*$rr*$aa}] } 
   proc conevolumex {aa rr }  { return [ expr { (1./3.)*[pi]*$rr*$rr*$aa}] } 
   proc pyramidvolumex {aa bb cc }  { return [ expr { (1./3.)*$aa*$bb*$cc  }] } 
   proc rectangularprismvolumex {aa bb cc }  { return [ expr { $aa*$bb*$cc  }] } 
   proc triangularprismvolumex {aa bb cc }  { return [ expr { $aa*$bb*$cc*.5  }] } 
   proc polygonperimeterx {aa bb }  { return [ expr { $aa*$bb}] } 
   proc rectangleperimeterx {aa bb }  { return [ expr {2.*( $aa+$bb)}] } 
   proc parallelogramperimeterx {aa bb }  { return [ expr {2.*( $aa+$bb)}] } 
   proc triangleperimeterx {aa bb cc}  { return [ expr { $aa+$bb+$cc }] } 
   proc triangletrapezoidx {aa bb cc}  { return [ expr { $aa*($bb+$cc)*(1./2.) }] }
   #law of cosines, aa bb cc are three sides of right triangle, here ordered 
   #as aa small side , bb middle side, cc largest side.
   # inrad is radius of cirle inscribed in right triangle,
   # use sides as inrad aa bb cc 
   proc anglecosa  { aa bb cc } {return [ expr {  ($bb*$bb+$cc*$cc-$aa*$aa)/(2.*$bb*$cc) }]}
   proc anglecosb { aa bb cc }  {return [ expr {  ($cc*$cc+$aa*$aa-$bb*$bb)/(2.*$aa*$cc) }]}
   proc anglecosc { aa bb cc } { return [ expr {  ($aa*$aa+$bb*$bb-$cc*$cc)/(2.*$aa*$bb) }]}
   #with examples
   #for radius of 1
   #circlediameter 1 
   #circlearea 1  
   #circlecircumference 1  
   #spherediameter 1   
   #spherevolume 1 
   #spheresurface 1 
   #inrad 3 4 5 
   #anglecosa 3 4 5 
   #anglecosb 3 4 5  
   #anglecosc 3 4 5  
   

gold Here are some one liners for "chance of" conditions. The "chance of" procedures make use of the random function and do not return the same answer everytime.

  proc emmy  aa  {expr {rand()<.9? 1 : 0 }}
  proc emmy2 aa { if { [ expr { rand() } ] <= .90 } {return 1 }}
  if { [ expr { rand() } ] <= .90 } {set immigrantyear  1 }
  proc plaguex  aa  {expr {rand()<.15? 1 : 0 }}
  if { [ expr { rand() } ] <= .15 } {set plaguethisyear 1 }
  # There is a 15 percent chance of plague this year
  # with random casualities up to 10 percent of population.
  proc plaguelossx aa {expr {rand()<.15? int($aa*.1*rand()) : 0 }}
  proc ratx  aa  {expr {rand()<.41? 1 : 0 }}
  if { [ expr { rand() } ] <= .41 } {set ratinfestthisyear 1 }
  set ratliters  [ expr { $liters*.1*rand()   } ]
  set ratliters [ expr { int($ratliters) } ] 
  set sumariansstarved [ expr { $sumarians*.02*rand()   } ]
  set sumariansgain aa {expr {rand()<.15? $aa*.1*rand() : 0 }}
  set sumariansgain   [ expr {  $sumarians  * .10 * rand() } ]  
  set sumariansgain   [ expr {  int($sumariansgain) } ] 
  set sumarians [ expr { $sumarians + $sumariansgain   } ]

gold Here are some one liner procedures grabbing mantissas, either with zero point or without. A format statement can hide some artifacts of binary computer arithmetic. Once defined in the computer, these routines can be doubled up, [ mac [ mak 4.666 ]. And proc Macomma with regexp {.,(\d+)} will cure the european comma decimal syndrome.

     proc mac {aa} { regexp {.(\d+)} $aa -> bb;return $bb }
     proc macomma {aa} { regexp {.,(\d+)} $aa -> bb;return $bb }
    console session
    3% proc mac {aa} { regexp {.(\d+)} $aa -> bb;return $bb }
    4% mac 4.55555
    55555
    6%  proc mic {aa} { return [expr { fmod($aa,1.)   } ] }
    7% mic 4.222
    0.22200000000000042


    10% proc mak {aa} { return [ expr { $aa - int($aa) } ] }
    11% mak 4.666
    0.6660000000000004


   8% proc mak {aa} { return [format "%12f" [ expr { $aa - int($aa) } ]] }
   9% mak  4.666
    0.666000

gold Here is one liner procedure developing simple error as percentage.

  #proc errorx always returns a positive error. 
  #Normally assume $aa is human estimate,
  #assume $bb is divinely exact. 
        proc errorx  {aa bb} {expr { $aa > $bb ?   (($aa*1.)/$bb -1.)*100. : (($bb*1.)/$aa -1.)*100.}}
     console session
     9% errorx 3.1 3.14
        1.2903225806451646
     10% errorx 3.14 3.1
        1.2903225806451646
     11% errorx 3.03 3.141592
        3.6829042904290565

gold Here is some one liner procedures for various error function approximations, though "not ready for the mars shot" and dependent on helper procs.

     proc erffunc { xx } { return [ expr { (2 / [ piesq  ]) * ((1)*(pow($xx,9))/([facx 4]*9)+(-1)*(pow($xx,7))/([facx 3]*7)+(1)*(pow($xx,5))/([facx 2]*5)+(-1)*(pow($xx,3))/([facx 1]*3) + $xx  ) }  ]};# large terms only
      #proc erffunc_1st_term { xx } { return [ expr { (2 / [ piesq ]) * ( $xx ) }  ]};# first term only on this line
      #proc erffunc_large_terms { xx } { return [ expr { (2 / [ piesq  ]) * ((1)*($xx*$xx*$xx*$xx*$xx)/(2*5)+ (-1)*($xx*$xx*$xx*$xx*$xx*$xx*$xx)/(6*7)+(-1)*($xx*$xx*$xx)/(1*3) + $xx  ) }  ]};# large terms only
      # usage, set test5 [ erffunc ];# test5 ~~ 0.5205
      #gold, 27Apr2007, working on etcl and windows xp
      proc facx n {expr {$n<2? 1:$n>20? $n*($n-1): $n * [facx [incr n -1]]}}
      # stopped at factorial greater than 20
      proc gm {args} { return [expr [expr .5*(1+sqrt(5))] $args]}
      #gold, golden mean, usage [gm] [gm /4]
      proc pi {args} [subst -novariable {
     expr [expr {atan2(0,-1)}] $args
     }]
      #wdb,usage [pi] [pi /4]
      proc piesq {args} { set pie [pi] ; return [ expr sqrt($pie) ]}
      proc degrad {argx} {return [expr 180 / [ pi ]]}; 
      proc raddeg {argx} {return [ expr [ pi ] / 180 ]}; 
      #Used to have a whole set of engr math functions in
      #javascript, based on subformulas/procs like RS's [factorial]
      #and wdb's proc for [constant] .

See factorial for discussion.


gold Here is a one liner procedure for sum of infinite geometric series, though the explanation and examples take up more than one line.

      proc geoseries1 {aa bb cc} { if {$bb <= -1||$bb >= 1} { return 0} ;return [ expr $aa / ( 1 - $bb ) ]};
      # 27Apr2007,gold,works with etcl
      # convergent geometric series if $a != 0 and -1 > $r < 1
      # $a is constant multiplier, $r is fraction under exp.
      # Series is undefined if r< -1 or r > 1
      # Holding $cc open for number of terms in partial sum.
      # If divergent, proc returns zero,
      #usage,set test5 [ geoseries1 15 .2857 1 ];#test5~~21
      #usage,set test5 [ geoseries1 15 -1.2857 1 ];#test5~~zero
      #usage,set test5 [ geoseries1 15 1.2857 1 ];#test5~~zero
      #Lets adapt AM's more concise procedure from below 
      #for the partial sum of a geometric series.
      proc geoseries3 {aa bb {cc -1}} {expr {abs($bb)<1? ($aa/(1.0-$bb))-([expr {$cc>0}]*$aa*pow($bb,$cc))/(1-$bb) : 0.0}}
      #usage,set test5 [ geoseries3 15 .2857 1 ];#test5~~15
      #usage,set test5 [ geoseries3 15 .2857 4 ];#test5~~20.8597
      # Now, lets define and pseudocode an error formula as
      # [ expr { 1 -(estimated)/( ideal & exact ) } ] or 
      # [ expr {1 - (partial sum of n terms)/(total sum of infinite terms) } ]  
      #set error [expr {1-[ geoseries3 15 .2857 5 ] / [ geoseries3 15 .2857 ] }];# using default args on later.
      # error with 5 terms approaches .002;# error with 7 terms approaches .00015
      # Vola, more than 7 terms exceeds "slide rule accuracy".     

AM This can be compacted even more:

      proc geoseries {aa bb} {expr {abs($bb)<1? $aa/(1.0-$bb) : 0.0}

(What is cc in the original?)

gold $cc is number of terms for partial sum. Count your braces {odd or even ?}.


gold These one line procedures were developed on older versions of TCL4. I do not doubt that alternate solutions or better solutions exist on the later elaborate TCL releases. Mostly I use etcl on an older personal computer. Some of these single line procedures are easier to patch a TCL procedure rather than learn a new grammar. Usually the procedure are called with a set statement like

  set examplenumber  [parresistor2 { 25 35 } ]

or

  set examplestring [ whitelist examplestring ]

.

     proc plainsub {text item replacewith} {
     set text [string map [list $item $replacewith] $text]
      }
     proc %+ {a  } {return [string toupper $a]; #%+ tree >TREE }
    proc %- {a  } {return [string tolower $a]; #%+ Tree >tree  }
    proc %++ {a b} {return $a$b;#%+* tree root  >treeroot }
     proc %-- {a b} {regsub $b $a "" a; return $a;#%-- 5 7>5 }
     proc %% {a b} {regsub -all $b $a "";#%% tree root  >tree }
   proc %1 {a b} {regsub $b $a "" a; return $a;#%1 tree root>tree }
    proc %2 {a b} {regsub $b $a "" a;regsub $b $a "" a; return $a;#%2 tree root>tree }
     proc %3 {a b} {regsub $b $a "" a;regsub $b $a "" a;regsub $b $a "" a; return $a;#%3 tree root>tree}
      proc %2x  {a} {return $a$a;#%2x tree>treetree}
      proc %3x  {a} {return $a$a$a;#%3x tree>treetreetree}
       proc %4x  {a} {return "$a,$a,$a";#%5x tree>tree,tree,tree }
       proc %5x  {a} {return "$a $a $a";#%5x tree>tree tree tree } 
      proc repeat {n body} {while {$n} {incr n -1; uplevel $body}}
      proc random n {expr {round($n*rand())}}
      proc whitelist {a} {return [lreplace $a 0 -1];#take string,return list without blanks}
      set k [split {abcdefghijklmnopqrstuvwxyz} {}]
      # eraser procedures for positive and negative numbers
     proc eggy {bb} {if {$bb <= 0 } { return 0} ;return  $bb  };# deletes negative numbers
     proc neggy {bb} {if {$bb >= 0 } { return 0} ;return  $bb  };#deletes positive numbers
     proc zergy {bb} {if {$bb == 0 } { return 0} ;return  $bb  };#deletes zero numbers

     proc  neggabs {bb} {if {$bb <= 0} { return [ expr $bb * -1]} ;return  0  };
      #deletes positive numbers and returns absolute value of negatves
         # formula for two parallel resistors of resistance aa and bb ohms.
     proc parresistor2 {aa bb } { return [ expr (($aa *  $bb )/ ($aa + $bb))]}
     #usage: set resistor [ parresistor 100 100  ];answer is 50.
   # formula for three parallel resistors of resistance aa, bb,  and cc ohms.
    proc parresistor {aa bb cc } { return [ expr (($aa *  $bb * $cc)/ ($aa*$bb+$aa*$cc+$bb*$cc))]}
     #usage: set resistor [ parresistor 100 100 100 ];answer is 33
   # formula for fet transistor of volttage 0.009 volts and resistance bb ohms.
  proc fetvolts {aa bb } { return [ expr ($aa *  $bb )]}
      # fet transistor load usage: set fetvolts [ .009 2500 ];answer is 22.5
     # formula for fet transistor of volttage 0.009 volts, resistance bb ohms, cc and dd volts.
    proc fetdrainvolts {aa bb cc dd } { return [ expr ($aa *  $bb + $cc +  $dd)]}
      # fet transistor usage: set fetdrainvolts [ .009 2500 7 5 ];answer is 34.5
      # thin film resistor of dimension aa length and ww width, and sheet resistance cc
      proc thinfilmresistor {aa ww cc } { return [ expr (($aa * $cc)/ ($ww*1.))]}
      #usage ;thinfilmresistor of length 0.8 cm,   width 0.2 cm, and sheet resistance of 150 ohms
       # set resistance2 [ thinfilmresistor {.8 .2 100 } ] ;#answer is 600 ohms
        # efficiency and output of electric motor with one horsepower for 746 watts.
       proc electrichorsepower  {aa bb cc } { return [ expr (($aa *  $bb * $cc)* (1./746.))]};#horsepower
         # efficiency as 0.8 no_units, voltage as 25 volts, and input current as 10 amps
        # The scale factor would be (1./746.) horsepower per watt.
         #usage:append  details " [ electrichorsepower  .8 25 10  ]  " ;#answer is 0.268 horsepower
       # formula for cascaded efficiency for n1 *n2 * n3 
          proc   cascadedefficiency  {aa bb cc } { return [ expr (($aa *  $bb * $cc)* (100./1.))]};# 
        #example for n1 = 85 percent, n2 equals 90 percent,and n3 equals 73 percent and scale factor 100./1.
     # set  exampleproblem [ cascadedefficiency   .85 .90 .73    ] #answer is 56 percent.

gold Here is the one liner procedure on the age of the earth.

      #Lord Kelvin calculated the age of the earth by approximating the cooling of an molten iron sphere.
      # heating of radioactive elements in earth's crust was not considered.
      # following assumptions crust thermal defusivity $cc is 1.5E-6 meters/sec*sec,
      # As a alternate defusivity estimate, Sandstone is about 1.1E-6 meters/sec*sec. 
      # alpha $dd is 0.04 degrees centigrade per meter
      # initial temperature $aa was 2500 centgrade degrees ,
      # final temperature $bb was near zero degrees centigrade.$ee was number seconds in year was 3156000 seconds.
      proc kelvinearthtempage {aa bb cc dd ee} { return [ expr (($aa -  $bb)*($aa -  $bb)/ ( $cc * [pi]*  $dd* $dd*$ee))]}
      # Kevin estimated a low and high age estimate of 25 million years and 100 million years, respectively.
      #usage: low estimate: set age_of_earth " [  kelvinearthtempage 2500 .1 .0000015 .04  31536000.  ] ";#answer 26 million years
      #usage: high estimate could be:  set age_of_earth " [  kelvinearthtempage 5100 .1 .0000015 .04  31536000.  ] ";#answer 110 million years

gold Here is the one liner approach to the Fibbonaci series. However, the algorithms are limited to positive numbers only. Performance may suffer degradation due to lengthy calls and limits on the number of procedure recursion calls. See Fibonacci numbers and math::constants.

      proc fib {n} { if {$n < 2} then {expr {$n}} else {expr {[fib [expr {$n-1}]]+[fib [expr {$n-2}]]} }}
      #usage: $x.text insert 1.0 " goo  [  fib 8  ] " or answewr is 21
      # usage     set xat [fib 10] or answwer is 55
      # usage     set zat [fib 11] or answer is 89
      # Now, lets define and pseudocode for formula of golden section as
      # fib N+1 / fib Nth  and substitute fib 11 / fib 10
      # for rough estimate of golden section: set gat [ expr {    ($zat*1.)   /   ($xat*1.)   } ]
      # answer was 1.6181818 whereas the exact value was (1+sqrt(5))/2 (approx 1.6180339887)

      # from the procedure with the exact formula.
      proc gm {args} { return [expr [expr .5*(1+sqrt(5))] $args]}
      #gold, golden mean, usage [gm] [gm /4]
      
       
     # Now, lets define and pseudocode an error formula either by
      # [ expr { 1 -(estimated)/( ideal & exact ) } ] or 
      # if negative and not greater than one,    
      # set error as [ expr   ( ideal & exact ) /   (estimated) -1. ] 
      
     
        set dat [ expr { (( ($zat*1.) / ($xat*1.)) / [ gm *1. ] -1.) } ]or 0.0000913
       # Meaning the ratio of the 10 and 11th terms approach the limit by 0.0000913 error 

AMG: Here's another implementation, using expr's ?: operator instead of if:

       proc fib {n} {expr {$n < 2 ? $n : [fib [expr {$n - 1}]] + [fib [expr {$n - 2}]]}}

gold Here is mathops & mathlib follow-on to the one liner approach to the Fibbonaci series, using Binet formula for fibonacci (N). See Fibonacci numbers. The library call is ::math::Fibonacci (N).

    proc listfib { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend booboo [ int [ binet $i] ] };return $booboo} 
    proc binet { n} {set n [int $n ]; return [int [*  [/ 1 [sqrt 5]]  [- [**  [/   [+ 1 [sqrt 5]] 2 ] $n ]  [** [/   [- 1 [sqrt 5]] 2 ]  $n ] ] ] ] } 
    # usage,  set binet1  [ binet 8]  # answer 21,   removing int's will return real numbers
    # usage,  set fibno  [ listfib 1 8 ], answer 1 1 2 3 5 8 13 21 
    proc fibonacci_approx_for_large_N {n} { set phi [/   [+ 1 [sqrt 5]] 2 ]  ; return [round [/  [** $phi  $n   ] [sqrt 5 ]]] } # test only, not sure for all N
    listfib 1 20
    1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765

gold Here is the one liner approach to area of cyclic quadrilateral, using mathops & mathlib calls. The four sides are aa, bb, cc, and dd, ref Brahmagupta Area of Cyclic Quadrilateral and eTCL demo example calculator. .

            proc perimeter {aa bb cc dd } {return [+ $aa $bb $cc $dd ]}
            proc semip {aa bb cc dd } {return  [* [+ $aa $bb $cc $dd ] .5] }
            set semip [ semip ]
            proc reference_factor {aa bb cc dd } {return [/ [+ [* $aa $aa ] [* $bb $bb ]] [+ [* $cc $cc ] [* $dd $dd ]]]}
            proc cyclic_quad_area {aa bb cc dd } {return [sqrt [* [- $semip $aa ] [- $semip $bb ] [- $semip $cc ] [- $semip $dd ]]] }                   

gold Following one liners are decimal equivalent to some Babylonian tables, using mathop here from Babylonian Cubic Equation Problem and eTCL demo example calculator, numerical analysis .

    #   following one liners are decimal equivalent to some Babylonian tables
    #   possible cubic problem instances include separate tables for  cubes n*n*n and quasi_cubes
    #   quasi_cube n*n*(n-1), quasi_cube n*(n + 1)*(n + 2), quasi_cube  n*n*(n + 1), quasi_square n*(n+1)   
    #   list_integers is list of positive integers, 1 2 3 4 ... n
    proc list_integers { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [*  $i  1.]};return $boo}  
    # usage, list_integers 1 10
    # 1.0  1.0 2.0 2.0 3.0 3.0 4.0 4.0 5.0 5.0 6.0 6.0 7.0 7.0 8.0 8.0 9.0 9.0 10.0 10.0
    #  list_reciprocals is list of 1/1 +1/2 1/3 1/4 ... 1/n
    proc list_reciprocals { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [/  1. $i  ]};return $boo}
    # usage, list_reciprocals 1 10    
    # 1.0 1.0 2.0 0.5 3.0 0.333 4.0 0.25 5.0 0.2 6.0 0.166 7.0 0.142 8.0 0.125 9.0 0.11 10.0 0.1
    # list_squares is list of integer squares, 
    proc list_squares { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [*  $i  $i  ]};return $boo}
    # usage, list_squares 1 10  
    # 1.0 1 2.0 4 3.0 9 4.0 16 5.0 25 6.0 36 7.0 49 8.0 64 9.0 81 10.0 100
    # quasi_cube2 is n*(n)*(n-1)
    proc list_quasi_cube2 { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [*  $i  $i [- $i 1]]};return $boo}
    # usage, list_quasi_cube2  1 10   
    # 1.0 0 2.0 4 3.0 18 4.0 48 5.0 100 6.0 180 7.0 294 8.0 448 9.0 648 10.0 900
    # quasi_cube3 is n*(n+1)*(n+2)
    proc list_quasi_cube3 { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [*  $i  [+ $i 1] [+ $i 2]]};return $boo}
    # usage list_quasi_cube3   1 10
    # 1.0 6 2.0 24 3.0 60 4.0 120 5.0 210 6.0 336 7.0 504 8.0 720 9.0 990 10.0 1320
    # quasi_cube4 is n*(n)*(n+1)
    proc list_quasi_cube4 { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [*  $i  $i [+ $i 1]]};return $boo}
    # usage, list_quasi_cube4 1 10
    # 1.0 2 2.0 12 3.0 36 4.0 80 5.0 150 6.0 252 7.0 392 8.0 576 9.0 810 10.0 1100
    # quasi_square2 is  n*(n+1), 
    proc list_quasi_square2 { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [*  $i  [+ $i 1]]};return $boo}
    # usage, list_quasi_square2 1 10
    # 1.0 2 2.0 6 3.0 12 4.0 20 5.0 30 6.0 42 7.0 56 8.0 72 9.0 90 10.0 110
    # list_sum_integers 
    proc list_sum_integers { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [/  [*  $i  [+ $i 1] ] 2. ]};return $boo}
    # usage, list_sum_integers 1 10
    #1.0 1.0 2.0 3.0 3.0 6.0 4.0 10.0 5.0 15.0 6.0 21.0 7.0 28.0 8.0 36.0 9.0 45.0 10.0 55.0
    # list_sum_squares 
    proc list_sum_squares { aa bb} { for {set i 1} {$i<=$bb} {incr i} {lappend boo [* 1. $i ] [/ [*  $i  [+ $i 1.] [+ [* $i 2.]  1.]] 6.]};return $boo}
    # usage list_sum_squares 1 10
    # 1.0 1.0 2.0 5.0 3.0 14.0 4.0 30.0 5.0 55.0 6.0 91.0 7.0 140.0 8.0 204.0 9.0 285.0 10.0 385.0

gold Here is an TCL program using one line procedures for the eTcl console. This modifies the sum of list procedure from RS in the Zen of Tcl and Elegance vs. performance and see reference Math Operators as Commands The recursive multiplication seems a useful procedure for the TCL calculators, as well as the reciprocal procedure (!1/ below). Assuming at least two arguments, the reciprocal procedure !1/ 1 2 would give the sum of 1/1 and 1/2 or 1.5 Checked some of the trivial arguments, but not all (eg. !* 0 = 0, !- 0 = 0, !/ 0 = 0,!1/ 1 = 1,!+ 1 = 1,!* 1= 1 )

    # working under TCL version 8.5.6 and eTCL 1.0.1
    # gold on TCL WIKI , 24may2011
    console show
    set lister { 1 2 3 }
    proc sum list {expr [join $list +]} ;#RS
    proc !+ args { expr [join $args +] }
    proc !* args { expr [join $args *] }
    proc !- args { expr [join $args -] }
    proc !/ args { expr [join $args *1./] }
    proc !1/ args { expr [ join $args  +1./ ]}
    proc %+ lister {expr [join $lister +]}
    proc %* lister {expr [join $lister *]}
    proc %- lister {expr [join $lister -]}
    proc %/ lister {expr [join $lister *1./]}
    puts " args cmds take form of !+ 1 2 3 or !/ 1 2 3"
    puts " list cmds take form of %+ \$lister"
    puts " or %* \$lister  or %- \$lister or %/ \$lister " 
 #console output
 3% !* 1 2 3
 6
 4% !/ 1 2 3
 0.16666666666666666
 5% !- 1 2 3
 -4
 6%  !1/ 1 2 
 1.5
 7% %/ $lister
 0.16666666666666666
 8% %- $lister
 -4
 9% %* $lister
 6
 10% %+ $lister
 6

RLE (2011-06-25) Most of the directly above procs are already provided as part of Tcl 8.5 (with the one exception that if one wants a floating point answer, at least one input has to be a floating point number):

% namespace path {::tcl::mathop ::tcl::mathfunc}
% + 1 2 3
6
% / 1.0 2 3 
0.16666666666666666
% - 1 2 3 
-4
% set lister [ list 1.0 2 3 ]
1.0 2 3
% / {*}$lister
0.16666666666666666
% - {*}$lister
-4.0
% * {*}$lister
6.0
% + {*}$lister
6.0

Slot_Calculator_PIE

FIRST VERSION

            #!/usr/bin/env wish
            # finding PI from series notation
            # code from TCL Club Slot_Calculator_Demo
            # 5Jan2009, gold on TCL Club
            # pretty print from autoindent and ased editor
            # comment follows on 12dec2018 from gold
            # finding PI from series notation V2
            # written on Windows XP on eTCL
            # working under TCL version 8.6
            # Revamping older program from 5Jan2009.
            # One of my early programs on the wiki,
            # but I believe the pie routines
            # and pie content might have some interest (to me).
            # gold on TCL Club, 12dec2018
            package require Tk
            set reportcard "ready"
            set reportcard2 "zero entry detected !!! "
            label .title -text "PI Series Calculator" -font {Times 15 bold} -relief raised -fg blue -bg seashell3
            frame .puzzle -bg aquamarine4
            frame .f1
            frame .f2
            frame .f3
            frame .f4
            frame .f5
            set colorgrd seashell4
            set colorback bisque
            set colorwarning tomato1
            label .l1 -text "initial N or Nth" -background seashell1 -width 25 -anchor w
            entry .e1 -textvariable side1  -background $colorback
            pack .l1 .e1 -in .f1 -side left
            label .l2 -text "upper N2 terms" -background seashell2  -width 25 -anchor w
            entry .e2 -textvariable side2  -background $colorback
            pack .l2 .e2 -in .f2 -side left
            label .l3 -text "algorithm 1,2,3,...6  " -background seashell3 -width 25 -anchor w
            entry .e3 -textvariable side3  -background $colorback
            pack .l3 .e3 -in .f3 -side left
            label .l4 -text "answer  " -background seashell2 -width 25 -anchor w
            entry .e4 -textvariable answer2  -background $colorback
            pack .l4 .e4 -in .f5 -side left
            pack .f1 .f2 .f3 .f5 -in .puzzle -side top -expand 1
            frame .answer -bd 2 -relief ridge -bg aquamarine4
            proc Scrolled_Text { f args } {
                frame $f
                eval {text $f.text -wrap word \
                            -xscrollcommand [list $f.xscroll set] \
                            -yscrollcommand [list $f.yscroll set]} $args
                scrollbar $f.xscroll -orient horizontal  \
                        -command [list $f.text xview]
                scrollbar $f.yscroll -orient vertical  \
                        -command [list $f.text yview]
                grid $f.text $f.yscroll -sticky news
                grid $f.xscroll -sticky news
                grid rowconfigure $f 0 -weight 1
                grid columnconfigure $f 0 -weight 1
                return $f.text
            }
            global t x
            set t [Scrolled_Text .eval -width 20 -height 5 -bg bisque]
            set x [Scrolled_Text .eval2 -width 20 -height 5 -bg bisque]
            pack .eval .eval2 -fill both -expand true -side left -in .answer
            $t insert end  " identified1 !!![ winfo children . ]"  ;
            $x insert end  " identified2 !!! [ winfo children . ]"  ;
            focus $t
            focus $x
            pack .answer  -in .puzzle -side bottom -pady {10 0}
            frame .buttons -bg aquamarine4
            ::ttk::button .calculator -text "Solve" -command { calculate  side1 side2 side3 }
            ::ttk::button .test2 -text "Testcase1" -command {testcasexxxx 0 100 1 3.14}
            ::ttk::button .test3 -text "Testcase2" -command {testcasexxxx 50 1000 2 3.14}
            ::ttk::button .test4 -text "Testcase3" -command {testcasexxxx 100 1000000 3 3.14}
            ::ttk::button .clearallx -text clear -command {clearall  }
            ::ttk::button .about -text About -command About
            ::ttk::button .self_help -text self_help -command { self_help }
            ::ttk::button .exit -text exit -command {exit}
            pack .calculator  -in .buttons -side top -padx 10 -pady 5
            pack  .clearallx .self_help .about .exit .test4 .test3  .test2   -side bottom -in .buttons
            grid .title - -pady 10 -padx 10 -ipadx 10
            grid .puzzle .buttons -sticky ns -pady {0 10}
            proc testcasexxxx { de1 de2 de3 wer } {
                # testcase is side of 5 units and 30 units
                # result or product is 150 units
                global side1 side2 side3 answer2 x t
                set answer2 ""
                set answer5 ""
                set side1 $de1
                set side2 $de2
                set side3 $de3
                set answer2 " testcase, ans=$wer "
                $x insert 1.0 " testcase entered, answer = $wer "
                $t insert 1.0 " testcase entered, answer = $wer "
            }
            proc clearall {} {
                global colorwarning
                global colorback
                global side1 side2 side3 answer2 x t
                set side1 ""
                set side2 ""
                set side3 ""
                set answer2 ""
            }
            proc sumsquares { args } {
                set sum 0
                foreach item  $args  {
                    if {$item == ""} {set item "0"}
                    incr sum [ expr { $item * $item } ]
                }
                return [ expr { sqrt($sum) }   ]
            }
            proc pietanic2 { side1  side2  side3} {
                if {$side3 == "1"} { return [  pietry4  $side1 $side2]}
                if {$side3 == "2"} { return [  montepi $side1 ]}
                if {$side3 == "3"} { return [  montepithon  $side1 ]}
                if {$side3 == "4"} { return [  pietanic  ]}
                if {$side3 == "5"} { return [  primepi $side1  ]}
                if {$side3 == "6"} { return [  pietry  $side1 $side2]}
                # default to pietanic if not 1,2,3
                return [ pietanic  ]
            }
            proc calculate {  ide1  ide2  ide3  } {
                global colorwarning
                global colorback
                global answer2 x t
                global side1 side2 side3
                set answer2 ""
                set xside1 $side1
                set xside2 $side2
                set xside3 $side3
                #set answer2 [ sumsquares $side1 $side2 $side3 ]
                set answer2 [ pietanic2 $side1 $side2 $side3]
                $x insert 1.0 "$side1 $side2 $side3, answer = $answer2 "
                $t insert 1.0 "$side1 $side2 $side3, answer = $answer2 "
            }
            proc About {} {
                set msg "Calculator for pi series.
                testing on series accuracy."
                tk_messageBox -title "About" -message $msg
            }
            proc self_help {} {
                set msg " finding PI from series notation V2
                from TCL ,
                # self help listing
                # problem, finding PI from series notation V2
                # 3 givens follow.
                1) initial N or Nth:
                2) upper N2 terms:
                3) algorithm 1,2,3,...6:
                # Recommended procedure is push testcase
                # and fill frame,
                # change first three entries etc,
                # and then push report.
                # >>> copyright notice <<<
                # This posting, screenshots, and TCL source code is
                # copyrighted under the TCL/TK license terms.
                # Editorial rights and disclaimers
                # retained under the TCL/TK license terms
                # and will be defended as necessary in court.
                # algorithm list, 6 algorithms_subroutines so far.
                # 1  pietry4
                # 2  montepi
                # 3  montepithon
                # 4  pietanic
                # 5  primepi
                # 6  pietry
                # default to pietanic if algorithm not entered
                # Each algorithm has individual conditions and
                # defaults, and may use entries in alternate ways.
                # The intent was to be flexible to user selection.
                # 12Dec2018. Revamping older program fm 9Jan2009.
                # gold on  TCL Club, 12Dec2018 "
                tk_messageBox -title "Self_Help" -message $msg }
            # algorithms for test
            proc atan5 {aa }  { return [expr {(1.*$aa)-(pow($aa,3)/3.)+(pow($aa,5)/5.)-(pow($aa,7)/7.)+(pow($aa,9)/9.)-(pow($aa,11)/11.) } ]  }
            proc pietanic { } { return [expr 4.*44.*[atan5 [expr 1./57]]+4.*7.*[atan5 [expr 1./239]] -4.*12*[atan5 [expr 1./682]]+4.*24*[atan5 [expr 1./12943]] ]}
            proc ran {} {return [expr rand()]};
            proc montepi {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} {set x [ran ]; set y [ran]; if {($x*$x + $y*$y) < 1} {incr cc;}}; expr {4e0*$cc/$n}}
            # usage: montepi 90, answer is 3.1555,
            # not bad for a Monte Carlo (random process) algorithm.
            # derived from the TCL random function, the x and y pairs that are digital fractions from 0 to 1.
            # montepi will hardly fire on less than 10 cases.
            # montepi answer varies from 2.97 to 3.27 on small trial of 50
            proc gcdE {a b} {expr {$b==0? $a: [gcdE $b [expr {$a%$b}]]}};#RS
            proc montepithon {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} {set x [expr {int(10000*[ran ])}];set y [expr {int(10000*[ran ])}] ;if {[gcdE $x $y]<2} {incr cc}; }; return  [expr {sqrt(6.*$n/$cc)}]  }
            # usage:[ montepithon  50 ], n is the number of trials or number of interger pairs tested.
            # answer varies from 2.97 to 3.27 on small trial of 50 integer pairs.
            # This ratio of gcd pairs to N trials needs
            # about a million pairs for 3 significant figures of pi.
            # This algorithm is based on Euler's rule
            # that ratio of trials to found gcd pairs is about pi squared over 6.
            # montepithon will hardly fire on less than 10 cases.
            proc pietry4 {aa bb} {for {set i 1} {$i<=$bb} {incr i 1} { set aa [expr $aa +90./($i*$i*$i*$i) ]  } ;set aa [expr sqrt($aa)];return [expr sqrt($aa)] }
            #usage:pietry4 0 100,  answer is 3.141592
            proc isprime x {expr {$x>1 && ![regexp {^(oo+?)\1+$} [string repeat o $x]]}}
            proc primepi {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} { if { [isprime $i] || [isprime [expr $i+1] ]} {incr cc;}}; expr {sqrt(6./((1.*$cc)/($n*1)))}}
            #Usage:$t.text insert 1.0 " primepi   [primepi 50]   "  3.2163, not bad for a prime number algorithm
            # Here n is the nth positive integer from zero.
            # This algorithm was easier to code, but is a little suspect
            # because the integer numbers were not randomly chosen
            # (as specified by the Euler rule for paired primes).
            # primepi will hardly fire on less than 30 cases.
            proc pietry {aa bb} {for {set i 1} {$i<=$bb} {incr i} { set aa [expr $aa +6./($i*$i) ]  } ;return [expr sqrt($aa)] }
            #usage  [ pietry 0 1000] answer is 3.14063
            $t insert 1.0 "test trial "
            $x insert 1.0 "test trial "
            . configure -borderwidth 10 -highlightthickness 2 -relief raised -highlightcolor DarkOliveGreen -background aquamarine4
            console hide
            
            

SECOND VERSION WITH ADDED HACKS

        #!/usr/bin/env wish
        # finding PI from series notation
        # code from TCL Club  Slot_Calculator_Demo
        # 5Jan2009, gold
        # following comment from gold 12dec2018
        # pretty print from autoindent and ased editor
        # finding PI from series notation V2
        # written on Windows XP on eTCL
        # working under TCL version 8.6
        # Revamping older program from 5Jan2009.
        # One of my early programs,
        # but I believe the pie routines
        # and pie content might have some interest (to me).
        # gold on TCL Club, 12dec2018
        package require Tk
        set reportcard "ready"
        set reportcard2 "zero entry detected !!! "
        label .title -text "PI Series Calculator" -font {Times 15 bold} -relief raised -fg blue -bg seashell3
        frame .puzzle -bg aquamarine4
        frame .f1
        frame .f2
        frame .f3
        frame .f4
        frame .f5
        set colorgrd seashell4
        set colorback bisque
        set colorwarning tomato1
        label .l1 -text "initial N or Nth" -background seashell1 -width 25 -anchor w
        entry .e1 -textvariable side1  -background $colorback
        pack .l1 .e1 -in .f1 -side left
        label .l2 -text "upper N2 terms" -background seashell2  -width 25 -anchor w
        entry .e2 -textvariable side2  -background $colorback
        pack .l2 .e2 -in .f2 -side left
        label .l3 -text "algorithm 1,2,3,...7  " -background seashell3 -width 25 -anchor w
        entry .e3 -textvariable side3  -background $colorback
        pack .l3 .e3 -in .f3 -side left
        label .l4 -text "answer  " -background seashell2 -width 25 -anchor w
        entry .e4 -textvariable answer2  -background $colorback
        pack .l4 .e4 -in .f5 -side left
        pack .f1 .f2 .f3 .f5 -in .puzzle -side top -expand 1
        frame .answer -bd 2 -relief ridge -bg aquamarine4
        proc Scrolled_Text { f args } {
            frame $f
            eval {text $f.text -wrap word \
                        -xscrollcommand [list $f.xscroll set] \
                        -yscrollcommand [list $f.yscroll set]} $args
            scrollbar $f.xscroll -orient horizontal  \
                    -command [list $f.text xview]
            scrollbar $f.yscroll -orient vertical  \
                    -command [list $f.text yview]
            grid $f.text $f.yscroll -sticky news
            grid $f.xscroll -sticky news
            grid rowconfigure $f 0 -weight 1
            grid columnconfigure $f 0 -weight 1
            return $f.text
        }
        global t x
        set t [Scrolled_Text .eval -width 20 -height 5 -bg bisque]
        set x [Scrolled_Text .eval2 -width 20 -height 5 -bg bisque]
        pack .eval .eval2 -fill both -expand true -side left -in .answer
        $t insert end  " identified1 !!![ winfo children . ]"  ;
        $x insert end  " identified2 !!! [ winfo children . ]"  ;
        focus $t
        focus $x
        pack .answer  -in .puzzle -side bottom -pady {10 0}
        frame .buttons -bg aquamarine4
        ::ttk::button .calculater -text "Solve" -command { calculate  side1 side2 side3 }
        ::ttk::button .test2 -text "Testcase1" -command {testcasexxxx 0 100 1 3.14}
        ::ttk::button .test3 -text "Testcase2" -command {testcasexxxx 50 1000 2 3.14}
        ::ttk::button .test4 -text "Testcase3" -command {testcasexxxx 100 1000000 3 3.14}
        ::ttk::button .clearallx -text clear -command {clearall  }
        ::ttk::button .about -text About -command About
        ::ttk::button .self_help -text self_help -command { self_help }
        ::ttk::button .exit -text exit -command {exit}
        pack .calculater  -in .buttons -side top -padx 10 -pady 5
        pack  .clearallx .about .self_help .exit .test4 .test3  .test2   -side bottom -in .buttons
        grid .title - -pady 10 -padx 10 -ipadx 10
        grid .puzzle .buttons -sticky ns -pady {0 10}
        proc testcasexxxx { de1 de2 de3 wer } {
            # testcase is side of 5 units and 30 units
            # result or product is 150 units
            global side1 side2 side3 answer2 x t
            set answer2 ""
            set answer5 ""
            set side1 $de1
            set side2 $de2
            set side3 $de3
            set answer2 " testcase, ans=$wer "
            $x insert 1.0 " testcase entered, answer = $wer "
            $t insert 1.0 " testcase entered, answer = $wer "
        }
        proc clearall {} {
            global colorwarning
            global colorback
            global side1 side2 side3 answer2 x t
            set side1 ""
            set side2 ""
            set side3 ""
            set answer2 ""
        }
        proc sumsquares { args } {
            set sum 0
            foreach item  $args  {
                if {$item == ""} {set item "0"}
                incr sum [ expr { $item * $item } ]
            }
            return [ expr { sqrt($sum) }   ]
        }
        proc pietanic2 { side1  side2  side3} {
            if {$side3 == "1"} { return [  pietry4  $side1 $side2]}
            if {$side3 == "2"} { return [  montepi $side1 ]}
            if {$side3 == "3"} { return [  montepithon  $side1 ]}
            if {$side3 == "4"} { return [  pietanic  ]}
            if {$side3 == "5"} { return [  primepi $side1  ]}
            if {$side3 == "6"} { return [  pietry  $side1 $side2]}
            if {$side3 == "7"} { return [  leibniz5  $side1 $side2]}
            # default to pietanic if not 1,2,3
            return [ pietanic  ]
        }
        proc binfactory  { side1  side2  side3} {
            global t x
            set algo1 { arctangent terms algorithm, best N=0,  30<N2<80 * }
            set algo2 { monte carlo algorithm, best 100<N<1000, N2 locked * }
            set algo3 { ratio of gcd pairs to N trials algorithm, best 10<N<1000, N2 locked *}
            set algo4 { specified terms of x in leibiniz series, all entries locked * }
            set algo5 { pairs of successive N and N+1 primes to Nth term, best 10<N<50, N2 locked * }
            set algo6 { euler series, 6/n*n, best N==0, 50<N2<1000 * }
            set algo7 {  gregory-leibniz series at initial x= 1, N locked to 1,best 200<N2<1000 * }
            set algo8 {  strip area of quarter circle,best 100<N<500, N2 locked  * }
            if {$side3 == "1"} { $t insert 1.0 "fm 1, $algo1 pi series ";$x insert 1.0 "fm 1, $algo1 pi series "}
            if {$side3 == "2"} { $t insert 1.0 "fm 2, $algo2 pi series ";$x insert 1.0 "fm 2, $algo2 pi series  " }
            if {$side3 == "3"} { $t insert 1.0 "fm 3, $algo3 pi series ";$x insert 1.0 "fm 3, $algo3 pi series "}
            if {$side3 == "4"} { $t insert 1.0 "fm 4, $algo4 pi series ";$x insert 1.0 "fm 4, $algo4 pi series "}
            if {$side3 == "5"} { $t insert 1.0 "fm 5, $algo5 pi series ";$x insert 1.0 "fm 5, $algo5 pi series " }
            if {$side3 == "6"} { $t insert 1.0 "fm 6, $algo6 pi series ";$x insert 1.0 "fm 6, $algo6 pi series " }
            if {$side3 == "7"} { $t insert 1.0 "fm 7, $algo7 pi series ";$x insert 1.0 "fm 7, $algo7 pi series " }
            if {$side3 == "8"} { $t insert 1.0 "fm 8, $algo8 pi series ";$x insert 1.0 "fm 8, $algo8 pi series " }
            # default to pietanic if not 1,2,3
            if {$side3 >= 8} { $t insert 1.0 "fm 1,defaulted pi series ";$x insert 1.0 "fm 1,defaulted pi series " }
            if {$side3 <= 0} { $t insert 1.0 "fm 1,defaulted pi series ";$x insert 1.0 "fm 1,defaulted pi series " }
            return
        }
        proc calculate {  ide1  ide2  ide3  } {
            global colorwarning
            global colorback
            global answer2 x t
            global side1 side2 side3
            set answer2 ""
            set xside1 $side1
            set xside2 $side2
            set xside3 $side3
            #set answer2 [ sumsquares $side1 $side2 $side3 ]
            binfactory $side1 $side2 $side3
            set answer2 [ pietanic2 $side1 $side2 $side3]
            $x insert 1.0 "$side1 $side2 $side3, answer = $answer2 "
            $t insert 1.0 "$side1 $side2 $side3, answer = $answer2 "
        }
        proc About {} {
            set msg "Calculator for pi series.
            testing on series accuracy."
            tk_messageBox -title "About" -message $msg
        }
        proc self_help {} {
            set msg " finding PI from series notation V2
            from TCL ,
            # self help listing
            # problem, finding PI from series notation V2
            # 3 givens follow.
            1) initial N or Nth:
            2) upper N2 terms:
            3) algorithm 1,2,3,...6:
            # Recommended procedure is push testcase
            # and fill frame,
            # change first three entries etc,
            # and then push report.
            # >>> copyright notice <<<
            # This posting, screenshots, and TCL source code is
            # copyrighted under the TCL/TK license terms.
            # Editorial rights and disclaimers
            # retained under the TCL/TK license terms
            # and will be defended as necessary in court.
            # algorithm list, 7 algorithms_subroutines so far.
            # number subroutine_name
            # 1  pietry4
            # 2  montepi
            # 3  montepithon
            # 4  pietanic
            # 5  primepi
            # 6  pietry
            # 7  leibniz5
            # default to pietanic if algorithm not entered.
            # Each algorithm has individual conditions and
            # defaults, and may use entries in alternate ways.
            # The intent was to be flexible to user selection.
            # 12Dec2018. Revamping older program fm 9Jan2009.
            # One of the
            # first and early TCL programs that
            # I wrote on wiki, but believe the pie routines
            # and pie content might have some interest (to me).
            # gold on  TCL Club, 12Dec2018 "
            tk_messageBox -title "Self_Help" -message $msg }
        # algorithms for test
        proc atan5 {aa }  { return [expr {(1.*$aa)-(pow($aa,3)/3.)+(pow($aa,5)/5.)-(pow($aa,7)/7.)+(pow($aa,9)/9.)-(pow($aa,11)/11.) } ]  }
        proc pietanic { } { return [expr 4.*44.*[atan5 [expr 1./57]]+4.*7.*[atan5 [expr 1./239]] -4.*12*[atan5 [expr 1./682]]+4.*24*[atan5 [expr 1./12943]] ]}
        proc ran {} {return [expr rand()]};
        proc montepi {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} {set x [ran ]; set y [ran]; if {($x*$x + $y*$y) < 1} {incr cc;}}; expr {4e0*$cc/$n}}
        #usage: montepi 90, answer is 3.1555,
        # not bad for a Monte Carlo (random process) algorithm.
        # derived from the TCL random function, the x and y pairs that are digital fractions from 0 to 1.
        # montepi will hardly fire on less than 10 cases.
        #montepi answer varies from 2.97 to 3.27 on small trial of 50
        proc gcdE {a b} {expr {$b==0? $a: [gcdE $b [expr {$a%$b}]]}};#RS
        proc montepithon {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} {set x [expr {int(10000*[ran ])}];set y [expr {int(10000*[ran ])}] ;if {[gcdE $x $y]<2} {incr cc}; }; return  [expr {sqrt(6.*$n/$cc)}]  }
        #usage:[ montepithon  50 ], n is the number of trials or number of interger pairs tested.
        #answer varies from 2.97 to 3.27 on small trial of 50 integer pairs.
        # This ratio of gcd pairs to N trials needs
        # about a million pairs for 3 significant figures of pi.
        # This algorithm is based on Euler's rule
        # that ratio of trials to found gcd pairs is about pi squared over 6.
        # montepithon will hardly fire on less than 10 cases.
        proc pietry4 {aa bb} {for {set i 1} {$i<=$bb} {incr i 1} { set aa [expr $aa +90./($i*$i*$i*$i) ]  } ;set aa [expr sqrt($aa)];return [expr sqrt($aa)] }
        #usage:pietry4 0 100,  answer is 3.141592
        proc isprime x {expr {$x>1 && ![regexp {^(oo+?)\1+$} [string repeat o $x]]}}
        proc primepi {n} { set cc 0; for {set i 1} {$i <= $n} {incr i} { if { [isprime $i] || [isprime [expr $i+1] ]} {incr cc;}}; expr {sqrt(6./((1.*$cc)/($n*1)))}}
        #Usage:$t.text insert 1.0 " primepi   [primepi 50]   "  3.2163, not bad for a prime number algorithm
        # Here n is the nth positive integer from zero.
        # This algorithm was easier to code, but is a little suspect
        # because the integer numbers were not randomly chosen
        # (as specified by the Euler rule for paired primes).
        # primepi will hardly fire on less than 30 cases.
        proc pietry {aa bb} {set aa 0;for {set i 1} {$i<=$bb} {incr i} { set aa [expr $aa +6./($i*$i) ]  } ;return [expr sqrt($aa)] }
        #usage  [ pietry 0 1000] answer is 3.14063
        #7
        proc leibniz5 {aa bb} {set aa 1;set i 1;while {$i <= $bb} {set dd [expr {2.*$i+1}];set ee [expr { (1.*pow(-1,$i)
                    *1.)/ $dd }] ; set aa    [expr $aa + $ee];incr i;};return [expr 4.*$aa];}
        #puts " [ leibniz 1 500 ]"
        $t insert 1.0 "test trial "
        $x insert 1.0 "test trial "
        . configure -borderwidth 10 -highlightthickness 2 -relief raised -highlightcolor DarkOliveGreen -background aquamarine4
        console hide
        

answered question: from ask no8.

gold 23Jun2010,


I have loaded a wiki page called Oneliner's Pie in the Sky, which has a small calculator for PI series. The Gregory-Leibnez series for the arctan has alternating powers of negative one.


The oneliner below is working somewhat, but I've got a mental blank on this. Can someone improve this code?

   arctan series = x - x^3/3 + x^5/5 - x^7/7 + ...
    arctan(1)=pi/4 = x - x^3/3 + x^5/5 - x^7/7 + ...
   substituting 1 for x
   pi = 4.-4./3+4/5+4./7
 proc liebniz {aa bb} {console show;set i 1;while {$i <= $bb} {set dd [expr {2.*$i+1}];set ee [expr { (1.*pow(-1,$i)*1.)/ $dd }] ; puts $ee;set aa    [expr $aa + $ee];incr i;};return [expr 4.*$aa];}
 puts " [ liebniz 1 500 ]"

GWM one - brace your expressions. set aa expr {$aa+$ee} - reduces execution time by a factor of 100. Really. two - the intermediate output to console "puts $ee" is also slowing response.

Original timing (with puts $ee removed) and 100 times as many iterations so that time can actually measure the time!:

 % time {puts "[liebniz 1 50000]"}
  3.141612653189785
  2344000 microseconds per iteration

Braced expr {}:

  %time {puts "[liebniz 1 50000]"}
  3.141612653189785
  47000 microseconds per iteration

This version is about 3 times faster, by omitting intermediate evaluation of pow() and use of incr to calculate dd (which is now an int, so expr uses -1./$dd or 1./$dd to evaluate as a real number).

  proc liebniz2 {aa bb} {console show;set i 1; set dd 1;while {$i <= $bb} {incr dd 2 ; set aa    [expr {$aa + ($i%2?-1.:1.)/ $dd}];incr i;};return [expr 4.*$aa];}

Time for liebniz2:

 % time {puts "[liebniz2 1 50000]"}
  3.141612653189785
  16000 microseconds per iteration

Test of Ased editor autoindent on above files

gold 12Dec2018, cleaning up some files above.


        proc plainsub {text item replacewith} {
            set text [string map [list $item $replacewith] $text]
        }
        proc %+ {a  } {return [string toupper $a]; #%+ tree >TREE }
        proc %- {a  } {return [string tolower $a]; #%+ Tree >tree  }
        proc %++ {a b} {return $a$b;#%+* tree root  >treeroot }
        proc %-- {a b} {regsub $b $a "" a; return $a;#%-- 5 7>5 }
        proc %% {a b} {regsub -all $b $a "";#%% tree root  >tree }
        proc %1 {a b} {regsub $b $a "" a; return $a;#%1 tree root>tree }
        proc %2 {a b} {regsub $b $a "" a;regsub $b $a "" a; return $a;#%2 tree root>tree }
        proc %3 {a b} {regsub $b $a "" a;regsub $b $a "" a;regsub $b $a "" a; return $a;#%3 tree root>tree}
        proc %2x  {a} {return $a$a;#%2x tree>treetree}
        proc %3x  {a} {return $a$a$a;#%3x tree>treetreetree}
        proc %4x  {a} {return "$a,$a,$a";#%5x tree>tree,tree,tree }
        proc %5x  {a} {return "$a $a $a";#%5x tree>tree tree tree }
        proc repeat {n body} {while {$n} {incr n -1; uplevel $body}}
        proc random n {expr {round($n*rand())}}
        proc whitelist {a} {return [lreplace $a 0 -1];#take string,return list without blanks}
        set k [split {abcdefghijklmnopqrstuvwxyz} {}]
        # eraser procedures for positive and negative numbers
        proc eggy {bb} {if {$bb <= 0 } { return 0} ;return  $bb  };# deletes negative numbers
        proc neggy {bb} {if {$bb >= 0 } { return 0} ;return  $bb  };#deletes positive numbers
        proc zergy {bb} {if {$bb == 0 } { return 0} ;return  $bb  };#deletes zero numbers        
        proc  neggabs {bb} {if {$bb <= 0} { return [ expr $bb * -1]} ;return  0  };
        #deletes positive numbers and returns absolute value of negatves
        # formula for two parallel resistors of resistance aa and bb ohms.
        proc parresistor2 {aa bb } { return [ expr (($aa *  $bb )/ ($aa + $bb))]}
        #usage: set resistor [ parresistor 100 100  ];answer is 50.
        # formula for three parallel resistors of resistance aa, bb,  and cc ohms.
        proc parresistor {aa bb cc } { return [ expr (($aa *  $bb * $cc)/ ($aa*$bb+$aa*$cc+$bb*$cc))]}
        #usage: set resistor [ parresistor 100 100 100 ];answer is 33
        # formula for fet transistor of volttage 0.009 volts and resistance bb ohms.
        proc fetvolts {aa bb } { return [ expr ($aa *  $bb )]}
        # fet transistor load usage: set fetvolts [ .009 2500 ];answer is 22.5
        # formula for fet transistor of volttage 0.009 volts, resistance bb ohms, cc and dd volts.
        proc fetdrainvolts {aa bb cc dd } { return [ expr ($aa *  $bb + $cc +  $dd)]}
        # fet transistor usage: set fetdrainvolts [ .009 2500 7 5 ];answer is 34.5
        # thin film resistor of dimension aa length and ww width, and sheet resistance cc
        proc thinfilmresistor {aa ww cc } { return [ expr (($aa * $cc)/ ($ww*1.))]}
        #usage ;thinfilmresistor of length 0.8 cm,   width 0.2 cm, and sheet resistance of 150 ohms
        # set resistance2 [ thinfilmresistor {.8 .2 100 } ] ;#answer is 600 ohms
        # efficiency and output of electric motor with one horsepower for 746 watts.
        proc electrichorsepower  {aa bb cc } { return [ expr (($aa *  $bb * $cc)* (1./746.))]};#horsepower
        # efficiency as 0.8 no_units, voltage as 25 volts, and input current as 10 amps
        # The scale factor would be (1./746.) horsepower per watt.
        #usage:append  details " [ electrichorsepower  .8 25 10  ]  " ;#answer is 0.268 horsepower
        # formula for cascaded efficiency for n1 *n2 * n3
        proc   cascadedefficiency  {aa bb cc } { return [ expr (($aa *  $bb * $cc)* (100./1.))]};#
        #example for n1 = 85 percent, n2 equals 90 percent,and n3 equals 73 percent and scale factor 100./1.
        # set  exampleproblem [ cascadedefficiency   .85 .90 .73    ] #answer is 56 percent.

gold This page is copyrighted under the TCL/TK license terms, this license .

Comments Section

Please place any comments here, Thanks.