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

db4
John Benediktsson 2009-04-29 04:11:25 -07:00
commit 21fbed98b3
10 changed files with 250 additions and 8 deletions

View File

@ -63,6 +63,24 @@ WHERE
[ 4 ] [ 1 3 blah ] unit-test [ 4 ] [ 1 3 blah ] unit-test
<<
FUNCTOR: symbol-test ( W -- )
W DEFINES ${W}
WHERE
SYMBOL: W
;FUNCTOR
"blorgh" symbol-test
>>
[ blorgh ] [ blorgh ] unit-test
GENERIC: some-generic ( a -- b ) GENERIC: some-generic ( a -- b )
! Does replacing an ordinary word with a functor-generated one work? ! Does replacing an ordinary word with a functor-generated one work?
@ -72,6 +90,7 @@ GENERIC: some-generic ( a -- b )
TUPLE: some-tuple ; TUPLE: some-tuple ;
: some-word ( -- ) ; : some-word ( -- ) ;
M: some-tuple some-generic ; M: some-tuple some-generic ;
SYMBOL: some-symbol
"> <string-reader> "functors-test" parse-stream "> <string-reader> "functors-test" parse-stream
] unit-test ] unit-test
@ -82,6 +101,7 @@ GENERIC: some-generic ( a -- b )
"some-tuple" "functors.tests" lookup "some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean "some-generic" "functors.tests" lookup method >boolean
] unit-test ; ] unit-test ;
[ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
test-redefinition test-redefinition
@ -90,12 +110,14 @@ FUNCTOR: redefine-test ( W -- )
W-word DEFINES ${W}-word W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple W-tuple DEFINES-CLASS ${W}-tuple
W-generic IS ${W}-generic W-generic IS ${W}-generic
W-symbol DEFINES ${W}-symbol
WHERE WHERE
TUPLE: W-tuple ; TUPLE: W-tuple ;
: W-word ( -- ) ; : W-word ( -- ) ;
M: W-tuple W-generic ; M: W-tuple W-generic ;
SYMBOL: W-symbol
;FUNCTOR ;FUNCTOR
@ -105,4 +127,5 @@ M: W-tuple W-generic ;
"> <string-reader> "functors-test" parse-stream "> <string-reader> "functors-test" parse-stream
] unit-test ] unit-test
test-redefinition test-redefinition

View File

@ -5,7 +5,7 @@ words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser generic.parser effects.parser locals.types locals.parser generic.parser
locals.rewrite.closures vocabs.parser classes.parser locals.rewrite.closures vocabs.parser classes.parser
arrays accessors ; arrays accessors words.symbol ;
IN: functors IN: functors
! This is a hack ! This is a hack
@ -90,6 +90,10 @@ SYNTAX: `:
parse-declared* parse-declared*
\ define-declared* parsed ; \ define-declared* parsed ;
SYNTAX: `SYMBOL:
scan-param parsed
\ define-symbol parsed ;
SYNTAX: `SYNTAX: SYNTAX: `SYNTAX:
scan-param parsed scan-param parsed
parse-definition* parse-definition*
@ -128,6 +132,7 @@ DEFER: ;FUNCTOR delimiter
{ ":" POSTPONE: `: } { ":" POSTPONE: `: }
{ "INSTANCE:" POSTPONE: `INSTANCE: } { "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: } { "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline } { "inline" POSTPONE: `inline }
{ "call-next-method" POSTPONE: `call-next-method } { "call-next-method" POSTPONE: `call-next-method }
} ; } ;

View File

