From b69c3b377822f27e7186f886f2862e9ea75d98c8 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 31 Aug 2016 19:12:40 +0100 Subject: [PATCH] First sketch of "IDE" for Syndicate --- racket/Makefile | 2 +- racket/syndicate-ide/hsv.rkt | 28 +++++++++ racket/syndicate-ide/info.rkt | 1 + racket/syndicate-ide/main.rkt | 114 ++++++++++++++++++++++++++++++++++ 4 files changed, 144 insertions(+), 1 deletion(-) create mode 100644 racket/syndicate-ide/hsv.rkt create mode 100644 racket/syndicate-ide/info.rkt create mode 100644 racket/syndicate-ide/main.rkt diff --git a/racket/Makefile b/racket/Makefile index 158413e..47f6281 100644 --- a/racket/Makefile +++ b/racket/Makefile @@ -1,5 +1,5 @@ PACKAGENAME=syndicate -COLLECTS=syndicate syndicate-gl +COLLECTS=syndicate syndicate-gl syndicate-ide all: setup diff --git a/racket/syndicate-ide/hsv.rkt b/racket/syndicate-ide/hsv.rkt new file mode 100644 index 0000000..6e16daa --- /dev/null +++ b/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)) diff --git a/racket/syndicate-ide/info.rkt b/racket/syndicate-ide/info.rkt new file mode 100644 index 0000000..c14a2ca --- /dev/null +++ b/racket/syndicate-ide/info.rkt @@ -0,0 +1 @@ +#lang setup/infotab diff --git a/racket/syndicate-ide/main.rkt b/racket/syndicate-ide/main.rkt new file mode 100644 index 0000000..02b7ed1 --- /dev/null +++ b/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)))) + )))