Browse Source

various scriptlib updates

master v0.1a
Julian Noble 1 year ago
parent
commit
51a5a7a16b
  1. 4
      scriptlib/error.tcl
  2. 2
      scriptlib/hello.tcl
  3. 20
      scriptlib/scriptinfo
  4. 6
      scriptlib/scriptinfo2
  5. 156
      scriptlib/stdout_per_second.tcl
  6. 8
      scriptlib/tests/block_padleft.tcl
  7. 95
      scriptlib/tests/codewars_cola.tcl
  8. 6
      scriptlib/tests/first_assign.tcl
  9. 32
      scriptlib/tests/fun.tcl
  10. 37
      scriptlib/tests/functional/divisible_sum_pairs.tcl
  11. 28
      scriptlib/tests/functional/j.tcl
  12. 23
      scriptlib/tests/functional/quicksort.tcl
  13. 6
      scriptlib/tests/html.tcl
  14. 6
      scriptlib/tests/listbuilder.tcl
  15. 10
      scriptlib/tests/nameservers.tcl
  16. 64
      scriptlib/tests/parser.tcl
  17. 5
      scriptlib/tests/pipeline1.tcl
  18. 4
      scriptlib/tests/pipeswitch.tcl
  19. 10
      scriptlib/tests/wanted.tcl

4
scriptlib/error.tcl

@ -1,5 +1,7 @@
puts stdout "1 (stdout) test of error in scriptlib tcl script" puts stdout "1 (stdout) test of error in scriptlib tcl script"
puts stderr "2 (stderr) error line will be run next - followed by a dashed line on stdout" puts stderr "2 (stderr) error line will be run next"
error "This is the error" error "This is the error"
#should be unreachable
puts stdout "-----------------------------" puts stdout "-----------------------------"

2
scriptlib/hello.tcl

@ -12,6 +12,6 @@ puts -nonewline stderr "5 hello on stderr no line-ending"
flush stderr flush stderr
puts -nonewline stdout "6 hello on stdout no line-ending" puts -nonewline stdout "6 hello on stdout no line-ending"
flush stdout flush stdout
set ::tcl_interactive 1

20
scriptlib/scriptinfo

@ -0,0 +1,20 @@
# tcl - commented line with 'tcl' as indicator this is a tcl script. A standard shebang line would also work.
puts stderr "info script: [info script]"
apply {{self} {
set selfdir [file dirname $self]
puts stderr "selfdir: $selfdir"
source $selfdir/scriptinfo2
#if {[file exists $selfdir/kettle.tcl]} {
## Look for a local copy first, for when we install ourselves.
#source $selfdir/kettle.tcl
#} else {
## use the installed core.
#package require kettle
#}
}} [file dirname [file normalize [info script]/__]]

6
scriptlib/scriptinfo2

@ -0,0 +1,6 @@
# tcl - commented line with 'tcl' as indicator this is a tcl script. A standard shebang line would also work.
puts stderr "scriptinfo2 info script: [info script]"
puts stderr "scriptinfo2 argc: $::argc"
puts stderr "scriptinfo2 argv: $::argv"
puts stderr "scriptinfo2 argv0: $::argv0"

156
scriptlib/stdout_per_second.tcl

