functions.tcl

# These are procedures that I think are useful for everyday use. 
# Not all procedures in this file may have the most optimized 
# implementation, but I guarantee that they work as intended. 
# The focus is on functionality first, and improvements can be 
# made over time to enhance performance.
# When and why I do this:
#  - prioritizing convenience and readability over performance
#  - core function is missing in libtcl.a like clock or parray
#  - improves code readability like odd? instead of modulo fiddling
#  - adds additional functionality to some core function like parray
#  - avoids repetitive boilerplate code and keeps things DRY
#  - makes code more expressive and self-documenting
#  - ensures a consistent interface: 
#    (predicate functions end with '?', 
#    utility functions are short and clear)
#  - keeps coding fun and Tcl enjoyable 😎

# ---------------------------------------------------------------------
# Procedure: datetime
# Added as a replacement for the missing 'clock' command and for 
# convenience. Command is platform-independent, which is especially 
# useful when working in environments like jails or on systems where 
# external tools (like date) are not available.
# See: https://www.sqlite.org/lang_datefunc.html
#
# Arguments:
#  - format: The datetime format (uses SQLite's strftime format)
#            Defaults to ISO 8601 (YYYY-MM-DD HH:MM:SS)
#  - mods:   Modifiers (uses SQLite's date time modifiers)
#            Defaults to the current local date and time
#
# Usage examples:
# datetime
# datetime "%Y-%m-%d %H:%M:%S" "'now', '+1 day'"
# datetime "%Y-%m-%d" "'now','start of year','+9 months','weekday 2'"
# datetime "%s"
# ---------------------------------------------------------------------
proc datetime {{fmt "%Y-%m-%d %H:%M:%S"} {mods "'now', 'localtime'"}} {
	set sql "SELECT strftime('$fmt', $mods);"
	if {[info commands db] eq "db"} {
		return [db one $sql]
	} else {
		sqlite3 __datetime_db :memory:
		set result [__datetime_db one $sql]
		__datetime_db close
		return $result
	}
}

# ---------------------------------------------------------------------
# Procedure: parray
# Displays the contents of an array with custom formatting. This command
# allows filtering by key and/or value. It is useful when working with
# Tcl arrays, providing a convenient way to format and display array data
# with optional key and value filters.
#
# Arguments:
#  - arrayName: The name of the array (passed by reference).
#  - keyfilter: A pattern used to filter the array keys 
#    default is '*', meaning no filtering
#  - valuefilter: A nocase pattern used to filter the array values 
#    default is '*', meaning no filtering
#
# Usage examples:
# parray myArray
# parray myArray "ba*"
# parray myArray "*" "value*"
# parray myArray "key1" "value1"
# ---------------------------------------------------------------------
proc parray {arrayName {keyfilter *} {valuefilter *}} {
	upvar 1 $arrayName __a
	if {![array exists __a]} {
		return -code error "Variable: '$arrayName' isn't an array"
	}

	set maxlen 0
	set names [lsort [array names __a $keyfilter]]

	# Find the maximum name length
	foreach name $names {
		if {[string length $name] > $maxlen} {
			set maxlen [string length $name]
		}
	}

	set maxlen [expr {$maxlen + [string length $arrayName] + 2}]

	# Display the array with custom formatting
	foreach name $names {
		if {[string match -nocase "$valuefilter" $__a($name)]} {
			set key_string [format %s(%s) $arrayName $name]
			puts stdout [format "%-*s = %s" $maxlen $key_string $__a($name)]
		}
	}
}

