Usage: beat.tcl [-h] [-G] [-T] [-V] [-@] [-f <format>] [-o <offset>] [-t
<font>] [--] [<timestamp>]

Arguments:
  [<timestamp>]
          Timestamp in fractional seconds since Epoch to convert to beats.
Current timestamp with microsecond precision is used if it is absent.

Options:
  -h, --help
          Print this message and exit

  -G, --gui
          Start Tk GUI clock that displays current time according to offset and
formatting options. Ignores timestamp argument.

  -T, --test
          Run test suite and exit

  -V, --version
          Print version number and exit

  -@
          Prefix beats with '@'

  -f, --format <format>
          Format string for beats, floating-point or integer (default: '%d')

  -o, --offset <offset>
          Either Tcl [clock add] arguments or whole number of hours to add to
UTC timestamp before converting it to beats (default: '1 hour')

  -t, --font <font>
          Tk font description for GUI clock (default: 'Helvetica 24')

You can use -o/--offset to produce the equivalent of .beat time in a
non-standard time zone. For example, use '0' for UTC.

> ./beat.tcl -G -@ -f '%.1f'

#! /usr/bin/env tclsh
# An Internet Time (.beat time) and general decimal time library.
# Copyright (c) 2021, 2024 D. Bohdan.
# License: MIT.

package require Tcl 8.6 9
package require TclOO

namespace eval ::beat {
    variable defaultFont {Helvetica 24}
    variable defaultFormat %d
    variable defaultOffset {1 hour}
    variable secondsInDay 86400
    variable version 3.1.0

    namespace export format scan *-to-*
    namespace ensemble create
}

# Epoch time in seconds -> .beats.
proc ::beat::format {t {offset {}} {format {}} {integer true}} {
    variable defaultFormat
    variable defaultOffset
    variable secondsInDay

    if {$format eq {}} {
        set format $defaultFormat
    }
    if {$offset eq {}} {
        set offset $defaultOffset
    }

    set beats [seconds-to-decimal [expr {
        fmod([clock-add-double $t {*}$offset], $secondsInDay)
    }]]
    if {$integer} {
        set beats [expr { int($beats) }]
    }

    ::format $format $beats
}

# .beats -> seconds since midnight in UTC.
proc ::beat::scan {beats {offset {}}} {
    variable defaultOffset
    variable secondsInDay

    if {$offset eq {}} {
        set offset $defaultOffset
    }

    set timestamp [clock-add-double \
        [decimal-to-seconds $beats] \
        {*}[negate-offset {*}$offset] \
    ]

    # Handle negative timestamps.
    set timestamp [expr {
        $timestamp
        + (1 + ceil($timestamp * 1.0 / $secondsInDay)) * $secondsInDay
    }]

    expr { fmod($timestamp, $secondsInDay) }
}

proc ::beat::seconds-to-decimal {s {unitsPerDay 1000}} {
    variable secondsInDay

    expr { $s * $unitsPerDay * 1.0 / $secondsInDay }
}

proc ::beat::decimal-to-seconds {dec {unitsPerDay 1000}} {
    variable secondsInDay

    expr { $dec * $secondsInDay * 1.0 / $unitsPerDay }
}

proc ::beat::clock-add-double {clockval args} {
    set int [expr { int($clockval) } ]
    set frac [expr { $clockval - $int }]

    set added [clock add $int {*}$args -timezone :UTC]
    expr { $added + $frac }
}

proc ::beat::negate-offset args {
    set negated [lmap {count unit} $args {
        list [expr { -$count }] $unit
    }]

    concat {*}$negated
}

proc ::beat::current-time {} {
    expr { [clock microseconds] / 1000000.0 }
}

