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

basis/io/files/links/links-docs.factor

@@ -5,6 +5,10 @@ HELP: make-link
 { $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
 { $description "Creates a symbolic link." } ;
 
+HELP: make-hard-link
+{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } }
+{ $description "Creates a hard link." } ;
+
 HELP: read-link
 { $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
 { $description "Reads the symbolic link and returns its target path." } ;

basis/io/files/links/links.factor

@@ -6,6 +6,8 @@ IN: io.files.links
 
 HOOK: make-link os ( target symlink -- )
 
+HOOK: make-hard-link os ( target link -- )
+
 HOOK: read-link os ( symlink -- path )
 
 : copy-link ( target symlink -- )

basis/io/files/links/unix/unix.factor

@@ -7,6 +7,9 @@ IN: io.files.links.unix
 M: unix make-link ( path1 path2 -- )
     normalize-path symlink io-error ;
 
+M: unix make-hard-link ( path1 path2 -- )
+    normalize-path link io-error ;
+
 M: unix read-link ( path -- path' )
     normalize-path read-symbolic-link ;
 

basis/tools/scaffold/scaffold.factor

@@ -6,7 +6,7 @@ vocabs.loader io combinators calendar accessors math.parser
 io.streams.string ui.tools.operations quotations strings arrays
 prettyprint words vocabs sorting sets classes math alien urls
 splitting ascii combinators.short-circuit alarms words.symbol
-system ;
+system summary ;
 IN: tools.scaffold
 
 SYMBOL: developer-name
@@ -16,6 +16,10 @@ ERROR: not-a-vocab-root string ;
 ERROR: vocab-name-contains-separator path ;
 ERROR: vocab-name-contains-dot path ;
 ERROR: no-vocab vocab ;
+ERROR: bad-developer-name name ;
+
+M: bad-developer-name summary
+    drop "Developer name must be a string." ;
 
 <PRIVATE
 
@@ -101,10 +105,14 @@ ERROR: no-vocab vocab ;
     ] if ;
 
 : scaffold-authors ( vocab-root vocab -- )
-    "authors.txt" vocab-root/vocab/file>path scaffolding? [
+    developer-name get [
-        [ developer-name get ] dip utf8 set-file-contents
+        "authors.txt" vocab-root/vocab/file>path scaffolding? [
+            developer-name get swap utf8 set-file-contents
+        ] [
+            drop
+        ] if
     ] [
-        drop
+        2drop
     ] if ;
 
 : lookup-type ( string -- object/string ? )
@@ -298,9 +306,12 @@ SYMBOL: examples-flag
         "}" print
     ] with-variable ;
 
+: touch. ( path -- )
+    [ touch-file ]
+    [ "Click to edit: " write <pathname> . ] bi ;
+
 : scaffold-rc ( path -- )
-    [ home ] dip append-path
+    [ home ] dip append-path touch. ;
-    [ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
 
 : scaffold-factor-boot-rc ( -- )
     os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
@@ -308,4 +319,7 @@ SYMBOL: examples-flag
 : scaffold-factor-rc ( -- )
     os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
 
-: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
+
+HOOK: scaffold-emacs os ( -- )
+
+M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;

basis/tools/scaffold/windows/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/tools/scaffold/windows/windows.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.pathnames system tools.scaffold windows.shell32 ;
+IN: tools.scaffold.windows
+
+M: windows scaffold-emacs ( -- )
+    application-data ".emacs" append-path touch. ;

basis/unix/unix.factor

@@ -194,6 +194,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_
 FUNCTION: int setuid ( uid_t uid ) ;
 FUNCTION: int socket ( int domain, int type, int protocol ) ;
 FUNCTION: int symlink ( char* path1, char* path2 ) ;
+FUNCTION: int link ( char* path1, char* path2 ) ;
 FUNCTION: int system ( char* command ) ;
 
 FUNCTION: int unlink ( char* path ) ;

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,85 @@
+USING: alien.c-types alien.syntax audio combinators
+combinators.short-circuit io io.binary io.encodings.binary
+io.files io.streams.byte-array kernel locals math
+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" }
+    ;
+
+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" }
+    ;
+
+ERROR: invalid-wav-file ;
+
+: ensured-read ( count -- output/f )
+    [ read ] keep over length = [ drop f ] unless ;
+: ensured-read* ( count -- output )
+    ensured-read [ invalid-wav-file ] unless* ;
+
+: read-chunk ( -- byte-array/f )
+    4 ensured-read [ 4 ensured-read* dup le> ensured-read* 3append ] [ f ] if* ;
+: read-riff-chunk ( -- byte-array/f )
+    "riff-chunk" heap-size ensured-read* ;
+
+: id= ( chunk id -- ? )
+    [ 4 head ] dip sequence= ;
+
+: check-chunk ( chunk id min-size -- ? )
+    [ id= ] [ [ length ] dip >= ] bi-curry* bi and ;
+
+:: read-wav-chunks ( -- fmt data )
+    f :> fmt! f :> data!
+    [ { [ fmt data and not ] [ read-chunk ] } 0&& dup ]
+    [ {
+        { [ dup FMT-MAGIC  "wav-fmt-chunk"  heap-size check-chunk ] [ fmt!  ] }
+        { [ dup DATA-MAGIC "wav-data-chunk" heap-size check-chunk ] [ data! ] }
+    } cond ] while drop
+    fmt data 2dup and [ invalid-wav-file ] unless ;
+
+: verify-wav ( chunk -- )
+    {
+        [ RIFF-MAGIC id= ]
+        [ riff-chunk-format 4 memory>byte-array 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-riff-chunk verify-wav (read-wav)
+    ] 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/tar/tar.factor

@@ -13,7 +13,7 @@ CONSTANT: block-size 512
 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 linkname magic version uname gname devmajor devminor prefix ;
 
-ERROR: checksum-error ;
+ERROR: checksum-error header ;
 
 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 
@@ -60,14 +60,16 @@ ERROR: checksum-error ;
     ] if ;
 
 : parse-tar-header ( seq -- obj )
-    [ checksum-header ] keep over zero-checksum = [
+    dup checksum-header dup zero-checksum = [
         2drop
         \ tar-header new
             0 >>size
             0 >>checksum
     ] [
-        binary [ read-tar-header ] with-byte-reader
+        [
-        [ checksum>> = [ checksum-error ] unless ] keep
+            binary [ read-tar-header ] with-byte-reader
+            dup checksum>>
+        ] dip = [ checksum-error ] unless
     ] if ;
 
 ERROR: unknown-typeflag ch ;
@@ -90,7 +92,8 @@ M: unknown-typeflag summary ( obj -- str )
     ] if ;
 
 ! Hard link
-: typeflag-1 ( header -- ) unknown-typeflag ;
+: typeflag-1 ( header -- )
+    [ name>> ] [ linkname>> ] bi make-hard-link ;
 
 ! Symlink
 : typeflag-2 ( header -- )
@@ -141,7 +144,8 @@ M: unknown-typeflag summary ( obj -- str )
 
 ! Long file name
 : typeflag-L ( header -- )
-    drop ;
+    drop
+    ;
     ! <string-writer> [ read-data-blocks ] keep
     ! >string [ zero? ] trim-tail filename set
     ! filename get prepend-current-directory make-directories ;
@@ -161,7 +165,7 @@ M: unknown-typeflag summary ( obj -- str )
 ! Vendor extended header type
 : typeflag-X ( header -- ) unknown-typeflag ;
 
-: (parse-tar) ( -- )
+: parse-tar ( -- )
     block-size read dup length block-size = [
         parse-tar-header
         dup typeflag>>
@@ -182,19 +186,19 @@ M: unknown-typeflag summary ( obj -- str )
             ! { CHAR: E [ typeflag-E ] }
             ! { CHAR: I [ typeflag-I ] }
             ! { CHAR: K [ typeflag-K ] }
-            ! { CHAR: L [ typeflag-L ] }
+            { CHAR: L [ typeflag-L ] }
             ! { CHAR: M [ typeflag-M ] }
             ! { CHAR: N [ typeflag-N ] }
             ! { CHAR: S [ typeflag-S ] }
             ! { CHAR: V [ typeflag-V ] }
             ! { CHAR: X [ typeflag-X ] }
             { f [ drop ] }
-        } case (parse-tar)
+        } case parse-tar
     ] [
         drop
     ] if ;
 
 : untar ( path -- )
-    normalize-path [ ] [ parent-directory ] bi [
+    normalize-path dup parent-directory [
-         binary [ (parse-tar) ] with-file-reader
+         binary [ parse-tar ] with-file-reader
     ] with-directory ;