Functional Programming in Tcl

by Mark Dettinger
ad-functional is a library of functions that support functional programming style in Tcl. Most of the functions introduced here are taken from Haskell.

The Functions

map

proc_doc map {f xs} "takes a function f and a list {x1 x2 x3 ...} and
                     returns the list { f x1, f x2, f x3, ...}" {
    set result {}
    foreach x $xs {
        lappend result [eval_unary $f $x]
    }
    return $result
}
Examples (fib = fibonacci function, sqr = square function):

fold and fold1

proc_doc fold {f e xs} "takes a binary function f, a start element e and a list {x1 x2 ...}
                        and returns f (...(f (f (f e x1) x2) x3)...)" {
    set result $e
    foreach x $xs {
	set result [eval_binary $f $result $x]
    }
    return $result
}
Instead of a user-defined function f, you can also use a binary operator like +, *, || or &&.
Example:
proc_doc fold1 {f xs} "takes a binary function f and a list {x1 x2 x3 ...}
                       and returns (...(f (f (f x1 x2) x3) x4)...)" {
    if { [null_p $xs] } {
	error "ERROR: fold1 is undefined for empty lists."
    } else { 
	fold $f [head $xs] [tail $xs]
    }
}

# "fold1" behaves like "fold", but does not take a start element and
# does not work for empty lists.
#
# Example:
# fold1 min [list 3 1 4 1 5 9 2 6] = 1
# fold1 max [list 3 1 4 1 5 9 2 6] = 9

scanl and scanl1

proc_doc scanl {f e xs} "takes a binary function f, a start element e and a list {x1 x2 ...}
                         and returns {e (f e x1) (f (f e x1) x2) ...}" {
    set current_element $e
    set result [list $e]
    foreach x $xs {    
	set current_element [eval_binary $f $current_element $x] 
	lappend result $current_element
    }
    return $result
}

# Example:
# scanl + 0 [list 1 2 3 4] = {0 1 3 6 10}
# scanl * 1 [list 1 2 3 4] = {1 1 2 6 24}

proc_doc scanl1 {f xs} "takes a binary function f and a list {x1 x2 x3 ...}
                       and returns {x1 (f x1 x2) (f (f x1 x2) x3) ...}" {
    if { [null_p $xs] } {
	error "ERROR: scanl1 is undefined for empty lists."
    } else { 
	scanl $f [head $xs] [tail $xs]
    }
}

# "scanl1" behaves like "scanl", but does not take a start element and
# does not work for empty lists.
#
# Example:
# scanl1 min [list 3 1 4 1 5 9 2 6] = {3 1 1 1 1 1 1 1}
# scanl1 max [list 3 1 4 1 5 9 2 6] = {3 3 4 4 5 9 9 9}

the identity function "id"

proc_doc id {x} "identity function: just returns its argument" {
    return $x
}

# I'm not kidding! An identity function can be useful sometimes, e.g.
# as a default initializer for optional arguments of functional kind:

proc_doc qsort {xs {value id}} "sorts a sequence with the quicksort algorithm" {
    if { [llength $xs]<2 } { return $xs }
    set pivot [head $xs]
    set big_elmts {}
    set small_elmts {}
    foreach x [tail $xs] {
	if { [eval_unary $value $x] > [eval_unary $value $pivot] } {
	    lappend big_elmts $x
	} else {
	    lappend small_elmts $x
	}
    }
    concat [qsort $small_elmts $value] [list $pivot] [qsort $big_elmts $value]
}

# % qsort {5 2 9 4}
# 2 4 5 9
# % qsort {Oracle ArsDigita SAP Vignette} "string length"
# SAP Oracle Vignette ArsDigita

const

proc_doc const {k x} "ignores its second argument and returns its first argument" {
    return $k
}

# Example:
# map "const 7" [list 1 2 3 4 5] = {7 7 7 7 7}

curry and uncurry


proc curry {f args} {
    eval_unary $f $args
}

proc uncurry {f tuple} {
    eval "$f $tuple"
}

# curry? uncurry? What the hell should THAT be good for?
# Well, these functions convert a function taking _many arguments_
# into a function taking _one tuple of arguments_ and vice versa.

# Example:
# min 3 5 = 3
# min {3 5} = error (because min expects two arguments)
# uncurry min {3 5} = 3

Exercise 1

Using "map" and "uncurry", convert the tuple list {{3 1} {4 1} {5 9} {2 6}} into {1 1 5 2} (each tuple is replaced by the minimum of its two components).