oo::class create ::beat::GUI {
    variable _at
    variable _font
    variable _format
    variable _integer
    variable _offset
    variable _root

    constructor {font at offset format integer} {
        set _at $at
        set _font $font
        set _format $format
        set _integer $integer
        set _offset $offset

        my create-gui
        my update-time
    }

    destructor {
        after cancel [list [self] update-time]
        destroy $_root
    }

    method create-gui {} {
        set _root [toplevel .beatGUI]
        wm title $_root Beats

        ttk::label $_root.timeLabel -font $_font -text {}

        grid $_root.timeLabel -padx 20 -pady 20
        grid columnconfigure $_root 0 -weight 1
        grid rowconfigure $_root 0 -weight 1

        bind $_root <Escape> [list [self] destroy]
        wm protocol $_root WM_DELETE_WINDOW [list [self] destroy]
    }

    method root {} {
        return $_root
    }

    method update-time {} {
        set beats [::beat::format \
            [::beat::current-time] \
            $_offset \
            $_format \
            $_integer \
        ]

        if {$_at} {
            set beats @$beats
        }

        $_root.timeLabel configure -text $beats

        after 100 [list [self] update-time]
    }
}

proc ::beat::test {command reference {maxDiff 0}} {
    upvar 1 errors errors

    set numeric [string is double -strict $reference]
    set value [uplevel 1 $command]

    if {
        ($numeric && (abs($value - $reference) > $maxDiff))
        || (!$numeric && $value ne $reference)
    } {
        set within [expr { $maxDiff == 0 ? {} : " within $maxDiff" }]
        lappend errors "\[$command\] -> $value instead of $reference$within"
    }
}

proc ::beat::run-tests {} {
    variable defaultOffset
    variable secondsInDay

    set ref {
        1000000000 115
        1100000000 523
        1200000000 930
        1300000000 337
        1400000000 745
        1500000000 152
        1600000000 560
        1700000000 967
        1800000000 375
        1900000000 782
        2000000000 189
        1612973550 717
    }

    set offsets {{}}
    for {set i -25} {$i <= 25} {incr i} {
        lappend offsets [list $i hours]
    }

    set errors {}

    dict for {timestamp beats} $ref {
        test [list format $timestamp $defaultOffset %d true] $beats
        test [list scan $beats] [expr { fmod($timestamp, $secondsInDay) }] 86
    }

    test [list negate-offset 1 hour] {-1 hour}
    test [list negate-offset -5 hours -32 min 5 s] {5 hours 32 min -5 s}

    foreach offset $offsets {
        foreach timestamp [dict keys $ref] {
            set beats [format $timestamp $offset %f]

            test [list scan $beats $offset] [expr {
                fmod($timestamp, $secondsInDay)
            }] 86
        }
    }

    test [list seconds-to-decimal 48400 1000] 560 1
    test [list seconds-to-decimal 48400 200] 112 1
    test [list seconds-to-decimal 48400 100] 56 1
    test [list seconds-to-decimal 48400 20] 11 1
    test [list seconds-to-decimal 48400 10] 5 1

    test [list decimal-to-seconds 560 1000] 48384
    test [list decimal-to-seconds 112 200] 48384
    test [list decimal-to-seconds 56 100] 48384
    test [list decimal-to-seconds 11 20] 47520
    test [list decimal-to-seconds 5 10] 43200

    for {set i 0} {$i < 1000} {incr i} {
        test "seconds-to-decimal \[decimal-to-seconds $i\]" $i 1
    }

    for {set i 0} {$i < 86400} {incr i} {
        test "decimal-to-seconds \[seconds-to-decimal $i\]" $i 86
    }

    if {$errors ne {}} {
        error "tests failed:\n[join $errors \n]"
    }
}

proc ::beat::usage channel {
    puts $channel [::format \
        {Usage:\
            %s [-h] [-G] [-T] [-V] [-@] [-f <format>] [-o <offset>]\
            [-t <font>] [--] [<timestamp>]} \
        [file tail [info script]] \
    ]
}

