#lang racket/base

(provide ide-dataspace
         install-ide-dataspace!)

(require racket/async-channel)
(require (only-in racket/list flatten))
(require racket/match)
(require (only-in racket/math pi sqr))
(require racket/set)
(require 2htdp/image)

(require (only-in syndicate seal process-name process-behavior process))
(require (only-in syndicate/dataspace dataspace?))
(require (only-in syndicate/relay relay))
(require syndicate/actor)
(require (only-in syndicate/lang current-ground-dataspace))
(require syndicate/patch)
(require syndicate/protocol/standard-relay)
(require syndicate/ground)
(require syndicate/trace)
(require syndicate/store)
(require syndicate-gl/2d)

(require "hsv.rkt")

(struct view-position (pid pos) #:prefab) ;; assertion
(struct influence (subject object) #:prefab) ;; message

;; A SpringType is one of
;; - tension - only pulls the ends together when stretched
;; - compression - only pushes the ends apart when compressed
;; - both - both tension and compression

(struct spring (type subject object strength length) #:prefab) ;; assertion
(struct push-view (pid delta) #:prefab) ;; message

(define (random-in-range lo hi)
  (+ lo (* (random) (- hi lo))))

(define (tooltip touching? x y w h label-strings0)
  (define label-strings (flatten label-strings0))
  (define label-text (apply above (map (lambda (s) (text s 22 "black")) label-strings)))
  (define label (overlay label-text (empty-scene (+ (image-width label-text) 10)
                                                 (+ (image-height label-text) 10))))
  (define (x-pos window-width)
    (define left (- (x) (image-width label) 10))
    (define right (+ (x) w 10))
    (cond
      [(not (negative? left)) left]
      [(<= (+ right (image-width label)) window-width) right]
      [else (+ (x) (* 1/2 w) (* -1/2 (image-width label)))]))
  (react (define/query-value window-width 0 (inbound (window $w _)) w)
         (assert #:when (touching?)
                 (outbound (simple-sprite -10
                                          (x-pos (window-width))
                                          (+ (y) (* 1/2 h) (- (* 1/2 (image-height label))))
                                          (image-width label)
                                          (image-height label)
                                          label)))))

(define (actor-view name parent-pid pid is-dataspace?)
  (spawn #:name (list 'actor-view name pid)

         (field [pos #f])
         (define/query-value win #f (inbound (window $w $h)) (window w h)
           #:on-add (when (not (pos)) (pos (make-rectangular (random-in-range 0 w)
                                                             (random-in-range 0 h)))))

         (define color (color-by-hash pid))
         (define costume (circle (if is-dataspace? 40 20) "solid" color))
         (define extent (make-rectangular (image-width costume) (image-height costume)))

         (define (x) (real-part (pos)))
         (define (y) (imag-part (pos)))

         (define/query-value touching? #f (inbound (touching pid)) #t)
         (on-start (tooltip touching? x y (real-part extent) (imag-part extent)
                            (list (format "~a" name)
                                  (format "~a" pid))))

         (assert #:when (pos) (view-position pid (+ (pos) (* 1/2 extent))))
         (assert #:when (pos)
                 (outbound (simple-sprite #:touchable-id pid
                                          #:touchable-predicate in-unit-circle?
                                          0
                                          (x)
                                          (y)
                                          (real-part extent)
                                          (imag-part extent)
                                          costume)))

         (on (message (push-view pid $delta))
             (when (pos)
               (pos (+ (pos) delta))))

         (on (message (trace-notification pid _ 'action _))
             (log-info "~v acting" pid)
             (void))

         (on (message (influence pid _))
             (log-info "~v influencing" pid)
             (void))

         (on (message (influence _ pid))
             (log-info "~v influenced" pid)
             (void))

         (stop-when (message (trace-notification _ pid 'exit _)))))

(define 1x1-white-rectangle (rectangle 1 1 "solid" "white"))
(define (compute-link-line start-pos end-pos width)
  (define delta (- end-pos start-pos))
  (define heading (angle delta))
  (define displacement (make-polar 10 (- heading (* pi 1/2))))
  (outbound
   (simple-sprite 1
                  #:rotation (* -180 (/ heading pi))
                  (real-part (+ start-pos displacement))
                  (imag-part (+ start-pos displacement))
                  (magnitude delta)
                  width
                  1x1-white-rectangle)))

(define (spawn-influence-view-factory)
  (spawn #:name 'influence-view-factory
         (field [pairs (set)])
         (on (message (influence $subject $object))
             (define entry (cons subject object))
             (when (not (set-member? (pairs) entry))
               (pairs (set-add (pairs) entry))
               (react
                (stop-when (retracted (view-position subject _)) (pairs (set-remove (pairs) entry)))
                (stop-when (retracted (view-position object _)) (pairs (set-remove (pairs) entry))))
               (spawn #:name (list 'influence-view entry)
                      (field [strength 1] [line-width 0])
                      (define/query-value subject-pos #f (view-position subject $p) p)
                      (define/query-value object-pos #f (view-position object $p) p)
                      (stop-when (retracted (view-position subject _)))
                      (stop-when (retracted (view-position object _)))
                      (assert #:when (and (subject-pos) (object-pos) (>= (strength) 0.1))
                              (compute-link-line (subject-pos) (object-pos) (line-width)))
                      (assert #:when (>= (strength) 0.1)
                              (spring 'tension subject object 1 (+ 50 (/ 100 (strength)))))
                      (begin/dataflow
                        (define new-width (min 10 (floor (strength))))
                        (when (not (= new-width (line-width))) (line-width new-width)))
                      (on (message (inbound (frame-event $counter _ _ $target-frame-rate)))
                          (define update-every (inexact->exact (floor (/ target-frame-rate 3))))
                          (when (zero? (modulo counter update-every))
                            (strength (/ (strength) (expt 2 (* update-every (/ target-frame-rate)))))))
                      (on (message (influence subject object))
                          (strength (+ (strength) 1))))))))

(define (spawn-layout-engine)
  (spawn #:name 'layout-engine
         (define/query-value win #f (inbound (window $w $h)) (window w h))
         (define/query-hash positions (view-position $pid $pos) pid pos)
         (define/query-set springs ($ s (spring _ _ _ _ _)) s)
         (on #:when (win) (message (inbound (frame-event _ _ _ _)))
             (define midpoint (/ (make-rectangular (window-width (win)) (window-height (win))) 2))
             (for [((this-pid pos) (in-hash (positions)))]
               (send! (push-view this-pid
                                 (* 1/10
                                    (+ (- midpoint pos)
                                       (for/sum [((other-pid other-pos) (in-hash (positions)))
                                                 #:when (not (equal? other-pid this-pid))]
                                         (define delta (- pos other-pos))
                                         (when (< (magnitude delta) 10)
                                           (set! delta (make-polar 10 (random-in-range (- pi) pi))))
                                         (make-polar (/ 1000000 (sqr (magnitude delta)))
                                                     (angle delta)))
                                       (for/sum [(s (in-set (springs)))]
                                         (define other-pid (match s
                                                             [(spring _ p (== this-pid) _ _) p]
                                                             [(spring _ (== this-pid) p _ _) p]
                                                             [_ #f]))
                                         (or (and other-pid
                                                  (not (equal? this-pid other-pid))
                                                  (let ((other-pos (hash-ref (positions) other-pid #f)))
                                                    (and other-pos
                                                         (let ()
                                                           (define heading (angle (- other-pos pos)))
                                                           (define current-length (magnitude (- other-pos pos)))
                                                           (define ideal-length (spring-length s))
                                                           (define force (* (spring-strength s)
                                                                            (- current-length ideal-length)))
                                                           (make-polar ((case (spring-type s)
                                                                          [(both) (lambda (z v) v)]
                                                                          [(tension) max]
                                                                          [(compression) min]) 0 force)
                                                                       heading)))))
                                             0))))))))
         ))

(define (process-is-dataspace? p)
  (match p
    [(process _name _beh (? dataspace? _)) #t]
    [(process _name _beh (relay _ _ _ _ _ (process _inner-name _inner-beh (? dataspace? _)))) #t]
    [_ #f]))

(define ((ide-dataspace #:exit? [exit? #t]) . boot-actions)
  (define from-user-thread-ch (make-async-channel))

  (define user-thread
    (thread (lambda ()
              (with-store ((current-trace-procedures
                            (cons (lambda (n) (async-channel-put from-user-thread-ch n))
                                  (current-trace-procedures))))
                (run-ground boot-actions)))))

  (signal-background-activity! #t)
  (with-store ((current-trace-procedures '()))
    ((2d-dataspace #:label "Syndicate IDE" #:exit? exit?)

     (spawn #:name 'user-thread-death-monitor
            (field [user-thread-running? #t])
            (assert #:when (user-thread-running?) 'user-thread-running)
            (on (message (inbound (? frame-event? _)))
                (when (thread-dead? user-thread) (user-thread-running? #f))))

     ;; Ground dataspace
     (actor-view 'ground #f '() #t)

     (spawn #:name 'notification-relay
            (on (message (inbound (? frame-event? _)))
                (let loop ()
                  (define n (async-channel-try-get from-user-thread-ch))
                  (match n
                    [#f
                     (void)]
                    [(trace-notification _ new-pid 'spawn (list parent-pid p))
                     (actor-view (process-name p)
                                 (match parent-pid
                                   [(cons 'meta _) #f]
                                   [_ parent-pid])
                                 new-pid
                                 (process-is-dataspace? p))]
                    [(trace-notification s o 'influence (? patch? p))
                     (for [(source-pid (in-set (extract-patch-pids p)))]
                       (send! (influence (cons source-pid (cdr s)) o)))]
                    [(trace-notification s o 'influence (message _))
                     (send! (influence s o))]
                    [(? trace-notification? n)
                     (send! n)])
                  (when n (loop)))))

     (spawn #:name 'quit-listener
            (on (message (inbound (key-event #\q #t _)))
                (assert! (outbound 'stop))))

     (spawn-influence-view-factory)
     (spawn-layout-engine)

     ;; (spawn #:name 'debug
     ;;        (on (message (? trace-notification? $n))
     ;;            (log-info "INBOUND: ~v --~v--> ~v"
     ;;                      (trace-notification-source n)
     ;;                      (trace-notification-type n)
     ;;                      (trace-notification-sink n))))

     )))

(define install-ide-dataspace!
  (make-keyword-procedure
   (lambda (ks vs . positionals)
     (define installed-dataspace (current-ground-dataspace))
     (current-ground-dataspace (keyword-apply ide-dataspace ks vs positionals)))))