#!/usr/bin/env tclsh
# Tcl/Tk calculator program.
# This program is released under BSD license without any warranties.
# Copyright (C) 2019 Andy Goth <[email protected]>
# Source: https://wiki.tcl-lang.org/page/calc

# Load required packages.
lappend auto_path [file join [file dirname [info script]] lib]
package require Tcl 8.6
package require Tk
package require yeti
package require ylex
package require wcb

# Create the ::calc namespace.
namespace eval ::calc {
    variable Count 0        ;# Number of items in the history.
}

# Create the scanner.
yeti::ylex ::calc::ScannerBuilder -name ::calc::ScannerClass
::calc::ScannerBuilder code error {}
::calc::ScannerBuilder macro {
    SPACE       {[ \f\n\r\t\v]+}
    END         {(?!\w)}
    OP          {<<|>>|\*\*|[-(),&|^+*/%]}
    DEC         {\d+<END>}
    BIN         {0[Bb][01]+<END>}
    OCT         {0[Oo][0-7]+<END>}
    HEX         {0[Xx][[:xdigit:]]+<END>}
    EXP         {[eE][+-]?\d+}
    REAL        {(?:\d+<EXP>|\d*\.\d+<EXP>?|\d+\.\d*<EXP>?)<END>}
    DMS         {[NnSsEeWw]?\d+(?::\d+){1,2}(?:\.\d*)?<END>}
    NAME        {[a-zA-Z_]\w*}
}
::calc::ScannerBuilder add {
    {<SPACE>}   {}
    {<OP>}      {return [list $yytext]}
    {<DEC>}     {return [list VAL [scan $yytext %lld]]}
    {<BIN>}     {return [list VAL [scan $yytext %llb]]}
    {<OCT>}     {return [list VAL [scan [regsub {..} $yytext {}] %llo]]}
    {<HEX>}     {return [list VAL [scan $yytext %llx]]}
    {<REAL>}    {return [list VAL [scan $yytext %f]]}
    {<DMS>}     {return [list VAL [::calc::DecodeDms $yytext]]}
    {<NAME>}    {return [list NAME $yytext]}
    {.}         {error "invalid character \"$yytext\""}
}
eval [::calc::ScannerBuilder dump]
::calc::ScannerClass ::calc::Scanner
::calc::ScannerBuilder destroy

# Create the parser.
yeti::yeti ::calc::ParserBuilder -name ::calc::ParserClass -start ior
::calc::ParserBuilder code error {}
::calc::ParserBuilder add {
    ior xor             {return $1}
      | {ior | xor}     {return [::calc::math::| $1 $3]}
    xor and             {return $1}
      | {xor ^ and}     {return [::calc::math::^ $1 $3]}
    and shf             {return $1}
      | {and & shf}     {return [::calc::math::& $1 $3]}
    shf add             {return $1}
      | {shf << add}    {return [::calc::math::<< $1 $3]}
      | {shf >> add}    {return [::calc::math::>> $1 $3]}
    add mul             {return $1}
      | {add + mul}     {return [::calc::math::+ $1 $3]}
      | {add - mul}     {return [::calc::math::- $1 $3]}
    mul exp             {return $1}
      | {mul * exp}     {return [::calc::math::* $1 $3]}
      | {mul / exp}     {return [::calc::math::/ $1 $3]}
      | {mul % exp}     {return [::calc::math::% $1 $3]}
    exp una             {return $1}
      | {una ** exp}    {return [::calc::math::** $1 $3]}
    una num             {return $1}
      | {+ una}         {return [::calc::math::+ $2]}
      | {- una}         {return [::calc::math::- $2]}
    num {( ior )}       {return $2}
      | fun             {return $1}
      | var             {return $1}
      | VAL             {return $1}
    fun {NAME ( )}      {return [::calc::math::$1]}
      | {NAME ( arg )}  {return [::calc::math::$1 {*}$3]}
    arg ior             {return [list $1]}
      | {arg , ior}     {return [list {*}$1 $3]}
    var NAME            {return [set ::calc::math::$1]}
}
eval [::calc::ParserBuilder dump]
::calc::ParserClass ::calc::Parser -scanner ::calc::Scanner
::calc::ParserBuilder destroy

