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:
But it does achieve a few things:
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:
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.