fst, snd and thd


proc_doc fst {xs} "returns the first element of a list" {
    lindex $xs 0
}

proc_doc snd {xs} "returns the second element of a list" {
    lindex $xs 1
}
 
proc_doc thd {xs} "returns the third element of a list" {
    lindex $xs 2
}

# Example:
# set people [db_list_of_lists unused "select first_name, last_name, email ..."]
# set first_names [map fst $people]
# set last_names  [map snd $people]
# set emails      [map thd $people]

flip


proc_doc flip {f a b} "takes a binary function f and two arguments a and b
                       and returns f b a (arguments are flipped)" {
    eval_binary $f $b $a
}

# Example:
# flip lindex 0 {42 37 59 14} = 42

Exercise 2

Using "fold", "map", "flip" and "lindex", compute the sum of the 4th column of the matrix
[list [list 3 1 4 1 5]
      [list 9 2 6 5 3]
      [list 5 8 9 7 9]
      [list 3 2 3 8 4]]
Hint: First try to extract the list {1 5 7 8} using "map", "flip" and "lindex", then reduce it to 21 using "fold".

compose

proc_doc compose {f g x} "function composition: evaluates f (g x)" {
    eval_unary $f [eval_unary $g $x]
}

# Example:
# map {compose sqr 7+} {1 2 3 4 5} = {64 81 100 121 144}

# Algebraic Property:
# map {compose f g} $xs = map f [map g $xs]

Standard numerical functions

proc_doc abs {x} "returns the absolute value of x" {
    expr $x<0 ? -$x : $x
}

proc_doc gcd {x y} "returns the greatest common divisor of x and y" {
    gcd' [abs $x] [abs $y] 
}

proc gcd' {x y} {
    if { $y==0 } { return $x }
    gcd' $y [expr $x%$y]
}

proc_doc lcm {x y} "returns the least common multiple of x and y" {
    if { $x==0} { return 0 }
    if { $y==0} { return 0 }
    abs [expr $x/[gcd $x $y]*$y]
}

proc_doc odd_p {n} "returns 1 if n is odd and 0 otherwise" {
    expr $n%2
}

proc_doc even_p {n} "returns 1 if n is even and 0 otherwise" {
    expr 1-$n%2
}

proc_doc min {x y} "returns the minimum of x and y" {
    expr $x<$y ? $x : $y
}

proc_doc max {x y} "returns the maximum of x and y" {
    expr $x>$y ? $x : $y
}

List Aggregate Functions


proc_doc and {xs} "reduces a list of boolean values using &&" {
    fold && 1 $xs
}

# Example
# and {1 1 0 1} = 0
# and {1 1 1 1} = 1

proc_doc or {xs} "reduces a list of boolean values using ||" {
    fold || 0 $xs
}

# Example
# or {1 1 0 1} = 1
# or {0 0 0 0} = 0

proc_doc all {pred xs} "takes a predicate pred and a list xs and returns 1
                        if all elements of xs fulfill pred" {
    and [map $pred $xs]
}

# Example:
# all even_p {2 44 64 80 10} = 1
# all even_p {2 44 65 80 10} = 0

proc_doc any {pred xs} "takes a predicate pred and a list xs and returns 1
                        if there exists an element of xs that fulfills pred" {
    or [map $pred $xs]
}

# Example:
# any odd_p {2 44 64 80 10} = 0
# any odd_p {2 44 65 80 10} = 1

proc_doc lmin {xs} "returns the minimum element of the list xs" {
    fold1 min $xs
}

proc_doc lmax {xs} "returns the maximum element of the list xs" {
    fold1 max $xs
}

proc_doc sum {xs} "returns the sum of the elements of the list xs" {
    fold + 0 $xs
}

proc_doc product {xs} "returns the product of the elements of the list xs" {
    fold * 1 $xs
}

Standard list processing functions


proc_doc head {xs} "first element of a list" {
    lindex $xs 0
}
 
proc_doc last {xs} "last element of a list" {
    lindex $xs [expr [llength $xs]-1]
}

proc_doc init {xs} "all elements of a list but the last" {
    lrange $xs 0 [expr [llength $xs]-2]
}

proc_doc tail {xs} "all elements of a list but the first" {
    lrange $xs 1 [expr [llength $xs]-1]
}

proc_doc take {n xs} "returns the first n elements of xs" {
    lrange $xs 0 [expr $n-1]
}

proc_doc drop {n xs} "returns the remaining elements of xs (without the first n)" {
    lrange $xs $n [expr [llength $xs]-1]
}

