steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-09-11 00:37:21 -05:00
parent ff97d589c9 61a1625880
commit 7597ebf462
6 changed files with 212 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/base64/base64.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences io.binary splitting grouping ;
USING: kernel math sequences io.binary splitting grouping
accessors ;
IN: base64
<PRIVATE
: count-end ( seq quot -- count )
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline
: count-end ( seq quot -- n )
trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@ -21,13 +22,16 @@ IN: base64
} nth ;
: encode3 ( seq -- seq )
be> 4 <reversed> [ -6 * shift HEX: 3f bitand ch>base64 ] with B{ } map-as ;
be> 4 <reversed> [
-6 * shift HEX: 3f bitand ch>base64
] with B{ } map-as ;
: decode4 ( str -- str )
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str )
[ 3 0 pad-right encode3 ] [ length 1+ ] bi head 4 CHAR: = pad-right ;
[ 3 0 pad-right encode3 ] [ length 1+ ] bi
head-slice 4 CHAR: = pad-right ;
PRIVATE>
@ -42,5 +46,5 @@ PRIVATE>
: base64> ( base64 -- str )
#! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = not ] count-end ]
[ [ CHAR: = = ] count-end ]
bi head* ;

4
basis/db/db-docs.factor
View File

@ -12,11 +12,11 @@ HELP: new-db
{ $description "Creates a new database object from a given class." } ;
HELP: make-db*
{ $values { "seq" sequence } { "db" object } { "db" object } }
{ $values { "object" object } { "db" object } { "db" object } }
{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
HELP: make-db
{ $values { "seq" sequence } { "class" class } { "db" db } }
{ $values { "object" object } { "class" class } { "db" db } }
{ $description "Takes a sequence of parameters specific to each database and a class name of the database, and constructs a new database object." } ;
HELP: db-open

6
basis/random/random.factor
View File

@ -36,9 +36,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
: random ( seq -- elt )
[ f ] [
[
length dup log2 7 + 8 /i 1+ random-bytes
[ length 3 shift 2^ ] [ byte-array>bignum ] bi
swap / * >integer
length dup log2 7 + 8 /i 1+
[ random-bytes byte-array>bignum ]
[ 3 shift 2^ ] bi / * >integer
] keep nth
] if-empty ;

16
extra/webapps/ip/ip.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions http.server.dispatchers
html.forms io.servers.connection namespaces prettyprint ;
IN: webapps.ip
TUPLE: ip-app < dispatcher ;
: <display-ip-action> ( -- action )
<page-action>
[ remote-address get host>> "ip" set-value ] >>init
{ ip-app "ip" } >>template ;
: <ip-app> ( -- dispatcher )
ip-app new-dispatcher
<display-ip-action> "" add-responder ;

7
extra/webapps/ip/ip.xml Normal file
View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<body>Your IP address is: <t:label t:name="ip" />
</body>
</html>
</t:chloe>

341
unmaintained/ogg/player/player.factor
View File

@ -15,7 +15,7 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
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 ;
io.encodings.binary debugger math.order accessors ;
IN: ogg.player
@ -30,62 +30,63 @@ TUPLE: player stream temp-state
gadget ;
: init-vorbis ( player -- )
dup player-oy ogg_sync_init drop
dup player-vi vorbis_info_init
player-vc vorbis_comment_init ;
dup oy>> ogg_sync_init drop
dup vi>> vorbis_info_init
vc>> vorbis_comment_init ;
: init-theora ( player -- )
dup player-ti theora_info_init
player-tc theora_comment_init ;
dup ti>> theora_info_init
tc>> theora_comment_init ;
: init-sound ( player -- )
init-openal check-error
1 gen-buffers check-error over set-player-buffers
2 "uint" <c-array> over set-player-buffer-indexes
1 gen-sources check-error first swap set-player-source ;
1 gen-buffers check-error >>buffers
2 "uint" <c-array> >>buffer-indexes
1 gen-sources check-error first >>source drop ;
: <player> ( stream -- player )
{ set-player-stream } player construct
0 over set-player-vorbis
0 over set-player-theora
0 over set-player-video-time
0 over set-player-video-granulepos
f over set-player-video-ready?
f over set-player-audio-full?
0 over set-player-audio-index
0 over set-player-start-time
audio-buffer-size "short" <c-array> over set-player-audio-buffer
0 over set-player-audio-granulepos
f over set-player-playing?
"ogg_packet" malloc-object over set-player-op
"ogg_sync_state" malloc-object over set-player-oy
"ogg_page" malloc-object over set-player-og
"ogg_stream_state" malloc-object over set-player-vo
"vorbis_info" malloc-object over set-player-vi
"vorbis_dsp_state" malloc-object over set-player-vd
"vorbis_block" malloc-object over set-player-vb
"vorbis_comment" malloc-object over set-player-vc
"ogg_stream_state" malloc-object over set-player-to
"theora_info" malloc-object over set-player-ti
"theora_comment" malloc-object over set-player-tc
"theora_state" malloc-object over set-player-td
"yuv_buffer" <c-object> over set-player-yuv
"ogg_stream_state" <c-object> over set-player-temp-state
dup init-sound
dup init-vorbis
dup init-theora ;
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-object >>op
"ogg_sync_state" malloc-object >>oy
"ogg_page" malloc-object >>og
"ogg_stream_state" malloc-object >>vo
"vorbis_info" malloc-object >>vi
"vorbis_dsp_state" malloc-object >>vd
"vorbis_block" malloc-object >>vb
"vorbis_comment" malloc-object >>vc
"ogg_stream_state" malloc-object >>to
"theora_info" malloc-object >>ti
"theora_comment" malloc-object >>tc
"theora_state" malloc-object >>td
"yuv_buffer" <c-object> >>yuv
"ogg_stream_state" <c-object> >>temp-state
dup init-sound
dup init-vorbis
dup init-theora ;
: num-channels ( player -- channels )
player-vi vorbis_info-channels ;
vi>> vorbis_info-channels ;
: al-channel-format ( player -- format )
num-channels 1 = [ AL_FORMAT_MONO16 ] [ AL_FORMAT_STEREO16 ] if ;
num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;
: get-time ( player -- time )
dup player-start-time zero? [
millis over set-player-start-time
dup start-time>> zero? [
millis >>start-time
] when
player-start-time millis swap - 1000.0 /f ;
start-time>> millis swap - 1000.0 /f ;
: clamp ( n -- n )
255 min 0 max ; inline
@ -138,7 +139,7 @@ TUPLE: player stream temp-state
pick yuv_buffer-y_width >fixnum
[ yuv>rgb-pixel ] each-with4 ; inline
: yuv>rgb ( rgb yuv -- )
: yuv>rgb ( rgb yuv -- )
0 -rot
dup yuv_buffer-y_height >fixnum
[ yuv>rgb-row ] each-with2
@ -147,52 +148,55 @@ TUPLE: player stream temp-state
HINTS: yuv>rgb byte-array byte-array ;
: process-video ( player -- player )
dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb
dup player-gadget relayout-1 yield
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 player-source AL_BUFFERS_PROCESSED 0 <uint>
dup source>> AL_BUFFERS_PROCESSED 0 <uint>
[ alGetSourcei check-error ] keep *uint ;
: append-new-audio-buffer ( player -- player )
dup player-buffers 1 gen-buffers append over set-player-buffers
[ [ player-buffers second ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
[ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ;
dup buffers>> 1 gen-buffers append >>buffers
[ [ buffers>> second ] keep al-channel-format ] keep
[ audio-buffer>> dup length ] keep
[ vi>> vorbis_info-rate alBufferData check-error ] keep
[ source>> 1 ] keep
[ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;
: fill-processed-audio-buffer ( player n -- player )
#! n is the number of audio buffers processed
over >r >r dup player-source r> pick player-buffer-indexes
over >r >r dup source>> r> pick buffer-indexes>>
[ alSourceUnqueueBuffers check-error ] keep
*uint dup r> swap >r al-channel-format rot
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
[ audio-buffer>> dup length ] keep
[ vi>> vorbis_info-rate alBufferData check-error ] keep
[ source>> 1 ] keep
r> <uint> swap >r alSourceQueueBuffers check-error r> ;
: append-audio ( player -- player bool )
num-audio-buffers-processed {
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }
{ [ 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 )
[ [ player-buffers first ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep
[ player-buffers first <uint> alSourceQueueBuffers check-error ] keep
[ player-source alSourcePlay check-error ] keep
t over set-player-playing? t ;
[ [ buffers>> first ] keep al-channel-format ] keep
[ audio-buffer>> dup length ] keep
[ vi>> vorbis_info-rate alBufferData check-error ] keep
[ source>> 1 ] keep
[ buffers>> first <uint> alSourceQueueBuffers check-error ] keep
[ source>> alSourcePlay check-error ] keep
t >>playing? t ;
: process-audio ( player -- player bool )
dup player-playing? [ append-audio ] [ start-audio ] if ;
dup playing?>> [ append-audio ] [ start-audio ] if ;
: read-bytes-into ( dest size stream -- len )
#! Read the given number of bytes from a stream
@ -206,13 +210,13 @@ HINTS: yuv>rgb byte-array byte-array ;
4096 ; inline
: sync-buffer ( player -- buffer size player )
[ player-oy buffer-size ogg_sync_buffer buffer-size ] keep ;
[ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;
: stream-into-buffer ( buffer size player -- len player )
[ player-stream read-bytes-into ] keep ;
[ stream>> read-bytes-into ] keep ;
: confirm-buffer ( len player -- player eof? )
[ player-oy swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
[ 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
@ -221,59 +225,60 @@ HINTS: yuv>rgb byte-array byte-array ;
: queue-page ( player -- player )
#! Push a page into the stream for packetization
[ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep
[ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ;
[ [ 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 { player-oy player-og } get-slots ogg_sync_pageout 0 > ;
dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;
: standard-initial-header? ( player -- player bool )
dup player-og ogg_page_bos zero? not ;
dup og>> ogg_page_bos zero? not ;
: ogg-stream-init ( player -- state player )
#! Init the encode/decode logical stream state
[ player-temp-state ] keep
[ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
[ 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
[ player-og ogg_stream_pagein drop ] 2keep ;
[ og>> ogg_stream_pagein drop ] 2keep ;
: ogg-stream-packetout ( state player -- state player )
[ player-op ogg_stream_packetout drop ] 2keep ;
[ 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 { player-ti player-tc player-op } get-slots theora_decode_header 0 >= ;
dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
: is-theora-packet? ( player -- player bool )
dup player-theora zero? [ theora-header? ] [ f ] if ;
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
[ player-to swap dup length memcpy ] keep ;
[ to>> swap dup length memcpy ] keep ;
: handle-initial-theora-header ( state player -- player )
copy-to-theora-state 1 over set-player-theora ;
copy-to-theora-state 1 >>theora ;
: vorbis-header? ( player -- player bool )
#! Is the current page a vorbis header?
dup { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin 0 >= ;
dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
: is-vorbis-packet? ( player -- player bool )
dup player-vorbis zero? [ vorbis-header? ] [ f ] if ;
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
[ player-vo swap dup length memcpy ] keep ;
[ vo>> swap dup length memcpy ] keep ;
: handle-initial-vorbis-header ( state player -- player )
copy-to-vorbis-state 1 over set-player-vorbis ;
copy-to-vorbis-state 1 >>vorbis ;
: handle-initial-unknown-header ( state player -- player )
swap ogg_stream_clear drop ;
@ -308,43 +313,43 @@ HINTS: yuv>rgb byte-array byte-array ;
#! 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 player-vorbis 1 2 between? not ;
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 player-theora 1 2 between? not ;
dup theora>> 1 2 between? not ;
: get-remaining-vorbis-header-packet ( player -- player bool )
dup { player-vo player-op } get-slots ogg_stream_packetout {
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 { player-to player-op } get-slots ogg_stream_packetout {
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 { player-vi player-vc player-op } get-slots vorbis_synthesis_headerin zero? [
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 { player-ti player-tc player-op } get-slots theora_decode_header zero? [
dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [
"Error parsing theora stream; corrupt stream?" throw
] unless ;
: increment-vorbis-header-count ( player -- player )
dup player-vorbis 1+ over set-player-vorbis ;
[ 1+ ] change-vorbis ;
: increment-theora-header-count ( player -- player )
dup player-theora 1+ over set-player-theora ;
[ 1+ ] change-theora ;
: parse-remaining-vorbis-headers ( player -- player )
have-required-vorbis-headers? not [
@ -376,51 +381,51 @@ HINTS: yuv>rgb byte-array byte-array ;
] when ;
: tear-down-vorbis ( player -- player )
dup player-vi vorbis_info_clear
dup player-vc vorbis_comment_clear ;
dup vi>> vorbis_info_clear
dup vc>> vorbis_comment_clear ;
: tear-down-theora ( player -- player )
dup player-ti theora_info_clear
dup player-tc theora_comment_clear ;
dup ti>> theora_info_clear
dup tc>> theora_comment_clear ;
: init-vorbis-codec ( player -- player )
dup { player-vd player-vi } get-slots vorbis_synthesis_init drop
dup { player-vd player-vb } get-slots vorbis_block_init drop ;
dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
: init-theora-codec ( player -- player )
dup { player-td player-ti } get-slots theora_decode_init drop
dup player-ti theora_info-frame_width over player-ti theora_info-frame_height
4 * * <byte-array> over set-player-rgb ;
dup [ td>> ] [ ti>> ] bi theora_decode_init drop
dup ti>> theora_info-frame_width over ti>> theora_info-frame_height
4 * * <byte-array> >>rgb ;
: display-vorbis-details ( player -- player )
[
"Ogg logical stream " %
dup player-vo ogg_stream_state-serialno #
dup vo>> ogg_stream_state-serialno #
" is Vorbis " %
dup player-vi vorbis_info-channels #
dup vi>> vorbis_info-channels #
" channel " %
dup player-vi vorbis_info-rate #
dup vi>> vorbis_info-rate #
" Hz audio." %
] "" make print ;
: display-theora-details ( player -- player )
[
"Ogg logical stream " %
dup player-to ogg_stream_state-serialno #
dup to>> ogg_stream_state-serialno #
" is Theora " %
dup player-ti theora_info-width #
dup ti>> theora_info-width #
"x" %
dup player-ti theora_info-height #
dup ti>> theora_info-height #
" " %
dup player-ti theora_info-fps_numerator
over player-ti theora_info-fps_denominator /f #
dup ti>> theora_info-fps_numerator
over ti>> theora_info-fps_denominator /f #
" fps video" %
] "" make print ;
: initialize-decoder ( player -- player )
dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
dup player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
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 [
@ -428,13 +433,13 @@ HINTS: yuv>rgb byte-array byte-array ;
] when ;
: audio-buffer-not-ready? ( player -- player bool )
dup player-vorbis zero? not over player-audio-full? not and ;
dup vorbis>> zero? not over audio-full?>> not and ;
: pending-decoded-audio? ( player -- player pcm len bool )
f <void*> 2dup >r player-vd r> vorbis_synthesis_pcmout dup 0 > ;
f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
: buffer-space-available ( player -- available )
audio-buffer-size swap player-audio-index - ;
audio-buffer-size swap audio-index>> - ;
: samples-to-read ( player available len -- numread )
>r swap num-channels / r> min ;
@ -442,8 +447,8 @@ HINTS: yuv>rgb byte-array byte-array ;
: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
: add-to-buffer ( player val -- )
over player-audio-index pick player-audio-buffer set-short-nth
dup player-audio-index 1+ swap set-player-audio-index ;
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 ;
@ -462,24 +467,24 @@ HINTS: yuv>rgb byte-array byte-array ;
pick [ buffer-space-available swap ] keep -rot samples-to-read
pick over >r >r process-samples r> r> swap
! numread player
dup player-audio-index audio-buffer-size = [
t over set-player-audio-full?
dup audio-index>> audio-buffer-size = [
t >>audio-full?
] when
dup player-vd vorbis_dsp_state-granulepos dup 0 >= [
dup vd>> vorbis_dsp_state-granulepos dup 0 >= [
! numtoread player granulepos
#! This is wrong: fix
pick - over set-player-audio-granulepos
pick - >>audio-granulepos
] [
! numtoread player granulepos
pick + over set-player-audio-granulepos
pick + >>audio-granulepos
] if
[ player-vd swap vorbis_synthesis_read drop ] keep ;
[ vd>> swap vorbis_synthesis_read drop ] keep ;
: no-pending-audio ( player -- player bool )
#! No pending audio. Is there a pending packet to decode.
dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [
dup { player-vb player-op } get-slots vorbis_synthesis 0 = [
dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop
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
] [
@ -498,16 +503,16 @@ HINTS: yuv>rgb byte-array byte-array ;
] when ;
: video-buffer-not-ready? ( player -- player bool )
dup player-theora zero? not over player-video-ready? not and ;
dup theora>> zero? not over video-ready?>> not and ;
: decode-video ( player -- player )
video-buffer-not-ready? [
dup { player-to player-op } get-slots ogg_stream_packetout 0 > [
dup { player-td player-op } get-slots theora_decode_packetin drop
dup player-td theora_state-granulepos over set-player-video-granulepos
dup { player-td player-video-granulepos } get-slots theora_granule_time
over set-player-video-time
t over set-player-video-ready?
dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
dup td>> theora_state-granulepos >>video-granulepos
dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
>>video-time
t >>video-ready?
decode-video
] when
] when ;
@ -516,16 +521,16 @@ HINTS: yuv>rgb byte-array byte-array ;
get-more-header-data sync-pages
decode-audio
decode-video
dup player-audio-full? [
dup audio-full?>> [
process-audio [
f over set-player-audio-full?
0 over set-player-audio-index
f >>audio-full?
0 >>audio-index
] when
] when
dup player-video-ready? [
dup player-video-time over get-time - dup 0.0 < [
dup video-ready?>> [
dup video-time>> over get-time - dup 0.0 < [
-0.1 > [ process-video ] when
f over set-player-video-ready?
f >>video-ready?
] [
drop
] if
@ -533,36 +538,39 @@ HINTS: yuv>rgb byte-array byte-array ;
decode ;
: free-malloced-objects ( player -- player )
[ player-op free ] keep
[ player-oy free ] keep
[ player-og free ] keep
[ player-vo free ] keep
[ player-vi free ] keep
[ player-vd free ] keep
[ player-vb free ] keep
[ player-vc free ] keep
[ player-to free ] keep
[ player-ti free ] keep
[ player-tc free ] keep
[ player-td free ] keep ;
{
[ 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 player-source rot player-buffer-indexes swapd
num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
alSourceUnqueueBuffers check-error
] keep ;
: delete-openal-buffers ( player -- player )
[
player-buffers [
buffers>> [
1 swap <uint> alDeleteBuffers check-error
] each
] keep ;
: delete-openal-source ( player -- player )
[ player-source 1 swap <uint> alDeleteSources check-error ] keep ;
[ source>> 1 swap <uint> alDeleteSources check-error ] keep ;
: cleanup ( player -- player )
free-malloced-objects
@ -572,28 +580,28 @@ HINTS: yuv>rgb byte-array byte-array ;
: wait-for-sound ( player -- player )
#! Waits for the openal to finish playing remaining sounds
dup player-source AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
*int AL_PLAYING = [
100 sleep
wait-for-sound
] when ;
TUPLE: theora-gadget player ;
TUPLE: theora-gadget < gadget player ;
: <theora-gadget> ( player -- gadget )
theora-gadget construct-gadget
[ set-theora-gadget-player ] keep ;
theora-gadget new-gadget
swap >>player ;
M: theora-gadget pref-dim*
theora-gadget-player
player-ti dup theora_info-width swap theora_info-height 2array ;
player>>
ti>> dup theora_info-width swap theora_info-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
theora-gadget-player player-rgb glDrawPixels ;
player>> rgb>> glDrawPixels ;
: initialize-gui ( gadget -- )
"Theora Player" open-window ;
@ -602,7 +610,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
parse-initial-headers
parse-remaining-headers
initialize-decoder
dup player-gadget [ initialize-gui ] when*
dup gadget>> [ initialize-gui ] when*
[ decode ] try
wait-for-sound
cleanup
@ -616,9 +624,8 @@ M: theora-gadget draw-gadget* ( gadget -- )
: play-theora-stream ( stream -- )
<player>
dup <theora-gadget> over set-player-gadget
dup <theora-gadget> >>gadget
play-ogg ;
: play-theora-file ( filename -- )
binary <file-reader> play-theora-stream ;