# ---------------------------------------------------------------------
# Procedure: test
# My simple test suite :) It's sufficient for most use cases where
# you don't need advanced features. It's lightweight, easy to use, 
# and it can handle basic test scenarios well. The command is flexible 
# enough for quick testing of functions, commands, and database 
# interactions. If you're looking for something simple and effective, 
# this is the way to go!
# 
# The test suite supports two types of comparison:
# 1. `regexp`: If the expected value is wrapped in slashes (`/`), 
#    a regular expression comparison is performed. This allows 
#    flexibility when you need to match patterns in the result.
# 2. `eq`: If the expected value is not wrapped in slashes, 
#    a direct string comparison is used, meaning the result must
#    match the expected value exactly.
# ---------------------------------------------------------------------
# Usage:
# test testname {
#   testbody
# } {expected}
#
# The testbody is a block of Tcl code that will be evaluated, and the 
# result is compared to the expected value (expected). 
# If the comparison passes, the test is marked as "PASS"; otherwise, 
# it will be marked as "FAIL". 
# ---------------------------------------------------------------------
proc test {testname testbody {expected {}}} {
	set fail_line 0
	set result [eval $testbody]
	
	# Check if we want a regexp comparison; the expected value 
	# is between / and /
	if {[regexp {^/.*/$} $expected]} {
		# Perform regexp comparison
		set expected [string range $expected 1 end-1] ;# remove the slashes
		if {[regexp "^${expected}\$" $result]} {
			puts "PASS: $testname"
		} else {
			set fail_line [lindex [info frame -1] 3]
			puts "FAIL: $testname, want: $expected, got: $result line: $fail_line"
		}
	} else {
		# Perform simple string comparison
		if { $result eq $expected } {
			puts "PASS: $testname"
		} else {
			set fail_line [lindex [info frame -1] 3]
			puts "FAIL: $testname, want: $expected, got: $result line: $fail_line"
		}
	}
}

# ---------------------------------------------------------------------
# Procedure: randhex 
# Generates a random hexadecimal string using SQLite if available,  
# otherwise falls back to an in-memory SQLite instance.  
#  
# Arguments:  
# length (default: 16) - Number of random bytes to generate.  
#                        Each byte is converted to 2 hex characters,  
#                        so the output length is length * 2 characters.  
#  
# Behavior:  
#   - If the global "db" command exists (assumed to be an active SQLite 
#     connection),  
#     it is used directly for efficiency. (~35 µs in my case) 
#   - If "db" does not exist, a temporary SQLite database is 
#     created in RAM  
#     to execute the query, which adds some overhead 
#     (~2500 µs in my case).  
#  
# Notes:  
#   - SQLite's randomblob() provides high-quality randomness,  
#     superior to Tcl's built-in rand().  
#   - Optimized for web applications where an active database 
#     connection is usually available to generate dynamic content.  
# ---------------------------------------------------------------------
proc randhex {{length 16}} {
	set sql "SELECT lower(hex(randomblob($length)))"
	if {[cmd? db]} {
		return [db one $sql]
	} else {
		sqlite3 __randhex_db :memory:
		set result [__randhex_db one $sql]
		__randhex_db close
		return $result
	}
}

# ---------------------------------------------------------------------
# Procedure: kv (!)
# A minimalist's key-value manager for dict-like lists
# This procedure operates on lists where key-value pairs  are stored in 
# an even number of elements. The list is modified in-place via 
# reference, so no new list is returned and operations are destructive.
#
# Arguments:
# @arg lstVar  The list variable name to operate on.
# @arg key     The key to get/set/add/delete.
# @arg value   The value to set for the given key (if provided).
#
# It allows the following operations on the list:
# - GET (fetch the value for a given key),
# - SET (set a value for a key, or update an existing one),
# - ADD (add a new key-value pair if the key doesn't exist),
# - DEL (delete a key-value pair by removing both the key and value).
#
# Special behavior:
# - If the value is "-" it deletes the key and its value
# - If the key is "-" (minus sign), the entire list is pretty printed.
# - The list must have an even number of elements to work correctly.
# 
# Example usage:
# set lst {name Jack age 30}
# kv lst name      ;# -> Jack
# kv lst name John ;# Sets new name
# kv lst age       ;# -> 30
# kv lst city NYC  ;# Adds 'city' -> 'NYC'
# kv lst fullname {John Doe} ;# Adds 'fullname' -> 'John Doe'
# kv lst -         ;# Pretty prints the current list
# kv lst city -    ;# Deletes the city key and its value
#
# Returns the value associated with the key if GET operation, or an 
# empty string if the key is not found. If a modification is made 
# (SET/ADD), the list is updated in-place via reference, and the set 
# value is returned.
# In the case of DELETE, the removed keyname is returned, or an empty 
# string if the key was not found.
# ---------------------------------------------------------------------
proc kv {lstVar key {value {}}} {
	upvar 1 $lstVar lst
	if {[odd? $lst]} {
		return -code error "odd number of elements"
	}
	set idx [lsearch -exact $lst $key]

	# Pretty print when key is "-"
	if {$key eq "-"} {
		puts "Pretty printing $lstVar:"
		set maxlen 0
		foreach {k v} $lst {
			set maxlen [expr {max($maxlen, [string length $k])}]
		}
		foreach {k v} $lst {
			puts [format "%-*s -> %s" $maxlen $k $v]
		}
		return
	}

	if {$value eq {}} {
		# get
		return [expr {$idx == -1 ? "" : [lindex $lst [expr {$idx + 1}]]}]
	} elseif {$value eq "-"} {
		# del
		if {$idx != -1} {
			set lst [lreplace $lst $idx [expr {$idx + 1}]]
		}
		return $key
	} elseif {$idx == -1} {
		# add
		lappend lst $key $value
	} else {
		# set
		lset lst [expr {$idx + 1}] $value
	}
	return $value
}

