Julian Noble
1 year ago
19 changed files with 411 additions and 111 deletions
@ -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 "-----------------------------" |
||||||
|
|
||||||
|
@ -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]/__]] |
||||||
|
|
@ -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" |
@ -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 |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -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] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
@ -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]]] |
||||||
|
} |
||||||
|
} |
@ -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]]] |
||||||
|
} |
||||||
|
} |
@ -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; |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
@ -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 |
||||||
|
} |
Loading…
Reference in new issue