First sketch of "IDE" for Syndicate
This commit is contained in:
parent
8249993a86
commit
b69c3b3778
|
@ -1,5 +1,5 @@
|
||||||
PACKAGENAME=syndicate
|
PACKAGENAME=syndicate
|
||||||
COLLECTS=syndicate syndicate-gl
|
COLLECTS=syndicate syndicate-gl syndicate-ide
|
||||||
|
|
||||||
all: setup
|
all: setup
|
||||||
|
|
||||||
|
|
|
@ -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))
|
|
@ -0,0 +1 @@
|
||||||
|
#lang setup/infotab
|
|
@ -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))))
|
||||||
|
)))
|
Loading…
Reference in New Issue