# ---------------------------------------------------------------------
# Procedure: static
# Allows you to create "static" variables that retain their values 
# between calls to the procedure.
# It uses a namespace to store the value and ensures that each 
# procedure call can access and modify its "static" variable without 
# polluting the global scope.  
#
# Credits: kruzalex (Alexander Kruzlik)
# See: https://wiki.tcl-lang.org/page/static+variables
#
# Example with a numeric variable:
# proc intgen {} {
#     static i 0       ;# Initialize 'i' to 0
#     incr i           ;# Increment 'i' on each call
#     puts $i          ;# Print the current value of 'i'
# }
#
# Example with a text (string) variable:
# proc strgen {} {
#     static t ""      ;# Initialize 't' as an empty string
#     append t "-x"    ;# Append '-x' to 't' on each call
#     puts $t          ;# Print the current value of 't'
# }
#
# Call 'intgen' multiple times to see how 'i' persists across calls
# intgen   ;# 1
# intgen   ;# 2
# intgen   ;# 3
#
# Call 'strgen' multiple times to see how 't' persists across calls
# strgen   ;# -x
# strgen   ;# -x-x
# strgen   ;# -x-x-x
# ---------------------------------------------------------------------
proc static {name {value 0}} {
	set caller [lindex [info level -1] 0]
	set qname ::wappstatic::${caller}
	if {![info exists ${qname}::$name]} {
		foreach var [list [lrange [info level 0] 1 end]] {  
			if {[llength $var]==1} {lappend var $value}  
				namespace eval $qname [linsert $var 0 variable]
			}
		}
		uplevel 1 [list upvar 0 ${qname}::$name $name]
}

# ---------------------------------------------------------------------
# Work in progres
# The following code can be the subject of frequent changes.
# ---------------------------------------------------------------------

# Procedure: timestamp
# Returns current timestamp in seconds, miliseconds, or microseconds
proc timestamp {{unit "s"}} {
	set memory 0
	if {[cmd? db]} {
		set db db
	} else {
		set memory 1
		sqlite3 __timestamp__db :memory:
		set db __timestamp__db
	}

	if {$unit eq "s"} {
		set result [$db one {select strftime('%s', 'now')}]
	} elseif {$unit eq "ms"} {
		set result [$db one {select cast((julianday('now') - 2440587.5) * 86400 * 1000 as integer)}]
	} elseif {$unit eq "us"} {
		set result [$db one {select cast((julianday('now') - 2440587.5) * 86400 * 1000000 as integer)}]
	} else {
		return -1 ;# Neplatný parameter
	}

	if $memory {
		db close
	}
	return $result
}

# Procedure: dbg
# Prints args values to stdout, each on the separate line 
proc dbg {args} {
	if {[info globals DEBUG] ne ""} {
		if {$::DEBUG == 1} {
			set m ""
			set i 1
			foreach arg $args { 
				append m "arg $i: -> $arg\n"
				incr i
			} 
			puts -nonewline $m 
		}
	}
}

# Procedure: listjson
# Converts flat dict-like list into JSON
# Returns: 
#  - valid JSON string
#  - error, if the number of the elements is odd
proc listjson {lst} {
	if {[odd? $lst]} {
		return -code error "listjson: odd number of elements"
	}

	set json_str "{"
	foreach {key value} $lst {
		append json_str "\"$key\": \"$value\","
	}
	# remove last comma
	if {[string length $json_str] > 1} {
		set json_str [string range $json_str 0 end-1]
	}
	append json_str "}"
	return $json_str
}

# Procedure: arraylist 
# Creates dict-like list from an array
proc arraylist {arrayName} {
	upvar $arrayName input
	set result {}
	set current {}

	foreach key [array names input] {
		if {$key eq "*"} {
			# Prepend record in non-empty current
			if {[llength $current] > 0} {
				set result "[linsert $result 0 $current] "
			}
			set current {}
			continue
		}
		set current [linsert $current 0 $key $input($key)]
	}

	# Prepend last record
	if {[llength $current] > 0} {
		set result [linsert $result 0 $current]
	}
	return $result
}


