From 0e3a5f01df03146e4a09a13e89fb27d4eb02e9d2 Mon Sep 17 00:00:00 2001 From: Greg Cooper Date: Thu, 21 Jul 2005 18:06:23 +0000 Subject: [PATCH] - new and improved model for conditionals based on "super-lift" - added quasiquote - made structures memory-efficient - removed "non-scheduled" dependencies - split into several modules svn: r420 --- collects/frtime/animation.ss | 19 +- collects/frtime/demos/analog-clock.ss | 9 +- collects/frtime/demos/pong.ss | Bin 24895 -> 5743 bytes collects/frtime/demos/push-pull-ball.ss | 26 +- collects/frtime/erl.ss | 14 +- collects/frtime/frp-core.ss | 835 +++++++++++++++++ collects/frtime/frp-snip.ss | 97 ++ collects/frtime/frp.ss | 995 ++++++++++++--------- collects/frtime/frtime-tool.ss | 4 +- collects/frtime/frtime.ss | 417 +-------- collects/frtime/ft-qq.ss | 178 ++++ collects/frtime/graphics-posn-less-unit.ss | 7 +- collects/frtime/gui.ss | 1 + collects/frtime/lang-ext.ss | 741 +++++++++++++++ collects/frtime/list.ss | 13 +- collects/frtime/mzscheme-core.ss | 413 +++++++++ collects/frtime/mzscheme-utils.ss | 362 ++++++++ collects/frtime/struct.ss | 277 ++++++ 18 files changed, 3563 insertions(+), 845 deletions(-) create mode 100644 collects/frtime/frp-core.ss create mode 100644 collects/frtime/frp-snip.ss create mode 100644 collects/frtime/ft-qq.ss create mode 100644 collects/frtime/lang-ext.ss create mode 100644 collects/frtime/mzscheme-core.ss create mode 100644 collects/frtime/mzscheme-utils.ss create mode 100644 collects/frtime/struct.ss diff --git a/collects/frtime/animation.ss b/collects/frtime/animation.ss index 44c2081cf4..9b6c28ffa5 100644 --- a/collects/frtime/animation.ss +++ b/collects/frtime/animation.ss @@ -2,7 +2,7 @@ (require (all-except "graphics.ss" make-posn posn-x posn-y make-rgb) (lifted "graphics.ss" posn-x posn-y make-posn make-rgb) - (all-except (lib "match.ss") match) + (lib "match.ss") (lib "class.ss") (lib "list.ss" "frtime") (lib "etc.ss" "frtime") @@ -73,6 +73,7 @@ (define-struct rrect (ur w h color)) (define-struct curve (xmin xmax ymin ymax fn)) (define-struct polygon (posn-list posn color)) + (define-struct solid-polygon (posn-list posn color)) (define (make-circle center r color) (make-solid-ellipse (make-posn (- (posn-x center) r) @@ -110,7 +111,8 @@ [(>= h 0) ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (posn-y ul)) (- w) h color)] [(>= w 0) ((draw-solid-rectangle pixmap) (make-posn (posn-x ul) (+ (posn-y ul) h)) w (- h) color)] [else ((draw-solid-rectangle pixmap) (make-posn (+ (posn-x ul) w) (+ (posn-y ul) h)) (- w) (- h) color)])] - [($ polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)] + [($ polygon pts offset color) ((draw-polygon pixmap) pts offset color)] + [($ solid-polygon pts offset color) ((draw-solid-polygon pixmap) pts offset color)] [(? list? x) (draw-list x)] [(? void?) (void)]) a-los)) @@ -136,7 +138,7 @@ (define (valid-posn? v) (and (posn? v) (number? (posn-x v)) (number? (posn-y v)))) - (define seconds~ (/ time-b 1000.0)) + (define (key sym) (key-strokes @@ -213,7 +215,7 @@ (define (wave hz) (let* ([state (collect-b - (snapshot-e (changes hz) time-b) + (snapshot-e (changes hz) milliseconds) (make-wave-state (value-now hz) 0) (lambda (new-freq+time old-state) (match new-freq+time @@ -224,7 +226,7 @@ h1 (+ o0 (* .002 pi t (- h0 h1))))])])))]) (+ (lift #f wave-state-offset state) - (* time-b pi (lift #f wave-state-hz state) .002)))) + (* milliseconds pi (lift #f wave-state-hz state) .002)))) (define (current-and-last-value signal) (let ([init (value-now signal)]) @@ -291,7 +293,8 @@ (make-posn (integral (posn-x p)) (integral (posn-y p)))) (provide - (all-defined-except pixmap window draw-list l d make-circle make-ring make-solid-ellipse - make-rect make-line make-polygon make-graph-string make-wave-state wave-state-hz wave-state-offset) - (lifted make-circle make-ring make-solid-ellipse make-rect make-line make-polygon make-graph-string) + (all-defined-except pixmap window draw-list l d + make-wave-state wave-state-hz wave-state-offset) + #;(lifted make-circle make-ring make-solid-ellipse make-rect make-line make-polygon make-solid-polygon + make-graph-string) (all-from "graphics.ss"))) diff --git a/collects/frtime/demos/analog-clock.ss b/collects/frtime/demos/analog-clock.ss index af58c91b71..5dfd4cede7 100644 --- a/collects/frtime/demos/analog-clock.ss +++ b/collects/frtime/demos/analog-clock.ss @@ -28,8 +28,11 @@ (define offset (hold - (clicks-in-clock . -=> . (value-now (posn- mouse-pos clock-center))))) - + (clicks-in-clock + . -=> . + (snapshot (mouse-pos clock-center) + (posn- mouse-pos clock-center))))) + ;; Define follow-mouse which is true when the center of the clock ;; should be at the mouse cursor; false when it is at the last ;; click position. Clicking the left button of the mouse @@ -37,7 +40,7 @@ (define follow-mouse? (hold (merge-e clicks-in-clock - (left-releases . -=> . false)))) + (left-releases . -=> . false)) #f)) ;; Define the position of the center and the radius of the clock. (define clock-center diff --git a/collects/frtime/demos/pong.ss b/collects/frtime/demos/pong.ss index f43ebd59c3f39782f447f47f5d3c016652850628..6b82729e487d12b191952665d674c1d0cae4210a 100644 GIT binary patch literal 5743 zcmeHL&2Hm15WeRr2Hp#m1--VsX*Ou$7wDz;G+4+IV+)~Wtz>8IK7GF-MM|<{yGnKo zw5Wg}vN-?qamX1_sBgQpP*)^$x}Z^%rR!*$ZnAM%j%f5;Y}2(G1#Wq{OFIjZ)>7?b zm2WE<5D>4JEFkk51XougQO{|nD36jvD_KNIx+_VnqZcJhohGWF(eGxB?AnN?6PisZ zoPgbNzo>(ZH`%t>Xj$e;B_ytCGM-G2B>koiRMC;4gEYE4v(ZYMCNL2;l4 zMMcmuG2UnntqVFN(SozZB3ZFkNZI3#M7Al`kxu_qmF`}S;E9=-Em|*H?Qkk(f2I(zdCqCF<}6?m{YO;IrLZ~z=&t0fh2R4RgjLnGxh zJ&HnU1t9@Vp587b+pXcwXYAtdD}_2Ur#(s>eo8j3UD<-*-HN7U72ftK6rZ{}NtEA; zErq;M->v-@uk{{oPPuq>oqV^JS>@whSK9>-pV-Tx7!@XS5_NL^&xq6y2{Y{|1T)4hYGd0llla@G=5+X(h4r>m zbQ%gTl%4k%*3i3o&u;#t!s-r>Sy$Ty4}Vl)Z9~*J+N^u0t5a)Fx*v7r_J#FG!9P=2 zIbUrIJmM0I1}4p(WukP{cS#ZD_Y^%#j`%I>f;LP0(3*Lqfa32V0=5_Gw%L~ zN8%oRk!fC6n8AvW5yN8@)!8-;#>Zxl221!>4{&k|ApOl9J;U_G2{%~CQJPpZi71YD zYq{u&+_^;5=yT!0&DOX&yF*C*eZe%Oy=kc>9A^b_7%0Kn;KJRtp}#Na+TbK~Z8#xe z9p#KH*Ft{n_0{cJ+()Zc<5QI9ntS?YLu-3R6UK95I&e{NV~3na@s$q#xQsGPr}$nlz2P#&XLX3TZuD>un<7|tg$aB> z@@W;1Ix>8;J zQFPfCv&eN9(>ctg?$CUVFgH2yoUmGr(<0W&N0B$pXn}!`A^FuxsAyn1+pwr(&SC@l zLL;3nS6k24;%dRkTxH!*5qhHdrE81js5a7h4mgvqcr24<%ci?LWa9v!uU@D^&MOKR zbcEqp_en{ZM)r!TQa(V`H0&2;k*qOjF!<(aT94G@9OGCuc&&5HV^cUi!j5bN^_UMR M=y3A41}`A@7alb(IsgCw literal 24895 zcmeHP&6DFs6_?!}&u1pt4S|A?isRiZyBoZj4>loN`PeD~973u>>E_oKLX z=ncGkv3EM+eI3VnHfcQ@j@{FQ#)~k+Q|j(;GU$4d!<_GnNyW7Wjd}vgQRE-HV-GMo z&U4g$uj>!{{_r3+XCPKxfY#ysYcvND$bqx^O+_Yf2i?BQJ0Zg4M&Enr4?T5b?Vx+F z7e=1ba5nIxJ3Mw{xVQorAn|b+byOR6hy%Y53^tr~xHxbppooUE37-Q$9(Ti2xY~lN z$nE=~xa4FHL%)YTaXPMCF=*h$G3ruG-kprc;ZRZlMtets!c`b_>_ub0=LVgTJM;qR zgY(npZ@}lnF!DbQK{rX47laNX&+WV2z!Ta&nE2g^9{>|vVpl(QkKGQL5X^_t`WA2W zhhr~tdt*Nw#vOU*h9Eied&1r{Gvbno55p5qx2-gxkjLK0ja-x{S}M*1_T6>+p#H0> z_vs+ux8d&dVlHaYrh+Cu$unx0Fj+CO?zF{7tubftlVdL)gK}e!nAeQ5cU9^ zLM$$~T=Xsw##(y=Su>Sto9roP_1o6(*){nwTLW^yo4DQxoQXpb_c!_Vo8{7=T3T&%WydaB$+* zdu{}g>ClV)xb^<{EbywFHq8?;gzve$sKzuibbaH-bV^L!R6+G#EJ9!}48Z4x2lpsm zo(;NTkm9gh5VvN6IP%UQ@PjEC>Ma*V`GTJQdHg&HdNz+TT9wYDj-q@XZ%wB+h{rjM zX^f^-I*U4p+cS-+2az9Q)3{O?))Hnrx!(GR6d6qhVnTC*^&5WGZ?}`Q$B+lg!1|O`DprAVsKX_Gd%U{h*joZ;GJUL z7o0(2G8y(ekbVxw{zFI+O4p^1rhH!Cb`oB1=kw|hMqxCD9ZH2v>M&j$Md8DbZR>ee zOKGJRrRQPS3)zdSSz&Yl#qte&++UQRFwKwPA`*#fg-WPCDBmoczd}dTljmYXfGxQ@ z3ChnhOh@~Pw%y6*!<6#R`>xS$eDLni9H%n!5Q%?U74)Jg5BCcGY;tm(DP{ybCn-Q) zDe(f>aLbAuHcbLJ-|S!3PCRRxHg;@`q>@fB%=<(lv(2~Bu(b<9q+Q+SFNSm}cB8?5 z^uMgUZM@sstuir*Uj%g0bNbx|o%?Fyt(ssQO`ppl-<$qz4{+q!3bs8Ef)_|__-yTB zR1WF7pn6fX({iS3J8mO7YVxjY@+KC#|-`NbE1z!^!8_? zHnG~;6LDkCKjV>!jfkyX5QmHeX{Q$+5{u|$BVlV-q)FQJ9FNE*nzWIywI?D$+Pbun zrmRCu?z#55uDDo7R*K47AkD*D)5mStCO{EdnITQD?Q{opi?eGix$!) zfYw~`pP&ByHz<7qjPF7lHeK1;#V857iU3lbJT%HBr+k{X}zUWR(sA=6{&+AfvppP)}J zc5M8Wn1aaUzuSnX4oQkvv3%0@6PUN}!{b8*yf~IDM;nM&Ao1y6I2w{T0KZT0G-D~Y z6Pv(uj_T|S4$Yc=w-J{o8B!|c3S1s!K#V2t)NvcDSsE@~+hCid4d)cLeI5&Urk~^d zNMew7{Vesj{w2U>-eo3}Wh-C7__~n#X;9j^0W@> zbNT4sedcVl+D*r4ven4@Wa2|rw^M(vwgIoK)^gNc2Ib<^w#l~J?hq=~$K zP)9%Z2Ocy5U8qu@O>3agOtFw zSbcYgNWjIuez6A^1~4n6D^PX=_2|QK6hbBV$n!warbKE`QYTurSYzkT&MsXR<9@pR zj(66Qlv|v#hP|e!0Q9>C^t%Y1-I`OV1Y%|A9du3!T9egAX)~&~G@D%KvL1!;kcJSU zS|{Do#BN#ILhXj7i=JmhfKV*QOooi^6LT_SfzBxz$ZcF_Kr}!x^P2mnF!#L<2oPi< zL&KcV8@<2>9h$b7;b(miPT(5_d;-uQBIA5*F}A0B1lxa=yF}81^j$EI#=LzV!|`aE zg*Cnk)$Qo`gulr)WULUf<4iT#S{Eai&TUqxtBeJn7T4-GKg1Yan-Fc{e0>;312^zL zRkPBa6_{bD{9qm|U=|M&vtW%D{BZ|_^#KB*_a&!C|=d~Xyi2(^Ui6FPlR?+I=4+aZ?8*%;#`6Z`gH<)`1}VIaBe(Q^gxBhB4A|hE z5;JDII)%ADC)2FOL->N@Vd6PtZh5BIWORp@pXq5f;5c)C zqC22m7rsseO`&D3c!c2IbK!~L;yI>p->-8(R2uDk)jr;gZK}D+zRm$NR&O+LY089C zq((nnWZl$rKqYk*R+EK<^mBPRAY^>B9bYCvSe{YE`d2vzdTFZqBY?I+$})GdEi$s&ySwz{^VnmGZK|G7%aig7Tbo=~RgmlbK2R zX|631oXK4kiQu9qTV>^dQbp!AdQ*${+!OeraRUxVm8&RQ_W5}-Z1rJF|B%1JSuuQu zQ#*Kt(++rrLri#e`726Ss`RQhjr_=G6PuIxMEnE~^?o|ro1ZGn%}n-)@0pwd`f;*l z`%_bKn|RFZexxMy5CPVH7mq)U2W@q>ECv-*7Q@i!@H5zwKv)E!`NyRRVipD^2)Re% z`^))up(JtsEI}P_Q>$@$E_bc+;M=&;ZG*->!JjUqkGkRT29Ei`u~H8@na$wEWA;mc zmp)IjgbBfoc|Nu3_Ii^+r#q+fXPwz5jN+q=rG0t-HO-e7FdleFC7(S@1CXI^N%#wg z0a}`{8i1m}<-uPzfSgnM5FDzMzCHGoBmKGI%Rn%2N9jX6>z2Rv>$GgXo4ZP8mg8-D zzVos>8U>mNvJb1x{WI;L)KX!be|^V3I|o{HPFc%%$GUiY>pz49l3!iJ=Wa7N|0y z0VJ|5UeVZ5f|K68Dgz-3PCj(TC50@lmaJV|qC_qCX)uFdUZtVLVv?}IhEZ{f&y=t( z5PGG~WT2N?1yUpS#0WzyPib*nN(kZ@lvMKcdxamV03^w*Fk0Ga>x7DY2fSvqYkCcF zx5C{Cx4{g5_E?IIgk&p>N?9opGZ@z&ri2I2Z4Uf^s%_*DZAhUg=DjI89^||N3tOAlgu3F5ySa+_hbwSL;k|@Xw zl2Rg2055x$m60MSb8nrKo5jKbCIrNTeGSSB2gXRb7U{uYr43nBu_G-8RYaWSz^29) L!quw|9LM=T{n_XD diff --git a/collects/frtime/demos/push-pull-ball.ss b/collects/frtime/demos/push-pull-ball.ss index 5ba03aad0a..b51bbaf950 100644 --- a/collects/frtime/demos/push-pull-ball.ss +++ b/collects/frtime/demos/push-pull-ball.ss @@ -8,20 +8,26 @@ (define pos1 (rec pos (until (make-posn 200 200) - (if (> (posn-diff pos mouse-pos) radius) - (posn+ pos - (posn* (normalize (posn- mouse-pos pos)) - (- (posn-diff pos mouse-pos) (sub1 radius)))) - pos)))) + (delay-by + (let ([brnch (posn+ pos + (posn* (normalize (posn- mouse-pos pos)) + (- (posn-diff pos mouse-pos) (sub1 radius))))]) + (if (> (posn-diff pos mouse-pos) radius) + brnch + pos)) + 0)))) (define pos2 (rec pos (until (make-posn 100 100) - (if (< (posn-diff pos pos1) (* 2 radius)) - (posn+ pos - (posn* (normalize (posn- pos1 pos)) - (- (posn-diff pos pos1) (add1 (* 2 radius))))) - pos)))) + (delay-by + (let ([brnch (posn+ pos + (posn* (normalize (posn- pos1 pos)) + (- (posn-diff pos pos1) (add1 (* 2 radius)))))]) + (if (< (posn-diff pos pos1) (* 2 radius)) + brnch + pos)) + 0)))) (display-shapes (list diff --git a/collects/frtime/erl.ss b/collects/frtime/erl.ss index fe972ced32..db165dff21 100644 --- a/collects/frtime/erl.ss +++ b/collects/frtime/erl.ss @@ -47,8 +47,8 @@ ([exn:fail:network? (lambda (_) (loop (add1 port)))]) (values (tcp-listen port) port)))) - (define ip-address - (let*-values + (define ip-address '127.0.0.1 + #;(let*-values ([(sub-proc in-p dummy1 dummy2) (subprocess #f #f #f "/bin/hostname" "-i")] [(ip-address) (read in-p)]) (subprocess-wait sub-proc) @@ -59,8 +59,8 @@ (define my-ip:port (string->symbol (format "~a:~a" ip-address port))) - (define dns - (dns-find-nameserver)) + (define dns #f + #;(dns-find-nameserver)) (define ip-regexp (regexp "[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?\\.[0-9][0-9]?[0-9]?")) @@ -120,8 +120,8 @@ v)))))) (define (receive-help timeout timeout-thunk matcher) - (if (and timeout (negative? timeout)) - (timeout-thunk) + ;(if (and timeout (negative? timeout)) + ;(timeout-thunk) (let* ([start-time (current-milliseconds)] [mb (hash-table-get mailboxes (tid-lid (self)))] [val (try-extract matcher (mailbox-old-head mb))]) @@ -150,7 +150,7 @@ (loop)) (val))) (timeout-thunk)))) - (val))))) + (val))));) (define-syntax receive (syntax-rules (after) diff --git a/collects/frtime/frp-core.ss b/collects/frtime/frp-core.ss new file mode 100644 index 0000000000..92db572410 --- /dev/null +++ b/collects/frtime/frp-core.ss @@ -0,0 +1,835 @@ + +(module frp-core mzscheme + (require (lib "etc.ss") + (lib "list.ss") + (lib "match.ss") + "erl.ss" + "heap.ss") + + + + + + ;;;;;;;;;;;;; + ;; Globals ;; + ;;;;;;;;;;;;; + + (define frtime-inspector (make-inspector)) + (print-struct #t) + + (define snap? (make-parameter #f)) + + (define named-dependents (make-hash-table)) + + (define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004") + + + + + + + + ;;;;;;;;;;;;;;;; + ;; Structures ;; + ;;;;;;;;;;;;;;;; + + ; also models events, where 'value' is all the events that + ; haven't yet occurred (more specifically, an event-cons cell whose + ; tail is *undefined*) + (define-values (struct:signal + make-signal + signal? + signal-value + signal-dependents + signal-stale? + signal-thunk + signal-depth + signal-continuation-marks + signal-custodians + signal-producers + set-signal-value! + set-signal-dependents! + set-signal-stale?! + set-signal-thunk! + set-signal-depth! + set-signal-continuation-marks! + set-signal-custodians! + set-signal-producers!) + (let*-values ([(field-name-symbols) + (list 'value 'dependents 'stale? 'thunk + 'depth 'continuation-marks 'guards 'producers)] + [(desc make-signal signal? acc mut) + (make-struct-type + 'signal #f (length field-name-symbols) 0 #f null frtime-inspector + (lambda (fn . args) + (unregister #f fn) ; clear out stale dependencies from previous apps + (let* (; revisit error-reporting for switched behaviors + [ccm (current-continuation-marks)] + [app-fun (lambda (cur-fn) + (let ([res (apply cur-fn args)]) + (when (signal? res) + (set-signal-continuation-marks! res ccm)) + res))]) + (super-lift app-fun fn))))]) + (apply values + desc + make-signal + signal? + (append + (build-list (length field-name-symbols) + (lambda (i) (make-struct-field-accessor acc i (list-ref field-name-symbols i)))) + (build-list (length field-name-symbols) + (lambda (i) (make-struct-field-mutator mut i (list-ref field-name-symbols i)))))))) + + (define-syntax signal + (let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk + 'depth 'continuation-marks 'guards 'producers)]) + (list-immutable + ((syntax-local-certifier) #'struct:signal) + ((syntax-local-certifier) #'make-signal) + ((syntax-local-certifier) #'signal?) + (apply list-immutable + (map + (lambda (fd) + ((syntax-local-certifier) (datum->syntax-object + #'here + (string->symbol (format "signal-~a" fd))))) + (reverse field-name-symbols))) + (apply list-immutable + (map + (lambda (fd) + ((syntax-local-certifier) (datum->syntax-object + #'here + (string->symbol (format "set-signal-~a!" fd))))) + (reverse field-name-symbols))) + #t))) + + (define-struct ft-cust (signal constructed-sigs)) + ;(define-struct non-scheduled (signal)) + (define make-non-scheduled identity) + (define (non-scheduled? x) #f) + (define (non-scheduled-signal x) + (error 'non-scheduled-signal "should never be called")) + + (define current-custs + (make-parameter empty)) + + (define-struct multiple (values) frtime-inspector) + + (define-struct event-cons (head tail)) + (define econs make-event-cons) + (define efirst event-cons-head) + (define erest event-cons-tail) + (define econs? event-cons?) + (define set-efirst! set-event-cons-head!) + (define set-erest! set-event-cons-tail!) + + (define-struct (signal:unchanged signal) () frtime-inspector) + (define-struct (signal:compound signal:unchanged) (content copy) frtime-inspector) + (define-struct (signal:switching signal:unchanged) (current trigger) frtime-inspector) + (define-struct (signal:event signal) () frtime-inspector) + + ; an external event; contains a list of pairs + ; (recip val), where val is passed to recip's thunk + (define-struct external-event (recip-val-pairs)) + + ; update the given signal at the given time + (define-struct alarm (time signal)) + + + ;; Simple Structure Combinators + + (define (event-receiver) + (event-producer2 + (lambda (emit) + (lambda the-args + (when (cons? the-args) + (emit (first the-args))))))) + + (define (event-producer2 proc . deps) + (let* ([out (econs undefined undefined)] + [proc/emit (proc + (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val))]) + (apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps))) + + (define (build-signal ctor thunk producers) + (let ([ccm (current-continuation-marks)]) + (do-in-manager + (let* ([custs (current-custs)] + [cust-sigs (map ft-cust-signal custs)] + [sig (ctor + undefined empty #t thunk + (add1 (apply max 0 (append (map safe-signal-depth producers) + (map safe-signal-depth cust-sigs)))) + ccm + custs + (append cust-sigs producers))]) + ;(printf "~a custodians~n" (length custs)) + (when (cons? producers) + (register sig producers)) + (when (cons? cust-sigs) + (register (make-non-scheduled sig) cust-sigs)) + (for-each (lambda (g) (set-ft-cust-constructed-sigs! + g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) + custs) + (iq-enqueue sig) + sig)))) + + (define (proc->signal:switching thunk current-box trigger . producers) + (let ([ccm (current-continuation-marks)]) + (do-in-manager + (let* ([custs (current-custs)] + [cust-sigs (map ft-cust-signal custs)] + [sig (make-signal:switching + undefined empty #t thunk + (add1 (apply max 0 (append (map safe-signal-depth producers) + (map safe-signal-depth cust-sigs)))) + ccm + custs + (append cust-sigs producers) + current-box + trigger)]) + ;(printf "~a custodians~n" (length custs)) + (when (cons? producers) + (register sig producers)) + (when (cons? cust-sigs) + (register (make-non-scheduled sig) cust-sigs)) + (for-each (lambda (g) (set-ft-cust-constructed-sigs! + g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) + custs) + (iq-enqueue sig) + sig)))) + + (define (proc->signal thunk . producers) + (build-signal make-signal thunk producers)) + + (define (proc->signal:unchanged thunk . producers) + (build-signal make-signal:unchanged thunk producers)) + + ;; mutate! : compound num -> (any -> ()) + (define (procs->signal:compound ctor mutate! . args) + (do-in-manager + (let* ([custs (current-custs)] + [cust-sigs (map ft-cust-signal custs)] + [value (apply ctor (map value-now/no-copy args))] + #;[mutators + (foldl + (lambda (arg idx acc) + (if (signal? arg) ; behavior? + (cons (proc->signal + (let ([m (mutate! value idx)]) + (lambda () + (let ([v (value-now/no-copy arg)]) + (m v) + 'struct-mutator))) + arg) acc) + acc)) + empty args (build-list (length args) identity))] + [sig (make-signal:compound + value + empty + #f + (lambda () ;mutators + (let loop ([i 0] [args args]) + (when (cons? args) + ((mutate! value i) (value-now/no-copy (car args))) + (loop (add1 i) (cdr args)))) + value) + (add1 (apply max 0 (append (map safe-signal-depth args) + (map safe-signal-depth cust-sigs)))) + (current-continuation-marks) + custs + (append cust-sigs args) + (apply ctor args) + (lambda () (apply ctor (map value-now args))))]) + ;(printf "mutators = ~a~n" mutators) + (when (cons? args) + (register sig args)) + (when (cons? cust-sigs) + (register (make-non-scheduled sig) cust-sigs)) + (for-each (lambda (g) (set-ft-cust-constructed-sigs! + g (cons (make-weak-box sig) (ft-cust-constructed-sigs g)))) + custs) + ;(printf "~n*made a compound [~a]*~n~n" (value-now/no-copy sig)) + sig))) + + + + + ;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Simple Signal Tools ;; + ;;;;;;;;;;;;;;;;;;;;;;;;; + + + (define (send-event rcvr val) + (! man (make-external-event (list (list rcvr val))))) + + (define (send-synchronous-event rcvr val) + (when (man?) + (error 'send-synchronous-event "already in frtime engine (would deadlock)")) + (! man (make-external-event (list (list rcvr val)))) + (do-in-manager ())) + + (define (send-synchronous-events rcvr-val-pairs) + (when (man?) + (error 'send-synchronous-events "already in frtime engine (would deadlock)")) + (unless (ormap list? rcvr-val-pairs) (error "not list")) + (unless (ormap signal? (map first rcvr-val-pairs)) (error "not signals")) + (! man (make-external-event rcvr-val-pairs)) + (do-in-manager ())) + + + ; set-cell! : cell[a] a -> void + (define (set-cell! ref beh) + (! man (make-external-event (list (list ((signal-thunk ref) #t) beh))))) + + + (define-values (undefined undefined?) + (let-values ([(desc make-undefined undefined? acc mut) + (make-struct-type + 'undefined #f 0 0 #f null frtime-inspector + (lambda (fn . args) fn))]) + (values (make-undefined) undefined?))) + + + (define (behavior? v) + (and (signal? v) (not (event-cons? (signal-value v))))) + + (define (undef b) + (match b + [(and (? signal?) + (= signal-value value)) + (set-signal-stale?! b #f) + (when (not (undefined? value)) + (set-signal-value! b undefined) + (propagate b))] + [_ (void)])) + + + (define (multiple->values v) + (if (multiple? v) + (apply values (multiple-values v)) + v)) + + (define (values->multiple proc) + (call-with-values + proc + (case-lambda + [(v) v] + [vals (make-multiple vals)]))) + + ; value-now : signal[a] -> a + (define (value-now val) + ;(multiple->values + (cond + [(signal:compound? val) ((signal:compound-copy val))] + [(signal:switching? val) (value-now (unbox (signal:switching-current val)))] + [(signal? val) (signal-value val)] + [else val]));) + + (define (value-now/no-copy val) + ;(multiple->values + (cond + [(signal:switching? val) (value-now/no-copy (unbox (signal:switching-current val)))] + [(signal? val) (signal-value val)] + [else val]));) + + + ;; given a list, will return a list of their value-nows that will agree + (define (value-now/sync . sigs) + (do-in-manager-after + (apply values (map value-now sigs)))) + + #;(define-syntax value-now/sync + (syntax-rules () + [(_ beh ...) + (begin + (! man (list 'run-thunk/stabalized (self) (lambda () (list (value-now beh) ...)))) + (receive [('val v) v] + [('exn e) (raise e)]))])) + + + + (define (extract k evs) + (if (cons? evs) + (let ([ev (first evs)]) + (if (or (eq? ev undefined) (undefined? (erest ev))) + (extract k (rest evs)) + (begin + (let ([val (efirst (erest ev))]) + (set-first! evs (erest ev)) + (k val))))))) + + + (define (kill-signal sig) + ;(printf "killing~n") + (for-each + (lambda (prod) + (unregister sig prod)) + (signal-producers sig)) + (set-signal-thunk! sig (lambda _ 'really-dead)) + (set-signal-value! sig 'dead) + (set-signal-dependents! sig empty) + (set-signal-producers! sig empty) + (for-each + (lambda (c) + (set-ft-cust-constructed-sigs! + c + (filter (lambda (wbox) + (cond + [(weak-box-value wbox) => (lambda (v) (not (eq? sig v)))] + [else (begin #;(printf "empty weak box~n") #f)])) + (ft-cust-constructed-sigs c)))) + (signal-custodians sig))) + + + + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Dataflow Graph Maintenance ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + (define (fix-streams streams args) + (if (empty? streams) + empty + (cons + (if (undefined? (first streams)) + (let ([stream (signal-value (first args))]) + stream + #;(if (undefined? stream) + stream + (if (equal? stream (econs undefined undefined)) + stream + (econs undefined stream)))) + (first streams)) + (fix-streams (rest streams) (rest args))))) + + (define (event-forwarder sym evt f+l) + (let ([proc (lambda (emit) + (lambda (the-event) + (for-each (lambda (tid) + (! tid (list 'remote-evt sym the-event))) (rest f+l))))] + + [args (list evt)]) + (let* ([out (econs undefined undefined)] + [proc/emit (proc + (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val))] + [streams (map signal-value args)] + [thunk (lambda () + (when (ormap undefined? streams) + ;(fprintf (current-error-port) "had an undefined stream~n") + (set! streams (fix-streams streams args))) + (let loop () + (extract (lambda (the-event) (proc/emit the-event) (loop)) + streams)) + (set! streams (map signal-value args)) + out)]) + (apply proc->signal thunk args)))) + + + + (define (safe-signal-depth v) + (cond + [(signal? v) (signal-depth v)] + [(non-scheduled? v) (signal-depth (non-scheduled-signal v))] + [0])) + + + ; *** will have to change significantly to support depth-guided recomputation *** + ; Basically, I'll have to check that I'm not introducing a cycle. + ; If there is no cycle, then I simply ensure that inf's depth is at least one more than + ; sup's. If this requires an increase to inf's depth, then I need to propagate the + ; new depth to inf's dependents. Since there are no cycles, this step is guaranteed to + ; terminate. When checking for cycles, I should of course stop when I detect a pre-existing + ; cycle. + ; If there is a cycle, then 'inf' has (and retains) a lower depth than 'sup' (?), which + ; indicates the cycle. Importantly, 'propagate' uses the external message queue whenever + ; a dependency crosses an inversion of depth. + (define (fix-depths inf sup) + (let help ([inf inf] [sup sup] [mem empty]) + (if (memq sup mem) + (send-event exceptions (list (make-exn:fail "tight cycle in dataflow graph" (signal-continuation-marks sup)) + sup)) + (when (<= (safe-signal-depth inf) + (safe-signal-depth sup)) + (set-signal-depth! inf (add1 (safe-signal-depth sup))) + (for-each + (lambda (dep) (help dep inf (cons sup mem))) + (foldl (lambda (wb acc) + (match (weak-box-value wb) + [(and sig (? signal?)) (cons sig acc)] + [(and (? non-scheduled?) (= non-scheduled-signal sig)) (cons sig acc)] + [_ acc])) + empty (signal-dependents inf))))))) + + + (define-values (iq-enqueue iq-dequeue iq-empty? iq-resort) + (let* ([depth + (lambda (msg) + (if (signal? msg) + (signal-depth msg) + (signal-depth (first msg))))] + [heap (make-heap + (lambda (b1 b2) (< (depth b1) (depth b2))) + eq?)]) + (values + (lambda (b) (heap-insert heap b)) + (lambda () (heap-pop heap)) + (lambda () (heap-empty? heap)) + (lambda () (let loop ([elts empty]) + (if (heap-empty? heap) + (let loop ([elts elts]) + (when (cons? elts) + (heap-insert heap (first elts)) + (loop (rest elts)))) + (loop (cons (heap-pop heap) elts)))))))) + + (define-values (alarms-enqueue alarms-dequeue-beh alarms-peak-ms alarms-empty?) + (let ([heap (make-heap (lambda (a b) (< (first a) (first b))) eq?)]) + (values (lambda (ms beh) (heap-insert heap (list ms (make-weak-box beh)))) + (lambda () (match (heap-pop heap) [(_ beh) (weak-box-value beh)])) + (lambda () (match (heap-peak heap) [(ms _) ms])) + (lambda () (heap-empty? heap))))) + + (define (schedule-alarm ms beh) + (when (> ms 1073741824) + (set! ms (- ms 2147483647))) + (if (eq? (self) man) + (alarms-enqueue ms beh) + (! man (make-alarm ms beh)))) + + + + + + ;;;;;;;;;;;;;;;;;;;;; + ;; Manager Helpers ;; + ;;;;;;;;;;;;;;;;;;;;; + + (define man? + (opt-lambda ([v (self)]) + (eq? v man))) + + + + + (define-syntax do-in-manager + (syntax-rules () + [(_ expr ...) + (if (man?) + (begin expr ...) + (begin + (! man (list 'run-thunk (self) (let ([custs (current-custs)]) + (lambda () + (parameterize ([current-custs custs]) + expr ...))))) + (receive [('vals . vs) (apply values vs)] + [('exn e) (raise e)])))])) + + (define-syntax do-in-manager-after + (syntax-rules () + [(_ expr ...) + (if (man?) + (begin expr ...) + (begin + (! man (list 'run-thunk/stabilized (self) + (let ([custs (current-custs)]) + (lambda () + (parameterize ([current-custs custs]) + expr ...))))) + (receive [('vals . vs) (apply values vs)] + [('exn e) (raise e)])))])) + + (define (register inf sup) + (do-in-manager + (match sup + [(and (? signal?) + (= signal-dependents dependents)) + (set-signal-dependents! + sup + (cons (make-weak-box inf) dependents)) + (fix-depths inf sup)] + [(? list?) (for-each (lambda (sup1) (register inf sup1)) sup)] + [_ (void)]) + inf)) + + (define (unregister inf sup) + (do-in-manager + (match sup + [(and (? signal?) + (= signal-dependents dependents)) + (set-signal-dependents! + sup + (filter (lambda (a) + (let ([v (weak-box-value a)]) + (nor (eq? v inf) + (eq? v #f)))) + dependents))] + [_ (void)]))) + + (define (super-lift fun bhvr) + (if (behavior? bhvr) + (do-in-manager + (let* ([cust (make-ft-cust (void) empty)] + [custs (cons cust (current-custs))] + [pfun (lambda (b) + (parameterize ([current-custs custs]) + (fun b)))] + [current (box undefined)]) + (letrec ([custodian-signal + (proc->signal:unchanged + (lambda () + (for-each kill-signal (filter identity (map weak-box-value (ft-cust-constructed-sigs cust)))) + (unregister rtn (unbox current)) + (set-box! current (pfun (value-now/no-copy bhvr))) + (register rtn (unbox current)) + ;; keep rtn's producers up-to-date + (set-car! (signal-producers rtn) (unbox current)) + (iq-resort) + 'custodian) + bhvr)] + [rtn (proc->signal:switching + (lambda () custodian-signal (value-now/no-copy (unbox current))) + current custodian-signal undefined bhvr custodian-signal)]) + (set-ft-cust-signal! cust custodian-signal) + rtn))) + (fun bhvr))) + + + (define (propagate b) + (let ([empty-boxes 0] + [dependents (signal-dependents b)] + [depth (signal-depth b)]) + (for-each + (lambda (wb) + (match (weak-box-value wb) + [(and dep (? signal?) (= signal-stale? #f)) + (set-signal-stale?! dep #t) + ; If I'm crossing a "back" edge (one potentially causing a cycle), + ; then I send a message. Otherwise, I add to the internal + ; priority queue. + (if (< depth (signal-depth dep)) + (iq-enqueue dep) + (! man dep))] + [_ + (set! empty-boxes (add1 empty-boxes))])) + dependents) + (when (> empty-boxes 9) + (set-signal-dependents! + b + (filter weak-box-value dependents))))) + + + (define (update0 b) + (match b + [(and (? signal?) + (= signal-value value) + (= signal-thunk thunk) + (= signal-custodians custs)) + (set-signal-stale?! b #f) + (let ([new-value (parameterize ([current-custs custs]) + (thunk))]) + (if (or (signal:unchanged? b) (not (eq? value new-value))) + (begin + #;(if (signal? new-value) + (raise (make-exn:fail + "signal from update thunk!!!" + (signal-continuation-marks b)))) + #;(printf "~n[~a]: ~a --> ~a~n" (cond + [(signal:switching? b) 'signal:switching] + [(signal:compound? b) 'signal:compound] + [(signal:unchanged? b) 'signal:unchanged] + [else 'signal]) + value new-value) + (set-signal-value! b new-value) + (propagate b)) + #;(parameterize ([print-struct #f]) + (printf "~a ... ~a (~a)~n" value new-value b))))] + [_ (void)])) + + (define (update1 b a) + (match b + [(and (? signal?) + (= signal-value value) + (= signal-thunk thunk)) + (set-signal-stale?! b #f) + (let ([new-value (thunk a)]) + (when (not (equal? value new-value)) + (set-signal-value! b new-value) + (propagate b)))] + [_ (void)])) + + + + (define (signal-count) + (! man `(stat ,(self))) + (receive [n n])) + + + + ;;;;;;;;;;;;; + ;; Manager ;; + ;;;;;;;;;;;;; + + ;; the manager of all signals and event streams + (define man + (spawn/name + 'frtime-heart + (let* ([named-providers (make-hash-table)] + [cur-beh #f] + [signal-cache (make-hash-table 'weak)] + [notifications empty] + + ;; added for run-thunk/stablized + [thunks-to-run empty] + [do-and-queue (lambda (pid thnk) + (with-handlers + ([exn:fail? (lambda (exn) + (set! notifications + (cons (list pid 'exn exn) + notifications)))]) + (set! notifications + (cons (list* pid 'vals (call-with-values thnk list)) + notifications))))]) + (let outer () + (with-handlers ([exn:fail? + (lambda (exn) + (when (and cur-beh + #;(not (undefined? (signal-value cur-beh)))) + #(when (empty? (continuation-mark-set->list + (exn-continuation-marks exn) 'frtime)) + (set! exn (make-exn:fail (exn-message exn) + (signal-continuation-marks + cur-beh)))) + ;(raise exn) + (iq-enqueue (list exceptions (list exn cur-beh))) + (when (behavior? cur-beh) + (undef cur-beh) + #;(kill-signal cur-beh))) + (outer))]) + (let inner () + + ;; process external messages until there is an internal update + ;; or an expired alarm + (let loop () + (receive [after (cond + [(not (iq-empty?)) 0] + [(not (alarms-empty?)) (- (alarms-peak-ms) + (current-milliseconds))] + [else #f]) + (void)] + [(? signal? b) + (iq-enqueue b) + (loop)] + [($ external-event recip-val-pairs) + (for-each iq-enqueue recip-val-pairs) + (loop)] + [($ alarm ms beh) + (schedule-alarm ms beh) + (loop)] + [('run-thunk rtn-pid thunk) + (begin + (do-and-queue rtn-pid thunk) + ; (with-handlers + ; ([exn:fail? (lambda (exn) + ; (set! notifications + ; (cons (list rtn-pid 'exn exn) + ; notifications)))]) + ; (set! notifications (cons (list rtn-pid 'val (thunk)) + ; notifications))) + (loop))] + + + ;; !Experimental! + ;; queues thunks to be evaluated after this round of computation, + ;; but before the next round + + [('run-thunk/stabilized rtn-pid thunk) + (begin + (set! thunks-to-run (cons (list rtn-pid thunk) thunks-to-run)) + (loop))] + + + [('stat rtn-pid) + (let ([x 0]) + (hash-table-for-each signal-cache (lambda (k v) + (if k (set! x (add1 x))))) + (! rtn-pid x))] + + [('bind sym evt) + (let ([forwarder+listeners (cons #f empty)]) + (set-car! forwarder+listeners + (event-forwarder sym evt forwarder+listeners)) + (hash-table-put! named-providers sym forwarder+listeners)) + (loop)] + [('remote-reg tid sym) + (let ([f+l (hash-table-get named-providers sym)]) + (when (not (member tid (rest f+l))) + (set-rest! f+l (cons tid (rest f+l))))) + (loop)] + [('remote-evt sym val) + (iq-enqueue + (list (hash-table-get named-dependents sym (lambda () dummy)) val)) + (loop)] + [msg + (fprintf (current-error-port) + "frtime engine: msg not understood: ~a~n" + msg) + (loop)])) + + ;; enqueue expired timers for execution + (let loop () + (unless (or (alarms-empty?) + (< (current-milliseconds) + (alarms-peak-ms))) + (let ([beh (alarms-dequeue-beh)]) + (when (and beh (not (signal-stale? beh))) + (set-signal-stale?! beh #t) + (iq-enqueue beh))) + (loop))) + + ;; process internal updates + (let loop () + (unless (iq-empty?) + (match (iq-dequeue) + [(b val) + (set! cur-beh b) + (update1 b val) + (set! cur-beh #f)] + [b + (set! cur-beh b) + (update0 b) + (hash-table-get signal-cache b (lambda () (hash-table-put! signal-cache b #t))) + (set! cur-beh #f)]) + (loop))) + + + ;; do the run-thunk/stabalized; use existing notification mechanism + (for-each (lambda (pair) + (do-and-queue (first pair) (second pair))) + thunks-to-run) + + + (for-each (lambda (lst) + (! (first lst) (rest lst))) + notifications) + + (set! notifications empty) + (set! thunks-to-run empty) + + (inner))))))) + + (define exceptions + (event-receiver)) + + (define dummy (proc->signal void)) + + (provide (all-defined))) \ No newline at end of file diff --git a/collects/frtime/frp-snip.ss b/collects/frtime/frp-snip.ss new file mode 100644 index 0000000000..8b2ab76e90 --- /dev/null +++ b/collects/frtime/frp-snip.ss @@ -0,0 +1,97 @@ +(module frp-snip mzscheme + (require (lib "class.ss") + (lib "string.ss") + (lib "list.ss") + + ;; FRP requires + + (lib "frp-core.ss" "frtime") + (all-except (lib "lang-ext.ss" "frtime") undefined?) +; (rename (lib "frp-core.ss" "frtime") behavior? behavior?) +; (rename (lib "lang-ext.ss" "frtime") event? event?) +; (rename (lib "frp-core.ss" "frtime") signal? signal?) +; +; (rename (lib "frp-core.ss" "frtime") econs? econs?) +; (rename (lib "frp-core.ss" "frtime") efirst efirst) +; +; (rename (lib "frp-core.ss" "frtime") value-now value-now) +; (rename (lib "frp-core.ss" "frtime") signal-value signal-value) +; (rename (lib "lang-ext.ss" "frtime") undefined undefined) +; (rename (lib "lang-ext.ss" "frtime") undefined? frp:undefined?) +; +; (rename (lib "frp-core.ss" "frtime") proc->signal proc->signal) + + ;; MrEd require + (all-except (lib "mred.ss" "mred") send-event)) + + (define drs-eventspace #f) + + (define (set-eventspace evspc) + (set! drs-eventspace evspc)) + + (define value-snip-copy% + (class string-snip% + (init-field current parent) + (inherit get-admin) + (define/public (set-current c) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (lambda () + (set! current c) + (let ([admin (get-admin)]) + (when admin + (send admin needs-update this 0 0 2000 100))))))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (send current draw dc x y left top right bottom dx dy draw-caret)) + (super-instantiate (" ")))) + + (define (make-snip bhvr) + (make-object string-snip% + (let ([tmp (cond + [(behavior? bhvr) (value-now bhvr)] + [(event? bhvr) (signal-value bhvr)] + [else bhvr])]) + (cond + [(econs? tmp) (format "#" (efirst tmp))] + [(undefined? tmp) ""] + [else (expr->string tmp)])))) + + (define value-snip% + (class string-snip% + (init-field bhvr) + (field [copies empty] + [loc-bhvr (proc->signal (lambda () (update)) bhvr)] + [current (make-snip bhvr)]) + + (define/override (copy) + (let ([ret (make-object value-snip-copy% current this)]) + (set! copies (cons ret copies)) + ret)) + + (define/public (update) + (set! current (make-snip bhvr)) + (for-each (lambda (copy) (send copy set-current current)) copies)) + + (super-instantiate (" ")))) + + (define (render beh as-snip?) + (cond + [as-snip? (watch beh)] + [(undefined? (value-now beh)) ""] + [(behavior? beh) (format "#" (value-now beh))] + [(event? beh) (format "#" (efirst (signal-value beh)))] + [else beh])) + + (define (watch beh) + (cond + [(undefined? beh) + (begin + ;(printf "~a was regarded as undefined~n" beh) + (make-object string-snip% "") + ) + ] + [(signal? beh) (make-object value-snip% beh)] + [else beh])) + + (provide (all-defined)) + ) diff --git a/collects/frtime/frp.ss b/collects/frtime/frp.ss index 771c607eb3..840da013e6 100644 --- a/collects/frtime/frp.ss +++ b/collects/frtime/frp.ss @@ -1,5 +1,4 @@ ; Ideas: -; make smart 'if' ; tag impure and imperative signals (pure vs. stateful vs. effectful) ; use weak boxes in internal queue ; have manager initialize signals @@ -84,25 +83,28 @@ ; flip arguments in event-handling combinators (done) ; + +;; Fix all predicates for compound signals to return constant as per frp:pair? +;; Consider re-implementing switch strategy (module frp mzscheme (require (lib "list.ss") (lib "etc.ss") (lib "class.ss") - (all-except (lib "mred.ss" "mred") send-event) + ;(all-except (lib "mred.ss" "mred") send-event) (lib "string.ss") "erl.ss" (lib "match.ss") "heap.ss") - (require-for-syntax (lib "list.ss")) - + (require-for-syntax (lib "list.ss") (lib "etc.ss") (lib "struct.ss" "frtime")) + (define frtime-version "0.3b -- Tue Nov 9 13:39:45 2004") (define frtime-inspector (make-inspector)) (print-struct #t) - - (define snap? (make-parameter #f)) + (define snap? (make-parameter #f)) + ; also models events, where 'value' is all the events that ; haven't yet occurred (more specifically, an event-cons cell whose ; tail is *undefined*) @@ -115,37 +117,32 @@ signal-thunk signal-depth signal-continuation-marks - signal-guards + signal-custodians + signal-producers set-signal-value! set-signal-dependents! set-signal-stale?! set-signal-thunk! set-signal-depth! set-signal-continuation-marks! - set-signal-guards) - (let-values ([(desc make-signal signal? acc mut) - (make-struct-type - 'signal #f 7 0 #f null frtime-inspector - (lambda (fn . args) - (unregister #f fn) ; clear out stale dependencies from previous apps - (let* ([cur-fn (value-now fn)] - [cur-app (safe-eval (apply cur-fn args))] - [ccm (current-continuation-marks)] - [ret (proc->signal void fn cur-app)] - [thunk (lambda () - (when (not (eq? cur-fn (value-now fn))) - (unregister ret cur-app) - (set! cur-fn (value-now fn)) - (set! cur-app (safe-eval (apply cur-fn args))) - (when (signal? cur-app) - (set-signal-continuation-marks! cur-app ccm)) - (register ret cur-app)) - (value-now cur-app))]) - (set-signal-thunk! ret thunk) - ; may need to change for multiple values - (set-signal-value! ret (thunk)) - ret)))] - [(field-name-symbols) (list 'value 'dependents 'stale? 'thunk 'depth 'continuation-marks 'guards)]) + set-signal-custodians! + set-signal-producers!) + (let*-values ([(field-name-symbols) + (list 'value 'dependents 'stale? 'thunk + 'depth 'continuation-marks 'guards 'producers)] + [(desc make-signal signal? acc mut) + (make-struct-type + 'signal #f (length field-name-symbols) 0 #f null frtime-inspector + (lambda (fn . args) + (unregister #f fn) ; clear out stale dependencies from previous apps + (let* (; revisit error-reporting for switched behaviors + [ccm (current-continuation-marks)] + [app-fun (lambda (cur-fn) + (let ([res (apply cur-fn args)]) + (when (signal? res) + (set-signal-continuation-marks! res ccm)) + res))]) + (super-lift app-fun fn))))]) (apply values desc make-signal @@ -156,10 +153,33 @@ (build-list (length field-name-symbols) (lambda (i) (make-struct-field-mutator mut i (list-ref field-name-symbols i)))))))) - (define-struct guard (signal trans)) + (define-syntax signal + (let ([field-name-symbols (list 'value 'dependents 'stale? 'thunk + 'depth 'continuation-marks 'guards 'producers)]) + (list-immutable + ((syntax-local-certifier) #'struct:signal) + ((syntax-local-certifier) #'make-signal) + ((syntax-local-certifier) #'signal?) + (apply list-immutable + (map + (lambda (fd) + ((syntax-local-certifier) (datum->syntax-object + #'here + (string->symbol (format "signal-~a" fd))))) + (reverse field-name-symbols))) + (apply list-immutable + (map + (lambda (fd) + ((syntax-local-certifier) (datum->syntax-object + #'here + (string->symbol (format "set-signal-~a!" fd))))) + (reverse field-name-symbols))) + #t))) + + (define-struct ft-cust (signal constructed-sigs)) (define-struct non-scheduled (signal)) - (define current-guards + (define current-custs (make-parameter empty)) (define-struct multiple (values)) @@ -172,12 +192,171 @@ (define set-efirst! set-event-cons-head!) (define set-erest! set-event-cons-tail!) + (define-struct (signal:compound signal) (content copy)) + + ;;;;;;;;;;;;;;;;;;;;; + ;; Ported Structs ;; + ;;;;;;;;;;;;;;;;;;;;; + + (define (frp:eq? itm1 itm2) + (lift #t eq? itm1 itm2)) + + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; CONS + + + (define (frp:cons f r) + (if (or (behavior? f) (behavior? r)) + (procs->signal:compound + cons + (lambda (p i) + (if (zero? i) + (lambda (v) (set-car! p v)) + (lambda (v) (set-cdr! p v)))) + f r) + (cons f r))) + + (define (make-accessor acc) + (lambda (v) + (cond + [(signal:compound? v) (acc (signal:compound-content v))] + [(signal? v) (lift #t acc v)] + [else (acc v)]))) + + (define frp:car + (make-accessor car)) + + (define frp:cdr + (make-accessor cdr)) + + (define frp:pair? (lambda (arg) (if (signal:compound? arg) + (pair? (signal:compound-content arg)) + (lift true pair? arg)))) + + (define (frp:empty? x) + (lift true empty? x)) + + (define (frp:append lst0 lst1) + (frp:if (frp:empty? lst0) + lst1 + (frp:cons (frp:car lst0) + (frp:append (frp:cdr lst0) lst1)))) + + (define frp:list + (lambda elts + (frp:if (frp:empty? elts) + '() + (frp:cons (frp:car elts) + (apply frp:list (frp:cdr elts)))))) + + (define frp:list* + (lambda elts + (frp:if (frp:empty? elts) + '() + (frp:if (frp:empty? (frp:cdr elts)) + (frp:car elts) + (frp:cons (frp:car elts) + (apply frp:list* (frp:cdr elts))))))) + + (define (frp:list? itm) + (if (signal:compound? itm) + (let ([ctnt (signal:compound-content itm)]) + ; (let ([ctnt (value-now itm)]) + (if (cons? ctnt) + (frp:list? (cdr ctnt)) + #f)) + (if (signal? itm) + (frp:if (lift true cons? itm) + (frp:list? (frp:cdr itm)) + (frp:null? itm)) + (or (null? itm) + (and (cons? itm) (frp:list? (cdr itm))))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Vector + + + (define (frp:vector . args) + (if (ormap behavior? args) + (apply procs->signal:compound + vector + (lambda (vec idx) + (lambda (x) + (vector-set! vec idx x))) + args) + (apply vector args))) + + (define (frp:vector-ref v i) + (cond + [(signal:compound? v) (vector-ref (signal:compound-content v) i)] + [(signal? v) (lift #t vector-ref v i)] + [else (vector-ref v i)])) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; make-struct-type + define-struct Macros + + + (define (frp:make-struct-type name-symbol super-struct-type init-field-k auto-field-k . args) + (let-values ([(desc ctor pred acc mut) + (apply make-struct-type name-symbol super-struct-type init-field-k auto-field-k + args)]) + (values + desc + (lambda fields + (if (ormap behavior? fields) + (apply procs->signal:compound + ctor + (lambda (strct idx) + (lambda (val) + (mut strct idx val))) + fields) + (apply ctor fields))) + (lambda (v) (lift #t pred v)) ; FIX + acc + mut))) + + (define (frp:make-struct-field-accessor acc i sym) + (make-accessor (make-struct-field-accessor acc i sym))) + + ; FORBIDS MUTATION + (define (frp:make-struct-field-mutator acc i sym) + (lambda (s) + (error "MUTATION NOT ALLOWED IN FrTime STRUCTURES"))) + + (define-syntax (frp:define-struct stx) + (syntax-case stx () + [(_ (s t) (field ...) insp) + (let ([field-names (syntax->list #'(field ...))] + [super-for-gen (if (syntax-e #'t) + (string->symbol + (format "struct:~a" (syntax-e #'t))) + #f)] + [super-for-exp (if (syntax-e #'t) + #'t + #t)]) + #`(begin + (define-values #,(build-struct-names #'s field-names #f #f stx) + (parameterize ([current-inspector insp]) + #,(build-struct-generation #'s field-names #f #f super-for-gen))) + (define-syntax s + #,(build-struct-expand-info #'s field-names #f #f super-for-exp + empty empty))))] + [(_ (s t) (field ...)) + #'(frp:define-struct (s t) (field ...) (current-inspector))] + [(_ s (field ...) insp) + #'(frp:define-struct (s #f) (field ...) insp)] + [(_ s (field ...)) + #'(frp:define-struct (s #f) (field ...) (current-inspector))])) + (define (event? v) (and (signal? v) (if (undefined? (signal-value v)) undefined (event-cons? (signal-value v))))) - + (define (event-receiver? v) (and (event? v) (procedure-arity-includes? (signal-thunk v) 1))) @@ -191,21 +370,82 @@ [(non-scheduled? v) (signal-depth (non-scheduled-signal v))] [0])) + (define-syntax do-in-manager + (syntax-rules () + [(_ expr ...) + (if (man?) + (begin expr ...) + (begin + (! man (list 'run-thunk (self) (let ([custs (current-custs)]) + (lambda () + (parameterize ([current-custs custs]) + expr ...))))) + (receive [('val v) v] + [('exn e) (raise e)])))])) + + ;; mutate! : compound num -> (any -> ()) + (define (procs->signal:compound ctor mutate! . args) + (do-in-manager + (let* ([custs (current-custs)] + [cust-sigs (map ft-cust-signal custs)] + [value (apply ctor (map value-now/no-copy args))] + [mutators + (foldl + (lambda (arg idx acc) + (if (signal? arg) ; behavior? + (cons (proc->signal + (let ([m (mutate! value idx)]) + (lambda () + (let ([v (value-now/no-copy arg)]) + (m v) + v))) + arg) acc) + acc)) + empty args (build-list (length args) identity))] + [sig (make-signal:compound + value + empty + #f + (lambda () mutators value) + (add1 (apply max 0 (append (map safe-signal-depth args) + (map (lambda (s) (+ 0 (safe-signal-depth s))) + cust-sigs)))) + (current-continuation-marks) + custs + args + (apply ctor args) + (lambda () (apply ctor (map value-now args))))]) + ;(printf "mutators = ~a~n" mutators) + (when (cons? args) + (register sig args)) + (when (cons? cust-sigs) + (register (make-non-scheduled sig) cust-sigs)) + (for-each (lambda (g) (set-ft-cust-constructed-sigs! + g (cons sig (ft-cust-constructed-sigs g)))) + custs) + sig))) + (define (proc->signal thunk . producers) - (let* ([guard-sigs (map guard-signal (current-guards))] - [all-dependees (append guard-sigs producers)] - [sig (make-signal - undefined empty #f thunk - (add1 (apply max 0 (map safe-signal-depth - all-dependees))) - (current-continuation-marks) - (current-guards))]) - (when (cons? producers) - (register sig producers)) - (when (cons? guard-sigs) - (register (make-non-scheduled sig) guard-sigs)) - (set-signal-value! sig (safe-eval (thunk))) - sig)) + (do-in-manager + (let* ([custs (current-custs)] + [cust-sigs (map ft-cust-signal custs)] + [sig (make-signal + undefined empty #t thunk + (add1 (apply max 0 (append (map safe-signal-depth producers) + (map safe-signal-depth cust-sigs)))) + (current-continuation-marks) + (current-custs) + producers)]) + ;(printf "~a custodians~n" (length custs)) + (when (cons? producers) + (register sig producers)) + (when (cons? cust-sigs) + (register (make-non-scheduled sig) cust-sigs)) + (for-each (lambda (g) (set-ft-cust-constructed-sigs! + g (cons sig (ft-cust-constructed-sigs g)))) + custs) + (iq-enqueue sig) + sig))) (define errortrace-key 'drscheme-debug-continuation-mark-key) @@ -220,35 +460,58 @@ ; an external event; contains a list of pairs ; (recip val), where val is passed to recip's thunk (define-struct external-event (recip-val-pairs)) - + ; update the given signal at the given time (define-struct alarm (time signal)) - (define (frp:if-helper test then-thunk else-thunk undef-thunk) - (let* ([if-fun (let ([true-guards (cons (make-guard test identity) (current-guards))] - [false-guards (cons (make-guard test not) (current-guards))] - [undef-guards (cons (make-guard test undefined?) (current-guards))]) - (lambda (b) - (cond - [(undefined? b) (parameterize ([current-guards undef-guards]) - (undef-thunk))] - [b (parameterize ([current-guards true-guards]) - (then-thunk))] - [else (parameterize ([current-guards false-guards]) - (else-thunk))])))]) - (switch - ((changes test) . ==> . - if-fun) - (if-fun (value-now test))))) + (define (kill-signal sig) + ;(printf "killing~n") + (for-each + (lambda (prod) + (unregister sig prod)) + (signal-producers sig)) + (set-signal-thunk! sig void) + (set-signal-value! sig 'dead) + (set-signal-dependents! sig empty) + (set-signal-producers! sig empty) + (for-each + (lambda (c) + (set-ft-cust-constructed-sigs! + c + (remq sig (ft-cust-constructed-sigs c)))) + (signal-custodians sig))) - (define (weakly-cache thunk) - (let ([cache (make-weak-box #f)]) - (lambda () - (cond - [(weak-box-value cache)] - [else (let ([result (thunk)]) - (set! cache (make-weak-box result)) - result)])))) + (define (super-lift fun bhvr) + (do-in-manager + (let* ([cust (make-ft-cust (void) empty)] + [custs (cons cust (current-custs))] + [pfun (lambda (b) + (parameterize ([current-custs custs]) + (fun b)))] + [current undefined]) + (letrec ([custodian-signal + (proc->signal + (lambda () + (for-each kill-signal (ft-cust-constructed-sigs cust)) + (unregister rtn current) + (set! current (pfun (value-now bhvr))) + (register rtn current) + (set-car! (signal-producers rtn) current) + (iq-resort)) + bhvr)] + [rtn (proc->signal + (lambda () custodian-signal (value-now current)) + current bhvr custodian-signal)]) + (set-ft-cust-signal! cust custodian-signal) + rtn)))) + + (define (frp:if-helper test then-thunk else-thunk undef-thunk) + (let ([if-fun (lambda (b) + (cond + [(undefined? b) (undef-thunk)] + [b (then-thunk)] + [else (else-thunk)]))]) + (super-lift if-fun test))) (define-syntax frp:if (syntax-rules () @@ -259,26 +522,36 @@ [(_ test-exp then-exp else-exp undef-exp) (let ([v test-exp]) (cond - [(behavior? v) (frp:if-helper v (lambda () then-exp) (lambda () else-exp) (lambda () undef-exp))] + [(behavior? v) (frp:if-helper + v + (lambda () then-exp) + (lambda () else-exp) + (lambda () undef-exp))] [(undefined? v) undef-exp] [v then-exp] [else else-exp]))])) - + ; value-now : signal[a] -> a (define (value-now val) - (if (signal? val) - (signal-value val) - val)) + (cond + [(signal:compound? val) ((signal:compound-copy val))] + [(signal? val) (signal-value val)] + [else val])) + + (define (value-now/no-copy val) + (cond + [(signal? val) (signal-value val)] + [else val])) ; no multiple value support - (define (value-now/copy val) - (if (signal? val) - (let ([v1 (signal-value val)]) - (if (vector? v1) - (build-vector (vector-length v1) (lambda (i) (vector-ref v1 i))) - v1)) - val)) - + #;(define (value-now/copy val) + (if (signal? val) + (let ([v1 (signal-value val)]) + (if (vector? v1) + (build-vector (vector-length v1) (lambda (i) (vector-ref v1 i))) + v1)) + val)) + ; (define value-now/copy ; (frp:lambda (val) @@ -304,7 +577,7 @@ (define (fix-depths inf sup) (let help ([inf inf] [sup sup] [mem empty]) (if (memq sup mem) - (send-event exceptions (list (make-exn:fail "delay-less cycle in dataflow graph" (signal-continuation-marks sup)) + (send-event exceptions (list (make-exn:fail "tight cycle in dataflow graph" (signal-continuation-marks sup)) sup)) (when (<= (safe-signal-depth inf) (safe-signal-depth sup)) @@ -319,8 +592,8 @@ empty (signal-dependents inf))))))) (define (register inf sup) - (if (eq? (self) man) - (match sup + (do-in-manager + (match sup [(and (? signal?) (= signal-dependents dependents)) (set-signal-dependents! @@ -329,25 +602,21 @@ (fix-depths inf sup)] [(? list?) (for-each (lambda (sup1) (register inf sup1)) sup)] [_ (void)]) - (begin - (! man (make-reg inf sup (self))) - (receive [(? man?) (void)]))) - inf) - + inf)) + (define (unregister inf sup) - (if (eq? (self) man) - (match sup - [(and (? signal?) - (= signal-dependents dependents)) - (set-signal-dependents! - sup - (filter (lambda (a) - (let ([v (weak-box-value a)]) - (nor (eq? v inf) - (eq? v #f)))) - dependents))] - [_ (void)]) - (! man (make-unreg inf sup)))) + (do-in-manager + (match sup + [(and (? signal?) + (= signal-dependents dependents)) + (set-signal-dependents! + sup + (filter (lambda (a) + (let ([v (weak-box-value a)]) + (nor (eq? v inf) + (eq? v #f)))) + dependents))] + [_ (void)]))) (define-values (undefined undefined?) (let-values ([(desc make-undefined undefined? acc mut) @@ -355,55 +624,33 @@ 'undefined #f 0 0 #f null frtime-inspector (lambda (fn . args) fn))]) (values (make-undefined) undefined?))) -#| - (define undefined - (string->uninterned-symbol "")) - (define (undefined? x) - (eq? x undefined)) -|# - (define-syntax safe-eval - (syntax-rules () - [(_ expr ...) - (with-continuation-mark - 'frtime 'safe-eval - (with-handlers ([exn:fail? - (lambda (exn) - (cond - #;[(and (exn:fail? exn) - (undefined? (exn:application-value exn)))] - [(man?) (iq-enqueue (list exceptions (list exn 'unknown)))] - [else (thread (lambda () (fprintf (current-error-port) "exception caught outside frtime engine~n") (raise exn)))]) - undefined)]) - expr ...))])) - ; could use special treatment for constructors - ; to avoid making lots of garbage (?) (define create-strict-thunk (case-lambda [(fn) fn] [(fn arg1) (lambda () - (let ([a1 (value-now arg1)]) + (let ([a1 (value-now/no-copy arg1)]) (if (undefined? a1) undefined (fn a1))))] [(fn arg1 arg2) (lambda () - (let ([a1 (value-now arg1)] - [a2 (value-now arg2)]) + (let ([a1 (value-now/no-copy arg1)] + [a2 (value-now/no-copy arg2)]) (if (or (undefined? a1) (undefined? a2)) undefined (fn a1 a2))))] [(fn arg1 arg2 arg3) (lambda () - (let ([a1 (value-now arg1)] - [a2 (value-now arg2)] - [a3 (value-now arg3)]) + (let ([a1 (value-now/no-copy arg1)] + [a2 (value-now/no-copy arg2)] + [a3 (value-now/no-copy arg3)]) (if (or (undefined? a1) (undefined? a2) (undefined? a3)) undefined (fn a1 a2 a3))))] [(fn . args) (lambda () - (let ([as (map value-now args)]) + (let ([as (map value-now/no-copy args)]) (if (ormap undefined? as) undefined (apply fn as))))])) @@ -411,16 +658,16 @@ (define create-thunk (case-lambda [(fn) fn] - [(fn arg1) (lambda () (fn (value-now arg1)))] - [(fn arg1 arg2) (lambda () (fn (value-now arg1) (value-now arg2)))] - [(fn arg1 arg2 arg3) (lambda () (fn (value-now arg1) - (value-now arg2) - (value-now arg3)))] - [(fn . args) (lambda () (apply fn (map value-now args)))])) - + [(fn arg1) (lambda () (fn (value-now/no-copy arg1)))] + [(fn arg1 arg2) (lambda () (fn (value-now/no-copy arg1) (value-now/no-copy arg2)))] + [(fn arg1 arg2 arg3) (lambda () (fn (value-now/no-copy arg1) + (value-now/no-copy arg2) + (value-now/no-copy arg3)))] + [(fn . args) (lambda () (apply fn (map value-now/no-copy args)))])) + (define (lift strict? fn . args) (if (snap?) ;; maybe fix later to handle undefined-strictness - (apply fn (map value-now args)) + (apply fn (map value-now/no-copy args)) (with-continuation-mark 'frtime 'lift-active (if (ormap behavior? args) @@ -432,13 +679,6 @@ undefined (apply fn args)))))) - (define (last) - (let ([prev #f]) - (lambda (v) - (let ([ret (if prev prev v)]) - (set! prev v) - ret)))) - (define (extract k evs) (if (cons? evs) (let ([ev (first evs)]) @@ -466,10 +706,10 @@ (let ([stream (signal-value (first args))]) stream #;(if (undefined? stream) - stream - (if (equal? stream (econs undefined undefined)) - stream - (econs undefined stream)))) + stream + (if (equal? stream (econs undefined undefined)) + stream + (econs undefined stream)))) (first streams)) (fix-streams (rest streams) (rest args))))) @@ -489,19 +729,19 @@ (esc (void)))))] [proc-k (lambda (evt) (proc emit suspend evt) (set! proc-k #f))]) (let ([thunk (lambda () - (when (ormap undefined? streams) - ;(fprintf (current-error-port) "had an undefined stream~n") - (set! streams (fix-streams streams args))) - (let loop () - (extract (lambda (the-event) - (when proc-k - (call/cc - (lambda (k) - (set! esc k) - (proc-k the-event)))) (loop)) - streams)) - (set! streams (map signal-value args)) - out)]) + (when (ormap undefined? streams) + ;(fprintf (current-error-port) "had an undefined stream~n") + (set! streams (fix-streams streams args))) + (let loop () + (extract (lambda (the-event) + (when proc-k + (call/cc + (lambda (k) + (set! esc k) + (proc-k the-event)))) (loop)) + streams)) + (set! streams (map signal-value args)) + out)]) (apply proc->signal thunk args))))) (define (event-processor proc . args) @@ -522,7 +762,7 @@ (set! streams (map signal-value args)) out)]) (apply proc->signal thunk args))) - + (define (event-producer2 proc . deps) (let* ([out (econs undefined undefined)] [proc/emit (proc @@ -531,28 +771,6 @@ (set! out (erest out)) val))]) (apply proc->signal (lambda the-args (apply proc/emit the-args) out) deps))) - - #;(define-syntax (event-processor stx) - (syntax-case stx () - [(src-event-processor proc args) - (with-syntax ([emit (datum->syntax-object (syntax src-event-processor) 'emit)] - [the-event (datum->syntax-object - (syntax src-event-processor) 'the-event)]) - (syntax (let* ([out (econs undefined undefined)] - [emit (lambda (val) - (set-erest! out (econs val undefined)) - (set! out (erest out)))] - [streams (map signal-value args)] - [thunk (lambda () - (when (ormap undefined? streams) - (fprintf (current-error-port) "had an undefined stream~n") - (set! streams (fix-streams streams args))) - (let loop () - (extract (lambda (the-event) proc (loop)) - streams)) - (set! streams (map signal-value args)) - out)]) - (apply proc->signal thunk args))))])) (define-syntax (event-producer stx) (syntax-case stx () @@ -578,11 +796,11 @@ (unregister ret init) (set! init (value-now e-b)) (register ret init) + (set-signal-producers! ret (list e-b init)) (set-signal-depth! ret (max (signal-depth ret) - (add1 (safe-signal-depth init))))) - (if (signal? init) - (signal-value init) - init)] + (add1 (safe-signal-depth init)))) + (iq-resort)) + (value-now init)] [(msg) e]) e-b init))))) @@ -610,7 +828,7 @@ (event-producer2 (lambda (emit) (lambda the-args - (emit (value-now/copy b)))) + (emit (value-now b)))) b)) (define (event-forwarder sym evt f+l) @@ -684,7 +902,7 @@ (define nothing (void));(string->uninterned-symbol "nothing")) (define (nothing? v) (eq? v nothing)) - + ; =#=> : event[a] (a -> b U nothing) -> event[b] (define (e . =#=> . f) (event-processor @@ -733,13 +951,15 @@ ; hold : a event[a] -> behavior[a] (define hold (opt-lambda (e [init undefined]) - (proc->signal - (let ([b true]) - (lambda () - (if b - (begin (set! b false) init) - (efirst (signal-value e))))) - e))) + (let ([val init]) + (let* ([updator (event-processor + (lambda (emit) + (lambda (the-event) + (set! val the-event) + (emit the-event))) + e)] + [rtn (proc->signal (lambda () updator val) updator)]) + rtn)))) ; event[a] signal[b]* -> event[(list a b*)] (define (snapshot-e e . bs) @@ -748,9 +968,9 @@ (lambda (the-event) (emit (cons the-event (map value-now bs))))) e)) - + (define (snapshot/apply fn . args) - (apply fn (map value-now args))) + (apply (value-now/no-copy fn) (map value-now/no-copy args))) ; (a b* -> c) event[a] signal[b]* -> event[c] (define (snapshot-map-e fn ev . bs) @@ -759,7 +979,7 @@ (lambda (the-event) (emit (apply fn the-event (map value-now bs))))) ev)) - + (define-syntax (event-loop-help stx) (syntax-case stx () [(_ ([name expr] ...) @@ -790,25 +1010,32 @@ ([name expr] ...) new-clause ...) )])) - + (define update (case-lambda [(b) (update0 b)] [(b a) (update1 b a)])) - (define-values (iq-enqueue iq-dequeue iq-empty?) + (define-values (iq-enqueue iq-dequeue iq-empty? iq-resort) (let* ([depth (lambda (msg) (if (signal? msg) (signal-depth msg) (signal-depth (first msg))))] [heap (make-heap - (lambda (b1 b2) (< (depth b1) (depth b2))) - eq?)]) + (lambda (b1 b2) (< (depth b1) (depth b2))) + eq?)]) (values (lambda (b) (heap-insert heap b)) (lambda () (heap-pop heap)) - (lambda () (heap-empty? heap))))) + (lambda () (heap-empty? heap)) + (lambda () (let loop ([elts empty]) + (if (heap-empty? heap) + (let loop ([elts elts]) + (when (cons? elts) + (heap-insert heap (first elts)) + (loop (rest elts)))) + (loop (cons (heap-pop heap) elts)))))))) ; *** will have to change ... *** (define (propagate b) @@ -839,12 +1066,11 @@ [(and (? signal?) (= signal-value value) (= signal-thunk thunk) - (= signal-guards guards)) + (= signal-custodians custs)) (set-signal-stale?! b #f) - (let ([new-value (parameterize ([current-guards guards]) + (let ([new-value (parameterize ([current-custs custs]) (thunk))]) - ; consider modifying this test in order to support, e.g., mutable structs - (when (or (vector? new-value) (not (equal? value new-value))) + (when (or (signal:compound? b) (not (equal? value new-value))) (set-signal-value! b new-value) (propagate b)))] [_ (void)])) @@ -856,7 +1082,6 @@ (= signal-thunk thunk)) (set-signal-stale?! b #f) (let ([new-value (thunk a)]) - ; consider modifying this test in order to support, e.g., mutable structs (when (not (equal? value new-value)) (set-signal-value! b new-value) (propagate b)))] @@ -893,35 +1118,29 @@ (lambda () (match (heap-peak heap) [(ms _) ms])) (lambda () (heap-empty? heap))))) - (define exceptions - (event-receiver)) - (define notifier - (event-producer2 - (lambda (emit) - (lambda the-args - (when (cons? the-args) - (let ([arg (first the-args)]) - (! (first arg) ((second arg))))))))) - (set-signal-depth! notifier +inf.0) - ;; the manager of all signals and event streams (define man (spawn/name 'frtime-heart (let ([named-providers (make-hash-table)] - [cur-beh #f]) + [cur-beh #f] + [notifications empty]) (let outer () (with-handlers ([exn:fail? (lambda (exn) (when (and cur-beh - (andmap (lambda (g) ((guard-trans g) (value-now (guard-signal g)))) - (signal-guards cur-beh))) - #;(when (empty? (continuation-mark-set->list (exn-continuation-marks exn) 'frtime)) - (set-exn-continuation-marks! exn (signal-continuation-marks cur-beh))) + #;(not (undefined? (signal-value cur-beh)))) + (when (empty? (continuation-mark-set->list + (exn-continuation-marks exn) 'frtime)) + (set! exn (make-exn:fail (exn-message exn) + (signal-continuation-marks + cur-beh)))) + ;(raise exn) (iq-enqueue (list exceptions (list exn cur-beh))) (when (behavior? cur-beh) - (undef cur-beh))) + (undef cur-beh) + #;(kill-signal cur-beh))) (outer))]) (let inner () @@ -934,41 +1153,44 @@ (current-milliseconds))] [else #f]) (void)] - [(? signal? b) - (iq-enqueue b) - (loop)] - [($ external-event recip-val-pairs) - (for-each iq-enqueue recip-val-pairs) - (loop)] - [($ alarm ms beh) - (schedule-alarm ms beh) - (loop)] - [($ reg inf sup ret) - (register inf sup) - (! ret man) - (loop)] - [($ unreg inf sup) - (unregister inf sup) - (loop)] - [('bind sym evt) - (let ([forwarder+listeners (cons #f empty)]) - (set-car! forwarder+listeners - (event-forwarder sym evt forwarder+listeners)) - (hash-table-put! named-providers sym forwarder+listeners)) - (loop)] - [('remote-reg tid sym) - (let ([f+l (hash-table-get named-providers sym)]) - (when (not (member tid (rest f+l))) - (set-rest! f+l (cons tid (rest f+l))))) - (loop)] - [('remote-evt sym val) - (iq-enqueue (list (hash-table-get named-dependents sym (lambda () dummy)) val)) - (loop)] - [msg - (fprintf (current-error-port) - "frtime engine: msg not understood: ~a~n" - msg) - (loop)])) + [(? signal? b) + (iq-enqueue b) + (loop)] + [($ external-event recip-val-pairs) + (for-each iq-enqueue recip-val-pairs) + (loop)] + [($ alarm ms beh) + (schedule-alarm ms beh) + (loop)] + [('run-thunk rtn-pid thunk) + (with-handlers + ([exn:fail? (lambda (exn) + (set! notifications + (cons (list rtn-pid 'exn exn) + notifications)))]) + (set! notifications (cons (list rtn-pid 'val (thunk)) + notifications))) + (loop)] + [('bind sym evt) + (let ([forwarder+listeners (cons #f empty)]) + (set-car! forwarder+listeners + (event-forwarder sym evt forwarder+listeners)) + (hash-table-put! named-providers sym forwarder+listeners)) + (loop)] + [('remote-reg tid sym) + (let ([f+l (hash-table-get named-providers sym)]) + (when (not (member tid (rest f+l))) + (set-rest! f+l (cons tid (rest f+l))))) + (loop)] + [('remote-evt sym val) + (iq-enqueue + (list (hash-table-get named-dependents sym (lambda () dummy)) val)) + (loop)] + [msg + (fprintf (current-error-port) + "frtime engine: msg not understood: ~a~n" + msg) + (loop)])) ;; enqueue expired timers for execution (let loop () @@ -980,7 +1202,7 @@ (set-signal-stale?! beh #t) (iq-enqueue beh))) (loop))) - + ;; process internal updates (let loop () (unless (iq-empty?) @@ -995,11 +1217,28 @@ (set! cur-beh #f)]) (loop))) + (for-each (lambda (lst) + (! (first lst) (rest lst))) + notifications) + (set! notifications empty) + (inner))))))) - + (define man? (opt-lambda ([v (self)]) (eq? v man))) + + (define exceptions + (event-receiver)) + + (define notifier + (event-producer2 + (lambda (emit) + (lambda the-args + (when (cons? the-args) + (let ([arg (first the-args)]) + (! (first arg) ((second arg))))))))) + (set-signal-depth! notifier +inf.0) (define dummy (proc->signal void)) @@ -1028,13 +1267,13 @@ (define (send-event rcvr val) (! man (make-external-event (list (list rcvr val))))) - + (define (send-synchronous-event rcvr val) (when (man?) (error 'send-synchronous-event "already in frtime engine (would deadlock)")) (! man (make-external-event (list (list rcvr val) (list notifier (list (self) (lambda () man)))))) (receive [(? man?) (void)])) - + (define (send-synchronous-events rcvr-val-pairs) (when (man?) (error 'send-synchronous-events "already in frtime engine (would deadlock)")) @@ -1042,7 +1281,7 @@ (unless (ormap signal? (map first rcvr-val-pairs)) (error "not signals")) (! man (make-external-event (cons (list notifier (list (self) (lambda () man))) rcvr-val-pairs))) (receive [(? man?) (void)])) - + (define (sync/read . signals) (if (man?) (apply values (map value-now signals)) @@ -1088,17 +1327,17 @@ (event-producer (let ([now (current-milliseconds)]) (snapshot (dtime) - (when (cons? the-args) - (set! myself (first the-args))) - (when (and dtime (>= now (+ last-time dtime))) - (emit (thunk)) - (set! last-time now)) - (when dtime - (schedule-alarm (+ last-time dtime) myself)))) + (when (cons? the-args) + (set! myself (first the-args))) + (when (and dtime (>= now (+ last-time dtime))) + (emit (thunk)) + (set! last-time now)) + (when dtime + (schedule-alarm (+ last-time dtime) myself)))) dtime))]) (send-event ret ret) ret)) - + (define (make-time-b ms) (let ([ret (proc->signal void)]) (set-signal-thunk! ret @@ -1112,17 +1351,17 @@ (define never-e (changes #f)) - (define milliseconds (make-time-b 10)) + (define milliseconds (make-time-b 20)) (define time-b milliseconds) - + (define seconds (let ([ret (proc->signal void)]) (set-signal-thunk! ret - (lambda () - (let ([s (current-seconds)] - [t (current-milliseconds)]) - (schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret) - s))) + (lambda () + (let ([s (current-seconds)] + [t (current-milliseconds)]) + (schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret) + s))) (set-signal-value! ret ((signal-thunk ret))) ret)) @@ -1130,7 +1369,7 @@ ; signal[a] signal[num] -> signal[a] (define (delay-by beh ms-b) (letrec ([last (cons (cons (if (zero? (value-now ms-b)) - (value-now beh) + (value-now/no-copy beh) undefined) (current-milliseconds)) empty)] @@ -1150,13 +1389,13 @@ [consumer (proc->signal (lambda () (let* ([now (current-milliseconds)] - [new (value-now/copy beh)] + [new (value-now beh)] [ms (value-now ms-b)]) (when (not (equal? new (caar last))) (set-rest! last (cons (cons new now) empty)) (set! last (rest last)) - (schedule-alarm (+ now ms) producer)))) + (schedule-alarm (+ now ms) producer)))) beh ms-b)]) producer)) @@ -1167,7 +1406,7 @@ ; (instead of milliseconds) ; integral : signal[num] signal[num] -> signal[num] (define integral - (opt-lambda (b [ms-b 10]) + (opt-lambda (b [ms-b 20]) (letrec ([accum 0] [last-time (current-milliseconds)] [last-val (value-now b)] @@ -1180,7 +1419,7 @@ consumer (lambda () (let ([now (current-milliseconds)]) - (if (> now (+ last-time 10)) + (if (> now (+ last-time 20)) (begin (when (not (number? last-val)) (set! last-val 0)) @@ -1227,11 +1466,11 @@ (define new-cell (opt-lambda ([init undefined]) (switch (event-receiver) init))) - + ; set-cell! : cell[a] a -> void (define (set-cell! ref beh) (! man (make-external-event (list (list ((signal-thunk ref) #t) beh))))) - + (define (synchronize) (when (man?) (error 'synchronize "already in frtime engine (would deadlock)")) @@ -1282,10 +1521,7 @@ (set! cur (- 1 cur)) cur))))) - (define drs-eventspace #f) - (define (set-eventspace evspc) - (set! drs-eventspace evspc)) (define raise-exceptions (new-cell #t)) (define exception-raiser @@ -1293,72 +1529,13 @@ (thread (lambda () (raise (car p)))))))) - (define value-snip-copy% - (class string-snip% - (init-field current parent) - (inherit get-admin) - (define/public (set-current c) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (lambda () - (set! current c) - (let ([admin (get-admin)]) - (when admin - (send admin needs-update this 0 0 2000 100))))))) - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (send current draw dc x y left top right bottom dx dy draw-caret)) - (super-instantiate (" ")))) - - (define (make-snip bhvr) - (make-object string-snip% - (let ([tmp (cond - [(behavior? bhvr) (value-now bhvr)] - [(event? bhvr) (signal-value bhvr)] - [else bhvr])]) - (cond - [(econs? tmp) (format "#" (efirst tmp))] - [(undefined? tmp) ""] - [else (expr->string tmp)])))) - - (define value-snip% - (class string-snip% - (init-field bhvr) - (field [copies empty] - [loc-bhvr (proc->signal (lambda () (update)) bhvr)] - [current (make-snip bhvr)]) - - (define/override (copy) - (let ([ret (make-object value-snip-copy% current this)]) - (set! copies (cons ret copies)) - ret)) - - (define/public (update) - (set! current (make-snip bhvr)) - (for-each (lambda (copy) (send copy set-current current)) copies)) - - (super-instantiate (" ")))) - - (define (render beh as-snip?) - (cond - [as-snip? (watch beh)] - [(undefined? (value-now beh)) ""] - [(behavior? beh) (format "#" (value-now beh))] - [(event? beh) (format "#" (efirst (signal-value beh)))] - [else beh])) - - (define (watch beh) - (cond - [(undefined? beh) - (make-object string-snip% "")] - [(signal? beh) (make-object value-snip% beh)] - [else beh])) (define (find pred lst) (cond - [(empty? lst) #f] - [(pred (first lst)) (first lst)] - [else (find pred (rest lst))])) - + [(empty? lst) #f] + [(pred (first lst)) (first lst)] + [else (find pred (rest lst))])) + (define-syntax (frp:provide stx) (syntax-case stx () [(_ . clauses) @@ -1377,7 +1554,7 @@ (begin clause ... (define (tmp-name . args) - (apply lift true fun-name args)) + (apply lift true fun-name args)) ... (provide (rename tmp-name fun-name) ...))))] [(lifted:nonstrict . ids) @@ -1390,14 +1567,14 @@ (begin clause ... (define (tmp-name . args) - (apply lift false fun-name args)) + (apply lift false fun-name args)) ... (provide (rename tmp-name fun-name) ...))))] [provide-spec (syntax (begin clause ... (provide provide-spec)))])])) (syntax (begin)) (syntax->list (syntax clauses)))])) - + (define (ensure-no-signal-args val name) (if (procedure? val) (lambda args @@ -1442,7 +1619,7 @@ (apply lift true tmp-name args)) ...))] [(as-is:unchecked module id ...) - (syntax (begin clause ... (require (only module id) ...)))] + (syntax (begin clause ... (require (rename module id id) ...)))] [(as-is module . ids) (with-syntax ([(fun-name ...) (syntax ids)] [(tmp-name ...) (generate-temporaries/loc stx #'ids)]) @@ -1461,30 +1638,12 @@ (syntax->list #'clauses))])) (define undefined?/lifted (lambda (arg) (lift false undefined? arg))) - (define frp:pair? (lambda (arg) (lift true pair? arg))) (define frp:null? (lambda (arg) (lift true null? arg))) - (define frp:cons (lambda (a d) (lift false cons a d))) - (define frp:car (lambda (arg) (lift true car arg))) - (define frp:cdr (lambda (arg) (lift true cdr arg))) + + ;(define frp:cons (lambda (a d) (lift false cons a d))) + ;(define frp:car (lambda (arg) (lift true car arg))) + ;(define frp:cdr (lambda (arg) (lift true cdr arg))) -#| - (define (frp:cons a d) - (if (or (behavior? a) - (behavior? d)) - (proc->signal (let ([c (cons a d)]) - (lambda () c)) a d) - (cons a d))) - - (define (frp:car c) - (if (behavior? c) - (car (signal-value c)) - (car c))) - - (define (frp:cdr c) - (if (behavior? c) - (cdr (signal-value c)) - (cdr c))) -|# (provide module #%app #%top @@ -1502,16 +1661,52 @@ (rename frp:null? null?) (rename frp:car car) (rename frp:cdr cdr) + (rename frp:make-struct-type make-struct-type) + (rename frp:make-struct-field-accessor make-struct-field-accessor) + (rename frp:vector vector) + (rename frp:vector-ref vector-ref) (rename undefined?/lifted undefined?) - (all-defined-except frp:if - frp:require - frp:provide - frp:letrec - frp:match - frp:cons - frp:pair? - frp:null? - frp:car - frp:cdr - undefined? - undefined?/lifted))) + + (rename undefined? frp:undefined?) + ; (rename frp:eq? eq?) + + ;added for quasiquote + (rename frp:empty? empty?) + (rename frp:list list) + (rename frp:list* list*) + (rename frp:list? list?) + (rename frp:append append) + + (rename frp:define-struct define-struct) + ; (rename frp:quasiquote quasiquote) + ; (rename frp:qq-append qq-append) + ; (rename frp:unquote-splicing unquote-splicing) + (all-defined-except + frp:if + frp:require + frp:provide + frp:letrec + frp:match + frp:cons + frp:pair? + frp:null? + frp:car + frp:cdr + frp:make-struct-type + frp:make-struct-field-accessor + frp:vector + frp:vector-ref + ; frp:quasiquote + ; frp:qq-append + ; frp:unquote-splicing + undefined? + undefined?/lifted + frp:define-struct + ; reconstruct + + ;added for quasiquote + frp:list + frp:list* + frp:list? + frp:append + ))) diff --git a/collects/frtime/frtime-tool.ss b/collects/frtime/frtime-tool.ss index fc13adb10e..7d31625a49 100644 --- a/collects/frtime/frtime-tool.ss +++ b/collects/frtime/frtime-tool.ss @@ -26,8 +26,8 @@ "FrTime without libraries") (define/public (get-language-url) #f) (define/public (get-reader) - (lambda (name port offsets) - (let ([v (read-syntax name port offsets)]) + (lambda (name port) + (let ([v (read-syntax name port)]) (if (eof-object? v) v (namespace-syntax-introduce v))))) diff --git a/collects/frtime/frtime.ss b/collects/frtime/frtime.ss index 00c87f59ca..77e8e04b03 100644 --- a/collects/frtime/frtime.ss +++ b/collects/frtime/frtime.ss @@ -1,410 +1,11 @@ -(module frtime (lib "frp.ss" "frtime") - - (require (all-except mzscheme - module - #%app - #%top - #%datum - #%plain-module-begin - #%module-begin - if - require - provide - letrec - match - cons car cdr pair? null? null - caar cdar cadr cddr caddr cdddr cadddr cddddr - ;undefined? - and - or - cond when unless - map ormap andmap assoc member) - (rename mzscheme mz:cons cons) - ;(rename mzscheme mz:and and) - ;(rename mzscheme mz:or or) - ;(lib "list.ss") - (lib "contract.ss") - (only "erl.ss" tid?)) +(module frtime (lib "mzscheme-utils.ss" "frtime") + (require (lib "lang-ext.ss" "frtime")) + (require (lib "frp-snip.ss" "frtime")) + (require (lib "ft-qq.ss" "frtime")) - (define-syntax cond - (syntax-rules (else =>) - [(_ [else result1 result2 ...]) - (begin result1 result2 ...)] - [(_ [test => result]) - (let ([temp test]) - (if temp (result temp)))] - [(_ [test => result] clause1 clause2 ...) - (let ([temp test]) - (if temp - (result temp) - (cond clause1 clause2 ...) - (cond clause1 clause2 ...)))] - [(_ [test]) test] - [(_ [test] clause1 clause2 ...) - (let ((temp test)) - (if temp - temp - (cond clause1 clause2 ...) - (cond clause1 clause2 ...)))] - [(_ [test result1 result2 ...]) - (if test (begin result1 result2 ...))] - [(_ [test result1 result2 ...] - clause1 clause2 ...) - (if test - (begin result1 result2 ...) - (cond clause1 clause2 ...) - (cond clause1 clause2 ...))])) + ;(provide-for-syntax (rename (lib "mzscheme-utils.ss" "frtime") syntax->list syntax->list)) - (define-syntax and - (syntax-rules () - [(_) #t] - [(_ exp) exp] - [(_ exp exps ...) (if exp - (and exps ...) - #f)])) - - (define-syntax or - (syntax-rules () - [(_) #f] - [(_ exp) exp] - [(_ exp exps ...) (let ([v exp]) - (if v - v - (or exps ...) - (or-undef exps ...)))])) - - (define-syntax or-undef - (syntax-rules () - [(_) undefined] - [(_ exp) (let ([v exp]) (if v v undefined))] - [(_ exp exps ...) (let ([v exp]) - (if v - v - (or-undef exps ...) - (or-undef exps ...)))])) - - (define-syntax when - (syntax-rules () - [(_ test body ...) (if test (begin body ...))])) - - (define-syntax unless - (syntax-rules () - [(_ test body ...) (if (not test) (begin body ...))])) - - (define (ormap proc lst) - (and (pair? lst) - (or (proc (car lst)) (ormap proc (cdr lst))))) - - (define (andmap proc lst) - (or (null? lst) - (and (proc (car lst)) (andmap proc (cdr lst))))) - - (define (caar v) - (car (car v))) - - (define (cdar v) - (cdr (car v))) - - (define (cadr v) - (car (cdr v))) - - (define (cddr v) - (cdr (cdr v))) - - (define (caddr v) - (car (cddr v))) - - (define (cdddr v) - (cdr (cddr v))) - - (define (cadddr v) - (car (cdddr v))) - - (define (cddddr v) - (cdr (cdddr v))) - -; (define list -; (case-lambda -; [() null] -; [(a . d) (cons a (apply list d))])) - - (define-syntax frtime:case - (syntax-rules () - [(_ exp clause ...) - (let ([v exp]) - (vcase v clause ...))])) - - (define-syntax vcase - (syntax-rules (else) - [(_ v [else exp ...]) - (begin exp ...)] - [(_ v [dl exp ...]) - (if (lift #t memv v (quote dl)) - (begin exp ...))] - [(_ v [dl exp ...] clause ...) - (if (lift #t memv v (quote dl)) - (begin exp ...) - (vcase v clause ...))])) - - (define map - (case-lambda - [(f l) (if (pair? l) - (cons (f (car l)) (map f (cdr l))) - null)] - [(f l1 l2) (if (and (pair? l1) (pair? l2)) - (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2))) - null)] - [(f l . ls) (if (and (pair? l) (andmap pair? ls)) - (cons (lift #f apply f (car l) (map car ls)) (lift #f apply map f (cdr l) (map cdr ls))) - null)])) - - ; TO DO: assoc member [vectors] structs - ; first cut: could be made more efficient by creating - ; a dedicated signal to update each element of the vector - (define (frtime:vector2 . args) - (if (ormap behavior? args) - (let* ([n (length args)] - [v1 (make-vector n)] - [v2 (make-vector n)]) - (apply - proc->signal - (lambda () - (let ([tmp v2]) - (set! v2 v1) - (set! v1 tmp)) - (let loop ([i 0] [args args]) - (when (< i n) - (vector-set! v1 i (value-now (car args))) - (loop (add1 i) (cdr args)))) - v1) - args)) - (apply vector args))) - - (define (frtime:vector . args) - (if (ormap behavior? args) - (let* ([n (length args)] - [vec (make-vector n)] - [arg-behs - ; initialize the vector - (let loop ([i 0] [args args] [ret null]) - (if (< i n) - (loop (add1 i) - (cdr args) - (mz:cons - (let ([arg (car args)]) - (proc->signal - (lambda () - (let ([v (value-now arg)]) - (vector-set! vec i v) - v)) - arg)) - ret)) - ret))]) - (apply proc->signal (lambda () arg-behs vec) arg-behs)) - (apply vector args))) - - (define ((behaviorof pred) x) - (let ([v (value-now x)]) - (or (undefined? v) - (pred v)))) - - (define (lift-strict . args) - (apply lift #t args)) - - ;; Imported from mzscheme: - (provide (lifted + - * / = eq? equal? eqv? < > <= >= list? add1 cos sin tan symbol->string symbol? - number->string exp expt even? odd? list-ref string-append eval - sub1 sqrt not number? string? zero? min max modulo - string->number void? rational? char? char-upcase char-ci>=? char-ci<=? - string>=? char-upper-case? char-alphabetic? - string? - string-locale-ci? charstring substring string->list - string-ci=? string<=? string-ci<=? string>? string-locale=? char<=? char->integer integer->char boolean? - integer? quotient remainder positive? negative? inexact->exact exact->inexact - make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact? - char-whitespace? assq assv memq memv list-tail reverse append length seconds->date - expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks - exn:fail? - ) - (rename frtime:case case) - (rename frtime:vector vector) - (rename frtime:vector2 vector2) - (rename eq? mzscheme:eq?) - make-exn:fail - make-namespace namespace? namespace-symbol->identifier namespace-variable-value - namespace-set-variable-value! namespace-undefine-variable! namespace-mapped-symbols - parameterize current-seconds current-milliseconds current-inexact-milliseconds - call-with-values make-parameter - null gensym collect-garbage - error define-struct set! printf fprintf current-error-port for-each void - procedure-arity-includes? raise-type-error raise thread - current-continuation-marks - raise-mismatch-error require-for-syntax define-syntax syntax-rules syntax-case - set-eventspace - install-errortrace-key - (lifted:nonstrict apply format list list*) - general-event-processor - lambda - case-lambda - define-values - define - let - let-values - let* - let*-values - begin - begin0 - quote - quasiquote - unquote - values - syntax - let/ec - with-handlers - delay - force - random - sleep - ) - - ;; Defined in frp.ss: - (provide module - #%app - #%top - #%datum - #%plain-module-begin - #%module-begin - render - require - provide - letrec - undefined - undefined? - if - lift - match - time-b - seconds - milliseconds - exceptions - cons - pair? - null? - car - cdr - signal-value - signal? - behavior? - event? - event-receiver? - frtime-version - raise-exceptions - synchronize - frp:send - snapshot - snapshot-all - snapshot/sync - snapshot/apply - ) - - - ; (define (behavior? v) (not (event? v))) - - ;; Defined in this module: - (provide when unless behaviorof -=> nothing nothing? - cond and or andmap ormap map lift-strict never-e - caar cadr cdar cddr caddr cdddr cadddr cddddr - magic value-nowable?) - - ; returns true on values that can be passed to value-now - ; (e.g. behaviors or constants) - ; note difference from behavior?, which returns true only - ; on values that may actually change and should be monitored - ; for change - (define (value-nowable? v) - #t) - ;(not (and (signal? v) (event-cons? (signal-value v))))) - - (provide/contract - [proc->signal (((-> any/c)) - any/c - . ->* . (signal?))] - - [value-now (value-nowable? . -> . any)] - - [until (value-nowable? value-nowable? . -> . behavior?)] - - [switch ((event?) (value-nowable?) . opt-> . signal?)] - - [merge-e (() (listof event?) . ->* . (event?))] - - [once-e (event? . -> . event?)] - - [changes (value-nowable? . -> . event?)] - - [event-receiver (-> event?)] - - [when-e (value-nowable? . -> . event?)] - - [while-e (value-nowable? value-nowable? . -> . event?)] - - [==> (event? (any/c . -> . any) . -> . event?)] - - [=#> (event? (any/c . -> . any) . -> . event?)] - - [=#=> (event? (any/c . -> . (union any/c nothing?)) . -> . event?)] - - [map-e ((any/c . -> . any) event? . -> . event?)] - - [filter-e ((any/c . -> . any) event? . -> . event?)] - - [filter-map-e ((any/c . -> . (union any/c nothing?)) event? . -> . event?)] - - [collect-e (event? any/c (any/c any/c . -> . any) . -> . event?)] - - [collect-b (event? any/c (any/c any/c . -> . any) . -> . behavior?)] - - [accum-e (event? any/c . -> . event?)] - - [accum-b (event? any/c . -> . behavior?)] - - [send-event (event-receiver? any/c . -> . void?)] - - [send-synchronous-event (event-receiver? any/c . -> . void?)] - - [send-synchronous-events (list? . -> . void?)] - - [hold ((event?) (value-nowable?) . opt-> . behavior?)] - - [new-cell (() (any/c) . opt-> . (union behavior? event?))] - - [set-cell! ((union behavior? event?) any/c . -> . void?)] - - [snapshot-e ((event?) any/c . ->* . (event?))] - - [snapshot-map-e ((procedure? event?) - any/c ;; the behaviors - . ->* . - (event?))] - - [derivative (value-nowable? . -> . behavior?)] - - [integral ((value-nowable?) (value-nowable?) . opt-> . behavior?)] - - [delay-by (value-nowable? value-nowable? . -> . signal?)] - - [inf-delay (value-nowable? . -> . behavior?)] - - [bind (symbol? event? . -> . event?)] - - [remote-reg (tid? symbol? . -> . event?)] - - )) + (provide (all-from (lib "mzscheme-utils.ss" "frtime")) + (all-from (lib "lang-ext.ss" "frtime")) + (all-from (lib "frp-snip.ss" "frtime")) + (all-from (lib "ft-qq.ss" "frtime")))) diff --git a/collects/frtime/ft-qq.ss b/collects/frtime/ft-qq.ss new file mode 100644 index 0000000000..c3ba9a289b --- /dev/null +++ b/collects/frtime/ft-qq.ss @@ -0,0 +1,178 @@ +(module ft-qq (lib "mzscheme-core.ss" "frtime") ;(lib "frp.ss" "frtime") + (require (as-is:unchecked mzscheme define-values define-syntaxes require-for-syntax + raise-type-error quote unquote unquote-splicing)) + ;(require-for-syntax (lib "frp.ss" "frtime")) + (require-for-syntax #%stx) + + + (define-values (frp:qq-append) + (lambda (a b) + (if (list? a) + (append a b) + (raise-type-error 'unquote-splicing "proper list" a)))) + + (define-syntaxes (frp:quasiquote) + (let ([here (quote-syntax here)] ; id with module bindings, but not lexical + [unquote-stx (quote-syntax unquote)] + [unquote-splicing-stx (quote-syntax unquote-splicing)]) + (lambda (in-form) + (if (identifier? in-form) + (raise-syntax-error #f "bad syntax" in-form)) + (let-values + (((form) (if (stx-pair? (stx-cdr in-form)) + (if (stx-null? (stx-cdr (stx-cdr in-form))) + (stx-car (stx-cdr in-form)) + (raise-syntax-error #f "bad syntax" in-form)) + (raise-syntax-error #f "bad syntax" in-form))) + ((normal) + (lambda (x old) + (if (eq? x old) + (if (stx-null? x) + (quote-syntax ()) + (list (quote-syntax quote) x)) + x))) + ((apply-cons) + (lambda (a d) + (if (stx-null? d) + (list (quote-syntax list) a) + (if (if (pair? d) + (module-identifier=? (quote-syntax list) (car d)) + #f) + (list* (quote-syntax list) a (cdr d)) + (list (quote-syntax cons) a d)))))) + (datum->syntax-object + here + (normal + (letrec-values + (((qq) + (lambda (x level) + (let-values + (((qq-list) + (lambda (x level) + (let-values + (((old-first) (stx-car x))) + (let-values + (((old-second) (stx-cdr x))) + (let-values + (((first) (qq old-first level))) + (let-values + (((second) (qq old-second level))) + (let-values + () + (if (if (eq? first old-first) + (eq? second old-second) + #f) + x + (apply-cons + (normal first old-first) + (normal second old-second))))))))))) + (if (stx-pair? x) + (let-values + (((first) (stx-car x))) + (if (if (if (identifier? first) + (module-identifier=? first unquote-stx) + #f) + (stx-list? x) + #f) + (let-values + (((rest) (stx-cdr x))) + (if (let-values + (((g35) (not (stx-pair? rest)))) + (if g35 g35 (not (stx-null? (stx-cdr rest))))) + (raise-syntax-error + 'unquote + "expects exactly one expression" + in-form + x)) + (if (zero? level) + (stx-car rest) + (qq-list x (sub1 level)))) + (if (if (if (identifier? first) + (module-identifier=? first (quote-syntax frp:quasiquote)) + #f) + (stx-list? x) + #f) + (qq-list x (add1 level)) + (if (if (if (identifier? first) + (module-identifier=? first unquote-splicing-stx) + #f) + (stx-list? x) + #f) + (raise-syntax-error + 'unquote-splicing + "invalid context within quasiquote" + in-form + x) + (if (if (stx-pair? first) + (if (identifier? (stx-car first)) + (if (module-identifier=? (stx-car first) + unquote-splicing-stx) + (stx-list? first) + #F) + #f) + #f) + (let-values + (((rest) (stx-cdr first))) + (if (let-values + (((g34) (not (stx-pair? rest)))) + (if g34 + g34 + (not (stx-null? (stx-cdr rest))))) + (raise-syntax-error + 'unquote + "expects exactly one expression" + in-form + x)) + (let-values + (((uqsd) (stx-car rest)) + ((old-l) (stx-cdr x)) + ((l) (qq (stx-cdr x) level))) + (if (zero? level) + (let-values + (((l) (normal l old-l))) + (let-values + () + (list (quote-syntax frp:qq-append) uqsd l))) + (let-values + (((restx) (qq-list rest (sub1 level)))) + (let-values + () + (if (if (eq? l old-l) + (eq? restx rest) + #f) + x + (apply-cons + (apply-cons + (quote-syntax (quote unquote-splicing)) + (normal restx rest)) + (normal l old-l)))))))) + (qq-list x level)))))) + (if (if (syntax? x) + (vector? (syntax-e x)) + #f) + (let-values + (((l) (vector->list (syntax-e x)))) + (let-values + (((l2) (qq l level))) + (let-values + () + (if (eq? l l2) + x + (list (quote-syntax list->vector) l2))))) + (if (if (syntax? x) (box? (syntax-e x)) #f) + (let-values + (((v) (unbox (syntax-e x)))) + (let-values + (((qv) (qq v level))) + (let-values + () + (if (eq? v qv) + x + (list (quote-syntax box) qv))))) + x))))))) + (qq form 0)) + form) + in-form))))) + + (provide ;(rename frp:qq-append qq-append) + (rename frp:quasiquote quasiquote))) diff --git a/collects/frtime/graphics-posn-less-unit.ss b/collects/frtime/graphics-posn-less-unit.ss index 1ae95d9599..9a6d7639eb 100644 --- a/collects/frtime/graphics-posn-less-unit.ss +++ b/collects/frtime/graphics-posn-less-unit.ss @@ -11,9 +11,10 @@ (lib "class100.ss") (lib "etc.ss") "erl.ss" - (only "frp.ss" event-receiver) - (rename "frp.ss" frp-man man) - (only "frp.ss" send-event) + ;(rename "frp-core.ss" event-receiver event-receiver) + ;(rename "frp-core.ss" frp-man man) + ;(rename "frp-core.ss" send-event send-event) + (lib "frp-core.ss" "frtime") "graphics-sig.ss") (provide graphics-posn-less@) diff --git a/collects/frtime/gui.ss b/collects/frtime/gui.ss index 70cd5ae281..c71a360e59 100644 --- a/collects/frtime/gui.ss +++ b/collects/frtime/gui.ss @@ -3,6 +3,7 @@ (all-except (lib "etc.ss") rec) (lib "list.ss") (lib "class.ss") + (rename (lib "frp-core.ss" "frtime") proc->signal proc->signal) (all-except (lib "mred.ss" "mred") send-event)) (define reactive-control<%> diff --git a/collects/frtime/lang-ext.ss b/collects/frtime/lang-ext.ss new file mode 100644 index 0000000000..9d2876e9e9 --- /dev/null +++ b/collects/frtime/lang-ext.ss @@ -0,0 +1,741 @@ +(module lang-ext mzscheme + (require (lib "frp-core.ss" "frtime") + (lib "etc.ss") + (lib "list.ss")) + + (require-for-syntax (lib "list.ss")) + + (define nothing (void));(string->uninterned-symbol "nothing")) + + (define (nothing? v) (eq? v nothing)) + + + + ; new-cell : behavior[a] -> behavior[a] (cell) + (define new-cell + (opt-lambda ([init undefined]) + (switch (event-receiver) init))) + + + (define (b1 . until . b2) + (proc->signal + (lambda () (if (undefined? (value-now b2)) + (value-now b1) + (value-now b2))) + ; deps + b1 b2)) + + (define-syntax (event-loop-help stx) + (syntax-case stx () + [(_ ([name expr] ...) + [e => body] ...) + (with-syntax ([args #'(name ...)]) + #'(accum-e + (merge-e + (e . ==> . (lambda (v) + (lambda (state) + (apply + (lambda args (body v)) + state)))) ...) + (list expr ...)))])) + + (define-syntax (event-loop stx) + + (define (add-arrow clause) + (syntax-case clause (=>) + [(e => body) #'(e => body)] + [(e body) #'(e => (lambda (_) body))])) + + (syntax-case stx () + [(_ ([name expr] ...) + clause ...) + (with-syntax ([(new-clause ...) + (map add-arrow (syntax->list #'(clause ...)))]) + #'(event-loop-help + ([name expr] ...) + new-clause ...) + )])) + + + (define undefined?/lifted (lambda (arg) (lift false undefined? arg))) + + (define (event? v) + (and (signal? v) + (if (undefined? (signal-value v)) + undefined + (event-cons? (signal-value v))))) + + + (define-syntax (event-producer stx) + (syntax-case stx () + [(src-event-producer expr dep ...) + (with-syntax ([emit (datum->syntax-object (syntax src-event-producer) 'emit)] + [the-args (datum->syntax-object + (syntax src-event-producer) 'the-args)]) + (syntax (let* ([out (econs undefined undefined)] + [emit (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)))]) + (proc->signal (lambda the-args expr out) dep ...))))])) + + ; switch : event[behavior] behavior -> behavior + (define switch + (opt-lambda (e [init undefined]) + (let* ([init (box init)] + [e-b (hold e (unbox init))]) + (rec ret + (proc->signal:switching + (case-lambda + [() + (when (not (eq? (unbox init) (signal-value e-b))) + (unregister ret (unbox init)) + (set-box! init (value-now/no-copy e-b)) + (register ret (unbox init)) + (set-signal-producers! ret (list e-b (unbox init))) + (set-signal-depth! ret (max (signal-depth ret) + (add1 (safe-signal-depth (unbox init))))) + (iq-resort)) + (value-now/no-copy (unbox init))] + [(msg) e]) + init + e-b + e-b (unbox init)))))) + + ; event ... -> event + (define (merge-e . args) + (apply event-processor + (lambda (emit) + (lambda (the-event) + (emit the-event))) + args)) + + (define (once-e e) + (let ([b #t]) + (rec ret (event-processor + (lambda (emit) + (lambda (the-event) + (when b + (set! b false) + (unregister ret e) + (emit the-event)))) + e)))) + + ; behavior[a] -> event[a] + (define (changes b) + (event-producer2 + (lambda (emit) + (lambda the-args + (emit (value-now b)))) + b)) + + + + ; when-e : behavior[bool] -> event + (define (when-e b) + (let* ([last (value-now b)]) + (event-producer2 + (lambda (emit) + (lambda the-args + (let ([current (value-now b)]) + (when (and (not last) current) + (emit current)) + (set! last current)))) + b))) + + ; while-e : behavior[bool] behavior[number] -> event + (define (while-e b interval) + (rec ret (event-producer2 + (lambda (emit) + (lambda the-args + (cond + [(value-now b) => + (lambda (v) + (emit v) + (schedule-alarm (+ (value-now interval) (current-milliseconds)) ret))]))) + b))) + + ; ==> : event[a] (a -> b) -> event[b] + (define (e . ==> . f) + (event-processor + (lambda (emit) + (lambda (the-event) + (emit ((value-now f) the-event)))) + e)) + + + + #| + (define (e . =>! . f) + (event-processor + ((value-now f) the-event) + (list e))) + |# + + ; -=> : event[a] b -> event[b] + (define-syntax -=> + (syntax-rules () + [(_ e k-e) (==> e (lambda (_) k-e))])) + + ; =#> : event[a] (a -> bool) -> event[a] + (define (e . =#> . p) + (event-processor + (lambda (emit) + (lambda (the-event) + (when (value-now (p the-event)) + (emit the-event)))) + e)) + + + + ; =#=> : event[a] (a -> b U nothing) -> event[b] + (define (e . =#=> . f) + (event-processor + (lambda (emit) + (lambda (the-event) + (let ([x (f the-event)]) + (unless (or (nothing? x) (undefined? x)) + (emit x))))) + e)) + + (define (map-e f e) + (==> e f)) + (define (filter-e p e) + (=#> e p)) + (define (filter-map-e f e) + (=#=> e f)) + + ; event[a] b (a b -> b) -> event[b] + (define (collect-e e init trans) + (event-processor + (lambda (emit) + (lambda (the-event) + (let ([ret (trans the-event init)]) + (set! init ret) + (emit ret)))) + e)) + + ; event[(a -> a)] a -> event[a] + (define (accum-e e init) + (event-processor + (lambda (emit) + (lambda (the-event) + (let ([ret (the-event init)]) + (set! init ret) + (emit ret)))) + e)) + + ; event[a] b (a b -> b) -> behavior[b] + (define (collect-b ev init trans) + (hold (collect-e ev init trans) init)) + + ; event[(a -> a)] a -> behavior[a] + (define (accum-b ev init) + (hold (accum-e ev init) init)) + + ; hold : a event[a] -> behavior[a] + (define hold + (opt-lambda (e [init undefined]) + (let ([val init]) + (let* ([updator (event-processor + (lambda (emit) + (lambda (the-event) + (set! val the-event) + (emit the-event))) + e)] + [rtn (proc->signal (lambda () updator val) updator)]) + rtn)))) + + (define-syntax snapshot/sync + (syntax-rules () + [(_ (id ...) expr ...) + (let-values ([(id ...) (sync/read id ...)]) + expr ...)])) + + (define-syntax snapshot + (syntax-rules () + [(_ (id ...) expr ...) + (let ([id (value-now id)] ...) + expr ...)])) + + (define-syntax snapshot-all + (syntax-rules () + [(_ expr ...) + (parameterize ([snap? #t]) + expr ...)])) + + (define (snapshot-e e . bs) + (event-processor + (lambda (emit) + (lambda (the-event) + (emit (cons the-event (map value-now bs))))) + e)) + + (define (snapshot/apply fn . args) + (apply fn (map value-now args))) + + + + ;; Deprecated + (define-syntax frp:send + (syntax-rules () + [(_ obj meth arg ...) + (if (snap?) + (send obj meth (value-now arg) ...) + (send obj meth arg ...))])) + + ;; Depricated + (define (magic dtime thunk) + (let* ([last-time (current-milliseconds)] + [ret (let ([myself #f]) + (event-producer + (let ([now (current-milliseconds)]) + (snapshot (dtime) + (when (cons? the-args) + (set! myself (first the-args))) + (when (and dtime (>= now (+ last-time dtime))) + (emit (thunk)) + (set! last-time now)) + (when dtime + (schedule-alarm (+ last-time dtime) myself)))) + dtime))]) + (send-event ret ret) + ret)) + + + ;; Depricated + (define (make-time-b ms) + (let ([ret (proc->signal void)]) + (set-signal-thunk! ret + (lambda () + (let ([t (current-milliseconds)]) + (schedule-alarm (+ ms t) ret) + t))) + (set-signal-value! ret ((signal-thunk ret))) + ret)) + + + + (define milliseconds (make-time-b 20)) + (define time-b milliseconds) + + (define seconds + (let ([ret (proc->signal void)]) + (set-signal-thunk! ret + (lambda () + (let ([s (current-seconds)] + [t (current-milliseconds)]) + (schedule-alarm (* 1000 (add1 (floor (/ t 1000)))) ret) + s))) + (set-signal-value! ret ((signal-thunk ret))) + ret)) + + ; general efficiency fix for delay + ; signal[a] signal[num] -> signal[a] + (define (delay-by beh ms-b) + (letrec ([last (cons (cons (if (zero? (value-now ms-b)) + (value-now/no-copy beh) + undefined) + (current-milliseconds)) + empty)] + [head last] + [producer (proc->signal + (lambda () + (let* ([now (current-milliseconds)] + [ms (value-now ms-b)]) + (let loop () + (if (or (empty? (rest head)) + (< now (+ ms (cdadr head)))) + (caar head) + (begin + consumer ;; just to prevent GC + (set! head (rest head)) + (loop)))))))] + [consumer (proc->signal + (lambda () + (let* ([now (current-milliseconds)] + [new (value-now beh)] + [ms (value-now ms-b)]) + (when (not (equal? new (caar last))) + (set-rest! last (cons (cons new now) + empty)) + (set! last (rest last)) + (schedule-alarm (+ now ms) producer)))) + beh ms-b)]) + producer)) + + (define (inf-delay beh) + (delay-by beh 0)) + + ; fix to take arbitrary monotonically increasing number + ; (instead of milliseconds) + ; integral : signal[num] signal[num] -> signal[num] + (define integral + (opt-lambda (b [ms-b 20]) + (letrec ([accum 0] + [last-time (current-milliseconds)] + [last-val (value-now b)] + [last-alarm 0] + [producer (proc->signal (lambda () + consumer ;; just to prevent GC + accum))] + [consumer (proc->signal void b ms-b)]) + (set-signal-thunk! + consumer + (lambda () + (let ([now (current-milliseconds)]) + (if (> now (+ last-time 20)) + (begin + (when (not (number? last-val)) + (set! last-val 0)) + (set! accum (+ accum + (* last-val + (- now last-time)))) + (set! last-time now) + (set! last-val (value-now b)) + (when (value-now ms-b) + (schedule-alarm (+ last-time (value-now ms-b)) + consumer))) + (when (or (>= now last-alarm) + (and (< now 0) + (>= last-alarm 0))) + (set! last-alarm (+ now 20)) + (schedule-alarm last-alarm consumer))) + (schedule-alarm now producer)))) + ((signal-thunk consumer)) + producer))) + + ; fix for accuracy + ; derivative : signal[num] -> signal[num] + (define (derivative b) + (let* ([last-value (value-now b)] + [last-time (current-milliseconds)] + [thunk (lambda () + (let* ([new-value (value-now b)] + [new-time (current-milliseconds)] + [result (if (or (= new-value last-value) + (= new-time last-time) + (> new-time + (+ 500 last-time)) + (not (number? last-value)) + (not (number? new-value))) + 0 + (/ (- new-value last-value) + (- new-time last-time)))]) + (set! last-value new-value) + (set! last-time new-time) + result))]) + (proc->signal thunk b))) + + + + (define create-strict-thunk + (case-lambda + [(fn) fn] + [(fn arg1) (lambda () + (let ([a1 (value-now/no-copy arg1)]) + (if (undefined? a1) + undefined + (fn a1))))] + [(fn arg1 arg2) (lambda () + (let ([a1 (value-now/no-copy arg1)] + [a2 (value-now/no-copy arg2)]) + (if (or (undefined? a1) + (undefined? a2)) + undefined + (fn a1 a2))))] + [(fn arg1 arg2 arg3) (lambda () + (let ([a1 (value-now/no-copy arg1)] + [a2 (value-now/no-copy arg2)] + [a3 (value-now/no-copy arg3)]) + (if (or (undefined? a1) + (undefined? a2) + (undefined? a3)) + undefined + (fn a1 a2 a3))))] + [(fn . args) (lambda () + (let ([as (map value-now/no-copy args)]) + (if (ormap undefined? as) + undefined + (apply fn as))))])) + + (define create-thunk + (case-lambda + [(fn) fn] + [(fn arg1) (lambda () (fn (value-now/no-copy arg1)))] + [(fn arg1 arg2) (lambda () (fn (value-now/no-copy arg1) (value-now/no-copy arg2)))] + [(fn arg1 arg2 arg3) (lambda () (fn (value-now/no-copy arg1) + (value-now/no-copy arg2) + (value-now/no-copy arg3)))] + [(fn . args) (lambda () (apply fn (map value-now/no-copy args)))])) + + + (define (lift strict? fn . args) + (if (snap?) ;; maybe fix later to handle undefined-strictness + (apply fn (map value-now/no-copy args)) + (with-continuation-mark + 'frtime 'lift-active + (if (ormap behavior? args) + (begin + (when (ormap signal:compound? args) + (printf "attempting to lift ~a over a signal:compound in ~a!~n" fn (map value-now args))) + (apply + proc->signal + (apply (if strict? create-strict-thunk create-thunk) fn args) + args)) + (if (and strict? (ormap undefined? args)) + undefined + (apply fn args)))))) + + (define (lift-strict . args) + (apply lift #t args)) + + + (define (general-event-processor proc . args) + ; proc : (lambda (emit suspend first-evt) ...) + (let* ([out (econs undefined undefined)] + [esc #f] + [emit (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val)] + [streams (map signal-value args)]) + (letrec ([suspend (lambda () + (call/cc + (lambda (k) + (set! proc-k k) + (esc (void)))))] + [proc-k (lambda (evt) (proc emit suspend evt) (set! proc-k #f))]) + (let ([thunk (lambda () + (when (ormap undefined? streams) + ;(fprintf (current-error-port) "had an undefined stream~n") + (set! streams (fix-streams streams args))) + (let loop () + (extract (lambda (the-event) + (when proc-k + (call/cc + (lambda (k) + (set! esc k) + (proc-k the-event)))) (loop)) + streams)) + (set! streams (map signal-value args)) + out)]) + (apply proc->signal thunk args))))) + + + (define (event-processor proc . args) + (let* ([out (econs undefined undefined)] + [proc/emit (proc + (lambda (val) + (set-erest! out (econs val undefined)) + (set! out (erest out)) + val))] + [streams (map signal-value args)] + [thunk (lambda () + (when (ormap undefined? streams) + ;(fprintf (current-error-port) "had an undefined stream~n") + (set! streams (fix-streams streams args))) + (let loop () + (extract (lambda (the-event) (proc/emit the-event) (loop)) + streams)) + (set! streams (map signal-value args)) + out)]) + (apply proc->signal thunk args))) + + + + ;;;;;;;;;;;;;;;;;;;;;; + ;; Command Lambda + + + (define-syntax mk-command-lambda + (syntax-rules () + [(_ (free ...) forms body ...) + (if (ormap behavior? (list free ...)) + (procs->signal:compound + (lambda x (lambda forms + (snapshot (free ...) body ...))) + (lambda (a b) void) + free ...) + (lambda forms body ...))])) + + (define-syntax (command-lambda stx) + + (define (arglist-bindings arglist-stx) + (syntax-case arglist-stx () + [var + (identifier? arglist-stx) + (list arglist-stx)] + [(var ...) + (syntax->list arglist-stx)] + [(var . others) + (cons #'var (arglist-bindings #'others))])) + + + (define (make-snapshot-unbound insp unbound-ids) + (lambda (expr bound-ids) + (let snapshot-unbound ([expr expr] [bound-ids bound-ids]) + (syntax-recertify + (syntax-case expr (#%datum + quote + #%top + let-values + letrec-values + lambda) + [x (identifier? #'x) (if (or + (syntax-property #'x 'protected) + (ormap (lambda (id) + (bound-identifier=? id #'x)) bound-ids)) + #'x + (begin + (hash-table-put! unbound-ids #'x #t) + #'(#%app value-now x)))] + [(#%datum . val) expr] + [(quote . _) expr] + [(#%top . var) (begin + (hash-table-put! unbound-ids #'var #t) + #`(#%app value-now #,expr))] ; FIX + + [(letrec-values (((variable ...) in-e) ...) body-e ...) + (let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)]) + (with-syntax ([(new-in-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(in-e ...)))] + [(new-body-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(body-e ...)))]) + #'(letrec-values (((variable ...) new-in-e) ...) new-body-e ...)))] + [(let-values (((variable ...) in-e) ...) body-e ...) + (let ([new-bound-ids (append (syntax->list #'(variable ... ...)) bound-ids)]) + (with-syntax ([(new-in-e ...) (map (lambda (exp) + (snapshot-unbound exp bound-ids)) + (syntax->list #'(in-e ...)))] + [(new-body-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(body-e ...)))]) + #'(let-values (((variable ...) new-in-e) ...) new-body-e ...)))] + [(lambda forms body-e ...) + (let ([new-bound-ids (append (arglist-bindings #'forms) bound-ids)]) + (with-syntax ([(new-body-e ...) (map (lambda (exp) + (snapshot-unbound exp new-bound-ids)) + (syntax->list #'(body-e ...)))]) + #'(lambda forms new-body-e ...)))] + [(tag exp ...) + (with-syntax ([(new-exp ...) (map (lambda (exp) + (snapshot-unbound exp bound-ids)) + (syntax->list #'(exp ...)))]) + #'(tag new-exp ...))] + [x (begin + (fprintf (current-error-port) "snapshot-unbound: fell through on ~a~n" #'x) + ())]) + expr insp #f)))) + + (syntax-case stx () + [(src-command-lambda (id ...) expr ...) + (let ([c-insp (current-code-inspector)]) + (parameterize ([current-code-inspector (make-inspector)]) + (syntax-case (local-expand #'(lambda (id ...) expr ...) 'expression ()) (lambda) + [(lambda (id ...) expr ...) + (let ([unbound-ids (make-hash-table)]) + (with-syntax ([(new-expr ...) (map (lambda (exp) + ((make-snapshot-unbound c-insp unbound-ids) + exp + (syntax->list #'(id ...)))) + (syntax->list #'(expr ...)))] + [(free-var ...) (hash-table-map unbound-ids + (lambda (k v) k))]) + (begin + ;(printf "~a~n" unbound-ids) + #'(if (ormap behavior? (list free-var ...)) + (procs->signal:compound (lambda _ + (lambda (id ...) + new-expr ...)) + (lambda (a b) void) + free-var ...) + (lambda (id ...) expr ...)))))])))])) + + + (define for-each-e! + (let ([ht (make-hash-table 'weak)]) + (opt-lambda (ev proc [ref 'dummy]) + (hash-table-put! ht ref (cons (ev . ==> . proc) (hash-table-get ht ref (lambda () empty))))))) + + (define raise-exceptions (new-cell #t)) + + (define exception-raiser + (exceptions . ==> . (lambda (p) (when (value-now raise-exceptions) + (thread + (lambda () (raise (car p)))))))) + + + + + + + + + + (provide raise-exceptions + nothing + nothing? + general-event-processor + event-processor + switch + merge-e + once-e + changes + when-e + while-e + ==> + -=> + =#> + =#=> + map-e + filter-e + filter-map-e + collect-e + accum-e + collect-b + accum-b + hold + for-each-e! + snapshot/sync + snapshot + snapshot-e + snapshot/apply + magic + milliseconds + seconds + delay-by + inf-delay + integral + derivative + new-cell + lift + lift-strict + event? + command-lambda + mk-command-lambda + until + event-loop + + ;; from frp-core + event-receiver + send-event + send-synchronous-event + send-synchronous-events + set-cell! + undefined + (rename undefined?/lifted undefined?) + (rename undefined? frp:undefined?) + behavior? + value-now + value-now/no-copy + value-now/sync + frtime-version + signal-count + + + ) + ) + + diff --git a/collects/frtime/list.ss b/collects/frtime/list.ss index a4e0453033..8543a9504b 100644 --- a/collects/frtime/list.ss +++ b/collects/frtime/list.ss @@ -2,8 +2,8 @@ (require (lifted (lib "list.ss") quicksort mergesort fifth sixth seventh eighth - last-pair empty? cons?) - (only (lib "list.ss") empty)) + last-pair) + (rename (lib "list.ss") empty empty)) (define first car) (define rest cdr) @@ -11,8 +11,10 @@ (define third caddr) (define fourth cadddr) + (define empty? null?) + (define remove - (letrec ([rm (case-lambda + (letrec ([rm (case-lambda [(item list) (rm item list equal?)] [(item list equal?) (let loop ([list list]) @@ -152,4 +154,7 @@ [(f (first l)) (cons (first l) (filter f (rest l)))] [else (filter f (rest l))])) - (provide (all-defined) empty)) + + (define (cons? x) (pair? x)) + + (provide (all-defined) empty)) \ No newline at end of file diff --git a/collects/frtime/mzscheme-core.ss b/collects/frtime/mzscheme-core.ss new file mode 100644 index 0000000000..4c508d5180 --- /dev/null +++ b/collects/frtime/mzscheme-core.ss @@ -0,0 +1,413 @@ +(module mzscheme-core mzscheme + ;(require (all-except mzscheme provide module if require letrec null?) + ;(lib "list.ss")) + (require-for-syntax (lib "struct.ss" "frtime") (lib "list.ss")) + (require (lib "list.ss") + (lib "frp-core.ss" "frtime") + (rename (lib "lang-ext.ss" "frtime") lift lift) + (rename (lib "lang-ext.ss" "frtime") new-cell new-cell)) + + + + + + + ;;;;;;;;;;;;;;;;;;;;;;;; + ;; Fundamental Macros ;; + ;;;;;;;;;;;;;;;;;;;;;;;; + + + (define-syntax frp:letrec + (syntax-rules () + [(_ ([id val] ...) expr ...) + (let ([id (new-cell)] ...) + (let ([tmp val]) + (if (signal? tmp) + (set-cell! id tmp) + (set! id tmp))) + ... + expr ...)])) + + ;(define-syntax frp:match + ; (syntax-rules () + ; [(_ expr clause ...) (lift #t (match-lambda clause ...) expr)])) + + (define (->boolean x) + (if x #t #f)) + + (define-syntax frp:if + (syntax-rules () + [(_ test-exp then-exp) + (frp:if test-exp then-exp (void))] + [(_ test-exp then-exp else-exp) + (frp:if test-exp then-exp else-exp undefined)] + [(_ test-exp then-exp else-exp undef-exp) + (super-lift + (lambda (b) + ;(printf "~n\t******\tIF CONDITION IS ~a~n" b) + (cond + [(undefined? b) undef-exp] + [b then-exp] + [else else-exp])) + (lift #t ->boolean test-exp))])) + + (define (copy-list lst) + (frp:if (null? lst) + () + (frp:cons (frp:car lst) (copy-list (frp:cdr lst))))) + + (define-syntax frp:let-values + (syntax-rules () + [(_ ([vars expr] ...) body0 body1 ...) + (let-values ([vars (split-multiple expr)] ...) + body0 body1 ...)])) + + (define-for-syntax (get-rest-arg arglist-stx) + (syntax-case arglist-stx () + [var + (identifier? arglist-stx) + arglist-stx] + [(var ...) + #f] + [(var . others) + (get-rest-arg #'others)])) + + (define-for-syntax (translate-clause stx) + (syntax-case stx () + [(bindings body0 body1 ...) + (let ([the-rest-arg (get-rest-arg #'bindings)]) + (if the-rest-arg + #`(bindings + (let ([#,the-rest-arg (copy-list #,the-rest-arg)]) + body0 body1 ...)) + #'(bindings body0 body1 ...)))])) + + (define-syntax (frp:lambda stx) + (syntax-case stx () + [(_ bindings body0 body1 ...) + (with-syntax ([new-clause (translate-clause #'(bindings body0 body1 ...))]) + #'(lambda . new-clause))])) + + (define-syntax (frp:case-lambda stx) + (syntax-case stx () + [(_ clause ...) + (with-syntax ([(new-clause ...) + (map translate-clause (syntax->list #'(clause ...)))]) + #'(case-lambda + new-clause ...))])) + #| + (define (split-list acc lst) + (if (null? (cdr lst)) + (values acc lst) + (split-list (append acc (list (car lst))) (cdr lst)))) + + (define (frp:apply fn . args) + (let-values ([(first-args rest-args) (split-list () args)]) + (if (behavior? rest-args) + (super-lift + (lambda (rest-args) + (apply apply fn (append first-args rest-args))) + args) + (apply apply fn (append first-args rest-args))))) + |# + + + ;;;;;;;;;;;;;;;; + ;; Structures ;; + ;;;;;;;;;;;;;;;; + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; CONS + + + (define (frp:cons f r) + (if (or (behavior? f) (behavior? r)) + (procs->signal:compound + cons + (lambda (p i) + (if (zero? i) + (lambda (v) (set-car! p v)) + (lambda (v) (set-cdr! p v)))) + f r) + (cons f r))) + + (define (make-accessor acc) + (lambda (v) + (let loop ([v v]) + (cond + [(signal:compound? v) (acc (signal:compound-content v))] + [(signal:switching? v) (super-lift + (lambda (_) + (loop (unbox (signal:switching-current v)))) + (signal:switching-trigger v))] + [(signal? v) (printf "access to ~a in ~a~n" acc (value-now/no-copy v)) (lift #t acc v)] + [else (acc v)])))) + + (define frp:car + (make-accessor car)) + + (define frp:cdr + (make-accessor cdr)) + + (define frp:pair? (lambda (arg) (if (signal:compound? arg) + (pair? (signal:compound-content arg)) + (lift #t pair? arg)))) + + (define (frp:null? arg) + (if (signal:compound? arg) + #f + (lift #t null? arg))) + + (define frp:empty? frp:null?) + + (define frp:append + (case-lambda + [() ()] + [(lst) lst] + [(lst1 lst2 . lsts) + (frp:if (frp:empty? lst1) + (apply frp:append lst2 lsts) + (frp:cons (frp:car lst1) + (apply frp:append (frp:cdr lst1) lst2 lsts)))])) + + (define frp:list + (lambda elts + (frp:if (frp:empty? elts) + '() + (frp:cons (frp:car elts) + (apply frp:list (frp:cdr elts)))))) + + (define frp:list* + (lambda elts + (frp:if (frp:empty? elts) + '() + (frp:if (frp:empty? (frp:cdr elts)) + (frp:car elts) + (frp:cons (frp:car elts) + (apply frp:list* (frp:cdr elts))))))) + + (define (frp:list? itm) + (if (signal:compound? itm) + (let ([ctnt (signal:compound-content itm)]) + ; (let ([ctnt (value-now itm)]) + (if (cons? ctnt) + (frp:list? (cdr ctnt)) + #f)) + (if (signal? itm) + (frp:if (lift #t cons? itm) + (frp:list? (frp:cdr itm)) + (frp:null? itm)) + (or (null? itm) + (and (cons? itm) (frp:list? (cdr itm))))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Vector + + + (define (frp:vector . args) + (if (ormap behavior? args) + (apply procs->signal:compound + vector + (lambda (vec idx) + (lambda (x) + (vector-set! vec idx x))) + args) + (apply vector args))) + + (define (frp:vector-ref v i) + (cond + [(signal:compound? v) (vector-ref (signal:compound-content v) i)] + [(signal? v) (lift #t vector-ref v i)] + [else (vector-ref v i)])) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; make-struct-type + define-struct Macros + + + (define (frp:make-struct-type name-symbol super-struct-type init-field-k auto-field-k . args) + (let-values ([(desc ctor pred acc mut) + (apply make-struct-type name-symbol super-struct-type init-field-k auto-field-k + args)]) + (values + desc + (lambda fields + (if (ormap behavior? fields) + (apply procs->signal:compound + ctor + (lambda (strct idx) + (lambda (val) + (mut strct idx val))) + fields) + (apply ctor fields))) + (lambda (v) (if (signal:compound? v) + (pred (value-now/no-copy v)) + (lift #t pred v))) + acc + mut))) + + (define (frp:make-struct-field-accessor acc i sym) + (make-accessor (make-struct-field-accessor acc i sym))) + + ; FORBIDS MUTATION + (define (frp:make-struct-field-mutator acc i sym) + (lambda (s) + (error "MUTATION NOT ALLOWED IN FrTime STRUCTURES"))) + + (define-syntax (frp:define-struct stx) + (syntax-case stx () + [(_ (s t) (field ...) insp) + (let ([field-names (syntax->list #'(field ...))] + [super-for-gen (if (syntax-e #'t) + (string->symbol + (format "struct:~a" (syntax-e #'t))) + #f)] + [super-for-exp (if (syntax-e #'t) + #'t + #t)]) + #`(begin + (define-values #,(build-struct-names #'s field-names #f #f stx) + (parameterize ([current-inspector insp]) + #,(build-struct-generation #'s field-names #f #f super-for-gen))) + (define-syntax s + #,(build-struct-expand-info #'s field-names #f #f super-for-exp + empty empty))))] + [(_ (s t) (field ...)) + #'(frp:define-struct (s t) (field ...) (current-inspector))] + [(_ s (field ...) insp) + #'(frp:define-struct (s #f) (field ...) insp)] + [(_ s (field ...)) + #'(frp:define-struct (s #f) (field ...) (current-inspector))])) + + + + + + + + + ;;;;;;;;;;;;;;;;;;;;;;; + ;; Provide & Require ;; + ;;;;;;;;;;;;;;;;;;;;;;; + + + (define-syntax (frp:provide stx) + (syntax-case stx () + [(_ . clauses) + (foldl + (lambda (c prev) + (syntax-case prev () + [(begin clause ...) + (syntax-case c (lifted lifted:nonstrict) + [(lifted . ids) + (with-syntax ([(fun-name ...) (syntax ids)] + [(tmp-name ...) + (map (lambda (id) + (datum->syntax-object stx (syntax-object->datum id))) + (generate-temporaries (syntax ids)))]) + (syntax + (begin + clause ... + (define (tmp-name . args) + (apply lift #t fun-name args)) + ... + (provide (rename tmp-name fun-name) ...))))] + [(lifted:nonstrict . ids) + (with-syntax ([(fun-name ...) (syntax ids)] + [(tmp-name ...) + (map (lambda (id) + (datum->syntax-object stx (syntax-object->datum id))) + (generate-temporaries (syntax ids)))]) + (syntax + (begin + clause ... + (define (tmp-name . args) + (apply lift #f fun-name args)) + ... + (provide (rename tmp-name fun-name) ...))))] + [provide-spec + (syntax (begin clause ... (provide provide-spec)))])])) + (syntax (begin)) + (syntax->list (syntax clauses)))])) + + (define-syntax (frp:require stx) + (define (generate-temporaries/loc st ids) + (map (lambda (id) + (datum->syntax-object stx (syntax-object->datum id))) + (generate-temporaries ids))) + (syntax-case stx () + [(_ . clauses) + (foldl + (lambda (c prev) + (syntax-case prev () + [(begin clause ...) + (syntax-case c (lifted lifted:nonstrict as-is:unchecked as-is frlibs) + [(lifted:nonstrict module . ids) + (with-syntax ([(fun-name ...) #'ids] + [(tmp-name ...) (generate-temporaries/loc stx #'ids)]) + #'(begin + clause ... + (require (rename module tmp-name fun-name) ...) + (define (fun-name . args) + (apply lift false tmp-name args)) + ...))] + [(lifted module . ids) + (with-syntax ([(fun-name ...) (syntax ids)] + [(tmp-name ...) (generate-temporaries/loc stx #'ids)]) + #'(begin + clause ... + (require (rename module tmp-name fun-name) ...) + (define (fun-name . args) + (apply lift #t tmp-name args)) + ...))] + [(as-is:unchecked module id ...) + (syntax (begin clause ... (require (rename module id id) ...)))] + [(as-is module . ids) + (with-syntax ([(fun-name ...) (syntax ids)] + [(tmp-name ...) (generate-temporaries/loc stx #'ids)]) + #'(begin + clause ... + (require (rename module tmp-name fun-name) ...) + (define fun-name (ensure-no-signal-args tmp-name 'fun-name)) + ...))] + [(frlibs str ...) + #'(begin + clause ... + (require (lib str "frtime") ...))] + [require-spec + #'(begin clause ... (require require-spec))])])) + #'(begin) + (syntax->list #'clauses))])) + + + + + (provide module + #%app + #%top + #%datum + #%plain-module-begin + #%module-begin + (rename frp:if if) + (rename frp:lambda lambda) + (rename frp:case-lambda case-lambda) + ;(rename frp:apply apply) + (rename frp:letrec letrec) + (rename frp:cons cons) + (rename frp:car car) + (rename frp:cdr cdr) + (rename frp:list list) + (rename frp:list? list?) + (rename frp:list* list*) + (rename frp:null? null?) + (rename frp:pair? pair?) + (rename frp:append append) + (rename frp:vector vector) + (rename frp:vector-ref vector-ref) + (rename frp:make-struct-type make-struct-type) + (rename frp:make-struct-field-accessor make-struct-field-accessor) + (rename frp:make-struct-field-mutator make-struct-field-mutator) + (rename frp:define-struct define-struct) + (rename frp:provide provide) + (rename frp:require require))) diff --git a/collects/frtime/mzscheme-utils.ss b/collects/frtime/mzscheme-utils.ss new file mode 100644 index 0000000000..398146ae1c --- /dev/null +++ b/collects/frtime/mzscheme-utils.ss @@ -0,0 +1,362 @@ +(module mzscheme-utils (lib "mzscheme-core.ss" "frtime") + + (require (all-except mzscheme + module + #%app + #%top + #%datum + #%plain-module-begin + #%module-begin + if + lambda + case-lambda + ;apply + reverse + list-ref + require + provide + letrec + match + cons car cdr pair? null? + caar cdar cadr cddr caddr cdddr cadddr cddddr + make-struct-type + make-struct-field-accessor + make-struct-field-mutator + vector + vector-ref + quasiquote + ;qq-append + define-struct + list + list* + list? + append + and + or + cond when unless ;case + map ormap andmap assoc member) + (rename mzscheme mzscheme:if if) + (rename (lib "lang-ext.ss" "frtime") lift lift) + (rename (lib "frp-core.ss" "frtime") super-lift super-lift) + (rename (lib "frp-core.ss" "frtime") behavior? behavior?) + (rename (lib "lang-ext.ss" "frtime") undefined undefined) + (rename (lib "lang-ext.ss" "frtime") undefined? undefined?)) + + + + + (define (list-ref lst idx) + (if (lift #t positive? idx) + (list-ref (cdr lst) (lift #t sub1 idx)) + (car lst))) + + ;(define (frp:eq? itm1 itm2) + ; (lift #t eq? itm1 itm2)) + + + (define-syntax cond + (syntax-rules (else =>) + [(_ [else result1 result2 ...]) + (begin result1 result2 ...)] + [(_ [test => result]) + (let ([temp test]) + (if temp (result temp)))] + [(_ [test => result] clause1 clause2 ...) + (let ([temp test]) + (if temp + (result temp) + (cond clause1 clause2 ...) + (cond clause1 clause2 ...)))] + [(_ [test]) test] + [(_ [test] clause1 clause2 ...) + (let ((temp test)) + (if temp + temp + (cond clause1 clause2 ...) + (cond clause1 clause2 ...)))] + [(_ [test result1 result2 ...]) + (if test (begin result1 result2 ...))] + [(_ [test result1 result2 ...] + clause1 clause2 ...) + (if test + (begin result1 result2 ...) + (cond clause1 clause2 ...) + (cond clause1 clause2 ...))])) + + (define-syntax and + (syntax-rules () + [(_) #t] + [(_ exp) exp] + [(_ exp exps ...) (if exp + (and exps ...) + #f)])) + + (define-syntax or + (syntax-rules () + [(_) #f] + [(_ exp) exp] + [(_ exp exps ...) (let ([v exp]) + (if v + v + (or exps ...) + (or-undef exps ...)))])) + + + (define-syntax or-undef + (syntax-rules () + [(_) undefined] + [(_ exp) (let ([v exp]) (if v v undefined))] + [(_ exp exps ...) (let ([v exp]) + (if v + v + (or-undef exps ...) + (or-undef exps ...)))])) + + + + (define-syntax when + (syntax-rules () + [(_ test body ...) (if test (begin body ...))])) + + (define-syntax unless + (syntax-rules () + [(_ test body ...) (if (not test) (begin body ...))])) + + (define (ormap proc lst) + (and (pair? lst) + (or (proc (car lst)) (ormap proc (cdr lst))))) + + (define (andmap proc lst) + (or (null? lst) + (and (proc (car lst)) (andmap proc (cdr lst))))) + + (define (caar v) + (car (car v))) + + (define (cdar v) + (cdr (car v))) + + (define (cadr v) + (car (cdr v))) + + (define (cddr v) + (cdr (cdr v))) + + (define (caddr v) + (car (cddr v))) + + (define (cdddr v) + (cdr (cddr v))) + + (define (cadddr v) + (car (cdddr v))) + + (define (cddddr v) + (cdr (cdddr v))) + + #| + (define-syntax frp:case + (syntax-rules () + [(_ expr clause ...) + (super-lift (lambda (v) (case v clause ...)) expr)])) + |# + (define (split-list acc lst) + (if (null? (cdr lst)) + (values acc (car lst)) + (split-list (append acc (list (car lst))) (cdr lst)))) + + (define frp:apply + (lambda (fn . args) + (if (behavior? args) + (super-lift + (lambda (args) + (apply apply fn args)) + args) + (apply apply fn args)))) + #| + ;; taken from startup.ss + (define-syntax frp:case + (lambda (x) + (syntax-case x (else) + ((_ v) + (syntax (begin v (cond)))) + ((_ v (else e1 e2 ...)) + (syntax/loc x (begin v e1 e2 ...))) + ((_ v ((k ...) e1 e2 ...)) + (syntax/loc x (if (memv v '(k ...)) (begin e1 e2 ...)))) + ((_ v ((k ...) e1 e2 ...) c1 c2 ...) + (syntax/loc x (let ((x v)) + (if (memv x '(k ...)) + (begin e1 e2 ...) + (frp:case x c1 c2 ...))))) + ((_ v (bad e1 e2 ...) . rest) + (raise-syntax-error + #f + "bad syntax (not a datum sequence)" + x + (syntax bad))) + ((_ v clause . rest) + (raise-syntax-error + #f + "bad syntax (missing expression after datum sequence)" + x + (syntax clause))) + ((_ . v) + (not (null? (syntax-e (syntax v)))) + (raise-syntax-error + #f + "bad syntax (illegal use of `.')" + x))))) + + +|# + + (define-syntax frp:case + (syntax-rules () + [(_ exp clause ...) + (let ([v exp]) + (vcase v clause ...))])) + + (define-syntax vcase + (syntax-rules (else) + [(_ v [else exp ...]) + (begin exp ...)] + [(_ v [dl exp ...]) + (if (lift #t memv v (quote dl)) + (begin exp ...))] + [(_ v [dl exp ...] clause ...) + (if (lift #t memv v (quote dl)) + (begin exp ...) + (vcase v clause ...))])) + + (define map + (case-lambda + [(f l) (if (pair? l) + (cons (f (car l)) (map f (cdr l))) + null)] + [(f l1 l2) (if (and (pair? l1) (pair? l2)) + (cons (f (car l1) (car l2)) (map f (cdr l1) (cdr l2))) + null)] + [(f l . ls) (if (and (pair? l) (andmap pair? ls)) + (cons (apply f (car l) (map car ls)) (apply map f (cdr l) (map cdr ls))) + null)])) + + + (define (frp:length lst) + (cond + [(pair? lst) (lift #t add1 (frp:length (cdr lst)))] + [(null? lst) 0] + [else (error 'length (format "expects list, given ~a" lst))])) + + (define (reverse lst) + (let loop ([lst lst] [acc ()]) + (if (pair? lst) + (loop (cdr lst) (cons (car lst) acc)) + acc))) + + (provide cond + and + or + or-undef + when + unless + map + ormap + andmap + caar + cadr + cddr + caddr + cdddr + cadddr + cddddr + ;case + build-path + collection-path + + list-ref + (rename frp:case case) + (rename frp:apply apply) + (rename frp:length length) + reverse + + (lifted + - * / = + eq? + equal? eqv? < > <= >= + add1 cos sin tan symbol->string symbol? + number->string string->symbol eof-object? exp expt even? odd? string-append eval ; list-ref + sub1 sqrt not number? string? zero? min max modulo + string->number void? rational? char? char-upcase char-ci>=? char-ci<=? + string>=? char-upper-case? char-alphabetic? + string? + string-locale-ci? charstring substring string->list + string-ci=? string<=? string-ci<=? string>? string-locale=? char<=? char->integer integer->char boolean? + integer? quotient remainder positive? negative? inexact->exact exact->inexact + make-polar denominator truncate bitwise-not bitwise-xor bitwise-and bitwise-ior inexact? + char-whitespace? assq assv memq memv list-tail ;reverse + ;length + seconds->date + expand syntax-object->datum exn-message continuation-mark-set->list exn-continuation-marks + exn:fail? + list->vector make-vector vector-set!) + + (rename eq? mzscheme:eq?) + make-exn:fail current-inspector make-inspector + make-namespace namespace? namespace-symbol->identifier namespace-variable-value + namespace-set-variable-value! namespace-undefine-variable! namespace-mapped-symbols + parameterize current-seconds current-milliseconds current-inexact-milliseconds + call-with-values make-parameter + null + gensym collect-garbage + error set! printf fprintf current-error-port for-each void + procedure-arity-includes? raise-type-error raise thread + current-continuation-marks + raise-mismatch-error require-for-syntax define-syntax syntax-rules syntax-case + ; set-eventspace + ;install-errortrace-key + (lifted:nonstrict format) + print-struct + ;lambda + ;case-lambda + define + let + let* + values + let*-values + let-values + define-values + begin + begin0 + quote + unquote + unquote-splicing + + syntax + let/ec + with-handlers + delay + force + random + sleep + read-case-sensitive + file-exists? + with-input-from-file + read + + + ; null + ; make-struct-field-mutator + ) + + ; from core + (provide (all-from (lib "mzscheme-core.ss" "frtime"))) + + ) diff --git a/collects/frtime/struct.ss b/collects/frtime/struct.ss new file mode 100644 index 0000000000..6ae85c082e --- /dev/null +++ b/collects/frtime/struct.ss @@ -0,0 +1,277 @@ + +(module struct mzscheme + (require (lib "etc.ss") + (lib "stx.ss" "syntax")) + (require-for-template mzscheme) + + (provide build-struct-names + build-struct-generation + build-struct-expand-info + struct-declaration-info? + + generate-struct-declaration + generate-delayed-struct-declaration) + + ;; build-struct-names : id (list-of id) bool bool -> (list-of id) + (define build-struct-names + (opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f]) + (let ([name (symbol->string (syntax-e name-stx))] + [fields (map symbol->string (map syntax-e fields))] + [+ string-append]) + (map (lambda (s) + (datum->syntax-object name-stx (string->symbol s) srcloc-stx)) + (append + (list + (+ "struct:" name) + (+ "make-" name) + (+ name "?")) + (let loop ([l fields]) + (if (null? l) + null + (append + (if omit-sel? + null + (list (+ name "-" (car l)))) + (if omit-set? + null + (list (+ "set-" name "-" (car l) "!"))) + (loop (cdr l)))))))))) + + (define build-struct-generation + (opt-lambda (name-stx fields omit-sel? omit-set? [super-type #f] [prop-value-list null] + [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]) + (let ([names (build-struct-names name-stx fields omit-sel? omit-set?)]) + (build-struct-generation* names name-stx fields omit-sel? omit-set? super-type prop-value-list + immutable-positions mk-rec-prop-list)))) + + (define build-struct-generation* + (opt-lambda (names name fields omit-sel? omit-set? [super-type #f] [prop-value-list null] + [immutable-positions null] [mk-rec-prop-list (lambda (struct: make- ? acc mut) null)]) + (let ([num-fields (length fields)] + [acc/mut-makers (let loop ([l fields][n 0]) + (if (null? l) + null + (let ([mk-one + (lambda (acc?) + (list + `(,(if acc? + 'frp:make-struct-field-accessor + 'frp:make-struct-field-mutator) + ,(if acc? 'acc 'mut) + ,n ',(car l))))]) + (append + (if omit-sel? + null + (mk-one #t)) + (if omit-set? + null + (mk-one #f)) + (loop (cdr l) (add1 n))))))] + [extra-props (mk-rec-prop-list 'struct: 'make- '? 'acc 'mut)]) + `(let-values ([(struct: make- ? acc mut) + (frp:make-struct-type ',name ,super-type ,num-fields 0 #f ,prop-value-list #f #f ,immutable-positions)]) + (values struct: + make- + ? + ,@acc/mut-makers))))) + + (define build-struct-expand-info + (lambda (name-stx fields omit-sel? omit-set? base-name base-getters base-setters) + (let* ([names (build-struct-names name-stx fields omit-sel? omit-set?)]) + (build-struct-expand-info* names name-stx fields omit-sel? omit-set? base-name base-getters base-setters)))) + + (define build-struct-expand-info* + (lambda (names name-stx fields omit-sel? omit-set? base-name base-getters base-setters) + (let* ([flds (cdddr names)] + [every-other (lambda (l) + (let loop ([l l]) + (cond + [(null? l) null] + [(null? (cdr l)) (list (car l))] + [else (cons (car l) (loop (cddr l)))])))] + [add-#f (lambda (omit? base) + (if omit? + (if (let loop ([l base]) + (cond + [(null? l) #t] + [(not (car l)) #f] + [else (loop (cdr l))])) + (append base '(#f))) + base))] + [qs (lambda (x) (if (eq? x #t) + x + (and x `((syntax-local-certifier) (quote-syntax ,x)))))]) + `(list-immutable + ,(qs (car names)) + ,(qs (cadr names)) + ,(qs (caddr names)) + (list-immutable + ,@(reverse (if omit-sel? + null + (map qs (if omit-set? flds (every-other flds))))) + ,@(map qs (add-#f omit-sel? base-getters))) + (list-immutable + ,@(reverse (if omit-set? + null + (map qs (if omit-sel? + flds + (every-other (if (null? flds) + null + (cdr flds))))))) + ,@(map qs (add-#f omit-set? base-setters))) + ,(qs base-name))))) + + + (define (struct-declaration-info? x) + (define (identifier/#f? x) + (or (not x) + (identifier? x))) + (define (id/#f-list? id? x) + (or (null? x) + (and (pair? x) + (if (null? (cdr x)) + (identifier/#f? (car x)) + (and (id? (car x)) + (id/#f-list? id? (cdr x))))))) + + (and (list? x) + (= (length x) 6) + (identifier/#f? (car x)) + (identifier/#f? (cadr x)) + (identifier/#f? (caddr x)) + (id/#f-list? identifier? (list-ref x 3)) + (id/#f-list? identifier/#f? (list-ref x 4)) + (or (eq? #t (list-ref x 5)) (identifier/#f? (list-ref x 5))))) + + + ;; ---------------------------------------- + + (define struct-info-type-id car) + (define struct-info-constructor-id cadr) + (define struct-info-predicate-id caddr) + (define struct-info-accessor-ids cadddr) + (define struct-info-mutator-ids (lambda (x) (list-ref x 4))) + + (define (get-stx-info orig-stx super-id defined-names gen-expr?) + ;; Looks up super info, if needed, and builds compile-time info for the + ;; new struct; called by all three forms, but does only half the work + ;; if `defined-names' is #f. + ;; If `expr?' is #t, then generate an expression to build the info, + ;; otherwise build the info directly. + (let ([qs (if gen-expr? (lambda (x) #`((syntax-local-certifier) (quote-syntax #,x))) values)] + [every-other (lambda (l) + (let loop ([l l][r null]) + (cond + [(null? l) r] + [(null? (cdr l)) (cons (car l) r)] + [else (loop (cddr l) (cons (car l) r))])))] + [super-info (and super-id + (syntax-local-value super-id (lambda () #f)))]) + (when super-id + ;; Did we get valid super-info ? + (when (or (not (struct-declaration-info? super-info)) + (not (struct-info-type-id super-info))) + (raise-syntax-error + #f + (if (struct-declaration-info? super-info) + "parent struct information does not include a type for subtyping" + (format "parent struct type not defined~a" + (if super-info + (format " (~a does not name struct type information)" + (syntax-e super-id)) + ""))) + orig-stx + super-id))) + ;; Generate the results: + (values + super-info + (if defined-names + (let-values ([(initial-gets initial-sets) + (if super-info + (values (map qs (struct-info-accessor-ids super-info)) + (map qs (struct-info-mutator-ids super-info))) + (values null null))] + [(fields) (cdddr defined-names)] + [(wrap) (if gen-expr? (lambda (x) #`(list-immutable #,@x)) values)]) + (wrap + (list-immutable (qs (car defined-names)) + (qs (cadr defined-names)) + (qs (caddr defined-names)) + (wrap + (apply + list-immutable + (append (map qs (every-other fields)) + initial-gets))) + (wrap + (apply + list-immutable + (append (map qs (if (null? fields) + null + (every-other (cdr fields)))) + initial-sets))) + (if super-id + (qs super-id) + #t)))) + #f)))) + + (define (make-core make-make-struct-type orig-stx defined-names super-info name field-names) + #`(let-values ([(type maker pred access mutate) + #,(make-make-struct-type orig-stx name defined-names super-info)]) + (values type maker pred + #,@(let loop ([field-names field-names][n 0]) + (if (null? field-names) + null + (list* #`(make-struct-field-accessor access #,n '#,(car field-names)) + #`(make-struct-field-mutator mutate #,n '#,(car field-names)) + (loop (cdr field-names) (add1 n)))))))) + + (define (generate-struct-declaration orig-stx + name super-id field-names + context + make-make-struct-type + continue-macro-id continue-data) + (let ([defined-names (build-struct-names name field-names #f #f name)] + [delay? (and (not (memq context '(module top-level expression))) + super-id)]) + (let-values ([(super-info stx-info) + (if delay? + (values #f #f) + (get-stx-info orig-stx super-id defined-names #t))]) + (let ([result + #`(begin + (define-values + #,defined-names + #,(if delay? + #`(begin0 ;; the `begin0' guarantees that it's an expression + (#,continue-macro-id #,orig-stx #,name #,super-id + #,defined-names #,field-names + #,continue-data)) + (make-core make-make-struct-type orig-stx defined-names super-info name field-names))) + (define-syntaxes (#,name) + #,(if delay? + #`(let-values ([(super-info stx-info) + (get-stx-info (quote-syntax ,orig-stx) + (quote-syntax ,super-id) + (list #,@(map (lambda (x) + #`(quote-syntax #,x)) + defined-names)) + #f + values)]) + stx-info) + stx-info)))]) + (if super-id + (syntax-property result + 'disappeared-use + (syntax-local-introduce super-id)) + result))))) + + (define (generate-delayed-struct-declaration stx make-make-make-struct-type) + (syntax-case stx () + [(_ orig-stx name super-id defined-names field-names continue-data) + (let-values ([(super-info stx-info) (get-stx-info #'orig-stx #'super-id #f #f)]) + (make-core (make-make-make-struct-type #'continue-data) + #'orig-stx + (syntax->list #'defined-names) + super-info + #'name + (syntax->list #'field-names)))])))