REBOL [ Date: 13-Mar-2011/17:56:26+1:00 File: %evaluate.r Title: "Evaluate" Author: "Ladislav Mecir" Purpose: { A few expression evaluators and expression translators written in REBOL. } ] #include-check %use-rule.r slash: to lit-word! first [/] double-slash: to lit-word! first [//] unless value? 'words-of [ words-of: func [value] [copy next first value] values-of: func [value] [copy next second value] ] ; An object containing evaluating functions. evaluate: make object! [ pow: :power mul: :multiply div: :divide rem: :remainder ad: :add sub: :subtract neg: :negate setw: :set seq: func [a b] [a] ] ; An object containing translating functions. translate: make object! [ pow: func [a b] [append append copy [power] a b] mul: func [a b] [append append copy [multiply] a b] div: func [a b] [append append copy [divide] a b] rem: func [a b] [append append copy [remainder] a b] ad: func [a b] [append append copy [add] a b] sub: func [a b] [append append copy [subtract] a b] neg: func [a] [append copy [negate] a] setw: func [a b] [append append/only copy [set first] append copy [] a b] seq: func [a b] [append a b] ] ; The expression parsing functions below take an EVALUATOR argument, ; which can be an object containing either evaluating or translating functions, ; causing the respective expression parsing function to either yield a result, ; or a translation of the given expression. ; In the functions, the variable 'a is used as an accumulator. ; When 'a is going to be overwritten, ; we store the content in a rule-local variable 'b. std: func [ { Standard priority/associativity evaluator Priority/associativity: 0: number, paren 1: unary -, unary +/right to left 2: power/right to left 3: multiplication, division, remainder/left to right 4: addition, subtraction/left to right 5: set-word/right to left 6: expression expression/left to right } [catch] expression [block!] evaluator [object!] /local pow mul div rem ad sub neg setw seq pos a element p1 p2 p3 p4 expr ] [ set bind words-of evaluator 'local values-of evaluator element: [pos: paren! :pos into p4 | set a number!] ; right to left p1: use-rule [b] [ '- p1 (a: neg a) | '+ p1 | set b set-word! p4 (a: setw b a) | element ] ; right to left p2: use-rule [b] [p1 opt ['** (b: a) p2 (a: pow b a)]] ; left to right p3: use-rule [b] [ p2 any [ '* (b: a) p2 (a: mul b a) | slash (b: a) p2 (a: div b a) | double-slash (b: a) p2 (a: rem b a) ] ] ; left to right p4: use-rule [b] [ p3 any ['+ (b: a) p3 (a: ad b a) | '- (b: a) p3 (a: sub b a)] ] ; left to right expr: use-rule [b] [ p4 any [(b: a) p4 (a: seq b a)] end | (throw make error! "invalid expression") ] parse expression expr a ] sra: func [ { Simple right-associative expression evaluator Priority/associativity: 0: number, paren 1: infix: power, multiplication, division, remainder, addition, subtraction/right to left 2: prefix: negate, power, multiplication, division, remainder, addition set-word/right to left 3: subexpression subexpression/left to right } [catch] expression [block!] evaluator [object!] /local pow mul div rem ad sub neg setw seq pos a m expr right-operand prefix infix element ] [ set bind words-of evaluator 'local values-of evaluator element: [pos: paren! :pos into expr | set a number!] prefix: use-rule [b] [ '- right-operand (a: neg a) | set b set-word! right-operand (a: setw b a) | '+ right-operand (b: a) infix (a: ad b a) | '* right-operand (b: a) infix (a: mul b a) | slash (b: a) right-operand infix (a: div b a) | double-slash (b: a) right-operand infix (a: rem b a) | '** (b: a) right-operand infix (a: pow b a) ] infix: use-rule [b] [ element opt [ '+ (b: a) right-operand (a: ad b a) | '- (b: a) right-operand (a: sub b a) | '* (b: a) right-operand (a: mul b a) | slash (b: a) right-operand (a: div b a) | double-slash (b: a) right-operand (a: rem b a) | '** (b: a) right-operand (a: pow b a) ] ] right-operand: [prefix | infix] expr: use-rule [b] [ right-operand any [(b: a) infix (a: seq b a)] end | (throw make error! "invalid expression") ] parse expression expr a ] rle: func [ { REBOL-like expression evaluator Priority/associativity: 0: number, paren 1: infix: power, multiplication, division, remainder, addition, subtraction/left to right 2: prefix: negate, power, multiplication, division, remainder, addition set-word/right to left 3: subexpression subexpression/left to right } [catch] expression [block!] evaluator [object!] /local pow mul div rem ad sub neg setw seq pos a expr right-operand prefix infix element ] [ set bind words-of evaluator 'local values-of evaluator element: [pos: paren! :pos into expr | set a number!] prefix: use-rule [b] [ '- prefix (a: neg a) | set b set-word! right-operand (a: setw b a) | '+ right-operand (b: a) infix (a: ad b a) | '* right-operand (b: a) infix (a: mul b a) | slash right-operand (b: a) infix (a: div b a) | double-slash right-operand (b: a) infix (a: rem b a) | '** right-operand (b: a) infix (a: pow b a) ] right-operand: [prefix | infix] infix: use-rule [b] [ element any [ '+ (b: a) element (a: ad b a) | '- (b: a) element (a: sub b a) | '* (b: a) element (a: mul b a) | slash (b: a) element (a: div b a) | double-slash (b: a) element (a: rem b a) | '** (b: a) element (a: pow b a) ] opt [ '+ (b: a) prefix (a: ad b a) | '- (b: a) prefix (a: sub b a) | '* (b: a) prefix (a: mul b a) | slash (b: a) prefix (a: div b a) | double-slash (b: a) prefix (a: rem b a) | '** (b: a) prefix (a: pow b a) ] ] expr: use-rule [b] [ right-operand any [(b: a) infix (a: seq b a)] end | (throw make error! "invalid expression") ] parse expression expr a ] comment [ foreach expression [ [1 + 2 ** 3 * 2] ] [ print ["Expression:" mold expression] foreach f [std sra rle] [ print [ f "result:" do get f expression evaluate "translation:" mold do get f expression translate ] ] ] ] comment [ results: Expression: [1 + 2 ** 3 * 2] std result: 17.0 translation: [add 1 multiply power 2 3 2] sra result: 65.0 translation: [add 1 power 2 multiply 3 2] rle result: 54.0 translation: [multiply power add 1 2 3 2] ]