Code edit

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

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

# 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

    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} {
    set shortcutSyntax 1
    set singleArg 1

    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*} }]

            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
}



# 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 }
        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} {
    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 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 }
            }
        } $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) } {
            foreach subelem $elem {
                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
}


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


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

    # [::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 }]
    assert [::fptools::mswitch default \
            { 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 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\""
        exit 1
    }
}

Discussion edit

See also edit

• Additional list functions

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References