Notes on TIP 309 - expose expression parsing

Arjen Markus (13 december 2012) Several years back I wrote TIP 309 in pursuit of a method to manipulate arithmetic expressions. The idea: go beyond ordinary arithmetic and make it possible to use complex numbers in the same way as real numbers or to implement (basic) symbolic manipulation.

The start of the Tcl novem development is an opportunity to look at it again.

Complex numbers

Here is a simple program that shows how this can actually be used (it uses a mock-up version of the proposed command, of course):

# example.tcl --
#     Example of using the proposed command s-expr
#

# s-expr --
#     Mock up version of the proposed command
#
# Arguments:
#     expression     An - in principle - arbitrary arithmetic expression
#
# Result:
#     A prefix version of the expression.
#     In this mock-up just "+ $x $y"
#
proc s-expr {expression} {
    return [list {+ $x $y} x y]
}

# complex --
#     Namespace defining complex number operations
#
namespace eval ::complex {
    variable expressions
}

# number --
#     Construct a complex number
#
# Arguments:
#     real        Real part
#     imaginary   Imaginary part
#
proc ::complex::number {real imaginary} {
    return [list $real $imaginary]
}

# + --
#     Complex addition
#
# Arguments:
#     z1       First argument
#     z2       Second argument
#
# Result:
#     Complex sum of the two arguments
#
proc ::complex::+ {z1 z2} {

    lassign $z1 x1 y1
    lassign $z2 x2 y2

    return [list [expr {$x1+$x2}] [expr {$y1+$y2}]]
}

# cexpr -- 
#     Evaluate complex arithmetic expressions
#
# Arguments:
#     expression     Arbitrary arithmetic expression
#
# Result:
#     Value of the expression
#
proc ::complex::cexpr {expression} {
    variable expressions
        
    #
    # Construct a new procedure if the expression has not been handled before
    #

    if { ![info exists expressions($expression)] } {
        set parsed [s-expr $expression]

        set prefix [lindex $parsed 0]
        set vars   [lrange $parsed 1 end]

        set expressions($expression) 1

        set upvars {}
        foreach var $vars {
            append upvars "upvar 2 $var $var\n"
        }

        proc $expression {} "$upvars$prefix"
     }

     $expression
}

# main --
#     Test this example
#
set x [::complex::number 0 1]
set y [::complex::number 1 0]

puts "Sum of i and 1: "
puts [::complex::cexpr {$x + $y}] 

As you can see: the [cexpr] command behaves (superficially) in the same way as the [expr] command, but takes complex numbers in stead of ordinary reals.

Automatic differentiation

My second example is automatic differentiation as a simple form of symbolic manipulation:

# example_deriv.tcl --
#     Example of using the proposed command s-expr:
#     automatic differentiation
#

# s-expr --
#     Mock up version of the proposed command
#
# Arguments:
#     expression     An - in principle - arbitrary arithmetic expression
#
# Result:
#     A prefix version of the expression.
#     In this mock-up just "exp [* $a $x]"
#
proc s-expr {expression} {
    return [list {exp [* $a $x]} a x]
}

# autodiff --
#     Namespace defining automatic differentiation facilities
#
namespace eval ::autodiff {
    variable expressions
}

# exp --
#     Exponentiation
#
# Arguments:
#     value          Value and the derivative wrt the variable
#
# Result:
#     Value of exp(value) and the derivative
#
proc ::autodiff::exp {value} {
    lassign $value v dv
    return [list [expr {exp($v)}] [expr {$dv * exp($v)}]]
}

# * --
#     Multiplication
#
# Arguments:
#     x            First argument and the derivative wrt the variable
#     y            Second argument and the derivative wrt the variable
#
# Result:
#     Value of x*y and the derivative
#
proc ::autodiff::* {x y} {
    lassign $x x dx
    lassign $y y dy
    return [list [expr {$x*$y}] [expr {$dx*$y + $x*$dy}]]
}