@ -1,6 +1,16 @@
USING: help.markup help.syntax math math.vectors vectors ; USING: help.markup help.syntax math math.vectors vectors ;
IN: math.quaternions IN: math.quaternions
HELP: q+
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } }
{ $description "Add quaternions." }
{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ;
HELP: q-
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } }
{ $description "Subtract quaternions." }
{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ;
HELP: q* HELP: q*
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } } { $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
{ $description "Multiply quaternions." } { $description "Multiply quaternions." }

View File

@ -24,3 +24,7 @@ math.constants ;
[ t ] [ qk q>v v>q qk = ] unit-test [ t ] [ qk q>v v>q qk = ] unit-test
[ t ] [ 1 c>q q1 = ] unit-test [ t ] [ 1 c>q q1 = ] unit-test
[ t ] [ C{ 0 1 } c>q qi = ] unit-test [ t ] [ C{ 0 1 } c>q qi = ] unit-test
[ t ] [ qi qi q+ qi 2 q*n = ] unit-test
[ t ] [ qi qi q- q0 = ] unit-test
[ t ] [ qi qj q+ qj qi q+ = ] unit-test
[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test

View File

@ -20,6 +20,12 @@ IN: math.quaternions
PRIVATE> PRIVATE>
: q+ ( u v -- u+v )
v+ ;
: q- ( u v -- u-v )
v- ;
: q* ( u v -- u*v ) : q* ( u v -- u*v )
[ q*a ] [ q*b ] 2bi 2array ; [ q*a ] [ q*b ] 2bi 2array ;

View File

@ -89,11 +89,14 @@ ERROR: bad-literal-tuple ;
swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>tuple ; [ dup <enum> ] dip update boa>tuple ;
: parse-tuple-literal ( -- tuple ) : parse-tuple-literal-slots ( class -- tuple )
scan-word scan { scan {
{ f [ unexpected-eof ] } { f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] } { "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] } { "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] } { "}" [ new ] }
[ bad-literal-tuple ] [ bad-literal-tuple ]
} case ; } case ;
: parse-tuple-literal ( -- tuple )
scan-word parse-tuple-literal-slots ;

23
extra/audio/audio.factor Normal file
View File

@ -0,0 +1,23 @@
USING: accessors alien arrays combinators kernel math openal ;
IN: audio
TUPLE: audio
{ channels integer }
{ sample-bits integer }
{ sample-rate integer }
{ size integer }
{ data c-ptr } ;
C: <audio> audio
ERROR: format-unsupported-by-openal audio ;
: openal-format ( audio -- format )
dup [ channels>> ] [ sample-bits>> ] bi 2array {
{ { 1 8 } [ drop AL_FORMAT_MONO8 ] }
{ { 1 16 } [ drop AL_FORMAT_MONO16 ] }
{ { 2 8 } [ drop AL_FORMAT_STEREO8 ] }
{ { 2 16 } [ drop AL_FORMAT_STEREO16 ] }
[ drop format-unsupported-by-openal ]
} case ;

View File

@ -0,0 +1,74 @@
USING: alien.c-types alien.syntax audio combinators
combinators.short-circuit io io.binary io.encodings.binary
io.files io.streams.memory kernel locals sequences ;
IN: audio.wav
CONSTANT: RIFF-MAGIC "RIFF"
CONSTANT: WAVE-MAGIC "WAVE"
CONSTANT: FMT-MAGIC "fmt "
CONSTANT: DATA-MAGIC "data"
C-STRUCT: riff-chunk-header
{ "char[4]" "id" }
{ "uchar[4]" "size" }
;
C-STRUCT: riff-chunk
{ "riff-chunk-header" "header" }
{ "char[4]" "format" }
{ "uchar[0]" "body" }
;
C-STRUCT: wav-fmt-chunk
{ "riff-chunk-header" "header" }
{ "uchar[2]" "audio-format" }
{ "uchar[2]" "num-channels" }
{ "uchar[4]" "sample-rate" }
{ "uchar[4]" "byte-rate" }
{ "uchar[2]" "block-align" }
{ "uchar[2]" "bits-per-sample" }
;
C-STRUCT: wav-data-chunk
{ "riff-chunk-header" "header" }
{ "uchar[0]" "body" }
;
: read-chunk ( -- byte-array/f )
4 read [ 4 read le> [ <uint> ] [ read ] bi 3append ] [ f ] if* ;
: id= ( chunk id -- ? )
[ 4 memory>byte-array ] dip sequence= ;
:: read-wav-chunks ( -- fmt data )
f :> fmt! f :> data!
[ { [ fmt data and not ] [ read-chunk ] } 0&& dup ]
[ {
{ [ dup FMT-MAGIC id= ] [ fmt! ] }
{ [ dup DATA-MAGIC id= ] [ data! ] }
} cond ] while drop
fmt data ;
ERROR: invalid-wav-file ;
: verify-wav ( chunk -- )
{ [ RIFF-MAGIC id= ] [ riff-chunk-format WAVE-MAGIC id= ] } 1&&
[ invalid-wav-file ] unless ;
: (read-wav) ( -- audio )
read-wav-chunks
[
[ wav-fmt-chunk-num-channels 2 memory>byte-array le> ]
[ wav-fmt-chunk-bits-per-sample 2 memory>byte-array le> ]
[ wav-fmt-chunk-sample-rate 4 memory>byte-array le> ] tri
] [
[ riff-chunk-header-size 4 memory>byte-array le> dup ]
[ wav-data-chunk-body ] bi swap memory>byte-array
] bi* <audio> ;
: read-wav ( filename -- audio )
binary [
read-chunk
[ verify-wav ]
[ riff-chunk-body <memory-stream> [ (read-wav) ] with-input-stream* ] bi
] with-file-reader ;

