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-02-19 07:25:51 -08:00
parent 0959d47d4a bdb790010a
commit de01e67a91
48 changed files with 1020 additions and 474 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/calendar/format/format-tests.factor
View File

@ -51,6 +51,11 @@ IN: calendar.format.tests
timestamp>string timestamp>string
] unit-test ] unit-test
[ "20080504070000" ] [
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
timestamp>mdtm
] unit-test
[ [
T{ timestamp f T{ timestamp f
2008 2008
@ -74,3 +79,5 @@ IN: calendar.format.tests
{ gmt-offset T{ duration f 0 0 0 0 0 0 } } { gmt-offset T{ duration f 0 0 0 0 0 0 } }
} }
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test ] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test

3
basis/calendar/format/format.factor
View File

@ -78,6 +78,9 @@ M: integer year. ( n -- )
M: timestamp year. ( timestamp -- ) M: timestamp year. ( timestamp -- )
year>> year. ; year>> year. ;
: timestamp>mdtm ( timestamp -- str )
[ { YYYY MM DD hh mm ss } formatted ] with-string-writer ;
: (timestamp>string) ( timestamp -- ) : (timestamp>string) ( timestamp -- )
{ DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ; { DAY ", " D " " MONTH " " YYYY " " hh ":" mm ":" ss } formatted ;

2
basis/ftp/client/client.factor
View File

@ -93,7 +93,7 @@ ERROR: ftp-error got expected ;
: ensure-login ( url -- url ) : ensure-login ( url -- url )
dup username>> [ dup username>> [
"anonymous" >>username "anonymous" >>username
"ftp-client" >>password "ftp-client@factorcode.org" >>password
] unless ; ] unless ;
: >ftp-url ( url -- url' ) >url ensure-port ensure-login ; : >ftp-url ( url -- url' ) >url ensure-port ensure-login ;

5
basis/ftp/ftp.factor
View File

@ -4,8 +4,7 @@ USING: accessors arrays assocs combinators io io.files kernel
math.parser sequences strings ; math.parser sequences strings ;
IN: ftp IN: ftp
SINGLETON: active SYMBOLS: +active+ +passive+ ;
SINGLETON: passive
TUPLE: ftp-response n strings parsed ; TUPLE: ftp-response n strings parsed ;
@ -17,5 +16,3 @@ TUPLE: ftp-response n strings parsed ;
over strings>> push ; over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ; : ftp-send ( string -- ) write "\r\n" write flush ;
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline

50
basis/ftp/server/server-tests.factor Normal file
View File

@ -0,0 +1,50 @@
USING: calendar ftp.server io.encodings.ascii io.files
io.files.unique namespaces threads tools.test kernel
io.servers.connection ftp.client accessors urls
io.pathnames io.directories sequences fry ;
IN: ftp.server.tests
: test-file-contents ( -- string )
"Files are so boring anymore." ;
: create-test-file ( -- path )
test-file-contents
"ftp.server" "test" make-unique-file
[ ascii set-file-contents ] keep canonicalize-path ;
: test-ftp-server ( quot -- )
'[
current-temporary-directory get 0
<ftp-server>
[ start-server* ]
[
sockets>> first addr>> port>>
<url>
swap >>port
"ftp" >>protocol
"localhost" >>host
create-test-file >>path
_ call
]
[ stop-server ] tri
] with-unique-directory drop ; inline
[ t ]
[
[
unique-directory [
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
] with-directory
] test-ftp-server test-file-contents =
] unit-test
[
[
"/" >>path
unique-directory [
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
] with-directory
] test-ftp-server test-file-contents =
] must-fail

398
basis/ftp/server/server.factor
View File

@ -1,52 +1,46 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit accessors combinators io USING: accessors assocs byte-arrays calendar classes
io.encodings.8-bit io.encodings io.encodings.binary combinators combinators.short-circuit concurrency.promises
io.encodings.utf8 io.files io.files.info io.directories continuations destructors ftp io io.backend io.directories
io.sockets kernel math.parser namespaces make sequences io.encodings io.encodings.8-bit io.encodings.binary
ftp io.launcher.unix.parser unicode.case splitting tools.files io.encodings.utf8 io.files io.files.info
assocs classes io.servers.connection destructors calendar io.pathnames io.launcher.unix.parser io.servers.connection
io.timeouts io.streams.duplex threads continuations math io.sockets io.streams.duplex io.streams.string io.timeouts
concurrency.promises byte-arrays io.backend tools.hexdump kernel make math math.bitwise math.parser namespaces sequences
io.streams.string math.bitwise tools.files io.pathnames ; splitting threads unicode.case logging calendar.format
strings io.files.links io.files.types ;
IN: ftp.server IN: ftp.server
TUPLE: ftp-client url mode state command-promise user password ; SYMBOL: server
: <ftp-client> ( url -- ftp-client )
ftp-client new
swap >>url ;
SYMBOL: client SYMBOL: client
: ftp-server-directory ( -- str ) TUPLE: ftp-server < threaded-server { serving-directory string } ;
\ ftp-server-directory get-global "resource:temp" or
normalize-path ; TUPLE: ftp-client user password extra-connection ;
TUPLE: ftp-command raw tokenized ; TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( str -- obj )
: <ftp-command> ( -- obj ) dup \ <ftp-command> DEBUG log-message
ftp-command new ; ftp-command new
over >>raw
swap tokenize-command >>tokenized ;
TUPLE: ftp-get path ; TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj ) : <ftp-get> ( path -- obj )
ftp-get new ftp-get new
swap >>path ; swap >>path ;
TUPLE: ftp-put path ; TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj ) : <ftp-put> ( path -- obj )
ftp-put new ftp-put new
swap >>path ; swap >>path ;
TUPLE: ftp-list ; TUPLE: ftp-list ;
C: <ftp-list> ftp-list C: <ftp-list> ftp-list
: read-command ( -- ftp-command ) TUPLE: ftp-disconnect ;
<ftp-command> readln C: <ftp-disconnect> ftp-disconnect
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
: (send-response) ( n string separator -- ) : (send-response) ( n string separator -- )
[ number>string write ] 2dip write ftp-send ; [ number>string write ] 2dip write ftp-send ;
@ -56,28 +50,42 @@ C: <ftp-list> ftp-list
[ but-last-slice [ "-" (send-response) ] with each ] [ but-last-slice [ "-" (send-response) ] with each ]
[ first " " (send-response) ] 2bi ; [ first " " (send-response) ] 2bi ;
: server-response ( n string -- ) : server-response ( string n -- )
2dup number>string swap ":" glue \ server-response DEBUG log-message
<ftp-response> <ftp-response>
swap add-response-line
swap >>n swap >>n
swap add-response-line
send-response ; send-response ;
: ftp-error ( string -- ) : serving? ( path -- ? )
500 "Unrecognized command: " rot append server-response ; canonicalize-path server get serving-directory>> head? ;
: can-serve-directory? ( path -- ? )
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
: can-serve-file? ( path -- ? )
{
[ exists? ]
[ file-info type>> +regular-file+ = ]
[ serving? ]
} 1&& ;
: ftp-error ( string -- ) 500 server-response ;
: ftp-unimplemented ( string -- ) 502 server-response ;
: send-banner ( -- ) : send-banner ( -- )
220 "Welcome to " host-name append server-response ; "Welcome to " host-name append 220 server-response ;
: anonymous-only ( -- ) : anonymous-only ( -- )
530 "This FTP server is anonymous only." server-response ; "This FTP server is anonymous only." 530 server-response ;
: handle-QUIT ( obj -- ) : handle-QUIT ( obj -- )
drop 221 "Goodbye." server-response ; drop "Goodbye." 221 server-response ;
: handle-USER ( ftp-command -- ) : handle-USER ( ftp-command -- )
[ [
tokenized>> second client get (>>user) tokenized>> second client get (>>user)
331 "Please specify the password." server-response "Please specify the password." 331 server-response
] [ ] [
2drop "bad USER" ftp-error 2drop "bad USER" ftp-error
] recover ; ] recover ;
@ -85,7 +93,7 @@ C: <ftp-list> ftp-list
: handle-PASS ( ftp-command -- ) : handle-PASS ( ftp-command -- )
[ [
tokenized>> second client get (>>password) tokenized>> second client get (>>password)
230 "Login successful" server-response "Login successful" 230 server-response
] [ ] [
2drop "PASS error" ftp-error 2drop "PASS error" ftp-error
] recover ; ] recover ;
@ -102,7 +110,7 @@ ERROR: type-error type ;
: handle-TYPE ( obj -- ) : handle-TYPE ( obj -- )
[ [
tokenized>> second parse-type tokenized>> second parse-type
[ 200 ] dip "Switching to " " mode" surround server-response "Switching to " " mode" surround 200 server-response
] [ ] [
2drop "TYPE is binary only" ftp-error 2drop "TYPE is binary only" ftp-error
] recover ; ] recover ;
@ -115,65 +123,57 @@ ERROR: type-error type ;
: handle-PWD ( obj -- ) : handle-PWD ( obj -- )
drop drop
257 current-directory get "\"" dup surround server-response ; current-directory get "\"" dup surround 257 server-response ;
: handle-SYST ( obj -- ) : handle-SYST ( obj -- )
drop drop
215 "UNIX Type: L8" server-response ; "UNIX Type: L8" 215 server-response ;
: if-command-promise ( quot -- )
[ client get command-promise>> ] dip
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-STOR ( obj -- )
[
tokenized>> second
[ [ <ftp-put> ] dip fulfill ] if-command-promise
] [
2drop
] recover ;
! EPRT |2|::1|62138|
! : handle-EPRT ( obj -- )
! tokenized>> second "|" split harvest ;
: start-directory ( -- ) : start-directory ( -- )
150 "Here comes the directory listing." server-response ; "Here comes the directory listing." 150 server-response ;
: transfer-outgoing-file ( path -- )
[ "Opening BINARY mode data connection for " ] dip
[ file-name ] [
file-info size>> number>string
"(" " bytes)." surround
] bi " " glue append 150 server-response ;
: transfer-incoming-file ( path -- )
"Opening BINARY mode data connection for " prepend
150 server-response ;
: finish-file-transfer ( -- )
"File send OK." 226 server-response ;
GENERIC: handle-passive-command ( stream obj -- )
: passive-loop ( server -- )
[
[
|dispose
30 seconds over set-timeout
accept drop &dispose
client get extra-connection>>
30 seconds ?promise-timeout
handle-passive-command
]
[ client get f >>extra-connection drop ]
[ drop ] cleanup
] with-destructors ;
: finish-directory ( -- ) : finish-directory ( -- )
226 "Directory send OK." server-response ; "Directory send OK." 226 server-response ;
GENERIC: service-command ( stream obj -- ) M: ftp-list handle-passive-command ( stream obj -- )
M: ftp-list service-command ( stream obj -- )
drop drop
start-directory [ start-directory [
utf8 encode-output utf8 encode-output
[ current-directory get directory. ] with-string-writer string-lines [ current-directory get directory. ] with-string-writer string-lines
harvest [ ftp-send ] each harvest [ ftp-send ] each
] with-output-stream ] with-output-stream finish-directory ;
finish-directory ;
: transfer-outgoing-file ( path -- ) M: ftp-get handle-passive-command ( stream obj -- )
[
150
"Opening BINARY mode data connection for "
] dip
[
file-name
] [
file-info size>> number>string
"(" " bytes)." surround
] bi " " glue append server-response ;
: transfer-incoming-file ( path -- )
[ 150 ] dip "Opening BINARY mode data connection for " prepend
server-response ;
: finish-file-transfer ( -- )
226 "File send OK." server-response ;
M: ftp-get service-command ( stream obj -- )
[ [
path>> path>>
[ transfer-outgoing-file ] [ transfer-outgoing-file ]
@ -183,7 +183,7 @@ M: ftp-get service-command ( stream obj -- )
3drop "File transfer failed" ftp-error 3drop "File transfer failed" ftp-error
] recover ; ] recover ;
M: ftp-put service-command ( stream obj -- ) M: ftp-put handle-passive-command ( stream obj -- )
[ [
path>> path>>
[ transfer-incoming-file ] [ transfer-incoming-file ]
@ -193,165 +193,165 @@ M: ftp-put service-command ( stream obj -- )
3drop "File transfer failed" ftp-error 3drop "File transfer failed" ftp-error
] recover ; ] recover ;
: passive-loop ( server -- ) M: ftp-disconnect handle-passive-command ( stream obj -- )
[ drop dispose ;
[
|dispose : fulfill-client ( obj -- )
30 seconds over set-timeout client get extra-connection>> [
accept drop &dispose fulfill
client get command-promise>> ] [
30 seconds ?promise-timeout drop
service-command "Establish an active or passive connection first" ftp-error
] ] if* ;
[ client get f >>command-promise drop ]
[ drop ] cleanup : handle-STOR ( obj -- )
] with-destructors ; tokenized>> second
dup can-serve-file? [
<ftp-put> fulfill-client
] [
drop
<ftp-disconnect> fulfill-client
] if ;
: handle-LIST ( obj -- ) : handle-LIST ( obj -- )
drop drop current-directory get
[ [ <ftp-list> ] dip fulfill ] if-command-promise ; can-serve-directory? [
<ftp-list> fulfill-client
: handle-SIZE ( obj -- )
[
[ 213 ] dip
tokenized>> second file-info size>>
number>string server-response
] [ ] [
2drop <ftp-disconnect> fulfill-client
550 "Could not get file size" server-response ] if ;
] recover ;
: not-a-plain-file ( path -- )
": not a plain file." append ftp-error ;
: handle-RETR ( obj -- ) : handle-RETR ( obj -- )
[ tokenized>> second <ftp-get> swap fulfill ] tokenized>> second
curry if-command-promise ; dup can-serve-file? [
<ftp-get> fulfill-client
] [
not-a-plain-file
<ftp-disconnect> fulfill-client
] if ;
: handle-SIZE ( obj -- )
tokenized>> second
dup can-serve-file? [
file-info size>> number>string 213 server-response
] [
not-a-plain-file
] if ;
: expect-connection ( -- port ) : expect-connection ( -- port )
<promise> client get (>>extra-connection)
random-local-server random-local-server
client get <promise> >>command-promise drop
[ [ passive-loop ] curry in-thread ] [ [ passive-loop ] curry in-thread ]
[ addr>> port>> ] bi ; [ addr>> port>> ] bi ;
: handle-PASV ( obj -- ) : handle-PASV ( obj -- )
drop client get passive >>mode drop drop
221
expect-connection port>bytes [ number>string ] bi@ "," glue expect-connection port>bytes [ number>string ] bi@ "," glue
"Entering Passive Mode (127,0,0,1," ")" surround "Entering Passive Mode (127,0,0,1," ")" surround
server-response ; 221 server-response ;
: handle-EPSV ( obj -- ) : handle-EPSV ( obj -- )
drop drop
client get command-promise>> [ client get f >>extra-connection drop
"You already have a passive stream" ftp-error expect-connection number>string
] [ "Entering Extended Passive Mode (|||" "|)" surround
229 229 server-response ;
expect-connection number>string
"Entering Extended Passive Mode (|||" "|)" surround
server-response
] if ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 : handle-MDTM ( obj -- )
! : handle-LPRT ( obj -- ) tokenized>> "," split ; tokenized>> 1 swap ?nth [
dup file-info dup directory? [
ERROR: not-a-directory ; drop not-a-plain-file
ERROR: no-permissions ;
: handle-CWD ( obj -- )
[
tokenized>> second dup normalize-path
dup ftp-server-directory head? [
no-permissions
] unless
file-info directory? [
set-current-directory
250 "Directory successully changed." server-response
] [ ] [
not-a-directory nip
modified>> timestamp>mdtm
213 server-response
] if ] if
] [ ] [
2drop "" not-a-plain-file
550 "Failed to change directory." server-response ] if* ;
] recover ;
: unrecognized-command ( obj -- ) raw>> ftp-error ; ERROR: not-a-directory ;
ERROR: no-directory-permissions ;
: handle-client-loop ( -- ) : directory-change-success ( -- )
<ftp-command> readln "Directory successully changed." 250 server-response ;
USE: prettyprint global [ dup . flush ] bind
[ >>raw ] : directory-change-failed ( -- )
[ tokenize-command >>tokenized ] bi "Failed to change directory." 553 server-response ;
: handle-CWD ( obj -- )
tokenized>> 1 swap ?nth [
dup can-serve-directory? [
set-current-directory
directory-change-success
] [
drop
directory-change-failed
] if
] [
directory-change-success
] if* ;
: unrecognized-command ( obj -- )
raw>> "Unrecognized command: " prepend ftp-error ;
: client-loop-dispatch ( str/f -- ? )
dup tokenized>> first >upper { dup tokenized>> first >upper {
{ "QUIT" [ handle-QUIT f ] }
{ "USER" [ handle-USER t ] } { "USER" [ handle-USER t ] }
{ "PASS" [ handle-PASS t ] } { "PASS" [ handle-PASS t ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
{ "CWD" [ handle-CWD t ] }
! { "XCWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ handle-QUIT f ] }
! { "PORT" [ ] } ! TODO
{ "PASV" [ handle-PASV t ] }
! { "MODE" [ ] }
{ "TYPE" [ handle-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
{ "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
{ "RETR" [ handle-RETR t ] }
{ "LIST" [ handle-LIST t ] }
{ "SIZE" [ handle-SIZE t ] }
! { "NLST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
! { "RNTO" [ ] }
! { "DELE" [ handle-DELE t ] }
! { "RMD" [ handle-RMD t ] }
! ! { "XRMD" [ handle-XRMD t ] }
! { "MKD" [ handle-MKD t ] }
{ "PWD" [ handle-PWD t ] }
! { "ABOR" [ ] }
{ "SYST" [ handle-SYST t ] } { "SYST" [ handle-SYST t ] }
! { "STAT" [ ] } { "ACCT" [ drop "ACCT unimplemented" ftp-unimplemented t ] }
! { "HELP" [ ] } { "PWD" [ handle-PWD t ] }
{ "TYPE" [ handle-TYPE t ] }
! { "SITE" [ ] } { "CWD" [ handle-CWD t ] }
! { "NOOP" [ ] } { "PASV" [ handle-PASV t ] }
! { "EPRT" [ handle-EPRT ] }
! { "LPRT" [ handle-LPRT ] }
{ "EPSV" [ handle-EPSV t ] } { "EPSV" [ handle-EPSV t ] }
! { "LPSV" [ drop handle-LPSV t ] } { "LIST" [ handle-LIST t ] }
{ "STOR" [ handle-STOR t ] }
{ "RETR" [ handle-RETR t ] }
{ "SIZE" [ handle-SIZE t ] }
{ "MDTM" [ handle-MDTM t ] }
[ drop unrecognized-command t ] [ drop unrecognized-command t ]
} case [ handle-client-loop ] when ; } case ;
TUPLE: ftp-server < threaded-server ; : read-command ( -- ftp-command/f )
readln [ f ] [ <ftp-command> ] if-empty ;
: handle-client-loop ( -- )
read-command [
client-loop-dispatch
[ handle-client-loop ] when
] when* ;
: serve-directory ( server -- )
serving-directory>> [
send-banner
handle-client-loop
] with-directory ;
M: ftp-server handle-client* ( server -- ) M: ftp-server handle-client* ( server -- )
drop
[ [
ftp-server-directory [ "New client" \ handle-client* DEBUG log-message
host-name <ftp-client> client set ftp-client new client set
send-banner handle-client-loop [ server set ] [ serve-directory ] bi
] with-directory
] with-destructors ; ] with-destructors ;
: <ftp-server> ( port -- server ) : <ftp-server> ( directory port -- server )
ftp-server new-threaded-server ftp-server new-threaded-server
swap >>insecure swap >>insecure
swap canonicalize-path >>serving-directory
"ftp.server" >>name "ftp.server" >>name
5 minutes >>timeout 5 minutes >>timeout
latin1 >>encoding ; latin1 >>encoding ;
: ftpd ( port -- ) : ftpd ( directory port -- )
<ftp-server> start-server ; <ftp-server> start-server ;
: ftpd-main ( -- ) 2100 ftpd ; : ftpd-main ( path -- ) 2100 ftpd ;
MAIN: ftpd-main MAIN: ftpd-main

18
basis/images/images.factor
View File

@ -9,6 +9,24 @@ IN: images
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
{ RGBA [ 4 ] }
{ ABGR [ 4 ] }
{ ARGB [ 4 ] }
{ RGBX [ 4 ] }
{ XRGB [ 4 ] }
{ BGRX [ 4 ] }
{ XBGR [ 4 ] }
{ R16G16B16 [ 6 ] }
{ R32G32B32 [ 12 ] }
{ R16G16B16A16 [ 8 ] }
{ R32G32B32A32 [ 16 ] }
} case ;
TUPLE: image dim component-order bitmap ; TUPLE: image dim component-order bitmap ;
: <image> ( -- image ) image new ; inline : <image> ( -- image ) image new ; inline

14
basis/io/encodings/korean/korean-docs.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2009 Yun, Jonghyouk.
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup ;
IN: io.encodings.korean
ARTICLE: "io.encodings.korean" "Korean text encodings"
"The " { $vocab-link "io.encodings.korean" } " vocabulary implements encodings used for Korean text besides the standard UTF encodings for Unicode strings."
{ $subsection cp949 } ;
ABOUT: "io.encodings.korean"
HELP: cp949
{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR. " }
{ $see-also "encodings-introduction" } ;

2
basis/io/encodings/korean/korean.factor
View File

@ -6,6 +6,8 @@ math.order math.parser memoize multiline sequences splitting
values hashtables io.binary ; values hashtables io.binary ;
IN: io.encodings.korean IN: io.encodings.korean
! TODO: migrate to common code-table parser (by Dan).
SINGLETON: cp949 SINGLETON: cp949
cp949 "EUC-KR" register-encoding cp949 "EUC-KR" register-encoding

3
basis/io/files/info/unix/linux/linux.factor
View File

@ -72,13 +72,14 @@ M: linux file-systems
] map ; ] map ;
: (find-mount-point) ( path mtab-paths -- mtab-entry ) : (find-mount-point) ( path mtab-paths -- mtab-entry )
[ follow-links ] dip 2dup at* [ 2dup at* [
2nip 2nip
] [ ] [
drop [ parent-directory ] dip (find-mount-point) drop [ parent-directory ] dip (find-mount-point)
] if ; ] if ;
: find-mount-point ( path -- mtab-entry ) : find-mount-point ( path -- mtab-entry )
canonicalize-path
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ; ERROR: file-system-not-found ;

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

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.files.links system unix ; USING: io.backend io.files.links system unix io.pathnames kernel
io.files sequences ;
IN: io.files.links.unix IN: io.files.links.unix
M: unix make-link ( path1 path2 -- ) M: unix make-link ( path1 path2 -- )
@ -8,3 +9,7 @@ M: unix make-link ( path1 path2 -- )
M: unix read-link ( path -- path' ) M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ; normalize-path read-symbolic-link ;
M: unix canonicalize-path ( path -- path' )
path-components "/"
[ append-path dup exists? [ follow-links ] when ] reduce ;

4
basis/io/servers/connection/connection.factor
View File

@ -12,6 +12,7 @@ IN: io.servers.connection
TUPLE: threaded-server TUPLE: threaded-server
name name
log-level
secure insecure secure insecure
secure-config secure-config
sockets sockets
@ -29,6 +30,7 @@ ready ;
: new-threaded-server ( class -- threaded-server ) : new-threaded-server ( class -- threaded-server )
new new
"server" >>name "server" >>name
DEBUG >>log-level
ascii >>encoding ascii >>encoding
1 minutes >>timeout 1 minutes >>timeout
V{ } clone >>sockets V{ } clone >>sockets
@ -115,7 +117,7 @@ M: threaded-server handle-client* handler>> call ;
: (start-server) ( threaded-server -- ) : (start-server) ( threaded-server -- )
init-server init-server
dup threaded-server [ dup threaded-server [
dup name>> [ [ ] [ name>> ] bi [
[ listen-on [ start-accept-loop ] parallel-each ] [ listen-on [ start-accept-loop ] parallel-each ]
[ ready>> raise-flag ] [ ready>> raise-flag ]
bi bi

4
basis/io/servers/packet/datagram.factor → basis/io/servers/packet/packet.factor
View File

@ -1,4 +1,6 @@
IN: io.servers.datagram USING: concurrency.combinators destructors fry
io.sockets kernel logging ;
IN: io.servers.packet
<PRIVATE <PRIVATE

9
basis/logging/logging-docs.factor
View File

@ -8,6 +8,9 @@ HELP: DEBUG
HELP: NOTICE HELP: NOTICE
{ $description "Log level for ordinary messages." } ; { $description "Log level for ordinary messages." } ;
HELP: WARNING
{ $description "Log level for warnings." } ;
HELP: ERROR HELP: ERROR
{ $description "Log level for error messages." } ; { $description "Log level for error messages." } ;
@ -18,6 +21,7 @@ ARTICLE: "logging.levels" "Log levels"
"Several log levels are supported, from lowest to highest:" "Several log levels are supported, from lowest to highest:"
{ $subsection DEBUG } { $subsection DEBUG }
{ $subsection NOTICE } { $subsection NOTICE }
{ $subsection WARNING }
{ $subsection ERROR } { $subsection ERROR }
{ $subsection CRITICAL } ; { $subsection CRITICAL } ;
@ -36,7 +40,7 @@ ARTICLE: "logging.files" "Log files"
HELP: log-message HELP: log-message
{ $values { "msg" string } { "word" word } { "level" "a log level" } } { $values { "msg" string } { "word" word } { "level" "a log level" } }
{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; { $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging HELP: add-logging
{ $values { "level" "a log level" } { "word" word } } { $values { "level" "a log level" } { "word" word } }
@ -91,7 +95,7 @@ HELP: close-logs
HELP: with-logging HELP: with-logging
{ $values { "service" "a log service name" } { "quot" quotation } } { $values { "service" "a log service name" } { "quot" quotation } }
{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ; { $description "Calls the quotation a new dynamic scope where all logging calls more urgent than " { $link log-level } " are sent to the log file for " { $snippet "service" } "." } ;
ARTICLE: "logging.rotation" "Log rotation" ARTICLE: "logging.rotation" "Log rotation"
"Log files should be rotated periodically to prevent unbounded growth." "Log files should be rotated periodically to prevent unbounded growth."
@ -120,4 +124,3 @@ ARTICLE: "logging" "Logging framework"
{ $subsection "logging.server" } ; { $subsection "logging.server" } ;
ABOUT: "logging" ABOUT: "logging"

32
basis/logging/logging.factor
View File

@ -4,25 +4,47 @@ USING: logging.server sequences namespaces concurrency.messaging
words kernel arrays shuffle tools.annotations words kernel arrays shuffle tools.annotations
prettyprint.config prettyprint debugger io.streams.string prettyprint.config prettyprint debugger io.streams.string
splitting continuations effects generalizations parser strings splitting continuations effects generalizations parser strings
quotations fry accessors ; quotations fry accessors math assocs math.order ;
IN: logging IN: logging
SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ; SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; SYMBOL: log-level
log-level [ DEBUG ] initialize
: log-levels ( -- assoc )
H{
{ DEBUG 0 }
{ NOTICE 10 }
{ WARNING 20 }
{ ERROR 30 }
{ CRITICAL 40 }
} ;
ERROR: undefined-log-level ;
: log-level<=> ( log-level log-level -- ? )
[ log-levels at* [ undefined-log-level ] unless ] bi@ <=> ;
: log? ( log-level -- ? )
log-level get log-level<=> +lt+ = not ;
: send-to-log-server ( array string -- ) : send-to-log-server ( array string -- )
prefix "log-server" get send ; prefix "log-server" get send ;
SYMBOL: log-service SYMBOL: log-service
ERROR: bad-log-message-parameters msg word level ;
: check-log-message ( msg word level -- msg word level ) : check-log-message ( msg word level -- msg word level )
3dup [ string? ] [ word? ] [ word? ] tri* and and 3dup [ string? ] [ word? ] [ word? ] tri* and and
[ "Bad parameters to log-message" throw ] unless ; inline [ bad-log-message-parameters ] unless ; inline
: log-message ( msg word level -- ) : log-message ( msg word level -- )
check-log-message check-log-message
log-service get dup [ log-service get
2dup [ log? ] [ ] bi* and [
[ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip
4array "log-message" send-to-log-server 4array "log-message" send-to-log-server
] [ ] [
@ -36,7 +58,7 @@ SYMBOL: log-service
{ } "close-logs" send-to-log-server ; { } "close-logs" send-to-log-server ;
: with-logging ( service quot -- ) : with-logging ( service quot -- )
log-service swap with-variable ; inline [ log-service ] dip with-variable ; inline
! Aspect-oriented programming idioms ! Aspect-oriented programming idioms

4
basis/logging/parser/parser.factor
View File

@ -3,7 +3,7 @@
USING: accessors peg peg.parsers memoize kernel sequences USING: accessors peg peg.parsers memoize kernel sequences
logging arrays words strings vectors io io.files logging arrays words strings vectors io io.files
io.encodings.utf8 namespaces make combinators logging.server io.encodings.utf8 namespaces make combinators logging.server
calendar calendar.format ; calendar calendar.format assocs ;
IN: logging.parser IN: logging.parser
TUPLE: log-entry date level word-name message ; TUPLE: log-entry date level word-name message ;
@ -21,7 +21,7 @@ SYMBOL: multiline
"[" "]" surrounded-by ; "[" "]" surrounded-by ;
: 'log-level' ( -- parser ) : 'log-level' ( -- parser )
log-levels [ log-levels keys [
[ name>> token ] keep [ nip ] curry action [ name>> token ] keep [ nip ] curry action
] map choice ; ] map choice ;

8
basis/math/functions/functions.factor
View File

@ -252,10 +252,14 @@ M: real tanh ftanh ;
: -i* ( x -- y ) >rect swap neg rect> ; : -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y ) GENERIC: asin ( x -- y ) foldable
M: number asin
dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y ) GENERIC: acos ( x -- y ) foldable
M: number acos
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
inline inline

2
basis/stack-checker/stack-checker-docs.factor
View File

@ -56,7 +56,7 @@ ARTICLE: "inference-recursive" "Stack effects of recursive words"
"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." "When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
$nl $nl
"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" "Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if" "[ foo ] infer." } { $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." }
"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; "If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" ARTICLE: "inference-recursive-combinators" "Recursive combinator inference"

49
basis/tools/files/files.factor
View File

@ -35,9 +35,10 @@ IN: tools.files
PRIVATE> PRIVATE>
SYMBOLS: file-name file-name/type permissions file-type nlinks file-size SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+
file-date file-time file-datetime uid gid user group link-target unix-datetime +nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+
directory-or-size ; +uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+
+directory-or-size+ ;
TUPLE: listing-tool path specs sort ; TUPLE: listing-tool path specs sort ;
@ -48,10 +49,10 @@ C: <file-listing> file-listing
: <listing-tool> ( path -- listing-tool ) : <listing-tool> ( path -- listing-tool )
listing-tool new listing-tool new
swap >>path swap >>path
{ file-name } >>specs ; { +file-name+ } >>specs ;
: list-slow? ( listing-tool -- ? ) : list-slow? ( listing-tool -- ? )
specs>> { file-name } sequence= not ; specs>> { +file-name+ } sequence= not ;
ERROR: unknown-file-spec symbol ; ERROR: unknown-file-spec symbol ;
@ -59,12 +60,12 @@ HOOK: file-spec>string os ( file-listing spec -- string )
M: object file-spec>string ( file-listing spec -- string ) M: object file-spec>string ( file-listing spec -- string )
{ {
{ file-name [ directory-entry>> name>> ] } { +file-name+ [ directory-entry>> name>> ] }
{ directory-or-size [ file-info>> dir-or-size ] } { +directory-or-size+ [ file-info>> dir-or-size ] }
{ file-size [ file-info>> size>> number>string ] } { +file-size+ [ file-info>> size>> number>string ] }
{ file-date [ file-info>> modified>> listing-date ] } { +file-date+ [ file-info>> modified>> listing-date ] }
{ file-time [ file-info>> modified>> listing-time ] } { +file-time+ [ file-info>> modified>> listing-time ] }
{ file-datetime [ file-info>> modified>> timestamp>ymdhms ] } { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
[ unknown-file-spec ] [ unknown-file-spec ]
} case ; } case ;
@ -85,22 +86,22 @@ HOOK: (directory.) os ( path -- lines )
: directory. ( path -- ) (directory.) simple-table. ; : directory. ( path -- ) (directory.) simple-table. ;
SYMBOLS: device-name mount-point type SYMBOLS: +device-name+ +mount-point+ +type+
available-space free-space used-space total-space +available-space+ +free-space+ +used-space+ +total-space+
percent-used percent-free ; +percent-used+ +percent-free+ ;
: percent ( real -- integer ) 100 * >integer ; inline : percent ( real -- integer ) 100 * >integer ; inline
: file-system-spec ( file-system-info obj -- str ) : file-system-spec ( file-system-info obj -- str )
{ {
{ device-name [ device-name>> "" or ] } { +device-name+ [ device-name>> "" or ] }
{ mount-point [ mount-point>> "" or ] } { +mount-point+ [ mount-point>> "" or ] }
{ type [ type>> "" or ] } { +type+ [ type>> "" or ] }
{ available-space [ available-space>> 0 or ] } { +available-space+ [ available-space>> 0 or ] }
{ free-space [ free-space>> 0 or ] } { +free-space+ [ free-space>> 0 or ] }
{ used-space [ used-space>> 0 or ] } { +used-space+ [ used-space>> 0 or ] }
{ total-space [ total-space>> 0 or ] } { +total-space+ [ total-space>> 0 or ] }
{ percent-used [ { +percent-used+ [
[ used-space>> ] [ total-space>> ] bi [ used-space>> ] [ total-space>> ] bi
[ 0 or ] bi@ dup 0 = [ 0 or ] bi@ dup 0 =
[ 2drop 0 ] [ / percent ] if [ 2drop 0 ] [ / percent ] if
@ -116,8 +117,8 @@ percent-used percent-free ;
: file-systems. ( -- ) : file-systems. ( -- )
{ {
device-name available-space free-space used-space +device-name+ +available-space+ +free-space+ +used-space+
total-space percent-used mount-point +total-space+ +percent-used+ +mount-point+
} print-file-systems ; } print-file-systems ;
{ {

19
basis/tools/files/unix/unix.factor
View File

@ -47,21 +47,24 @@ IN: tools.files.unix
M: unix (directory.) ( path -- lines ) M: unix (directory.) ( path -- lines )
<listing-tool> <listing-tool>
{ permissions nlinks user group file-size file-date file-name } >>specs {
+permissions+ +nlinks+ +user+ +group+
+file-size+ +file-date+ +file-name+
} >>specs
{ { directory-entry>> name>> <=> } } >>sort { { directory-entry>> name>> <=> } } >>sort
[ [ list-files ] with-group-cache ] with-user-cache ; [ [ list-files ] with-group-cache ] with-user-cache ;
M: unix file-spec>string ( file-listing spec -- string ) M: unix file-spec>string ( file-listing spec -- string )
{ {
{ file-name/type [ { +file-name/type+ [
directory-entry>> [ name>> ] [ file-type>trailing ] bi append directory-entry>> [ name>> ] [ file-type>trailing ] bi append
] } ] }
{ permissions [ file-info>> permissions-string ] } { +permissions+ [ file-info>> permissions-string ] }
{ nlinks [ file-info>> nlink>> number>string ] } { +nlinks+ [ file-info>> nlink>> number>string ] }
{ user [ file-info>> uid>> user-name ] } { +user+ [ file-info>> uid>> user-name ] }
{ group [ file-info>> gid>> group-name ] } { +group+ [ file-info>> gid>> group-name ] }
{ uid [ file-info>> uid>> number>string ] } { +uid+ [ file-info>> uid>> number>string ] }
{ gid [ file-info>> gid>> number>string ] } { +gid+ [ file-info>> gid>> number>string ] }
[ call-next-method ] [ call-next-method ]
} case ; } case ;

2
basis/tools/files/windows/windows.factor
View File

@ -9,7 +9,7 @@ IN: tools.files.windows
M: windows (directory.) ( entries -- lines ) M: windows (directory.) ( entries -- lines )
<listing-tool> <listing-tool>
{ file-datetime directory-or-size file-name } >>specs { +file-datetime+ +directory-or-size+ +file-name+ } >>specs
{ { directory-entry>> name>> <=> } } >>sort { { directory-entry>> name>> <=> } } >>sort
list-files ; list-files ;

14
core/io/pathnames/pathnames-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax io.backend io.files strings ; USING: help.markup help.syntax io.backend io.files strings
sequences ;
IN: io.pathnames IN: io.pathnames
HELP: path-separator? HELP: path-separator?
@ -22,6 +23,10 @@ HELP: file-name
{ $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" }
} ; } ;
HELP: path-components
{ $values { "path" "a pathnames string" } { "seq" sequence } }
{ $description "Splits a pathname on the " { $link path-separator } " into its its component strings." } ;
HELP: append-path HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; { $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ;
@ -57,6 +62,10 @@ HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ; { $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
HELP: canonicalize-path
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Returns an canonical name for a path. The canonical name is an absolute path containing no symlinks." } ;
HELP: <pathname> HELP: <pathname>
{ $values { "string" "a pathname string" } { "pathname" pathname } } { $values { "string" "a pathname string" } { "pathname" pathname } }
{ $description "Creates a new " { $link pathname } "." } ; { $description "Creates a new " { $link pathname } "." } ;
@ -74,9 +83,12 @@ ARTICLE: "io.pathnames" "Pathname manipulation"
{ $subsection POSTPONE: P" } { $subsection POSTPONE: P" }
"Pathname manipulation:" "Pathname manipulation:"
{ $subsection normalize-path } { $subsection normalize-path }
{ $subsection canonicalize-path }
{ $subsection parent-directory } { $subsection parent-directory }
{ $subsection file-name } { $subsection file-name }
{ $subsection last-path-separator } { $subsection last-path-separator }
{ $subsection path-components }
{ $subsection prepend-path }
{ $subsection append-path } { $subsection append-path }
"Pathname presentations:" "Pathname presentations:"
{ $subsection pathname } { $subsection pathname }

4
core/io/pathnames/pathnames-tests.factor
View File

@ -66,3 +66,7 @@ IN: io.pathnames.tests
] with-scope ] with-scope
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
! Regression test for bug in file-extension
[ f ] [ "/funny.directory/file-with-no-extension" file-extension ] unit-test
[ "" ] [ "/funny.directory/file-with-no-extension." file-extension ] unit-test

9
core/io/pathnames/pathnames.factor
View File

@ -119,7 +119,14 @@ PRIVATE>
] unless ; ] unless ;
: file-extension ( filename -- extension ) : file-extension ( filename -- extension )
"." split1-last nip ; file-name "." split1-last nip ;
: path-components ( path -- seq )
normalize-path path-separator split harvest ;
HOOK: canonicalize-path os ( path -- path' )
M: object canonicalize-path normalize-path ;
: resource-path ( path -- newpath ) : resource-path ( path -- newpath )
"resource-path" get prepend-path ; "resource-path" get prepend-path ;

30
extra/annotations/annotations-docs.factor
View File

@ -9,6 +9,22 @@ IN: annotations
: comment-usage.-word ( base -- word ) "s." append "annotations" lookup ; : comment-usage.-word ( base -- word ) "s." append "annotations" lookup ;
PRIVATE> PRIVATE>
: $annotation ( element -- )
first
[ "!" " your comment here" surround 1array $syntax ]
[ [ "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 3array $description ]
[ ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 1array $unchecked-example ]
tri ;
: $annotation-usage. ( element -- )
first
[ "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 3array $description ;
: $annotation-usage ( element -- )
first
{ "usages" sequence } $values
[ "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray ] bi 1array $description ;
"Code annotations" "Code annotations"
{ {
"The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism." "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism."
@ -26,17 +42,9 @@ annotation-tags natural-sort
annotation-tags [ annotation-tags [
{ {
[ [ \ $syntax ] dip "!" " your comment here" surround 2array ] [ [ \ $annotation swap 2array 1array ] [ comment-word set-word-help ] bi ]
[ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ] [ [ \ $annotation-usage swap 2array 1array ] [ comment-usage-word set-word-help ] bi ]
[ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ] [ [ \ $annotation-usage. swap 2array 1array ] [ comment-usage.-word set-word-help ] bi ]
[ comment-word set-word-help ]
[ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ]
[ comment-usage.-word set-word-help ]
[ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ]
[ comment-usage-word set-word-help ]
[ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ] [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ]
} cleave } cleave
] each ] each

2
extra/fuel/fuel.factor
View File

@ -99,6 +99,8 @@ PRIVATE>
: fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ; : fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
: fuel-word-synopsis ( word usings -- ) (fuel-word-synopsis) fuel-eval-set-result ;
: fuel-vocab-summary ( name -- ) : fuel-vocab-summary ( name -- )
(fuel-vocab-summary) fuel-eval-set-result ; (fuel-vocab-summary) fuel-eval-set-result ;

6
extra/fuel/help/help.factor
View File

@ -90,6 +90,12 @@ PRIVATE>
: (fuel-word-help) ( name -- elem ) : (fuel-word-help) ( name -- elem )
fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ; fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
: (fuel-word-synopsis) ( word usings -- str/f )
[
[ vocab ] filter interactive-vocabs get append interactive-vocabs set
fuel-find-word [ synopsis ] when*
] with-scope ;
: (fuel-word-see) ( word -- elem ) : (fuel-word-see) ( word -- elem )
[ name>> \ article swap ] [ name>> \ article swap ]
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline [ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline

10
extra/id3/id3-docs.factor
View File

@ -1,13 +1,19 @@
! Copyright (C) 2008 Tim Wawrzynczak ! Copyright (C) 2008 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax sequences kernel ; USING: help.markup help.syntax sequences kernel accessors ;
IN: id3 IN: id3
HELP: file-id3-tags HELP: file-id3-tags
{ $values { $values
{ "path" "a path string" } { "path" "a path string" }
{ "object/f" "a tuple storing ID3 metadata or f" } } { "object/f" "a tuple storing ID3 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ; { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
$nl { $link title>> }
$nl { $link artist>> }
$nl { $link album>> }
$nl { $link year>> }
$nl { $link genre>> }
$nl { $link comment>> } } ;
ARTICLE: "id3" "ID3 tags" ARTICLE: "id3" "ID3 tags"
"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl "The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl

195
extra/id3/id3-tests.factor
View File

@ -1,182 +1,35 @@
! Copyright (C) 2009 Tim Wawrzynczak ! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test id3 ; USING: tools.test id3 id3.private ;
IN: id3.tests IN: id3.tests
[ T{ mp3v2-file [
{ header T{ header f t 0 502 } } T{ id3-info
{ frames { title "BLAH" }
{ { artist "ARTIST" }
T{ frame { album "ALBUM" }
{ frame-id "COMM" } { year "2009" }
{ flags B{ 0 0 } } { comment "COMMENT" }
{ size 19 } { genre "Bluegrass" }
{ data "eng, AG# 08E1C12E" } }
} ] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
T{ frame
{ frame-id "TIT2" }
{ flags B{ 0 0 } }
{ size 15 }
{ data "Stormy Weather" }
}
T{ frame
{ frame-id "TRCK" }
{ flags B{ 0 0 } }
{ size 3 }
{ data "32" }
}
T{ frame
{ frame-id "TCON" }
{ flags B{ 0 0 } }
{ size 5 }
{ data "(96)" }
}
T{ frame
{ frame-id "TALB" }
{ flags B{ 0 0 } }
{ size 28 }
{ data "Night and Day Frank Sinatra" }
}
T{ frame
{ frame-id "PRIV" }
{ flags B{ 0 0 } }
{ size 39 }
{ data "WM/MediaClassPrimaryID<49>}`<60>#<23><>K<EFBFBD>H<EFBFBD>*(D" }
}
T{ frame
{ frame-id "PRIV" }
{ flags B{ 0 0 } }
{ size 41 }
{ data "WM/MediaClassSecondaryID" }
}
T{ frame
{ frame-id "TPE1" }
{ flags B{ 0 0 } }
{ size 14 }
{ data "Frank Sinatra" }
}
}
}
}
] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
[ [
T{ mp3v2-file T{ id3-info
{ header { title "Anthem of the Trinity" }
T{ header { version t } { flags 0 } { size 1405 } } { artist "Terry Riley" }
{ album "Shri Camel" }
{ genre "Classical" }
} }
{ frames
{
T{ frame
{ frame-id "TIT2" }
{ flags B{ 0 0 } }
{ size 22 }
{ data "Anthem of the Trinity" }
}
T{ frame
{ frame-id "TPE1" }
{ flags B{ 0 0 } }
{ size 12 }
{ data "Terry Riley" }
}
T{ frame
{ frame-id "TALB" }
{ flags B{ 0 0 } }
{ size 11 }
{ data "Shri Camel" }
}
T{ frame
{ frame-id "TCON" }
{ flags B{ 0 0 } }
{ size 10 }
{ data "Classical" }
}
T{ frame
{ frame-id "UFID" }
{ flags B{ 0 0 } }
{ size 23 }
{ data "http://musicbrainz.org" }
}
T{ frame
{ frame-id "TXXX" }
{ flags B{ 0 0 } }
{ size 23 }
{ data "MusicBrainz Artist Id" }
}
T{ frame
{ frame-id "TXXX" }
{ flags B{ 0 0 } }
{ size 22 }
{ data "musicbrainz_artistid" }
}
T{ frame
{ frame-id "TRCK" }
{ flags B{ 0 0 } }
{ size 2 }
{ data "1" }
}
T{ frame
{ frame-id "TXXX" }
{ flags B{ 0 0 } }
{ size 22 }
{ data "MusicBrainz Album Id" }
}
T{ frame
{ frame-id "TXXX" }
{ flags B{ 0 0 } }
{ size 21 }
{ data "musicbrainz_albumid" }
}
T{ frame
{ frame-id "TXXX" }
{ flags B{ 0 0 } }
{ size 29 }
{ data "MusicBrainz Album Artist Id" }
}
T{ frame
{ frame-id "TXXX" }
{ flags B{ 0 0 } }
{ size 27 }
{ data "musicbrainz_albumartistid" }
}
T{ frame
{ frame-id "TPOS" }
{ flags B{ 0 0 } }
{ size 2 }
{ data "1" }
}
T{ frame
{ frame-id "TSOP" }
{ flags B{ 0 0 } }
{ size 1 }
}
T{ frame
{ frame-id "TMED" }
{ flags B{ 0 0 } }
{ size 4 }
{ data "DIG" }
}
}
}
}
] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test ] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test
[ [
T{ mp3v1-file T{ id3-info
{ title { title "Stormy Weather" }
"BLAH" { artist "Frank Sinatra" }
} { album "Night and Day Frank Sinatra" }
{ artist { comment "eng, AG# 08E1C12E" }
"ARTIST" { genre "Big Band" }
} }
{ album ] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
"ALBUM"
}
{ year "2009" }
{ comment
"COMMENT"
}
{ genre 89 }
}
] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test

185
extra/id3/id3.factor
View File

@ -1,28 +1,159 @@
! Copyright (C) 2009 Tim Wawrzynczak ! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ;
IN: id3 IN: id3
<PRIVATE
! genres
CONSTANT: genres
H{
{ 0 "Blues" }
{ 1 "Classic Rock" }
{ 2 "Country" }
{ 3 "Dance" }
{ 4 "Disco" }
{ 5 "Funk" }
{ 6 "Grunge" }
{ 7 "Hip-Hop" }
{ 8 "Jazz" }
{ 9 "Metal" }
{ 10 "New Age" }
{ 11 "Oldies" }
{ 12 "Other" }
{ 13 "Pop" }
{ 14 "R&B" }
{ 15 "Rap" }
{ 16 "Reggae" }
{ 17 "Rock" }
{ 18 "Techno" }
{ 19 "Industrial" }
{ 20 "Alternative" }
{ 21 "Ska" }
{ 22 "Death Metal" }
{ 23 "Pranks" }
{ 24 "Soundtrack" }
{ 25 "Euro-Techno" }
{ 26 "Ambient" }
{ 27 "Trip-Hop" }
{ 28 "Vocal" }
{ 29 "Jazz+Funk" }
{ 30 "Fusion" }
{ 31 "Trance" }
{ 32 "Classical" }
{ 33 "Instrumental" }
{ 34 "Acid" }
{ 35 "House" }
{ 36 "Game" }
{ 37 "Sound Clip" }
{ 38 "Gospel" }
{ 39 "Noise" }
{ 40 "AlternRock" }
{ 41 "Bass" }
{ 42 "Soul" }
{ 43 "Punk" }
{ 44 "Space" }
{ 45 "Meditative" }
{ 46 "Instrumental Pop" }
{ 47 "Instrumental Rock" }
{ 48 "Ethnic" }
{ 49 "Gothic" }
{ 50 "Darkwave" }
{ 51 "Techno-Industrial" }
{ 52 "Electronic" }
{ 53 "Pop-Folk" }
{ 54 "Eurodance" }
{ 55 "Dream" }
{ 56 "Southern Rock" }
{ 57 "Comedy" }
{ 58 "Cult" }
{ 59 "Gangsta" }
{ 60 "Top 40" }
{ 61 "Christian Rap" }
{ 62 "Pop/Funk" }
{ 63 "Jungle" }
{ 64 "Native American" }
{ 65 "Cabaret" }
{ 66 "New Wave" }
{ 67 "Psychedelic" }
{ 68 "Rave" }
{ 69 "Showtunes" }
{ 70 "Trailer" }
{ 71 "Lo-Fi" }
{ 72 "Tribal" }
{ 73 "Acid Punk" }
{ 74 "Acid Jazz" }
{ 75 "Polka" }
{ 76 "Retro" }
{ 77 "Musical" }
{ 78 "Rock & Roll" }
{ 79 "Hard Rock" }
{ 80 "Folk" }
{ 81 "Folk-Rock" }
{ 82 "National Folk" }
{ 83 "Swing" }
{ 84 "Fast Fusion" }
{ 85 "Bebop" }
{ 86 "Latin" }
{ 87 "Revival" }
{ 88 "Celtic" }
{ 89 "Bluegrass" }
{ 90 "Avantgarde" }
{ 91 "Gothic Rock" }
{ 92 "Progressive Rock" }
{ 93 "Psychedelic Rock" }
{ 94 "Symphonic Rock" }
{ 95 "Slow Rock" }
{ 96 "Big Band" }
{ 97 "Chorus" }
{ 98 "Easy Listening" }
{ 99 "Acoustic" }
{ 100 "Humour" }
{ 101 "Speech" }
{ 102 "Chanson" }
{ 103 "Opera" }
{ 104 "Chamber Music" }
{ 105 "Sonata" }
{ 106 "Symphony" }
{ 107 "Booty Bass" }
{ 108 "Primus" }
{ 109 "Porn Groove" }
{ 110 "Satire" }
{ 111 "Slow Jam" }
{ 112 "Club" }
{ 113 "Tango" }
{ 114 "Samba" }
{ 115 "Folklore" }
{ 116 "Ballad" }
{ 117 "Power Ballad" }
{ 118 "Rhythmic Soul" }
{ 119 "Freestyle" }
{ 120 "Duet" }
{ 121 "Punk Rock" }
{ 122 "Drum Solo" }
{ 123 "A capella" }
{ 124 "Euro-House" }
{ 125 "Dance Hall" }
} ! end genre hashtable
! tuples ! tuples
TUPLE: header version flags size ; TUPLE: header version flags size ;
TUPLE: frame frame-id flags size data ; TUPLE: frame frame-id flags size data ;
TUPLE: mp3v2-file header frames ; TUPLE: id3v2-info header frames ;
TUPLE: mp3v1-file title artist album year comment genre ; TUPLE: id3-info title artist album year comment genre ;
: <mp3v1-file> ( -- object ) mp3v1-file new ; : <id3-info> ( -- object ) id3-info new ;
: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ; : <id3v2-info> ( header frames -- object ) id3v2-info boa ;
: <header> ( -- object ) header new ; : <header> ( -- object ) header new ;
: <frame> ( -- object ) frame new ; : <frame> ( -- object ) frame new ;
<PRIVATE
! utility words ! utility words
: id3v2? ( mmap -- ? ) : id3v2? ( mmap -- ? )
@ -59,10 +190,10 @@ TUPLE: mp3v1-file title artist album year comment genre ;
: (read-frame) ( mmap -- frame ) : (read-frame) ( mmap -- frame )
[ <frame> ] dip [ <frame> ] dip
{ {
[ read-frame-id ascii decode >>frame-id ] [ read-frame-id utf8 decode >>frame-id ]
[ read-frame-flags >byte-array >>flags ] [ read-frame-flags >byte-array >>flags ]
[ read-frame-size >28bitword >>size ] [ read-frame-size >28bitword >>size ]
[ read-frame-data ascii decode >>data ] [ read-frame-data utf8 decode >>data ]
} cleave ; } cleave ;
: read-frame ( mmap -- frame/f ) : read-frame ( mmap -- frame/f )
@ -98,8 +229,20 @@ TUPLE: mp3v1-file title artist album year comment genre ;
: drop-header ( mmap -- seq1 seq2 ) : drop-header ( mmap -- seq1 seq2 )
dup 10 tail-slice swap ; dup 10 tail-slice swap ;
: read-v2-tag-data ( seq -- mp3v2-file ) : parse-frames ( id3v2-info -- id3-info )
drop-header read-v2-header swap read-frames <mp3v2-file> ; [ <id3-info> ] dip frames>>
{
[ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ]
[ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ]
[ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ]
[ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when*
>>genre ] when* ]
[ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ]
[ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ]
} cleave ;
: read-v2-tag-data ( seq -- id3-info )
drop-header read-v2-header swap read-frames <id3v2-info> parse-frames ;
! v1 information ! v1 information
@ -125,14 +268,14 @@ TUPLE: mp3v1-file title artist album year comment genre ;
[ 124 ] dip nth ; [ 124 ] dip nth ;
: (read-v1-tag-data) ( seq -- mp3-file ) : (read-v1-tag-data) ( seq -- mp3-file )
[ <mp3v1-file> ] dip [ <id3-info> ] dip
{ {
[ read-title ascii decode filter-text-data >>title ] [ read-title utf8 decode filter-text-data >>title ]
[ read-artist ascii decode filter-text-data >>artist ] [ read-artist utf8 decode filter-text-data >>artist ]
[ read-album ascii decode filter-text-data >>album ] [ read-album utf8 decode filter-text-data >>album ]
[ read-year ascii decode filter-text-data >>year ] [ read-year utf8 decode filter-text-data >>year ]
[ read-comment ascii decode filter-text-data >>comment ] [ read-comment utf8 decode filter-text-data >>comment ]
[ read-genre >fixnum >>genre ] [ read-genre >fixnum genres at >>genre ]
} cleave ; } cleave ;
: read-v1-tag-data ( seq -- mp3-file ) : read-v1-tag-data ( seq -- mp3-file )
@ -140,13 +283,13 @@ TUPLE: mp3v1-file title artist album year comment genre ;
PRIVATE> PRIVATE>
! main stuff ! public interface
: file-id3-tags ( path -- object/f ) : file-id3-tags ( path -- object/f )
[ [
{ {
{ [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 )
{ [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info )
[ drop f ] ! ( mmap -- f ) [ drop f ] ! ( mmap -- f )
} cond } cond
] with-mapped-uchar-file ; ] with-mapped-uchar-file ;

8
extra/literals/literals-docs.factor
View File

@ -1,19 +1,19 @@
! Copyright (C) 2008 Joe Groff. ! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax multiline ; USING: help.markup help.syntax kernel multiline ;
IN: literals IN: literals
HELP: $ HELP: $
{ $syntax "$ word" } { $syntax "$ word" }
{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." } { $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
{ $notes "Since " { $snippet "word" } " is executed at parse time, " { $snippet "$" } " cannot be used with words defined in the same compilation unit." } { $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
{ $examples { $examples
{ $example <" { $example <"
USING: kernel literals prettyprint ; USING: kernel literals prettyprint ;
IN: scratchpad IN: scratchpad
<< : five 5 ; >> CONSTANT: five 5
{ $ five } . { $ five } .
"> "{ 5 }" } "> "{ 5 }" }
@ -30,7 +30,7 @@ IN: scratchpad
HELP: $[ HELP: $[
{ $syntax "$[ code ]" } { $syntax "$[ code ]" }
{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." } { $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
{ $notes "Since " { $snippet "code" } " is executed at parse time, it cannot reference any words defined in the same compilation unit." } { $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
{ $examples { $examples
{ $example <" { $example <"

5
extra/literals/literals-tests.factor
View File

@ -2,11 +2,12 @@ USING: kernel literals math tools.test ;
IN: literals.tests IN: literals.tests
<< <<
: five 5 ;
: seven-eleven 7 11 ;
: six-six-six 6 6 6 ; : six-six-six 6 6 6 ;
>> >>
: five 5 ;
: seven-eleven 7 11 ;
[ { 5 } ] [ { $ five } ] unit-test [ { 5 } ] [ { $ five } ] unit-test
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test [ { 7 11 } ] [ { $ seven-eleven } ] unit-test
[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test [ { 6 6 6 } ] [ { $ six-six-six } ] unit-test

4
extra/literals/literals.factor
View File

@ -1,6 +1,6 @@
! (c) Joe Groff, see license for details ! (c) Joe Groff, see license for details
USING: continuations kernel parser words quotations vectors ; USING: accessors continuations kernel parser words quotations vectors ;
IN: literals IN: literals
: $ scan-word [ execute ] curry with-datastack >vector ; parsing : $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
: $[ \ ] parse-until >quotation with-datastack >vector ; parsing : $[ \ ] parse-until >quotation with-datastack >vector ; parsing

1
extra/math/derivatives/authors.txt Normal file
View File

@ -0,0 +1 @@
Jason W. Merrill

11
extra/math/derivatives/derivatives-docs.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: math.derivatives
ARTICLE: "math.derivatives" "Derivatives"
"The " { $vocab-link "math.derivatives" } " vocabulary defines the derivative of many of the words in the " { $vocab-link "math" } " and " { $vocab-link "math.functions" } " vocabularies. The derivative for a word is given by a sequence of quotations stored in its " { $snippet "derivative" } " word property that give the partial derivative of the word with respect to each of its inputs."
{ $see-also "math.derivatives.syntax" }
;
ABOUT: "math.derivatives"

4
extra/math/derivatives/derivatives-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test automatic-differentiation.derivatives ;
IN: automatic-differentiation.derivatives.tests

53
extra/math/derivatives/derivatives.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.derivatives.syntax
math.order math.parser summary accessors make combinators ;
IN: math.derivatives
ERROR: undefined-derivative point word ;
M: undefined-derivative summary
[ dup "Derivative of " % word>> name>> %
" is undefined at " % point>> # "." % ]
"" make ;
DERIVATIVE: + [ 2drop ] [ 2drop ]
DERIVATIVE: - [ 2drop ] [ 2drop neg ]
DERIVATIVE: * [ nip * ] [ drop * ]
DERIVATIVE: / [ nip / ] [ sq / neg * ]
! Conditional checks if the epsilon-part of the exponent is
! 0 to avoid getting float answers for integer powers.
DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ]
[ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ]
DERIVATIVE: abs
[ 0 <=>
{
{ +lt+ [ neg ] }
{ +eq+ [ 0 \ abs undefined-derivative ] }
{ +gt+ [ ] }
} case
]
DERIVATIVE: sqrt [ sqrt 2 * / ]
DERIVATIVE: exp [ exp * ]
DERIVATIVE: log [ / ]
DERIVATIVE: sin [ cos * ]
DERIVATIVE: cos [ sin neg * ]
DERIVATIVE: tan [ sec sq * ]
DERIVATIVE: sinh [ cosh * ]
DERIVATIVE: cosh [ sinh * ]
DERIVATIVE: tanh [ sech sq * ]
DERIVATIVE: asin [ sq neg 1 + sqrt / ]
DERIVATIVE: acos [ sq neg 1 + sqrt neg / ]
DERIVATIVE: atan [ sq 1 + / ]
DERIVATIVE: asinh [ sq 1 + sqrt / ]
DERIVATIVE: acosh [ [ 1 + sqrt ] [ 1 - sqrt ] bi * / ]
DERIVATIVE: atanh [ sq neg 1 + / ]
DERIVATIVE: neg [ drop neg ]
DERIVATIVE: recip [ sq recip neg * ]

1
extra/math/derivatives/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Jason W. Merrill

18
extra/math/derivatives/syntax/syntax-docs.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
IN: math.derivatives.syntax
HELP: DERIVATIVE:
{ $description "Defines the derivative of a word by setting its " { $snippet "derivative" } " word property. Reads a word followed by " { $snippet "n" } " quotations, giving the " { $snippet "n" } " partial derivatives of the word with respect to each of its arguments successively. Each quotation should take " { $snippet "n + 1" } " inputs, where the first input is an increment and the last " { $snippet "n" } " inputs are the point at which to evaluate the derivative. The derivative should be a linear function of the increment, and should have the same number of outputs as the original word." }
{ $examples
{ $unchecked-example "USING: math math.functions math.derivatives.syntax ;"
"DERIVATIVE: sin [ cos * ]"
"DERIVATIVE: * [ nip * ] [ drop * ]" "" }
} ;
ARTICLE: "math.derivatives.syntax" "Derivative Syntax"
"The " { $vocab-link "math.derivatives.syntax" } " vocabulary provides the " { $link POSTPONE: DERIVATIVE: } " syntax for specifying the derivative of a word."
;
ABOUT: "math.derivatives.syntax"

10
extra/math/derivatives/syntax/syntax.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words effects accessors sequences
math.ranges ;
IN: math.derivatives.syntax
: DERIVATIVE: scan-object dup stack-effect in>> length [1,b]
[ drop scan-object ] map
"derivative" set-word-prop ; parsing

1
extra/math/dual/authors.txt Normal file
View File

@ -0,0 +1 @@
Jason W. Merrill

132
extra/math/dual/dual-docs.factor Normal file
View File

@ -0,0 +1,132 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel words math math.functions math.derivatives.syntax ;
IN: math.dual
HELP: <dual>
{ $values
{ "ordinary-part" real } { "epsilon-part" real }
{ "dual" dual number }
}
{ $description "Creates a dual number from its ordinary and epsilon parts." } ;
HELP: d*
{ $values
{ "x" dual } { "y" dual }
{ "x*y" dual }
}
{ $description "Multiply dual numbers." } ;
HELP: d+
{ $values
{ "x" dual } { "y" dual }
{ "x+y" dual }
}
{ $description "Add dual numbers." } ;
HELP: d-
{ $values
{ "x" dual } { "y" dual }
{ "x-y" dual }
}
{ $description "Subtract dual numbers." } ;
HELP: d/
{ $values
{ "x" dual } { "y" dual }
{ "x/y" dual }
}
{ $description "Divide dual numbers." }
{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ;
HELP: d^
{ $values
{ "x" dual } { "y" dual }
{ "x^y" dual }
}
{ $description "Raise a dual number to a (possibly dual) power" } ;
HELP: dabs
{ $values
{ "x" dual }
{ "|x|" dual }
}
{ $description "Absolute value of a dual number." } ;
HELP: dacosh
{ $values
{ "x" dual }
{ "y" dual }
}
{ $description "Inverse hyberbolic cosine of a dual number." } ;
HELP: dasinh
{ $values
{ "x" dual }
{ "y" dual }
}
{ $description "Inverse hyberbolic sine of a dual number." } ;
HELP: datanh
{ $values
{ "x" dual }
{ "y" dual }
}
{ $description "Inverse hyberbolic tangent of a dual number." } ;
HELP: dneg
{ $values
{ "x" dual }
{ "-x" dual }
}
{ $description "Negative of a dual number." } ;
HELP: drecip
{ $values
{ "x" dual }
{ "1/x" dual }
}
{ $description "Reciprocal of a dual number." } ;
HELP: define-dual-method
{ $values
{ "word" word }
}
{ $description "Defines a method on the dual numbers for generic word." }
{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ;
{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words
HELP: dual
{ $class-description "The class of dual numbers with non-zero epsilon part." } ;
HELP: dual-op
{ $values
{ "word" word }
}
{ $description "Similar to " { $link execute } ", but promotes word to operate on duals." }
{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } ". Once a derivative has been defined for a word, dual-op makes it easy to extend the definition to dual numbers." }
{ $examples
{ $unchecked-example "USING: math math.dual math.derivatives.syntax math.functions ;"
"DERIVATIVE: sin [ cos * ]"
"M: dual sin \\sin dual-op ;" "" }
{ $unchecked-example "USING: math math.dual math.derivatives.syntax ;"
"DERIVATIVE: * [ drop ] [ nip ]"
": d* ( x y -- x*y ) \ * dual-op ;" "" }
} ;
HELP: unpack-dual
{ $values
{ "dual" dual }
{ "ordinary-part" number } { "epsilon-part" number }
}
{ $description "Extracts the ordinary and epsilon part of a dual number." } ;
ARTICLE: "math.dual" "Dual Numbers"
"The " { $vocab-link "math.dual" } " vocabulary implements dual numbers, along with arithmetic methods for working with them. Many of the functions in " { $vocab-link "math.functions" } " are extended to work with dual numbers."
$nl
"Dual numbers are ordered pairs " { $snippet "<o,e>"} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "<o1,e1>*<o2,e2> = <o1*o2,e1*o2 + e2*o1>" } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f(<o1,e1>) = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "."
;
ABOUT: "math.dual"

16
extra/math/dual/dual-tests.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test math.dual kernel accessors math math.functions
math.constants ;
IN: math.dual.tests
[ 0.0 1.0 ] [ 0 1 <dual> sin unpack-dual ] unit-test
[ 1.0 0.0 ] [ 0 1 <dual> cos unpack-dual ] unit-test
[ 3 5 ] [ 1 5 <dual> 2 d+ unpack-dual ] unit-test
[ 0 -1 ] [ 1 5 <dual> 1 6 <dual> d- unpack-dual ] unit-test
[ 2 1 ] [ 2 3 <dual> 1 -1 <dual> d* unpack-dual ] unit-test
[ 1/2 -1/4 ] [ 2 1 <dual> 1 swap d/ unpack-dual ] unit-test
[ 2 ] [ 1 1 <dual> 2 d^ epsilon-part>> ] unit-test
[ 2.0 .25 ] [ 4 1 <dual> sqrt unpack-dual ] unit-test
[ 2 -1 ] [ -2 1 <dual> dabs unpack-dual ] unit-test
[ -2 -1 ] [ 2 1 <dual> dneg unpack-dual ] unit-test

92
extra/math/dual/dual.factor Normal file
View File

@ -0,0 +1,92 @@
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.derivatives accessors
macros words effects sequences generalizations fry
combinators.smart generic compiler.units ;
IN: math.dual
TUPLE: dual ordinary-part epsilon-part ;
C: <dual> dual
! Ordinary numbers implement the dual protocol by returning
! themselves as the ordinary part, and 0 as the epsilon part.
M: number ordinary-part>> ;
M: number epsilon-part>> drop 0 ;
: unpack-dual ( dual -- ordinary-part epsilon-part )
[ ordinary-part>> ] [ epsilon-part>> ] bi ;
<PRIVATE
: input-length ( word -- n ) stack-effect in>> length ;
MACRO: ordinary-op ( word -- o )
[ input-length ] keep
'[ [ ordinary-part>> ] _ napply _ execute ] ;
! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves
! their ordinary and epsilon parts to produce
! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN
! This allows a set of partial derivatives each to be evaluated
! at the same point.
MACRO: duals>nweave ( n -- )
dup dup dup
'[
[ [ epsilon-part>> ] _ napply ]
_ nkeep
[ ordinary-part>> ] _ napply
_ nweave
] ;
MACRO: chain-rule ( word -- e )
[ input-length '[ _ duals>nweave ] ]
[ "derivative" word-prop ]
[ input-length 1+ '[ _ nspread ] ]
tri
'[ [ @ _ @ ] sum-outputs ] ;
PRIVATE>
MACRO: dual-op ( word -- )
[ '[ _ ordinary-op ] ]
[ input-length '[ _ nkeep ] ]
[ '[ _ chain-rule ] ]
tri
'[ _ @ @ <dual> ] ;
: define-dual-method ( word -- )
[ \ dual swap create-method ] keep '[ _ dual-op ] define ;
! Specialize math functions to operate on dual numbers.
[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan }
[ define-dual-method ] each ] with-compilation-unit
! Inverse methods { asinh, acosh, atanh } are not generic, so
! there is no way to specialize them for dual numbers. However,
! they are defined in terms of functions that can operate on
! dual numbers and arithmetic methods, so if it becomes
! possible to make arithmetic operators work directly on dual
! numbers, we will get these for free.
! Arithmetic words are not generic (yet?), so we have to
! define special versions of them to operate on dual numbers.
: d+ ( x y -- x+y ) \ + dual-op ;
: d- ( x y -- x-y ) \ - dual-op ;
: d* ( x y -- x*y ) \ * dual-op ;
: d/ ( x y -- x/y ) \ / dual-op ;
: d^ ( x y -- x^y ) \ ^ dual-op ;
: dabs ( x -- |x| ) \ abs dual-op ;
! The following words are also not generic, but are defined in
! terms of words that can operate on dual numbers and
! arithmetic. If it becomes possible to implement arithmetic on
! dual numbers directly, these functions can be deleted.
: dneg ( x -- -x ) \ neg dual-op ;
: drecip ( x -- 1/x ) \ recip dual-op ;
: dasinh ( x -- y ) \ asinh dual-op ;
: dacosh ( x -- y ) \ acosh dual-op ;
: datanh ( x -- y ) \ atanh dual-op ;

1
misc/fuel/README
View File

@ -111,6 +111,7 @@ beast.
| C-cC-ev | edit vocabulary (fuel-edit-vocabulary) | | C-cC-ev | edit vocabulary (fuel-edit-vocabulary) |
| C-cC-ew | edit word (fuel-edit-word-at-point) | | C-cC-ew | edit word (fuel-edit-word-at-point) |
| C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) | | C-cC-ed | edit word's doc (C-u M-x fuel-edit-word-doc-at-point) |
| C-cC-el | load vocabs in USING: form |
|-----------------+------------------------------------------------------------| |-----------------+------------------------------------------------------------|
| C-cC-er | eval region | | C-cC-er | eval region |
| C-M-r, C-cC-ee | eval region, extending it to definition boundaries | | C-M-r, C-cC-ee | eval region, extending it to definition boundaries |

21
misc/fuel/fuel-autodoc.el
View File

@ -32,6 +32,22 @@
:type 'boolean) :type 'boolean)
(defcustom fuel-autodoc-eval-using-form-p nil
"When enabled, automatically load vocabularies in USING: form
to display autodoc messages.
In order to show autodoc messages for words in a Factor buffer,
the used vocabularies must be loaded in the Factor image. Setting
this variable to `t' will do that automatically for you,
asynchronously. That means that you'll be able to move around
while the vocabs are being loaded, but no other FUEL
functionality will be available until loading finishes (and it
may take a while). Thus, this functionality is disabled by
default. You can force loading the vocabs in a Factor buffer
USING: form with \\[fuel-load-usings]."
:group 'fuel-autodoc
:type 'boolean)
;;; Eldoc function: ;;; Eldoc function:
@ -41,9 +57,10 @@
(let ((word (or word (fuel-syntax-symbol-at-point))) (let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-log--inhibit-p t)) (fuel-log--inhibit-p t))
(when word (when word
(let* ((cmd (if (fuel-syntax--in-using) (let* ((usings (if fuel-autodoc-eval-using-form-p :usings t))
(cmd (if (fuel-syntax--in-using)
`(:fuel* (,word fuel-vocab-summary) :in t) `(:fuel* (,word fuel-vocab-summary) :in t)
`(:fuel* (((:quote ,word) synopsis :get)) :in))) `(:fuel* ((,word :usings fuel-word-synopsis)) t ,usings)))
(ret (fuel-eval--send/wait cmd fuel-autodoc--timeout)) (ret (fuel-eval--send/wait cmd fuel-autodoc--timeout))
(res (fuel-eval--retort-result ret))) (res (fuel-eval--retort-result ret)))
(when (and ret (not (fuel-eval--retort-error ret)) (stringp res)) (when (and ret (not (fuel-eval--retort-error ret)) (stringp res))

2
misc/fuel/fuel-eval.el
View File

@ -77,7 +77,7 @@
(t (error "Invalid 'in' (%s)" in)))) (t (error "Invalid 'in' (%s)" in))))
(defsubst factor--fuel-usings (usings) (defsubst factor--fuel-usings (usings)
(cond ((null usings) :usings) (cond ((or (null usings) (eq usings :usings)) :usings)
((eq usings t) nil) ((eq usings t) nil)
((listp usings) `(:array ,@usings)) ((listp usings) `(:array ,@usings))
(t (error "Invalid 'usings' (%s)" usings)))) (t (error "Invalid 'usings' (%s)" usings))))

15
misc/fuel/fuel-mode.el
View File

@ -132,6 +132,18 @@ With prefix argument, ask for the file name."
(let ((file (car (fuel-mode--read-file arg)))) (let ((file (car (fuel-mode--read-file arg))))
(when file (fuel-debug--uses-for-file file)))) (when file (fuel-debug--uses-for-file file))))
(defun fuel-load-usings ()
"Loads all vocabularies in the current buffer's USING: from.
Useful to activate autodoc help messages in a vocabulary not yet
loaded. See documentation for `fuel-autodoc-eval-using-form-p'
for details."
(interactive)
(message "Loading all vocabularies in USING: form ...")
(let ((err (fuel-eval--retort-error
(fuel-eval--send/wait '(:fuel* (t) t :usings) 120000))))
(message (if err "Warning: some vocabularies failed to load"
"All vocabularies loaded"))))
;;; Minor mode definition: ;;; Minor mode definition:
@ -191,7 +203,8 @@ interacting with a factor listener is at your disposal.
(fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point) (fuel-mode--key ?e ?d 'fuel-edit-word-doc-at-point)
(fuel-mode--key ?e ?e 'fuel-eval-extended-region) (fuel-mode--key ?e ?e 'fuel-eval-extended-region)
(fuel-mode--key ?e ?l 'fuel-run-file) (fuel-mode--key ?e ?k 'fuel-run-file)
(fuel-mode--key ?e ?l 'fuel-load-usings)
(fuel-mode--key ?e ?r 'fuel-eval-region) (fuel-mode--key ?e ?r 'fuel-eval-region)
(fuel-mode--key ?e ?u 'fuel-update-usings) (fuel-mode--key ?e ?u 'fuel-update-usings)
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary) (fuel-mode--key ?e ?v 'fuel-edit-vocabulary)