# deriv --
#     Evaluate the derivative of arithmetic expressions
#     with respect to a given variable
#
# Arguments:
#     dvar           Name of the variable (must be a scalar)
#     expression     Arbitrary arithmetic expression
#
# Result:
#     Derivative of the expression
#
proc ::autodiff::deriv {dvar expression} {
    variable expressions

    #
    # Construct a new procedure if the expression has not been handled before
    #

    if { ![info exists expressions($expression)] } {
        set parsed [s-expr $expression]

        set prefix [lindex $parsed 0]
        set vars   [lrange $parsed 1 end]

        set expressions($expression) 1

        set upvars {}
        foreach var $vars {
            append upvars "upvar 2 $var _$var\n"
        }
        foreach var $vars {
            if { $var ne $dvar } {
                append upvars "set $var \[list \$_$var 0.0]\n"
            } else {
                append upvars "set $var \[list \$_$var 1.0]\n"
            }
        }

        proc $expression {} "$upvars\nlindex \[$prefix\] 1"
     }

     $expression
}

# main --
#     Test this example
#
set a -0.5
foreach x {0 1 2 3 4 5} {
    puts "[::autodiff::deriv x {exp($a*$x)}] (expected: [expr {$a*exp($a*$x)}])"
}

Physical and other units

It occurred to me that we can use this same method to implement units. Here is a very simple example.

Using the units module as suggested below would enable us to add meters and centimeters for instance. I have not implemented such a feature.

Note: store the sample implementation below as "transform_expr.tcl" to run this code.

# units.tcl --
#     Computing with (physical) units
#
source transform_expr.tcl

namespace eval ::units {
    variable registeredCombinations

    namespace export combineUnits uset uexpr
}

# combineUnits --
#     Register the combination of two units
#
# Arguments:
#     operation    The operation in question
#     unit1        First unit
#     unit2        Second unit
#     result       Resulting unit
#
proc ::units::combineUnits {operation unit1 unit2 result} {
    variable registeredCombinations
    set registeredCombinations($operation,$unit1,$unit2) $result
}

#
# uset --
#     Set a variable to a value plus unit
#
# Arguments:
#     varName   Name of the variable
#     value     Value
#     unit      Unit
#
# Result:
#     Variable varName gets a value plus unit
#
proc ::units::uset {varName value unit} {

    upvar 1 $varName var

    set var [list $value $unit]
}

# + --
#     Add two numbers if they have the same unit
#
# Arguments:
#     op1       First number
#     op2       Second number
#
# Result:
#     Sum with unit or error
#
proc ::units::+ {op1 op2} {

    lassign $op1 value1 unit1
    lassign $op2 value2 unit2

    if { $unit1 ne $unit2 } {
        return -code error "Numbers with incompatible units ($unit1 and $unit2) can not be added"
    } else {
        return [list [expr {$value1 + $value2}] $unit1]
    }
}

# * --
#     Multiply two numbers if their combined unit is defined
#
# Arguments:
#     op1       First number
#     op2       Second number
#
# Result:
#     Product with unit or error
#
proc ::units::* {op1 op2} {
    variable registeredCombinations

    lassign $op1 value1 unit1
    lassign $op2 value2 unit2

    if { $unit1 eq "" } {
        return [list [expr {$value1 * $value2}] $unit2]
    }
    if { $unit2 eq "" } {
        return [list [expr {$value1 * $value2}] $unit1]
    }

    if { ![info exists registeredCombinations(*,$unit1,$unit2)] } {
        return -code error "Numbers with incompatible units ($unit1 and $unit2) can not be mulitplied"
    } else {
        return [list [expr {$value1 * $value2}] $registeredCombinations(*,$unit1,$unit2)]
    }
}

# / --
#     Divide two numbers if their combined unit is defined
#
# Arguments:
#     op1       First number
#     op2       Second number
#
# Result:
#     Quotient with unit or error
#
proc ::units::/ {op1 op2} {
    variable registeredCombinations

    lassign $op1 value1 unit1
    lassign $op2 value2 unit2

    if { $unit2 eq "" } {
        return [list [expr {$value1 / $value2}] $unit1]
    }

    if { ![info exists registeredCombinations(/,$unit1,$unit2)] } {
        return -code error "Numbers with incompatible units ($unit1 and $unit2) can not be mulitplied"
    } else {
        return [list [expr {$value1 / $value2}] $registeredCombinations(/,$unit1,$unit2)]
    }
}

