private/stepper.ss
(module stepper mzscheme
  (require (lib "pretty.ss")
           (lib "mred.ss" "mred")
           (lib "class.ss")
           "reduction-semantics.ss")
  
  (define (step lang red term)
    (define f (new stepper-frame%))
    (send f show #t))
  
  (define stepper-frame%
    (class frame%
      (init-field left-column)
      (define/public (add-column los) ...)))
  
  (define (record-differences sexp1 sexp2)
    (let ([ht (make-hash-table)])
      (let loop ([sexp1 sexp1]
                 [sexp2 sexp2])
        (cond
          [(eq? sexp1 sexp2) (void)]
          [(and (pair? sexp1)
                (pair? sexp2)
                (equal? (d-length sexp1)
                        (d-length sexp2)))
           (for-each/d loop sexp1 sexp2)]
          [(equal? sexp1 sexp2) (void)]
          [else 
           (hash-table-put! ht sexp1 #t)
           (hash-table-put! ht sexp2 #t)]))))
  
  (define (show-differences s1 s2)
    (define diff-ht (record-differences s1 s2))
    (define f (new frame% [label ""] [width 600] [height 500]))
    (define hp (new horizontal-panel% [parent f]))
    (define t1 (new text%))
    (define t2 (new text%))
    (define c1 (new editor-canvas% 
                    [parent hp]
                    [editor t1]))
    (define c2 (new editor-canvas% 
                    [parent hp]
                    [editor t2]))
    (render-sexp/colors s1 diff-ht t1)
    (render-sexp/colors s2 diff-ht t2)
    (send f show #t))
  
  ;; render-sexp/colors : sexp ht text -> void
  (define (render-sexp/colors sexp diff-ht text)
    (parameterize ([pretty-print-columns 30])
      (pretty-print sexp (open-output-text-editor text)))
    (send text change-style 
          (make-object style-delta% 'change-family 'modern)
          0
          (send text last-position)))
  
  (define (for-each/d f l1 l2)
    (let loop ([l1 l1]
               [l2 l2])
      (cond
        [(pair? l1)
         (f (car l1) (car l2))
         (loop (cdr l1) (cdr l2))]
        [(null? l1) (void)]
        [else (f l1 l2)])))
  
  (define (d-length l1)
    (let loop ([l1 l1]
               [n 0])
      (cond
        [(pair? l1) (loop (cdr l1) (+ n 1))]
        [(null? l1) n]
        [else (cons 'dotted (+ n 1))])))
  
  
  (show-differences
   '(store
     ()
     (((call/cc
        (throw
         x3
         ((x3
           (throw
            x2
            (((lambda (x) ((call/cc call/cc) x)) x2)))))))
       (throw x2 (((lambda (x) ((call/cc call/cc) x)) x2))))))
   '(store
     ()
     ((begin
        1
        ((values
          (throw
           x4
           ((x4
             (throw
              x2
              (((lambda (x) ((call/cc call/cc) x)) x2)))))))
         (throw
          x2
          (((lambda (x) ((call/cc call/cc) x)) x2)))))))))