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 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"
#should be unreachable
puts stdout "-----------------------------"

2
scriptlib/hello.tcl

@ -12,6 +12,6 @@ puts -nonewline stderr "5 hello on stderr no line-ending"
flush stderr
puts -nonewline stdout "6 hello on stdout no line-ending"
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} {
set persec [lindex $::argv 0]
} else {
set persec 1
}
if {$::argc == 2} {
set what [lindex $::argv 1]
} else {
set what "."
}
if {$persec > 1000} {
puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed"
flush stderr
after 500
}
#--- confg ---
set newline_every_x_seconds 5
#---
chan configure stdout -blocking 1 -buffering none
set counter 0
set ms [expr {1000 / $persec}]
set nl_every [expr {$persec * $newline_every_x_seconds}]
proc schedule {} {
if {$::forever_stdout_per_second} {
after idle [list after 0 ::emit]
tailcall after $::ms ::schedule
} else {
after idle [list ::the_end]
}
}
set ::forever_stdout_per_second 1
proc the_end {} {
puts stderr "-done-"
flush stderr
flush stdout
set ::done_stdout_per_second 1
}
proc emit {} {
upvar ::counter c
if {($c > 1) && (($c % $::nl_every) == 0)} {
puts -nonewline stdout " "
flush stdout
puts stderr $c
flush stderr
} else {
puts -nonewline stdout $::what
}
#flush stdout
incr c
}
chan configure stdin -blocking 0 -buffering none
chan event stdin readable [list apply {{chan} {
set chunk [chan read $chan]
if {[string length $chunk]} {
if {[string match "*q*" [string tolower $chunk]]} {
set ::forever_stdout_per_second 0
chan event $chan readable {}
puts stderr "cancelling"
}
}
if {[chan eof $chan]} {
chan event $chan readable {}
}
}} stdin]
schedule
vwait ::forever_stdout_per_second
vwait ::done_stdout_per_second
if {$::argc >= 1} {
set persec [lindex $::argv 0]
} else {
set persec 1
}
if {$::argc == 2} {
set what [lindex $::argv 1]
} else {
set what "."
}
if {$persec > 1000} {
puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed"
flush stderr
after 500
}
#--- confg ---
set newline_every_x_seconds 5
#---
chan configure stdout -blocking 1 -buffering none
set counter 0
set ms [expr {1000 / $persec}]
set nl_every [expr {$persec * $newline_every_x_seconds}]
proc schedule {} {
if {$::forever_stdout_per_second} {
after idle [list after 0 ::emit]
tailcall after $::ms ::schedule
} else {
after idle [list ::the_end]
}
}
set ::forever_stdout_per_second 1
proc the_end {} {
puts stderr "-done-"
flush stderr
flush stdout
set ::done_stdout_per_second 1
}
proc emit {} {
upvar ::counter c
if {($c > 1) && (($c % $::nl_every) == 0)} {
puts -nonewline stdout " "
flush stdout
puts stderr $c
flush stderr
} else {
puts -nonewline stdout $::what
}
#flush stdout
incr c
}
chan configure stdin -blocking 0 -buffering none
chan event stdin readable [list apply {{chan} {
set chunk [chan read $chan]
if {[string length $chunk]} {
if {[string match "*q*" [string tolower $chunk]]} {
set ::forever_stdout_per_second 0
chan event $chan readable {}
puts stderr "cancelling"
}
}
if {[chan eof $chan]} {
chan event $chan readable {}
}
}} stdin]
schedule
vwait ::forever_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 stderr "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
puts stderr "Relevant for consideration if attempting to build pipelines parametrically"
puts stdout {set i {"a b "}}
set i {"a b "}
@ -12,3 +14,7 @@ puts stderr "% x=\$i -> $errm"
#%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 <|]
append case { {*}$switchargs}
#we can't maintain case as a proper list.. because it isn't. (contains {*}$xxx)
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]]
if {$nsup eq "::"} {
set nsup ""
@ -273,18 +277,18 @@ proc pipefun::fun {name argspec body} {
# }
# } <arglist| {*}$args
#}]
puts "creating alias '$name'"
interp alias {} $name {} pipeswitchc $pipecases
puts "creating alias '$name' (argspec:$argspec)"
#interp alias {} $name {} pipeswitchc $pipecases
interp alias {} $name {} pipeswitch $pipecases
}
interp alias {} fun {} pipefun::fun
interp alias {} funs {} pipefun::funs
interp alias {} funclear {} pipefun::funclear
interp alias {} funinfo {} pipefun::funinfo
interp alias {} funclause {} pipefun::funclause
interp alias {} fun {} [nsjoin [namespace current] pipefun::fun]
interp alias {} funs {} [nsjoin [namespace current] pipefun::funs]
interp alias {} funclear {} [nsjoin [namespace current] pipefun::funclear]
interp alias {} funinfo {} [nsjoin [namespace current] pipefun::funinfo]
interp alias {} funclause {} [nsjoin [namespace current] pipefun::funclause]
fun age argc#,v@0-end {
#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
fun age a@,m@,2# {
puts "You're $a! $m"
# pipematch r@@ok/resultx.= age $a
puts stderr "You're $a! $m"
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.
#i.e we require an @@error/mismatch to proceed to other implementations
#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.
#puts stdout "=ispipematch true"
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 {
pipecase \
.= val $pipeargs |argd> \
.= val $pipeargs |argd> inspect -channel null |>\
1.= {
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]
} |> p [attrs] |> footer [attrs]
} |> inspect -channel null -label argd |> p [attrs] |> footer [attrs]
#puts "author: $author"
@ -215,5 +215,5 @@ proc make_script {pipeline} {
proc run_pipe {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.
set data
} |> string trim |> linelist |> .=/2 lmap v {string trim $v}
} |> string trim |> linelist |> .=>2 lmap v {string trim $v}
pipeputs $commentpipe
{*}$commentpipe
@ -111,14 +111,14 @@ puts stdout "normallist:$normallist"
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 "pipe2:"
pipeputs $pipe2
{*}$pipe2
puts stdout "alt: $alt"
pipeset pipe3 alt.= = $rawlist |> .=* list
pipeset pipe3 alt.= = $rawlist |> .=>* list
puts stdout "Or.."
puts stdout "pipe3:"
pipeputs $pipe3

10
scriptlib/tests/nameservers.tcl

@ -7,12 +7,12 @@ proc pipe_webpub {} {
pipeset subpipe % .= {
pipeswitch {
pipecase \
.= val [lindex $switchargs 0] \
|> {string trimright $data .} |server> {split $data .} \
|> 'webpub.net'.= {
.= val [lindex $switchargs 0] {|
>} {string trimright $data .} |server> {split $data .} {|
>} 'webpub.net'.= {
join [lrange $data 1 2] .
} \
|> {
} {|
>} {
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 |> {
.= lrange $data 1 end-1 |>\
b.= string toupper
.= lrange $data 1 end-1 {|
>} b.= string toupper
puts stdout "=================================="
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]]
}
pipecase .= val $args |> {
pipecase .= val $args {|
>} {
puts "catchall pipe4 $data"
return $data
}

10
scriptlib/tests/wanted.tcl

@ -2,17 +2,17 @@
# this should run 'list a b c tail'
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'
% 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 <| ?
#% 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