View File

@ -0,0 +1,93 @@
USING: accessors destructors kernel math math.order namespaces
system threads ;
IN: game-loop
TUPLE: game-loop
{ tick-length integer read-only }
delegate
{ last-tick integer }
thread
{ running? boolean }
{ tick-number integer }
{ frame-number integer }
{ benchmark-time integer }
{ benchmark-tick-number integer }
{ benchmark-frame-number integer } ;
GENERIC: tick* ( delegate -- )
GENERIC: draw* ( tick-slice delegate -- )
SYMBOL: game-loop
: since-last-tick ( loop -- milliseconds )
last-tick>> millis swap - ;
: tick-slice ( loop -- slice )
[ since-last-tick ] [ tick-length>> ] bi /f 1.0 min ;
CONSTANT: MAX-FRAMES-TO-SKIP 5
<PRIVATE
: redraw ( loop -- )
[ 1+ ] change-frame-number
[ tick-slice ] [ delegate>> ] bi draw* ;
: tick ( loop -- )
delegate>> tick* ;
: increment-tick ( loop -- )
[ 1+ ] change-tick-number
dup tick-length>> [ + ] curry change-last-tick
drop ;
: ?tick ( loop count -- )
dup zero? [ drop millis >>last-tick drop ] [
over [ since-last-tick ] [ tick-length>> ] bi >=
[ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ]
[ 2drop ] if
] if ;
: (run-loop) ( loop -- )
dup running?>>
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
[ drop ] if ;
: run-loop ( loop -- )
dup game-loop [ (run-loop) ] with-variable ;
: benchmark-millis ( loop -- millis )
millis swap benchmark-time>> - ;
PRIVATE>
: reset-loop-benchmark ( loop -- )
millis >>benchmark-time
dup tick-number>> >>benchmark-tick-number
dup frame-number>> >>benchmark-frame-number
drop ;
: benchmark-ticks-per-second ( loop -- n )
[ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-millis ] tri /f ;
: benchmark-frames-per-second ( loop -- n )
[ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-millis ] tri /f ;
: start-loop ( loop -- )
millis >>last-tick
t >>running?
[ reset-loop-benchmark ]
[ [ run-loop ] curry "game loop" spawn ]
[ (>>thread) ] tri ;
: stop-loop ( loop -- )
f >>running?
f >>thread
drop ;
: <game-loop> ( tick-length delegate -- loop )
millis f f 0 0 millis 0 0
game-loop boa ;
M: game-loop dispose
stop-loop ;

View File

@ -3,7 +3,7 @@
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
IN: morse IN: morse
ERROR: no-morse-code ch ; ERROR: no-morse-ch ch ;
<PRIVATE <PRIVATE
@ -11,7 +11,7 @@ CONSTANT: dot-char CHAR: .
CONSTANT: dash-char CHAR: - CONSTANT: dash-char CHAR: -
CONSTANT: char-gap-char CHAR: \s CONSTANT: char-gap-char CHAR: \s
CONSTANT: word-gap-char CHAR: / CONSTANT: word-gap-char CHAR: /
CONSTANT: unknown-char "?" CONSTANT: unknown-char CHAR: ?
PRIVATE> PRIVATE>
@ -76,7 +76,7 @@ CONSTANT: morse-code-table $[
] ]
: ch>morse ( ch -- morse ) : ch>morse ( ch -- morse )
ch>lower morse-code-table at unknown-char or ; ch>lower morse-code-table at unknown-char 1string or ;
: morse>ch ( str -- ch ) : morse>ch ( str -- ch )
morse-code-table value-at char-gap-char or ; morse-code-table value-at char-gap-char or ;
@ -156,7 +156,8 @@ CONSTANT: beep-freq 880
{ dot-char [ dot ] } { dot-char [ dot ] }
{ dash-char [ dash ] } { dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] } { word-gap-char [ intra-char-gap ] }
[ drop intra-char-gap ] { unknown-char [ intra-char-gap ] }
[ no-morse-ch ]
} case } case
] interleave ; ] interleave ;