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

basis/functors/functors-tests.factor

@@ -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
+

basis/functors/functors.factor

@@ -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 }
     } ;

basis/math/quaternions/quaternions-docs.factor

@@ -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." }

basis/math/quaternions/quaternions-tests.factor

@@ -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

basis/math/quaternions/quaternions.factor

@@ -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 ;
 

core/classes/tuple/parser/parser.factor

@@ -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 )
+: parse-tuple-literal-slots ( class -- tuple )
-    scan-word scan {
+    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 ;

extra/audio/audio.factor

@@ -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 ;
+

extra/audio/wav/wav.factor

@@ -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 ;

extra/game-loop/game-loop.factor

@@ -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 ;
+

extra/morse/morse.factor

@@ -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 ;