(module stepper mzscheme
  (require (lib "pretty.ss")
           (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "framework.ss" "framework")
           "size-snip.ss"
           "reduction-semantics.ss")

  (provide step)
  
  (define (step lang red term)
    (define f (new frame% 
                   [label "PLT Redex Stepper"]
                   [width 400]
                   [height 400]))
    (define pb (new columnar-pasteboard%))
    (define ec (new forward-size-editor-canvas% [parent f] [editor pb]))
    (send f show #t)
    (let ([c1 (list (mk-snip term))]
          [c2 (map mk-snip (apply-reduction-relation red term))])
      (send pb add-column c1)
      (send pb add-column c2)
      (new button% 
           [callback
            (λ (a b)
              (for-each (λ (x) (send x reflow-program)) c1)
              (for-each (λ (x) (send x reflow-program)) c2))]
           [label "button"]
           [parent f])))
  
  (define forward-size-editor-canvas%
    (class editor-canvas%
      (inherit get-editor)
      (define/override (on-size w h)
        (send (get-editor) update-heights))
      (super-new)))
  
  (define (mk-snip sexp)
    (let* ([txt (new scheme:text%)]
           [s (new size-editor-snip% 
                   [editor txt]
                   [expr sexp]
                   [char-width 40]
                   [pp default-pretty-printer])])
      (send txt set-autowrap-bitmap #f)
      (send s format-expr)
      s))
  
  (define columnar-pasteboard% 
    (class (resizing-pasteboard-mixin pasteboard%)
      (define columns '())
      (inherit insert)
      (define/public (add-column los)
        (for-each (λ (x) (insert x) (send x reflow-program)) los)
        (set! columns (append columns (list los)))
        (update-heights))
      
      (inherit get-admin move-to resize)
      (define/public (update-heights)
        (let ([admin (get-admin)])
          (let-values ([(w h) (get-view-size)])
            (let loop ([columns columns]
                       [x 0])
              (cond
                [(null? columns) (void)]
                [else
                 (let* ([column (car columns)]
                        [base-space (quotient h (length column))]
                        [widest
                         (let loop ([snips column]
                                    [extra-space (modulo h (length column))]
                                    [y 0]
                                    [widest 0])
                           (cond
                             [(null? snips) widest]
                             [else 
                              (let* ([snip (car snips)]
                                     [sw (get-snip-width snip)]
                                     [h (+ base-space
                                           (if (zero? extra-space)
                                               0
                                               1))])
                                (move-to snip x y)
                                (resize snip sw h)
                                (loop (cdr snips)
                                      (if (zero? extra-space)
                                          0
                                          (- extra-space 1))
                                      (+ y h)
                                      (max widest sw)))]))])
                   (loop (cdr columns)
                         (+ x widest)))])))))

      (inherit get-snip-location)
      (define/private (get-snip-width snip)
        (let ([lb (box 0)]
              [rb (box 0)])
          (get-snip-location snip lb #f #f)
          (get-snip-location snip rb #f #t)
          (- (unbox rb) (unbox lb))))
      
      (define/private (get-view-size)
        (let ([admin (get-admin)])
          (if admin
              (let ([wb (box 0)]
                    [hb (box 0)])
                (send admin get-view #f #f wb hb)
                (values (unbox wb) (- (unbox hb) 2)))
              (values 10 10))))
      
      (super-new)))
  
  (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))]))))