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

Merge commit 'origin/master'

db4
Chris Double 2008-04-03 11:57:43 +13:00
parent eac450bdcf dd9f20197c
commit 90bb54f304
33 changed files with 160 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
core/bootstrap/syntax.factor
View File

@ -43,6 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
"SINGLETON:"
"SYMBOL:"
"TUPLE:"
"T{"

0
extra/classes/singleton/authors.txt → core/classes/singleton/authors.txt
View File

0
extra/classes/singleton/singleton-docs.factor → core/classes/singleton/singleton-docs.factor
View File

12
core/classes/singleton/singleton-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

11
core/classes/singleton/singleton.factor Executable file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ;
: define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ;

8
core/io/backend/backend-tests.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
IN: io.backend.tests
USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-pathname drop ] unit-test
IN: io.backend.tests
USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-path drop ] unit-test

6
core/io/backend/backend.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
io.encodings.utf8 init assocs ;
io.encodings.utf8 init assocs splitting ;
IN: io.backend
SYMBOL: io-backend
@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
HOOK: normalize-directory io-backend ( str -- newstr )
HOOK: normalize-pathname io-backend ( str -- newstr )
HOOK: normalize-path io-backend ( str -- newstr )
M: object normalize-directory normalize-pathname ;
M: object normalize-directory normalize-path ;
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio

2
core/io/files/files-docs.factor
View File

