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

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

db4
John Benediktsson 2009-04-29 04:11:25 -07:00
parent d804a0a683 570315d8c5
commit 21fbed98b3
10 changed files with 250 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
basis/functors/functors-tests.factor
View File

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

7
basis/functors/functors.factor
View File

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

10
basis/math/quaternions/quaternions-docs.factor
View File

@ -1,6 +1,16 @@
USING: help.markup help.syntax math math.vectors vectors ;
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*
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
{ $description "Multiply quaternions." }

4
basis/math/quaternions/quaternions-tests.factor
View File

@ -24,3 +24,7 @@ math.constants ;
[ t ] [ qk q>v v>q qk = ] unit-test
[ t ] [ 1 c>q q1 = ] 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

6
basis/math/quaternions/quaternions.factor
View File

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

7
core/classes/tuple/parser/parser.factor
View File

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

74
extra/audio/wav/wav.factor Normal file
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 ;

93
extra/game-loop/game-loop.factor Normal file
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 ;

9
extra/morse/morse.factor
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 ;
IN: morse
ERROR: no-morse-code ch ;
ERROR: no-morse-ch ch ;
<PRIVATE
@ -11,7 +11,7 @@ CONSTANT: dot-char CHAR: .
CONSTANT: dash-char CHAR: -
CONSTANT: char-gap-char CHAR: \s
CONSTANT: word-gap-char CHAR: /
CONSTANT: unknown-char "?"
CONSTANT: unknown-char CHAR: ?
PRIVATE>
@ -76,7 +76,7 @@ CONSTANT: morse-code-table $[
]
: 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-code-table value-at char-gap-char or ;
@ -156,7 +156,8 @@ CONSTANT: beep-freq 880
{ dot-char [ dot ] }
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
[ drop intra-char-gap ]
{ unknown-char [ intra-char-gap ] }
[ no-morse-ch ]
} case
] interleave ;