#lang planet dyoo/whalesong (require (planet dyoo/whalesong/resource) (planet dyoo/whalesong/web-world) (planet dyoo/whalesong/js)) ; This is a small demonstration of the Javascript ; graphics library Raphael from http://raphaeljs.com/ . ; The example below the bindings draws a Lissajous curve. ;;; ;;; Whalesong binding of Raphael ;;; (load-script "http://yandex.st/raphael/1.5.2/raphael.js") (define paper #f) (define (raphael-init id width height) (unless paper (set! paper (js-eval (format "Raphael(~s, ~a, ~a)" id width height))))) (define (raphael-rect x1 y1 x2 y2 . more) (case (length more) [(0) (call-method paper "rect" x1 y1 x2 y2)] [(1) (call-method paper "rect" x1 y1 x2 y2 (car more))] [else (error 'raphael-rect "too many arguments")])) (define (raphael-circle x y r) (call-method paper "circle" x y r)) (define (raphael-ellipse x y rx ry) (call-method paper "ellipse" x y rx ry)) (define (raphael-image src-uri x y w h) (call-method paper "image" x y w h)) (define (raphael-set) (call-method paper "set")) (define (raphael-push set . elems) (for-each (λ (e) (call-method paper "push" e)) elems)) (define (raphael-text x y str) (call-method paper "text" x y str)) (define (raphael-path str) ; str in SVG path string format (call-method paper "path" str)) (define (raphael-line x1 y1 x2 y2) (raphael-path (format "M~a ~aL~a ~a" x1 y1 x2 y2))) (define (raphael-clear) (call-method paper "clear")) (define (raphael-node c) (call-method c "node")) (define (raphael-hide c) (call-method c "hide")) (define (raphael-show c) (call-method c "show")) (define (raphael-remove c) (call-method c "remove")) (define (raphael-rotate c deg . more) (case (length more) [(0) (call-method c "rotate" deg)] [(1) (let ([is-absolute (car more)]) (call-method c "rotate" deg is-absolute))] [(2) (let ([cx (car more)] [cy (cadr more)]) ; (cx,xy) is the center (call-method c "rotate" deg cx cy))])) (define (raphael-translate c dx dy) (call-method c "translate" dx dy)) (define (raphael-scale c xtimes ytimes . more) (case (length more) [(0) (call-method c "scale" xtimes ytimes)] [(2) (let ([centerx (car more)] [centery (cadr more)]) (call-method c "scale" xtimes ytimes centerx centery))] [else (error 'raphael-scale "wrong number of arguments")])) (define (raphael-attr c . more) (case (length more) [(2) (let* ([attribute-name (car more)] [attribute-value (cadr more)] [attribute-value (if (number? attribute-value) (number->string attribute-value) attribute-value)]) (call-method c "attr" attribute-name attribute-value))] [(1) (cond [(string? (car more)) ; return current attribute values (call-method c "attr" (car more))] [(list? (car more)) (for-each (λ (p) (let ([name (car p)] [val (cadr p)]) (raphael-attr c name val))) (car more))] [else (error 'raphael-attr "wrong argument type: string or list-of-two-element-lists expected")])] [else (error 'raphael-attr "expected 2 or 3 arguments")])) ;;; ;;; Demonstration of the Raphael bindings ;;; (define WIDTH 400) (define HEIGHT 400) (define XMIN -1.0) (define XMAX 1.0) (define YMIN -1.0) (define YMAX 1.0) (define FRAMES-PER-SECOND 30) (define SECONDS-PER-ORBIT 20) (define STAR-PATH "M16,22.375L7.116,28.83l3.396-10.438l-8.883-6.458l10.979,0.002L16.002, 1.5l3.391,10.434h10.981l-8.886,6.457l3.396,10.439L16,22.375L16,22.375z") (define (count->time c) (let ([seconds (/ (remainder c (* SECONDS-PER-ORBIT FRAMES-PER-SECOND)) FRAMES-PER-SECOND)]) (* 2 pi (/ seconds SECONDS-PER-ORBIT)))) (define screen-x (let ([dx (- XMAX XMIN)]) (lambda (x) (let* ([x (max x XMIN)] [x (min x XMAX)]) (/ (* (- x XMIN) WIDTH) dx))))) (define screen-y (let ([dy (- YMAX YMIN)]) (lambda (y) (let* ([y (max y YMIN)] [y (min y XMAX)]) (/ (* (- (- y) YMIN) HEIGHT) dy))))) (define-struct world (count star)) ;;; See http://en.wikipedia.org/wiki/Lissajous_curve for ;;; other values of a and b to try. (define a 5) (define b 4) (define c 3) (define (x t) (* 0.8 (sin (* a t)))) (define (y t) (* 0.8 (sin (* b t)))) ;; tick: world view -> world (define (tick world view) (let* ([c (world-count world)] [s (world-star world)] [t (count->time c)] [t2 (count->time (sub1 c))]) (cond [(zero? c) (raphael-init "raphael_area" WIDTH HEIGHT) (make-world 1 (raphael-circle (screen-x (x t)) (screen-y (y t)) 3))] [else (raphael-remove s) (let ([color (format "rgb(~a%, ~a%, ~a%)" (* 100 (/ (+ 1.0 (x t)) 2.0)) (* 100 (/ (+ 1.0 (y t)) 2.0)) 50)]) (raphael-attr (raphael-line (screen-x (x t2)) (screen-y (y t2)) (screen-x (x t)) (screen-y (y t))) "stroke" color) (make-world (add1 c) (let* ([s (raphael-path STAR-PATH)] [s (raphael-translate s (- (screen-x (x t)) 15) (- (screen-y (y t)) 15))] [s (raphael-attr s "fill" color)] [s (raphael-rotate s c)] [scale (+ 3 (* 20 (/ (+ 1.0 (sin (* 5 t))) 2)))] [s (raphael-scale s scale scale)]) (raphael-attr s "stroke" "black"))))]))) ;; draw: world view -> view (define (draw world view) view) (big-bang (make-world 0 #f) (initial-view (xexp->dom '(html (head) (body (div (@ (id "raphael_area"))))))) (on-tick tick (/ 1 FRAMES-PER-SECOND)) (to-draw draw))