Red Vector Balls

vector-balls.red

Red [
	Title:  "Vector Balls Demo"
	Author: ["Nenad Rakocevic" "Gregg Irwin"]
	Date:   "[2-feb-2001 15-jun-2016]"
	File:   %vector-balls.red
	Version: 0.4
	History: {[
		0.2	12-jun-2000	"First version released."
		0.3	02-feb-2001	"Speed field added"
		0.4 26-jun-2016 "Ported to Red by Gregg"
	]}
]

;ball-img: load/as %ball-new.png 'png
ball-img: make image! [25x25 #{
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000
8B00008B00008B00008B00008B00008B0000000000000000FFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFF0000000000007F00008B00009B00009B0000A70000A70000A70000
A70000A70000A70000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000007300007F00008B00009B0000
9B0000A70000A70000B30000B30000B30000B30000B30000B30000B30000
000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000
7300007F00008B00009B00009B0000A70000A70000B30000B30000B30000
B30000B30000B30000B30000B30000B30000000000FFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFF0000006700007F00008B00008B00009B00009B0000
A70000A70000B30000B30000B30000B30000BF0000BF0000BF0000B30000
B30000B30000000000FFFFFFFFFFFFFFFFFFFFFFFF000000670000730000
7F00008B00009B00009B0000A70000A70000A70000B30000B30000B30000
B30000BF0000BF0000BF0000BF0000B30000B30000A70000000000FFFFFF
FFFFFF0000004F00006700007300007F00008B00009B00009B0000A70000
A70000A70000B30000B30000B30000B30000BF0000BF0000BF0000BF0000
B30000B30000A70000A70000000000FFFFFF0000005B0000670000730000
7F00008B00008B00009B00009B0000A70000A70000B30000FF4040FF5F5F
DF8A55FF5F5FC72B2BBF0000BF0000B30000B30000B30000A70000000000
0000004000005B00006700007300007F00008B00008B00009B00009B0000
A70000A70000B30000FF5F5FFF9F9FFFBABAFF9F9FFF7F7FC72B2BB30000
B30000B30000A70000A700008B00000000004F00005B0000670000730000
7F00008B00008B00009B00009B00009B0000A70000AA0000FF5555FF9F9F
FFBABAFF9F9FFF7F7FC72B2BB30000B30000B30000A70000A700009B0000
4000004F00005B00006700007300007F00007F00008B00008B00009B0000
9B00009B0000AA0000B30000FF5555FF7F7FFF7F7FFF5555B30000B30000
B30000A70000A70000A700009B00004000004000005B0000670000730000
7300007F00007F00008B00008B00009B00009B00009B0000A70000B30000
C72B2BC72B2BB30000AA0000AA0000A70000A70000A700009B00008B0000
4000004000004F00005B00006700007300007F00007F00008B00008B0000
8B00009B00009B00009B0000A70000A70000A70000AA0000A70000A70000
A70000A700009B00009B00008B00004000004000004F00005B0000670000
7300007300007F00007F00008B00008B00008B00009B00009B00009B0000
9B00009B0000A70000A70000A700009B00009B00009B00008B00008B0000
4000004000004F00005B00005B00006700007300007300007F00007F0000
8B00008B00008B00008B00009B00009B00009B00009B00009B00009B0000
9B00009B00008B00008B00007F00000000004000004000004F00005B0000
6700006700007300007300007F00007F00007F00008B00008B00008B0000
8B00008B00008B00009B00008B00008B00008B00008B00007F0000730000
0000004000004000004000004F00005B0000670000670000730000730000
7300007F00007F00007F00007F00008B00008B00008B00008B00008B0000
8B00007F00007F0000730000670000FFFFFF0000004000004000004F0000
4F00005B00006700006700006700007300007300007300007F00007F0000
7F00007F00007F00007F00007F00007F00007F0000730000670000000000
FFFFFF0000004000004000004000004F00004F00005B00005B0000670000
670000670000730000730000730000730000730000730000730000730000
7300007300006700005B0000000000FFFFFFFFFFFF000000400000400000
4000004000004F00005B00005B00005B0000670000670000670000670000
7300007300007300007300006700006700006700005B0000000000FFFFFF
FFFFFFFFFFFFFFFFFF0000004000004000004000004000004F00004F0000
5B00005B00005B00005B00006700006700006700006700006700005B0000
5B00004F0000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000
4000004000004000004000004000004F00004F00004F00005B00005B0000
5B00005B00005B00005B00004F00004F0000000000FFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000400000400000400000400000
4000004000004000004000004F00004F00004F00004F0000400000400000
000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFF000000000000400000400000400000400000400000400000400000
400000400000400000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000
400000400000400000400000400000400000000000000000FFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF} #{
FFFFFFFFFFFFFFFF7F00000000000000007FFFFFFFFFFFFFFFFFFFFFFFFF
FF7F0000000000000000000000007FFFFFFFFFFFFFFFFFFFFF0000000000
0000000000000000000000FFFFFFFFFFFFFFFF0000000000000000000000
00000000000000FFFFFFFFFFFF0000000000000000000000000000000000
000000FFFFFFFF00000000000000000000000000000000000000000000FF
FF7F000000000000000000000000000000000000000000007FFF00000000
00000000000000000000000000000000000000007F000000000000000000
000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000000000000000
000000000000000000007F00000000000000000000000000000000000000
0000000000FF000000000000000000000000000000000000000000000000
FF7F000000000000000000000000000000000000000000005FFFFF000000
00000000000000000000000000000000000000FFFFFFFF00000000000000
00000000000000000000000000FFFFFFFFFFFF0000000000000000000000
00000000000000FFFFFFFFFFFFFFFF000000000000000000000000000000
00FFFFFFFFFFFFFFFFFFFF7F0000000000000000000000005FFFFFFFFFFF
FFFFFFFFFFFFFFFF7F00000000000000005FFFFFFFFFFFFFFF}]


