Update search paths after combinators.lib -> sequences.lib move

db4
Aaron Schaefer 2008-02-12 16:49:53 -05:00
parent 7361ee58a8
commit b4324cdd58
9 changed files with 120 additions and 121 deletions

View File

@ -1,6 +1,5 @@
USING: arrays bunny.model combinators.lib continuations USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
kernel multiline opengl opengl.shaders opengl.capabilities opengl.capabilities opengl.gl sequences sequences.lib ;
opengl.gl sequences ;
IN: bunny.cel-shaded IN: bunny.cel-shaded
STRING: vertex-shader-source STRING: vertex-shader-source

View File

@ -1,9 +1,8 @@
USING: alien alien.c-types arrays sequences math USING: alien alien.c-types arrays sequences math math.vectors math.matrices
math.vectors math.matrices math.parser io io.files kernel opengl math.parser io io.files kernel opengl opengl.gl opengl.glu
opengl.gl opengl.glu opengl.capabilities shuffle http.client opengl.capabilities shuffle http.client vectors splitting tools.time system
vectors splitting combinators combinators.cleave float-arrays continuations namespaces
tools.time system combinators combinators.lib combinators.cleave sequences.lib ;
float-arrays continuations namespaces ;
IN: bunny.model IN: bunny.model
: numbers ( str -- seq ) : numbers ( str -- seq )

View File

@ -1,14 +1,10 @@
USING: combinators.lib kernel math math.ranges random sequences USING: combinators.lib kernel math random sequences tools.test continuations
tools.test continuations arrays vectors ; arrays vectors ;
IN: temporary IN: temporary
[ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
[ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
@ -17,11 +13,6 @@ IN: temporary
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test
[ [ sq ] 3apply ] must-infer [ [ sq ] 3apply ] must-infer
@ -55,5 +46,3 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ] [ dup array? ] [ dup vector? ] [ dup float? ]
} || nip } || nip
] unit-test ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.styles io hashtables kernel USING: io.files io.launcher io.styles io hashtables kernel
sequences combinators.lib assocs system sorting math.parser ; sequences sequences.lib assocs system sorting math.parser ;
IN: contributors IN: contributors
: changelog ( -- authors ) : changelog ( -- authors )

View File