@ -1,78 +1,78 @@
if {$::argc >= 1} { if {$::argc >= 1} {
set persec [lindex $::argv 0] set persec [lindex $::argv 0]
} else { } else {
set persec 1 set persec 1
} }
if {$::argc == 2} { if {$::argc == 2} {
set what [lindex $::argv 1] set what [lindex $::argv 1]
} else { } else {
set what "." set what "."
} }
if {$persec > 1000} { if {$persec > 1000} {
puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed" puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed"
flush stderr flush stderr
after 500 after 500
} }
#--- confg --- #--- confg ---
set newline_every_x_seconds 5 set newline_every_x_seconds 5
#--- #---
chan configure stdout -blocking 1 -buffering none chan configure stdout -blocking 1 -buffering none
set counter 0 set counter 0
set ms [expr {1000 / $persec}] set ms [expr {1000 / $persec}]
set nl_every [expr {$persec * $newline_every_x_seconds}] set nl_every [expr {$persec * $newline_every_x_seconds}]
proc schedule {} { proc schedule {} {
if {$::forever_stdout_per_second} { if {$::forever_stdout_per_second} {
after idle [list after 0 ::emit] after idle [list after 0 ::emit]
tailcall after $::ms ::schedule tailcall after $::ms ::schedule
} else { } else {
after idle [list ::the_end] after idle [list ::the_end]
} }
} }
set ::forever_stdout_per_second 1 set ::forever_stdout_per_second 1
proc the_end {} { proc the_end {} {
puts stderr "-done-" puts stderr "-done-"
flush stderr flush stderr
flush stdout flush stdout
set ::done_stdout_per_second 1 set ::done_stdout_per_second 1
} }
proc emit {} { proc emit {} {
upvar ::counter c upvar ::counter c
if {($c > 1) && (($c % $::nl_every) == 0)} { if {($c > 1) && (($c % $::nl_every) == 0)} {
puts -nonewline stdout " " puts -nonewline stdout " "
flush stdout flush stdout
puts stderr $c puts stderr $c
flush stderr flush stderr
} else { } else {
puts -nonewline stdout $::what puts -nonewline stdout $::what
} }
#flush stdout #flush stdout
incr c incr c
} }
chan configure stdin -blocking 0 -buffering none chan configure stdin -blocking 0 -buffering none
chan event stdin readable [list apply {{chan} { chan event stdin readable [list apply {{chan} {
set chunk [chan read $chan] set chunk [chan read $chan]
if {[string length $chunk]} { if {[string length $chunk]} {
if {[string match "*q*" [string tolower $chunk]]} { if {[string match "*q*" [string tolower $chunk]]} {
set ::forever_stdout_per_second 0 set ::forever_stdout_per_second 0
chan event $chan readable {} chan event $chan readable {}
puts stderr "cancelling" puts stderr "cancelling"
} }
} }
if {[chan eof $chan]} { if {[chan eof $chan]} {
chan event $chan readable {} chan event $chan readable {}
} }
}} stdin] }} stdin]
schedule schedule
vwait ::forever_stdout_per_second vwait ::forever_stdout_per_second
vwait ::done_stdout_per_second vwait ::done_stdout_per_second

8
scriptlib/tests/block_padleft.tcl

@ -7,3 +7,11 @@ puts stdout "block_padleft pipeline"
puts stdout "[alias block_padleft]" puts stdout "[alias block_padleft]"
puts stderr "block_padleft \[>punk . logo] 50" puts stderr "block_padleft \[>punk . logo] 50"
puts stdout "[block_padleft [>punk . logo] 50]" puts stdout "[block_padleft [>punk . logo] 50]"
package require overtype
set out ""
foreach ln [.= block_padleft [>punk . logo ] 2 |> linelist] bgline [.= block_padleft [>punk . logo] 100 |> linelist] {
append out [overtype::left $bgline [a+ green bold]$ln[a+]]\n
}
puts stdout "$out"

95
scriptlib/tests/codewars_cola.tcl