vobjects: [
	"6star" [
		[0 0 300] [0 0 -300] [300 0 0] [-300 0 0] [80 -80 80] [-90 -80 80] [80 -80 -80] 
		[-90 -80 -80] [0 -300 0] [0 300 0] [80 80 80] [-80 80 80] [80 80 -80] [-80 80 -80]
	] 
	"ball" [
		[200 0 0] [-200 0 0] [0 0 200] [0 0 -200] [145 0 145] [-145 0 145] [145 0 -145] 
		[-145 0 -145] [0 145 145] [0 0 0] [145 145 0] [-145 145 0] [0 145 -145] [0 -145 145] 
		[145 -145 0] [-145 -145 0] [0 -145 -145] [0 -200 0] [0 200 0] [0 0 0]
	] 
	"red" [
		; R
		[400 0 80]   [250 0 160] [320 0 160] 
		[400 0 160]        [190 0 80] 
		[400 0 0]    [330 0 0] [260 0 0]
		[400 0 -90]        [220 0 -90] 
		[400 0 -170]             [180 0 -170]         
		; [330 0 -170] 
		
		; E
		[70 0 160] [0 0 160] [-80 0 160] 
		[70 0 80]
		[70 0 0]   [-20 0 0] 
		[70 0 -90]
		[70 0 -170] [0 0 -170] [-80 0 -170]
		
		; D		
		[-220 0 160]  [-330 0 160]
		[-220 0 80]              [-400 0 80]
		[-220 0 0]               [-400 0 0]
		[-220 0 -90]             [-400 0 -90]
		[-220 0 -170] [-330 0 -170]
	] 
	"bim" [
		;B
		[400 0 80]   [250 0 160] [320 0 160] 
		[400 0 160]        [190 0 80] 
		[400 0 0]    [330 0 0] [250 0 0]
		[400 0 -90]        [190 0 -90] 
		[400 0 -170] [330 0 -170] [250 0 -170] 
	
		; I
		[70 0 160] [0 0 160] [-80 0 160] 
				   [0 0 80]
				   [0 0 0] 
				   [0 0 -90]
		[70 0 -170] [0 0 -170] [-80 0 -170]
		
		; M		
		[-220 0 160]                        [-400 0 160]
		[-220 0 80] [-270 0 80] [-360 0 80] [-400 0 80]
		[-220 0 0]         [-310 0 0]       [-400 0 0]
		[-220 0 -90]                        [-400 0 -90]
		[-220 0 -170]                       [-400 0 -170]
	] 
	"bim2" [
		[0 0 160] [70 0 160] [-80 0 160] [0 0 80] [0 0 -90] [0 0 0] [70 0 -170] [-80 0 -170] 
		[0 0 -170] [400 0 160] [400 0 0] [400 0 -170] [400 0 80] [400 0 -90] [250 0 0] 
		[190 0 -90] [250 0 -170] [330 0 0] [330 0 -170] [190 0 80] [250 0 160] [320 0 160] 
		[-220 0 160] [-220 0 -170] [-400 0 160] [-400 0 -170] [-310 0 0] [-220 0 0] 
		[-400 0 0] [-220 0 80] [-400 0 80] [-270 0 80] [-360 0 80] [-220 0 -90] [-400 0 -90] 
		[0 -50 0] [0 -50 80] [0 -50 -90] [0 -50 -170] [0 -50 160] [70 -50 160] [-80 -50 160] 
		[70 -50 -170] [-80 -50 -170] [250 -50 0] [330 -50 0] [400 -50 0] [400 -50 80] 
		[190 -50 80] [190 -50 -90] [400 -50 160] [400 -50 -90] [400 -50 -170] [330 -50 -170] 
		[250 -50 -170] [320 -50 160] [250 -50 160] [-220 -50 0] [-310 -50 0] [-400 -50 0] 
		[-220 -50 80] [-220 -50 -90] [-270 -50 80] [-360 -50 80] [-220 -50 -170] 
		[-400 -50 -90] [-400 -50 -170] [-220 -50 160] [-400 -50 160] [-400 -50 80]
	] 
	"box" [
		[200 -200 200] [-200 -200 -200] [-200 -200 200] [200 -200 -200] [200 200 200] 
		[-200 200 -200] [-200 200 200] [200 200 -200] [200 0 0] [-200 0 0] [0 -200 0] 
		[0 200 0] [0 0 200] [0 0 -200] [200 200 0] [-200 200 0] [0 200 200] [0 200 -200] 
		[200 -200 0] [-200 -200 0] [-200 0 200] [200 0 200] [-200 0 -200] [200 0 -200] 
		[0 -200 200] [0 -200 -200]
	] 
	"coil" [
		[150 250 0] [-150 50 0] [0 -50 -150] [0 150 150] [110 200 110] [-110 100 110] 
		[-110 0 -110] [110 -100 -110] [110 300 -110] [150 -150 0] [110 -200 110] [0 -250 150] 
		[-110 -300 110]
	] 
	"man" [
		[0 0 200] [0 0 100] [0 0 0] [0 -10 -100] [53 26 -200] [-53 26 -200] [84 0 -306] 
		[-84 0 -306] [101 42 -317] [-101 42 -317] [74 0 66] [-74 0 66] [150 62 0] [-150 62 0] 
		[140 147 39] [-140 147 39]
	] 
	"together" [
		[50 0 50] [-50 0 50] [50 0 -50] [-50 0 -50] [110 100 110] [-110 100 110] [-110 100 -110] 
		[110 100 -110] [50 200 50] [-50 200 50] [50 200 -50] [-50 200 -50] [110 -100 110] 
		[-110 -100 110] [110 -100 -110] [-110 -100 -110] [50 -200 -50] [-50 -200 -50] 
		[50 -200 50] [-50 -200 50]
	]
]


