#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

(provide msd->pict
         render)

(require (only-in racket/list partition last))
(require racket/match)
(require racket/math)
(require racket/set)
(require (only-in racket/string string-split))

(require preserves)

(require pict)
(require pict/color)
(require file/convertible)

(require "types.rkt")

;;---------------------------------------------------------------------------

(define N (* pi 1/2))
(define S (* pi -1/2))
(define E (* pi 0))
(define W (* pi 1))

(define NE (* pi 1/4))
(define SE (* pi -1/4))
(define NW (* pi 3/4))
(define SW (* pi -3/4))

(define ENE (* pi 1/8))
(define ESE (* pi -1/8))
(define WNW (* pi 7/8))
(define WSW (* pi -7/8))

;; A SwimlaneState is
;; - a (labelled-cell String ColorString SwimlaneState), representing
;;   a fresh annotation on a possibly-new swimlane
;; - 'inactive, an occupied but inactive lane
;; - 'active, an occupied and active lane
;; - #f, an unoccupied lane

(struct labelled-cell (label color underlying-state) #:prefab)

(define (hash-set-or-remove h k v)
  (if v
      (hash-set h k v)
      (hash-remove h k)))

(define (reset-label v)
  (match v
    [(labelled-cell _ _ underlying-state) underlying-state]
    [_ v]))

(define (reset-statemap statemap)
  (for/hash [((k v) (in-hash statemap))]
    (values k (reset-label v))))

(define (transpose xs)
  (apply map list xs))

(define (FR color w h)
  (filled-rectangle #:color color #:draw-border? #f w h))

(define (should-label-row? row-number max-lane current-row)
  (and (not (negative? row-number))
       (for/or [(lane (+ max-lane 1))]
         (labelled-cell? (hash-ref current-row lane #f)))))

(define (msd->pict m #:config [config (render-config)])
  (match-define (msd max-lane all-events) m)
  (define-values (connections events) (partition connection? all-events))

  (define-values (_row-count statemaps)
    (for/fold [(previous-row 0) (table (hash))]
              [(event (in-list events))]
      (define-values (pos new-state)
        (match event
          [(begin-swimlane pos)
           (values pos 'inactive)]
          [(activate-swimlane pos)
           (values pos 'active)]
          [(deactivate-swimlane pos)
           (values pos 'inactive)]
          [(end-swimlane pos)
           (values pos #f)]
          [(annotate-swimlane pos color annotation)
           (values pos (list color annotation))]))

      (match-define (diagram-position lane row) pos)

      (define old-statemap
        (hash-ref table row (lambda () (reset-statemap (hash-ref table previous-row hash)))))

      (define new-statemap
        (hash-set-or-remove old-statemap
                            lane
                            (match new-state
                              [(list color annotation)
                               (labelled-cell annotation color (hash-ref old-statemap lane 'inactive))]
                              [_ new-state])))

      (values row (hash-set-or-remove table row (if (hash-empty? new-statemap) #f new-statemap)))))

  (define (fill-out height p)
    (ct-superimpose (blank (render-config-width config) height)
                    (if p
                        (inset p (* -1/2 (pict-width p)) 0)
                        (blank 0))))

  (define (inactive height)
    (FR "gray" (/ (render-config-active-width config) 2) height))

  (define (render-underlay max-lane prev-row current-row next-row height)
    (for/list [(lane (+ max-lane 1))]
      (define prev-state (hash-ref prev-row lane #f))
      (define next-state (hash-ref next-row lane #f))
      (fill-out height
                (match (match (hash-ref current-row lane #f)
                         [(labelled-cell s _ u) u]
                         [u u])
                  ['inactive (inactive height)]
                  ['active
                   (define (trunk height)
                     (hb-append 0
                                (FR "black" 1 height)
                                (FR (render-config-activation-color config) (- (render-config-active-width config) 2) height)
                                (FR "black" 1 height)))
                   (define bar (FR "black" (render-config-active-width config) 1))
                   (match* (prev-state next-state)
                     [('active 'active) (trunk height)]
                     [('active _) (vl-append 0 (trunk (- height 1)) bar)]
                     [(_ 'active) (vl-append 0 bar (trunk (- height 1)))]
                     [(_ _) (vl-append 0 bar (trunk (- height 2)) bar)])]
                  [#f (blank 0)]))))

  (define (render-overlay max-lane current-row)
    (for/list [(lane (+ max-lane 1))]
      (fill-out (render-config-height config)
                (match (hash-ref current-row lane #f)
                  [(labelled-cell s color u)
                   (define para (apply vl-append 0
                                       (map (lambda (s)
                                              (define limit 200)
                                              (text (if (> (string-length s) limit)
                                                        (string-append (substring s 0 limit) "...")
                                                        s)
                                                    'modern))
                                            (string-split s "\n"))))
                   (vc-append
                    (disk 4)
                    (frame
                     (cc-superimpose
                      (FR color (+ (pict-width para) 8) (+ (pict-height para) 8))
                      para)))]
                  [_ #f]))))

  (define rows (sort (hash->list statemaps) < #:key car))

  (define dummy-initial-row (cons (- (car (car rows)) 1) (hash)))
  (define dummy-final-row (match (last rows)
                            [(cons final-row final-statemap)
                             (cons (+ final-row 1) (reset-statemap final-statemap))]))
  (define row-triples
    (map (lambda (a b c)
           (list (car b)
                 (reset-statemap (cdr a))
                 (cdr b)
                 (reset-statemap (cdr c))))
         (cons dummy-initial-row rows)
         (append rows (list dummy-final-row))
         (append (cdr rows) (list dummy-final-row dummy-final-row))))

  (define over-and-unders
    (map (match-lambda
           [(list row-number prev-row current-row next-row)
            (define overlay (render-overlay max-lane current-row))
            (define height (+ (render-config-gap config) (apply max (map pict-height overlay))))
            (define underlay (render-underlay max-lane prev-row current-row next-row height))
            (list row-number
                  underlay
                  overlay
                  (should-label-row? row-number max-lane current-row))])
         row-triples))

  (define overlay-index (for/hash [(entry over-and-unders)]
                          (values (car entry) (caddr entry))))

  (define base-pict
    (apply vl-append 0
           (map (lambda (over-and-under)
                  (hc-append (ct-superimpose (apply hb-append 4 (cadr over-and-under))
                                             (apply hb-append 4 (caddr over-and-under)))
                             (if (and (render-config-number-steps? config) (cadddr over-and-under))
                                 (let ((L (cc-superimpose
                                           (circle 30)
                                           (text (number->string (car over-and-under))))))
                                   (hc-append (blank (render-config-number-gap config) 0)
                                              (inset L
                                                     (- (pict-width L))
                                                     (- (pict-height L)))))
                                 (blank 0))))
                over-and-unders)))

  (define (overlay-pict lane row)
    (define picts (hash-ref overlay-index row '()))
    (and (< lane (length picts)) (list-ref picts lane)))

  (define (find-overlay lane row)
    (or (for/or [(r (in-naturals row))] (overlay-pict lane r))
        (for/or [(r (in-range (- row 1) -1 -1))] (overlay-pict lane r))))

  (define unscaled-pict
    (for/fold [(base-pict base-pict)]
              [(c connections)]
      (match-define (connection bidirectional?
                                (diagram-position from-lane from-row)
                                (diagram-position to-lane to-row))
        c)
      (define from-pict (find-overlay from-lane from-row))
      (define to-pict (find-overlay to-lane to-row))
      (if (and from-pict to-pict)
          (if bidirectional?
              (pin-arrows-line 10 base-pict
                               from-pict
                               (if (>= to-lane from-lane) rc-find lc-find)
                               to-pict
                               (if (>= to-lane from-lane) lc-find rc-find)
                               #:start-angle (if (>= to-lane from-lane) E W)
                               #:start-pull 1/10
                               #:end-angle (if (<= to-lane from-lane) W E)
                               #:end-pull 1/10)
              (pin-arrow-line 10 base-pict
                              from-pict
                              cb-find
                              to-pict
                              ct-find
                              #:start-angle (if (>= to-lane from-lane) SE SW)
                              #:start-pull 1/10
                              #:end-angle (if (<= to-lane from-lane) SW SE)
                              #:end-pull 1/10))
          base-pict)))

  (scale unscaled-pict (render-config-scale config)))

(define (render p #:target target)
  (define (final-border) 1)
  (define final-pict (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
                                            (+ (pict-height p) (* 2 (final-border))))
                                     (panorama p)))
  (case target
    [(screen)
     (local-require racket/gui/base)
     (show-pict final-pict 800 600)
     (void)]
    [(png)
     (display (convert final-pict 'png-bytes))]
    [(png@2x)
     (display (convert final-pict 'png@2x-bytes))]
    [(svg)
     (display (convert final-pict 'svg-bytes))]
    [(eps)
     (display (convert final-pict 'eps-bytes))]
    [(pdf)
     (display (convert final-pict 'pdf-bytes))]))