@ -0,0 +1,95 @@
#naive - literal approach to the problem via a form of simulation (as attempted in https://www.youtube.com/watch?v=7fylNa2wZaU)
#the proper solution is of course just a little bit of maths - but the list-manipulation is an interesting exercise.
proc collapse lst {
#puts stdout "lst:'$lst' len:[llength $lst]"
foreach i $lst {
#puts stderr "'$i len:[llength $i] len-el0:[llength [lindex $i 0]]'"
if {[llength $i] == 2 && [llength [lindex $i 0]] ==2} {
lappend out [list [list [lindex $i 0 0] [expr {[lindex $i 0 1] + [lindex $i 1 1]}] ] ]
} else {
lappend out $i
}
}
return $out
}
#.=* list |h/0,t/tail> .=t>1*,h>end,h>end list |> punk::group_list_by {[lindex $item 0]} |> inspect |> .= collapse <q| {a 1} {b 1} {c 1}
#usage: drinkx 0 n {a 1} {b 1}...
pipealias drinkx .=* list {|
h/0,t/tail
>} .=t>1*,h>end,h>end list {|
data2,
nplus@end/1
>} {expr {$nsofar + $nplus}} {|
nsofar
>} {set data2} {|
>} punk::group_list_by {[lindex $item 0]} {|
>} .= collapse {|
>} .=>2 lmap v {lindex $v 0} {|
>} .=nsofar>1,n>2,data>end* list <q/2-end,nsofar/0,n/1|
input.= list {sheldon 1} {leonard 1} {penny 1} {rajesh 1} {howard 1}
pipealias xxx .= {list $nsofar $n {*}$q} {|
,
i/0,
n/1
>} .=>. {set in $data; while {$i < $n } {
#puts stdout "$i < $n"
#puts stdout "drinkx $in"
set in [drinkx {*}$in]
lassign $in i n
}; set in} {|
>} inspect -channel null {|
result/end
>} {set result} <q/2-end,nsofar/0,n/1|
#xxx 0 10010 {*}$input
#howard
#xxx 0 7230702951 {*}$input
#(our result is at end of list)
#leonard
set js_solution {
function whoIsNext(names, r){
let peopleInLine = names.length;
let copiesOfEachPerson = 1;
while (r > peopleInLine) {
r -= peopleInLine;
copiesOfEachPerson *= 2;
peopleInLine *= 2;
}
return names[Math.floor((r - 1) / copiesOfEachPerson) % peopleInLine];
}
}
proc who_is_next {names n} {
set peopleInLine [llength $names]
set copiesOfEachPerson 1
while {$n > $peopleInLine} {
set n [expr {$n - $peopleInLine}]
set copiesOfEachPerson [expr {$copiesOfEachPerson * 2}]
set peopleInLine [expr {$peopleInLine * 2}]
}
set idx [expr {int(floor(($n -1)/$copiesOfEachPerson)) % $peopleInLine}]
#puts "idx:$idx names: $names"
set result [lindex $names $idx]
}

6
scriptlib/tests/first_assign.tcl

@ -1,4 +1,6 @@
#experiment with the dangers of substitution in the first position after = in pipelines #experiment with the dangers of substitution in the first position after = in pipelines
puts stderr "Relevant for consideration if attempting to build pipelines parametrically"
puts stdout {set i {"a b "}} puts stdout {set i {"a b "}}
set i {"a b "} set i {"a b "}
@ -12,3 +14,7 @@ puts stderr "% x=\$i -> $errm"
#%x="a b " #%x="a b "
#however.. this is no different from the risk in normal tcl usage
# e.g lindex x$i 0

32
scriptlib/tests/fun.tcl