@ -1,7 +1,5 @@
USING: kernel combinators sequences math math.functions math.vectors mortar
USING: kernel combinators sequences math math.functions math.vectors mortar slot-accessors slot-accessors x x.widgets.wm.root x.widgets.wm.frame sequences.lib ;
x x.widgets.wm.root x.widgets.wm.frame combinators.lib ;
IN: factory.commands IN: factory.commands
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -72,4 +70,4 @@ drop
! { { [ dup empty? ] [ drop ] } ! { { [ dup empty? ] [ drop ] }
! { [ dup length 1 = ] [ drop maximize ] } ! { [ dup length 1 = ] [ drop maximize ] }
! { [ t ] [ tile-master* ] } ! { [ t ] [ tile-master* ] }

View File

@ -1,6 +1,5 @@
USING: arrays combinators.lib io io.streams.string USING: arrays io io.streams.string kernel math math.parser namespaces
kernel math math.parser namespaces prettyprint prettyprint sequences sequences.lib splitting strings ascii ;
sequences splitting strings ascii ;
IN: hexdump IN: hexdump
<PRIVATE <PRIVATE

View File

@ -1,5 +1,5 @@
USING: combinators.lib kernel math math.analysis USING: kernel math math.analysis math.functions math.vectors sequences
math.functions math.vectors sequences sequences.lib sorting ; sequences.lib sorting ;
IN: math.statistics IN: math.statistics
: mean ( seq -- n ) : mean ( seq -- n )
@ -43,9 +43,9 @@ IN: math.statistics
: ste ( seq -- x ) : ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence ) #! standard error, standard deviation / sqrt ( length of sequence )
dup std swap length sqrt / ; dup std swap length sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) ) : ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y)) ! finds sigma((xi-mean(x))(yi-mean(y))
0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ; 0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) : (r) ( mean(x) mean(y) {x} {y} sx sy -- r )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
! !
! TODO: ! TODO:
! based on number of channels in file. ! based on number of channels in file.
! - End of decoding is indicated by an exception when reading the stream. ! - 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 ! How to work around this? C player example uses feof but streams don't
@ -14,27 +14,27 @@ USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
sequences libc shuffle alien.c-types system openal math sequences libc shuffle alien.c-types system openal math
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 ; continuations io.files hints combinators.lib sequences.lib ;
IN: ogg.player IN: ogg.player
: audio-buffer-size ( -- number ) 128 1024 * ; inline : audio-buffer-size ( -- number ) 128 1024 * ; inline
TUPLE: player stream temp-state TUPLE: player stream temp-state
op oy og op oy og
vo vi vd vb vc vorbis vo vi vd vb vc vorbis
to ti tc td yuv rgb theora video-ready? video-time video-granulepos to ti tc td yuv rgb theora video-ready? video-time video-granulepos
source buffers buffer-indexes start-time source buffers buffer-indexes start-time
playing? audio-full? audio-index audio-buffer audio-granulepos playing? audio-full? audio-index audio-buffer audio-granulepos
gadget ; gadget ;
: init-vorbis ( player -- ) : init-vorbis ( player -- )
dup player-oy ogg_sync_init drop dup player-oy ogg_sync_init drop
dup player-vi vorbis_info_init dup player-vi vorbis_info_init
player-vc vorbis_comment_init ; player-vc vorbis_comment_init ;
: init-theora ( player -- ) : init-theora ( player -- )
dup player-ti theora_info_init dup player-ti theora_info_init
player-tc theora_comment_init ; player-tc theora_comment_init ;
: init-sound ( player -- ) : init-sound ( player -- )
@ -45,45 +45,45 @@ TUPLE: player stream temp-state
: <player> ( stream -- player ) : <player> ( stream -- player )
{ set-player-stream } player construct { set-player-stream } player construct
0 over set-player-vorbis 0 over set-player-vorbis
0 over set-player-theora 0 over set-player-theora
0 over set-player-video-time 0 over set-player-video-time
0 over set-player-video-granulepos 0 over set-player-video-granulepos
f over set-player-video-ready? f over set-player-video-ready?
f over set-player-audio-full? f over set-player-audio-full?
0 over set-player-audio-index 0 over set-player-audio-index
0 over set-player-start-time 0 over set-player-start-time
audio-buffer-size "short" <c-array> over set-player-audio-buffer audio-buffer-size "short" <c-array> over set-player-audio-buffer
0 over set-player-audio-granulepos 0 over set-player-audio-granulepos
f over set-player-playing? f over set-player-playing?
"ogg_packet" malloc-object over set-player-op "ogg_packet" malloc-object over set-player-op
"ogg_sync_state" malloc-object over set-player-oy "ogg_sync_state" malloc-object over set-player-oy
"ogg_page" malloc-object over set-player-og "ogg_page" malloc-object over set-player-og
"ogg_stream_state" malloc-object over set-player-vo "ogg_stream_state" malloc-object over set-player-vo
"vorbis_info" malloc-object over set-player-vi "vorbis_info" malloc-object over set-player-vi
"vorbis_dsp_state" malloc-object over set-player-vd "vorbis_dsp_state" malloc-object over set-player-vd
"vorbis_block" malloc-object over set-player-vb "vorbis_block" malloc-object over set-player-vb
"vorbis_comment" malloc-object over set-player-vc "vorbis_comment" malloc-object over set-player-vc
"ogg_stream_state" malloc-object over set-player-to "ogg_stream_state" malloc-object over set-player-to
"theora_info" malloc-object over set-player-ti "theora_info" malloc-object over set-player-ti
"theora_comment" malloc-object over set-player-tc "theora_comment" malloc-object over set-player-tc
"theora_state" malloc-object over set-player-td "theora_state" malloc-object over set-player-td
"yuv_buffer" <c-object> over set-player-yuv "yuv_buffer" <c-object> over set-player-yuv
"ogg_stream_state" <c-object> over set-player-temp-state "ogg_stream_state" <c-object> over set-player-temp-state
dup init-sound dup init-sound
dup init-vorbis dup init-vorbis
dup init-theora ; dup init-theora ;
: num-channels ( player -- channels ) : num-channels ( player -- channels )
player-vi vorbis_info-channels ; player-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 ] if ;
: get-time ( player -- time ) : get-time ( player -- time )
dup player-start-time zero? [ dup player-start-time zero? [
millis over set-player-start-time millis over set-player-start-time
] when ] when
player-start-time millis swap - 1000.0 /f ; player-start-time millis swap - 1000.0 /f ;
: clamp ( n -- n ) : clamp ( n -- n )
@ -149,28 +149,28 @@ HINTS: yuv>rgb byte-array byte-array ;
dup player-gadget [ dup player-gadget [
dup { player-td player-yuv } get-slots theora_decode_YUVout drop dup { player-td player-yuv } get-slots theora_decode_YUVout drop
dup player-rgb over player-yuv yuv>rgb dup player-rgb over player-yuv yuv>rgb
dup player-gadget find-world dup draw-world dup player-gadget find-world dup draw-world
] 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 player-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 player-buffers 1 gen-buffers append over set-player-buffers
[ [ player-buffers second ] keep al-channel-format ] keep [ [ player-buffers second ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep [ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep [ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep [ player-source 1 ] keep
[ player-buffers second <uint> alSourceQueueBuffers check-error ] keep ; [ player-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 player-source r> pick player-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 [ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep [ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep [ player-source 1 ] keep
r> <uint> swap >r alSourceQueueBuffers check-error r> ; r> <uint> swap >r alSourceQueueBuffers check-error r> ;
@ -179,12 +179,12 @@ HINTS: yuv>rgb byte-array byte-array ;
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] } { [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
{ [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] } { [ over player-buffers length 2 = over zero? and ] [ 0 sleep drop f ] }
{ [ t ] [ fill-processed-audio-buffer t ] } { [ 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 [ [ player-buffers first ] keep al-channel-format ] keep
[ player-audio-buffer dup length ] keep [ player-audio-buffer dup length ] keep
[ player-vi vorbis_info-rate alBufferData check-error ] keep [ player-vi vorbis_info-rate alBufferData check-error ] keep
[ player-source 1 ] keep [ player-source 1 ] keep
[ player-buffers first <uint> alSourceQueueBuffers check-error ] keep [ player-buffers first <uint> alSourceQueueBuffers check-error ] keep
[ player-source alSourcePlay check-error ] keep [ player-source alSourcePlay check-error ] keep
@ -201,12 +201,12 @@ HINTS: yuv>rgb byte-array byte-array ;
: check-not-negative ( int -- ) : check-not-negative ( int -- )
0 < [ "Word result was a negative number." throw ] when ; 0 < [ "Word result was a negative number." throw ] when ;
: buffer-size ( -- number ) : buffer-size ( -- number )
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 ; [ player-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 ; [ player-stream read-bytes-into ] keep ;
@ -217,23 +217,23 @@ HINTS: yuv>rgb byte-array byte-array ;
#! Take some compressed bitstream data and sync it for #! Take some compressed bitstream data and sync it for
#! page extraction. #! page extraction.
sync-buffer stream-into-buffer confirm-buffer ; sync-buffer stream-into-buffer confirm-buffer ;
: 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 [ { player-vo player-og } get-slots ogg_stream_pagein drop ] keep
[ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ; [ { player-to player-og } get-slots ogg_stream_pagein drop ] keep ;
: 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 { player-oy player-og } get-slots 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 player-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 [ player-temp-state ] keep
[ player-og ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ; [ player-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 )
@ -266,11 +266,11 @@ HINTS: yuv>rgb byte-array byte-array ;
: is-vorbis-packet? ( player -- player bool ) : is-vorbis-packet? ( player -- player bool )
dup player-vorbis zero? [ vorbis-header? ] [ f ] if ; dup player-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 ; [ player-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 over set-player-vorbis ;
@ -293,16 +293,16 @@ HINTS: yuv>rgb byte-array byte-array ;
#! Parse Vorbis headers, ignoring any other type stored #! Parse Vorbis headers, ignoring any other type stored
#! in the Ogg container. #! in the Ogg container.
retrieve-page [ retrieve-page [
process-initial-header [ process-initial-header [
parse-initial-headers parse-initial-headers
] [ ] [
#! Don't leak the page, get it into the appropriate stream #! Don't leak the page, get it into the appropriate stream
queue-page queue-page
] if ] if
] [ ] [
buffer-data not [ parse-initial-headers ] when buffer-data not [ parse-initial-headers ] when
] if ; ] if ;
: have-required-vorbis-headers? ( player -- player bool ) : have-required-vorbis-headers? ( player -- player bool )
#! 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
@ -350,17 +350,17 @@ HINTS: yuv>rgb byte-array byte-array ;
get-remaining-vorbis-header-packet [ get-remaining-vorbis-header-packet [
decode-remaining-vorbis-header-packet decode-remaining-vorbis-header-packet
increment-vorbis-header-count increment-vorbis-header-count
parse-remaining-vorbis-headers parse-remaining-vorbis-headers
] when ] when
] when ; ] when ;
: parse-remaining-theora-headers ( player -- player ) : parse-remaining-theora-headers ( player -- player )
have-required-theora-headers? not [ have-required-theora-headers? not [
get-remaining-theora-header-packet [ get-remaining-theora-header-packet [
decode-remaining-theora-header-packet decode-remaining-theora-header-packet
increment-theora-header-count increment-theora-header-count
parse-remaining-theora-headers parse-remaining-theora-headers
] when ] when
] when ; ] when ;
: get-more-header-data ( player -- player ) : get-more-header-data ( player -- player )
@ -368,12 +368,12 @@ HINTS: yuv>rgb byte-array byte-array ;
: parse-remaining-headers ( player -- player ) : parse-remaining-headers ( player -- player )
have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [ have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
parse-remaining-vorbis-headers parse-remaining-vorbis-headers
parse-remaining-theora-headers parse-remaining-theora-headers
retrieve-page [ queue-page ] [ get-more-header-data ] if retrieve-page [ queue-page ] [ get-more-header-data ] if
parse-remaining-headers parse-remaining-headers
] when ; ] when ;
: tear-down-vorbis ( player -- player ) : tear-down-vorbis ( player -- player )
dup player-vi vorbis_info_clear dup player-vi vorbis_info_clear
dup player-vc vorbis_comment_clear ; dup player-vc vorbis_comment_clear ;
@ -387,8 +387,8 @@ HINTS: yuv>rgb byte-array byte-array ;
dup { player-vd player-vb } get-slots vorbis_block_init drop ; dup { player-vd player-vb } get-slots 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 { player-td player-ti } get-slots theora_decode_init drop
dup player-ti theora_info-frame_width over player-ti theora_info-frame_height dup player-ti theora_info-frame_width over player-ti theora_info-frame_height
4 * * <byte-array> over set-player-rgb ; 4 * * <byte-array> over set-player-rgb ;
@ -412,36 +412,36 @@ HINTS: yuv>rgb byte-array byte-array ;
"x" % "x" %
dup player-ti theora_info-height # dup player-ti theora_info-height #
" " % " " %
dup player-ti theora_info-fps_numerator dup player-ti theora_info-fps_numerator
over player-ti theora_info-fps_denominator /f # over player-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 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 player-theora zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
: sync-pages ( player -- player ) : sync-pages ( player -- player )
retrieve-page [ retrieve-page [
queue-page sync-pages queue-page sync-pages
] 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 player-vorbis zero? not over player-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 player-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 player-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 ;
: 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 player-audio-index pick player-audio-buffer set-short-nth
dup player-audio-index 1+ swap set-player-audio-index ; dup player-audio-index 1+ swap set-player-audio-index ;
: get-audio-value ( pcm sample channel -- value ) : get-audio-value ( pcm sample channel -- value )
@ -452,15 +452,15 @@ HINTS: yuv>rgb byte-array byte-array ;
: (process-sample) ( player pcm sample -- ) : (process-sample) ( player pcm sample -- )
pick num-channels [ process-channels ] each-with3 ; pick num-channels [ process-channels ] each-with3 ;
: process-samples ( player pcm numread -- ) : process-samples ( player pcm numread -- )
[ (process-sample) ] each-with2 ; [ (process-sample) ] each-with2 ;
: decode-pending-audio ( player pcm result -- player ) : decode-pending-audio ( player pcm result -- player )
! [ "ret = " % dup # ] "" make write ! [ "ret = " % dup # ] "" make write
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 player-audio-index audio-buffer-size = [
t over set-player-audio-full? t over set-player-audio-full?
] when ] when
@ -480,10 +480,10 @@ HINTS: yuv>rgb byte-array byte-array ;
dup { player-vb player-op } get-slots vorbis_synthesis 0 = [ dup { player-vb player-op } get-slots vorbis_synthesis 0 = [
dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop dup { player-vd player-vb } get-slots vorbis_synthesis_blockin drop
] when ] when
t t
] [ ] [
#! Need more data. Break out to suck in another page. #! Need more data. Break out to suck in another page.
f f
] if ; ] if ;
: decode-audio ( player -- player ) : decode-audio ( player -- player )
@ -504,13 +504,13 @@ HINTS: yuv>rgb byte-array byte-array ;
dup { player-to player-op } get-slots ogg_stream_packetout 0 > [ 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 player-op } get-slots theora_decode_packetin drop
dup player-td theora_state-granulepos over set-player-video-granulepos dup player-td theora_state-granulepos over set-player-video-granulepos
dup { player-td player-video-granulepos } get-slots theora_granule_time dup { player-td player-video-granulepos } get-slots theora_granule_time
over set-player-video-time over set-player-video-time
t over set-player-video-ready? t over set-player-video-ready?
decode-video decode-video
] when ] when
] when ; ] when ;
: decode ( player -- player ) : decode ( player -- player )
get-more-header-data sync-pages get-more-header-data sync-pages
decode-audio decode-audio
@ -520,7 +520,7 @@ HINTS: yuv>rgb byte-array byte-array ;
f over set-player-audio-full? f over set-player-audio-full?
0 over set-player-audio-index 0 over set-player-audio-index
] when ] when
] when ] when
dup player-video-ready? [ dup player-video-ready? [
dup player-video-time over get-time - dup 0.0 < [ dup player-video-time over get-time - dup 0.0 < [
-0.1 > [ process-video ] when -0.1 > [ process-video ] when
@ -539,7 +539,7 @@ HINTS: yuv>rgb byte-array byte-array ;
[ player-vi free ] keep [ player-vi free ] keep
[ player-vd free ] keep [ player-vd free ] keep
[ player-vb free ] keep [ player-vb free ] keep
[ player-vc free ] keep [ player-vc free ] keep
[ player-to free ] keep [ player-to free ] keep
[ player-ti free ] keep [ player-ti free ] keep
[ player-tc free ] keep [ player-tc free ] keep
@ -550,23 +550,23 @@ HINTS: yuv>rgb byte-array byte-array ;
[ [
num-audio-buffers-processed over player-source rot player-buffer-indexes swapd num-audio-buffers-processed over player-source rot player-buffer-indexes swapd
alSourceUnqueueBuffers check-error alSourceUnqueueBuffers check-error
] keep ; ] keep ;
: delete-openal-buffers ( player -- player ) : delete-openal-buffers ( player -- player )
[ [
player-buffers [ player-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 ; [ player-source 1 swap <uint> alDeleteSources check-error ] keep ;
: cleanup ( player -- player ) : cleanup ( player -- player )
free-malloced-objects free-malloced-objects
unqueue-openal-buffers unqueue-openal-buffers
delete-openal-buffers delete-openal-buffers
delete-openal-source ; delete-openal-source ;
: wait-for-sound ( player -- player ) : wait-for-sound ( player -- player )
@ -583,7 +583,7 @@ TUPLE: theora-gadget player ;
theora-gadget construct-gadget theora-gadget construct-gadget
[ set-theora-gadget-player ] keep ; [ set-theora-gadget-player ] keep ;
M: theora-gadget pref-dim* M: theora-gadget pref-dim*
theora-gadget-player 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 ;
@ -598,10 +598,10 @@ M: theora-gadget draw-gadget* ( gadget -- )
"Theora Player" open-window ; "Theora Player" open-window ;
: play-ogg ( player -- ) : play-ogg ( player -- )
parse-initial-headers parse-initial-headers
parse-remaining-headers parse-remaining-headers
initialize-decoder initialize-decoder
dup player-gadget [ initialize-gui ] when* dup player-gadget [ initialize-gui ] when*
[ decode ] [ drop ] recover [ decode ] [ drop ] recover
! decode ! decode
wait-for-sound wait-for-sound
@ -615,8 +615,8 @@ M: theora-gadget draw-gadget* ( gadget -- )
<file-reader> play-vorbis-stream ; <file-reader> play-vorbis-stream ;
: play-theora-stream ( stream -- ) : play-theora-stream ( stream -- )
<player> <player>
dup <theora-gadget> over set-player-gadget dup <theora-gadget> over set-player-gadget
play-ogg ; play-ogg ;
: play-theora-file ( filename -- ) : play-theora-file ( filename -- )

View File

@ -1,5 +1,18 @@
USING: arrays kernel sequences sequences.lib math USING: arrays kernel sequences sequences.lib math math.functions math.ranges
math.functions tools.test strings ; tools.test strings ;
IN: temporary
[ 50 ] [ 100 [1,b] [ even? ] count ] unit-test
[ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test
[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer
{ { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test
{ { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@ -7,6 +20,8 @@ math.functions tools.test strings ;
[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test [ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test [ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
[ -4 ] [ 1 -4 [ abs ] higher ] unit-test [ -4 ] [ 1 -4 [ abs ] higher ] unit-test
[ 1 ] [ 1 -4 [ abs ] lower ] unit-test [ 1 ] [ 1 -4 [ abs ] lower ] unit-test