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

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

### Pattern matching.

# Match a list against a list pattern. A list pattern consists of patterns for
# each element of the list. Each element pattern can be preceded by an option
# that specifies what kind of pattern it is. The possible pattern options are:
# "-exact", "-glob", "-lambda", "-prefix" and "-regexp". If the list is longer
# than the list pattern only as many elements as there are in the list pattern
# are checked unless you enable strict mode with the option "-strict". 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 {list listPattern {debug 0}} {
    set matchModeDefault -glob
    set matchMode $matchModeDefault
    set canBeAnOption 1 ;# Can the next $p be an option?
    set specialOptions {-strict --} ;# Options that affect all patterns.
    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 {
                    -strict {
                        set lengthMatch 1
                    }
                    -- {
                        set canBeAnOption 0
                    }
                }
            } else {
                if {$debug} {
                    puts "        match mode"
                }
                set matchMode $p
                set canBeAnOption 0
            }
            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]
            }
            -prefix {
                uplevel 1 [list {*}$p $elem]
            }
            -regexp {
                regexp $p $elem
            }
            default {
                return -code error "bad option \"$matchMode\""
            }
        }]
        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] < 3} {
        wrongnargs {list pattern script ?pattern script?}
    }
    set list [lindex $args 0]
    foreach {pattern script} [lrange $args 1 end] {
        if {($pattern eq "default") || [match $list $pattern]} {
            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::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::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 }]
    }
    assert [::fptools::match {a b c} {}]
    assert {
        ![::fptools::match {a b c} {-strict}]
    }
    assert [::fptools::match {a b c d e f g h} {a b c}]
    assert {
        ![::fptools::match {a b c} {-strict a b c d e f g h}]
    }
    assert [::fptools::match \
            {a b c} {-strict -glob a -strict -exact b -strict c}]
    assert [::fptools::match ------ {-strict -- ------}]
    # 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::match -exact {-exact -exact}]
    assert [::fptools::match -glob {-glob -glob}]
    assert [::fptools::match 5 {-lambda {{x} {expr {$x == 5}}}}]
    assert [::fptools::match 118 {-prefix {string is integer -strict}}]
    assert {
        ![::fptools::match hello {-prefix {string is integer -strict}}]
    }
}

# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    ::fptools::tests::run
}