diff --git a/build-support/factor.sh b/build-support/factor.sh index ba5815cfc1..d5b8bd5411 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -174,6 +174,7 @@ find_os() { CYGWIN_NT-5.2-WOW64) OS=winnt;; *CYGWIN_NT*) OS=winnt;; *CYGWIN*) OS=winnt;; + MINGW32*) OS=winnt;; *darwin*) OS=macosx;; *Darwin*) OS=macosx;; *linux*) OS=linux;; diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor index bd2e6ea4a0..0697537d12 100644 --- a/core/classes/parser/parser.factor +++ b/core/classes/parser/parser.factor @@ -6,7 +6,7 @@ IN: classes.parser : save-class-location ( class -- ) location remember-class ; -: create-class-in ( word -- word ) +: create-class-in ( string -- word ) current-vocab create dup save-class-location dup predicate-word dup set-word save-location ; diff --git a/extra/cursors/authors.txt b/extra/cursors/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/cursors/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor new file mode 100644 index 0000000000..3c98608b72 --- /dev/null +++ b/extra/cursors/cursors-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: cursors math tools.test make ; +IN: cursors.tests + +[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test +[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test +[ f f ] [ { 2 4 } [ odd? ] find ] unit-test + +[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test +[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test + +[ t ] [ { } [ odd? ] all? ] unit-test +[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test +[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test + +[ t ] [ { } [ odd? ] all? ] unit-test +[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test +[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test + +[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor new file mode 100644 index 0000000000..059129f22e --- /dev/null +++ b/extra/cursors/cursors.factor @@ -0,0 +1,99 @@ +! Copyright (C) 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math sequences sequences.private ; +IN: cursors + +GENERIC: cursor-done? ( cursor -- ? ) +GENERIC: cursor-get-unsafe ( cursor -- obj ) +GENERIC: cursor-advance ( cursor -- ) +GENERIC: cursor-valid? ( cursor -- ? ) +GENERIC: cursor-write ( obj cursor -- ) + +ERROR: cursor-ended cursor ; + +: cursor-get ( cursor -- obj ) + dup cursor-done? + [ cursor-ended ] [ cursor-get-unsafe ] if ; inline + +: find-done? ( quot cursor -- ? ) + dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline + +: cursor-until ( quot cursor -- ) + [ find-done? not ] + [ cursor-advance drop ] bi-curry bi-curry while ; inline + +: cursor-each ( cursor quot -- ) + [ f ] compose swap cursor-until ; inline + +: cursor-find ( cursor quot -- obj ? ) + swap [ cursor-until ] keep + dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline + +: cursor-any? ( cursor quot -- ? ) + cursor-find nip ; inline + +: cursor-all? ( cursor quot -- ? ) + [ not ] compose cursor-any? not ; inline + +: cursor-map-quot ( quot to -- quot' ) + [ [ call ] dip cursor-write ] 2curry ; inline + +: cursor-map ( from to quot -- ) + swap cursor-map-quot cursor-each ; inline + +: cursor-write-if ( obj quot to -- ) + [ over [ call ] dip ] dip + [ cursor-write ] 2curry when ; inline + +: cursor-filter-quot ( quot to -- quot' ) + [ cursor-write-if ] 2curry ; inline + +: cursor-filter ( from to quot -- ) + swap cursor-filter-quot cursor-each ; inline + +TUPLE: from-sequence { seq sequence } { n integer } ; + +: >from-sequence< ( from-sequence -- n seq ) + [ n>> ] [ seq>> ] bi ; inline + +M: from-sequence cursor-done? ( cursor -- ? ) + >from-sequence< length >= ; + +M: from-sequence cursor-valid? + >from-sequence< bounds-check? not ; + +M: from-sequence cursor-get-unsafe + >from-sequence< nth-unsafe ; + +M: from-sequence cursor-advance + [ 1+ ] change-n drop ; + +: >input ( seq -- cursor ) + 0 from-sequence boa ; inline + +: iterate ( seq quot iterator -- ) + [ >input ] 2dip call ; inline + +: each ( seq quot -- ) [ cursor-each ] iterate ; inline +: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline +: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline +: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline + +TUPLE: to-sequence { seq sequence } { exemplar sequence } ; + +M: to-sequence cursor-write + seq>> push ; + +: freeze ( cursor -- seq ) + [ seq>> ] [ exemplar>> ] bi like ; inline + +: >output ( seq -- cursor ) + [ [ length ] keep new-resizable ] keep + to-sequence boa ; inline + +: transform ( seq quot transformer -- newseq ) + [ [ >input ] [ >output ] bi ] 2dip + [ call ] [ 2drop freeze ] 3bi ; inline + +: map ( seq quot -- ) [ cursor-map ] transform ; inline +: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline diff --git a/extra/managed-server/authors.txt b/extra/managed-server/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/managed-server/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/managed-server/chat/authors.txt b/extra/managed-server/chat/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/managed-server/chat/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor new file mode 100644 index 0000000000..723814bb13 --- /dev/null +++ b/extra/managed-server/chat/chat.factor @@ -0,0 +1,103 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators combinators.smart +destructors fry io io.encodings.utf8 kernel managed-server +namespaces parser sequences sorting splitting strings.parser +unicode.case unicode.categories calendar calendar.format +locals multiline ; +IN: managed-server.chat + +TUPLE: chat-server < managed-server ; + +SYMBOL: commands +commands [ H{ } clone ] initialize + +SYMBOL: chat-docs +chat-docs [ H{ } clone ] initialize + +CONSTANT: line-beginning "-!- " + +: handle-me ( string -- ) + [ + [ "* " username " " ] dip + ] "" append-outputs-as send-everyone ; + +: handle-quit ( string -- ) + client [ (>>object) ] [ t >>quit? drop ] bi ; + +: handle-help ( string -- ) + [ + "Commands: " + commands get keys natural-sort ", " join append print flush + ] [ + chat-docs get ?at + [ print flush ] + [ "Unknown command: " prepend print flush ] if + ] if-empty ; + +:: add-command ( quot docs key -- ) + quot key commands get set-at + docs key chat-docs get set-at ; + +[ handle-help ] +<" Syntax: /help [command] +Displays the documentation for a command."> +"help" add-command + +[ drop clients keys ", " join print flush ] +<" Syntax: /who +Shows the list of connected users."> +"who" add-command + +[ drop gmt timestamp>rfc822 print flush ] +<" Syntax: /time +Returns the current GMT time."> "time" add-command + +[ handle-me ] +<" Syntax: /me action"> +"me" add-command + +[ handle-quit ] +<" Syntax: /quit [message] +Disconnects a user from the chat server."> "quit" add-command + +: handle-command ( string -- ) + dup " " split1 swap >lower commands get at* [ + call( string -- ) drop + ] [ + 2drop "Unknown command: " prepend print flush + ] if ; + +: ( port -- managed-server ) + "chat-server" chat-server new-managed-server + utf8 >>encoding ; + +: handle-chat ( string -- ) + [ + [ username ": " ] dip + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-login + "Username: " write flush + readln ; + +M: chat-server handle-client-join + [ + line-beginning username " has joined" + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-client-disconnect + [ + line-beginning username " has quit " + client object>> dup [ "\"" dup surround ] when + ] "" append-outputs-as send-everyone ; + +M: chat-server handle-already-logged-in + "The username ``" username "'' is already in use; try again." + 3append print flush ; + +M: chat-server handle-managed-client* + readln dup f = [ t client (>>quit?) ] when + [ + "/" ?head [ handle-command ] [ handle-chat ] if + ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor new file mode 100644 index 0000000000..4d7ede84dc --- /dev/null +++ b/extra/managed-server/managed-server.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar continuations destructors io +io.encodings.binary io.servers.connection io.sockets +io.streams.duplex fry kernel locals math math.ranges multiline +namespaces prettyprint random sequences sets splitting threads +tools.continuations ; +IN: managed-server + +TUPLE: managed-server < threaded-server clients ; + +TUPLE: managed-client +input-stream output-stream local-address remote-address +username object quit? ; + +HOOK: handle-login threaded-server ( -- username ) +HOOK: handle-already-logged-in managed-server ( -- ) +HOOK: handle-client-join managed-server ( -- ) +HOOK: handle-client-disconnect managed-server ( -- ) +HOOK: handle-managed-client* managed-server ( -- ) + +M: managed-server handle-already-logged-in ; +M: managed-server handle-client-join ; +M: managed-server handle-client-disconnect ; +M: managed-server handle-managed-client* ; + +: server ( -- managed-client ) managed-server get ; +: client ( -- managed-client ) managed-client get ; +: clients ( -- assoc ) server clients>> ; +: client-streams ( -- assoc ) clients values ; +: username ( -- string ) client username>> ; + +: send-everyone ( seq -- ) + [ client-streams ] dip '[ + output-stream>> [ _ print flush ] with-output-stream* + ] each ; + +ERROR: already-logged-in username ; + + ( username -- managed-client ) + managed-client new + swap >>username + input-stream get >>input-stream + output-stream get >>output-stream + local-address get >>local-address + remote-address get >>remote-address ; + +: check-logged-in ( username -- username ) + dup server clients>> key? [ + [ server ] dip + [ handle-already-logged-in ] [ already-logged-in ] bi + ] when ; + +: add-managed-client ( -- ) + client username check-logged-in clients set-at ; + +: delete-managed-client ( -- ) + username server clients>> delete-at ; + +: handle-managed-client ( -- ) + [ [ handle-managed-client* client quit?>> not ] loop ] + [ delete-managed-client handle-client-disconnect ] + [ ] cleanup ; + +PRIVATE> + +M: managed-server handle-client* + managed-server set + handle-login managed-client set + add-managed-client + handle-client-join handle-managed-client ; + +: new-managed-server ( port name class -- server ) + new-threaded-server + swap >>name + swap >>insecure + f >>timeout + H{ } clone >>clients ; inline diff --git a/extra/nurbs/nurbs-tests.factor b/extra/nurbs/nurbs-tests.factor index db606f9c5c..191c2af7ca 100644 --- a/extra/nurbs/nurbs-tests.factor +++ b/extra/nurbs/nurbs-tests.factor @@ -11,13 +11,13 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ] ! unit circle as NURBS 3 { { 1.0 0.0 1.0 } - { $ √2/2 $ √2/2 $ √2/2 } + ${ √2/2 √2/2 √2/2 } { 0.0 1.0 1.0 } - { $ -√2/2 $ √2/2 $ √2/2 } + ${ -√2/2 √2/2 √2/2 } { -1.0 0.0 1.0 } - { $ -√2/2 $ -√2/2 $ √2/2 } + ${ -√2/2 -√2/2 √2/2 } { 0.0 -1.0 1.0 } - { $ √2/2 $ -√2/2 $ √2/2 } + ${ √2/2 -√2/2 √2/2 } { 1.0 0.0 1.0 } } { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } test-nurbs set @@ -26,7 +26,7 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ] [ t ] [ test-nurbs get 0.5 eval-nurbs { -1.0 0.0 } 0.00001 v~ ] unit-test [ t ] [ test-nurbs get 0.75 eval-nurbs { 0.0 -1.0 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.125 eval-nurbs { $ √2/2 $ √2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $ √2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test -[ t ] [ test-nurbs get 0.875 eval-nurbs { $ √2/2 $ -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test +[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test