First sketch of "IDE" for Syndicate

racket/Makefile

@@ -1,5 +1,5 @@
 PACKAGENAME=syndicate
-COLLECTS=syndicate syndicate-gl
+COLLECTS=syndicate syndicate-gl syndicate-ide
 
 all: setup
 

racket/syndicate-ide/hsv.rkt

@@ -0,0 +1,28 @@
+#lang racket/base
+
+(provide fmod
+         hsv->color
+         color-by-hash)
+
+(require 2htdp/image)
+
+(define (fmod a b)
+  (- a (* b (truncate (/ a b)))))
+
+(define (hsv->color h s v)
+  (define h* (fmod (/ h 60.0) 6))
+  (define chroma (* v s))
+  (define x (* chroma (- 1 (abs (- (fmod h* 2) 1)))))
+  (define-values (r g b)
+    (cond
+     [(< h* 1) (values chroma x 0)]
+     [(< h* 2) (values x chroma 0)]
+     [(< h* 3) (values 0 chroma x)]
+     [(< h* 4) (values 0 x chroma)]
+     [(< h* 5) (values x 0 chroma)]
+     [else     (values chroma 0 x)]))
+  (define (scale x) (inexact->exact (truncate (* 255 x))))
+  (make-color (scale r) (scale g) (scale b)))
+
+(define (color-by-hash v)
+  (hsv->color (* 360.0 (/ (bitwise-and (equal-hash-code v) 16777215) 16777216.0)) 1 1))

racket/syndicate-ide/info.rkt

@@ -0,0 +1 @@
+#lang setup/infotab

racket/syndicate-ide/main.rkt

@@ -0,0 +1,114 @@
+#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))))
+     )))