fptools

Difference between version 18 and 19 - Previous - Next
'''fptools''' is a library of general-purpose commands for [functional programming] in Tcl 8.5, Tcl 8.6 and [Jim Tcl]. The library implements [Commands pipe%|%command pipelines], [pattern matching] on lists, [range], a Clojure-like `recur` that uses [tailcall] when available and a number of list transformations. Each proc is described in a comment above its declaration.
'''fptools''' is a library of general-purpose commands for [functional programming] in Tcl 8.5, Tcl 8.6 and [Jim Tcl]. The library implements [Commands pipe%|%command pipelines], [pattern matching] on lists, [range], a [Clojure]-like `recur` that uses [tailcall] when available and a number of list transformations. Each proc is described in a comment above its declaration.
You can download the library with [wiki-reaper]: `wiki-reaper 41349 0 16 | tee fptools-0.6.2.tm` If you fix a bug please increment the patch level in `::fptools::version`.
**Code**
======
#! /usr/bin/env tclsh
# fptools, a collection of procedures for functional programming for Tcl 8.5,
# Tcl 8.6 and Jim Tcl.
# Copyright (C) 2015, 2017 dbohdan
# License: MIT.
namespace eval ::fptools {
variable version 0.6.2
}
# Return an incorrect usage error up one level.
proc ::fptools::wrongnargs {arguments} {
set caller [dict get [info frame -1] proc]
return -code error -level 2 \
"wrong # args: should be \"$caller $arguments\""
}
** See also **
# Tail call the caller proc with the arguments from $args. (If [tailcall] isn't
# available, just call it with the same arguments.)
if {[info commands tailcall] eq {tailcall}} {
proc ::fptools::recur args {
set caller [dict get [info frame -1] proc]
tailcall $caller {*}$args
}
} else {
proc ::fptools::recur args {
set caller [dict get [info frame -1] proc]
$caller {*}$args
}
}
* [Additional list functions]
# Pipe the items of the list $value through a series of scripts. The results can
# be accessed from within each script as $pipe(n) (for the nth step, starting
# with $value as $pipe(0)).
proc ::fptools::pipe {value args} {
if { [llength $args] == 0 } {
wrongnargs {value script ?script ...? (or value {script ?script ...?})}
} elseif { [llength $args] == 1 } {
set commandList [lindex $args 0]
} else {
set commandList $args
}
set varName _
upvar 1 $varName iterator
upvar 1 pipe pipe
array unset pipe
set iterator {}
set pipe(0) $value
** Code **
for {set i 0} {$i < [llength $commandList]} {incr i} {
set iNext [expr {$i + 1}]
set command [lindex $commandList $i]
set pipe($iNext) {}
foreach iterator $pipe($i) {
lappend pipe($iNext) [uplevel 1 [list eval $command]]
}
}
set result $pipe($i)
return $result
}
#
# Default usage:
# * lpipe value {?lambdaArgs lambdaBody ...?}
# With options:
# * lpipe -long value {?lambda ...?}
# * lpipe -expanded value ?lambdaArgs lambdaBody ...?
# * lpipe -long -expanded value ?lambda ...?
#
# Apply one or more lambdas consequentially to $value. Lambdas can be applied in
# one of several ways. The way any given lambda is applied depends on the
# optional prefix you give before it. The prefixes are as follows:
#
# * "apply" or "all" or no prefix -- Apply the lambda to the value. The returned
# result of the lambda becomes the new value used for the next iteration.
#
# * "map" or "each" -- An N-to-1 map. Apply the lambda to each element of the
# value list one or more elements at a time depending on how many arguments the
# lambda takes. A list of consisting of the results of every such application in
# order becomes the new value.
#
# * "map*" or "each*" -- An N-to-M map. Same as above but treats each return
# result of the lambda as a list with one or more elements. The new value is a
# concatenation of those lists in order.
#
# * "reduce" or "foldl" -- Reduce the list that is the current value to a single
# value using a left fold (see http://wiki.tcl-lang.org/17983). Expects a lambda
# that takes two arguments.
#
# * "foldr" -- Same but reverses the list first.
proc ::fptools::lpipe {args} {
======
proc ::fptools::lpipe args {
set shortcutSyntax 1 set singleArg 1
if { [llength $args] == 0 } {
if {[llength $args] == 0} {
wrongnargs {?-option ...? value {?lambdaArgs1 lambdaBody1 ...?}} } else { for {set i 0} {[string match -* [lindex $args $i]]} {incr i} { set option [lindex $args $i] switch -exact -- $option { -- { break } -expanded { set singleArg 0 } -long { set shortcutSyntax 0 } default { error "unknown option: \"$option\"" } } } set value [lindex $args $i] if {$singleArg} { set lambdas [lindex $args $i+1] if {[llength $args] > $i + 2} { error "too many arguments: \"[lrange $args $i+2 end]\";\ did you forget to use the option -expanded?" } } else { set lambdas [lrange $args $i+1 end] } } # Get one lambda from the list. set getLambda { {} { upvar 1 shortcutSyntax shortcutSyntax upvar 1 lambdas lambdas upvar 1 i i set lambda [lindex $lambdas $i] if {$shortcutSyntax} { set lambda [list $lambda [lindex $lambdas $i+1]] incr i } return $lambda } } for {set i 0} {$i < [llength $lambdas]} {incr i} { if {[lindex $lambdas $i] in {map map* each each*}} { # Map N arguments (however many the lambda has) using the lambda to # one ("map" mode) or many ("map*" mode) items.
set flatten [expr { [lindex $lambdas $i] in {map* each*} }]
set flatten [expr {[lindex $lambdas $i] in {map* each*}}]
incr i set lambda [apply $getLambda] set lambdaArgCount [llength [lindex $lambda 0]] set newValue {} for {set j 0} {$j < [llength $value]} {incr j $lambdaArgCount} { set items {} for {set k $j} {$k < $j + $lambdaArgCount} {incr k} { lappend items [lindex $value $k] } set itemsResult [uplevel 1 [list apply $lambda {*}$items]] if {$flatten} { lappend newValue {*}$itemsResult } else { lappend newValue $itemsResult } } set value $newValue } elseif {[lindex $lambdas $i] eq {filter}} { # Filter. incr i set lambda [apply $getLambda] set newValue {} foreach item $value { if {[uplevel 1 [list apply $lambda $item]]} { lappend newValue $item } } set value $newValue } elseif {[lindex $lambdas $i] in {reduce foldl foldr}} { # Reduce the list to a single value with a two-argument lambda. if {[lindex $lambdas $i] eq {foldr}} { set value [lreverse $value] } incr i set lambda [apply $getLambda] set left [lindex $value 0] foreach right [lrange $value 1 end] { set left [uplevel 1 [list apply $lambda $left $right]] } set value $left } else { # Apply the lambda to the list. if {[lindex $lambdas $i] in {apply all}} { incr i } set lambda [apply $getLambda] set value [uplevel 1 [list apply $lambda $value]] } } return $value } ### List tools # Generate a list containing a range of integers. proc ::fptools::range args { set start 0 set end 0 set step 1 switch -exact -- [llength $args] {
1 { lassign $args end }
2 { lassign $args start end }
3 { lassign $args start end step }
1 {lassign $args end}
2 {lassign $args start end}
3 {lassign $args start end step}
default { wrongnargs {?start? end ?step?} } } if {$step == 0} { error "step can't be zero" } if {($end - $start) * $step < 0} { error "can't use step $step with a range from $start to $end" } set result {} for {set i $start} {$i < $end} {incr i $step} { lappend result $i } return $result } # Return the unique elements in a list.
proc ::fptools::luniq {list} {
proc ::fptools::luniq list {
return [lsort -unique $list] } # Take $n elements randomly (uniformly) sampled from a list. proc ::fptools::lsample {list {n 1}} { set result {} for {set i 0} {$i < $n} {incr i} { lappend result [lindex $list [expr { int(rand() * [llength $list]) }]] } return $result } # Return 1 if the list is empty and 0 otherwise. proc ::fptools::lempty {list} {
return [expr {
[llength $list] == 0
}]
expr {[llength $list] == 0}
} # Return only those elements of $list for which $script evaluates to true. proc ::fptools::lfilter {varName list script} { upvar 1 $varName var set result {} foreach var $list val $list { if {[uplevel 1 $script]} { lappend result $val } } return $result } # Reduce (left fold) a list of values to a single value using $script. To get a # right fold reverse the list first with [lreverse]. proc ::fptools::lreduce {varNameFirst varNameSecond initValue list script} { upvar 1 $varNameFirst first upvar 1 $varNameSecond second set first $initValue foreach second $list { set first [uplevel 1 $script] } return $first } # Compare the elements in two lists with the binary operation $op. Returns # 1 or 0. proc ::fptools::lcompare {list1 list2 {op eq}} { if {[info commands {::tcl::mathop::*}] eq {}} { # Jim Tcl. set compareLambda [format { {a b _} {
expr { $a %s $b }
expr {$a %s $b}
} } $op] } else { set compareLambda { {a b op} { ::tcl::mathop::$op $a $b } } } foreach elem1 $list1 elem2 $list2 { if {![apply $compareLambda $elem1 $elem2 $op]} { return 0 } } return 1 } # Flatten a list of nested lists $n levels. proc ::fptools::lflatten {list {n 1}} { set stack [list $list 0] set result {} while {[llength $stack] > 0} { lassign $stack elem depth set stack [lrange $stack 2 end]
if { ([llength $elem] > 1) && ($depth <= $n) } {
if {([llength $elem] > 1) && ($depth <= $n)} {
foreach subelem $elem {
set stack [linsert $stack 0 $subelem [expr { $depth + 1 }]]
set stack [linsert $stack 0 $subelem [expr {$depth + 1}]]
} } else { set result [linsert $result 0 $elem] } } return $result } # Create a new list by applying multiple scripts to the values in a list. proc ::fptools::lmultimap args { if {[llength $args] < 3} { wrongnargs {varList list script ?script...?} } lassign $args varList list set scripts [lrange $args 2 end] set varListLength [llength $varList] foreach varName $varList { upvar 1 $varName "loopVars$varName" } set result {} for {set i 0} {$i < [llength $list]} {incr i $varListLength} { foreach varName $varList value \ [lrange $list $i [expr {$i + $varListLength - 1}]] { set "loopVars$varName" $value } foreach script $scripts { lappend result [uplevel 1 $script] } } return $result } # Take any arguments and return an empty string. proc ::fptools::discard args { return {} } # Remove and return $n elements from the list stored in the variable $varName. proc ::fptools::lshift! {varName {n 1}} { upvar 1 $varName list set result [lrange $list 0 $n-1] set list [lrange $list $n end] return $result } # Get multiple elements from $list using the [lindex] notation. proc ::fptools::lmultiindex {list args} { set result {} foreach index $args { lappend result [lindex $list $index] } return $result } # Get multiple ranges of elements from $list. proc ::fptools::lmultirange {list args} { set result {} foreach {from to} $args { lappend result [lrange $list $from $to] } return $result } ### Pattern matching. # Match a list against a list pattern. A list pattern consists of element # patterns, one for each element in the list. An element pattern can be # preceded by an option that says what kind of pattern it is. The pattern # options are: "-exact", "-glob", "-lambda", "-command" and "-regexp". # # Matching has two modes: strict and nonstrict. In nonstrict mode, which is # the default mode, if a list is longer than the list pattern only as many # elements as there are in the list pattern are checked against it. In strict # mode a list that is longer than the list pattern does not match the list # pattern. In nonstrict mode an empty pattern matches everything; in strict # mode it matches nothing. # # If you want to match a pattern that starts with a dash ("-") you need to use # a match option or "--" before it. proc ::fptools::match {listPattern list {debug 0}} { set matchModeDefault -glob set matchMode $matchModeDefault # Can the next $p be an option? set canBeAnOption 1 # Options that affect all patterns. set specialOptions {-strict --} # All possible match modes. set matchModes {-exact -glob -lambda -command -regexp} set lengthMatch 0 if {$debug} { puts "matching [list $list] against [list $listPattern]" } set i 0 foreach p $listPattern { if {$debug} { puts " $p" } if {$canBeAnOption && ([string index $p 0] eq "-")} { if {$p in $specialOptions} { if {$debug} { puts { special option} } switch -exact -- $p { -nonstrict { set lengthMatch 0 } -strict { set lengthMatch 1 } -- { set canBeAnOption 0 } } } else { if {$debug} { puts { match mode} } if {$p in $matchModes} { set matchMode $p set canBeAnOption 0 } else { return -code error "bad option \"$p\"" } } continue } else { set canBeAnOption 1 } set elem [lindex $list $i] incr i if {$debug} { puts " element: $elem" } set gotMatch [switch -exact -- $matchMode { -exact {
expr { $elem eq $p }
expr {$elem eq $p}
} -glob { string match $p $elem } -lambda { uplevel 1 [list apply $p $elem] } -command { uplevel 1 [list {*}$p $elem] } -regexp { regexp $p $elem } default { error "unknown match mode $matchMode\ got through the initial check" } }] if {$debug} { puts " matched: $gotMatch" } # Reset matchMode for the next match. set matchMode $matchModeDefault if {!$gotMatch} { return 0 } } if {$lengthMatch && ($i < [llength $list])} { return 0 } return 1 } # If a list matches a list pattern (using [::fptools::match]) run a script that # corresponds to it. One of the patterns given must match or else an error is # generated. If the script is "-", fall through to the next script. proc ::fptools::mswitch args { if {[llength $args] == 2} { lassign $args list statements } elseif {[llength $args] >= 3} { set list [lindex $args 0] set statements [lrange $args 1 end] } else { wrongnargs {list pattern script ?pattern script?} } if {[llength $statements] % 2 == 1} { return -code error {extra mswitch pattern with no script} } for {set i 0} {$i < [llength $statements]} {incr i 2} { set pattern [lindex $statements $i] set script [lindex $statements $i+1] if {($pattern eq {default}) || [match $pattern $list]} { # Fallthrough. while {$script eq {-}} { incr i 2 set script [lindex $statements $i+1] } return [uplevel 1 $script] } } error {no matches} } ### Tests. namespace eval ::fptools::tests { variable verbose 0 } proc ::fptools::tests::assert expr { variable verbose if {$verbose} { puts "asserting $expr" } if {![expr $expr]} { error "assertion failed: $expr" } } proc ::fptools::tests::run {} { # [::fptools::pipe] test. assert {
[::fptools::pipe 2 \
{ expr { $_ + 1} } \
{ expr { $pipe(0) + $pipe(1) } } \
] == 5
[::fptools::pipe 2 {
expr { $_ + 1}
} {
expr { $pipe(0) + $pipe(1) }
}] == 5
} # [::fptools::lpipe] tests. assert { [::fptools::lpipe -long {1 2 3 4} { each {{x} { expr { $x + 1 } }} all {{x} { concat 1 $x 6 }} }] == {1 2 3 4 5 6} } assert { [::fptools::lpipe -expanded {k1 v1 k2 v2} each* {x y} { list $y $x }] == {v1 k1 v2 k2} } assert { [::fptools::lpipe -expanded {a b c} each* {x y z} { list $y $z $x }] == {b c a} } # [::fptools::range] tests.
assert { [::fptools::range 10] eq {0 1 2 3 4 5 6 7 8 9} }
assert { [::fptools::range 1 10] eq {1 2 3 4 5 6 7 8 9} }
assert { [::fptools::range -10 0 1] eq {-10 -9 -8 -7 -6 -5 -4 -3 -2 -1} }
assert { [catch { ::fptools::range 0 10 -1 }] }
assert { [catch { ::fptools::range -10 -7 -1 }] }
assert { [catch { ::fptools::range 10 0 1 }] }
assert { [catch { ::fptools::range -7 -10 1 }] }
assert { [::fptools::range 0 0 1] eq {} }
assert {[::fptools::range 10] eq {0 1 2 3 4 5 6 7 8 9}}
assert {[::fptools::range 1 10] eq {1 2 3 4 5 6 7 8 9}}
assert {[::fptools::range -10 0 1] eq {-10 -9 -8 -7 -6 -5 -4 -3 -2 -1}}
assert {[catch {::fptools::range 0 10 -1}]}
assert {[catch {::fptools::range -10 -7 -1}]}
assert {[catch {::fptools::range 10 0 1}]}
assert {[catch {::fptools::range -7 -10 1}]}
assert {[::fptools::range 0 0 1] eq {}}
# [::fptools::lcompare] tests.
assert { [::fptools::lcompare {1 2 3} {1 2 3}] }
assert { [::fptools::lcompare {1 2 a} {1 2 a}] }
assert { ![::fptools::lcompare {1 2 3} {1 2}] }
assert { ![::fptools::lcompare {1 2} {1 2 3}] }
assert { [::fptools::lcompare {0 1 2} {1 2 3} <] }
assert { [::fptools::lcompare {1 2 3} {0 1 2} >] }
assert { [::fptools::lcompare {1 2 3} {1 2 3} ==] }
assert { [::fptools::lcompare {1 2 3} {-7 -9 -11} !=] }
assert {[::fptools::lcompare {1 2 3} {1 2 3}]}
assert {[::fptools::lcompare {1 2 a} {1 2 a}]}
assert {![::fptools::lcompare {1 2 3} {1 2}]}
assert {![::fptools::lcompare {1 2} {1 2 3}]}
assert {[::fptools::lcompare {0 1 2} {1 2 3} <]}
assert {[::fptools::lcompare {1 2 3} {0 1 2} >]}
assert {[::fptools::lcompare {1 2 3} {1 2 3} ==]}
assert {[::fptools::lcompare {1 2 3} {-7 -9 -11} !=]}
# [::fptools::lflatten] tests.
assert { [::fptools::lflatten {1 2 3 {4 5 {6 7}}}] eq {1 2 3 4 5 {6 7}} }
assert { [::fptools::lflatten {1 2 3 {4 5 {6 7}}} 0] eq {1 2 3 {4 5 {6 7}}} }
assert { [::fptools::lflatten {1 2 3 {4 5 {6 7}}} 1] eq {1 2 3 4 5 {6 7}} }
assert { [::fptools::lflatten {1 2 3 {4 5 {6 7}}} 2] eq {1 2 3 4 5 6 7} }
assert { [::fptools::lflatten {1 2 3 {4 5 {6 7}}} 3] eq {1 2 3 4 5 6 7} }
assert { [::fptools::lflatten {1 2 3 {4 5 {6 7}}} 99] eq {1 2 3 4 5 6 7} }
assert {[::fptools::lflatten {1 2 3 {4 5 {6 7}}}] eq {1 2 3 4 5 {6 7}}}
assert {[::fptools::lflatten {1 2 3 {4 5 {6 7}}} 0] eq {1 2 3 {4 5 {6 7}}}}
assert {[::fptools::lflatten {1 2 3 {4 5 {6 7}}} 1] eq {1 2 3 4 5 {6 7}}}
assert {[::fptools::lflatten {1 2 3 {4 5 {6 7}}} 2] eq {1 2 3 4 5 6 7}}
assert {[::fptools::lflatten {1 2 3 {4 5 {6 7}}} 3] eq {1 2 3 4 5 6 7}}
assert {[::fptools::lflatten {1 2 3 {4 5 {6 7}}} 99] eq {1 2 3 4 5 6 7}}
# [::fptools::lmultimap] tests.
assert { [::fptools::lmultimap {x y} { 1 2 3 } \
{ lindex $x-$y }] eq {1-2 3-} }
assert { [::fptools::lmultimap {x y} { 1 2 3 } \
{ lindex $x-$y } { lindex $x } { lindex $y }] eq {1-2 1 2 3- 3 {}} }
assert {[::fptools::lmultimap {x y} {1 2 3} {
lindex $x-$y}] eq {1-2 3-}}
assert {[::fptools::lmultimap {x y} {1 2 3} {
lindex $x-$y} {lindex $x} {lindex $y}]
eq {1-2 1 2 3- 3 {}}
}
# [::fptools::lmultirange] tests.
assert { [::fptools::lmultirange {0 1 2 3 4} 0 0 1 end] eq {0 {1 2 3 4}} }
assert {
[::fptools::lmultirange {0 1 2 3 4} end end 0 end-1] eq {4 {0 1 2 3}}
assert {[::fptools::lmultirange {0 1 2 3 4} 0 0 1 end]
eq {0 {1 2 3 4}}}
assert {[::fptools::lmultirange {0 1 2 3 4} end end 0 end-1]
eq {4 {0 1 2 3}}
} # [::fptools::match] and [::fptools::mswitch] tests. assert [::fptools::mswitch {a b c} \
{* * c} { lindex 1 } default { lindex 0 }]
{* * c} {lindex 1} \
default {lindex 0}
]
assert [::fptools::mswitch {a b c} \
{-glob * -glob * -exact c} { lindex 1 } default { lindex 0 }]
{-glob * -glob * -exact c} {lindex 1} \
default {lindex 0}
]
assert [::fptools::mswitch {a b c} \
{-glob * -glob * -regexp [a-z]} { lindex 1 } default { lindex 0 }]
{-glob * -glob * -regexp [a-z]} {lindex 1} \
default {lindex 0}
]
assert [::fptools::mswitch {a b x} \
{-glob * -glob * -regexp [a-z]} { lindex 1 } default { lindex 0 }]
assert {
![::fptools::mswitch {a b x} \
{-glob * -glob * c} { lindex 1 } default { lindex 0 }]
{-glob * -glob * -regexp [a-z]} {lindex 1} \
default {lindex 0}
]
assert {![::fptools::mswitch {a b x} \
{-glob * -glob * c} {lindex 1} \
default {lindex 0}]
} # Use the next pattern's script.
assert [::fptools::mswitch {a b c} \
{* * c} - \
pattern1 { lindex 1 } \
default { lindex 0 } \
]
assert [::fptools::mswitch {a b c} \
pattern0 - \
pattern1 - \
pattern2 { lindex 0 } \
default - \
{never reached} { lindex 1 } \
]
assert {[
::fptools::mswitch {a b c} {* * c} - \
pattern1 {lindex 1} \
default {lindex 0}
]}
assert {[::fptools::mswitch {a b c} \
pattern0 - \
pattern1 - \
pattern2 {lindex 0} \
default - \
{never reached} {lindex 1}
]}
# Match the literal word "default", not the *default option*, with a # switch. assert [::fptools::mswitch default \
{-exact default} { lindex 1 } default { lindex 0 }]
{-exact default} {lindex 1} \
default {lindex 0}
]
assert [::fptools::mswitch default \
{ default } { lindex 1 } default { lindex 0 }]
{ default } {lindex 1} \
default {lindex 0}
]
# Two-argument mswitch. assert [::fptools::mswitch {a b c} {
{* * c} { lindex 1 }
default { lindex 0 }
{* * c} {lindex 1}
default {lindex 0}
}] assert [::fptools::match {} {a b c}] assert { ![::fptools::match {-strict} {a b c}] } assert [::fptools::match {a b c} {a b c d e f g h}] assert { ![::fptools::match {-strict a b c d e f g h} {a b c}] } assert [::fptools::match \ {-strict -glob a -strict -exact b -strict c} {a b c}] assert [::fptools::match {-strict -- ------} ------] assert { [catch { ::fptools::match {------} {------} }] } assert [::fptools::match {-exact -exact} -exact] assert [::fptools::match {-- -exact} -exact] assert [::fptools::match {-glob -glob} -glob] assert [::fptools::match {-- -glob} -glob] assert [::fptools::match {-lambda {{x} {expr {$x == 5}}}} 5] assert [::fptools::match {-command {string is integer -strict}} 118] assert { ![::fptools::match {-command {string is integer -strict}} hello] } } # If this is the main script... if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} { lassign $argv command if {$command in {report list}} { # Print all procedures. set runningJimTcl [catch { info tclversion }] if {$runningJimTcl} { proc argsWithDefaults {procName} { return [info args $procName] } } else { proc argsWithDefaults {procName} { set arguments {} foreach argument [info args $procName] { if {[info default $procName $argument defaultValue]} { lappend arguments [list $argument $defaultValue] } else { lappend arguments $argument } } return $arguments } } foreach procName [lsort [info procs ::fptools::*]] { puts "$procName \{[argsWithDefaults $procName]\}" } } elseif {$command eq {test}} { if {[lindex $argv 1] eq {--verbose}} { set ::fptools::tests::verbose 1 } ::fptools::tests::run } else { puts "unknown command line arguments: \"$argv\";\
must be \"report\" or \"test\""
must be \"report\" or \"test\""
exit 1 } }
======
**Discussion**
**See also**
* [Additional list functions]
<<categories>>Functional Programming | Jim Package | Package
<<categories>> Functional Programming | Jim Package | Package