! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
! TODO:
!   based on number of channels in file.
! - End of decoding is indicated by an exception when reading the stream.
!   How to work around this? C player example uses feof but streams don't
!   have that in Factor.
! - Work out openal buffer method that plays nicely with streaming over
!   slow connections.
! - Have start/stop/seek methods on the player object.
!
USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
       sequences libc shuffle alien.c-types system openal math
       namespaces threads shuffle opengl arrays ui.gadgets.worlds
       combinators math.parser ui.gadgets ui.render opengl.gl ui
       continuations io.files hints combinators.lib sequences.lib
       io.encodings.binary debugger math.order accessors ;

IN: ogg.player

: audio-buffer-size ( -- number ) 128 1024 * ; inline

TUPLE: player stream temp-state
       op oy og
       vo vi vd vb vc vorbis
       to ti tc td yuv rgb theora video-ready? video-time video-granulepos
       source buffers buffer-indexes start-time
       playing? audio-full? audio-index audio-buffer audio-granulepos
       gadget ;

: init-vorbis ( player -- )
    dup oy>> ogg_sync_init drop
    dup vi>> vorbis_info_init
    vc>> vorbis_comment_init ;

: init-theora ( player -- )
    dup ti>> theora_info_init
    tc>> theora_comment_init ;

: init-sound ( player -- )
    init-openal check-error
    1 gen-buffers check-error >>buffers
    2 uint <c-array> >>buffer-indexes
    1 gen-sources check-error first >>source drop ;

: <player> ( stream -- player )
    player new
        swap >>stream
        0 >>vorbis
        0 >>theora
        0 >>video-time
        0 >>video-granulepos
        f >>video-ready?
        f >>audio-full?
        0 >>audio-index
        0 >>start-time
        audio-buffer-size "short" <c-array> >>audio-buffer
        0 >>audio-granulepos
        f >>playing?
        ogg_packet malloc-struct >>op
        ogg_sync_state malloc-struct >>oy
        ogg_page malloc-struct >>og
        ogg_stream_state malloc-struct >>vo
        vorbis_info malloc-struct >>vi
        vorbis_dsp_state malloc-struct >>vd
        vorbis_block malloc-struct >>vb
        vorbis_comment malloc-struct >>vc
        ogg_stream_state malloc-struct >>to
        theora_info malloc-struct >>ti
        theora_comment malloc-struct >>tc
        theora_state malloc-struct >>td
        yuv_buffer <struct> >>yuv
        ogg_stream_state <struct> >>temp-state
        dup init-sound
        dup init-vorbis
        dup init-theora ;

: num-channels ( player -- channels )
    vi>> vorbis_info-channels ;

: al-channel-format ( player -- format )
    num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;

: get-time ( player -- time )
    dup start-time>> zero? [
        millis >>start-time
    ] when
    start-time>> millis swap - 1000.0 /f ;

: clamp ( n -- n )
    255 min 0 max ; inline

: stride ( line yuv  -- uvy yy )
    [ uv_stride>> >fixnum swap 2/ * ] 2keep
    y_stride>> >fixnum * >fixnum ; inline

: each-with4 ( obj obj obj obj seq quot -- )
    4 each-withn ; inline

: compute-y ( yuv uvy yy x -- y )
    + >fixnum nip swap y>> uchar-nth 16 - ; inline

: compute-v ( yuv uvy yy x -- v )
    nip 2/ + >fixnum swap u>> uchar-nth 128 - ; inline

: compute-u ( yuv uvy yy x -- v )
    nip 2/ + >fixnum swap v>> uchar-nth 128 - ; inline