# Predicates
# ---------------------------------------------------------------------

# Procedure: int?
# Returns true if the value is an integer
proc int? {val} {
	string is integer -strict $val
}

# Procedure: double?
# Returns true if the value is a double 
proc double? {val} {
	string is double -strict $val
}

# Procedure: empty?
# Returns true if the value is the empty string or list
proc empty? {val} {
	if {[llength $val] == 0 || [string length $val] == 0} {
		return 1
	}
	return 0
}

# Procedure: even?
# Returns true if the value is even
proc even? {val} {
	if {[int? $val]} {
		if {[expr {$val % 2}] == 0} {
			return 1
		}
		return 0
	}
	if {[expr {[llength $val] % 2}] == 0} {
		return 1
	}
	return 0
}

# Procedure: odd?
# Returns true if the value is odd
proc odd? {val} {
	if {[int? $val]} {
		if {[expr {$val % 2}] == 1} {
			return 1
		}
		return 0
	}
	if {[llength $val] % 2 == 1} {
		return 1
	}
	return 0
}

# Procedure: file?
# Returns true the file exists
proc file? {path} {
	if {[file isfile $path]} {
		return 1
	}
	return 0
}

# Procedure: fwrite?
# Returns true if the file is writable
proc fwrite? {path} {
	if {[file writable $path]} {
		return 1
	}
	return 0
}

# Procedure: fread?
# Returns true if the file is readable
proc fread? {path} {
	if {[file readable $path]} {
		return 1
	}
	return 0
}

# Procedure: dir?
# Returns true if the path is directory
proc dir? {path} {
	if {[file isdirectory $path]} {
		return 1
	}
	return 0
}

# Procedure: global?
# Returns true if the varName is global variable
proc global? {varName} {
	if {[info globals $varName] ne ""} {
		return 1
	}
	return 0
}

# Procedure: var?
# Checks the existence of the varName in the caller's scope
proc var? {varName} {
	return [uplevel 1 [list info exists $varName]]
}

# Procedure: cmd?
# Checks the existence of the command
proc cmd? {command} {
	if {[info commands $command] ne ""} {
		return 1
	}
	return 0
}

# Procedure: member?
# Returns true if element is the member of lst
proc member? {lst element} {
	expr {[lsearch [flatten $lst] $element] != -1}
}

# Procedure: number?
# Returns true if value is number
proc number? {val} {
	if {[int? $val] || [double? $val]} {
		return 1
	}
	return 0
}

# Procedure: boolean?
# Returns true if value is boolean
proc boolean? {val} {
	return [expr {
		$val == 1 || $val eq on || $val eq true || $val eq yes || 
		$val == 0 || $val == off || $val eq false || $val eq no
	}]
}

# Procedure: true?
# Returns true if value evaluates to true
proc true? {val} {
	return [expr {
		$val == 1 || $val eq on || $val eq true || $val eq yes
	}]
}

# Procedure: false?
# Returns true if value evaluates to false
proc false? {val} {
	return [expr {
		$val == 0 || $val eq off || $val eq false || $val eq no 
	}]
}

# Procedure: zero?
# Returns true if value is number and equals to integer or double
proc zero? {val} {
	if {[number? $val]} {
		if {[int? $val] || [double? $val]} {
			return 1
		}
	}
	return 0
}

# Procedure: starts?
# Returns true if str starts with the prefix
proc starts? {str prefix} {
	return [string match "$prefix*" $str]
}

# Procedure: ends?
# Returns true if str ends with the prefix
proc ends? {str suffix} {
	return [string match "*$suffix" $str]
}

# Procedure: list?
# If you want to create universal list/string procedures.
# The tax is the shimmering effect.  
#
# Tcl does not provide a way to distinguish between list and string
# except for malformed lists. This helper allows universal string/list
# functions to make that distinction. Unfortunately, the shimmering
# effect may occur. It returns true ONLY if the value is a string
# explicitly enclosed in {}. Use when you need procedures that work
# for both strings and lists.
# See: proc count
proc list? {val} {
	if {[starts? $val "{"] && [ends? $val "}"]} { 
		return 1 
	} 
	return 0
}

