Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
f6acad88d4
|
|
@ -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;;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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 ;
|
||||
|
||||
: <chat-server> ( 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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: <managed-client> ( 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> 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
|
||||
|
|
@ -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 } <nurbs-curve> 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue