Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 135 lines (123 sloc) 4.454 kb
7097296 cormullion added content
authored
1 #!/usr/bin/env newlisp
2
3 (set-locale "C")
4 (load (append (env "NEWLISPDIR") "/guiserver.lsp"))
5
6 (gs:init)
7 (gs:frame 'SuperCollider 100 100 550 550 "SuperCollider")
8 (gs:set-border-layout 'SuperCollider)
9 (gs:canvas 'MyCanvas 'SuperCollider)
10 (gs:add-to 'SuperCollider 'MyCanvas "center")
11 (gs:set-background 'MyCanvas gs:black)
12 (gs:set-anti-aliasing true)
13
14 (set 'width 550 'height 550
15 'x (* 5 (- (rand 3) 1)) 'y (* 5 (- (rand 3) 1))
16 'delta-x (* 5 (- (rand 3) 1))
17 'delta-y (* 5 (- (rand 3) 1))
18 'circle-radius 4)
19
20 (gs:set-translation (/ width 2 ) (/ height 2))
21 (gs:set-size 'MyCanvas width height)
22
23 (set 'apoly1 '(
24 (-0 -85) (-23 -103)
25 (-55 -112) (-114 -90)
26 (-114 -90) (-75 -103)
27 (-38 -89) (-18 -57)
28 (-18 -33) (-25 -14)
29 (-52 9) (-73 14)
30 (-95 11) (-125 -10)
31 (-135 -50) (-134 -15)
32 (-121 11) (-72 41)
33 (-77 76) (-67 106)
34 (-21 142) (-50 118)
35 (-58 99) (-58 75)
36 (-38 42) (-0 27)
37 (38 42) (58 75)
38 (57 99) (50 118)
39 (21 142) (47 128)
40 (66 106) (76 76)
41 (72 40) (120 10)
42 (133 -16) (133 -52)
43 (123 -11) (94 11)
44 (71 14) (50 9)
45 (23 -14) (16 -33)
46 (17 -57) (37 -89)
47 (75 -103) (97 -99)
48 (113 -89) (112 -90)
49 (89 -105) (54 -112)
50 (22 -103) (0 -85)))
51
52 (define (init)
53 (gs:fill-rect 'Frame (/ (- width) 2) ( / (- height) 2) width height '(0.1 0.2 0.1))
54 (gs:fill-polygon 'Container1 (flat apoly1) gs:black)
55 (gs:fill-circle 'Electron x y circle-radius gs:green))
56
57 (set 'PI 3.14159 'TWOPI (add PI PI))
58
59 (define (angle2d x1 y1 x2 y2)
60 ; Return the angle between two vectors
61 ; The angle is from vector 1 to vector 2, positive anticlockwise
62 ; The result is between -pi -> pi
63 (set 'theta1 (atan2 y1 x1))
64 (set 'theta2 (atan2 y2 x2))
65 (set 'dtheta (sub theta2 theta1))
66 (while (> dtheta PI)
67 (dec dtheta TWOPI))
68 (while (< dtheta (- PI))
69 (inc dtheta TWOPI))
70 dtheta)
71
72 (define (inside? pt poly)
73 ; point is a list (x y)
74 ; poly is a list of points ((x y) (x y))
75 ; uses "the worst algorithm in the world for testing points"
76 ; http://erich.realtimerendering.com/ptinpoly/
77 (let ((inside nil)
78 (len (length poly))
79 (point-x (pt 0))
80 (point-y (pt 1))
81 (max-x 0) (min-x 0)
82 (max-y 0) (min-y 0)
83 (angle 0))
84 (set 'max-x (first (apply (fn (a b) (if (>= (first a) (first b)) a b)) poly 2)))
85 (set 'min-x (first (apply (fn (a b) (if (<= (first a) (first b)) a b)) poly 2)))
86 (set 'max-y (last (apply (fn (a b) (if (>= (last a) (last b)) a b)) poly 2)))
87 (set 'min-y (last (apply (fn (a b) (if (<= (last a) (last b)) a b)) poly 2)))
88 (cond
89 ; quick bounds check
90 ((or (< point-x min-x)
91 (< point-y min-y)
92 (> point-x max-x)
93 (> point-y max-y)) inside)
94 (true
95 ; OK. Do it the hard way.
96 (for (i 0 (- len 1))
97 (set 'p1x (sub (first (nth i poly)) point-x))
98 (set 'p1y (sub (last (nth i poly)) point-y))
99 (set 'p2x (sub (first (nth (% (+ i 1) len) poly)) point-x))
100 (set 'p2y (sub (last (nth (% (+ i 1) len) poly)) point-y))
101 (set 'angle (add angle (angle2d p1x p1y p2x p2y))))
102 (if (< (abs angle) PI)
103 (set 'inside nil)
104 (set 'inside true))))
105 inside))
106
107 (define (init)
108 (gs:fill-rect 'Frame (/ (- width) 2) ( / (- height) 2) width height '(0.2 0.2 0.3))
109 (gs:fill-polygon 'Container1 (flat apoly1) gs:black)
110 (gs:fill-circle 'Electron x y circle-radius gs:green))
111
112 (define (move-shape)
113 ; hit walls, bounce back
114 (if (<= x (+ circle-radius (- (/ width 2)))) (set 'delta-x (- delta-x)))
115 (if (<= y (+ circle-radius (- (/ height 2)))) (set 'delta-y (- delta-y)))
116 (if (>= x (- (/ width 2) circle-radius)) (set 'delta-x (- delta-x)))
117 (if (>= y (- (/ height 2) circle-radius)) (set 'delta-y (- delta-y)))
118 (inc x delta-x) (inc y delta-y)
119 (gs:move-tag 'Electron delta-x delta-y)
120 (if (inside? (list x y) apoly1)
121 (begin
122 ; change color of electron
123 (gs:color-tag 'Electron gs:white)
124 ; mark if we find something
125 (if (= 0 (rand 6)) (gs:fill-circle 'Target x y circle-radius gs:yellow))
126 ; randomize movement
127 (set 'delta-x (* 5 (- (rand 3) 1)))
128 (set 'delta-y (* 5 (- (rand 3) 1))))
129 (gs:color-tag 'Electron gs:red))
130 (gs:update))
131
132 (gs:set-visible 'SuperCollider true)
133 (init)
134 (while (gs:check-event 10000)
135 (move-shape))
Something went wrong with that request. Please try again.