1 ! Copyright (C) 2007 Chris Double.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\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
11 ! - Have start/stop/seek methods on the player object.
\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 ;
\r
22 : audio-buffer-size ( -- number ) 128 1024 * ; inline
\r
24 TUPLE: player stream temp-state
\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
32 : init-vorbis ( player -- )
\r
33 dup player-oy ogg_sync_init drop
\r
34 dup player-vi vorbis_info_init
\r
35 player-vc vorbis_comment_init ;
\r
37 : init-theora ( player -- )
\r
38 dup player-ti theora_info_init
\r
39 player-tc theora_comment_init ;
\r
41 : init-sound ( player -- )
\r
42 init-openal check-error
\r
43 1 gen-buffers check-error over set-player-buffers
\r
44 2 "uint" <c-array> over set-player-buffer-indexes
\r
45 1 gen-sources check-error first swap set-player-source ;
\r
47 : <player> ( stream -- player )
\r
48 { set-player-stream } player construct
\r
49 0 over set-player-vorbis
\r
50 0 over set-player-theora
\r
51 0 over set-player-video-time
\r
52 0 over set-player-video-granulepos
\r
53 f over set-player-video-ready?
\r
54 f over set-player-audio-full?
\r
55 0 over set-player-audio-index
\r
56 0 over set-player-start-time
\r
57 audio-buffer-size "short" <c-array> over set-player-audio-buffer
\r
58 0 over set-player-audio-granulepos
\r
59 f over set-player-playing?
\r
60 "ogg_packet" malloc-object over set-player-op
\r
61 "ogg_sync_state" malloc-object over set-player-oy
\r
62 "ogg_page" malloc-object over set-player-og
\r
63 "ogg_stream_state" malloc-object over set-player-vo
\r
64 "vorbis_info" malloc-object over set-player-vi
\r
65 "vorbis_dsp_state" malloc-object over set-player-vd
\r
66 "vorbis_block" malloc-object over set-player-vb
\r
67 "vorbis_comment" malloc-object over set-player-vc
\r
68 "ogg_stream_state" malloc-object over set-player-to
\r
69 "theora_info" malloc-object over set-player-ti
\r
70 "theora_comment" malloc-object over set-player-tc
\r
71 "theora_state" malloc-object over set-player-td
\r
72 "yuv_buffer" <c-object> over set-player-yuv
\r
73 "ogg_stream_state" <c-object> over set-player-temp-state
\r
78 : num-channels ( player -- channels )
\r
79 player-vi vorbis_info-channels ;
\r
81 : al-channel-format ( player -- format )
\r
82 num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ;
\r
84 : get-time ( player -- time )
\r
85 dup player-start-time zero? [
\r
86 millis over set-player-start-time
\r
88 player-start-time millis swap - 1000.0 /f ;
\r
91 255 min 0 max ; inline
\r
93 : stride ( line yuv -- uvy yy )
\r
94 [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep
\r
95 yuv_buffer-y_stride >fixnum * >fixnum ; inline
\r
97 : each-with4 ( obj obj obj obj seq quot -- )
\r
98 4 each-withn ; inline
\r
100 : compute-y ( yuv uvy yy x -- y )
\r
101 + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline
\r
103 : compute-v ( yuv uvy yy x -- v )
\r
104 nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline
\r
106 : compute-u ( yuv uvy yy x -- v )
\r
107 nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline
\r
109 : compute-yuv ( yuv uvy yy x -- y u v )
\r
110 [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline
\r
112 : compute-blue ( y u v -- b )
\r
113 drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
\r
115 : compute-green ( y u v -- g )
\r
116 >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;
\r
119 : compute-red ( y u v -- g )
\r
120 nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
\r
122 : compute-rgb ( y u v -- b g r )
\r
123 [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;
\r
126 : store-rgb ( index rgb b g r -- index )
\r
128 >r pick 0 + >fixnum pick set-uchar-nth
\r
129 r> pick 1 + >fixnum pick set-uchar-nth
\r
130 r> pick 2 + >fixnum pick set-uchar-nth
\r
133 : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
\r
134 compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
\r
136 : yuv>rgb-row ( index rgb yuv y -- index )
\r
138 pick yuv_buffer-y_width >fixnum
\r
139 [ yuv>rgb-pixel ] each-with4 ; inline
\r
141 : yuv>rgb ( rgb yuv -- )
\r
143 dup yuv_buffer-y_height >fixnum
\r
144 [ yuv>rgb-row ] each-with2
\r
147 HINTS: yuv>rgb byte-array byte-array ;
\r
149 : process-video ( player -- player )
\r
150 dup player-gadget [
\r
151 dup { player-td player-yuv } get-slots theora_decode_YUVout drop
\r
152 dup player-rgb over player-yuv yuv>rgb
\r
153 dup player-gadget relayout-1 yield
\r
156 : num-audio-buffers-processed ( player -- player n )
\r
157 dup player-source AL_BUFFERS_PROCESSED 0 <uint>
\r
158 [ alGetSourcei check-error ] keep *uint ;
\r
160 : append-new-audio-buffer ( player -- player )
\r
161 dup player-buffers 1 gen-buffers append over set-player-buffers
\r
162 [ [ player-buffers second ] keep al-channel-format ] keep
\r
163 [ player-audio-buffer dup length ] keep
\r
164 [ player-vi vorbis_info-rate alBufferData check-error ] keep
\r
165 [ player-source 1 ] keep
\r
166 [ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ;
\r
168 : fill-processed-audio-buffer ( player n -- player )
\r
169 #! n is the number of audio buffers processed
\r
170 over >r >r dup player-source r> pick player-buffer-indexes
\r
171 [ alSourceUnqueueBuffers check-error ] keep
\r
172 *uint dup r> swap >r al-channel-format rot
\r
173 [ player-audio-buffer dup length ] keep
\r
174 [ player-vi vorbis_info-rate alBufferData check-error ] keep
\r
175 [ player-source 1 ] keep
\r
176 r> <uint> swap >r alSourceQueueBuffers check-error r> ;
\r
178 : append-audio ( player -- player bool )
\r
179 num-audio-buffers-processed {
\r
180 { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
\r
181 { [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
\r
182 [ fill-processed-audio-buffer t ]
\r
185 : start-audio ( player -- player bool )
\r
186 [ [ player-buffers first ] keep al-channel-format ] keep
\r
187 [ player-audio-buffer dup length ] keep
\r
188 [ player-vi vorbis_info-rate alBufferData check-error ] keep
\r
189 [ player-source 1 ] keep
\r
190 [ player-buffers first <uint> alSourceQueueBuffers check-error ] keep
\r
191 [ player-source alSourcePlay check-error ] keep
\r
192 t over set-player-playing? t ;
\r
194 : process-audio ( player -- player bool )
\r
195 dup player-playing? [ append-audio ] [ start-audio ] if ;
\r
197 : read-bytes-into ( dest size stream -- len )
\r
198 #! Read the given number of bytes from a stream
\r
199 #! and store them in the destination byte array.
\r
200 stream-read >byte-array dup length [ memcpy ] keep ;
\r
202 : check-not-negative ( int -- )
\r
203 0 < [ "Word result was a negative number." throw ] when ;
\r
205 : buffer-size ( -- number )
\r
208 : sync-buffer ( player -- buffer size player )
\r
209 [ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ;
\r
211 : stream-into-buffer ( buffer size player -- len player )
\r
212 [ player-stream read-bytes-into ] keep ;
\r
214 : confirm-buffer ( len player -- player eof? )
\r
215 [ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
\r
217 : buffer-data ( player -- player eof? )
\r
218 #! Take some compressed bitstream data and sync it for
\r
219 #! page extraction.
\r
220 sync-buffer stream-into-buffer confirm-buffer ;
\r
222 : queue-page ( player -- player )
\r
223 #! Push a page into the stream for packetization
\r
224 [ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep
\r
225 [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ;
\r
227 : retrieve-page ( player -- player bool )
\r
228 #! Sync the streams and get a page. Return true if a page was
\r
229 #! successfully retrieved.
\r
230 dup { player-oy player-og } get-slots ogg_sync_pageout 0 > ;
\r
232 : standard-initial-header? ( player -- player bool )
\r
233 dup player-og ogg_page_bos zero? not ;
\r
235 : ogg-stream-init ( player -- state player )
\r
236 #! Init the encode/decode logical stream state
\r
237 [ player-temp-state ] keep
\r
238 [ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
\r
240 : ogg-stream-pagein ( state player -- state player )
\r
241 #! Add the incoming page to the stream state
\r
242 [ player-og ogg_stream_pagein drop ] 2keep ;
\r
244 : ogg-stream-packetout ( state player -- state player )
\r
245 [ player-op ogg_stream_packetout drop ] 2keep ;
\r
247 : decode-packet ( player -- state player )
\r
248 ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
\r
250 : theora-header? ( player -- player bool )
\r
251 #! Is the current page a theora header?
\r
252 dup { player-ti player-tc player-op } get-slots theora_decode_header 0 >= ;
\r
254 : is-theora-packet? ( player -- player bool )
\r
255 dup player-theora zero? [ theora-header? ] [ f ] if ;
\r
257 : copy-to-theora-state ( state player -- player )
\r
258 #! Copy the state to the theora state structure in the player
\r
259 [ player-to swap dup length memcpy ] keep ;
\r
261 : handle-initial-theora-header ( state player -- player )
\r
262 copy-to-theora-state 1 over set-player-theora ;
\r
264 : vorbis-header? ( player -- player bool )
\r
265 #! Is the current page a vorbis header?
\r
266 dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin 0 >= ;
\r
268 : is-vorbis-packet? ( player -- player bool )
\r
269 dup player-vorbis zero? [ vorbis-header? ] [ f ] if ;
\r
271 : copy-to-vorbis-state ( state player -- player )
\r
272 #! Copy the state to the vorbis state structure in the player
\r
273 [ player-vo swap dup length memcpy ] keep ;
\r
275 : handle-initial-vorbis-header ( state player -- player )
\r
276 copy-to-vorbis-state 1 over set-player-vorbis ;
\r
278 : handle-initial-unknown-header ( state player -- player )
\r
279 swap ogg_stream_clear drop ;
\r
281 : process-initial-header ( player -- player bool )
\r
282 #! Is this a standard initial header? If not, stop parsing
\r
283 standard-initial-header? [
\r
285 { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
\r
286 { [ is-theora-packet? ] [ handle-initial-theora-header ] }
\r
287 [ handle-initial-unknown-header ]
\r
293 : parse-initial-headers ( player -- player )
\r
294 #! Parse Vorbis headers, ignoring any other type stored
\r
295 #! in the Ogg container.
\r
297 process-initial-header [
\r
298 parse-initial-headers
\r
300 #! Don't leak the page, get it into the appropriate stream
\r
304 buffer-data not [ parse-initial-headers ] when
\r
307 : have-required-vorbis-headers? ( player -- player bool )
\r
308 #! Return true if we need to decode vorbis due to there being
\r
309 #! vorbis headers read from the stream but we don't have them all
\r
311 dup player-vorbis 1 2 between? not ;
\r
313 : have-required-theora-headers? ( player -- player bool )
\r
314 #! Return true if we need to decode theora due to there being
\r
315 #! theora headers read from the stream but we don't have them all
\r
317 dup player-theora 1 2 between? not ;
\r
319 : get-remaining-vorbis-header-packet ( player -- player bool )
\r
320 dup { player-vo player-op } get-slots ogg_stream_packetout {
\r
321 { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
\r
322 { [ dup zero? ] [ drop f ] }
\r
323 { [ t ] [ drop t ] }
\r
326 : get-remaining-theora-header-packet ( player -- player bool )
\r
327 dup { player-to player-op } get-slots ogg_stream_packetout {
\r
328 { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }
\r
329 { [ dup zero? ] [ drop f ] }
\r
330 { [ t ] [ drop t ] }
\r
333 : decode-remaining-vorbis-header-packet ( player -- player )
\r
334 dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin zero? [
\r
335 "Error parsing vorbis stream; corrupt stream?" throw
\r
338 : decode-remaining-theora-header-packet ( player -- player )
\r
339 dup { player-ti player-tc player-op } get-slots theora_decode_header zero? [
\r
340 "Error parsing theora stream; corrupt stream?" throw
\r
343 : increment-vorbis-header-count ( player -- player )
\r
344 dup player-vorbis 1+ over set-player-vorbis ;
\r
346 : increment-theora-header-count ( player -- player )
\r
347 dup player-theora 1+ over set-player-theora ;
\r
349 : parse-remaining-vorbis-headers ( player -- player )
\r
350 have-required-vorbis-headers? not [
\r
351 get-remaining-vorbis-header-packet [
\r
352 decode-remaining-vorbis-header-packet
\r
353 increment-vorbis-header-count
\r
354 parse-remaining-vorbis-headers
\r
358 : parse-remaining-theora-headers ( player -- player )
\r
359 have-required-theora-headers? not [
\r
360 get-remaining-theora-header-packet [
\r
361 decode-remaining-theora-header-packet
\r
362 increment-theora-header-count
\r
363 parse-remaining-theora-headers
\r
367 : get-more-header-data ( player -- player )
\r
370 : parse-remaining-headers ( player -- player )
\r
371 have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
\r
372 parse-remaining-vorbis-headers
\r
373 parse-remaining-theora-headers
\r
374 retrieve-page [ queue-page ] [ get-more-header-data ] if
\r
375 parse-remaining-headers
\r
378 : tear-down-vorbis ( player -- player )
\r
379 dup player-vi vorbis_info_clear
\r
380 dup player-vc vorbis_comment_clear ;
\r
382 : tear-down-theora ( player -- player )
\r
383 dup player-ti theora_info_clear
\r
384 dup player-tc theora_comment_clear ;
\r
386 : init-vorbis-codec ( player -- player )
\r
387 dup { player-vd player-vi } get-slots vorbis_synthesis_init drop
\r
388 dup { player-vd player-vb } get-slots vorbis_block_init drop ;
\r
390 : init-theora-codec ( player -- player )
\r
391 dup { player-td player-ti } get-slots theora_decode_init drop
\r
392 dup player-ti theora_info-frame_width over player-ti theora_info-frame_height
\r
393 4 * * <byte-array> over set-player-rgb ;
\r
396 : display-vorbis-details ( player -- player )
\r
398 "Ogg logical stream " %
\r
399 dup player-vo ogg_stream_state-serialno #
\r
401 dup player-vi vorbis_info-channels #
\r
403 dup player-vi vorbis_info-rate #
\r
407 : display-theora-details ( player -- player )
\r
409 "Ogg logical stream " %
\r
410 dup player-to ogg_stream_state-serialno #
\r
412 dup player-ti theora_info-width #
\r
414 dup player-ti theora_info-height #
\r
416 dup player-ti theora_info-fps_numerator
\r
417 over player-ti theora_info-fps_denominator /f #
\r
421 : initialize-decoder ( player -- player )
\r
422 dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
\r
423 dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
\r
425 : sync-pages ( player -- player )
\r
427 queue-page sync-pages
\r
430 : audio-buffer-not-ready? ( player -- player bool )
\r
431 dup player-vorbis zero? not over player-audio-full? not and ;
\r
433 : pending-decoded-audio? ( player -- player pcm len bool )
\r
434 f <void*> 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ;
\r
436 : buffer-space-available ( player -- available )
\r
437 audio-buffer-size swap player-audio-index - ;
\r
439 : samples-to-read ( player available len -- numread )
\r
440 >r swap num-channels / r> min ;
\r
442 : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
\r
444 : add-to-buffer ( player val -- )
\r
445 over player-audio-index pick player-audio-buffer set-short-nth
\r
446 dup player-audio-index 1+ swap set-player-audio-index ;
\r
448 : get-audio-value ( pcm sample channel -- value )
\r
449 rot *void* void*-nth float-nth ;
\r
451 : process-channels ( player pcm sample channel -- )
\r
452 get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;
\r
454 : (process-sample) ( player pcm sample -- )
\r
455 pick num-channels [ process-channels ] each-with3 ;
\r
457 : process-samples ( player pcm numread -- )
\r
458 [ (process-sample) ] each-with2 ;
\r
460 : decode-pending-audio ( player pcm result -- player )
\r
461 ! [ "ret = " % dup # ] "" make write
\r
462 pick [ buffer-space-available swap ] keep -rot samples-to-read
\r
463 pick over >r >r process-samples r> r> swap
\r
465 dup player-audio-index audio-buffer-size = [
\r
466 t over set-player-audio-full?
\r
468 dup player-vd vorbis_dsp_state-granulepos dup 0 >= [
\r
469 ! numtoread player granulepos
\r
470 #! This is wrong: fix
\r
471 pick - over set-player-audio-granulepos
\r
473 ! numtoread player granulepos
\r
474 pick + over set-player-audio-granulepos
\r
476 [ player-vd swap vorbis_synthesis_read drop ] keep ;
\r
478 : no-pending-audio ( player -- player bool )
\r
479 #! No pending audio. Is there a pending packet to decode.
\r
480 dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [
\r
481 dup { player-vb player-op } get-slots vorbis_synthesis 0 = [
\r
482 dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop
\r
486 #! Need more data. Break out to suck in another page.
\r
490 : decode-audio ( player -- player )
\r
491 audio-buffer-not-ready? [
\r
492 #! If there's pending decoded audio, grab it
\r
493 pending-decoded-audio? [
\r
494 decode-pending-audio decode-audio
\r
496 2drop no-pending-audio [ decode-audio ] when
\r
500 : video-buffer-not-ready? ( player -- player bool )
\r
501 dup player-theora zero? not over player-video-ready? not and ;
\r
503 : decode-video ( player -- player )
\r
504 video-buffer-not-ready? [
\r
505 dup { player-to player-op } get-slots ogg_stream_packetout 0 > [
\r
506 dup { player-td player-op } get-slots theora_decode_packetin drop
\r
507 dup player-td theora_state-granulepos over set-player-video-granulepos
\r
508 dup { player-td player-video-granulepos } get-slots theora_granule_time
\r
509 over set-player-video-time
\r
510 t over set-player-video-ready?
\r
515 : decode ( player -- player )
\r
516 get-more-header-data sync-pages
\r
519 dup player-audio-full? [
\r
521 f over set-player-audio-full?
\r
522 0 over set-player-audio-index
\r
525 dup player-video-ready? [
\r
526 dup player-video-time over get-time - dup 0.0 < [
\r
527 -0.1 > [ process-video ] when
\r
528 f over set-player-video-ready?
\r
535 : free-malloced-objects ( player -- player )
\r
536 [ player-op free ] keep
\r
537 [ player-oy free ] keep
\r
538 [ player-og free ] keep
\r
539 [ player-vo free ] keep
\r
540 [ player-vi free ] keep
\r
541 [ player-vd free ] keep
\r
542 [ player-vb free ] keep
\r
543 [ player-vc free ] keep
\r
544 [ player-to free ] keep
\r
545 [ player-ti free ] keep
\r
546 [ player-tc free ] keep
\r
547 [ player-td free ] keep ;
\r
550 : unqueue-openal-buffers ( player -- player )
\r
553 num-audio-buffers-processed over player-source rot player-buffer-indexes swapd
\r
554 alSourceUnqueueBuffers check-error
\r
557 : delete-openal-buffers ( player -- player )
\r
560 1 swap <uint> alDeleteBuffers check-error
\r
564 : delete-openal-source ( player -- player )
\r
565 [ player-source 1 swap <uint> alDeleteSources check-error ] keep ;
\r
567 : cleanup ( player -- player )
\r
568 free-malloced-objects
\r
569 unqueue-openal-buffers
\r
570 delete-openal-buffers
\r
571 delete-openal-source ;
\r
573 : wait-for-sound ( player -- player )
\r
574 #! Waits for the openal to finish playing remaining sounds
\r
575 dup player-source AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
\r
576 *int AL_PLAYING = [
\r
581 TUPLE: theora-gadget player ;
\r
583 : <theora-gadget> ( player -- gadget )
\r
584 theora-gadget construct-gadget
\r
585 [ set-theora-gadget-player ] keep ;
\r
587 M: theora-gadget pref-dim*
\r
588 theora-gadget-player
\r
589 player-ti dup theora_info-width swap theora_info-height 2array ;
\r
591 M: theora-gadget draw-gadget* ( gadget -- )
\r
593 1.0 -1.0 glPixelZoom
\r
594 GL_UNPACK_ALIGNMENT 1 glPixelStorei
\r
595 [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
\r
596 theora-gadget-player player-rgb glDrawPixels ;
\r
598 : initialize-gui ( gadget -- )
\r
599 "Theora Player" open-window ;
\r
601 : play-ogg ( player -- )
\r
602 parse-initial-headers
\r
603 parse-remaining-headers
\r
605 dup player-gadget [ initialize-gui ] when*
\r
611 : play-vorbis-stream ( stream -- )
\r
612 <player> play-ogg ;
\r
614 : play-vorbis-file ( filename -- )
\r
615 binary <file-reader> play-vorbis-stream ;
\r
617 : play-theora-stream ( stream -- )
\r
619 dup <theora-gadget> over set-player-gadget
\r
622 : play-theora-file ( filename -- )
\r
623 binary <file-reader> play-theora-stream ;
\r