#lang scheme/gui

(provide/contract [dot-positioning (-> (is-a?/c pasteboard%) string? boolean? void?)]
                  [find-dot (-> (or/c path? false/c))])
      
(require scheme/system)

(provide dot-label neato-label neato-hier-label neato-ipsep-label)
(define dot-label "dot")
(define neato-label "neato")
(define neato-hier-label "neato – hier")
(define neato-ipsep-label "neato – ipsep")

;; these paths are explicitly checked (when find-executable-path
;; fails) because starting drscheme from the finder (or the doc) 
;; under mac os x generally does not get the path right.
(define dot-paths 
  '("/usr/bin"
    "/bin"
    "/usr/local/bin"
    "/opt/local/bin/"))

(define (find-dot [neato? #f])
  (cond
    [(and (find-executable-path "dot")
          (find-executable-path "neato"))
     (if neato?
         (find-executable-path "neato")
         (find-executable-path "dot"))]
    [else
     (ormap (λ (x) (and (file-exists? (build-path x "dot"))
                        (file-exists? (build-path x "neato"))
                        (build-path x (if neato? "neato" "dot"))))
            dot-paths)]))

(define (dot-positioning pb option overlap?)
  (let ([info (snip-info pb)])
    (let-values ([(cb positions max-y) (run-dot info option overlap?)])
      (send pb begin-edit-sequence)
      (send pb set-dot-callback
            (λ (pb dc left top right bottom dx dy)
              (let ([sm (send dc get-smoothing)]
                    [pen (send dc get-pen)]
                    [brush (send dc get-brush)])
                (send dc set-smoothing 'aligned)
                (cb dc left top right bottom dx dy)
                (send dc set-pen pen)
                (send dc set-brush brush)
                (send dc set-smoothing sm))))
      (for-each
       (λ (position-line)
         (let* ([id (list-ref position-line 0)]
                [x (list-ref position-line 1)]
                [y (list-ref position-line 2)]
                [snip (car (hash-ref info id))])
           (send pb move-to snip x (- max-y y))))
       positions)
      (send pb invalidate-bitmap-cache)
      (send pb end-edit-sequence))))

;; with-snips : pasteboard% -> hash-table[snip -> (list i number[width] number[height] (listof number))]
(define (snip-info pb)
  (let ([num-ht (make-hasheq)]
        [children-ht (make-hasheq)])
    (let loop ([snip (send pb find-first-snip)]
               [i 0])
      (when snip
        (hash-set! num-ht snip i)
        (loop (send snip next) (+ i 1))))
    (let ([lb (box 0)]
          [tb (box 0)]
          [rb (box 0)]
          [bb (box 0)])
      (hash-for-each
       num-ht
       (λ (snip num)
         (send pb get-snip-location snip lb tb #f)
         (send pb get-snip-location snip rb bb #t)
         (hash-set! children-ht
                    (hash-ref num-ht snip)
                    (list 
                     snip
                     (- (unbox rb) (unbox lb))
                     (- (unbox bb) (unbox tb))
                     (map (λ (c) (hash-ref num-ht c))
                          (send snip get-children))))))
      children-ht)))

;; run-dot : hash-table[snip -> (list i (listof number))] string -> void
(define (run-dot ht option overlap?)
  (define info (sort (hash-map ht (λ (k v) (cons k v)))
                     (λ (x y) (< (car x) (car y)))))
  (let-values ([(in1 out1) (make-pipe)]
               [(in2 out2) (make-pipe)])
    ;;(graph->dot info option overlap?)
    (thread
     (λ ()
       (parameterize ([current-output-port out1])
         (graph->dot info option overlap?))
       (close-output-port out1)))
    (thread
     (λ ()
       (parameterize ([current-input-port in1]
                      [current-output-port out2])
         (system (format "~a -Tplain" (path->string (find-dot (regexp-match #rx"neato" option))))))
       (close-output-port out2)
       (close-input-port in1)))
    (parse-plain in2)))


;; graph->dot (listof (list snip number (listof number)) -> void
;; prints out the dot input file based on `g'
(define (graph->dot g option overlap?)
  (printf "digraph {\n")
  (cond
    [(equal? option dot-label)
     (printf "  rankdir=\"~a\"\n" (if overlap? "LR" "TB"))]
    [(equal? option neato-label)
     (printf "  overlap=\"~a\"\n" (if overlap? "true" "false"))
     (printf "  splines=\"true\"\n")]
    [(equal? option neato-hier-label)
     (printf "  overlap=\"~a\"\n" (if overlap? "true" "false"))
     (printf "  mode=\"hier\"\n")
     (printf "  splines=\"true\"\n")]
    [(equal? option neato-ipsep-label)
     (printf "  mode=\"ipsep\"\n")
     (printf "  splines=\"true\"\n")
     (printf "  overlap=\"~a\"\n" (if overlap? "true" "ipsep"))])
  (for-each
   (λ (line)
     (let* ([snip (list-ref line 1)]
            [id (list-ref line 0)]
            [w (list-ref line 2)]
            [h (list-ref line 3)]
            [children (list-ref line 4)])
       (printf "  ~a [width=~a height=~a shape=box label=\"\"]\n" 
               (num->id id) 
               (format-number (pixels->inches w))
               (format-number (pixels->inches h)))
       (for-each
        (λ (child)
          (printf "  ~a -> ~a\n" (num->id id) (num->id child)))
        children)))
   g)
  (printf "}\n"))

(define (num->id n) (format "s~a" n))
(define (id->num s) (string->number (substring s 1 (string-length s))))

(define (format-number n)
  (let ([candidate (number->string (exact->inexact n))])
    (cond
      [(regexp-match #rx"^([0-9]*)\\.([0-9]*)$" candidate)
       =>
       (λ (m)
         (let ([prefix (list-ref m 1)]
               [suffix (list-ref m 2)])
           (if (< (string-length suffix) 5)
               candidate
               (string-append prefix "." (substring suffix 0 4)))))]
      [else
       candidate])))
  
(define (parse-plain port)
  
  (define max-y 0)
  
  (define positions '())
  
  (define (main)
    (let ([graph-line (read-line port)])
      (let loop ()
        (let ([line (read-line port)])
          (cond
            [(regexp-match #rx"^node" line)
             (join (parse-node line)
                   (loop))]
            [(regexp-match #rx"^edge" line)
             (join (parse-edge line)
                   (loop))]
            [(regexp-match #rx"stop" line)
             void]
            [else
             (error 'parse-file "didn't recognize line:\n  ~s" line)])))))
  
  (define (join p1 p2)
    (cond
      [(eq? p1 void) p2]
      [(eq? p2 void) p1]
      [else 
       (λ (dc left top right bottom dx dy) 
         (p1 dc left top right bottom dx dy)
         (p2 dc left top right bottom dx dy))]))

  (define (parse-node line) 
    (let*-values ([(node line) (chomp line)]
                  [(id line) (chomp line)]
                  [(raw-x line) (chomp line)]
                  [(raw-y line) (chomp line)]
                  [(raw-w line) (chomp line)]
                  [(raw-h line) (chomp line)]
                  [(label line) (chomp line)]
                  [(style line) (chomp line)]
                  [(raw-shape line) (chomp line)]
                  [(color line) (chomp line)]
                  [(fillcolor line) (chomp line)])
      
      (define x (inches->pixels (string->number raw-x)))
      (define y (inches->pixels (string->number raw-y)))
      (define w (inches->pixels (string->number raw-w)))
      (define h (inches->pixels (string->number raw-h)))
      (define shape (string->symbol raw-shape))
      
      (set! positions (cons (list (id->num id) 
                                  (- x (/ w 2)) 
                                  (+ y (/ h 2)))
                            positions))
      
      (set! max-y (max (+ y h) max-y))
      void))
        
  (define (parse-edge line)
    (define (give-up)
      (error 'redex "could not parse edge line:\n  ~s\n" line))
    (let* ([m (regexp-match #rx"edge ([^ ]+) ([^ ]+) ([0-9]+) (.*)$" line)]
           [_ (unless m (give-up))]
           [from (list-ref m 1)]
           [to (list-ref m 2)]
           [point-count (string->number (list-ref m 3))]
           [rest (list-ref m 4)]
           [points 
            (let loop ([pts point-count]
                       [rest rest])
              (if (zero? pts) 
                  '()
                  (let* ([m (regexp-match #rx"^([-0-9.]+) ([-0-9.]+) (.*)$" rest)]
                         [_ (unless m (give-up))]
                         [x (string->number (list-ref m 1))]
                         [y (string->number (list-ref m 2))])
                    (set! max-y (max y max-y))
                    (cons (list x y)
                          (loop (- pts 1)
                                (list-ref m 3))))))])
      (λ (dc left top right bottom dx dy)
        (draw-edges dc dx dy points))))
  
  ;; chomp : string -> (values string (union #f string))
  ;; returns the first word at the beginning of the string and the remainder of the string (or #f is there is no more)
  (define (chomp s)
    (let ([s (regexp-replace #rx"^ *" s "")])
      (cond
        [(equal? s "")
         (values "" #f)]
        [else
         (case (string-ref s 0)
           [(#\") (let ([m (regexp-match #rx"^\"([^\"]*)\"(.*)$" s)])
                    (values (list-ref m 1)
                            (list-ref m 2)))]
           [else
            (cond
              [(regexp-match #rx"^([^ ]*) (.*)$" s)
               =>
               (λ (m)
                 (values (list-ref m 1)
                         (list-ref m 2)))]
              [(regexp-match #rx"^([^ ]*)$" s)
               =>
               (λ (m)
                 (values (list-ref m 1)
                         #f))]
              [else
               (error 'chomp "~s" s)])])])))
            
  (define (draw-edges dc dx dy raw-points)
    (let ([points (map (λ (x) (list (inches->pixels (car x))
                                    (inches->pixels (list-ref x 1))))
                       raw-points)])
      (send dc set-pen "blue" 1 'solid)
      (send dc set-brush "black" 'transparent)
      (let ([path (new dc-path%)])
        (send path move-to 
              (car (car points))
              (- max-y (cadr (car points))))
        (let loop ([points (cdr points)])
          (cond
            [(null? points) (void)]
            [else (let ([p1 (list-ref points 0)]
                        [p2 (list-ref points 1)]
                        [p3 (list-ref points 2)])
                    (send path curve-to 
                          (list-ref p1 0) (- max-y (list-ref p1 1))
                          (list-ref p2 0) (- max-y (list-ref p2 1))
                          (list-ref p3 0) (- max-y (list-ref p3 1)))
                    (loop (cdddr points)))]))
        (send dc draw-path path dx dy))))
  
  (values (main)
          positions
          max-y))

(define (draw-plain port)
  
  (define draw (parse-plain port))
  
  (define f (new frame% [label ""] [width 400] [height 400]))
  (define c (new canvas% [parent f]
                 [paint-callback
                  (λ (c dc)
                    (draw dc))]))
  (send (send c get-dc) set-smoothing 'aligned)
  (send f show #t))

(define (pixels->inches x) (/ x 72))
(define (inches->pixels x) (* x 72))