PageRenderTime 61ms CodeModel.GetById 1ms app.highlight 54ms RepoModel.GetById 1ms app.codeStats 0ms

/unmaintained/ogg/player/player.factor

http://github.com/abeaumont/factor
Unknown | 631 lines | 518 code | 113 blank | 0 comment | 0 complexity | fafb0b53d61c30640e80669c5267a04a MD5 | raw file
  1! Copyright (C) 2007 Chris Double.
  2! See http://factorcode.org/license.txt for BSD license.
  3!
  4! TODO:
  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
  8!   have that in Factor.
  9! - Work out openal buffer method that plays nicely with streaming over
 10!   slow connections.
 11! - Have start/stop/seek methods on the player object.
 12!
 13USING: 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 ;
 19
 20IN: ogg.player
 21
 22: audio-buffer-size ( -- number ) 128 1024 * ; inline
 23
 24TUPLE: player stream temp-state
 25       op oy og
 26       vo vi vd vb vc vorbis
 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
 30       gadget ;
 31
 32: init-vorbis ( player -- )
 33    dup oy>> ogg_sync_init drop
 34    dup vi>> vorbis_info_init
 35    vc>> vorbis_comment_init ;
 36
 37: init-theora ( player -- )
 38    dup ti>> theora_info_init
 39    tc>> theora_comment_init ;
 40
 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 ;
 46
 47: <player> ( stream -- player )
 48    player new
 49        swap >>stream
 50        0 >>vorbis
 51        0 >>theora
 52        0 >>video-time
 53        0 >>video-granulepos
 54        f >>video-ready?
 55        f >>audio-full?
 56        0 >>audio-index
 57        0 >>start-time
 58        audio-buffer-size "short" <c-array> >>audio-buffer
 59        0 >>audio-granulepos
 60        f >>playing?
 61        "ogg_packet" malloc-object >>op
 62        "ogg_sync_state" malloc-object >>oy
 63        "ogg_page" malloc-object >>og
 64        "ogg_stream_state" malloc-object >>vo
 65        "vorbis_info" malloc-object >>vi
 66        "vorbis_dsp_state" malloc-object >>vd
 67        "vorbis_block" malloc-object >>vb
 68        "vorbis_comment" malloc-object >>vc
 69        "ogg_stream_state" malloc-object >>to
 70        "theora_info" malloc-object >>ti
 71        "theora_comment" malloc-object >>tc
 72        "theora_state" malloc-object >>td
 73        "yuv_buffer" <c-object> >>yuv
 74        "ogg_stream_state" <c-object> >>temp-state
 75        dup init-sound
 76        dup init-vorbis
 77        dup init-theora ;
 78
 79: num-channels ( player -- channels )
 80    vi>> vorbis_info-channels ;
 81
 82: al-channel-format ( player -- format )
 83    num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;
 84
 85: get-time ( player -- time )
 86    dup start-time>> zero? [
 87        millis >>start-time
 88    ] when
 89    start-time>> millis swap - 1000.0 /f ;
 90
 91: clamp ( n -- n )
 92    255 min 0 max ; inline
 93
 94: stride ( line yuv  -- uvy yy )
 95    [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep
 96    yuv_buffer-y_stride >fixnum * >fixnum ; inline
 97
 98: each-with4 ( obj obj obj obj seq quot -- )
 99    4 each-withn ; inline
100
101: compute-y ( yuv uvy yy x -- y )
102    + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline
103
104: compute-v ( yuv uvy yy x -- v )
105    nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline
106
107: compute-u ( yuv uvy yy x -- v )
108    nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline
109
110: compute-yuv ( yuv uvy yy x -- y u v )
111    [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline
112
113: compute-blue ( y u v -- b )
114    drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
115
116: compute-green ( y u v -- g )
117    >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;
118    inline
119
120: compute-red ( y u v -- g )
121    nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
122
123: compute-rgb ( y u v -- b g r )
124    [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;
125    inline
126
127: store-rgb ( index rgb b g r -- index )
128    >r
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
132    drop ; inline
133
134: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
135    compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
136
137: yuv>rgb-row ( index rgb yuv y -- index )
138    over stride
139    pick yuv_buffer-y_width >fixnum
140    [ yuv>rgb-pixel ] each-with4 ; inline
141
142: yuv>rgb ( rgb yuv -- )
143    0 -rot
144    dup yuv_buffer-y_height >fixnum
145    [ yuv>rgb-row ] each-with2
146    drop ;
147
148HINTS: yuv>rgb byte-array byte-array ;
149
150: process-video ( player -- player )
151    dup gadget>> [
152        {
153            [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
154            [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
155            [ gadget>> relayout-1 yield ]
156            [ ]
157        } cleave
158    ] when ;
159
160: num-audio-buffers-processed ( player -- player n )
161    dup source>> AL_BUFFERS_PROCESSED 0 <uint>
162    [ alGetSourcei check-error ] keep *uint ;
163
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>> vorbis_info-rate alBufferData check-error ]  keep
169    [ source>> 1 ] keep
170    [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;
171
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 dup r> swap >r al-channel-format rot
177    [ audio-buffer>> dup length  ] keep
178    [ vi>> vorbis_info-rate alBufferData check-error ]  keep
179    [ source>> 1 ] keep
180    r> <uint> swap >r alSourceQueueBuffers check-error r> ;
181
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 ]
187    } cond ;
188
189: start-audio ( player -- player bool )
190    [ [ buffers>> first ] keep al-channel-format ] keep
191    [ audio-buffer>> dup length ] keep
192    [ vi>> vorbis_info-rate alBufferData check-error ]  keep
193    [ source>> 1 ] keep
194    [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep
195    [ source>> alSourcePlay check-error ] keep
196    t >>playing? t ;
197
198: process-audio ( player -- player bool )
199    dup playing?>> [ append-audio ] [ start-audio ] if ;
200
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  ;
205
206: check-not-negative ( int -- )
207    0 < [ "Word result was a negative number." throw ] when ;
208
209: buffer-size ( -- number )
210    4096 ; inline
211
212: sync-buffer ( player -- buffer size player )
213    [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;
214
215: stream-into-buffer ( buffer size player -- len player )
216    [ stream>> read-bytes-into ] keep ;
217
218: confirm-buffer ( len player -- player eof? )
219  [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
220
221: buffer-data ( player -- player eof? )
222    #! Take some compressed bitstream data and sync it for
223    #! page extraction.
224    sync-buffer stream-into-buffer confirm-buffer ;
225
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 ]
230    [ ] tri ;
231
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 > ;
236
237: standard-initial-header? ( player -- player bool )
238    dup og>> ogg_page_bos zero? not ;
239
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 ;
244
245: ogg-stream-pagein ( state player -- state player )
246    #! Add the incoming page to the stream state
247    [ og>> ogg_stream_pagein drop ] 2keep ;
248
249: ogg-stream-packetout ( state player -- state player )
250    [ op>> ogg_stream_packetout drop ] 2keep ;
251
252: decode-packet ( player -- state player )
253    ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
254
255: theora-header? ( player -- player bool )
256    #! Is the current page a theora header?
257    dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
258
259: is-theora-packet? ( player -- player bool )
260    dup theora>> zero? [ theora-header? ] [ f ] if ;
261
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 ;
265
266: handle-initial-theora-header ( state player -- player )
267    copy-to-theora-state 1 >>theora ;
268
269: vorbis-header? ( player -- player bool )
270    #! Is the current page a vorbis header?
271    dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
272
273: is-vorbis-packet? ( player -- player bool )
274    dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;
275
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 ;
279
280: handle-initial-vorbis-header ( state player -- player )
281    copy-to-vorbis-state 1 >>vorbis ;
282
283: handle-initial-unknown-header ( state player -- player )
284    swap ogg_stream_clear drop ;
285
286: process-initial-header ( player -- player bool )
287    #! Is this a standard initial header? If not, stop parsing
288    standard-initial-header? [
289        decode-packet {
290            { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
291            { [ is-theora-packet? ] [ handle-initial-theora-header ] }
292            [ handle-initial-unknown-header ]
293        } cond t
294    ] [
295        f
296    ] if ;
297
298: parse-initial-headers ( player -- player )
299    #! Parse Vorbis headers, ignoring any other type stored
300    #! in the Ogg container.
301    retrieve-page [
302        process-initial-header [
303            parse-initial-headers
304        ] [
305            #! Don't leak the page, get it into the appropriate stream
306            queue-page
307        ] if
308    ] [
309        buffer-data not [ parse-initial-headers ] when
310    ] if ;
311
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
315    #! yet.
316    dup vorbis>> 1 2 between? not ;
317
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
321    #! yet.
322    dup theora>> 1 2 between? not ;
323
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 ] }
328        { [ t     ] [ drop t ] }
329    } cond ;
330
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 ] }
335        { [ t     ] [ drop t ] }
336    } cond ;
337
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
341    ] unless ;
342
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
346    ] unless ;
347
348: increment-vorbis-header-count ( player -- player )
349    [ 1+ ] change-vorbis ;
350
351: increment-theora-header-count ( player -- player )
352    [ 1+ ] change-theora ;
353
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
360        ] when
361    ] when ;
362
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
369        ] when
370    ] when ;
371
372: get-more-header-data ( player -- player )
373    buffer-data drop ;
374
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
381    ] when ;
382
383: tear-down-vorbis ( player -- player )
384    dup vi>> vorbis_info_clear
385    dup vc>> vorbis_comment_clear ;
386
387: tear-down-theora ( player -- player )
388    dup ti>> theora_info_clear
389    dup tc>> theora_comment_clear ;
390
391: init-vorbis-codec ( player -- player )
392    dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
393    dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
394
395: init-theora-codec ( player -- player )
396    dup [ td>> ] [ ti>> ] bi theora_decode_init drop
397    dup ti>> theora_info-frame_width over ti>> theora_info-frame_height
398    4 * * <byte-array> >>rgb ;
399
400
401: display-vorbis-details ( player -- player )
402    [
403        "Ogg logical stream " %
404        dup vo>> ogg_stream_state-serialno #
405        " is Vorbis " %
406        dup vi>> vorbis_info-channels #
407        " channel " %
408        dup vi>> vorbis_info-rate #
409        " Hz audio." %
410    ] "" make print ;
411
412: display-theora-details ( player -- player )
413    [
414        "Ogg logical stream " %
415        dup to>> ogg_stream_state-serialno #
416        " is Theora " %
417        dup ti>> theora_info-width #
418        "x" %
419        dup ti>> theora_info-height #
420        " " %
421        dup ti>> theora_info-fps_numerator
422        over ti>> theora_info-fps_denominator /f #
423        " fps video" %
424    ] "" make print ;
425
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 ;
429
430: sync-pages ( player -- player )
431    retrieve-page [
432        queue-page sync-pages
433    ] when ;
434
435: audio-buffer-not-ready? ( player -- player bool )
436    dup vorbis>> zero? not over audio-full?>> not and ;
437
438: pending-decoded-audio? ( player -- player pcm len bool )
439    f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
440
441: buffer-space-available ( player -- available )
442    audio-buffer-size swap audio-index>> - ;
443
444: samples-to-read ( player available len -- numread )
445    >r swap num-channels / r> min ;
446
447: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
448
449: add-to-buffer ( player val -- )
450    over audio-index>> pick audio-buffer>> set-short-nth
451    [ 1+ ] change-audio-index drop ;
452
453: get-audio-value ( pcm sample channel -- value )
454    rot *void* void*-nth float-nth ;
455
456: process-channels ( player pcm sample channel -- )
457    get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;
458
459: (process-sample) ( player pcm sample -- )
460    pick num-channels [ process-channels ] each-with3 ;
461
462: process-samples ( player pcm numread -- )
463    [ (process-sample) ] each-with2 ;
464
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
469    ! numread player
470    dup audio-index>> audio-buffer-size = [
471        t >>audio-full?
472    ] when
473    dup vd>> vorbis_dsp_state-granulepos dup 0 >= [
474        ! numtoread player granulepos
475        #! This is wrong: fix
476        pick - >>audio-granulepos
477    ] [
478        ! numtoread player granulepos
479        pick + >>audio-granulepos
480    ] if
481    [ vd>> swap vorbis_synthesis_read drop ] keep ;
482
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
488        ] when
489        t
490    ] [
491        #! Need more data. Break out to suck in another page.
492        f
493    ] if ;
494
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
500        ] [
501            2drop no-pending-audio [ decode-audio ] when
502        ] if
503    ] when ;
504
505: video-buffer-not-ready? ( player -- player bool )
506    dup theora>> zero? not over video-ready?>> not and ;
507
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>> theora_state-granulepos >>video-granulepos
513            dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
514            >>video-time
515            t >>video-ready?
516            decode-video
517        ] when
518    ] when ;
519
520: decode ( player -- player )
521    get-more-header-data sync-pages
522    decode-audio
523    decode-video
524    dup audio-full?>> [
525        process-audio [
526            f >>audio-full?
527            0 >>audio-index
528        ] when
529    ] when
530    dup video-ready?>> [
531        dup video-time>> over get-time - dup 0.0 < [
532            -0.1 > [ process-video ] when
533            f >>video-ready?
534        ] [
535            drop
536        ] if
537    ] when
538    decode ;
539
540: free-malloced-objects ( player -- player )
541    {
542        [ op>> free ]
543        [ oy>> free ]
544        [ og>> free ]
545        [ vo>> free ]
546        [ vi>> free ]
547        [ vd>> free ]
548        [ vb>> free ]
549        [ vc>> free ]
550        [ to>> free ]
551        [ ti>> free ]
552        [ tc>> free ]
553        [ td>> free ]
554        [ ]
555    } cleave ;
556
557
558: unqueue-openal-buffers ( player -- player )
559    [
560
561        num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
562        alSourceUnqueueBuffers check-error
563    ] keep ;
564
565: delete-openal-buffers ( player -- player )
566    [
567        buffers>> [
568            1 swap <uint> alDeleteBuffers check-error
569        ] each
570    ] keep ;
571
572: delete-openal-source ( player -- player )
573    [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;
574
575: cleanup ( player -- player )
576    free-malloced-objects
577    unqueue-openal-buffers
578    delete-openal-buffers
579    delete-openal-source ;
580
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
584    *int AL_PLAYING = [
585        100 sleep
586        wait-for-sound
587    ] when ;
588
589TUPLE: theora-gadget < gadget player ;
590
591: <theora-gadget> ( player -- gadget )
592    theora-gadget new-gadget
593        swap >>player ;
594
595M: theora-gadget pref-dim*
596    player>>
597    ti>> dup theora_info-width swap theora_info-height 2array ;
598
599M: theora-gadget draw-gadget* ( gadget -- )
600    0 0 glRasterPos2i
601    1.0 -1.0 glPixelZoom
602    GL_UNPACK_ALIGNMENT 1 glPixelStorei
603    [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
604    player>> rgb>> glDrawPixels ;
605
606: initialize-gui ( gadget -- )
607    "Theora Player" open-window ;
608
609: play-ogg ( player -- )
610    parse-initial-headers
611    parse-remaining-headers
612    initialize-decoder
613    dup gadget>> [ initialize-gui ] when*
614    [ decode ] try
615    wait-for-sound
616    cleanup
617    drop ;
618
619: play-vorbis-stream ( stream -- )
620    <player> play-ogg ;
621
622: play-vorbis-file ( filename -- )
623    binary <file-reader> play-vorbis-stream ;
624
625: play-theora-stream ( stream -- )
626    <player>
627    dup <theora-gadget> >>gadget
628    play-ogg ;
629
630: play-theora-file ( filename -- )
631    binary <file-reader> play-theora-stream ;