Version 8 of infix to prefix

Updated 2012-08-23 18:31:29 by wdb
if false {

wdb If possible, for mathematical problems I ask maxima or wolfram alpha, then I take their output as input for expr.

This method fails if the resulting formulas contain complex numbers. The function expr doesn't calcultate (yet) complex values, so all I can do is using own complex functions which are in prefix notion, such as

 % complex+ {3 4} {1 5}
 4 9
 %

But therefor, I must transform infix-notated formulae to prefix. Here it comes:

}


namespace eval infixToPrefix {
  namespace export *
}

proc infixToPrefix::tokenize src {
  # list tokens in $src
  set result {}
  set l [string length $src]
  set str ""
  for {set i 0} {$i < $l} {incr i} {
    if {[string index $src $i] in {+ - * / ^ ( )}} then {
      if {$str ne ""} then {
        lappend result $str
        set str ""
      }
      lappend result [string index $src $i]
    } else {
      append str [string index $src $i]
    }
  }
  if {$str ne ""} then {
    lappend result $str
  }
  set result
}

proc infixToPrefix::listify tokenList {
  # return nested lists
  set level 0
  set term {}
  set result {}
  foreach token $tokenList {
    if {$token eq "\("} then {
      incr level
    } 
    if {$level == 0} then {
      if {[llength $term] > 0} then {
        lappend result [listify [lrange $term 1 end-1]]
        set term {}
      }
      lappend result $token
    } else {
      lappend term $token
    }
    if {$token eq "\)"} then {
      incr level -1
    }
  }
  if {[llength $term] > 0} then {
    lappend result [listify [lrange $term 1 end-1]]
  }
  set result
}

proc infixToPrefix::extractFunctions lst {
  # group function calls (precedence 1)
  set funcs [info functions]
  lappend funcs -
  if {[llength $lst] < 2} then {
    # echo length [llength $lst] -- $lst
    if {[llength [lindex $lst 0]] < 2} then {
      set lst
    } else {
      list [groupByPrecedence [lindex $lst 0]]
    }
  } elseif {[lindex $lst 0] in $funcs} then {
    # leading function name found
    set lst1 [extractFunctions [lrange $lst 1 end]]
    list [list [lindex $lst 0] [lindex $lst1 0]] {*}[lrange $lst1 1 end]
  } else {
    # not a function
    list\
      [groupByPrecedence [lindex $lst 0]]\
      [lindex $lst 1]\
      {*}[groupByPrecedence [lrange $lst 2 end]]
  }
}

proc infixToPrefix::groupByOp {lst op} {
  # group equal operators
  set idx [lsearch $lst [string map [list * \\*] $op]]
  if {$idx < 0} then {
    # no occurrence of $op in $lst
    set lst
  } else {
    set start [expr $idx-1]
    set result [lrange $lst 0 [expr {$start-1}]]
    set l [llength $lst]
    for {set i $idx} {$i < $l} {incr i 2} {
      if {[lindex $lst $i] ne $op} then break
    }
    set end [expr {$i-1}]
    lappend result\
      [lrange $lst $start $end]\
      {*}[groupByOp [lrange $lst [expr {$end+1}] end] $op]
  }
}

proc infixToPrefix::groupByOps {lst args} {
  # group subsequently by operators
  foreach op $args {
    set lst [groupByOp $lst $op]
  }
  set lst
}

proc infixToPrefix::groupByPrecedence lst {
  # group by precedence: function-name, ^, /, *, -, +
  if {[llength $lst] < 2} then {
    set result $lst
  } else {
    set result [groupByOps [extractFunctions $lst] ^ / * - +]
  }
  if {[llength $result] == 1} then {
    lindex $result 0
  } else {
    set result
  }
}

proc infixToPrefix::grpToPrefix grp {
  # put infix-operators to front
  if {[llength $grp] == 1} then {
    set grp
  } elseif {[llength $grp] == 2} then {
    list [lindex $grp 0] [grpToPrefix [lindex $grp 1]]
  } else {
    lassign $grp term op
    lappend result $op [grpToPrefix $term]
    foreach {op term} [lrange $grp 1 end] {
      lappend result [grpToPrefix $term]
    }
    set result
  }
}

proc infixToPrefix::simplifyExpr prf {
  # splice nested terms with equal operator
  if {[llength $prf] < 2} then {
    set prf
  } else {
    set op [lindex $prf 0]
    lappend result $op
    foreach expr [lrange $prf 1 end] {
      set expr1 [simplifyExpr $expr]
      if {$op in {+ *} && [lindex $expr1 0] eq $op} then {
        lappend result {*}[lrange $expr1 1 end]
      } else {
        lappend result $expr1
      }
    }
    set result
  }
}

if false {

The final function transforms braces to brackets and maxima-specific terms to own-specific ones.

}

proc infixToPrefix::infixToPrefix term {
  # return lambda-expr to be apply'd
  set tok [tokenize $term]
  set lis [listify $tok]
  set grp [groupByPrecedence $lis]
  set prf [grpToPrefix $grp]
  set exp [simplifyExpr $prf]
  set trns [string map\
              [list \{ \[ \} \]\
                 %i "{0 1}"\
                 ^ complex** sqrt complexSqrt\
                 / complex/ * complex*\
                 - complex- + complex+]\
              $exp]
  regsub -all { ([a-zA-Z]+)} $trns { $\1}
}

namespace import infixToPrefix::infixToPrefix