Merge branch 'master' of git://factorcode.org/git/factor
commit
21fbed98b3
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 }
|
||||||
} ;
|
} ;
|
||||||
|
|
|
@ -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." }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue