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

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

db4
Doug Coleman 2009-04-30 10:26:51 -05:00
parent 65d76e6509 afa787989a
commit 335d7b9cee
11 changed files with 255 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/io/files/links/links-docs.factor
View File

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

2
basis/io/files/links/links.factor
View File

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

3
basis/io/files/links/unix/unix.factor
View File

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

28
basis/tools/scaffold/scaffold.factor
View File

@ -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 ] dip utf8 set-file-contents
developer-name get [
"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
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
[ home ] dip append-path touch. ;
: 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 ;

1
basis/tools/scaffold/windows/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

7
basis/tools/scaffold/windows/windows.factor Executable file
View File

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

1
basis/unix/unix.factor
View File

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

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 ;

85
extra/audio/wav/wav.factor Normal file
View File

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

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 ;

26
extra/tar/tar.factor
View File

@ -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 [
binary [ (parse-tar) ] with-file-reader
normalize-path dup parent-directory [
binary [ parse-tar ] with-file-reader
] with-directory ;