(module pict mzscheme
  (require (lib "mrpict.ss" "texpict")
           (lib "utils.ss" "texpict")
           (lib "etc.ss")
           (lib "list.ss")
           (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "kw.ss")
           "reduction-semantics.ss"
           "struct.ss"
           "loc-wrapper.ss"
           "matcher.ss")
  
  (provide language->pict
           language->ps
           reduction-relation->pict
           reduction-relation->ps)

  ;; for the test suite
  (provide build-lines setup-lines
           make-spacer-token 
           make-string-token
           make-pict-token
           make-align-token
           loc-wrapper->tree
           pict-token?
           token-column
           token-span) 
  
  (define STIX? #f) ;; waiting for the STIX fonts
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;   reduction to pict
  ;;
  
  (define (reduction-relation->pict rr)
    (current-rule-picts->pict
     (map (rr-lws->trees (language-nts (reduction-relation-lang rr)))
          (reduction-relation-lws rr))))
  
  (define (reduction-relation->ps rr filename)
    (save-as-ps (λ () (reduction-relation->pict rr))
                filename))
  
  (define ((rr-lws->trees nts) rp)
    (let ([tp (λ (x)
                (lines->pict 
                 (setup-lines 
                  (build-lines nts (list (loc-wrapper->tree x))))))])
      (make-rule-pict (rule-pict-arrow rp)
                      (tp (rule-pict-lhs rp))
                      (tp (rule-pict-rhs rp))
                      (rule-pict-label rp)
                      (map tp (rule-pict-side-conditions rp))
                      (map tp (rule-pict-fresh-vars rp)))))
  
  (define (rule-picts->pict/horizontal rps)
    (let ([lhs-space (make-horiz-space (map rule-pict-lhs rps))]
          [rhs-space (make-horiz-space (map rule-pict-rhs rps))]
          [arrow-space 
           (inset (make-horiz-space (map arrow->pict (map rule-pict-arrow rps)))
                  2
                  0)])
      (apply
       vl-append
       (add-between
        (blank 0 4)
        (map (λ (rp)
               (htl-append 
                (inset (rule-pict-lhs rp) 
                       (- (pict-width lhs-space)
                          (pict-width (rule-pict-lhs rp)))
                       0 0 0)
                (let ([ap (arrow->pict (rule-pict-arrow rp))])
                  (inset ap
                         (- (pict-width ap)
                            (/ (pict-width arrow-space) 2))
                         0
                         (- (pict-width ap)
                            (/ (pict-width arrow-space) 2))
                         0))
                (inset (rule-pict-rhs rp) 
                       0 0
                       (- (pict-width rhs-space)
                          (pict-width (rule-pict-rhs rp)))
                       0)
                (rp->pict-label rp)))
             rps)))))
  
  (define (rule-picts->pict/vertical rps)
    (let* ([mk-top-line-spacer
            (λ (rp)
              (hbl-append (rule-pict-lhs rp)
                          (basic-text " " default-style)
                          (arrow->pict (rule-pict-arrow rp))
                          (basic-text " " default-style)
                          (rp->pict-label rp)))]
           [mk-bot-line-spacer
            (λ (rp)
              (hbl-append (rule-pict-rhs rp)
                          (basic-text " " default-style)
                          (rp->side-condition-pict rp)))]
           [multi-line-spacer
            (ghost
             (launder
              (ctl-superimpose 
               (apply ctl-superimpose (map mk-top-line-spacer rps))
               (apply ctl-superimpose (map mk-bot-line-spacer rps)))))]
           [spacer (dc void 
                       (pict-width multi-line-spacer)
                       (pict-descent multi-line-spacer) ;; probably could be zero ...
                       0
                       (pict-descent multi-line-spacer))])
      (apply
       vl-append
       (add-between
        (blank 0 4)
        (map (λ (rp)
               (vl-append
                (ltl-superimpose 
                 (hbl-append (rule-pict-lhs rp)
                             (basic-text " " default-style)
                             (arrow->pict (rule-pict-arrow rp)))
                 (rtl-superimpose 
                  spacer
                  (rp->pict-label rp)))
                (ltl-superimpose
                 (rtl-superimpose
                  spacer
                  (rp->side-condition-pict rp))
                 (rule-pict-rhs rp))))
             rps)))))
  
  (define (rp->side-condition-pict rp)
    (let* ([frsh 
            (if (null? (rule-pict-fresh-vars rp))
                null
                (list
                 (hbl-append
                  (apply 
                   hbl-append
                   (add-between
                    (basic-text ", " default-style)
                    (rule-pict-fresh-vars rp)))
                  (basic-text " fresh" default-style))))]
           [lst (add-between
                 (basic-text ", " default-style)
                 (append
                  (rule-pict-side-conditions rp)
                  frsh))])
      (if (null? lst)
          (blank)
          (htl-append
           (basic-text "(" default-style)
           (apply htl-append lst)
           (basic-text ")" default-style)))))
  
  (define (rp->pict-label rp)
    (if (rule-pict-label rp)
        (basic-text (format " [~a]" (rule-pict-label rp)) label-style)
        (blank)))
  
  (define (add-between i l)
    (cond
      [(null? l) l]
      [else 
       (cons (car l)
             (apply append 
                    (map (λ (x) (list i x)) (cdr l))))]))
  
  (define (make-horiz-space picts) (blank (pict-width (apply cc-superimpose picts)) 0))
  
  (define current-rule-picts->pict rule-picts->pict/vertical)
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  language to pict
  ;;
    
  (define (language->ps lang non-terminals filename)
    (save-as-ps (λ () (language->pict lang non-terminals))
                filename))
  
  (define (language->pict lang non-terminals)
    (let* ([all-non-terminals (hash-table-map (compiled-lang-ht lang) (λ (x y) x))]
           [non-terminals (or non-terminals all-non-terminals)])
      (make-grammar-pict (compiled-lang-pict-builder lang) 
                         non-terminals
                         all-non-terminals)))
 
  ;; lang-pict-builder : (-> pict) string -> void
  (define (save-as-ps mk-pict filename) 
    (let ([ps-dc (make-ps-dc filename)])
      (parameterize ([dc-for-text-size ps-dc])
        (send ps-dc start-doc "x")
        (send ps-dc start-page)
        (draw-pict (mk-pict) ps-dc 0 0)
        (send ps-dc end-page)
        (send ps-dc end-doc))))

  (define (make-ps-dc filename)
    (let ([ps-setup (make-object ps-setup%)])
      (send ps-setup copy-from (current-ps-setup))
      (send ps-setup set-file filename)
      (parameterize ([current-ps-setup ps-setup])
        (make-object post-script-dc% #f #f))))
  
  (define (make-grammar-pict raw-info nts all-nts)
    (let* ([info (filter (λ (x) (member (car x) nts))
                         raw-info)]
           [term-space 
            (launder
             (ghost
              (apply cc-superimpose (map (λ (x) (non-terminal (format "~a" (car x))))
                                         info))))])
      (apply vl-append
             (map (λ (line)
                    (htl-append 
                     (rc-superimpose term-space (non-terminal (format "~a" (car line))))
                     (lines->pict 
                      (setup-lines 
                       (build-lines
                        all-nts
                        (add-bars
                         (map loc-wrapper->tree (cdr line))))))))
                  info))))
  
  (define (make-::=) (basic-text " ::= " default-style))
  (define (make-bar) (basic-text " | " default-style))
  
  (define (add-bars lst)
    (cond
      [(null? lst) null]
      [else
       (cons
        (let ([fst (car lst)])
          (make-loc-wrapper
           (rc-superimpose (ghost (make-bar)) (make-::=))
           (loc-wrapper-line fst)
           (loc-wrapper-line-span fst)
           (loc-wrapper-column fst)
           0
           (loc-wrapper-column fst)))
        
        (let loop ([fst (car lst)]
                   [rst (cdr lst)])
          (cond
            [(null? rst) (list fst)]
            [else 
             (let* ([snd (car rst)]
                    [bar 
                     (cond
                       [(= (loc-wrapper-line snd)
                           (loc-wrapper-line fst))
                        (let* ([line (loc-wrapper-line snd)]
                               [line-span (loc-wrapper-line-span snd)]
                               [column (+ (loc-wrapper-column fst)
                                          (loc-wrapper-span fst))]
                               [span (- (loc-wrapper-column snd)
                                        (+ (loc-wrapper-column fst)
                                           (loc-wrapper-span fst)))]
                               [last-column (+ column span)])
                          (make-loc-wrapper (make-bar) line line-span column span last-column))]
                       [else
                        (make-loc-wrapper
                         (rc-superimpose (make-bar) (ghost (make-::=)))
                         (loc-wrapper-line snd)
                         (loc-wrapper-line-span snd)
                         (loc-wrapper-column snd)
                         0
                         (loc-wrapper-column snd))])])
               (list* fst
                      bar
                      (loop snd (cdr rst))))])))]))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  pattern processing
  ;;
  
  ;; token = string-token | spacer-token | pict-token | align-token
  
  (define-struct token (column span) (make-inspector))
  
  ;; string : string
  ;; style : valid third argument to mrpict.ss's `text' function
  (define-struct (string-token token) (string style) (make-inspector))
  
  ;; width : number
  ;; pict : pict
  (define-struct (pict-token token) (pict) (make-inspector))
  
  ;; spacer : number
  (define-struct (spacer-token token) () (make-inspector))
  
  ;; pict : pict
  ;; this token always appears at the beginning of a line and its width
  ;; is the x-coordinate of the pict inside itself (which must appear on
  ;; an earlier line)
  (define-struct align-token (pict) (make-inspector))
  
  (define (loc-wrapper->tree p)
    (p #:hole-pict hole-pict))
  
  (define (hole-pict a1 a2 line line-span col span last-column)
    (make-grouper 
     (list
      (make-loc-wrapper
       (blank)
       line
       0
       col
       (- (loc-wrapper-column a1) col)
       (loc-wrapper-column a1))
      a1 
      (make-loc-wrapper/space-between
       (basic-text "[" default-style)
       a1 a2)
      a2
      
      (cond
        [(and (= (loc-wrapper-line a2) line)
              (= (loc-wrapper-line-span a2) 0))
         (make-loc-wrapper
          (basic-text "]" default-style)
          (+ (loc-wrapper-line a2)
             (loc-wrapper-line-span a2))
          (- (+ line line-span)
             (+ (loc-wrapper-line a2)
                (loc-wrapper-line-span a2)))
          (+ (loc-wrapper-column a2)
             (loc-wrapper-span a2))
          (- (+ col span)
             (+ (loc-wrapper-column a2)
                (loc-wrapper-span a2)))
          (+ col span))]
        [else
         (make-loc-wrapper
          (basic-text "]" default-style)
          (+ (loc-wrapper-line a2)
             (loc-wrapper-line-span a2))
          0
          (loc-wrapper-last-column a2)
          0
          (loc-wrapper-last-column a2))]))))
  
  (define (make-loc-wrapper/space-between e before after)
    (cond
      [(= (loc-wrapper-line before) (loc-wrapper-line after))
       (let* ([line (+ (loc-wrapper-line before)
                       (loc-wrapper-line-span before))]
              [line-span
               (- (loc-wrapper-line after)
                  (+ (loc-wrapper-line before)
                     (loc-wrapper-line-span before)))]
              [column
               (+ (loc-wrapper-column before)
                  (loc-wrapper-span before))]
              [span
               (- (loc-wrapper-column after)
                  (+ (loc-wrapper-column before)
                     (loc-wrapper-span before)))]
              [last-column (+ column span)])
         (make-loc-wrapper e line line-span column span last-column))]
      [else
       (make-loc-wrapper
        e
        (loc-wrapper-line after)
        0
        (loc-wrapper-column after)
        0
        (loc-wrapper-column after))]))
  
  (define (build-lines all-nts lws)
    (define initial-column (loc-wrapper-column (car lws)))
    (define initial-line (loc-wrapper-line (car lws)))
    (define current-line (loc-wrapper-line (car lws)))
    (define current-column (loc-wrapper-column (car lws)))
    (define tokens '())
    (define lines '())
    (define (eject line col span atom raw-string?)
      (unless (= current-line line)
        ;; make new lines
        (for-each 
         (λ (x) 
           (set! lines (cons (reverse! tokens) lines))
           (set! tokens '()))
         (build-list (- line current-line) (λ (x) 'whatever)))
        
        (set! tokens (cons (make-spacer-token 0
                                              (- col initial-column))
                           tokens))
        
        (set! current-line line)
        (set! current-column col))
      (when (< current-column col)
        (let ([space-span (- col current-column)])
          (set! tokens (cons (make-string-token (- current-column initial-column)
                                                space-span
                                                (apply string (build-list space-span (λ (x) #\space)))
                                                default-style)
                             tokens))))
      (set! tokens (append 
                    (if raw-string?
                        (list
                         (make-string-token (- col initial-column) 
                                            span 
                                            atom
                                            default-style))
                        (reverse
                         (atom->tokens (- col initial-column) span atom all-nts)))
                    tokens))
      (set! current-column (+ col span)))
    
    (define (handle-loc-wrapped lw last-line last-column last-span)
      (cond
        [(loc-wrapper? lw)
         (handle-object (loc-wrapper-e lw)
                        (loc-wrapper-line lw)
                        (loc-wrapper-column lw)
                        (loc-wrapper-span lw))]
        [(pict? lw)
         (eject current-line current-column 0 lw #f)]
        [else
         (handle-object lw last-line last-column last-span)]))
    
    (define (handle-object obj line col span)
      (cond
        [(grouper? obj)
         (map (λ (x) (handle-loc-wrapped x line col span))
              (grouper-content obj))]
        [(null? obj)
         (eject line col span '() #f)]
        [(list? obj)
         (eject line col 1 "(" #t)
         (for-each (λ (x) (handle-loc-wrapped x line col span))
                   obj)
         (eject current-line 
                (if (= line current-line)
                    (+ col span -1) 
                    current-column)
                1 
                ")"
                #t)]
        [(pair? obj)
         ;; dotted list
         (eject line col 1 "(" #t)
         (let loop ([items obj])
           (cond
             [(pair? items) 
              (handle-loc-wrapped (car items) line col span)
              (loop (cdr items))]
             [else
              (eject current-line 
                     current-column
                     2
                     " ."
                     #t)
              (handle-loc-wrapped items line col span)]))
         (eject current-line 
                (if (= line current-line)
                    (+ col span -1) 
                    current-column)
                1
                ")"
                #t)]
        [(unq-pict? obj)
         (eject line col span 
                (handle-unq (unq-pict-arg obj))
                #f)]
        [else 
         (eject line col span obj #f)]))
    
    (define (handle-unq e)
      (side-condition->pict
       (let loop ([e e])
         (cond
           [(pair? e) (cons (loop (car e))
                            (loop (cdr e)))]
           [(term-pict? e)
            (lines->pict
             (setup-lines
              (build-lines all-nts
                           (list (term-pict-arg e)))))]
           [else e]))))
    
    (for-each (λ (lw) (handle-loc-wrapped lw 0 0 0))
              lws)
    (set! lines (cons (reverse! tokens) lines)) ;; handle last line ejection
    lines)
  
  ;; setup-lines : (listof (listof token)) -> (listof (listof token))
  ;; removes the spacer tokens from the beginning of lines, replacing them with align tokens
  ;; expects the lines to be in reverse order
  (define (setup-lines lines)
    (let loop ([lines lines])
      (cond
        [(null? lines) null]
        [else 
         (let ([line (car lines)]
               [rst (cdr lines)])
           (if (null? line)
               (cons line (loop (cdr lines)))
               (if (spacer-token? (car line))
                   (let* ([pict (blank)]
                          [rst (split-out (token-span (car line))
                                          pict
                                          rst)])
                     (cons (cons (make-align-token pict) (cdr line))
                           (loop rst)))
                   (cons line (loop (cdr lines))))))])))
  
  ;; split-out : number pict (listof (listof token)) -> (listof (listof token))
  (define (split-out col pict lines)
    (let ([new-token (make-pict-token col 0 pict)])
      (let loop ([lines lines])
        (cond
          [(null? lines)
           ;; this case can happen when the line in question is to the left of all other lines
           (error 'exchange-spacer "could not find matching line")]
          [else (let ([line (car lines)])
                  (if (null? line)
                      (cons line (loop (cdr lines)))
                      (let ([spacer (car line)])
                        (cond
                          [(not (spacer-token? spacer))
                           (cons (insert-new-token col new-token (token-column spacer) (car lines))
                                 (cdr lines))]
                          [(= (token-span spacer)
                              col)
                           (cons (list* spacer new-token (cdr line))
                                 (cdr lines))]
                          [(> (token-span spacer)
                              col)
                           (cons line (loop (cdr lines)))]
                          [(< (token-span spacer)
                              col)
                           (cons (insert-new-token col new-token (token-column spacer) (car lines))
                                 (cdr lines))]))))]))))
                  
  (define (insert-new-token column-to-insert new-token init-width line)
    (let loop ([line line])
      (cond
        [(null? line)
         (error 'insert-new-token "not yet finished (need to go to a previous line)")]
        [else
         (let ([tok (car line)])
           (unless (token? tok)
             (error 'insert-new-token "ack ~s" tok))
           (cond
             [(<= column-to-insert (token-column tok))
              (cons new-token line)]
             [(< (token-column tok)
                 column-to-insert
                 (+ (token-column tok) (token-span tok)))
              (append (split-token (- column-to-insert (token-column tok)) tok new-token)
                      (cdr line))]
             [(= column-to-insert (+ (token-column tok) (token-span tok)))
              (list* (car line) new-token (cdr line))]
             [else 
              (cons (car line)
                    (loop (cdr line)))]))])))
               
  (define (split-token offset tok new-token)
    (cond
      [(string-token? tok)
       (list (make-string-token (token-column tok)
                                offset
                                (substring (string-token-string tok)
                                           0 offset)
                                (string-token-style tok))
             new-token
             (make-string-token (+ (token-column tok) offset)
                                (- (token-span tok) offset)
                                (substring (string-token-string tok)
                                           offset 
                                           (string-length (string-token-string tok)))
                                (string-token-style tok)))]
      [(pict-token? tok)
       (list new-token)]))
  
  ;; lines->pict : (listof (listof token)) -> pict
  ;; expects the lines to be in order from bottom to top
  (define (lines->pict lines)
    (let loop ([lines lines])
      (cond
        [(null? lines) (blank)]
        [(null? (cdr lines))
         (handle-single-line (car lines) (blank))]
        [else
         (let ([rst (loop (cdr lines))])
           (vl-append rst (handle-single-line (car lines) rst)))])))
  
  (define (handle-single-line line rst)
    (cond
      [(null? line) 
       (let ([h (pict-height (token->pict (make-string-token 0 0 "x" default-style)))])
         (blank 0 h))]
      [else
       (if (align-token? (car line))
           (let-values ([(x y) (lt-find rst (align-token-pict (car line)))])
             (apply hbl-append 
                    (blank x 0)
                    (map token->pict (cdr line))))
           (apply hbl-append (map token->pict line)))]))
  
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;; font specs
  ;;
  
  (define (token->pict tok)
    (cond
      [(string-token? tok)
       (basic-text (string-token-string tok) (string-token-style tok))]
      [(pict-token? tok) (pict-token-pict tok)]
      [else (error 'token->pict "~s" tok)]))
  
  (define (atom->tokens col span atom all-nts)
    (cond
      [(pict? atom)
       (list (make-pict-token col span atom))]
      [(and (symbol? atom)
            (regexp-match #rx"^([^_]*)_(.*)$" (format "~a" atom)))
       =>
       (λ (m)
         (let* ([first-part (cadr m)]
                [second-part (caddr m)]
                [first-span (- span (string-length first-part))])
           (list 
            (make-string-token col
                               first-span
                               first-part
                               non-terminal-style)
            (make-string-token (+ col first-span) 
                               (- span first-span)
                               second-part
                               non-terminal-subscript-style))))]
      [(memq atom all-nts)
       (list (make-string-token col span (format "~s" atom) non-terminal-style))]
      [(and STIX? (eq? atom '...))
       (list (make-pict-token col span (basic-text "\u22ef" default-style)))]
      [else
       (list (make-string-token col span (format "~s" atom) default-style))]))
  
  (define (basic-text str style) (text str style default-font-size))
  (define (non-terminal str) (text str non-terminal-style default-font-size))
  (define non-terminal-style '(italic . roman))
  (define non-terminal-subscript-style `(subscript . ,non-terminal-style))
  (define default-style 'roman)
  (define label-style 'swiss)
  (define default-font-size 14)
  
  (define long-arrow-pict
    (let ([ans #f])
      (λ ()
        (or ans
            (begin
              (set! ans (mk-arrow-pict))
              ans)))))
  
  (define (mk-arrow-pict)
    (let-values ([(w h d a) (send (dc-for-text-size) 
                                  get-text-extent
                                  "xxx"
                                  (send the-font-list
                                        find-or-create-font
                                        default-font-size
                                        default-style
                                        'normal
                                        'normal))])
      (let* ([height-space 5/12]
             [points
              (list (make-object point% 
                      w
                      (* h 1/2))
                    (make-object point%
                      (* w 4/5)
                      (* h (+ 1/2 (* height-space 1/2))))
                    (make-object point%
                      (* w 4/5)
                      (* h (+ 1/2 (* height-space -1/2)))))])
        (dc
         (λ (dc dx dy)
           (let ([pen (send dc get-pen)]
                 [brush (send dc get-brush)])
             (send dc set-pen (send pen get-color) 1.2 'solid)
             (send dc set-brush (send pen get-color) 'solid)
             (send dc draw-line 
                   dx 
                   (+ dy (/ h 2))
                   (+ dx w)
                   (+ dy (/ h 2)))
             (send dc draw-polygon points dx dy)
             (send dc set-brush brush)
             (send dc set-pen pen)))
         w h (- h d) a))))
  
  (define (arrow->pict arr)
    (if (and (not STIX?) (eq? arr '-->))
        (long-arrow-pict)
        (basic-text
         (case arr
           ;; we're waiting for the STIX fonts before using this guy. (case above blocks it out)
           [(-->) "\u27f5"]
           
           [(==>) "\u27f9"]
           [(->) "\u2192"]
           [(=>) "\u21D2"]
           [(..>) "\u21E2"]
           [(>->) "\u21a3"]
           [(~>) "\u21DD"]
           [(:->) "\u21a6"]
           [(c->) "\u21aa"]
           [(-->>) "\u21a0"]
           [(>--) "\u291a"]
           [(--<) "\u2919"]
           [(>>--) "\u291c"]
           [(--<<) "\u291b"]
           [else (error 'arrow->pict "unknown arrow ~s" arr)])
         default-style)))
  

  (require (lib "match.ss"))
  (define (side-condition->pict sc)
    (let loop ([sc sc])
      (match sc
        [(? pict? sc) sc]
        [`(or ,s1 ,s2)
          (hbl-append
           (loop s1)
           (basic-text " or " 'roman)
           (loop s2))]
        [`(or ,s1 ,s2 ...)
          (apply hbl-append
                 (add-between (basic-text ", or " 'roman)
                              (map loop (cons s1 s2))))]
        [else 
         (fprintf (current-error-port) "unknown Scheme code: ~s\n" sc)
         (pink-background (basic-text (format "~s" sc) 'roman))])))
  
  (define (pink-background p)
    (refocus
     (cc-superimpose 
      (colorize (filled-rectangle (pict-width p)
                                  (pict-height p))
                "pink")
      p)
     p))
  
  )