Workable first stab at visualization of running configuration
This commit is contained in:
Tony Garnock-Jones
parent
7880b2ba28
commit
550bb12c4a
|
|
@ -4,11 +4,13 @@
|
|||
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-behavior process))
|
||||
(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)
|
||||
|
|
@ -17,6 +19,7 @@
|
|||
(require syndicate/protocol/standard-relay)
|
||||
(require syndicate/ground)
|
||||
(require syndicate/trace)
|
||||
(require syndicate/store)
|
||||
(require syndicate-gl/2d)
|
||||
|
||||
(require "hsv.rkt")
|
||||
|
|
@ -24,49 +27,61 @@
|
|||
(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 (coord-top pos extent scale)
|
||||
(define half-scale (* 1/2 scale))
|
||||
(+ half-scale (- (* half-scale pos) (* 1/2 extent))))
|
||||
|
||||
(define (tooltip touching? x y w h label-string)
|
||||
(define label-text (text label-string 22 "black"))
|
||||
(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 (pos)
|
||||
(define v (- (x) (image-width label) 10))
|
||||
(if (negative? v)
|
||||
(+ (x) w 10)
|
||||
v))
|
||||
(react (assert #:when (touching?)
|
||||
(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
|
||||
(pos)
|
||||
(x-pos (window-width))
|
||||
(+ (y) (* 1/2 h) (- (* 1/2 (image-height label))))
|
||||
(image-width label)
|
||||
(image-height label)
|
||||
label)))))
|
||||
|
||||
(define (actor-view parent-pid pid is-dataspace?)
|
||||
(actor #:name (list 'actor-view pid)
|
||||
(define (actor-view name parent-pid pid is-dataspace?)
|
||||
(actor #:name (list 'actor-view name pid)
|
||||
|
||||
(field [pos (make-rectangular (random-in-range -1 1) (random-in-range -1 1))])
|
||||
|
||||
(define/query-value win (window 1 1) (inbound (window $w $h)) (window w h))
|
||||
(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) (coord-top (real-part (pos)) (real-part extent) (window-width (win))))
|
||||
(define (y) (coord-top (imag-part (pos)) (imag-part extent) (window-height (win))))
|
||||
(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) (format "~a" pid)))
|
||||
(on-start (tooltip touching? x y (real-part extent) (imag-part extent)
|
||||
(list (format "~a" name)
|
||||
(format "~a" pid))))
|
||||
|
||||
(assert (view-position pid (pos)))
|
||||
(assert (outbound (simple-sprite #:touchable-id 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)
|
||||
|
|
@ -75,6 +90,10 @@
|
|||
(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))
|
||||
|
|
@ -89,6 +108,90 @@
|
|||
|
||||
(stop-when (message (trace-notification _ pid 'exit _)))))
|
||||
|
||||
(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
|
||||
(rectangle 1 1 "solid" "white"))))
|
||||
|
||||
(define (spawn-influence-view-factory)
|
||||
(actor #: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))))
|
||||
(actor #: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)
|
||||
(actor #: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]
|
||||
|
|
@ -100,13 +203,13 @@
|
|||
|
||||
(define user-thread
|
||||
(thread (lambda ()
|
||||
(parameterize ((current-trace-procedures
|
||||
(cons (lambda (n) (async-channel-put from-user-thread-ch n))
|
||||
(current-trace-procedures))))
|
||||
(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)
|
||||
(parameterize ((current-trace-procedures '()))
|
||||
(with-store ((current-trace-procedures '()))
|
||||
((2d-dataspace #:label "Syndicate IDE")
|
||||
|
||||
(actor #:name 'user-thread-death-monitor
|
||||
|
|
@ -116,7 +219,7 @@
|
|||
(when (thread-dead? user-thread) (user-thread-running? #f))))
|
||||
|
||||
;; Ground dataspace
|
||||
(actor-view #f '() #t)
|
||||
(actor-view 'ground #f '() #t)
|
||||
|
||||
(actor #:name 'notification-relay
|
||||
(on (message (inbound (? frame-event? _)))
|
||||
|
|
@ -126,7 +229,10 @@
|
|||
[#f
|
||||
(void)]
|
||||
[(trace-notification _ new-pid 'spawn (list parent-pid p))
|
||||
(actor-view parent-pid
|
||||
(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))
|
||||
|
|
@ -142,12 +248,16 @@
|
|||
(on (message (inbound (key-event #\q #t _)))
|
||||
(assert! (outbound 'stop))))
|
||||
|
||||
(actor #: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))))
|
||||
(spawn-influence-view-factory)
|
||||
(spawn-layout-engine)
|
||||
|
||||
;; (actor #: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!
|
||||
|
|
|
|||
Loading…
Reference in New Issue