# uexpr --
#     Evaluate arithmetic expressions on dimensioned values
#
# Arguments:
#     expression     Arbitrary arithmetic expression
#
# Result:
#     Value of the expression
#
proc ::units::uexpr {expression} {
    variable expressions

    #
    # Construct a new procedure if the expression has not been handled before
    #

    if { ![info exists expressions($expression)] } {
        set parsed [transformExpr $expression]

        set prefix [lindex $parsed 0]
        set vars   [lindex $parsed 1]

        set expressions($expression) 1

        set upvars {}
        foreach var $vars {
            append upvars "upvar 2 $var $var\n"
        }

        proc $expression {} "$upvars$prefix"
     }

     $expression
}

# main --
#     Test the code
#
namespace import ::units::*

combineUnits / K m K/m
combineUnits * m m m2

uset length 10.0 m
uset width 3.0 m

#puts "Perimeter: [* 2 [+ $length $width]]"
#puts "Area:      [* $length $width]"

puts "Perimeter: [uexpr {2*($length+$width)}]"
puts "Area:      [uexpr {$length*$width}]"

uset distance              10.0 m
uset temperatureDifference  3.5 K
#puts "Temperature gradient: [/ $temperatureDifference $distance]"
#puts "Sum temperature and distance: [+ $temperatureDifference $distance]"
puts "Temperature gradient: [uexpr {$temperatureDifference/$distance}]"
puts "Sum temperature and distance: [uexpr {$temperatureDifference+$distance}]"

RLE (2012-12-14): Note, tcllib already contains a units package for handling units conversion.

AM (14 december 2012) That package is about converting values expressed in one unit to values expressed in a different but compatible unit. What I have in mind is:

expr { 1meter + 1kelvin } ==> error: units incompatible 

Vector expressions

Yet another possibility - one that will rely only on the extraction of the variables used in the expressions - is to evaluate some expression over the elements of lists:

# Compute the sum over the positive elements and the sum of squares
set list {-1 2 3 -1.4 3 -4.9 5.2 6.101 -3}
puts "Sum of the positive elements: [sum {$list} {$list > 0.0}]
puts "Sum of all squares: [sum {$list**2}]

Here is a rather elegant implementation (if I may say so myself) - elegant because you can combine lists of values and scalars anyway you want in the expressions. It is taken care of automatically via the [lindex'] procedure.

(Note that Tcl 8.6 has the lmap command which similarly allows you to apply expressions on lists of values)

# vectors.tcl --
#     Computing with arrays of numbers
#
source transform_expr.tcl

namespace eval ::vectors {
    namespace export vexpr
}

# lindex' --
#     Return a list element or the scalar value
#
# Arguments:
#     list_or_value   List or scalar
#     index           Index of the element
#
proc lindex' {list_or_value index} {

    if { [llength $list_or_value] == 1 } {
        return $list_or_value
    } else {
        return [lindex $list_or_value $index]
    }
}

# vsum --
#     Summation of an array-valued expression with condition
#
# Arguments:
#     expression     Arbitrary arithmetic expression
#     condition      Condition on the elements
#
# Result:
#     Sum of the expression
#
proc ::vectors::vsum { expression condition} {
    variable expressions

    #
    # Construct a new procedure if the expression has not been handled before
    #

    if { ![info exists expressions($expression:$condition)] } {
        set parsedExpr [transformExpr $expression]
        set parsedCond [transformExpr $condition]

        set vars   [lsort -unique [concat [lindex $parsedExpr 1] [lindex $parsedCond 1]]]

        set expressions($expression:$condition) 1

        set UPVARS  {}
        set LENGTHS {}
        set ASSIGN  {}
        foreach var $vars {
            append  UPVARS "upvar 2 $var __$var\n"
            lappend LENGTHS "\[llength \$__$var\]"
            append  ASSIGN  "set $var \[lindex' \$__$var \$__i__\]\n"
        }
        set LENGTHS [join $LENGTHS ,]

        proc $expression:$condition {} [string map \
            [list UPVARS $UPVARS LENGTHS $LENGTHS ASSIGN $ASSIGN EXPR $expression COND $condition] \
           {UPVARS
            set __sum__    0.0
            set __length__ [expr {max(LENGTHS)}]
            for {set __i__ 0} {$__i__ < $__length__} {incr __i__} {
                ASSIGN
                if { COND } {
                    set __sum__ [expr {$__sum__ + EXPR}]
                }
            }
            return $__sum__
        }]
     }

     $expression:$condition
}