# ::calc::EncodeDms --
# Encodes a degrees-minutes or degrees-minutes-seconds value.
proc ::calc::EncodeDms {enableSec a} {
    # Decode the input.
    set a [DecodeNumber $a]

    # Process the sign.
    if {$a < 0} {
        set sign -
        set a [expr {-$a}]
    } else {
        set sign {}
    }

    if {$enableSec} {
        # Encode degrees-minutes-seconds.
        set deg [expr {int($a)}]
        set fix [expr {int(($a - $deg) * 3600000000 + 0.5)}]
        set min [expr {$fix / 60000000 % 60}]
        set sec [expr {$fix / 1000000 % 60}]
        set frac [expr {$fix % 1000000}]
        format %s%d:%02d:%02d.%06d $sign $deg $min $sec $frac
    } else {
        # Encode degrees-minutes.
        set deg [expr {int($a)}]
        set fix [expr {int(($a - $deg) * 60000000 + 0.5)}]
        set min [expr {$fix / 1000000 % 60}]
        set frac [expr {$fix % 1000000}]
        format %s%d:%02d.%06d $sign $deg $min $frac
    }
}

# ::calc::DecodeDms --
# Decodes a degrees-minutes-seconds value.  The seconds field is optional.
proc ::calc::DecodeDms {a} {
    # Split the value into fields.
    regexp {^([NnSsEeWw]?)0*(\d+)(?::0*(\d+))(?::0*(\d+))?(\.\d*)?$} $a _\
            hemi deg min sec frac

    # Treat degenerate fractions as zero.
    if {$frac in {{} .}} {
        set frac 0
    }

    # Add the fraction to the least-significant place.
    if {$min >= 60} {
        return -code error "minutes field too large"
    } elseif {$sec eq {}} {
        set min [expr {$min + $frac}]
        set sec 0
    } elseif {$sec >= 60} {
        return -code error "seconds field too large"
    } else {
        set sec [expr {$sec + $frac}]
    }

    # Compute the result.  Negate the southern and western hemispheres.
    if {$hemi in {S s W w}} {
        expr {-$deg - $min / 60.0 - $sec / 3600.0}
    } else {
        expr {+$deg + $min / 60.0 + $sec / 3600.0}
    }
}

# ::calc::DecodeNumber --
# Attempts to decode any number in a recognized format.
proc ::calc::DecodeNumber {a} {
    if {[string is double -strict $a]} {
        return $a
    } else {
        ::calc::DecodeDms $a
    }
}

# ::calc::Call --
# Calls a function with all arguments decoded as numbers.
proc ::calc::Call {func args} {
    {*}$func {*}[lmap arg $args {DecodeNumber $arg}]
}

# Create the ::calc::math namespace to contain all math functions and operators.
namespace eval ::calc::math {
    # Create selected math functions, renaming a few of them along the way.
    foreach {from to} {
        abs   abs       acos  acos      asin  asin      atan  atan
        atan2 atan2     ceil  ceil      cos   cos       cosh  cosh
        int   entier    isqrt isqrt     exp   exp       floor floor
        hypot hypot     ln    log       log   log10     max   max
        min   min       rand  rand      round round     sqrt  sqrt
        sin   sin       sinh  sinh      tan   tan       tanh  tanh
    } {
        interp alias {} ::calc::math::$from {} ::calc::Call ::tcl::mathfunc::$to
    }

    # Create functions to format in degrees-minutes and degrees-minutes-seconds.
    interp alias {} ::calc::math::dm  {} ::calc::EncodeDms 0
    interp alias {} ::calc::math::dms {} ::calc::EncodeDms 1

    # Create functions to convert between degrees and radians.
    proc deg {a} {variable pi; expr {$a * 180 / $pi}}
    proc rad {a} {variable pi; expr {$a * $pi / 180}}

    # Create trigonometric functions that work in degrees.
    proc acosd {a} {deg [expr {acos($a)}]}
    proc asind {a} {deg [expr {asin($a)}]}
    proc atand {a} {deg [expr {atan($a)}]}
    proc atan2d {a b} {deg [expr {atan2($a, $b)}]}
    proc cosd {a} {expr {cos([rad $a])}}
    proc sind {a} {expr {sin([rad $a])}}
    proc tand {a} {expr {tan([rad $a])}}

