2 changed files with 445 additions and 77 deletions
@ -0,0 +1,320 @@
|
||||
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 "" funcl::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 |
||||
} |
||||
|
||||
|
||||
|
||||
Loading…
Reference in new issue