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

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
}