    # Create functions to format numbers in binary, octal, and hexadecimal.
    # When given a negative number, truncate the two's-complement to 32 bits.
    foreach {name code} {bin b oct o hex x} {
        proc $name {a} [string map [list %CODE% [list $code]] {
            if {$a < 0} {
                set a [expr {$a & 0xffffffff}]
            }
            format 0%CODE%%ll%CODE% $a
        }]
    }

    # Create math operations that recognize DMS inputs as well as numbers.
    foreach op {+ - * / % ** << >> & ^ |} {
        interp alias {} ::calc::math::$op {} ::calc::Call ::tcl::mathop::$op
    }

    # ::calc::math::/ --
    # Custom division operation that avoids truncation.
    proc / {a b} {
        if {[string is integer -strict $a] && [string is integer -strict $b]
         && !($a % $b)} {
            expr {$a / $b}
        } else {
            expr {double([::calc::DecodeNumber $a]) / [::calc::DecodeNumber $b]}
        }
    }

    # ::calc::math::% --
    # Custom modulo operation that works with integers and real numbers.
    proc % {a b} {
        if {[string is integer -strict $a] && [string is integer -strict $b]} {
            expr {$a % $b}
        } else {
            expr {fmod([::calc::DecodeNumber $a], [::calc::DecodeNumber $b])}
        }
    }

    # Clean up temporary variables.
    unset from to name code op

    # Create constants.
    set pi  [expr {acos(-1)}]
    set e   [expr {exp(1)}]
    set phi [expr {(1 + sqrt(5)) / 2}]
    set inf Inf
}

# ::calc::eval --
# Evaluates the math expression.
proc ::calc::eval {expr} {
    Parser reset
    Scanner start $expr
    Parser parse
}

