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