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 ;\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 player-oy ogg_sync_init drop\r
  34     dup player-vi vorbis_info_init\r
  35     player-vc vorbis_comment_init ;\r
  36 \r
  37 : init-theora ( player -- )\r
  38     dup player-ti theora_info_init\r
  39     player-tc theora_comment_init ;\r
  40 \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
  46 \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
  74     dup init-sound\r
  75     dup init-vorbis\r
  76     dup init-theora ;\r
  77 \r
  78 : num-channels ( player -- channels )\r
  79     player-vi vorbis_info-channels ;\r
  80 \r
  81 : al-channel-format ( player -- format )\r
  82     num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ;\r
  83 \r
  84 : get-time ( player -- time )\r
  85     dup player-start-time zero? [\r
  86         millis over set-player-start-time\r
  87     ] when\r
  88     player-start-time millis swap - 1000.0 /f ;\r
  89 \r
  90 : clamp ( n -- n )\r
  91     255 min 0 max ; inline\r
  92 \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
  96 \r
  97 : each-with4 ( obj obj obj obj seq quot -- )\r
  98     4 each-withn ; inline\r
  99 \r
 100 : compute-y ( yuv uvy yy x -- y )\r
 101     + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline\r
 102 \r
 103 : compute-v ( yuv uvy yy x -- v )\r
 104     nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline\r
 105 \r
 106 : compute-u ( yuv uvy yy x -- v )\r
 107     nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline\r
 108 \r
 109 : compute-yuv ( yuv uvy yy x -- y u v )\r
 110     [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline\r
 111 \r
 112 : compute-blue ( y u v -- b )\r
 113     drop 516 * 128 + swap 298 * + -8 shift clamp ; inline\r
 114 \r
 115 : compute-green ( y u v -- g )\r
 116     >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;\r
 117     inline\r
 118 \r
 119 : compute-red ( y u v -- g )\r
 120     nip 409 * swap 298 * + 128 + -8 shift clamp ; inline\r
 121 \r
 122 : compute-rgb ( y u v -- b g r )\r
 123     [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;\r
 124     inline\r
 125 \r
 126 : store-rgb ( index rgb b g r -- index )\r
 127     >r\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
 131     drop ; inline\r
 132 \r
 133 : yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )\r
 134     compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline\r
 135 \r
 136 : yuv>rgb-row ( index rgb yuv y -- index )\r
 137     over stride\r
 138     pick yuv_buffer-y_width >fixnum\r
 139     [ yuv>rgb-pixel ] each-with4 ; inline\r
 140 \r
 141 : yuv>rgb ( rgb yuv  -- )\r
 142     0 -rot\r
 143     dup yuv_buffer-y_height >fixnum\r
 144     [ yuv>rgb-row ] each-with2\r
 145     drop ;\r
 146 \r
 147 HINTS: yuv>rgb byte-array byte-array ;\r
 148 \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
 154     ] when ;\r
 155 \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
 159 \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
 167 \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
 177 \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
 183     } cond ;\r
 184 \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
 193 \r
 194 : process-audio ( player -- player bool )\r
 195     dup player-playing? [ append-audio ] [ start-audio ] if ;\r
 196 \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
 201 \r
 202 : check-not-negative ( int -- )\r
 203     0 < [ "Word result was a negative number." throw ] when ;\r
 204 \r
 205 : buffer-size ( -- number )\r
 206     4096 ; inline\r
 207 \r
 208 : sync-buffer ( player -- buffer size player )\r
 209     [ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ;\r
 210 \r
 211 : stream-into-buffer ( buffer size player -- len player )\r
 212     [ player-stream read-bytes-into ] keep ;\r
 213 \r
 214 : confirm-buffer ( len player -- player eof? )\r
 215   [ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;\r
 216 \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
 221 \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
 226 \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
 231 \r
 232 : standard-initial-header? ( player -- player bool )\r
 233     dup player-og ogg_page_bos zero? not ;\r
 234 \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
 239 \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
 243 \r
 244 : ogg-stream-packetout ( state player -- state player )\r
 245     [ player-op ogg_stream_packetout drop ] 2keep ;\r
 246 \r
 247 : decode-packet ( player -- state player )\r
 248     ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;\r
 249 \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
 253 \r
 254 : is-theora-packet? ( player -- player bool )\r
 255     dup player-theora zero? [ theora-header? ] [ f ] if ;\r
 256 \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
 260 \r
 261 : handle-initial-theora-header ( state player -- player )\r
 262     copy-to-theora-state 1 over set-player-theora ;\r
 263 \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
 267 \r
 268 : is-vorbis-packet? ( player -- player bool )\r
 269     dup player-vorbis zero? [ vorbis-header? ] [ f ] if ;\r
 270 \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
 274 \r
 275 : handle-initial-vorbis-header ( state player -- player )\r
 276     copy-to-vorbis-state 1 over set-player-vorbis ;\r
 277 \r
 278 : handle-initial-unknown-header ( state player -- player )\r
 279     swap ogg_stream_clear drop ;\r
 280 \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
 284         decode-packet {\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
 288         } cond t\r
 289     ] [\r
 290         f\r
 291     ] if ;\r
 292 \r
 293 : parse-initial-headers ( player -- player )\r
 294     #! Parse Vorbis headers, ignoring any other type stored\r
 295     #! in the Ogg container.\r
 296     retrieve-page [\r
 297         process-initial-header [\r
 298             parse-initial-headers\r
 299         ] [\r
 300             #! Don't leak the page, get it into the appropriate stream\r
 301             queue-page\r
 302         ] if\r
 303     ] [\r
 304         buffer-data not [ parse-initial-headers ] when\r
 305     ] if ;\r
 306 \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
 310     #! yet.\r
 311     dup player-vorbis 1 2 between? not ;\r
 312 \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
 316     #! yet.\r
 317     dup player-theora 1 2 between? not ;\r
 318 \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
 324     } cond ;\r
 325 \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
 331     } cond ;\r
 332 \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
 336     ] unless ;\r
 337 \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
 341     ] unless ;\r
 342 \r
 343 : increment-vorbis-header-count ( player -- player )\r
 344     dup player-vorbis 1+ over set-player-vorbis ;\r
 345 \r
 346 : increment-theora-header-count ( player -- player )\r
 347     dup player-theora 1+ over set-player-theora ;\r
 348 \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
 355         ] when\r
 356     ] when ;\r
 357 \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
 364         ] when\r
 365     ] when ;\r
 366 \r
 367 : get-more-header-data ( player -- player )\r
 368     buffer-data drop ;\r
 369 \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
 376     ] when ;\r
 377 \r
 378 : tear-down-vorbis ( player -- player )\r
 379     dup player-vi vorbis_info_clear\r
 380     dup player-vc vorbis_comment_clear ;\r
 381 \r
 382 : tear-down-theora ( player -- player )\r
 383     dup player-ti theora_info_clear\r
 384     dup player-tc theora_comment_clear ;\r
 385 \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
 389 \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
 394 \r
 395 \r
 396 : display-vorbis-details ( player -- player )\r
 397     [\r
 398         "Ogg logical stream " %\r
 399         dup player-vo ogg_stream_state-serialno #\r
 400         " is Vorbis " %\r
 401         dup player-vi vorbis_info-channels #\r
 402         " channel " %\r
 403         dup player-vi vorbis_info-rate #\r
 404         " Hz audio." %\r
 405     ] "" make print ;\r
 406 \r
 407 : display-theora-details ( player -- player )\r
 408     [\r
 409         "Ogg logical stream " %\r
 410         dup player-to ogg_stream_state-serialno #\r
 411         " is Theora " %\r
 412         dup player-ti theora_info-width #\r
 413         "x" %\r
 414         dup player-ti theora_info-height #\r
 415         " " %\r
 416         dup player-ti theora_info-fps_numerator\r
 417         over player-ti theora_info-fps_denominator /f #\r
 418         " fps video" %\r
 419     ] "" make print ;\r
 420 \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
 424 \r
 425 : sync-pages ( player -- player )\r
 426     retrieve-page [\r
 427         queue-page sync-pages\r
 428     ] when ;\r
 429 \r
 430 : audio-buffer-not-ready? ( player -- player bool )\r
 431     dup player-vorbis zero? not over player-audio-full? not and ;\r
 432 \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
 435 \r
 436 : buffer-space-available ( player -- available )\r
 437     audio-buffer-size swap player-audio-index - ;\r
 438 \r
 439 : samples-to-read ( player available len -- numread )\r
 440     >r swap num-channels / r> min ;\r
 441 \r
 442 : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline\r
 443 \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
 447 \r
 448 : get-audio-value ( pcm sample channel -- value )\r
 449     rot *void* void*-nth float-nth ;\r
 450 \r
 451 : process-channels ( player pcm sample channel -- )\r
 452     get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;\r
 453 \r
 454 : (process-sample) ( player pcm sample -- )\r
 455     pick num-channels [ process-channels ] each-with3 ;\r
 456 \r
 457 : process-samples ( player pcm numread -- )\r
 458     [ (process-sample) ] each-with2 ;\r
 459 \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
 464     ! numread player\r
 465     dup player-audio-index audio-buffer-size = [\r
 466         t over set-player-audio-full?\r
 467     ] when\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
 472     ] [\r
 473         ! numtoread player granulepos\r
 474         pick + over set-player-audio-granulepos\r
 475     ] if\r
 476     [ player-vd swap vorbis_synthesis_read drop ] keep ;\r
 477 \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
 483         ] when\r
 484         t\r
 485     ] [\r
 486         #! Need more data. Break out to suck in another page.\r
 487         f\r
 488     ] if ;\r
 489 \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
 495         ] [\r
 496             2drop no-pending-audio [ decode-audio ] when\r
 497         ] if\r
 498     ] when ;\r
 499 \r
 500 : video-buffer-not-ready? ( player -- player bool )\r
 501     dup player-theora zero? not over player-video-ready? not and ;\r
 502 \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
 511             decode-video\r
 512         ] when\r
 513     ] when ;\r
 514 \r
 515 : decode ( player -- player )\r
 516     get-more-header-data sync-pages\r
 517     decode-audio\r
 518     decode-video\r
 519     dup player-audio-full? [\r
 520         process-audio [\r
 521             f over set-player-audio-full?\r
 522             0 over set-player-audio-index\r
 523         ] when\r
 524     ] when\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
 529         ] [\r
 530             drop\r
 531         ] if\r
 532     ] when\r
 533     decode ;\r
 534 \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
 548 \r
 549 \r
 550 : unqueue-openal-buffers ( player -- player )\r
 551     [\r
 552 \r
 553         num-audio-buffers-processed over player-source rot player-buffer-indexes swapd\r
 554         alSourceUnqueueBuffers check-error\r
 555     ] keep ;\r
 556 \r
 557 : delete-openal-buffers ( player -- player )\r
 558     [\r
 559         player-buffers [\r
 560             1 swap <uint> alDeleteBuffers check-error\r
 561         ] each\r
 562     ] keep ;\r
 563 \r
 564 : delete-openal-source ( player -- player )\r
 565     [ player-source 1 swap <uint> alDeleteSources check-error ] keep ;\r
 566 \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
 572 \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
 577         100 sleep\r
 578         wait-for-sound\r
 579     ] when ;\r
 580 \r
 581 TUPLE: theora-gadget player ;\r
 582 \r
 583 : <theora-gadget> ( player -- gadget )\r
 584   theora-gadget construct-gadget\r
 585   [ set-theora-gadget-player ] keep ;\r
 586 \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
 590 \r
 591 M: theora-gadget draw-gadget* ( gadget -- )\r
 592     0 0 glRasterPos2i\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
 597 \r
 598 : initialize-gui ( gadget -- )\r
 599     "Theora Player" open-window ;\r
 600 \r
 601 : play-ogg ( player -- )\r
 602     parse-initial-headers\r
 603     parse-remaining-headers\r
 604     initialize-decoder\r
 605     dup player-gadget [ initialize-gui ] when*\r
 606     [ decode ] try\r
 607     wait-for-sound\r
 608     cleanup\r
 609     drop ;\r
 610 \r
 611 : play-vorbis-stream ( stream -- )\r
 612     <player> play-ogg ;\r
 613 \r
 614 : play-vorbis-file ( filename -- )\r
 615     binary <file-reader> play-vorbis-stream ;\r
 616 \r
 617 : play-theora-stream ( stream -- )\r
 618     <player>\r
 619     dup <theora-gadget> over set-player-gadget\r
 620     play-ogg ;\r
 621 \r
 622 : play-theora-file ( filename -- )\r
 623     binary <file-reader> play-theora-stream ;\r
 624 \r