Merge branch 'master' of git://factorcode.org/git/factor

Conflicts:

	extra/pango/cairo/gadgets/gadgets.factor

core/assocs/assocs-docs.factor

@@ -139,7 +139,7 @@ HELP: new-assoc
 
 HELP: assoc-find
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
-{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
+{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." }
 { $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
 
 HELP: clear-assoc

core/kernel/kernel-docs.factor

@@ -219,6 +219,16 @@ $nl
 { $example "t \\ t eq? ." "t" }
 "Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
 
+ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
+"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
+$nl
+"The following two lines are equivalent:"
+{ $code "[ drop f ] unless" "swap and" }
+"The following two lines are equivalent:"
+{ $code "[ ] [ ] ?if" "swap or" }
+"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
+{ $code "[ L ] unless*" "L or" } ;
+
 ARTICLE: "conditionals" "Conditionals and logic"
 "The basic conditionals:"
 { $subsection if }
@@ -238,6 +248,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
 { $subsection and }
 { $subsection or }
 { $subsection xor }
+{ $subsection "conditionals-boolean-equivalence" }
 "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
 { $see-also "booleans" "bitwise-arithmetic" both? either? } ;
 
@@ -720,9 +731,7 @@ HELP: unless*
 { $description "Variant of " { $link if* } " with no true quotation." }
 { $notes
 "The following two lines are equivalent:"
-{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
+{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
-"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
-{ $code "[ L ] unless*" "L or" } } ;
 
 HELP: ?if
 { $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }

core/syntax/syntax-docs.factor

@@ -346,7 +346,7 @@ HELP: \
 { $syntax "\\ word" }
 { $values { "word" "a word" } }
 { $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." }
-{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } } ;
+{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ;
 
 HELP: DEFER:
 { $syntax "DEFER: word" }
@@ -526,6 +526,9 @@ HELP: PREDICATE:
         "it satisfies the predicate"
     }
     "Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch."
+}
+{ $examples
+    { $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" }
 } ;
 
 HELP: TUPLE:

extra/furnace/actions/actions-tests.factor

@@ -21,3 +21,21 @@ blah
     init-request
     { } "action-1" get call-responder
 ] unit-test
+
+<action>
+    "a" >>rest
+    [ "a" param string>number sq ] >>display
+"action-2" set
+
+STRING: action-request-test-2
+GET http://foo/bar/123 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+    action-request-test-2 lf>crlf
+    [ read-request ] with-string-reader
+    init-request
+    { "5" } "action-2" get call-responder
+] unit-test

extra/furnace/actions/actions.factor

@@ -2,20 +2,22 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors sequences kernel assocs combinators
 validators http hashtables namespaces fry continuations locals
-io arrays math boxes
+io arrays math boxes splitting urls
 xml.entities
 http.server
 http.server.responses
 furnace
+furnace.flash
 html.elements
 html.components
+html.components
 html.templates.chloe
 html.templates.chloe.syntax ;
 IN: furnace.actions
 
 SYMBOL: params
 
-SYMBOL: rest-param
+SYMBOL: rest
 
 : render-validation-messages ( -- )
     validation-messages get
@@ -27,7 +29,7 @@ SYMBOL: rest-param
 
 CHLOE: validation-messages drop render-validation-messages ;
 
-TUPLE: action rest-param init display validate submit ;
+TUPLE: action rest init display validate submit ;
 
 : new-action ( class -- action )
     new
@@ -39,48 +41,68 @@ TUPLE: action rest-param init display validate submit ;
 : <action> ( -- action )
     action new-action ;
 
+: flashed-variables ( -- seq )
+    { validation-messages named-validation-messages } ;
+
 : handle-get ( action -- response )
-    blank-values
+    '[
+        ,
         [ init>> call ]
+        [ drop flashed-variables restore-flash ]
         [ display>> call ]
-    bi ;
+        tri
+    ] with-exit-continuation ;
 
 : validation-failed ( -- * )
-    request get method>> "POST" =
+    request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
-    [ action get display>> call ] [ <400> ] if exit-with ;
 
-: handle-post ( action -- response )
+: (handle-post) ( action -- response )
-    init-validation
+    [ validate>> call ] [ submit>> call ] bi ;
-    blank-values
-    [ validate>> call ]
-    [ submit>> call ] bi ;
-
-: handle-rest-param ( arg -- )
-    dup length 1 > action get rest-param>> not or
-    [ <404> exit-with ] [
-        action get rest-param>> associate rest-param set
-    ] if ;
-
-M: action call-responder* ( path action -- response )
-    dup action set
-    '[
-        , dup empty? [ drop ] [ handle-rest-param ] if
-
-        init-validation
-        ,
-        request get
-        [ request-params rest-param get assoc-union params set ]
-        [ method>> ] bi
-        {
-            { "GET" [ handle-get ] }
-            { "HEAD" [ handle-get ] }
-            { "POST" [ handle-post ] }
-        } case
-    ] with-exit-continuation ;
 
 : param ( name -- value )
     params get at ;
 
+: revalidate-url-key "__u" ;
+
+: check-url ( url -- ? )
+    request get url>>
+    [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
+
+: revalidate-url ( -- url/f )
+    revalidate-url-key param dup [ >url dup check-url swap and ] when ;
+
+: handle-post ( action -- response )
+    '[
+        form-nesting-key params get at " " split
+        [ , (handle-post) ]
+        [ swap '[ , , nest-values ] ] reduce
+        call
+    ] with-exit-continuation
+    [
+        revalidate-url
+        [ flashed-variables <flash-redirect> ] [ <403> ] if*
+    ] unless* ;
+
+: handle-rest ( path action -- assoc )
+    rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
+
+: init-action ( path action -- )
+    blank-values
+    init-validation
+    handle-rest
+    request get request-params assoc-union params set ;
+
+M: action call-responder* ( path action -- response )
+    [ init-action ] keep
+    request get method>> {
+        { "GET" [ handle-get ] }
+        { "HEAD" [ handle-get ] }
+        { "POST" [ handle-post ] }
+    } case ;
+
+M: action modify-form
+    drop request get url>> revalidate-url-key hidden-form-field ;
+
 : check-validation ( -- )
     validation-failed? [ validation-failed ] when ;
 

extra/furnace/asides/asides.factor

@@ -0,0 +1,73 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces sequences arrays kernel
+assocs assocs.lib hashtables math.parser urls combinators
+furnace http http.server http.server.filters furnace.sessions
+html.elements html.templates.chloe.syntax ;
+IN: furnace.asides
+
+TUPLE: asides < filter-responder ;
+
+C: <asides> asides
+
+: begin-aside* ( -- id )
+    request get
+    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
+    asides sget set-at-unique
+    session-changed ;
+
+: end-aside-post ( url post-data -- response )
+    request [
+        clone
+            swap >>post-data
+            swap >>url
+    ] change
+    request get url>> path>> split-path
+    asides get responder>> call-responder ;
+
+ERROR: end-aside-in-get-error ;
+
+: end-aside* ( url id -- response )
+    request get method>> "POST" = [ end-aside-in-get-error ] unless
+    asides sget at [
+        first3 {
+            { "GET" [ drop <redirect> ] }
+            { "HEAD" [ drop <redirect> ] }
+            { "POST" [ end-aside-post ] }
+        } case
+    ] [ <redirect> ] ?if ;
+
+SYMBOL: aside-id
+
+: aside-id-key "__a" ;
+
+: begin-aside ( -- )
+    begin-aside* aside-id set ;
+
+: end-aside ( default -- response )
+    aside-id [ f ] change end-aside* ;
+
+M: asides call-responder*
+    dup asides set
+    aside-id-key request get request-params at aside-id set
+    call-next-method ;
+
+M: asides init-session*
+    H{ } clone asides sset
+    call-next-method ;
+
+M: asides link-attr ( tag -- )
+    drop
+    "aside" optional-attr {
+        { "none" [ aside-id off ] }
+        { "begin" [ begin-aside ] }
+        { "current" [ ] }
+        { f [ ] }
+    } case ;
+
+M: asides modify-query ( query responder -- query' )
+    drop
+    aside-id get [ aside-id-key associate assoc-union ] when* ;
+
+M: asides modify-form ( responder -- )
+    drop aside-id get aside-id-key hidden-form-field ;

extra/furnace/auth/login/login.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors quotations assocs kernel splitting
 combinators sequences namespaces hashtables sets
-fry arrays threads qualified random validators
+fry arrays threads qualified random validators words
 io
 io.sockets
 io.encodings.utf8
@@ -26,14 +26,29 @@ furnace.auth
 furnace.auth.providers
 furnace.auth.providers.db
 furnace.actions
-furnace.flows
+furnace.asides
+furnace.flash
 furnace.sessions
 furnace.boilerplate ;
 QUALIFIED: smtp
 IN: furnace.auth.login
 
+: word>string ( word -- string )
+    [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
+
+: words>strings ( seq -- seq' )
+    [ word>string ] map ;
+
+: string>word ( string -- word )
+    ":" split1 swap lookup ;
+
+: strings>words ( seq -- seq' )
+    [ string>word ] map ;
+
 TUPLE: login < dispatcher users checksum ;
 
+TUPLE: protected < filter-responder description capabilities ;
+
 : users ( -- provider )
     login get users>> ;
 
@@ -64,7 +79,7 @@ M: user-saver dispose
 
 ! ! ! Login
 : successful-login ( user -- response )
-    username>> set-uid URL" $login" end-flow ;
+    username>> set-uid URL" $login" end-aside ;
 
 : login-failed ( -- * )
     "invalid username or password" validation-error
@@ -72,6 +87,13 @@ M: user-saver dispose
 
 : <login-action> ( -- action )
     <page-action>
+        [
+            protected fget [
+                [ description>> "description" set-value ]
+                [ capabilities>> words>strings "capabilities" set-value ] bi
+            ] when*
+        ] >>init
+
         { login "login" } >>template
 
         [
@@ -177,7 +199,7 @@ M: user-saver dispose
 
             drop
 
-            URL" $login" end-flow
+            URL" $login" end-aside
         ] >>submit ;
 
 ! ! ! Password recovery
@@ -290,23 +312,23 @@ SYMBOL: lost-password-from
     <action>
         [
             f set-uid
-            URL" $login" end-flow
+            URL" $login" end-aside
         ] >>submit ;
 
 ! ! ! Authentication logic
-
+: <protected> ( responder -- protected )
-TUPLE: protected < filter-responder capabilities ;
+    protected new
-
+        swap >>responder ;
-C: <protected> protected
 
 : show-login-page ( -- response )
-    begin-flow
+    begin-aside
-    URL" $login/login" <redirect> ;
+    URL" $login/login" { protected } <flash-redirect> ;
 
 : check-capabilities ( responder user -- ? )
     [ capabilities>> ] bi@ subset? ;
 
 M: protected call-responder* ( path responder -- response )
+    dup protected set
     uid dup [
         users get-user 2dup check-capabilities [
             [ logged-in-user set ] [ save-user-after ] bi
@@ -337,7 +359,9 @@ M: login call-responder* ( path responder -- response )
 ! ! ! Configuration
 
 : allow-edit-profile ( login -- login )
-    <edit-profile-action> f <protected> <login-boilerplate>
+    <edit-profile-action> <protected>
+        "edit your profile" >>description
+    <login-boilerplate>
         "edit-profile" add-responder ;
 
 : allow-registration ( login -- login )

extra/furnace/auth/login/login.xml

@@ -4,6 +4,19 @@
 
 	<t:title>Login</t:title>
 
+	<t:if t:value="description">
+		<p>You must log in to <t:label t:name="description" />.</p>
+	</t:if>
+
+	<t:if t:value="capabilities">
+		<p>Your user must have the following capabilities:</p>
+		<ul>
+			<t:each t:name="capabilities">
+				<li><t:label t:name="value" /></li>
+			</t:each>
+		</ul>
+	</t:if>
+
 	<t:form t:action="login">
 
 		<table>

extra/furnace/flash/flash.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs assocs.lib kernel sequences urls
+http http.server http.server.filters http.server.redirection
+furnace furnace.sessions ;
+IN: furnace.flash
+
+: flash-id-key "__f" ;
+
+TUPLE: flash-scopes < filter-responder ;
+
+C: <flash-scopes> flash-scopes
+
+SYMBOL: flash-scope
+
+: fget ( key -- value ) flash-scope get at ;
+
+M: flash-scopes call-responder*
+    flash-id-key
+    request get request-params at
+    flash-scopes sget at flash-scope set
+    call-next-method ;
+
+M: flash-scopes init-session*
+    H{ } clone flash-scopes sset
+    call-next-method ;
+
+: make-flash-scope ( seq -- id )
+    [ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
+    session-changed ;
+
+: <flash-redirect> ( url seq -- response )
+    make-flash-scope
+    [ clone ] dip flash-id-key set-query-param
+    <redirect> ;
+
+: restore-flash ( seq -- )
+    [ flash-scope get key? ] filter [ [ fget ] keep set ] each ;

extra/furnace/flows/flows.factor

@@ -1,78 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces sequences arrays kernel
-assocs assocs.lib hashtables math.parser urls combinators
-furnace http http.server http.server.filters furnace.sessions
-html.elements html.templates.chloe.syntax ;
-IN: furnace.flows
-
-TUPLE: flows < filter-responder ;
-
-C: <flows> flows
-
-: begin-flow* ( -- id )
-    request get
-    [ url>> ] [ post-data>> ] [ method>> ] tri 3array
-    flows sget set-at-unique
-    session-changed ;
-
-: end-flow-post ( url post-data -- response )
-    request [
-        clone
-            "POST" >>method
-            swap >>post-data
-            swap >>url
-    ] change
-    request get url>> path>> split-path
-    flows get responder>> call-responder ;
-
-: end-flow* ( url id -- response )
-    flows sget at [
-        first3 {
-            { "GET" [ drop <redirect> ] }
-            { "HEAD" [ drop <redirect> ] }
-            { "POST" [ end-flow-post ] }
-        } case
-    ] [ <redirect> ] ?if ;
-
-SYMBOL: flow-id
-
-: flow-id-key "factorflowid" ;
-
-: begin-flow ( -- )
-    begin-flow* flow-id set ;
-
-: end-flow ( default -- response )
-    flow-id get end-flow* ;
-
-M: flows call-responder*
-    dup flows set
-    flow-id-key request get request-params at flow-id set
-    call-next-method ;
-
-M: flows init-session*
-    H{ } clone flows sset
-    call-next-method ;
-
-M: flows link-attr ( tag -- )
-    drop
-    "flow" optional-attr {
-        { "none" [ flow-id off ] }
-        { "begin" [ begin-flow ] }
-        { "current" [ ] }
-        { f [ ] }
-    } case ;
-
-M: flows modify-query ( query responder -- query' )
-    drop
-    flow-id get [ flow-id-key associate assoc-union ] when* ;
-
-M: flows hidden-form-field ( responder -- )
-    drop
-    flow-id get [
-        <input
-            "hidden" =type
-            flow-id-key =name
-            =value
-        input/>
-    ] when* ;

extra/furnace/furnace-tests.factor

@@ -1,6 +1,7 @@
 IN: furnace.tests
 USING: http.server.dispatchers http.server.responses
-http.server furnace tools.test kernel namespaces accessors ;
+http.server furnace tools.test kernel namespaces accessors
+io.streams.string ;
 TUPLE: funny-dispatcher < dispatcher ;
 
 : <funny-dispatcher> funny-dispatcher new-dispatcher ;
@@ -28,3 +29,7 @@ M: base-path-check-responder call-responder*
     V{ } responder-nesting set
     "a/b/c" split-path main-responder get call-responder body>>
 ] unit-test
+
+[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ]
+[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+unit-test

extra/furnace/furnace.factor

@@ -2,12 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel combinators assocs
 continuations namespaces sequences splitting words
-vocabs.loader classes
+vocabs.loader classes strings
-fry urls multiline
+fry urls multiline present
 xml
 xml.data
+xml.entities
 xml.writer
-xml.utilities
 html.components
 html.elements
 html.templates
@@ -19,6 +19,7 @@ http.server.redirection
 http.server.responses
 qualified ;
 QUALIFIED-WITH: assocs a
+EXCLUDE: xml.utilities => children>string ;
 IN: furnace
 
 : nested-responders ( -- seq )
@@ -51,12 +52,16 @@ GENERIC: modify-query ( query responder -- query' )
 
 M: object modify-query drop ;
 
-: adjust-url ( url -- url' )
+GENERIC: adjust-url ( url -- url' )
+
+M: url adjust-url
     clone
         [ [ modify-query ] each-responder ] change-query
         [ resolve-base-path ] change-path
     relative-to-request ;
 
+M: string adjust-url ;
+
 : <redirect> ( url -- response )
     adjust-url request get method>> {
         { "GET" [ <temporary-redirect> ] }
@@ -64,15 +69,19 @@ M: object modify-query drop ;
         { "POST" [ <permanent-redirect> ] }
     } case ;
 
-GENERIC: hidden-form-field ( responder -- )
+GENERIC: modify-form ( responder -- )
 
-M: object hidden-form-field drop ;
+M: object modify-form drop ;
 
 : request-params ( request -- assoc )
     dup method>> {
         { "GET" [ url>> query>> ] }
         { "HEAD" [ url>> query>> ] }
-        { "POST" [ post-data>> ] }
+        { "POST" [
+            post-data>>
+            dup content-type>> "application/x-www-form-urlencoded" =
+            [ content>> ] [ drop f ] if
+        ] }
     } case ;
 
 SYMBOL: exit-continuation
@@ -88,7 +97,7 @@ SYMBOL: exit-continuation
     [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
 
 CHLOE: atom
-    [ "title" required-attr ]
+    [ children>string ]
     [ "href" required-attr ]
     [ "query" optional-attr parse-query-attr ] tri
     <url>
@@ -128,6 +137,22 @@ CHLOE: a
     [ drop </a> ]
     tri ;
 
+: hidden-form-field ( value name -- )
+    over [
+        <input
+            "hidden" =type
+            =name
+            present =value
+        input/>
+    ] [ 2drop ] if ;
+
+: form-nesting-key "__n" ;
+
+: form-magic ( tag -- )
+    [ modify-form ] each-responder
+    nested-values get " " join f like form-nesting-key hidden-form-field
+    "for" optional-attr [ hidden render ] when* ;
+
 : form-start-tag ( tag -- )
     [
         [
@@ -138,10 +163,8 @@ CHLOE: a
                 [ tag-attrs non-chloe-attrs-only print-attrs ]
                 tri
             form>
-        ] [
+        ]
-            [ hidden-form-field ] each-responder
+        [ form-magic ] bi
-            "for" optional-attr [ hidden render ] when*
-        ] bi
     ] with-scope ;
 
 CHLOE: form
@@ -167,17 +190,3 @@ CHLOE: button
         [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
         [ nip ]
     } 2cleave process-chloe-tag ;
-
-: attr>word ( value -- word/f )
-    dup ":" split1 swap lookup
-    [ ] [ "No such word: " swap append throw ] ?if ;
-
-: attr>var ( value -- word/f )
-    attr>word dup symbol? [
-        "Must be a symbol: " swap append throw
-    ] unless ;
-
-: if-satisfied? ( tag -- ? )
-    "code" required-attr attr>word execute ;
-
-CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;

extra/furnace/rss/rss.factor

@@ -1,14 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel fry
-rss http.server.responses furnace.actions ;
-IN: furnace.rss
-
-: <feed-content> ( body -- response )
-    feed>xml "application/atom+xml" <content> ;
-
-TUPLE: feed-action < action feed ;
-
-: <feed-action> ( -- feed )
-    feed-action new-action
-        dup '[ , feed>> call <feed-content> ] >>display ;

extra/furnace/sessions/sessions.factor

@@ -109,14 +109,14 @@ M: session-saver dispose
     [ session set ] [ save-session-after ] bi
     sessions get responder>> call-responder ;
 
-: session-id-key "factorsessid" ;
+: session-id-key "__s" ;
 
 : cookie-session-id ( request -- id/f )
     session-id-key get-cookie
     dup [ value>> string>number ] when ;
 
 : post-session-id ( request -- id/f )
-    session-id-key swap post-data>> at string>number ;
+    session-id-key swap request-params at string>number ;
 
 : request-session-id ( -- id/f )
     request get dup method>> {
@@ -137,13 +137,8 @@ M: session-saver dispose
 : put-session-cookie ( response -- response' )
     session get id>> number>string <session-cookie> put-cookie ;
 
-M: sessions hidden-form-field ( responder -- )
+M: sessions modify-form ( responder -- )
-    drop
+    drop session get id>> session-id-key hidden-form-field ;
-    <input
-        "hidden" =type
-        session-id-key =name
-        session get id>> number>string =value
-    input/> ;
 
 M: sessions call-responder* ( path responder -- response )
     sessions set

extra/furnace/syndication/syndication.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences fry sequences.lib
+combinators syndication
+http.server.responses http.server.redirection
+furnace furnace.actions ;
+IN: furnace.syndication
+
+GENERIC: feed-entry-title ( object -- string )
+
+GENERIC: feed-entry-date ( object -- timestamp )
+
+GENERIC: feed-entry-url ( object -- url )
+
+GENERIC: feed-entry-description ( object -- description )
+
+M: object feed-entry-description drop f ;
+
+GENERIC: >entry ( object -- entry )
+
+M: entry >entry ;
+
+M: object >entry
+    <entry>
+        swap {
+            [ feed-entry-title >>title ]
+            [ feed-entry-date >>date ]
+            [ feed-entry-url >>url ]
+            [ feed-entry-description >>description ]
+        } cleave ;
+
+: process-entries ( seq -- seq' )
+    20 short head-slice [
+        >entry clone
+        [ adjust-url relative-to-request ] change-url
+    ] map ;
+
+: <feed-content> ( body -- response )
+    feed>xml "application/atom+xml" <content> ;
+
+TUPLE: feed-action < action title url entries ;
+
+: <feed-action> ( -- action )
+    feed-action new-action
+        dup '[
+            feed new
+                ,
+                [ title>> call >>title ]
+                [ url>> call adjust-url relative-to-request >>url ]
+                [ entries>> call process-entries >>entries ]
+                tri
+            <feed-content>
+        ] >>display ;

extra/globs/globs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators regexp lazy-lists sequences kernel
+USING: parser-combinators regexp lists sequences kernel
 promises strings unicode.case ;
 IN: globs
 

extra/html/components/components-tests.factor

@@ -17,8 +17,6 @@ TUPLE: color red green blue ;
 
 [ ] [ "jimmy" "red" set-value ] unit-test
 
-[ "123.5" ] [ 123.5 object>string ] unit-test
-
 [ "jimmy" ] [
     [
         "red" label render

extra/html/components/components.factor

@@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting
 mirrors hashtables combinators continuations math strings
 fry locals calendar calendar.format xml.entities validators
 html.elements html.streams xmode.code2html farkup inspector
-lcs.diff2html urls ;
+lcs.diff2html urls present ;
 IN: html.components
 
 SYMBOL: values
@@ -29,22 +29,36 @@ SYMBOL: values
 : deposit-slots ( destination names -- )
     [ <mirror> ] dip deposit-values ;
 
-: with-each-index ( seq quot -- )
+: with-each-value ( name quot -- )
-    '[
+    [ value ] dip '[
         [
             values [ clone ] change
-            1+ "index" set-value @
+            1+ "index" set-value
+            "value" set-value
+            @
         ] with-scope
     ] each-index ; inline
 
-: with-each-value ( seq quot -- )
+: with-each-object ( name quot -- )
-    '[ "value" set-value @ ] with-each-index ; inline
+    [ value ] dip '[
+        [
+            blank-values
+            1+ "index" set-value
+            from-object
+            @
+        ] with-scope
+    ] each-index ; inline
 
-: with-each-object ( seq quot -- )
+SYMBOL: nested-values
-    '[ from-object @ ] with-each-index ; inline
 
-: with-values ( object quot -- )
+: with-values ( name quot -- )
-    '[ blank-values , from-object @ ] with-scope ; inline
+    '[
+        ,
+        [ nested-values [ swap prefix ] change ]
+        [ value blank-values from-object ]
+        bi
+        @
+    ] with-scope ; inline
 
 : nest-values ( name quot -- )
     swap [
@@ -67,13 +81,13 @@ GENERIC: render* ( value name render -- )
 <PRIVATE
 
 : render-input ( value name type -- )
-    <input =type =name object>string =value input/> ;
+    <input =type =name present =value input/> ;
 
 PRIVATE>
 
 SINGLETON: label
 
-M: label render* 2drop object>string escape-string write ;
+M: label render* 2drop present escape-string write ;
 
 SINGLETON: hidden
 
@@ -82,9 +96,9 @@ M: hidden render* drop "hidden" render-input ;
 : render-field ( value name size type -- )
     <input
         =type
-        [ object>string =size ] when*
+        [ present =size ] when*
         =name
-        object>string =value
+        present =value
     input/> ;
 
 TUPLE: field size ;
@@ -111,11 +125,11 @@ TUPLE: textarea rows cols ;
 
 M: textarea render*
     <textarea
-        [ rows>> [ object>string =rows ] when* ]
+        [ rows>> [ present =rows ] when* ]
-        [ cols>> [ object>string =cols ] when* ] bi
+        [ cols>> [ present =cols ] when* ] bi
         =name
     textarea>
-        object>string escape-string write
+        present escape-string write
     </textarea> ;
 
 ! Choice
@@ -126,7 +140,7 @@ TUPLE: choice size multiple choices ;
 
 : render-option ( text selected? -- )
     <option [ "true" =selected ] when option>
-        object>string escape-string write
+        present escape-string write
     </option> ;
 
 : render-options ( options selected -- )
@@ -135,7 +149,7 @@ TUPLE: choice size multiple choices ;
 M: choice render*
     <select
         swap =name
-        dup size>> [ object>string =size ] when*
+        dup size>> [ present =size ] when*
         dup multiple>> [ "true" =multiple ] when
     select>
         [ choices>> value ] [ multiple>> ] bi
@@ -162,12 +176,18 @@ M: checkbox render*
 GENERIC: link-title ( obj -- string )
 GENERIC: link-href ( obj -- url )
 
+M: string link-title ;
+M: string link-href ;
+
+M: url link-title ;
+M: url link-href ;
+
 SINGLETON: link
 
 M: link render*
     2drop
     <a dup link-href =href a>
-        link-title object>string escape-string write
+        link-title present escape-string write
     </a> ;
 
 ! XMode code component

extra/html/elements/elements.factor

@@ -5,7 +5,7 @@
 
 USING: io kernel namespaces prettyprint quotations
 sequences strings words xml.entities compiler.units effects
-urls math math.parser combinators calendar calendar.format ;
+urls math math.parser combinators present ;
 
 IN: html.elements
 
@@ -127,22 +127,11 @@ SYMBOL: html
     dup def-for-html-word-<foo
     def-for-html-word-foo/> ;
 
-: object>string ( object -- string )
-    #! Should this be generic and in the core?
-    {
-        { [ dup real? ] [ number>string ] }
-        { [ dup timestamp? ] [ timestamp>string ] }
-        { [ dup url? ] [ url>string ] }
-        { [ dup string? ] [ ] }
-        { [ dup word? ] [ word-name ] }
-        { [ dup not ] [ drop "" ] }
-    } cond ;
-
 : write-attr ( value name -- )
     " " write-html
     write-html
     "='" write-html
-    object>string escape-quoted-string write-html
+    present escape-quoted-string write-html
     "'" write-html ;
 
 : attribute-effect T{ effect f { "string" } 0 } ;

extra/html/templates/chloe/chloe-tests.factor

@@ -148,3 +148,35 @@ TUPLE: person first-name last-name ;
         "test9" test-template call-template
     ] run-template
 ] unit-test
+
+[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
+
+[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
+    [
+        "test10" test-template call-template
+    ] run-template
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+    H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
+    [
+        "test11" test-template call-template
+    ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+    blank-values
+    { "a" "b" } "choices" set-value
+    "true" "b" set-value
+] unit-test
+
+[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
+    [
+        "test12" test-template call-template
+    ] run-template
+] unit-test

extra/html/templates/chloe/chloe.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel sequences combinators kernel namespaces
 classes.tuple assocs splitting words arrays memoize
 io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry math urls
+unicode.case tuple-syntax mirrors fry math urls present
 multiline xml xml.data xml.writer xml.utilities
 html.elements
 html.components
@@ -68,7 +68,7 @@ CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
 
 : (bind-tag) ( tag quot -- )
     [
-        [ "name" required-attr value ] keep
+        [ "name" required-attr ] keep
         '[ , process-tag-children ]
     ] dip call ; inline
 
@@ -85,6 +85,17 @@ CHLOE: comment drop ;
 
 CHLOE: call-next-template drop call-next-template ;
 
+: attr>word ( value -- word/f )
+    dup ":" split1 swap lookup
+    [ ] [ "No such word: " swap append throw ] ?if ;
+
+: if-satisfied? ( tag -- ? )
+    [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+    [ "value" optional-attr [ value ] [ t ] if* ]
+    bi and ;
+
+CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
 CHLOE-SINGLETON: label
 CHLOE-SINGLETON: link
 CHLOE-SINGLETON: farkup
@@ -116,7 +127,7 @@ CHLOE-TUPLE: code
 : expand-attrs ( tag -- tag )
     dup [ tag? ] is? [
         clone [
-            [ "@" ?head [ value object>string ] when ] assoc-map
+            [ "@" ?head [ value present ] when ] assoc-map
         ] change-attrs
     ] when ;
 

extra/html/templates/chloe/test/test10.xml

@@ -0,0 +1,3 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>

extra/html/templates/chloe/test/test11.xml

@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<table>
+		<t:bind t:name="person">
+			<tr>
+				<td><t:label t:name="first-name"/></td>
+				<td><t:label t:name="last-name"/></td>
+			</tr>
+		</t:bind>
+	</table>
+
+</t:chloe>

extra/html/templates/chloe/test/test12.xml

@@ -0,0 +1,3 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>

extra/http/client/client.factor

@@ -22,7 +22,7 @@ DEFER: http-request
 SYMBOL: redirects
 
 : redirect-url ( request url -- request )
-    '[ , >url derive-url ensure-port ] change-url ;
+    '[ , >url ensure-port derive-url ensure-port ] change-url ;
 
 : do-redirect ( response data -- response data )
     over code>> 300 399 between? [
@@ -100,12 +100,11 @@ M: download-failed error.
 : download ( url -- )
     dup download-name download-to ;
 
-: <post-request> ( content-type content url -- request )
+: <post-request> ( post-data url -- request )
     <request>
         "POST" >>method
         swap >url ensure-port >>url
-        swap >>post-data
+        swap >>post-data ;
-        swap >>post-data-type ;
 
-: http-post ( content-type content url -- response data )
+: http-post ( post-data url -- response data )
     <post-request> http-request ;

extra/http/http-tests.factor

@@ -1,15 +1,16 @@
 USING: http tools.test multiline tuple-syntax
 io.streams.string kernel arrays splitting sequences
-assocs io.sockets db db.sqlite continuations urls ;
+assocs io.sockets db db.sqlite continuations urls hashtables ;
 IN: http.tests
 
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
-GET http://foo/bar HTTP/1.1
+POST http://foo/bar HTTP/1.1
 Some-Header: 1
 Some-Header: 2
 Content-Length: 4
+Content-type: application/octet-stream
 
 blah
 ;
@@ -17,10 +18,10 @@ blah
 [
     TUPLE{ request
         url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
-        method: "GET"
+        method: "POST"
         version: "1.1"
-        header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
+        header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
-        post-data: "blah"
+        post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
         cookies: V{ }
     }
 ] [
@@ -30,8 +31,9 @@ blah
 ] unit-test
 
 STRING: read-request-test-1'
-GET /bar HTTP/1.1
+POST /bar HTTP/1.1
 content-length: 4
+content-type: application/octet-stream
 some-header: 1; 2
 
 blah
@@ -87,7 +89,7 @@ blah
         code: 404
         message: "not found"
         header: H{ { "content-type" "text/html; charset=UTF8" } }
-        cookies: V{ }
+        cookies: { }
         content-type: "text/html"
         content-charset: "UTF8"
     }
@@ -172,7 +174,7 @@ test-db [
 [ ] [
     [
         <dispatcher>
-            <action> f <protected>
+            <action> <protected>
             <login>
             <sessions>
             "" add-responder
@@ -219,3 +221,56 @@ test-db [
 [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
 
 [ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
+
+USING: html.components html.elements xml xml.utilities validators
+furnace furnace.flash ;
+
+SYMBOL: a
+
+[ ] [
+    [
+        <dispatcher>
+            <action>
+                [ a get-global "a" set-value ] >>init
+                [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+                [ { { "a" [ v-integer ] } } validate-params ] >>validate
+                [ "a" value a set-global URL" " <redirect> ] >>submit
+            <flash-scopes>
+            <sessions>
+            >>default
+            add-quit-action
+        test-db <db-persistence>
+        main-responder set
+
+        [ 1237 httpd ] "HTTPD test" spawn drop
+    ] with-scope
+] unit-test
+
+[ ] [ 100 sleep ] unit-test
+
+3 a set-global
+
+: test-a string>xml "input" tag-named "value" swap at ;
+
+[ "3" ] [
+    "http://localhost:1237/" http-get*
+    swap dup cookies>> "cookies" set session-id-key get-cookie
+    value>> "session-id" set test-a
+] unit-test
+
+[ "4" ] [
+    H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+! Test flash scope
+[ "xyz" ] [
+    H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+] unit-test
+
+[ 4 ] [ a get-global ] unit-test
+
+[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test

extra/http/http.factor

@@ -4,13 +4,13 @@ USING: accessors kernel combinators math namespaces
 
 assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
-math.parser calendar calendar.format
+math.parser calendar calendar.format present
 
 io io.server io.sockets.secure
 
 unicode.case unicode.categories qualified
 
-urls html.templates ;
+urls html.templates xml xml.data xml.writer ;
 
 EXCLUDE: fry => , ;
 
@@ -54,11 +54,9 @@ IN: http
 
 : header-value>string ( value -- string )
     {
-        { [ dup number? ] [ number>string ] }
         { [ dup timestamp? ] [ timestamp>http-string ] }
-        { [ dup url? ] [ url>string ] }
+        { [ dup array? ] [ [ header-value>string ] map "; " join ] }
-        { [ dup string? ] [ ] }
+        [ present ]
-        { [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
     } cond ;
 
 : check-header-string ( str -- str )
@@ -132,7 +130,6 @@ url
 version
 header
 post-data
-post-data-type
 cookies ;
 
 : set-header ( request/response value key -- request/response )
@@ -177,19 +174,27 @@ cookies ;
 : header ( request/response key -- value )
     swap header>> at ;
 
-SYMBOL: max-post-request
+TUPLE: post-data raw content content-type ;
 
-1024 256 * max-post-request set-global
+: <post-data> ( raw content-type -- post-data )
+    post-data new
+        swap >>content-type
+        swap >>raw ;
 
-: content-length ( header -- n )
+: parse-post-data ( post-data -- post-data )
-    "content-length" swap at string>number dup [
+    [ ] [ raw>> ] [ content-type>> ] tri {
-        dup max-post-request get > [
+        { "application/x-www-form-urlencoded" [ query>assoc ] }
-            "content-length > max-post-request" throw
+        { "text/xml" [ string>xml ] }
-        ] when
+        [ drop ]
-    ] when ;
+    } case >>content ;
 
 : read-post-data ( request -- request )
-    dup header>> content-length [ read >>post-data ] when* ;
+    dup method>> "POST" = [
+        [ ]
+        [ "content-length" header string>number read ]
+        [ "content-type" header ] tri
+        <post-data> parse-post-data >>post-data
+    ] when ;
 
 : extract-host ( request -- request )
     [ ] [ url>> ] [ "host" header parse-host ] tri
@@ -197,13 +202,6 @@ SYMBOL: max-post-request
     ensure-port
     drop ;
 
-: extract-post-data-type ( request -- request )
-    dup "content-type" header >>post-data-type ;
-
-: parse-post-data ( request -- request )
-    dup post-data-type>> "application/x-www-form-urlencoded" =
-    [ dup post-data>> query>assoc >>post-data ] when ;
-
 : extract-cookies ( request -- request )
     dup "cookie" header [ parse-cookies >>cookies ] when* ;
 
@@ -225,25 +223,17 @@ SYMBOL: max-post-request
     read-post-data
     detect-protocol
     extract-host
-    extract-post-data-type
-    parse-post-data
     extract-cookies ;
 
 : write-method ( request -- request )
     dup method>> write bl ;
 
 : write-request-url ( request -- request )
-    dup url>> relative-url url>string write bl ;
+    dup url>> relative-url present write bl ;
 
 : write-version ( request -- request )
     "HTTP/" write dup request-version write crlf ;
 
-: unparse-post-data ( request -- request )
-    dup post-data>> dup sequence? [ drop ] [
-        assoc>query >>post-data
-        "application/x-www-form-urlencoded" >>post-data-type
-    ] if ;
-
 : url-host ( url -- string )
     [ host>> ] [ port>> ] bi dup "http" protocol-port =
     [ drop ] [ ":" swap number>string 3append ] if ;
@@ -251,13 +241,33 @@ SYMBOL: max-post-request
 : write-request-header ( request -- request )
     dup header>> >hashtable
     over url>> host>> [ over url>> url-host "host" pick set-at ] when
-    over post-data>> [ length "content-length" pick set-at ] when*
+    over post-data>> [
-    over post-data-type>> [ "content-type" pick set-at ] when*
+        [ raw>> length "content-length" pick set-at ]
+        [ content-type>> "content-type" pick set-at ]
+        bi
+    ] when*
     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
     write-header ;
 
+GENERIC: >post-data ( object -- post-data )
+
+M: post-data >post-data ;
+
+M: string >post-data "application/octet-stream" <post-data> ;
+
+M: byte-array >post-data "application/octet-stream" <post-data> ;
+
+M: xml >post-data xml>string "text/xml" <post-data> ;
+
+M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
+
+M: f >post-data ;
+
+: unparse-post-data ( request -- request )
+    [ >post-data ] change-post-data ;
+
 : write-post-data ( request -- request )
-    dup post-data>> [ write ] when* ;
+    dup method>> "POST" = [ dup post-data>> raw>> write ] when ; 
 
 : write-request ( request -- )
     unparse-post-data
@@ -307,7 +317,7 @@ body ;
 
 : read-response-header
     read-header >>header
-    extract-cookies
+    dup "set-cookie" header parse-cookies >>cookies
     dup "content-type" header [
         parse-content-type [ >>content-type ] [ >>content-charset ] bi*
     ] when* ;

extra/http/server/cgi/cgi.factor

@@ -35,8 +35,10 @@ IN: http.server.cgi
         request get "accept" header "HTTP_ACCEPT" set
 
         post? [
-            request get post-data-type>> "CONTENT_TYPE" set
+            request get post-data>> raw>>
-            request get post-data>> length number>string "CONTENT_LENGTH" set
+            [ "CONTENT_TYPE" set ]
+            [ length number>string "CONTENT_LENGTH" set ]
+            bi
         ] when
     ] H{ } make-assoc ;
 
@@ -51,7 +53,7 @@ IN: http.server.cgi
     "CGI output follows" >>message
     swap '[
         , output-stream get swap <cgi-process> <process-stream> [
-            post? [ request get post-data>> write flush ] when
+            post? [ request get post-data>> raw>> write flush ] when
             input-stream get swap (stream-copy)
         ] with-stream
     ] >>body ;

extra/http/server/dispatchers/dispatchers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces sequences assocs accessors
+USING: kernel namespaces sequences assocs accessors splitting
-http http.server http.server.responses ;
+unicode.case http http.server http.server.responses ;
 IN: http.server.dispatchers
 
 TUPLE: dispatcher default responders ;
@@ -31,8 +31,11 @@ TUPLE: vhost-dispatcher default responders ;
 : <vhost-dispatcher> ( -- dispatcher )
     vhost-dispatcher new-dispatcher ;
 
+: canonical-host ( host -- host' )
+    >lower "www." ?head drop "." ?tail drop ;
+
 : find-vhost ( dispatcher -- responder )
-    request get url>> host>> over responders>> at*
+    request get url>> host>> canonical-host over responders>> at*
     [ nip ] [ drop default>> ] if ;
 
 M: vhost-dispatcher call-responder* ( path dispatcher -- response )

extra/http/server/redirection/redirection-tests.factor

@@ -1,6 +1,6 @@
 IN: http.server.redirection.tests
 USING: http http.server.redirection urls accessors
-namespaces tools.test ;
+namespaces tools.test present ;
 
 \ relative-to-request must-infer
 
@@ -15,34 +15,34 @@ namespaces tools.test ;
     request set
 
     [ "http://www.apple.com:80/xxx/bar" ] [ 
-        <url> relative-to-request url>string 
+        <url> relative-to-request present 
     ] unit-test
 
     [ "http://www.apple.com:80/xxx/baz" ] [
-        <url> "baz" >>path relative-to-request url>string
+        <url> "baz" >>path relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/xxx/baz?c=d" ] [
-        <url> "baz" >>path { { "c" "d" } } >>query relative-to-request url>string
+        <url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/xxx/bar?c=d" ] [
-        <url> { { "c" "d" } } >>query relative-to-request url>string
+        <url> { { "c" "d" } } >>query relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/flip" ] [
-        <url> "/flip" >>path relative-to-request url>string
+        <url> "/flip" >>path relative-to-request present
     ] unit-test
     
     [ "http://www.apple.com:80/flip?c=d" ] [
-        <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request url>string
+        <url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
     ] unit-test
     
     [ "http://www.jedit.org:80/" ] [
-        "http://www.jedit.org" >url relative-to-request url>string
+        "http://www.jedit.org" >url relative-to-request present
     ] unit-test
     
     [ "http://www.jedit.org:80/?a=b" ] [
-        "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request url>string
+        "http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
     ] unit-test
 ] with-scope

extra/http/server/server-tests.factor

@@ -0,0 +1,4 @@
+USING: http http.server math sequences continuations tools.test ;
+IN: http.server.tests
+
+[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test

extra/http/server/server.factor

@@ -22,7 +22,7 @@ C: <trivial-responder> trivial-responder
 
 M: trivial-responder call-responder* nip response>> clone ;
 
-main-responder global [ <404> <trivial-responder> get-global or ] change-at
+main-responder global [ <404> <trivial-responder> or ] change-at
 
 : invert-slice ( slice -- slice' )
     dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
@@ -40,7 +40,7 @@ main-responder global [ <404> <trivial-responder> get-global or ] change-at
 
 : <500> ( error -- response )
     500 "Internal server error" <trivial-response>
-    development-mode get [ swap '[ , http-error. ] >>body ] [ drop ] if ;
+    swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
 
 : do-response ( response -- )
     dup write-response

extra/io/unix/launcher/parser/parser.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: peg peg.parsers kernel sequences strings words
+USING: peg peg.parsers kernel sequences strings words ;
-memoize ;
 IN: io.unix.launcher.parser
 
 ! Our command line parser. Supported syntax:
@@ -9,20 +8,20 @@ IN: io.unix.launcher.parser
 ! foo\ bar -- escaping the space
 ! 'foo bar' -- quotation
 ! "foo bar" -- quotation
-MEMO: 'escaped-char' ( -- parser )
+: 'escaped-char' ( -- parser )
-    "\\" token [ drop t ] satisfy 2seq [ second ] action ;
+    "\\" token any-char 2seq [ second ] action ;
 
-MEMO: 'quoted-char' ( delimiter -- parser' )
+: 'quoted-char' ( delimiter -- parser' )
     'escaped-char'
     swap [ member? not ] curry satisfy
     2choice ; inline
 
-MEMO: 'quoted' ( delimiter -- parser )
+: 'quoted' ( delimiter -- parser )
     dup 'quoted-char' repeat0 swap dup surrounded-by ;
 
-MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
+: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
 
-MEMO: 'argument' ( -- parser )
+: 'argument' ( -- parser )
     "\"" 'quoted'
     "'" 'quoted'
     'unquoted' 3choice

extra/jamshred/gl/gl.factor

@@ -1,8 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types colors jamshred.game jamshred.oint
+USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ;
-jamshred.player jamshred.tunnel kernel math math.vectors opengl
-opengl.gl opengl.glu sequences ;
 IN: jamshred.gl
 
 : min-vertices 6 ; inline
@@ -14,6 +12,35 @@ IN: jamshred.gl
 : n-segments-ahead ( -- n ) 60 ; inline
 : n-segments-behind ( -- n ) 40 ; inline
 
+: wall-drawing-offset ( -- n )
+    #! so that we can't see through the wall, we draw it a bit further away
+    0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+    radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+    [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+    [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+    [
+        [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+    ] [
+        location>> v+
+    ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+    location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+    swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+    #! return a sequence of n numbers between 0 and 2pi
+    dup [ / pi 2 * * ] curry map ;
 : draw-segment-vertex ( segment theta -- )
     over segment-color gl-color segment-vertex-and-normal
     gl-normal gl-vertex ;

extra/jamshred/jamshred.factor

@@ -88,7 +88,7 @@ jamshred-gadget H{
     { T{ mouse-scroll } [ handle-mouse-scroll ] }
 } set-gestures
 
-: jamshred-window ( -- )
+: jamshred-window ( -- jamshred )
-    [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
+    [ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
 
 MAIN: jamshred-window

extra/jamshred/oint/oint.factor

@@ -39,8 +39,11 @@ C: <oint> oint
 : random-turn ( oint theta -- )
     2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
 
+: location+ ( v oint -- )
+    [ location>> v+ ] [ (>>location) ] bi ;
+
 : go-forward ( distance oint -- )
-    [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
+    [ forward>> n*v ] [ location+ ] bi ;
 
 : distance-vector ( oint oint -- vector )
     [ location>> ] bi@ swap v- ;
@@ -62,3 +65,9 @@ C: <oint> oint
 :: reflect ( v n -- v' )
     #! bounce v on a surface with normal n
     v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+    over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+    [ location>> ] bi@ half-way ;

extra/jamshred/player/player.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
+USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ;
+USE: tools.walker
 IN: jamshred.player
 
 TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
@@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
     [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
     [ (>>nearest-segment) ] tri ;
 
+: update-time ( player -- seconds-passed )
+    millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
 : moved ( player -- ) millis swap (>>last-move) ;
 
 : speed-range ( -- range )
@@ -41,38 +45,82 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
 : multiply-player-speed ( n player -- )
     [ * speed-range clamp-to-range ] change-speed drop ; 
 
-: distance-to-move ( player -- distance )
+: distance-to-move ( seconds-passed player -- distance )
-    [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+    speed>> * ;
-    [ (>>last-move) ] tri ;
 
-DEFER: (move-player)
+: bounce ( d-left player -- d-left' player )
-
-: ?bounce ( distance-remaining player -- )
-    over 0 > [
     {
-            [ dup nearest-segment>> bounce ]
+        [ dup nearest-segment>> bounce-off-wall ]
         [ sounds>> bang ]
         [ 3/4 swap multiply-player-speed ]
-            [ (move-player) ]
+        [ ]
-        } cleave
+    } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+    player nearest-segment>>
+    player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+    player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+    (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+    (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+    dup nearest-segment>> (distance-to-collision) ;
+
+: from ( player -- radius distance-from-centre )
+    [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+    distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+    fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+    2dup distance-to-heading-segment-area 0 <= [
+        [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+        [ (>>nearest-segment) ] tri
     ] [
         2drop
     ] if ;
 
-: move-player-distance ( distance-remaining player distance -- distance-remaining player )
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
-    pick min tuck over go-forward [ - ] dip ;
+    [let* | d-to-move [ d-left distance min ]
+            move-v [ d-to-move heading n*v ] |
+        move-v player location+
+        heading player update-nearest-segment2
+        d-left d-to-move - player ] ;
 
-: (move-player) ( distance-remaining player -- )
+: move-toward-wall ( d-left player d-to-wall -- d-left' player )
-    over 0 <= [
+    over [ forward>> ] keep distance-to-heading-segment-area min
-        2drop
+    over forward>> move-player-on-heading ;
-    ] [
+
-        dup dup nearest-segment>> distance-to-collision
+: ?move-player-freely ( d-left player -- d-left' player )
-        move-player-distance ?bounce
+    over 0 > [
-    ] if ;
+        dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
+            move-toward-wall ?move-player-freely
+        ] [ drop ] if
+    ] when ;
+
+: drag-heading ( player -- heading )
+    [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+    dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+    [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+    ?move-player-freely over 0 > [
+        ! bounce
+        drag-player
+        (move-player)
+    ] when ;
 
 : move-player ( player -- )
-    [ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
+    [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
 
 : update-player ( player -- )
-    dup move-player nearest-segment>>
+    [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
-    white swap set-segment-color ;

extra/jamshred/tunnel/tunnel-tests.factor

@@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests
 [ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
 [ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
 [ { 0 1 0 } ]
-[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test

extra/jamshred/tunnel/tunnel.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Alex Chapman
+! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USE: tools.walker
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline
@@ -8,21 +9,6 @@ IN: jamshred.tunnel
 TUPLE: segment < oint number color radius ;
 C: <segment> segment
 
-: segment-vertex ( theta segment -- vertex )
-     tuck 2dup up>> swap sin v*n
-     >r left>> swap cos v*n r> v+
-     swap location>> v+ ;
-
-: segment-vertex-normal ( vertex segment -- normal )
-    location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
-    swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
-    #! return a sequence of n numbers between 0 and 2pi
-    dup [ / pi 2 * * ] curry map ;
-
 : segment-number++ ( segment -- )
     [ number>> 1+ ] keep (>>number) ;
 
@@ -40,9 +26,7 @@ C: <segment> segment
 : (random-segments) ( segments n -- segments )
     dup 0 > [
         >r dup peek random-segment over push r> 1- (random-segments)
-    ] [
+    ] [ drop ] if ;
-        drop
-    ] if ;
 
 : default-segment-radius ( -- r ) 1 ;
 
@@ -66,7 +50,7 @@ C: <segment> segment
 : <straight-tunnel> ( -- segments )
     n-segments simple-segments ;
 
-: sub-tunnel ( from to sements -- segments )
+: sub-tunnel ( from to segments -- segments )
     #! return segments between from and to, after clamping from and to to
     #! valid values
     [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
@@ -97,6 +81,32 @@ C: <segment> segment
     [ nearest-segment-forward ] 3keep
     nearest-segment-backward r> nearer-segment ;
 
+: get-segment ( segments n -- segment )
+    over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+    number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+    number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+    #! the next segment on the given heading
+    over forward>> v. 0 <=> {
+        { +gt+ [ next-segment ] }
+        { +lt+ [ previous-segment ] }
+        { +eq+ [ nip ] } ! current segment
+    } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+    [let | cf [ current forward>> ] |
+        cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+    [let | cf [ current forward>> ]
+           h [ next current half-way-between-oints ] |
+        cf h v. cf location v. - cf heading v. / ] ;
+
 : vector-to-centre ( seg loc -- v )
     over location>> swap v- swap forward>> proj-perp ;
 
@@ -106,19 +116,25 @@ C: <segment> segment
 : wall-normal ( seg oint -- n )
     location>> vector-to-centre normalize ;
 
-: from ( seg loc -- radius d-f-c )
+: distant ( -- n ) 1000 ;
-    dupd location>> distance-from-centre [ radius>> ] dip ;
 
-: distance-from-wall ( seg loc -- distance ) from - ;
+: max-real ( a b -- c )
-: fraction-from-centre ( seg loc -- fraction ) from / ;
+    #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
-: fraction-from-wall ( seg loc -- fraction )
+    dup real? [
-    fraction-from-centre 1 swap - ;
+        over real? [ max ] [ nip ] if
+    ] [
+        drop dup real? [ drop distant ] unless
+    ] if ;
 
 :: collision-coefficient ( v w r -- c )
+    v norm 0 = [
+        distant
+    ] [
         [let* | a [ v dup v. ]
                 b [ v w v. 2 * ]
                 c [ w dup v. r sq - ] |
-        c b a quadratic max ] ;
+            c b a quadratic max-real ]
+    ] if ;
 
 : sideways-heading ( oint segment -- v )
     [ forward>> ] bi@ proj-perp ;
@@ -126,18 +142,12 @@ C: <segment> segment
 : sideways-relative-location ( oint segment -- loc )
     [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
 
-: bounce-offset 0.1 ; inline
+: (distance-to-collision) ( oint segment -- distance )
-
+    [ sideways-heading ] [ sideways-relative-location ]
-: bounce-radius ( segment -- r )
+    [ nip radius>> ] 2tri collision-coefficient ;
-    radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?)
 
 : collision-vector ( oint segment -- v )
-    [ sideways-heading ] [ sideways-relative-location ]
+    dupd (distance-to-collision) swap forward>> n*v ;
-    [ bounce-radius ] 2tri
-    swap [ collision-coefficient ] dip forward>> n*v ;
-
-: distance-to-collision ( oint segment -- distance )
-    collision-vector norm ;
 
 : bounce-forward ( segment oint -- )
     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
@@ -151,6 +161,6 @@ C: <segment> segment
     #! must be done after forward and left!
     nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
 
-: bounce ( oint segment -- )
+: bounce-off-wall ( oint segment -- )
     swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
 

extra/json/reader/reader.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel parser-combinators namespaces sequences promises strings 
        assocs math math.parser math.vectors math.functions math.order
-       lazy-lists hashtables ascii ;
+       lists hashtables ascii ;
 IN: json.reader
 
 ! Grammar for JSON from RFC 4627

extra/lazy-lists/lazy-lists.factor

@@ -1,445 +0,0 @@
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-!
-USING: kernel sequences math vectors arrays namespaces
-quotations promises combinators io ;
-IN: lazy-lists
-
-! Lazy List Protocol
-MIXIN: list
-GENERIC: car   ( cons -- car )
-GENERIC: cdr   ( cons -- cdr )
-GENERIC: nil?  ( cons -- ? )
-
-M: promise car ( promise -- car )
-  force car ;
-
-M: promise cdr ( promise -- cdr )
-  force cdr ;
-
-M: promise nil? ( cons -- bool )
-  force nil? ;
-
-TUPLE: cons car cdr ;
-
-C: cons cons
-
-M: cons car ( cons -- car )
-    cons-car ;
-
-M: cons cdr ( cons -- cdr )
-    cons-cdr ;
-
-: nil ( -- cons )
-  T{ cons f f f } ;
-
-M: cons nil? ( cons -- bool )
-    nil eq? ;
-
-: 1list ( obj -- cons )
-    nil cons ;
-
-: 2list ( a b -- cons )
-    nil cons cons ;
-
-: 3list ( a b c -- cons )
-    nil cons cons cons ;
-
-! Both 'car' and 'cdr' are promises
-TUPLE: lazy-cons car cdr ;
-
-: lazy-cons ( car cdr -- promise )
-    [ promise ] bi@ \ lazy-cons boa
-    T{ promise f f t f } clone
-    [ set-promise-value ] keep ;
-
-M: lazy-cons car ( lazy-cons -- car )
-    lazy-cons-car force ;
-
-M: lazy-cons cdr ( lazy-cons -- cdr )
-    lazy-cons-cdr force ;
-
-M: lazy-cons nil? ( lazy-cons -- bool )
-    nil eq? ;
-
-: 1lazy-list ( a -- lazy-cons )
-  [ nil ] lazy-cons ;
-
-: 2lazy-list ( a b -- lazy-cons )
-  1lazy-list 1quotation lazy-cons ;
-
-: 3lazy-list ( a b c -- lazy-cons )
-  2lazy-list 1quotation lazy-cons ;
-
-: lnth ( n list -- elt )
-  swap [ cdr ] times car ;
-
-: (llength) ( list acc -- n )
-  over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
-
-: llength ( list -- n )
-  0 (llength) ;
-
-: uncons ( cons -- car cdr )
-    #! Return the car and cdr of the lazy list
-    dup car swap cdr ;
-
-: leach ( list quot -- )
-  swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
-
-: lreduce ( list identity quot -- result )
-  swapd leach ; inline
-
-TUPLE: memoized-cons original car cdr nil? ;
-
-: not-memoized ( -- obj )
-  { } ;
-
-: not-memoized? ( obj -- bool )
-  not-memoized eq? ;
-
-: <memoized-cons> ( cons -- memoized-cons )
-  not-memoized not-memoized not-memoized
-  memoized-cons boa ;
-
-M: memoized-cons car ( memoized-cons -- car )
-  dup memoized-cons-car not-memoized? [
-    dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
-  ] [
-    memoized-cons-car
-  ] if ;
-
-M: memoized-cons cdr ( memoized-cons -- cdr )
-  dup memoized-cons-cdr not-memoized? [
-    dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
-  ] [
-    memoized-cons-cdr
-  ] if ;
-
-M: memoized-cons nil? ( memoized-cons -- bool )
-  dup memoized-cons-nil? not-memoized? [
-    dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
-  ] [
-    memoized-cons-nil?
-  ] if ;
-
-TUPLE: lazy-map cons quot ;
-
-C: <lazy-map> lazy-map
-
-: lmap ( list quot -- result )
-    over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
-
-M: lazy-map car ( lazy-map -- car )
-  [ lazy-map-cons car ] keep
-  lazy-map-quot call ;
-
-M: lazy-map cdr ( lazy-map -- cdr )
-  [ lazy-map-cons cdr ] keep
-  lazy-map-quot lmap ;
-
-M: lazy-map nil? ( lazy-map -- bool )
-  lazy-map-cons nil? ;
-
-: lmap-with ( value list quot -- result )
-  with lmap ;
-
-TUPLE: lazy-take n cons ;
-
-C: <lazy-take> lazy-take
-
-: ltake ( n list -- result )
-    over zero? [ 2drop nil ] [ <lazy-take> ] if ;
-
-M: lazy-take car ( lazy-take -- car )
-  lazy-take-cons car ;
-
-M: lazy-take cdr ( lazy-take -- cdr )
-  [ lazy-take-n 1- ] keep
-  lazy-take-cons cdr ltake ;
-
-M: lazy-take nil? ( lazy-take -- bool )
-  dup lazy-take-n zero? [
-    drop t
-  ] [
-    lazy-take-cons nil?
-  ] if ;
-
-TUPLE: lazy-until cons quot ;
-
-C: <lazy-until> lazy-until
-
-: luntil ( list quot -- result )
-  over nil? [ drop ] [ <lazy-until> ] if ;
-
-M: lazy-until car ( lazy-until -- car )
-   lazy-until-cons car ;
-
-M: lazy-until cdr ( lazy-until -- cdr )
-   [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
-   [ 2drop nil ] [ luntil ] if ;
-
-M: lazy-until nil? ( lazy-until -- bool )
-   drop f ;
-
-TUPLE: lazy-while cons quot ;
-
-C: <lazy-while> lazy-while
-
-: lwhile ( list quot -- result )
-  over nil? [ drop ] [ <lazy-while> ] if ;
-
-M: lazy-while car ( lazy-while -- car )
-   lazy-while-cons car ;
-
-M: lazy-while cdr ( lazy-while -- cdr )
-   [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
-
-M: lazy-while nil? ( lazy-while -- bool )
-   [ car ] keep lazy-while-quot call not ;
-
-TUPLE: lazy-filter cons quot ;
-
-C: <lazy-filter> lazy-filter
-
-: lfilter ( list quot -- result )
-    over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
-
-: car-filter?  ( lazy-filter -- ? )
-  [ lazy-filter-cons car ] keep
-  lazy-filter-quot call ;
-
-: skip ( lazy-filter -- )
-  [ lazy-filter-cons cdr ] keep
-  set-lazy-filter-cons ;
-
-M: lazy-filter car ( lazy-filter -- car )
-  dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
-
-M: lazy-filter cdr ( lazy-filter -- cdr )
-  dup car-filter? [
-    [ lazy-filter-cons cdr ] keep
-    lazy-filter-quot lfilter
-  ] [
-    dup skip cdr
-  ] if ;
-
-M: lazy-filter nil? ( lazy-filter -- bool )
-  dup lazy-filter-cons nil? [
-    drop t
-  ] [
-    dup car-filter? [
-      drop f
-    ] [
-      dup skip nil?
-    ] if
-  ] if ;
-
-: list>vector ( list -- vector )
-  [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
-  [ [ , ] leach ] { } make ;
-
-TUPLE: lazy-append list1 list2 ;
-
-C: <lazy-append> lazy-append
-
-: lappend ( list1 list2 -- result )
-  over nil? [ nip ] [ <lazy-append> ] if ;
-
-M: lazy-append car ( lazy-append -- car )
-  lazy-append-list1 car ;
-
-M: lazy-append cdr ( lazy-append -- cdr )
-  [ lazy-append-list1 cdr  ] keep
-  lazy-append-list2 lappend ;
-
-M: lazy-append nil? ( lazy-append -- bool )
-   drop f ;
-
-TUPLE: lazy-from-by n quot ;
-
-C: lfrom-by lazy-from-by ( n quot -- list )
-
-: lfrom ( n -- list )
-  [ 1+ ] lfrom-by ;
-
-M: lazy-from-by car ( lazy-from-by -- car )
-  lazy-from-by-n ;
-
-M: lazy-from-by cdr ( lazy-from-by -- cdr )
-  [ lazy-from-by-n ] keep
-  lazy-from-by-quot dup slip lfrom-by ;
-
-M: lazy-from-by nil? ( lazy-from-by -- bool )
-  drop f ;
-
-TUPLE: lazy-zip list1 list2 ;
-
-C: <lazy-zip> lazy-zip
-
-: lzip ( list1 list2 -- lazy-zip )
-    over nil? over nil? or
-    [ 2drop nil ] [ <lazy-zip> ] if ;
-
-M: lazy-zip car ( lazy-zip -- car )
-    [ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
-
-M: lazy-zip cdr ( lazy-zip -- cdr )
-    [ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
-
-M: lazy-zip nil? ( lazy-zip -- bool )
-    drop f ;
-
-TUPLE: sequence-cons index seq ;
-
-C: <sequence-cons> sequence-cons
-
-: seq>list ( index seq -- list )
-  2dup length >= [
-    2drop nil
-  ] [
-    <sequence-cons>
-  ] if ;
-
-M: sequence-cons car ( sequence-cons -- car )
-  [ sequence-cons-index ] keep
-  sequence-cons-seq nth ;
-
-M: sequence-cons cdr ( sequence-cons -- cdr )
-  [ sequence-cons-index 1+ ] keep
-  sequence-cons-seq seq>list ;
-
-M: sequence-cons nil? ( sequence-cons -- bool )
-    drop f ;
-
-: >list ( object -- list )
-  {
-    { [ dup sequence? ] [ 0 swap seq>list ] }
-    { [ dup list?     ] [ ] }
-    [ "Could not convert object to a list" throw ]
-  } cond ;
-
-TUPLE: lazy-concat car cdr ;
-
-C: <lazy-concat> lazy-concat
-
-DEFER: lconcat
-
-: (lconcat) ( car cdr -- list )
-  over nil? [
-    nip lconcat
-  ] [
-    <lazy-concat>
-  ] if ;
-
-: lconcat ( list -- result )
-  dup nil? [
-    drop nil
-  ] [
-    uncons (lconcat)
-  ] if ;
-
-M: lazy-concat car ( lazy-concat -- car )
-  lazy-concat-car car ;
-
-M: lazy-concat cdr ( lazy-concat -- cdr )
-  [ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
-
-M: lazy-concat nil? ( lazy-concat -- bool )
-  dup lazy-concat-car nil? [
-    lazy-concat-cdr nil?
-  ] [
-    drop f
-  ] if ;
-
-: lcartesian-product ( list1 list2 -- result )
-  swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
-
-: lcartesian-product* ( lists -- result )
-  dup nil? [
-    drop nil
-  ] [
-    [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
-      swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
-    ] reduce
-  ] if ;
-
-: lcomp ( list quot -- result )
-  [ lcartesian-product* ] dip lmap ;
-
-: lcomp* ( list guards quot -- result )
-  [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
-
-DEFER: lmerge
-
-: (lmerge) ( list1 list2 -- result )
-  over [ car ] curry -rot
-  [
-    dup [ car ] curry -rot
-    [
-      [ cdr ] bi@ lmerge
-    ] 2curry lazy-cons
-  ] 2curry lazy-cons ;
-
-: lmerge ( list1 list2 -- result )
-  {
-    { [ over nil? ] [ nip   ] }
-    { [ dup nil?  ]  [ drop ] }
-    { [ t         ]  [ (lmerge) ] }
-  } cond ;
-
-TUPLE: lazy-io stream car cdr quot ;
-
-C: <lazy-io> lazy-io
-
-: lcontents ( stream -- result )
-  f f [ stream-read1 ] <lazy-io> ;
-
-: llines ( stream -- result )
-  f f [ stream-readln ] <lazy-io> ;
-
-M: lazy-io car ( lazy-io -- car )
-  dup lazy-io-car dup [
-    nip
-  ] [
-    drop dup lazy-io-stream over lazy-io-quot call
-    swap dupd set-lazy-io-car
-  ] if ;
-
-M: lazy-io cdr ( lazy-io -- cdr )
-  dup lazy-io-cdr dup [
-    nip
-  ] [
-    drop dup
-    [ lazy-io-stream ] keep
-    [ lazy-io-quot ] keep
-    car [
-      [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
-    ] [
-      3drop nil
-    ] if
-  ] if ;
-
-M: lazy-io nil? ( lazy-io -- bool )
-  car not ;
-
-INSTANCE: cons list
-INSTANCE: sequence-cons list
-INSTANCE: memoized-cons list
-INSTANCE: promise list
-INSTANCE: lazy-io list
-INSTANCE: lazy-concat list
-INSTANCE: lazy-cons list
-INSTANCE: lazy-map list
-INSTANCE: lazy-take list
-INSTANCE: lazy-append list
-INSTANCE: lazy-from-by list
-INSTANCE: lazy-zip list
-INSTANCE: lazy-while list
-INSTANCE: lazy-until list
-INSTANCE: lazy-filter list

extra/lisp/lisp-tests.factor

@@ -1,17 +1,19 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lisp lisp.parser tools.test sequences math kernel parser ;
+USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
 
 IN: lisp.test
 
 [
     init-env
     
-    "#f" [ f ] lisp-define
+    [ f ] "#f" lisp-define
-    "#t" [ t ] lisp-define
+    [ t ] "#t" lisp-define
     
-    "+" "math" "+" define-primitve
+    "+" "math" "+" define-primitive
-    "-" "math" "-" define-primitve
+    "-" "math" "-" define-primitive
+    
+!    "list" [ >array ] lisp-define
     
     { 5 } [
       [ 2 3 ] "+" <lisp-symbol> funcall
@@ -22,26 +24,39 @@ IN: lisp.test
     ] unit-test
     
     { 3 } [
-      "((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
+      "((lambda (x y) (+ x y)) 1 2)" lisp-eval
     ] unit-test
     
     { 42 } [
-      "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
+      "((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
+    ] unit-test
+    
+    { T{ lisp-symbol f "if" } } [
+        "(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
+    ] unit-test
+    
+    { t } [
+        T{ lisp-symbol f "if" } lisp-macro?
     ] unit-test
     
     { 1 } [
-      "(if #t 1 2)" lisp-string>factor call
+      "(if #t 1 2)" lisp-eval
     ] unit-test
     
     { "b" } [
-      "(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
+      "(cond (#f \"a\") (#t \"b\"))" lisp-eval
     ] unit-test
     
     { 5 } [
-      "(begin (+ 1 4))" lisp-string>factor call
+      "(begin (+ 1 4))" lisp-eval
     ] unit-test
     
     { 3 } [
-       "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
+       "((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
     ] unit-test
+    
+!     { { 1 2 3 4 5 } } [
+!       "(list 1 2 3 4 5)" lisp-eval
+!     ] unit-test
+
 ] with-interactive-vocabs

extra/lisp/lisp.factor

@@ -1,46 +1,45 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel peg sequences arrays strings combinators.lib
-namespaces combinators math bake locals locals.private accessors
+namespaces combinators math locals locals.private accessors
-vectors syntax lisp.parser assocs parser sequences.lib words quotations
+vectors syntax lisp.parser assocs parser sequences.lib words
-fry ;
+quotations fry lists inspector ;
 IN: lisp
 
 DEFER: convert-form
 DEFER: funcall
 DEFER: lookup-var
+DEFER: lookup-macro
+DEFER: lisp-macro?
+DEFER: macro-expand
+DEFER: define-lisp-macro
     
 ! Functions to convert s-exps to quotations
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( s-exp -- quot )
+: convert-body ( cons -- quot )
-    [ ] [ convert-form compose ] reduce ; inline
+    [ ] [ convert-form compose ] foldl ; inline
     
-: convert-if ( s-exp -- quot )
+: convert-begin ( cons -- quot )  
-    rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
+    cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
     
-: convert-begin ( s-exp -- quot )  
+: convert-cond ( cons -- quot )  
-    rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
+    cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
+    { } lmap-as '[ , cond ]  ;
     
-: convert-cond ( s-exp -- quot )  
+: convert-general-form ( cons -- quot )
-    rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
+    uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
-    { } map-as '[ , cond ]  ;
-    
-: convert-general-form ( s-exp -- quot )
-    unclip convert-form swap convert-body swap '[ , @ funcall ] ;
 
 ! words for convert-lambda  
 <PRIVATE  
 : localize-body ( assoc body -- assoc newbody )  
-    [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
+    [ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
-                     [ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
-                   ] map ;
 
 : localize-lambda ( body vars -- newbody newvars )
     make-locals dup push-locals swap
-    [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
+    [ swap localize-body convert-form swap pop-locals ] dip swap ;
                    
-: split-lambda ( s-exp -- body vars )                   
+: split-lambda ( cons -- body-cons vars-seq )                   
-    first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
+    3car -rot nip [ name>> ] lmap>array ; inline
     
 : rest-lambda ( body vars -- quot )
     "&rest" swap [ index ] [ remove ] 2bi
@@ -51,46 +50,80 @@ DEFER: lookup-var
     localize-lambda <lambda> '[ , compose ] ;
 PRIVATE>
     
-: convert-lambda ( s-exp -- quot )  
+: convert-lambda ( cons -- quot )  
     split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
     
-: convert-quoted ( s-exp -- quot )  
+: convert-quoted ( cons -- quot )  
-    second 1quotation ;
+    cdr 1quotation ;
     
-: convert-list-form ( s-exp -- quot )  
+: convert-unquoted ( cons -- quot )    
-    dup first dup lisp-symbol?
+    "unquote not valid outside of quasiquote!" throw ;
-    [ name>>
+    
+: convert-quasiquoted ( cons -- newcons )
+    [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
+    [ cadr ] traverse ;
+    
+: convert-defmacro ( cons -- quot )
+    cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
+    
+: form-dispatch ( cons lisp-symbol -- quot )
+    name>>
     { { "lambda" [ convert-lambda ] }
+      { "defmacro" [ convert-defmacro ] }
       { "quote" [ convert-quoted ] }
-        { "if" [ convert-if ] }
+      { "unquote" [ convert-unquoted ] }
+      { "quasiquote" [ convert-quasiquoted ] }
       { "begin" [ convert-begin ] }
       { "cond" [ convert-cond ] }
      [ drop convert-general-form ]
-      } case ]
+    } case ;
-    [ drop convert-general-form ] if ;
+    
+: convert-list-form ( cons -- quot )  
+    dup car
+    { { [ dup lisp-macro?  ] [ drop macro-expand ] }
+      { [ dup lisp-symbol? ] [ form-dispatch ] } 
+     [ drop convert-general-form ]
+    } cond ;
     
 : convert-form ( lisp-form -- quot )
-    { { [ dup s-exp? ] [ body>> convert-list-form ] }
+    {
+      { [ dup cons? ] [ convert-list-form ] }
       { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
      [ 1quotation ]
     } cond ;
     
+: compile-form ( lisp-ast -- quot )
+    convert-form lambda-rewrite call ; inline
+    
+: macro-call ( lambda -- cons )
+    call ; inline
+    
+: macro-expand ( cons -- quot )
+    uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form  ] bi* call ;
+    
 : lisp-string>factor ( str -- quot )
-    lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+    lisp-expr parse-result-ast compile-form ;
+    
+: lisp-eval ( str -- * )    
+  lisp-string>factor call ;
     
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 SYMBOL: lisp-env
-ERROR: no-such-var var ;
+SYMBOL: macro-env
+    
+ERROR: no-such-var variable-name ;
+M: no-such-var summary drop "No such variable" ;
 
 : init-env ( -- )
-    H{ } clone lisp-env set ;
+    H{ } clone lisp-env set
+    H{ } clone macro-env set ;
 
-: lisp-define ( name quot -- )
+: lisp-define ( quot name -- )
-    swap lisp-env get set-at ;
+    lisp-env get set-at ;
     
 : lisp-get ( name -- word )
-    dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
+    dup lisp-env get at [ ] [ no-such-var ] ?if ;
     
 : lookup-var ( lisp-symbol -- quot )
     name>> lisp-get ;
@@ -98,5 +131,14 @@ ERROR: no-such-var var ;
 : funcall ( quot sym -- * )
     dup lisp-symbol?  [ lookup-var ] when call ; inline
     
-: define-primitve ( name vocab word -- )  
+: define-primitive ( name vocab word -- )  
-    swap lookup 1quotation '[ , compose call ] lisp-define ;
+    swap lookup 1quotation '[ , compose call ] swap lisp-define ;
+    
+: lookup-macro ( lisp-symbol -- lambda )
+    name>> macro-env get at ;
+    
+: define-lisp-macro ( quot name -- )
+    macro-env get set-at ;
+    
+: lisp-macro? ( car -- ? )
+    dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;

extra/lisp/parser/parser-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lisp.parser tools.test peg peg.ebnf ;
+USING: lisp.parser tools.test peg peg.ebnf lists ;
 
 IN: lisp.parser.tests
 
@@ -40,7 +40,29 @@ IN: lisp.parser.tests
     "+" "atom" \ lisp-expr rule parse parse-result-ast
 ] unit-test
 
-{ T{ s-exp f
+{ +nil+ } [
-     V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
+    "()" lisp-expr parse-result-ast
+] unit-test
+
+{ T{
+    cons
+    f
+    T{ lisp-symbol f "foo" }
+    T{
+        cons
+        f
+        1
+        T{ cons f 2 T{ cons f "aoeu" +nil+ } }
+    } } } [
     "(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
 ] unit-test
+
+{ T{ cons f
+       1
+       T{ cons f
+           T{ cons f 3 T{ cons f 4 +nil+ } }
+           T{ cons f 2 +nil+ } }
+   }
+} [
+    "(1 (3 4) 2)" lisp-expr parse-result-ast
+] unit-test

extra/lisp/parser/parser.factor

@@ -1,16 +1,13 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
+USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
-combinators.lib math ;
+combinators.lib math fry accessors lists ;
 
 IN: lisp.parser
 
 TUPLE: lisp-symbol name ;
 C: <lisp-symbol> lisp-symbol
 
-TUPLE: s-exp body ;
-C: <s-exp> s-exp
-
 EBNF: lisp-expr
 _            = (" " | "\t" | "\n")*
 LPAREN       = "("
@@ -24,8 +21,9 @@ rational     = integer "/" (digit)+                      => [[ first3 nip string
 number       = float
               | rational
               | integer
-id-specials  = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
+id-specials  = "!" | "$" | "%" | "&" | "*" | "/" | ":"
-              | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+              | "<" | "#" | " =" | ">" | "?" | "^" | "_"
+              | "~" | "+" | "-" | "." | "@"
 letters      = [a-zA-Z]                                  => [[ 1array >string ]]
 initials     = letters | id-specials
 numbers      = [0-9]                                     => [[ 1array >string ]]
@@ -37,5 +35,5 @@ atom         = number
               | identifier
               | string
 list-item    = _ ( atom | s-expression ) _               => [[ second ]]
-s-expression = LPAREN (list-item)* RPAREN                => [[ second <s-exp> ]]
+s-expression = LPAREN (list-item)* RPAREN                => [[ second seq>cons ]]
 ;EBNF

extra/lists/authors.txt

@@ -0,0 +1 @@
+James Cash

extra/lists/lazy/examples/examples.factor

@@ -2,8 +2,8 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: lazy-lists math kernel sequences quotations ;
+USING: lists.lazy math kernel sequences quotations ;
-IN: lazy-lists.examples
+IN: lists.lazy.examples
 
 : naturals 0 lfrom ;
 : positives 1 lfrom ;
@@ -11,5 +11,5 @@ IN: lazy-lists.examples
 : odds 1 lfrom [ 2 mod 1 = ] lfilter ;
 : powers-of-2 1 [ 2 * ] lfrom-by ;
 : ones 1 [ ] lfrom-by ;
-: squares naturals [ dup * ] lmap ;
+: squares naturals [ dup * ] lazy-map ;
 : first-five-squares 5 squares ltake list>array ;

extra/lists/lazy/lazy-docs.factor

@@ -1,48 +1,8 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: help.markup help.syntax sequences strings ;
+USING: help.markup help.syntax sequences strings lists ;
-IN: lazy-lists 
+IN: lists.lazy 
-
-{ car cons cdr nil nil? list? uncons } related-words
-
-HELP: cons 
-{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
-{ $description "Constructs a cons cell." } ;
-
-HELP: car
-{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
-{ $description "Returns the first item in the list." } ;
-
-HELP: cdr
-{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
-{ $description "Returns the tail of the list." } ;
-
-HELP: nil 
-{ $values { "cons" "An empty cons" } }
-{ $description "Returns a representation of an empty list" } ;
-
-HELP: nil? 
-{ $values { "cons" "a cons object" } { "?" "a boolean" } }
-{ $description "Return true if the cons object is the nil cons." } ;
-
-HELP: list? ( object -- ? )
-{ $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } ;
-
-{ 1list 2list 3list } related-words
-
-HELP: 1list
-{ $values { "obj" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 1 element." } ;
-
-HELP: 2list
-{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 2 elements." } ;
-
-HELP: 3list
-{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 3 elements." } ;
 
 HELP: lazy-cons
 { $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
@@ -68,37 +28,15 @@ HELP: <memoized-cons>
 { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } 
 { $see-also cons car cdr nil nil? } ;
 
-HELP: lnth
+{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
-{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
-{ $description "Outputs the nth element of the list." } 
-{ $see-also llength cons car cdr } ;
 
-HELP: llength
+HELP: lazy-map
-{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
-{ $description "Outputs the length of the list. This should not be called on an infinite list." } 
-{ $see-also lnth cons car cdr } ;
-
-HELP: uncons
-{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
-{ $description "Put the head and tail of the list on the stack." } ;
-
-{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
-
-HELP: leach
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
-{ $description "Call the quotation for each item in the list." } ;
-
-HELP: lreduce
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
-{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
-
-HELP: lmap
 { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
 { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
 
-HELP: lmap-with
+HELP: lazy-map-with
 { $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
-{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
+{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
 
 HELP: ltake
 { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
@@ -148,6 +86,8 @@ HELP: >list
 { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } 
 { $see-also seq>list } ;
     
+{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+
 HELP: lconcat
 { $values { "list" "a list of lists" } { "result" "a list" } }
 { $description "Concatenates a list of lists together into one list." } ;
@@ -175,7 +115,7 @@ HELP: lmerge
 { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
 { $description "Return the result of merging the two lists in a lazy manner." } 
 { $examples
-  { $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+  { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
 } ;
 
 HELP: lcontents
@@ -187,4 +127,3 @@ HELP: llines
 { $values { "stream" "a stream" } { "result" "a list" } }
 { $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." } 
 { $see-also lcontents } ;
-

extra/lists/lazy/lazy-tests.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006 Matthew Willis and Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: lazy-lists tools.test kernel math io sequences ;
+USING: lists lists.lazy tools.test kernel math io sequences ;
-IN: lazy-lists.tests
+IN: lists.lazy.tests
 
 [ { 1 2 3 4 } ] [
   { 1 2 3 4 } >list list>array
@@ -25,5 +25,5 @@ IN: lazy-lists.tests
 ] unit-test
 
 [ { 4 5 6 } ] [ 
-    3 { 1 2 3 } >list [ + ] lmap-with list>array
+    3 { 1 2 3 } >list [ + ] lazy-map-with list>array
 ] unit-test

extra/lists/lazy/lazy.factor

@@ -0,0 +1,392 @@
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Updated by Matthew Willis, July 2006
+! Updated by Chris Double, September 2006
+! Updated by James Cash, June 2008
+!
+USING: kernel sequences math vectors arrays namespaces
+quotations promises combinators io lists accessors ;
+IN: lists.lazy
+
+M: promise car ( promise -- car )
+    force car ;
+
+M: promise cdr ( promise -- cdr )
+    force cdr ;
+
+M: promise nil? ( cons -- bool )
+    force nil? ;
+    
+! Both 'car' and 'cdr' are promises
+TUPLE: lazy-cons car cdr ;
+
+: lazy-cons ( car cdr -- promise )
+    [ promise ] bi@ \ lazy-cons boa
+    T{ promise f f t f } clone
+    [ set-promise-value ] keep ;
+
+M: lazy-cons car ( lazy-cons -- car )
+    car>> force ;
+
+M: lazy-cons cdr ( lazy-cons -- cdr )
+    cdr>> force ;
+
+M: lazy-cons nil? ( lazy-cons -- bool )
+    nil eq? ;
+
+: 1lazy-list ( a -- lazy-cons )
+    [ nil ] lazy-cons ;
+
+: 2lazy-list ( a b -- lazy-cons )
+    1lazy-list 1quotation lazy-cons ;
+
+: 3lazy-list ( a b c -- lazy-cons )
+    2lazy-list 1quotation lazy-cons ;
+
+TUPLE: memoized-cons original car cdr nil? ;
+
+: not-memoized ( -- obj )
+    { } ;
+
+: not-memoized? ( obj -- bool )
+    not-memoized eq? ;
+
+: <memoized-cons> ( cons -- memoized-cons )
+    not-memoized not-memoized not-memoized
+    memoized-cons boa ;
+
+M: memoized-cons car ( memoized-cons -- car )
+    dup car>> not-memoized? [
+        dup original>> car [ >>car drop ] keep
+    ] [
+        car>>
+    ] if ;
+
+M: memoized-cons cdr ( memoized-cons -- cdr )
+    dup cdr>> not-memoized? [
+        dup original>> cdr [ >>cdr drop ] keep
+    ] [
+        cdr>>
+    ] if ;
+
+M: memoized-cons nil? ( memoized-cons -- bool )
+    dup nil?>> not-memoized? [
+        dup original>> nil?  [ >>nil? drop ] keep
+    ] [
+        nil?>>
+    ] if ;
+
+TUPLE: lazy-map cons quot ;
+
+C: <lazy-map> lazy-map
+
+: lazy-map ( list quot -- result )
+    over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
+
+M: lazy-map car ( lazy-map -- car )
+    [ cons>> car ] keep
+    quot>> call ;
+
+M: lazy-map cdr ( lazy-map -- cdr )
+    [ cons>> cdr ] keep
+    quot>> lazy-map ;
+
+M: lazy-map nil? ( lazy-map -- bool )
+    cons>> nil? ;
+
+: lazy-map-with ( value list quot -- result )
+    with lazy-map ;
+
+TUPLE: lazy-take n cons ;
+
+C: <lazy-take> lazy-take
+
+: ltake ( n list -- result )
+        over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+
+M: lazy-take car ( lazy-take -- car )
+    cons>> car ;
+
+M: lazy-take cdr ( lazy-take -- cdr )
+    [ n>> 1- ] keep
+    cons>> cdr ltake ;
+
+M: lazy-take nil? ( lazy-take -- bool )
+    dup n>> zero? [
+        drop t
+    ] [
+        cons>> nil?
+    ] if ;
+
+TUPLE: lazy-until cons quot ;
+
+C: <lazy-until> lazy-until
+
+: luntil ( list quot -- result )
+    over nil? [ drop ] [ <lazy-until> ] if ;
+
+M: lazy-until car ( lazy-until -- car )
+     cons>> car ;
+
+M: lazy-until cdr ( lazy-until -- cdr )
+     [ cons>> uncons ] keep quot>> tuck call
+     [ 2drop nil ] [ luntil ] if ;
+
+M: lazy-until nil? ( lazy-until -- bool )
+     drop f ;
+
+TUPLE: lazy-while cons quot ;
+
+C: <lazy-while> lazy-while
+
+: lwhile ( list quot -- result )
+    over nil? [ drop ] [ <lazy-while> ] if ;
+
+M: lazy-while car ( lazy-while -- car )
+     cons>> car ;
+
+M: lazy-while cdr ( lazy-while -- cdr )
+     [ cons>> cdr ] keep quot>> lwhile ;
+
+M: lazy-while nil? ( lazy-while -- bool )
+     [ car ] keep quot>> call not ;
+
+TUPLE: lazy-filter cons quot ;
+
+C: <lazy-filter> lazy-filter
+
+: lfilter ( list quot -- result )
+    over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
+
+: car-filter? ( lazy-filter -- ? )
+    [ cons>> car ] [ quot>> ] bi call ;
+
+: skip ( lazy-filter -- )
+    dup cons>> cdr >>cons drop ;
+
+M: lazy-filter car ( lazy-filter -- car )
+    dup car-filter? [ cons>> ] [ dup skip ] if car ;
+
+M: lazy-filter cdr ( lazy-filter -- cdr )
+    dup car-filter? [
+        [ cons>> cdr ] [ quot>> ] bi lfilter
+    ] [
+        dup skip cdr
+    ] if ;
+
+M: lazy-filter nil? ( lazy-filter -- bool )
+    dup cons>> nil? [
+        drop t
+    ] [
+        dup car-filter? [
+            drop f
+        ] [
+            dup skip nil?
+        ] if
+    ] if ;
+
+: list>vector ( list -- vector )
+    [ [ , ] leach ] V{ } make ;
+
+: list>array ( list -- array )
+    [ [ , ] leach ] { } make ;
+
+TUPLE: lazy-append list1 list2 ;
+
+C: <lazy-append> lazy-append
+
+: lappend ( list1 list2 -- result )
+    over nil? [ nip ] [ <lazy-append> ] if ;
+
+M: lazy-append car ( lazy-append -- car )
+    list1>> car ;
+
+M: lazy-append cdr ( lazy-append -- cdr )
+    [ list1>> cdr    ] keep
+    list2>> lappend ;
+
+M: lazy-append nil? ( lazy-append -- bool )
+     drop f ;
+
+TUPLE: lazy-from-by n quot ;
+
+C: lfrom-by lazy-from-by ( n quot -- list )
+
+: lfrom ( n -- list )
+    [ 1+ ] lfrom-by ;
+
+M: lazy-from-by car ( lazy-from-by -- car )
+    n>> ;
+
+M: lazy-from-by cdr ( lazy-from-by -- cdr )
+    [ n>> ] keep
+    quot>> dup slip lfrom-by ;
+
+M: lazy-from-by nil? ( lazy-from-by -- bool )
+    drop f ;
+
+TUPLE: lazy-zip list1 list2 ;
+
+C: <lazy-zip> lazy-zip
+
+: lzip ( list1 list2 -- lazy-zip )
+        over nil? over nil? or
+        [ 2drop nil ] [ <lazy-zip> ] if ;
+
+M: lazy-zip car ( lazy-zip -- car )
+        [ list1>> car ] keep list2>> car 2array ;
+
+M: lazy-zip cdr ( lazy-zip -- cdr )
+        [ list1>> cdr ] keep list2>> cdr lzip ;
+
+M: lazy-zip nil? ( lazy-zip -- bool )
+        drop f ;
+
+TUPLE: sequence-cons index seq ;
+
+C: <sequence-cons> sequence-cons
+
+: seq>list ( index seq -- list )
+    2dup length >= [
+        2drop nil
+    ] [
+        <sequence-cons>
+    ] if ;
+
+M: sequence-cons car ( sequence-cons -- car )
+    [ index>> ] keep
+    seq>> nth ;
+
+M: sequence-cons cdr ( sequence-cons -- cdr )
+    [ index>> 1+ ] keep
+    seq>> seq>list ;
+
+M: sequence-cons nil? ( sequence-cons -- bool )
+    drop f ;
+
+: >list ( object -- list )
+    {
+        { [ dup sequence? ] [ 0 swap seq>list ] }
+        { [ dup list?         ] [ ] }
+        [ "Could not convert object to a list" throw ]
+    } cond ;
+
+TUPLE: lazy-concat car cdr ;
+
+C: <lazy-concat> lazy-concat
+
+DEFER: lconcat
+
+: (lconcat) ( car cdr -- list )
+    over nil? [
+        nip lconcat
+    ] [
+        <lazy-concat>
+    ] if ;
+
+: lconcat ( list -- result )
+    dup nil? [
+        drop nil
+    ] [
+        uncons swap (lconcat)
+    ] if ;
+
+M: lazy-concat car ( lazy-concat -- car )
+    car>> car ;
+
+M: lazy-concat cdr ( lazy-concat -- cdr )
+    [ car>> cdr ] keep cdr>> (lconcat) ;
+
+M: lazy-concat nil? ( lazy-concat -- bool )
+    dup car>> nil? [
+        cdr>> nil?
+    ] [
+        drop f
+    ] if ;
+
+: lcartesian-product ( list1 list2 -- result )
+    swap [ swap [ 2array ] lazy-map-with  ] lazy-map-with  lconcat ;
+
+: lcartesian-product* ( lists -- result )
+    dup nil? [
+        drop nil
+    ] [
+        [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
+            swap [ swap [ suffix ] lazy-map-with  ] lazy-map-with  lconcat
+        ] reduce
+    ] if ;
+
+: lcomp ( list quot -- result )
+    [ lcartesian-product* ] dip lazy-map ;
+
+: lcomp* ( list guards quot -- result )
+    [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
+
+DEFER: lmerge
+
+: (lmerge) ( list1 list2 -- result )
+    over [ car ] curry -rot
+    [
+        dup [ car ] curry -rot
+        [
+            [ cdr ] bi@ lmerge
+        ] 2curry lazy-cons
+    ] 2curry lazy-cons ;
+
+: lmerge ( list1 list2 -- result )
+    {
+        { [ over nil? ] [ nip     ] }
+        { [ dup nil?    ]    [ drop ] }
+        { [ t                 ]    [ (lmerge) ] }
+    } cond ;
+
+TUPLE: lazy-io stream car cdr quot ;
+
+C: <lazy-io> lazy-io
+
+: lcontents ( stream -- result )
+    f f [ stream-read1 ] <lazy-io> ;
+
+: llines ( stream -- result )
+    f f [ stream-readln ] <lazy-io> ;
+
+M: lazy-io car ( lazy-io -- car )
+    dup car>> dup [
+        nip
+    ] [
+        drop dup stream>> over quot>> call
+        swap dupd set-lazy-io-car
+    ] if ;
+
+M: lazy-io cdr ( lazy-io -- cdr )
+    dup cdr>> dup [
+        nip
+    ] [
+        drop dup
+        [ stream>> ] keep
+        [ quot>> ] keep
+        car [
+            [ f f ] dip <lazy-io> [ >>cdr drop ] keep
+        ] [
+            3drop nil
+        ] if
+    ] if ;
+
+M: lazy-io nil? ( lazy-io -- bool )
+    car not ;
+
+INSTANCE: sequence-cons list
+INSTANCE: memoized-cons list
+INSTANCE: promise list
+INSTANCE: lazy-io list
+INSTANCE: lazy-concat list
+INSTANCE: lazy-cons list
+INSTANCE: lazy-map list
+INSTANCE: lazy-take list
+INSTANCE: lazy-append list
+INSTANCE: lazy-from-by list
+INSTANCE: lazy-zip list
+INSTANCE: lazy-while list
+INSTANCE: lazy-until list
+INSTANCE: lazy-filter list

extra/lists/lists-docs.factor

@@ -0,0 +1,104 @@
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+
+IN: lists
+
+{ car cons cdr nil nil? list? uncons } related-words
+
+HELP: cons 
+{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
+{ $description "Constructs a cons cell." } ;
+
+HELP: car
+{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
+{ $description "Returns the first item in the list." } ;
+
+HELP: cdr
+{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
+{ $description "Returns the tail of the list." } ;
+    
+HELP: nil 
+{ $values { "symbol" "The empty cons (+nil+)" } }
+{ $description "Returns a symbol representing the empty list" } ;
+
+HELP: nil? 
+{ $values { "cons" "a cons object" } { "?" "a boolean" } }
+{ $description "Return true if the cons object is the nil cons." } ;
+
+HELP: list? ( object -- ? )
+{ $values { "object" "an object" } { "?" "a boolean" } }
+{ $description "Returns true if the object conforms to the list protocol." } ;
+
+{ 1list 2list 3list } related-words
+
+HELP: 1list
+{ $values { "obj" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 1 element." } ;
+
+HELP: 2list
+{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 2 elements." } ;
+
+HELP: 3list
+{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 3 elements." } ;
+    
+HELP: lnth
+{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
+{ $description "Outputs the nth element of the list." } 
+{ $see-also llength cons car cdr } ;
+
+HELP: llength
+{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
+{ $description "Outputs the length of the list. This should not be called on an infinite list." } 
+{ $see-also lnth cons car cdr } ;
+
+HELP: uncons
+{ $values { "cons" "a cons object" }  { "cdr" "the tail of the list" } { "car" "the head of the list" } }
+{ $description "Put the head and tail of the list on the stack." } ;
+
+{ leach foldl lmap>array } related-words
+
+HELP: leach
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
+{ $description "Call the quotation for each item in the list." } ;
+
+HELP: foldl
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
+
+HELP: foldr
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
+
+HELP: lmap
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } }
+{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
+    
+HELP: lreverse
+{ $values { "list" "a cons object" } { "newlist" "a new cons object" } }
+{ $description "Reverses the input list, outputing a new, reversed list" } ;
+    
+HELP: list>seq    
+{ $values { "list" "a cons object" } { "array" "an array object" } }
+{ $description "Turns the given cons object into an array, maintaing order." } ;
+    
+HELP: seq>list
+{ $values { "seq" "a sequence" } { "list" "a cons object" } }
+{ $description "Turns the given array into a cons object, maintaing order." } ;
+    
+HELP: cons>seq
+{ $values { "cons" "a cons object" } { "array" "an array object" } }
+{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
+    
+HELP: seq>cons
+{ $values { "seq" "a sequence object" } { "cons" "a cons object" } }
+{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
+    
+HELP: traverse    
+{ $values { "list"  "a cons object" } { "pred" "a quotation with stack effect ( list/elt -- ? )" }
+          { "quot" "a quotation with stack effect ( list/elt -- result)" }  { "result" "a new cons object" } }
+{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" 
+    " returns true for with the result of applying quot to." } ;
+    

extra/lists/lists-tests.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test lists math ;
+
+IN: lists.tests
+
+{ { 3 4 5 6 7 } } [
+    { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq 
+] unit-test
+
+{ { 3 4 5 6 } } [
+    T{ cons f 1       
+        T{ cons f 2 
+            T{ cons f 3
+                T{ cons f 4
+                +nil+ } } } } [ 2 + ] lmap>array
+] unit-test
+
+{ 10 } [
+    T{ cons f 1       
+        T{ cons f 2 
+            T{ cons f 3
+                T{ cons f 4
+                +nil+ } } } } 0 [ + ] foldl
+] unit-test
+    
+{ T{ cons f
+      1
+      T{ cons f
+          2
+          T{ cons f
+              T{ cons f
+                  3
+                  T{ cons f
+                      4
+                      T{ cons f
+                          T{ cons f 5 +nil+ }
+                          +nil+ } } }
+          +nil+ } } }
+} [
+    { 1 2 { 3 4 { 5 } } } seq>cons
+] unit-test
+    
+{ { 1 2 { 3 4 { 5 } } } } [
+  { 1 2 { 3 4 { 5 } } } seq>cons cons>seq
+] unit-test
+    
+{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
+    { 1 2 3 4 } seq>cons [ 1+ ] lmap
+] unit-test
+    
+{ 15 } [
+ { 1 2 3 4 5 } seq>list 0 [ + ] foldr
+] unit-test
+    
+{ { 5 4 3 2 1 } } [
+    { 1 2 3 4 5 } seq>list lreverse list>seq
+] unit-test
+    
+{ 5 } [
+    { 1 2 3 4 5 } seq>list llength
+] unit-test
+    
+{ { 3 4 { 5 6 { 7 } } } } [
+  { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
+] unit-test

extra/lists/lists.factor

@@ -0,0 +1,107 @@
+! Copyright (C) 2008 Chris Double & James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors math arrays vectors classes words locals ;
+
+IN: lists
+
+! List Protocol
+MIXIN: list
+GENERIC: car   ( cons -- car )
+GENERIC: cdr   ( cons -- cdr )
+GENERIC: nil?  ( object -- ?   )
+    
+TUPLE: cons car cdr ;
+
+C: cons cons
+
+M: cons car ( cons -- car )
+    car>> ;
+
+M: cons cdr ( cons -- cdr )
+    cdr>> ;
+    
+SYMBOL: +nil+
+M: word nil? +nil+ eq? ;
+M: object nil? drop f ;
+    
+: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
+
+: nil ( -- symbol ) +nil+ ; 
+    
+: uncons ( cons -- cdr car )
+    [ cdr ] [ car ] bi ;
+    
+: 1list ( obj -- cons )
+    nil cons ;
+    
+: 2list ( a b -- cons )
+    nil cons cons ;
+
+: 3list ( a b c -- cons )
+    nil cons cons cons ;
+    
+: cadr ( cons -- elt )    
+    cdr car ;
+    
+: 2car ( cons -- car caar )    
+    [ car ] [ cdr car ] bi ;
+    
+: 3car ( cons -- car caar caaar )    
+    [ car ] [ cdr car ] [ cdr cdr car ] tri ;
+
+: lnth ( n list -- elt )
+    swap [ cdr ] times car ;
+    
+: (leach) ( list quot -- cdr quot )
+    [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
+
+: leach ( list quot -- )
+    over nil? [ 2drop ] [ (leach) leach ] if ; inline
+
+: lmap ( list quot -- result )
+    over nil? [ drop ] [ (leach) lmap cons ] if ; inline
+
+: foldl ( list identity quot -- result ) swapd leach ; inline
+
+: foldr ( list identity quot -- result )
+    pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
+        [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
+        call
+    ] if ; inline
+
+: llength ( list -- n )
+    0 [ drop 1+ ] foldl ;
+    
+: lreverse ( list -- newlist )    
+    nil [ swap cons ] foldl ;
+    
+: seq>list ( seq -- list )    
+    <reversed> nil [ swap cons ] reduce ;
+    
+: same? ( obj1 obj2 -- ? ) 
+    [ class ] bi@ = ;
+    
+: seq>cons ( seq -- cons )
+    [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
+    
+: (lmap>array) ( acc cons quot -- newcons )
+    over nil? [ 2drop ]
+    [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
+    
+: lmap>array ( cons quot -- newcons )
+    { } -rot (lmap>array) ; inline
+    
+: lmap-as ( cons quot exemplar -- seq )
+    [ lmap>array ] dip like ;
+    
+: cons>seq ( cons -- array )    
+    [ dup cons? [ cons>seq ] when ] lmap>array ;
+    
+: list>seq ( list -- array )    
+    [ ] lmap>array ;
+    
+: traverse ( list pred quot -- result )
+    [ 2over call [ tuck [ call ] 2dip ] when
+      pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ;
+    
+INSTANCE: cons list

extra/lists/summary.txt

@@ -0,0 +1 @@
+Implementation of lisp-style linked lists

extra/lists/tags.txt

@@ -0,0 +1,3 @@
+cons
+lists
+sequences

extra/math/erato/erato-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math.erato tools.test ;
+USING: lists.lazy math.erato tools.test ;
 IN: math.erato.tests
 
 [ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test

extra/math/erato/erato.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
+USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
        math.ranges sequences ;
 IN: math.erato
 

extra/math/primes/factors/factors.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
+USING: arrays kernel lists math math.primes namespaces sequences ;
 IN: math.primes.factors
 
 <PRIVATE
@@ -17,7 +17,7 @@ IN: math.primes.factors
     dup empty? [ drop ] [ first , ] if ;
 
 : (factors) ( quot list n -- )
-    dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
+    dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
 
 : (decompose) ( n quot -- seq )
     [ lprimes rot (factors) ] { } make ;

extra/math/primes/primes-tests.factor

@@ -1,4 +1,4 @@
-USING: arrays math.primes tools.test lazy-lists ;
+USING: arrays math.primes tools.test lists.lazy ;
 
 { 1237 } [ 1234 next-prime ] unit-test
 { f t } [ 1234 prime? 1237 prime? ] unit-test

extra/math/primes/primes.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lazy-lists math math.functions math.miller-rabin
+USING: combinators kernel lists.lazy math math.functions math.miller-rabin
        math.order math.primes.list math.ranges sequences sorting ;
 IN: math.primes
 

extra/monads/monads-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test monads math kernel sequences lazy-lists promises ;
+USING: tools.test monads math kernel sequences lists promises ;
 IN: monads.tests
 
 [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test

extra/monads/monads.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel sequences sequences.deep splitting
-accessors fry locals combinators namespaces lazy-lists
+accessors fry locals combinators namespaces lists lists.lazy
 shuffle ;
 IN: monads
 
@@ -124,7 +124,7 @@ M: list-monad fail   2drop nil ;
 
 M: list monad-of drop list-monad ;
 
-M: list >>= '[ , _ lmap lconcat ] ;
+M: list >>= '[ , _ lazy-map lconcat ] ;
 
 ! State
 SINGLETON: state-monad

extra/morse/morse.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
 IN: morse
 
 <PRIVATE

extra/openssl/openssl.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors byte-arrays kernel debugger sequences namespaces math
 math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors debugger inspector
+continuations destructors debugger inspector splitting
 locals unicode.case
 openssl.libcrypto openssl.libssl
 io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
@@ -188,8 +188,12 @@ M: ssl-handle dispose*
     [ 256 X509_NAME_get_text_by_NID ] keep
     swap -1 = [ drop f ] [ latin1 alien>string ] if ;
 
+: common-names-match? ( expected actual -- ? )
+    [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
+
 : check-common-name ( host ssl-handle -- )
-    SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
+    SSL_get_peer_certificate common-name
+    2dup common-names-match?
     [ 2drop ] [ common-name-verify-error ] if ;
 
 M: openssl check-certificate ( host ssl -- )

extra/parser-combinators/parser-combinators-docs.factor

@@ -23,4 +23,4 @@ HELP: any-char-parser
     "from the input string. The value consumed is the "
     "result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
+{ $example "USING: lists.lazy parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;

extra/parser-combinators/parser-combinators-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel lazy-lists tools.test strings math
+USING: kernel lists.lazy tools.test strings math
 sequences parser-combinators arrays math.parser unicode.categories ;
 IN: parser-combinators.tests
 

extra/parser-combinators/parser-combinators.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists promises kernel sequences strings math
+USING: lists lists.lazy promises kernel sequences strings math
 arrays splitting quotations combinators namespaces
 unicode.case unicode.categories sequences.deep ;
 IN: parser-combinators
@@ -147,8 +147,8 @@ TUPLE: and-parser parsers ;
             >r parse-result-parsed r>
             [ parse-result-parsed 2array ] keep
             parse-result-unparsed <parse-result>
-        ] lmap-with
+        ] lazy-map-with
-    ] lmap-with lconcat ;
+    ] lazy-map-with lconcat ;
 
 M: and-parser parse ( input parser -- list )
     #! Parse 'input' by sequentially combining the
@@ -171,7 +171,7 @@ M: or-parser parse ( input parser1 -- list )
     #! of parser1 and parser2 being applied to the same
     #! input. This implements the choice parsing operator.
     or-parser-parsers 0 swap seq>list
-    [ parse ] lmap-with lconcat ;
+    [ parse ] lazy-map-with lconcat ;
 
 : left-trim-slice ( string -- string )
     #! Return a new string without any leading whitespace
@@ -216,7 +216,7 @@ M: apply-parser parse ( input parser -- result )
     -rot parse [
         [ parse-result-parsed swap call ] keep
         parse-result-unparsed <parse-result>
-    ] lmap-with ;
+    ] lazy-map-with ;
 
 TUPLE: some-parser p1 ;
 

extra/parser-combinators/simple/simple-docs.factor

@@ -11,7 +11,7 @@ HELP: 'digit'
     "the input string. The numeric value of the digit "
     " consumed is the result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
 
 HELP: 'integer'
 { $values 
@@ -21,7 +21,7 @@ HELP: 'integer'
     "the input string. The numeric value of the integer "
     " consumed is the result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
 HELP: 'string'
 { $values 
   { "parser" "a parser object" } }
@@ -30,7 +30,7 @@ HELP: 'string'
     "quotations from the input string. The string value "
     " consumed is the result of the parse." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
 
 HELP: 'bold'
 { $values 
@@ -62,6 +62,6 @@ HELP: comma-list
     "'element' should be a parser that can parse the elements. The "
     "result of the parser is a sequence of the parsed elements." }
 { $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
 
 { $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words

extra/parser-combinators/simple/simple.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings math sequences lazy-lists words
+USING: kernel strings math sequences lists.lazy words
 math.parser promises parser-combinators unicode.categories ;
 IN: parser-combinators.simple
 

extra/persistent-vectors/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/persistent-vectors/persistent-vectors-docs.factor

@@ -0,0 +1,53 @@
+USING: help.markup help.syntax kernel math sequences ;
+IN: persistent-vectors
+
+HELP: new-nth
+{ $values { "val" object } { "i" integer } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link set-nth } ". Outputs a new sequence with the " { $snippet "i" } "th element replaced by " { $snippet "val" } "." }
+{ $notes "This operation runs in " { $snippet "O(log_32 n)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppush
+{ $values { "val" object } { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link push } ". Outputs a new sequence with all elements of " { $snippet "seq" } " together with " { $snippet "val" } " added at the end." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: ppop
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $contract "Persistent analogue of " { $link pop* } ". Outputs a new sequence with all elements of " { $snippet "seq" } " except for the final element." }
+{ $notes "This operation runs in amortized " { $snippet "O(1)" } " time on " { $link persistent-vector } " instances and " { $snippet "O(n)" } " time on all other sequences." } ;
+
+HELP: PV{
+{ $syntax "elements... }" }
+{ $description "Parses a literal " { $link persistent-vector } "." } ;
+
+HELP: >persistent-vector
+{ $values { "seq" sequence } { "pvec" persistent-vector } }
+{ $description "Creates a " { $link persistent-vector } " with the same elements as " { $snippet "seq" } "." } ;
+
+HELP: persistent-vector
+{ $class-description "The class of persistent vectors." } ;
+
+HELP: pempty
+{ $values { "pvec" persistent-vector } }
+{ $description "Outputs an empty " { $link persistent-vector } "." } ;
+
+ARTICLE: "persistent-vectors" "Persistent vectors"
+"A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time."
+$nl
+"The class of persistent vectors:"
+{ $subsection persistent-vector }
+"Persistent vectors support the immutable sequence protocol, namely as " { $link length } " and " { $link nth } ", and so can be used with most sequence words (" { $link "sequences" } ")."
+$nl
+"In addition to standard sequence operations, persistent vectors implement efficient operations specific to them. They run in sub-linear time on persistent vectors, and degrate to linear-time algorithms on ordinary sequences:"
+{ $subsection new-nth }
+{ $subsection ppush }
+{ $subsection ppop }
+"The empty persistent vector, used for building up all other persistent vectors:"
+{ $subsection pempty }
+"Converting a sequence into a persistent vector:"
+{ $subsection >persistent-vector }
+"Persistent vectors have a literal syntax:"
+{ $subsection POSTPONE: PV{ }
+"This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ;
+
+ABOUT: "persistent-vectors"

extra/persistent-vectors/persistent-vectors-tests.factor

@@ -0,0 +1,63 @@
+IN: persistent-vectors.tests
+USING: tools.test persistent-vectors sequences kernel arrays
+random namespaces vectors math math.order ;
+
+\ new-nth must-infer
+\ ppush must-infer
+\ ppop must-infer
+
+[ 0 ] [ pempty length ] unit-test
+
+[ 1 ] [ 3 pempty ppush length ] unit-test
+
+[ 3 ] [ 3 pempty ppush first ] unit-test
+
+[ PV{ 3 1 3 3 7 } ] [
+    pempty { 3 1 3 3 7 } [ swap ppush ] each
+] unit-test
+
+[ { 3 1 3 3 7 } ] [
+    pempty { 3 1 3 3 7 } [ swap ppush ] each >array
+] unit-test
+
+{ 100 1060 2000 10000 100000 1000000 } [
+    [ t ] swap [ dup >persistent-vector sequence= ] curry unit-test
+] each
+
+[ ] [ 10000 [ drop 16 random-bits ] PV{ } map-as "1" set ] unit-test
+[ ] [ "1" get >vector "2" set ] unit-test
+
+[ t ] [
+    3000 [
+        drop
+        16 random-bits 10000 random
+        [ "1" [ new-nth ] change ]
+        [ "2" [ new-nth ] change ] 2bi
+        "1" get "2" get sequence=
+    ] all?
+] unit-test
+
+[ PV{ } ppop ] [ empty-error? ] must-fail-with
+
+[ t ] [ PV{ 3 } ppop empty? ] unit-test
+
+[ PV{ 3 7 } ] [ PV{ 3 7 6 } ppop ] unit-test
+
+[ PV{ 3 7 6 5 } ] [ 5 PV{ 3 7 6 } ppush ] unit-test
+
+[ ] [ PV{ } "1" set ] unit-test
+[ ] [ V{ } clone "2" set ] unit-test
+
+[ t ] [
+    100 [
+        drop
+        100 random [
+            16 random-bits [ "1" [ ppush ] change ] [ "2" get push ] bi
+        ] times
+        100 random "1" get length min [
+            "1" [ ppop ] change
+            "2" get pop*
+        ] times
+        "1" get "2" get sequence=
+    ] all?
+] unit-test

extra/persistent-vectors/persistent-vectors.factor

@@ -0,0 +1,183 @@
+! Based on Clojure's PersistentVector by Rich Hickey.
+
+USING: math accessors kernel sequences.private sequences arrays
+combinators parser prettyprint.backend ;
+IN: persistent-vectors
+
+ERROR: empty-error pvec ;
+
+GENERIC: ppush ( val seq -- seq' )
+
+M: sequence ppush swap suffix ;
+
+GENERIC: ppop ( seq -- seq' )
+
+M: sequence ppop 1 head* ;
+
+GENERIC: new-nth ( val i seq -- seq' )
+
+M: sequence new-nth clone [ set-nth ] keep ;
+
+TUPLE: persistent-vector count root tail ;
+
+M: persistent-vector length count>> ;
+
+<PRIVATE
+
+TUPLE: node children level ;
+
+: node-size 32 ; inline
+
+: node-mask node-size mod ; inline
+
+: node-shift -5 * shift ; inline
+
+: node-nth ( i node -- obj )
+    [ node-mask ] [ children>> ] bi* nth ; inline
+
+: body-nth ( i node -- i node' )
+    dup level>> [
+        dupd [ level>> node-shift ] keep node-nth
+    ] times ; inline
+
+: tail-offset ( pvec -- n )
+    [ count>> ] [ tail>> children>> length ] bi - ;
+
+M: persistent-vector nth-unsafe
+    2dup tail-offset >=
+    [ tail>> ] [ root>> body-nth ] if
+    node-nth ;
+
+: node-add ( val node -- node' )
+    clone [ ppush ] change-children ;
+
+: ppush-tail ( val pvec -- pvec' )
+    [ node-add ] change-tail ;
+
+: full? ( node -- ? )
+    children>> length node-size = ;
+
+: 1node ( val level -- node )
+    node new
+        swap >>level
+        swap 1array >>children ;
+
+: 2node ( first second -- node )
+    [ 2array ] [ drop level>> 1+ ] 2bi node boa ;
+
+: new-child ( new-child node -- node' expansion/f )
+    dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+
+: new-last ( val seq -- seq' )
+    [ length 1- ] keep new-nth ;
+
+: node-set-last ( child node -- node' )
+    clone [ new-last ] change-children ;
+
+: (ppush-new-tail) ( tail node -- node' expansion/f )
+    dup level>> 1 = [
+        new-child
+    ] [
+        tuck children>> peek (ppush-new-tail)
+        [ swap new-child ] [ swap node-set-last f ] ?if
+    ] if ;
+
+: do-expansion ( pvec root expansion/f -- pvec )
+    [ 2node ] when* >>root ;
+
+: ppush-new-tail ( val pvec -- pvec' )
+    [ ] [ tail>> ] [ root>> ] tri
+    (ppush-new-tail) do-expansion
+    swap 0 1node >>tail ;
+
+M: persistent-vector ppush ( val pvec -- pvec' )
+    clone
+    dup tail>> full?
+    [ ppush-new-tail ] [ ppush-tail ] if
+    [ 1+ ] change-count ;
+
+: node-set-nth ( val i node -- node' )
+    clone [ new-nth ] change-children ;
+
+: node-change-nth ( i node quot -- node' )
+    [ clone ] dip [
+        [ clone ] dip [ change-nth ] 2keep drop
+    ] curry change-children ; inline
+
+: (new-nth) ( val i node -- node' )
+    dup level>> 0 = [
+        [ node-mask ] dip node-set-nth
+    ] [
+        [ dupd level>> node-shift node-mask ] keep
+        [ (new-nth) ] node-change-nth
+    ] if ;
+
+M: persistent-vector new-nth ( obj i pvec -- pvec' )
+    2dup count>> = [ nip ppush ] [
+        clone
+        2dup tail-offset >= [
+            [ node-mask ] dip
+            [ node-set-nth ] change-tail
+        ] [
+            [ (new-nth) ] change-root
+        ] if
+    ] if ;
+
+: (ppop-contraction) ( node -- node' tail' )
+    clone [ unclip-last swap ] change-children swap ;
+
+: ppop-contraction ( node -- node' tail' )
+    [ (ppop-contraction) ] [ level>> 1 = ] bi swap and ;
+
+: (ppop-new-tail) ( root -- root' tail' )
+    dup level>> 1 > [
+        dup children>> peek (ppop-new-tail) over children>> empty?
+        [ 2drop ppop-contraction ] [ [ swap node-set-last ] dip ] if
+    ] [
+        ppop-contraction
+    ] if ;
+
+: ppop-tail ( pvec -- pvec' )
+    [ clone [ ppop ] change-children ] change-tail ;
+
+: ppop-new-tail ( pvec -- pvec' )
+    dup root>> (ppop-new-tail)
+    [
+        dup [ level>> 1 > ] [ children>> length 1 = ] bi and 
+        [ children>> first ] when
+    ] dip
+    [ >>root ] [ >>tail ] bi* ;
+
+PRIVATE>
+
+: pempty ( -- pvec )
+    T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline
+
+M: persistent-vector ppop ( pvec -- pvec' )
+    dup count>> {
+        { 0 [ empty-error ] }
+        { 1 [ drop pempty ] }
+        [
+            [
+                clone
+                dup tail>> children>> length 1 >
+                [ ppop-tail ] [ ppop-new-tail ] if
+            ] dip 1- >>count
+        ]
+    } case ;
+
+M: persistent-vector like
+    drop pempty [ swap ppush ] reduce ;
+
+M: persistent-vector equal?
+    over persistent-vector? [ sequence= ] [ 2drop f ] if ;
+
+: >persistent-vector ( seq -- pvec ) pempty like ; inline
+
+: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
+
+M: persistent-vector pprint-delims drop \ PV{ \ } ;
+
+M: persistent-vector >pprint-sequence ;
+
+INSTANCE: persistent-vector immutable-sequence

extra/persistent-vectors/summary.txt

@@ -0,0 +1 @@
+Immutable vectors with O(log_32 n) random access and amortized O(1) push/pop

extra/persistent-vectors/tags.txt

@@ -0,0 +1 @@
+collections

extra/present/present.factor

@@ -0,0 +1,15 @@
+USING: math math.parser calendar calendar.format strings words
+kernel ;
+IN: present
+
+GENERIC: present ( object -- string )
+
+M: real present number>string ;
+
+M: timestamp present timestamp>string ;
+
+M: string present ;
+
+M: word present word-name ;
+
+M: f present drop "" ;

extra/project-euler/007/007.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math math.primes ;
+USING: lists math math.primes ;
 IN: project-euler.007
 
 ! http://projecteuler.net/index.php?section=problems&id=7

extra/project-euler/134/134.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math.algebra math math.functions
+USING: arrays kernel lists lists.lazy math.algebra math math.functions
     math.order math.primes math.ranges project-euler.common sequences ;
 IN: project-euler.134
 
@@ -39,7 +39,7 @@ IN: project-euler.134
 PRIVATE>
 
 : euler134 ( -- answer )
-    0 5 lprimes-from uncons [ 1000000 > ] luntil
+    0 5 lprimes-from uncons swap [ 1000000 > ] luntil
     [ [ s + ] keep ] leach drop ;
 
 ! [ euler134 ] 10 ave-time

extra/regexp/regexp.factor

@@ -1,4 +1,4 @@
-USING: arrays combinators kernel lazy-lists math math.parser
+USING: arrays combinators kernel lists math math.parser
 namespaces parser parser-combinators parser-combinators.simple
 promises quotations sequences combinators.lib strings math.order
 assocs prettyprint.backend memoize unicode.case unicode.categories ;

extra/rss/authors.txt

@@ -1 +0,0 @@
-Daniel Ehrenberg

extra/rss/rss.factor

@@ -1,117 +0,0 @@
-! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml.utilities kernel assocs xml.generator math.order
-    strings sequences xml.data xml.writer
-    io.streams.string combinators xml xml.entities io.files io
-    http.client namespaces xml.generator hashtables
-    calendar.format accessors continuations urls ;
-IN: rss
-
-: any-tag-named ( tag names -- tag-inside )
-    f -rot [ tag-named nip dup ] with find 2drop ;
-
-TUPLE: feed title link entries ;
-
-C: <feed> feed
-
-TUPLE: entry title link description pub-date ;
-
-C: <entry> entry
-
-: try-parsing-timestamp ( string -- timestamp )
-    [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
-
-: rss1.0-entry ( tag -- entry )
-    {
-        [ "title" tag-named children>string ]
-        [ "link" tag-named children>string ]
-        [ "description" tag-named children>string ]
-        [
-            f "date" "http://purl.org/dc/elements/1.1/" <name>
-            tag-named dup [ children>string try-parsing-timestamp ] when
-        ]
-    } cleave <entry> ;
-
-: rss1.0 ( xml -- feed )
-    [
-        "channel" tag-named
-        [ "title" tag-named children>string ]
-        [ "link" tag-named children>string ] bi
-    ] [ "item" tags-named [ rss1.0-entry ] map ] bi
-    <feed> ;
-
-: rss2.0-entry ( tag -- entry )
-    {
-        [ "title" tag-named children>string ]
-        [ { "link" "guid" } any-tag-named children>string ]
-        [ "description" tag-named children>string ]
-        [
-            { "date" "pubDate" } any-tag-named
-            children>string try-parsing-timestamp
-        ]
-    } cleave <entry> ;
-
-: rss2.0 ( xml -- feed )
-    "channel" tag-named 
-    [ "title" tag-named children>string ]
-    [ "link" tag-named children>string ]
-    [ "item" tags-named [ rss2.0-entry ] map ]
-    tri <feed> ;
-
-: atom1.0-entry ( tag -- entry )
-    {
-        [ "title" tag-named children>string ]
-        [ "link" tag-named "href" swap at ]
-        [
-            { "content" "summary" } any-tag-named
-            dup tag-children [ string? not ] contains?
-            [ tag-children [ write-chunk ] with-string-writer ]
-            [ children>string ] if
-        ]
-        [
-            { "published" "updated" "issued" "modified" } 
-            any-tag-named children>string try-parsing-timestamp
-        ]
-    } cleave <entry> ;
-
-: atom1.0 ( xml -- feed )
-    [ "title" tag-named children>string ]
-    [ "link" tag-named "href" swap at ]
-    [ "entry" tags-named [ atom1.0-entry ] map ]
-    tri <feed> ;
-
-: xml>feed ( xml -- feed )
-    dup name-tag {
-        { "RDF" [ rss1.0 ] }
-        { "rss" [ rss2.0 ] }
-        { "feed" [ atom1.0 ] }
-    } case ;
-
-: read-feed ( string -- feed )
-    [ string>xml xml>feed ] with-html-entities ;
-
-: download-feed ( url -- feed )
-    #! Retrieve an news syndication file, return as a feed tuple.
-    http-get read-feed ;
-
-! Atom generation
-: simple-tag, ( content name -- )
-    [ , ] tag, ;
-
-: simple-tag*, ( content name attrs -- )
-    [ , ] tag*, ;
-
-: entry, ( entry -- )
-    "entry" [
-        dup title>> "title" { { "type" "html" } } simple-tag*,
-        "link" over link>> dup url? [ url>string ] when "href" associate contained*,
-        dup pub-date>> timestamp>rfc3339 "published" simple-tag,
-        description>> [ "content" { { "type" "html" } } simple-tag*, ] when*
-    ] tag, ;
-
-: feed>xml ( feed -- xml )
-    "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
-        dup title>> "title" simple-tag,
-        "link" over link>> dup url? [ url>string ] when "href" associate contained*,
-        entries>> [ entry, ] each
-    ] make-xml* ;

extra/syndication/authors.txt

@@ -0,0 +1,3 @@
+Daniel Ehrenberg
+Chris Double
+Slava Pestov

extra/syndication/syndication-tests.factor

@@ -1,6 +1,9 @@
-USING: rss io kernel io.files tools.test io.encodings.utf8
+USING: syndication io kernel io.files tools.test io.encodings.utf8
-calendar ;
+calendar urls ;
-IN: rss.tests
+IN: syndication.tests
+
+\ download-feed must-infer
+\ feed>xml must-infer
 
 : load-news-file ( filename -- feed )
     #! Load an news syndication file and process it, returning
@@ -11,32 +14,32 @@ IN: rss.tests
     feed
     f
     "Meerkat"
-    "http://meerkat.oreillynet.com"
+    URL" http://meerkat.oreillynet.com"
     {
         T{
             entry
             f
             "XML: A Disruptive Technology"
-            "http://c.moreover.com/click/here.pl?r123"
+            URL" http://c.moreover.com/click/here.pl?r123"
             "\n      XML is placing increasingly heavy loads on the existing technical\n      infrastructure of the Internet.\n    "
             f
         }
     }
-} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
+} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test
 [ T{
     feed
     f
     "dive into mark"
-    "http://example.org/"
+    URL" http://example.org/"
     {
         T{
             entry
             f
             "Atom draft-07 snapshot"
-            "http://example.org/2005/04/02/atom"
+            URL" http://example.org/2005/04/02/atom"
             "\n         <div xmlns=\"http://www.w3.org/1999/xhtml\">\n           <p><i>[Update: The Atom draft is finished.]</i></p>\n         </div>\n       "
 
             T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
         }
     }
-} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
+} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test

extra/syndication/syndication.factor

@@ -0,0 +1,135 @@
+! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
+! Portions copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml.utilities kernel assocs xml.generator math.order
+    strings sequences xml.data xml.writer
+    io.streams.string combinators xml xml.entities io.files io
+    http.client namespaces xml.generator hashtables
+    calendar.format accessors continuations urls present ;
+IN: syndication
+
+: any-tag-named ( tag names -- tag-inside )
+    f -rot [ tag-named nip dup ] with find 2drop ;
+
+TUPLE: feed title url entries ;
+
+: <feed> ( -- feed ) feed new ;
+
+TUPLE: entry title url description date ;
+
+: set-entries ( feed entries -- feed )
+    [ dup url>> ] dip
+    [ [ derive-url ] change-url ] with map
+    >>entries ;
+
+: <entry> ( -- entry ) entry new ;
+
+: try-parsing-timestamp ( string -- timestamp )
+    [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
+: rss1.0-entry ( tag -- entry )
+    entry new
+    swap {
+        [ "title" tag-named children>string >>title ]
+        [ "link" tag-named children>string >url >>url ]
+        [ "description" tag-named children>string >>description ]
+        [
+            f "date" "http://purl.org/dc/elements/1.1/" <name>
+            tag-named dup [ children>string try-parsing-timestamp ] when
+            >>date
+        ]
+    } cleave ;
+
+: rss1.0 ( xml -- feed )
+    feed new
+    swap [
+        "channel" tag-named
+        [ "title" tag-named children>string >>title ]
+        [ "link" tag-named children>string >url >>url ] bi
+    ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ;
+
+: rss2.0-entry ( tag -- entry )
+    entry new
+    swap {
+        [ "title" tag-named children>string >>title ]
+        [ { "link" "guid" } any-tag-named children>string >url >>url ]
+        [ "description" tag-named children>string >>description ]
+        [
+            { "date" "pubDate" } any-tag-named
+            children>string try-parsing-timestamp >>date
+        ]
+    } cleave ;
+
+: rss2.0 ( xml -- feed )
+    feed new
+    swap
+    "channel" tag-named 
+    [ "title" tag-named children>string >>title ]
+    [ "link" tag-named children>string >url >>url ]
+    [ "item" tags-named [ rss2.0-entry ] map set-entries ]
+    tri ;
+
+: atom1.0-entry ( tag -- entry )
+    entry new
+    swap {
+        [ "title" tag-named children>string >>title ]
+        [ "link" tag-named "href" swap at >url >>url ]
+        [
+            { "content" "summary" } any-tag-named
+            dup tag-children [ string? not ] contains?
+            [ tag-children [ write-chunk ] with-string-writer ]
+            [ children>string ] if >>description
+        ]
+        [
+            { "published" "updated" "issued" "modified" } 
+            any-tag-named children>string try-parsing-timestamp
+            >>date
+        ]
+    } cleave ;
+
+: atom1.0 ( xml -- feed )
+    feed new
+    swap
+    [ "title" tag-named children>string >>title ]
+    [ "link" tag-named "href" swap at >url >>url ]
+    [ "entry" tags-named [ atom1.0-entry ] map set-entries ]
+    tri ;
+
+: xml>feed ( xml -- feed )
+    dup name-tag {
+        { "RDF" [ rss1.0 ] }
+        { "rss" [ rss2.0 ] }
+        { "feed" [ atom1.0 ] }
+    } case ;
+
+: read-feed ( string -- feed )
+    [ string>xml xml>feed ] with-html-entities ;
+
+: download-feed ( url -- feed )
+    #! Retrieve an news syndication file, return as a feed tuple.
+    http-get read-feed ;
+
+! Atom generation
+: simple-tag, ( content name -- )
+    [ , ] tag, ;
+
+: simple-tag*, ( content name attrs -- )
+    [ , ] tag*, ;
+
+: entry, ( entry -- )
+    "entry" [
+        {
+            [ title>> "title" { { "type" "html" } } simple-tag*, ]
+            [ url>> present "href" associate "link" swap contained*, ]
+            [ date>> timestamp>rfc3339 "published" simple-tag, ]
+            [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
+        } cleave
+    ] tag, ;
+
+: feed>xml ( feed -- xml )
+    "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
+        [ title>> "title" simple-tag, ]
+        [ url>> present "href" associate "link" swap contained*, ]
+        [ entries>> [ entry, ] each ]
+        tri
+    ] make-xml* ;

extra/syndication/tags.txt

@@ -0,0 +1 @@
+web

extra/tetris/game/game.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lazy-lists combinators system ;
+tetris.piece tetris.tetromino lists combinators system ;
 IN: tetris.game
 
 TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;

extra/tetris/piece/piece.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays tetris.tetromino math math.vectors 
-sequences quotations lazy-lists ;
+sequences quotations lists.lazy ;
 IN: tetris.piece
 
 #! A piece adds state to the tetromino that is the piece's delegate. The

extra/urls/urls-tests.factor

@@ -1,5 +1,7 @@
 IN: urls.tests
-USING: urls tools.test tuple-syntax arrays kernel assocs ;
+USING: urls urls.private tools.test
+tuple-syntax arrays kernel assocs
+present ;
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
@@ -110,7 +112,7 @@ urls [
 ] assoc-each
 
 urls [
-    swap [ 1array ] [ [ url>string ] curry ] bi* unit-test
+    swap [ 1array ] [ [ present ] curry ] bi* unit-test
 ] assoc-each
 
 [ "b" ] [ "a" "b" url-append-path ] unit-test

extra/urls/urls.factor

@@ -4,7 +4,7 @@ USING: kernel unicode.categories combinators sequences splitting
 fry namespaces assocs arrays strings io.sockets
 io.sockets.secure io.encodings.string io.encodings.utf8
 math math.parser accessors mirrors parser
-prettyprint.backend hashtables ;
+prettyprint.backend hashtables present ;
 IN: urls
 
 : url-quotable? ( ch -- ? )
@@ -14,19 +14,25 @@ IN: urls
         { [ dup letter? ] [ t ] }
         { [ dup LETTER? ] [ t ] }
         { [ dup digit? ] [ t ] }
-        { [ dup "/_-.:" member? ] [ t ] }
+        { [ dup "/_-." member? ] [ t ] }
         [ f ]
     } cond nip ; foldable
 
+<PRIVATE
+
 : push-utf8 ( ch -- )
     1string utf8 encode
     [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
 
+PRIVATE>
+
 : url-encode ( str -- str )
     [
         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
     ] "" make ;
 
+<PRIVATE
+
 : url-decode-hex ( index str -- )
     2dup length 2 - >= [
         2drop
@@ -51,9 +57,13 @@ IN: urls
         ] if url-decode-iter
     ] if ;
 
+PRIVATE>
+
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make utf8 decode ;
 
+<PRIVATE
+
 : add-query-param ( value key assoc -- )
     [
         at [
@@ -65,6 +75,8 @@ IN: urls
         ] when*
     ] 2keep set-at ;
 
+PRIVATE>
+
 : query>assoc ( query -- assoc )
     dup [
         "&" split H{ } clone [
@@ -77,11 +89,7 @@ IN: urls
 
 : assoc>query ( hash -- str )
     [
-        {
+        dup array? [ [ present ] map ] [ present 1array ] if
-            { [ dup number? ] [ number>string 1array ] }
-            { [ dup string? ] [ 1array ] }
-            { [ dup sequence? ] [ ] }
-        } cond
     ] assoc-map
     [
         [
@@ -108,6 +116,8 @@ TUPLE: url protocol username password host port path query anchor ;
         ] when
     ] bi* ;
 
+<PRIVATE
+
 : parse-host-part ( url protocol rest -- url string' )
     [ >>protocol ] [
         "//" ?head [ "Invalid URL" throw ] unless
@@ -121,6 +131,8 @@ TUPLE: url protocol username password host port path query anchor ;
         ] [ "/" prepend ] bi*
     ] bi* ;
 
+PRIVATE>
+
 GENERIC: >url ( obj -- url )
 
 M: url >url ;
@@ -135,6 +147,8 @@ M: string >url
     ]
     [ url-decode >>anchor ] bi* ;
 
+<PRIVATE
+
 : unparse-username-password ( url -- )
     dup username>> dup [
         % password>> [ ":" % % ] when* "@" %
@@ -150,7 +164,7 @@ M: string >url
         [ path>> "/" head? [ "/" % ] unless ]
     } cleave ;
 
-: url>string ( url -- string )
+M: url present
     [
         {
             [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
@@ -169,6 +183,8 @@ M: string >url
         [ [ "/" last-split1 drop "/" ] dip 3append ]
     } cond ;
 
+PRIVATE>
+
 : derive-url ( base url -- url' )
     [ clone dup ] dip
     2dup [ path>> ] bi@ url-append-path
@@ -199,4 +215,4 @@ M: string >url
 ! Literal syntax
 : URL" lexer get skip-blank parse-string >url parsed ; parsing
 
-M: url pprint* dup url>string "URL\" " "\"" pprint-string ;
+M: url pprint* dup present "URL\" " "\"" pprint-string ;

extra/webapps/factor-website/factor-website.factor

@@ -6,7 +6,8 @@ namespaces db db.sqlite smtp
 http.server
 http.server.dispatchers
 furnace.db
-furnace.flows
+furnace.asides
+furnace.flash
 furnace.sessions
 furnace.auth.login
 furnace.auth.providers.db
@@ -15,6 +16,7 @@ webapps.pastebin
 webapps.planet
 webapps.todo
 webapps.wiki
+webapps.wee-url
 webapps.user-admin ;
 IN: webapps.factor-website
 
@@ -35,6 +37,8 @@ IN: webapps.factor-website
 
         init-articles-table
         init-revisions-table
+
+        init-short-url-table
     ] with-db ;
 
 TUPLE: factor-website < dispatcher ;
@@ -45,6 +49,7 @@ TUPLE: factor-website < dispatcher ;
         <pastebin> "pastebin" add-responder
         <planet-factor> "planet" add-responder
         <wiki> "wiki" add-responder
+        <wee-url> "wee-url" add-responder
         <user-admin> "user-admin" add-responder
     <login>
         users-in-db >>users
@@ -53,8 +58,7 @@ TUPLE: factor-website < dispatcher ;
         allow-edit-profile
     <boilerplate>
         { factor-website "page" } >>template
-    <flows>
+    <asides> <flash-scopes> <sessions>
-    <sessions>
     test-db <db-persistence> ;
 
 : init-factor-website ( -- )