# Procedure: count
# Universal list/string procedure test ... to count number of
# the elements or characters in the input value.
# count $val     -> for strings
# count "{$val}" -> for lists
# See: proc list?
proc count {val} {
	if {[list? $val]} {
		set val {*}$val
		return [llength $val]
	} else {
		return [string length $val]
	}
}

# Procedure: trim
# Trims character from the both sides of str
proc trim {str {chars " "}} {
	return [string trim $str $chars]
}

# Procedure: ltrim
# Trims character from the left side of str
proc ltrim {str {chars " "}} {
	return [string trimleft $str $chars]
}

# Procedure: rtrim
# Trims character from the right side of str
proc rtrim {str {chars " "}} {
	return [string trimright $str $chars]
}

# Procedure: lower
# Converts a string to lowercase
proc lower {str} {
	return [string tolower $str]
}

# Procedure: upper
# Converts a string to uppercase
proc upper {str} {
	return [string toupper $str]
}

# Procedure: if2
# If we don't have if-else.
# Test of a custom if (else) that works and looks as much like 
# the original as possible, when called.
proc if2 {cond body1 {else ""} {body2 ""}} {
		set cond [uplevel 1 [list expr !!($cond)]]
		if {$cond} {
			uplevel 1 $body1
		} else {
			uplevel 1 $body2
		}
}

# Procedure: all?
# Checks if all elemnets in the list satisfy the predicate
# all? number? $lst -> 0/1
proc all? {predicate lst} {
	if {![cmd? $predicate]} {
		return -code error "all?: invalid predicate name '$predicate'"
	}
	foreach e $lst {
		if {![$predicate $e]} {
			return 0
		}
	}	
	return 1
}

# Procedure: filter
# Filters a list based on a predicate, returning elements that 
# satisfy the predicate
# filter odd? {1 2 3} -> 1 3
proc filter {predicate lst} {
	if {![cmd? $predicate]} {
		return -code error "filter: invalid predicate name '$predicate'"
	}
	set result {}
	foreach e $lst {
		if {[$predicate $e]} {
			lappend result $e
		}
	}
	return $result
}

# Procedure: reject
# Filters a list based on a predicate, returning elements that 
# do NOT satisfy the predicate.
# reject odd? {1 2 3} -> 2
proc reject {predicate lst} {
	if {![cmd? $predicate]} {
		return -code error "reject: invalid predicate name '$predicate'"
	}
	set result {}
	foreach e $lst {
		if {![$predicate $e]} {
			lappend result $e
		}
	}
	return $result
}

# Procedure: key
# Returns the value of the key from the dict or dict-like list
proc key {lst key} {
	if {[odd? $lst]} {
		return -code error "key: odd number of elements"
	}
	set i [lsearch -exact $lst $key]
	if {$i == -1} {
		return {}
	}
	lindex $lst [expr {$i + 1}]
}

# Procedure: idx
#
proc idx {lst index {default ""}} {
	if {$index > 0 && $index < [llength $lst]} {
		return [lindex $lst $index]
	}
	return $default
}

# Procedure: trap
# Essentially works like 'if catch then body'.
# Trap stores the latest error in the 'traperror' auto variable 
# in the caller's scope.
# Returns 1 on error, 0 on success
# Example usages:
# trap {lassing} -> ignore the error and continue
# trap {lassign} {puts $traperror}
# trap {lassign} {puts "Recovering ..."; lassign {b} a}
# if {[trap {lassign}]} { puts $traperror; do this } else {do that}
proc trap {cmd {body ""}} {
	set level [expr {[info level] - 1}]
	set caller [lindex [info level $level] 0]
	set code [catch {uplevel 1 $cmd} err]
	
	if {$code} {
		if {$level == 0} {
			set err "Trapped in level 0 in proc: ${caller} -> [vibe '$cmd' lgreen]: $err"
		} else {
			set err "Trapped in proc: ${caller} -> [vibe '$cmd' lgreen]: $err"
		}

		uplevel 1 [list set traperror $err]
		if {$body ne ""} {
			uplevel 1 $body
		}
	}
	return $code
}

# Procedure: reduce
#
proc reduce {func lst {initial {}}} {
	if {[empty? $lst]} {
		return -code error "reduce: empty list"
	}
	if {[false? [cmd? $func]]} {
		return -code error "reduce: invalid func name '$func'"
	}
	# If there is no initial, we will use the first element
	if {[empty? $initial]} {
		set initial [lindex $lst 0]
		set lst [lrange $lst 1 end]
	}

	set acc $initial
	foreach element $lst {
		set acc [uplevel 1 [list $func $acc $element]]
	}
	return $acc
}

