HELP: [|
{ $syntax "[| bindings... | body... ]" }
-{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack values and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
+{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
{ $examples "See " { $link "locals-examples" } "." } ;
HELP: [let
{ $code ":> c :> b :> a" }
{ $code ":> ( a b c )" }
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes
"This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link POSTPONE: [let } " can be used to create a lexical scope where one is not otherwise available." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a macro with named inputs. The macro binds its input variables to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" }
{ $description "Defines a memoized word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
{ $syntax "M:: class generic ( vars... -- outputs... ) body... ;" }
{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
$nl
-"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information." }
{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." }
{ $examples "See " { $link "locals-examples" } "." } ;
ARTICLE: "locals-mutable" "Mutable lexical variables"
"When a lexical variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
$nl
-"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
+"Mutable bindings are implemented in a manner similar to that taken by the ML language. Each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
$nl
"Writing to mutable variables from outer lexical scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable lexical variables in action." ;
M: audio-listener audio-velocity velocity>> ; inline
M: audio-listener audio-orientation orientation>> ; inline
-GENERIC# generate-audio 1 ( generator buffer-size -- c-ptr size )
+GENERIC: generate-audio ( generator -- c-ptr size )
GENERIC: generator-audio-format ( generator -- channels sample-bits sample-rate )
TUPLE: audio-engine < disposable
TUPLE: streaming-audio-clip < audio-clip
generator
- { buffer-size integer }
{ channels integer }
{ sample-bits integer }
{ sample-rate integer }
:: queue-clip-buffer ( audio-clip al-buffer -- )
audio-clip al-source>> :> al-source
audio-clip generator>> :> generator
- audio-clip buffer-size>> :> buffer-size
- generator buffer-size generate-audio :> ( data size )
+ generator generate-audio :> ( data size )
data [
al-buffer audio-clip openal-format data size audio-clip sample-rate>> alBufferData
clip
] [ f ] if ;
-:: <streaming-audio-clip> ( audio-engine source generator buffer-size buffer-count -- audio-clip/f )
+:: <streaming-audio-clip> ( audio-engine source generator buffer-count -- audio-clip/f )
audio-engine get-available-source :> al-source
al-source [
source >>source
al-source >>al-source
generator >>generator
- buffer-size >>buffer-size
channels >>channels
sample-bits >>sample-bits
sample-rate >>sample-rate
al-buffers [ clip swap queue-clip-buffer ] each
clip audio-engine clips>> push
clip
- ] [ f ] if ;
+ ] [ generator dispose f ] if ;
M: audio-clip dispose*
[ dup audio-engine>> clips>> remove! drop ]
M: streaming-audio-clip dispose*
[ call-next-method ]
- [ al-buffers>> [ length ] keep alDeleteBuffers ] bi ;
+ [ generator>> dispose ]
+ [ al-buffers>> [ length ] keep alDeleteBuffers ] tri ;
: play-clip ( audio-clip -- )
[ update-source ]
: play-static-audio-clip ( audio-engine source audio loop? -- audio-clip/f )
<static-audio-clip> dup [ play-clip ] when* ;
-: play-streaming-audio-clip ( audio-engine source generator buffer-size buffer-count -- audio-clip/f )
+: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f )
<streaming-audio-clip> dup [ play-clip ] when* ;
: pause-clip ( audio-clip -- )
--- /dev/null
+! (c)2007, 2010 Chris Double, Joe Groff bsd license
+USING: accessors alien.c-types audio.engine byte-arrays classes.struct
+combinators destructors fry gpu.buffers io io.files io.encodings.binary
+kernel libc locals make math math.order math.parser ogg ogg.vorbis
+sequences specialized-arrays specialized-vectors ;
+FROM: alien.c-types => float short void* ;
+SPECIALIZED-ARRAYS: float void* ;
+SPECIALIZED-VECTOR: short
+IN: audio.vorbis
+
+TUPLE: vorbis-stream < disposable
+ stream
+ { packet ogg-packet }
+ { sync-state ogg-sync-state }
+ { page ogg-page }
+ { stream-state ogg-stream-state }
+ { info vorbis-info }
+ { dsp-state vorbis-dsp-state }
+ { block vorbis-block }
+ { comment vorbis-comment }
+ { temp-state ogg-stream-state }
+ { #vorbis-headers integer initial: 0 }
+ { stream-eof? boolean } ;
+
+CONSTANT: stream-buffer-size 4096
+
+ERROR: ogg-error code ;
+ERROR: vorbis-error code ;
+ERROR: no-vorbis-in-ogg ;
+
+<PRIVATE
+: init-vorbis ( vorbis-stream -- )
+ [ sync-state>> ogg_sync_init drop ]
+ [ info>> vorbis_info_init ]
+ [ comment>> vorbis_comment_init ] tri ;
+
+: sync-buffer ( vorbis-stream -- buffer size )
+ sync-state>> stream-buffer-size ogg_sync_buffer
+ stream-buffer-size ; inline
+
+: 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 ;
+
+: stream-into-buffer ( buffer size vorbis-stream -- len )
+ stream>> read-bytes-into ; inline
+
+: ?ogg-error ( n -- )
+ dup 0 < [ ogg-error ] [ drop ] if ; inline
+
+: confirm-buffer ( len vorbis-stream -- ? )
+ '[ _ sync-state>> swap ogg_sync_wrote ?ogg-error ] keep zero? not ; inline
+
+: buffer-data-from-stream ( vorbis-stream -- ? )
+ [ sync-buffer ] [ stream-into-buffer ] [ confirm-buffer ] tri ; inline
+
+: queue-page ( vorbis-stream -- )
+ [ stream-state>> ] [ page>> ] bi ogg_stream_pagein drop ; inline
+
+: retrieve-page ( vorbis-stream -- ? )
+ [ sync-state>> ] [ page>> ] bi ogg_sync_pageout 0 > ; inline
+
+: sync-pages ( vorbis-stream -- )
+ dup retrieve-page [ [ queue-page ] [ sync-pages ] bi ] [ drop ] if ;
+
+: standard-initial-header? ( vorbis-stream -- bool )
+ page>> ogg_page_bos zero? not ; inline
+
+: ogg-stream-init ( vorbis-stream -- state )
+ [ temp-state>> dup ]
+ [ page>> ogg_page_serialno ogg_stream_init ?ogg-error ] bi ; inline
+
+: ogg-stream-pagein ( state vorbis-stream -- )
+ page>> ogg_stream_pagein drop ; inline
+
+: ogg-stream-packetout ( state vorbis-stream -- )
+ packet>> ogg_stream_packetout drop ; inline
+
+: decode-packet ( vorbis-stream -- state )
+ [ ogg-stream-init ] keep
+ [ ogg-stream-pagein ] [ ogg-stream-packetout ] [ drop ] 2tri ; inline
+
+: vorbis-header? ( vorbis-stream -- ? )
+ [ info>> ] [ comment>> ] [ packet>> ] tri vorbis_synthesis_headerin 0 >= ; inline
+
+: is-initial-vorbis-packet? ( vorbis-stream -- ? )
+ dup #vorbis-headers>> zero? [ vorbis-header? ] [ drop f ] if ; inline
+
+: save-initial-vorbis-header ( state vorbis-stream -- )
+ [ stream-state>> swap dup byte-length memcpy ]
+ [ 1 >>#vorbis-headers drop ] bi ; inline
+
+: drop-initial-other-header ( state vorbis-stream -- )
+ swap ogg_stream_clear 2drop ; inline
+
+: process-initial-header ( vorbis-stream -- ? )
+ dup standard-initial-header? [
+ [ decode-packet ] keep
+ dup is-initial-vorbis-packet?
+ [ save-initial-vorbis-header ]
+ [ drop-initial-other-header ] if
+ t
+ ] [ drop f ] if ;
+
+: parse-initial-headers ( vorbis-stream -- )
+ dup retrieve-page
+ [ dup process-initial-header [ parse-initial-headers ] [ queue-page ] if ]
+ [ dup buffer-data-from-stream [ parse-initial-headers ] [ drop ] if ] if ;
+
+: have-required-vorbis-headers? ( vorbis-stream -- ? )
+ #vorbis-headers>> 1 2 between? not ; inline
+
+: ?vorbis-error ( code -- )
+ [ vorbis-error ] unless-zero ; inline
+
+: get-remaining-vorbis-header-packet ( player -- ? )
+ [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout {
+ { [ dup 0 < ] [ vorbis-error ] }
+ { [ dup zero? ] [ drop f ] }
+ [ drop t ]
+ } cond ;
+
+: decode-remaining-vorbis-header-packet ( vorbis-stream -- )
+ [ info>> ] [ comment>> ] [ packet>> ] tri vorbis_synthesis_headerin ?vorbis-error ;
+
+: parse-remaining-vorbis-headers ( vorbis-stream -- )
+ dup have-required-vorbis-headers? not [
+ dup get-remaining-vorbis-header-packet [
+ [ decode-remaining-vorbis-header-packet ]
+ [ [ 1 + ] change-#vorbis-headers drop ]
+ [ parse-remaining-vorbis-headers ] tri
+ ] [ drop ] if
+ ] [ drop ] if ;
+
+: parse-remaining-headers ( vorbis-stream -- )
+ dup have-required-vorbis-headers? not [
+ [ parse-remaining-vorbis-headers ]
+ [ dup retrieve-page [ queue-page ] [ buffer-data-from-stream drop ] if ]
+ [ parse-remaining-headers ] tri
+ ] [ drop ] if ;
+
+: init-vorbis-codec ( vorbis-stream -- )
+ [ [ dsp-state>> ] [ info>> ] bi vorbis_synthesis_init drop ]
+ [ [ dsp-state>> ] [ block>> ] bi vorbis_block_init drop ] bi ;
+
+: initialize-decoder ( vorbis-stream -- )
+ dup #vorbis-headers>> zero?
+ [ no-vorbis-in-ogg ]
+ [ init-vorbis-codec ] if ;
+
+: get-pending-decoded-audio ( vorbis-stream -- pcm len )
+ dsp-state>> f <void*> [ vorbis_synthesis_pcmout ] keep *void* swap ;
+
+:: make-pcm-buffer ( vorbis-stream pcm len -- short-array )
+ vorbis-stream info>> channels>> :> #channels
+ pcm #channels <direct-void*-array> :> channel*s
+ #channels len * <short-vector> :> output
+
+ len iota [| sample |
+ #channels iota [| channel |
+ channel channel*s nth len <direct-float-array> :> samples
+ sample samples nth
+ -32767.0 * >integer -32767 32767 clamp
+ output push
+ ] each
+ ] each
+ output >short-array ; inline
+
+: read-samples ( vorbis-stream pcm len -- )
+ [ dsp-state>> ] [ drop ] [ ] tri* vorbis_synthesis_read drop ; inline
+
+: queue-audio ( vorbis-stream -- ? )
+ dup [ stream-state>> ] [ packet>> ] bi ogg_stream_packetout 0 > [
+ dup [ block>> ] [ packet>> ] bi vorbis_synthesis 0 = [
+ [ dsp-state>> ] [ block>> ] bi vorbis_synthesis_blockin drop
+ ] [ drop ] if t
+ ] [ drop f ] if ;
+
+: decode-audio ( vorbis-stream -- short-array/f length/f )
+ dup get-pending-decoded-audio dup 0 > [
+ [ make-pcm-buffer dup byte-length ] [ read-samples ] 3bi
+ ] [
+ 2drop dup queue-audio [ decode-audio ] [ drop f f ] if
+ ] if ;
+PRIVATE>
+
+: <vorbis-stream> ( stream -- vorbis-stream )
+ [
+ vorbis-stream new-disposable
+ swap >>stream
+ ogg-packet malloc-struct |free >>packet
+ ogg-sync-state malloc-struct |free >>sync-state
+ ogg-page malloc-struct |free >>page
+ ogg-stream-state malloc-struct |free >>stream-state
+ vorbis-info malloc-struct |free >>info
+ vorbis-dsp-state malloc-struct |free >>dsp-state
+ vorbis-block malloc-struct |free >>block
+ vorbis-comment malloc-struct |free >>comment
+ ogg-stream-state malloc-struct |free >>temp-state
+ dup {
+ [ init-vorbis ]
+ [ parse-initial-headers ]
+ [ parse-remaining-headers ]
+ [ initialize-decoder ]
+ } cleave
+ ] with-destructors ;
+
+: read-vorbis-stream ( filename -- vorbis-stream )
+ binary <file-reader> <vorbis-stream> ; inline
+
+M: vorbis-stream dispose*
+ {
+ [ temp-state>> [ free ] when* ]
+ [ comment>> [ [ vorbis_comment_clear ] [ free ] bi ] when* ]
+ [ block>> [ free ] when* ]
+ [ dsp-state>> [ free ] when* ]
+ [ info>> [ [ vorbis_info_clear ] [ free ] bi ] when* ]
+ [ stream-state>> [ free ] when* ]
+ [ page>> [ free ] when* ]
+ [ sync-state>> [ free ] when* ]
+ [ packet>> [ free ] when* ]
+ } cleave ;
+
+M: vorbis-stream generator-audio-format
+ [ info>> channels>> ] [ drop 16 ] [ info>> rate>> ] tri ;
+M: vorbis-stream generate-audio
+ dup decode-audio
+ [ [ drop ] 2dip ]
+ [ drop [ buffer-data-from-stream drop ] [ sync-pages ] [ decode-audio ] tri ] if* ;
projects / factor.git / commitdiff