You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
320 lines
10 KiB
320 lines
10 KiB
package provide funcl [namespace eval funcl { |
|
variable version |
|
set version 0.1 |
|
}] |
|
#funcl = function list (nested call structure) |
|
# |
|
#a basic functional composition o combinator |
|
#o(f,g)(x) == f(g(x)) |
|
|
|
namespace eval funcl { |
|
|
|
#from punk |
|
proc arg_is_script_shaped {arg} { |
|
if {[string first " " $arg] >= 0} { |
|
return 1 |
|
} elseif {[string first \n $arg] >= 0} { |
|
return 1 |
|
} elseif {[string first ";" $arg] >= 0} { |
|
return 1 |
|
} elseif {[string first \t $arg] >= 0} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
|
|
proc o args { |
|
set closing [string repeat {]} [expr [llength $args]-1]] |
|
set body "[join $args { [}] \$data $closing" |
|
return $body |
|
} |
|
|
|
proc o_ args { |
|
set body "" |
|
set tails [lrepeat [llength $args] ""] |
|
puts stdout "tails: $tails" |
|
|
|
set end [lindex $args end] |
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
|
set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
|
} else { |
|
set endfunc $end |
|
} |
|
if {[llength $args] == 1} { |
|
return $endfunc |
|
} |
|
|
|
set wrap { [} |
|
append wrap $endfunc |
|
append wrap { ]} |
|
|
|
set i 0 |
|
foreach cmdlist [lrange $args 0 end-1] { |
|
set is_script 0 |
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
|
set is_script 1 |
|
set script [lindex $cmdlist 0] |
|
} |
|
set t "" |
|
if {$i > 0} { |
|
append body { [} |
|
} |
|
set posn [lsearch $cmdlist _] |
|
if {$posn <= 0} { |
|
append body $cmdlist |
|
if {$i == [expr {[llength $args] -2}]} { |
|
#append body " \$data" |
|
append body " $wrap" |
|
} |
|
if {$i > 0} { |
|
set t {]} |
|
} |
|
} else { |
|
append body [lrange $cmdlist 0 $posn-1] |
|
if {$i == [expr {[llength $args] -2}]} { |
|
#append body " \$data" |
|
append body " $wrap" |
|
} |
|
set t [lrange $cmdlist $posn+1 end] |
|
if {$i > 0} { |
|
append t { ]} |
|
} |
|
} |
|
lset tails $i $t |
|
incr i |
|
} |
|
append body [join [lreverse $tails] " "] |
|
puts stdout "tails: $tails" |
|
|
|
return $body |
|
} |
|
|
|
#review - consider _call -- if count > 1 then they must all be callable cmdlists(?) |
|
# what does it mean to have additional _fn wrapper with no other elements? (no actual function) |
|
#e.g _fn 2 5 6 somefunc {_fn 1 3 {_call 1 3 xxx}} {_fn 1 4 command {_fn ...}} |
|
# what type indicates running subtrees in parallel vs sequentially? |
|
# any reason to have _call count other than 1? Presumably the parent node indicates the parallelism/sequentialism etc. |
|
# |
|
# |
|
# accept or return a funcl (or funcltree if multiple funcls in one commandlist) |
|
# also accept/return a call - return empty list if passed a call |
|
proc next_funcl {funcl_or_tree} { |
|
if {[lindex $funcl_or_tree 0] eq "_call"} { |
|
return [list] |
|
} |
|
if {[lindex $funcl_or_tree 0] in [list "_fn" "_call"]} { |
|
set funcl $funcl_or_tree |
|
} else { |
|
error "funcltree not implemented" |
|
} |
|
|
|
|
|
set count [lindex $funcl 1] |
|
if {$count == 0} { |
|
#null funcl.. what is it? metadata/placeholder? |
|
return $funcl |
|
} |
|
set indices [lrange $funcl 2 [expr {1 + $count}]] |
|
set i 0 |
|
foreach idx $indices { |
|
if {$i > 0} { |
|
#todo - return a funcltree |
|
error "multi funcl not implemented" |
|
} |
|
set next [lindex $funcl $idx] |
|
incr i |
|
} |
|
|
|
return $next |
|
|
|
} |
|
|
|
#convert a funcl to a tcl script |
|
proc funcl_script {funcl} { |
|
if {![llength $funcl]} { |
|
return "" |
|
} |
|
set body "" |
|
set tails [list] |
|
|
|
set type [lindex $funcl 0] |
|
if {$type ni [list "_fn" "_call"]} { |
|
#todo - handle funcltree |
|
error "type $type not implemented" |
|
} |
|
|
|
|
|
#only count of 1 with index 3 supported(?) |
|
if {$type eq "_call"} { |
|
#leaf |
|
set cmdlist [lindex $funcl 3] |
|
return $cmdlist |
|
} |
|
|
|
#we will use next_funcl to walk the nodes.. todo support treefuncl response from next_funcl which could branch multiple times. |
|
#by continually passing back the resulting treefuncl/funcl to next_funcl we can process in correct order (?) |
|
# we would still need to maintain state to stitch it back together once returned from a subtree.. |
|
# ie multiple tail parts |
|
set count [lindex $funcl 1] |
|
|
|
if {$count == 1} { |
|
set idx [lindex $funcl 2] |
|
if {$idx == 3} { |
|
set cmdlist_pre [list] |
|
} else { |
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
|
} |
|
append body $cmdlist_pre |
|
set t [lrange $funcl $idx+1 end] |
|
lappend tails $t |
|
} else { |
|
#?? |
|
error "funcl_script branching not yet supported" |
|
} |
|
|
|
|
|
set get_next 1 |
|
set i 1 |
|
while {$get_next} { |
|
set funcl [next_funcl $funcl] |
|
if {![llength $funcl]} { |
|
set get_next 0 |
|
} |
|
lassign $funcl type count idx ;#todo support count > 1 |
|
if {$type eq "_call"} { |
|
set get_next 0 |
|
} |
|
set t "" |
|
if {$type eq "_call"} { |
|
append body { [} |
|
append body [lindex $funcl $idx] |
|
append body { ]} |
|
} else { |
|
append body { [} |
|
if {$idx == 3} { |
|
set cmdlist_pre [list] |
|
} else { |
|
set cmdlist_pre [lrange $funcl 3 $idx-1] |
|
} |
|
append body $cmdlist_pre |
|
set t [lrange $funcl $idx+1 end] |
|
lappend tails $t |
|
lappend tails { ]} |
|
} |
|
incr i |
|
} |
|
append body [join [lreverse $tails] " "] |
|
#puts stdout "tails: $tails" |
|
|
|
return $body |
|
} |
|
|
|
|
|
interp alias "" o_of "" o_of_n 1 |
|
|
|
#o_of_n |
|
#tcl list rep o combinator |
|
# |
|
# can take lists of ordinary commandlists, scripts and funcls |
|
# _fn 1 x where 1 indicates number of subfuncls and where x indicates next funcl position (_fn list or _arg) |
|
# _fn 0 indicates next item is an unwrapped commandlist (terminal command) |
|
# |
|
#o_of is equivalent to o_of_n 1 (1 argument o combinator) |
|
#last n args are passed to the prior function |
|
#e.g for n=1 f a b = f(a(b)) |
|
#e.g for n=2, e f a b = e(f(a b)) |
|
proc o_of_n {n args} { |
|
if {$n != 1} { |
|
error "o_of_n only implemented for 1 sub-funcl" |
|
} |
|
set comp [list] ;#composition list |
|
set end [lindex $args end] |
|
if {[lindex $end 0] in [list "_fn" "_call"]} { |
|
#is_funcl |
|
set endfunc [lindex $args end] |
|
} else { |
|
if {[llength $end] == 1 && [arg_is_script_shaped $end]} { |
|
#set endfunc [string map [list <end> $end] {uplevel 1 [list if 1 <end> ]}] |
|
set endfunc [list _call 1 3 [list uplevel 1 [list if 1 [lindex $end 0]]]] |
|
} else { |
|
set endfunc [list _call 1 3 [list {*}$end]] |
|
} |
|
} |
|
|
|
if {[llength $args] == 1} { |
|
return $endfunc |
|
} |
|
set comp $endfunc |
|
set revlist [lreverse [lrange $args 0 end-1]] |
|
foreach cmdlist $revlist { |
|
if {([llength $cmdlist] == 1) && [arg_is_script_shaped [lindex $cmdlist 0]]} { |
|
set is_script 1 |
|
set script [lindex $cmdlist 0] |
|
set arglist [list data] |
|
|
|
set comp [list _fn 1 6 call_script $script $arglist $comp] |
|
} else { |
|
set posn1 [expr {[llength $cmdlist] + 2 + $n}] |
|
set comp [list _fn $n $posn1 {*}$cmdlist $comp] |
|
} |
|
} |
|
return $comp |
|
} |
|
proc call_script {script argnames args} { |
|
uplevel 3 [list if 1 [list apply [list $argnames $script] {*}$args]] |
|
} |
|
proc funcl_script_test {scr} { |
|
do_funcl_script_test $scr |
|
} |
|
proc do_funcl_script_test {scr} { |
|
#set j "in do_funcl_script_test" |
|
#set data "xxx" |
|
#puts '$scr' |
|
if 1 $scr |
|
} |
|
|
|
#standard o_ with no script-handling |
|
proc o_plain args { |
|
set body "" |
|
set i 0 |
|
set tails [lrepeat [llength $args] ""] |
|
#puts stdout "tails: $tails" |
|
foreach cmdlist $args { |
|
set t "" |
|
if {$i > 0} { |
|
append body { [} |
|
} |
|
set posn [lsearch $cmdlist _] |
|
if {$posn <= 0} { |
|
append body $cmdlist |
|
if {$i == [expr {[llength $args] -1}]} { |
|
append body " \$data" |
|
} |
|
if {$i > 0} { |
|
set t {]} |
|
} |
|
} else { |
|
append body [lrange $cmdlist 0 $posn-1] |
|
if {$i == [expr {[llength $args] -1}]} { |
|
append body " \$data" |
|
} |
|
set t [lrange $cmdlist $posn+1 end] |
|
if {$i > 0} { |
|
append t { ]} |
|
} |
|
} |
|
lset tails $i $t |
|
incr i |
|
} |
|
append body [join [lreverse $tails] " "] |
|
#puts stdout "tails: $tails" |
|
|
|
return $body |
|
} |
|
#timings suggest no faster to split out the first item from the cmdlist loop |
|
} |
|
|
|
|
|
|