# ::calc::setup --
# Configures a text widget to be a calculator.
proc ::calc::setup {win} {
    # Create entry and result fields.
    .calc insert end \n entry " " result
    .calc mark set insert entry.first

    # Create a tab stop at the right edge of the text widget.
    bind $win <Configure> {
        set box [%W bbox "1.0 lineend"]
        %W configure -tabs [list\
                [expr {[lindex $box 0] + [lindex $box 2] - 2}] right]
    }

    # Create input callback.
    wcb::callback $win before insert {apply {{win index args} {
        variable Count

        # Loop over each part being inserted.
        set i 1
        set cancel 1
        foreach {string tags} $args {
            if {$string eq "\n"} {
                # Interpret a bare newline as a command to store the result.
                catch {
                    # Get and evaluate the input expression.
                    set in [$win get entry.first entry.last-1char]
                    set out [calc::eval $in]

                    # Store the result into the history.
                    incr Count
                    set ::calc::math::ans $out
                    set ::calc::math::a$Count $out

                    # Display the result.
                    $win insert entry.first $in\n oldEntry\
                            "a$Count =\t" oldVar $out\n oldResult

                    # Clear the input.
                    $win replace result.first result.last " " result
                    $win delete entry.first entry.last-1char
                    $win see end
                }
                wcb::replace $i [expr {$i + 1}]
            } elseif {$string in {\f \r \t \v}} {
                # Disallow entering whitespace control characters by themselves.
                wcb::replace $i [expr {$i + 1}]
            } else {
                # Ensure the input is tagged correctly.
                if {"entry" ni $tags} {
                    lappend tags entry
                }

                # Simplify input whitespace.
                wcb::replace $i [expr {$i + 1}] [string map\
                        {\f {} \n " " \r {} \t " " \v {}}\
                        [string trim $string \n\t]] $tags

                # Clamp the insert position to the entry field.
                if {[$win compare $index < entry.first]} {
                    catch {$win tag remove sel sel.first sel.last}
                    $win mark set insert entry.first
                } elseif {[$win compare $index >= entry.last]} {
                    catch {$win tag remove sel sel.first sel.last}
                    $win mark set insert entry.last-1char
                }

                # Do not cancel the command if there is any good input.
                set cancel 0
            }
            incr i 2
        }

        # Cancel the command if all parts have been omitted.
        if {$cancel} {
            wcb::cancel
        }
    } ::calc}}

    # Create delete callback.
    wcb::callback $win before delete {apply {{win from {to {}}} {
        # Check if the selection is being deleted.
        set sel [expr {$from eq "sel.first" && $to eq "sel.last"}]

        # Fill in the default end index.
        if {$to eq {}} {
            set to $from+1char
        }

        # Clamp the start and/or end indexes to the entry field.
        set clampFrom [$win compare $from < entry.first]
        set clampTo [$win compare $to >= entry.last]
        if {$clampFrom || $clampTo} {
            # Clamp the indexes, or resolve the selection indexes.
            if {$clampFrom} {
                set from entry.first
            } elseif {$sel} {
                set from [$win index $from]
            }
            if {$clampTo} {
                set to entry.last-1char
            } elseif {$sel} {
                set to [$win index $to]
            }

            # Now that the indexes have been updated, take action.
            if {!$sel} {
                # If the selection is not being deleted, simply apply clamping.
                wcb::replace 0 1 $from $to
            } elseif {[$win compare $from >= $to]} {
                # Abort if clamping results in an empty range.
                wcb::cancel {}
            } else {
                # If the selection is being deleted, clamp the selection itself.
                $win tag remove sel sel.first sel.last
                $win tag add sel $from $to
            }
        }
    }}}

    # Create motion callback.
    wcb::callback $win before motion {apply {{win index} {
        if {($index eq "insert-1displayindices"
          && [$win compare insert == entry.first])
         || ($index eq "insert+1displayindices"
          && [$win compare insert == entry.last-1chars])} {
            # Cancel attempts to leave the entry field using left or right.
            wcb::cancel {}
        }
    }}}
    wcb::callback $win after motion {apply {{win index} {
        if {[$win compare insert < entry.first]} {
            set index [$win index "insert lineend"]
            foreach tag {oldResult oldEntry} {
                if {[set match [$win tag prevrange $tag $index]] ne {}
                 && [$win compare $index >= "[lindex $match 0] linestart"]
                 && [$win compare $index < "[lindex $match 1] lineend"]} {
                    catch {$win tag remove sel sel.first sel.last}
                    after idle [list $win tag add sel {*}$match]
                    break
                }
            }
        } elseif {[$win compare $index >= entry.last]} {
            catch {$win tag remove sel sel.first sel.last}
        }
    }}}

    # Create post-update callbacks.
    foreach event {insert delete} {
        wcb::callback $win after $event {apply {{win args} {
            try {
                # Attempt to evalute the input field.
                set out [calc::eval [$win get entry.first entry.last-1char]]
            } on error {} {
                # On failure, force the result to a single space.
                set out " "
            }

            # Put the result onscreen.
            if {[set match [$win tag ranges result]] eq {}} {
                $win insert end $out result
            } else {
                $win replace result.first result.last $out result
            }
            $win see end
        }}}
    }
}

# Create user interface.
wm title . Calculator
text .calc -highlightthickness 0 -setgrid 1 -background palegreen\
        -yscrollcommand {.scroll set}
.calc tag configure oldEntry -font {-family monospace -size 14}\
        -selectforeground chartreuse -selectbackground forestgreen\
        -foreground olivedrab
.calc tag configure oldVar -font {-family monospace -size 10}\
        -selectforeground chartreuse -selectbackground forestgreen\
        -foreground seagreen
.calc tag configure oldResult -font {-family monospace -size 14}\
        -selectforeground chartreuse -selectbackground forestgreen\
        -foreground green
.calc tag configure entry -font {-family monospace -size 18}\
        -borderwidth 2 -relief groove\
        -foreground darkslategray -background greenyellow\
        -selectforeground chartreuse -selectbackground darkgreen\
        -lmargin1 4 -rmargin 4 -spacing1 2 -spacing3 2
.calc tag configure result -font {-family monospace -size 18 -weight bold}\
        -selectforeground chartreuse -selectbackground forestgreen\
        -foreground green -justify right
ttk::scrollbar .scroll -command {.calc yview}
grid .calc .scroll -sticky nsew
grid columnconfigure . .calc -weight 1
grid rowconfigure . .calc -weight 1
focus .calc
calc::setup .calc

# vim: set sts=4 sw=4 tw=80 et ft=tcl: