Creating your own expr command

Arjen Markus (4 april 2006) While some people would like shorthands for [expr], so that they can use the prefix notation for mathematical operations, others greatly prefer the infix notation and would like to be able to expand that to their own commands/procedures. (BLT has such a facility for dealing with vectors and mpexpr for dealing with large integers). Well, the script below allows you to define your own expr-like command or procedure.

It is not complete yet:

It does not resolve function calls yet
It does not deal with array elements yet
As constants may taken any form or shape, I think supporting general constants will be nigh to impossible

But it does achieve a few things:

You can define a new command that takes an expression like {$a+($b-$c)/$d} and transforms that into a prefix form so that you can simply define specific commands for the +, -, * and / operations appropriate for the data stored in the variables a, b, c, d.
The command is fairly efficient as it will need to analyse an expression only once and then caches the result

The example below shows how this works out for the complex numbers package in Tcllib:

   ::ParseExpressions::makeExpr cexpr {}

creates a command cexpr that interprets the variables as complex numbers. The (imported) +,-, /, and * procedures do the dirty work:

   cexpr {$a+($b-$c)/$d} ==> uplevel 1 {+ $a [/ [- $b $c] $d]} ==> the answer

In a very similar way one could:

Create a command to deal with vector and matrix computations
Create a command to deal with arbitrary precision reals
Create a command to deal with interval arithmetic
...

I intend to put this in Tcllib, when the script is ready (see the list above), in one form or another.

 # parse_expr.tcl --
 #    Parse an arbitrary arithmetic expression
 #    and turn it into an equivalent prefix
 #    expression.
 #

 namespace eval ::ParseExpressions {
    namespace export parseExpr
 }

 # TranslateLexeme --
 #     Translate the lexeme (operator or function name)
 # Arguments:
 #     lexeme         Lexeme to be translated
 #     translation    List of expression-function pairs
 # Result:
 #     Next lexeme
 #
 proc ::ParseExpressions::TranslateLexeme {lexeme translation} {

     set idx [lsearch $translation $lexeme]
     if { $idx >= 0 && $idx%2 == 0 } {
         return [lindex $translation [incr idx]]
     } else {
         return $lexeme
     }
 }

 # GetLexeme --
 #     Split the expression in lexemes
 # Arguments:
 #     token_list     List of tokens
 # Result:
 #     Next lexeme
 #
 proc ::ParseExpressions::GetLexeme {token_list} {

     #
     # Simple for the moment :)
     #
    #puts "lexeme: [lindex $token_list 0] -- [lrange $token_list 1 end]"
     return [lindex $token_list 0]
 }

 # ConsumeLexeme --
 #     Remove the current lexeme and return a new partial expression
 # Arguments:
 #     token_list     List of tokens
 # Result:
 #     New partial expression
 #
 proc ::ParseExpressions::ConsumeLexeme {token_list} {

     #
     # Simple for the moment :)
     #
    #puts "consume: [lindex $token_list 0] -- [lrange $token_list 1 end]"
     return [lrange $token_list 1 end]
 }

 # ParsePrimaryExpr --
 #     Parse primary expressions
 # Arguments:
 #     token_list     List of tokens
 #     translation    List of expression-function pairs
 # Result:
 #     Parsed expression and remaining list
 #
 proc ::ParseExpressions::ParsePrimaryExpr {token_list translation} {

    #puts "Primary - $token_list"
     #
     # Simple for the moment :)
     #
    #puts "Primary - result: [lindex $token_list 0]"
     set lexeme [GetLexeme $token_list]
     if { $lexeme == "(" } {
         set token_list [ConsumeLexeme $token_list]
         foreach {result token_list} [ParseAddExpr $token_list $translation] {break}
        #puts "Returned tokenlist: $token_list"

         set lexeme [GetLexeme $token_list]
         set token_list [ConsumeLexeme $token_list]
         if { $lexeme != ")" } { error "No closing parenthesis" }

         return [list $result $token_list]
     } elseif { $lexeme == ")" } {
         return [list {} $token_list]
     } else {
         return [list [lindex $token_list 0] [lrange $token_list 1 end]]
     }
 }

 # ParseMultiplyExpr --
 #     Parse multiply-like expressions
 # Arguments:
 #     token_list     List of tokens
 #     translation    List of expression-function pairs
 # Result:
 #     Parsed expression and remaining list
 #
 proc ::ParseExpressions::ParseMultiplyExpr {token_list translation} {

    #puts "Multiply - $token_list"
     set result ""
     foreach {left token_list} [ParsePrimaryExpr $token_list $translation] {break}

     set hasop 0
     set lexeme [GetLexeme $token_list]

     while { $lexeme == "*" || $lexeme == "/" } {

         set token_list [ConsumeLexeme $token_list]
         set lexeme     [TranslateLexeme $lexeme $translation]
         foreach {right token_list} [ParseMultiplyExpr $token_list $translation] {break}

         if { ! $hasop } {
             set hasop 1
             set result "\[$lexeme $left $right\]"
         } else {
             set result "\[$lexeme $result $right\]"
         }

         set lexeme [GetLexeme $token_list]
     }

     if { ! $hasop } {
         set result "$left"
     }

    #puts "Multiply - result: $result"
     return [list $result $token_list]
 }

 # ParseAddExpr --
 #     Parse add-like expressions
 # Arguments:
 #     token_list     List of tokens
 #     translation    List of expression-function pairs
 # Result:
 #     Parsed expression and remaining list
 #
 proc ::ParseExpressions::ParseAddExpr {token_list translation} {
    #puts "Add - $token_list"

     set result ""
     foreach {left token_list} [ParseMultiplyExpr $token_list $translation] {break}

     set hasop 0
     set lexeme [GetLexeme $token_list]

     while { $lexeme == "+" || $lexeme == "-" } {

         set token_list [ConsumeLexeme $token_list]
         set lexeme     [TranslateLexeme $lexeme $translation]
         foreach {right token_list} [ParseMultiplyExpr $token_list $translation] {break}

         if { ! $hasop } {
             set hasop 1
             set result "\[$lexeme $left $right\]"
         } else {
             set result "\[$lexeme $result $right\]"
         }

         set lexeme [GetLexeme $token_list]
     }

     if { ! $hasop } {
         set result "$left"
     }
    #puts "Add - result: $result"
     return [list $result $token_list]
 }

 # ParseExpr --
 #     Turn a list of tokens into an expression tree
 # Arguments:
 #     token_list     List of tokens
 #     translation    List of expression-function pairs
 # Result:
 #     Nested list representing the expression tree
 #
 proc ::ParseExpressions::ParseExpr {token_list translation} {
     variable operators

     if { $token_list == {} } {
         return {}
     }

     return [string range [lindex [ParseAddExpr $token_list $translation] 0] 1 end-1]
 }

 # TokenizeExpr --
 #     Split an expression in tokens for further processing
 # Arguments:
 #     string         String holding the expression
 # Returns:
 #     List of tokens
 #
 proc ::ParseExpressions::TokenizeExpr {string} {
     set result {}

     set name 0
     set token ""
     set op ""
     set brackets 0
     foreach c [split $string ""] {
         switch -regexp -- $c {
         {\$} {
             if { $name } {
                 return -code error "\$ follows a variable name without an operator"
             }
             set op ""
             set name 1
             append token $c
         }
         {[a-zA-Z_0-9]} {
             set op ""
             append token $c
         }
         { } {
             # Skip spaces ...
         }
         {\.} {
             # Append to integer numbers only
             if { [string is integer $token] || $token == "" } {
                 set op ""
                 append token $c
             } else {
                 return -code error ". follows a variable name without an operator"
             }
         }
         {[-+*/]} {
             if { $token != "" } {
                 lappend result $token
                 set token ""
             }
             if { $op != "" } {
                 puts ">>> $result"
                 return -code error "Two operators without intervening operands"
             }
             set op $c
             lappend result $c
             set name 0
         }
         {[(]} {
             incr brackets
             if { $name != 0 } {
                 return -code error "( preceeded by a variable name or number"
             }
             set op ""
             lappend result $c
         }
         {[)]} {
             incr brackets -1
             if { $brackets < 0 } {
                 return -code error "too many closing brackets"
             }
             if { $token != "" } {
                 lappend result $token
                 set token ""
             }
             lappend result $c
         }
         }
     }

     if { $token != "" } {
         lappend result $token
     }

     if { $brackets > 0 } {
         return -code error "opening brackets not balanced with closing brackets"
     }

     return $result
 }

 # makeExpr --
 #     Make an expression evalutating procedure
 # Arguments:
 #     name           Name of the procedure
 #     translation    Translation of the operators into functions (list
 #                    of operator-function name pairs)
 # Returns:
 #     Nothing
 # Side effects:
 #     New procedure created in the caller's namespace
 #
 proc ::ParseExpressions::makeExpr {name translation} {
     set ns [uplevel 1 {namespace current}]
     proc ${ns}::$name expr [string map [list TR $translation NAME $name] {
     variable Expr_NAME
     if { ![info exists Expr_NAME($expr)] } {
         set Expr_NAME($expr) [::ParseExpressions::ParseExpr [::ParseExpressions::TokenizeExpr $expr] {TR}]
     }
     uplevel 1 $Expr_NAME($expr)
     }]
 }

 # main --
 #     Testing the stuff
 #
 proc add {a b} {
     return "$a+$b"
 }
 proc sub {a b} {
     return "$a-$b"
 }

 puts [::ParseExpressions::ParseExpr {1 + 2} {}]
 puts [::ParseExpressions::ParseExpr {1 + 2 + 3} {}]
 puts [::ParseExpressions::ParseExpr {1 + 2 * 3} {}]
 puts [::ParseExpressions::ParseExpr {1 * 2 + 3} {}]
 puts [::ParseExpressions::ParseExpr {1 - 2 - 3 - 4 * 5 } {}]
 puts [::ParseExpressions::ParseExpr {1 - ( 2 - 3 ) - 4 * 5 } {}]
 puts [::ParseExpressions::ParseExpr {1} {}]
 puts [::ParseExpressions::ParseExpr {1 - ( ( 2 - 3 ) / ( 4 * 5 ) ) } {}]

 puts [::ParseExpressions::TokenizeExpr {$a + $b * ( $c - $d)}]
 puts [::ParseExpressions::TokenizeExpr {($along2 * $bstep )+ 1 / ( $c - $d + 1.0)}]

 # Incorrect expressions:
 #puts [::ParseExpressions::TokenizeExpr {($a++$b * $bstep )+ 1 / ( $c - $d + 1.0)}]
 #puts [::ParseExpressions::TokenizeExpr {($a$b * $bstep )+ 1 / ( $c - $d + 1.0)}]

 # TODO:
 # - function calls, array elements, ** operator
 # - unary operators

 ::ParseExpressions::makeExpr chexpr {+ add - sub}

 set a "AA"
 set b "BB"
 set c "CC"
 set d "DD"
 puts [chexpr $a+$b-($c+$d)]

 # More serious now ....
 #
 package require math::complexnumbers
 namespace import ::math::complexnumbers::*

 ::ParseExpressions::makeExpr cexpr {}

 set a [complex 1 1]
 set b [complex 2 1]
 set c [conj $a]

 puts "a + b   = [cexpr {$a+$b}]"
 puts "a + b*a = [cexpr {$a+$b*$a}]"
 puts "a / c   = [cexpr {$a/$c}]"

AM [expr] can be exploited in other ways too: Using expr on lists

arjen - 2010-02-16 02:50:58

I have picked up this idea again and added unary operations. That new code is not on the Wiki yet. I want to add function calls to the mix first.

Basically, with my project for wrapping LAPACK routines I am becoming increasingly interested in working with lists of numerical data (vectors and matrices). And an [expr] command that works nicely with them would be very convenient.

Category Mathematics