proc_doc filter {pred xs} "returns all elements of xs that fulfill the predicate pred" {
    set result {}
    foreach x $xs {
	if { [eval_unary $pred $x] } {
	    lappend result $x
	}
    }
    return $result
}

# Examples:
# filter even_p {3 1 4 1 5 9 2 6} = {4 2 6}
# filter 500< {317 826 912 318} = {826 912}

proc_doc copy {n x} "returns list of n copies of x" {
    set result {}
    for {set i 0} {$i<$n} {incr i} {
	lappend result $x
    }
    return $result    
}

# Example:
# copy 10 7 = {7 7 7 7 7 7 7 7 7 7}

proc_doc cycle {n xs} "returns concatenated list of n copies of xs" {
    set result {}
    for {set i 0} {$i<$n} {incr i} {
	set result [concat $result $xs]
    }
    return $result    
}

# Example:
# cycle 4 {1 2 3} = {1 2 3 1 2 3 1 2 3 1 2 3}

proc_doc cons {x xs} "inserts x at the front of the list xs" {
    concat [list $x] $xs 
}

proc_doc reverse {xs} "reverses the list xs" {
    fold "flip cons" {} $xs
}

proc_doc elem_p {x xs} "checks if x is contained in s" {
    expr [lsearch $xs $x]==-1 ? 0 : 1
}

proc_doc not_elem_p {x xs} "checks if x is not contained in s" {
    expr [lsearch $xs $x]==-1 ? 1 : 0
}

proc_doc nub {xs} "removes duplicates from xs" {
    set result {}
    foreach x $xs {
	if { [not_elem_p $x $result] } {
	    lappend result $x
	}
    }
    return $result
}

proc_doc null_p {xs} "checks if xs is the empty list" {
    expr [llength $xs]==0
}

proc_doc enum_from_to {lo hi} "generates {lo lo+1 ... hi-1 hi}" {
    set result {}
    for {set i $lo} {$i<=$hi} {incr i} {
	lappend result $i
    }
    return $result
}

zip and zip_with functions


proc_doc zip {args} "takes two lists {x1 x2 x3 ...} and {y1 y2 y3 ...} and
                     returns a list of tuples {x1 y1} {x2 y2} {x3 y3} ...
                     Works analogously with three or more lists." {				 
    transpose $args
}

# Example:
# % set first_names {Nicole Tom}
# % set last_names  {Kidman Cruise}
# % zip $first_names $last_names
# {Nicole Kidman} {Tom Cruise}
# % map {flip join _} [zip $first_names $last_names]
# Nicole_Kidman Tom_Cruise

proc_doc zip_with {f xs ys} "takes two lists {x1 x2 x3 ...} and {y1 y2 y3 ...} and
                             returns the list {(f x1 y1) (f x2 y2) (f x3 y3) ..." {
    set result {}
    foreach x $xs y $ys {
	if { !([null_p $x] || [null_p $y]) } {
	    lappend result [eval_binary $f $x $y]
	}
    }
    return $result
}

# Example:
# % set first_names {Sandra Catherine Nicole}
# % set last_names  {Bullock Zeta-Jones Kidman}
# % zip_with {curry {flip join " "}} $first_names $last_names
# "Sandra Bullock" "Catherine Zeta-Jones" "Nicole Kidman"


proc_doc transpose {lists} "tranposes a matrix (a list of lists)" {
    set result {}
    set num_lists [llength $lists]
    for {set i 0} {$i<$num_lists} {incr i} {
	set l($i) [lindex $lists $i]
    }
    while {1} {
	set element {}
	for {set i 0} {$i<$num_lists} {incr i} {
	    if [null_p $l($i)] { return $result }
	    lappend element [head $l($i)]
	    set l($i) [tail $l($i)]
	}
	lappend result $element
    }
    # Note: This function takes about n*n seconds
    #       to transpose a (100*n) x (100*n) matrix.
}

Auxiliary Functions


proc_doc eval_unary {f x} "Evaluates f x. f can also be an operator." {
    if { [regexp \[a-z\] $f match] } {
	# Seems that "f" is a function (because the name contains letters).
	eval "$f {$x}"
    } else {
	# Seems that "f" is something like "1+" or "42==".
	expr $f $x
    }    
}

proc_doc eval_binary {f a b} "Evaluates f a b. f can also be an operator." {
    if { [regexp \[a-z\] $f match] } {
	# Seems that "f" is a function (because the name contains letters).
	eval "$f {$a} {$b}"
    } else {
	# Seems that "f" is an infix operator like "+", "*" or "||".
	expr $a $f $b
    }
}

