| blob | 2204aa441ecb4aa2c9f06d7e4c461704a33d0873 |
1 ! Copyright (C) 2007 Chris Double.\r
2 ! See http://factorcode.org/license.txt for BSD license.\r
3 !\r
4 ! TODO:\r
5 ! based on number of channels in file.\r
6 ! - End of decoding is indicated by an exception when reading the stream.\r
7 ! How to work around this? C player example uses feof but streams don't\r
8 ! have that in Factor.\r
9 ! - Work out openal buffer method that plays nicely with streaming over\r
10 ! slow connections.\r
11 ! - Have start/stop/seek methods on the player object.\r
12 !\r
13 USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays\r
14 sequences libc shuffle alien.c-types system openal math\r
15 namespaces threads shuffle opengl arrays ui.gadgets.worlds\r
16 combinators math.parser ui.gadgets ui.render opengl.gl ui\r
17 continuations io.files hints combinators.lib sequences.lib\r
18 io.encodings.binary debugger math.order accessors ;\r
19 \r
20 IN: ogg.player\r
21 \r
22 : audio-buffer-size ( -- number ) 128 1024 * ; inline\r
23 \r
24 TUPLE: player stream temp-state\r
25 op oy og\r
26 vo vi vd vb vc vorbis\r
27 to ti tc td yuv rgb theora video-ready? video-time video-granulepos\r
28 source buffers buffer-indexes start-time\r
29 playing? audio-full? audio-index audio-buffer audio-granulepos\r
30 gadget ;\r
31 \r
32 : init-vorbis ( player -- )\r
33 dup oy>> ogg_sync_init drop\r
34 dup vi>> vorbis_info_init\r
35 vc>> vorbis_comment_init ;\r
36 \r
37 : init-theora ( player -- )\r
38 dup ti>> theora_info_init\r
39 tc>> theora_comment_init ;\r
40 \r
41 : init-sound ( player -- )\r
42 init-openal check-error\r
43 1 gen-buffers check-error >>buffers\r
44 2 "uint" <c-array> >>buffer-indexes\r
45 1 gen-sources check-error first >>source drop ;\r
46 \r
47 : <player> ( stream -- player )\r
48 player new\r
49 swap >>stream\r
50 0 >>vorbis\r
51 0 >>theora\r
52 0 >>video-time\r
53 0 >>video-granulepos\r
54 f >>video-ready?\r
55 f >>audio-full?\r
56 0 >>audio-index\r
57 0 >>start-time\r
58 audio-buffer-size "short" <c-array> >>audio-buffer\r
59 0 >>audio-granulepos\r
60 f >>playing?\r
61 "ogg_packet" malloc-object >>op\r
62 "ogg_sync_state" malloc-object >>oy\r
63 "ogg_page" malloc-object >>og\r
64 "ogg_stream_state" malloc-object >>vo\r
65 "vorbis_info" malloc-object >>vi\r
66 "vorbis_dsp_state" malloc-object >>vd\r
67 "vorbis_block" malloc-object >>vb\r
68 "vorbis_comment" malloc-object >>vc\r
69 "ogg_stream_state" malloc-object >>to\r
70 "theora_info" malloc-object >>ti\r
71 "theora_comment" malloc-object >>tc\r
72 "theora_state" malloc-object >>td\r
73 "yuv_buffer" <c-object> >>yuv\r
74 "ogg_stream_state" <c-object> >>temp-state\r
75 dup init-sound\r
76 dup init-vorbis\r
77 dup init-theora ;\r
78 \r
79 : num-channels ( player -- channels )\r
80 vi>> vorbis_info-channels ;\r
81 \r
82 : al-channel-format ( player -- format )\r
83 num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;\r
84 \r
85 : get-time ( player -- time )\r
86 dup start-time>> zero? [\r
87 millis >>start-time\r
88 ] when\r
89 start-time>> millis swap - 1000.0 /f ;\r
90 \r
91 : clamp ( n -- n )\r
92 255 min 0 max ; inline\r
93 \r
94 : stride ( line yuv -- uvy yy )\r
95 [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep\r
96 yuv_buffer-y_stride >fixnum * >fixnum ; inline\r
97 \r
98 : each-with4 ( obj obj obj obj seq quot -- )\r
99 4 each-withn ; inline\r
100 \r
101 : compute-y ( yuv uvy yy x -- y )\r
102 + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline\r
103 \r
104 : compute-v ( yuv uvy yy x -- v )\r
105 nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline\r
106 \r
107 : compute-u ( yuv uvy yy x -- v )\r
108 nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline\r
109 \r
110 : compute-yuv ( yuv uvy yy x -- y u v )\r
111 [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline\r
112 \r
113 : compute-blue ( y u v -- b )\r
114 drop 516 * 128 + swap 298 * + -8 shift clamp ; inline\r
115 \r
116 : compute-green ( y u v -- g )\r
117 >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;\r
118 inline\r
119 \r
120 : compute-red ( y u v -- g )\r
121 nip 409 * swap 298 * + 128 + -8 shift clamp ; inline\r
122 \r
123 : compute-rgb ( y u v -- b g r )\r
124 [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;\r
125 inline\r
126 \r
127 : store-rgb ( index rgb b g r -- index )\r
128 >r\r
129 >r pick 0 + >fixnum pick set-uchar-nth\r
130 r> pick 1 + >fixnum pick set-uchar-nth\r
131 r> pick 2 + >fixnum pick set-uchar-nth\r
132 drop ; inline\r
133 \r
134 : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )\r
135 compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline\r
136 \r
137 : yuv>rgb-row ( index rgb yuv y -- index )\r
138 over stride\r
139 pick yuv_buffer-y_width >fixnum\r
140 [ yuv>rgb-pixel ] each-with4 ; inline\r
141 \r
142 : yuv>rgb ( rgb yuv -- )\r
143 0 -rot\r
144 dup yuv_buffer-y_height >fixnum\r
145 [ yuv>rgb-row ] each-with2\r
146 drop ;\r
147 \r
148 HINTS: yuv>rgb byte-array byte-array ;\r
149 \r
150 : process-video ( player -- player )\r
151 dup gadget>> [\r
152 {\r
153 [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]\r
154 [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]\r
155 [ gadget>> relayout-1 yield ]\r
156 [ ]\r
157 } cleave\r
158 ] when ;\r
159 \r
160 : num-audio-buffers-processed ( player -- player n )\r
161 dup source>> AL_BUFFERS_PROCESSED 0 <uint>\r
162 [ alGetSourcei check-error ] keep *uint ;\r
163 \r
164 : append-new-audio-buffer ( player -- player )\r
165 dup buffers>> 1 gen-buffers append >>buffers\r
166 [ [ buffers>> second ] keep al-channel-format ] keep\r
167 [ audio-buffer>> dup length ] keep\r
168 [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
169 [ source>> 1 ] keep\r
170 [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;\r
171 \r
172 : fill-processed-audio-buffer ( player n -- player )\r
173 #! n is the number of audio buffers processed\r
174 over >r >r dup source>> r> pick buffer-indexes>>\r
175 [ alSourceUnqueueBuffers check-error ] keep\r
176 *uint dup r> swap >r al-channel-format rot\r
177 [ audio-buffer>> dup length ] keep\r
178 [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
179 [ source>> 1 ] keep\r
180 r> <uint> swap >r alSourceQueueBuffers check-error r> ;\r
181 \r
182 : append-audio ( player -- player bool )\r
183 num-audio-buffers-processed {\r
184 { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
185 { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }\r
186 [ fill-processed-audio-buffer t ]\r
187 } cond ;\r
188 \r
189 : start-audio ( player -- player bool )\r
190 [ [ buffers>> first ] keep al-channel-format ] keep\r
191 [ audio-buffer>> dup length ] keep\r
192 [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
193 [ source>> 1 ] keep\r
194 [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep\r
195 [ source>> alSourcePlay check-error ] keep\r
196 t >>playing? t ;\r
197 \r
198 : process-audio ( player -- player bool )\r
199 dup playing?>> [ append-audio ] [ start-audio ] if ;\r
200 \r
201 : read-bytes-into ( dest size stream -- len )\r
202 #! Read the given number of bytes from a stream\r
203 #! and store them in the destination byte array.\r
204 stream-read >byte-array dup length [ memcpy ] keep ;\r
205 \r
206 : check-not-negative ( int -- )\r
207 0 < [ "Word result was a negative number." throw ] when ;\r
208 \r
209 : buffer-size ( -- number )\r
210 4096 ; inline\r
211 \r
212 : sync-buffer ( player -- buffer size player )\r
213 [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;\r
214 \r
215 : stream-into-buffer ( buffer size player -- len player )\r
216 [ stream>> read-bytes-into ] keep ;\r
217 \r
218 : confirm-buffer ( len player -- player eof? )\r
219 [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;\r
220 \r
221 : buffer-data ( player -- player eof? )\r
222 #! Take some compressed bitstream data and sync it for\r
223 #! page extraction.\r
224 sync-buffer stream-into-buffer confirm-buffer ;\r
225 \r
226 : queue-page ( player -- player )\r
227 #! Push a page into the stream for packetization\r
228 [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
229 [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
230 [ ] tri ;\r
231 \r
232 : retrieve-page ( player -- player bool )\r
233 #! Sync the streams and get a page. Return true if a page was\r
234 #! successfully retrieved.\r
235 dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;\r
236 \r
237 : standard-initial-header? ( player -- player bool )\r
238 dup og>> ogg_page_bos zero? not ;\r
239 \r
240 : ogg-stream-init ( player -- state player )\r
241 #! Init the encode/decode logical stream state\r
242 [ temp-state>> ] keep\r
243 [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;\r
244 \r
245 : ogg-stream-pagein ( state player -- state player )\r
246 #! Add the incoming page to the stream state\r
247 [ og>> ogg_stream_pagein drop ] 2keep ;\r
248 \r
249 : ogg-stream-packetout ( state player -- state player )\r
250 [ op>> ogg_stream_packetout drop ] 2keep ;\r
251 \r
252 : decode-packet ( player -- state player )\r
253 ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;\r
254 \r
255 : theora-header? ( player -- player bool )\r
256 #! Is the current page a theora header?\r
257 dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;\r
258 \r
259 : is-theora-packet? ( player -- player bool )\r
260 dup theora>> zero? [ theora-header? ] [ f ] if ;\r
261 \r
262 : copy-to-theora-state ( state player -- player )\r
263 #! Copy the state to the theora state structure in the player\r
264 [ to>> swap dup length memcpy ] keep ;\r
265 \r
266 : handle-initial-theora-header ( state player -- player )\r
267 copy-to-theora-state 1 >>theora ;\r
268 \r
269 : vorbis-header? ( player -- player bool )\r
270 #! Is the current page a vorbis header?\r
271 dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;\r
272 \r
273 : is-vorbis-packet? ( player -- player bool )\r
274 dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;\r
275 \r
276 : copy-to-vorbis-state ( state player -- player )\r
277 #! Copy the state to the vorbis state structure in the player\r
278 [ vo>> swap dup length memcpy ] keep ;\r
279 \r
280 : handle-initial-vorbis-header ( state player -- player )\r
281 copy-to-vorbis-state 1 >>vorbis ;\r
282 \r
283 : handle-initial-unknown-header ( state player -- player )\r
284 swap ogg_stream_clear drop ;\r
285 \r
286 : process-initial-header ( player -- player bool )\r
287 #! Is this a standard initial header? If not, stop parsing\r
288 standard-initial-header? [\r
289 decode-packet {\r
290 { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }\r
291 { [ is-theora-packet? ] [ handle-initial-theora-header ] }\r
292 [ handle-initial-unknown-header ]\r
293 } cond t\r
294 ] [\r
295 f\r
296 ] if ;\r
297 \r
298 : parse-initial-headers ( player -- player )\r
299 #! Parse Vorbis headers, ignoring any other type stored\r
300 #! in the Ogg container.\r
301 retrieve-page [\r
302 process-initial-header [\r
303 parse-initial-headers\r
304 ] [\r
305 #! Don't leak the page, get it into the appropriate stream\r
306 queue-page\r
307 ] if\r
308 ] [\r
309 buffer-data not [ parse-initial-headers ] when\r
310 ] if ;\r
311 \r
312 : have-required-vorbis-headers? ( player -- player bool )\r
313 #! Return true if we need to decode vorbis due to there being\r
314 #! vorbis headers read from the stream but we don't have them all\r
315 #! yet.\r
316 dup vorbis>> 1 2 between? not ;\r
317 \r
318 : have-required-theora-headers? ( player -- player bool )\r
319 #! Return true if we need to decode theora due to there being\r
320 #! theora headers read from the stream but we don't have them all\r
321 #! yet.\r
322 dup theora>> 1 2 between? not ;\r
323 \r
324 : get-remaining-vorbis-header-packet ( player -- player bool )\r
325 dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {\r
326 { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }\r
327 { [ dup zero? ] [ drop f ] }\r
328 { [ t ] [ drop t ] }\r
329 } cond ;\r
330 \r
331 : get-remaining-theora-header-packet ( player -- player bool )\r
332 dup [ to>> ] [ op>> ] bi ogg_stream_packetout {\r
333 { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }\r
334 { [ dup zero? ] [ drop f ] }\r
335 { [ t ] [ drop t ] }\r
336 } cond ;\r
337 \r
338 : decode-remaining-vorbis-header-packet ( player -- player )\r
339 dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [\r
340 "Error parsing vorbis stream; corrupt stream?" throw\r
341 ] unless ;\r
342 \r
343 : decode-remaining-theora-header-packet ( player -- player )\r
344 dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [\r
345 "Error parsing theora stream; corrupt stream?" throw\r
346 ] unless ;\r
347 \r
348 : increment-vorbis-header-count ( player -- player )\r
349 [ 1+ ] change-vorbis ;\r
350 \r
351 : increment-theora-header-count ( player -- player )\r
352 [ 1+ ] change-theora ;\r
353 \r
354 : parse-remaining-vorbis-headers ( player -- player )\r
355 have-required-vorbis-headers? not [\r
356 get-remaining-vorbis-header-packet [\r
357 decode-remaining-vorbis-header-packet\r
358 increment-vorbis-header-count\r
359 parse-remaining-vorbis-headers\r
360 ] when\r
361 ] when ;\r
362 \r
363 : parse-remaining-theora-headers ( player -- player )\r
364 have-required-theora-headers? not [\r
365 get-remaining-theora-header-packet [\r
366 decode-remaining-theora-header-packet\r
367 increment-theora-header-count\r
368 parse-remaining-theora-headers\r
369 ] when\r
370 ] when ;\r
371 \r
372 : get-more-header-data ( player -- player )\r
373 buffer-data drop ;\r
374 \r
375 : parse-remaining-headers ( player -- player )\r
376 have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [\r
377 parse-remaining-vorbis-headers\r
378 parse-remaining-theora-headers\r
379 retrieve-page [ queue-page ] [ get-more-header-data ] if\r
380 parse-remaining-headers\r
381 ] when ;\r
382 \r
383 : tear-down-vorbis ( player -- player )\r
384 dup vi>> vorbis_info_clear\r
385 dup vc>> vorbis_comment_clear ;\r
386 \r
387 : tear-down-theora ( player -- player )\r
388 dup ti>> theora_info_clear\r
389 dup tc>> theora_comment_clear ;\r
390 \r
391 : init-vorbis-codec ( player -- player )\r
392 dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop\r
393 dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;\r
394 \r
395 : init-theora-codec ( player -- player )\r
396 dup [ td>> ] [ ti>> ] bi theora_decode_init drop\r
397 dup ti>> theora_info-frame_width over ti>> theora_info-frame_height\r
398 4 * * <byte-array> >>rgb ;\r
399 \r
400 \r
401 : display-vorbis-details ( player -- player )\r
402 [\r
403 "Ogg logical stream " %\r
404 dup vo>> ogg_stream_state-serialno #\r
405 " is Vorbis " %\r
406 dup vi>> vorbis_info-channels #\r
407 " channel " %\r
408 dup vi>> vorbis_info-rate #\r
409 " Hz audio." %\r
410 ] "" make print ;\r
411 \r
412 : display-theora-details ( player -- player )\r
413 [\r
414 "Ogg logical stream " %\r
415 dup to>> ogg_stream_state-serialno #\r
416 " is Theora " %\r
417 dup ti>> theora_info-width #\r
418 "x" %\r
419 dup ti>> theora_info-height #\r
420 " " %\r
421 dup ti>> theora_info-fps_numerator\r
422 over ti>> theora_info-fps_denominator /f #\r
423 " fps video" %\r
424 ] "" make print ;\r
425 \r
426 : initialize-decoder ( player -- player )\r
427 dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if\r
428 dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;\r
429 \r
430 : sync-pages ( player -- player )\r
431 retrieve-page [\r
432 queue-page sync-pages\r
433 ] when ;\r
434 \r
435 : audio-buffer-not-ready? ( player -- player bool )\r
436 dup vorbis>> zero? not over audio-full?>> not and ;\r
437 \r
438 : pending-decoded-audio? ( player -- player pcm len bool )\r
439 f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;\r
440 \r
441 : buffer-space-available ( player -- available )\r
442 audio-buffer-size swap audio-index>> - ;\r
443 \r
444 : samples-to-read ( player available len -- numread )\r
445 >r swap num-channels / r> min ;\r
446 \r
447 : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline\r
448 \r
449 : add-to-buffer ( player val -- )\r
450 over audio-index>> pick audio-buffer>> set-short-nth\r
451 [ 1+ ] change-audio-index drop ;\r
452 \r
453 : get-audio-value ( pcm sample channel -- value )\r
454 rot *void* void*-nth float-nth ;\r
455 \r
456 : process-channels ( player pcm sample channel -- )\r
457 get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;\r
458 \r
459 : (process-sample) ( player pcm sample -- )\r
460 pick num-channels [ process-channels ] each-with3 ;\r
461 \r
462 : process-samples ( player pcm numread -- )\r
463 [ (process-sample) ] each-with2 ;\r
464 \r
465 : decode-pending-audio ( player pcm result -- player )\r
466 ! [ "ret = " % dup # ] "" make write\r
467 pick [ buffer-space-available swap ] keep -rot samples-to-read\r
468 pick over >r >r process-samples r> r> swap\r
469 ! numread player\r
470 dup audio-index>> audio-buffer-size = [\r
471 t >>audio-full?\r
472 ] when\r
473 dup vd>> vorbis_dsp_state-granulepos dup 0 >= [\r
474 ! numtoread player granulepos\r
475 #! This is wrong: fix\r
476 pick - >>audio-granulepos\r
477 ] [\r
478 ! numtoread player granulepos\r
479 pick + >>audio-granulepos\r
480 ] if\r
481 [ vd>> swap vorbis_synthesis_read drop ] keep ;\r
482 \r
483 : no-pending-audio ( player -- player bool )\r
484 #! No pending audio. Is there a pending packet to decode.\r
485 dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
486 dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [\r
487 dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop\r
488 ] when\r
489 t\r
490 ] [\r
491 #! Need more data. Break out to suck in another page.\r
492 f\r
493 ] if ;\r
494 \r
495 : decode-audio ( player -- player )\r
496 audio-buffer-not-ready? [\r
497 #! If there's pending decoded audio, grab it\r
498 pending-decoded-audio? [\r
499 decode-pending-audio decode-audio\r
500 ] [\r
501 2drop no-pending-audio [ decode-audio ] when\r
502 ] if\r
503 ] when ;\r
504 \r
505 : video-buffer-not-ready? ( player -- player bool )\r
506 dup theora>> zero? not over video-ready?>> not and ;\r
507 \r
508 : decode-video ( player -- player )\r
509 video-buffer-not-ready? [\r
510 dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
511 dup [ td>> ] [ op>> ] bi theora_decode_packetin drop\r
512 dup td>> theora_state-granulepos >>video-granulepos\r
513 dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time\r
514 >>video-time\r
515 t >>video-ready?\r
516 decode-video\r
517 ] when\r
518 ] when ;\r
519 \r
520 : decode ( player -- player )\r
521 get-more-header-data sync-pages\r
522 decode-audio\r
523 decode-video\r
524 dup audio-full?>> [\r
525 process-audio [\r
526 f >>audio-full?\r
527 0 >>audio-index\r
528 ] when\r
529 ] when\r
530 dup video-ready?>> [\r
531 dup video-time>> over get-time - dup 0.0 < [\r
532 -0.1 > [ process-video ] when\r
533 f >>video-ready?\r
534 ] [\r
535 drop\r
536 ] if\r
537 ] when\r
538 decode ;\r
539 \r
540 : free-malloced-objects ( player -- player )\r
541 {\r
542 [ op>> free ]\r
543 [ oy>> free ]\r
544 [ og>> free ]\r
545 [ vo>> free ]\r
546 [ vi>> free ]\r
547 [ vd>> free ]\r
548 [ vb>> free ]\r
549 [ vc>> free ]\r
550 [ to>> free ]\r
551 [ ti>> free ]\r
552 [ tc>> free ]\r
553 [ td>> free ]\r
554 [ ]\r
555 } cleave ;\r
556 \r
557 \r
558 : unqueue-openal-buffers ( player -- player )\r
559 [\r
560 \r
561 num-audio-buffers-processed over source>> rot buffer-indexes>> swapd\r
562 alSourceUnqueueBuffers check-error\r
563 ] keep ;\r
564 \r
565 : delete-openal-buffers ( player -- player )\r
566 [\r
567 buffers>> [\r
568 1 swap <uint> alDeleteBuffers check-error\r
569 ] each\r
570 ] keep ;\r
571 \r
572 : delete-openal-source ( player -- player )\r
573 [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;\r
574 \r
575 : cleanup ( player -- player )\r
576 free-malloced-objects\r
577 unqueue-openal-buffers\r
578 delete-openal-buffers\r
579 delete-openal-source ;\r
580 \r
581 : wait-for-sound ( player -- player )\r
582 #! Waits for the openal to finish playing remaining sounds\r
583 dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep\r
584 *int AL_PLAYING = [\r
585 100 sleep\r
586 wait-for-sound\r
587 ] when ;\r
588 \r
589 TUPLE: theora-gadget < gadget player ;\r
590 \r
591 : <theora-gadget> ( player -- gadget )\r
592 theora-gadget new-gadget\r
593 swap >>player ;\r
594 \r
595 M: theora-gadget pref-dim*\r
596 player>>\r
597 ti>> dup theora_info-width swap theora_info-height 2array ;\r
598 \r
599 M: theora-gadget draw-gadget* ( gadget -- )\r
600 0 0 glRasterPos2i\r
601 1.0 -1.0 glPixelZoom\r
602 GL_UNPACK_ALIGNMENT 1 glPixelStorei\r
603 [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep\r
604 player>> rgb>> glDrawPixels ;\r
605 \r
606 : initialize-gui ( gadget -- )\r
607 "Theora Player" open-window ;\r
608 \r
609 : play-ogg ( player -- )\r
610 parse-initial-headers\r
611 parse-remaining-headers\r
612 initialize-decoder\r
613 dup gadget>> [ initialize-gui ] when*\r
614 [ decode ] try\r
615 wait-for-sound\r
616 cleanup\r
617 drop ;\r
618 \r
619 : play-vorbis-stream ( stream -- )\r
620 <player> play-ogg ;\r
621 \r
622 : play-vorbis-file ( filename -- )\r
623 binary <file-reader> play-vorbis-stream ;\r
624 \r
625 : play-theora-stream ( stream -- )\r
626 <player>\r
627 dup <theora-gadget> >>gadget\r
628 play-ogg ;\r
629 \r
630 : play-theora-file ( filename -- )\r
631 binary <file-reader> play-theora-stream ;\r