# vexpr --
#     Evaluate arithmetic expressions with arrays of numbers
#
# Arguments:
#     expression     Arbitrary arithmetic expression
#
# Result:
#     Value (list) of the expression
#
# TODO:
#     Complete the implementation
#
proc ::vectors::vexpr {expression} {

    TODO!

}

# main --
#     Test the code
#

set values {1 2 3 4 5 2 3 0}
set threshold 3
puts "Sum:            [::vectors::vsum {$values} {$values > $threshold}]"
puts "Sum of squares: [::vectors::vsum {$values**2} {$values > $threshold}]"

JBR : Operator precedence expression parser

AM (14 december 2012) Yes, I like that stuff :), but if we use Tcl's parser functionality there can be no discrepancy. Still, that parser could be an alternative (though I do want real numbers to be recognised).

Sample implementation

Below you will find code that uses the testexprparser command from the Tcl test suite to implement the transformation from infix to prefix notation. Just a first step and not very well tested either, but for the expressions given below it works fine.

Note: I use Tcl 9.0 for this - the commands used for the Tcl test suite are stored in a loadable library, rather than in a separate shell.


# transform_expr.tcl --
#     Transform an expression from infix to prefix
#
lappend env(PATH) ../tcl-novem/win
load tcltest90

proc transformExpr {expr} {
    set parsed [testexprparser $expr -1]
    lassign [TransformExprPriv $parsed 0] result postfix variables
    return  [list [string range $result 2 end-1] [lsort -unique $variables]]
}
proc TransformExprPriv {parsed insubexpr} {

   #puts "-Invoking priv"

    set result    {}
    set variables {}
    set isvar     0
    set current   0
    set postfix   ""

    for {set current 0} {$current < [llength $parsed]} {incr current 3} {
        lassign [lrange $parsed $current [expr {$current+2}]] mnemonic string numberComponents
       #puts "$mnemonic -- $string -- $current -- $isvar"
        switch -- $mnemonic {
            "-" -
            ""  {
                # Ignore these mnenomics - start and stop
            }

            "subexpr" {
                set start     [expr {$current+3}]
                set end       [expr {$start + 3*$numberComponents-1}]
               #puts "==> [lrange $parsed $start $end]"

                lassign [TransformExprPriv [lrange $parsed $start $end] 1] subexpr op newvars

                append postfix   ""
                append result    " $subexpr$op"
                set    variables [concat $variables $newvars]

                incr current [expr {3*$numberComponents}]
                continue
            }

            "operator" {
                set postfix   "]"
                append result "\[$string "
            }

            "variable" {
                set isvar     1
                if { $insubexpr } {
                    append result "$string "
                }
            }

            "text" {
                if { $isvar } {
                    lappend variables $string
                } else {
                    append result "$string "
                }
                set insubexpr 0
                set isvar     0
            }
        }
       #puts ">>> $result$postfix"
       #puts ">>> $result"
    }

   #puts "-Returning from priv"
    return [list $result $postfix $variables]
}

foreach expr {
    {1 / (1+$a)}
    sin($a)
    min($a,$b,$c)+1
    {max(0, min($a, 1))}
    {(1+$a*$b) / (1+$a**2)}
    {1+$a*$b*$c}
    sin($a*$b)
    {1 + $a($b)}
    {$a in {1 2 3}}
    {$a > 0? 1 : 0} } {

    puts "Expression: $expr"
    puts "     Infix: [transformExpr $expr]"
}