#!/usr/bin/env tclsh
# keks.tcl -- Tcl KEKS encoder implementation
# Copyright (C) 2024-2025 Sergey Matveev <stargrave@stargrave.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, version 3 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this program.  If not, see <http://www.gnu.org/licenses/>.

namespace eval KEKS {

set version 0.1.0

proc add {v} {
    upvar buf buf
    set buf [string cat $buf $v]
}

proc char {v} {
    upvar buf buf
    add [binary format c $v]
}

########################################################################

# v is a complete raw value of the atom.
proc RAW {v} {
    upvar buf buf
    add $v
}

proc EOC {} {
    upvar buf buf
    char [expr 0x00]
}

proc NIL {} {
    upvar buf buf
    char [expr 0x01]
}

proc FALSE {} {
    upvar buf buf
    char [expr 0x02]
}

proc TRUE {} {
    upvar buf buf
    char [expr 0x03]
}

########################################################################

# v is either 16-bytes string, or UUID or uncompressed IP address.
proc HEXLET {v} {
    set v [binary decode hex [string map {- "" : ""} $v]]
    if {[string length $v] != 16} {
        error "bad len"
    }
    upvar buf buf
    char [expr 0x04]
    add $v
}

proc MAGIC {v} {
    set l [string length $v]
    if {$l > 12} {
        error "too long"
    }
    upvar buf buf
    add "KEKS"
    add $v
    add [string repeat [binary format c 0] [expr {12 - $l}]]
}

########################################################################

proc toBEbin {l v} {
    set a {}
    for {set i 0} {$i < $l} {incr i} {
        set b [expr {($l - $i - 1) * 8}]
        lappend a [binary format c [expr {($v & (0xFF << $b)) >> $b}]]
    }
    return [join $a ""]
}

proc toBE {l v} {
    upvar buf buf
    add [toBEbin $l $v]
}

proc INT {v} {
    upvar buf buf
    if {$v >= 0} {
        char [expr 0x0C]
    } else {
        char [expr 0x0D]
        set v [expr {- ($v + 1)}]
    }
    if {$v == 0} {
        BIN ""
        return
    }
    set l 0
    while {1} {
        if {$v < [expr {1 << (($l+1)*8)}]} {
            break
        }
        incr l
    }
    BIN [toBEbin [expr {$l + 1}] $v]
}

# Either "nan", "+inf", "-inf", or integers {mantissa exponent}.
proc FLOAT {v} {
    upvar buf buf
    switch $v {
        nan {
            char [expr 0x10]
        }
        +inf {
            char [expr 0x11]
        }
        -inf {
            char [expr 0x12]
        }
        default {
            char [expr 0x13]
            INT [lindex $v 0]
            INT [lindex $v 1]
        }
    }
}

########################################################################

proc _str {atom v} {
    set ll 0
    set vl [string length $v]
    set lv $vl
    if {$vl >= [expr {63 + 255 + 65535}]} {
        set lv 63
        set ll 8
        set vl [expr {$vl - 63 - 255 - 65535}]
    } elseif {$vl >= [expr {62 + 255}]} {
        set lv 62
        set ll 2
        set vl [expr {$vl - 62 - 255}]
    } elseif {$vl > 60} {
        set lv 61
        set ll 1
        set vl [expr {$vl - 61}]
    }
    upvar buf buf
    char [expr {$atom | $lv}]
    if {$ll > 0} {
        toBE $ll $vl
    }
    add $v
}

proc BIN {v} {
    upvar buf buf
    _str [expr 0x80] $v
}

proc STR {v} {
    upvar buf buf
    _str [expr {0x80 | 0x40}] [encoding convertto utf-8 $v]
}

proc BLOB {chunkLen v} {
    upvar buf buf
    char [expr 0x0B]
    toBE 8 [expr {$chunkLen - 1}]
    set vl [string length $v]
    set chunks [expr {$vl / $chunkLen}]
    for {set i 0} {$i < $chunks} {incr i} {
        BIN [string range $v \
            [expr {$i * $chunkLen}] \
            [expr {(($i + 1) * $chunkLen) - 1}]]
    }
    set left [expr {$vl - ($chunks * $chunkLen)}]
    if {$left == 0} {
        BIN ""
    } else {
        BIN [string range $v [expr {$vl - $left}] end]
    }
}

########################################################################

# v is a list of values that will be eval-ed.
proc LIST {v} {
    upvar buf buf
    char [expr 0x08]
    foreach i $v {
        eval $i
    }
    EOC
}

# a and b are strings that are length-first compared.
proc LenFirstSort {a b} {
    set a [encoding convertto utf-8 $a]
    set b [encoding convertto utf-8 $b]
    set al [string length $a]
    set bl [string length $b]
    if {$al < $bl} {
        return -1
    }
    if {$al > $bl} {
        return 1
    }
    for {set i 0} {$i < [string length $a]} {incr i} {
        set av [lindex $a $i]
        set bv [lindex $b $i]
        if {$av < $bv} {
            return -1
        }
        if {$av > $bv} {
            return 1
        }
    }
    error "non-unique keys"
}

# pairs is a list of key-value values. key is an ordinary string.
# value will be eval-ed.
proc MAP {pairs} {
    set d [dict create]
    set keys {}
    foreach {k v} $pairs {
        lappend keys $k
        dict set d $k $v
    }
    set keys [lsort -command LenFirstSort $keys]
    upvar buf buf
    char [expr 0x09]
    foreach k $keys {
        STR $k
        eval [dict get $d $k]
    }
    EOC
}

# v is a list of strings. It will become a map with NIL values.
proc SET {v} {
    set args {}
    foreach k $v {
        lappend args $k NIL
    }
    upvar buf buf
    MAP $args
}

########################################################################

# v is a "2006-01-02 15:04:05"-formatted string that is converted to seconds.
proc ISOToSec {v} {
    return [clock scan $v -format {%Y-%m-%d %H:%M:%S} -gmt 1]
}

variable Leapsecs {
    "1972-07"
    "1973-01"
    "1974-01"
    "1975-01"
    "1976-01"
    "1977-01"
    "1978-01"
    "1979-01"
    "1980-01"
    "1981-07"
    "1982-07"
    "1983-07"
    "1985-07"
    "1988-01"
    "1990-01"
    "1991-01"
    "1992-07"
    "1993-07"
    "1994-07"
    "1996-01"
    "1997-07"
    "1999-01"
    "2006-01"
    "2009-01"
    "2012-07"
    "2015-07"
    "2017-01"
}
for {set i 0} {$i < [llength $Leapsecs]} {incr i} {
    set v [lindex $Leapsecs $i]
    set v [ISOToSec "$v-01 00:00:00"]
    set v [expr {$v + 10 + $i}]
    lset Leapsecs $i $v
}

proc ToTAI {v} {
    variable Leapsecs
    set i 0
    for {} {$i < [llength $Leapsecs]} {incr i} {
        if {$v < [lindex $Leapsecs $i]} {
            break
        }
    }
    if {$v >= 0} {
        incr v 10
    }
    incr v $i
    if {$v == [lindex $Leapsecs $i]} {
        incr v
    }
    return $v
}

# v is TAI number of seconds.
proc TAI64 {v {n 0} {a 0}} {
    upvar buf buf
    set v [expr {$v + (1<<62)}]
    if {$a != 0} {
        char [expr 0x1A]
        toBE 8 $v
        toBE 4 $n
        toBE 4 $a
    } elseif {$n != 0} {
        char [expr 0x19]
        toBE 8 $v
        toBE 4 $n
    } else {
        char [expr 0x18]
        toBE 8 $v
    }
}

########################################################################

namespace export EOC NIL FALSE TRUE HEXLET MAGIC INT STR BIN FLOAT RAW
namespace export TAI64 ToTAI ISOToSec
namespace export LIST MAP SET LenFirstSort BLOB

}

package provide KEKS $KEKS::version

if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    namespace import KEKS::*
    set buf ""
    set in [read stdin]
    eval $in
    puts [binary encode hex $buf]
}
