1 ! Copyright (C) 2007 Chris Double.
2 ! See http://factorcode.org/license.txt for BSD license.
5 ! based on number of channels in file.
6 ! - End of decoding is indicated by an exception when reading the stream.
7 ! How to work around this? C player example uses feof but streams don't
9 ! - Work out openal buffer method that plays nicely with streaming over
11 ! - Have start/stop/seek methods on the player object.
13 USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
14 sequences libc shuffle alien.c-types system openal math
15 namespaces threads shuffle opengl arrays ui.gadgets.worlds
16 combinators math.parser ui.gadgets ui.render opengl.gl ui
17 continuations io.files hints combinators.lib sequences.lib
18 io.encodings.binary debugger math.order accessors ;
22 : audio-buffer-size ( -- number ) 128 1024 * ; inline
24 TUPLE: player stream temp-state
27 to ti tc td yuv rgb theora video-ready? video-time video-granulepos
28 source buffers buffer-indexes start-time
29 playing? audio-full? audio-index audio-buffer audio-granulepos
32 : init-vorbis ( player -- )
33 dup oy>> ogg_sync_init drop
34 dup vi>> vorbis_info_init
35 vc>> vorbis_comment_init ;
37 : init-theora ( player -- )
38 dup ti>> theora_info_init
39 tc>> theora_comment_init ;
41 : init-sound ( player -- )
42 init-openal check-error
43 1 gen-buffers check-error >>buffers
44 2 uint <c-array> >>buffer-indexes
45 1 gen-sources check-error first >>source drop ;
47 : <player> ( stream -- player )
58 audio-buffer-size "short" <c-array> >>audio-buffer
61 ogg_packet malloc-struct >>op
62 ogg_sync_state malloc-struct >>oy
63 ogg_page malloc-struct >>og
64 ogg_stream_state malloc-struct >>vo
65 vorbis_info malloc-struct >>vi
66 vorbis_dsp_state malloc-struct >>vd
67 vorbis_block malloc-struct >>vb
68 vorbis_comment malloc-struct >>vc
69 ogg_stream_state malloc-struct >>to
70 theora_info malloc-struct >>ti
71 theora_comment malloc-struct >>tc
72 theora_state malloc-struct >>td
73 yuv_buffer <struct> >>yuv
74 ogg_stream_state <struct> >>temp-state
79 : num-channels ( player -- channels )
80 vi>> vorbis_info-channels ;
82 : al-channel-format ( player -- format )
83 num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;
85 : get-time ( player -- time )
86 dup start-time>> zero? [
89 start-time>> millis swap - 1000.0 /f ;
92 255 min 0 max ; inline
94 : stride ( line yuv -- uvy yy )
95 [ uv_stride>> >fixnum swap 2/ * ] 2keep
96 y_stride>> >fixnum * >fixnum ; inline
98 : each-with4 ( obj obj obj obj seq quot -- )
101 : compute-y ( yuv uvy yy x -- y )
102 + >fixnum nip swap y>> uchar-nth 16 - ; inline
104 : compute-v ( yuv uvy yy x -- v )
105 nip 2/ + >fixnum swap u>> uchar-nth 128 - ; inline
107 : compute-u ( yuv uvy yy x -- v )
108 nip 2/ + >fixnum swap v>> uchar-nth 128 - ; inline
110 : compute-yuv ( yuv uvy yy x -- y u v )
111 [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline
113 : compute-blue ( y u v -- b )
114 drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
116 : compute-green ( y u v -- g )
117 >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;
120 : compute-red ( y u v -- g )
121 nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
123 : compute-rgb ( y u v -- b g r )
124 [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;
127 : store-rgb ( index rgb b g r -- index )
129 >r pick 0 + >fixnum pick set-uchar-nth
130 r> pick 1 + >fixnum pick set-uchar-nth
131 r> pick 2 + >fixnum pick set-uchar-nth
134 : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
135 compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
137 : yuv>rgb-row ( index rgb yuv y -- index )
139 pick y_width>> >fixnum
140 [ yuv>rgb-pixel ] each-with4 ; inline
142 : yuv>rgb ( rgb yuv -- )
144 dup y_height>> >fixnum
145 [ yuv>rgb-row ] each-with2
148 HINTS: yuv>rgb byte-array byte-array ;
150 : process-video ( player -- player )
153 [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
154 [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
155 [ gadget>> relayout-1 yield ]
160 : num-audio-buffers-processed ( player -- player n )
161 dup source>> AL_BUFFERS_PROCESSED 0 uint <ref>
162 [ alGetSourcei check-error ] keep uint deref ;
164 : append-new-audio-buffer ( player -- player )
165 dup buffers>> 1 gen-buffers append >>buffers
166 [ [ buffers>> second ] keep al-channel-format ] keep
167 [ audio-buffer>> dup length ] keep
168 [ vi>> rate>> alBufferData check-error ] keep
170 [ buffers>> second uint <ref> alSourceQueueBuffers check-error ] keep ;
172 : fill-processed-audio-buffer ( player n -- player )
173 ! n is the number of audio buffers processed
174 over >r >r dup source>> r> pick buffer-indexes>>
175 [ alSourceUnqueueBuffers check-error ] keep
176 uint deref dup r> swap >r al-channel-format rot
177 [ audio-buffer>> dup length ] keep
178 [ vi>> rate>> alBufferData check-error ] keep
180 r> uint <ref> swap >r alSourceQueueBuffers check-error r> ;
182 : append-audio ( player -- player bool )
183 num-audio-buffers-processed {
184 { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
185 { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }
186 [ fill-processed-audio-buffer t ]
189 : start-audio ( player -- player bool )
190 [ [ buffers>> first ] keep al-channel-format ] keep
191 [ audio-buffer>> dup length ] keep
192 [ vi>> rate>> alBufferData check-error ] keep
194 [ buffers>> first uint <ref> alSourceQueueBuffers check-error ] keep
195 [ source>> alSourcePlay check-error ] keep
198 : process-audio ( player -- player bool )
199 dup playing?>> [ append-audio ] [ start-audio ] if ;
201 : read-bytes-into ( dest size stream -- len )
202 ! Read the given number of bytes from a stream
203 ! and store them in the destination byte array.
204 stream-read >byte-array dup length [ memcpy ] keep ;
206 : check-not-negative ( int -- )
207 0 < [ "Word result was a negative number." throw ] when ;
209 : buffer-size ( -- number )
212 : sync-buffer ( player -- buffer size player )
213 [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;
215 : stream-into-buffer ( buffer size player -- len player )
216 [ stream>> read-bytes-into ] keep ;
218 : confirm-buffer ( len player -- player eof? )
219 [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
221 : buffer-data ( player -- player eof? )
222 ! Take some compressed bitstream data and sync it for
224 sync-buffer stream-into-buffer confirm-buffer ;
226 : queue-page ( player -- player )
227 ! Push a page into the stream for packetization
228 [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
229 [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
232 : retrieve-page ( player -- player bool )
233 ! Sync the streams and get a page. Return true if a page was
234 ! successfully retrieved.
235 dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;
237 : standard-initial-header? ( player -- player bool )
238 dup og>> ogg_page_bos zero? not ;
240 : ogg-stream-init ( player -- state player )
241 ! Init the encode/decode logical stream state
242 [ temp-state>> ] keep
243 [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
245 : ogg-stream-pagein ( state player -- state player )
246 ! Add the incoming page to the stream state
247 [ og>> ogg_stream_pagein drop ] 2keep ;
249 : ogg-stream-packetout ( state player -- state player )
250 [ op>> ogg_stream_packetout drop ] 2keep ;
252 : decode-packet ( player -- state player )
253 ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
255 : theora-header? ( player -- player bool )
256 ! Is the current page a theora header?
257 dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
259 : is-theora-packet? ( player -- player bool )
260 dup theora>> zero? [ theora-header? ] [ f ] if ;
262 : copy-to-theora-state ( state player -- player )
263 ! Copy the state to the theora state structure in the player
264 [ to>> swap dup length memcpy ] keep ;
266 : handle-initial-theora-header ( state player -- player )
267 copy-to-theora-state 1 >>theora ;
269 : vorbis-header? ( player -- player bool )
270 ! Is the current page a vorbis header?
271 dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
273 : is-vorbis-packet? ( player -- player bool )
274 dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;
276 : copy-to-vorbis-state ( state player -- player )
277 ! Copy the state to the vorbis state structure in the player
278 [ vo>> swap dup length memcpy ] keep ;
280 : handle-initial-vorbis-header ( state player -- player )
281 copy-to-vorbis-state 1 >>vorbis ;
283 : handle-initial-unknown-header ( state player -- player )
284 swap ogg_stream_clear drop ;
286 : process-initial-header ( player -- player bool )
287 ! Is this a standard initial header? If not, stop parsing
288 standard-initial-header? [
290 { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
291 { [ is-theora-packet? ] [ handle-initial-theora-header ] }
292 [ handle-initial-unknown-header ]
298 : parse-initial-headers ( player -- player )
299 ! Parse Vorbis headers, ignoring any other type stored
300 ! in the Ogg container.
302 process-initial-header [
303 parse-initial-headers
305 ! Don't leak the page, get it into the appropriate stream
309 buffer-data not [ parse-initial-headers ] when
312 : have-required-vorbis-headers? ( player -- player bool )
313 ! Return true if we need to decode vorbis due to there being
314 ! vorbis headers read from the stream but we don't have them all
316 dup vorbis>> 1 2 between? not ;
318 : have-required-theora-headers? ( player -- player bool )
319 ! Return true if we need to decode theora due to there being
320 ! theora headers read from the stream but we don't have them all
322 dup theora>> 1 2 between? not ;
324 : get-remaining-vorbis-header-packet ( player -- player bool )
325 dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {
326 { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
327 { [ dup zero? ] [ drop f ] }
331 : get-remaining-theora-header-packet ( player -- player bool )
332 dup [ to>> ] [ op>> ] bi ogg_stream_packetout {
333 { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }
334 { [ dup zero? ] [ drop f ] }
338 : decode-remaining-vorbis-header-packet ( player -- player )
339 dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [
340 "Error parsing vorbis stream; corrupt stream?" throw
343 : decode-remaining-theora-header-packet ( player -- player )
344 dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [
345 "Error parsing theora stream; corrupt stream?" throw
348 : increment-vorbis-header-count ( player -- player )
349 [ 1+ ] change-vorbis ;
351 : increment-theora-header-count ( player -- player )
352 [ 1+ ] change-theora ;
354 : parse-remaining-vorbis-headers ( player -- player )
355 have-required-vorbis-headers? not [
356 get-remaining-vorbis-header-packet [
357 decode-remaining-vorbis-header-packet
358 increment-vorbis-header-count
359 parse-remaining-vorbis-headers
363 : parse-remaining-theora-headers ( player -- player )
364 have-required-theora-headers? not [
365 get-remaining-theora-header-packet [
366 decode-remaining-theora-header-packet
367 increment-theora-header-count
368 parse-remaining-theora-headers
372 : get-more-header-data ( player -- player )
375 : parse-remaining-headers ( player -- player )
376 have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
377 parse-remaining-vorbis-headers
378 parse-remaining-theora-headers
379 retrieve-page [ queue-page ] [ get-more-header-data ] if
380 parse-remaining-headers
383 : tear-down-vorbis ( player -- player )
384 dup vi>> vorbis_info_clear
385 dup vc>> vorbis_comment_clear ;
387 : tear-down-theora ( player -- player )
388 dup ti>> theora_info_clear
389 dup tc>> theora_comment_clear ;
391 : init-vorbis-codec ( player -- player )
392 dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
393 dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
395 : init-theora-codec ( player -- player )
396 dup [ td>> ] [ ti>> ] bi theora_decode_init drop
397 dup ti>> frame_width>> over ti>> frame_height>>
398 4 * * <byte-array> >>rgb ;
401 : display-vorbis-details ( player -- player )
403 "Ogg logical stream " %
404 dup vo>> serialno>> #
406 dup vi>> channels>> #
412 : display-theora-details ( player -- player )
414 "Ogg logical stream " %
415 dup to>> serialno>> #
421 dup ti>> fps_numerator>>
422 over ti>> fps_denominator>> /f #
426 : initialize-decoder ( player -- player )
427 dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
428 dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
430 : sync-pages ( player -- player )
432 queue-page sync-pages
435 : audio-buffer-not-ready? ( player -- player bool )
436 dup vorbis>> zero? not over audio-full?>> not and ;
438 : pending-decoded-audio? ( player -- player pcm len bool )
439 f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
441 : buffer-space-available ( player -- available )
442 audio-buffer-size swap audio-index>> - ;
444 : samples-to-read ( player available len -- numread )
445 >r swap num-channels / r> min ;
447 : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
449 : add-to-buffer ( player val -- )
450 over audio-index>> pick audio-buffer>> set-short-nth
451 [ 1+ ] change-audio-index drop ;
453 : get-audio-value ( pcm sample channel -- value )
454 rot *void* void*-nth float-nth ;
456 : process-channels ( player pcm sample channel -- )
457 get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;
459 : (process-sample) ( player pcm sample -- )
460 pick num-channels [ process-channels ] each-with3 ;
462 : process-samples ( player pcm numread -- )
463 [ (process-sample) ] each-with2 ;
465 : decode-pending-audio ( player pcm result -- player )
466 ! [ "ret = " % dup # ] "" make write
467 pick [ buffer-space-available swap ] keep -rot samples-to-read
468 pick over >r >r process-samples r> r> swap
470 dup audio-index>> audio-buffer-size = [
473 dup vd>> granulepos>> dup 0 >= [
474 ! numtoread player granulepos
476 pick - >>audio-granulepos
478 ! numtoread player granulepos
479 pick + >>audio-granulepos
481 [ vd>> swap vorbis_synthesis_read drop ] keep ;
483 : no-pending-audio ( player -- player bool )
484 ! No pending audio. Is there a pending packet to decode.
485 dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
486 dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
487 dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
491 ! Need more data. Break out to suck in another page.
495 : decode-audio ( player -- player )
496 audio-buffer-not-ready? [
497 ! If there's pending decoded audio, grab it
498 pending-decoded-audio? [
499 decode-pending-audio decode-audio
501 2drop no-pending-audio [ decode-audio ] when
505 : video-buffer-not-ready? ( player -- player bool )
506 dup theora>> zero? not over video-ready?>> not and ;
508 : decode-video ( player -- player )
509 video-buffer-not-ready? [
510 dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
511 dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
512 dup td>> granulepos>> >>video-granulepos
513 dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
520 : decode ( player -- player )
521 get-more-header-data sync-pages
531 dup video-time>> over get-time - dup 0.0 < [
532 -0.1 > [ process-video ] when
540 : free-malloced-objects ( player -- player )
558 : unqueue-openal-buffers ( player -- player )
561 num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
562 alSourceUnqueueBuffers check-error
565 : delete-openal-buffers ( player -- player )
568 1 swap uint <ref> alDeleteBuffers check-error
572 : delete-openal-source ( player -- player )
573 [ source>> 1 swap uint <ref> alDeleteSources check-error ] keep ;
575 : cleanup ( player -- player )
576 free-malloced-objects
577 unqueue-openal-buffers
578 delete-openal-buffers
579 delete-openal-source ;
581 : wait-for-sound ( player -- player )
582 ! Waits for the openal to finish playing remaining sounds
583 dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
589 TUPLE: theora-gadget < gadget player ;
591 : <theora-gadget> ( player -- gadget )
592 theora-gadget new-gadget
595 M: theora-gadget pref-dim*
597 ti>> dup width>> swap height>> 2array ;
599 M: theora-gadget draw-gadget* ( gadget -- )
602 GL_UNPACK_ALIGNMENT 1 glPixelStorei
603 [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
604 player>> rgb>> glDrawPixels ;
606 : initialize-gui ( gadget -- )
607 "Theora Player" open-window ;
609 : play-ogg ( player -- )
610 parse-initial-headers
611 parse-remaining-headers
613 dup gadget>> [ initialize-gui ] when*
619 : play-vorbis-stream ( stream -- )
622 : play-vorbis-file ( filename -- )
623 binary <file-reader> play-vorbis-stream ;
625 : play-theora-stream ( stream -- )
627 dup <theora-gadget> >>gadget
630 : play-theora-file ( filename -- )
631 binary <file-reader> play-theora-stream ;