# Procedure: first
# Returns the first element/word of the lst/str
proc first {lst} {
	lindex $lst 0
}

# Procedure: rest
# Returns the lst/str except for the first element/word
proc rest {lst} {
	lassign $lst var
}

# Procedure: last
# Returns the last element/word of the lst/str
proc last {lst} {
	lindex $lst end
}

# Procedure: replace
# Returns the list or the string where the what was 
# replaced with the with :) 
proc replace {where what with} {
	regsub -all $what $where $with
}

# Procedure: slice
# Returns a slice of the lst from the start index to the end index.
# If end is omitted, returns a slice of the lst from the start index
# to the end of the lst.
proc slice {lst start {end -1}} {
	if {$end == -1} {
		return [lrange $lst $start end]
	}
	return [lrange $lst $start $end]
}

# Procedure: range
# Returns a range of the str from the start index to the end index.
# If end is omitted, returns a range of the str from the start index
# to the end of the str.
proc range {str start {end -1}} {
		if {$end == -1} {
				set end [string length $str]
		}
		return [string range $str $start $end] ;#[expr {$end - 1}]]
}

# Procedure: parse
# Parse a string by specified separator(s) (which can be a regexp in {}) 
# This function also handles consecutive separator characters correctly.
# parse "abc:dvd" ":"        -> abc dvd
# parse "abc:dvd,xyz" {[:,]} -> abc dvd xyz
# parse "abc::dvd::xyz" "::" -> abc dvd xyz
# parse $s {\n{2,}}          -> parse paragraphs :)
proc parse {str {chars " "}} {
	set str [regsub -all $chars $str "\x00"]
	set result [split $str "\x00"]
	return $result
}

# Procedure: setm
# Sets multiple variables at once. The number of variables must match 
# the number of values.
# Usage: 
# setm v1 v2 v3 yes no "hello world"
proc setm {args} {
	set half [expr {[llength $args] / 2}]
	set variables [lrange $args 0 $half-1]
	set values [lrange $args $half end]

	if {[llength $variables] != [llength $values]} {
		return -code error "setm: number of variables and values must match"
	}
	# uplevel 1 "lassign [list $values] $variables"
	uplevel 1 [list lassign $values {*}$variables]
}

# Procedure: setl
# Sets multiple variables at once using list. The number of variables 
# must match the number of the list elements.
# Usage:
# setl v1 v2 v3 {yes no "hello world"}
proc setl {args} {
	set variables [lrange $args 0 end-1]
	set values [lindex $args end]
	if {[llength $variables] != [llength $values]} {
		return -code error "setl: number of variables and values must match"
	}
	# uplevel 1 "lassign [list $values] $variables"
	uplevel 1 [list lassign $values {*}$variables]
}

# Procedure: flatten
# Converts nested lists to the flat lists
# Bye recursive calls and malformed lists
proc flatten {lst} {
	replace [replace $lst "{" ""] "}" ""
}

# Procedure: assoc
# Searches for the first sublist in a list whose first element 
# matches the given key
# assoc {{a b c} {D E F}} D ;# -> D E F
proc assoc {lst key} {
	set idx [lsearch -exact -index 0 $lst $key]
	return [lindex $lst $idx]
}

# Procedure: lookup
# Searches for the first sublist in a list whose first element
# matches the given key and returns the value at the relative
# index.
# lookup {{a b c} {D E F}} D 2 ;# -> F
proc lookup {lst key {index 1}} {
	set l [assoc $lst $key]
	return [lindex $l $index]
}

# Procedure: seek
# Searches for a key in the sublists and returns the value
# at the specified relative index in the sublist, where the first 
# element is the key and the second (or more) elements are values.
# If the key is not found, or if the index is out of bounds, 
# it returns the specified default value.
# Usage example:
# seek {{name john age 30} {name jack age 55}} jack 2 ;# -> 55
# seek {{abc dvd xyz} {123 456 789}} 456 1 ;# -> 789
# seek {{abc dvd xyz} {123 456 789}} 456 5 "not found" ;# -> not found
proc seek {lst key {index 1} {default ""}} {
	foreach row $lst {
		set i [lsearch -exact $row $key] 
		if {$i != -1} {
			# if key found
			set found [lindex $row [expr {$i + $index}]]
			if {$found ne ""} {
				return $found
			} else {
				return -code error "seek: index out of bounds"
			}
		}
	}
	return $default ;# key not found
}

