continued fraction

##+##########################################################################
#
# Continued Fractions -- Displays the continued fraction for a number,
# either on the console or, if running with Tk, in a window.
# Note: limited by the precision of a double
#
# by Keith Vetter 2013-08-21
# More info: https://en.wikipedia.org/wiki/Continued_fraction
# See also: https://www.wolframalpha.com/input/?i=continued+fraction+sqrt(2)
#

set S(depth) 15
set S(examples) {
    "phi" "pi" "e" "5/7" "sqrt(2)" "sqrt(3)" "tan(1/2.)" "tan(1/3.)"
}
set S(expression) [lindex $S(examples) 0]

proc DoDisplay {} {
    global S
    if {! [info exists ::tk_version]} return

    wm title . "Continued Fraction"

    ::tk::entry .expression -textvariable S(expression)
    tk_optionMenu .examples S(expression,example) {*}$S(examples)
    for {set i 0} {$i < [llength $S(examples)]} { incr i } {
        [winfo child .examples] entryconfig $i -command {Go $::S(expression,example)}
    }
    ::ttk::button .go -text "Go" -command {Go $::S(expression)}
    ::tk::label .linear -textvariable S(linear) -bg white -bd 2 -relief ridge -anchor w -padx 2m
    text .t -height [expr {$S(depth)+1}] -width 70 -wrap none -padx 2m -state disabled
    .t tag config under -underline 1

    grid .expression .examples .go -sticky ew
    grid .t - - -sticky news
    grid .linear - - -sticky ew
    grid rowconfigure . 1 -weight 1
    grid columnconfigure . 0 -weight 1

    bind .expression <Key-Return> {.go invoke}
}

proc Go {expression} {
    set ::S(expression) $expression
    lassign [QuickParseExpression $expression] numExpression denExpression
    lassign [MakeRational [SafeMath $numExpression] [SafeMath $denExpression]] num den

    set cf [ComputeCF $num $den]
    set ::S(linear) [PrettyCF $cf]

    ShowCF $cf
}

proc QuickParseExpression {expression} {
    # Continued fractions work best with integers, so if we can determine that the expression
    # is of the form "a / b" then we can make the denominator "b" and get better accuracy.
    # Also, for convenience, convert "pi", "e", and "phi" into their mathematical equivalence.

    foreach {word value} {"pi" "acos(-1)" "e" "exp(1)" "phi" "((1 + sqrt(5))/2)"} {
        set expression [regsub -all "\\m$word\\M" $expression $value]
    }
    while {[regexp {^ *\( *(.*) *\) *$} $expression . expression]} { continue }
    set lastDivide -1
    set parenCount 0
    for {set i 0} {$i < [string length $expression]} {incr i} {
        set ch [string index $expression $i]
        if {$ch eq "("} { incr parenCount ; continue }
        if {$ch eq ")"} { incr parenCount -1 ; continue }
        if {$ch eq "/" && $parenCount == 0} { set lastDivide $i ; continue }
    }
    if {$lastDivide == -1} {
        return [list $expression 1]
    }
    return [list [string range $expression 0 $lastDivide-1] [string range $expression $lastDivide+1 end]]
}

proc ComputeCF {n m {maxDepth 0}} {
    set result {}
    if {$maxDepth <= 0} { set maxDepth $::S(depth) }
    for {set depth 0} {$depth < $maxDepth} {incr depth} {
        set integer [expr {$n/$m}]
        lappend result $integer
        set n [expr {$n - $integer * $m}]
        if {$n == 0} break
        lassign [list $n $m] m n
    }
    if {$n > 0} {
        lappend result "..."
    }
    return $result
}

proc ShowCF {cf} {
    global THIS ALL

    if {! [info exists ::tk_version]} {
        puts "$::S(expression) => [PrettyCF $cf]"
        puts [join [PrettyPrint $cf] \n]
        return
    }
    GetSizesForDisplaying $cf

    .t config -state normal
    .t delete 0.0 end
    set prefix ""
    for {set i 0} {$i < [llength $cf]-1} {incr i} {
        set j [expr {$i+1}]
        set value [lindex $cf $i]

        set pre [expr {$ALL($j)/2}]
        set post [expr {($ALL($j)-1)/2}]
        set one [string repeat " " $pre]1[string repeat " " $post]
        set line "$prefix$value + "
        .t insert end $line normal $one under \n

        append prefix [string repeat " " $THIS($i)]
    }
    .t insert end "$prefix[lindex $cf end]"
    .t config -state disabled
}

proc PrettyCF {cf} {
    set rest [lassign $cf first]
    return "\[$first; [join $rest {, }]\]"
}
proc PrettyPrint {cf} {
    global THIS ALL
    GetSizesForDisplaying $cf

    set prefix ""
    set lines {}
    for {set i 0} {$i < [llength $cf]-1} {incr i} {
        set j [expr {$i+1}]
        set value [lindex $cf $i]

        set blanks [expr {$THIS($i) + $ALL($j)/2}]
        set line0 "$prefix[string repeat { } $blanks]1"
        set line1 "$prefix$value + [string repeat {-} $ALL($j)]"
        lappend lines $line0 $line1
        append prefix [string repeat " " $THIS($i)]
    }
    set line "$prefix[lindex $cf end]"
    lappend lines $line
    return $lines
}
proc GetSizesForDisplaying {cf} {
    global THIS ALL
    unset -nocomplain THIS
    unset -nocomplain ALL

    set len [expr {[llength $cf] - 1}]
    for {set i $len; set last 0} {$i >= 0} {incr i -1} {
        set value [lindex $cf $i]
        set THIS($i) [set ALL($i) [string length $value]]
        if {$last > 0} {
            incr THIS($i) 3
            incr ALL($i) 3
            incr ALL($i) $last
        }
        set last $ALL($i)
    }
}

proc MakeRational {num den} {
    if {[string is entier $num] && [string is entier $den]} {
        return [list $num $den]
    }

    set num_frac [string length [lindex [split $num "."] 1]]
    set den_frac [string length [lindex [split $den "."] 1]]
    set size [expr {max($num_frac,$den_frac)}]
    set scale "1[string repeat 0 $size]"
    set num [expr {int($num * $scale)}]
    set den [expr {int($den * $scale)}]

    set gcd [gcd $num $den]
    set num [expr {$num / $gcd}]
    set den [expr {$den / $gcd}]
    return [list $num $den]
}
proc gcd {p q} {
    while {$q != 0} {set q [expr {$p % [set p $q]}]}
    return [expr {abs($p)}]
}
proc ReverseCF {cf} {
    lassign {1 0} num den
    foreach term [lreverse $cf] {
        lassign [list [expr {$term * $num + $den}] $num] num den
    }
    return [list $num / $den]
}

proc SafeMath {expression} {
    interp create -safe newInterp
    try {
        set value [newInterp eval expr \{ $expression \}]
    } on error {result option} {
        error "bad expression: '$expression'"
    } finally {
        interp delete newInterp
    }
    return $value
}


DoDisplay
if {$argv eq {}} {
    Go [set S(expression,example) [lindex $S(examples) [expr {int(rand()*[llength $S(examples)])}]]]
} else {
    Go [lindex $argv 0]
}

return

Exact Real Arithmetic in Tcl (pdf)

http://www.tcl.tk/community/tcl2015/proceedings.html

https://youtu.be/0z1fIsUNhO4

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References