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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: base64
<PRIVATE <PRIVATE
: count-end ( seq quot -- count ) : count-end ( seq quot -- n )
>r [ length ] keep r> find-last drop dup [ - 1- ] [ 2drop 0 ] if ; inline trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
: ch>base64 ( ch -- ch ) : ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@ -21,13 +22,16 @@ IN: base64
} nth ; } nth ;
: encode3 ( seq -- seq ) : 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 ) : decode4 ( str -- str )
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: >base64-rem ( str -- str ) : >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> PRIVATE>
@ -42,5 +46,5 @@ PRIVATE>
: base64> ( base64 -- str ) : base64> ( base64 -- str )
#! input length must be a multiple of 4 #! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ] [ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = not ] count-end ] [ [ CHAR: = = ] count-end ]
bi head* ; 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." } ; { $description "Creates a new database object from a given class." } ;
HELP: make-db* 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." } ; { $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 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." } ; { $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 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 ) : random ( seq -- elt )
[ f ] [ [ f ] [
[ [
length dup log2 7 + 8 /i 1+ random-bytes length dup log2 7 + 8 /i 1+
[ length 3 shift 2^ ] [ byte-array>bignum ] bi [ random-bytes byte-array>bignum ]
swap / * >integer [ 3 shift 2^ ] bi / * >integer
] keep nth ] keep nth
] if-empty ; ] 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 namespaces threads shuffle opengl arrays ui.gadgets.worlds
combinators math.parser ui.gadgets ui.render opengl.gl ui combinators math.parser ui.gadgets ui.render opengl.gl ui
continuations io.files hints combinators.lib sequences.lib continuations io.files hints combinators.lib sequences.lib
io.encodings.binary debugger math.order ; io.encodings.binary debugger math.order accessors ;
IN: ogg.player IN: ogg.player
@ -30,62 +30,63 @@ TUPLE: player stream temp-state
gadget ; gadget ;
: init-vorbis ( player -- ) : init-vorbis ( player -- )
dup player-oy ogg_sync_init drop dup oy>> ogg_sync_init drop
dup player-vi vorbis_info_init dup vi>> vorbis_info_init
player-vc vorbis_comment_init ; vc>> vorbis_comment_init ;
: init-theora ( player -- ) : init-theora ( player -- )
dup player-ti theora_info_init dup ti>> theora_info_init
player-tc theora_comment_init ; tc>> theora_comment_init ;
: init-sound ( player -- ) : init-sound ( player -- )
init-openal check-error init-openal check-error
1 gen-buffers check-error over set-player-buffers 1 gen-buffers check-error >>buffers
2 "uint" <c-array> over set-player-buffer-indexes 2 "uint" <c-array> >>buffer-indexes
1 gen-sources check-error first swap set-player-source ; 1 gen-sources check-error first >>source drop ;
: <player> ( stream -- player ) : <player> ( stream -- player )
{ set-player-stream } player construct player new
0 over set-player-vorbis swap >>stream
0 over set-player-theora 0 >>vorbis
0 over set-player-video-time 0 >>theora
0 over set-player-video-granulepos 0 >>video-time
f over set-player-video-ready? 0 >>video-granulepos
f over set-player-audio-full? f >>video-ready?
0 over set-player-audio-index f >>audio-full?
0 over set-player-start-time 0 >>audio-index
audio-buffer-size "short" <c-array> over set-player-audio-buffer 0 >>start-time
0 over set-player-audio-granulepos audio-buffer-size "short" <c-array> >>audio-buffer
f over set-player-playing? 0 >>audio-granulepos
"ogg_packet" malloc-object over set-player-op f >>playing?
"ogg_sync_state" malloc-object over set-player-oy "ogg_packet" malloc-object >>op
"ogg_page" malloc-object over set-player-og "ogg_sync_state" malloc-object >>oy
"ogg_stream_state" malloc-object over set-player-vo "ogg_page" malloc-object >>og
"vorbis_info" malloc-object over set-player-vi "ogg_stream_state" malloc-object >>vo
"vorbis_dsp_state" malloc-object over set-player-vd "vorbis_info" malloc-object >>vi
"vorbis_block" malloc-object over set-player-vb "vorbis_dsp_state" malloc-object >>vd
"vorbis_comment" malloc-object over set-player-vc "vorbis_block" malloc-object >>vb
"ogg_stream_state" malloc-object over set-player-to "vorbis_comment" malloc-object >>vc
"theora_info" malloc-object over set-player-ti "ogg_stream_state" malloc-object >>to
"theora_comment" malloc-object over set-player-tc "theora_info" malloc-object >>ti
"theora_state" malloc-object over set-player-td "theora_comment" malloc-object >>tc
"yuv_buffer" <c-object> over set-player-yuv "theora_state" malloc-object >>td
"ogg_stream_state" <c-object> over set-player-temp-state "yuv_buffer" <c-object> >>yuv
dup init-sound "ogg_stream_state" <c-object> >>temp-state
dup init-vorbis dup init-sound
dup init-theora ; dup init-vorbis
dup init-theora ;
: num-channels ( player -- channels ) : num-channels ( player -- channels )
player-vi vorbis_info-channels ; vi>> vorbis_info-channels ;
: al-channel-format ( player -- format ) : 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 ) : get-time ( player -- time )
dup player-start-time zero? [ dup start-time>> zero? [
millis over set-player-start-time millis >>start-time
] when ] when
player-start-time millis swap - 1000.0 /f ; start-time>> millis swap - 1000.0 /f ;
: clamp ( n -- n ) : clamp ( n -- n )
255 min 0 max ; inline 255 min 0 max ; inline
@ -138,7 +139,7 @@ TUPLE: player stream temp-state
pick yuv_buffer-y_width >fixnum pick yuv_buffer-y_width >fixnum
[ yuv>rgb-pixel ] each-with4 ; inline [ yuv>rgb-pixel ] each-with4 ; inline
: yuv>rgb ( rgb yuv -- ) : yuv>rgb ( rgb yuv -- )
0 -rot 0 -rot
dup yuv_buffer-y_height >fixnum dup yuv_buffer-y_height >fixnum
[ yuv>rgb-row ] each-with2 [ yuv>rgb-row ] each-with2
@ -147,52 +148,55 @@ TUPLE: player stream temp-state
HINTS: yuv>rgb byte-array byte-array ; HINTS: yuv>rgb byte-array byte-array ;
: process-video ( player -- player ) : process-video ( player -- player )
dup player-gadget [ dup gadget>> [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop {
dup player-rgb over player-yuv yuv>rgb [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
dup player-gadget relayout-1 yield [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
[ gadget>> relayout-1 yield ]
[ ]
} cleave
] when ; ] when ;
: num-audio-buffers-processed ( player -- player n ) : 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 ; [ alGetSourcei check-error ] keep *uint ;
: append-new-audio-buffer ( player -- player ) : append-new-audio-buffer ( player -- player )
dup player-buffers 1 gen-buffers append over set-player-buffers dup buffers>> 1 gen-buffers append >>buffers
[ [ player-buffers second ] keep al-channel-format ] keep [ [ buffers>> second ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep [ audio-buffer>> dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep [ vi>> vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep [ source>> 1 ] keep
[ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ; [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;
: fill-processed-audio-buffer ( player n -- player ) : fill-processed-audio-buffer ( player n -- player )
#! n is the number of audio buffers processed #! 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 [ alSourceUnqueueBuffers check-error ] keep
*uint dup r> swap >r al-channel-format rot *uint dup r> swap >r al-channel-format rot
[ player-audio-buffer dup length ] keep [ audio-buffer>> dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep [ vi>> vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep [ source>> 1 ] keep
r> <uint> swap >r alSourceQueueBuffers check-error r> ; r> <uint> swap >r alSourceQueueBuffers check-error r> ;
: append-audio ( player -- player bool ) : append-audio ( player -- player bool )
num-audio-buffers-processed { num-audio-buffers-processed {
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } { [ over 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 2 = over zero? and ] [ yield drop f ] }
[ fill-processed-audio-buffer t ] [ fill-processed-audio-buffer t ]
} cond ; } cond ;
: start-audio ( player -- player bool ) : start-audio ( player -- player bool )
[ [ player-buffers first ] keep al-channel-format ] keep [ [ buffers>> first ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep [ audio-buffer>> dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep [ vi>> vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep [ source>> 1 ] keep
[ player-buffers first <uint> alSourceQueueBuffers check-error ] keep [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep
[ player-source alSourcePlay check-error ] keep [ source>> alSourcePlay check-error ] keep
t over set-player-playing? t ; t >>playing? t ;
: process-audio ( player -- player bool ) : 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-bytes-into ( dest size stream -- len )
#! Read the given number of bytes from a stream #! Read the given number of bytes from a stream
@ -206,13 +210,13 @@ HINTS: yuv>rgb byte-array byte-array ;
4096 ; inline 4096 ; inline
: sync-buffer ( player -- buffer size player ) : 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 ) : 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? ) : 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? ) : buffer-data ( player -- player eof? )
#! Take some compressed bitstream data and sync it for #! Take some compressed bitstream data and sync it for
@ -221,59 +225,60 @@ HINTS: yuv>rgb byte-array byte-array ;
: queue-page ( player -- player ) : queue-page ( player -- player )
#! Push a page into the stream for packetization #! Push a page into the stream for packetization
[ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
[ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ; [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
[ ] tri ;
: retrieve-page ( player -- player bool ) : retrieve-page ( player -- player bool )
#! Sync the streams and get a page. Return true if a page was #! Sync the streams and get a page. Return true if a page was
#! successfully retrieved. #! 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 ) : 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 ) : ogg-stream-init ( player -- state player )
#! Init the encode/decode logical stream state #! Init the encode/decode logical stream state
[ player-temp-state ] keep [ temp-state>> ] keep
[ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
: ogg-stream-pagein ( state player -- state player ) : ogg-stream-pagein ( state player -- state player )
#! Add the incoming page to the stream state #! 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 ) : 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 ) : decode-packet ( player -- state player )
ogg-stream-init ogg-stream-pagein ogg-stream-packetout ; ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
: theora-header? ( player -- player bool ) : theora-header? ( player -- player bool )
#! Is the current page a theora header? #! 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 ) : 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-to-theora-state ( state player -- player )
#! Copy the state to the theora state structure in the 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 ) : 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 ) : vorbis-header? ( player -- player bool )
#! Is the current page a vorbis header? #! 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 ) : 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-to-vorbis-state ( state player -- player )
#! Copy the state to the vorbis state structure in the 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 ) : 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 ) : handle-initial-unknown-header ( state player -- player )
swap ogg_stream_clear drop ; 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 #! 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 #! vorbis headers read from the stream but we don't have them all
#! yet. #! yet.
dup player-vorbis 1 2 between? not ; dup vorbis>> 1 2 between? not ;
: have-required-theora-headers? ( player -- player bool ) : have-required-theora-headers? ( player -- player bool )
#! Return true if we need to decode theora due to there being #! 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 #! theora headers read from the stream but we don't have them all
#! yet. #! yet.
dup player-theora 1 2 between? not ; dup theora>> 1 2 between? not ;
: get-remaining-vorbis-header-packet ( player -- player bool ) : 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 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
{ [ dup zero? ] [ drop f ] } { [ dup zero? ] [ drop f ] }
{ [ t ] [ drop t ] } { [ t ] [ drop t ] }
} cond ; } cond ;
: get-remaining-theora-header-packet ( player -- player bool ) : 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 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }
{ [ dup zero? ] [ drop f ] } { [ dup zero? ] [ drop f ] }
{ [ t ] [ drop t ] } { [ t ] [ drop t ] }
} cond ; } cond ;
: decode-remaining-vorbis-header-packet ( player -- player ) : 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 "Error parsing vorbis stream; corrupt stream?" throw
] unless ; ] unless ;
: decode-remaining-theora-header-packet ( player -- player ) : 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 "Error parsing theora stream; corrupt stream?" throw
] unless ; ] unless ;
: increment-vorbis-header-count ( player -- player ) : increment-vorbis-header-count ( player -- player )
dup player-vorbis 1+ over set-player-vorbis ; [ 1+ ] change-vorbis ;
: increment-theora-header-count ( player -- player ) : increment-theora-header-count ( player -- player )
dup player-theora 1+ over set-player-theora ; [ 1+ ] change-theora ;
: parse-remaining-vorbis-headers ( player -- player ) : parse-remaining-vorbis-headers ( player -- player )
have-required-vorbis-headers? not [ have-required-vorbis-headers? not [
@ -376,51 +381,51 @@ HINTS: yuv>rgb byte-array byte-array ;
] when ; ] when ;
: tear-down-vorbis ( player -- player ) : tear-down-vorbis ( player -- player )
dup player-vi vorbis_info_clear dup vi>> vorbis_info_clear
dup player-vc vorbis_comment_clear ; dup vc>> vorbis_comment_clear ;
: tear-down-theora ( player -- player ) : tear-down-theora ( player -- player )
dup player-ti theora_info_clear dup ti>> theora_info_clear
dup player-tc theora_comment_clear ; dup tc>> theora_comment_clear ;
: init-vorbis-codec ( player -- player ) : init-vorbis-codec ( player -- player )
dup { player-vd player-vi } get-slots vorbis_synthesis_init drop dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
dup { player-vd player-vb } get-slots vorbis_block_init drop ; dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
: init-theora-codec ( player -- player ) : init-theora-codec ( player -- player )
dup { player-td player-ti } get-slots theora_decode_init drop dup [ td>> ] [ ti>> ] bi theora_decode_init drop
dup player-ti theora_info-frame_width over player-ti theora_info-frame_height dup ti>> theora_info-frame_width over ti>> theora_info-frame_height
4 * * <byte-array> over set-player-rgb ; 4 * * <byte-array> >>rgb ;
: display-vorbis-details ( player -- player ) : display-vorbis-details ( player -- player )
[ [
"Ogg logical stream " % "Ogg logical stream " %
dup player-vo ogg_stream_state-serialno # dup vo>> ogg_stream_state-serialno #
" is Vorbis " % " is Vorbis " %
dup player-vi vorbis_info-channels # dup vi>> vorbis_info-channels #
" channel " % " channel " %
dup player-vi vorbis_info-rate # dup vi>> vorbis_info-rate #
" Hz audio." % " Hz audio." %
] "" make print ; ] "" make print ;
: display-theora-details ( player -- player ) : display-theora-details ( player -- player )
[ [
"Ogg logical stream " % "Ogg logical stream " %
dup player-to ogg_stream_state-serialno # dup to>> ogg_stream_state-serialno #
" is Theora " % " is Theora " %
dup player-ti theora_info-width # dup ti>> theora_info-width #
"x" % "x" %
dup player-ti theora_info-height # dup ti>> theora_info-height #
" " % " " %
dup player-ti theora_info-fps_numerator dup ti>> theora_info-fps_numerator
over player-ti theora_info-fps_denominator /f # over ti>> theora_info-fps_denominator /f #
" fps video" % " fps video" %
] "" make print ; ] "" make print ;
: initialize-decoder ( player -- player ) : initialize-decoder ( player -- player )
dup player-vorbis zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if dup 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 theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
: sync-pages ( player -- player ) : sync-pages ( player -- player )
retrieve-page [ retrieve-page [
@ -428,13 +433,13 @@ HINTS: yuv>rgb byte-array byte-array ;
] when ; ] when ;
: audio-buffer-not-ready? ( player -- player bool ) : 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 ) : 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 ) : 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 ) : samples-to-read ( player available len -- numread )
>r swap num-channels / r> min ; >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 : each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
: add-to-buffer ( player val -- ) : add-to-buffer ( player val -- )
over player-audio-index pick player-audio-buffer set-short-nth over audio-index>> pick audio-buffer>> set-short-nth
dup player-audio-index 1+ swap set-player-audio-index ; [ 1+ ] change-audio-index drop ;
: get-audio-value ( pcm sample channel -- value ) : get-audio-value ( pcm sample channel -- value )
rot *void* void*-nth float-nth ; 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 [ buffer-space-available swap ] keep -rot samples-to-read
pick over >r >r process-samples r> r> swap pick over >r >r process-samples r> r> swap
! numread player ! numread player
dup player-audio-index audio-buffer-size = [ dup audio-index>> audio-buffer-size = [
t over set-player-audio-full? t >>audio-full?
] when ] when
dup player-vd vorbis_dsp_state-granulepos dup 0 >= [ dup vd>> vorbis_dsp_state-granulepos dup 0 >= [
! numtoread player granulepos ! numtoread player granulepos
#! This is wrong: fix #! This is wrong: fix
pick - over set-player-audio-granulepos pick - >>audio-granulepos
] [ ] [
! numtoread player granulepos ! numtoread player granulepos
pick + over set-player-audio-granulepos pick + >>audio-granulepos
] if ] 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 ( player -- player bool )
#! No pending audio. Is there a pending packet to decode. #! No pending audio. Is there a pending packet to decode.
dup { player-vo player-op } get-slots ogg_stream_packetout 0 > [ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
dup { player-vb player-op } get-slots vorbis_synthesis 0 = [ dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
] when ] when
t t
] [ ] [
@ -498,16 +503,16 @@ HINTS: yuv>rgb byte-array byte-array ;
] when ; ] when ;
: video-buffer-not-ready? ( player -- player bool ) : 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 ) : decode-video ( player -- player )
video-buffer-not-ready? [ video-buffer-not-ready? [
dup { player-to player-op } get-slots ogg_stream_packetout 0 > [ dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
dup { player-td player-op } get-slots theora_decode_packetin drop dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
dup player-td theora_state-granulepos over set-player-video-granulepos dup td>> theora_state-granulepos >>video-granulepos
dup { player-td player-video-granulepos } get-slots theora_granule_time dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
over set-player-video-time >>video-time
t over set-player-video-ready? t >>video-ready?
decode-video decode-video
] when ] when
] when ; ] when ;
@ -516,16 +521,16 @@ HINTS: yuv>rgb byte-array byte-array ;
get-more-header-data sync-pages get-more-header-data sync-pages
decode-audio decode-audio
decode-video decode-video
dup player-audio-full? [ dup audio-full?>> [
process-audio [ process-audio [
f over set-player-audio-full? f >>audio-full?
0 over set-player-audio-index 0 >>audio-index
] when ] when
] when ] when
dup player-video-ready? [ dup video-ready?>> [
dup player-video-time over get-time - dup 0.0 < [ dup video-time>> over get-time - dup 0.0 < [
-0.1 > [ process-video ] when -0.1 > [ process-video ] when
f over set-player-video-ready? f >>video-ready?
] [ ] [
drop drop
] if ] if
@ -533,36 +538,39 @@ HINTS: yuv>rgb byte-array byte-array ;
decode ; decode ;
: free-malloced-objects ( player -- player ) : free-malloced-objects ( player -- player )
[ player-op free ] keep {
[ player-oy free ] keep [ op>> free ]
[ player-og free ] keep [ oy>> free ]
[ player-vo free ] keep [ og>> free ]
[ player-vi free ] keep [ vo>> free ]
[ player-vd free ] keep [ vi>> free ]
[ player-vb free ] keep [ vd>> free ]
[ player-vc free ] keep [ vb>> free ]
[ player-to free ] keep [ vc>> free ]
[ player-ti free ] keep [ to>> free ]
[ player-tc free ] keep [ ti>> free ]
[ player-td free ] keep ; [ tc>> free ]
[ td>> free ]
[ ]
} cleave ;
: unqueue-openal-buffers ( player -- player ) : 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 alSourceUnqueueBuffers check-error
] keep ; ] keep ;
: delete-openal-buffers ( player -- player ) : delete-openal-buffers ( player -- player )
[ [
player-buffers [ buffers>> [
1 swap <uint> alDeleteBuffers check-error 1 swap <uint> alDeleteBuffers check-error
] each ] each
] keep ; ] keep ;
: delete-openal-source ( player -- player ) : 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 ) : cleanup ( player -- player )
free-malloced-objects free-malloced-objects
@ -572,28 +580,28 @@ HINTS: yuv>rgb byte-array byte-array ;
: wait-for-sound ( player -- player ) : wait-for-sound ( player -- player )
#! Waits for the openal to finish playing remaining sounds #! 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 = [ *int AL_PLAYING = [
100 sleep 100 sleep
wait-for-sound wait-for-sound
] when ; ] when ;
TUPLE: theora-gadget player ; TUPLE: theora-gadget < gadget player ;
: <theora-gadget> ( player -- gadget ) : <theora-gadget> ( player -- gadget )
theora-gadget construct-gadget theora-gadget new-gadget
[ set-theora-gadget-player ] keep ; swap >>player ;
M: theora-gadget pref-dim* M: theora-gadget pref-dim*
theora-gadget-player player>>
player-ti dup theora_info-width swap theora_info-height 2array ; ti>> dup theora_info-width swap theora_info-height 2array ;
M: theora-gadget draw-gadget* ( gadget -- ) M: theora-gadget draw-gadget* ( gadget -- )
0 0 glRasterPos2i 0 0 glRasterPos2i
1.0 -1.0 glPixelZoom 1.0 -1.0 glPixelZoom
GL_UNPACK_ALIGNMENT 1 glPixelStorei GL_UNPACK_ALIGNMENT 1 glPixelStorei
[ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
theora-gadget-player player-rgb glDrawPixels ; player>> rgb>> glDrawPixels ;
: initialize-gui ( gadget -- ) : initialize-gui ( gadget -- )
"Theora Player" open-window ; "Theora Player" open-window ;
@ -602,7 +610,7 @@ M: theora-gadget draw-gadget* ( gadget -- )
parse-initial-headers parse-initial-headers
parse-remaining-headers parse-remaining-headers
initialize-decoder initialize-decoder
dup player-gadget [ initialize-gui ] when* dup gadget>> [ initialize-gui ] when*
[ decode ] try [ decode ] try
wait-for-sound wait-for-sound
cleanup cleanup
@ -616,9 +624,8 @@ M: theora-gadget draw-gadget* ( gadget -- )
: play-theora-stream ( stream -- ) : play-theora-stream ( stream -- )
<player> <player>
dup <theora-gadget> over set-player-gadget dup <theora-gadget> >>gadget
play-ogg ; play-ogg ;
: play-theora-file ( filename -- ) : play-theora-file ( filename -- )
binary <file-reader> play-theora-stream ; binary <file-reader> play-theora-stream ;