# Procedure: fwrite
proc fwrite {path data {translation auto}} {
	set fd [open $path w]
	chan configure $fd -translation $translation 
	if {$translation eq "binary"} {
		puts -nonewline $fd $data
	} else {
		puts $fd $data
	}
	close $fd
}

# Procedure: fappend
proc fappend {path data {translation auto}} {
	set fd [open $path a]
	chan configure $fd -translation $translation
	if {$translation eq "binary"} {
		puts -nonewline $fd $data
	} else {
		puts $fd $data
	}
	close $fd
}

# Procedure: fread
proc fread {path {translation auto}} {
	set fd [open $path r]
	chan configure $fd -translation $translation 
	set data [read $fd]
	close $fd
	return $data
}

# Procedure: fdel
proc fdel {path} {
	file delete $path
}

# Procedure: fdelforce
proc fdelforce {path} {
	file delete -force $path
}

# Procedure: sql
# This is essetially [db eval {...}] alias, so you don't forget to set 
# the empty values to <null> or something similar automatically
proc sql {sql args} {
	array set opt [concat {-db db} $args]
	set db $opt(-db)
	$db nullvalue <null>
	uplevel [list $db eval $sql]
}

# Procedure: sqlget
# Arguments:
#  -keys 1/0 add column names into resultset
#  -db   to set db command name, default is db
#  -flat 0/1 flat unstructured list of all returned records and values
# Returns a list or list of lists or list of dict-like lists as a result 
# of the SQL SELECT query.
# If 'limit 1' is hardcoded at the end of the query, it returns a single 
# list/dict-like list.
proc sqlget {sql args} {

	array set opt [concat {-keys 1 -flat 0 -db db} $args]

	set ::_keys $opt(-keys)
	set flat  $opt(-flat)
	set db    $opt(-db)

	$db nullvalue <null>

	if {$flat} {
		set rows [uplevel 1 [list $db eval $sql]]
		return $rows ;# bye
	}

  uplevel 1 [list $db eval $sql ::_data {
    set ::_row {}
    foreach ::_f $::_data(*) {
			if {$::_keys} {
				lappend ::_row $::_f $::_data($::_f)
			} else {
				lappend ::_row $::_data($::_f)
			}
    }
    lappend ::_result $::_row
  }]
	if {[ends? [lower $sql] "limit 1"]} {
		set rows [lindex $::_result 0]
	} else {
		set rows $::_result
	}
	unset ::_f
	unset ::_row
	unset ::_data
  unset ::_result
	unset ::_keys
  return $rows
}

# Procedure: sqlone 
# Returns the first column value from the first row of the result
# Example: sqlone {select title from book [where ...] limit 1}
proc sqlone {sql args} {
	array set opt [concat {-db db} $args]
	set db $opt(-db)
	$db nullvalue <null>
	uplevel [list $db onecolumn $sql]
}

# Procedure: sqlset (!)
# Executes a destructive SQL query (INSERT, UPDATE, DELETE, ...).
# Returns the number of rows affected by the query.
proc sqlset {sql args} {
	array set opt [concat {-db db} $args]
	set db $opt(-db)
	set sql [string trim $sql]

	set result [uplevel [list $db eval $sql]]
	
	set type [first [lower $sql]]
	if {$type eq "insert" || $type eq "update" || $type eq "delete" || $type eq "replace"} {
		return [$db changes]
	}
	
	if {$result eq ""} {
		return "ok:$type"
	} else {
		return $result
	}
}

# Procedure: sqlcli
# 
proc sqlcli {cmd} {
	set sock [socket 127.0.0.1 7306]
	puts $sock $cmd 
	flush $sock
	set response [read $sock] 
	return $response
}