object-names: collect [
	foreach item vobjects [
		if string? item [keep item]
	]
]

ball-list: make block! 50
angle: make object! [x: y: z: 0.0]
eye-distance: 256.0
depth: 1024.0
dyn-size: off

ball-obj: context [
	color: none
	offset: 0x0
	size: 25x25
	image: ball-img
	;transparent-color: black
	coord: none
	scoord: none
	refresh: does [
		if dyn-size [
			size/x: to integer! (2000.0 - absolute scoord/z) / 50.0	; set size according to depth (increase the
			size/y: to integer! (2000.0 - absolute scoord/z) / 50.0	; depth effect, decrease refresh rate !)
		]
		;offset/x: to integer! scoord/x - (size/x / 2)	; for centering the face
		;offset/y: to integer! scoord/y - (size/y / 2)
		offset: as-pair (scoord/x - (size/x / 2)) (scoord/y - (size/y / 2))
	]
]

rotate: does [
	if axe-x/data [angle/x: angle/x + 6.0]
	if axe-y/data [angle/y: angle/y + 4.0]
	if axe-z/data [angle/z: angle/z + 3.0]
	update-balls
]

update-balls: function [][
	
	sinxa: sine angle/x
	cosxa: cosine angle/x
	sinya: sine angle/y
	cosya: cosine angle/y
	sinza: sine angle/z
	cosza: cosine angle/z

	foreach ball ball-list [
		co: ball/coord

		wz: (co/y * cosxa) - (co/z * sinxa)
		wy: (co/y * sinxa) + (co/z * cosxa)
		wx: co/x

		nx: (wx * cosya) - (wz * sinya)
		nz: (wx * sinya) + (wz * cosya)
		wx: nx
		wz: nz

		nx: (wx * cosza) - (wy * sinza)
		ny: (wx * sinza) + (wy * cosza)
		wx: nx
		wy: ny

		ball/scoord/x: ((wx * eye-distance) / (wz - depth)) + 160.0
		ball/scoord/y: ((wy * eye-distance) / (wz - depth)) + 120.0
		ball/scoord/z: wz - depth

		ball/refresh
	]

	sort/compare ball-list func [a b][a/scoord/z < b/scoord/z]

	clear balls-blk
	foreach ball ball-list [
		append/only balls-blk compose [
			image ball-img (ball/offset) ; (ball/transparent-color)
			(either dyn-size [ball/offset + ball/size][])
		]
	]
	
	show canvas
	loop 2 [do-events/no-wait]
]