: compute-yuv ( yuv uvy yy x -- y u v )
    [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline

: compute-blue ( y u v -- b )
    drop 516 * 128 + swap 298 * + -8 shift clamp ; inline

: compute-green ( y u v -- g )
    >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;
    inline

: compute-red ( y u v -- g )
    nip 409 * swap 298 * + 128 + -8 shift clamp ; inline

: compute-rgb ( y u v -- b g r )
    [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;
    inline

: store-rgb ( index rgb b g r -- index )
    >r
    >r pick 0 + >fixnum pick set-uchar-nth
    r> pick 1 + >fixnum pick set-uchar-nth
    r> pick 2 + >fixnum pick set-uchar-nth
    drop ; inline

: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
    compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline

: yuv>rgb-row ( index rgb yuv y -- index )
    over stride
    pick y_width>> >fixnum
    [ yuv>rgb-pixel ] each-with4 ; inline

: yuv>rgb ( rgb yuv -- )
    0 -rot
    dup y_height>> >fixnum
    [ yuv>rgb-row ] each-with2
    drop ;

HINTS: yuv>rgb byte-array byte-array ;

: process-video ( player -- player )
    dup gadget>> [
        {
            [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
            [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
            [ gadget>> relayout-1 yield ]
            [ ]
        } cleave
    ] when ;

: num-audio-buffers-processed ( player -- player n )
    dup source>> AL_BUFFERS_PROCESSED 0 uint <ref>
    [ alGetSourcei check-error ] keep uint deref ;

: append-new-audio-buffer ( player -- player )
    dup buffers>> 1 gen-buffers append >>buffers
    [ [ buffers>> second ] keep al-channel-format ] keep
    [ audio-buffer>> dup length  ] keep
    [ vi>> rate>> alBufferData check-error ]  keep
    [ source>> 1 ] keep
    [ buffers>> second uint <ref> alSourceQueueBuffers check-error ] keep ;

: fill-processed-audio-buffer ( player n -- player )
    ! n is the number of audio buffers processed
    over >r >r dup source>> r> pick buffer-indexes>>
    [ alSourceUnqueueBuffers check-error ] keep
    uint deref dup r> swap >r al-channel-format rot
    [ audio-buffer>> dup length  ] keep
    [ vi>> rate>> alBufferData check-error ]  keep
    [ source>> 1 ] keep
    r> uint <ref> swap >r alSourceQueueBuffers check-error r> ;

: append-audio ( player -- player bool )
    num-audio-buffers-processed {
        { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
        { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }
        [ fill-processed-audio-buffer t ]
    } cond ;

: start-audio ( player -- player bool )
    [ [ buffers>> first ] keep al-channel-format ] keep
    [ audio-buffer>> dup length ] keep
    [ vi>> rate>> alBufferData check-error ]  keep
    [ source>> 1 ] keep
    [ buffers>> first uint <ref> alSourceQueueBuffers check-error ] keep
    [ source>> alSourcePlay check-error ] keep
    t >>playing? t ;

: process-audio ( player -- player bool )
    dup playing?>> [ append-audio ] [ start-audio ] if ;

: read-bytes-into ( dest size stream -- len )
    ! Read the given number of bytes from a stream
    ! and store them in the destination byte array.
    stream-read >byte-array dup length [ memcpy ] keep  ;

: check-not-negative ( int -- )
    0 < [ "Word result was a negative number." throw ] when ;

: buffer-size ( -- number )
    4096 ; inline

: sync-buffer ( player -- buffer size player )
    [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;

: stream-into-buffer ( buffer size player -- len player )
    [ stream>> read-bytes-into ] keep ;

: confirm-buffer ( len player -- player eof? )
  [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;

: buffer-data ( player -- player eof? )
    ! Take some compressed bitstream data and sync it for
    ! page extraction.
    sync-buffer stream-into-buffer confirm-buffer ;

: queue-page ( player -- player )
    ! Push a page into the stream for packetization
    [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
    [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
    [ ] tri ;

: retrieve-page ( player -- player bool )
    ! Sync the streams and get a page. Return true if a page was
    ! successfully retrieved.
    dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;

: standard-initial-header? ( player -- player bool )
    dup og>> ogg_page_bos zero? not ;

: ogg-stream-init ( player -- state player )
    ! Init the encode/decode logical stream state
    [ temp-state>> ] keep
    [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;

: ogg-stream-pagein ( state player -- state player )
    ! Add the incoming page to the stream state
    [ og>> ogg_stream_pagein drop ] 2keep ;

: ogg-stream-packetout ( state player -- state player )
    [ op>> ogg_stream_packetout drop ] 2keep ;

: decode-packet ( player -- state player )
    ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;

: theora-header? ( player -- player bool )
    ! Is the current page a theora header?
    dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;

: is-theora-packet? ( player -- player bool )
    dup theora>> zero? [ theora-header? ] [ f ] if ;

: copy-to-theora-state ( state player -- player )
    ! Copy the state to the theora state structure in the player
    [ to>> swap dup length memcpy ] keep ;

: handle-initial-theora-header ( state player -- player )
    copy-to-theora-state 1 >>theora ;

: vorbis-header? ( player -- player bool )
    ! Is the current page a vorbis header?
    dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;

: is-vorbis-packet? ( player -- player bool )
    dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;

: copy-to-vorbis-state ( state player -- player )
    ! Copy the state to the vorbis state structure in the player
    [ vo>> swap dup length memcpy ] keep ;

: handle-initial-vorbis-header ( state player -- player )
    copy-to-vorbis-state 1 >>vorbis ;

: handle-initial-unknown-header ( state player -- player )
    swap ogg_stream_clear drop ;

: process-initial-header ( player -- player bool )
    ! Is this a standard initial header? If not, stop parsing
    standard-initial-header? [
        decode-packet {
            { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
            { [ is-theora-packet? ] [ handle-initial-theora-header ] }
            [ handle-initial-unknown-header ]
        } cond t
    ] [
        f
    ] if ;

: parse-initial-headers ( player -- player )
    ! Parse Vorbis headers, ignoring any other type stored
    ! in the Ogg container.
    retrieve-page [
        process-initial-header [
            parse-initial-headers
        ] [
            ! Don't leak the page, get it into the appropriate stream
            queue-page
        ] if
    ] [
        buffer-data not [ parse-initial-headers ] when
    ] if ;

: have-required-vorbis-headers? ( player -- player bool )
    ! Return true if we need to decode vorbis due to there being
    ! vorbis headers read from the stream but we don't have them all
    ! yet.
    dup vorbis>> 1 2 between? not ;

: have-required-theora-headers? ( player -- player bool )
    ! Return true if we need to decode theora due to there being
    ! theora headers read from the stream but we don't have them all
    ! yet.
    dup theora>> 1 2 between? not ;

: get-remaining-vorbis-header-packet ( player -- player bool )
    dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {
        { [ dup 0 <   ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
        { [ dup zero? ] [ drop f ] }
        { [ t     ] [ drop t ] }
    } cond ;

: get-remaining-theora-header-packet ( player -- player bool )
    dup [ to>> ] [ op>> ] bi ogg_stream_packetout {
        { [ dup 0 <   ] [ "Error parsing theora stream; corrupt stream?" throw ] }
        { [ dup zero? ] [ drop f ] }
        { [ t     ] [ drop t ] }
    } cond ;

: decode-remaining-vorbis-header-packet ( player -- player )
    dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [
        "Error parsing vorbis stream; corrupt stream?" throw
    ] unless ;

: decode-remaining-theora-header-packet ( player -- player )
    dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [
        "Error parsing theora stream; corrupt stream?" throw
    ] unless ;

: increment-vorbis-header-count ( player -- player )
    [ 1+ ] change-vorbis ;

: increment-theora-header-count ( player -- player )
    [ 1+ ] change-theora ;

: parse-remaining-vorbis-headers ( player -- player )
    have-required-vorbis-headers? not [
        get-remaining-vorbis-header-packet [
            decode-remaining-vorbis-header-packet
            increment-vorbis-header-count
            parse-remaining-vorbis-headers
        ] when
    ] when ;

: parse-remaining-theora-headers ( player -- player )
    have-required-theora-headers? not [
        get-remaining-theora-header-packet [
            decode-remaining-theora-header-packet
            increment-theora-header-count
            parse-remaining-theora-headers
        ] when
    ] when ;

: get-more-header-data ( player -- player )
    buffer-data drop ;

: parse-remaining-headers ( player -- player )
    have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
        parse-remaining-vorbis-headers
        parse-remaining-theora-headers
        retrieve-page [ queue-page ] [ get-more-header-data ] if
        parse-remaining-headers
    ] when ;

: tear-down-vorbis ( player -- player )
    dup vi>> vorbis_info_clear
    dup vc>> vorbis_comment_clear ;

: tear-down-theora ( player -- player )
    dup ti>> theora_info_clear
    dup tc>> theora_comment_clear ;

: init-vorbis-codec ( player -- player )
    dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
    dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;

: init-theora-codec ( player -- player )
    dup [ td>> ] [ ti>> ] bi theora_decode_init drop
    dup ti>> frame_width>> over ti>> frame_height>>
    4 * * <byte-array> >>rgb ;


: display-vorbis-details ( player -- player )
    [
        "Ogg logical stream " %
        dup vo>> serialno>> #
        " is Vorbis " %
        dup vi>> channels>> #
        " channel " %
        dup vi>> rate>> #
        " Hz audio." %
    ] "" make print ;

: display-theora-details ( player -- player )
    [
        "Ogg logical stream " %
        dup to>> serialno>> #
        " is Theora " %
        dup ti>> width>> #
        "x" %
        dup ti>> height>> #
        " " %
        dup ti>> fps_numerator>>
        over ti>> fps_denominator>> /f #
        " fps video" %
    ] "" make print ;

: initialize-decoder ( player -- player )
    dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
    dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;

: sync-pages ( player -- player )
    retrieve-page [
        queue-page sync-pages
    ] when ;

: audio-buffer-not-ready? ( player -- player bool )
    dup vorbis>> zero? not over audio-full?>> not and ;

: pending-decoded-audio? ( player -- player pcm len bool )
    f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;

: buffer-space-available ( player -- available )
    audio-buffer-size swap audio-index>> - ;

: samples-to-read ( player available len -- numread )
    >r swap num-channels / r> min ;

: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline

: add-to-buffer ( player val -- )
    over audio-index>> pick audio-buffer>> set-short-nth
    [ 1+ ] change-audio-index drop ;

: get-audio-value ( pcm sample channel -- value )
    rot *void* void*-nth float-nth ;

: process-channels ( player pcm sample channel -- )
    get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;

: (process-sample) ( player pcm sample -- )
    pick num-channels [ process-channels ] each-with3 ;

: process-samples ( player pcm numread -- )
    [ (process-sample) ] each-with2 ;

: decode-pending-audio ( player pcm result -- player )
!     [ "ret = " % dup # ] "" make write
    pick [ buffer-space-available swap ] keep -rot samples-to-read
    pick over >r >r process-samples r> r> swap
    ! numread player
    dup audio-index>> audio-buffer-size = [
        t >>audio-full?
    ] when
    dup vd>> granulepos>> dup 0 >= [
        ! numtoread player granulepos
        ! This is wrong: fix
        pick - >>audio-granulepos
    ] [
        ! numtoread player granulepos
        pick + >>audio-granulepos
    ] if
    [ vd>> swap vorbis_synthesis_read drop ] keep ;

: no-pending-audio ( player -- player bool )
    ! No pending audio. Is there a pending packet to decode.
    dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
        dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
            dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
        ] when
        t
    ] [
        ! Need more data. Break out to suck in another page.
        f
    ] if ;

: decode-audio ( player -- player )
    audio-buffer-not-ready? [
        ! If there's pending decoded audio, grab it
        pending-decoded-audio? [
            decode-pending-audio decode-audio
        ] [
            2drop no-pending-audio [ decode-audio ] when
        ] if
    ] when ;

: video-buffer-not-ready? ( player -- player bool )
    dup theora>> zero? not over video-ready?>> not and ;

: decode-video ( player -- player )
    video-buffer-not-ready? [
        dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
            dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
            dup td>> granulepos>> >>video-granulepos
            dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
            >>video-time
            t >>video-ready?
            decode-video
        ] when
    ] when ;

: decode ( player -- player )
    get-more-header-data sync-pages
    decode-audio
    decode-video
    dup audio-full?>> [
        process-audio [
            f >>audio-full?
            0 >>audio-index
        ] when
    ] when
    dup video-ready?>> [
        dup video-time>> over get-time - dup 0.0 < [
            -0.1 > [ process-video ] when
            f >>video-ready?
        ] [
            drop
        ] if
    ] when
    decode ;

: free-malloced-objects ( player -- player )
    {
        [ op>> free ]
        [ oy>> free ]
        [ og>> free ]
        [ vo>> free ]
        [ vi>> free ]
        [ vd>> free ]
        [ vb>> free ]
        [ vc>> free ]
        [ to>> free ]
        [ ti>> free ]
        [ tc>> free ]
        [ td>> free ]
        [ ]
    } cleave ;


: unqueue-openal-buffers ( player -- player )
    [

        num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
        alSourceUnqueueBuffers check-error
    ] keep ;

: delete-openal-buffers ( player -- player )
    [
        buffers>> [
            1 swap uint <ref> alDeleteBuffers check-error
        ] each
    ] keep ;

: delete-openal-source ( player -- player )
    [ source>> 1 swap uint <ref> alDeleteSources check-error ] keep ;

: cleanup ( player -- player )
    free-malloced-objects
    unqueue-openal-buffers
    delete-openal-buffers
    delete-openal-source ;

: wait-for-sound ( player -- player )
    ! Waits for the openal to finish playing remaining sounds
    dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
    *int AL_PLAYING = [
        100 sleep
        wait-for-sound
    ] when ;

TUPLE: theora-gadget < gadget player ;

: <theora-gadget> ( player -- gadget )
    theora-gadget new-gadget
        swap >>player ;

M: theora-gadget pref-dim*
    player>>
    ti>> dup width>> swap height>> 2array ;

M: theora-gadget draw-gadget* ( gadget -- )
    0 0 glRasterPos2i
    1.0 -1.0 glPixelZoom
    GL_UNPACK_ALIGNMENT 1 glPixelStorei
    [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
    player>> rgb>> glDrawPixels ;

: initialize-gui ( gadget -- )
    "Theora Player" open-window ;

: play-ogg ( player -- )
    parse-initial-headers
    parse-remaining-headers
    initialize-decoder
    dup gadget>> [ initialize-gui ] when*
    [ decode ] try
    wait-for-sound
    cleanup
    drop ;

: play-vorbis-stream ( stream -- )
    <player> play-ogg ;

: play-vorbis-file ( filename -- )
    binary <file-reader> play-vorbis-stream ;

: play-theora-stream ( stream -- )
    <player>
    dup <theora-gadget> >>gadget
    play-ogg ;

: play-theora-file ( filename -- )
    binary <file-reader> play-theora-stream ;