Print calculation steps.

print-calculate-steps.rkt

#lang racket

(require racket/generator
         (only-in parser-tools/lex define-tokens define-empty-tokens)
         parser-tools/yacc)

(define-tokens a (NUM))
(define-empty-tokens b (+ - * / EOF))

(define expr-parser
  (parser
   [tokens a b]
   [start expr]
   [end EOF]
   [error (void)]
   [precs (left + -) (left * /)]
   [grammar
    (expr [(expr + expr)
           (list '+ $1 $3)]
          [(expr - expr)
           (list '- $1 $3)]
          [(expr * expr)
           (list '* $1 $3)]
          [(expr / expr)
           (list '/ $1 $3)]
          [(NUM)
           $1])]))

(define input->tokens
  (lambda (lst)
    (cond
      [(null? lst)
       (list 'EOF)]
      [(number? (car lst))
       (cons
        (token-NUM (car lst))
        (input->tokens (cdr lst)))]
      [else
       (cons
        (car lst)
        (input->tokens (cdr lst)))])))

(define infix-walkthrough
  (lambda (tree f)
    (let loop ([tree tree])
      (cond
        [(not (list? tree))
         (f tree)]
        [else
         (begin
           (loop (cadr tree))
           (f (car tree))
           (loop (caddr tree)))]))))

(define print-expr
  (lambda (expr)
    (infix-walkthrough expr
                       (lambda (s)
                         (begin
                           (display s)
                           (display #\space))))))

(define eval-expr-small-step
  (lambda (expr)
    (cond
      [(number? expr) expr]
      [(number? (caddr expr))
       (cond
         [(number? (cadr expr))
          (beta-reduce expr)]
         [else
          (list (car expr)
                (eval-expr-small-step (cadr expr))
                (caddr expr))])]
      [else
       (list (car expr)
             (cadr expr)
             (eval-expr-small-step (caddr expr)))])))

(define beta-reduce
  (lambda (expr)
    (let ([op (car expr)]
          [rator (cadr expr)]
          [rand (caddr expr)])
      (cond
        [(eqv? op '+) (+ rator rand)]
        [(eqv? op '-) (- rator rand)]
        [(eqv? op '*) (* rator rand)]
        [(eqv? op '/) (/ rator rand)]))))

(define print-calculate-steps
  (lambda (input)
    (let* ([run-lexer (sequence->generator (input->tokens input))]
           [expr (expr-parser run-lexer)])
      (print-expr expr)
      (newline)
      (let loop ([expr (eval-expr-small-step expr)])
        (display "=> ")
        (print-expr expr)
        (newline)
        (unless (number? expr)
          (loop (eval-expr-small-step expr)))))))

(print-calculate-steps '(1 + 2 * 3 - 2))

rewrite-via-pmatch.rkt

#lang racket

(require racket/match)

(define input '(1 + 2 * 3 - 4 * 5 + 6))

(define eval0
  (lambda (tokens)
    (match tokens
      [(list a '+ b ...) `(+ ,a ,(eval0 b))]
      [(list a '- b ...) `(- ,a ,(eval0 b))]
      [(list a '* b r ...) (eval0 `((* ,a ,b) ,@r))]
      [(list a) a])))

(eval0 input)
; => '(+ 1 (- (* 2 3) (+ (* 4 5) 6)))

stepper.sls

#!r6rs

(library
 (calculator stepper)
 (export print-calculate-steps)
 (import (rnrs))
 
 (define append-reverse
   (lambda (l1 l2)
     (cond
       [(null? l1) l2]
       [else
        (append-reverse
         (cdr l1)
         (cons (car l1) l2))])))
 
 (define op-alst
   `([+ . ,+]
     [- . ,-]
     [* . ,*]
     [/ . ,/]))
 
 (define single-or-list
   (lambda (lst)
     (cond
       [(null? (cdr lst))
        (car lst)]
       [else
        lst])))
 
 (define step
   (lambda (tokens)
     (define identity
       (lambda (x) x))
     (cond
       [(step-par tokens)
        => identity]
       [(step-mult tokens)
        => identity]
       [(step-addi tokens)
        => identity]
       [else tokens])))
 
 (define step-par
   (lambda (tokens)
     (let loop ([saved '()]
                [tokens tokens])
       (cond
         [(null? tokens) #f]
         [(pair? (car tokens))
          (append-reverse
           saved
           (cons (single-or-list (step (car tokens)))
                 (cdr tokens)))]
         [else
          (loop (cons (car tokens)
                      saved)
                (cdr tokens))]))))
 
 (define step-cal
   (lambda (op-lst)
     (lambda (tokens)
       (let loop ([saved '()]
                  [tokens tokens])
         (cond
           [(null? tokens) #f]
           [(memv (car tokens) op-lst)
            (append-reverse
             (cdr saved)
             (cons
              ((cdr (assv (car tokens) op-alst))
               (car saved)
               (cadr tokens))
              (cddr tokens)))]
           [else
            (loop (cons (car tokens)
                        saved)
                  (cdr tokens))])))))
 
 (define step-mult
   (step-cal '(* /)))
 
 (define step-addi
   (step-cal '(+ -)))
 
 (define print-calculate-steps
   (lambda (tokens)
     (display tokens)
     (newline)
     (let loop ([tokens (step tokens)])
       (display "=> ")
       (display tokens)
       (newline)
       (unless (null? (cdr tokens))
         (loop (step tokens))))))
 
#|
 (define input '(1 + 2 * 3 - 4 - 5 * (6 + 7) + 8 / 2))
 
 (print-calculate-steps input)

{1 + 2 * 3 - 4 - 5 * {6 + 7} + 8 / 2}
=> {1 + 2 * 3 - 4 - 5 * 13 + 8 / 2}
=> {1 + 6 - 4 - 5 * 13 + 8 / 2}
=> {1 + 6 - 4 - 65 + 8 / 2}
=> {1 + 6 - 4 - 65 + 4}
=> {7 - 4 - 65 + 4}
=> {3 - 65 + 4}
=> {-62 + 4}
=> {-58}

|#
 )

哈工大出来的啊，12年的研究生明年也该毕业了吧。

来自贴吧带着爱。