# Procedure: vibe
# Color printing in terminal
proc vibe {text {color white}} {
	# Define basic colors with ANSI codes
	array set colors {
		black    30
		red      31 
		green    32
		yellow   33
		blue     34
		magenta  35
		cyan     36
		white    37
		
		lblack   90
		lred     91
		lgreen   92
		lyellow  93
		lblue    94
		lmagenta 95
		lcyan    96
		lwhite   97
	}

	# Check if the color is a valid 256-color code (0-255)
	if {[int? $color] && $color >= 0 && $color <= 255} {
		set color_code "38;5;$color"
	} elseif {[string match "#*" $color]} {
		# If the color is in truecolor hex format, extract RGB values
		set color_code "38;2;"
		
		# Extract RGB values from the hex color
		set hex [range $color 1 end]
		set r [expr 0x[range $hex 0 1]]
		set g [expr 0x[range $hex 2 3]]
		set b [expr 0x[range $hex 4 5]]

		append color_code "$r;$g;$b"
	} elseif {[info exists colors($color)]} {
		# Use predefined color from the array
		set color_code $colors($color)
	} else {
		# Default to white if color is invalid (this is optional)
		set color_code $colors(white)
	}

	# Print the text with the selected color code
	return "\033\[${color_code}m$text\033\[0m"
}

# Procedure: markdown
# Basic subset of the markdown markup
proc markdown {input} {
	set out {}

	set blocks [parse $input "\n{2,}"]
	foreach block $blocks {
		if {[starts? $block "# "]} {
			set block [trim $block "# "]
			append out "<h1>$block</h1>\n"
		} elseif {[starts? $block "## "]} {
			set block [trim $block "# "]
			append out "<h2>$block</h2>\n"
		} elseif {[starts? $block "### "]} {
			set block [trim $block "# "]
			append out "<h3>$block</h3>\n"
		} elseif {[starts? $block "---"]} {
			append out "<hr>\n"
		} elseif {[starts? $block "> "]} {
			set block [trim $block "> "]
			append out "<blockquote>\n$block\n</blockquote>\n"
		} elseif {[starts? $block "- "]} {
			append out "<ul>\n"
			set elems [parse $block "\n"]
			foreach e $elems {
				set e [ltrim $e "- "]
				append out "<li>$e</li>\n"
			}
			append out "</ul>\n"
		} elseif {[starts? $block "```"] && [ends? $block "```"]} {
			set block [trim $block "```"]
			append out "<pre><code>$block</code></pre>\n"
		} else {
			append out "<p>\n$block</p>\n"
		}
	}

	array set inlines {
		rawlink {\s(https?://[^\s]+)} 
		link    {\[([^\]]+)\]\((https?://[^\)]+)\)}
		strong  {\*\*(.+?)\*\*}
		em      {\*(.+)\*}
		code    {\s\`(.+)\`\s}
	}
	set out [regsub -all -line $inlines(strong) $out "<strong>\\1</strong>"] 
	set out [regsub -all -line $inlines(em) $out "<em>\\1</em>"] 
	set out [regsub -all -line $inlines(code) $out "<code>\\1</code>"]
	set out [regsub -all -line $inlines(link) $out "<a href=\"\\2\">\\1</a>"]
	set out [regsub -all -line $inlines(rawlink) $out " <a href=\"\\1\">\\1</a>"]

	return $out
}

# Procedure: stats
proc stats {lst} {
	set n [llength $lst]
	if {$n == 0} {
			return -code error "stats: empty list"
	}

	set sum 0
	set sum_of_squares 0
	set sum_of_cubes 0
	set sum_of_fourth 0

	foreach value $lst {
			set sum [expr {$sum + $value}]
			set sum_of_squares [expr {$sum_of_squares + $value * $value}]
			set sum_of_cubes [expr {$sum_of_cubes + $value * $value * $value}]
			set sum_of_fourth [expr {$sum_of_fourth + $value * $value * $value * $value}]
	}

	set mean [expr {$sum / $n}]
	set variance [expr {($sum_of_squares / $n) - ($mean * $mean)}]
	set sdev [expr {sqrt($variance)}]
	
	# Adjusted skewness (Pearson's moment coefficient)
	set skew [expr {($n * $sum_of_cubes - 3 * $sum * $sum_of_squares + 2 * $mean * $mean * $sum) / ($n * pow($sdev, 3))}]
	
	# Adjusted kurtosis (Excess kurtosis formula)
	set kurt [expr {($n * ($n + 1) * $sum_of_fourth - 3 * ($n - 1) * ($n - 2) * ($n - 3) * ($sum_of_squares * $sum_of_squares)) / ($n * ($n - 1) * ($n - 2) * ($n - 3) * $variance * $variance)}]

	set avdev 0
	foreach value $lst {
			set avdev [expr {$avdev + abs($value - $mean)}]
	}
	set avdev [expr {$avdev / $n}]

	return [list N $n mean $mean avdev $avdev sdev $sdev var $variance skew $skew kurt $kurt]
}