From bbf0a8d266d517faccc9c74fe9a89e198ce4d821 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 May 2009 12:28:52 -0500 Subject: [PATCH 1/7] fix stack effect --- core/classes/parser/parser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 ; From 553fd8aa1596d436e67718533b6c52d57bd75005 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 May 2009 18:57:49 -0500 Subject: [PATCH 2/7] use ${ in some nurbs tests --- extra/nurbs/nurbs-tests.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) 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 From 4d882f25cd91e945ca69859da53f07c5a99b363f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 May 2009 11:20:40 -0500 Subject: [PATCH 3/7] add managed-server to extra/ --- extra/managed-server/authors.txt | 1 + extra/managed-server/chat/authors.txt | 1 + extra/managed-server/chat/chat.factor | 23 ++++++++ extra/managed-server/managed-server.factor | 63 ++++++++++++++++++++++ 4 files changed, 88 insertions(+) create mode 100644 extra/managed-server/authors.txt create mode 100644 extra/managed-server/chat/authors.txt create mode 100644 extra/managed-server/chat/chat.factor create mode 100644 extra/managed-server/managed-server.factor 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..7cd4db58f7 --- /dev/null +++ b/extra/managed-server/chat/chat.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry io kernel managed-server +namespaces sequences ; +IN: managed-server.chat + +TUPLE: chat-server < managed-server ; + +: ( port -- managed-server ) + "chat-server" chat-server new-managed-server ; + +M: chat-server handle-managed-client* + clients>> + readln dup empty? [ + 2drop + ] [ + '[ + nip output-stream>> + [ + client get username>> ": " _ 3append print flush + ] with-output-stream* + ] assoc-each + ] if ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor new file mode 100644 index 0000000000..2a9df2ae8a --- /dev/null +++ b/extra/managed-server/managed-server.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar continuations io +io.encodings.binary io.servers.connection io.sockets +io.streams.duplex kernel locals math math.ranges multiline +namespaces prettyprint random sequences sets splitting threads +tools.continuations ; +IN: managed-server + +SYMBOL: client + +TUPLE: managed-server < threaded-server clients ; + +TUPLE: managed-client input-stream output-stream local-address +remote-address username ; + +GENERIC: login ( managed-server -- username ) +GENERIC: handle-managed-client* ( threaded-server -- ) + +ERROR: already-logged-in username ; +ERROR: bad-login 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 threaded-server get clients>> key? [ already-logged-in ] when ; + +: add-managed-client ( managed-client -- ) + dup username>> + threaded-server get clients>> set-at ; + +: delete-managed-client ( -- ) + client get username>> + threaded-server get clients>> delete-at ; + +: handle-managed-client ( -- ) + [ [ threaded-server get handle-managed-client* t ] loop ] + [ delete-managed-client ] + [ ] cleanup ; + +PRIVATE> + +M: managed-server login drop readln ; + +M: managed-server handle-client* + login + [ client set ] [ add-managed-client ] bi + handle-managed-client ; + +: new-managed-server ( port name class -- server ) + new-threaded-server + swap >>name + swap >>insecure + f >>timeout + H{ } clone >>clients ; inline From 2151df5b1f93cf1e94bf55c080065abd446c5c17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 29 May 2009 13:39:24 -0500 Subject: [PATCH 4/7] refactor managed-server and chat, add hooks for when stuff happens, add /me, /who, /quit --- extra/managed-server/chat/chat.factor | 64 ++++++++++++++++----- extra/managed-server/managed-server.factor | 66 +++++++++++++++------- 2 files changed, 96 insertions(+), 34 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 7cd4db58f7..1ec22516bd 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -1,23 +1,61 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry io kernel managed-server -namespaces sequences ; +USING: accessors assocs combinators combinators.smart +destructors fry io kernel managed-server namespaces +sequences splitting unicode.case ; IN: managed-server.chat +CONSTANT: line-beginning "-!- " + TUPLE: chat-server < managed-server ; : ( port -- managed-server ) "chat-server" chat-server new-managed-server ; +: unknown-command ( string -- ) + "Unknown command: " prepend print-client ; + +: handle-who ( string -- ) + drop + clients keys ", " join print flush ; + +: handle-me ( string -- ) + [ + [ "* " username " " ] dip + ] "" append-outputs-as send-everyone ; + +: handle-quit ( string -- ) + client [ (>>object) ] [ output-stream>> dispose ] bi ; + +: handle-command ( string -- ) + " " split1 swap >lower { + { "who" [ handle-who ] } + { "me" [ handle-me ] } + { "quit" [ handle-quit ] } + [ " " glue unknown-command ] + } case ; + +: handle-chat ( string -- ) + [ + [ username ": " ] dip + ] "" append-outputs-as send-everyone ; + +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* - clients>> - readln dup empty? [ - 2drop - ] [ - '[ - nip output-stream>> - [ - client get username>> ": " _ 3append print flush - ] with-output-stream* - ] assoc-each - ] if ; + readln [ + "/" ?head [ handle-command ] [ handle-chat ] if + ] unless-empty ; diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 2a9df2ae8a..ad09035251 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -1,24 +1,46 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs calendar continuations io +USING: accessors assocs calendar continuations destructors io io.encodings.binary io.servers.connection io.sockets -io.streams.duplex kernel locals math math.ranges multiline +io.streams.duplex fry kernel locals math math.ranges multiline namespaces prettyprint random sequences sets splitting threads tools.continuations ; IN: managed-server -SYMBOL: client - TUPLE: managed-server < threaded-server clients ; -TUPLE: managed-client input-stream output-stream local-address -remote-address username ; +TUPLE: managed-client +input-stream output-stream local-address remote-address +username object ; -GENERIC: login ( managed-server -- username ) -GENERIC: handle-managed-client* ( threaded-server -- ) +HOOK: 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 swap '[ + output-stream>> [ _ print flush ] with-output-stream* + ] each ; + +: print-client ( string -- ) + client output-stream>> + [ stream-print ] [ stream-flush ] bi ; ERROR: already-logged-in username ; -ERROR: bad-login username ; +ERROR: normal-quit ; >remote-address ; : check-logged-in ( username -- username ) - dup threaded-server get clients>> key? [ already-logged-in ] when ; + dup server clients>> key? [ + [ server ] dip + [ handle-already-logged-in ] [ already-logged-in ] bi + ] when ; -: add-managed-client ( managed-client -- ) - dup username>> - threaded-server get clients>> set-at ; +: add-managed-client ( -- ) + client username check-logged-in clients set-at ; : delete-managed-client ( -- ) - client get username>> - threaded-server get clients>> delete-at ; + username server clients>> delete-at ; : handle-managed-client ( -- ) - [ [ threaded-server get handle-managed-client* t ] loop ] - [ delete-managed-client ] + [ [ handle-managed-client* t ] loop ] + [ delete-managed-client handle-client-disconnect ] [ ] cleanup ; PRIVATE> -M: managed-server login drop readln ; +M: managed-server login readln ; M: managed-server handle-client* - login - [ client set ] [ add-managed-client ] bi - handle-managed-client ; + managed-server set + login managed-client set + add-managed-client + handle-client-join handle-managed-client ; : new-managed-server ( port name class -- server ) new-threaded-server From 39cb541b5315a3bcf1715aa3c52c15aeafdc1ef6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 01:29:02 -0500 Subject: [PATCH 5/7] Fix a problem with disconnects, add a lot of features to chat server, lots of refactoring of managed-server --- extra/managed-server/chat/chat.factor | 80 +++++++++++++++++----- extra/managed-server/managed-server.factor | 17 ++--- 2 files changed, 66 insertions(+), 31 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 1ec22516bd..723814bb13 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -1,23 +1,21 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.smart -destructors fry io kernel managed-server namespaces -sequences splitting unicode.case ; +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 -CONSTANT: line-beginning "-!- " - TUPLE: chat-server < managed-server ; -: ( port -- managed-server ) - "chat-server" chat-server new-managed-server ; +SYMBOL: commands +commands [ H{ } clone ] initialize -: unknown-command ( string -- ) - "Unknown command: " prepend print-client ; +SYMBOL: chat-docs +chat-docs [ H{ } clone ] initialize -: handle-who ( string -- ) - drop - clients keys ", " join print flush ; +CONSTANT: line-beginning "-!- " : handle-me ( string -- ) [ @@ -25,21 +23,64 @@ TUPLE: chat-server < managed-server ; ] "" append-outputs-as send-everyone ; : handle-quit ( string -- ) - client [ (>>object) ] [ output-stream>> dispose ] bi ; + 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 -- ) - " " split1 swap >lower { - { "who" [ handle-who ] } - { "me" [ handle-me ] } - { "quit" [ handle-quit ] } - [ " " glue unknown-command ] - } case ; + 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" @@ -56,6 +97,7 @@ M: chat-server handle-already-logged-in 3append print flush ; M: chat-server handle-managed-client* - readln [ + 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 index ad09035251..4d7ede84dc 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -11,9 +11,9 @@ TUPLE: managed-server < threaded-server clients ; TUPLE: managed-client input-stream output-stream local-address remote-address -username object ; +username object quit? ; -HOOK: login threaded-server ( -- username ) +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 ( -- ) @@ -31,16 +31,11 @@ M: managed-server handle-managed-client* ; : username ( -- string ) client username>> ; : send-everyone ( seq -- ) - client-streams swap '[ + [ client-streams ] dip '[ output-stream>> [ _ print flush ] with-output-stream* ] each ; -: print-client ( string -- ) - client output-stream>> - [ stream-print ] [ stream-flush ] bi ; - ERROR: already-logged-in username ; -ERROR: normal-quit ; > delete-at ; : handle-managed-client ( -- ) - [ [ handle-managed-client* t ] loop ] + [ [ handle-managed-client* client quit?>> not ] loop ] [ delete-managed-client handle-client-disconnect ] [ ] cleanup ; PRIVATE> -M: managed-server login readln ; - M: managed-server handle-client* managed-server set - login managed-client set + handle-login managed-client set add-managed-client handle-client-join handle-managed-client ; From e98a0738e2f688289e3895586f9227fdfdfa0960 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 10:34:47 -0500 Subject: [PATCH 6/7] support mingw in factor.sh --- build-support/factor.sh | 1 + 1 file changed, 1 insertion(+) 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;; From 2d02ff7dad1bf394b9e7bd6335bb01fb0797598b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 12:13:17 -0500 Subject: [PATCH 7/7] cleaned up slava's old cursor code --- extra/cursors/authors.txt | 1 + extra/cursors/cursors-tests.factor | 21 +++++++ extra/cursors/cursors.factor | 99 ++++++++++++++++++++++++++++++ 3 files changed, 121 insertions(+) create mode 100644 extra/cursors/authors.txt create mode 100644 extra/cursors/cursors-tests.factor create mode 100644 extra/cursors/cursors.factor 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