@ -253,11 +253,15 @@ proc pipefun::fun {name argspec body} {
#set case [list pipecase ,$a= |$a> .= $b <|] #set case [list pipecase ,$a= |$a> .= $b <|]
append case { {*}$switchargs} append case { {*}$switchargs}
#we can't maintain case as a proper list.. because it isn't. (contains {*}$xxx) #we can't maintain case as a proper list.. because it isn't. (contains {*}$xxx)
append pipecases $case\n append pipecases $case\n
} }
set casenomatch [string map [list <name> $name] {pipecase .= {error "casenomatch fun: <name> args: $args" "pipefun::fun <name>" {casenomatch unhandled_args}} <args|}]
append casenomatch { {*}$switchargs}
append pipecases $casenomatch\n
set nsup [uplevel 1 [list namespace current]] set nsup [uplevel 1 [list namespace current]]
if {$nsup eq "::"} { if {$nsup eq "::"} {
set nsup "" set nsup ""
@ -273,18 +277,18 @@ proc pipefun::fun {name argspec body} {
# } # }
# } <arglist| {*}$args # } <arglist| {*}$args
#}] #}]
puts "creating alias '$name'" puts "creating alias '$name' (argspec:$argspec)"
interp alias {} $name {} pipeswitchc $pipecases #interp alias {} $name {} pipeswitchc $pipecases
interp alias {} $name {} pipeswitch $pipecases
} }
interp alias {} fun {} [nsjoin [namespace current] pipefun::fun]
interp alias {} fun {} pipefun::fun interp alias {} funs {} [nsjoin [namespace current] pipefun::funs]
interp alias {} funs {} pipefun::funs interp alias {} funclear {} [nsjoin [namespace current] pipefun::funclear]
interp alias {} funclear {} pipefun::funclear interp alias {} funinfo {} [nsjoin [namespace current] pipefun::funinfo]
interp alias {} funinfo {} pipefun::funinfo interp alias {} funclause {} [nsjoin [namespace current] pipefun::funclause]
interp alias {} funclause {} pipefun::funclause
fun age argc#,v@0-end { fun age argc#,v@0-end {
#always runs for age - falls through to other implementations #always runs for age - falls through to other implementations
@ -294,8 +298,12 @@ fun age argc#,v@0-end {
#only runs for exactly 2 args #only runs for exactly 2 args
fun age a@,m@,2# { fun age a@,m@,2# {
puts "You're $a! $m" puts stderr "You're $a! $m"
# pipematch r@@ok/resultx.= age $a pipeswitch {
pipecase r@@ok/result.= age $a
pipecase r.= age $a
}
return $r
} }
@ -357,7 +365,7 @@ fun age a {
#but only if we *don't* have a mismatch. #but only if we *don't* have a mismatch.
#i.e we require an @@error/mismatch to proceed to other implementations #i.e we require an @@error/mismatch to proceed to other implementations
#puts stderr "=--->$switchresult" #puts stderr "=--->$switchresult"
if {[ispipematch r@@error/mismatch.= val $switchresult]} { if {[ispipematch r@@casemismatch.= val $switchresult]} {
#all good - simulate an @@error/mismatch - or raise an 'ignore' error so that this implementation is considered to be unmatched and we fall through to others. #all good - simulate an @@error/mismatch - or raise an 'ignore' error so that this implementation is considered to be unmatched and we fall through to others.
#puts stdout "=ispipematch true" #puts stdout "=ispipematch true"
error [list ignore [list argcheck passed]] error [list ignore [list argcheck passed]]

37
scriptlib/tests/functional/divisible_sum_pairs.tcl

@ -0,0 +1,37 @@
set ints [list 1 2 3 4 5 6]
set k 5
cartesianpairs1.= {foreach i $ints {foreach j $ints {lappend out [list $i $j]}}; set out} <ints| {*}$ints
pipeset cpairs1 .= {foreach i $ints {foreach j $ints {lappend out [list $i $j]}}; set out} <ints|
pipeset cpairs2 .= {foreach i $a {foreach j $b {lappend out [list $i $j]}}; set out} <a@0,b@1|
pipeset alg .= list |> \
{inspect -label K= $k} |> \
.= {foreach i $ints {foreach j $ints {lappend out [list $i $j]}}; set out} |> \
list_filter_cond { = $item |a/0,b/1> .= {expr $b > $a}} |> \
{list_filter_cond { .= list $item $k |a/0/0,b/0/1,k/1> \
.= {expr {($a + $b) % $k == 0} }} $data } <k/head,ints/tail|
puts [{*}$alg $k {*}$ints]
#todo
#https://wiki.tcl-lang.org/page/cons
proc cons {a b} {list $a $b}
proc car {p} {lindex $p 0}
proc cdr {p} {lindex $p 1}
proc LIST args {
if {![llength $args]} {
return {}
} else {
return [cons [lindex $args 0] [LIST {*}[lrange $args 1 end]]]
}
}

28
scriptlib/tests/functional/j.tcl

@ -0,0 +1,28 @@
#NOT really very lazy..
#pipealias lazy .=>. {inspect "$h|$t"} |> {list $h [list lazy $name $t]} |r,fn/1> {upvar $name nm; pipeset nm .= {*}$fn} |> {lindex $r 0} <h/1/anyhead,t/1/anytail,name@0|
pipealias lazy .=>. {list $h [list lazy $name $t]} |r,fn/1> {upvar $name nm; pipeset nm .= {*}$fn} |> {lindex $r 0} <h/1/anyhead,t/1/anytail,name@0|
pipealias lazyfun =infun>0 |a/0/0,b/0/1,c/0/2> {list $a $b [list init {*}$c]} |> .=* |> inspect |h> {pipealias $name .= eval \$$name} |> {set name} <infun/0,name/0/1,'lazy'/@0/0|
lazyfun {lazy j {a b c d e}}
#pipealias listgen = |h/0,fn/1> {upvar $name nm; pipeset nm .= {*}$fn} |> {set h} <l@1,name@0|
#NOTE that not all functional languages seem to make use of cons cells - and they are arguably not required and/or not the right approach for Tcl(?)
#standard lists are likely to be more efficient.
#
proc cons {a b} {list $a $b}
proc car {p} {lindex $p 0}
proc cdr {p} {lindex $p 1}
# "cons cell" structure (a specific type of linked-list)
proc LIST args {
if {![llength $args]} {
return {}
} else {
return [cons [lindex $args 0] [LIST {*}[lrange $args 1 end]]]
}
}

23
scriptlib/tests/functional/quicksort.tcl

@ -0,0 +1,23 @@
#quicksort is a prime example of an algorithm that is more suited to imperative than functional.
#As it relies on swap in place it can be considered a pathological case for functional programmin
#There are however ways to make it work
#example of some functional approaches to quicksort
#https://www.youtube.com/watch?v=vzfy4EKwG_Y
set js {
function partition(arr, pivotIndex, low, high) {
let partitionIndex = low;
for (let i = low; i< high; i++) {
if (arr[i] < arr[pivotIndex]) {
swap(arr, i, partitionIndex);
partitionIndex++;
}
}
swap(arr, high, partitionIndex);
return partitionIndex;
}
}

6
scriptlib/tests/html.tcl

@ -120,7 +120,7 @@ pipeset htmldoc .= list "julian@precisium.com.au" "info@precisium.com" |email_
pipeswitch { pipeswitch {
pipecase \ pipecase \
.= val $pipeargs |argd> \ .= val $pipeargs |argd> inspect -channel null |>\
1.= { 1.= {
dict exists $argd -author dict exists $argd -author
} { } {
@ -139,7 +139,7 @@ pipeset htmldoc .= list "julian@precisium.com.au" "info@precisium.com" |email_
pipecase .= val "Author: unknown" |> div [attrs hidden hidden] pipecase .= val "Author: unknown" |> div [attrs hidden hidden]
} |> p [attrs] |> footer [attrs] } |> inspect -channel null -label argd |> p [attrs] |> footer [attrs]
#puts "author: $author" #puts "author: $author"
@ -215,5 +215,5 @@ proc make_script {pipeline} {
proc run_pipe {pipeline} { proc run_pipe {pipeline} {
funcl::funcl_script_test [make_script $pipeline] funcl::funcl_script_test [make_script $pipeline]
} }
puts stdout "created pipeline in variable htmldoc"

6
scriptlib/tests/listbuilder.tcl

@ -101,7 +101,7 @@ pipeset commentpipe normallist.= rawlist/0.= {
} { } {
#more comments - but we need to pass the pipeline data through here - so 'set data' required at end. #more comments - but we need to pass the pipeline data through here - so 'set data' required at end.
set data set data
} |> string trim |> linelist |> .=/2 lmap v {string trim $v} } |> string trim |> linelist |> .=>2 lmap v {string trim $v}
pipeputs $commentpipe pipeputs $commentpipe
{*}$commentpipe {*}$commentpipe
@ -111,14 +111,14 @@ puts stdout "normallist:$normallist"
puts stderr $sep puts stderr $sep
pipeset pipe2 alt.= = $rawlist |> .=/1 lrange 0 end pipeset pipe2 alt.= = $rawlist |> .=>1 lrange 0 end
puts stdout "Alternative interpretation of list data" puts stdout "Alternative interpretation of list data"
puts stdout "pipe2:" puts stdout "pipe2:"
pipeputs $pipe2 pipeputs $pipe2
{*}$pipe2 {*}$pipe2
puts stdout "alt: $alt" puts stdout "alt: $alt"
pipeset pipe3 alt.= = $rawlist |> .=* list pipeset pipe3 alt.= = $rawlist |> .=>* list
puts stdout "Or.." puts stdout "Or.."
puts stdout "pipe3:" puts stdout "pipe3:"
pipeputs $pipe3 pipeputs $pipe3

10
scriptlib/tests/nameservers.tcl

@ -7,12 +7,12 @@ proc pipe_webpub {} {
pipeset subpipe % .= { pipeset subpipe % .= {
pipeswitch { pipeswitch {
pipecase \ pipecase \
.= val [lindex $switchargs 0] \ .= val [lindex $switchargs 0] {|
|> {string trimright $data .} |server> {split $data .} \ >} {string trimright $data .} |server> {split $data .} {|
|> 'webpub.net'.= { >} 'webpub.net'.= {
join [lrange $data 1 2] . join [lrange $data 1 2] .
} \ } {|
|> { >} {
list type internal server $server list type internal server $server
} }

64
scriptlib/tests/parser.tcl

@ -0,0 +1,64 @@
proc p_digit str {
if {[string is digit -strict [string index $str 0]]} {
return [list [string index $str 0] [string range $str 1 end]]
} else {
return [list]
}
}
proc p_char {str ch} {
if {[string index $str 0] eq $ch} {
return [list [string index $str 0] [string range $str 1 end]]
} else {
return [list]
}
}
proc parser_of_char {ch} {
pipeset outparser @@ok/result.= {
pipeswitch {
pipecase .= list $input $ch |data/0,char/1> \
,'${ch}'@0.= {p_char $data $char}
return [list ok [list result [list]]]
}
} <ch/0,input/1| $ch
}
proc some {parser} {
}
#generate a functor on a pipeline targeting a specific section of the 'value' in: ok {result value}
proc fmap {cmdlist pipeline} {
pipeset functor .= {
pipeswitch {
pipecase .= list $cmd $p $input |cmd@,pipe@,input@> \
,'result'@@ok/@0.= {
.= list $pipe $input |p@,i@> {{*}$p $i}
} |result@@ok/result> =result>1/1
return nothing-functor
}
} <cmd@,p@,input@| $cmdlist $pipeline
}
proc charP {ch} {
pipeset parser .= {
pipeswitch {
#puts "-->$input"
pipecase = $input |> \
,'${ch}'@0.= {list [string index $data 0] [string range $data 1 end] } |> {
set data
}
return nothing
}
} <ch/0,input/1| $ch
}

5
scriptlib/tests/pipeline1.tcl

@ -41,8 +41,9 @@ set input [list a b c d e f g]
a.= val $input |> { a.= val $input |> {
.= lrange $data 1 end-1 |>\ .= lrange $data 1 end-1 {|
b.= string toupper
>} b.= string toupper
puts stdout "==================================" puts stdout "=================================="
puts stdout "info vars: [info vars]" puts stdout "info vars: [info vars]"

4
scriptlib/tests/pipeswitch.tcl

@ -64,7 +64,9 @@ proc match_args {args} {
return [list source pipecase3 data [list transformed {*}$data]] return [list source pipecase3 data [list transformed {*}$data]]
} }
pipecase .= val $args |> { pipecase .= val $args {|
>} {
puts "catchall pipe4 $data" puts "catchall pipe4 $data"
return $data return $data
} }

10
scriptlib/tests/wanted.tcl

@ -2,17 +2,17 @@
# this should run 'list a b c tail' # this should run 'list a b c tail'
catch { catch {
% x.=/0* tail |> {puts $data;set data} <in| list a b c % x.=>0* tail |> inspect <in| list a b c
} }
#should it then be able to run pipelines as 'args' #should it then be able to run pipelines as 'args'
% x.=/0* |> {puts $data;set data} <in| % y.= list etc blah |> string toupper % x.=>0* |> inspect <in| % y.= list etc blah |> string toupper
#but then what would happen if the args pipeline also took input via another <| ? #but then what would happen if the args pipeline also took input via another <| ?
#% x.=/0* |> {puts $data;set data} <in| % y.= list etc blah <| list data % x.=>* |> inspect <in| % y.= list etc blah <| list data
#presumably pipelines shouldn't be passed in as expanded lists.. #punk modified so pipeline operates to the leftmost <|
% out= x= |> {puts $data; set data} |p1/0> .= { {*}$p1 } |> {puts $data;set data} <in| [list % y.= list etc blah |> string toupper] % out= x= |> inspect |p1/0> .= { {*}$p1 } |> inspect <in| [list % y.= list etc blah |> string toupper]

Loading…
Cancel
Save