proc ::beat::help {} {
    variable defaultFont
    variable defaultFormat
    variable defaultOffset

    usage stdout

    puts -nonewline [::format {
Arguments:
  [<timestamp>]
          Timestamp in fractional seconds since Epoch to convert to beats.\
          Current timestamp with microsecond precision is used if it is absent.

Options:
  -h, --help
          Print this message and exit

  -G, --gui
          Start Tk GUI clock that displays current time\
          according to offset and formatting options.\
          Ignores timestamp argument.

  -T, --test
          Run test suite and exit

  -V, --version
          Print version number and exit

  -@
          Prefix beats with '@'

  -f, --format <format>
          Format string for beats, floating-point or integer\
          (default: '%s')

  -o, --offset <offset>
          Either Tcl [clock add] arguments or whole number of hours\
          to add to UTC timestamp before converting it to beats\
          (default: '%s')

  -t, --font <font>
          Tk font description for GUI clock\
          (default: '%s')

You can use -o/--offset to produce the equivalent of .beat time\
in a non-standard time zone. For example, use '0' for UTC.
} $defaultFormat $defaultOffset $defaultFont]
}

proc ::beat::exit-with-error {message code} {
    puts stderr "Error: $message"
    exit $code
}

proc ::beat::usage-error message {
    usage stderr
    exit-with-error $message 2
}

proc ::beat::main argv {
    variable defaultFont
    variable version

    set at false
    set font $defaultFont
    set format {}
    set integer true
    set offset {}
    set printHelp false
    set printVersion false
    set startGUI false

    set len [llength $argv]
    for {set i 0} {$i < $len} {incr i} {
        set arg [lindex $argv $i]
        set value [lindex $argv $i+1]
        set haveValue [expr { $i + 1 < $len }]

        switch -glob -- $arg {
            -@ {
                set at true
            }

            -h -
            -help -
            --help -
            help {
                set printHelp true
            }

            -f -
            -format -
            --format {
                if {!$haveValue} {
                    usage-error "$arg needs a value"
                }
                set format $value
                incr i

                if {$value eq {}} {
                    continue
                }

                set validFormat false
                foreach testValue {123.45 123} {
                    try {
                        ::format $format $testValue
                        set validFormat true
                        set integer [string is integer -strict $testValue]
                        break
                    } trap {TCL FORMAT} _ {} trap {TCL VALUE} _ {
                        # Do nothing.
                    }
                }

                if {!$validFormat} {
                    usage-error "invalid format: $format"
                }
            }

            -G -
            -gui -
            --gui {
                set startGUI true
            }

            -o -
            -offset -
            --offset {
                if {!$haveValue} {
                    usage-error "$arg needs a value"
                }
                set offset $value
                incr i

                if {[string is double -strict $offset]} {
                    set offset [list $offset hours]
                }

                try {
                    clock-add-double 0 {*}$offset
                } trap CLOCK _ {
                    usage-error "invalid offset: $offset"
                }
            }

            -t -
            -font -
            --font {
                if {!$haveValue} {
                    usage-error "$arg needs a value"
                }
                set font $value
                incr i
            }

            -T -
            -test -
            --test -
            test {
                run-tests
                exit 0
            }

            -V -
            -version -
            --version -
            version {
                set printVersion true
            }

            -- {
                incr i
                break
            }

            -* {
                if {[llength $argv] == 1 && [string is double -strict $arg]} {
                    break
                }

                usage-error "unknown option: $arg"
            }

            default {
                break
            }
        }
    }

    set argv [lrange $argv $i end]

    switch -- [llength $argv] {
        0 {
            set timestamp [current-time]
        }

        1 {
            set timestamp $argv

            # Check the format and reject NaN and the infinities.
            if {
                ![string is double -strict $timestamp]
                || $timestamp != $timestamp
                || abs($timestamp) == inf
            } {
                usage-error "invalid timestamp: $timestamp"
            }
        }

        default {
            usage-error {too many arguments}
        }
    }

    if {$printHelp} {
        help
        exit 0
    }

    if {$printVersion} {
        puts $version
        exit 0
    }

    if {$startGUI} {
        try {
            package require Tk
            package require Ttk
            wm withdraw .

            set gui [GUI new $font $at $offset $format $integer]
            bind [$gui root] <Destroy> [list exit 0]
        } on error e {
            exit-with-error $e 1
        }

        return
    }

    if {$at} {
        puts -nonewline @
    }
    puts [format $timestamp $offset $format $integer]
}

# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    beat::main $argv
}