@ -252,7 +252,7 @@ HELP: normalize-directory
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
HELP: normalize-pathname
HELP: normalize-path
{ $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." } ;

6
core/io/files/files-tests.factor
View File

@ -220,8 +220,6 @@ io.encodings.utf8 ;
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
@ -239,9 +237,6 @@ io.encodings.utf8 ;
[ "lib" ] [ "" "lib" append-path ] unit-test
[ "lib" ] [ "" "./lib" append-path ] unit-test
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
[ "foo/bar/." parent-directory ] must-fail
[ "foo/bar/./" parent-directory ] must-fail
[ "foo/bar/baz/.." parent-directory ] must-fail
@ -263,5 +258,4 @@ io.encodings.utf8 ;
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
[ t ] [ "resource:core" absolute-path? ] unit-test
[ t ] [ "/foo" absolute-path? ] unit-test
[ f ] [ "" absolute-path? ] unit-test

48
core/io/files/files.factor
View File

@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
swap normalize-pathname (file-reader) swap <decoder> ;
swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
swap normalize-pathname (file-writer) swap <encoder> ;
swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
swap normalize-pathname (file-appender) swap <encoder> ;
swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
@ -102,6 +102,7 @@ PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] }
@ -111,8 +112,8 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
{ [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
@ -126,6 +127,9 @@ PRIVATE>
2 tail left-trim-separators
>r parent-directory r> append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
{ [ t ] [
>r right-trim-separators "/" r>
left-trim-separators 3append
@ -167,7 +171,7 @@ SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
normalize-pathname (exists?) ;
normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
@ -183,18 +187,33 @@ M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "io.files" add-init-hook
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: (normalize-path) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
] if ;
M: object normalize-path ( path -- path' )
(normalize-path) ;
: with-directory ( path quot -- )
>r normalize-pathname r>
>r (normalize-path) r>
current-directory swap with-variable ; inline
: set-current-directory ( path -- )
normalize-pathname current-directory set ;
normalize-path current-directory set ;
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-pathname right-trim-separators {
normalize-path right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@ -267,7 +286,7 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
normalize-pathname
normalize-path
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
@ -286,9 +305,6 @@ DEFER: copy-tree-into
[ copy-tree-into ] curry each ;
! Special paths
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: temp-directory ( -- path )
"temp" resource-path dup make-directories ;
@ -296,14 +312,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
M: object normalize-pathname ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
normalize-pathname
] [
current-directory get prepend-path
] if ;
! Pathname presentations
TUPLE: pathname string ;

5
core/prettyprint/prettyprint.factor
View File

@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate
combinators quotations ;
classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
@ -254,6 +254,9 @@ M: predicate-class see-class*
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
M: singleton-class see-class* ( class -- )
\ SINGLETON: pprint-word pprint-word ;
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word

9
core/syntax/syntax.factor
View File

@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
combinators debugger ;
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -154,6 +154,11 @@ IN: bootstrap.syntax
parse-definition define-predicate-class
] define-syntax
"SINGLETON:" [
scan create-class-in
dup save-location define-singleton-class
] define-syntax
"TUPLE:" [
parse-tuple-definition define-tuple-class
] define-syntax

2
extra/cairo/png/png.factor
View File

@ -24,7 +24,7 @@ ERROR: cairo-error string ;
} cond ;
: <png> ( path -- png )
normalize-pathname
normalize-path
cairo_image_surface_create_from_png
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]

12
extra/classes/singleton/singleton-tests.factor
View File

@ -1,12 +0,0 @@
USING: kernel singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

22
extra/classes/singleton/singleton.factor
View File

@ -1,22 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel namespaces parser quotations
sequences words prettyprint prettyprint.backend prettyprint.sections
compiler.units classes ;
IN: classes.singleton
PREDICATE: singleton < predicate-class
[ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ;
: define-singleton ( token -- )
create-class-in
dup save-location
\ singleton
over [ eq? ] curry define-predicate-class ;
: SINGLETON:
scan define-singleton ; parsing
M: singleton see-class* ( class -- )
<colon \ SINGLETON: pprint-word pprint-word ;

2
extra/editors/editors.factor
View File

@ -26,7 +26,7 @@ SYMBOL: edit-hook
require ;
: edit-location ( file line -- )
>r normalize-pathname "\\\\?\\" ?head drop r>
>r (normalize-path) "\\\\?\\" ?head drop r>
edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )

1
extra/editors/textwrangler/authors.txt Normal file
View File

@ -0,0 +1 @@
Ben Schlingelhof

1
extra/editors/textwrangler/summary.txt Normal file
View File

@ -0,0 +1 @@
Textwrangler editor integration

13
extra/editors/textwrangler/textwrangler.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Ben Schlingelhof.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io.launcher kernel parser words sequences
math math.parser namespaces editors ;
IN: editors.textwrangler
: tw ( file line -- )
[ "edit +" % # " " % % ] "" make run-process drop ;
: tw-word ( word -- )
where first2 tw ;
[ tw ] edit-hook set-global

2
extra/io/sockets/sockets.factor
View File

@ -7,7 +7,7 @@ IN: io.sockets
TUPLE: local path ;
: <local> ( path -- addrspec )
normalize-pathname local construct-boa ;
normalize-path local construct-boa ;
TUPLE: inet4 host port ;

6
extra/io/unix/files/files-tests.factor
View File

@ -21,3 +21,9 @@ IN: io.unix.files.tests
[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
[ t ] [ "/foo" absolute-path? ] unit-test

20
extra/io/unix/files/files.factor
View File

@ -43,22 +43,22 @@ M: unix-io (file-appender) ( path -- stream )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
M: unix-io touch-file ( path -- )
normalize-pathname
normalize-path
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
M: unix-io move-file ( from to -- )
[ normalize-pathname ] bi@ rename io-error ;
[ normalize-path ] bi@ rename io-error ;
M: unix-io delete-file ( path -- )
normalize-pathname unlink io-error ;
normalize-path unlink io-error ;
M: unix-io make-directory ( path -- )
normalize-pathname OCT: 777 mkdir io-error ;
normalize-path OCT: 777 mkdir io-error ;
M: unix-io delete-directory ( path -- )
normalize-pathname rmdir io-error ;
normalize-path rmdir io-error ;
: (copy-file) ( from to -- )
dup parent-directory make-directories
@ -69,7 +69,7 @@ M: unix-io delete-directory ( path -- )
] with-disposal ;
M: unix-io copy-file ( from to -- )
[ normalize-pathname ] bi@
[ normalize-path ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
2bi ;
@ -96,15 +96,15 @@ M: unix-io copy-file ( from to -- )
\ file-info construct-boa ;
M: unix-io file-info ( path -- info )
normalize-pathname stat* stat>file-info ;
normalize-path stat* stat>file-info ;
M: unix-io link-info ( path -- info )
normalize-pathname lstat* stat>file-info ;
normalize-path lstat* stat>file-info ;
M: unix-io make-link ( path1 path2 -- )
normalize-pathname symlink io-error ;
normalize-path symlink io-error ;
M: unix-io read-link ( path -- path' )
normalize-pathname
normalize-path
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;

2
extra/io/unix/launcher/launcher.factor
View File

@ -37,7 +37,7 @@ USE: unix
2nip reset-fd ;
: redirect-file ( obj mode fd -- )
>r >r normalize-pathname r> file-mode
>r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ;
: redirect-closed ( obj mode fd -- )

2
extra/io/windows/ce/files/files.factor
View File

@ -4,7 +4,7 @@ prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend ;
IN: windows.ce.files
! M: windows-ce-io normalize-pathname ( string -- string )
! M: windows-ce-io normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )

8
extra/io/windows/files/files.factor
View File

@ -89,14 +89,14 @@ SYMBOLS: +read-only+ +hidden+ +system+
] if ;
M: windows-nt-io file-info ( path -- info )
normalize-pathname get-file-information-stat ;
normalize-path get-file-information-stat ;
M: windows-nt-io link-info ( path -- info )
file-info ;
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-pathname open-existing dup close-always
normalize-path open-existing dup close-always
"FILETIME" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info )
#! timestamp order: creation access write
[
>r >r >r
normalize-pathname open-existing dup close-always
normalize-path open-existing dup close-always
r> r> r> (set-file-times)
] with-destructors ;
@ -127,7 +127,7 @@ M: windows-nt-io link-info ( path -- info )
M: windows-nt-io touch-file ( path -- )
[
normalize-pathname
normalize-path
maybe-create-file over close-always
[ drop ] [ f now dup (set-file-times) ] if
] with-destructors ;

2
extra/io/windows/launcher/launcher.factor
View File

@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags
current-directory get normalize-pathname >>lpCurrentDirectory ;
current-directory get (normalize-path) >>lpCurrentDirectory ;
: call-CreateProcess ( CreateProcess-args -- )
{

17
extra/io/windows/nt/files/files-tests.factor Normal file → Executable file
View File

@ -1,9 +1,9 @@
USING: io.files kernel tools.test io.backend
io.windows.nt.files splitting ;
io.windows.nt.files splitting sequences ;
IN: io.windows.nt.files.tests
[ t ] [ "\\foo" absolute-path? ] unit-test
[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test
[ f ] [ "\\foo" absolute-path? ] unit-test
[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:\\foo" absolute-path? ] unit-test
[ t ] [ "c:" absolute-path? ] unit-test
@ -29,19 +29,22 @@ IN: io.windows.nt.files.tests
[ ] [ "" resource-path cd ] unit-test
[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
"C:\\builds\\factor\\12345\\"
"..\\log.txt" append-path normalize-pathname
"..\\log.txt" append-path normalize-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
"..\\.." append-path normalize-pathname
"..\\.." append-path normalize-path
] unit-test
[ "\\\\?\\C:\\builds\\" ] [
"C:\\builds\\factor\\12345\\"
"..\\.." append-path normalize-pathname
"..\\.." append-path normalize-path
] unit-test
[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
[ t ] [ "" resource-path 2 tail exists? ] unit-test

28
extra/io/windows/nt/files/files.factor
View File

@ -36,28 +36,14 @@ ERROR: not-absolute-path ;
} && [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
unicode-prefix prepend ;
dup unicode-prefix head? [
unicode-prefix prepend
] unless ;
ERROR: nonstring-pathname ;
ERROR: empty-pathname ;
M: windows-nt-io normalize-pathname ( string -- string )
"resource:" ?head [
left-trim-separators resource-path
normalize-pathname
] [
dup empty? [ empty-pathname ] when
current-directory get prepend-path
dup unicode-prefix head? [
dup first path-separator? [
left-trim-separators
current-directory get 2 head
prepend-path
] when
unicode-prefix prepend
] unless
{ { CHAR: / CHAR: \\ } } substitute ! necessary
] if ;
M: windows-nt-io normalize-path ( string -- string' )
(normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
prepend-prefix ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;

2
extra/io/windows/nt/launcher/launcher.factor
View File

@ -32,7 +32,7 @@ IN: io.windows.nt.launcher
drop 2nip null-pipe ;
:: redirect-file ( default path access-mode create-mode -- handle )
path normalize-pathname
path normalize-path
access-mode
share-mode
security-attributes-inherit

12
extra/io/windows/windows.factor
View File

@ -25,7 +25,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
M: windows-io normalize-directory ( string -- string )
normalize-pathname "\\" ?tail drop "\\*" append ;
normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
{
@ -135,21 +135,21 @@ M: windows-io (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
M: windows-io move-file ( from to -- )
[ normalize-pathname ] bi@ MoveFile win32-error=0/f ;
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
M: windows-io delete-file ( path -- )
normalize-pathname DeleteFile win32-error=0/f ;
normalize-path DeleteFile win32-error=0/f ;
M: windows-io copy-file ( from to -- )
dup parent-directory make-directories
[ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ;
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
M: windows-io make-directory ( path -- )
normalize-pathname
normalize-path
f CreateDirectory win32-error=0/f ;
M: windows-io delete-directory ( path -- )
normalize-pathname
normalize-path
RemoveDirectory win32-error=0/f ;
HOOK: WSASocket-flags io-backend ( -- DWORD )

17
extra/new-effects/new-effects.factor
View File

@ -1,17 +0,0 @@
USING: assocs kernel sequences ;
IN: new-effects
: new-nth ( seq n -- elt )
swap nth ; inline
: new-set-nth ( seq obj n -- seq )
pick set-nth ; inline
: new-at ( assoc key -- elt )
swap at ; inline
: new-at* ( assoc key -- elt ? )
swap at* ; inline
: new-set-at ( assoc value key -- assoc )
pick set-at ; inline

22
extra/newfx/newfx.factor
View File

@ -17,9 +17,16 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: nth-is ( seq i val -- seq ) swap pick set-nth ;
: nth-is ( seq i val -- seq ) swap pick set-nth ;
: is-nth ( seq val i -- seq ) pick set-nth ;
: is-nth ( seq val i -- seq ) pick set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mutate-nth ( seq i val -- ) swap rot set-nth ;
: mutate-at-nth ( seq val i -- ) rot set-nth ;
: mutate-nth-of ( i val seq -- ) swapd set-nth ;
: mutate-at-nth-of ( val i seq -- ) set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -33,6 +40,14 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mutate-key ( tbl key val -- ) swap rot set-at ;
: mutate-at-key ( tbl val key -- ) rot set-at ;
: mutate-key-of ( key val tbl -- ) swapd set-at ;
: mutate-at-key-of ( val key tbl -- ) set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: push ( seq obj -- seq ) over sequences:push ;
: push-on ( obj seq -- seq ) tuck sequences:push ;
@ -48,3 +63,6 @@ IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A note about the 'mutate' qualifier. Other words also technically mutate
! their primary object. However, the 'mutate' qualifier is supposed to
! indicate that this is the main objective of the word, as a side effect.

10
extra/random/mersenne-twister/mersenne-twister.factor
View File

@ -4,7 +4,7 @@
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
accessors math.ranges random ;
accessors math.ranges random circular ;
IN: random.mersenne-twister
<PRIVATE
@ -16,8 +16,6 @@ TUPLE: mersenne-twister seq i ;
: mt-a HEX: 9908b0df ; inline
: mt-hi HEX: 80000000 bitand ; inline
: mt-lo HEX: 7fffffff bitand ; inline
: wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline
: mt-wrap ( x -- y ) mt-n wrap ; inline
: set-generated ( y from-elt to seq -- )
>r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
@ -27,8 +25,8 @@ TUPLE: mersenne-twister seq i ;
tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
: (mt-generate) ( n mt-seq -- y to from-elt )
[ >r dup 1+ mt-wrap r> calculate-y ]
[ >r mt-m + mt-wrap r> nth ]
[ >r dup 1+ r> calculate-y ]
[ >r mt-m + r> nth ]
[ drop ] 2tri ;
: mt-generate ( mt -- )
@ -36,7 +34,7 @@ TUPLE: mersenne-twister seq i ;
[ 0 >>i drop ] bi ;
: init-mt-first ( seed -- seq )
>r mt-n 0 <array> r>
>r mt-n 0 <array> <circular> r>
HEX: ffffffff bitand 0 pick set-nth ;
: init-mt-formula ( seq i -- f(seq[i]) )