115 lines
4.2 KiB
Racket
115 lines
4.2 KiB
Racket
#lang racket/base
|
|
|
|
(provide ide-dataspace)
|
|
|
|
(require racket/async-channel)
|
|
(require racket/match)
|
|
(require racket/set)
|
|
(require 2htdp/image)
|
|
|
|
(require (only-in syndicate seal))
|
|
(require syndicate/actor)
|
|
(require syndicate/patch)
|
|
(require syndicate/protocol/standard-relay)
|
|
(require syndicate/ground)
|
|
(require syndicate/trace)
|
|
(require syndicate-gl/2d)
|
|
|
|
(require "hsv.rkt")
|
|
|
|
(struct view-position (pid pos) #:prefab) ;; assertion
|
|
(struct influence (subject object) #: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 (actor-view parent-pid pid)
|
|
(actor #:name (list 'actor-view 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))
|
|
|
|
(define color (color-by-hash pid))
|
|
(define costume (circle 20 "solid" color))
|
|
(define extent (make-rectangular (image-width costume) (image-height costume)))
|
|
|
|
(assert (view-position pid (pos)))
|
|
(assert (outbound (simple-sprite 0
|
|
(coord-top (real-part (pos))
|
|
(real-part extent)
|
|
(window-width (win)))
|
|
(coord-top (imag-part (pos))
|
|
(imag-part extent)
|
|
(window-height (win)))
|
|
(real-part extent)
|
|
(imag-part extent)
|
|
costume)))
|
|
|
|
(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 ((ide-dataspace) . boot-actions)
|
|
(define from-user-thread-ch (make-async-channel))
|
|
|
|
(define user-thread
|
|
(thread (lambda ()
|
|
(parameterize ((current-trace-procedures
|
|
(cons (lambda (n) (async-channel-put from-user-thread-ch n))
|
|
(current-trace-procedures))))
|
|
(run-ground boot-actions)))))
|
|
|
|
(parameterize ((current-trace-procedures '()))
|
|
((2d-dataspace #:label "Syndicate IDE")
|
|
|
|
(actor #: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))))
|
|
|
|
(actor #: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 _))
|
|
(actor-view parent-pid new-pid)]
|
|
[(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)))))
|
|
|
|
(actor #:name 'quit-listener
|
|
(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))))
|
|
)))
|