'''fptools''' is a library of general-purpose procedures 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 procedure is described in a comment that directly precedes its declaration.

You can download the library with [wiki-reaper]: `wiki-reaper 41349 0 | tee fptools-0.1.tm`

If you fix a bug please increment the patch level in `::fptools::version`.

**Code**

======
# fptools, a collection of procedures for functional programming in Tcl 8.5,
# Tcl 8.6 and Jim Tcl.
# Copyright (C) 2015 Danyil Bohdan.
# License: MIT.
namespace eval ::fptools {
    variable version 0.3.0
}

# 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\""
}

# Tail call the caller proc if [tailcall] is available else just call the caller
# proc with the arguments from $args.
proc ::fptools::recur args {
    set caller [dict get [info frame -1] proc]
    if {[info commands tailcall] eq "tailcall"} {
        tailcall $caller {*}$args
    } else {
        $caller {*}$args
    }
}

# Pipe results of commands. The results can be accessed from within each script
# as $_ (previous step) and $pipe(n) (nth step).
proc ::fptools::pipe args {
    if {[llength $args] == 0} {
        wrongnargs {script ?script ...?}
    }

    set varName _

    upvar 1 $varName stepResult
    upvar 1 pipe pipe

    array unset pipe
    set i 0
    foreach command $args {
        set stepResult [uplevel 1 [list eval $command]]
        set pipe($i) $stepResult
        incr i
    }

    set result $stepResult
    return $result
}

### List tools

# Generate a list containing a range of numbers.
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 }
        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 unique elements in a 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
    }]
}

# 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 you can 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 two lists.
proc ::fptools::lcompare {list1 list2 {op eq}} {
    if {[info commands {::tcl::mathop::*}] eq ""} {
        # Jim Tcl.
        set compareLambda [format {
            {a 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 { [string is list $elem] && ($depth <= $n) } {
            foreach subelem $elem {
                set stack [linsert $stack 0 $subelem [expr { $depth + 1 }]]
            }
        } else {
            set result [linsert $result 0 $elem]
        }
    }
    return $result
}

# Create a list by applying multiple scripts to each value 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 {}
    while {[llength $list] > 0} {
        foreach varName $varList value [lshift! list $varListLength] {
            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 [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 patterns,
# one for each element of the list. Each 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]"
    }
    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 [lshift! list]
        if {$debug} {
            puts "        element: $elem"
        }
        set gotMatch [switch -exact -- $matchMode {
            -exact {
                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 && ([llength $list] > 0)} {
        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.
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}
    }

    while {[llength $statements] > 0} {
        lassign [lshift! statements 2] pattern script
        if {($pattern eq "default") || [match $pattern $list]} {
            while {$script eq "-"} {
                lassign [lshift! statements 2] _ script
            }
            return [uplevel 1 $script]
        }
    }
    error "no matches"
}

### Tests.

namespace eval ::fptools::tests {}

proc ::fptools::tests::assert expr {
    if {![expr $expr]} {
        error "assertion failed: $expr"
    }
}

proc ::fptools::tests::run {} {
    # [::fptools::pipe] test.
    assert {
        [::fptools::pipe \
                { lindex 2 } \
                { expr { $_ + 1} } \
                { expr { $pipe(0) + $pipe(1) } } \
        ] == 5
    }

    # [::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 {} }

    # [::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} !=] }

    # [::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} }

    # [::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 {}} }

    # [::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}}
    }

    # [::fptools::match] and [::fptools::mswitch] tests.
    assert [::fptools::mswitch {a b c} \
            {* * c} { lindex 1 } default { lindex 0 }]
    assert [::fptools::mswitch {a b c} \
            {-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 }]
    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 }]
    }
    # 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 } \
    ]
    # Match the literal word "default", not the *default option*, with a
    # switch.
    assert [::fptools::mswitch default \
            {-exact default} { lindex 1 } default { lindex 0 }]
    # Two-argument mswitch.
    assert [::fptools::mswitch {a b c} {
        {* * 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 eq "report"} {
        # Print all procedures.
        foreach procName [lsort [info procs ::fptools::*]] {
            set arguments {}
            foreach argument [info args $procName] {
                if {[info default $procName $argument defaultValue]} {
                    lappend arguments [list $argument $defaultValue]
                } else {
                    lappend arguments $argument
                }
            }
            puts "$procName \{$arguments\}"
        }
    } elseif {$command eq "test"} {
        ::fptools::tests::run
    } else {
        puts "unknown command line arguments: \"$argv\""
        exit 1
    }
}

======

**Discussion**

**See also**

   * [Additional list functions]

<<categories>>Functional Programming | Jim Package