unmaintained/ogg/player/player.factor

   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