如何编写一个方案过程来展平算术表达式？

Question

例如：

(* (* (* 1 2) 3) (* 4 5)) = (* 1 (* 2 (* 3 (* 4 5))))

我已经坐了几个小时想弄清楚如何编写这个程序，但我似乎无法让它工作。

生成的程序是（但是它没有按预期工作）：

(define interpret-arithmetic-expression_Magritte_bizarre
  (lambda (e)
    (cond
      [(is-literal? e)
       (make-literal (literal-1 e))]
      [(is-plus? e)
       (if (is-plus? (plus-1 e))
           (make-plus (interpret-arithmetic-expression_Magritte_bizarre (plus-1 (plus-1 e)))
                      (make-plus (interpret-arithmetic-expression_Magritte_bizarre (plus-2 (plus-1 e)))
                                 (interpret-arithmetic-expression_Magritte_bizarre (plus-2 e))))
           (make-plus (interpret-arithmetic-expression_Magritte_bizarre (plus-1 e))
                      (interpret-arithmetic-expression_Magritte_bizarre (plus-2 e))))]
      [(is-times? e)
       (if (is-times? (times-1 e))
           (make-times (interpret-arithmetic-expression_Magritte_bizarre (times-1 (times-1 e)))
                       (make-times (interpret-arithmetic-expression_Magritte_bizarre (times-2 (times-1 e)))
                                   (interpret-arithmetic-expression_Magritte_bizarre (times-2 e))))
           (make-times (interpret-arithmetic-expression_Magritte_bizarre (times-1 e))
                       (interpret-arithmetic-expression_Magritte_bizarre (times-2 e))))]
      [else
       (errorf 'interpret-arithmetic-expression_Magritte
               "unrecognized expression: ~s"
               e)])))

Answer 1

这并不完全是一个答案：

• 尚不完全清楚您真正想要的答案是什么；
• 这是毫不掩饰的Racket，并没有伪装成可移植Scheme（我以前是一名CL 程序员——我什至不确定我什至不知道什么是可移植Scheme！）。

但是，下面的代码会扁平化各种表达式：

> (flatten-expression '(+ (+ (* 2 a (* 1 b)) 1 3 (+ 3))))
'(+ (* 2 a 1 b) 1 3 3)

如果你使用前置简化器，它也会做得更好：

> (flatten-expression '(- 1 (+ 2 4) 5))
'(- 1 (+ 2 4) 5)
> (flatten-expression (presimplify-expression '(- 1 (+ 2 4) 5)))
'(- 1 (+ 2 4 5))

还有一个基本的评估器。

#lang racket

;;;; Flattening expressions
;;;
;;; Expressions are either (op ...), numbers or symbols.  Operators are
;;; symbols.
;;;
;;; These tests only look at the top-level of a compound expression
;;;
;;; There is a lot more that could be done than this of course:
;;; partially-evaluating things, for instance.
;;;

(define (compound-expression? e)
  (and (list? e)
       (symbol? (first e))))

(define (atomic-expression? e)
  (or (number? e)
      (symbol? e)))

(define (valid-expression? e)
  (or (atomic-expression? e)
      (compound-expression? e)))

;;; Pulling apart and assembling compound expressions
;;;

(define (ce-op e)
  (first e))

(define (ce-args e)
  (rest e))

(define (make-ce op args)
  (cons op args))

;;; A full checker
;;;

(define (valid-expression*? e)
  (cond
    [(atomic-expression? e)
     #t]
    [(compound-expression? e)
     (andmap valid-expression*? (ce-args e))]
    [else #f]))


;;; Flattening.
;;; This is overcomplicated: really it could just know what operators can
;;; be flattened.
;;;

(define flattenable-operators '(* +))

(define (flatten-expression e (fops flattenable-operators))
  (define (flatten-fop op argtail accum agenda)
    (if (null? argtail)
        (if (null? agenda)
            (make-ce op (reverse accum))
            (flatten-fop op (first agenda) accum (rest agenda)))
        (let ([arg (first argtail)]
              [tail (rest argtail)])
          (cond
            [(atomic-expression? arg)
             (flatten-fop op tail (cons arg accum) agenda)]
            [(compound-expression? arg)
             (if (eqv? (ce-op arg) op)
                 (flatten-fop op (ce-args arg) accum (cons tail agenda))
                 (flatten-fop op tail
                              (cons (flatten-expression arg fops)
                                    accum)
                              agenda))]
            [else (error "not an expression:" arg)]))))
  (cond
    [(atomic-expression? e)
     e]
    [(compound-expression? e)
     (let ([op (ce-op e)]
           [args (ce-args e)])
       (if (memv op fops)
           (flatten-fop op args '() '())
           (make-ce op (map (λ (a) (flatten-expression a fops)) args))))]
    [else (error "not an expression:" e)]))

;;; A simplifier to make the flattener's life more productive
;;;

(define (presimplify-expression e)
  ;; This has built-in knowledge of some arithmetic operators,
  ;; and uses the usual Lisp/Scheme semantics for / and -: (/ a b c) is
  ;; (/ a (* b c)) & so on.
  (cond
    [(atomic-expression? e)
     e]
    [(compound-expression? e)
     (let ([op (ce-op e)]
           [args (ce-args e)])
       (case (length args)
         [(0)
          (case op
            [(+ *) 0]
            [(/ -) (error "no args for" op)]
            [else e])]
         [(1)
          (case op
            [(+ * /) (presimplify-expression (first args))]
            [else (make-ce op (map presimplify-expression args))])]
         [else
          (case op
            [(-) (make-ce op
                          (list (presimplify-expression (first args))
                                (make-ce '+ (map presimplify-expression
                                                 (rest args)))))]
            [(/) (make-ce op
                          (list (presimplify-expression (first args))
                                (make-ce '* (map presimplify-expression
                                                 (rest args)))))]
            [else (make-ce op (map presimplify-expression args))])]))]
    [else
     (error "not an expression:" e)]))

(define (simplify-expression e (fops flattenable-operators))
  (flatten-expression (presimplify-expression e) fops))

;;; An evaluator
;;;

(define builtin-bindings
  `((+ . ,+)
    (- . ,-)
    (* . ,*)
    (/ . ,/)))

(define (evaluate-expression e (bindings '()))
  (for ([b bindings])
    (unless (and (cons? b) (symbol? (car b)))
      (error "bad binding form" b))
    (when (assv (car b) builtin-bindings)
      (error "trying to rebind a builtin " (car b))))
  (define (symbol-binding s)
    (let ([binding (or (assv s builtin-bindings)
                       (assv s bindings))])
      (unless binding
        (error "unbound variable" s))
      (cdr binding)))
  (define (eval-exp e)
    (cond
      [(atomic-expression? e)
       (cond
         [(number? e) e]
         [(symbol? e) (symbol-binding e)]
         [else (error "mutant horror" e)])]
      [(compound-expression? e)
       (let ([op (ce-op e)]
             [args (ce-args e)])
         (apply (symbol-binding op)
                (map eval-exp args)))]))
  (eval-exp e))