Further Examples


proc_doc sums {xs} "returns the list of partial sums of the list xs" {
    scanl + 0 $xs
}

proc_doc products {xs} "returns the list of partial products of the list xs" {
    scanl * 1 $xs
}

proc_doc iterate {n f x} "returns {x (f x) (f (f x) (f (f (f x))) ...}" {
    set result {}
    for {set i 0} {$i<$n} {incr i} {
	lappend result $x
	set x [eval_unary $f $x]
    }
    return $result
}

# Example:
# iterate 10 1+ 5 = {5 6 7 8 9 10 11 12 13 14}
# iterate 10 2* 1 = {1 2 4 8 16 32 64 128 256 512}

proc_doc unzip {xs} "unzip takes a list of tuples {x1 y1} {x2 y2} {x3 y3} ... and
                     returns a tuple of lists {x1 x2 x3 ...} {y1 y2 y3 ...}." {
    set left {}
    set right {}
    foreach x $xs {
	# assertion: x is a tuple
	lappend left [lindex $x 0]
	lappend right [lindex $x 1]
    }
    return [list $left $right]
}

# "unzip" is just a special case of the function "transpose"
# and is here just for completeness.

# --------------------------------------------------------------------------------
# List breaking functions: To gain a real advantage from using these functions,
# you would actually need a language that has "lazy evaluation" (like Haskell).
# In Tcl they can be useful too, but they are not as powerful.
#
#   split_at n xs    = (take n xs, drop n xs)
#
#   take_while p xs  returns the longest initial segment of xs whose
#                    elements satisfy p
#   drop_while p xs  returns the remaining portion of the list
#   span p xs        = (takeWhile p xs, dropWhile p xs)
#
#   take_until p xs  returns the list of elements upto and including the
#                    first element of xs which satisfies p
#
# --------------------------------------------------------------------------------

proc_doc split_at {n xs} "splits a list using take and drop" {
    list [take $n $xs] [drop $n $xs]
}

proc_doc take_while {p xs} "returns the longest initial segment of xs whose
                            elements satisfy p" {
    set index 0    
    foreach x $xs {
	if { ![eval_unary $p $x] } { break }
	incr index
    }
    take $index $xs
}

proc_doc drop_while {p xs} "returns the remaining portion of the list" {
    set index 0    
    foreach x $xs {
	if { ![eval_unary $p $x] } { break }
	incr index
    }
    drop $index $xs
}

proc_doc span {p xs} "splits a list using take_while and drop_while" {
    list [take_while $p $xs] [drop_while $p $xs]
}

proc_doc take_until {p xs} "returns the list of elements upto and including the
                            first element of xs which satisfies p" {
    set index 0    
    foreach x $xs {
	incr index
	if { [eval_unary $p $x] } { break }
    }
    take $index $xs
}

Factorial


proc factorial {n} {
    product [enum_from_to 1 $n]
}

Pascal's Triangle


proc_doc mul {n fraction} "multiplies n with a fraction (given as a tuple)" {
    set num [fst $fraction]
    set denom [snd $fraction]
    set g [gcd $n $denom]
    expr ($n/$g)*$num/($denom/$g)
}

proc_doc choose {n k} "Here's how to compute 'n choose k' like a real nerd." {
    fold mul 1 [transpose [list [iterate $k "flip - 1" $n] [enum_from_to 1 $k]]]
}

proc_doc pascal {size} "prints Pascal's triangle" {
    for {set n 0} {$n<=$size} {incr n} {
	puts [map "choose $n" [enum_from_to 0 $n]]
    }
}

Prime Numbers


proc prime_p {n} {
    if { $n<2 } { return 0 }
    if { $n==2 } { return 1 }
    if { [even_p $n] } { return 0 }
    for {set i 3} {$i*$i<=$n} {incr i 2} {
	if { $n%$i==0 } { return 0 }
    }
    return 1
}

# % filter prime_p [enum_from_to 1 100]
# 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97

Extreme Example

proc multiplication_table {x} {
    # This is an extreme example for test purposes only.
    # This way of programming is not recommended. Kids: do not try this at home.
    flip join \n [map {compose {flip join ""} {map {compose {format %4d} product}}} \
    [map transpose [transpose [list [map "copy $x" [enum_from_to 1 $x]] \
                                    [copy $x [enum_from_to 1 $x]]]]]]

dettinger@arsdigita.com