#! /bin/env tclsh
namespace import ::tcl::mathfunc::max
namespace import ::tcl::mathfunc::min
namespace import ::tcl::mathop::+
namespace import ::tcl::mathop::-
namespace import ::tcl::mathop::/
namespace import ::tcl::mathop::<<
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
package require {ycl list}
interp alias {} [namespace current]::all {} [yclprefix] list all
namespace import [yclprefix]::list::take
variable ldedent [yclprefix]::list::dedent
namespace eval doc {}
proc asnumeric value {
set count [scan $value %lld result]
if {$count} {
return $result
}
set count [scan $value %llf result]
if {$count} {
return $result
}
return [scan $value %llx]
}
variable doc::cmp {
description {
compare two strings, returning the index at which they differ, or -1.
}
}
proc cmp {str1 str2} {
set start 0
set last1 [expr {[string length $str1] -1}]
set last2 [expr {[string length $str2] -1}]
if {$last1 > $last2} {
set last1 $last2[set last2 $last1; lindex {}]
}
set end [/ $last1 2]
while 1 {
if {$start > $last1} {
if {$last2 > $last1} {
if {$last1 == -1} {
return 0
} else {
return [+ $start 1]
}
} else {
return -1
}
}
set str1range $str1
range str1range $start $end
set str2range $str2
range str2range $start $end
if {$str1range eq $str2range} {
set start [expr {$end + 1}]
set end [+ $end [max [/ [- $last1 $end] 2] 1]]
} else {
if {$start == $end} {
return $start
}
set end [- $end [max [/ [- $end $start] 2] 1]]
}
}
set max [- [min [string length $str1] [string length $str2]] 1]
return $end
}
proc dedent {text} {
variable ldedent
set text [split $text \n]
set text [$ldedent $text]
set text [join $text[set text [list]] \n]
return $text
}
variable doc::delimit {
description {
split input based on delimiters, which are themselves included in the
output. Earlier matches take precedence, and where there is a tie for
position, shorter matches take precedence. With re delimiters, the ^
anchors the pattern to each index of $input that this function to for
the next possible match.
}
args {
input {
description { what to delimit }
}
into {
description {
maximum number of pieces to chop input into. -1 means as many as
possible. This is a count of the delimited pieces, not the
delimiters.
}
default {
return -level 0 -1
}
}
string {
description { a string delimiter }
default {}
count -1
process {
lappend delimiters string $string
}
}
match {
description { a [string match]-style delimiter }
default {}
count -1
process {
lappend delimiters match $match
}
}
re {
description { a [regexp]-style delimiter }
default {}
count -1
process {
lappend delimiters re $re
}
}
format {
description {
a list of specifiers what to return. Valid specifiers are...
info {
return results as a dictionary which includes extended information
}
strings {
return strings
}
indexes {
return indexes
}
count {
return a count of matches
}
}
default {
set format [list indexes]
}
constrain {
[all $format in $formats]
}
}
}
}
proc delimit {input args} {
set res [list]
set delimiters [list]
set formats [list [STRINGS] [INDEXES] [INFO] [COUNT]]
checkargs $doc::delimit {*}$args
set count 0
set len [string length $input]
set previous -1
set add [list apply [list {first last type spec} {
upvar count count
upvar format format
upvar strings strings
upvar input input
upvar res res
if {[INFO] in $format} {
set res2 [dict create first $first last $last type $type spec $spec]
if {[STRINGS] in $format} {
dict update res2 string string {
set string $input
range string $first $last
}
}
lappend res $res2
} else {
if {[STRINGS] in $format} {
set range $input
lappend res [range range $first $last]
} elseif {[COUNT] in $format} {
set res $count
} else {
lappend res [list $first $last]
}
}
} [namespace current]]]
for {set i 0} {$i<$len} {::incr i} {
set matches [list]
foreach {type spec} $delimiters {
set match [list $type $spec]
switch -- $type {
string {
if {[string first $spec $input $i] == $i} {
lappend match $i [expr {$i + [string length $spec] - 1}]
lappend matches $match
}
}
match {
set range $input
if {[set shortmatch [shortmatch $spec [range range $i end]]] > 0} {
set last [expr {$i + $shortmatch}]
lappend match $i $last
lappend matches $match
}
}
re {
#don't use -start switch here because semantics are different for ^
set range $input
set rematch [regexp -inline -indices $spec [range range $i end]]
if {[llength $rematch]} {
if {[llength [lindex $rematch 0]] != 1} {
#discard submatches
lassign $rematch[set rematch {}] rematch
}
lassign $rematch first last
set first [expr {$first + $i}]
set last [expr {$last + $i}]
lappend match $first $last
lappend matches $match
}
}
}
}
if {[llength $matches]} {
::incr count
set matches [lsort -integer -index 2 $matches]
lassign $matches match match2
lassign $match type spec first last
lassign $match2 type2 spec2 first2 last2
if {$first == $first2 && $last2 < $last} {
lassign $match2 type spec first last
}
if {$first > $previous + 1} {
{*}$add [expr {$previous+1}] [expr {$first - 1}] unmatched {}
}
{*}$add $first $last $type $spec
set match [list]
set match2 [list]
set previous $last
set i $last
}
#$into-1 to count partitioned instead of partitions
if {$into > -1 && $count >= $into-1 } {
break
}
}
if {$previous < $len - 1} {
{*}$add [expr {$previous + 1}] [expr {$len - 1}] unmatched {}
}
return $res
}
variable doc::isnumeric {
description
if $value is a decimal number
returns $value
with any surrounding whitespace removed
otherwise
returns the empty string
a leading zero
does not signify octal
is interpreted as part of a decimal representation
}
proc isdecimal value {
set value [string trim $value]
if {
[expr {
[string is double -strict $value]
&& (
![string is entier $value]
||
![regexp {^\s*[+-]*?0[bBoOxX]?} $value]
)}]
} {
# all numbers with a mantissa recognized here since only decimal
# representations are allowed.
return $value
}
# account for 0-padded decimal integers
regsub {^([+-])*0*([^[:space:]]*)$} $value {\1\2} value
if {[string is double $value]} {
return $value
}
}
proc isdict value {
expr {![catch {dict size $value}]}
}
variable doc::isnumeric {
description
if $value is numeric
returns $value
with any surrounding whitespace removed
otherwise
returns the empty string
a leading zero
does not signify octal
is interpreted as part of a decimal representation
}
proc isnumeric value {
set value [string trim $value]
# Use [string is double] to accept Inf and NaN
if {[string is double $value]} {
return $value
}
regsub {^\s*([+-])*0[BOXbox]?0*([^[:space:]]*)\s*$} $value {\1\2} value
if {[string is double $value]} {
return $value
}
return {}
}
proc iter value {
package require {ycl coro call}
namespace import [yclprefix]::coro::call::autocall
namespace import [yclprefix]::coro::call::body
namespace import [yclprefix]::coro::call::hi
namespace import [yclprefix]::coro::call::reply
proc iter value {
set name [namespace current]::[info cmdcount]
set res [coroutine $name\0 ::apply [list value [body {
set length [string length $value]
hi
for {set i 0} {$i < $length} {::incr i} {
reply [string index $value $i]
}
}] [namespace current]] $value]
autocall $name
}
tailcall iter $value
}
variable doc::range {
description
like [string range]
but in-place
}
proc range {stringname args} {
upvar $stringname string
set string [::string range $string[set string {}] {*}$args]
return $string
}
proc replace {stringname args} {
upvar $stringname string
set string [string replace $string[set string {}] {*}$args]
}
proc reverse stringname {
upvar $stringname string
set string [string reverse $string[set string {}]]
}
variable doc::shortmatch {
description {
same as [string match], but return -1 if $string doesn't match, and the
index of the last char of the shortest match if it does
}
}
proc shortmatch args {
set string [lindex $args end]
set args [lrange $args 0 end-1]
set len [string length $string]
set incr [expr {$len / 2}]
set last [expr {$len -1}]
set match -1
set break 0
while 1 {
set range $string
if {[string match {*}$args [range range 0 $last]]} {
if {$match == $last} {
break
}
set match $last
set last [expr {$last - $incr}]
set incr [expr max($incr / 2,1)]
} else {
if {$incr == 0 || $last >= $len} {
break
}
set last [expr {$last + $incr}]
}
}
return $match
}
variable doc::splitv {
description {
like [::split], but stores the result in a variable
}
}
proc splitv {varname args} {
upvar $varname var
set var [split $var[set var {}] {*}$args]
}
variable doc::template {
synopsis {
template ?varspec or directive ...? string
}
description [
{
a concise way to invoke [string map]
all mapped values are quoted with [list]
each $varspec is the name of a variable
optionally preceded by a delimiter that ends with a character
that isn't valid in a variable name
optionally followed by a delimiter that begins with a character
which isn't valid in a variable name
}
directives {
# {
The subsequent $varspec is not to be quoted with [list] .
}
= {
The subsequent $varspec is a list
containing the $odelim and optionally the $cdelim for the $varspec that
follows it . If only $odelim is provided , $cdelim shares its value .
}
! {
A $varspec value of "!" is like "=" , but its effects remain in place
for the all the following $varspec values .
}
}
]
}
proc template args [string map [list @varchars@ {a-zA-z0-9_}] {
if {![llength $args]} {
error [list {wrong # args} [llength $args]]
}
set string [lindex $args end]
set args [lrange $args[set args {}] 0 end-1]
set script {::string map [list }
set state {}
set changedefaultdelim 0
set changedelim 0
set list 1
set odefault @
set cdefault @
set mode varspec
foreach arg $args {
switch $state {
{} {
switch $arg {
= {
set state changedelim
set mode varname
continue
}
! {
set state changedefaultdelim
set mode varspec
continue
}
\# {
set list 0
continue
}
}
}
changedelim {
set arg [lassign $arg[set arg {}] odelim]
if {[llength $arg]} {
lassign $arg cdelim
}
set changedelim 1
set state {}
continue
}
changedefaultdelim {
set arg [lassign $arg[set arg {}] odefault]
if {[llength $arg]} {
lassign $arg cdefault
} else {
set cdefault $odefault
}
set changedefaultdelim 0
set state {}
continue
}
default {
error [list {unknown state} $state]
}
}
if {!$changedelim} {
set odelim $odefault
set cdelim $cdefault
}
if {$mode eq {varspec}} {
if {![regexp "^(.*\[^@varchars@])?(\[@varchars@]+|\[@varchars@]*\\(\[^\\)]*\\))(\[^a-zA-z0-9_].*)?$" \
$arg -> odelim1 varname cdelim1]} {
error [list {bad varspec} $arg]
}
if {$odelim1 ne {}} {
set odelim $odelim1
}
if {$cdelim1 ne {}} {
set cdelim $cdelim1
}
} else {
set varname $arg
}
if {$list} {
set qvarname "\[list \$$varname]"
} else {
set qvarname \$$varname
}
append script "$odelim$varname$cdelim $qvarname "
set list 1
set changedefaultdelim 0
set changedelim 0
set mode varspec
}
append script {] } [list $string]
uplevel 1 $script
}]
proc tolower name {
upvar $name string
set string [string tolower $string[set string {}]]
}
proc COUNT {} {return count}
proc INDEXES {} {return indexes}
proc INFO {} {return info}
proc STRINGS {} {return strings}