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 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 "-----------------------------" |
||||
|
||||
|
||||
@ -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} { |
||||
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 |
||||
|
||||
|
||||
|
||||
|
||||
@ -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