make-balls: func [name [string!] /local buf ball pos][
	
	buf: make block! 50	
	foreach ball vobjects/:name [
		append/only buf make ball-obj compose/deep [
			coord:  make object! [x: (to float! ball/1) y: (to float! ball/2) z: (to float! ball/3)]
			scoord: make object! [x: y: z: 0.0]
;				if found? ball-color [
;					either pos: find effect 'colorize [
;						change next pos ball-color
;					][
;						append effect [colorize (ball-color)]
;					]
;				]
		]
	]
	buf

]

balls-blk: copy []

get-frames: does [to integer! pick v-frames/data v-frames/selected]
get-speed: does [pick v-speed/data v-speed/selected]

my-lay: layout [
	style labevel: text 90 bold 
	style axe-label: text bold

	v-cmd-pan: panel [
		below
		labevel "Speed"
		labevel "Frames"
		;labevel "Balls color"
		labevel "Dynamic size"
		labevel "Rotation axis" 
		return
		v-speed:  drop-list data ["SLOW" "MEDIUM" "FAST"] on-create [face/selected: 2]
		;v-frames: drop-list data ["100" "200" "400" "1000" "2000"] on-create [face/selected: 1]
		v-frames: drop-list data ["90" "180" "360" "720" "1440"] on-create [face/selected: 3]
		
		;v-color: base 20x20 255.0.0 ;edge [size: 1x1 color: 144.144.144 effect: 'bevel]
;				[
;					ball-color: request-color/color either ball-color [ball-color][255.0.0]
;					if ball-color [v-color/color: ball-color]
;				]
		pad 1x-3
		check [dyn-size: face/data]		; Dynamic size
		panel 80x100 [
			origin 0x0
			space  2x2
			below
			axe-x: check " X" ;data on
			axe-y: check " Y" data on
			axe-z: check " Z" ;data on
		]
		return
		pad 20x0
		labevel 120 "3D Object selection" para [wrap?: no]
		pad 0x-10
		v-list: text-list 120x145 data object-names on-create [face/selected: 3]
		button 120 "Animate" [
			angle/x: angle/y: angle/z: 0.0
			ball-list: make-balls pick v-list/data v-list/selected
			delay: select ["SLOW" .03 "MEDIUM" .01 "FAST" 0] get-speed
			loop get-frames [rotate  wait delay]
			;clear balls-blk
		]
		pad 0x15
		button 120 "Quit" [quit]
	]
	pad 10x0
	canvas: base 325x275 black draw balls-blk
]

system/view/auto-sync?: no			; We'll call SHOW when we want to update the UI

view center-face my-lay

Great script Gregg.
line 350: button 120 "Quit" [quit]
Usually I prefer 'unview.